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-2014, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Checks; use Checks; 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_Disp; use Exp_Disp; 36with Exp_Sel; use Exp_Sel; 37with Exp_Smem; use Exp_Smem; 38with Exp_Tss; use Exp_Tss; 39with Exp_Util; use Exp_Util; 40with Freeze; use Freeze; 41with Hostparm; 42with Itypes; use Itypes; 43with Namet; use Namet; 44with Nlists; use Nlists; 45with Nmake; use Nmake; 46with Opt; use Opt; 47with Restrict; use Restrict; 48with Rident; use Rident; 49with Rtsfind; use Rtsfind; 50with Sem; use Sem; 51with Sem_Aux; use Sem_Aux; 52with Sem_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_Res; use Sem_Res; 59with Sem_Util; use Sem_Util; 60with Sinfo; use Sinfo; 61with Snames; use Snames; 62with Stand; use Stand; 63with Stringt; use Stringt; 64with Targparm; use Targparm; 65with Tbuild; use Tbuild; 66with Uintp; use Uintp; 67 68package body Exp_Ch9 is 69 70 -- The following constant establishes the upper bound for the index of 71 -- an entry family. It is used to limit the allocated size of protected 72 -- types with defaulted discriminant of an integer type, when the bound 73 -- of some entry family depends on a discriminant. The limitation to entry 74 -- families of 128K should be reasonable in all cases, and is a documented 75 -- implementation restriction. 76 77 Entry_Family_Bound : constant Int := 2**16; 78 79 ----------------------- 80 -- Local Subprograms -- 81 ----------------------- 82 83 function Actual_Index_Expression 84 (Sloc : Source_Ptr; 85 Ent : Entity_Id; 86 Index : Node_Id; 87 Tsk : Entity_Id) return Node_Id; 88 -- Compute the index position for an entry call. Tsk is the target task. If 89 -- the bounds of some entry family depend on discriminants, the expression 90 -- computed by this function uses the discriminants of the target task. 91 92 procedure Add_Object_Pointer 93 (Loc : Source_Ptr; 94 Conc_Typ : Entity_Id; 95 Decls : List_Id); 96 -- Prepend an object pointer declaration to the declaration list Decls. 97 -- This object pointer is initialized to a type conversion of the System. 98 -- Address pointer passed to entry barrier functions and entry body 99 -- procedures. 100 101 procedure Add_Formal_Renamings 102 (Spec : Node_Id; 103 Decls : List_Id; 104 Ent : Entity_Id; 105 Loc : Source_Ptr); 106 -- Create renaming declarations for the formals, inside the procedure that 107 -- implements an entry body. The renamings make the original names of the 108 -- formals accessible to gdb, and serve no other purpose. 109 -- Spec is the specification of the procedure being built. 110 -- Decls is the list of declarations to be enhanced. 111 -- Ent is the entity for the original entry body. 112 113 function Build_Accept_Body (Astat : Node_Id) return Node_Id; 114 -- Transform accept statement into a block with added exception handler. 115 -- Used both for simple accept statements and for accept alternatives in 116 -- select statements. Astat is the accept statement. 117 118 function Build_Barrier_Function 119 (N : Node_Id; 120 Ent : Entity_Id; 121 Pid : Node_Id) return Node_Id; 122 -- Build the function body returning the value of the barrier expression 123 -- for the specified entry body. 124 125 function Build_Barrier_Function_Specification 126 (Loc : Source_Ptr; 127 Def_Id : Entity_Id) return Node_Id; 128 -- Build a specification for a function implementing the protected entry 129 -- barrier of the specified entry body. 130 131 function Build_Corresponding_Record 132 (N : Node_Id; 133 Ctyp : Node_Id; 134 Loc : Source_Ptr) return Node_Id; 135 -- Common to tasks and protected types. Copy discriminant specifications, 136 -- build record declaration. N is the type declaration, Ctyp is the 137 -- concurrent entity (task type or protected type). 138 139 function Build_Dispatching_Tag_Check 140 (K : Entity_Id; 141 N : Node_Id) return Node_Id; 142 -- Utility to create the tree to check whether the dispatching call in 143 -- a timed entry call, a conditional entry call, or an asynchronous 144 -- transfer of control is a call to a primitive of a non-synchronized type. 145 -- K is the temporary that holds the tagged kind of the target object, and 146 -- N is the enclosing construct. 147 148 function Build_Entry_Count_Expression 149 (Concurrent_Type : Node_Id; 150 Component_List : List_Id; 151 Loc : Source_Ptr) return Node_Id; 152 -- Compute number of entries for concurrent object. This is a count of 153 -- simple entries, followed by an expression that computes the length 154 -- of the range of each entry family. A single array with that size is 155 -- allocated for each concurrent object of the type. 156 157 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; 158 -- Build the function that translates the entry index in the call 159 -- (which depends on the size of entry families) into an index into the 160 -- Entry_Bodies_Array, to determine the body and barrier function used 161 -- in a protected entry call. A pointer to this function appears in every 162 -- protected object. 163 164 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id; 165 -- Build subprogram declaration for previous one 166 167 function Build_Lock_Free_Protected_Subprogram_Body 168 (N : Node_Id; 169 Prot_Typ : Node_Id; 170 Unprot_Spec : Node_Id) return Node_Id; 171 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is 172 -- the subprogram specification of the unprotected version of N. Transform 173 -- N such that it invokes the unprotected version of the body. 174 175 function Build_Lock_Free_Unprotected_Subprogram_Body 176 (N : Node_Id; 177 Prot_Typ : Node_Id) return Node_Id; 178 -- N denotes a subprogram body of protected type Prot_Typ. Build a version 179 -- of N where the original statements of N are synchronized through atomic 180 -- actions such as compare and exchange. Prior to invoking this routine, it 181 -- has been established that N can be implemented in a lock-free fashion. 182 183 function Build_Parameter_Block 184 (Loc : Source_Ptr; 185 Actuals : List_Id; 186 Formals : List_Id; 187 Decls : List_Id) return Entity_Id; 188 -- Generate an access type for each actual parameter in the list Actuals. 189 -- Create an encapsulating record that contains all the actuals and return 190 -- its type. Generate: 191 -- type Ann1 is access all <actual1-type> 192 -- ... 193 -- type AnnN is access all <actualN-type> 194 -- type Pnn is record 195 -- <formal1> : Ann1; 196 -- ... 197 -- <formalN> : AnnN; 198 -- end record; 199 200 procedure Build_PPC_Wrapper (E : Entity_Id; Decl : Node_Id); 201 -- Build body of wrapper procedure for an entry or entry family that has 202 -- pre/postconditions. The body gathers the PPC's and expands them in the 203 -- usual way, and performs the entry call itself. This way preconditions 204 -- are evaluated before the call is queued. E is the entry in question, 205 -- and Decl is the enclosing synchronized type declaration at whose freeze 206 -- point the generated body is analyzed. 207 208 function Build_Protected_Entry 209 (N : Node_Id; 210 Ent : Entity_Id; 211 Pid : Node_Id) return Node_Id; 212 -- Build the procedure implementing the statement sequence of the specified 213 -- entry body. 214 215 function Build_Protected_Entry_Specification 216 (Loc : Source_Ptr; 217 Def_Id : Entity_Id; 218 Ent_Id : Entity_Id) return Node_Id; 219 -- Build a specification for the procedure implementing the statements of 220 -- the specified entry body. Add attributes associating it with the entry 221 -- defining identifier Ent_Id. 222 223 function Build_Protected_Spec 224 (N : Node_Id; 225 Obj_Type : Entity_Id; 226 Ident : Entity_Id; 227 Unprotected : Boolean := False) return List_Id; 228 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_ 229 -- Subprogram_Type. Builds signature of protected subprogram, adding the 230 -- formal that corresponds to the object itself. For an access to protected 231 -- subprogram, there is no object type to specify, so the parameter has 232 -- type Address and mode In. An indirect call through such a pointer will 233 -- convert the address to a reference to the actual object. The object is 234 -- a limited record and therefore a by_reference type. 235 236 function Build_Protected_Subprogram_Body 237 (N : Node_Id; 238 Pid : Node_Id; 239 N_Op_Spec : Node_Id) return Node_Id; 240 -- This function is used to construct the protected version of a protected 241 -- subprogram. Its statement sequence first defers abort, then locks the 242 -- associated protected object, and then enters a block that contains a 243 -- call to the unprotected version of the subprogram (for details, see 244 -- Build_Unprotected_Subprogram_Body). This block statement requires a 245 -- cleanup handler that unlocks the object in all cases. For details, 246 -- see Exp_Ch7.Expand_Cleanup_Actions. 247 248 function Build_Renamed_Formal_Declaration 249 (New_F : Entity_Id; 250 Formal : Entity_Id; 251 Comp : Entity_Id; 252 Renamed_Formal : Node_Id) return Node_Id; 253 -- Create a renaming declaration for a formal, within a protected entry 254 -- body or an accept body. The renamed object is a component of the 255 -- parameter block that is a parameter in the entry call. 256 -- 257 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming 258 -- does not dereference the corresponding component to prevent an illegal 259 -- use of the incomplete type (AI05-0151). 260 261 function Build_Selected_Name 262 (Prefix : Entity_Id; 263 Selector : Entity_Id; 264 Append_Char : Character := ' ') return Name_Id; 265 -- Build a name in the form of Prefix__Selector, with an optional character 266 -- appended. This is used for internal subprograms generated for operations 267 -- of protected types, including barrier functions. For the subprograms 268 -- generated for entry bodies and entry barriers, the generated name 269 -- includes a sequence number that makes names unique in the presence of 270 -- entry overloading. This is necessary because entry body procedures and 271 -- barrier functions all have the same signature. 272 273 procedure Build_Simple_Entry_Call 274 (N : Node_Id; 275 Concval : Node_Id; 276 Ename : Node_Id; 277 Index : Node_Id); 278 -- Some comments here would be useful ??? 279 280 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id; 281 -- This routine constructs a specification for the procedure that we will 282 -- build for the task body for task type T. The spec has the form: 283 -- 284 -- procedure tnameB (_Task : access tnameV); 285 -- 286 -- where name is the character name taken from the task type entity that 287 -- is passed as the argument to the procedure, and tnameV is the task 288 -- value type that is associated with the task type. 289 290 function Build_Unprotected_Subprogram_Body 291 (N : Node_Id; 292 Pid : Node_Id) return Node_Id; 293 -- This routine constructs the unprotected version of a protected 294 -- subprogram body, which is contains all of the code in the 295 -- original, unexpanded body. This is the version of the protected 296 -- subprogram that is called from all protected operations on the same 297 -- object, including the protected version of the same subprogram. 298 299 procedure Build_Wrapper_Bodies 300 (Loc : Source_Ptr; 301 Typ : Entity_Id; 302 N : Node_Id); 303 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding 304 -- record of a concurrent type. N is the insertion node where all bodies 305 -- will be placed. This routine builds the bodies of the subprograms which 306 -- serve as an indirection mechanism to overriding primitives of concurrent 307 -- types, entries and protected procedures. Any new body is analyzed. 308 309 procedure Build_Wrapper_Specs 310 (Loc : Source_Ptr; 311 Typ : Entity_Id; 312 N : in out Node_Id); 313 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding 314 -- record of a concurrent type. N is the insertion node where all specs 315 -- will be placed. This routine builds the specs of the subprograms which 316 -- serve as an indirection mechanism to overriding primitives of concurrent 317 -- types, entries and protected procedures. Any new spec is analyzed. 318 319 procedure Collect_Entry_Families 320 (Loc : Source_Ptr; 321 Cdecls : List_Id; 322 Current_Node : in out Node_Id; 323 Conctyp : Entity_Id); 324 -- For each entry family in a concurrent type, create an anonymous array 325 -- type of the right size, and add a component to the corresponding_record. 326 327 function Concurrent_Object 328 (Spec_Id : Entity_Id; 329 Conc_Typ : Entity_Id) return Entity_Id; 330 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return 331 -- the entity associated with the concurrent object in the Protected_Body_ 332 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity 333 -- denotes formal parameter _O, _object or _task. 334 335 function Copy_Result_Type (Res : Node_Id) return Node_Id; 336 -- Copy the result type of a function specification, when building the 337 -- internal operation corresponding to a protected function, or when 338 -- expanding an access to protected function. If the result is an anonymous 339 -- access to subprogram itself, we need to create a new signature with the 340 -- same parameter names and the same resolved types, but with new entities 341 -- for the formals. 342 343 procedure Debug_Private_Data_Declarations (Decls : List_Id); 344 -- Decls is a list which may contain the declarations created by Install_ 345 -- Private_Data_Declarations. All generated entities are marked as needing 346 -- debug info and debug nodes are manually generation where necessary. This 347 -- step of the expansion must to be done after private data has been moved 348 -- to its final resting scope to ensure proper visibility of debug objects. 349 350 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id); 351 -- If control flow optimizations are suppressed, and Alt is an accept, 352 -- delay, or entry call alternative with no trailing statements, insert 353 -- a null trailing statement with the given Loc (which is the sloc of 354 -- the accept, delay, or entry call statement). There might not be any 355 -- generated code for the accept, delay, or entry call itself (the effect 356 -- of these statements is part of the general processsing done for the 357 -- enclosing selective accept, timed entry call, or asynchronous select), 358 -- and the null statement is there to carry the sloc of that statement to 359 -- the back-end for trace-based coverage analysis purposes. 360 361 procedure Extract_Dispatching_Call 362 (N : Node_Id; 363 Call_Ent : out Entity_Id; 364 Object : out Entity_Id; 365 Actuals : out List_Id; 366 Formals : out List_Id); 367 -- Given a dispatching call, extract the entity of the name of the call, 368 -- its actual dispatching object, its actual parameters and the formal 369 -- parameters of the overridden interface-level version. If the type of 370 -- the dispatching object is an access type then an explicit dereference 371 -- is returned in Object. 372 373 procedure Extract_Entry 374 (N : Node_Id; 375 Concval : out Node_Id; 376 Ename : out Node_Id; 377 Index : out Node_Id); 378 -- Given an entry call, returns the associated concurrent object, the entry 379 -- name, and the entry family index. 380 381 function Family_Offset 382 (Loc : Source_Ptr; 383 Hi : Node_Id; 384 Lo : Node_Id; 385 Ttyp : Entity_Id; 386 Cap : Boolean) return Node_Id; 387 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an 388 -- accept statement, or the upper bound in the discrete subtype of an entry 389 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent 390 -- type of the entry. If Cap is true, the result is capped according to 391 -- Entry_Family_Bound. 392 393 function Family_Size 394 (Loc : Source_Ptr; 395 Hi : Node_Id; 396 Lo : Node_Id; 397 Ttyp : Entity_Id; 398 Cap : Boolean) return Node_Id; 399 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a 400 -- family, and handle properly the superflat case. This is equivalent to 401 -- the use of 'Length on the index type, but must use Family_Offset to 402 -- handle properly the case of bounds that depend on discriminants. If 403 -- Cap is true, the result is capped according to Entry_Family_Bound. 404 405 procedure Find_Enclosing_Context 406 (N : Node_Id; 407 Context : out Node_Id; 408 Context_Id : out Entity_Id; 409 Context_Decls : out List_Id); 410 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and 411 -- Build_Master_Entity. Given an arbitrary node in the tree, find the 412 -- nearest enclosing body, block, package or return statement and return 413 -- its constituents. Context is the enclosing construct, Context_Id is 414 -- the scope of Context_Id and Context_Decls is the declarative list of 415 -- Context. 416 417 function Index_Object (Spec_Id : Entity_Id) return Entity_Id; 418 -- Given a subprogram identifier, return the entity which is associated 419 -- with the protection entry index in the Protected_Body_Subprogram or 420 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal 421 -- parameter _E. 422 423 function Is_Exception_Safe (Subprogram : Node_Id) return Boolean; 424 -- Tell whether a given subprogram cannot raise an exception 425 426 function Is_Potentially_Large_Family 427 (Base_Index : Entity_Id; 428 Conctyp : Entity_Id; 429 Lo : Node_Id; 430 Hi : Node_Id) return Boolean; 431 432 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean; 433 -- Determine whether Id is a function or a procedure and is marked as a 434 -- private primitive. 435 436 function Null_Statements (Stats : List_Id) return Boolean; 437 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END. 438 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well 439 -- to still count as null. Returns True for a null sequence. The argument 440 -- is the list of statements from the DO-END sequence. 441 442 function Parameter_Block_Pack 443 (Loc : Source_Ptr; 444 Blk_Typ : Entity_Id; 445 Actuals : List_Id; 446 Formals : List_Id; 447 Decls : List_Id; 448 Stmts : List_Id) return Entity_Id; 449 -- Set the components of the generated parameter block with the values 450 -- of the actual parameters. Generate aliased temporaries to capture the 451 -- values for types that are passed by copy. Otherwise generate a reference 452 -- to the actual's value. Return the address of the aggregate block. 453 -- Generate: 454 -- Jnn1 : alias <formal-type1>; 455 -- Jnn1 := <actual1>; 456 -- ... 457 -- P : Blk_Typ := ( 458 -- Jnn1'unchecked_access; 459 -- <actual2>'reference; 460 -- ...); 461 462 function Parameter_Block_Unpack 463 (Loc : Source_Ptr; 464 P : Entity_Id; 465 Actuals : List_Id; 466 Formals : List_Id) return List_Id; 467 -- Retrieve the values of the components from the parameter block and 468 -- assign then to the original actual parameters. Generate: 469 -- <actual1> := P.<formal1>; 470 -- ... 471 -- <actualN> := P.<formalN>; 472 473 function Trivial_Accept_OK return Boolean; 474 -- If there is no DO-END block for an accept, or if the DO-END block has 475 -- only null statements, then it is possible to do the Rendezvous with much 476 -- less overhead using the Accept_Trivial routine in the run-time library. 477 -- However, this is not always a valid optimization. Whether it is valid or 478 -- not depends on the Task_Dispatching_Policy. The issue is whether a full 479 -- rescheduling action is required or not. In FIFO_Within_Priorities, such 480 -- a rescheduling is required, so this optimization is not allowed. This 481 -- function returns True if the optimization is permitted. 482 483 ----------------------------- 484 -- Actual_Index_Expression -- 485 ----------------------------- 486 487 function Actual_Index_Expression 488 (Sloc : Source_Ptr; 489 Ent : Entity_Id; 490 Index : Node_Id; 491 Tsk : Entity_Id) return Node_Id 492 is 493 Ttyp : constant Entity_Id := Etype (Tsk); 494 Expr : Node_Id; 495 Num : Node_Id; 496 Lo : Node_Id; 497 Hi : Node_Id; 498 Prev : Entity_Id; 499 S : Node_Id; 500 501 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id; 502 -- Compute difference between bounds of entry family 503 504 -------------------------- 505 -- Actual_Family_Offset -- 506 -------------------------- 507 508 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is 509 510 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; 511 -- Replace a reference to a discriminant with a selected component 512 -- denoting the discriminant of the target task. 513 514 ----------------------------- 515 -- Actual_Discriminant_Ref -- 516 ----------------------------- 517 518 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is 519 Typ : constant Entity_Id := Etype (Bound); 520 B : Node_Id; 521 522 begin 523 if not Is_Entity_Name (Bound) 524 or else Ekind (Entity (Bound)) /= E_Discriminant 525 then 526 if Nkind (Bound) = N_Attribute_Reference then 527 return Bound; 528 else 529 B := New_Copy_Tree (Bound); 530 end if; 531 532 else 533 B := 534 Make_Selected_Component (Sloc, 535 Prefix => New_Copy_Tree (Tsk), 536 Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc)); 537 538 Analyze_And_Resolve (B, Typ); 539 end if; 540 541 return 542 Make_Attribute_Reference (Sloc, 543 Attribute_Name => Name_Pos, 544 Prefix => New_Occurrence_Of (Etype (Bound), Sloc), 545 Expressions => New_List (B)); 546 end Actual_Discriminant_Ref; 547 548 -- Start of processing for Actual_Family_Offset 549 550 begin 551 return 552 Make_Op_Subtract (Sloc, 553 Left_Opnd => Actual_Discriminant_Ref (Hi), 554 Right_Opnd => Actual_Discriminant_Ref (Lo)); 555 end Actual_Family_Offset; 556 557 -- Start of processing for Actual_Index_Expression 558 559 begin 560 -- The queues of entries and entry families appear in textual order in 561 -- the associated record. The entry index is computed as the sum of the 562 -- number of queues for all entries that precede the designated one, to 563 -- which is added the index expression, if this expression denotes a 564 -- member of a family. 565 566 -- The following is a place holder for the count of simple entries 567 568 Num := Make_Integer_Literal (Sloc, 1); 569 570 -- We construct an expression which is a series of addition operations. 571 -- See comments in Entry_Index_Expression, which is identical in 572 -- structure. 573 574 if Present (Index) then 575 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); 576 577 Expr := 578 Make_Op_Add (Sloc, 579 Left_Opnd => Num, 580 581 Right_Opnd => 582 Actual_Family_Offset ( 583 Make_Attribute_Reference (Sloc, 584 Attribute_Name => Name_Pos, 585 Prefix => New_Occurrence_Of (Base_Type (S), Sloc), 586 Expressions => New_List (Relocate_Node (Index))), 587 Type_Low_Bound (S))); 588 else 589 Expr := Num; 590 end if; 591 592 -- Now add lengths of preceding entries and entry families 593 594 Prev := First_Entity (Ttyp); 595 596 while Chars (Prev) /= Chars (Ent) 597 or else (Ekind (Prev) /= Ekind (Ent)) 598 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 599 loop 600 if Ekind (Prev) = E_Entry then 601 Set_Intval (Num, Intval (Num) + 1); 602 603 elsif Ekind (Prev) = E_Entry_Family then 604 S := 605 Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); 606 607 -- The need for the following full view retrieval stems from this 608 -- complex case of nested generics and tasking: 609 610 -- generic 611 -- type Formal_Index is range <>; 612 -- ... 613 -- package Outer is 614 -- type Index is private; 615 -- generic 616 -- ... 617 -- package Inner is 618 -- procedure P; 619 -- end Inner; 620 -- private 621 -- type Index is new Formal_Index range 1 .. 10; 622 -- end Outer; 623 624 -- package body Outer is 625 -- task type T is 626 -- entry Fam (Index); -- (2) 627 -- entry E; 628 -- end T; 629 -- package body Inner is -- (3) 630 -- procedure P is 631 -- begin 632 -- T.E; -- (1) 633 -- end P; 634 -- end Inner; 635 -- ... 636 637 -- We are currently building the index expression for the entry 638 -- call "T.E" (1). Part of the expansion must mention the range 639 -- of the discrete type "Index" (2) of entry family "Fam". 640 641 -- However only the private view of type "Index" is available to 642 -- the inner generic (3) because there was no prior mention of 643 -- the type inside "Inner". This visibility requirement is 644 -- implicit and cannot be detected during the construction of 645 -- the generic trees and needs special handling. 646 647 if In_Instance_Body 648 and then Is_Private_Type (S) 649 and then Present (Full_View (S)) 650 then 651 S := Full_View (S); 652 end if; 653 654 Lo := Type_Low_Bound (S); 655 Hi := Type_High_Bound (S); 656 657 Expr := 658 Make_Op_Add (Sloc, 659 Left_Opnd => Expr, 660 Right_Opnd => 661 Make_Op_Add (Sloc, 662 Left_Opnd => 663 Actual_Family_Offset (Hi, Lo), 664 Right_Opnd => 665 Make_Integer_Literal (Sloc, 1))); 666 667 -- Other components are anonymous types to be ignored 668 669 else 670 null; 671 end if; 672 673 Next_Entity (Prev); 674 end loop; 675 676 return Expr; 677 end Actual_Index_Expression; 678 679 -------------------------- 680 -- Add_Formal_Renamings -- 681 -------------------------- 682 683 procedure Add_Formal_Renamings 684 (Spec : Node_Id; 685 Decls : List_Id; 686 Ent : Entity_Id; 687 Loc : Source_Ptr) 688 is 689 Ptr : constant Entity_Id := 690 Defining_Identifier 691 (Next (First (Parameter_Specifications (Spec)))); 692 -- The name of the formal that holds the address of the parameter block 693 -- for the call. 694 695 Comp : Entity_Id; 696 Decl : Node_Id; 697 Formal : Entity_Id; 698 New_F : Entity_Id; 699 Renamed_Formal : Node_Id; 700 701 begin 702 Formal := First_Formal (Ent); 703 while Present (Formal) loop 704 Comp := Entry_Component (Formal); 705 New_F := 706 Make_Defining_Identifier (Sloc (Formal), 707 Chars => Chars (Formal)); 708 Set_Etype (New_F, Etype (Formal)); 709 Set_Scope (New_F, Ent); 710 711 -- Now we set debug info needed on New_F even though it does not come 712 -- from source, so that the debugger will get the right information 713 -- for these generated names. 714 715 Set_Debug_Info_Needed (New_F); 716 717 if Ekind (Formal) = E_In_Parameter then 718 Set_Ekind (New_F, E_Constant); 719 else 720 Set_Ekind (New_F, E_Variable); 721 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 722 end if; 723 724 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 725 726 Renamed_Formal := 727 Make_Selected_Component (Loc, 728 Prefix => 729 Unchecked_Convert_To (Entry_Parameters_Type (Ent), 730 Make_Identifier (Loc, Chars (Ptr))), 731 Selector_Name => New_Occurrence_Of (Comp, Loc)); 732 733 Decl := 734 Build_Renamed_Formal_Declaration 735 (New_F, Formal, Comp, Renamed_Formal); 736 737 Append (Decl, Decls); 738 Set_Renamed_Object (Formal, New_F); 739 Next_Formal (Formal); 740 end loop; 741 end Add_Formal_Renamings; 742 743 ------------------------ 744 -- Add_Object_Pointer -- 745 ------------------------ 746 747 procedure Add_Object_Pointer 748 (Loc : Source_Ptr; 749 Conc_Typ : Entity_Id; 750 Decls : List_Id) 751 is 752 Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ); 753 Decl : Node_Id; 754 Obj_Ptr : Node_Id; 755 756 begin 757 -- Create the renaming declaration for the Protection object of a 758 -- protected type. _Object is used by Complete_Entry_Body. 759 -- ??? An attempt to make this a renaming was unsuccessful. 760 761 -- Build the entity for the access type 762 763 Obj_Ptr := 764 Make_Defining_Identifier (Loc, 765 New_External_Name (Chars (Rec_Typ), 'P')); 766 767 -- Generate: 768 -- _object : poVP := poVP!O; 769 770 Decl := 771 Make_Object_Declaration (Loc, 772 Defining_Identifier => 773 Make_Defining_Identifier (Loc, Name_uObject), 774 Object_Definition => 775 New_Occurrence_Of (Obj_Ptr, Loc), 776 Expression => 777 Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO))); 778 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 779 Prepend_To (Decls, Decl); 780 781 -- Generate: 782 -- type poVP is access poV; 783 784 Decl := 785 Make_Full_Type_Declaration (Loc, 786 Defining_Identifier => 787 Obj_Ptr, 788 Type_Definition => 789 Make_Access_To_Object_Definition (Loc, 790 Subtype_Indication => 791 New_Occurrence_Of (Rec_Typ, Loc))); 792 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 793 Prepend_To (Decls, Decl); 794 end Add_Object_Pointer; 795 796 ----------------------- 797 -- Build_Accept_Body -- 798 ----------------------- 799 800 function Build_Accept_Body (Astat : Node_Id) return Node_Id is 801 Loc : constant Source_Ptr := Sloc (Astat); 802 Stats : constant Node_Id := Handled_Statement_Sequence (Astat); 803 New_S : Node_Id; 804 Hand : Node_Id; 805 Call : Node_Id; 806 Ohandle : Node_Id; 807 808 begin 809 -- At the end of the statement sequence, Complete_Rendezvous is called. 810 -- A label skipping the Complete_Rendezvous, and all other accept 811 -- processing, has already been added for the expansion of requeue 812 -- statements. The Sloc is copied from the last statement since it 813 -- is really part of this last statement. 814 815 Call := 816 Build_Runtime_Call 817 (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous); 818 Insert_Before (Last (Statements (Stats)), Call); 819 Analyze (Call); 820 821 -- If exception handlers are present, then append Complete_Rendezvous 822 -- calls to the handlers, and construct the required outer block. As 823 -- above, the Sloc is copied from the last statement in the sequence. 824 825 if Present (Exception_Handlers (Stats)) then 826 Hand := First (Exception_Handlers (Stats)); 827 while Present (Hand) loop 828 Call := 829 Build_Runtime_Call 830 (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous); 831 Append (Call, Statements (Hand)); 832 Analyze (Call); 833 Next (Hand); 834 end loop; 835 836 New_S := 837 Make_Handled_Sequence_Of_Statements (Loc, 838 Statements => New_List ( 839 Make_Block_Statement (Loc, 840 Handled_Statement_Sequence => Stats))); 841 842 else 843 New_S := Stats; 844 end if; 845 846 -- At this stage we know that the new statement sequence does 847 -- not have an exception handler part, so we supply one to call 848 -- Exceptional_Complete_Rendezvous. This handler is 849 850 -- when all others => 851 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 852 853 -- We handle Abort_Signal to make sure that we properly catch the abort 854 -- case and wake up the caller. 855 856 Ohandle := Make_Others_Choice (Loc); 857 Set_All_Others (Ohandle); 858 859 Set_Exception_Handlers (New_S, 860 New_List ( 861 Make_Implicit_Exception_Handler (Loc, 862 Exception_Choices => New_List (Ohandle), 863 864 Statements => New_List ( 865 Make_Procedure_Call_Statement (Sloc (Stats), 866 Name => New_Occurrence_Of ( 867 RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)), 868 Parameter_Associations => New_List ( 869 Make_Function_Call (Sloc (Stats), 870 Name => New_Occurrence_Of ( 871 RTE (RE_Get_GNAT_Exception), Sloc (Stats))))))))); 872 873 Set_Parent (New_S, Astat); -- temp parent for Analyze call 874 Analyze_Exception_Handlers (Exception_Handlers (New_S)); 875 Expand_Exception_Handlers (New_S); 876 877 -- Exceptional_Complete_Rendezvous must be called with abort 878 -- still deferred, which is the case for a "when all others" handler. 879 880 return New_S; 881 end Build_Accept_Body; 882 883 ----------------------------------- 884 -- Build_Activation_Chain_Entity -- 885 ----------------------------------- 886 887 procedure Build_Activation_Chain_Entity (N : Node_Id) is 888 function Has_Activation_Chain (Stmt : Node_Id) return Boolean; 889 -- Determine whether an extended return statement has an activation 890 -- chain. 891 892 -------------------------- 893 -- Has_Activation_Chain -- 894 -------------------------- 895 896 function Has_Activation_Chain (Stmt : Node_Id) return Boolean is 897 Decl : Node_Id; 898 899 begin 900 Decl := First (Return_Object_Declarations (Stmt)); 901 while Present (Decl) loop 902 if Nkind (Decl) = N_Object_Declaration 903 and then Chars (Defining_Identifier (Decl)) = Name_uChain 904 then 905 return True; 906 end if; 907 908 Next (Decl); 909 end loop; 910 911 return False; 912 end Has_Activation_Chain; 913 914 -- Local variables 915 916 Context : Node_Id; 917 Context_Id : Entity_Id; 918 Decls : List_Id; 919 920 -- Start of processing for Build_Activation_Chain_Entity 921 922 begin 923 -- Activation chain is never used for sequential elaboration policy, see 924 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 925 926 if Partition_Elaboration_Policy = 'S' then 927 return; 928 end if; 929 930 Find_Enclosing_Context (N, Context, Context_Id, Decls); 931 932 -- If activation chain entity has not been declared already, create one 933 934 if Nkind (Context) = N_Extended_Return_Statement 935 or else No (Activation_Chain_Entity (Context)) 936 then 937 -- Since extended return statements do not store the entity of the 938 -- chain, examine the return object declarations to avoid creating 939 -- a duplicate. 940 941 if Nkind (Context) = N_Extended_Return_Statement 942 and then Has_Activation_Chain (Context) 943 then 944 return; 945 end if; 946 947 declare 948 Loc : constant Source_Ptr := Sloc (Context); 949 Chain : Entity_Id; 950 Decl : Node_Id; 951 952 begin 953 Chain := Make_Defining_Identifier (Sloc (N), Name_uChain); 954 955 -- Note: An extended return statement is not really a task 956 -- activator, but it does have an activation chain on which to 957 -- store the tasks temporarily. On successful return, the tasks 958 -- on this chain are moved to the chain passed in by the caller. 959 -- We do not build an Activation_Chain_Entity for an extended 960 -- return statement, because we do not want to build a call to 961 -- Activate_Tasks. Task activation is the responsibility of the 962 -- caller. 963 964 if Nkind (Context) /= N_Extended_Return_Statement then 965 Set_Activation_Chain_Entity (Context, Chain); 966 end if; 967 968 Decl := 969 Make_Object_Declaration (Loc, 970 Defining_Identifier => Chain, 971 Aliased_Present => True, 972 Object_Definition => 973 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)); 974 975 Prepend_To (Decls, Decl); 976 977 -- Ensure that _chain appears in the proper scope of the context 978 979 if Context_Id /= Current_Scope then 980 Push_Scope (Context_Id); 981 Analyze (Decl); 982 Pop_Scope; 983 else 984 Analyze (Decl); 985 end if; 986 end; 987 end if; 988 end Build_Activation_Chain_Entity; 989 990 ---------------------------- 991 -- Build_Barrier_Function -- 992 ---------------------------- 993 994 function Build_Barrier_Function 995 (N : Node_Id; 996 Ent : Entity_Id; 997 Pid : Node_Id) return Node_Id 998 is 999 Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); 1000 Cond : constant Node_Id := Condition (Ent_Formals); 1001 Loc : constant Source_Ptr := Sloc (Cond); 1002 Func_Id : constant Entity_Id := Barrier_Function (Ent); 1003 Op_Decls : constant List_Id := New_List; 1004 Stmt : Node_Id; 1005 Func_Body : Node_Id; 1006 1007 begin 1008 -- Add a declaration for the Protection object, renaming declarations 1009 -- for the discriminals and privals and finally a declaration for the 1010 -- entry family index (if applicable). 1011 1012 Install_Private_Data_Declarations (Sloc (N), 1013 Spec_Id => Func_Id, 1014 Conc_Typ => Pid, 1015 Body_Nod => N, 1016 Decls => Op_Decls, 1017 Barrier => True, 1018 Family => Ekind (Ent) = E_Entry_Family); 1019 1020 -- If compiling with -fpreserve-control-flow, make sure we insert an 1021 -- IF statement so that the back-end knows to generate a conditional 1022 -- branch instruction, even if the condition is just the name of a 1023 -- boolean object. Note that Expand_N_If_Statement knows to preserve 1024 -- such redundant IF statements under -fpreserve-control-flow 1025 -- (whether coming from this routine, or directly from source). 1026 1027 if Opt.Suppress_Control_Flow_Optimizations then 1028 Stmt := Make_Implicit_If_Statement (Cond, 1029 Condition => Cond, 1030 Then_Statements => New_List ( 1031 Make_Simple_Return_Statement (Loc, 1032 New_Occurrence_Of (Standard_True, Loc))), 1033 Else_Statements => New_List ( 1034 Make_Simple_Return_Statement (Loc, 1035 New_Occurrence_Of (Standard_False, Loc)))); 1036 1037 else 1038 Stmt := Make_Simple_Return_Statement (Loc, Cond); 1039 end if; 1040 1041 -- Note: the condition in the barrier function needs to be properly 1042 -- processed for the C/Fortran boolean possibility, but this happens 1043 -- automatically since the return statement does this normalization. 1044 1045 Func_Body := 1046 Make_Subprogram_Body (Loc, 1047 Specification => 1048 Build_Barrier_Function_Specification (Loc, 1049 Make_Defining_Identifier (Loc, Chars (Func_Id))), 1050 Declarations => Op_Decls, 1051 Handled_Statement_Sequence => 1052 Make_Handled_Sequence_Of_Statements (Loc, 1053 Statements => New_List (Stmt))); 1054 Set_Is_Entry_Barrier_Function (Func_Body); 1055 1056 return Func_Body; 1057 end Build_Barrier_Function; 1058 1059 ------------------------------------------ 1060 -- Build_Barrier_Function_Specification -- 1061 ------------------------------------------ 1062 1063 function Build_Barrier_Function_Specification 1064 (Loc : Source_Ptr; 1065 Def_Id : Entity_Id) return Node_Id 1066 is 1067 begin 1068 Set_Debug_Info_Needed (Def_Id); 1069 1070 return Make_Function_Specification (Loc, 1071 Defining_Unit_Name => Def_Id, 1072 Parameter_Specifications => New_List ( 1073 Make_Parameter_Specification (Loc, 1074 Defining_Identifier => 1075 Make_Defining_Identifier (Loc, Name_uO), 1076 Parameter_Type => 1077 New_Occurrence_Of (RTE (RE_Address), Loc)), 1078 1079 Make_Parameter_Specification (Loc, 1080 Defining_Identifier => 1081 Make_Defining_Identifier (Loc, Name_uE), 1082 Parameter_Type => 1083 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), 1084 1085 Result_Definition => 1086 New_Occurrence_Of (Standard_Boolean, Loc)); 1087 end Build_Barrier_Function_Specification; 1088 1089 -------------------------- 1090 -- Build_Call_With_Task -- 1091 -------------------------- 1092 1093 function Build_Call_With_Task 1094 (N : Node_Id; 1095 E : Entity_Id) return Node_Id 1096 is 1097 Loc : constant Source_Ptr := Sloc (N); 1098 begin 1099 return 1100 Make_Function_Call (Loc, 1101 Name => New_Occurrence_Of (E, Loc), 1102 Parameter_Associations => New_List (Concurrent_Ref (N))); 1103 end Build_Call_With_Task; 1104 1105 ----------------------------- 1106 -- Build_Class_Wide_Master -- 1107 ----------------------------- 1108 1109 procedure Build_Class_Wide_Master (Typ : Entity_Id) is 1110 Loc : constant Source_Ptr := Sloc (Typ); 1111 Master_Id : Entity_Id; 1112 Master_Scope : Entity_Id; 1113 Name_Id : Node_Id; 1114 Related_Node : Node_Id; 1115 Ren_Decl : Node_Id; 1116 1117 begin 1118 -- Nothing to do if there is no task hierarchy 1119 1120 if Restriction_Active (No_Task_Hierarchy) then 1121 return; 1122 end if; 1123 1124 -- Find the declaration that created the access type. It is either a 1125 -- type declaration, or an object declaration with an access definition, 1126 -- in which case the type is anonymous. 1127 1128 if Is_Itype (Typ) then 1129 Related_Node := Associated_Node_For_Itype (Typ); 1130 else 1131 Related_Node := Parent (Typ); 1132 end if; 1133 1134 Master_Scope := Find_Master_Scope (Typ); 1135 1136 -- Nothing to do if the master scope already contains a _master entity. 1137 -- The only exception to this is the following scenario: 1138 1139 -- Source_Scope 1140 -- Transient_Scope_1 1141 -- _master 1142 1143 -- Transient_Scope_2 1144 -- use of master 1145 1146 -- In this case the source scope is marked as having the master entity 1147 -- even though the actual declaration appears inside an inner scope. If 1148 -- the second transient scope requires a _master, it cannot use the one 1149 -- already declared because the entity is not visible. 1150 1151 Name_Id := Make_Identifier (Loc, Name_uMaster); 1152 1153 if not Has_Master_Entity (Master_Scope) 1154 or else No (Current_Entity_In_Scope (Name_Id)) 1155 then 1156 declare 1157 Master_Decl : Node_Id; 1158 1159 begin 1160 Set_Has_Master_Entity (Master_Scope); 1161 1162 -- Generate: 1163 -- _master : constant Integer := Current_Master.all; 1164 1165 Master_Decl := 1166 Make_Object_Declaration (Loc, 1167 Defining_Identifier => 1168 Make_Defining_Identifier (Loc, Name_uMaster), 1169 Constant_Present => True, 1170 Object_Definition => 1171 New_Occurrence_Of (Standard_Integer, Loc), 1172 Expression => 1173 Make_Explicit_Dereference (Loc, 1174 New_Occurrence_Of (RTE (RE_Current_Master), Loc))); 1175 1176 Insert_Action (Related_Node, Master_Decl); 1177 Analyze (Master_Decl); 1178 1179 -- Mark the containing scope as a task master. Masters associated 1180 -- with return statements are already marked at this stage (see 1181 -- Analyze_Subprogram_Body). 1182 1183 if Ekind (Current_Scope) /= E_Return_Statement then 1184 declare 1185 Par : Node_Id := Related_Node; 1186 1187 begin 1188 while Nkind (Par) /= N_Compilation_Unit loop 1189 Par := Parent (Par); 1190 1191 -- If we fall off the top, we are at the outer level, 1192 -- and the environment task is our effective master, 1193 -- so nothing to mark. 1194 1195 if Nkind_In (Par, N_Block_Statement, 1196 N_Subprogram_Body, 1197 N_Task_Body) 1198 then 1199 Set_Is_Task_Master (Par); 1200 exit; 1201 end if; 1202 end loop; 1203 end; 1204 end if; 1205 end; 1206 end if; 1207 1208 Master_Id := 1209 Make_Defining_Identifier (Loc, 1210 New_External_Name (Chars (Typ), 'M')); 1211 1212 -- Generate: 1213 -- Mnn renames _master; 1214 1215 Ren_Decl := 1216 Make_Object_Renaming_Declaration (Loc, 1217 Defining_Identifier => Master_Id, 1218 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), 1219 Name => Name_Id); 1220 1221 Insert_Action (Related_Node, Ren_Decl); 1222 1223 Set_Master_Id (Typ, Master_Id); 1224 end Build_Class_Wide_Master; 1225 1226 -------------------------------- 1227 -- Build_Corresponding_Record -- 1228 -------------------------------- 1229 1230 function Build_Corresponding_Record 1231 (N : Node_Id; 1232 Ctyp : Entity_Id; 1233 Loc : Source_Ptr) return Node_Id 1234 is 1235 Rec_Ent : constant Entity_Id := 1236 Make_Defining_Identifier 1237 (Loc, New_External_Name (Chars (Ctyp), 'V')); 1238 Disc : Entity_Id; 1239 Dlist : List_Id; 1240 New_Disc : Entity_Id; 1241 Cdecls : List_Id; 1242 1243 begin 1244 Set_Corresponding_Record_Type (Ctyp, Rec_Ent); 1245 Set_Ekind (Rec_Ent, E_Record_Type); 1246 Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp)); 1247 Set_Is_Concurrent_Record_Type (Rec_Ent, True); 1248 Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp); 1249 Set_Stored_Constraint (Rec_Ent, No_Elist); 1250 Cdecls := New_List; 1251 1252 -- Use discriminals to create list of discriminants for record, and 1253 -- create new discriminals for use in default expressions, etc. It is 1254 -- worth noting that a task discriminant gives rise to 5 entities; 1255 1256 -- a) The original discriminant. 1257 -- b) The discriminal for use in the task. 1258 -- c) The discriminant of the corresponding record. 1259 -- d) The discriminal for the init proc of the corresponding record. 1260 -- e) The local variable that renames the discriminant in the procedure 1261 -- for the task body. 1262 1263 -- In fact the discriminals b) are used in the renaming declarations 1264 -- for e). See details in einfo (Handling of Discriminants). 1265 1266 if Present (Discriminant_Specifications (N)) then 1267 Dlist := New_List; 1268 Disc := First_Discriminant (Ctyp); 1269 1270 while Present (Disc) loop 1271 New_Disc := CR_Discriminant (Disc); 1272 1273 Append_To (Dlist, 1274 Make_Discriminant_Specification (Loc, 1275 Defining_Identifier => New_Disc, 1276 Discriminant_Type => 1277 New_Occurrence_Of (Etype (Disc), Loc), 1278 Expression => 1279 New_Copy (Discriminant_Default_Value (Disc)))); 1280 1281 Next_Discriminant (Disc); 1282 end loop; 1283 1284 else 1285 Dlist := No_List; 1286 end if; 1287 1288 -- Now we can construct the record type declaration. Note that this 1289 -- record is "limited tagged". It is "limited" to reflect the underlying 1290 -- limitedness of the task or protected object that it represents, and 1291 -- ensuring for example that it is properly passed by reference. It is 1292 -- "tagged" to give support to dispatching calls through interfaces. We 1293 -- propagate here the list of interfaces covered by the concurrent type 1294 -- (Ada 2005: AI-345). 1295 1296 return 1297 Make_Full_Type_Declaration (Loc, 1298 Defining_Identifier => Rec_Ent, 1299 Discriminant_Specifications => Dlist, 1300 Type_Definition => 1301 Make_Record_Definition (Loc, 1302 Component_List => 1303 Make_Component_List (Loc, 1304 Component_Items => Cdecls), 1305 Tagged_Present => 1306 Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp), 1307 Interface_List => Interface_List (N), 1308 Limited_Present => True)); 1309 end Build_Corresponding_Record; 1310 1311 --------------------------------- 1312 -- Build_Dispatching_Tag_Check -- 1313 --------------------------------- 1314 1315 function Build_Dispatching_Tag_Check 1316 (K : Entity_Id; 1317 N : Node_Id) return Node_Id 1318 is 1319 Loc : constant Source_Ptr := Sloc (N); 1320 1321 begin 1322 return 1323 Make_Op_Or (Loc, 1324 Make_Op_Eq (Loc, 1325 Left_Opnd => 1326 New_Occurrence_Of (K, Loc), 1327 Right_Opnd => 1328 New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc)), 1329 1330 Make_Op_Eq (Loc, 1331 Left_Opnd => 1332 New_Occurrence_Of (K, Loc), 1333 Right_Opnd => 1334 New_Occurrence_Of (RTE (RE_TK_Tagged), Loc))); 1335 end Build_Dispatching_Tag_Check; 1336 1337 ---------------------------------- 1338 -- Build_Entry_Count_Expression -- 1339 ---------------------------------- 1340 1341 function Build_Entry_Count_Expression 1342 (Concurrent_Type : Node_Id; 1343 Component_List : List_Id; 1344 Loc : Source_Ptr) return Node_Id 1345 is 1346 Eindx : Nat; 1347 Ent : Entity_Id; 1348 Ecount : Node_Id; 1349 Comp : Node_Id; 1350 Lo : Node_Id; 1351 Hi : Node_Id; 1352 Typ : Entity_Id; 1353 Large : Boolean; 1354 1355 begin 1356 -- Count number of non-family entries 1357 1358 Eindx := 0; 1359 Ent := First_Entity (Concurrent_Type); 1360 while Present (Ent) loop 1361 if Ekind (Ent) = E_Entry then 1362 Eindx := Eindx + 1; 1363 end if; 1364 1365 Next_Entity (Ent); 1366 end loop; 1367 1368 Ecount := Make_Integer_Literal (Loc, Eindx); 1369 1370 -- Loop through entry families building the addition nodes 1371 1372 Ent := First_Entity (Concurrent_Type); 1373 Comp := First (Component_List); 1374 while Present (Ent) loop 1375 if Ekind (Ent) = E_Entry_Family then 1376 while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop 1377 Next (Comp); 1378 end loop; 1379 1380 Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); 1381 Hi := Type_High_Bound (Typ); 1382 Lo := Type_Low_Bound (Typ); 1383 Large := Is_Potentially_Large_Family 1384 (Base_Type (Typ), Concurrent_Type, Lo, Hi); 1385 Ecount := 1386 Make_Op_Add (Loc, 1387 Left_Opnd => Ecount, 1388 Right_Opnd => Family_Size 1389 (Loc, Hi, Lo, Concurrent_Type, Large)); 1390 end if; 1391 1392 Next_Entity (Ent); 1393 end loop; 1394 1395 return Ecount; 1396 end Build_Entry_Count_Expression; 1397 1398 ----------------------- 1399 -- Build_Entry_Names -- 1400 ----------------------- 1401 1402 procedure Build_Entry_Names 1403 (Obj_Ref : Node_Id; 1404 Obj_Typ : Entity_Id; 1405 Stmts : List_Id) 1406 is 1407 Loc : constant Source_Ptr := Sloc (Obj_Ref); 1408 Data : Entity_Id := Empty; 1409 Index : Entity_Id := Empty; 1410 Typ : Entity_Id := Obj_Typ; 1411 1412 procedure Build_Entry_Name (Comp_Id : Entity_Id); 1413 -- Given an entry [family], create a static string which denotes the 1414 -- name of Comp_Id and assign it to the underlying data structure which 1415 -- contains the entry names of a concurrent object. 1416 1417 function Object_Reference return Node_Id; 1418 -- Return a reference to field _object or _task_id depending on the 1419 -- concurrent object being processed. 1420 1421 ---------------------- 1422 -- Build_Entry_Name -- 1423 ---------------------- 1424 1425 procedure Build_Entry_Name (Comp_Id : Entity_Id) is 1426 function Build_Range (Def : Node_Id) return Node_Id; 1427 -- Given a discrete subtype definition of an entry family, generate a 1428 -- range node which covers the range of Def's type. 1429 1430 procedure Create_Index_And_Data; 1431 -- Generate the declarations of variables Index and Data. Subsequent 1432 -- calls do nothing. 1433 1434 function Increment_Index return Node_Id; 1435 -- Increment the index used in the assignment of string names to the 1436 -- Data array. 1437 1438 function Name_Declaration (Def_Id : Entity_Id) return Node_Id; 1439 -- Given the name of a temporary variable, create the following 1440 -- declaration for it: 1441 -- 1442 -- Def_Id : aliased constant String := <String_Name_From_Buffer>; 1443 1444 function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id; 1445 -- Given the name of a temporary variable, place it in the array of 1446 -- string names. Generate: 1447 -- 1448 -- Data (Index) := Def_Id'Unchecked_Access; 1449 1450 ----------------- 1451 -- Build_Range -- 1452 ----------------- 1453 1454 function Build_Range (Def : Node_Id) return Node_Id is 1455 High : Node_Id := Type_High_Bound (Etype (Def)); 1456 Low : Node_Id := Type_Low_Bound (Etype (Def)); 1457 1458 begin 1459 -- If a bound references a discriminant, generate an identifier 1460 -- with the same name. Resolution will map it to the formals of 1461 -- the init proc. 1462 1463 if Is_Entity_Name (Low) 1464 and then Ekind (Entity (Low)) = E_Discriminant 1465 then 1466 Low := 1467 Make_Selected_Component (Loc, 1468 Prefix => New_Copy_Tree (Obj_Ref), 1469 Selector_Name => Make_Identifier (Loc, Chars (Low))); 1470 else 1471 Low := New_Copy_Tree (Low); 1472 end if; 1473 1474 if Is_Entity_Name (High) 1475 and then Ekind (Entity (High)) = E_Discriminant 1476 then 1477 High := 1478 Make_Selected_Component (Loc, 1479 Prefix => New_Copy_Tree (Obj_Ref), 1480 Selector_Name => Make_Identifier (Loc, Chars (High))); 1481 else 1482 High := New_Copy_Tree (High); 1483 end if; 1484 1485 return 1486 Make_Range (Loc, 1487 Low_Bound => Low, 1488 High_Bound => High); 1489 end Build_Range; 1490 1491 --------------------------- 1492 -- Create_Index_And_Data -- 1493 --------------------------- 1494 1495 procedure Create_Index_And_Data is 1496 begin 1497 if No (Index) and then No (Data) then 1498 declare 1499 Count : RE_Id; 1500 Data_Typ : RE_Id; 1501 Size : Entity_Id; 1502 1503 begin 1504 if Is_Protected_Type (Typ) then 1505 Count := RO_PE_Number_Of_Entries; 1506 Data_Typ := RE_Protected_Entry_Names_Array; 1507 else 1508 Count := RO_ST_Number_Of_Entries; 1509 Data_Typ := RE_Task_Entry_Names_Array; 1510 end if; 1511 1512 -- Step 1: Generate the declaration of the index variable: 1513 1514 -- Index : Entry_Index := 1; 1515 1516 Index := Make_Temporary (Loc, 'I'); 1517 1518 Append_To (Stmts, 1519 Make_Object_Declaration (Loc, 1520 Defining_Identifier => Index, 1521 Object_Definition => 1522 New_Occurrence_Of (RTE (RE_Entry_Index), Loc), 1523 Expression => Make_Integer_Literal (Loc, 1))); 1524 1525 -- Step 2: Generate the declaration of an array to house all 1526 -- names: 1527 1528 -- Size : constant Entry_Index := <Count> (Obj_Ref); 1529 -- Data : aliased <Data_Typ> := (1 .. Size => null); 1530 1531 Size := Make_Temporary (Loc, 'S'); 1532 1533 Append_To (Stmts, 1534 Make_Object_Declaration (Loc, 1535 Defining_Identifier => Size, 1536 Constant_Present => True, 1537 Object_Definition => 1538 New_Occurrence_Of (RTE (RE_Entry_Index), Loc), 1539 Expression => 1540 Make_Function_Call (Loc, 1541 Name => 1542 New_Occurrence_Of (RTE (Count), Loc), 1543 Parameter_Associations => 1544 New_List (Object_Reference)))); 1545 1546 Data := Make_Temporary (Loc, 'A'); 1547 1548 Append_To (Stmts, 1549 Make_Object_Declaration (Loc, 1550 Defining_Identifier => Data, 1551 Aliased_Present => True, 1552 Object_Definition => 1553 New_Occurrence_Of (RTE (Data_Typ), Loc), 1554 Expression => 1555 Make_Aggregate (Loc, 1556 Component_Associations => New_List ( 1557 Make_Component_Association (Loc, 1558 Choices => New_List ( 1559 Make_Range (Loc, 1560 Low_Bound => 1561 Make_Integer_Literal (Loc, 1), 1562 High_Bound => 1563 New_Occurrence_Of (Size, Loc))), 1564 Expression => Make_Null (Loc)))))); 1565 end; 1566 end if; 1567 end Create_Index_And_Data; 1568 1569 --------------------- 1570 -- Increment_Index -- 1571 --------------------- 1572 1573 function Increment_Index return Node_Id is 1574 begin 1575 return 1576 Make_Assignment_Statement (Loc, 1577 Name => New_Occurrence_Of (Index, Loc), 1578 Expression => 1579 Make_Op_Add (Loc, 1580 Left_Opnd => New_Occurrence_Of (Index, Loc), 1581 Right_Opnd => Make_Integer_Literal (Loc, 1))); 1582 end Increment_Index; 1583 1584 ---------------------- 1585 -- Name_Declaration -- 1586 ---------------------- 1587 1588 function Name_Declaration (Def_Id : Entity_Id) return Node_Id is 1589 begin 1590 return 1591 Make_Object_Declaration (Loc, 1592 Defining_Identifier => Def_Id, 1593 Aliased_Present => True, 1594 Constant_Present => True, 1595 Object_Definition => 1596 New_Occurrence_Of (Standard_String, Loc), 1597 Expression => 1598 Make_String_Literal (Loc, String_From_Name_Buffer)); 1599 end Name_Declaration; 1600 1601 -------------------- 1602 -- Set_Entry_Name -- 1603 -------------------- 1604 1605 function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id is 1606 begin 1607 return 1608 Make_Assignment_Statement (Loc, 1609 Name => 1610 Make_Indexed_Component (Loc, 1611 Prefix => New_Occurrence_Of (Data, Loc), 1612 Expressions => New_List (New_Occurrence_Of (Index, Loc))), 1613 1614 Expression => 1615 Make_Attribute_Reference (Loc, 1616 Prefix => New_Occurrence_Of (Def_Id, Loc), 1617 Attribute_Name => Name_Unchecked_Access)); 1618 end Set_Entry_Name; 1619 1620 -- Local variables 1621 1622 Temp_Id : Entity_Id; 1623 Subt_Def : Node_Id; 1624 1625 -- Start of processing for Build_Entry_Name 1626 1627 begin 1628 if Ekind (Comp_Id) = E_Entry_Family then 1629 Subt_Def := Discrete_Subtype_Definition (Parent (Comp_Id)); 1630 1631 Create_Index_And_Data; 1632 1633 -- Step 1: Create the string name of the entry family. 1634 -- Generate: 1635 -- Temp : aliased constant String := "name ()"; 1636 1637 Temp_Id := Make_Temporary (Loc, 'S'); 1638 Get_Name_String (Chars (Comp_Id)); 1639 Add_Char_To_Name_Buffer (' '); 1640 Add_Char_To_Name_Buffer ('('); 1641 Add_Char_To_Name_Buffer (')'); 1642 1643 Append_To (Stmts, Name_Declaration (Temp_Id)); 1644 1645 -- Generate: 1646 -- for Member in Family_Low .. Family_High loop 1647 -- Set_Entry_Name (...); 1648 -- Index := Index + 1; 1649 -- end loop; 1650 1651 Append_To (Stmts, 1652 Make_Loop_Statement (Loc, 1653 Iteration_Scheme => 1654 Make_Iteration_Scheme (Loc, 1655 Loop_Parameter_Specification => 1656 Make_Loop_Parameter_Specification (Loc, 1657 Defining_Identifier => 1658 Make_Temporary (Loc, 'L'), 1659 Discrete_Subtype_Definition => 1660 Build_Range (Subt_Def))), 1661 1662 Statements => New_List ( 1663 Set_Entry_Name (Temp_Id), 1664 Increment_Index), 1665 End_Label => Empty)); 1666 1667 -- Entry 1668 1669 else 1670 Create_Index_And_Data; 1671 1672 -- Step 1: Create the string name of the entry. Generate: 1673 -- Temp : aliased constant String := "name"; 1674 1675 Temp_Id := Make_Temporary (Loc, 'S'); 1676 Get_Name_String (Chars (Comp_Id)); 1677 1678 Append_To (Stmts, Name_Declaration (Temp_Id)); 1679 1680 -- Step 2: Associate the string name with the underlying data 1681 -- structure. 1682 1683 Append_To (Stmts, Set_Entry_Name (Temp_Id)); 1684 Append_To (Stmts, Increment_Index); 1685 end if; 1686 end Build_Entry_Name; 1687 1688 ---------------------- 1689 -- Object_Reference -- 1690 ---------------------- 1691 1692 function Object_Reference return Node_Id is 1693 Conc_Typ : constant Entity_Id := Corresponding_Record_Type (Typ); 1694 Field : Name_Id; 1695 Ref : Node_Id; 1696 1697 begin 1698 if Is_Protected_Type (Typ) then 1699 Field := Name_uObject; 1700 else 1701 Field := Name_uTask_Id; 1702 end if; 1703 1704 Ref := 1705 Make_Selected_Component (Loc, 1706 Prefix => 1707 Unchecked_Convert_To (Conc_Typ, New_Copy_Tree (Obj_Ref)), 1708 Selector_Name => Make_Identifier (Loc, Field)); 1709 1710 if Is_Protected_Type (Typ) then 1711 Ref := 1712 Make_Attribute_Reference (Loc, 1713 Prefix => Ref, 1714 Attribute_Name => Name_Unchecked_Access); 1715 end if; 1716 1717 return Ref; 1718 end Object_Reference; 1719 1720 -- Local variables 1721 1722 Comp : Node_Id; 1723 Proc : RE_Id; 1724 1725 -- Start of processing for Build_Entry_Names 1726 1727 begin 1728 -- Retrieve the original concurrent type 1729 1730 if Is_Concurrent_Record_Type (Typ) then 1731 Typ := Corresponding_Concurrent_Type (Typ); 1732 end if; 1733 1734 pragma Assert (Is_Concurrent_Type (Typ)); 1735 1736 -- Nothing to do if the type has no entries 1737 1738 if not Has_Entries (Typ) then 1739 return; 1740 end if; 1741 1742 -- Avoid generating entry names for a protected type with only one entry 1743 1744 if Is_Protected_Type (Typ) 1745 and then Find_Protection_Type (Base_Type (Typ)) /= 1746 RTE (RE_Protection_Entries) 1747 then 1748 return; 1749 end if; 1750 1751 -- Step 1: Populate the array with statically generated strings denoting 1752 -- entries and entry family names. 1753 1754 Comp := First_Entity (Typ); 1755 while Present (Comp) loop 1756 if Comes_From_Source (Comp) 1757 and then Ekind_In (Comp, E_Entry, E_Entry_Family) 1758 then 1759 Build_Entry_Name (Comp); 1760 end if; 1761 1762 Next_Entity (Comp); 1763 end loop; 1764 1765 -- Step 2: Associate the array with the related concurrent object: 1766 1767 -- Set_Entry_Names (Obj_Ref, <Data>'Unchecked_Access); 1768 1769 if Present (Data) then 1770 if Is_Protected_Type (Typ) then 1771 Proc := RO_PE_Set_Entry_Names; 1772 else 1773 Proc := RO_ST_Set_Entry_Names; 1774 end if; 1775 1776 Append_To (Stmts, 1777 Make_Procedure_Call_Statement (Loc, 1778 Name => New_Occurrence_Of (RTE (Proc), Loc), 1779 Parameter_Associations => New_List ( 1780 Object_Reference, 1781 Make_Attribute_Reference (Loc, 1782 Prefix => New_Occurrence_Of (Data, Loc), 1783 Attribute_Name => Name_Unchecked_Access)))); 1784 end if; 1785 end Build_Entry_Names; 1786 1787 --------------------------- 1788 -- Build_Parameter_Block -- 1789 --------------------------- 1790 1791 function Build_Parameter_Block 1792 (Loc : Source_Ptr; 1793 Actuals : List_Id; 1794 Formals : List_Id; 1795 Decls : List_Id) return Entity_Id 1796 is 1797 Actual : Entity_Id; 1798 Comp_Nam : Node_Id; 1799 Comps : List_Id; 1800 Formal : Entity_Id; 1801 Has_Comp : Boolean := False; 1802 Rec_Nam : Node_Id; 1803 1804 begin 1805 Actual := First (Actuals); 1806 Comps := New_List; 1807 Formal := Defining_Identifier (First (Formals)); 1808 1809 while Present (Actual) loop 1810 if not Is_Controlling_Actual (Actual) then 1811 1812 -- Generate: 1813 -- type Ann is access all <actual-type> 1814 1815 Comp_Nam := Make_Temporary (Loc, 'A'); 1816 1817 Append_To (Decls, 1818 Make_Full_Type_Declaration (Loc, 1819 Defining_Identifier => Comp_Nam, 1820 Type_Definition => 1821 Make_Access_To_Object_Definition (Loc, 1822 All_Present => True, 1823 Constant_Present => Ekind (Formal) = E_In_Parameter, 1824 Subtype_Indication => 1825 New_Occurrence_Of (Etype (Actual), Loc)))); 1826 1827 -- Generate: 1828 -- Param : Ann; 1829 1830 Append_To (Comps, 1831 Make_Component_Declaration (Loc, 1832 Defining_Identifier => 1833 Make_Defining_Identifier (Loc, Chars (Formal)), 1834 Component_Definition => 1835 Make_Component_Definition (Loc, 1836 Aliased_Present => 1837 False, 1838 Subtype_Indication => 1839 New_Occurrence_Of (Comp_Nam, Loc)))); 1840 1841 Has_Comp := True; 1842 end if; 1843 1844 Next_Actual (Actual); 1845 Next_Formal_With_Extras (Formal); 1846 end loop; 1847 1848 Rec_Nam := Make_Temporary (Loc, 'P'); 1849 1850 if Has_Comp then 1851 1852 -- Generate: 1853 -- type Pnn is record 1854 -- Param1 : Ann1; 1855 -- ... 1856 -- ParamN : AnnN; 1857 1858 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are 1859 -- the original parameter names and Ann1 .. AnnN are the access to 1860 -- actual types. 1861 1862 Append_To (Decls, 1863 Make_Full_Type_Declaration (Loc, 1864 Defining_Identifier => 1865 Rec_Nam, 1866 Type_Definition => 1867 Make_Record_Definition (Loc, 1868 Component_List => 1869 Make_Component_List (Loc, Comps)))); 1870 else 1871 -- Generate: 1872 -- type Pnn is null record; 1873 1874 Append_To (Decls, 1875 Make_Full_Type_Declaration (Loc, 1876 Defining_Identifier => 1877 Rec_Nam, 1878 Type_Definition => 1879 Make_Record_Definition (Loc, 1880 Null_Present => True, 1881 Component_List => Empty))); 1882 end if; 1883 1884 return Rec_Nam; 1885 end Build_Parameter_Block; 1886 1887 -------------------------------------- 1888 -- Build_Renamed_Formal_Declaration -- 1889 -------------------------------------- 1890 1891 function Build_Renamed_Formal_Declaration 1892 (New_F : Entity_Id; 1893 Formal : Entity_Id; 1894 Comp : Entity_Id; 1895 Renamed_Formal : Node_Id) return Node_Id 1896 is 1897 Loc : constant Source_Ptr := Sloc (New_F); 1898 Decl : Node_Id; 1899 1900 begin 1901 -- If the formal is a tagged incomplete type, it is already passed 1902 -- by reference, so it is sufficient to rename the pointer component 1903 -- that corresponds to the actual. Otherwise we need to dereference 1904 -- the pointer component to obtain the actual. 1905 1906 if Is_Incomplete_Type (Etype (Formal)) 1907 and then Is_Tagged_Type (Etype (Formal)) 1908 then 1909 Decl := 1910 Make_Object_Renaming_Declaration (Loc, 1911 Defining_Identifier => New_F, 1912 Subtype_Mark => New_Occurrence_Of (Etype (Comp), Loc), 1913 Name => Renamed_Formal); 1914 1915 else 1916 Decl := 1917 Make_Object_Renaming_Declaration (Loc, 1918 Defining_Identifier => New_F, 1919 Subtype_Mark => New_Occurrence_Of (Etype (Formal), Loc), 1920 Name => 1921 Make_Explicit_Dereference (Loc, Renamed_Formal)); 1922 end if; 1923 1924 return Decl; 1925 end Build_Renamed_Formal_Declaration; 1926 1927 ----------------------- 1928 -- Build_PPC_Wrapper -- 1929 ----------------------- 1930 1931 procedure Build_PPC_Wrapper (E : Entity_Id; Decl : Node_Id) is 1932 Loc : constant Source_Ptr := Sloc (E); 1933 Synch_Type : constant Entity_Id := Scope (E); 1934 1935 Wrapper_Id : constant Entity_Id := 1936 Make_Defining_Identifier (Loc, 1937 Chars => New_External_Name (Chars (E), 'E')); 1938 -- the wrapper procedure name 1939 1940 Wrapper_Body : Node_Id; 1941 1942 Synch_Id : constant Entity_Id := 1943 Make_Defining_Identifier (Loc, 1944 Chars => New_External_Name (Chars (Scope (E)), 'A')); 1945 -- The parameter that designates the synchronized object in the call 1946 1947 Actuals : constant List_Id := New_List; 1948 -- The actuals in the entry call 1949 1950 Decls : constant List_Id := New_List; 1951 1952 Entry_Call : Node_Id; 1953 Entry_Name : Node_Id; 1954 1955 Specs : List_Id; 1956 -- The specification of the wrapper procedure 1957 1958 begin 1959 1960 -- Only build the wrapper if entry has pre/postconditions. 1961 -- Should this be done unconditionally instead ??? 1962 1963 declare 1964 P : Node_Id; 1965 1966 begin 1967 P := Pre_Post_Conditions (Contract (E)); 1968 1969 if No (P) then 1970 return; 1971 end if; 1972 1973 -- Transfer ppc pragmas to the declarations of the wrapper 1974 1975 while Present (P) loop 1976 if Nam_In (Pragma_Name (P), Name_Precondition, 1977 Name_Postcondition) 1978 then 1979 Append (Relocate_Node (P), Decls); 1980 Set_Analyzed (Last (Decls), False); 1981 end if; 1982 1983 P := Next_Pragma (P); 1984 end loop; 1985 end; 1986 1987 -- First formal is synchronized object 1988 1989 Specs := New_List ( 1990 Make_Parameter_Specification (Loc, 1991 Defining_Identifier => Synch_Id, 1992 Out_Present => True, 1993 In_Present => True, 1994 Parameter_Type => New_Occurrence_Of (Scope (E), Loc))); 1995 1996 Entry_Name := 1997 Make_Selected_Component (Loc, 1998 Prefix => New_Occurrence_Of (Synch_Id, Loc), 1999 Selector_Name => New_Occurrence_Of (E, Loc)); 2000 2001 -- If entity is entry family, second formal is the corresponding index, 2002 -- and entry name is an indexed component. 2003 2004 if Ekind (E) = E_Entry_Family then 2005 declare 2006 Index : constant Entity_Id := 2007 Make_Defining_Identifier (Loc, Name_I); 2008 begin 2009 Append_To (Specs, 2010 Make_Parameter_Specification (Loc, 2011 Defining_Identifier => Index, 2012 Parameter_Type => 2013 New_Occurrence_Of (Entry_Index_Type (E), Loc))); 2014 2015 Entry_Name := 2016 Make_Indexed_Component (Loc, 2017 Prefix => Entry_Name, 2018 Expressions => New_List (New_Occurrence_Of (Index, Loc))); 2019 end; 2020 end if; 2021 2022 Entry_Call := 2023 Make_Procedure_Call_Statement (Loc, 2024 Name => Entry_Name, 2025 Parameter_Associations => Actuals); 2026 2027 -- Now add formals that match those of the entry, and build actuals for 2028 -- the nested entry call. 2029 2030 declare 2031 Form : Entity_Id; 2032 New_Form : Entity_Id; 2033 Parm_Spec : Node_Id; 2034 2035 begin 2036 Form := First_Formal (E); 2037 while Present (Form) loop 2038 New_Form := Make_Defining_Identifier (Loc, Chars (Form)); 2039 Parm_Spec := 2040 Make_Parameter_Specification (Loc, 2041 Defining_Identifier => New_Form, 2042 Out_Present => Out_Present (Parent (Form)), 2043 In_Present => In_Present (Parent (Form)), 2044 Parameter_Type => New_Occurrence_Of (Etype (Form), Loc)); 2045 2046 Append (Parm_Spec, Specs); 2047 Append (New_Occurrence_Of (New_Form, Loc), Actuals); 2048 Next_Formal (Form); 2049 end loop; 2050 end; 2051 2052 -- Add renaming declarations for the discriminants of the enclosing 2053 -- type, which may be visible in the preconditions. 2054 2055 if Has_Discriminants (Synch_Type) then 2056 declare 2057 D : Entity_Id; 2058 Decl : Node_Id; 2059 2060 begin 2061 D := First_Discriminant (Synch_Type); 2062 while Present (D) loop 2063 Decl := 2064 Make_Object_Renaming_Declaration (Loc, 2065 Defining_Identifier => 2066 Make_Defining_Identifier (Loc, Chars (D)), 2067 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc), 2068 Name => 2069 Make_Selected_Component (Loc, 2070 Prefix => New_Occurrence_Of (Synch_Id, Loc), 2071 Selector_Name => Make_Identifier (Loc, Chars (D)))); 2072 Prepend (Decl, Decls); 2073 Next_Discriminant (D); 2074 end loop; 2075 end; 2076 end if; 2077 2078 Set_PPC_Wrapper (E, Wrapper_Id); 2079 Wrapper_Body := 2080 Make_Subprogram_Body (Loc, 2081 Specification => 2082 Make_Procedure_Specification (Loc, 2083 Defining_Unit_Name => Wrapper_Id, 2084 Parameter_Specifications => Specs), 2085 Declarations => Decls, 2086 Handled_Statement_Sequence => 2087 Make_Handled_Sequence_Of_Statements (Loc, 2088 Statements => New_List (Entry_Call))); 2089 2090 -- The wrapper body is analyzed when the enclosing type is frozen 2091 2092 Append_Freeze_Action (Defining_Entity (Decl), Wrapper_Body); 2093 end Build_PPC_Wrapper; 2094 2095 -------------------------- 2096 -- Build_Wrapper_Bodies -- 2097 -------------------------- 2098 2099 procedure Build_Wrapper_Bodies 2100 (Loc : Source_Ptr; 2101 Typ : Entity_Id; 2102 N : Node_Id) 2103 is 2104 Rec_Typ : Entity_Id; 2105 2106 function Build_Wrapper_Body 2107 (Loc : Source_Ptr; 2108 Subp_Id : Entity_Id; 2109 Obj_Typ : Entity_Id; 2110 Formals : List_Id) return Node_Id; 2111 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation 2112 -- associated with a protected or task type. Subp_Id is the subprogram 2113 -- name which will be wrapped. Obj_Typ is the type of the new formal 2114 -- parameter which handles dispatching and object notation. Formals are 2115 -- the original formals of Subp_Id which will be explicitly replicated. 2116 2117 ------------------------ 2118 -- Build_Wrapper_Body -- 2119 ------------------------ 2120 2121 function Build_Wrapper_Body 2122 (Loc : Source_Ptr; 2123 Subp_Id : Entity_Id; 2124 Obj_Typ : Entity_Id; 2125 Formals : List_Id) return Node_Id 2126 is 2127 Body_Spec : Node_Id; 2128 2129 begin 2130 Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals); 2131 2132 -- The subprogram is not overriding or is not a primitive declared 2133 -- between two views. 2134 2135 if No (Body_Spec) then 2136 return Empty; 2137 end if; 2138 2139 declare 2140 Actuals : List_Id := No_List; 2141 Conv_Id : Node_Id; 2142 First_Form : Node_Id; 2143 Formal : Node_Id; 2144 Nam : Node_Id; 2145 2146 begin 2147 -- Map formals to actuals. Use the list built for the wrapper 2148 -- spec, skipping the object notation parameter. 2149 2150 First_Form := First (Parameter_Specifications (Body_Spec)); 2151 2152 Formal := First_Form; 2153 Next (Formal); 2154 2155 if Present (Formal) then 2156 Actuals := New_List; 2157 while Present (Formal) loop 2158 Append_To (Actuals, 2159 Make_Identifier (Loc, 2160 Chars => Chars (Defining_Identifier (Formal)))); 2161 Next (Formal); 2162 end loop; 2163 end if; 2164 2165 -- Special processing for primitives declared between a private 2166 -- type and its completion: the wrapper needs a properly typed 2167 -- parameter if the wrapped operation has a controlling first 2168 -- parameter. Note that this might not be the case for a function 2169 -- with a controlling result. 2170 2171 if Is_Private_Primitive_Subprogram (Subp_Id) then 2172 if No (Actuals) then 2173 Actuals := New_List; 2174 end if; 2175 2176 if Is_Controlling_Formal (First_Formal (Subp_Id)) then 2177 Prepend_To (Actuals, 2178 Unchecked_Convert_To 2179 (Corresponding_Concurrent_Type (Obj_Typ), 2180 Make_Identifier (Loc, Name_uO))); 2181 2182 else 2183 Prepend_To (Actuals, 2184 Make_Identifier (Loc, 2185 Chars => Chars (Defining_Identifier (First_Form)))); 2186 end if; 2187 2188 Nam := New_Occurrence_Of (Subp_Id, Loc); 2189 else 2190 -- An access-to-variable object parameter requires an explicit 2191 -- dereference in the unchecked conversion. This case occurs 2192 -- when a protected entry wrapper must override an interface 2193 -- level procedure with interface access as first parameter. 2194 2195 -- O.all.Subp_Id (Formal_1, ..., Formal_N) 2196 2197 if Nkind (Parameter_Type (First_Form)) = 2198 N_Access_Definition 2199 then 2200 Conv_Id := 2201 Make_Explicit_Dereference (Loc, 2202 Prefix => Make_Identifier (Loc, Name_uO)); 2203 else 2204 Conv_Id := Make_Identifier (Loc, Name_uO); 2205 end if; 2206 2207 Nam := 2208 Make_Selected_Component (Loc, 2209 Prefix => 2210 Unchecked_Convert_To 2211 (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id), 2212 Selector_Name => New_Occurrence_Of (Subp_Id, Loc)); 2213 end if; 2214 2215 -- Create the subprogram body. For a function, the call to the 2216 -- actual subprogram has to be converted to the corresponding 2217 -- record if it is a controlling result. 2218 2219 if Ekind (Subp_Id) = E_Function then 2220 declare 2221 Res : Node_Id; 2222 2223 begin 2224 Res := 2225 Make_Function_Call (Loc, 2226 Name => Nam, 2227 Parameter_Associations => Actuals); 2228 2229 if Has_Controlling_Result (Subp_Id) then 2230 Res := 2231 Unchecked_Convert_To 2232 (Corresponding_Record_Type (Etype (Subp_Id)), Res); 2233 end if; 2234 2235 return 2236 Make_Subprogram_Body (Loc, 2237 Specification => Body_Spec, 2238 Declarations => Empty_List, 2239 Handled_Statement_Sequence => 2240 Make_Handled_Sequence_Of_Statements (Loc, 2241 Statements => New_List ( 2242 Make_Simple_Return_Statement (Loc, Res)))); 2243 end; 2244 2245 else 2246 return 2247 Make_Subprogram_Body (Loc, 2248 Specification => Body_Spec, 2249 Declarations => Empty_List, 2250 Handled_Statement_Sequence => 2251 Make_Handled_Sequence_Of_Statements (Loc, 2252 Statements => New_List ( 2253 Make_Procedure_Call_Statement (Loc, 2254 Name => Nam, 2255 Parameter_Associations => Actuals)))); 2256 end if; 2257 end; 2258 end Build_Wrapper_Body; 2259 2260 -- Start of processing for Build_Wrapper_Bodies 2261 2262 begin 2263 if Is_Concurrent_Type (Typ) then 2264 Rec_Typ := Corresponding_Record_Type (Typ); 2265 else 2266 Rec_Typ := Typ; 2267 end if; 2268 2269 -- Generate wrapper bodies for a concurrent type which implements an 2270 -- interface. 2271 2272 if Present (Interfaces (Rec_Typ)) then 2273 declare 2274 Insert_Nod : Node_Id; 2275 Prim : Entity_Id; 2276 Prim_Elmt : Elmt_Id; 2277 Prim_Decl : Node_Id; 2278 Subp : Entity_Id; 2279 Wrap_Body : Node_Id; 2280 Wrap_Id : Entity_Id; 2281 2282 begin 2283 Insert_Nod := N; 2284 2285 -- Examine all primitive operations of the corresponding record 2286 -- type, looking for wrapper specs. Generate bodies in order to 2287 -- complete them. 2288 2289 Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ)); 2290 while Present (Prim_Elmt) loop 2291 Prim := Node (Prim_Elmt); 2292 2293 if (Ekind (Prim) = E_Function 2294 or else Ekind (Prim) = E_Procedure) 2295 and then Is_Primitive_Wrapper (Prim) 2296 then 2297 Subp := Wrapped_Entity (Prim); 2298 Prim_Decl := Parent (Parent (Prim)); 2299 2300 Wrap_Body := 2301 Build_Wrapper_Body (Loc, 2302 Subp_Id => Subp, 2303 Obj_Typ => Rec_Typ, 2304 Formals => Parameter_Specifications (Parent (Subp))); 2305 Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body)); 2306 2307 Set_Corresponding_Spec (Wrap_Body, Prim); 2308 Set_Corresponding_Body (Prim_Decl, Wrap_Id); 2309 2310 Insert_After (Insert_Nod, Wrap_Body); 2311 Insert_Nod := Wrap_Body; 2312 2313 Analyze (Wrap_Body); 2314 end if; 2315 2316 Next_Elmt (Prim_Elmt); 2317 end loop; 2318 end; 2319 end if; 2320 end Build_Wrapper_Bodies; 2321 2322 ------------------------ 2323 -- Build_Wrapper_Spec -- 2324 ------------------------ 2325 2326 function Build_Wrapper_Spec 2327 (Subp_Id : Entity_Id; 2328 Obj_Typ : Entity_Id; 2329 Formals : List_Id) return Node_Id 2330 is 2331 Loc : constant Source_Ptr := Sloc (Subp_Id); 2332 First_Param : Node_Id; 2333 Iface : Entity_Id; 2334 Iface_Elmt : Elmt_Id; 2335 Iface_Op : Entity_Id; 2336 Iface_Op_Elmt : Elmt_Id; 2337 2338 function Overriding_Possible 2339 (Iface_Op : Entity_Id; 2340 Wrapper : Entity_Id) return Boolean; 2341 -- Determine whether a primitive operation can be overridden by Wrapper. 2342 -- Iface_Op is the candidate primitive operation of an interface type, 2343 -- Wrapper is the generated entry wrapper. 2344 2345 function Replicate_Formals 2346 (Loc : Source_Ptr; 2347 Formals : List_Id) return List_Id; 2348 -- An explicit parameter replication is required due to the Is_Entry_ 2349 -- Formal flag being set for all the formals of an entry. The explicit 2350 -- replication removes the flag that would otherwise cause a different 2351 -- path of analysis. 2352 2353 ------------------------- 2354 -- Overriding_Possible -- 2355 ------------------------- 2356 2357 function Overriding_Possible 2358 (Iface_Op : Entity_Id; 2359 Wrapper : Entity_Id) return Boolean 2360 is 2361 Iface_Op_Spec : constant Node_Id := Parent (Iface_Op); 2362 Wrapper_Spec : constant Node_Id := Parent (Wrapper); 2363 2364 function Type_Conformant_Parameters 2365 (Iface_Op_Params : List_Id; 2366 Wrapper_Params : List_Id) return Boolean; 2367 -- Determine whether the parameters of the generated entry wrapper 2368 -- and those of a primitive operation are type conformant. During 2369 -- this check, the first parameter of the primitive operation is 2370 -- skipped if it is a controlling argument: protected functions 2371 -- may have a controlling result. 2372 2373 -------------------------------- 2374 -- Type_Conformant_Parameters -- 2375 -------------------------------- 2376 2377 function Type_Conformant_Parameters 2378 (Iface_Op_Params : List_Id; 2379 Wrapper_Params : List_Id) return Boolean 2380 is 2381 Iface_Op_Param : Node_Id; 2382 Iface_Op_Typ : Entity_Id; 2383 Wrapper_Param : Node_Id; 2384 Wrapper_Typ : Entity_Id; 2385 2386 begin 2387 -- Skip the first (controlling) parameter of primitive operation 2388 2389 Iface_Op_Param := First (Iface_Op_Params); 2390 2391 if Present (First_Formal (Iface_Op)) 2392 and then Is_Controlling_Formal (First_Formal (Iface_Op)) 2393 then 2394 Iface_Op_Param := Next (Iface_Op_Param); 2395 end if; 2396 2397 Wrapper_Param := First (Wrapper_Params); 2398 while Present (Iface_Op_Param) 2399 and then Present (Wrapper_Param) 2400 loop 2401 Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param); 2402 Wrapper_Typ := Find_Parameter_Type (Wrapper_Param); 2403 2404 -- The two parameters must be mode conformant 2405 2406 if not Conforming_Types 2407 (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant) 2408 then 2409 return False; 2410 end if; 2411 2412 Next (Iface_Op_Param); 2413 Next (Wrapper_Param); 2414 end loop; 2415 2416 -- One of the lists is longer than the other 2417 2418 if Present (Iface_Op_Param) or else Present (Wrapper_Param) then 2419 return False; 2420 end if; 2421 2422 return True; 2423 end Type_Conformant_Parameters; 2424 2425 -- Start of processing for Overriding_Possible 2426 2427 begin 2428 if Chars (Iface_Op) /= Chars (Wrapper) then 2429 return False; 2430 end if; 2431 2432 -- If an inherited subprogram is implemented by a protected procedure 2433 -- or an entry, then the first parameter of the inherited subprogram 2434 -- shall be of mode OUT or IN OUT, or access-to-variable parameter. 2435 2436 if Ekind (Iface_Op) = E_Procedure 2437 and then Present (Parameter_Specifications (Iface_Op_Spec)) 2438 then 2439 declare 2440 Obj_Param : constant Node_Id := 2441 First (Parameter_Specifications (Iface_Op_Spec)); 2442 begin 2443 if not Out_Present (Obj_Param) 2444 and then Nkind (Parameter_Type (Obj_Param)) /= 2445 N_Access_Definition 2446 then 2447 return False; 2448 end if; 2449 end; 2450 end if; 2451 2452 return 2453 Type_Conformant_Parameters ( 2454 Parameter_Specifications (Iface_Op_Spec), 2455 Parameter_Specifications (Wrapper_Spec)); 2456 end Overriding_Possible; 2457 2458 ----------------------- 2459 -- Replicate_Formals -- 2460 ----------------------- 2461 2462 function Replicate_Formals 2463 (Loc : Source_Ptr; 2464 Formals : List_Id) return List_Id 2465 is 2466 New_Formals : constant List_Id := New_List; 2467 Formal : Node_Id; 2468 Param_Type : Node_Id; 2469 2470 begin 2471 Formal := First (Formals); 2472 2473 -- Skip the object parameter when dealing with primitives declared 2474 -- between two views. 2475 2476 if Is_Private_Primitive_Subprogram (Subp_Id) 2477 and then not Has_Controlling_Result (Subp_Id) 2478 then 2479 Formal := Next (Formal); 2480 end if; 2481 2482 while Present (Formal) loop 2483 2484 -- Create an explicit copy of the entry parameter 2485 2486 -- When creating the wrapper subprogram for a primitive operation 2487 -- of a protected interface we must construct an equivalent 2488 -- signature to that of the overriding operation. For regular 2489 -- parameters we can just use the type of the formal, but for 2490 -- access to subprogram parameters we need to reanalyze the 2491 -- parameter type to create local entities for the signature of 2492 -- the subprogram type. Using the entities of the overriding 2493 -- subprogram will result in out-of-scope errors in the back-end. 2494 2495 if Nkind (Parameter_Type (Formal)) = N_Access_Definition then 2496 Param_Type := Copy_Separate_Tree (Parameter_Type (Formal)); 2497 else 2498 Param_Type := 2499 New_Occurrence_Of (Etype (Parameter_Type (Formal)), Loc); 2500 end if; 2501 2502 Append_To (New_Formals, 2503 Make_Parameter_Specification (Loc, 2504 Defining_Identifier => 2505 Make_Defining_Identifier (Loc, 2506 Chars => Chars (Defining_Identifier (Formal))), 2507 In_Present => In_Present (Formal), 2508 Out_Present => Out_Present (Formal), 2509 Parameter_Type => Param_Type)); 2510 2511 Next (Formal); 2512 end loop; 2513 2514 return New_Formals; 2515 end Replicate_Formals; 2516 2517 -- Start of processing for Build_Wrapper_Spec 2518 2519 begin 2520 -- There is no point in building wrappers for non-tagged concurrent 2521 -- types. 2522 2523 pragma Assert (Is_Tagged_Type (Obj_Typ)); 2524 2525 -- An entry or a protected procedure can override a routine where the 2526 -- controlling formal is either IN OUT, OUT or is of access-to-variable 2527 -- type. Since the wrapper must have the exact same signature as that of 2528 -- the overridden subprogram, we try to find the overriding candidate 2529 -- and use its controlling formal. 2530 2531 First_Param := Empty; 2532 2533 -- Check every implemented interface 2534 2535 if Present (Interfaces (Obj_Typ)) then 2536 Iface_Elmt := First_Elmt (Interfaces (Obj_Typ)); 2537 Search : while Present (Iface_Elmt) loop 2538 Iface := Node (Iface_Elmt); 2539 2540 -- Check every interface primitive 2541 2542 if Present (Primitive_Operations (Iface)) then 2543 Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); 2544 while Present (Iface_Op_Elmt) loop 2545 Iface_Op := Node (Iface_Op_Elmt); 2546 2547 -- Ignore predefined primitives 2548 2549 if not Is_Predefined_Dispatching_Operation (Iface_Op) then 2550 Iface_Op := Ultimate_Alias (Iface_Op); 2551 2552 -- The current primitive operation can be overridden by 2553 -- the generated entry wrapper. 2554 2555 if Overriding_Possible (Iface_Op, Subp_Id) then 2556 First_Param := 2557 First (Parameter_Specifications (Parent (Iface_Op))); 2558 2559 exit Search; 2560 end if; 2561 end if; 2562 2563 Next_Elmt (Iface_Op_Elmt); 2564 end loop; 2565 end if; 2566 2567 Next_Elmt (Iface_Elmt); 2568 end loop Search; 2569 end if; 2570 2571 -- Ada 2012 (AI05-0090-1): If no interface primitive is covered by 2572 -- this subprogram and this is not a primitive declared between two 2573 -- views then force the generation of a wrapper. As an optimization, 2574 -- previous versions of the frontend avoid generating the wrapper; 2575 -- however, the wrapper facilitates locating and reporting an error 2576 -- when a duplicate declaration is found later. See example in 2577 -- AI05-0090-1. 2578 2579 if No (First_Param) 2580 and then not Is_Private_Primitive_Subprogram (Subp_Id) 2581 then 2582 if Is_Task_Type 2583 (Corresponding_Concurrent_Type (Obj_Typ)) 2584 then 2585 First_Param := 2586 Make_Parameter_Specification (Loc, 2587 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), 2588 In_Present => True, 2589 Out_Present => False, 2590 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); 2591 2592 -- For entries and procedures of protected types the mode of 2593 -- the controlling argument must be in-out. 2594 2595 else 2596 First_Param := 2597 Make_Parameter_Specification (Loc, 2598 Defining_Identifier => 2599 Make_Defining_Identifier (Loc, 2600 Chars => Name_uO), 2601 In_Present => True, 2602 Out_Present => (Ekind (Subp_Id) /= E_Function), 2603 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); 2604 end if; 2605 end if; 2606 2607 declare 2608 Wrapper_Id : constant Entity_Id := 2609 Make_Defining_Identifier (Loc, Chars (Subp_Id)); 2610 New_Formals : List_Id; 2611 Obj_Param : Node_Id; 2612 Obj_Param_Typ : Entity_Id; 2613 2614 begin 2615 -- Minimum decoration is needed to catch the entity in 2616 -- Sem_Ch6.Override_Dispatching_Operation. 2617 2618 if Ekind (Subp_Id) = E_Function then 2619 Set_Ekind (Wrapper_Id, E_Function); 2620 else 2621 Set_Ekind (Wrapper_Id, E_Procedure); 2622 end if; 2623 2624 Set_Is_Primitive_Wrapper (Wrapper_Id); 2625 Set_Wrapped_Entity (Wrapper_Id, Subp_Id); 2626 Set_Is_Private_Primitive (Wrapper_Id, 2627 Is_Private_Primitive_Subprogram (Subp_Id)); 2628 2629 -- Process the formals 2630 2631 New_Formals := Replicate_Formals (Loc, Formals); 2632 2633 -- A function with a controlling result and no first controlling 2634 -- formal needs no additional parameter. 2635 2636 if Has_Controlling_Result (Subp_Id) 2637 and then 2638 (No (First_Formal (Subp_Id)) 2639 or else not Is_Controlling_Formal (First_Formal (Subp_Id))) 2640 then 2641 null; 2642 2643 -- Routine Subp_Id has been found to override an interface primitive. 2644 -- If the interface operation has an access parameter, create a copy 2645 -- of it, with the same null exclusion indicator if present. 2646 2647 elsif Present (First_Param) then 2648 if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then 2649 Obj_Param_Typ := 2650 Make_Access_Definition (Loc, 2651 Subtype_Mark => 2652 New_Occurrence_Of (Obj_Typ, Loc)); 2653 Set_Null_Exclusion_Present (Obj_Param_Typ, 2654 Null_Exclusion_Present (Parameter_Type (First_Param))); 2655 2656 else 2657 Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc); 2658 end if; 2659 2660 Obj_Param := 2661 Make_Parameter_Specification (Loc, 2662 Defining_Identifier => 2663 Make_Defining_Identifier (Loc, 2664 Chars => Name_uO), 2665 In_Present => In_Present (First_Param), 2666 Out_Present => Out_Present (First_Param), 2667 Parameter_Type => Obj_Param_Typ); 2668 2669 Prepend_To (New_Formals, Obj_Param); 2670 2671 -- If we are dealing with a primitive declared between two views, 2672 -- implemented by a synchronized operation, we need to create 2673 -- a default parameter. The mode of the parameter must match that 2674 -- of the primitive operation. 2675 2676 else 2677 pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id)); 2678 Obj_Param := 2679 Make_Parameter_Specification (Loc, 2680 Defining_Identifier => 2681 Make_Defining_Identifier (Loc, Name_uO), 2682 In_Present => In_Present (Parent (First_Entity (Subp_Id))), 2683 Out_Present => Ekind (Subp_Id) /= E_Function, 2684 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); 2685 Prepend_To (New_Formals, Obj_Param); 2686 end if; 2687 2688 -- Build the final spec. If it is a function with a controlling 2689 -- result, it is a primitive operation of the corresponding 2690 -- record type, so mark the spec accordingly. 2691 2692 if Ekind (Subp_Id) = E_Function then 2693 declare 2694 Res_Def : Node_Id; 2695 2696 begin 2697 if Has_Controlling_Result (Subp_Id) then 2698 Res_Def := 2699 New_Occurrence_Of 2700 (Corresponding_Record_Type (Etype (Subp_Id)), Loc); 2701 else 2702 Res_Def := New_Copy (Result_Definition (Parent (Subp_Id))); 2703 end if; 2704 2705 return 2706 Make_Function_Specification (Loc, 2707 Defining_Unit_Name => Wrapper_Id, 2708 Parameter_Specifications => New_Formals, 2709 Result_Definition => Res_Def); 2710 end; 2711 else 2712 return 2713 Make_Procedure_Specification (Loc, 2714 Defining_Unit_Name => Wrapper_Id, 2715 Parameter_Specifications => New_Formals); 2716 end if; 2717 end; 2718 end Build_Wrapper_Spec; 2719 2720 ------------------------- 2721 -- Build_Wrapper_Specs -- 2722 ------------------------- 2723 2724 procedure Build_Wrapper_Specs 2725 (Loc : Source_Ptr; 2726 Typ : Entity_Id; 2727 N : in out Node_Id) 2728 is 2729 Def : Node_Id; 2730 Rec_Typ : Entity_Id; 2731 procedure Scan_Declarations (L : List_Id); 2732 -- Common processing for visible and private declarations 2733 -- of a protected type. 2734 2735 procedure Scan_Declarations (L : List_Id) is 2736 Decl : Node_Id; 2737 Wrap_Decl : Node_Id; 2738 Wrap_Spec : Node_Id; 2739 2740 begin 2741 if No (L) then 2742 return; 2743 end if; 2744 2745 Decl := First (L); 2746 while Present (Decl) loop 2747 Wrap_Spec := Empty; 2748 2749 if Nkind (Decl) = N_Entry_Declaration 2750 and then Ekind (Defining_Identifier (Decl)) = E_Entry 2751 then 2752 Wrap_Spec := 2753 Build_Wrapper_Spec 2754 (Subp_Id => Defining_Identifier (Decl), 2755 Obj_Typ => Rec_Typ, 2756 Formals => Parameter_Specifications (Decl)); 2757 2758 elsif Nkind (Decl) = N_Subprogram_Declaration then 2759 Wrap_Spec := 2760 Build_Wrapper_Spec 2761 (Subp_Id => Defining_Unit_Name (Specification (Decl)), 2762 Obj_Typ => Rec_Typ, 2763 Formals => 2764 Parameter_Specifications (Specification (Decl))); 2765 end if; 2766 2767 if Present (Wrap_Spec) then 2768 Wrap_Decl := 2769 Make_Subprogram_Declaration (Loc, 2770 Specification => Wrap_Spec); 2771 2772 Insert_After (N, Wrap_Decl); 2773 N := Wrap_Decl; 2774 2775 Analyze (Wrap_Decl); 2776 end if; 2777 2778 Next (Decl); 2779 end loop; 2780 end Scan_Declarations; 2781 2782 -- start of processing for Build_Wrapper_Specs 2783 2784 begin 2785 if Is_Protected_Type (Typ) then 2786 Def := Protected_Definition (Parent (Typ)); 2787 else pragma Assert (Is_Task_Type (Typ)); 2788 Def := Task_Definition (Parent (Typ)); 2789 end if; 2790 2791 Rec_Typ := Corresponding_Record_Type (Typ); 2792 2793 -- Generate wrapper specs for a concurrent type which implements an 2794 -- interface. Operations in both the visible and private parts may 2795 -- implement progenitor operations. 2796 2797 if Present (Interfaces (Rec_Typ)) 2798 and then Present (Def) 2799 then 2800 Scan_Declarations (Visible_Declarations (Def)); 2801 Scan_Declarations (Private_Declarations (Def)); 2802 end if; 2803 end Build_Wrapper_Specs; 2804 2805 --------------------------- 2806 -- Build_Find_Body_Index -- 2807 --------------------------- 2808 2809 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is 2810 Loc : constant Source_Ptr := Sloc (Typ); 2811 Ent : Entity_Id; 2812 E_Typ : Entity_Id; 2813 Has_F : Boolean := False; 2814 Index : Nat; 2815 If_St : Node_Id := Empty; 2816 Lo : Node_Id; 2817 Hi : Node_Id; 2818 Decls : List_Id := New_List; 2819 Ret : Node_Id; 2820 Spec : Node_Id; 2821 Siz : Node_Id := Empty; 2822 2823 procedure Add_If_Clause (Expr : Node_Id); 2824 -- Add test for range of current entry 2825 2826 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 2827 -- If a bound of an entry is given by a discriminant, retrieve the 2828 -- actual value of the discriminant from the enclosing object. 2829 2830 ------------------- 2831 -- Add_If_Clause -- 2832 ------------------- 2833 2834 procedure Add_If_Clause (Expr : Node_Id) is 2835 Cond : Node_Id; 2836 Stats : constant List_Id := 2837 New_List ( 2838 Make_Simple_Return_Statement (Loc, 2839 Expression => Make_Integer_Literal (Loc, Index + 1))); 2840 2841 begin 2842 -- Index for current entry body 2843 2844 Index := Index + 1; 2845 2846 -- Compute total length of entry queues so far 2847 2848 if No (Siz) then 2849 Siz := Expr; 2850 else 2851 Siz := 2852 Make_Op_Add (Loc, 2853 Left_Opnd => Siz, 2854 Right_Opnd => Expr); 2855 end if; 2856 2857 Cond := 2858 Make_Op_Le (Loc, 2859 Left_Opnd => Make_Identifier (Loc, Name_uE), 2860 Right_Opnd => Siz); 2861 2862 -- Map entry queue indexes in the range of the current family 2863 -- into the current index, that designates the entry body. 2864 2865 if No (If_St) then 2866 If_St := 2867 Make_Implicit_If_Statement (Typ, 2868 Condition => Cond, 2869 Then_Statements => Stats, 2870 Elsif_Parts => New_List); 2871 Ret := If_St; 2872 2873 else 2874 Append_To (Elsif_Parts (If_St), 2875 Make_Elsif_Part (Loc, 2876 Condition => Cond, 2877 Then_Statements => Stats)); 2878 end if; 2879 end Add_If_Clause; 2880 2881 ------------------------------ 2882 -- Convert_Discriminant_Ref -- 2883 ------------------------------ 2884 2885 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 2886 B : Node_Id; 2887 2888 begin 2889 if Is_Entity_Name (Bound) 2890 and then Ekind (Entity (Bound)) = E_Discriminant 2891 then 2892 B := 2893 Make_Selected_Component (Loc, 2894 Prefix => 2895 Unchecked_Convert_To (Corresponding_Record_Type (Typ), 2896 Make_Explicit_Dereference (Loc, 2897 Make_Identifier (Loc, Name_uObject))), 2898 Selector_Name => Make_Identifier (Loc, Chars (Bound))); 2899 Set_Etype (B, Etype (Entity (Bound))); 2900 else 2901 B := New_Copy_Tree (Bound); 2902 end if; 2903 2904 return B; 2905 end Convert_Discriminant_Ref; 2906 2907 -- Start of processing for Build_Find_Body_Index 2908 2909 begin 2910 Spec := Build_Find_Body_Index_Spec (Typ); 2911 2912 Ent := First_Entity (Typ); 2913 while Present (Ent) loop 2914 if Ekind (Ent) = E_Entry_Family then 2915 Has_F := True; 2916 exit; 2917 end if; 2918 2919 Next_Entity (Ent); 2920 end loop; 2921 2922 if not Has_F then 2923 2924 -- If the protected type has no entry families, there is a one-one 2925 -- correspondence between entry queue and entry body. 2926 2927 Ret := 2928 Make_Simple_Return_Statement (Loc, 2929 Expression => Make_Identifier (Loc, Name_uE)); 2930 2931 else 2932 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate 2933 -- the following: 2934 2935 -- if E <= l1 then return 1; 2936 -- elsif E <= l1 + l2 then return 2; 2937 -- ... 2938 2939 Index := 0; 2940 Siz := Empty; 2941 Ent := First_Entity (Typ); 2942 2943 Add_Object_Pointer (Loc, Typ, Decls); 2944 2945 while Present (Ent) loop 2946 if Ekind (Ent) = E_Entry then 2947 Add_If_Clause (Make_Integer_Literal (Loc, 1)); 2948 2949 elsif Ekind (Ent) = E_Entry_Family then 2950 E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); 2951 Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); 2952 Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); 2953 Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False)); 2954 end if; 2955 2956 Next_Entity (Ent); 2957 end loop; 2958 2959 if Index = 1 then 2960 Decls := New_List; 2961 Ret := 2962 Make_Simple_Return_Statement (Loc, 2963 Expression => Make_Integer_Literal (Loc, 1)); 2964 2965 elsif Nkind (Ret) = N_If_Statement then 2966 2967 -- Ranges are in increasing order, so last one doesn't need guard 2968 2969 declare 2970 Nod : constant Node_Id := Last (Elsif_Parts (Ret)); 2971 begin 2972 Remove (Nod); 2973 Set_Else_Statements (Ret, Then_Statements (Nod)); 2974 end; 2975 end if; 2976 end if; 2977 2978 return 2979 Make_Subprogram_Body (Loc, 2980 Specification => Spec, 2981 Declarations => Decls, 2982 Handled_Statement_Sequence => 2983 Make_Handled_Sequence_Of_Statements (Loc, 2984 Statements => New_List (Ret))); 2985 end Build_Find_Body_Index; 2986 2987 -------------------------------- 2988 -- Build_Find_Body_Index_Spec -- 2989 -------------------------------- 2990 2991 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is 2992 Loc : constant Source_Ptr := Sloc (Typ); 2993 Id : constant Entity_Id := 2994 Make_Defining_Identifier (Loc, 2995 Chars => New_External_Name (Chars (Typ), 'F')); 2996 Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO); 2997 Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE); 2998 2999 begin 3000 return 3001 Make_Function_Specification (Loc, 3002 Defining_Unit_Name => Id, 3003 Parameter_Specifications => New_List ( 3004 Make_Parameter_Specification (Loc, 3005 Defining_Identifier => Parm1, 3006 Parameter_Type => 3007 New_Occurrence_Of (RTE (RE_Address), Loc)), 3008 3009 Make_Parameter_Specification (Loc, 3010 Defining_Identifier => Parm2, 3011 Parameter_Type => 3012 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), 3013 3014 Result_Definition => New_Occurrence_Of ( 3015 RTE (RE_Protected_Entry_Index), Loc)); 3016 end Build_Find_Body_Index_Spec; 3017 3018 ----------------------------------------------- 3019 -- Build_Lock_Free_Protected_Subprogram_Body -- 3020 ----------------------------------------------- 3021 3022 function Build_Lock_Free_Protected_Subprogram_Body 3023 (N : Node_Id; 3024 Prot_Typ : Node_Id; 3025 Unprot_Spec : Node_Id) return Node_Id 3026 is 3027 Actuals : constant List_Id := New_List; 3028 Loc : constant Source_Ptr := Sloc (N); 3029 Spec : constant Node_Id := Specification (N); 3030 Unprot_Id : constant Entity_Id := Defining_Unit_Name (Unprot_Spec); 3031 Formal : Node_Id; 3032 Prot_Spec : Node_Id; 3033 Stmt : Node_Id; 3034 3035 begin 3036 -- Create the protected version of the body 3037 3038 Prot_Spec := 3039 Build_Protected_Sub_Specification (N, Prot_Typ, Protected_Mode); 3040 3041 -- Build the actual parameters which appear in the call to the 3042 -- unprotected version of the body. 3043 3044 Formal := First (Parameter_Specifications (Prot_Spec)); 3045 while Present (Formal) loop 3046 Append_To (Actuals, 3047 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 3048 3049 Next (Formal); 3050 end loop; 3051 3052 -- Function case, generate: 3053 -- return <Unprot_Func_Call>; 3054 3055 if Nkind (Spec) = N_Function_Specification then 3056 Stmt := 3057 Make_Simple_Return_Statement (Loc, 3058 Expression => 3059 Make_Function_Call (Loc, 3060 Name => 3061 Make_Identifier (Loc, Chars (Unprot_Id)), 3062 Parameter_Associations => Actuals)); 3063 3064 -- Procedure case, call the unprotected version 3065 3066 else 3067 Stmt := 3068 Make_Procedure_Call_Statement (Loc, 3069 Name => 3070 Make_Identifier (Loc, Chars (Unprot_Id)), 3071 Parameter_Associations => Actuals); 3072 end if; 3073 3074 return 3075 Make_Subprogram_Body (Loc, 3076 Declarations => Empty_List, 3077 Specification => Prot_Spec, 3078 Handled_Statement_Sequence => 3079 Make_Handled_Sequence_Of_Statements (Loc, 3080 Statements => New_List (Stmt))); 3081 end Build_Lock_Free_Protected_Subprogram_Body; 3082 3083 ------------------------------------------------- 3084 -- Build_Lock_Free_Unprotected_Subprogram_Body -- 3085 ------------------------------------------------- 3086 3087 -- Procedures which meet the lock-free implementation requirements and 3088 -- reference a unique scalar component Comp are expanded in the following 3089 -- manner: 3090 3091 -- procedure P (...) is 3092 -- Expected_Comp : constant Comp_Type := 3093 -- Comp_Type 3094 -- (System.Atomic_Primitives.Lock_Free_Read_N 3095 -- (_Object.Comp'Address)); 3096 -- begin 3097 -- loop 3098 -- declare 3099 -- <original declarations before the object renaming declaration 3100 -- of Comp> 3101 -- 3102 -- Desired_Comp : Comp_Type := Expected_Comp; 3103 -- Comp : Comp_Type renames Desired_Comp; 3104 -- 3105 -- <original delarations after the object renaming declaration 3106 -- of Comp> 3107 -- 3108 -- begin 3109 -- <original statements> 3110 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N 3111 -- (_Object.Comp'Address, 3112 -- Interfaces.Unsigned_N (Expected_Comp), 3113 -- Interfaces.Unsigned_N (Desired_Comp)); 3114 -- end; 3115 -- end loop; 3116 -- end P; 3117 3118 -- Each return and raise statement of P is transformed into an atomic 3119 -- status check: 3120 3121 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 3122 -- (_Object.Comp'Address, 3123 -- Interfaces.Unsigned_N (Expected_Comp), 3124 -- Interfaces.Unsigned_N (Desired_Comp)); 3125 -- then 3126 -- <original statement> 3127 -- else 3128 -- goto L0; 3129 -- end if; 3130 3131 -- Functions which meet the lock-free implementation requirements and 3132 -- reference a unique scalar component Comp are expanded in the following 3133 -- manner: 3134 3135 -- function F (...) return ... is 3136 -- <original declarations before the object renaming declaration 3137 -- of Comp> 3138 -- 3139 -- Expected_Comp : constant Comp_Type := 3140 -- Comp_Type 3141 -- (System.Atomic_Primitives.Lock_Free_Read_N 3142 -- (_Object.Comp'Address)); 3143 -- Comp : Comp_Type renames Expected_Comp; 3144 -- 3145 -- <original delarations after the object renaming declaration of 3146 -- Comp> 3147 -- 3148 -- begin 3149 -- <original statements> 3150 -- end F; 3151 3152 function Build_Lock_Free_Unprotected_Subprogram_Body 3153 (N : Node_Id; 3154 Prot_Typ : Node_Id) return Node_Id 3155 is 3156 function Referenced_Component (N : Node_Id) return Entity_Id; 3157 -- Subprograms which meet the lock-free implementation criteria are 3158 -- allowed to reference only one unique component. Return the prival 3159 -- of the said component. 3160 3161 -------------------------- 3162 -- Referenced_Component -- 3163 -------------------------- 3164 3165 function Referenced_Component (N : Node_Id) return Entity_Id is 3166 Comp : Entity_Id; 3167 Decl : Node_Id; 3168 Source_Comp : Entity_Id := Empty; 3169 3170 begin 3171 -- Find the unique source component which N references in its 3172 -- statements. 3173 3174 for Index in 1 .. Lock_Free_Subprogram_Table.Last loop 3175 declare 3176 Element : Lock_Free_Subprogram renames 3177 Lock_Free_Subprogram_Table.Table (Index); 3178 begin 3179 if Element.Sub_Body = N then 3180 Source_Comp := Element.Comp_Id; 3181 exit; 3182 end if; 3183 end; 3184 end loop; 3185 3186 if No (Source_Comp) then 3187 return Empty; 3188 end if; 3189 3190 -- Find the prival which corresponds to the source component within 3191 -- the declarations of N. 3192 3193 Decl := First (Declarations (N)); 3194 while Present (Decl) loop 3195 3196 -- Privals appear as object renamings 3197 3198 if Nkind (Decl) = N_Object_Renaming_Declaration then 3199 Comp := Defining_Identifier (Decl); 3200 3201 if Present (Prival_Link (Comp)) 3202 and then Prival_Link (Comp) = Source_Comp 3203 then 3204 return Comp; 3205 end if; 3206 end if; 3207 3208 Next (Decl); 3209 end loop; 3210 3211 return Empty; 3212 end Referenced_Component; 3213 3214 -- Local variables 3215 3216 Comp : constant Entity_Id := Referenced_Component (N); 3217 Loc : constant Source_Ptr := Sloc (N); 3218 Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N); 3219 Decls : List_Id := Declarations (N); 3220 3221 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body 3222 3223 begin 3224 -- Add renamings for the protection object, discriminals, privals and 3225 -- the entry index constant for use by debugger. 3226 3227 Debug_Private_Data_Declarations (Decls); 3228 3229 -- Perform the lock-free expansion when the subprogram references a 3230 -- protected component. 3231 3232 if Present (Comp) then 3233 Protected_Component_Ref : declare 3234 Comp_Decl : constant Node_Id := Parent (Comp); 3235 Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl); 3236 Comp_Type : constant Entity_Id := Etype (Comp); 3237 3238 Is_Procedure : constant Boolean := 3239 Ekind (Corresponding_Spec (N)) = E_Procedure; 3240 -- Indicates if N is a protected procedure body 3241 3242 Block_Decls : List_Id; 3243 Try_Write : Entity_Id; 3244 Desired_Comp : Entity_Id; 3245 Decl : Node_Id; 3246 Label : Node_Id; 3247 Label_Id : Entity_Id := Empty; 3248 Read : Entity_Id; 3249 Expected_Comp : Entity_Id; 3250 Stmt : Node_Id; 3251 Stmts : List_Id := 3252 New_Copy_List (Statements (Hand_Stmt_Seq)); 3253 Typ_Size : Int; 3254 Unsigned : Entity_Id; 3255 3256 function Process_Node (N : Node_Id) return Traverse_Result; 3257 -- Transform a single node if it is a return statement, a raise 3258 -- statement or a reference to Comp. 3259 3260 procedure Process_Stmts (Stmts : List_Id); 3261 -- Given a statement sequence Stmts, wrap any return or raise 3262 -- statements in the following manner: 3263 -- 3264 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 3265 -- (_Object.Comp'Address, 3266 -- Interfaces.Unsigned_N (Expected_Comp), 3267 -- Interfaces.Unsigned_N (Desired_Comp)) 3268 -- then 3269 -- <Stmt>; 3270 -- else 3271 -- goto L0; 3272 -- end if; 3273 3274 ------------------ 3275 -- Process_Node -- 3276 ------------------ 3277 3278 function Process_Node (N : Node_Id) return Traverse_Result is 3279 3280 procedure Wrap_Statement (Stmt : Node_Id); 3281 -- Wrap an arbitrary statement inside an if statement where the 3282 -- condition does an atomic check on the state of the object. 3283 3284 -------------------- 3285 -- Wrap_Statement -- 3286 -------------------- 3287 3288 procedure Wrap_Statement (Stmt : Node_Id) is 3289 begin 3290 -- The first time through, create the declaration of a label 3291 -- which is used to skip the remainder of source statements 3292 -- if the state of the object has changed. 3293 3294 if No (Label_Id) then 3295 Label_Id := 3296 Make_Identifier (Loc, New_External_Name ('L', 0)); 3297 Set_Entity (Label_Id, 3298 Make_Defining_Identifier (Loc, Chars (Label_Id))); 3299 end if; 3300 3301 -- Generate: 3302 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 3303 -- (_Object.Comp'Address, 3304 -- Interfaces.Unsigned_N (Expected_Comp), 3305 -- Interfaces.Unsigned_N (Desired_Comp)) 3306 -- then 3307 -- <Stmt>; 3308 -- else 3309 -- goto L0; 3310 -- end if; 3311 3312 Rewrite (Stmt, 3313 Make_Implicit_If_Statement (N, 3314 Condition => 3315 Make_Function_Call (Loc, 3316 Name => 3317 New_Occurrence_Of (Try_Write, Loc), 3318 Parameter_Associations => New_List ( 3319 Make_Attribute_Reference (Loc, 3320 Prefix => Relocate_Node (Comp_Sel_Nam), 3321 Attribute_Name => Name_Address), 3322 3323 Unchecked_Convert_To (Unsigned, 3324 New_Occurrence_Of (Expected_Comp, Loc)), 3325 3326 Unchecked_Convert_To (Unsigned, 3327 New_Occurrence_Of (Desired_Comp, Loc)))), 3328 3329 Then_Statements => New_List (Relocate_Node (Stmt)), 3330 3331 Else_Statements => New_List ( 3332 Make_Goto_Statement (Loc, 3333 Name => 3334 New_Occurrence_Of (Entity (Label_Id), Loc))))); 3335 end Wrap_Statement; 3336 3337 -- Start of processing for Process_Node 3338 3339 begin 3340 -- Wrap each return and raise statement that appear inside a 3341 -- procedure. Skip the last return statement which is added by 3342 -- default since it is transformed into an exit statement. 3343 3344 if Is_Procedure 3345 and then ((Nkind (N) = N_Simple_Return_Statement 3346 and then N /= Last (Stmts)) 3347 or else Nkind (N) = N_Extended_Return_Statement 3348 or else (Nkind_In (N, N_Raise_Constraint_Error, 3349 N_Raise_Program_Error, 3350 N_Raise_Statement, 3351 N_Raise_Storage_Error) 3352 and then Comes_From_Source (N))) 3353 then 3354 Wrap_Statement (N); 3355 return Skip; 3356 end if; 3357 3358 -- Force reanalysis 3359 3360 Set_Analyzed (N, False); 3361 3362 return OK; 3363 end Process_Node; 3364 3365 procedure Process_Nodes is new Traverse_Proc (Process_Node); 3366 3367 ------------------- 3368 -- Process_Stmts -- 3369 ------------------- 3370 3371 procedure Process_Stmts (Stmts : List_Id) is 3372 Stmt : Node_Id; 3373 begin 3374 Stmt := First (Stmts); 3375 while Present (Stmt) loop 3376 Process_Nodes (Stmt); 3377 Next (Stmt); 3378 end loop; 3379 end Process_Stmts; 3380 3381 -- Start of processing for Protected_Component_Ref 3382 3383 begin 3384 -- Get the type size 3385 3386 if Known_Static_Esize (Comp_Type) then 3387 Typ_Size := UI_To_Int (Esize (Comp_Type)); 3388 3389 -- If the Esize (Object_Size) is unknown at compile time, look at 3390 -- the RM_Size (Value_Size) since it may have been set by an 3391 -- explicit representation clause. 3392 3393 elsif Known_Static_RM_Size (Comp_Type) then 3394 Typ_Size := UI_To_Int (RM_Size (Comp_Type)); 3395 3396 -- Should not happen since this has already been checked in 3397 -- Allows_Lock_Free_Implementation (see Sem_Ch9). 3398 3399 else 3400 raise Program_Error; 3401 end if; 3402 3403 -- Retrieve all relevant atomic routines and types 3404 3405 case Typ_Size is 3406 when 8 => 3407 Try_Write := RTE (RE_Lock_Free_Try_Write_8); 3408 Read := RTE (RE_Lock_Free_Read_8); 3409 Unsigned := RTE (RE_Uint8); 3410 3411 when 16 => 3412 Try_Write := RTE (RE_Lock_Free_Try_Write_16); 3413 Read := RTE (RE_Lock_Free_Read_16); 3414 Unsigned := RTE (RE_Uint16); 3415 3416 when 32 => 3417 Try_Write := RTE (RE_Lock_Free_Try_Write_32); 3418 Read := RTE (RE_Lock_Free_Read_32); 3419 Unsigned := RTE (RE_Uint32); 3420 3421 when 64 => 3422 Try_Write := RTE (RE_Lock_Free_Try_Write_64); 3423 Read := RTE (RE_Lock_Free_Read_64); 3424 Unsigned := RTE (RE_Uint64); 3425 3426 when others => 3427 raise Program_Error; 3428 end case; 3429 3430 -- Generate: 3431 -- Expected_Comp : constant Comp_Type := 3432 -- Comp_Type 3433 -- (System.Atomic_Primitives.Lock_Free_Read_N 3434 -- (_Object.Comp'Address)); 3435 3436 Expected_Comp := 3437 Make_Defining_Identifier (Loc, 3438 New_External_Name (Chars (Comp), Suffix => "_saved")); 3439 3440 Decl := 3441 Make_Object_Declaration (Loc, 3442 Defining_Identifier => Expected_Comp, 3443 Object_Definition => New_Occurrence_Of (Comp_Type, Loc), 3444 Constant_Present => True, 3445 Expression => 3446 Unchecked_Convert_To (Comp_Type, 3447 Make_Function_Call (Loc, 3448 Name => New_Occurrence_Of (Read, Loc), 3449 Parameter_Associations => New_List ( 3450 Make_Attribute_Reference (Loc, 3451 Prefix => Relocate_Node (Comp_Sel_Nam), 3452 Attribute_Name => Name_Address))))); 3453 3454 -- Protected procedures 3455 3456 if Is_Procedure then 3457 -- Move the original declarations inside the generated block 3458 3459 Block_Decls := Decls; 3460 3461 -- Reset the declarations list of the protected procedure to 3462 -- contain only Decl. 3463 3464 Decls := New_List (Decl); 3465 3466 -- Generate: 3467 -- Desired_Comp : Comp_Type := Expected_Comp; 3468 3469 Desired_Comp := 3470 Make_Defining_Identifier (Loc, 3471 New_External_Name (Chars (Comp), Suffix => "_current")); 3472 3473 -- Insert the declarations of Expected_Comp and Desired_Comp in 3474 -- the block declarations right before the renaming of the 3475 -- protected component. 3476 3477 Insert_Before (Comp_Decl, 3478 Make_Object_Declaration (Loc, 3479 Defining_Identifier => Desired_Comp, 3480 Object_Definition => New_Occurrence_Of (Comp_Type, Loc), 3481 Expression => 3482 New_Occurrence_Of (Expected_Comp, Loc))); 3483 3484 -- Protected function 3485 3486 else 3487 Desired_Comp := Expected_Comp; 3488 3489 -- Insert the declaration of Expected_Comp in the function 3490 -- declarations right before the renaming of the protected 3491 -- component. 3492 3493 Insert_Before (Comp_Decl, Decl); 3494 end if; 3495 3496 -- Rewrite the protected component renaming declaration to be a 3497 -- renaming of Desired_Comp. 3498 3499 -- Generate: 3500 -- Comp : Comp_Type renames Desired_Comp; 3501 3502 Rewrite (Comp_Decl, 3503 Make_Object_Renaming_Declaration (Loc, 3504 Defining_Identifier => 3505 Defining_Identifier (Comp_Decl), 3506 Subtype_Mark => 3507 New_Occurrence_Of (Comp_Type, Loc), 3508 Name => 3509 New_Occurrence_Of (Desired_Comp, Loc))); 3510 3511 -- Wrap any return or raise statements in Stmts in same the manner 3512 -- described in Process_Stmts. 3513 3514 Process_Stmts (Stmts); 3515 3516 -- Generate: 3517 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N 3518 -- (_Object.Comp'Address, 3519 -- Interfaces.Unsigned_N (Expected_Comp), 3520 -- Interfaces.Unsigned_N (Desired_Comp)) 3521 3522 if Is_Procedure then 3523 Stmt := 3524 Make_Exit_Statement (Loc, 3525 Condition => 3526 Make_Function_Call (Loc, 3527 Name => 3528 New_Occurrence_Of (Try_Write, Loc), 3529 Parameter_Associations => New_List ( 3530 Make_Attribute_Reference (Loc, 3531 Prefix => Relocate_Node (Comp_Sel_Nam), 3532 Attribute_Name => Name_Address), 3533 3534 Unchecked_Convert_To (Unsigned, 3535 New_Occurrence_Of (Expected_Comp, Loc)), 3536 3537 Unchecked_Convert_To (Unsigned, 3538 New_Occurrence_Of (Desired_Comp, Loc))))); 3539 3540 -- Small optimization: transform the default return statement 3541 -- of a procedure into the atomic exit statement. 3542 3543 if Nkind (Last (Stmts)) = N_Simple_Return_Statement then 3544 Rewrite (Last (Stmts), Stmt); 3545 else 3546 Append_To (Stmts, Stmt); 3547 end if; 3548 end if; 3549 3550 -- Create the declaration of the label used to skip the rest of 3551 -- the source statements when the object state changes. 3552 3553 if Present (Label_Id) then 3554 Label := Make_Label (Loc, Label_Id); 3555 Append_To (Decls, 3556 Make_Implicit_Label_Declaration (Loc, 3557 Defining_Identifier => Entity (Label_Id), 3558 Label_Construct => Label)); 3559 Append_To (Stmts, Label); 3560 end if; 3561 3562 -- Generate: 3563 -- loop 3564 -- declare 3565 -- <Decls> 3566 -- begin 3567 -- <Stmts> 3568 -- end; 3569 -- end loop; 3570 3571 if Is_Procedure then 3572 Stmts := 3573 New_List ( 3574 Make_Loop_Statement (Loc, 3575 Statements => New_List ( 3576 Make_Block_Statement (Loc, 3577 Declarations => Block_Decls, 3578 Handled_Statement_Sequence => 3579 Make_Handled_Sequence_Of_Statements (Loc, 3580 Statements => Stmts))), 3581 End_Label => Empty)); 3582 end if; 3583 3584 Hand_Stmt_Seq := 3585 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts); 3586 end Protected_Component_Ref; 3587 end if; 3588 3589 -- Make an unprotected version of the subprogram for use within the same 3590 -- object, with new name and extra parameter representing the object. 3591 3592 return 3593 Make_Subprogram_Body (Loc, 3594 Specification => 3595 Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode), 3596 Declarations => Decls, 3597 Handled_Statement_Sequence => Hand_Stmt_Seq); 3598 end Build_Lock_Free_Unprotected_Subprogram_Body; 3599 3600 ------------------------- 3601 -- Build_Master_Entity -- 3602 ------------------------- 3603 3604 procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id) is 3605 Loc : constant Source_Ptr := Sloc (Obj_Or_Typ); 3606 Context : Node_Id; 3607 Context_Id : Entity_Id; 3608 Decl : Node_Id; 3609 Decls : List_Id; 3610 Par : Node_Id; 3611 3612 begin 3613 if Is_Itype (Obj_Or_Typ) then 3614 Par := Associated_Node_For_Itype (Obj_Or_Typ); 3615 else 3616 Par := Parent (Obj_Or_Typ); 3617 end if; 3618 3619 -- When creating a master for a record component which is either a task 3620 -- or access-to-task, the enclosing record is the master scope and the 3621 -- proper insertion point is the component list. 3622 3623 if Is_Record_Type (Current_Scope) then 3624 Context := Par; 3625 Context_Id := Current_Scope; 3626 Decls := List_Containing (Context); 3627 3628 -- Default case for object declarations and access types. Note that the 3629 -- context is updated to the nearest enclosing body, block, package or 3630 -- return statement. 3631 3632 else 3633 Find_Enclosing_Context (Par, Context, Context_Id, Decls); 3634 end if; 3635 3636 -- Do not create a master if one already exists or there is no task 3637 -- hierarchy. 3638 3639 if Has_Master_Entity (Context_Id) 3640 or else Restriction_Active (No_Task_Hierarchy) 3641 then 3642 return; 3643 end if; 3644 3645 -- Create a master, generate: 3646 -- _Master : constant Master_Id := Current_Master.all; 3647 3648 Decl := 3649 Make_Object_Declaration (Loc, 3650 Defining_Identifier => 3651 Make_Defining_Identifier (Loc, Name_uMaster), 3652 Constant_Present => True, 3653 Object_Definition => New_Occurrence_Of (RTE (RE_Master_Id), Loc), 3654 Expression => 3655 Make_Explicit_Dereference (Loc, 3656 New_Occurrence_Of (RTE (RE_Current_Master), Loc))); 3657 3658 -- The master is inserted at the start of the declarative list of the 3659 -- context. 3660 3661 Prepend_To (Decls, Decl); 3662 3663 -- In certain cases where transient scopes are involved, the immediate 3664 -- scope is not always the proper master scope. Ensure that the master 3665 -- declaration and entity appear in the same context. 3666 3667 if Context_Id /= Current_Scope then 3668 Push_Scope (Context_Id); 3669 Analyze (Decl); 3670 Pop_Scope; 3671 else 3672 Analyze (Decl); 3673 end if; 3674 3675 -- Mark the enclosing scope and its associated construct as being task 3676 -- masters. 3677 3678 Set_Has_Master_Entity (Context_Id); 3679 3680 while Present (Context) 3681 and then Nkind (Context) /= N_Compilation_Unit 3682 loop 3683 if Nkind_In (Context, N_Block_Statement, 3684 N_Subprogram_Body, 3685 N_Task_Body) 3686 then 3687 Set_Is_Task_Master (Context); 3688 exit; 3689 3690 elsif Nkind (Parent (Context)) = N_Subunit then 3691 Context := Corresponding_Stub (Parent (Context)); 3692 end if; 3693 3694 Context := Parent (Context); 3695 end loop; 3696 end Build_Master_Entity; 3697 3698 --------------------------- 3699 -- Build_Master_Renaming -- 3700 --------------------------- 3701 3702 procedure Build_Master_Renaming 3703 (Ptr_Typ : Entity_Id; 3704 Ins_Nod : Node_Id := Empty) 3705 is 3706 Loc : constant Source_Ptr := Sloc (Ptr_Typ); 3707 Context : Node_Id; 3708 Master_Decl : Node_Id; 3709 Master_Id : Entity_Id; 3710 3711 begin 3712 -- Nothing to do if there is no task hierarchy 3713 3714 if Restriction_Active (No_Task_Hierarchy) then 3715 return; 3716 end if; 3717 3718 -- Determine the proper context to insert the master renaming 3719 3720 if Present (Ins_Nod) then 3721 Context := Ins_Nod; 3722 elsif Is_Itype (Ptr_Typ) then 3723 Context := Associated_Node_For_Itype (Ptr_Typ); 3724 else 3725 Context := Parent (Ptr_Typ); 3726 end if; 3727 3728 -- Generate: 3729 -- <Ptr_Typ>M : Master_Id renames _Master; 3730 3731 Master_Id := 3732 Make_Defining_Identifier (Loc, 3733 New_External_Name (Chars (Ptr_Typ), 'M')); 3734 3735 Master_Decl := 3736 Make_Object_Renaming_Declaration (Loc, 3737 Defining_Identifier => Master_Id, 3738 Subtype_Mark => New_Occurrence_Of (RTE (RE_Master_Id), Loc), 3739 Name => Make_Identifier (Loc, Name_uMaster)); 3740 3741 Insert_Action (Context, Master_Decl); 3742 3743 -- The renamed master now services the access type 3744 3745 Set_Master_Id (Ptr_Typ, Master_Id); 3746 end Build_Master_Renaming; 3747 3748 ----------------------------------------- 3749 -- Build_Private_Protected_Declaration -- 3750 ----------------------------------------- 3751 3752 function Build_Private_Protected_Declaration 3753 (N : Node_Id) return Entity_Id 3754 is 3755 Loc : constant Source_Ptr := Sloc (N); 3756 Body_Id : constant Entity_Id := Defining_Entity (N); 3757 Decl : Node_Id; 3758 Plist : List_Id; 3759 Formal : Entity_Id; 3760 New_Spec : Node_Id; 3761 Spec_Id : Entity_Id; 3762 3763 begin 3764 Formal := First_Formal (Body_Id); 3765 3766 -- The protected operation always has at least one formal, namely the 3767 -- object itself, but it is only placed in the parameter list if 3768 -- expansion is enabled. 3769 3770 if Present (Formal) or else Expander_Active then 3771 Plist := Copy_Parameter_List (Body_Id); 3772 else 3773 Plist := No_List; 3774 end if; 3775 3776 if Nkind (Specification (N)) = N_Procedure_Specification then 3777 New_Spec := 3778 Make_Procedure_Specification (Loc, 3779 Defining_Unit_Name => 3780 Make_Defining_Identifier (Sloc (Body_Id), 3781 Chars => Chars (Body_Id)), 3782 Parameter_Specifications => 3783 Plist); 3784 else 3785 New_Spec := 3786 Make_Function_Specification (Loc, 3787 Defining_Unit_Name => 3788 Make_Defining_Identifier (Sloc (Body_Id), 3789 Chars => Chars (Body_Id)), 3790 Parameter_Specifications => Plist, 3791 Result_Definition => 3792 New_Occurrence_Of (Etype (Body_Id), Loc)); 3793 end if; 3794 3795 Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec); 3796 Insert_Before (N, Decl); 3797 Spec_Id := Defining_Unit_Name (New_Spec); 3798 3799 -- Indicate that the entity comes from source, to ensure that cross- 3800 -- reference information is properly generated. The body itself is 3801 -- rewritten during expansion, and the body entity will not appear in 3802 -- calls to the operation. 3803 3804 Set_Comes_From_Source (Spec_Id, True); 3805 Analyze (Decl); 3806 Set_Has_Completion (Spec_Id); 3807 Set_Convention (Spec_Id, Convention_Protected); 3808 return Spec_Id; 3809 end Build_Private_Protected_Declaration; 3810 3811 --------------------------- 3812 -- Build_Protected_Entry -- 3813 --------------------------- 3814 3815 function Build_Protected_Entry 3816 (N : Node_Id; 3817 Ent : Entity_Id; 3818 Pid : Node_Id) return Node_Id 3819 is 3820 Loc : constant Source_Ptr := Sloc (N); 3821 3822 Decls : constant List_Id := Declarations (N); 3823 End_Lab : constant Node_Id := 3824 End_Label (Handled_Statement_Sequence (N)); 3825 End_Loc : constant Source_Ptr := 3826 Sloc (Last (Statements (Handled_Statement_Sequence (N)))); 3827 -- Used for the generated call to Complete_Entry_Body 3828 3829 Han_Loc : Source_Ptr; 3830 -- Used for the exception handler, inserted at end of the body 3831 3832 Op_Decls : constant List_Id := New_List; 3833 Complete : Node_Id; 3834 Edef : Entity_Id; 3835 Espec : Node_Id; 3836 Ohandle : Node_Id; 3837 Op_Stats : List_Id; 3838 3839 begin 3840 -- Set the source location on the exception handler only when debugging 3841 -- the expanded code (see Make_Implicit_Exception_Handler). 3842 3843 if Debug_Generated_Code then 3844 Han_Loc := End_Loc; 3845 3846 -- Otherwise the inserted code should not be visible to the debugger 3847 3848 else 3849 Han_Loc := No_Location; 3850 end if; 3851 3852 Edef := 3853 Make_Defining_Identifier (Loc, 3854 Chars => Chars (Protected_Body_Subprogram (Ent))); 3855 Espec := 3856 Build_Protected_Entry_Specification (Loc, Edef, Empty); 3857 3858 -- Add the following declarations: 3859 3860 -- type poVP is access poV; 3861 -- _object : poVP := poVP (_O); 3862 3863 -- where _O is the formal parameter associated with the concurrent 3864 -- object. These declarations are needed for Complete_Entry_Body. 3865 3866 Add_Object_Pointer (Loc, Pid, Op_Decls); 3867 3868 -- Add renamings for all formals, the Protection object, discriminals, 3869 -- privals and the entry index constant for use by debugger. 3870 3871 Add_Formal_Renamings (Espec, Op_Decls, Ent, Loc); 3872 Debug_Private_Data_Declarations (Decls); 3873 3874 -- Put the declarations and the statements from the entry 3875 3876 Op_Stats := 3877 New_List ( 3878 Make_Block_Statement (Loc, 3879 Declarations => Decls, 3880 Handled_Statement_Sequence => 3881 Handled_Statement_Sequence (N))); 3882 3883 case Corresponding_Runtime_Package (Pid) is 3884 when System_Tasking_Protected_Objects_Entries => 3885 Append_To (Op_Stats, 3886 Make_Procedure_Call_Statement (End_Loc, 3887 Name => 3888 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc), 3889 Parameter_Associations => New_List ( 3890 Make_Attribute_Reference (End_Loc, 3891 Prefix => 3892 Make_Selected_Component (End_Loc, 3893 Prefix => 3894 Make_Identifier (End_Loc, Name_uObject), 3895 Selector_Name => 3896 Make_Identifier (End_Loc, Name_uObject)), 3897 Attribute_Name => Name_Unchecked_Access)))); 3898 3899 when System_Tasking_Protected_Objects_Single_Entry => 3900 3901 -- Historically, a call to Complete_Single_Entry_Body was 3902 -- inserted, but it was a null procedure. 3903 3904 null; 3905 3906 when others => 3907 raise Program_Error; 3908 end case; 3909 3910 -- When exceptions can not be propagated, we never need to call 3911 -- Exception_Complete_Entry_Body 3912 3913 if No_Exception_Handlers_Set then 3914 return 3915 Make_Subprogram_Body (Loc, 3916 Specification => Espec, 3917 Declarations => Op_Decls, 3918 Handled_Statement_Sequence => 3919 Make_Handled_Sequence_Of_Statements (Loc, 3920 Statements => Op_Stats, 3921 End_Label => End_Lab)); 3922 3923 else 3924 Ohandle := Make_Others_Choice (Loc); 3925 Set_All_Others (Ohandle); 3926 3927 case Corresponding_Runtime_Package (Pid) is 3928 when System_Tasking_Protected_Objects_Entries => 3929 Complete := 3930 New_Occurrence_Of 3931 (RTE (RE_Exceptional_Complete_Entry_Body), Loc); 3932 3933 when System_Tasking_Protected_Objects_Single_Entry => 3934 Complete := 3935 New_Occurrence_Of 3936 (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); 3937 3938 when others => 3939 raise Program_Error; 3940 end case; 3941 3942 -- Establish link between subprogram body entity and source entry 3943 3944 Set_Corresponding_Protected_Entry (Edef, Ent); 3945 3946 -- Create body of entry procedure. The renaming declarations are 3947 -- placed ahead of the block that contains the actual entry body. 3948 3949 return 3950 Make_Subprogram_Body (Loc, 3951 Specification => Espec, 3952 Declarations => Op_Decls, 3953 Handled_Statement_Sequence => 3954 Make_Handled_Sequence_Of_Statements (Loc, 3955 Statements => Op_Stats, 3956 End_Label => End_Lab, 3957 Exception_Handlers => New_List ( 3958 Make_Implicit_Exception_Handler (Han_Loc, 3959 Exception_Choices => New_List (Ohandle), 3960 3961 Statements => New_List ( 3962 Make_Procedure_Call_Statement (Han_Loc, 3963 Name => Complete, 3964 Parameter_Associations => New_List ( 3965 Make_Attribute_Reference (Han_Loc, 3966 Prefix => 3967 Make_Selected_Component (Han_Loc, 3968 Prefix => 3969 Make_Identifier (Han_Loc, Name_uObject), 3970 Selector_Name => 3971 Make_Identifier (Han_Loc, Name_uObject)), 3972 Attribute_Name => Name_Unchecked_Access), 3973 3974 Make_Function_Call (Han_Loc, 3975 Name => New_Occurrence_Of ( 3976 RTE (RE_Get_GNAT_Exception), Loc))))))))); 3977 end if; 3978 end Build_Protected_Entry; 3979 3980 ----------------------------------------- 3981 -- Build_Protected_Entry_Specification -- 3982 ----------------------------------------- 3983 3984 function Build_Protected_Entry_Specification 3985 (Loc : Source_Ptr; 3986 Def_Id : Entity_Id; 3987 Ent_Id : Entity_Id) return Node_Id 3988 is 3989 P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP); 3990 3991 begin 3992 Set_Debug_Info_Needed (Def_Id); 3993 3994 if Present (Ent_Id) then 3995 Append_Elmt (P, Accept_Address (Ent_Id)); 3996 end if; 3997 3998 return 3999 Make_Procedure_Specification (Loc, 4000 Defining_Unit_Name => Def_Id, 4001 Parameter_Specifications => New_List ( 4002 Make_Parameter_Specification (Loc, 4003 Defining_Identifier => 4004 Make_Defining_Identifier (Loc, Name_uO), 4005 Parameter_Type => 4006 New_Occurrence_Of (RTE (RE_Address), Loc)), 4007 4008 Make_Parameter_Specification (Loc, 4009 Defining_Identifier => P, 4010 Parameter_Type => 4011 New_Occurrence_Of (RTE (RE_Address), Loc)), 4012 4013 Make_Parameter_Specification (Loc, 4014 Defining_Identifier => 4015 Make_Defining_Identifier (Loc, Name_uE), 4016 Parameter_Type => 4017 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)))); 4018 end Build_Protected_Entry_Specification; 4019 4020 -------------------------- 4021 -- Build_Protected_Spec -- 4022 -------------------------- 4023 4024 function Build_Protected_Spec 4025 (N : Node_Id; 4026 Obj_Type : Entity_Id; 4027 Ident : Entity_Id; 4028 Unprotected : Boolean := False) return List_Id 4029 is 4030 Loc : constant Source_Ptr := Sloc (N); 4031 Decl : Node_Id; 4032 Formal : Entity_Id; 4033 New_Plist : List_Id; 4034 New_Param : Node_Id; 4035 4036 begin 4037 New_Plist := New_List; 4038 4039 Formal := First_Formal (Ident); 4040 while Present (Formal) loop 4041 New_Param := 4042 Make_Parameter_Specification (Loc, 4043 Defining_Identifier => 4044 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 4045 In_Present => In_Present (Parent (Formal)), 4046 Out_Present => Out_Present (Parent (Formal)), 4047 Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc)); 4048 4049 if Unprotected then 4050 Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); 4051 end if; 4052 4053 Append (New_Param, New_Plist); 4054 Next_Formal (Formal); 4055 end loop; 4056 4057 -- If the subprogram is a procedure and the context is not an access 4058 -- to protected subprogram, the parameter is in-out. Otherwise it is 4059 -- an in parameter. 4060 4061 Decl := 4062 Make_Parameter_Specification (Loc, 4063 Defining_Identifier => 4064 Make_Defining_Identifier (Loc, Name_uObject), 4065 In_Present => True, 4066 Out_Present => 4067 (Etype (Ident) = Standard_Void_Type 4068 and then not Is_RTE (Obj_Type, RE_Address)), 4069 Parameter_Type => 4070 New_Occurrence_Of (Obj_Type, Loc)); 4071 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 4072 Prepend_To (New_Plist, Decl); 4073 4074 return New_Plist; 4075 end Build_Protected_Spec; 4076 4077 --------------------------------------- 4078 -- Build_Protected_Sub_Specification -- 4079 --------------------------------------- 4080 4081 function Build_Protected_Sub_Specification 4082 (N : Node_Id; 4083 Prot_Typ : Entity_Id; 4084 Mode : Subprogram_Protection_Mode) return Node_Id 4085 is 4086 Loc : constant Source_Ptr := Sloc (N); 4087 Decl : Node_Id; 4088 Def_Id : Entity_Id; 4089 New_Id : Entity_Id; 4090 New_Plist : List_Id; 4091 New_Spec : Node_Id; 4092 4093 Append_Chr : constant array (Subprogram_Protection_Mode) of Character := 4094 (Dispatching_Mode => ' ', 4095 Protected_Mode => 'P', 4096 Unprotected_Mode => 'N'); 4097 4098 begin 4099 if Ekind (Defining_Unit_Name (Specification (N))) = 4100 E_Subprogram_Body 4101 then 4102 Decl := Unit_Declaration_Node (Corresponding_Spec (N)); 4103 else 4104 Decl := N; 4105 end if; 4106 4107 Def_Id := Defining_Unit_Name (Specification (Decl)); 4108 4109 New_Plist := 4110 Build_Protected_Spec 4111 (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id, 4112 Mode = Unprotected_Mode); 4113 New_Id := 4114 Make_Defining_Identifier (Loc, 4115 Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode))); 4116 4117 -- The unprotected operation carries the user code, and debugging 4118 -- information must be generated for it, even though this spec does 4119 -- not come from source. It is also convenient to allow gdb to step 4120 -- into the protected operation, even though it only contains lock/ 4121 -- unlock calls. 4122 4123 Set_Debug_Info_Needed (New_Id); 4124 4125 -- If a pragma Eliminate applies to the source entity, the internal 4126 -- subprograms will be eliminated as well. 4127 4128 Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id)); 4129 4130 if Nkind (Specification (Decl)) = N_Procedure_Specification then 4131 New_Spec := 4132 Make_Procedure_Specification (Loc, 4133 Defining_Unit_Name => New_Id, 4134 Parameter_Specifications => New_Plist); 4135 4136 -- Create a new specification for the anonymous subprogram type 4137 4138 else 4139 New_Spec := 4140 Make_Function_Specification (Loc, 4141 Defining_Unit_Name => New_Id, 4142 Parameter_Specifications => New_Plist, 4143 Result_Definition => 4144 Copy_Result_Type (Result_Definition (Specification (Decl)))); 4145 4146 Set_Return_Present (Defining_Unit_Name (New_Spec)); 4147 end if; 4148 4149 return New_Spec; 4150 end Build_Protected_Sub_Specification; 4151 4152 ------------------------------------- 4153 -- Build_Protected_Subprogram_Body -- 4154 ------------------------------------- 4155 4156 function Build_Protected_Subprogram_Body 4157 (N : Node_Id; 4158 Pid : Node_Id; 4159 N_Op_Spec : Node_Id) return Node_Id 4160 is 4161 Loc : constant Source_Ptr := Sloc (N); 4162 Op_Spec : Node_Id; 4163 P_Op_Spec : Node_Id; 4164 Uactuals : List_Id; 4165 Pformal : Node_Id; 4166 Unprot_Call : Node_Id; 4167 Sub_Body : Node_Id; 4168 Lock_Name : Node_Id; 4169 Lock_Stmt : Node_Id; 4170 R : Node_Id; 4171 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning 4172 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning 4173 Stmts : List_Id; 4174 Object_Parm : Node_Id; 4175 Exc_Safe : Boolean; 4176 Lock_Kind : RE_Id; 4177 4178 begin 4179 Op_Spec := Specification (N); 4180 Exc_Safe := Is_Exception_Safe (N); 4181 4182 P_Op_Spec := 4183 Build_Protected_Sub_Specification (N, Pid, Protected_Mode); 4184 4185 -- Build a list of the formal parameters of the protected version of 4186 -- the subprogram to use as the actual parameters of the unprotected 4187 -- version. 4188 4189 Uactuals := New_List; 4190 Pformal := First (Parameter_Specifications (P_Op_Spec)); 4191 while Present (Pformal) loop 4192 Append_To (Uactuals, 4193 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal)))); 4194 Next (Pformal); 4195 end loop; 4196 4197 -- Make a call to the unprotected version of the subprogram built above 4198 -- for use by the protected version built below. 4199 4200 if Nkind (Op_Spec) = N_Function_Specification then 4201 if Exc_Safe then 4202 R := Make_Temporary (Loc, 'R'); 4203 Unprot_Call := 4204 Make_Object_Declaration (Loc, 4205 Defining_Identifier => R, 4206 Constant_Present => True, 4207 Object_Definition => New_Copy (Result_Definition (N_Op_Spec)), 4208 Expression => 4209 Make_Function_Call (Loc, 4210 Name => Make_Identifier (Loc, 4211 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 4212 Parameter_Associations => Uactuals)); 4213 4214 Return_Stmt := 4215 Make_Simple_Return_Statement (Loc, 4216 Expression => New_Occurrence_Of (R, Loc)); 4217 4218 else 4219 Unprot_Call := Make_Simple_Return_Statement (Loc, 4220 Expression => Make_Function_Call (Loc, 4221 Name => 4222 Make_Identifier (Loc, 4223 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 4224 Parameter_Associations => Uactuals)); 4225 end if; 4226 4227 Lock_Kind := RE_Lock_Read_Only; 4228 4229 else 4230 Unprot_Call := 4231 Make_Procedure_Call_Statement (Loc, 4232 Name => 4233 Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), 4234 Parameter_Associations => Uactuals); 4235 4236 Lock_Kind := RE_Lock; 4237 end if; 4238 4239 -- Wrap call in block that will be covered by an at_end handler 4240 4241 if not Exc_Safe then 4242 Unprot_Call := Make_Block_Statement (Loc, 4243 Handled_Statement_Sequence => 4244 Make_Handled_Sequence_Of_Statements (Loc, 4245 Statements => New_List (Unprot_Call))); 4246 end if; 4247 4248 -- Make the protected subprogram body. This locks the protected 4249 -- object and calls the unprotected version of the subprogram. 4250 4251 case Corresponding_Runtime_Package (Pid) is 4252 when System_Tasking_Protected_Objects_Entries => 4253 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entries), Loc); 4254 4255 when System_Tasking_Protected_Objects_Single_Entry => 4256 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entry), Loc); 4257 4258 when System_Tasking_Protected_Objects => 4259 Lock_Name := New_Occurrence_Of (RTE (Lock_Kind), Loc); 4260 4261 when others => 4262 raise Program_Error; 4263 end case; 4264 4265 Object_Parm := 4266 Make_Attribute_Reference (Loc, 4267 Prefix => 4268 Make_Selected_Component (Loc, 4269 Prefix => Make_Identifier (Loc, Name_uObject), 4270 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4271 Attribute_Name => Name_Unchecked_Access); 4272 4273 Lock_Stmt := Make_Procedure_Call_Statement (Loc, 4274 Name => Lock_Name, 4275 Parameter_Associations => New_List (Object_Parm)); 4276 4277 if Abort_Allowed then 4278 Stmts := New_List ( 4279 Make_Procedure_Call_Statement (Loc, 4280 Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc), 4281 Parameter_Associations => Empty_List), 4282 Lock_Stmt); 4283 4284 else 4285 Stmts := New_List (Lock_Stmt); 4286 end if; 4287 4288 if not Exc_Safe then 4289 Append (Unprot_Call, Stmts); 4290 else 4291 if Nkind (Op_Spec) = N_Function_Specification then 4292 Pre_Stmts := Stmts; 4293 Stmts := Empty_List; 4294 else 4295 Append (Unprot_Call, Stmts); 4296 end if; 4297 4298 -- Historical note: Previously, call the the cleanup was inserted 4299 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup, 4300 -- which is also shared by the 'not Exc_Safe' path. 4301 4302 Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts); 4303 4304 if Nkind (Op_Spec) = N_Function_Specification then 4305 Append (Return_Stmt, Stmts); 4306 Append (Make_Block_Statement (Loc, 4307 Declarations => New_List (Unprot_Call), 4308 Handled_Statement_Sequence => 4309 Make_Handled_Sequence_Of_Statements (Loc, 4310 Statements => Stmts)), Pre_Stmts); 4311 Stmts := Pre_Stmts; 4312 end if; 4313 end if; 4314 4315 Sub_Body := 4316 Make_Subprogram_Body (Loc, 4317 Declarations => Empty_List, 4318 Specification => P_Op_Spec, 4319 Handled_Statement_Sequence => 4320 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); 4321 4322 -- Mark this subprogram as a protected subprogram body so that the 4323 -- cleanup will be inserted. This is done only in the 'not Exc_Safe' 4324 -- path as otherwise the cleanup has already been inserted. 4325 4326 if not Exc_Safe then 4327 Set_Is_Protected_Subprogram_Body (Sub_Body); 4328 end if; 4329 4330 return Sub_Body; 4331 end Build_Protected_Subprogram_Body; 4332 4333 ------------------------------------- 4334 -- Build_Protected_Subprogram_Call -- 4335 ------------------------------------- 4336 4337 procedure Build_Protected_Subprogram_Call 4338 (N : Node_Id; 4339 Name : Node_Id; 4340 Rec : Node_Id; 4341 External : Boolean := True) 4342 is 4343 Loc : constant Source_Ptr := Sloc (N); 4344 Sub : constant Entity_Id := Entity (Name); 4345 New_Sub : Node_Id; 4346 Params : List_Id; 4347 4348 begin 4349 if External then 4350 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc); 4351 else 4352 New_Sub := 4353 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc); 4354 end if; 4355 4356 if Present (Parameter_Associations (N)) then 4357 Params := New_Copy_List_Tree (Parameter_Associations (N)); 4358 else 4359 Params := New_List; 4360 end if; 4361 4362 -- If the type is an untagged derived type, convert to the root type, 4363 -- which is the one on which the operations are defined. 4364 4365 if Nkind (Rec) = N_Unchecked_Type_Conversion 4366 and then not Is_Tagged_Type (Etype (Rec)) 4367 and then Is_Derived_Type (Etype (Rec)) 4368 then 4369 Set_Etype (Rec, Root_Type (Etype (Rec))); 4370 Set_Subtype_Mark (Rec, 4371 New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N))); 4372 end if; 4373 4374 Prepend (Rec, Params); 4375 4376 if Ekind (Sub) = E_Procedure then 4377 Rewrite (N, 4378 Make_Procedure_Call_Statement (Loc, 4379 Name => New_Sub, 4380 Parameter_Associations => Params)); 4381 4382 else 4383 pragma Assert (Ekind (Sub) = E_Function); 4384 Rewrite (N, 4385 Make_Function_Call (Loc, 4386 Name => New_Sub, 4387 Parameter_Associations => Params)); 4388 end if; 4389 4390 if External 4391 and then Nkind (Rec) = N_Unchecked_Type_Conversion 4392 and then Is_Entity_Name (Expression (Rec)) 4393 and then Is_Shared_Passive (Entity (Expression (Rec))) 4394 then 4395 Add_Shared_Var_Lock_Procs (N); 4396 end if; 4397 end Build_Protected_Subprogram_Call; 4398 4399 --------------------------------------------- 4400 -- Build_Protected_Subprogram_Call_Cleanup -- 4401 --------------------------------------------- 4402 4403 procedure Build_Protected_Subprogram_Call_Cleanup 4404 (Op_Spec : Node_Id; 4405 Conc_Typ : Node_Id; 4406 Loc : Source_Ptr; 4407 Stmts : List_Id) 4408 is 4409 Nam : Node_Id; 4410 4411 begin 4412 -- If the associated protected object has entries, a protected 4413 -- procedure has to service entry queues. In this case generate: 4414 4415 -- Service_Entries (_object._object'Access); 4416 4417 if Nkind (Op_Spec) = N_Procedure_Specification 4418 and then Has_Entries (Conc_Typ) 4419 then 4420 case Corresponding_Runtime_Package (Conc_Typ) is 4421 when System_Tasking_Protected_Objects_Entries => 4422 Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc); 4423 4424 when System_Tasking_Protected_Objects_Single_Entry => 4425 Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc); 4426 4427 when others => 4428 raise Program_Error; 4429 end case; 4430 4431 Append_To (Stmts, 4432 Make_Procedure_Call_Statement (Loc, 4433 Name => Nam, 4434 Parameter_Associations => New_List ( 4435 Make_Attribute_Reference (Loc, 4436 Prefix => 4437 Make_Selected_Component (Loc, 4438 Prefix => Make_Identifier (Loc, Name_uObject), 4439 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4440 Attribute_Name => Name_Unchecked_Access)))); 4441 4442 else 4443 -- Generate: 4444 -- Unlock (_object._object'Access); 4445 4446 case Corresponding_Runtime_Package (Conc_Typ) is 4447 when System_Tasking_Protected_Objects_Entries => 4448 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc); 4449 4450 when System_Tasking_Protected_Objects_Single_Entry => 4451 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc); 4452 4453 when System_Tasking_Protected_Objects => 4454 Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc); 4455 4456 when others => 4457 raise Program_Error; 4458 end case; 4459 4460 Append_To (Stmts, 4461 Make_Procedure_Call_Statement (Loc, 4462 Name => Nam, 4463 Parameter_Associations => New_List ( 4464 Make_Attribute_Reference (Loc, 4465 Prefix => 4466 Make_Selected_Component (Loc, 4467 Prefix => Make_Identifier (Loc, Name_uObject), 4468 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4469 Attribute_Name => Name_Unchecked_Access)))); 4470 end if; 4471 4472 -- Generate: 4473 -- Abort_Undefer; 4474 4475 if Abort_Allowed then 4476 Append_To (Stmts, 4477 Make_Procedure_Call_Statement (Loc, 4478 Name => 4479 New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), 4480 Parameter_Associations => Empty_List)); 4481 end if; 4482 end Build_Protected_Subprogram_Call_Cleanup; 4483 4484 ------------------------- 4485 -- Build_Selected_Name -- 4486 ------------------------- 4487 4488 function Build_Selected_Name 4489 (Prefix : Entity_Id; 4490 Selector : Entity_Id; 4491 Append_Char : Character := ' ') return Name_Id 4492 is 4493 Select_Buffer : String (1 .. Hostparm.Max_Name_Length); 4494 Select_Len : Natural; 4495 4496 begin 4497 Get_Name_String (Chars (Selector)); 4498 Select_Len := Name_Len; 4499 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len); 4500 Get_Name_String (Chars (Prefix)); 4501 4502 -- If scope is anonymous type, discard suffix to recover name of 4503 -- single protected object. Otherwise use protected type name. 4504 4505 if Name_Buffer (Name_Len) = 'T' then 4506 Name_Len := Name_Len - 1; 4507 end if; 4508 4509 Add_Str_To_Name_Buffer ("__"); 4510 for J in 1 .. Select_Len loop 4511 Add_Char_To_Name_Buffer (Select_Buffer (J)); 4512 end loop; 4513 4514 -- Now add the Append_Char if specified. The encoding to follow 4515 -- depends on the type of entity. If Append_Char is either 'N' or 'P', 4516 -- then the entity is associated to a protected type subprogram. 4517 -- Otherwise, it is a protected type entry. For each case, the 4518 -- encoding to follow for the suffix is documented in exp_dbug.ads. 4519 4520 -- It would be better to encapsulate this as a routine in Exp_Dbug ??? 4521 4522 if Append_Char /= ' ' then 4523 if Append_Char = 'P' or Append_Char = 'N' then 4524 Add_Char_To_Name_Buffer (Append_Char); 4525 return Name_Find; 4526 else 4527 Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char)); 4528 return New_External_Name (Name_Find, ' ', -1); 4529 end if; 4530 else 4531 return Name_Find; 4532 end if; 4533 end Build_Selected_Name; 4534 4535 ----------------------------- 4536 -- Build_Simple_Entry_Call -- 4537 ----------------------------- 4538 4539 -- A task entry call is converted to a call to Call_Simple 4540 4541 -- declare 4542 -- P : parms := (parm, parm, parm); 4543 -- begin 4544 -- Call_Simple (acceptor-task, entry-index, P'Address); 4545 -- parm := P.param; 4546 -- parm := P.param; 4547 -- ... 4548 -- end; 4549 4550 -- Here Pnn is an aggregate of the type constructed for the entry to hold 4551 -- the parameters, and the constructed aggregate value contains either the 4552 -- parameters or, in the case of non-elementary types, references to these 4553 -- parameters. Then the address of this aggregate is passed to the runtime 4554 -- routine, along with the task id value and the task entry index value. 4555 -- Pnn is only required if parameters are present. 4556 4557 -- The assignments after the call are present only in the case of in-out 4558 -- or out parameters for elementary types, and are used to assign back the 4559 -- resulting values of such parameters. 4560 4561 -- Note: the reason that we insert a block here is that in the context 4562 -- of selects, conditional entry calls etc. the entry call statement 4563 -- appears on its own, not as an element of a list. 4564 4565 -- A protected entry call is converted to a Protected_Entry_Call: 4566 4567 -- declare 4568 -- P : E1_Params := (param, param, param); 4569 -- Pnn : Boolean; 4570 -- Bnn : Communications_Block; 4571 4572 -- declare 4573 -- P : E1_Params := (param, param, param); 4574 -- Bnn : Communications_Block; 4575 4576 -- begin 4577 -- Protected_Entry_Call ( 4578 -- Object => po._object'Access, 4579 -- E => <entry index>; 4580 -- Uninterpreted_Data => P'Address; 4581 -- Mode => Simple_Call; 4582 -- Block => Bnn); 4583 -- parm := P.param; 4584 -- parm := P.param; 4585 -- ... 4586 -- end; 4587 4588 procedure Build_Simple_Entry_Call 4589 (N : Node_Id; 4590 Concval : Node_Id; 4591 Ename : Node_Id; 4592 Index : Node_Id) 4593 is 4594 begin 4595 Expand_Call (N); 4596 4597 -- If call has been inlined, nothing left to do 4598 4599 if Nkind (N) = N_Block_Statement then 4600 return; 4601 end if; 4602 4603 -- Convert entry call to Call_Simple call 4604 4605 declare 4606 Loc : constant Source_Ptr := Sloc (N); 4607 Parms : constant List_Id := Parameter_Associations (N); 4608 Stats : constant List_Id := New_List; 4609 Actual : Node_Id; 4610 Call : Node_Id; 4611 Comm_Name : Entity_Id; 4612 Conctyp : Node_Id; 4613 Decls : List_Id; 4614 Ent : Entity_Id; 4615 Ent_Acc : Entity_Id; 4616 Formal : Node_Id; 4617 Iface_Tag : Entity_Id; 4618 Iface_Typ : Entity_Id; 4619 N_Node : Node_Id; 4620 N_Var : Node_Id; 4621 P : Entity_Id; 4622 Parm1 : Node_Id; 4623 Parm2 : Node_Id; 4624 Parm3 : Node_Id; 4625 Pdecl : Node_Id; 4626 Plist : List_Id; 4627 X : Entity_Id; 4628 Xdecl : Node_Id; 4629 4630 begin 4631 -- Simple entry and entry family cases merge here 4632 4633 Ent := Entity (Ename); 4634 Ent_Acc := Entry_Parameters_Type (Ent); 4635 Conctyp := Etype (Concval); 4636 4637 -- If prefix is an access type, dereference to obtain the task type 4638 4639 if Is_Access_Type (Conctyp) then 4640 Conctyp := Designated_Type (Conctyp); 4641 end if; 4642 4643 -- Special case for protected subprogram calls 4644 4645 if Is_Protected_Type (Conctyp) 4646 and then Is_Subprogram (Entity (Ename)) 4647 then 4648 if not Is_Eliminated (Entity (Ename)) then 4649 Build_Protected_Subprogram_Call 4650 (N, Ename, Convert_Concurrent (Concval, Conctyp)); 4651 Analyze (N); 4652 end if; 4653 4654 return; 4655 end if; 4656 4657 -- First parameter is the Task_Id value from the task value or the 4658 -- Object from the protected object value, obtained by selecting 4659 -- the _Task_Id or _Object from the result of doing an unchecked 4660 -- conversion to convert the value to the corresponding record type. 4661 4662 if Nkind (Concval) = N_Function_Call 4663 and then Is_Task_Type (Conctyp) 4664 and then Ada_Version >= Ada_2005 4665 then 4666 declare 4667 ExpR : constant Node_Id := Relocate_Node (Concval); 4668 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR); 4669 Decl : Node_Id; 4670 4671 begin 4672 Decl := 4673 Make_Object_Declaration (Loc, 4674 Defining_Identifier => Obj, 4675 Object_Definition => New_Occurrence_Of (Conctyp, Loc), 4676 Expression => ExpR); 4677 Set_Etype (Obj, Conctyp); 4678 Decls := New_List (Decl); 4679 Rewrite (Concval, New_Occurrence_Of (Obj, Loc)); 4680 end; 4681 4682 else 4683 Decls := New_List; 4684 end if; 4685 4686 Parm1 := Concurrent_Ref (Concval); 4687 4688 -- Second parameter is the entry index, computed by the routine 4689 -- provided for this purpose. The value of this expression is 4690 -- assigned to an intermediate variable to assure that any entry 4691 -- family index expressions are evaluated before the entry 4692 -- parameters. 4693 4694 if not Is_Protected_Type (Conctyp) 4695 or else 4696 Corresponding_Runtime_Package (Conctyp) = 4697 System_Tasking_Protected_Objects_Entries 4698 then 4699 X := Make_Defining_Identifier (Loc, Name_uX); 4700 4701 Xdecl := 4702 Make_Object_Declaration (Loc, 4703 Defining_Identifier => X, 4704 Object_Definition => 4705 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), 4706 Expression => Actual_Index_Expression ( 4707 Loc, Entity (Ename), Index, Concval)); 4708 4709 Append_To (Decls, Xdecl); 4710 Parm2 := New_Occurrence_Of (X, Loc); 4711 4712 else 4713 Xdecl := Empty; 4714 Parm2 := Empty; 4715 end if; 4716 4717 -- The third parameter is the packaged parameters. If there are 4718 -- none, then it is just the null address, since nothing is passed. 4719 4720 if No (Parms) then 4721 Parm3 := New_Occurrence_Of (RTE (RE_Null_Address), Loc); 4722 P := Empty; 4723 4724 -- Case of parameters present, where third argument is the address 4725 -- of a packaged record containing the required parameter values. 4726 4727 else 4728 -- First build a list of parameter values, which are references to 4729 -- objects of the parameter types. 4730 4731 Plist := New_List; 4732 4733 Actual := First_Actual (N); 4734 Formal := First_Formal (Ent); 4735 while Present (Actual) loop 4736 4737 -- If it is a by_copy_type, copy it to a new variable. The 4738 -- packaged record has a field that points to this variable. 4739 4740 if Is_By_Copy_Type (Etype (Actual)) then 4741 N_Node := 4742 Make_Object_Declaration (Loc, 4743 Defining_Identifier => Make_Temporary (Loc, 'J'), 4744 Aliased_Present => True, 4745 Object_Definition => 4746 New_Occurrence_Of (Etype (Formal), Loc)); 4747 4748 -- Mark the object as not needing initialization since the 4749 -- initialization is performed separately, avoiding errors 4750 -- on cases such as formals of null-excluding access types. 4751 4752 Set_No_Initialization (N_Node); 4753 4754 -- We must make an assignment statement separate for the 4755 -- case of limited type. We cannot assign it unless the 4756 -- Assignment_OK flag is set first. An out formal of an 4757 -- access type must also be initialized from the actual, 4758 -- as stated in RM 6.4.1 (13). 4759 4760 if Ekind (Formal) /= E_Out_Parameter 4761 or else Is_Access_Type (Etype (Formal)) 4762 then 4763 N_Var := 4764 New_Occurrence_Of (Defining_Identifier (N_Node), Loc); 4765 Set_Assignment_OK (N_Var); 4766 Append_To (Stats, 4767 Make_Assignment_Statement (Loc, 4768 Name => N_Var, 4769 Expression => Relocate_Node (Actual))); 4770 end if; 4771 4772 Append (N_Node, Decls); 4773 4774 Append_To (Plist, 4775 Make_Attribute_Reference (Loc, 4776 Attribute_Name => Name_Unchecked_Access, 4777 Prefix => 4778 New_Occurrence_Of (Defining_Identifier (N_Node), Loc))); 4779 4780 -- If it is a VM_By_Copy_Actual, copy it to a new variable 4781 4782 elsif Is_VM_By_Copy_Actual (Actual) then 4783 N_Node := 4784 Make_Object_Declaration (Loc, 4785 Defining_Identifier => Make_Temporary (Loc, 'J'), 4786 Aliased_Present => True, 4787 Object_Definition => 4788 New_Occurrence_Of (Etype (Formal), Loc), 4789 Expression => New_Copy_Tree (Actual)); 4790 Set_Assignment_OK (N_Node); 4791 4792 Append (N_Node, Decls); 4793 4794 Append_To (Plist, 4795 Make_Attribute_Reference (Loc, 4796 Attribute_Name => Name_Unchecked_Access, 4797 Prefix => 4798 New_Occurrence_Of (Defining_Identifier (N_Node), Loc))); 4799 4800 else 4801 -- Interface class-wide formal 4802 4803 if Ada_Version >= Ada_2005 4804 and then Ekind (Etype (Formal)) = E_Class_Wide_Type 4805 and then Is_Interface (Etype (Formal)) 4806 then 4807 Iface_Typ := Etype (Etype (Formal)); 4808 4809 -- Generate: 4810 -- formal_iface_type! (actual.iface_tag)'reference 4811 4812 Iface_Tag := 4813 Find_Interface_Tag (Etype (Actual), Iface_Typ); 4814 pragma Assert (Present (Iface_Tag)); 4815 4816 Append_To (Plist, 4817 Make_Reference (Loc, 4818 Unchecked_Convert_To (Iface_Typ, 4819 Make_Selected_Component (Loc, 4820 Prefix => 4821 Relocate_Node (Actual), 4822 Selector_Name => 4823 New_Occurrence_Of (Iface_Tag, Loc))))); 4824 else 4825 -- Generate: 4826 -- actual'reference 4827 4828 Append_To (Plist, 4829 Make_Reference (Loc, Relocate_Node (Actual))); 4830 end if; 4831 end if; 4832 4833 Next_Actual (Actual); 4834 Next_Formal_With_Extras (Formal); 4835 end loop; 4836 4837 -- Now build the declaration of parameters initialized with the 4838 -- aggregate containing this constructed parameter list. 4839 4840 P := Make_Defining_Identifier (Loc, Name_uP); 4841 4842 Pdecl := 4843 Make_Object_Declaration (Loc, 4844 Defining_Identifier => P, 4845 Object_Definition => 4846 New_Occurrence_Of (Designated_Type (Ent_Acc), Loc), 4847 Expression => 4848 Make_Aggregate (Loc, Expressions => Plist)); 4849 4850 Parm3 := 4851 Make_Attribute_Reference (Loc, 4852 Prefix => New_Occurrence_Of (P, Loc), 4853 Attribute_Name => Name_Address); 4854 4855 Append (Pdecl, Decls); 4856 end if; 4857 4858 -- Now we can create the call, case of protected type 4859 4860 if Is_Protected_Type (Conctyp) then 4861 case Corresponding_Runtime_Package (Conctyp) is 4862 when System_Tasking_Protected_Objects_Entries => 4863 4864 -- Change the type of the index declaration 4865 4866 Set_Object_Definition (Xdecl, 4867 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)); 4868 4869 -- Some additional declarations for protected entry calls 4870 4871 if No (Decls) then 4872 Decls := New_List; 4873 end if; 4874 4875 -- Bnn : Communications_Block; 4876 4877 Comm_Name := Make_Temporary (Loc, 'B'); 4878 4879 Append_To (Decls, 4880 Make_Object_Declaration (Loc, 4881 Defining_Identifier => Comm_Name, 4882 Object_Definition => 4883 New_Occurrence_Of 4884 (RTE (RE_Communication_Block), Loc))); 4885 4886 -- Some additional statements for protected entry calls 4887 4888 -- Protected_Entry_Call ( 4889 -- Object => po._object'Access, 4890 -- E => <entry index>; 4891 -- Uninterpreted_Data => P'Address; 4892 -- Mode => Simple_Call; 4893 -- Block => Bnn); 4894 4895 Call := 4896 Make_Procedure_Call_Statement (Loc, 4897 Name => 4898 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), 4899 4900 Parameter_Associations => New_List ( 4901 Make_Attribute_Reference (Loc, 4902 Attribute_Name => Name_Unchecked_Access, 4903 Prefix => Parm1), 4904 Parm2, 4905 Parm3, 4906 New_Occurrence_Of (RTE (RE_Simple_Call), Loc), 4907 New_Occurrence_Of (Comm_Name, Loc))); 4908 4909 when System_Tasking_Protected_Objects_Single_Entry => 4910 -- Protected_Single_Entry_Call ( 4911 -- Object => po._object'Access, 4912 -- Uninterpreted_Data => P'Address); 4913 4914 Call := 4915 Make_Procedure_Call_Statement (Loc, 4916 Name => New_Occurrence_Of ( 4917 RTE (RE_Protected_Single_Entry_Call), Loc), 4918 4919 Parameter_Associations => New_List ( 4920 Make_Attribute_Reference (Loc, 4921 Attribute_Name => Name_Unchecked_Access, 4922 Prefix => Parm1), 4923 Parm3)); 4924 4925 when others => 4926 raise Program_Error; 4927 end case; 4928 4929 -- Case of task type 4930 4931 else 4932 Call := 4933 Make_Procedure_Call_Statement (Loc, 4934 Name => New_Occurrence_Of (RTE (RE_Call_Simple), Loc), 4935 Parameter_Associations => New_List (Parm1, Parm2, Parm3)); 4936 4937 end if; 4938 4939 Append_To (Stats, Call); 4940 4941 -- If there are out or in/out parameters by copy add assignment 4942 -- statements for the result values. 4943 4944 if Present (Parms) then 4945 Actual := First_Actual (N); 4946 Formal := First_Formal (Ent); 4947 4948 Set_Assignment_OK (Actual); 4949 while Present (Actual) loop 4950 if (Is_By_Copy_Type (Etype (Actual)) 4951 or else Is_VM_By_Copy_Actual (Actual)) 4952 and then Ekind (Formal) /= E_In_Parameter 4953 then 4954 N_Node := 4955 Make_Assignment_Statement (Loc, 4956 Name => New_Copy (Actual), 4957 Expression => 4958 Make_Explicit_Dereference (Loc, 4959 Make_Selected_Component (Loc, 4960 Prefix => New_Occurrence_Of (P, Loc), 4961 Selector_Name => 4962 Make_Identifier (Loc, Chars (Formal))))); 4963 4964 -- In all cases (including limited private types) we want 4965 -- the assignment to be valid. 4966 4967 Set_Assignment_OK (Name (N_Node)); 4968 4969 -- If the call is the triggering alternative in an 4970 -- asynchronous select, or the entry_call alternative of a 4971 -- conditional entry call, the assignments for in-out 4972 -- parameters are incorporated into the statement list that 4973 -- follows, so that there are executed only if the entry 4974 -- call succeeds. 4975 4976 if (Nkind (Parent (N)) = N_Triggering_Alternative 4977 and then N = Triggering_Statement (Parent (N))) 4978 or else 4979 (Nkind (Parent (N)) = N_Entry_Call_Alternative 4980 and then N = Entry_Call_Statement (Parent (N))) 4981 then 4982 if No (Statements (Parent (N))) then 4983 Set_Statements (Parent (N), New_List); 4984 end if; 4985 4986 Prepend (N_Node, Statements (Parent (N))); 4987 4988 else 4989 Insert_After (Call, N_Node); 4990 end if; 4991 end if; 4992 4993 Next_Actual (Actual); 4994 Next_Formal_With_Extras (Formal); 4995 end loop; 4996 end if; 4997 4998 -- Finally, create block and analyze it 4999 5000 Rewrite (N, 5001 Make_Block_Statement (Loc, 5002 Declarations => Decls, 5003 Handled_Statement_Sequence => 5004 Make_Handled_Sequence_Of_Statements (Loc, 5005 Statements => Stats))); 5006 5007 Analyze (N); 5008 end; 5009 end Build_Simple_Entry_Call; 5010 5011 -------------------------------- 5012 -- Build_Task_Activation_Call -- 5013 -------------------------------- 5014 5015 procedure Build_Task_Activation_Call (N : Node_Id) is 5016 Loc : constant Source_Ptr := Sloc (N); 5017 Chain : Entity_Id; 5018 Call : Node_Id; 5019 Name : Node_Id; 5020 P : Node_Id; 5021 5022 begin 5023 -- For sequential elaboration policy, all the tasks will be activated at 5024 -- the end of the elaboration. 5025 5026 if Partition_Elaboration_Policy = 'S' then 5027 return; 5028 end if; 5029 5030 -- Get the activation chain entity. Except in the case of a package 5031 -- body, this is in the node that was passed. For a package body, we 5032 -- have to find the corresponding package declaration node. 5033 5034 if Nkind (N) = N_Package_Body then 5035 P := Corresponding_Spec (N); 5036 loop 5037 P := Parent (P); 5038 exit when Nkind (P) = N_Package_Declaration; 5039 end loop; 5040 5041 Chain := Activation_Chain_Entity (P); 5042 5043 else 5044 Chain := Activation_Chain_Entity (N); 5045 end if; 5046 5047 if Present (Chain) then 5048 if Restricted_Profile then 5049 Name := New_Occurrence_Of 5050 (RTE (RE_Activate_Restricted_Tasks), Loc); 5051 else 5052 Name := New_Occurrence_Of 5053 (RTE (RE_Activate_Tasks), Loc); 5054 end if; 5055 5056 Call := 5057 Make_Procedure_Call_Statement (Loc, 5058 Name => Name, 5059 Parameter_Associations => 5060 New_List (Make_Attribute_Reference (Loc, 5061 Prefix => New_Occurrence_Of (Chain, Loc), 5062 Attribute_Name => Name_Unchecked_Access))); 5063 5064 if Nkind (N) = N_Package_Declaration then 5065 if Present (Corresponding_Body (N)) then 5066 null; 5067 5068 elsif Present (Private_Declarations (Specification (N))) then 5069 Append (Call, Private_Declarations (Specification (N))); 5070 5071 else 5072 Append (Call, Visible_Declarations (Specification (N))); 5073 end if; 5074 5075 else 5076 if Present (Handled_Statement_Sequence (N)) then 5077 5078 -- The call goes at the start of the statement sequence after 5079 -- the start of exception range label if one is present. 5080 5081 declare 5082 Stm : Node_Id; 5083 5084 begin 5085 Stm := First (Statements (Handled_Statement_Sequence (N))); 5086 5087 -- A special case, skip exception range label if one is 5088 -- present (from front end zcx processing). 5089 5090 if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then 5091 Next (Stm); 5092 end if; 5093 5094 -- Another special case, if the first statement is a block 5095 -- from optimization of a local raise to a goto, then the 5096 -- call goes inside this block. 5097 5098 if Nkind (Stm) = N_Block_Statement 5099 and then Exception_Junk (Stm) 5100 then 5101 Stm := 5102 First (Statements (Handled_Statement_Sequence (Stm))); 5103 end if; 5104 5105 -- Insertion point is after any exception label pushes, 5106 -- since we want it covered by any local handlers. 5107 5108 while Nkind (Stm) in N_Push_xxx_Label loop 5109 Next (Stm); 5110 end loop; 5111 5112 -- Now we have the proper insertion point 5113 5114 Insert_Before (Stm, Call); 5115 end; 5116 5117 else 5118 Set_Handled_Statement_Sequence (N, 5119 Make_Handled_Sequence_Of_Statements (Loc, 5120 Statements => New_List (Call))); 5121 end if; 5122 end if; 5123 5124 Analyze (Call); 5125 Check_Task_Activation (N); 5126 end if; 5127 end Build_Task_Activation_Call; 5128 5129 ------------------------------- 5130 -- Build_Task_Allocate_Block -- 5131 ------------------------------- 5132 5133 procedure Build_Task_Allocate_Block 5134 (Actions : List_Id; 5135 N : Node_Id; 5136 Args : List_Id) 5137 is 5138 T : constant Entity_Id := Entity (Expression (N)); 5139 Init : constant Entity_Id := Base_Init_Proc (T); 5140 Loc : constant Source_Ptr := Sloc (N); 5141 Chain : constant Entity_Id := 5142 Make_Defining_Identifier (Loc, Name_uChain); 5143 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 5144 Block : Node_Id; 5145 5146 begin 5147 Block := 5148 Make_Block_Statement (Loc, 5149 Identifier => New_Occurrence_Of (Blkent, Loc), 5150 Declarations => New_List ( 5151 5152 -- _Chain : Activation_Chain; 5153 5154 Make_Object_Declaration (Loc, 5155 Defining_Identifier => Chain, 5156 Aliased_Present => True, 5157 Object_Definition => 5158 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 5159 5160 Handled_Statement_Sequence => 5161 Make_Handled_Sequence_Of_Statements (Loc, 5162 5163 Statements => New_List ( 5164 5165 -- Init (Args); 5166 5167 Make_Procedure_Call_Statement (Loc, 5168 Name => New_Occurrence_Of (Init, Loc), 5169 Parameter_Associations => Args), 5170 5171 -- Activate_Tasks (_Chain); 5172 5173 Make_Procedure_Call_Statement (Loc, 5174 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 5175 Parameter_Associations => New_List ( 5176 Make_Attribute_Reference (Loc, 5177 Prefix => New_Occurrence_Of (Chain, Loc), 5178 Attribute_Name => Name_Unchecked_Access))))), 5179 5180 Has_Created_Identifier => True, 5181 Is_Task_Allocation_Block => True); 5182 5183 Append_To (Actions, 5184 Make_Implicit_Label_Declaration (Loc, 5185 Defining_Identifier => Blkent, 5186 Label_Construct => Block)); 5187 5188 Append_To (Actions, Block); 5189 5190 Set_Activation_Chain_Entity (Block, Chain); 5191 end Build_Task_Allocate_Block; 5192 5193 ----------------------------------------------- 5194 -- Build_Task_Allocate_Block_With_Init_Stmts -- 5195 ----------------------------------------------- 5196 5197 procedure Build_Task_Allocate_Block_With_Init_Stmts 5198 (Actions : List_Id; 5199 N : Node_Id; 5200 Init_Stmts : List_Id) 5201 is 5202 Loc : constant Source_Ptr := Sloc (N); 5203 Chain : constant Entity_Id := 5204 Make_Defining_Identifier (Loc, Name_uChain); 5205 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 5206 Block : Node_Id; 5207 5208 begin 5209 Append_To (Init_Stmts, 5210 Make_Procedure_Call_Statement (Loc, 5211 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 5212 Parameter_Associations => New_List ( 5213 Make_Attribute_Reference (Loc, 5214 Prefix => New_Occurrence_Of (Chain, Loc), 5215 Attribute_Name => Name_Unchecked_Access)))); 5216 5217 Block := 5218 Make_Block_Statement (Loc, 5219 Identifier => New_Occurrence_Of (Blkent, Loc), 5220 Declarations => New_List ( 5221 5222 -- _Chain : Activation_Chain; 5223 5224 Make_Object_Declaration (Loc, 5225 Defining_Identifier => Chain, 5226 Aliased_Present => True, 5227 Object_Definition => 5228 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 5229 5230 Handled_Statement_Sequence => 5231 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts), 5232 5233 Has_Created_Identifier => True, 5234 Is_Task_Allocation_Block => True); 5235 5236 Append_To (Actions, 5237 Make_Implicit_Label_Declaration (Loc, 5238 Defining_Identifier => Blkent, 5239 Label_Construct => Block)); 5240 5241 Append_To (Actions, Block); 5242 5243 Set_Activation_Chain_Entity (Block, Chain); 5244 end Build_Task_Allocate_Block_With_Init_Stmts; 5245 5246 ----------------------------------- 5247 -- Build_Task_Proc_Specification -- 5248 ----------------------------------- 5249 5250 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is 5251 Loc : constant Source_Ptr := Sloc (T); 5252 Spec_Id : Entity_Id; 5253 5254 begin 5255 -- Case of explicit task type, suffix TB 5256 5257 if Comes_From_Source (T) then 5258 Spec_Id := 5259 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB")); 5260 5261 -- Case of anonymous task type, suffix B 5262 5263 else 5264 Spec_Id := 5265 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B')); 5266 end if; 5267 5268 Set_Is_Internal (Spec_Id); 5269 5270 -- Associate the procedure with the task, if this is the declaration 5271 -- (and not the body) of the procedure. 5272 5273 if No (Task_Body_Procedure (T)) then 5274 Set_Task_Body_Procedure (T, Spec_Id); 5275 end if; 5276 5277 return 5278 Make_Procedure_Specification (Loc, 5279 Defining_Unit_Name => Spec_Id, 5280 Parameter_Specifications => New_List ( 5281 Make_Parameter_Specification (Loc, 5282 Defining_Identifier => 5283 Make_Defining_Identifier (Loc, Name_uTask), 5284 Parameter_Type => 5285 Make_Access_Definition (Loc, 5286 Subtype_Mark => 5287 New_Occurrence_Of (Corresponding_Record_Type (T), Loc))))); 5288 end Build_Task_Proc_Specification; 5289 5290 --------------------------------------- 5291 -- Build_Unprotected_Subprogram_Body -- 5292 --------------------------------------- 5293 5294 function Build_Unprotected_Subprogram_Body 5295 (N : Node_Id; 5296 Pid : Node_Id) return Node_Id 5297 is 5298 Decls : constant List_Id := Declarations (N); 5299 5300 begin 5301 -- Add renamings for the Protection object, discriminals, privals and 5302 -- the entry index constant for use by debugger. 5303 5304 Debug_Private_Data_Declarations (Decls); 5305 5306 -- Make an unprotected version of the subprogram for use within the same 5307 -- object, with a new name and an additional parameter representing the 5308 -- object. 5309 5310 return 5311 Make_Subprogram_Body (Sloc (N), 5312 Specification => 5313 Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), 5314 Declarations => Decls, 5315 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 5316 end Build_Unprotected_Subprogram_Body; 5317 5318 ---------------------------- 5319 -- Collect_Entry_Families -- 5320 ---------------------------- 5321 5322 procedure Collect_Entry_Families 5323 (Loc : Source_Ptr; 5324 Cdecls : List_Id; 5325 Current_Node : in out Node_Id; 5326 Conctyp : Entity_Id) 5327 is 5328 Efam : Entity_Id; 5329 Efam_Decl : Node_Id; 5330 Efam_Type : Entity_Id; 5331 5332 begin 5333 Efam := First_Entity (Conctyp); 5334 while Present (Efam) loop 5335 if Ekind (Efam) = E_Entry_Family then 5336 Efam_Type := Make_Temporary (Loc, 'F'); 5337 5338 declare 5339 Bas : Entity_Id := 5340 Base_Type 5341 (Etype (Discrete_Subtype_Definition (Parent (Efam)))); 5342 5343 Bas_Decl : Node_Id := Empty; 5344 Lo, Hi : Node_Id; 5345 5346 begin 5347 Get_Index_Bounds 5348 (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi); 5349 5350 if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then 5351 Bas := Make_Temporary (Loc, 'B'); 5352 5353 Bas_Decl := 5354 Make_Subtype_Declaration (Loc, 5355 Defining_Identifier => Bas, 5356 Subtype_Indication => 5357 Make_Subtype_Indication (Loc, 5358 Subtype_Mark => 5359 New_Occurrence_Of (Standard_Integer, Loc), 5360 Constraint => 5361 Make_Range_Constraint (Loc, 5362 Range_Expression => Make_Range (Loc, 5363 Make_Integer_Literal 5364 (Loc, -Entry_Family_Bound), 5365 Make_Integer_Literal 5366 (Loc, Entry_Family_Bound - 1))))); 5367 5368 Insert_After (Current_Node, Bas_Decl); 5369 Current_Node := Bas_Decl; 5370 Analyze (Bas_Decl); 5371 end if; 5372 5373 Efam_Decl := 5374 Make_Full_Type_Declaration (Loc, 5375 Defining_Identifier => Efam_Type, 5376 Type_Definition => 5377 Make_Unconstrained_Array_Definition (Loc, 5378 Subtype_Marks => 5379 (New_List (New_Occurrence_Of (Bas, Loc))), 5380 5381 Component_Definition => 5382 Make_Component_Definition (Loc, 5383 Aliased_Present => False, 5384 Subtype_Indication => 5385 New_Occurrence_Of (Standard_Character, Loc)))); 5386 end; 5387 5388 Insert_After (Current_Node, Efam_Decl); 5389 Current_Node := Efam_Decl; 5390 Analyze (Efam_Decl); 5391 5392 Append_To (Cdecls, 5393 Make_Component_Declaration (Loc, 5394 Defining_Identifier => 5395 Make_Defining_Identifier (Loc, Chars (Efam)), 5396 5397 Component_Definition => 5398 Make_Component_Definition (Loc, 5399 Aliased_Present => False, 5400 Subtype_Indication => 5401 Make_Subtype_Indication (Loc, 5402 Subtype_Mark => 5403 New_Occurrence_Of (Efam_Type, Loc), 5404 5405 Constraint => 5406 Make_Index_Or_Discriminant_Constraint (Loc, 5407 Constraints => New_List ( 5408 New_Occurrence_Of 5409 (Etype (Discrete_Subtype_Definition 5410 (Parent (Efam))), Loc))))))); 5411 5412 end if; 5413 5414 Next_Entity (Efam); 5415 end loop; 5416 end Collect_Entry_Families; 5417 5418 ----------------------- 5419 -- Concurrent_Object -- 5420 ----------------------- 5421 5422 function Concurrent_Object 5423 (Spec_Id : Entity_Id; 5424 Conc_Typ : Entity_Id) return Entity_Id 5425 is 5426 begin 5427 -- Parameter _O or _object 5428 5429 if Is_Protected_Type (Conc_Typ) then 5430 return First_Formal (Protected_Body_Subprogram (Spec_Id)); 5431 5432 -- Parameter _task 5433 5434 else 5435 pragma Assert (Is_Task_Type (Conc_Typ)); 5436 return First_Formal (Task_Body_Procedure (Conc_Typ)); 5437 end if; 5438 end Concurrent_Object; 5439 5440 ---------------------- 5441 -- Copy_Result_Type -- 5442 ---------------------- 5443 5444 function Copy_Result_Type (Res : Node_Id) return Node_Id is 5445 New_Res : constant Node_Id := New_Copy_Tree (Res); 5446 Par_Spec : Node_Id; 5447 Formal : Entity_Id; 5448 5449 begin 5450 -- If the result type is an access_to_subprogram, we must create new 5451 -- entities for its spec. 5452 5453 if Nkind (New_Res) = N_Access_Definition 5454 and then Present (Access_To_Subprogram_Definition (New_Res)) 5455 then 5456 -- Provide new entities for the formals 5457 5458 Par_Spec := First (Parameter_Specifications 5459 (Access_To_Subprogram_Definition (New_Res))); 5460 while Present (Par_Spec) loop 5461 Formal := Defining_Identifier (Par_Spec); 5462 Set_Defining_Identifier (Par_Spec, 5463 Make_Defining_Identifier (Sloc (Formal), Chars (Formal))); 5464 Next (Par_Spec); 5465 end loop; 5466 end if; 5467 5468 return New_Res; 5469 end Copy_Result_Type; 5470 5471 -------------------- 5472 -- Concurrent_Ref -- 5473 -------------------- 5474 5475 -- The expression returned for a reference to a concurrent object has the 5476 -- form: 5477 5478 -- taskV!(name)._Task_Id 5479 5480 -- for a task, and 5481 5482 -- objectV!(name)._Object 5483 5484 -- for a protected object. For the case of an access to a concurrent 5485 -- object, there is an extra explicit dereference: 5486 5487 -- taskV!(name.all)._Task_Id 5488 -- objectV!(name.all)._Object 5489 5490 -- here taskV and objectV are the types for the associated records, which 5491 -- contain the required _Task_Id and _Object fields for tasks and protected 5492 -- objects, respectively. 5493 5494 -- For the case of a task type name, the expression is 5495 5496 -- Self; 5497 5498 -- i.e. a call to the Self function which returns precisely this Task_Id 5499 5500 -- For the case of a protected type name, the expression is 5501 5502 -- objectR 5503 5504 -- which is a renaming of the _object field of the current object 5505 -- record, passed into protected operations as a parameter. 5506 5507 function Concurrent_Ref (N : Node_Id) return Node_Id is 5508 Loc : constant Source_Ptr := Sloc (N); 5509 Ntyp : constant Entity_Id := Etype (N); 5510 Dtyp : Entity_Id; 5511 Sel : Name_Id; 5512 5513 function Is_Current_Task (T : Entity_Id) return Boolean; 5514 -- Check whether the reference is to the immediately enclosing task 5515 -- type, or to an outer one (rare but legal). 5516 5517 --------------------- 5518 -- Is_Current_Task -- 5519 --------------------- 5520 5521 function Is_Current_Task (T : Entity_Id) return Boolean is 5522 Scop : Entity_Id; 5523 5524 begin 5525 Scop := Current_Scope; 5526 while Present (Scop) 5527 and then Scop /= Standard_Standard 5528 loop 5529 5530 if Scop = T then 5531 return True; 5532 5533 elsif Is_Task_Type (Scop) then 5534 return False; 5535 5536 -- If this is a procedure nested within the task type, we must 5537 -- assume that it can be called from an inner task, and therefore 5538 -- cannot treat it as a local reference. 5539 5540 elsif Is_Overloadable (Scop) and then In_Open_Scopes (T) then 5541 return False; 5542 5543 else 5544 Scop := Scope (Scop); 5545 end if; 5546 end loop; 5547 5548 -- We know that we are within the task body, so should have found it 5549 -- in scope. 5550 5551 raise Program_Error; 5552 end Is_Current_Task; 5553 5554 -- Start of processing for Concurrent_Ref 5555 5556 begin 5557 if Is_Access_Type (Ntyp) then 5558 Dtyp := Designated_Type (Ntyp); 5559 5560 if Is_Protected_Type (Dtyp) then 5561 Sel := Name_uObject; 5562 else 5563 Sel := Name_uTask_Id; 5564 end if; 5565 5566 return 5567 Make_Selected_Component (Loc, 5568 Prefix => 5569 Unchecked_Convert_To (Corresponding_Record_Type (Dtyp), 5570 Make_Explicit_Dereference (Loc, N)), 5571 Selector_Name => Make_Identifier (Loc, Sel)); 5572 5573 elsif Is_Entity_Name (N) and then Is_Concurrent_Type (Entity (N)) then 5574 if Is_Task_Type (Entity (N)) then 5575 5576 if Is_Current_Task (Entity (N)) then 5577 return 5578 Make_Function_Call (Loc, 5579 Name => New_Occurrence_Of (RTE (RE_Self), Loc)); 5580 5581 else 5582 declare 5583 Decl : Node_Id; 5584 T_Self : constant Entity_Id := Make_Temporary (Loc, 'T'); 5585 T_Body : constant Node_Id := 5586 Parent (Corresponding_Body (Parent (Entity (N)))); 5587 5588 begin 5589 Decl := 5590 Make_Object_Declaration (Loc, 5591 Defining_Identifier => T_Self, 5592 Object_Definition => 5593 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 5594 Expression => 5595 Make_Function_Call (Loc, 5596 Name => New_Occurrence_Of (RTE (RE_Self), Loc))); 5597 Prepend (Decl, Declarations (T_Body)); 5598 Analyze (Decl); 5599 Set_Scope (T_Self, Entity (N)); 5600 return New_Occurrence_Of (T_Self, Loc); 5601 end; 5602 end if; 5603 5604 else 5605 pragma Assert (Is_Protected_Type (Entity (N))); 5606 5607 return 5608 New_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc); 5609 end if; 5610 5611 else 5612 if Is_Protected_Type (Ntyp) then 5613 Sel := Name_uObject; 5614 5615 elsif Is_Task_Type (Ntyp) then 5616 Sel := Name_uTask_Id; 5617 5618 else 5619 raise Program_Error; 5620 end if; 5621 5622 return 5623 Make_Selected_Component (Loc, 5624 Prefix => 5625 Unchecked_Convert_To (Corresponding_Record_Type (Ntyp), 5626 New_Copy_Tree (N)), 5627 Selector_Name => Make_Identifier (Loc, Sel)); 5628 end if; 5629 end Concurrent_Ref; 5630 5631 ------------------------ 5632 -- Convert_Concurrent -- 5633 ------------------------ 5634 5635 function Convert_Concurrent 5636 (N : Node_Id; 5637 Typ : Entity_Id) return Node_Id 5638 is 5639 begin 5640 if not Is_Concurrent_Type (Typ) then 5641 return N; 5642 else 5643 return 5644 Unchecked_Convert_To 5645 (Corresponding_Record_Type (Typ), New_Copy_Tree (N)); 5646 end if; 5647 end Convert_Concurrent; 5648 5649 ------------------------------------- 5650 -- Debug_Private_Data_Declarations -- 5651 ------------------------------------- 5652 5653 procedure Debug_Private_Data_Declarations (Decls : List_Id) is 5654 Debug_Nod : Node_Id; 5655 Decl : Node_Id; 5656 5657 begin 5658 Decl := First (Decls); 5659 while Present (Decl) and then not Comes_From_Source (Decl) loop 5660 -- Declaration for concurrent entity _object and its access type, 5661 -- along with the entry index subtype: 5662 -- type prot_typVP is access prot_typV; 5663 -- _object : prot_typVP := prot_typV (_O); 5664 -- subtype Jnn is <Type of Index> range Low .. High; 5665 5666 if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then 5667 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5668 5669 -- Declaration for the Protection object, discriminals, privals and 5670 -- entry index constant: 5671 -- conc_typR : protection_typ renames _object._object; 5672 -- discr_nameD : discr_typ renames _object.discr_name; 5673 -- discr_nameD : discr_typ renames _task.discr_name; 5674 -- prival_name : comp_typ renames _object.comp_name; 5675 -- J : constant Jnn := 5676 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First)); 5677 5678 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 5679 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5680 Debug_Nod := Debug_Renaming_Declaration (Decl); 5681 5682 if Present (Debug_Nod) then 5683 Insert_After (Decl, Debug_Nod); 5684 end if; 5685 end if; 5686 5687 Next (Decl); 5688 end loop; 5689 end Debug_Private_Data_Declarations; 5690 5691 ------------------------------ 5692 -- Ensure_Statement_Present -- 5693 ------------------------------ 5694 5695 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is 5696 Stmt : Node_Id; 5697 5698 begin 5699 if Opt.Suppress_Control_Flow_Optimizations 5700 and then Is_Empty_List (Statements (Alt)) 5701 then 5702 Stmt := Make_Null_Statement (Loc); 5703 5704 -- Mark NULL statement as coming from source so that it is not 5705 -- eliminated by GIGI. 5706 5707 -- Another covert channel. If this is a requirement, it must be 5708 -- documented in sinfo/einfo ??? 5709 5710 Set_Comes_From_Source (Stmt, True); 5711 5712 Set_Statements (Alt, New_List (Stmt)); 5713 end if; 5714 end Ensure_Statement_Present; 5715 5716 ---------------------------- 5717 -- Entry_Index_Expression -- 5718 ---------------------------- 5719 5720 function Entry_Index_Expression 5721 (Sloc : Source_Ptr; 5722 Ent : Entity_Id; 5723 Index : Node_Id; 5724 Ttyp : Entity_Id) return Node_Id 5725 is 5726 Expr : Node_Id; 5727 Num : Node_Id; 5728 Lo : Node_Id; 5729 Hi : Node_Id; 5730 Prev : Entity_Id; 5731 S : Node_Id; 5732 5733 begin 5734 -- The queues of entries and entry families appear in textual order in 5735 -- the associated record. The entry index is computed as the sum of the 5736 -- number of queues for all entries that precede the designated one, to 5737 -- which is added the index expression, if this expression denotes a 5738 -- member of a family. 5739 5740 -- The following is a place holder for the count of simple entries 5741 5742 Num := Make_Integer_Literal (Sloc, 1); 5743 5744 -- We construct an expression which is a series of addition operations. 5745 -- The first operand is the number of single entries that precede this 5746 -- one, the second operand is the index value relative to the start of 5747 -- the referenced family, and the remaining operands are the lengths of 5748 -- the entry families that precede this entry, i.e. the constructed 5749 -- expression is: 5750 5751 -- number_simple_entries + 5752 -- (s'pos (index-value) - s'pos (family'first)) + 1 + 5753 -- family'length + ... 5754 5755 -- where index-value is the given index value, and s is the index 5756 -- subtype (we have to use pos because the subtype might be an 5757 -- enumeration type preventing direct subtraction). Note that the task 5758 -- entry array is one-indexed. 5759 5760 -- The upper bound of the entry family may be a discriminant, so we 5761 -- retrieve the lower bound explicitly to compute offset, rather than 5762 -- using the index subtype which may mention a discriminant. 5763 5764 if Present (Index) then 5765 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); 5766 5767 Expr := 5768 Make_Op_Add (Sloc, 5769 Left_Opnd => Num, 5770 5771 Right_Opnd => 5772 Family_Offset ( 5773 Sloc, 5774 Make_Attribute_Reference (Sloc, 5775 Attribute_Name => Name_Pos, 5776 Prefix => New_Occurrence_Of (Base_Type (S), Sloc), 5777 Expressions => New_List (Relocate_Node (Index))), 5778 Type_Low_Bound (S), 5779 Ttyp, 5780 False)); 5781 else 5782 Expr := Num; 5783 end if; 5784 5785 -- Now add lengths of preceding entries and entry families 5786 5787 Prev := First_Entity (Ttyp); 5788 5789 while Chars (Prev) /= Chars (Ent) 5790 or else (Ekind (Prev) /= Ekind (Ent)) 5791 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 5792 loop 5793 if Ekind (Prev) = E_Entry then 5794 Set_Intval (Num, Intval (Num) + 1); 5795 5796 elsif Ekind (Prev) = E_Entry_Family then 5797 S := 5798 Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); 5799 Lo := Type_Low_Bound (S); 5800 Hi := Type_High_Bound (S); 5801 5802 Expr := 5803 Make_Op_Add (Sloc, 5804 Left_Opnd => Expr, 5805 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False)); 5806 5807 -- Other components are anonymous types to be ignored 5808 5809 else 5810 null; 5811 end if; 5812 5813 Next_Entity (Prev); 5814 end loop; 5815 5816 return Expr; 5817 end Entry_Index_Expression; 5818 5819 --------------------------- 5820 -- Establish_Task_Master -- 5821 --------------------------- 5822 5823 procedure Establish_Task_Master (N : Node_Id) is 5824 Call : Node_Id; 5825 5826 begin 5827 if Restriction_Active (No_Task_Hierarchy) = False then 5828 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master); 5829 5830 -- The block may have no declarations (and nevertheless be a task 5831 -- master) if it contains a call that may return an object that 5832 -- contains tasks. 5833 5834 if No (Declarations (N)) then 5835 Set_Declarations (N, New_List (Call)); 5836 else 5837 Prepend_To (Declarations (N), Call); 5838 end if; 5839 5840 Analyze (Call); 5841 end if; 5842 end Establish_Task_Master; 5843 5844 -------------------------------- 5845 -- Expand_Accept_Declarations -- 5846 -------------------------------- 5847 5848 -- Part of the expansion of an accept statement involves the creation of 5849 -- a declaration that can be referenced from the statement sequence of 5850 -- the accept: 5851 5852 -- Ann : Address; 5853 5854 -- This declaration is inserted immediately before the accept statement 5855 -- and it is important that it be inserted before the statements of the 5856 -- statement sequence are analyzed. Thus it would be too late to create 5857 -- this declaration in the Expand_N_Accept_Statement routine, which is 5858 -- why there is a separate procedure to be called directly from Sem_Ch9. 5859 5860 -- Ann is used to hold the address of the record containing the parameters 5861 -- (see Expand_N_Entry_Call for more details on how this record is built). 5862 -- References to the parameters do an unchecked conversion of this address 5863 -- to a pointer to the required record type, and then access the field that 5864 -- holds the value of the required parameter. The entity for the address 5865 -- variable is held as the top stack element (i.e. the last element) of the 5866 -- Accept_Address stack in the corresponding entry entity, and this element 5867 -- must be set in place before the statements are processed. 5868 5869 -- The above description applies to the case of a stand alone accept 5870 -- statement, i.e. one not appearing as part of a select alternative. 5871 5872 -- For the case of an accept that appears as part of a select alternative 5873 -- of a selective accept, we must still create the declaration right away, 5874 -- since Ann is needed immediately, but there is an important difference: 5875 5876 -- The declaration is inserted before the selective accept, not before 5877 -- the accept statement (which is not part of a list anyway, and so would 5878 -- not accommodate inserted declarations) 5879 5880 -- We only need one address variable for the entire selective accept. So 5881 -- the Ann declaration is created only for the first accept alternative, 5882 -- and subsequent accept alternatives reference the same Ann variable. 5883 5884 -- We can distinguish the two cases by seeing whether the accept statement 5885 -- is part of a list. If not, then it must be in an accept alternative. 5886 5887 -- To expand the requeue statement, a label is provided at the end of the 5888 -- accept statement or alternative of which it is a part, so that the 5889 -- statement can be skipped after the requeue is complete. This label is 5890 -- created here rather than during the expansion of the accept statement, 5891 -- because it will be needed by any requeue statements within the accept, 5892 -- which are expanded before the accept. 5893 5894 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is 5895 Loc : constant Source_Ptr := Sloc (N); 5896 Stats : constant Node_Id := Handled_Statement_Sequence (N); 5897 Ann : Entity_Id := Empty; 5898 Adecl : Node_Id; 5899 Lab : Node_Id; 5900 Ldecl : Node_Id; 5901 Ldecl2 : Node_Id; 5902 5903 begin 5904 if Expander_Active then 5905 5906 -- If we have no handled statement sequence, we may need to build 5907 -- a dummy sequence consisting of a null statement. This can be 5908 -- skipped if the trivial accept optimization is permitted. 5909 5910 if not Trivial_Accept_OK 5911 and then 5912 (No (Stats) or else Null_Statements (Statements (Stats))) 5913 then 5914 Set_Handled_Statement_Sequence (N, 5915 Make_Handled_Sequence_Of_Statements (Loc, 5916 Statements => New_List (Make_Null_Statement (Loc)))); 5917 end if; 5918 5919 -- Create and declare two labels to be placed at the end of the 5920 -- accept statement. The first label is used to allow requeues to 5921 -- skip the remainder of entry processing. The second label is used 5922 -- to skip the remainder of entry processing if the rendezvous 5923 -- completes in the middle of the accept body. 5924 5925 if Present (Handled_Statement_Sequence (N)) then 5926 declare 5927 Ent : Entity_Id; 5928 5929 begin 5930 Ent := Make_Temporary (Loc, 'L'); 5931 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 5932 Ldecl := 5933 Make_Implicit_Label_Declaration (Loc, 5934 Defining_Identifier => Ent, 5935 Label_Construct => Lab); 5936 Append (Lab, Statements (Handled_Statement_Sequence (N))); 5937 5938 Ent := Make_Temporary (Loc, 'L'); 5939 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 5940 Ldecl2 := 5941 Make_Implicit_Label_Declaration (Loc, 5942 Defining_Identifier => Ent, 5943 Label_Construct => Lab); 5944 Append (Lab, Statements (Handled_Statement_Sequence (N))); 5945 end; 5946 5947 else 5948 Ldecl := Empty; 5949 Ldecl2 := Empty; 5950 end if; 5951 5952 -- Case of stand alone accept statement 5953 5954 if Is_List_Member (N) then 5955 5956 if Present (Handled_Statement_Sequence (N)) then 5957 Ann := Make_Temporary (Loc, 'A'); 5958 5959 Adecl := 5960 Make_Object_Declaration (Loc, 5961 Defining_Identifier => Ann, 5962 Object_Definition => 5963 New_Occurrence_Of (RTE (RE_Address), Loc)); 5964 5965 Insert_Before_And_Analyze (N, Adecl); 5966 Insert_Before_And_Analyze (N, Ldecl); 5967 Insert_Before_And_Analyze (N, Ldecl2); 5968 end if; 5969 5970 -- Case of accept statement which is in an accept alternative 5971 5972 else 5973 declare 5974 Acc_Alt : constant Node_Id := Parent (N); 5975 Sel_Acc : constant Node_Id := Parent (Acc_Alt); 5976 Alt : Node_Id; 5977 5978 begin 5979 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative); 5980 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept); 5981 5982 -- ??? Consider a single label for select statements 5983 5984 if Present (Handled_Statement_Sequence (N)) then 5985 Prepend (Ldecl2, 5986 Statements (Handled_Statement_Sequence (N))); 5987 Analyze (Ldecl2); 5988 5989 Prepend (Ldecl, 5990 Statements (Handled_Statement_Sequence (N))); 5991 Analyze (Ldecl); 5992 end if; 5993 5994 -- Find first accept alternative of the selective accept. A 5995 -- valid selective accept must have at least one accept in it. 5996 5997 Alt := First (Select_Alternatives (Sel_Acc)); 5998 5999 while Nkind (Alt) /= N_Accept_Alternative loop 6000 Next (Alt); 6001 end loop; 6002 6003 -- If this is the first accept statement, then we have to 6004 -- create the Ann variable, as for the stand alone case, except 6005 -- that it is inserted before the selective accept. Similarly, 6006 -- a label for requeue expansion must be declared. 6007 6008 if N = Accept_Statement (Alt) then 6009 Ann := Make_Temporary (Loc, 'A'); 6010 Adecl := 6011 Make_Object_Declaration (Loc, 6012 Defining_Identifier => Ann, 6013 Object_Definition => 6014 New_Occurrence_Of (RTE (RE_Address), Loc)); 6015 6016 Insert_Before_And_Analyze (Sel_Acc, Adecl); 6017 6018 -- If this is not the first accept statement, then find the Ann 6019 -- variable allocated by the first accept and use it. 6020 6021 else 6022 Ann := 6023 Node (Last_Elmt (Accept_Address 6024 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))))); 6025 end if; 6026 end; 6027 end if; 6028 6029 -- Merge here with Ann either created or referenced, and Adecl 6030 -- pointing to the corresponding declaration. Remaining processing 6031 -- is the same for the two cases. 6032 6033 if Present (Ann) then 6034 Append_Elmt (Ann, Accept_Address (Ent)); 6035 Set_Debug_Info_Needed (Ann); 6036 end if; 6037 6038 -- Create renaming declarations for the entry formals. Each reference 6039 -- to a formal becomes a dereference of a component of the parameter 6040 -- block, whose address is held in Ann. These declarations are 6041 -- eventually inserted into the accept block, and analyzed there so 6042 -- that they have the proper scope for gdb and do not conflict with 6043 -- other declarations. 6044 6045 if Present (Parameter_Specifications (N)) 6046 and then Present (Handled_Statement_Sequence (N)) 6047 then 6048 declare 6049 Comp : Entity_Id; 6050 Decl : Node_Id; 6051 Formal : Entity_Id; 6052 New_F : Entity_Id; 6053 Renamed_Formal : Node_Id; 6054 6055 begin 6056 Push_Scope (Ent); 6057 Formal := First_Formal (Ent); 6058 6059 while Present (Formal) loop 6060 Comp := Entry_Component (Formal); 6061 New_F := Make_Defining_Identifier (Loc, Chars (Formal)); 6062 6063 Set_Etype (New_F, Etype (Formal)); 6064 Set_Scope (New_F, Ent); 6065 6066 -- Now we set debug info needed on New_F even though it does 6067 -- not come from source, so that the debugger will get the 6068 -- right information for these generated names. 6069 6070 Set_Debug_Info_Needed (New_F); 6071 6072 if Ekind (Formal) = E_In_Parameter then 6073 Set_Ekind (New_F, E_Constant); 6074 else 6075 Set_Ekind (New_F, E_Variable); 6076 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 6077 end if; 6078 6079 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 6080 6081 Renamed_Formal := 6082 Make_Selected_Component (Loc, 6083 Prefix => 6084 Unchecked_Convert_To ( 6085 Entry_Parameters_Type (Ent), 6086 New_Occurrence_Of (Ann, Loc)), 6087 Selector_Name => 6088 New_Occurrence_Of (Comp, Loc)); 6089 6090 Decl := 6091 Build_Renamed_Formal_Declaration 6092 (New_F, Formal, Comp, Renamed_Formal); 6093 6094 if No (Declarations (N)) then 6095 Set_Declarations (N, New_List); 6096 end if; 6097 6098 Append (Decl, Declarations (N)); 6099 Set_Renamed_Object (Formal, New_F); 6100 Next_Formal (Formal); 6101 end loop; 6102 6103 End_Scope; 6104 end; 6105 end if; 6106 end if; 6107 end Expand_Accept_Declarations; 6108 6109 --------------------------------------------- 6110 -- Expand_Access_Protected_Subprogram_Type -- 6111 --------------------------------------------- 6112 6113 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is 6114 Loc : constant Source_Ptr := Sloc (N); 6115 Comps : List_Id; 6116 T : constant Entity_Id := Defining_Identifier (N); 6117 D_T : constant Entity_Id := Designated_Type (T); 6118 D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D'); 6119 E_T : constant Entity_Id := Make_Temporary (Loc, 'E'); 6120 P_List : constant List_Id := Build_Protected_Spec 6121 (N, RTE (RE_Address), D_T, False); 6122 Decl1 : Node_Id; 6123 Decl2 : Node_Id; 6124 Def1 : Node_Id; 6125 6126 begin 6127 -- Create access to subprogram with full signature 6128 6129 if Etype (D_T) /= Standard_Void_Type then 6130 Def1 := 6131 Make_Access_Function_Definition (Loc, 6132 Parameter_Specifications => P_List, 6133 Result_Definition => 6134 Copy_Result_Type (Result_Definition (Type_Definition (N)))); 6135 6136 else 6137 Def1 := 6138 Make_Access_Procedure_Definition (Loc, 6139 Parameter_Specifications => P_List); 6140 end if; 6141 6142 Decl1 := 6143 Make_Full_Type_Declaration (Loc, 6144 Defining_Identifier => D_T2, 6145 Type_Definition => Def1); 6146 6147 Insert_After_And_Analyze (N, Decl1); 6148 6149 -- Associate the access to subprogram with its original access to 6150 -- protected subprogram type. Needed by the backend to know that this 6151 -- type corresponds with an access to protected subprogram type. 6152 6153 Set_Original_Access_Type (D_T2, T); 6154 6155 -- Create Equivalent_Type, a record with two components for an access to 6156 -- object and an access to subprogram. 6157 6158 Comps := New_List ( 6159 Make_Component_Declaration (Loc, 6160 Defining_Identifier => Make_Temporary (Loc, 'P'), 6161 Component_Definition => 6162 Make_Component_Definition (Loc, 6163 Aliased_Present => False, 6164 Subtype_Indication => 6165 New_Occurrence_Of (RTE (RE_Address), Loc))), 6166 6167 Make_Component_Declaration (Loc, 6168 Defining_Identifier => Make_Temporary (Loc, 'S'), 6169 Component_Definition => 6170 Make_Component_Definition (Loc, 6171 Aliased_Present => False, 6172 Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); 6173 6174 Decl2 := 6175 Make_Full_Type_Declaration (Loc, 6176 Defining_Identifier => E_T, 6177 Type_Definition => 6178 Make_Record_Definition (Loc, 6179 Component_List => 6180 Make_Component_List (Loc, Component_Items => Comps))); 6181 6182 Insert_After_And_Analyze (Decl1, Decl2); 6183 Set_Equivalent_Type (T, E_T); 6184 end Expand_Access_Protected_Subprogram_Type; 6185 6186 -------------------------- 6187 -- Expand_Entry_Barrier -- 6188 -------------------------- 6189 6190 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is 6191 Cond : constant Node_Id := 6192 Condition (Entry_Body_Formal_Part (N)); 6193 Prot : constant Entity_Id := Scope (Ent); 6194 Spec_Decl : constant Node_Id := Parent (Prot); 6195 Func : Entity_Id; 6196 B_F : Node_Id; 6197 Body_Decl : Node_Id; 6198 6199 function Is_Global_Entity (N : Node_Id) return Traverse_Result; 6200 -- Check whether entity in Barrier is external to protected type. 6201 -- If so, barrier may not be properly synchronized. 6202 6203 ---------------------- 6204 -- Is_Global_Entity -- 6205 ---------------------- 6206 6207 function Is_Global_Entity (N : Node_Id) return Traverse_Result is 6208 E : Entity_Id; 6209 S : Entity_Id; 6210 6211 begin 6212 if Is_Entity_Name (N) and then Present (Entity (N)) then 6213 E := Entity (N); 6214 S := Scope (E); 6215 6216 if Ekind (E) = E_Variable then 6217 if Scope (E) = Func then 6218 null; 6219 6220 -- A protected call from a barrier to another object is ok 6221 6222 elsif Ekind (Etype (E)) = E_Protected_Type then 6223 null; 6224 6225 -- If the variable is within the package body we consider 6226 -- this safe. This is a common (if dubious) idiom. 6227 6228 elsif S = Scope (Prot) 6229 and then Ekind_In (S, E_Package, E_Generic_Package) 6230 and then Nkind (Parent (E)) = N_Object_Declaration 6231 and then Nkind (Parent (Parent (E))) = N_Package_Body 6232 then 6233 null; 6234 6235 else 6236 Error_Msg_N ("potentially unsynchronized barrier?", N); 6237 Error_Msg_N ("\& should be private component of type?", N); 6238 end if; 6239 end if; 6240 end if; 6241 6242 return OK; 6243 end Is_Global_Entity; 6244 6245 procedure Check_Unprotected_Barrier is 6246 new Traverse_Proc (Is_Global_Entity); 6247 6248 -- Start of processing for Expand_Entry_Barrier 6249 6250 begin 6251 if No_Run_Time_Mode then 6252 Error_Msg_CRT ("entry barrier", N); 6253 return; 6254 end if; 6255 6256 -- The body of the entry barrier must be analyzed in the context of the 6257 -- protected object, but its scope is external to it, just as any other 6258 -- unprotected version of a protected operation. The specification has 6259 -- been produced when the protected type declaration was elaborated. We 6260 -- build the body, insert it in the enclosing scope, but analyze it in 6261 -- the current context. A more uniform approach would be to treat the 6262 -- barrier just as a protected function, and discard the protected 6263 -- version of it because it is never called. 6264 6265 if Expander_Active then 6266 B_F := Build_Barrier_Function (N, Ent, Prot); 6267 Func := Barrier_Function (Ent); 6268 Set_Corresponding_Spec (B_F, Func); 6269 6270 Body_Decl := Parent (Corresponding_Body (Spec_Decl)); 6271 6272 if Nkind (Parent (Body_Decl)) = N_Subunit then 6273 Body_Decl := Corresponding_Stub (Parent (Body_Decl)); 6274 end if; 6275 6276 Insert_Before_And_Analyze (Body_Decl, B_F); 6277 6278 Set_Discriminals (Spec_Decl); 6279 Set_Scope (Func, Scope (Prot)); 6280 6281 else 6282 Analyze_And_Resolve (Cond, Any_Boolean); 6283 end if; 6284 6285 -- The Ravenscar profile restricts barriers to simple variables declared 6286 -- within the protected object. We also allow Boolean constants, since 6287 -- these appear in several published examples and are also allowed by 6288 -- other compilers. 6289 6290 -- Note that after analysis variables in this context will be replaced 6291 -- by the corresponding prival, that is to say a renaming of a selected 6292 -- component of the form _Object.Var. If expansion is disabled, as 6293 -- within a generic, we check that the entity appears in the current 6294 -- scope. 6295 6296 if Is_Entity_Name (Cond) then 6297 6298 -- A small optimization of useless renamings. If the scope of the 6299 -- entity of the condition is not the barrier function, then the 6300 -- condition does not reference any of the generated renamings 6301 -- within the function. 6302 6303 if Expander_Active and then Scope (Entity (Cond)) /= Func then 6304 Set_Declarations (B_F, Empty_List); 6305 end if; 6306 6307 if Entity (Cond) = Standard_False 6308 or else 6309 Entity (Cond) = Standard_True 6310 then 6311 return; 6312 6313 elsif not Expander_Active 6314 and then Scope (Entity (Cond)) = Current_Scope 6315 then 6316 return; 6317 6318 -- Check for case of _object.all.field (note that the explicit 6319 -- dereference gets inserted by analyze/expand of _object.field) 6320 6321 elsif Present (Renamed_Object (Entity (Cond))) 6322 and then 6323 Nkind (Renamed_Object (Entity (Cond))) = N_Selected_Component 6324 and then 6325 Chars 6326 (Prefix 6327 (Prefix (Renamed_Object (Entity (Cond))))) = Name_uObject 6328 then 6329 return; 6330 end if; 6331 end if; 6332 6333 -- It is not a boolean variable or literal, so check the restriction. 6334 -- Note that it is safe to be calling Check_Restriction from here, even 6335 -- though this is part of the expander, since Expand_Entry_Barrier is 6336 -- called from Sem_Ch9 even in -gnatc mode. 6337 6338 Check_Restriction (Simple_Barriers, Cond); 6339 6340 -- Emit warning if barrier contains global entities and is thus 6341 -- potentially unsynchronized. 6342 6343 Check_Unprotected_Barrier (Cond); 6344 end Expand_Entry_Barrier; 6345 6346 ------------------------------ 6347 -- Expand_N_Abort_Statement -- 6348 ------------------------------ 6349 6350 -- Expand abort T1, T2, .. Tn; into: 6351 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...)) 6352 6353 procedure Expand_N_Abort_Statement (N : Node_Id) is 6354 Loc : constant Source_Ptr := Sloc (N); 6355 Tlist : constant List_Id := Names (N); 6356 Count : Nat; 6357 Aggr : Node_Id; 6358 Tasknm : Node_Id; 6359 6360 begin 6361 Aggr := Make_Aggregate (Loc, Component_Associations => New_List); 6362 Count := 0; 6363 6364 Tasknm := First (Tlist); 6365 6366 while Present (Tasknm) loop 6367 Count := Count + 1; 6368 6369 -- A task interface class-wide type object is being aborted. Retrieve 6370 -- its _task_id by calling a dispatching routine. 6371 6372 if Ada_Version >= Ada_2005 6373 and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type 6374 and then Is_Interface (Etype (Tasknm)) 6375 and then Is_Task_Interface (Etype (Tasknm)) 6376 then 6377 Append_To (Component_Associations (Aggr), 6378 Make_Component_Association (Loc, 6379 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6380 Expression => 6381 6382 -- Task_Id (Tasknm._disp_get_task_id) 6383 6384 Make_Unchecked_Type_Conversion (Loc, 6385 Subtype_Mark => 6386 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 6387 Expression => 6388 Make_Selected_Component (Loc, 6389 Prefix => New_Copy_Tree (Tasknm), 6390 Selector_Name => 6391 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))); 6392 6393 else 6394 Append_To (Component_Associations (Aggr), 6395 Make_Component_Association (Loc, 6396 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6397 Expression => Concurrent_Ref (Tasknm))); 6398 end if; 6399 6400 Next (Tasknm); 6401 end loop; 6402 6403 Rewrite (N, 6404 Make_Procedure_Call_Statement (Loc, 6405 Name => New_Occurrence_Of (RTE (RE_Abort_Tasks), Loc), 6406 Parameter_Associations => New_List ( 6407 Make_Qualified_Expression (Loc, 6408 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_List), Loc), 6409 Expression => Aggr)))); 6410 6411 Analyze (N); 6412 end Expand_N_Abort_Statement; 6413 6414 ------------------------------- 6415 -- Expand_N_Accept_Statement -- 6416 ------------------------------- 6417 6418 -- This procedure handles expansion of accept statements that stand alone, 6419 -- i.e. they are not part of an accept alternative. The expansion of 6420 -- accept statement in accept alternatives is handled by the routines 6421 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The 6422 -- following description applies only to stand alone accept statements. 6423 6424 -- If there is no handled statement sequence, or only null statements, then 6425 -- this is called a trivial accept, and the expansion is: 6426 6427 -- Accept_Trivial (entry-index) 6428 6429 -- If there is a handled statement sequence, then the expansion is: 6430 6431 -- Ann : Address; 6432 -- {Lnn : Label} 6433 6434 -- begin 6435 -- begin 6436 -- Accept_Call (entry-index, Ann); 6437 -- Renaming_Declarations for formals 6438 -- <statement sequence from N_Accept_Statement node> 6439 -- Complete_Rendezvous; 6440 -- <<Lnn>> 6441 -- 6442 -- exception 6443 -- when ... => 6444 -- <exception handler from N_Accept_Statement node> 6445 -- Complete_Rendezvous; 6446 -- when ... => 6447 -- <exception handler from N_Accept_Statement node> 6448 -- Complete_Rendezvous; 6449 -- ... 6450 -- end; 6451 6452 -- exception 6453 -- when all others => 6454 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 6455 -- end; 6456 6457 -- The first three declarations were already inserted ahead of the accept 6458 -- statement by the Expand_Accept_Declarations procedure, which was called 6459 -- directly from the semantics during analysis of the accept statement, 6460 -- before analyzing its contained statements. 6461 6462 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come 6463 -- from possible expansion activity (the original source of course does 6464 -- not have any declarations associated with the accept statement, since 6465 -- an accept statement has no declarative part). In particular, if the 6466 -- expander is active, the first such declaration is the declaration of 6467 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement). 6468 6469 -- The two blocks are merged into a single block if the inner block has 6470 -- no exception handlers, but otherwise two blocks are required, since 6471 -- exceptions might be raised in the exception handlers of the inner 6472 -- block, and Exceptional_Complete_Rendezvous must be called. 6473 6474 procedure Expand_N_Accept_Statement (N : Node_Id) is 6475 Loc : constant Source_Ptr := Sloc (N); 6476 Stats : constant Node_Id := Handled_Statement_Sequence (N); 6477 Ename : constant Node_Id := Entry_Direct_Name (N); 6478 Eindx : constant Node_Id := Entry_Index (N); 6479 Eent : constant Entity_Id := Entity (Ename); 6480 Acstack : constant Elist_Id := Accept_Address (Eent); 6481 Ann : constant Entity_Id := Node (Last_Elmt (Acstack)); 6482 Ttyp : constant Entity_Id := Etype (Scope (Eent)); 6483 Blkent : Entity_Id; 6484 Call : Node_Id; 6485 Block : Node_Id; 6486 6487 begin 6488 -- If the accept statement is not part of a list, then its parent must 6489 -- be an accept alternative, and, as described above, we do not do any 6490 -- expansion for such accept statements at this level. 6491 6492 if not Is_List_Member (N) then 6493 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative); 6494 return; 6495 6496 -- Trivial accept case (no statement sequence, or null statements). 6497 -- If the accept statement has declarations, then just insert them 6498 -- before the procedure call. 6499 6500 elsif Trivial_Accept_OK 6501 and then (No (Stats) or else Null_Statements (Statements (Stats))) 6502 then 6503 -- Remove declarations for renamings, because the parameter block 6504 -- will not be assigned. 6505 6506 declare 6507 D : Node_Id; 6508 Next_D : Node_Id; 6509 6510 begin 6511 D := First (Declarations (N)); 6512 while Present (D) loop 6513 Next_D := Next (D); 6514 if Nkind (D) = N_Object_Renaming_Declaration then 6515 Remove (D); 6516 end if; 6517 6518 D := Next_D; 6519 end loop; 6520 end; 6521 6522 if Present (Declarations (N)) then 6523 Insert_Actions (N, Declarations (N)); 6524 end if; 6525 6526 Rewrite (N, 6527 Make_Procedure_Call_Statement (Loc, 6528 Name => New_Occurrence_Of (RTE (RE_Accept_Trivial), Loc), 6529 Parameter_Associations => New_List ( 6530 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp)))); 6531 6532 Analyze (N); 6533 6534 -- Discard Entry_Address that was created for it, so it will not be 6535 -- emitted if this accept statement is in the statement part of a 6536 -- delay alternative. 6537 6538 if Present (Stats) then 6539 Remove_Last_Elmt (Acstack); 6540 end if; 6541 6542 -- Case of statement sequence present 6543 6544 else 6545 -- Construct the block, using the declarations from the accept 6546 -- statement if any to initialize the declarations of the block. 6547 6548 Blkent := Make_Temporary (Loc, 'A'); 6549 Set_Ekind (Blkent, E_Block); 6550 Set_Etype (Blkent, Standard_Void_Type); 6551 Set_Scope (Blkent, Current_Scope); 6552 6553 Block := 6554 Make_Block_Statement (Loc, 6555 Identifier => New_Occurrence_Of (Blkent, Loc), 6556 Declarations => Declarations (N), 6557 Handled_Statement_Sequence => Build_Accept_Body (N)); 6558 6559 -- For the analysis of the generated declarations, the parent node 6560 -- must be properly set. 6561 6562 Set_Parent (Block, Parent (N)); 6563 6564 -- Prepend call to Accept_Call to main statement sequence If the 6565 -- accept has exception handlers, the statement sequence is wrapped 6566 -- in a block. Insert call and renaming declarations in the 6567 -- declarations of the block, so they are elaborated before the 6568 -- handlers. 6569 6570 Call := 6571 Make_Procedure_Call_Statement (Loc, 6572 Name => New_Occurrence_Of (RTE (RE_Accept_Call), Loc), 6573 Parameter_Associations => New_List ( 6574 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp), 6575 New_Occurrence_Of (Ann, Loc))); 6576 6577 if Parent (Stats) = N then 6578 Prepend (Call, Statements (Stats)); 6579 else 6580 Set_Declarations (Parent (Stats), New_List (Call)); 6581 end if; 6582 6583 Analyze (Call); 6584 6585 Push_Scope (Blkent); 6586 6587 declare 6588 D : Node_Id; 6589 Next_D : Node_Id; 6590 Typ : Entity_Id; 6591 6592 begin 6593 D := First (Declarations (N)); 6594 while Present (D) loop 6595 Next_D := Next (D); 6596 6597 if Nkind (D) = N_Object_Renaming_Declaration then 6598 6599 -- The renaming declarations for the formals were created 6600 -- during analysis of the accept statement, and attached to 6601 -- the list of declarations. Place them now in the context 6602 -- of the accept block or subprogram. 6603 6604 Remove (D); 6605 Typ := Entity (Subtype_Mark (D)); 6606 Insert_After (Call, D); 6607 Analyze (D); 6608 6609 -- If the formal is class_wide, it does not have an actual 6610 -- subtype. The analysis of the renaming declaration creates 6611 -- one, but we need to retain the class-wide nature of the 6612 -- entity. 6613 6614 if Is_Class_Wide_Type (Typ) then 6615 Set_Etype (Defining_Identifier (D), Typ); 6616 end if; 6617 6618 end if; 6619 6620 D := Next_D; 6621 end loop; 6622 end; 6623 6624 End_Scope; 6625 6626 -- Replace the accept statement by the new block 6627 6628 Rewrite (N, Block); 6629 Analyze (N); 6630 6631 -- Last step is to unstack the Accept_Address value 6632 6633 Remove_Last_Elmt (Acstack); 6634 end if; 6635 end Expand_N_Accept_Statement; 6636 6637 ---------------------------------- 6638 -- Expand_N_Asynchronous_Select -- 6639 ---------------------------------- 6640 6641 -- This procedure assumes that the trigger statement is an entry call or 6642 -- a dispatching procedure call. A delay alternative should already have 6643 -- been expanded into an entry call to the appropriate delay object Wait 6644 -- entry. 6645 6646 -- If the trigger is a task entry call, the select is implemented with 6647 -- a Task_Entry_Call: 6648 6649 -- declare 6650 -- B : Boolean; 6651 -- C : Boolean; 6652 -- P : parms := (parm, parm, parm); 6653 6654 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6655 6656 -- procedure _clean is 6657 -- begin 6658 -- ... 6659 -- Cancel_Task_Entry_Call (C); 6660 -- ... 6661 -- end _clean; 6662 6663 -- begin 6664 -- Abort_Defer; 6665 -- Task_Entry_Call 6666 -- (<acceptor-task>, -- Acceptor 6667 -- <entry-index>, -- E 6668 -- P'Address, -- Uninterpreted_Data 6669 -- Asynchronous_Call, -- Mode 6670 -- B); -- Rendezvous_Successful 6671 6672 -- begin 6673 -- begin 6674 -- Abort_Undefer; 6675 -- <abortable-part> 6676 -- at end 6677 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6678 -- end; 6679 -- exception 6680 -- when Abort_Signal => Abort_Undefer; 6681 -- end; 6682 6683 -- parm := P.param; 6684 -- parm := P.param; 6685 -- ... 6686 -- if not C then 6687 -- <triggered-statements> 6688 -- end if; 6689 -- end; 6690 6691 -- Note that Build_Simple_Entry_Call is used to expand the entry of the 6692 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure) 6693 -- as follows: 6694 6695 -- declare 6696 -- P : parms := (parm, parm, parm); 6697 -- begin 6698 -- Call_Simple (acceptor-task, entry-index, P'Address); 6699 -- parm := P.param; 6700 -- parm := P.param; 6701 -- ... 6702 -- end; 6703 6704 -- so the task at hand is to convert the latter expansion into the former 6705 6706 -- If the trigger is a protected entry call, the select is implemented 6707 -- with Protected_Entry_Call: 6708 6709 -- declare 6710 -- P : E1_Params := (param, param, param); 6711 -- Bnn : Communications_Block; 6712 6713 -- begin 6714 -- declare 6715 6716 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6717 6718 -- procedure _clean is 6719 -- begin 6720 -- ... 6721 -- if Enqueued (Bnn) then 6722 -- Cancel_Protected_Entry_Call (Bnn); 6723 -- end if; 6724 -- ... 6725 -- end _clean; 6726 6727 -- begin 6728 -- begin 6729 -- Protected_Entry_Call 6730 -- (po._object'Access, -- Object 6731 -- <entry index>, -- E 6732 -- P'Address, -- Uninterpreted_Data 6733 -- Asynchronous_Call, -- Mode 6734 -- Bnn); -- Block 6735 6736 -- if Enqueued (Bnn) then 6737 -- <abortable-part> 6738 -- end if; 6739 -- at end 6740 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6741 -- end; 6742 -- exception 6743 -- when Abort_Signal => Abort_Undefer; 6744 -- end; 6745 6746 -- if not Cancelled (Bnn) then 6747 -- <triggered-statements> 6748 -- end if; 6749 -- end; 6750 6751 -- Build_Simple_Entry_Call is used to expand the all to a simple protected 6752 -- entry call: 6753 6754 -- declare 6755 -- P : E1_Params := (param, param, param); 6756 -- Bnn : Communications_Block; 6757 6758 -- begin 6759 -- Protected_Entry_Call 6760 -- (po._object'Access, -- Object 6761 -- <entry index>, -- E 6762 -- P'Address, -- Uninterpreted_Data 6763 -- Simple_Call, -- Mode 6764 -- Bnn); -- Block 6765 -- parm := P.param; 6766 -- parm := P.param; 6767 -- ... 6768 -- end; 6769 6770 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is 6771 -- expanded into: 6772 6773 -- declare 6774 -- B : Boolean := False; 6775 -- Bnn : Communication_Block; 6776 -- C : Ada.Tags.Prim_Op_Kind; 6777 -- D : System.Storage_Elements.Dummy_Communication_Block; 6778 -- K : Ada.Tags.Tagged_Kind := 6779 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 6780 -- P : Parameters := (Param1 .. ParamN); 6781 -- S : Integer; 6782 -- U : Boolean; 6783 6784 -- begin 6785 -- if K = Ada.Tags.TK_Limited_Tagged 6786 -- or else K = Ada.Tags.TK_Tagged 6787 -- then 6788 -- <dispatching-call>; 6789 -- <triggering-statements>; 6790 6791 -- else 6792 -- S := 6793 -- Ada.Tags.Get_Offset_Index 6794 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 6795 6796 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 6797 6798 -- if C = POK_Protected_Entry then 6799 -- declare 6800 -- procedure _clean is 6801 -- begin 6802 -- if Enqueued (Bnn) then 6803 -- Cancel_Protected_Entry_Call (Bnn); 6804 -- end if; 6805 -- end _clean; 6806 6807 -- begin 6808 -- begin 6809 -- _Disp_Asynchronous_Select 6810 -- (<object>, S, P'Address, D, B); 6811 -- Bnn := Communication_Block (D); 6812 6813 -- Param1 := P.Param1; 6814 -- ... 6815 -- ParamN := P.ParamN; 6816 6817 -- if Enqueued (Bnn) then 6818 -- <abortable-statements> 6819 -- end if; 6820 -- at end 6821 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6822 -- end; 6823 -- exception 6824 -- when Abort_Signal => Abort_Undefer; 6825 -- end; 6826 6827 -- if not Cancelled (Bnn) then 6828 -- <triggering-statements> 6829 -- end if; 6830 6831 -- elsif C = POK_Task_Entry then 6832 -- declare 6833 -- procedure _clean is 6834 -- begin 6835 -- Cancel_Task_Entry_Call (U); 6836 -- end _clean; 6837 6838 -- begin 6839 -- Abort_Defer; 6840 6841 -- _Disp_Asynchronous_Select 6842 -- (<object>, S, P'Address, D, B); 6843 -- Bnn := Communication_Bloc (D); 6844 6845 -- Param1 := P.Param1; 6846 -- ... 6847 -- ParamN := P.ParamN; 6848 6849 -- begin 6850 -- begin 6851 -- Abort_Undefer; 6852 -- <abortable-statements> 6853 -- at end 6854 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6855 -- end; 6856 -- exception 6857 -- when Abort_Signal => Abort_Undefer; 6858 -- end; 6859 6860 -- if not U then 6861 -- <triggering-statements> 6862 -- end if; 6863 -- end; 6864 6865 -- else 6866 -- <dispatching-call>; 6867 -- <triggering-statements> 6868 -- end if; 6869 -- end if; 6870 -- end; 6871 6872 -- The job is to convert this to the asynchronous form 6873 6874 -- If the trigger is a delay statement, it will have been expanded into 6875 -- a call to one of the GNARL delay procedures. This routine will convert 6876 -- this into a protected entry call on a delay object and then continue 6877 -- processing as for a protected entry call trigger. This requires 6878 -- declaring a Delay_Block object and adding a pointer to this object to 6879 -- the parameter list of the delay procedure to form the parameter list of 6880 -- the entry call. This object is used by the runtime to queue the delay 6881 -- request. 6882 6883 -- For a description of the use of P and the assignments after the call, 6884 -- see Expand_N_Entry_Call_Statement. 6885 6886 procedure Expand_N_Asynchronous_Select (N : Node_Id) is 6887 Loc : constant Source_Ptr := Sloc (N); 6888 Abrt : constant Node_Id := Abortable_Part (N); 6889 Trig : constant Node_Id := Triggering_Alternative (N); 6890 6891 Abort_Block_Ent : Entity_Id; 6892 Abortable_Block : Node_Id; 6893 Actuals : List_Id; 6894 Astats : List_Id; 6895 Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A'); 6896 Blk_Typ : Entity_Id; 6897 Call : Node_Id; 6898 Call_Ent : Entity_Id; 6899 Cancel_Param : Entity_Id; 6900 Cleanup_Block : Node_Id; 6901 Cleanup_Block_Ent : Entity_Id; 6902 Cleanup_Stmts : List_Id; 6903 Conc_Typ_Stmts : List_Id; 6904 Concval : Node_Id; 6905 Dblock_Ent : Entity_Id; 6906 Decl : Node_Id; 6907 Decls : List_Id; 6908 Ecall : Node_Id; 6909 Ename : Node_Id; 6910 Enqueue_Call : Node_Id; 6911 Formals : List_Id; 6912 Hdle : List_Id; 6913 Handler_Stmt : Node_Id; 6914 Index : Node_Id; 6915 Lim_Typ_Stmts : List_Id; 6916 N_Orig : Node_Id; 6917 Obj : Entity_Id; 6918 Param : Node_Id; 6919 Params : List_Id; 6920 Pdef : Entity_Id; 6921 ProtE_Stmts : List_Id; 6922 ProtP_Stmts : List_Id; 6923 Stmt : Node_Id; 6924 Stmts : List_Id; 6925 TaskE_Stmts : List_Id; 6926 Tstats : List_Id; 6927 6928 B : Entity_Id; -- Call status flag 6929 Bnn : Entity_Id; -- Communication block 6930 C : Entity_Id; -- Call kind 6931 K : Entity_Id; -- Tagged kind 6932 P : Entity_Id; -- Parameter block 6933 S : Entity_Id; -- Primitive operation slot 6934 T : Entity_Id; -- Additional status flag 6935 6936 procedure Rewrite_Abortable_Part; 6937 -- If the trigger is a dispatching call, the expansion inserts multiple 6938 -- copies of the abortable part. This is both inefficient, and may lead 6939 -- to duplicate definitions that the back-end will reject, when the 6940 -- abortable part includes loops. This procedure rewrites the abortable 6941 -- part into a call to a generated procedure. 6942 6943 ---------------------------- 6944 -- Rewrite_Abortable_Part -- 6945 ---------------------------- 6946 6947 procedure Rewrite_Abortable_Part is 6948 Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 6949 Decl : Node_Id; 6950 6951 begin 6952 Decl := 6953 Make_Subprogram_Body (Loc, 6954 Specification => 6955 Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc), 6956 Declarations => New_List, 6957 Handled_Statement_Sequence => 6958 Make_Handled_Sequence_Of_Statements (Loc, Astats)); 6959 Insert_Before (N, Decl); 6960 Analyze (Decl); 6961 6962 -- Rewrite abortable part into a call to this procedure. 6963 6964 Astats := 6965 New_List ( 6966 Make_Procedure_Call_Statement (Loc, 6967 Name => New_Occurrence_Of (Proc, Loc))); 6968 end Rewrite_Abortable_Part; 6969 6970 begin 6971 Process_Statements_For_Controlled_Objects (Trig); 6972 Process_Statements_For_Controlled_Objects (Abrt); 6973 6974 Ecall := Triggering_Statement (Trig); 6975 6976 Ensure_Statement_Present (Sloc (Ecall), Trig); 6977 6978 -- Retrieve Astats and Tstats now because the finalization machinery may 6979 -- wrap them in blocks. 6980 6981 Astats := Statements (Abrt); 6982 Tstats := Statements (Trig); 6983 6984 -- The arguments in the call may require dynamic allocation, and the 6985 -- call statement may have been transformed into a block. The block 6986 -- may contain additional declarations for internal entities, and the 6987 -- original call is found by sequential search. 6988 6989 if Nkind (Ecall) = N_Block_Statement then 6990 Ecall := First (Statements (Handled_Statement_Sequence (Ecall))); 6991 while not Nkind_In (Ecall, N_Procedure_Call_Statement, 6992 N_Entry_Call_Statement) 6993 loop 6994 Next (Ecall); 6995 end loop; 6996 end if; 6997 6998 -- This is either a dispatching call or a delay statement used as a 6999 -- trigger which was expanded into a procedure call. 7000 7001 if Nkind (Ecall) = N_Procedure_Call_Statement then 7002 if Ada_Version >= Ada_2005 7003 and then 7004 (No (Original_Node (Ecall)) 7005 or else not Nkind_In (Original_Node (Ecall), 7006 N_Delay_Relative_Statement, 7007 N_Delay_Until_Statement)) 7008 then 7009 Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals); 7010 7011 Rewrite_Abortable_Part; 7012 Decls := New_List; 7013 Stmts := New_List; 7014 7015 -- Call status flag processing, generate: 7016 -- B : Boolean := False; 7017 7018 B := Build_B (Loc, Decls); 7019 7020 -- Communication block processing, generate: 7021 -- Bnn : Communication_Block; 7022 7023 Bnn := Make_Temporary (Loc, 'B'); 7024 Append_To (Decls, 7025 Make_Object_Declaration (Loc, 7026 Defining_Identifier => Bnn, 7027 Object_Definition => 7028 New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); 7029 7030 -- Call kind processing, generate: 7031 -- C : Ada.Tags.Prim_Op_Kind; 7032 7033 C := Build_C (Loc, Decls); 7034 7035 -- Tagged kind processing, generate: 7036 -- K : Ada.Tags.Tagged_Kind := 7037 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7038 7039 -- Dummy communication block, generate: 7040 -- D : Dummy_Communication_Block; 7041 7042 Append_To (Decls, 7043 Make_Object_Declaration (Loc, 7044 Defining_Identifier => 7045 Make_Defining_Identifier (Loc, Name_uD), 7046 Object_Definition => 7047 New_Occurrence_Of 7048 (RTE (RE_Dummy_Communication_Block), Loc))); 7049 7050 K := Build_K (Loc, Decls, Obj); 7051 7052 -- Parameter block processing 7053 7054 Blk_Typ := Build_Parameter_Block 7055 (Loc, Actuals, Formals, Decls); 7056 P := Parameter_Block_Pack 7057 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 7058 7059 -- Dispatch table slot processing, generate: 7060 -- S : Integer; 7061 7062 S := Build_S (Loc, Decls); 7063 7064 -- Additional status flag processing, generate: 7065 -- Tnn : Boolean; 7066 7067 T := Make_Temporary (Loc, 'T'); 7068 Append_To (Decls, 7069 Make_Object_Declaration (Loc, 7070 Defining_Identifier => T, 7071 Object_Definition => 7072 New_Occurrence_Of (Standard_Boolean, Loc))); 7073 7074 ------------------------------ 7075 -- Protected entry handling -- 7076 ------------------------------ 7077 7078 -- Generate: 7079 -- Param1 := P.Param1; 7080 -- ... 7081 -- ParamN := P.ParamN; 7082 7083 Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7084 7085 -- Generate: 7086 -- Bnn := Communication_Block (D); 7087 7088 Prepend_To (Cleanup_Stmts, 7089 Make_Assignment_Statement (Loc, 7090 Name => New_Occurrence_Of (Bnn, Loc), 7091 Expression => 7092 Make_Unchecked_Type_Conversion (Loc, 7093 Subtype_Mark => 7094 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7095 Expression => Make_Identifier (Loc, Name_uD)))); 7096 7097 -- Generate: 7098 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7099 7100 Prepend_To (Cleanup_Stmts, 7101 Make_Procedure_Call_Statement (Loc, 7102 Name => 7103 New_Occurrence_Of 7104 (Find_Prim_Op 7105 (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select), 7106 Loc), 7107 Parameter_Associations => 7108 New_List ( 7109 New_Copy_Tree (Obj), -- <object> 7110 New_Occurrence_Of (S, Loc), -- S 7111 Make_Attribute_Reference (Loc, -- P'Address 7112 Prefix => New_Occurrence_Of (P, Loc), 7113 Attribute_Name => Name_Address), 7114 Make_Identifier (Loc, Name_uD), -- D 7115 New_Occurrence_Of (B, Loc)))); -- B 7116 7117 -- Generate: 7118 -- if Enqueued (Bnn) then 7119 -- <abortable-statements> 7120 -- end if; 7121 7122 Append_To (Cleanup_Stmts, 7123 Make_Implicit_If_Statement (N, 7124 Condition => 7125 Make_Function_Call (Loc, 7126 Name => 7127 New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7128 Parameter_Associations => 7129 New_List (New_Occurrence_Of (Bnn, Loc))), 7130 7131 Then_Statements => 7132 New_Copy_List_Tree (Astats))); 7133 7134 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7135 -- will then generate a _clean for the communication block Bnn. 7136 7137 -- Generate: 7138 -- declare 7139 -- procedure _clean is 7140 -- begin 7141 -- if Enqueued (Bnn) then 7142 -- Cancel_Protected_Entry_Call (Bnn); 7143 -- end if; 7144 -- end _clean; 7145 -- begin 7146 -- Cleanup_Stmts 7147 -- at end 7148 -- _clean; 7149 -- end; 7150 7151 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7152 Cleanup_Block := 7153 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn); 7154 7155 -- Wrap the cleanup block in an exception handling block 7156 7157 -- Generate: 7158 -- begin 7159 -- Cleanup_Block 7160 -- exception 7161 -- when Abort_Signal => Abort_Undefer; 7162 -- end; 7163 7164 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7165 ProtE_Stmts := 7166 New_List ( 7167 Make_Implicit_Label_Declaration (Loc, 7168 Defining_Identifier => Abort_Block_Ent), 7169 7170 Build_Abort_Block 7171 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7172 7173 -- Generate: 7174 -- if not Cancelled (Bnn) then 7175 -- <triggering-statements> 7176 -- end if; 7177 7178 Append_To (ProtE_Stmts, 7179 Make_Implicit_If_Statement (N, 7180 Condition => 7181 Make_Op_Not (Loc, 7182 Right_Opnd => 7183 Make_Function_Call (Loc, 7184 Name => 7185 New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7186 Parameter_Associations => 7187 New_List (New_Occurrence_Of (Bnn, Loc)))), 7188 7189 Then_Statements => 7190 New_Copy_List_Tree (Tstats))); 7191 7192 ------------------------- 7193 -- Task entry handling -- 7194 ------------------------- 7195 7196 -- Generate: 7197 -- Param1 := P.Param1; 7198 -- ... 7199 -- ParamN := P.ParamN; 7200 7201 TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7202 7203 -- Generate: 7204 -- Bnn := Communication_Block (D); 7205 7206 Append_To (TaskE_Stmts, 7207 Make_Assignment_Statement (Loc, 7208 Name => 7209 New_Occurrence_Of (Bnn, Loc), 7210 Expression => 7211 Make_Unchecked_Type_Conversion (Loc, 7212 Subtype_Mark => 7213 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7214 Expression => Make_Identifier (Loc, Name_uD)))); 7215 7216 -- Generate: 7217 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7218 7219 Prepend_To (TaskE_Stmts, 7220 Make_Procedure_Call_Statement (Loc, 7221 Name => 7222 New_Occurrence_Of ( 7223 Find_Prim_Op (Etype (Etype (Obj)), 7224 Name_uDisp_Asynchronous_Select), 7225 Loc), 7226 7227 Parameter_Associations => 7228 New_List ( 7229 New_Copy_Tree (Obj), -- <object> 7230 New_Occurrence_Of (S, Loc), -- S 7231 Make_Attribute_Reference (Loc, -- P'Address 7232 Prefix => New_Occurrence_Of (P, Loc), 7233 Attribute_Name => Name_Address), 7234 Make_Identifier (Loc, Name_uD), -- D 7235 New_Occurrence_Of (B, Loc)))); -- B 7236 7237 -- Generate: 7238 -- Abort_Defer; 7239 7240 Prepend_To (TaskE_Stmts, 7241 Make_Procedure_Call_Statement (Loc, 7242 Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc), 7243 Parameter_Associations => No_List)); 7244 7245 -- Generate: 7246 -- Abort_Undefer; 7247 -- <abortable-statements> 7248 7249 Cleanup_Stmts := New_Copy_List_Tree (Astats); 7250 7251 Prepend_To (Cleanup_Stmts, 7252 Make_Procedure_Call_Statement (Loc, 7253 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), 7254 Parameter_Associations => No_List)); 7255 7256 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7257 -- will generate a _clean for the additional status flag. 7258 7259 -- Generate: 7260 -- declare 7261 -- procedure _clean is 7262 -- begin 7263 -- Cancel_Task_Entry_Call (U); 7264 -- end _clean; 7265 -- begin 7266 -- Cleanup_Stmts 7267 -- at end 7268 -- _clean; 7269 -- end; 7270 7271 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7272 Cleanup_Block := 7273 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T); 7274 7275 -- Wrap the cleanup block in an exception handling block 7276 7277 -- Generate: 7278 -- begin 7279 -- Cleanup_Block 7280 -- exception 7281 -- when Abort_Signal => Abort_Undefer; 7282 -- end; 7283 7284 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7285 7286 Append_To (TaskE_Stmts, 7287 Make_Implicit_Label_Declaration (Loc, 7288 Defining_Identifier => Abort_Block_Ent)); 7289 7290 Append_To (TaskE_Stmts, 7291 Build_Abort_Block 7292 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7293 7294 -- Generate: 7295 -- if not T then 7296 -- <triggering-statements> 7297 -- end if; 7298 7299 Append_To (TaskE_Stmts, 7300 Make_Implicit_If_Statement (N, 7301 Condition => 7302 Make_Op_Not (Loc, Right_Opnd => New_Occurrence_Of (T, Loc)), 7303 7304 Then_Statements => 7305 New_Copy_List_Tree (Tstats))); 7306 7307 ---------------------------------- 7308 -- Protected procedure handling -- 7309 ---------------------------------- 7310 7311 -- Generate: 7312 -- <dispatching-call>; 7313 -- <triggering-statements> 7314 7315 ProtP_Stmts := New_Copy_List_Tree (Tstats); 7316 Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall)); 7317 7318 -- Generate: 7319 -- S := Ada.Tags.Get_Offset_Index 7320 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 7321 7322 Conc_Typ_Stmts := 7323 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 7324 7325 -- Generate: 7326 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 7327 7328 Append_To (Conc_Typ_Stmts, 7329 Make_Procedure_Call_Statement (Loc, 7330 Name => 7331 New_Occurrence_Of 7332 (Find_Prim_Op (Etype (Etype (Obj)), 7333 Name_uDisp_Get_Prim_Op_Kind), 7334 Loc), 7335 Parameter_Associations => 7336 New_List ( 7337 New_Copy_Tree (Obj), 7338 New_Occurrence_Of (S, Loc), 7339 New_Occurrence_Of (C, Loc)))); 7340 7341 -- Generate: 7342 -- if C = POK_Procedure_Entry then 7343 -- ProtE_Stmts 7344 -- elsif C = POK_Task_Entry then 7345 -- TaskE_Stmts 7346 -- else 7347 -- ProtP_Stmts 7348 -- end if; 7349 7350 Append_To (Conc_Typ_Stmts, 7351 Make_Implicit_If_Statement (N, 7352 Condition => 7353 Make_Op_Eq (Loc, 7354 Left_Opnd => 7355 New_Occurrence_Of (C, Loc), 7356 Right_Opnd => 7357 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 7358 7359 Then_Statements => 7360 ProtE_Stmts, 7361 7362 Elsif_Parts => 7363 New_List ( 7364 Make_Elsif_Part (Loc, 7365 Condition => 7366 Make_Op_Eq (Loc, 7367 Left_Opnd => 7368 New_Occurrence_Of (C, Loc), 7369 Right_Opnd => 7370 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc)), 7371 7372 Then_Statements => 7373 TaskE_Stmts)), 7374 7375 Else_Statements => 7376 ProtP_Stmts)); 7377 7378 -- Generate: 7379 -- <dispatching-call>; 7380 -- <triggering-statements> 7381 7382 Lim_Typ_Stmts := New_Copy_List_Tree (Tstats); 7383 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall)); 7384 7385 -- Generate: 7386 -- if K = Ada.Tags.TK_Limited_Tagged 7387 -- or else K = Ada.Tags.TK_Tagged 7388 -- then 7389 -- Lim_Typ_Stmts 7390 -- else 7391 -- Conc_Typ_Stmts 7392 -- end if; 7393 7394 Append_To (Stmts, 7395 Make_Implicit_If_Statement (N, 7396 Condition => Build_Dispatching_Tag_Check (K, N), 7397 Then_Statements => Lim_Typ_Stmts, 7398 Else_Statements => Conc_Typ_Stmts)); 7399 7400 Rewrite (N, 7401 Make_Block_Statement (Loc, 7402 Declarations => 7403 Decls, 7404 Handled_Statement_Sequence => 7405 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7406 7407 Analyze (N); 7408 return; 7409 7410 -- Delay triggering statement processing 7411 7412 else 7413 -- Add a Delay_Block object to the parameter list of the delay 7414 -- procedure to form the parameter list of the Wait entry call. 7415 7416 Dblock_Ent := Make_Temporary (Loc, 'D'); 7417 7418 Pdef := Entity (Name (Ecall)); 7419 7420 if Is_RTE (Pdef, RO_CA_Delay_For) then 7421 Enqueue_Call := 7422 New_Occurrence_Of (RTE (RE_Enqueue_Duration), Loc); 7423 7424 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then 7425 Enqueue_Call := 7426 New_Occurrence_Of (RTE (RE_Enqueue_Calendar), Loc); 7427 7428 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); 7429 Enqueue_Call := New_Occurrence_Of (RTE (RE_Enqueue_RT), Loc); 7430 end if; 7431 7432 Append_To (Parameter_Associations (Ecall), 7433 Make_Attribute_Reference (Loc, 7434 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7435 Attribute_Name => Name_Unchecked_Access)); 7436 7437 -- Create the inner block to protect the abortable part 7438 7439 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7440 7441 Prepend_To (Astats, 7442 Make_Procedure_Call_Statement (Loc, 7443 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc))); 7444 7445 Abortable_Block := 7446 Make_Block_Statement (Loc, 7447 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7448 Handled_Statement_Sequence => 7449 Make_Handled_Sequence_Of_Statements (Loc, 7450 Statements => Astats), 7451 Has_Created_Identifier => True, 7452 Is_Asynchronous_Call_Block => True); 7453 7454 -- Append call to if Enqueue (When, DB'Unchecked_Access) then 7455 7456 Rewrite (Ecall, 7457 Make_Implicit_If_Statement (N, 7458 Condition => 7459 Make_Function_Call (Loc, 7460 Name => Enqueue_Call, 7461 Parameter_Associations => Parameter_Associations (Ecall)), 7462 Then_Statements => 7463 New_List (Make_Block_Statement (Loc, 7464 Handled_Statement_Sequence => 7465 Make_Handled_Sequence_Of_Statements (Loc, 7466 Statements => New_List ( 7467 Make_Implicit_Label_Declaration (Loc, 7468 Defining_Identifier => Blk_Ent, 7469 Label_Construct => Abortable_Block), 7470 Abortable_Block), 7471 Exception_Handlers => Hdle))))); 7472 7473 Stmts := New_List (Ecall); 7474 7475 -- Construct statement sequence for new block 7476 7477 Append_To (Stmts, 7478 Make_Implicit_If_Statement (N, 7479 Condition => 7480 Make_Function_Call (Loc, 7481 Name => New_Occurrence_Of ( 7482 RTE (RE_Timed_Out), Loc), 7483 Parameter_Associations => New_List ( 7484 Make_Attribute_Reference (Loc, 7485 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7486 Attribute_Name => Name_Unchecked_Access))), 7487 Then_Statements => Tstats)); 7488 7489 -- The result is the new block 7490 7491 Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent); 7492 7493 Rewrite (N, 7494 Make_Block_Statement (Loc, 7495 Declarations => New_List ( 7496 Make_Object_Declaration (Loc, 7497 Defining_Identifier => Dblock_Ent, 7498 Aliased_Present => True, 7499 Object_Definition => 7500 New_Occurrence_Of (RTE (RE_Delay_Block), Loc))), 7501 7502 Handled_Statement_Sequence => 7503 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7504 7505 Analyze (N); 7506 return; 7507 end if; 7508 7509 else 7510 N_Orig := N; 7511 end if; 7512 7513 Extract_Entry (Ecall, Concval, Ename, Index); 7514 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index); 7515 7516 Stmts := Statements (Handled_Statement_Sequence (Ecall)); 7517 Decls := Declarations (Ecall); 7518 7519 if Is_Protected_Type (Etype (Concval)) then 7520 7521 -- Get the declarations of the block expanded from the entry call 7522 7523 Decl := First (Decls); 7524 while Present (Decl) 7525 and then (Nkind (Decl) /= N_Object_Declaration 7526 or else not Is_RTE (Etype (Object_Definition (Decl)), 7527 RE_Communication_Block)) 7528 loop 7529 Next (Decl); 7530 end loop; 7531 7532 pragma Assert (Present (Decl)); 7533 Cancel_Param := Defining_Identifier (Decl); 7534 7535 -- Change the mode of the Protected_Entry_Call call 7536 7537 -- Protected_Entry_Call ( 7538 -- Object => po._object'Access, 7539 -- E => <entry index>; 7540 -- Uninterpreted_Data => P'Address; 7541 -- Mode => Asynchronous_Call; 7542 -- Block => Bnn); 7543 7544 -- Skip assignments to temporaries created for in-out parameters 7545 7546 -- This makes unwarranted assumptions about the shape of the expanded 7547 -- tree for the call, and should be cleaned up ??? 7548 7549 Stmt := First (Stmts); 7550 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7551 Next (Stmt); 7552 end loop; 7553 7554 Call := Stmt; 7555 7556 Param := First (Parameter_Associations (Call)); 7557 while Present (Param) 7558 and then not Is_RTE (Etype (Param), RE_Call_Modes) 7559 loop 7560 Next (Param); 7561 end loop; 7562 7563 pragma Assert (Present (Param)); 7564 Rewrite (Param, New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7565 Analyze (Param); 7566 7567 -- Append an if statement to execute the abortable part 7568 7569 -- Generate: 7570 -- if Enqueued (Bnn) then 7571 7572 Append_To (Stmts, 7573 Make_Implicit_If_Statement (N, 7574 Condition => 7575 Make_Function_Call (Loc, 7576 Name => New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7577 Parameter_Associations => New_List ( 7578 New_Occurrence_Of (Cancel_Param, Loc))), 7579 Then_Statements => Astats)); 7580 7581 Abortable_Block := 7582 Make_Block_Statement (Loc, 7583 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7584 Handled_Statement_Sequence => 7585 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts), 7586 Has_Created_Identifier => True, 7587 Is_Asynchronous_Call_Block => True); 7588 7589 -- For the VM call Update_Exception instead of Abort_Undefer. 7590 -- See 4jexcept.ads for an explanation. 7591 7592 if VM_Target = No_VM then 7593 if Exception_Mechanism = Back_End_Exceptions then 7594 7595 -- Aborts are not deferred at beginning of exception handlers 7596 -- in ZCX. 7597 7598 Handler_Stmt := Make_Null_Statement (Loc); 7599 7600 else 7601 Handler_Stmt := Make_Procedure_Call_Statement (Loc, 7602 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), 7603 Parameter_Associations => No_List); 7604 end if; 7605 else 7606 Handler_Stmt := Make_Procedure_Call_Statement (Loc, 7607 Name => New_Occurrence_Of (RTE (RE_Update_Exception), Loc), 7608 Parameter_Associations => New_List ( 7609 Make_Function_Call (Loc, 7610 Name => New_Occurrence_Of 7611 (RTE (RE_Current_Target_Exception), Loc)))); 7612 end if; 7613 7614 Stmts := New_List ( 7615 Make_Block_Statement (Loc, 7616 Handled_Statement_Sequence => 7617 Make_Handled_Sequence_Of_Statements (Loc, 7618 Statements => New_List ( 7619 Make_Implicit_Label_Declaration (Loc, 7620 Defining_Identifier => Blk_Ent, 7621 Label_Construct => Abortable_Block), 7622 Abortable_Block), 7623 7624 -- exception 7625 7626 Exception_Handlers => New_List ( 7627 Make_Implicit_Exception_Handler (Loc, 7628 7629 -- when Abort_Signal => 7630 -- Abort_Undefer.all; 7631 7632 Exception_Choices => 7633 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)), 7634 Statements => New_List (Handler_Stmt))))), 7635 7636 -- if not Cancelled (Bnn) then 7637 -- triggered statements 7638 -- end if; 7639 7640 Make_Implicit_If_Statement (N, 7641 Condition => Make_Op_Not (Loc, 7642 Right_Opnd => 7643 Make_Function_Call (Loc, 7644 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7645 Parameter_Associations => New_List ( 7646 New_Occurrence_Of (Cancel_Param, Loc)))), 7647 Then_Statements => Tstats)); 7648 7649 -- Asynchronous task entry call 7650 7651 else 7652 if No (Decls) then 7653 Decls := New_List; 7654 end if; 7655 7656 B := Make_Defining_Identifier (Loc, Name_uB); 7657 7658 -- Insert declaration of B in declarations of existing block 7659 7660 Prepend_To (Decls, 7661 Make_Object_Declaration (Loc, 7662 Defining_Identifier => B, 7663 Object_Definition => 7664 New_Occurrence_Of (Standard_Boolean, Loc))); 7665 7666 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC); 7667 7668 -- Insert declaration of C in declarations of existing block 7669 7670 Prepend_To (Decls, 7671 Make_Object_Declaration (Loc, 7672 Defining_Identifier => Cancel_Param, 7673 Object_Definition => 7674 New_Occurrence_Of (Standard_Boolean, Loc))); 7675 7676 -- Remove and save the call to Call_Simple 7677 7678 Stmt := First (Stmts); 7679 7680 -- Skip assignments to temporaries created for in-out parameters. 7681 -- This makes unwarranted assumptions about the shape of the expanded 7682 -- tree for the call, and should be cleaned up ??? 7683 7684 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7685 Next (Stmt); 7686 end loop; 7687 7688 Call := Stmt; 7689 7690 -- Create the inner block to protect the abortable part 7691 7692 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7693 7694 Prepend_To (Astats, 7695 Make_Procedure_Call_Statement (Loc, 7696 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc))); 7697 7698 Abortable_Block := 7699 Make_Block_Statement (Loc, 7700 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7701 Handled_Statement_Sequence => 7702 Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats), 7703 Has_Created_Identifier => True, 7704 Is_Asynchronous_Call_Block => True); 7705 7706 Insert_After (Call, 7707 Make_Block_Statement (Loc, 7708 Handled_Statement_Sequence => 7709 Make_Handled_Sequence_Of_Statements (Loc, 7710 Statements => New_List ( 7711 Make_Implicit_Label_Declaration (Loc, 7712 Defining_Identifier => Blk_Ent, 7713 Label_Construct => Abortable_Block), 7714 Abortable_Block), 7715 Exception_Handlers => Hdle))); 7716 7717 -- Create new call statement 7718 7719 Params := Parameter_Associations (Call); 7720 7721 Append_To (Params, 7722 New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7723 Append_To (Params, New_Occurrence_Of (B, Loc)); 7724 7725 Rewrite (Call, 7726 Make_Procedure_Call_Statement (Loc, 7727 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 7728 Parameter_Associations => Params)); 7729 7730 -- Construct statement sequence for new block 7731 7732 Append_To (Stmts, 7733 Make_Implicit_If_Statement (N, 7734 Condition => 7735 Make_Op_Not (Loc, New_Occurrence_Of (Cancel_Param, Loc)), 7736 Then_Statements => Tstats)); 7737 7738 -- Protected the call against abort 7739 7740 Prepend_To (Stmts, 7741 Make_Procedure_Call_Statement (Loc, 7742 Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc), 7743 Parameter_Associations => Empty_List)); 7744 end if; 7745 7746 Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param); 7747 7748 -- The result is the new block 7749 7750 Rewrite (N_Orig, 7751 Make_Block_Statement (Loc, 7752 Declarations => Decls, 7753 Handled_Statement_Sequence => 7754 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7755 7756 Analyze (N_Orig); 7757 end Expand_N_Asynchronous_Select; 7758 7759 ------------------------------------- 7760 -- Expand_N_Conditional_Entry_Call -- 7761 ------------------------------------- 7762 7763 -- The conditional task entry call is converted to a call to 7764 -- Task_Entry_Call: 7765 7766 -- declare 7767 -- B : Boolean; 7768 -- P : parms := (parm, parm, parm); 7769 7770 -- begin 7771 -- Task_Entry_Call 7772 -- (<acceptor-task>, -- Acceptor 7773 -- <entry-index>, -- E 7774 -- P'Address, -- Uninterpreted_Data 7775 -- Conditional_Call, -- Mode 7776 -- B); -- Rendezvous_Successful 7777 -- parm := P.param; 7778 -- parm := P.param; 7779 -- ... 7780 -- if B then 7781 -- normal-statements 7782 -- else 7783 -- else-statements 7784 -- end if; 7785 -- end; 7786 7787 -- For a description of the use of P and the assignments after the call, 7788 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the 7789 -- conditional entry call has already been expanded (by the Expand_N_Entry 7790 -- _Call_Statement procedure) as follows: 7791 7792 -- declare 7793 -- P : parms := (parm, parm, parm); 7794 -- begin 7795 -- ... info for in-out parameters 7796 -- Call_Simple (acceptor-task, entry-index, P'Address); 7797 -- parm := P.param; 7798 -- parm := P.param; 7799 -- ... 7800 -- end; 7801 7802 -- so the task at hand is to convert the latter expansion into the former 7803 7804 -- The conditional protected entry call is converted to a call to 7805 -- Protected_Entry_Call: 7806 7807 -- declare 7808 -- P : parms := (parm, parm, parm); 7809 -- Bnn : Communications_Block; 7810 7811 -- begin 7812 -- Protected_Entry_Call 7813 -- (po._object'Access, -- Object 7814 -- <entry index>, -- E 7815 -- P'Address, -- Uninterpreted_Data 7816 -- Conditional_Call, -- Mode 7817 -- Bnn); -- Block 7818 -- parm := P.param; 7819 -- parm := P.param; 7820 -- ... 7821 -- if Cancelled (Bnn) then 7822 -- else-statements 7823 -- else 7824 -- normal-statements 7825 -- end if; 7826 -- end; 7827 7828 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted 7829 -- into: 7830 7831 -- declare 7832 -- B : Boolean := False; 7833 -- C : Ada.Tags.Prim_Op_Kind; 7834 -- K : Ada.Tags.Tagged_Kind := 7835 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7836 -- P : Parameters := (Param1 .. ParamN); 7837 -- S : Integer; 7838 7839 -- begin 7840 -- if K = Ada.Tags.TK_Limited_Tagged 7841 -- or else K = Ada.Tags.TK_Tagged 7842 -- then 7843 -- <dispatching-call>; 7844 -- <triggering-statements> 7845 7846 -- else 7847 -- S := 7848 -- Ada.Tags.Get_Offset_Index 7849 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 7850 7851 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 7852 7853 -- if C = POK_Protected_Entry 7854 -- or else C = POK_Task_Entry 7855 -- then 7856 -- Param1 := P.Param1; 7857 -- ... 7858 -- ParamN := P.ParamN; 7859 -- end if; 7860 7861 -- if B then 7862 -- if C = POK_Procedure 7863 -- or else C = POK_Protected_Procedure 7864 -- or else C = POK_Task_Procedure 7865 -- then 7866 -- <dispatching-call>; 7867 -- end if; 7868 7869 -- <triggering-statements> 7870 -- else 7871 -- <else-statements> 7872 -- end if; 7873 -- end if; 7874 -- end; 7875 7876 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is 7877 Loc : constant Source_Ptr := Sloc (N); 7878 Alt : constant Node_Id := Entry_Call_Alternative (N); 7879 Blk : Node_Id := Entry_Call_Statement (Alt); 7880 7881 Actuals : List_Id; 7882 Blk_Typ : Entity_Id; 7883 Call : Node_Id; 7884 Call_Ent : Entity_Id; 7885 Conc_Typ_Stmts : List_Id; 7886 Decl : Node_Id; 7887 Decls : List_Id; 7888 Formals : List_Id; 7889 Lim_Typ_Stmts : List_Id; 7890 N_Stats : List_Id; 7891 Obj : Entity_Id; 7892 Param : Node_Id; 7893 Params : List_Id; 7894 Stmt : Node_Id; 7895 Stmts : List_Id; 7896 Transient_Blk : Node_Id; 7897 Unpack : List_Id; 7898 7899 B : Entity_Id; -- Call status flag 7900 C : Entity_Id; -- Call kind 7901 K : Entity_Id; -- Tagged kind 7902 P : Entity_Id; -- Parameter block 7903 S : Entity_Id; -- Primitive operation slot 7904 7905 begin 7906 Process_Statements_For_Controlled_Objects (N); 7907 7908 if Ada_Version >= Ada_2005 7909 and then Nkind (Blk) = N_Procedure_Call_Statement 7910 then 7911 Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals); 7912 7913 Decls := New_List; 7914 Stmts := New_List; 7915 7916 -- Call status flag processing, generate: 7917 -- B : Boolean := False; 7918 7919 B := Build_B (Loc, Decls); 7920 7921 -- Call kind processing, generate: 7922 -- C : Ada.Tags.Prim_Op_Kind; 7923 7924 C := Build_C (Loc, Decls); 7925 7926 -- Tagged kind processing, generate: 7927 -- K : Ada.Tags.Tagged_Kind := 7928 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7929 7930 K := Build_K (Loc, Decls, Obj); 7931 7932 -- Parameter block processing 7933 7934 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 7935 P := Parameter_Block_Pack 7936 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 7937 7938 -- Dispatch table slot processing, generate: 7939 -- S : Integer; 7940 7941 S := Build_S (Loc, Decls); 7942 7943 -- Generate: 7944 -- S := Ada.Tags.Get_Offset_Index 7945 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 7946 7947 Conc_Typ_Stmts := 7948 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 7949 7950 -- Generate: 7951 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 7952 7953 Append_To (Conc_Typ_Stmts, 7954 Make_Procedure_Call_Statement (Loc, 7955 Name => 7956 New_Occurrence_Of ( 7957 Find_Prim_Op (Etype (Etype (Obj)), 7958 Name_uDisp_Conditional_Select), 7959 Loc), 7960 Parameter_Associations => 7961 New_List ( 7962 New_Copy_Tree (Obj), -- <object> 7963 New_Occurrence_Of (S, Loc), -- S 7964 Make_Attribute_Reference (Loc, -- P'Address 7965 Prefix => New_Occurrence_Of (P, Loc), 7966 Attribute_Name => Name_Address), 7967 New_Occurrence_Of (C, Loc), -- C 7968 New_Occurrence_Of (B, Loc)))); -- B 7969 7970 -- Generate: 7971 -- if C = POK_Protected_Entry 7972 -- or else C = POK_Task_Entry 7973 -- then 7974 -- Param1 := P.Param1; 7975 -- ... 7976 -- ParamN := P.ParamN; 7977 -- end if; 7978 7979 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7980 7981 -- Generate the if statement only when the packed parameters need 7982 -- explicit assignments to their corresponding actuals. 7983 7984 if Present (Unpack) then 7985 Append_To (Conc_Typ_Stmts, 7986 Make_Implicit_If_Statement (N, 7987 Condition => 7988 Make_Or_Else (Loc, 7989 Left_Opnd => 7990 Make_Op_Eq (Loc, 7991 Left_Opnd => 7992 New_Occurrence_Of (C, Loc), 7993 Right_Opnd => 7994 New_Occurrence_Of (RTE ( 7995 RE_POK_Protected_Entry), Loc)), 7996 7997 Right_Opnd => 7998 Make_Op_Eq (Loc, 7999 Left_Opnd => 8000 New_Occurrence_Of (C, Loc), 8001 Right_Opnd => 8002 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 8003 8004 Then_Statements => Unpack)); 8005 end if; 8006 8007 -- Generate: 8008 -- if B then 8009 -- if C = POK_Procedure 8010 -- or else C = POK_Protected_Procedure 8011 -- or else C = POK_Task_Procedure 8012 -- then 8013 -- <dispatching-call> 8014 -- end if; 8015 -- <normal-statements> 8016 -- else 8017 -- <else-statements> 8018 -- end if; 8019 8020 N_Stats := New_Copy_List_Tree (Statements (Alt)); 8021 8022 Prepend_To (N_Stats, 8023 Make_Implicit_If_Statement (N, 8024 Condition => 8025 Make_Or_Else (Loc, 8026 Left_Opnd => 8027 Make_Op_Eq (Loc, 8028 Left_Opnd => 8029 New_Occurrence_Of (C, Loc), 8030 Right_Opnd => 8031 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 8032 8033 Right_Opnd => 8034 Make_Or_Else (Loc, 8035 Left_Opnd => 8036 Make_Op_Eq (Loc, 8037 Left_Opnd => 8038 New_Occurrence_Of (C, Loc), 8039 Right_Opnd => 8040 New_Occurrence_Of (RTE ( 8041 RE_POK_Protected_Procedure), Loc)), 8042 8043 Right_Opnd => 8044 Make_Op_Eq (Loc, 8045 Left_Opnd => 8046 New_Occurrence_Of (C, Loc), 8047 Right_Opnd => 8048 New_Occurrence_Of (RTE ( 8049 RE_POK_Task_Procedure), Loc)))), 8050 8051 Then_Statements => 8052 New_List (Blk))); 8053 8054 Append_To (Conc_Typ_Stmts, 8055 Make_Implicit_If_Statement (N, 8056 Condition => New_Occurrence_Of (B, Loc), 8057 Then_Statements => N_Stats, 8058 Else_Statements => Else_Statements (N))); 8059 8060 -- Generate: 8061 -- <dispatching-call>; 8062 -- <triggering-statements> 8063 8064 Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt)); 8065 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk)); 8066 8067 -- Generate: 8068 -- if K = Ada.Tags.TK_Limited_Tagged 8069 -- or else K = Ada.Tags.TK_Tagged 8070 -- then 8071 -- Lim_Typ_Stmts 8072 -- else 8073 -- Conc_Typ_Stmts 8074 -- end if; 8075 8076 Append_To (Stmts, 8077 Make_Implicit_If_Statement (N, 8078 Condition => Build_Dispatching_Tag_Check (K, N), 8079 Then_Statements => Lim_Typ_Stmts, 8080 Else_Statements => Conc_Typ_Stmts)); 8081 8082 Rewrite (N, 8083 Make_Block_Statement (Loc, 8084 Declarations => 8085 Decls, 8086 Handled_Statement_Sequence => 8087 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8088 8089 -- As described above, the entry alternative is transformed into a 8090 -- block that contains the gnulli call, and possibly assignment 8091 -- statements for in-out parameters. The gnulli call may itself be 8092 -- rewritten into a transient block if some unconstrained parameters 8093 -- require it. We need to retrieve the call to complete its parameter 8094 -- list. 8095 8096 else 8097 Transient_Blk := 8098 First_Real_Statement (Handled_Statement_Sequence (Blk)); 8099 8100 if Present (Transient_Blk) 8101 and then Nkind (Transient_Blk) = N_Block_Statement 8102 then 8103 Blk := Transient_Blk; 8104 end if; 8105 8106 Stmts := Statements (Handled_Statement_Sequence (Blk)); 8107 Stmt := First (Stmts); 8108 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 8109 Next (Stmt); 8110 end loop; 8111 8112 Call := Stmt; 8113 Params := Parameter_Associations (Call); 8114 8115 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then 8116 8117 -- Substitute Conditional_Entry_Call for Simple_Call parameter 8118 8119 Param := First (Params); 8120 while Present (Param) 8121 and then not Is_RTE (Etype (Param), RE_Call_Modes) 8122 loop 8123 Next (Param); 8124 end loop; 8125 8126 pragma Assert (Present (Param)); 8127 Rewrite (Param, 8128 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8129 8130 Analyze (Param); 8131 8132 -- Find the Communication_Block parameter for the call to the 8133 -- Cancelled function. 8134 8135 Decl := First (Declarations (Blk)); 8136 while Present (Decl) 8137 and then not Is_RTE (Etype (Object_Definition (Decl)), 8138 RE_Communication_Block) 8139 loop 8140 Next (Decl); 8141 end loop; 8142 8143 -- Add an if statement to execute the else part if the call 8144 -- does not succeed (as indicated by the Cancelled predicate). 8145 8146 Append_To (Stmts, 8147 Make_Implicit_If_Statement (N, 8148 Condition => Make_Function_Call (Loc, 8149 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 8150 Parameter_Associations => New_List ( 8151 New_Occurrence_Of (Defining_Identifier (Decl), Loc))), 8152 Then_Statements => Else_Statements (N), 8153 Else_Statements => Statements (Alt))); 8154 8155 else 8156 B := Make_Defining_Identifier (Loc, Name_uB); 8157 8158 -- Insert declaration of B in declarations of existing block 8159 8160 if No (Declarations (Blk)) then 8161 Set_Declarations (Blk, New_List); 8162 end if; 8163 8164 Prepend_To (Declarations (Blk), 8165 Make_Object_Declaration (Loc, 8166 Defining_Identifier => B, 8167 Object_Definition => 8168 New_Occurrence_Of (Standard_Boolean, Loc))); 8169 8170 -- Create new call statement 8171 8172 Append_To (Params, 8173 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8174 Append_To (Params, New_Occurrence_Of (B, Loc)); 8175 8176 Rewrite (Call, 8177 Make_Procedure_Call_Statement (Loc, 8178 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 8179 Parameter_Associations => Params)); 8180 8181 -- Construct statement sequence for new block 8182 8183 Append_To (Stmts, 8184 Make_Implicit_If_Statement (N, 8185 Condition => New_Occurrence_Of (B, Loc), 8186 Then_Statements => Statements (Alt), 8187 Else_Statements => Else_Statements (N))); 8188 end if; 8189 8190 -- The result is the new block 8191 8192 Rewrite (N, 8193 Make_Block_Statement (Loc, 8194 Declarations => Declarations (Blk), 8195 Handled_Statement_Sequence => 8196 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8197 end if; 8198 8199 Analyze (N); 8200 end Expand_N_Conditional_Entry_Call; 8201 8202 --------------------------------------- 8203 -- Expand_N_Delay_Relative_Statement -- 8204 --------------------------------------- 8205 8206 -- Delay statement is implemented as a procedure call to Delay_For 8207 -- defined in Ada.Calendar.Delays in order to reduce the overhead of 8208 -- simple delays imposed by the use of Protected Objects. 8209 8210 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is 8211 Loc : constant Source_Ptr := Sloc (N); 8212 begin 8213 Rewrite (N, 8214 Make_Procedure_Call_Statement (Loc, 8215 Name => New_Occurrence_Of (RTE (RO_CA_Delay_For), Loc), 8216 Parameter_Associations => New_List (Expression (N)))); 8217 Analyze (N); 8218 end Expand_N_Delay_Relative_Statement; 8219 8220 ------------------------------------ 8221 -- Expand_N_Delay_Until_Statement -- 8222 ------------------------------------ 8223 8224 -- Delay Until statement is implemented as a procedure call to 8225 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays. 8226 8227 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is 8228 Loc : constant Source_Ptr := Sloc (N); 8229 Typ : Entity_Id; 8230 8231 begin 8232 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then 8233 Typ := RTE (RO_CA_Delay_Until); 8234 else 8235 Typ := RTE (RO_RT_Delay_Until); 8236 end if; 8237 8238 Rewrite (N, 8239 Make_Procedure_Call_Statement (Loc, 8240 Name => New_Occurrence_Of (Typ, Loc), 8241 Parameter_Associations => New_List (Expression (N)))); 8242 8243 Analyze (N); 8244 end Expand_N_Delay_Until_Statement; 8245 8246 ------------------------- 8247 -- Expand_N_Entry_Body -- 8248 ------------------------- 8249 8250 procedure Expand_N_Entry_Body (N : Node_Id) is 8251 begin 8252 -- Associate discriminals with the next protected operation body to be 8253 -- expanded. 8254 8255 if Present (Next_Protected_Operation (N)) then 8256 Set_Discriminals (Parent (Current_Scope)); 8257 end if; 8258 end Expand_N_Entry_Body; 8259 8260 ----------------------------------- 8261 -- Expand_N_Entry_Call_Statement -- 8262 ----------------------------------- 8263 8264 -- An entry call is expanded into GNARLI calls to implement a simple entry 8265 -- call (see Build_Simple_Entry_Call). 8266 8267 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is 8268 Concval : Node_Id; 8269 Ename : Node_Id; 8270 Index : Node_Id; 8271 8272 begin 8273 if No_Run_Time_Mode then 8274 Error_Msg_CRT ("entry call", N); 8275 return; 8276 end if; 8277 8278 -- If this entry call is part of an asynchronous select, don't expand it 8279 -- here; it will be expanded with the select statement. Don't expand 8280 -- timed entry calls either, as they are translated into asynchronous 8281 -- entry calls. 8282 8283 -- ??? This whole approach is questionable; it may be better to go back 8284 -- to allowing the expansion to take place and then attempting to fix it 8285 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out 8286 -- whether the expanded call is on a task or protected entry. 8287 8288 if (Nkind (Parent (N)) /= N_Triggering_Alternative 8289 or else N /= Triggering_Statement (Parent (N))) 8290 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative 8291 or else N /= Entry_Call_Statement (Parent (N)) 8292 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call) 8293 then 8294 Extract_Entry (N, Concval, Ename, Index); 8295 Build_Simple_Entry_Call (N, Concval, Ename, Index); 8296 end if; 8297 end Expand_N_Entry_Call_Statement; 8298 8299 -------------------------------- 8300 -- Expand_N_Entry_Declaration -- 8301 -------------------------------- 8302 8303 -- If there are parameters, then first, each of the formals is marked by 8304 -- setting Is_Entry_Formal. Next a record type is built which is used to 8305 -- hold the parameter values. The name of this record type is entryP where 8306 -- entry is the name of the entry, with an additional corresponding access 8307 -- type called entryPA. The record type has matching components for each 8308 -- formal (the component names are the same as the formal names). For 8309 -- elementary types, the component type matches the formal type. For 8310 -- composite types, an access type is declared (with the name formalA) 8311 -- which designates the formal type, and the type of the component is this 8312 -- access type. Finally the Entry_Component of each formal is set to 8313 -- reference the corresponding record component. 8314 8315 procedure Expand_N_Entry_Declaration (N : Node_Id) is 8316 Loc : constant Source_Ptr := Sloc (N); 8317 Entry_Ent : constant Entity_Id := Defining_Identifier (N); 8318 Components : List_Id; 8319 Formal : Node_Id; 8320 Ftype : Entity_Id; 8321 Last_Decl : Node_Id; 8322 Component : Entity_Id; 8323 Ctype : Entity_Id; 8324 Decl : Node_Id; 8325 Rec_Ent : Entity_Id; 8326 Acc_Ent : Entity_Id; 8327 8328 begin 8329 Formal := First_Formal (Entry_Ent); 8330 Last_Decl := N; 8331 8332 -- Most processing is done only if parameters are present 8333 8334 if Present (Formal) then 8335 Components := New_List; 8336 8337 -- Loop through formals 8338 8339 while Present (Formal) loop 8340 Set_Is_Entry_Formal (Formal); 8341 Component := 8342 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); 8343 Set_Entry_Component (Formal, Component); 8344 Set_Entry_Formal (Component, Formal); 8345 Ftype := Etype (Formal); 8346 8347 -- Declare new access type and then append 8348 8349 Ctype := Make_Temporary (Loc, 'A'); 8350 8351 Decl := 8352 Make_Full_Type_Declaration (Loc, 8353 Defining_Identifier => Ctype, 8354 Type_Definition => 8355 Make_Access_To_Object_Definition (Loc, 8356 All_Present => True, 8357 Constant_Present => Ekind (Formal) = E_In_Parameter, 8358 Subtype_Indication => New_Occurrence_Of (Ftype, Loc))); 8359 8360 Insert_After (Last_Decl, Decl); 8361 Last_Decl := Decl; 8362 8363 Append_To (Components, 8364 Make_Component_Declaration (Loc, 8365 Defining_Identifier => Component, 8366 Component_Definition => 8367 Make_Component_Definition (Loc, 8368 Aliased_Present => False, 8369 Subtype_Indication => New_Occurrence_Of (Ctype, Loc)))); 8370 8371 Next_Formal_With_Extras (Formal); 8372 end loop; 8373 8374 -- Create the Entry_Parameter_Record declaration 8375 8376 Rec_Ent := Make_Temporary (Loc, 'P'); 8377 8378 Decl := 8379 Make_Full_Type_Declaration (Loc, 8380 Defining_Identifier => Rec_Ent, 8381 Type_Definition => 8382 Make_Record_Definition (Loc, 8383 Component_List => 8384 Make_Component_List (Loc, 8385 Component_Items => Components))); 8386 8387 Insert_After (Last_Decl, Decl); 8388 Last_Decl := Decl; 8389 8390 -- Construct and link in the corresponding access type 8391 8392 Acc_Ent := Make_Temporary (Loc, 'A'); 8393 8394 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); 8395 8396 Decl := 8397 Make_Full_Type_Declaration (Loc, 8398 Defining_Identifier => Acc_Ent, 8399 Type_Definition => 8400 Make_Access_To_Object_Definition (Loc, 8401 All_Present => True, 8402 Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc))); 8403 8404 Insert_After (Last_Decl, Decl); 8405 end if; 8406 end Expand_N_Entry_Declaration; 8407 8408 ----------------------------- 8409 -- Expand_N_Protected_Body -- 8410 ----------------------------- 8411 8412 -- Protected bodies are expanded to the completion of the subprograms 8413 -- created for the corresponding protected type. These are a protected and 8414 -- unprotected version of each protected subprogram in the object, a 8415 -- function to calculate each entry barrier, and a procedure to execute the 8416 -- sequence of statements of each protected entry body. For example, for 8417 -- protected type ptype: 8418 8419 -- function entB 8420 -- (O : System.Address; 8421 -- E : Protected_Entry_Index) 8422 -- return Boolean 8423 -- is 8424 -- <discriminant renamings> 8425 -- <private object renamings> 8426 -- begin 8427 -- return <barrier expression>; 8428 -- end entB; 8429 8430 -- procedure pprocN (_object : in out poV;...) is 8431 -- <discriminant renamings> 8432 -- <private object renamings> 8433 -- begin 8434 -- <sequence of statements> 8435 -- end pprocN; 8436 8437 -- procedure pprocP (_object : in out poV;...) is 8438 -- procedure _clean is 8439 -- Pn : Boolean; 8440 -- begin 8441 -- ptypeS (_object, Pn); 8442 -- Unlock (_object._object'Access); 8443 -- Abort_Undefer.all; 8444 -- end _clean; 8445 8446 -- begin 8447 -- Abort_Defer.all; 8448 -- Lock (_object._object'Access); 8449 -- pprocN (_object;...); 8450 -- at end 8451 -- _clean; 8452 -- end pproc; 8453 8454 -- function pfuncN (_object : poV;...) return Return_Type is 8455 -- <discriminant renamings> 8456 -- <private object renamings> 8457 -- begin 8458 -- <sequence of statements> 8459 -- end pfuncN; 8460 8461 -- function pfuncP (_object : poV) return Return_Type is 8462 -- procedure _clean is 8463 -- begin 8464 -- Unlock (_object._object'Access); 8465 -- Abort_Undefer.all; 8466 -- end _clean; 8467 8468 -- begin 8469 -- Abort_Defer.all; 8470 -- Lock (_object._object'Access); 8471 -- return pfuncN (_object); 8472 8473 -- at end 8474 -- _clean; 8475 -- end pfunc; 8476 8477 -- procedure entE 8478 -- (O : System.Address; 8479 -- P : System.Address; 8480 -- E : Protected_Entry_Index) 8481 -- is 8482 -- <discriminant renamings> 8483 -- <private object renamings> 8484 -- type poVP is access poV; 8485 -- _Object : ptVP := ptVP!(O); 8486 8487 -- begin 8488 -- begin 8489 -- <statement sequence> 8490 -- Complete_Entry_Body (_Object._Object); 8491 -- exception 8492 -- when all others => 8493 -- Exceptional_Complete_Entry_Body ( 8494 -- _Object._Object, Get_GNAT_Exception); 8495 -- end; 8496 -- end entE; 8497 8498 -- The type poV is the record created for the protected type to hold 8499 -- the state of the protected object. 8500 8501 procedure Expand_N_Protected_Body (N : Node_Id) is 8502 Loc : constant Source_Ptr := Sloc (N); 8503 Pid : constant Entity_Id := Corresponding_Spec (N); 8504 8505 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid); 8506 -- This flag indicates whether the lock free implementation is active 8507 8508 Current_Node : Node_Id; 8509 Disp_Op_Body : Node_Id; 8510 New_Op_Body : Node_Id; 8511 Op_Body : Node_Id; 8512 Op_Id : Entity_Id; 8513 8514 function Build_Dispatching_Subprogram_Body 8515 (N : Node_Id; 8516 Pid : Node_Id; 8517 Prot_Bod : Node_Id) return Node_Id; 8518 -- Build a dispatching version of the protected subprogram body. The 8519 -- newly generated subprogram contains a call to the original protected 8520 -- body. The following code is generated: 8521 -- 8522 -- function <protected-function-name> (Param1 .. ParamN) return 8523 -- <return-type> is 8524 -- begin 8525 -- return <protected-function-name>P (Param1 .. ParamN); 8526 -- end <protected-function-name>; 8527 -- 8528 -- or 8529 -- 8530 -- procedure <protected-procedure-name> (Param1 .. ParamN) is 8531 -- begin 8532 -- <protected-procedure-name>P (Param1 .. ParamN); 8533 -- end <protected-procedure-name> 8534 8535 --------------------------------------- 8536 -- Build_Dispatching_Subprogram_Body -- 8537 --------------------------------------- 8538 8539 function Build_Dispatching_Subprogram_Body 8540 (N : Node_Id; 8541 Pid : Node_Id; 8542 Prot_Bod : Node_Id) return Node_Id 8543 is 8544 Loc : constant Source_Ptr := Sloc (N); 8545 Actuals : List_Id; 8546 Formal : Node_Id; 8547 Spec : Node_Id; 8548 Stmts : List_Id; 8549 8550 begin 8551 -- Generate a specification without a letter suffix in order to 8552 -- override an interface function or procedure. 8553 8554 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode); 8555 8556 -- The formal parameters become the actuals of the protected function 8557 -- or procedure call. 8558 8559 Actuals := New_List; 8560 Formal := First (Parameter_Specifications (Spec)); 8561 while Present (Formal) loop 8562 Append_To (Actuals, 8563 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 8564 Next (Formal); 8565 end loop; 8566 8567 if Nkind (Spec) = N_Procedure_Specification then 8568 Stmts := 8569 New_List ( 8570 Make_Procedure_Call_Statement (Loc, 8571 Name => 8572 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8573 Parameter_Associations => Actuals)); 8574 8575 else 8576 pragma Assert (Nkind (Spec) = N_Function_Specification); 8577 8578 Stmts := 8579 New_List ( 8580 Make_Simple_Return_Statement (Loc, 8581 Expression => 8582 Make_Function_Call (Loc, 8583 Name => 8584 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8585 Parameter_Associations => Actuals))); 8586 end if; 8587 8588 return 8589 Make_Subprogram_Body (Loc, 8590 Declarations => Empty_List, 8591 Specification => Spec, 8592 Handled_Statement_Sequence => 8593 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 8594 end Build_Dispatching_Subprogram_Body; 8595 8596 -- Start of processing for Expand_N_Protected_Body 8597 8598 begin 8599 if No_Run_Time_Mode then 8600 Error_Msg_CRT ("protected body", N); 8601 return; 8602 end if; 8603 8604 -- This is the proper body corresponding to a stub. The declarations 8605 -- must be inserted at the point of the stub, which in turn is in the 8606 -- declarative part of the parent unit. 8607 8608 if Nkind (Parent (N)) = N_Subunit then 8609 Current_Node := Corresponding_Stub (Parent (N)); 8610 else 8611 Current_Node := N; 8612 end if; 8613 8614 Op_Body := First (Declarations (N)); 8615 8616 -- The protected body is replaced with the bodies of its 8617 -- protected operations, and the declarations for internal objects 8618 -- that may have been created for entry family bounds. 8619 8620 Rewrite (N, Make_Null_Statement (Sloc (N))); 8621 Analyze (N); 8622 8623 while Present (Op_Body) loop 8624 case Nkind (Op_Body) is 8625 when N_Subprogram_Declaration => 8626 null; 8627 8628 when N_Subprogram_Body => 8629 8630 -- Do not create bodies for eliminated operations 8631 8632 if not Is_Eliminated (Defining_Entity (Op_Body)) 8633 and then not Is_Eliminated (Corresponding_Spec (Op_Body)) 8634 then 8635 if Lock_Free_Active then 8636 New_Op_Body := 8637 Build_Lock_Free_Unprotected_Subprogram_Body 8638 (Op_Body, Pid); 8639 else 8640 New_Op_Body := 8641 Build_Unprotected_Subprogram_Body (Op_Body, Pid); 8642 end if; 8643 8644 Insert_After (Current_Node, New_Op_Body); 8645 Current_Node := New_Op_Body; 8646 Analyze (New_Op_Body); 8647 8648 -- Build the corresponding protected operation. It may 8649 -- appear that this is needed only if this is a visible 8650 -- operation of the type, or if it is an interrupt handler, 8651 -- and this was the strategy used previously in GNAT. 8652 8653 -- However, the operation may be exported through a 'Access 8654 -- to an external caller. This is the common idiom in code 8655 -- that uses the Ada 2005 Timing_Events package. As a result 8656 -- we need to produce the protected body for both visible 8657 -- and private operations, as well as operations that only 8658 -- have a body in the source, and for which we create a 8659 -- declaration in the protected body itself. 8660 8661 if Present (Corresponding_Spec (Op_Body)) then 8662 if Lock_Free_Active then 8663 New_Op_Body := 8664 Build_Lock_Free_Protected_Subprogram_Body 8665 (Op_Body, Pid, Specification (New_Op_Body)); 8666 else 8667 New_Op_Body := 8668 Build_Protected_Subprogram_Body 8669 (Op_Body, Pid, Specification (New_Op_Body)); 8670 end if; 8671 8672 Insert_After (Current_Node, New_Op_Body); 8673 Analyze (New_Op_Body); 8674 8675 Current_Node := New_Op_Body; 8676 8677 -- Generate an overriding primitive operation body for 8678 -- this subprogram if the protected type implements an 8679 -- interface. 8680 8681 if Ada_Version >= Ada_2005 8682 and then 8683 Present (Interfaces (Corresponding_Record_Type (Pid))) 8684 then 8685 Disp_Op_Body := 8686 Build_Dispatching_Subprogram_Body 8687 (Op_Body, Pid, New_Op_Body); 8688 8689 Insert_After (Current_Node, Disp_Op_Body); 8690 Analyze (Disp_Op_Body); 8691 8692 Current_Node := Disp_Op_Body; 8693 end if; 8694 end if; 8695 end if; 8696 8697 when N_Entry_Body => 8698 Op_Id := Defining_Identifier (Op_Body); 8699 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid); 8700 8701 Insert_After (Current_Node, New_Op_Body); 8702 Current_Node := New_Op_Body; 8703 Analyze (New_Op_Body); 8704 8705 when N_Implicit_Label_Declaration => 8706 null; 8707 8708 when N_Itype_Reference => 8709 Insert_After (Current_Node, New_Copy (Op_Body)); 8710 8711 when N_Freeze_Entity => 8712 New_Op_Body := New_Copy (Op_Body); 8713 8714 if Present (Entity (Op_Body)) 8715 and then Freeze_Node (Entity (Op_Body)) = Op_Body 8716 then 8717 Set_Freeze_Node (Entity (Op_Body), New_Op_Body); 8718 end if; 8719 8720 Insert_After (Current_Node, New_Op_Body); 8721 Current_Node := New_Op_Body; 8722 Analyze (New_Op_Body); 8723 8724 when N_Pragma => 8725 New_Op_Body := New_Copy (Op_Body); 8726 Insert_After (Current_Node, New_Op_Body); 8727 Current_Node := New_Op_Body; 8728 Analyze (New_Op_Body); 8729 8730 when N_Object_Declaration => 8731 pragma Assert (not Comes_From_Source (Op_Body)); 8732 New_Op_Body := New_Copy (Op_Body); 8733 Insert_After (Current_Node, New_Op_Body); 8734 Current_Node := New_Op_Body; 8735 Analyze (New_Op_Body); 8736 8737 when others => 8738 raise Program_Error; 8739 8740 end case; 8741 8742 Next (Op_Body); 8743 end loop; 8744 8745 -- Finally, create the body of the function that maps an entry index 8746 -- into the corresponding body index, except when there is no entry, or 8747 -- in a Ravenscar-like profile. 8748 8749 if Corresponding_Runtime_Package (Pid) = 8750 System_Tasking_Protected_Objects_Entries 8751 then 8752 New_Op_Body := Build_Find_Body_Index (Pid); 8753 Insert_After (Current_Node, New_Op_Body); 8754 Current_Node := New_Op_Body; 8755 Analyze (New_Op_Body); 8756 end if; 8757 8758 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the 8759 -- protected body. At this point all wrapper specs have been created, 8760 -- frozen and included in the dispatch table for the protected type. 8761 8762 if Ada_Version >= Ada_2005 then 8763 Build_Wrapper_Bodies (Loc, Pid, Current_Node); 8764 end if; 8765 end Expand_N_Protected_Body; 8766 8767 ----------------------------------------- 8768 -- Expand_N_Protected_Type_Declaration -- 8769 ----------------------------------------- 8770 8771 -- First we create a corresponding record type declaration used to 8772 -- represent values of this protected type. 8773 -- The general form of this type declaration is 8774 8775 -- type poV (discriminants) is record 8776 -- _Object : aliased <kind>Protection 8777 -- [(<entry count> [, <handler count>])]; 8778 -- [entry_family : array (bounds) of Void;] 8779 -- <private data fields> 8780 -- end record; 8781 8782 -- The discriminants are present only if the corresponding protected type 8783 -- has discriminants, and they exactly mirror the protected type 8784 -- discriminants. The private data fields similarly mirror the private 8785 -- declarations of the protected type. 8786 8787 -- The Object field is always present. It contains RTS specific data used 8788 -- to control the protected object. It is declared as Aliased so that it 8789 -- can be passed as a pointer to the RTS. This allows the protected record 8790 -- to be referenced within RTS data structures. An appropriate Protection 8791 -- type and discriminant are generated. 8792 8793 -- The Service field is present for protected objects with entries. It 8794 -- contains sufficient information to allow the entry service procedure for 8795 -- this object to be called when the object is not known till runtime. 8796 8797 -- One entry_family component is present for each entry family in the 8798 -- task definition (see Expand_N_Task_Type_Declaration). 8799 8800 -- When a protected object is declared, an instance of the protected type 8801 -- value record is created. The elaboration of this declaration creates the 8802 -- correct bounds for the entry families, and also evaluates the priority 8803 -- expression if needed. The initialization routine for the protected type 8804 -- itself then calls Initialize_Protection with appropriate parameters to 8805 -- initialize the value of the Task_Id field. Install_Handlers may be also 8806 -- called if a pragma Attach_Handler applies. 8807 8808 -- Note: this record is passed to the subprograms created by the expansion 8809 -- of protected subprograms and entries. It is an in parameter to protected 8810 -- functions and an in out parameter to procedures and entry bodies. The 8811 -- Entity_Id for this created record type is placed in the 8812 -- Corresponding_Record_Type field of the associated protected type entity. 8813 8814 -- Next we create a procedure specifications for protected subprograms and 8815 -- entry bodies. For each protected subprograms two subprograms are 8816 -- created, an unprotected and a protected version. The unprotected version 8817 -- is called from within other operations of the same protected object. 8818 8819 -- We also build the call to register the procedure if a pragma 8820 -- Interrupt_Handler applies. 8821 8822 -- A single subprogram is created to service all entry bodies; it has an 8823 -- additional boolean out parameter indicating that the previous entry call 8824 -- made by the current task was serviced immediately, i.e. not by proxy. 8825 -- The O parameter contains a pointer to a record object of the type 8826 -- described above. An untyped interface is used here to allow this 8827 -- procedure to be called in places where the type of the object to be 8828 -- serviced is not known. This must be done, for example, when a call that 8829 -- may have been requeued is cancelled; the corresponding object must be 8830 -- serviced, but which object that is not known till runtime. 8831 8832 -- procedure ptypeS 8833 -- (O : System.Address; P : out Boolean); 8834 -- procedure pprocN (_object : in out poV); 8835 -- procedure pproc (_object : in out poV); 8836 -- function pfuncN (_object : poV); 8837 -- function pfunc (_object : poV); 8838 -- ... 8839 8840 -- Note that this must come after the record type declaration, since 8841 -- the specs refer to this type. 8842 8843 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is 8844 Loc : constant Source_Ptr := Sloc (N); 8845 Prot_Typ : constant Entity_Id := Defining_Identifier (N); 8846 8847 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ); 8848 -- This flag indicates whether the lock free implementation is active 8849 8850 Pdef : constant Node_Id := Protected_Definition (N); 8851 -- This contains two lists; one for visible and one for private decls 8852 8853 Rec_Decl : Node_Id; 8854 Cdecls : List_Id; 8855 Discr_Map : constant Elist_Id := New_Elmt_List; 8856 Priv : Node_Id; 8857 New_Priv : Node_Id; 8858 Comp : Node_Id; 8859 Comp_Id : Entity_Id; 8860 Sub : Node_Id; 8861 Current_Node : Node_Id := N; 8862 Entries_Aggr : Node_Id; 8863 Body_Id : Entity_Id; 8864 Body_Arr : Node_Id; 8865 E_Count : Int; 8866 Object_Comp : Node_Id; 8867 8868 procedure Check_Inlining (Subp : Entity_Id); 8869 -- If the original operation has a pragma Inline, propagate the flag 8870 -- to the internal body, for possible inlining later on. The source 8871 -- operation is invisible to the back-end and is never actually called. 8872 8873 procedure Expand_Entry_Declaration (Comp : Entity_Id); 8874 -- Create the subprograms for the barrier and for the body, and append 8875 -- then to Entry_Bodies_Array. 8876 8877 function Static_Component_Size (Comp : Entity_Id) return Boolean; 8878 -- When compiling under the Ravenscar profile, private components must 8879 -- have a static size, or else a protected object will require heap 8880 -- allocation, violating the corresponding restriction. It is preferable 8881 -- to make this check here, because it provides a better error message 8882 -- than the back-end, which refers to the object as a whole. 8883 8884 procedure Register_Handler; 8885 -- For a protected operation that is an interrupt handler, add the 8886 -- freeze action that will register it as such. 8887 8888 -------------------- 8889 -- Check_Inlining -- 8890 -------------------- 8891 8892 procedure Check_Inlining (Subp : Entity_Id) is 8893 begin 8894 if Is_Inlined (Subp) then 8895 Set_Is_Inlined (Protected_Body_Subprogram (Subp)); 8896 Set_Is_Inlined (Subp, False); 8897 end if; 8898 end Check_Inlining; 8899 8900 --------------------------------- 8901 -- Check_Static_Component_Size -- 8902 --------------------------------- 8903 8904 function Static_Component_Size (Comp : Entity_Id) return Boolean is 8905 Typ : constant Entity_Id := Etype (Comp); 8906 C : Entity_Id; 8907 8908 begin 8909 if Is_Scalar_Type (Typ) then 8910 return True; 8911 8912 elsif Is_Array_Type (Typ) then 8913 return Compile_Time_Known_Bounds (Typ); 8914 8915 elsif Is_Record_Type (Typ) then 8916 C := First_Component (Typ); 8917 while Present (C) loop 8918 if not Static_Component_Size (C) then 8919 return False; 8920 end if; 8921 8922 Next_Component (C); 8923 end loop; 8924 8925 return True; 8926 8927 -- Any other type will be checked by the back-end 8928 8929 else 8930 return True; 8931 end if; 8932 end Static_Component_Size; 8933 8934 ------------------------------ 8935 -- Expand_Entry_Declaration -- 8936 ------------------------------ 8937 8938 procedure Expand_Entry_Declaration (Comp : Entity_Id) is 8939 Bdef : Entity_Id; 8940 Edef : Entity_Id; 8941 8942 begin 8943 E_Count := E_Count + 1; 8944 Comp_Id := Defining_Identifier (Comp); 8945 8946 Edef := 8947 Make_Defining_Identifier (Loc, 8948 Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'E')); 8949 Sub := 8950 Make_Subprogram_Declaration (Loc, 8951 Specification => 8952 Build_Protected_Entry_Specification (Loc, Edef, Comp_Id)); 8953 8954 Insert_After (Current_Node, Sub); 8955 Analyze (Sub); 8956 8957 -- Build wrapper procedure for pre/postconditions 8958 8959 Build_PPC_Wrapper (Comp_Id, N); 8960 8961 Set_Protected_Body_Subprogram 8962 (Defining_Identifier (Comp), 8963 Defining_Unit_Name (Specification (Sub))); 8964 8965 Current_Node := Sub; 8966 8967 Bdef := 8968 Make_Defining_Identifier (Loc, 8969 Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'B')); 8970 Sub := 8971 Make_Subprogram_Declaration (Loc, 8972 Specification => 8973 Build_Barrier_Function_Specification (Loc, Bdef)); 8974 8975 Insert_After (Current_Node, Sub); 8976 Analyze (Sub); 8977 Set_Protected_Body_Subprogram (Bdef, Bdef); 8978 Set_Barrier_Function (Comp_Id, Bdef); 8979 Set_Scope (Bdef, Scope (Comp_Id)); 8980 Current_Node := Sub; 8981 8982 -- Collect pointers to the protected subprogram and the barrier 8983 -- of the current entry, for insertion into Entry_Bodies_Array. 8984 8985 Append_To (Expressions (Entries_Aggr), 8986 Make_Aggregate (Loc, 8987 Expressions => New_List ( 8988 Make_Attribute_Reference (Loc, 8989 Prefix => New_Occurrence_Of (Bdef, Loc), 8990 Attribute_Name => Name_Unrestricted_Access), 8991 Make_Attribute_Reference (Loc, 8992 Prefix => New_Occurrence_Of (Edef, Loc), 8993 Attribute_Name => Name_Unrestricted_Access)))); 8994 end Expand_Entry_Declaration; 8995 8996 ---------------------- 8997 -- Register_Handler -- 8998 ---------------------- 8999 9000 procedure Register_Handler is 9001 9002 -- All semantic checks already done in Sem_Prag 9003 9004 Prot_Proc : constant Entity_Id := 9005 Defining_Unit_Name (Specification (Current_Node)); 9006 9007 Proc_Address : constant Node_Id := 9008 Make_Attribute_Reference (Loc, 9009 Prefix => 9010 New_Occurrence_Of (Prot_Proc, Loc), 9011 Attribute_Name => Name_Address); 9012 9013 RTS_Call : constant Entity_Id := 9014 Make_Procedure_Call_Statement (Loc, 9015 Name => 9016 New_Occurrence_Of 9017 (RTE (RE_Register_Interrupt_Handler), Loc), 9018 Parameter_Associations => New_List (Proc_Address)); 9019 begin 9020 Append_Freeze_Action (Prot_Proc, RTS_Call); 9021 end Register_Handler; 9022 9023 -- Start of processing for Expand_N_Protected_Type_Declaration 9024 9025 begin 9026 if Present (Corresponding_Record_Type (Prot_Typ)) then 9027 return; 9028 else 9029 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc); 9030 end if; 9031 9032 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); 9033 9034 Qualify_Entity_Names (N); 9035 9036 -- If the type has discriminants, their occurrences in the declaration 9037 -- have been replaced by the corresponding discriminals. For components 9038 -- that are constrained by discriminants, their homologues in the 9039 -- corresponding record type must refer to the discriminants of that 9040 -- record, so we must apply a new renaming to subtypes_indications: 9041 9042 -- protected discriminant => discriminal => record discriminant 9043 9044 -- This replacement is not applied to default expressions, for which 9045 -- the discriminal is correct. 9046 9047 if Has_Discriminants (Prot_Typ) then 9048 declare 9049 Disc : Entity_Id; 9050 Decl : Node_Id; 9051 9052 begin 9053 Disc := First_Discriminant (Prot_Typ); 9054 Decl := First (Discriminant_Specifications (Rec_Decl)); 9055 while Present (Disc) loop 9056 Append_Elmt (Discriminal (Disc), Discr_Map); 9057 Append_Elmt (Defining_Identifier (Decl), Discr_Map); 9058 Next_Discriminant (Disc); 9059 Next (Decl); 9060 end loop; 9061 end; 9062 end if; 9063 9064 -- Fill in the component declarations 9065 9066 -- Add components for entry families. For each entry family, create an 9067 -- anonymous type declaration with the same size, and analyze the type. 9068 9069 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ); 9070 9071 pragma Assert (Present (Pdef)); 9072 9073 -- Add private field components 9074 9075 if Present (Private_Declarations (Pdef)) then 9076 Priv := First (Private_Declarations (Pdef)); 9077 while Present (Priv) loop 9078 if Nkind (Priv) = N_Component_Declaration then 9079 if not Static_Component_Size (Defining_Identifier (Priv)) then 9080 9081 -- When compiling for a restricted profile, the private 9082 -- components must have a static size. If not, this is an 9083 -- error for a single protected declaration, and rates a 9084 -- warning on a protected type declaration. 9085 9086 if not Comes_From_Source (Prot_Typ) then 9087 9088 -- It's ok to be checking this restriction at expansion 9089 -- time, because this is only for the restricted profile, 9090 -- which is not subject to strict RM conformance, so it 9091 -- is OK to miss this check in -gnatc mode. 9092 9093 Check_Restriction (No_Implicit_Heap_Allocations, Priv); 9094 9095 elsif Restriction_Active (No_Implicit_Heap_Allocations) then 9096 Error_Msg_N ("component has non-static size??", Priv); 9097 Error_Msg_NE 9098 ("\creation of protected object of type& will violate" 9099 & " restriction No_Implicit_Heap_Allocations??", 9100 Priv, Prot_Typ); 9101 end if; 9102 end if; 9103 9104 -- The component definition consists of a subtype indication, 9105 -- or (in Ada 2005) an access definition. Make a copy of the 9106 -- proper definition. 9107 9108 declare 9109 Old_Comp : constant Node_Id := Component_Definition (Priv); 9110 Oent : constant Entity_Id := Defining_Identifier (Priv); 9111 New_Comp : Node_Id; 9112 Nent : constant Entity_Id := 9113 Make_Defining_Identifier (Sloc (Oent), 9114 Chars => Chars (Oent)); 9115 9116 begin 9117 if Present (Subtype_Indication (Old_Comp)) then 9118 New_Comp := 9119 Make_Component_Definition (Sloc (Oent), 9120 Aliased_Present => False, 9121 Subtype_Indication => 9122 New_Copy_Tree (Subtype_Indication (Old_Comp), 9123 Discr_Map)); 9124 else 9125 New_Comp := 9126 Make_Component_Definition (Sloc (Oent), 9127 Aliased_Present => False, 9128 Access_Definition => 9129 New_Copy_Tree (Access_Definition (Old_Comp), 9130 Discr_Map)); 9131 end if; 9132 9133 New_Priv := 9134 Make_Component_Declaration (Loc, 9135 Defining_Identifier => Nent, 9136 Component_Definition => New_Comp, 9137 Expression => Expression (Priv)); 9138 9139 Set_Has_Per_Object_Constraint (Nent, 9140 Has_Per_Object_Constraint (Oent)); 9141 9142 Append_To (Cdecls, New_Priv); 9143 end; 9144 9145 elsif Nkind (Priv) = N_Subprogram_Declaration then 9146 9147 -- Make the unprotected version of the subprogram available 9148 -- for expansion of intra object calls. There is need for 9149 -- a protected version only if the subprogram is an interrupt 9150 -- handler, otherwise this operation can only be called from 9151 -- within the body. 9152 9153 Sub := 9154 Make_Subprogram_Declaration (Loc, 9155 Specification => 9156 Build_Protected_Sub_Specification 9157 (Priv, Prot_Typ, Unprotected_Mode)); 9158 9159 Insert_After (Current_Node, Sub); 9160 Analyze (Sub); 9161 9162 Set_Protected_Body_Subprogram 9163 (Defining_Unit_Name (Specification (Priv)), 9164 Defining_Unit_Name (Specification (Sub))); 9165 Check_Inlining (Defining_Unit_Name (Specification (Priv))); 9166 Current_Node := Sub; 9167 9168 Sub := 9169 Make_Subprogram_Declaration (Loc, 9170 Specification => 9171 Build_Protected_Sub_Specification 9172 (Priv, Prot_Typ, Protected_Mode)); 9173 9174 Insert_After (Current_Node, Sub); 9175 Analyze (Sub); 9176 Current_Node := Sub; 9177 9178 if Is_Interrupt_Handler 9179 (Defining_Unit_Name (Specification (Priv))) 9180 then 9181 if not Restricted_Profile then 9182 Register_Handler; 9183 end if; 9184 end if; 9185 end if; 9186 9187 Next (Priv); 9188 end loop; 9189 end if; 9190 9191 -- Except for the lock-free implementation, append the _Object field 9192 -- with the right type to the component list. We need to compute the 9193 -- number of entries, and in some cases the number of Attach_Handler 9194 -- pragmas. 9195 9196 if not Lock_Free_Active then 9197 declare 9198 Ritem : Node_Id; 9199 Num_Attach_Handler : Int := 0; 9200 Protection_Subtype : Node_Id; 9201 Entry_Count_Expr : constant Node_Id := 9202 Build_Entry_Count_Expression 9203 (Prot_Typ, Cdecls, Loc); 9204 9205 begin 9206 if Has_Attach_Handler (Prot_Typ) then 9207 Ritem := First_Rep_Item (Prot_Typ); 9208 while Present (Ritem) loop 9209 if Nkind (Ritem) = N_Pragma 9210 and then Pragma_Name (Ritem) = Name_Attach_Handler 9211 then 9212 Num_Attach_Handler := Num_Attach_Handler + 1; 9213 end if; 9214 9215 Next_Rep_Item (Ritem); 9216 end loop; 9217 end if; 9218 9219 -- Determine the proper protection type. There are two special 9220 -- cases: 1) when the protected type has dynamic interrupt 9221 -- handlers, and 2) when it has static handlers and we use a 9222 -- restricted profile. 9223 9224 if Has_Attach_Handler (Prot_Typ) 9225 and then not Restricted_Profile 9226 then 9227 Protection_Subtype := 9228 Make_Subtype_Indication (Loc, 9229 Subtype_Mark => 9230 New_Occurrence_Of 9231 (RTE (RE_Static_Interrupt_Protection), Loc), 9232 Constraint => 9233 Make_Index_Or_Discriminant_Constraint (Loc, 9234 Constraints => New_List ( 9235 Entry_Count_Expr, 9236 Make_Integer_Literal (Loc, Num_Attach_Handler)))); 9237 9238 elsif Has_Interrupt_Handler (Prot_Typ) 9239 and then not Restriction_Active (No_Dynamic_Attachment) 9240 then 9241 Protection_Subtype := 9242 Make_Subtype_Indication (Loc, 9243 Subtype_Mark => 9244 New_Occurrence_Of 9245 (RTE (RE_Dynamic_Interrupt_Protection), Loc), 9246 Constraint => 9247 Make_Index_Or_Discriminant_Constraint (Loc, 9248 Constraints => New_List (Entry_Count_Expr))); 9249 9250 else 9251 case Corresponding_Runtime_Package (Prot_Typ) is 9252 when System_Tasking_Protected_Objects_Entries => 9253 Protection_Subtype := 9254 Make_Subtype_Indication (Loc, 9255 Subtype_Mark => 9256 New_Occurrence_Of 9257 (RTE (RE_Protection_Entries), Loc), 9258 Constraint => 9259 Make_Index_Or_Discriminant_Constraint (Loc, 9260 Constraints => New_List (Entry_Count_Expr))); 9261 9262 when System_Tasking_Protected_Objects_Single_Entry => 9263 Protection_Subtype := 9264 New_Occurrence_Of (RTE (RE_Protection_Entry), Loc); 9265 9266 when System_Tasking_Protected_Objects => 9267 Protection_Subtype := 9268 New_Occurrence_Of (RTE (RE_Protection), Loc); 9269 9270 when others => 9271 raise Program_Error; 9272 end case; 9273 end if; 9274 9275 Object_Comp := 9276 Make_Component_Declaration (Loc, 9277 Defining_Identifier => 9278 Make_Defining_Identifier (Loc, Name_uObject), 9279 Component_Definition => 9280 Make_Component_Definition (Loc, 9281 Aliased_Present => True, 9282 Subtype_Indication => Protection_Subtype)); 9283 end; 9284 9285 -- Put the _Object component after the private component so that it 9286 -- be finalized early as required by 9.4 (20) 9287 9288 Append_To (Cdecls, Object_Comp); 9289 end if; 9290 9291 Insert_After (Current_Node, Rec_Decl); 9292 Current_Node := Rec_Decl; 9293 9294 -- Analyze the record declaration immediately after construction, 9295 -- because the initialization procedure is needed for single object 9296 -- declarations before the next entity is analyzed (the freeze call 9297 -- that generates this initialization procedure is found below). 9298 9299 Analyze (Rec_Decl, Suppress => All_Checks); 9300 9301 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before 9302 -- the corresponding record is frozen. If any wrappers are generated, 9303 -- Current_Node is updated accordingly. 9304 9305 if Ada_Version >= Ada_2005 then 9306 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node); 9307 end if; 9308 9309 -- Collect pointers to entry bodies and their barriers, to be placed 9310 -- in the Entry_Bodies_Array for the type. For each entry/family we 9311 -- add an expression to the aggregate which is the initial value of 9312 -- this array. The array is declared after all protected subprograms. 9313 9314 if Has_Entries (Prot_Typ) then 9315 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List); 9316 else 9317 Entries_Aggr := Empty; 9318 end if; 9319 9320 -- Build two new procedure specifications for each protected subprogram; 9321 -- one to call from outside the object and one to call from inside. 9322 -- Build a barrier function and an entry body action procedure 9323 -- specification for each protected entry. Initialize the entry body 9324 -- array. If subprogram is flagged as eliminated, do not generate any 9325 -- internal operations. 9326 9327 E_Count := 0; 9328 Comp := First (Visible_Declarations (Pdef)); 9329 while Present (Comp) loop 9330 if Nkind (Comp) = N_Subprogram_Declaration then 9331 Sub := 9332 Make_Subprogram_Declaration (Loc, 9333 Specification => 9334 Build_Protected_Sub_Specification 9335 (Comp, Prot_Typ, Unprotected_Mode)); 9336 9337 Insert_After (Current_Node, Sub); 9338 Analyze (Sub); 9339 9340 Set_Protected_Body_Subprogram 9341 (Defining_Unit_Name (Specification (Comp)), 9342 Defining_Unit_Name (Specification (Sub))); 9343 Check_Inlining (Defining_Unit_Name (Specification (Comp))); 9344 9345 -- Make the protected version of the subprogram available for 9346 -- expansion of external calls. 9347 9348 Current_Node := Sub; 9349 9350 Sub := 9351 Make_Subprogram_Declaration (Loc, 9352 Specification => 9353 Build_Protected_Sub_Specification 9354 (Comp, Prot_Typ, Protected_Mode)); 9355 9356 Insert_After (Current_Node, Sub); 9357 Analyze (Sub); 9358 9359 Current_Node := Sub; 9360 9361 -- Generate an overriding primitive operation specification for 9362 -- this subprogram if the protected type implements an interface. 9363 9364 if Ada_Version >= Ada_2005 9365 and then 9366 Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) 9367 then 9368 Sub := 9369 Make_Subprogram_Declaration (Loc, 9370 Specification => 9371 Build_Protected_Sub_Specification 9372 (Comp, Prot_Typ, Dispatching_Mode)); 9373 9374 Insert_After (Current_Node, Sub); 9375 Analyze (Sub); 9376 9377 Current_Node := Sub; 9378 end if; 9379 9380 -- If a pragma Interrupt_Handler applies, build and add a call to 9381 -- Register_Interrupt_Handler to the freezing actions of the 9382 -- protected version (Current_Node) of the subprogram: 9383 9384 -- system.interrupts.register_interrupt_handler 9385 -- (prot_procP'address); 9386 9387 if not Restricted_Profile 9388 and then Is_Interrupt_Handler 9389 (Defining_Unit_Name (Specification (Comp))) 9390 then 9391 Register_Handler; 9392 end if; 9393 9394 elsif Nkind (Comp) = N_Entry_Declaration then 9395 9396 Expand_Entry_Declaration (Comp); 9397 9398 end if; 9399 9400 Next (Comp); 9401 end loop; 9402 9403 -- If there are some private entry declarations, expand it as if they 9404 -- were visible entries. 9405 9406 if Present (Private_Declarations (Pdef)) then 9407 Comp := First (Private_Declarations (Pdef)); 9408 while Present (Comp) loop 9409 if Nkind (Comp) = N_Entry_Declaration then 9410 Expand_Entry_Declaration (Comp); 9411 end if; 9412 9413 Next (Comp); 9414 end loop; 9415 end if; 9416 9417 -- Emit declaration for Entry_Bodies_Array, now that the addresses of 9418 -- all protected subprograms have been collected. 9419 9420 if Has_Entries (Prot_Typ) then 9421 Body_Id := 9422 Make_Defining_Identifier (Sloc (Prot_Typ), 9423 Chars => New_External_Name (Chars (Prot_Typ), 'A')); 9424 9425 case Corresponding_Runtime_Package (Prot_Typ) is 9426 when System_Tasking_Protected_Objects_Entries => 9427 Body_Arr := Make_Object_Declaration (Loc, 9428 Defining_Identifier => Body_Id, 9429 Aliased_Present => True, 9430 Object_Definition => 9431 Make_Subtype_Indication (Loc, 9432 Subtype_Mark => New_Occurrence_Of ( 9433 RTE (RE_Protected_Entry_Body_Array), Loc), 9434 Constraint => 9435 Make_Index_Or_Discriminant_Constraint (Loc, 9436 Constraints => New_List ( 9437 Make_Range (Loc, 9438 Make_Integer_Literal (Loc, 1), 9439 Make_Integer_Literal (Loc, E_Count))))), 9440 Expression => Entries_Aggr); 9441 9442 when System_Tasking_Protected_Objects_Single_Entry => 9443 Body_Arr := Make_Object_Declaration (Loc, 9444 Defining_Identifier => Body_Id, 9445 Aliased_Present => True, 9446 Object_Definition => New_Occurrence_Of 9447 (RTE (RE_Entry_Body), Loc), 9448 Expression => Remove_Head (Expressions (Entries_Aggr))); 9449 9450 when others => 9451 raise Program_Error; 9452 end case; 9453 9454 -- A pointer to this array will be placed in the corresponding record 9455 -- by its initialization procedure so this needs to be analyzed here. 9456 9457 Insert_After (Current_Node, Body_Arr); 9458 Current_Node := Body_Arr; 9459 Analyze (Body_Arr); 9460 9461 Set_Entry_Bodies_Array (Prot_Typ, Body_Id); 9462 9463 -- Finally, build the function that maps an entry index into the 9464 -- corresponding body. A pointer to this function is placed in each 9465 -- object of the type. Except for a ravenscar-like profile (no abort, 9466 -- no entry queue, 1 entry) 9467 9468 if Corresponding_Runtime_Package (Prot_Typ) = 9469 System_Tasking_Protected_Objects_Entries 9470 then 9471 Sub := 9472 Make_Subprogram_Declaration (Loc, 9473 Specification => Build_Find_Body_Index_Spec (Prot_Typ)); 9474 Insert_After (Current_Node, Sub); 9475 Analyze (Sub); 9476 end if; 9477 end if; 9478 end Expand_N_Protected_Type_Declaration; 9479 9480 -------------------------------- 9481 -- Expand_N_Requeue_Statement -- 9482 -------------------------------- 9483 9484 -- A non-dispatching requeue statement is expanded into one of four GNARLI 9485 -- operations, depending on the source and destination (task or protected 9486 -- object). A dispatching requeue statement is expanded into a call to the 9487 -- predefined primitive _Disp_Requeue. In addition, code is generated to 9488 -- jump around the remainder of processing for the original entry and, if 9489 -- the destination is (different) protected object, to attempt to service 9490 -- it. The following illustrates the various cases: 9491 9492 -- procedure entE 9493 -- (O : System.Address; 9494 -- P : System.Address; 9495 -- E : Protected_Entry_Index) 9496 -- is 9497 -- <discriminant renamings> 9498 -- <private object renamings> 9499 -- type poVP is access poV; 9500 -- _object : ptVP := ptVP!(O); 9501 9502 -- begin 9503 -- begin 9504 -- <start of statement sequence for entry> 9505 9506 -- -- Requeue from one protected entry body to another protected 9507 -- -- entry. 9508 9509 -- Requeue_Protected_Entry ( 9510 -- _object._object'Access, 9511 -- new._object'Access, 9512 -- E, 9513 -- Abort_Present); 9514 -- return; 9515 9516 -- <some more of the statement sequence for entry> 9517 9518 -- -- Requeue from an entry body to a task entry 9519 9520 -- Requeue_Protected_To_Task_Entry ( 9521 -- New._task_id, 9522 -- E, 9523 -- Abort_Present); 9524 -- return; 9525 9526 -- <rest of statement sequence for entry> 9527 -- Complete_Entry_Body (_object._object); 9528 9529 -- exception 9530 -- when all others => 9531 -- Exceptional_Complete_Entry_Body ( 9532 -- _object._object, Get_GNAT_Exception); 9533 -- end; 9534 -- end entE; 9535 9536 -- Requeue of a task entry call to a task entry 9537 9538 -- Accept_Call (E, Ann); 9539 -- <start of statement sequence for accept statement> 9540 -- Requeue_Task_Entry (New._task_id, E, Abort_Present); 9541 -- goto Lnn; 9542 -- <rest of statement sequence for accept statement> 9543 -- <<Lnn>> 9544 -- Complete_Rendezvous; 9545 9546 -- exception 9547 -- when all others => 9548 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9549 9550 -- Requeue of a task entry call to a protected entry 9551 9552 -- Accept_Call (E, Ann); 9553 -- <start of statement sequence for accept statement> 9554 -- Requeue_Task_To_Protected_Entry ( 9555 -- new._object'Access, 9556 -- E, 9557 -- Abort_Present); 9558 -- newS (new, Pnn); 9559 -- goto Lnn; 9560 -- <rest of statement sequence for accept statement> 9561 -- <<Lnn>> 9562 -- Complete_Rendezvous; 9563 9564 -- exception 9565 -- when all others => 9566 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9567 9568 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9569 -- marked by pragma Implemented (XXX, By_Entry). 9570 9571 -- The requeue is inside a protected entry: 9572 9573 -- procedure entE 9574 -- (O : System.Address; 9575 -- P : System.Address; 9576 -- E : Protected_Entry_Index) 9577 -- is 9578 -- <discriminant renamings> 9579 -- <private object renamings> 9580 -- type poVP is access poV; 9581 -- _object : ptVP := ptVP!(O); 9582 9583 -- begin 9584 -- begin 9585 -- <start of statement sequence for entry> 9586 9587 -- _Disp_Requeue 9588 -- (<interface class-wide object>, 9589 -- True, 9590 -- _object'Address, 9591 -- Ada.Tags.Get_Offset_Index 9592 -- (Tag (_object), 9593 -- <interface dispatch table index of target entry>), 9594 -- Abort_Present); 9595 -- return; 9596 9597 -- <rest of statement sequence for entry> 9598 -- Complete_Entry_Body (_object._object); 9599 9600 -- exception 9601 -- when all others => 9602 -- Exceptional_Complete_Entry_Body ( 9603 -- _object._object, Get_GNAT_Exception); 9604 -- end; 9605 -- end entE; 9606 9607 -- The requeue is inside a task entry: 9608 9609 -- Accept_Call (E, Ann); 9610 -- <start of statement sequence for accept statement> 9611 -- _Disp_Requeue 9612 -- (<interface class-wide object>, 9613 -- False, 9614 -- null, 9615 -- Ada.Tags.Get_Offset_Index 9616 -- (Tag (_object), 9617 -- <interface dispatch table index of target entrt>), 9618 -- Abort_Present); 9619 -- newS (new, Pnn); 9620 -- goto Lnn; 9621 -- <rest of statement sequence for accept statement> 9622 -- <<Lnn>> 9623 -- Complete_Rendezvous; 9624 9625 -- exception 9626 -- when all others => 9627 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9628 9629 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9630 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue 9631 -- statement is replaced by a dispatching call with actual parameters taken 9632 -- from the inner-most accept statement or entry body. 9633 9634 -- Target.Primitive (Param1, ..., ParamN); 9635 9636 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9637 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked 9638 -- at all. 9639 9640 -- declare 9641 -- S : constant Offset_Index := 9642 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename)); 9643 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S); 9644 9645 -- begin 9646 -- if C = POK_Protected_Entry 9647 -- or else C = POK_Task_Entry 9648 -- then 9649 -- <statements for dispatching requeue> 9650 9651 -- elsif C = POK_Protected_Procedure then 9652 -- <dispatching call equivalent> 9653 9654 -- else 9655 -- raise Program_Error; 9656 -- end if; 9657 -- end; 9658 9659 procedure Expand_N_Requeue_Statement (N : Node_Id) is 9660 Loc : constant Source_Ptr := Sloc (N); 9661 Conc_Typ : Entity_Id; 9662 Concval : Node_Id; 9663 Ename : Node_Id; 9664 Index : Node_Id; 9665 Old_Typ : Entity_Id; 9666 9667 function Build_Dispatching_Call_Equivalent return Node_Id; 9668 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9669 -- the form Concval.Ename. It is statically known that Ename is allowed 9670 -- to be implemented by a protected procedure. Create a dispatching call 9671 -- equivalent of Concval.Ename taking the actual parameters from the 9672 -- inner-most accept statement or entry body. 9673 9674 function Build_Dispatching_Requeue return Node_Id; 9675 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9676 -- the form Concval.Ename. It is statically known that Ename is allowed 9677 -- to be implemented by a protected or a task entry. Create a call to 9678 -- primitive _Disp_Requeue which handles the low-level actions. 9679 9680 function Build_Dispatching_Requeue_To_Any return Node_Id; 9681 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9682 -- the form Concval.Ename. Ename is either marked by pragma Implemented 9683 -- (XXX, By_Any | Optional) or not marked at all. Create a block which 9684 -- determines at runtime whether Ename denotes an entry or a procedure 9685 -- and perform the appropriate kind of dispatching select. 9686 9687 function Build_Normal_Requeue return Node_Id; 9688 -- N denotes a non-dispatching requeue statement to either a task or a 9689 -- protected entry. Build the appropriate runtime call to perform the 9690 -- action. 9691 9692 function Build_Skip_Statement (Search : Node_Id) return Node_Id; 9693 -- For a protected entry, create a return statement to skip the rest of 9694 -- the entry body. Otherwise, create a goto statement to skip the rest 9695 -- of a task accept statement. The lookup for the enclosing entry body 9696 -- or accept statement starts from Search. 9697 9698 --------------------------------------- 9699 -- Build_Dispatching_Call_Equivalent -- 9700 --------------------------------------- 9701 9702 function Build_Dispatching_Call_Equivalent return Node_Id is 9703 Call_Ent : constant Entity_Id := Entity (Ename); 9704 Obj : constant Node_Id := Original_Node (Concval); 9705 Acc_Ent : Node_Id; 9706 Actuals : List_Id; 9707 Formal : Node_Id; 9708 Formals : List_Id; 9709 9710 begin 9711 -- Climb the parent chain looking for the inner-most entry body or 9712 -- accept statement. 9713 9714 Acc_Ent := N; 9715 while Present (Acc_Ent) 9716 and then not Nkind_In (Acc_Ent, N_Accept_Statement, 9717 N_Entry_Body) 9718 loop 9719 Acc_Ent := Parent (Acc_Ent); 9720 end loop; 9721 9722 -- A requeue statement should be housed inside an entry body or an 9723 -- accept statement at some level. If this is not the case, then the 9724 -- tree is malformed. 9725 9726 pragma Assert (Present (Acc_Ent)); 9727 9728 -- Recover the list of formal parameters 9729 9730 if Nkind (Acc_Ent) = N_Entry_Body then 9731 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent); 9732 end if; 9733 9734 Formals := Parameter_Specifications (Acc_Ent); 9735 9736 -- Create the actual parameters for the dispatching call. These are 9737 -- simply copies of the entry body or accept statement formals in the 9738 -- same order as they appear. 9739 9740 Actuals := No_List; 9741 9742 if Present (Formals) then 9743 Actuals := New_List; 9744 Formal := First (Formals); 9745 while Present (Formal) loop 9746 Append_To (Actuals, 9747 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 9748 Next (Formal); 9749 end loop; 9750 end if; 9751 9752 -- Generate: 9753 -- Obj.Call_Ent (Actuals); 9754 9755 return 9756 Make_Procedure_Call_Statement (Loc, 9757 Name => 9758 Make_Selected_Component (Loc, 9759 Prefix => Make_Identifier (Loc, Chars (Obj)), 9760 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))), 9761 9762 Parameter_Associations => Actuals); 9763 end Build_Dispatching_Call_Equivalent; 9764 9765 ------------------------------- 9766 -- Build_Dispatching_Requeue -- 9767 ------------------------------- 9768 9769 function Build_Dispatching_Requeue return Node_Id is 9770 Params : constant List_Id := New_List; 9771 9772 begin 9773 -- Process the "with abort" parameter 9774 9775 Prepend_To (Params, 9776 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 9777 9778 -- Process the entry wrapper's position in the primary dispatch 9779 -- table parameter. Generate: 9780 9781 -- Ada.Tags.Get_Entry_Index 9782 -- (T => To_Tag_Ptr (Obj'Address).all, 9783 -- Position => 9784 -- Ada.Tags.Get_Offset_Index 9785 -- (Ada.Tags.Tag (Concval), 9786 -- <interface dispatch table position of Ename>)); 9787 9788 -- Note that Obj'Address is recursively expanded into a call to 9789 -- Base_Address (Obj). 9790 9791 if Tagged_Type_Expansion then 9792 Prepend_To (Params, 9793 Make_Function_Call (Loc, 9794 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 9795 Parameter_Associations => New_List ( 9796 9797 Make_Explicit_Dereference (Loc, 9798 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 9799 Make_Attribute_Reference (Loc, 9800 Prefix => New_Copy_Tree (Concval), 9801 Attribute_Name => Name_Address))), 9802 9803 Make_Function_Call (Loc, 9804 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 9805 Parameter_Associations => New_List ( 9806 Unchecked_Convert_To (RTE (RE_Tag), Concval), 9807 Make_Integer_Literal (Loc, 9808 DT_Position (Entity (Ename)))))))); 9809 9810 -- VM targets 9811 9812 else 9813 Prepend_To (Params, 9814 Make_Function_Call (Loc, 9815 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 9816 Parameter_Associations => New_List ( 9817 9818 Make_Attribute_Reference (Loc, 9819 Prefix => Concval, 9820 Attribute_Name => Name_Tag), 9821 9822 Make_Function_Call (Loc, 9823 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 9824 9825 Parameter_Associations => New_List ( 9826 9827 -- Obj_Tag 9828 9829 Make_Attribute_Reference (Loc, 9830 Prefix => Concval, 9831 Attribute_Name => Name_Tag), 9832 9833 -- Tag_Typ 9834 9835 Make_Attribute_Reference (Loc, 9836 Prefix => New_Occurrence_Of (Etype (Concval), Loc), 9837 Attribute_Name => Name_Tag), 9838 9839 -- Position 9840 9841 Make_Integer_Literal (Loc, 9842 DT_Position (Entity (Ename)))))))); 9843 end if; 9844 9845 -- Specific actuals for protected to XXX requeue 9846 9847 if Is_Protected_Type (Old_Typ) then 9848 Prepend_To (Params, 9849 Make_Attribute_Reference (Loc, -- _object'Address 9850 Prefix => 9851 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 9852 Attribute_Name => Name_Address)); 9853 9854 Prepend_To (Params, -- True 9855 New_Occurrence_Of (Standard_True, Loc)); 9856 9857 -- Specific actuals for task to XXX requeue 9858 9859 else 9860 pragma Assert (Is_Task_Type (Old_Typ)); 9861 9862 Prepend_To (Params, -- null 9863 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 9864 9865 Prepend_To (Params, -- False 9866 New_Occurrence_Of (Standard_False, Loc)); 9867 end if; 9868 9869 -- Add the object parameter 9870 9871 Prepend_To (Params, New_Copy_Tree (Concval)); 9872 9873 -- Generate: 9874 -- _Disp_Requeue (<Params>); 9875 9876 -- Find entity for Disp_Requeue operation, which belongs to 9877 -- the type and may not be directly visible. 9878 9879 declare 9880 Elmt : Elmt_Id; 9881 Op : Entity_Id; 9882 9883 begin 9884 Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ))); 9885 while Present (Elmt) loop 9886 Op := Node (Elmt); 9887 exit when Chars (Op) = Name_uDisp_Requeue; 9888 Next_Elmt (Elmt); 9889 end loop; 9890 9891 return 9892 Make_Procedure_Call_Statement (Loc, 9893 Name => New_Occurrence_Of (Op, Loc), 9894 Parameter_Associations => Params); 9895 end; 9896 end Build_Dispatching_Requeue; 9897 9898 -------------------------------------- 9899 -- Build_Dispatching_Requeue_To_Any -- 9900 -------------------------------------- 9901 9902 function Build_Dispatching_Requeue_To_Any return Node_Id is 9903 Call_Ent : constant Entity_Id := Entity (Ename); 9904 Obj : constant Node_Id := Original_Node (Concval); 9905 Skip : constant Node_Id := Build_Skip_Statement (N); 9906 C : Entity_Id; 9907 Decls : List_Id; 9908 S : Entity_Id; 9909 Stmts : List_Id; 9910 9911 begin 9912 Decls := New_List; 9913 Stmts := New_List; 9914 9915 -- Dispatch table slot processing, generate: 9916 -- S : Integer; 9917 9918 S := Build_S (Loc, Decls); 9919 9920 -- Call kind processing, generate: 9921 -- C : Ada.Tags.Prim_Op_Kind; 9922 9923 C := Build_C (Loc, Decls); 9924 9925 -- Generate: 9926 -- S := Ada.Tags.Get_Offset_Index 9927 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent)); 9928 9929 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent)); 9930 9931 -- Generate: 9932 -- _Disp_Get_Prim_Op_Kind (Obj, S, C); 9933 9934 Append_To (Stmts, 9935 Make_Procedure_Call_Statement (Loc, 9936 Name => 9937 New_Occurrence_Of ( 9938 Find_Prim_Op (Etype (Etype (Obj)), 9939 Name_uDisp_Get_Prim_Op_Kind), 9940 Loc), 9941 Parameter_Associations => New_List ( 9942 New_Copy_Tree (Obj), 9943 New_Occurrence_Of (S, Loc), 9944 New_Occurrence_Of (C, Loc)))); 9945 9946 Append_To (Stmts, 9947 9948 -- if C = POK_Protected_Entry 9949 -- or else C = POK_Task_Entry 9950 -- then 9951 9952 Make_Implicit_If_Statement (N, 9953 Condition => 9954 Make_Op_Or (Loc, 9955 Left_Opnd => 9956 Make_Op_Eq (Loc, 9957 Left_Opnd => 9958 New_Occurrence_Of (C, Loc), 9959 Right_Opnd => 9960 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 9961 9962 Right_Opnd => 9963 Make_Op_Eq (Loc, 9964 Left_Opnd => 9965 New_Occurrence_Of (C, Loc), 9966 Right_Opnd => 9967 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 9968 9969 -- Dispatching requeue equivalent 9970 9971 Then_Statements => New_List ( 9972 Build_Dispatching_Requeue, 9973 Skip), 9974 9975 -- elsif C = POK_Protected_Procedure then 9976 9977 Elsif_Parts => New_List ( 9978 Make_Elsif_Part (Loc, 9979 Condition => 9980 Make_Op_Eq (Loc, 9981 Left_Opnd => 9982 New_Occurrence_Of (C, Loc), 9983 Right_Opnd => 9984 New_Occurrence_Of ( 9985 RTE (RE_POK_Protected_Procedure), Loc)), 9986 9987 -- Dispatching call equivalent 9988 9989 Then_Statements => New_List ( 9990 Build_Dispatching_Call_Equivalent))), 9991 9992 -- else 9993 -- raise Program_Error; 9994 -- end if; 9995 9996 Else_Statements => New_List ( 9997 Make_Raise_Program_Error (Loc, 9998 Reason => PE_Explicit_Raise)))); 9999 10000 -- Wrap everything into a block 10001 10002 return 10003 Make_Block_Statement (Loc, 10004 Declarations => Decls, 10005 Handled_Statement_Sequence => 10006 Make_Handled_Sequence_Of_Statements (Loc, 10007 Statements => Stmts)); 10008 end Build_Dispatching_Requeue_To_Any; 10009 10010 -------------------------- 10011 -- Build_Normal_Requeue -- 10012 -------------------------- 10013 10014 function Build_Normal_Requeue return Node_Id is 10015 Params : constant List_Id := New_List; 10016 Param : Node_Id; 10017 RT_Call : Node_Id; 10018 10019 begin 10020 -- Process the "with abort" parameter 10021 10022 Prepend_To (Params, 10023 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 10024 10025 -- Add the index expression to the parameters. It is common among all 10026 -- four cases. 10027 10028 Prepend_To (Params, 10029 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ)); 10030 10031 if Is_Protected_Type (Old_Typ) then 10032 declare 10033 Self_Param : Node_Id; 10034 10035 begin 10036 Self_Param := 10037 Make_Attribute_Reference (Loc, 10038 Prefix => 10039 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 10040 Attribute_Name => 10041 Name_Unchecked_Access); 10042 10043 -- Protected to protected requeue 10044 10045 if Is_Protected_Type (Conc_Typ) then 10046 RT_Call := 10047 New_Occurrence_Of ( 10048 RTE (RE_Requeue_Protected_Entry), Loc); 10049 10050 Param := 10051 Make_Attribute_Reference (Loc, 10052 Prefix => 10053 Concurrent_Ref (Concval), 10054 Attribute_Name => 10055 Name_Unchecked_Access); 10056 10057 -- Protected to task requeue 10058 10059 else pragma Assert (Is_Task_Type (Conc_Typ)); 10060 RT_Call := 10061 New_Occurrence_Of ( 10062 RTE (RE_Requeue_Protected_To_Task_Entry), Loc); 10063 10064 Param := Concurrent_Ref (Concval); 10065 end if; 10066 10067 Prepend_To (Params, Param); 10068 Prepend_To (Params, Self_Param); 10069 end; 10070 10071 else pragma Assert (Is_Task_Type (Old_Typ)); 10072 10073 -- Task to protected requeue 10074 10075 if Is_Protected_Type (Conc_Typ) then 10076 RT_Call := 10077 New_Occurrence_Of ( 10078 RTE (RE_Requeue_Task_To_Protected_Entry), Loc); 10079 10080 Param := 10081 Make_Attribute_Reference (Loc, 10082 Prefix => 10083 Concurrent_Ref (Concval), 10084 Attribute_Name => 10085 Name_Unchecked_Access); 10086 10087 -- Task to task requeue 10088 10089 else pragma Assert (Is_Task_Type (Conc_Typ)); 10090 RT_Call := 10091 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc); 10092 10093 Param := Concurrent_Ref (Concval); 10094 end if; 10095 10096 Prepend_To (Params, Param); 10097 end if; 10098 10099 return 10100 Make_Procedure_Call_Statement (Loc, 10101 Name => RT_Call, 10102 Parameter_Associations => Params); 10103 end Build_Normal_Requeue; 10104 10105 -------------------------- 10106 -- Build_Skip_Statement -- 10107 -------------------------- 10108 10109 function Build_Skip_Statement (Search : Node_Id) return Node_Id is 10110 Skip_Stmt : Node_Id; 10111 10112 begin 10113 -- Build a return statement to skip the rest of the entire body 10114 10115 if Is_Protected_Type (Old_Typ) then 10116 Skip_Stmt := Make_Simple_Return_Statement (Loc); 10117 10118 -- If the requeue is within a task, find the end label of the 10119 -- enclosing accept statement and create a goto statement to it. 10120 10121 else 10122 declare 10123 Acc : Node_Id; 10124 Label : Node_Id; 10125 10126 begin 10127 -- Climb the parent chain looking for the enclosing accept 10128 -- statement. 10129 10130 Acc := Parent (Search); 10131 while Present (Acc) 10132 and then Nkind (Acc) /= N_Accept_Statement 10133 loop 10134 Acc := Parent (Acc); 10135 end loop; 10136 10137 -- The last statement is the second label used for completing 10138 -- the rendezvous the usual way. The label we are looking for 10139 -- is right before it. 10140 10141 Label := 10142 Prev (Last (Statements (Handled_Statement_Sequence (Acc)))); 10143 10144 pragma Assert (Nkind (Label) = N_Label); 10145 10146 -- Generate a goto statement to skip the rest of the accept 10147 10148 Skip_Stmt := 10149 Make_Goto_Statement (Loc, 10150 Name => 10151 New_Occurrence_Of (Entity (Identifier (Label)), Loc)); 10152 end; 10153 end if; 10154 10155 Set_Analyzed (Skip_Stmt); 10156 10157 return Skip_Stmt; 10158 end Build_Skip_Statement; 10159 10160 -- Start of processing for Expand_N_Requeue_Statement 10161 10162 begin 10163 -- Extract the components of the entry call 10164 10165 Extract_Entry (N, Concval, Ename, Index); 10166 Conc_Typ := Etype (Concval); 10167 10168 -- If the prefix is an access to class-wide type, dereference to get 10169 -- object and entry type. 10170 10171 if Is_Access_Type (Conc_Typ) then 10172 Conc_Typ := Designated_Type (Conc_Typ); 10173 Rewrite (Concval, 10174 Make_Explicit_Dereference (Loc, Relocate_Node (Concval))); 10175 Analyze_And_Resolve (Concval, Conc_Typ); 10176 end if; 10177 10178 -- Examine the scope stack in order to find nearest enclosing protected 10179 -- or task type. This will constitute our invocation source. 10180 10181 Old_Typ := Current_Scope; 10182 while Present (Old_Typ) 10183 and then not Is_Protected_Type (Old_Typ) 10184 and then not Is_Task_Type (Old_Typ) 10185 loop 10186 Old_Typ := Scope (Old_Typ); 10187 end loop; 10188 10189 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form 10190 -- Concval.Ename where the type of Concval is class-wide concurrent 10191 -- interface. 10192 10193 if Ada_Version >= Ada_2012 10194 and then Present (Concval) 10195 and then Is_Class_Wide_Type (Conc_Typ) 10196 and then Is_Concurrent_Interface (Conc_Typ) 10197 then 10198 declare 10199 Has_Impl : Boolean := False; 10200 Impl_Kind : Name_Id := No_Name; 10201 10202 begin 10203 -- Check whether the Ename is flagged by pragma Implemented 10204 10205 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then 10206 Has_Impl := True; 10207 Impl_Kind := Implementation_Kind (Entity (Ename)); 10208 end if; 10209 10210 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10211 -- an entry. Create a call to predefined primitive _Disp_Requeue. 10212 10213 if Has_Impl 10214 and then Impl_Kind = Name_By_Entry 10215 then 10216 Rewrite (N, Build_Dispatching_Requeue); 10217 Analyze (N); 10218 Insert_After (N, Build_Skip_Statement (N)); 10219 10220 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10221 -- a protected procedure. In this case the requeue is transformed 10222 -- into a dispatching call. 10223 10224 elsif Has_Impl 10225 and then Impl_Kind = Name_By_Protected_Procedure 10226 then 10227 Rewrite (N, Build_Dispatching_Call_Equivalent); 10228 Analyze (N); 10229 10230 -- The procedure_or_entry_NAME's implementation kind is either 10231 -- By_Any, Optional, or pragma Implemented was not applied at all. 10232 -- In this case a runtime test determines whether Ename denotes an 10233 -- entry or a protected procedure and performs the appropriate 10234 -- call. 10235 10236 else 10237 Rewrite (N, Build_Dispatching_Requeue_To_Any); 10238 Analyze (N); 10239 end if; 10240 end; 10241 10242 -- Processing for regular (non-dispatching) requeues 10243 10244 else 10245 Rewrite (N, Build_Normal_Requeue); 10246 Analyze (N); 10247 Insert_After (N, Build_Skip_Statement (N)); 10248 end if; 10249 end Expand_N_Requeue_Statement; 10250 10251 ------------------------------- 10252 -- Expand_N_Selective_Accept -- 10253 ------------------------------- 10254 10255 procedure Expand_N_Selective_Accept (N : Node_Id) is 10256 Loc : constant Source_Ptr := Sloc (N); 10257 Alts : constant List_Id := Select_Alternatives (N); 10258 10259 -- Note: in the below declarations a lot of new lists are allocated 10260 -- unconditionally which may well not end up being used. That's not 10261 -- a good idea since it wastes space gratuitously ??? 10262 10263 Accept_Case : List_Id; 10264 Accept_List : constant List_Id := New_List; 10265 10266 Alt : Node_Id; 10267 Alt_List : constant List_Id := New_List; 10268 Alt_Stats : List_Id; 10269 Ann : Entity_Id := Empty; 10270 10271 Check_Guard : Boolean := True; 10272 10273 Decls : constant List_Id := New_List; 10274 Stats : constant List_Id := New_List; 10275 Body_List : constant List_Id := New_List; 10276 Trailing_List : constant List_Id := New_List; 10277 10278 Choices : List_Id; 10279 Else_Present : Boolean := False; 10280 Terminate_Alt : Node_Id := Empty; 10281 Select_Mode : Node_Id; 10282 10283 Delay_Case : List_Id; 10284 Delay_Count : Integer := 0; 10285 Delay_Val : Entity_Id; 10286 Delay_Index : Entity_Id; 10287 Delay_Min : Entity_Id; 10288 Delay_Num : Int := 1; 10289 Delay_Alt_List : List_Id := New_List; 10290 Delay_List : constant List_Id := New_List; 10291 D : Entity_Id; 10292 M : Entity_Id; 10293 10294 First_Delay : Boolean := True; 10295 Guard_Open : Entity_Id; 10296 10297 End_Lab : Node_Id; 10298 Index : Int := 1; 10299 Lab : Node_Id; 10300 Num_Alts : Int; 10301 Num_Accept : Nat := 0; 10302 Proc : Node_Id; 10303 Time_Type : Entity_Id; 10304 Select_Call : Node_Id; 10305 10306 Qnam : constant Entity_Id := 10307 Make_Defining_Identifier (Loc, New_External_Name ('S', 0)); 10308 10309 Xnam : constant Entity_Id := 10310 Make_Defining_Identifier (Loc, New_External_Name ('J', 1)); 10311 10312 ----------------------- 10313 -- Local subprograms -- 10314 ----------------------- 10315 10316 function Accept_Or_Raise return List_Id; 10317 -- For the rare case where delay alternatives all have guards, and 10318 -- all of them are closed, it is still possible that there were open 10319 -- accept alternatives with no callers. We must reexamine the 10320 -- Accept_List, and execute a selective wait with no else if some 10321 -- accept is open. If none, we raise program_error. 10322 10323 procedure Add_Accept (Alt : Node_Id); 10324 -- Process a single accept statement in a select alternative. Build 10325 -- procedure for body of accept, and add entry to dispatch table with 10326 -- expression for guard, in preparation for call to run time select. 10327 10328 function Make_And_Declare_Label (Num : Int) return Node_Id; 10329 -- Manufacture a label using Num as a serial number and declare it. 10330 -- The declaration is appended to Decls. The label marks the trailing 10331 -- statements of an accept or delay alternative. 10332 10333 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id; 10334 -- Build call to Selective_Wait runtime routine 10335 10336 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int); 10337 -- Add code to compare value of delay with previous values, and 10338 -- generate case entry for trailing statements. 10339 10340 procedure Process_Accept_Alternative 10341 (Alt : Node_Id; 10342 Index : Int; 10343 Proc : Node_Id); 10344 -- Add code to call corresponding procedure, and branch to 10345 -- trailing statements, if any. 10346 10347 --------------------- 10348 -- Accept_Or_Raise -- 10349 --------------------- 10350 10351 function Accept_Or_Raise return List_Id is 10352 Cond : Node_Id; 10353 Stats : List_Id; 10354 J : constant Entity_Id := Make_Temporary (Loc, 'J'); 10355 10356 begin 10357 -- We generate the following: 10358 10359 -- for J in q'range loop 10360 -- if q(J).S /=null_task_entry then 10361 -- selective_wait (simple_mode,...); 10362 -- done := True; 10363 -- exit; 10364 -- end if; 10365 -- end loop; 10366 -- 10367 -- if no rendez_vous then 10368 -- raise program_error; 10369 -- end if; 10370 10371 -- Note that the code needs to know that the selector name 10372 -- in an Accept_Alternative is named S. 10373 10374 Cond := Make_Op_Ne (Loc, 10375 Left_Opnd => 10376 Make_Selected_Component (Loc, 10377 Prefix => 10378 Make_Indexed_Component (Loc, 10379 Prefix => New_Occurrence_Of (Qnam, Loc), 10380 Expressions => New_List (New_Occurrence_Of (J, Loc))), 10381 Selector_Name => Make_Identifier (Loc, Name_S)), 10382 Right_Opnd => 10383 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc)); 10384 10385 Stats := New_List ( 10386 Make_Implicit_Loop_Statement (N, 10387 Iteration_Scheme => 10388 Make_Iteration_Scheme (Loc, 10389 Loop_Parameter_Specification => 10390 Make_Loop_Parameter_Specification (Loc, 10391 Defining_Identifier => J, 10392 Discrete_Subtype_Definition => 10393 Make_Attribute_Reference (Loc, 10394 Prefix => New_Occurrence_Of (Qnam, Loc), 10395 Attribute_Name => Name_Range, 10396 Expressions => New_List ( 10397 Make_Integer_Literal (Loc, 1))))), 10398 10399 Statements => New_List ( 10400 Make_Implicit_If_Statement (N, 10401 Condition => Cond, 10402 Then_Statements => New_List ( 10403 Make_Select_Call ( 10404 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)), 10405 Make_Exit_Statement (Loc)))))); 10406 10407 Append_To (Stats, 10408 Make_Raise_Program_Error (Loc, 10409 Condition => Make_Op_Eq (Loc, 10410 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 10411 Right_Opnd => 10412 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 10413 Reason => PE_All_Guards_Closed)); 10414 10415 return Stats; 10416 end Accept_Or_Raise; 10417 10418 ---------------- 10419 -- Add_Accept -- 10420 ---------------- 10421 10422 procedure Add_Accept (Alt : Node_Id) is 10423 Acc_Stm : constant Node_Id := Accept_Statement (Alt); 10424 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm); 10425 Eloc : constant Source_Ptr := Sloc (Ename); 10426 Eent : constant Entity_Id := Entity (Ename); 10427 Index : constant Node_Id := Entry_Index (Acc_Stm); 10428 Null_Body : Node_Id; 10429 Proc_Body : Node_Id; 10430 PB_Ent : Entity_Id; 10431 Expr : Node_Id; 10432 Call : Node_Id; 10433 10434 begin 10435 if No (Ann) then 10436 Ann := Node (Last_Elmt (Accept_Address (Eent))); 10437 end if; 10438 10439 if Present (Condition (Alt)) then 10440 Expr := 10441 Make_If_Expression (Eloc, New_List ( 10442 Condition (Alt), 10443 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)), 10444 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc))); 10445 else 10446 Expr := 10447 Entry_Index_Expression 10448 (Eloc, Eent, Index, Scope (Eent)); 10449 end if; 10450 10451 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then 10452 Null_Body := New_Occurrence_Of (Standard_False, Eloc); 10453 10454 -- Always add call to Abort_Undefer when generating code, since 10455 -- this is what the runtime expects (abort deferred in 10456 -- Selective_Wait). In CodePeer mode this only confuses the 10457 -- analysis with unknown calls, so don't do it. 10458 10459 if not CodePeer_Mode then 10460 Call := 10461 Make_Procedure_Call_Statement (Eloc, 10462 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Eloc)); 10463 Insert_Before 10464 (First (Statements (Handled_Statement_Sequence 10465 (Accept_Statement (Alt)))), 10466 Call); 10467 Analyze (Call); 10468 end if; 10469 10470 PB_Ent := 10471 Make_Defining_Identifier (Eloc, 10472 New_External_Name (Chars (Ename), 'A', Num_Accept)); 10473 10474 if Comes_From_Source (Alt) then 10475 Set_Debug_Info_Needed (PB_Ent); 10476 end if; 10477 10478 Proc_Body := 10479 Make_Subprogram_Body (Eloc, 10480 Specification => 10481 Make_Procedure_Specification (Eloc, 10482 Defining_Unit_Name => PB_Ent), 10483 Declarations => Declarations (Acc_Stm), 10484 Handled_Statement_Sequence => 10485 Build_Accept_Body (Accept_Statement (Alt))); 10486 10487 -- During the analysis of the body of the accept statement, any 10488 -- zero cost exception handler records were collected in the 10489 -- Accept_Handler_Records field of the N_Accept_Alternative node. 10490 -- This is where we move them to where they belong, namely the 10491 -- newly created procedure. 10492 10493 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); 10494 Append (Proc_Body, Body_List); 10495 10496 else 10497 Null_Body := New_Occurrence_Of (Standard_True, Eloc); 10498 10499 -- if accept statement has declarations, insert above, given that 10500 -- we are not creating a body for the accept. 10501 10502 if Present (Declarations (Acc_Stm)) then 10503 Insert_Actions (N, Declarations (Acc_Stm)); 10504 end if; 10505 end if; 10506 10507 Append_To (Accept_List, 10508 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr))); 10509 10510 Num_Accept := Num_Accept + 1; 10511 end Add_Accept; 10512 10513 ---------------------------- 10514 -- Make_And_Declare_Label -- 10515 ---------------------------- 10516 10517 function Make_And_Declare_Label (Num : Int) return Node_Id is 10518 Lab_Id : Node_Id; 10519 10520 begin 10521 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num)); 10522 Lab := 10523 Make_Label (Loc, Lab_Id); 10524 10525 Append_To (Decls, 10526 Make_Implicit_Label_Declaration (Loc, 10527 Defining_Identifier => 10528 Make_Defining_Identifier (Loc, Chars (Lab_Id)), 10529 Label_Construct => Lab)); 10530 10531 return Lab; 10532 end Make_And_Declare_Label; 10533 10534 ---------------------- 10535 -- Make_Select_Call -- 10536 ---------------------- 10537 10538 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is 10539 Params : constant List_Id := New_List; 10540 10541 begin 10542 Append ( 10543 Make_Attribute_Reference (Loc, 10544 Prefix => New_Occurrence_Of (Qnam, Loc), 10545 Attribute_Name => Name_Unchecked_Access), 10546 Params); 10547 Append (Select_Mode, Params); 10548 Append (New_Occurrence_Of (Ann, Loc), Params); 10549 Append (New_Occurrence_Of (Xnam, Loc), Params); 10550 10551 return 10552 Make_Procedure_Call_Statement (Loc, 10553 Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc), 10554 Parameter_Associations => Params); 10555 end Make_Select_Call; 10556 10557 -------------------------------- 10558 -- Process_Accept_Alternative -- 10559 -------------------------------- 10560 10561 procedure Process_Accept_Alternative 10562 (Alt : Node_Id; 10563 Index : Int; 10564 Proc : Node_Id) 10565 is 10566 Astmt : constant Node_Id := Accept_Statement (Alt); 10567 Alt_Stats : List_Id; 10568 10569 begin 10570 Adjust_Condition (Condition (Alt)); 10571 10572 -- Accept with body 10573 10574 if Present (Handled_Statement_Sequence (Astmt)) then 10575 Alt_Stats := 10576 New_List ( 10577 Make_Procedure_Call_Statement (Sloc (Proc), 10578 Name => 10579 New_Occurrence_Of 10580 (Defining_Unit_Name (Specification (Proc)), 10581 Sloc (Proc)))); 10582 10583 -- Accept with no body (followed by trailing statements) 10584 10585 else 10586 Alt_Stats := Empty_List; 10587 end if; 10588 10589 Ensure_Statement_Present (Sloc (Astmt), Alt); 10590 10591 -- After the call, if any, branch to trailing statements, if any. 10592 -- We create a label for each, as well as the corresponding label 10593 -- declaration. 10594 10595 if not Is_Empty_List (Statements (Alt)) then 10596 Lab := Make_And_Declare_Label (Index); 10597 Append (Lab, Trailing_List); 10598 Append_List (Statements (Alt), Trailing_List); 10599 Append_To (Trailing_List, 10600 Make_Goto_Statement (Loc, 10601 Name => New_Copy (Identifier (End_Lab)))); 10602 10603 else 10604 Lab := End_Lab; 10605 end if; 10606 10607 Append_To (Alt_Stats, 10608 Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab)))); 10609 10610 Append_To (Alt_List, 10611 Make_Case_Statement_Alternative (Loc, 10612 Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)), 10613 Statements => Alt_Stats)); 10614 end Process_Accept_Alternative; 10615 10616 ------------------------------- 10617 -- Process_Delay_Alternative -- 10618 ------------------------------- 10619 10620 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is 10621 Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt)); 10622 Cond : Node_Id; 10623 Delay_Alt : List_Id; 10624 10625 begin 10626 -- Deal with C/Fortran boolean as delay condition 10627 10628 Adjust_Condition (Condition (Alt)); 10629 10630 -- Determine the smallest specified delay 10631 10632 -- for each delay alternative generate: 10633 10634 -- if guard-expression then 10635 -- Delay_Val := delay-expression; 10636 -- Guard_Open := True; 10637 -- if Delay_Val < Delay_Min then 10638 -- Delay_Min := Delay_Val; 10639 -- Delay_Index := Index; 10640 -- end if; 10641 -- end if; 10642 10643 -- The enclosing if-statement is omitted if there is no guard 10644 10645 if Delay_Count = 1 or else First_Delay then 10646 First_Delay := False; 10647 10648 Delay_Alt := New_List ( 10649 Make_Assignment_Statement (Loc, 10650 Name => New_Occurrence_Of (Delay_Min, Loc), 10651 Expression => Expression (Delay_Statement (Alt)))); 10652 10653 if Delay_Count > 1 then 10654 Append_To (Delay_Alt, 10655 Make_Assignment_Statement (Loc, 10656 Name => New_Occurrence_Of (Delay_Index, Loc), 10657 Expression => Make_Integer_Literal (Loc, Index))); 10658 end if; 10659 10660 else 10661 Delay_Alt := New_List ( 10662 Make_Assignment_Statement (Loc, 10663 Name => New_Occurrence_Of (Delay_Val, Loc), 10664 Expression => Expression (Delay_Statement (Alt)))); 10665 10666 if Time_Type = Standard_Duration then 10667 Cond := 10668 Make_Op_Lt (Loc, 10669 Left_Opnd => New_Occurrence_Of (Delay_Val, Loc), 10670 Right_Opnd => New_Occurrence_Of (Delay_Min, Loc)); 10671 10672 else 10673 -- The scope of the time type must define a comparison 10674 -- operator. The scope itself may not be visible, so we 10675 -- construct a node with entity information to insure that 10676 -- semantic analysis can find the proper operator. 10677 10678 Cond := 10679 Make_Function_Call (Loc, 10680 Name => Make_Selected_Component (Loc, 10681 Prefix => 10682 New_Occurrence_Of (Scope (Time_Type), Loc), 10683 Selector_Name => 10684 Make_Operator_Symbol (Loc, 10685 Chars => Name_Op_Lt, 10686 Strval => No_String)), 10687 Parameter_Associations => 10688 New_List ( 10689 New_Occurrence_Of (Delay_Val, Loc), 10690 New_Occurrence_Of (Delay_Min, Loc))); 10691 10692 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type)); 10693 end if; 10694 10695 Append_To (Delay_Alt, 10696 Make_Implicit_If_Statement (N, 10697 Condition => Cond, 10698 Then_Statements => New_List ( 10699 Make_Assignment_Statement (Loc, 10700 Name => New_Occurrence_Of (Delay_Min, Loc), 10701 Expression => New_Occurrence_Of (Delay_Val, Loc)), 10702 10703 Make_Assignment_Statement (Loc, 10704 Name => New_Occurrence_Of (Delay_Index, Loc), 10705 Expression => Make_Integer_Literal (Loc, Index))))); 10706 end if; 10707 10708 if Check_Guard then 10709 Append_To (Delay_Alt, 10710 Make_Assignment_Statement (Loc, 10711 Name => New_Occurrence_Of (Guard_Open, Loc), 10712 Expression => New_Occurrence_Of (Standard_True, Loc))); 10713 end if; 10714 10715 if Present (Condition (Alt)) then 10716 Delay_Alt := New_List ( 10717 Make_Implicit_If_Statement (N, 10718 Condition => Condition (Alt), 10719 Then_Statements => Delay_Alt)); 10720 end if; 10721 10722 Append_List (Delay_Alt, Delay_List); 10723 10724 Ensure_Statement_Present (Dloc, Alt); 10725 10726 -- If the delay alternative has a statement part, add choice to the 10727 -- case statements for delays. 10728 10729 if not Is_Empty_List (Statements (Alt)) then 10730 10731 if Delay_Count = 1 then 10732 Append_List (Statements (Alt), Delay_Alt_List); 10733 10734 else 10735 Append_To (Delay_Alt_List, 10736 Make_Case_Statement_Alternative (Loc, 10737 Discrete_Choices => New_List ( 10738 Make_Integer_Literal (Loc, Index)), 10739 Statements => Statements (Alt))); 10740 end if; 10741 10742 elsif Delay_Count = 1 then 10743 10744 -- If the single delay has no trailing statements, add a branch 10745 -- to the exit label to the selective wait. 10746 10747 Delay_Alt_List := New_List ( 10748 Make_Goto_Statement (Loc, 10749 Name => New_Copy (Identifier (End_Lab)))); 10750 10751 end if; 10752 end Process_Delay_Alternative; 10753 10754 -- Start of processing for Expand_N_Selective_Accept 10755 10756 begin 10757 Process_Statements_For_Controlled_Objects (N); 10758 10759 -- First insert some declarations before the select. The first is: 10760 10761 -- Ann : Address 10762 10763 -- This variable holds the parameters passed to the accept body. This 10764 -- declaration has already been inserted by the time we get here by 10765 -- a call to Expand_Accept_Declarations made from the semantics when 10766 -- processing the first accept statement contained in the select. We 10767 -- can find this entity as Accept_Address (E), where E is any of the 10768 -- entries references by contained accept statements. 10769 10770 -- The first step is to scan the list of Selective_Accept_Statements 10771 -- to find this entity, and also count the number of accepts, and 10772 -- determine if terminated, delay or else is present: 10773 10774 Num_Alts := 0; 10775 10776 Alt := First (Alts); 10777 while Present (Alt) loop 10778 Process_Statements_For_Controlled_Objects (Alt); 10779 10780 if Nkind (Alt) = N_Accept_Alternative then 10781 Add_Accept (Alt); 10782 10783 elsif Nkind (Alt) = N_Delay_Alternative then 10784 Delay_Count := Delay_Count + 1; 10785 10786 -- If the delays are relative delays, the delay expressions have 10787 -- type Standard_Duration. Otherwise they must have some time type 10788 -- recognized by GNAT. 10789 10790 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then 10791 Time_Type := Standard_Duration; 10792 else 10793 Time_Type := Etype (Expression (Delay_Statement (Alt))); 10794 10795 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) 10796 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time) 10797 then 10798 null; 10799 else 10800 Error_Msg_NE ( 10801 "& is not a time type (RM 9.6(6))", 10802 Expression (Delay_Statement (Alt)), Time_Type); 10803 Time_Type := Standard_Duration; 10804 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type); 10805 end if; 10806 end if; 10807 10808 if No (Condition (Alt)) then 10809 10810 -- This guard will always be open 10811 10812 Check_Guard := False; 10813 end if; 10814 10815 elsif Nkind (Alt) = N_Terminate_Alternative then 10816 Adjust_Condition (Condition (Alt)); 10817 Terminate_Alt := Alt; 10818 end if; 10819 10820 Num_Alts := Num_Alts + 1; 10821 Next (Alt); 10822 end loop; 10823 10824 Else_Present := Present (Else_Statements (N)); 10825 10826 -- At the same time (see procedure Add_Accept) we build the accept list: 10827 10828 -- Qnn : Accept_List (1 .. num-select) := ( 10829 -- (null-body, entry-index), 10830 -- (null-body, entry-index), 10831 -- .. 10832 -- (null_body, entry-index)); 10833 10834 -- In the above declaration, null-body is True if the corresponding 10835 -- accept has no body, and false otherwise. The entry is either the 10836 -- entry index expression if there is no guard, or if a guard is 10837 -- present, then an if expression of the form: 10838 10839 -- (if guard then entry-index else Null_Task_Entry) 10840 10841 -- If a guard is statically known to be false, the entry can simply 10842 -- be omitted from the accept list. 10843 10844 Append_To (Decls, 10845 Make_Object_Declaration (Loc, 10846 Defining_Identifier => Qnam, 10847 Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc), 10848 Aliased_Present => True, 10849 Expression => 10850 Make_Qualified_Expression (Loc, 10851 Subtype_Mark => 10852 New_Occurrence_Of (RTE (RE_Accept_List), Loc), 10853 Expression => 10854 Make_Aggregate (Loc, Expressions => Accept_List)))); 10855 10856 -- Then we declare the variable that holds the index for the accept 10857 -- that will be selected for service: 10858 10859 -- Xnn : Select_Index; 10860 10861 Append_To (Decls, 10862 Make_Object_Declaration (Loc, 10863 Defining_Identifier => Xnam, 10864 Object_Definition => 10865 New_Occurrence_Of (RTE (RE_Select_Index), Loc), 10866 Expression => 10867 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc))); 10868 10869 -- After this follow procedure declarations for each accept body 10870 10871 -- procedure Pnn is 10872 -- begin 10873 -- ... 10874 -- end; 10875 10876 -- where the ... are statements from the corresponding procedure body. 10877 -- No parameters are involved, since the parameters are passed via Ann 10878 -- and the parameter references have already been expanded to be direct 10879 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore, 10880 -- any embedded tasking statements (which would normally be illegal in 10881 -- procedures), have been converted to calls to the tasking runtime so 10882 -- there is no problem in putting them into procedures. 10883 10884 -- The original accept statement has been expanded into a block in 10885 -- the same fashion as for simple accepts (see Build_Accept_Body). 10886 10887 -- Note: we don't really need to build these procedures for the case 10888 -- where no delay statement is present, but it is just as easy to 10889 -- build them unconditionally, and not significantly inefficient, 10890 -- since if they are short they will be inlined anyway. 10891 10892 -- The procedure declarations have been assembled in Body_List 10893 10894 -- If delays are present, we must compute the required delay. 10895 -- We first generate the declarations: 10896 10897 -- Delay_Index : Boolean := 0; 10898 -- Delay_Min : Some_Time_Type.Time; 10899 -- Delay_Val : Some_Time_Type.Time; 10900 10901 -- Delay_Index will be set to the index of the minimum delay, i.e. the 10902 -- active delay that is actually chosen as the basis for the possible 10903 -- delay if an immediate rendez-vous is not possible. 10904 10905 -- In the most common case there is a single delay statement, and this 10906 -- is handled specially. 10907 10908 if Delay_Count > 0 then 10909 10910 -- Generate the required declarations 10911 10912 Delay_Val := 10913 Make_Defining_Identifier (Loc, New_External_Name ('D', 1)); 10914 Delay_Index := 10915 Make_Defining_Identifier (Loc, New_External_Name ('D', 2)); 10916 Delay_Min := 10917 Make_Defining_Identifier (Loc, New_External_Name ('D', 3)); 10918 10919 Append_To (Decls, 10920 Make_Object_Declaration (Loc, 10921 Defining_Identifier => Delay_Val, 10922 Object_Definition => New_Occurrence_Of (Time_Type, Loc))); 10923 10924 Append_To (Decls, 10925 Make_Object_Declaration (Loc, 10926 Defining_Identifier => Delay_Index, 10927 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 10928 Expression => Make_Integer_Literal (Loc, 0))); 10929 10930 Append_To (Decls, 10931 Make_Object_Declaration (Loc, 10932 Defining_Identifier => Delay_Min, 10933 Object_Definition => New_Occurrence_Of (Time_Type, Loc), 10934 Expression => 10935 Unchecked_Convert_To (Time_Type, 10936 Make_Attribute_Reference (Loc, 10937 Prefix => 10938 New_Occurrence_Of (Underlying_Type (Time_Type), Loc), 10939 Attribute_Name => Name_Last)))); 10940 10941 -- Create Duration and Delay_Mode objects used for passing a delay 10942 -- value to RTS 10943 10944 D := Make_Temporary (Loc, 'D'); 10945 M := Make_Temporary (Loc, 'M'); 10946 10947 declare 10948 Discr : Entity_Id; 10949 10950 begin 10951 -- Note that these values are defined in s-osprim.ads and must 10952 -- be kept in sync: 10953 -- 10954 -- Relative : constant := 0; 10955 -- Absolute_Calendar : constant := 1; 10956 -- Absolute_RT : constant := 2; 10957 10958 if Time_Type = Standard_Duration then 10959 Discr := Make_Integer_Literal (Loc, 0); 10960 10961 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 10962 Discr := Make_Integer_Literal (Loc, 1); 10963 10964 else 10965 pragma Assert 10966 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 10967 Discr := Make_Integer_Literal (Loc, 2); 10968 end if; 10969 10970 Append_To (Decls, 10971 Make_Object_Declaration (Loc, 10972 Defining_Identifier => D, 10973 Object_Definition => 10974 New_Occurrence_Of (Standard_Duration, Loc))); 10975 10976 Append_To (Decls, 10977 Make_Object_Declaration (Loc, 10978 Defining_Identifier => M, 10979 Object_Definition => 10980 New_Occurrence_Of (Standard_Integer, Loc), 10981 Expression => Discr)); 10982 end; 10983 10984 if Check_Guard then 10985 Guard_Open := 10986 Make_Defining_Identifier (Loc, New_External_Name ('G', 1)); 10987 10988 Append_To (Decls, 10989 Make_Object_Declaration (Loc, 10990 Defining_Identifier => Guard_Open, 10991 Object_Definition => 10992 New_Occurrence_Of (Standard_Boolean, Loc), 10993 Expression => 10994 New_Occurrence_Of (Standard_False, Loc))); 10995 end if; 10996 10997 -- Delay_Count is zero, don't need M and D set (suppress warning) 10998 10999 else 11000 M := Empty; 11001 D := Empty; 11002 end if; 11003 11004 if Present (Terminate_Alt) then 11005 11006 -- If the terminate alternative guard is False, use 11007 -- Simple_Mode; otherwise use Terminate_Mode. 11008 11009 if Present (Condition (Terminate_Alt)) then 11010 Select_Mode := Make_If_Expression (Loc, 11011 New_List (Condition (Terminate_Alt), 11012 New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc), 11013 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc))); 11014 else 11015 Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc); 11016 end if; 11017 11018 elsif Else_Present or Delay_Count > 0 then 11019 Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc); 11020 11021 else 11022 Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc); 11023 end if; 11024 11025 Select_Call := Make_Select_Call (Select_Mode); 11026 Append (Select_Call, Stats); 11027 11028 -- Now generate code to act on the result. There is an entry 11029 -- in this case for each accept statement with a non-null body, 11030 -- followed by a branch to the statements that follow the Accept. 11031 -- In the absence of delay alternatives, we generate: 11032 11033 -- case X is 11034 -- when No_Rendezvous => -- omitted if simple mode 11035 -- goto Lab0; 11036 11037 -- when 1 => 11038 -- P1n; 11039 -- goto Lab1; 11040 11041 -- when 2 => 11042 -- P2n; 11043 -- goto Lab2; 11044 11045 -- when others => 11046 -- goto Exit; 11047 -- end case; 11048 -- 11049 -- Lab0: Else_Statements; 11050 -- goto exit; 11051 11052 -- Lab1: Trailing_Statements1; 11053 -- goto Exit; 11054 -- 11055 -- Lab2: Trailing_Statements2; 11056 -- goto Exit; 11057 -- ... 11058 -- Exit: 11059 11060 -- Generate label for common exit 11061 11062 End_Lab := Make_And_Declare_Label (Num_Alts + 1); 11063 11064 -- First entry is the default case, when no rendezvous is possible 11065 11066 Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)); 11067 11068 if Else_Present then 11069 11070 -- If no rendezvous is possible, the else part is executed 11071 11072 Lab := Make_And_Declare_Label (0); 11073 Alt_Stats := New_List ( 11074 Make_Goto_Statement (Loc, 11075 Name => New_Copy (Identifier (Lab)))); 11076 11077 Append (Lab, Trailing_List); 11078 Append_List (Else_Statements (N), Trailing_List); 11079 Append_To (Trailing_List, 11080 Make_Goto_Statement (Loc, 11081 Name => New_Copy (Identifier (End_Lab)))); 11082 else 11083 Alt_Stats := New_List ( 11084 Make_Goto_Statement (Loc, 11085 Name => New_Copy (Identifier (End_Lab)))); 11086 end if; 11087 11088 Append_To (Alt_List, 11089 Make_Case_Statement_Alternative (Loc, 11090 Discrete_Choices => Choices, 11091 Statements => Alt_Stats)); 11092 11093 -- We make use of the fact that Accept_Index is an integer type, and 11094 -- generate successive literals for entries for each accept. Only those 11095 -- for which there is a body or trailing statements get a case entry. 11096 11097 Alt := First (Select_Alternatives (N)); 11098 Proc := First (Body_List); 11099 while Present (Alt) loop 11100 11101 if Nkind (Alt) = N_Accept_Alternative then 11102 Process_Accept_Alternative (Alt, Index, Proc); 11103 Index := Index + 1; 11104 11105 if Present 11106 (Handled_Statement_Sequence (Accept_Statement (Alt))) 11107 then 11108 Next (Proc); 11109 end if; 11110 11111 elsif Nkind (Alt) = N_Delay_Alternative then 11112 Process_Delay_Alternative (Alt, Delay_Num); 11113 Delay_Num := Delay_Num + 1; 11114 end if; 11115 11116 Next (Alt); 11117 end loop; 11118 11119 -- An others choice is always added to the main case, as well 11120 -- as the delay case (to satisfy the compiler). 11121 11122 Append_To (Alt_List, 11123 Make_Case_Statement_Alternative (Loc, 11124 Discrete_Choices => 11125 New_List (Make_Others_Choice (Loc)), 11126 Statements => 11127 New_List (Make_Goto_Statement (Loc, 11128 Name => New_Copy (Identifier (End_Lab)))))); 11129 11130 Accept_Case := New_List ( 11131 Make_Case_Statement (Loc, 11132 Expression => New_Occurrence_Of (Xnam, Loc), 11133 Alternatives => Alt_List)); 11134 11135 Append_List (Trailing_List, Accept_Case); 11136 Append_List (Body_List, Decls); 11137 11138 -- Construct case statement for trailing statements of delay 11139 -- alternatives, if there are several of them. 11140 11141 if Delay_Count > 1 then 11142 Append_To (Delay_Alt_List, 11143 Make_Case_Statement_Alternative (Loc, 11144 Discrete_Choices => 11145 New_List (Make_Others_Choice (Loc)), 11146 Statements => 11147 New_List (Make_Null_Statement (Loc)))); 11148 11149 Delay_Case := New_List ( 11150 Make_Case_Statement (Loc, 11151 Expression => New_Occurrence_Of (Delay_Index, Loc), 11152 Alternatives => Delay_Alt_List)); 11153 else 11154 Delay_Case := Delay_Alt_List; 11155 end if; 11156 11157 -- If there are no delay alternatives, we append the case statement 11158 -- to the statement list. 11159 11160 if Delay_Count = 0 then 11161 Append_List (Accept_Case, Stats); 11162 11163 -- Delay alternatives present 11164 11165 else 11166 -- If delay alternatives are present we generate: 11167 11168 -- find minimum delay. 11169 -- DX := minimum delay; 11170 -- M := <delay mode>; 11171 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P, 11172 -- DX, MX, X); 11173 -- 11174 -- if X = No_Rendezvous then 11175 -- case statement for delay statements. 11176 -- else 11177 -- case statement for accept alternatives. 11178 -- end if; 11179 11180 declare 11181 Cases : Node_Id; 11182 Stmt : Node_Id; 11183 Parms : List_Id; 11184 Parm : Node_Id; 11185 Conv : Node_Id; 11186 11187 begin 11188 -- The type of the delay expression is known to be legal 11189 11190 if Time_Type = Standard_Duration then 11191 Conv := New_Occurrence_Of (Delay_Min, Loc); 11192 11193 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11194 Conv := Make_Function_Call (Loc, 11195 New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 11196 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11197 11198 else 11199 pragma Assert 11200 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11201 11202 Conv := Make_Function_Call (Loc, 11203 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 11204 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11205 end if; 11206 11207 Stmt := Make_Assignment_Statement (Loc, 11208 Name => New_Occurrence_Of (D, Loc), 11209 Expression => Conv); 11210 11211 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode) 11212 11213 Parms := Parameter_Associations (Select_Call); 11214 Parm := First (Parms); 11215 11216 while Present (Parm) and then Parm /= Select_Mode loop 11217 Next (Parm); 11218 end loop; 11219 11220 pragma Assert (Present (Parm)); 11221 Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc)); 11222 Analyze (Parm); 11223 11224 -- Prepare two new parameters of Duration and Delay_Mode type 11225 -- which represent the value and the mode of the minimum delay. 11226 11227 Next (Parm); 11228 Insert_After (Parm, New_Occurrence_Of (M, Loc)); 11229 Insert_After (Parm, New_Occurrence_Of (D, Loc)); 11230 11231 -- Create a call to RTS 11232 11233 Rewrite (Select_Call, 11234 Make_Procedure_Call_Statement (Loc, 11235 Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc), 11236 Parameter_Associations => Parms)); 11237 11238 -- This new call should follow the calculation of the minimum 11239 -- delay. 11240 11241 Insert_List_Before (Select_Call, Delay_List); 11242 11243 if Check_Guard then 11244 Stmt := 11245 Make_Implicit_If_Statement (N, 11246 Condition => New_Occurrence_Of (Guard_Open, Loc), 11247 Then_Statements => New_List ( 11248 New_Copy_Tree (Stmt), 11249 New_Copy_Tree (Select_Call)), 11250 Else_Statements => Accept_Or_Raise); 11251 Rewrite (Select_Call, Stmt); 11252 else 11253 Insert_Before (Select_Call, Stmt); 11254 end if; 11255 11256 Cases := 11257 Make_Implicit_If_Statement (N, 11258 Condition => Make_Op_Eq (Loc, 11259 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 11260 Right_Opnd => 11261 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 11262 11263 Then_Statements => Delay_Case, 11264 Else_Statements => Accept_Case); 11265 11266 Append (Cases, Stats); 11267 end; 11268 end if; 11269 Append (End_Lab, Stats); 11270 11271 -- Replace accept statement with appropriate block 11272 11273 Rewrite (N, 11274 Make_Block_Statement (Loc, 11275 Declarations => Decls, 11276 Handled_Statement_Sequence => 11277 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats))); 11278 Analyze (N); 11279 11280 -- Note: have to worry more about abort deferral in above code ??? 11281 11282 -- Final step is to unstack the Accept_Address entries for all accept 11283 -- statements appearing in accept alternatives in the select statement 11284 11285 Alt := First (Alts); 11286 while Present (Alt) loop 11287 if Nkind (Alt) = N_Accept_Alternative then 11288 Remove_Last_Elmt (Accept_Address 11289 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))); 11290 end if; 11291 11292 Next (Alt); 11293 end loop; 11294 end Expand_N_Selective_Accept; 11295 11296 -------------------------------------- 11297 -- Expand_N_Single_Task_Declaration -- 11298 -------------------------------------- 11299 11300 -- Single task declarations should never be present after semantic 11301 -- analysis, since we expect them to be replaced by a declaration of an 11302 -- anonymous task type, followed by a declaration of the task object. We 11303 -- include this routine to make sure that is happening. 11304 11305 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is 11306 begin 11307 raise Program_Error; 11308 end Expand_N_Single_Task_Declaration; 11309 11310 ------------------------ 11311 -- Expand_N_Task_Body -- 11312 ------------------------ 11313 11314 -- Given a task body 11315 11316 -- task body tname is 11317 -- <declarations> 11318 -- begin 11319 -- <statements> 11320 -- end x; 11321 11322 -- This expansion routine converts it into a procedure and sets the 11323 -- elaboration flag for the procedure to true, to represent the fact 11324 -- that the task body is now elaborated: 11325 11326 -- procedure tnameB (_Task : access tnameV) is 11327 -- discriminal : dtype renames _Task.discriminant; 11328 11329 -- procedure _clean is 11330 -- begin 11331 -- Abort_Defer.all; 11332 -- Complete_Task; 11333 -- Abort_Undefer.all; 11334 -- return; 11335 -- end _clean; 11336 11337 -- begin 11338 -- Abort_Undefer.all; 11339 -- <declarations> 11340 -- System.Task_Stages.Complete_Activation; 11341 -- <statements> 11342 -- at end 11343 -- _clean; 11344 -- end tnameB; 11345 11346 -- tnameE := True; 11347 11348 -- In addition, if the task body is an activator, then a call to activate 11349 -- tasks is added at the start of the statements, before the call to 11350 -- Complete_Activation, and if in addition the task is a master then it 11351 -- must be established as a master. These calls are inserted and analyzed 11352 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is 11353 -- expanded. 11354 11355 -- There is one discriminal declaration line generated for each 11356 -- discriminant that is present to provide an easy reference point for 11357 -- discriminant references inside the body (see Exp_Ch2.Expand_Name). 11358 11359 -- Note on relationship to GNARLI definition. In the GNARLI definition, 11360 -- task body procedures have a profile (Arg : System.Address). That is 11361 -- needed because GNARLI has to use the same access-to-subprogram type 11362 -- for all task types. We depend here on knowing that in GNAT, passing 11363 -- an address argument by value is identical to passing a record value 11364 -- by access (in either case a single pointer is passed), so even though 11365 -- this procedure has the wrong profile. In fact it's all OK, since the 11366 -- callings sequence is identical. 11367 11368 procedure Expand_N_Task_Body (N : Node_Id) is 11369 Loc : constant Source_Ptr := Sloc (N); 11370 Ttyp : constant Entity_Id := Corresponding_Spec (N); 11371 Call : Node_Id; 11372 New_N : Node_Id; 11373 11374 Insert_Nod : Node_Id; 11375 -- Used to determine the proper location of wrapper body insertions 11376 11377 begin 11378 -- Add renaming declarations for discriminals and a declaration for the 11379 -- entry family index (if applicable). 11380 11381 Install_Private_Data_Declarations 11382 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N)); 11383 11384 -- Add a call to Abort_Undefer at the very beginning of the task 11385 -- body since this body is called with abort still deferred. 11386 11387 if Abort_Allowed then 11388 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 11389 Insert_Before 11390 (First (Statements (Handled_Statement_Sequence (N))), Call); 11391 Analyze (Call); 11392 end if; 11393 11394 -- The statement part has already been protected with an at_end and 11395 -- cleanup actions. The call to Complete_Activation must be placed 11396 -- at the head of the sequence of statements of that block. The 11397 -- declarations have been merged in this sequence of statements but 11398 -- the first real statement is accessible from the First_Real_Statement 11399 -- field (which was set for exactly this purpose). 11400 11401 if Restricted_Profile then 11402 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation); 11403 else 11404 Call := Build_Runtime_Call (Loc, RE_Complete_Activation); 11405 end if; 11406 11407 Insert_Before 11408 (First_Real_Statement (Handled_Statement_Sequence (N)), Call); 11409 Analyze (Call); 11410 11411 New_N := 11412 Make_Subprogram_Body (Loc, 11413 Specification => Build_Task_Proc_Specification (Ttyp), 11414 Declarations => Declarations (N), 11415 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 11416 11417 -- If the task contains generic instantiations, cleanup actions are 11418 -- delayed until after instantiation. Transfer the activation chain to 11419 -- the subprogram, to insure that the activation call is properly 11420 -- generated. It the task body contains inner tasks, indicate that the 11421 -- subprogram is a task master. 11422 11423 if Delay_Cleanups (Ttyp) then 11424 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); 11425 Set_Is_Task_Master (New_N, Is_Task_Master (N)); 11426 end if; 11427 11428 Rewrite (N, New_N); 11429 Analyze (N); 11430 11431 -- Set elaboration flag immediately after task body. If the body is a 11432 -- subunit, the flag is set in the declarative part containing the stub. 11433 11434 if Nkind (Parent (N)) /= N_Subunit then 11435 Insert_After (N, 11436 Make_Assignment_Statement (Loc, 11437 Name => 11438 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')), 11439 Expression => New_Occurrence_Of (Standard_True, Loc))); 11440 end if; 11441 11442 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after 11443 -- the task body. At this point all wrapper specs have been created, 11444 -- frozen and included in the dispatch table for the task type. 11445 11446 if Ada_Version >= Ada_2005 then 11447 if Nkind (Parent (N)) = N_Subunit then 11448 Insert_Nod := Corresponding_Stub (Parent (N)); 11449 else 11450 Insert_Nod := N; 11451 end if; 11452 11453 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod); 11454 end if; 11455 end Expand_N_Task_Body; 11456 11457 ------------------------------------ 11458 -- Expand_N_Task_Type_Declaration -- 11459 ------------------------------------ 11460 11461 -- We have several things to do. First we must create a Boolean flag used 11462 -- to mark if the body is elaborated yet. This variable gets set to True 11463 -- when the body of the task is elaborated (we can't rely on the normal 11464 -- ABE mechanism for the task body, since we need to pass an access to 11465 -- this elaboration boolean to the runtime routines). 11466 11467 -- taskE : aliased Boolean := False; 11468 11469 -- Next a variable is declared to hold the task stack size (either the 11470 -- default : Unspecified_Size, or a value that is set by a pragma 11471 -- Storage_Size). If the value of the pragma Storage_Size is static, then 11472 -- the variable is initialized with this value: 11473 11474 -- taskZ : Size_Type := Unspecified_Size; 11475 -- or 11476 -- taskZ : Size_Type := Size_Type (size_expression); 11477 11478 -- Note: No variable is needed to hold the task relative deadline since 11479 -- its value would never be static because the parameter is of a private 11480 -- type (Ada.Real_Time.Time_Span). 11481 11482 -- Next we create a corresponding record type declaration used to represent 11483 -- values of this task. The general form of this type declaration is 11484 11485 -- type taskV (discriminants) is record 11486 -- _Task_Id : Task_Id; 11487 -- entry_family : array (bounds) of Void; 11488 -- _Priority : Integer := priority_expression; 11489 -- _Size : Size_Type := size_expression; 11490 -- _Task_Info : Task_Info_Type := task_info_expression; 11491 -- _CPU : Integer := cpu_range_expression; 11492 -- _Relative_Deadline : Time_Span := time_span_expression; 11493 -- _Domain : Dispatching_Domain := dd_expression; 11494 -- end record; 11495 11496 -- The discriminants are present only if the corresponding task type has 11497 -- discriminants, and they exactly mirror the task type discriminants. 11498 11499 -- The Id field is always present. It contains the Task_Id value, as set by 11500 -- the call to Create_Task. Note that although the task is limited, the 11501 -- task value record type is not limited, so there is no problem in passing 11502 -- this field as an out parameter to Create_Task. 11503 11504 -- One entry_family component is present for each entry family in the task 11505 -- definition. The bounds correspond to the bounds of the entry family 11506 -- (which may depend on discriminants). The element type is void, since we 11507 -- only need the bounds information for determining the entry index. Note 11508 -- that the use of an anonymous array would normally be illegal in this 11509 -- context, but this is a parser check, and the semantics is quite prepared 11510 -- to handle such a case. 11511 11512 -- The _Size field is present only if a Storage_Size pragma appears in the 11513 -- task definition. The expression captures the argument that was present 11514 -- in the pragma, and is used to override the task stack size otherwise 11515 -- associated with the task type. 11516 11517 -- The _Priority field is present only if the task entity has a Priority or 11518 -- Interrupt_Priority rep item (pragma, aspect specification or attribute 11519 -- definition clause). It will be filled at the freeze point, when the 11520 -- record init proc is built, to capture the expression of the rep item 11521 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11522 -- here since aspect evaluations are delayed till the freeze point. 11523 11524 -- The _Task_Info field is present only if a Task_Info pragma appears in 11525 -- the task definition. The expression captures the argument that was 11526 -- present in the pragma, and is used to provide the Task_Image parameter 11527 -- to the call to Create_Task. 11528 11529 -- The _CPU field is present only if the task entity has a CPU rep item 11530 -- (pragma, aspect specification or attribute definition clause). It will 11531 -- be filled at the freeze point, when the record init proc is built, to 11532 -- capture the expression of the rep item (see Build_Record_Init_Proc in 11533 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations 11534 -- are delayed till the freeze point. 11535 11536 -- The _Relative_Deadline field is present only if a Relative_Deadline 11537 -- pragma appears in the task definition. The expression captures the 11538 -- argument that was present in the pragma, and is used to provide the 11539 -- Relative_Deadline parameter to the call to Create_Task. 11540 11541 -- The _Domain field is present only if the task entity has a 11542 -- Dispatching_Domain rep item (pragma, aspect specification or attribute 11543 -- definition clause). It will be filled at the freeze point, when the 11544 -- record init proc is built, to capture the expression of the rep item 11545 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11546 -- here since aspect evaluations are delayed till the freeze point. 11547 11548 -- When a task is declared, an instance of the task value record is 11549 -- created. The elaboration of this declaration creates the correct bounds 11550 -- for the entry families, and also evaluates the size, priority, and 11551 -- task_Info expressions if needed. The initialization routine for the task 11552 -- type itself then calls Create_Task with appropriate parameters to 11553 -- initialize the value of the Task_Id field. 11554 11555 -- Note: the address of this record is passed as the "Discriminants" 11556 -- parameter for Create_Task. Since Create_Task merely passes this onto the 11557 -- body procedure, it does not matter that it does not quite match the 11558 -- GNARLI model of what is being passed (the record contains more than just 11559 -- the discriminants, but the discriminants can be found from the record 11560 -- value). 11561 11562 -- The Entity_Id for this created record type is placed in the 11563 -- Corresponding_Record_Type field of the associated task type entity. 11564 11565 -- Next we create a procedure specification for the task body procedure: 11566 11567 -- procedure taskB (_Task : access taskV); 11568 11569 -- Note that this must come after the record type declaration, since 11570 -- the spec refers to this type. It turns out that the initialization 11571 -- procedure for the value type references the task body spec, but that's 11572 -- fine, since it won't be generated till the freeze point for the type, 11573 -- which is certainly after the task body spec declaration. 11574 11575 -- Finally, we set the task index value field of the entry attribute in 11576 -- the case of a simple entry. 11577 11578 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is 11579 Loc : constant Source_Ptr := Sloc (N); 11580 TaskId : constant Entity_Id := Defining_Identifier (N); 11581 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); 11582 Tasknm : constant Name_Id := Chars (Tasktyp); 11583 Taskdef : constant Node_Id := Task_Definition (N); 11584 11585 Body_Decl : Node_Id; 11586 Cdecls : List_Id; 11587 Decl_Stack : Node_Id; 11588 Elab_Decl : Node_Id; 11589 Ent_Stack : Entity_Id; 11590 Proc_Spec : Node_Id; 11591 Rec_Decl : Node_Id; 11592 Rec_Ent : Entity_Id; 11593 Size_Decl : Entity_Id; 11594 Task_Size : Node_Id; 11595 11596 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id; 11597 -- Searches the task definition T for the first occurrence of the pragma 11598 -- Relative Deadline. The caller has ensured that the pragma is present 11599 -- in the task definition. Note that this routine cannot be implemented 11600 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are 11601 -- not chained because their expansion into a procedure call statement 11602 -- would cause a break in the chain. 11603 11604 ---------------------------------- 11605 -- Get_Relative_Deadline_Pragma -- 11606 ---------------------------------- 11607 11608 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is 11609 N : Node_Id; 11610 11611 begin 11612 N := First (Visible_Declarations (T)); 11613 while Present (N) loop 11614 if Nkind (N) = N_Pragma 11615 and then Pragma_Name (N) = Name_Relative_Deadline 11616 then 11617 return N; 11618 end if; 11619 11620 Next (N); 11621 end loop; 11622 11623 N := First (Private_Declarations (T)); 11624 while Present (N) loop 11625 if Nkind (N) = N_Pragma 11626 and then Pragma_Name (N) = Name_Relative_Deadline 11627 then 11628 return N; 11629 end if; 11630 11631 Next (N); 11632 end loop; 11633 11634 raise Program_Error; 11635 end Get_Relative_Deadline_Pragma; 11636 11637 -- Start of processing for Expand_N_Task_Type_Declaration 11638 11639 begin 11640 -- If already expanded, nothing to do 11641 11642 if Present (Corresponding_Record_Type (Tasktyp)) then 11643 return; 11644 end if; 11645 11646 -- Here we will do the expansion 11647 11648 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); 11649 11650 Rec_Ent := Defining_Identifier (Rec_Decl); 11651 Cdecls := Component_Items (Component_List 11652 (Type_Definition (Rec_Decl))); 11653 11654 Qualify_Entity_Names (N); 11655 11656 -- First create the elaboration variable 11657 11658 Elab_Decl := 11659 Make_Object_Declaration (Loc, 11660 Defining_Identifier => 11661 Make_Defining_Identifier (Sloc (Tasktyp), 11662 Chars => New_External_Name (Tasknm, 'E')), 11663 Aliased_Present => True, 11664 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 11665 Expression => New_Occurrence_Of (Standard_False, Loc)); 11666 11667 Insert_After (N, Elab_Decl); 11668 11669 -- Next create the declaration of the size variable (tasknmZ) 11670 11671 Set_Storage_Size_Variable (Tasktyp, 11672 Make_Defining_Identifier (Sloc (Tasktyp), 11673 Chars => New_External_Name (Tasknm, 'Z'))); 11674 11675 if Present (Taskdef) 11676 and then Has_Storage_Size_Pragma (Taskdef) 11677 and then 11678 Is_Static_Expression 11679 (Expression 11680 (First (Pragma_Argument_Associations 11681 (Get_Rep_Pragma (TaskId, Name_Storage_Size))))) 11682 then 11683 Size_Decl := 11684 Make_Object_Declaration (Loc, 11685 Defining_Identifier => Storage_Size_Variable (Tasktyp), 11686 Object_Definition => 11687 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 11688 Expression => 11689 Convert_To (RTE (RE_Size_Type), 11690 Relocate_Node 11691 (Expression (First (Pragma_Argument_Associations 11692 (Get_Rep_Pragma 11693 (TaskId, Name_Storage_Size))))))); 11694 11695 else 11696 Size_Decl := 11697 Make_Object_Declaration (Loc, 11698 Defining_Identifier => Storage_Size_Variable (Tasktyp), 11699 Object_Definition => 11700 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 11701 Expression => 11702 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); 11703 end if; 11704 11705 Insert_After (Elab_Decl, Size_Decl); 11706 11707 -- Next build the rest of the corresponding record declaration. This is 11708 -- done last, since the corresponding record initialization procedure 11709 -- will reference the previously created entities. 11710 11711 -- Fill in the component declarations -- first the _Task_Id field 11712 11713 Append_To (Cdecls, 11714 Make_Component_Declaration (Loc, 11715 Defining_Identifier => 11716 Make_Defining_Identifier (Loc, Name_uTask_Id), 11717 Component_Definition => 11718 Make_Component_Definition (Loc, 11719 Aliased_Present => False, 11720 Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id), 11721 Loc)))); 11722 11723 -- Declare static ATCB (that is, created by the expander) if we are 11724 -- using the Restricted run time. 11725 11726 if Restricted_Profile then 11727 Append_To (Cdecls, 11728 Make_Component_Declaration (Loc, 11729 Defining_Identifier => 11730 Make_Defining_Identifier (Loc, Name_uATCB), 11731 11732 Component_Definition => 11733 Make_Component_Definition (Loc, 11734 Aliased_Present => True, 11735 Subtype_Indication => Make_Subtype_Indication (Loc, 11736 Subtype_Mark => 11737 New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc), 11738 11739 Constraint => 11740 Make_Index_Or_Discriminant_Constraint (Loc, 11741 Constraints => 11742 New_List (Make_Integer_Literal (Loc, 0))))))); 11743 11744 end if; 11745 11746 -- Declare static stack (that is, created by the expander) if we are 11747 -- using the Restricted run time on a bare board configuration. 11748 11749 if Restricted_Profile 11750 and then Preallocated_Stacks_On_Target 11751 then 11752 -- First we need to extract the appropriate stack size 11753 11754 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack); 11755 11756 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 11757 declare 11758 Expr_N : constant Node_Id := 11759 Expression (First ( 11760 Pragma_Argument_Associations ( 11761 Get_Rep_Pragma (TaskId, Name_Storage_Size)))); 11762 Etyp : constant Entity_Id := Etype (Expr_N); 11763 P : constant Node_Id := Parent (Expr_N); 11764 11765 begin 11766 -- The stack is defined inside the corresponding record. 11767 -- Therefore if the size of the stack is set by means of 11768 -- a discriminant, we must reference the discriminant of the 11769 -- corresponding record type. 11770 11771 if Nkind (Expr_N) in N_Has_Entity 11772 and then Present (Discriminal_Link (Entity (Expr_N))) 11773 then 11774 Task_Size := 11775 New_Occurrence_Of 11776 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))), 11777 Loc); 11778 Set_Parent (Task_Size, P); 11779 Set_Etype (Task_Size, Etyp); 11780 Set_Analyzed (Task_Size); 11781 11782 else 11783 Task_Size := Relocate_Node (Expr_N); 11784 end if; 11785 end; 11786 11787 else 11788 Task_Size := 11789 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc); 11790 end if; 11791 11792 Decl_Stack := Make_Component_Declaration (Loc, 11793 Defining_Identifier => Ent_Stack, 11794 11795 Component_Definition => 11796 Make_Component_Definition (Loc, 11797 Aliased_Present => True, 11798 Subtype_Indication => Make_Subtype_Indication (Loc, 11799 Subtype_Mark => 11800 New_Occurrence_Of (RTE (RE_Storage_Array), Loc), 11801 11802 Constraint => 11803 Make_Index_Or_Discriminant_Constraint (Loc, 11804 Constraints => New_List (Make_Range (Loc, 11805 Low_Bound => Make_Integer_Literal (Loc, 1), 11806 High_Bound => Convert_To (RTE (RE_Storage_Offset), 11807 Task_Size))))))); 11808 11809 Append_To (Cdecls, Decl_Stack); 11810 11811 -- The appropriate alignment for the stack is ensured by the run-time 11812 -- code in charge of task creation. 11813 11814 end if; 11815 11816 -- Add components for entry families 11817 11818 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); 11819 11820 -- Add the _Priority component if a Interrupt_Priority or Priority rep 11821 -- item is present. 11822 11823 if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then 11824 Append_To (Cdecls, 11825 Make_Component_Declaration (Loc, 11826 Defining_Identifier => 11827 Make_Defining_Identifier (Loc, Name_uPriority), 11828 Component_Definition => 11829 Make_Component_Definition (Loc, 11830 Aliased_Present => False, 11831 Subtype_Indication => 11832 New_Occurrence_Of (Standard_Integer, Loc)))); 11833 end if; 11834 11835 -- Add the _Size component if a Storage_Size pragma is present 11836 11837 if Present (Taskdef) 11838 and then Has_Storage_Size_Pragma (Taskdef) 11839 then 11840 Append_To (Cdecls, 11841 Make_Component_Declaration (Loc, 11842 Defining_Identifier => 11843 Make_Defining_Identifier (Loc, Name_uSize), 11844 11845 Component_Definition => 11846 Make_Component_Definition (Loc, 11847 Aliased_Present => False, 11848 Subtype_Indication => 11849 New_Occurrence_Of (RTE (RE_Size_Type), Loc)), 11850 11851 Expression => 11852 Convert_To (RTE (RE_Size_Type), 11853 Relocate_Node ( 11854 Expression (First ( 11855 Pragma_Argument_Associations ( 11856 Get_Rep_Pragma (TaskId, Name_Storage_Size)))))))); 11857 end if; 11858 11859 -- Add the _Task_Info component if a Task_Info pragma is present 11860 11861 if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then 11862 Append_To (Cdecls, 11863 Make_Component_Declaration (Loc, 11864 Defining_Identifier => 11865 Make_Defining_Identifier (Loc, Name_uTask_Info), 11866 11867 Component_Definition => 11868 Make_Component_Definition (Loc, 11869 Aliased_Present => False, 11870 Subtype_Indication => 11871 New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)), 11872 11873 Expression => New_Copy ( 11874 Expression (First ( 11875 Pragma_Argument_Associations ( 11876 Get_Rep_Pragma 11877 (TaskId, Name_Task_Info, Check_Parents => False))))))); 11878 end if; 11879 11880 -- Add the _CPU component if a CPU rep item is present 11881 11882 if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then 11883 Append_To (Cdecls, 11884 Make_Component_Declaration (Loc, 11885 Defining_Identifier => 11886 Make_Defining_Identifier (Loc, Name_uCPU), 11887 11888 Component_Definition => 11889 Make_Component_Definition (Loc, 11890 Aliased_Present => False, 11891 Subtype_Indication => 11892 New_Occurrence_Of (RTE (RE_CPU_Range), Loc)))); 11893 end if; 11894 11895 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is 11896 -- present. If we are using a restricted run time this component will 11897 -- not be added (deadlines are not allowed by the Ravenscar profile). 11898 11899 if not Restricted_Profile 11900 and then Present (Taskdef) 11901 and then Has_Relative_Deadline_Pragma (Taskdef) 11902 then 11903 Append_To (Cdecls, 11904 Make_Component_Declaration (Loc, 11905 Defining_Identifier => 11906 Make_Defining_Identifier (Loc, Name_uRelative_Deadline), 11907 11908 Component_Definition => 11909 Make_Component_Definition (Loc, 11910 Aliased_Present => False, 11911 Subtype_Indication => 11912 New_Occurrence_Of (RTE (RE_Time_Span), Loc)), 11913 11914 Expression => 11915 Convert_To (RTE (RE_Time_Span), 11916 Relocate_Node ( 11917 Expression (First ( 11918 Pragma_Argument_Associations ( 11919 Get_Relative_Deadline_Pragma (Taskdef)))))))); 11920 end if; 11921 11922 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep 11923 -- item is present. If we are using a restricted run time this component 11924 -- will not be added (dispatching domains are not allowed by the 11925 -- Ravenscar profile). 11926 11927 if not Restricted_Profile 11928 and then 11929 Has_Rep_Item 11930 (TaskId, Name_Dispatching_Domain, Check_Parents => False) 11931 then 11932 Append_To (Cdecls, 11933 Make_Component_Declaration (Loc, 11934 Defining_Identifier => 11935 Make_Defining_Identifier (Loc, Name_uDispatching_Domain), 11936 11937 Component_Definition => 11938 Make_Component_Definition (Loc, 11939 Aliased_Present => False, 11940 Subtype_Indication => 11941 New_Occurrence_Of 11942 (RTE (RE_Dispatching_Domain_Access), Loc)))); 11943 end if; 11944 11945 Insert_After (Size_Decl, Rec_Decl); 11946 11947 -- Analyze the record declaration immediately after construction, 11948 -- because the initialization procedure is needed for single task 11949 -- declarations before the next entity is analyzed. 11950 11951 Analyze (Rec_Decl); 11952 11953 -- Create the declaration of the task body procedure 11954 11955 Proc_Spec := Build_Task_Proc_Specification (Tasktyp); 11956 Body_Decl := 11957 Make_Subprogram_Declaration (Loc, 11958 Specification => Proc_Spec); 11959 11960 Insert_After (Rec_Decl, Body_Decl); 11961 11962 -- The subprogram does not comes from source, so we have to indicate the 11963 -- need for debugging information explicitly. 11964 11965 if Comes_From_Source (Original_Node (N)) then 11966 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec)); 11967 end if; 11968 11969 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before 11970 -- the corresponding record has been frozen. 11971 11972 if Ada_Version >= Ada_2005 then 11973 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl); 11974 end if; 11975 11976 -- Ada 2005 (AI-345): We must defer freezing to allow further 11977 -- declaration of primitive subprograms covering task interfaces 11978 11979 if Ada_Version <= Ada_95 then 11980 11981 -- Now we can freeze the corresponding record. This needs manually 11982 -- freezing, since it is really part of the task type, and the task 11983 -- type is frozen at this stage. We of course need the initialization 11984 -- procedure for this corresponding record type and we won't get it 11985 -- in time if we don't freeze now. 11986 11987 declare 11988 L : constant List_Id := Freeze_Entity (Rec_Ent, N); 11989 begin 11990 if Is_Non_Empty_List (L) then 11991 Insert_List_After (Body_Decl, L); 11992 end if; 11993 end; 11994 end if; 11995 11996 -- Complete the expansion of access types to the current task type, if 11997 -- any were declared. 11998 11999 Expand_Previous_Access_Type (Tasktyp); 12000 12001 -- Create wrappers for entries that have pre/postconditions 12002 12003 declare 12004 Ent : Entity_Id; 12005 12006 begin 12007 Ent := First_Entity (Tasktyp); 12008 while Present (Ent) loop 12009 if Ekind_In (Ent, E_Entry, E_Entry_Family) 12010 and then Present (Pre_Post_Conditions (Contract (Ent))) 12011 then 12012 Build_PPC_Wrapper (Ent, N); 12013 end if; 12014 12015 Next_Entity (Ent); 12016 end loop; 12017 end; 12018 end Expand_N_Task_Type_Declaration; 12019 12020 ------------------------------- 12021 -- Expand_N_Timed_Entry_Call -- 12022 ------------------------------- 12023 12024 -- A timed entry call in normal case is not implemented using ATC mechanism 12025 -- anymore for efficiency reason. 12026 12027 -- select 12028 -- T.E; 12029 -- S1; 12030 -- or 12031 -- delay D; 12032 -- S2; 12033 -- end select; 12034 12035 -- is expanded as follows: 12036 12037 -- 1) When T.E is a task entry_call; 12038 12039 -- declare 12040 -- B : Boolean; 12041 -- X : Task_Entry_Index := <entry index>; 12042 -- DX : Duration := To_Duration (D); 12043 -- M : Delay_Mode := <discriminant>; 12044 -- P : parms := (parm, parm, parm); 12045 12046 -- begin 12047 -- Timed_Protected_Entry_Call 12048 -- (<acceptor-task>, X, P'Address, DX, M, B); 12049 -- if B then 12050 -- S1; 12051 -- else 12052 -- S2; 12053 -- end if; 12054 -- end; 12055 12056 -- 2) When T.E is a protected entry_call; 12057 12058 -- declare 12059 -- B : Boolean; 12060 -- X : Protected_Entry_Index := <entry index>; 12061 -- DX : Duration := To_Duration (D); 12062 -- M : Delay_Mode := <discriminant>; 12063 -- P : parms := (parm, parm, parm); 12064 12065 -- begin 12066 -- Timed_Protected_Entry_Call 12067 -- (<object>'unchecked_access, X, P'Address, DX, M, B); 12068 -- if B then 12069 -- S1; 12070 -- else 12071 -- S2; 12072 -- end if; 12073 -- end; 12074 12075 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there 12076 -- is no delay and the triggering statements are executed. We first 12077 -- determine the kind of of the triggering call and then execute a 12078 -- synchronized operation or a direct call. 12079 12080 -- declare 12081 -- B : Boolean := False; 12082 -- C : Ada.Tags.Prim_Op_Kind; 12083 -- DX : Duration := To_Duration (D) 12084 -- K : Ada.Tags.Tagged_Kind := 12085 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 12086 -- M : Integer :=...; 12087 -- P : Parameters := (Param1 .. ParamN); 12088 -- S : Integer; 12089 12090 -- begin 12091 -- if K = Ada.Tags.TK_Limited_Tagged 12092 -- or else K = Ada.Tags.TK_Tagged 12093 -- then 12094 -- <dispatching-call>; 12095 -- B := True; 12096 12097 -- else 12098 -- S := 12099 -- Ada.Tags.Get_Offset_Index 12100 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 12101 12102 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B); 12103 12104 -- if C = POK_Protected_Entry 12105 -- or else C = POK_Task_Entry 12106 -- then 12107 -- Param1 := P.Param1; 12108 -- ... 12109 -- ParamN := P.ParamN; 12110 -- end if; 12111 12112 -- if B then 12113 -- if C = POK_Procedure 12114 -- or else C = POK_Protected_Procedure 12115 -- or else C = POK_Task_Procedure 12116 -- then 12117 -- <dispatching-call>; 12118 -- end if; 12119 -- end if; 12120 -- end if; 12121 12122 -- if B then 12123 -- <triggering-statements> 12124 -- else 12125 -- <timed-statements> 12126 -- end if; 12127 -- end; 12128 12129 -- The triggering statement and the sequence of timed statements have not 12130 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain 12131 -- global references if within an instantiation. 12132 12133 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is 12134 Loc : constant Source_Ptr := Sloc (N); 12135 12136 Actuals : List_Id; 12137 Blk_Typ : Entity_Id; 12138 Call : Node_Id; 12139 Call_Ent : Entity_Id; 12140 Conc_Typ_Stmts : List_Id; 12141 Concval : Node_Id; 12142 D_Alt : constant Node_Id := Delay_Alternative (N); 12143 D_Conv : Node_Id; 12144 D_Disc : Node_Id; 12145 D_Stat : Node_Id := Delay_Statement (D_Alt); 12146 D_Stats : List_Id; 12147 D_Type : Entity_Id; 12148 Decls : List_Id; 12149 Dummy : Node_Id; 12150 E_Alt : constant Node_Id := Entry_Call_Alternative (N); 12151 E_Call : Node_Id := Entry_Call_Statement (E_Alt); 12152 E_Stats : List_Id; 12153 Ename : Node_Id; 12154 Formals : List_Id; 12155 Index : Node_Id; 12156 Is_Disp_Select : Boolean; 12157 Lim_Typ_Stmts : List_Id; 12158 N_Stats : List_Id; 12159 Obj : Entity_Id; 12160 Param : Node_Id; 12161 Params : List_Id; 12162 Stmt : Node_Id; 12163 Stmts : List_Id; 12164 Unpack : List_Id; 12165 12166 B : Entity_Id; -- Call status flag 12167 C : Entity_Id; -- Call kind 12168 D : Entity_Id; -- Delay 12169 K : Entity_Id; -- Tagged kind 12170 M : Entity_Id; -- Delay mode 12171 P : Entity_Id; -- Parameter block 12172 S : Entity_Id; -- Primitive operation slot 12173 12174 -- Start of processing for Expand_N_Timed_Entry_Call 12175 12176 begin 12177 -- Under the Ravenscar profile, timed entry calls are excluded. An error 12178 -- was already reported on spec, so do not attempt to expand the call. 12179 12180 if Restriction_Active (No_Select_Statements) then 12181 return; 12182 end if; 12183 12184 Process_Statements_For_Controlled_Objects (E_Alt); 12185 Process_Statements_For_Controlled_Objects (D_Alt); 12186 12187 Ensure_Statement_Present (Sloc (D_Stat), D_Alt); 12188 12189 -- Retrieve E_Stats and D_Stats now because the finalization machinery 12190 -- may wrap them in blocks. 12191 12192 E_Stats := Statements (E_Alt); 12193 D_Stats := Statements (D_Alt); 12194 12195 -- The arguments in the call may require dynamic allocation, and the 12196 -- call statement may have been transformed into a block. The block 12197 -- may contain additional declarations for internal entities, and the 12198 -- original call is found by sequential search. 12199 12200 if Nkind (E_Call) = N_Block_Statement then 12201 E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); 12202 while not Nkind_In (E_Call, N_Procedure_Call_Statement, 12203 N_Entry_Call_Statement) 12204 loop 12205 Next (E_Call); 12206 end loop; 12207 end if; 12208 12209 Is_Disp_Select := 12210 Ada_Version >= Ada_2005 12211 and then Nkind (E_Call) = N_Procedure_Call_Statement; 12212 12213 if Is_Disp_Select then 12214 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals); 12215 Decls := New_List; 12216 12217 Stmts := New_List; 12218 12219 -- Generate: 12220 -- B : Boolean := False; 12221 12222 B := Build_B (Loc, Decls); 12223 12224 -- Generate: 12225 -- C : Ada.Tags.Prim_Op_Kind; 12226 12227 C := Build_C (Loc, Decls); 12228 12229 -- Because the analysis of all statements was disabled, manually 12230 -- analyze the delay statement. 12231 12232 Analyze (D_Stat); 12233 D_Stat := Original_Node (D_Stat); 12234 12235 else 12236 -- Build an entry call using Simple_Entry_Call 12237 12238 Extract_Entry (E_Call, Concval, Ename, Index); 12239 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); 12240 12241 Decls := Declarations (E_Call); 12242 Stmts := Statements (Handled_Statement_Sequence (E_Call)); 12243 12244 if No (Decls) then 12245 Decls := New_List; 12246 end if; 12247 12248 -- Generate: 12249 -- B : Boolean; 12250 12251 B := Make_Defining_Identifier (Loc, Name_uB); 12252 12253 Prepend_To (Decls, 12254 Make_Object_Declaration (Loc, 12255 Defining_Identifier => B, 12256 Object_Definition => 12257 New_Occurrence_Of (Standard_Boolean, Loc))); 12258 end if; 12259 12260 -- Duration and mode processing 12261 12262 D_Type := Base_Type (Etype (Expression (D_Stat))); 12263 12264 -- Use the type of the delay expression (Calendar or Real_Time) to 12265 -- generate the appropriate conversion. 12266 12267 if Nkind (D_Stat) = N_Delay_Relative_Statement then 12268 D_Disc := Make_Integer_Literal (Loc, 0); 12269 D_Conv := Relocate_Node (Expression (D_Stat)); 12270 12271 elsif Is_RTE (D_Type, RO_CA_Time) then 12272 D_Disc := Make_Integer_Literal (Loc, 1); 12273 D_Conv := 12274 Make_Function_Call (Loc, 12275 Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 12276 Parameter_Associations => 12277 New_List (New_Copy (Expression (D_Stat)))); 12278 12279 else pragma Assert (Is_RTE (D_Type, RO_RT_Time)); 12280 D_Disc := Make_Integer_Literal (Loc, 2); 12281 D_Conv := 12282 Make_Function_Call (Loc, 12283 Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 12284 Parameter_Associations => 12285 New_List (New_Copy (Expression (D_Stat)))); 12286 end if; 12287 12288 D := Make_Temporary (Loc, 'D'); 12289 12290 -- Generate: 12291 -- D : Duration; 12292 12293 Append_To (Decls, 12294 Make_Object_Declaration (Loc, 12295 Defining_Identifier => D, 12296 Object_Definition => New_Occurrence_Of (Standard_Duration, Loc))); 12297 12298 M := Make_Temporary (Loc, 'M'); 12299 12300 -- Generate: 12301 -- M : Integer := (0 | 1 | 2); 12302 12303 Append_To (Decls, 12304 Make_Object_Declaration (Loc, 12305 Defining_Identifier => M, 12306 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 12307 Expression => D_Disc)); 12308 12309 -- Do the assignment at this stage only because the evaluation of the 12310 -- expression must not occur before (see ACVC C97302A). 12311 12312 Append_To (Stmts, 12313 Make_Assignment_Statement (Loc, 12314 Name => New_Occurrence_Of (D, Loc), 12315 Expression => D_Conv)); 12316 12317 -- Parameter block processing 12318 12319 -- Manually create the parameter block for dispatching calls. In the 12320 -- case of entries, the block has already been created during the call 12321 -- to Build_Simple_Entry_Call. 12322 12323 if Is_Disp_Select then 12324 12325 -- Tagged kind processing, generate: 12326 -- K : Ada.Tags.Tagged_Kind := 12327 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>)); 12328 12329 K := Build_K (Loc, Decls, Obj); 12330 12331 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 12332 P := 12333 Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 12334 12335 -- Dispatch table slot processing, generate: 12336 -- S : Integer; 12337 12338 S := Build_S (Loc, Decls); 12339 12340 -- Generate: 12341 -- S := Ada.Tags.Get_Offset_Index 12342 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 12343 12344 Conc_Typ_Stmts := 12345 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 12346 12347 -- Generate: 12348 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B); 12349 12350 -- where Obj is the controlling formal parameter, S is the dispatch 12351 -- table slot number of the dispatching operation, P is the wrapped 12352 -- parameter block, D is the duration, M is the duration mode, C is 12353 -- the call kind and B is the call status. 12354 12355 Params := New_List; 12356 12357 Append_To (Params, New_Copy_Tree (Obj)); 12358 Append_To (Params, New_Occurrence_Of (S, Loc)); 12359 Append_To (Params, 12360 Make_Attribute_Reference (Loc, 12361 Prefix => New_Occurrence_Of (P, Loc), 12362 Attribute_Name => Name_Address)); 12363 Append_To (Params, New_Occurrence_Of (D, Loc)); 12364 Append_To (Params, New_Occurrence_Of (M, Loc)); 12365 Append_To (Params, New_Occurrence_Of (C, Loc)); 12366 Append_To (Params, New_Occurrence_Of (B, Loc)); 12367 12368 Append_To (Conc_Typ_Stmts, 12369 Make_Procedure_Call_Statement (Loc, 12370 Name => 12371 New_Occurrence_Of 12372 (Find_Prim_Op 12373 (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc), 12374 Parameter_Associations => Params)); 12375 12376 -- Generate: 12377 -- if C = POK_Protected_Entry 12378 -- or else C = POK_Task_Entry 12379 -- then 12380 -- Param1 := P.Param1; 12381 -- ... 12382 -- ParamN := P.ParamN; 12383 -- end if; 12384 12385 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 12386 12387 -- Generate the if statement only when the packed parameters need 12388 -- explicit assignments to their corresponding actuals. 12389 12390 if Present (Unpack) then 12391 Append_To (Conc_Typ_Stmts, 12392 Make_Implicit_If_Statement (N, 12393 12394 Condition => 12395 Make_Or_Else (Loc, 12396 Left_Opnd => 12397 Make_Op_Eq (Loc, 12398 Left_Opnd => New_Occurrence_Of (C, Loc), 12399 Right_Opnd => 12400 New_Occurrence_Of 12401 (RTE (RE_POK_Protected_Entry), Loc)), 12402 12403 Right_Opnd => 12404 Make_Op_Eq (Loc, 12405 Left_Opnd => New_Occurrence_Of (C, Loc), 12406 Right_Opnd => 12407 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 12408 12409 Then_Statements => Unpack)); 12410 end if; 12411 12412 -- Generate: 12413 12414 -- if B then 12415 -- if C = POK_Procedure 12416 -- or else C = POK_Protected_Procedure 12417 -- or else C = POK_Task_Procedure 12418 -- then 12419 -- <dispatching-call> 12420 -- end if; 12421 -- end if; 12422 12423 N_Stats := New_List ( 12424 Make_Implicit_If_Statement (N, 12425 Condition => 12426 Make_Or_Else (Loc, 12427 Left_Opnd => 12428 Make_Op_Eq (Loc, 12429 Left_Opnd => New_Occurrence_Of (C, Loc), 12430 Right_Opnd => 12431 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 12432 12433 Right_Opnd => 12434 Make_Or_Else (Loc, 12435 Left_Opnd => 12436 Make_Op_Eq (Loc, 12437 Left_Opnd => New_Occurrence_Of (C, Loc), 12438 Right_Opnd => 12439 New_Occurrence_Of (RTE ( 12440 RE_POK_Protected_Procedure), Loc)), 12441 Right_Opnd => 12442 Make_Op_Eq (Loc, 12443 Left_Opnd => New_Occurrence_Of (C, Loc), 12444 Right_Opnd => 12445 New_Occurrence_Of 12446 (RTE (RE_POK_Task_Procedure), Loc)))), 12447 12448 Then_Statements => New_List (E_Call))); 12449 12450 Append_To (Conc_Typ_Stmts, 12451 Make_Implicit_If_Statement (N, 12452 Condition => New_Occurrence_Of (B, Loc), 12453 Then_Statements => N_Stats)); 12454 12455 -- Generate: 12456 -- <dispatching-call>; 12457 -- B := True; 12458 12459 Lim_Typ_Stmts := 12460 New_List (New_Copy_Tree (E_Call), 12461 Make_Assignment_Statement (Loc, 12462 Name => New_Occurrence_Of (B, Loc), 12463 Expression => New_Occurrence_Of (Standard_True, Loc))); 12464 12465 -- Generate: 12466 -- if K = Ada.Tags.TK_Limited_Tagged 12467 -- or else K = Ada.Tags.TK_Tagged 12468 -- then 12469 -- Lim_Typ_Stmts 12470 -- else 12471 -- Conc_Typ_Stmts 12472 -- end if; 12473 12474 Append_To (Stmts, 12475 Make_Implicit_If_Statement (N, 12476 Condition => Build_Dispatching_Tag_Check (K, N), 12477 Then_Statements => Lim_Typ_Stmts, 12478 Else_Statements => Conc_Typ_Stmts)); 12479 12480 -- Generate: 12481 12482 -- if B then 12483 -- <triggering-statements> 12484 -- else 12485 -- <timed-statements> 12486 -- end if; 12487 12488 Append_To (Stmts, 12489 Make_Implicit_If_Statement (N, 12490 Condition => New_Occurrence_Of (B, Loc), 12491 Then_Statements => E_Stats, 12492 Else_Statements => D_Stats)); 12493 12494 else 12495 -- Simple case of a non-dispatching trigger. Skip assignments to 12496 -- temporaries created for in-out parameters. 12497 12498 -- This makes unwarranted assumptions about the shape of the expanded 12499 -- tree for the call, and should be cleaned up ??? 12500 12501 Stmt := First (Stmts); 12502 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 12503 Next (Stmt); 12504 end loop; 12505 12506 -- Do the assignment at this stage only because the evaluation 12507 -- of the expression must not occur before (see ACVC C97302A). 12508 12509 Insert_Before (Stmt, 12510 Make_Assignment_Statement (Loc, 12511 Name => New_Occurrence_Of (D, Loc), 12512 Expression => D_Conv)); 12513 12514 Call := Stmt; 12515 Params := Parameter_Associations (Call); 12516 12517 -- For a protected type, we build a Timed_Protected_Entry_Call 12518 12519 if Is_Protected_Type (Etype (Concval)) then 12520 12521 -- Create a new call statement 12522 12523 Param := First (Params); 12524 while Present (Param) 12525 and then not Is_RTE (Etype (Param), RE_Call_Modes) 12526 loop 12527 Next (Param); 12528 end loop; 12529 12530 Dummy := Remove_Next (Next (Param)); 12531 12532 -- Remove garbage is following the Cancel_Param if present 12533 12534 Dummy := Next (Param); 12535 12536 -- Remove the mode of the Protected_Entry_Call call, then remove 12537 -- the Communication_Block of the Protected_Entry_Call call, and 12538 -- finally add Duration and a Delay_Mode parameter 12539 12540 pragma Assert (Present (Param)); 12541 Rewrite (Param, New_Occurrence_Of (D, Loc)); 12542 12543 Rewrite (Dummy, New_Occurrence_Of (M, Loc)); 12544 12545 -- Add a Boolean flag for successful entry call 12546 12547 Append_To (Params, New_Occurrence_Of (B, Loc)); 12548 12549 case Corresponding_Runtime_Package (Etype (Concval)) is 12550 when System_Tasking_Protected_Objects_Entries => 12551 Rewrite (Call, 12552 Make_Procedure_Call_Statement (Loc, 12553 Name => 12554 New_Occurrence_Of 12555 (RTE (RE_Timed_Protected_Entry_Call), Loc), 12556 Parameter_Associations => Params)); 12557 12558 when others => 12559 raise Program_Error; 12560 end case; 12561 12562 -- For the task case, build a Timed_Task_Entry_Call 12563 12564 else 12565 -- Create a new call statement 12566 12567 Append_To (Params, New_Occurrence_Of (D, Loc)); 12568 Append_To (Params, New_Occurrence_Of (M, Loc)); 12569 Append_To (Params, New_Occurrence_Of (B, Loc)); 12570 12571 Rewrite (Call, 12572 Make_Procedure_Call_Statement (Loc, 12573 Name => 12574 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc), 12575 Parameter_Associations => Params)); 12576 end if; 12577 12578 Append_To (Stmts, 12579 Make_Implicit_If_Statement (N, 12580 Condition => New_Occurrence_Of (B, Loc), 12581 Then_Statements => E_Stats, 12582 Else_Statements => D_Stats)); 12583 end if; 12584 12585 Rewrite (N, 12586 Make_Block_Statement (Loc, 12587 Declarations => Decls, 12588 Handled_Statement_Sequence => 12589 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 12590 12591 Analyze (N); 12592 end Expand_N_Timed_Entry_Call; 12593 12594 ---------------------------------------- 12595 -- Expand_Protected_Body_Declarations -- 12596 ---------------------------------------- 12597 12598 procedure Expand_Protected_Body_Declarations 12599 (N : Node_Id; 12600 Spec_Id : Entity_Id) 12601 is 12602 begin 12603 if No_Run_Time_Mode then 12604 Error_Msg_CRT ("protected body", N); 12605 return; 12606 12607 elsif Expander_Active then 12608 12609 -- Associate discriminals with the first subprogram or entry body to 12610 -- be expanded. 12611 12612 if Present (First_Protected_Operation (Declarations (N))) then 12613 Set_Discriminals (Parent (Spec_Id)); 12614 end if; 12615 end if; 12616 end Expand_Protected_Body_Declarations; 12617 12618 ------------------------- 12619 -- External_Subprogram -- 12620 ------------------------- 12621 12622 function External_Subprogram (E : Entity_Id) return Entity_Id is 12623 Subp : constant Entity_Id := Protected_Body_Subprogram (E); 12624 12625 begin 12626 -- The internal and external subprograms follow each other on the entity 12627 -- chain. Note that previously private operations had no separate 12628 -- external subprogram. We now create one in all cases, because a 12629 -- private operation may actually appear in an external call, through 12630 -- a 'Access reference used for a callback. 12631 12632 -- If the operation is a function that returns an anonymous access type, 12633 -- the corresponding itype appears before the operation, and must be 12634 -- skipped. 12635 12636 -- This mechanism is fragile, there should be a real link between the 12637 -- two versions of the operation, but there is no place to put it ??? 12638 12639 if Is_Access_Type (Next_Entity (Subp)) then 12640 return Next_Entity (Next_Entity (Subp)); 12641 else 12642 return Next_Entity (Subp); 12643 end if; 12644 end External_Subprogram; 12645 12646 ------------------------------ 12647 -- Extract_Dispatching_Call -- 12648 ------------------------------ 12649 12650 procedure Extract_Dispatching_Call 12651 (N : Node_Id; 12652 Call_Ent : out Entity_Id; 12653 Object : out Entity_Id; 12654 Actuals : out List_Id; 12655 Formals : out List_Id) 12656 is 12657 Call_Nam : Node_Id; 12658 12659 begin 12660 pragma Assert (Nkind (N) = N_Procedure_Call_Statement); 12661 12662 if Present (Original_Node (N)) then 12663 Call_Nam := Name (Original_Node (N)); 12664 else 12665 Call_Nam := Name (N); 12666 end if; 12667 12668 -- Retrieve the name of the dispatching procedure. It contains the 12669 -- dispatch table slot number. 12670 12671 loop 12672 case Nkind (Call_Nam) is 12673 when N_Identifier => 12674 exit; 12675 12676 when N_Selected_Component => 12677 Call_Nam := Selector_Name (Call_Nam); 12678 12679 when others => 12680 raise Program_Error; 12681 12682 end case; 12683 end loop; 12684 12685 Actuals := Parameter_Associations (N); 12686 Call_Ent := Entity (Call_Nam); 12687 Formals := Parameter_Specifications (Parent (Call_Ent)); 12688 Object := First (Actuals); 12689 12690 if Present (Original_Node (Object)) then 12691 Object := Original_Node (Object); 12692 end if; 12693 12694 -- If the type of the dispatching object is an access type then return 12695 -- an explicit dereference. 12696 12697 if Is_Access_Type (Etype (Object)) then 12698 Object := Make_Explicit_Dereference (Sloc (N), Object); 12699 Analyze (Object); 12700 end if; 12701 end Extract_Dispatching_Call; 12702 12703 ------------------- 12704 -- Extract_Entry -- 12705 ------------------- 12706 12707 procedure Extract_Entry 12708 (N : Node_Id; 12709 Concval : out Node_Id; 12710 Ename : out Node_Id; 12711 Index : out Node_Id) 12712 is 12713 Nam : constant Node_Id := Name (N); 12714 12715 begin 12716 -- For a simple entry, the name is a selected component, with the 12717 -- prefix being the task value, and the selector being the entry. 12718 12719 if Nkind (Nam) = N_Selected_Component then 12720 Concval := Prefix (Nam); 12721 Ename := Selector_Name (Nam); 12722 Index := Empty; 12723 12724 -- For a member of an entry family, the name is an indexed component 12725 -- where the prefix is a selected component, whose prefix in turn is 12726 -- the task value, and whose selector is the entry family. The single 12727 -- expression in the expressions list of the indexed component is the 12728 -- subscript for the family. 12729 12730 else pragma Assert (Nkind (Nam) = N_Indexed_Component); 12731 Concval := Prefix (Prefix (Nam)); 12732 Ename := Selector_Name (Prefix (Nam)); 12733 Index := First (Expressions (Nam)); 12734 end if; 12735 end Extract_Entry; 12736 12737 ------------------- 12738 -- Family_Offset -- 12739 ------------------- 12740 12741 function Family_Offset 12742 (Loc : Source_Ptr; 12743 Hi : Node_Id; 12744 Lo : Node_Id; 12745 Ttyp : Entity_Id; 12746 Cap : Boolean) return Node_Id 12747 is 12748 Ityp : Entity_Id; 12749 Real_Hi : Node_Id; 12750 Real_Lo : Node_Id; 12751 12752 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 12753 -- If one of the bounds is a reference to a discriminant, replace with 12754 -- corresponding discriminal of type. Within the body of a task retrieve 12755 -- the renamed discriminant by simple visibility, using its generated 12756 -- name. Within a protected object, find the original discriminant and 12757 -- replace it with the discriminal of the current protected operation. 12758 12759 ------------------------------ 12760 -- Convert_Discriminant_Ref -- 12761 ------------------------------ 12762 12763 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 12764 Loc : constant Source_Ptr := Sloc (Bound); 12765 B : Node_Id; 12766 D : Entity_Id; 12767 12768 begin 12769 if Is_Entity_Name (Bound) 12770 and then Ekind (Entity (Bound)) = E_Discriminant 12771 then 12772 if Is_Task_Type (Ttyp) 12773 and then Has_Completion (Ttyp) 12774 then 12775 B := Make_Identifier (Loc, Chars (Entity (Bound))); 12776 Find_Direct_Name (B); 12777 12778 elsif Is_Protected_Type (Ttyp) then 12779 D := First_Discriminant (Ttyp); 12780 while Chars (D) /= Chars (Entity (Bound)) loop 12781 Next_Discriminant (D); 12782 end loop; 12783 12784 B := New_Occurrence_Of (Discriminal (D), Loc); 12785 12786 else 12787 B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); 12788 end if; 12789 12790 elsif Nkind (Bound) = N_Attribute_Reference then 12791 return Bound; 12792 12793 else 12794 B := New_Copy_Tree (Bound); 12795 end if; 12796 12797 return 12798 Make_Attribute_Reference (Loc, 12799 Attribute_Name => Name_Pos, 12800 Prefix => New_Occurrence_Of (Etype (Bound), Loc), 12801 Expressions => New_List (B)); 12802 end Convert_Discriminant_Ref; 12803 12804 -- Start of processing for Family_Offset 12805 12806 begin 12807 Real_Hi := Convert_Discriminant_Ref (Hi); 12808 Real_Lo := Convert_Discriminant_Ref (Lo); 12809 12810 if Cap then 12811 if Is_Task_Type (Ttyp) then 12812 Ityp := RTE (RE_Task_Entry_Index); 12813 else 12814 Ityp := RTE (RE_Protected_Entry_Index); 12815 end if; 12816 12817 Real_Hi := 12818 Make_Attribute_Reference (Loc, 12819 Prefix => New_Occurrence_Of (Ityp, Loc), 12820 Attribute_Name => Name_Min, 12821 Expressions => New_List ( 12822 Real_Hi, 12823 Make_Integer_Literal (Loc, Entry_Family_Bound - 1))); 12824 12825 Real_Lo := 12826 Make_Attribute_Reference (Loc, 12827 Prefix => New_Occurrence_Of (Ityp, Loc), 12828 Attribute_Name => Name_Max, 12829 Expressions => New_List ( 12830 Real_Lo, 12831 Make_Integer_Literal (Loc, -Entry_Family_Bound))); 12832 end if; 12833 12834 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo); 12835 end Family_Offset; 12836 12837 ----------------- 12838 -- Family_Size -- 12839 ----------------- 12840 12841 function Family_Size 12842 (Loc : Source_Ptr; 12843 Hi : Node_Id; 12844 Lo : Node_Id; 12845 Ttyp : Entity_Id; 12846 Cap : Boolean) return Node_Id 12847 is 12848 Ityp : Entity_Id; 12849 12850 begin 12851 if Is_Task_Type (Ttyp) then 12852 Ityp := RTE (RE_Task_Entry_Index); 12853 else 12854 Ityp := RTE (RE_Protected_Entry_Index); 12855 end if; 12856 12857 return 12858 Make_Attribute_Reference (Loc, 12859 Prefix => New_Occurrence_Of (Ityp, Loc), 12860 Attribute_Name => Name_Max, 12861 Expressions => New_List ( 12862 Make_Op_Add (Loc, 12863 Left_Opnd => 12864 Family_Offset (Loc, Hi, Lo, Ttyp, Cap), 12865 Right_Opnd => 12866 Make_Integer_Literal (Loc, 1)), 12867 Make_Integer_Literal (Loc, 0))); 12868 end Family_Size; 12869 12870 ---------------------------- 12871 -- Find_Enclosing_Context -- 12872 ---------------------------- 12873 12874 procedure Find_Enclosing_Context 12875 (N : Node_Id; 12876 Context : out Node_Id; 12877 Context_Id : out Entity_Id; 12878 Context_Decls : out List_Id) 12879 is 12880 begin 12881 -- Traverse the parent chain looking for an enclosing body, block, 12882 -- package or return statement. 12883 12884 Context := Parent (N); 12885 while not Nkind_In (Context, N_Block_Statement, 12886 N_Entry_Body, 12887 N_Extended_Return_Statement, 12888 N_Package_Body, 12889 N_Package_Declaration, 12890 N_Subprogram_Body, 12891 N_Task_Body) 12892 loop 12893 Context := Parent (Context); 12894 end loop; 12895 12896 -- Extract the constituents of the context 12897 12898 if Nkind (Context) = N_Extended_Return_Statement then 12899 Context_Decls := Return_Object_Declarations (Context); 12900 Context_Id := Return_Statement_Entity (Context); 12901 12902 -- Package declarations and bodies use a common library-level activation 12903 -- chain or task master, therefore return the package declaration as the 12904 -- proper carrier for the appropriate flag. 12905 12906 elsif Nkind (Context) = N_Package_Body then 12907 Context_Decls := Declarations (Context); 12908 Context_Id := Corresponding_Spec (Context); 12909 Context := Parent (Context_Id); 12910 12911 if Nkind (Context) = N_Defining_Program_Unit_Name then 12912 Context := Parent (Parent (Context)); 12913 else 12914 Context := Parent (Context); 12915 end if; 12916 12917 elsif Nkind (Context) = N_Package_Declaration then 12918 Context_Decls := Visible_Declarations (Specification (Context)); 12919 Context_Id := Defining_Unit_Name (Specification (Context)); 12920 12921 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 12922 Context_Id := Defining_Identifier (Context_Id); 12923 end if; 12924 12925 else 12926 Context_Decls := Declarations (Context); 12927 12928 if Nkind (Context) = N_Block_Statement then 12929 Context_Id := Entity (Identifier (Context)); 12930 12931 elsif Nkind (Context) = N_Entry_Body then 12932 Context_Id := Defining_Identifier (Context); 12933 12934 elsif Nkind (Context) = N_Subprogram_Body then 12935 if Present (Corresponding_Spec (Context)) then 12936 Context_Id := Corresponding_Spec (Context); 12937 else 12938 Context_Id := Defining_Unit_Name (Specification (Context)); 12939 12940 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 12941 Context_Id := Defining_Identifier (Context_Id); 12942 end if; 12943 end if; 12944 12945 elsif Nkind (Context) = N_Task_Body then 12946 Context_Id := Corresponding_Spec (Context); 12947 12948 else 12949 raise Program_Error; 12950 end if; 12951 end if; 12952 12953 pragma Assert (Present (Context)); 12954 pragma Assert (Present (Context_Id)); 12955 pragma Assert (Present (Context_Decls)); 12956 end Find_Enclosing_Context; 12957 12958 ----------------------- 12959 -- Find_Master_Scope -- 12960 ----------------------- 12961 12962 function Find_Master_Scope (E : Entity_Id) return Entity_Id is 12963 S : Entity_Id; 12964 12965 begin 12966 -- In Ada 2005, the master is the innermost enclosing scope that is not 12967 -- transient. If the enclosing block is the rewriting of a call or the 12968 -- scope is an extended return statement this is valid master. The 12969 -- master in an extended return is only used within the return, and is 12970 -- subsequently overwritten in Move_Activation_Chain, but it must exist 12971 -- now before that overwriting occurs. 12972 12973 S := Scope (E); 12974 12975 if Ada_Version >= Ada_2005 then 12976 while Is_Internal (S) loop 12977 if Nkind (Parent (S)) = N_Block_Statement 12978 and then 12979 Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement 12980 then 12981 exit; 12982 12983 elsif Ekind (S) = E_Return_Statement then 12984 exit; 12985 12986 else 12987 S := Scope (S); 12988 end if; 12989 end loop; 12990 end if; 12991 12992 return S; 12993 end Find_Master_Scope; 12994 12995 ------------------------------- 12996 -- First_Protected_Operation -- 12997 ------------------------------- 12998 12999 function First_Protected_Operation (D : List_Id) return Node_Id is 13000 First_Op : Node_Id; 13001 13002 begin 13003 First_Op := First (D); 13004 while Present (First_Op) 13005 and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body) 13006 loop 13007 Next (First_Op); 13008 end loop; 13009 13010 return First_Op; 13011 end First_Protected_Operation; 13012 13013 --------------------------------------- 13014 -- Install_Private_Data_Declarations -- 13015 --------------------------------------- 13016 13017 procedure Install_Private_Data_Declarations 13018 (Loc : Source_Ptr; 13019 Spec_Id : Entity_Id; 13020 Conc_Typ : Entity_Id; 13021 Body_Nod : Node_Id; 13022 Decls : List_Id; 13023 Barrier : Boolean := False; 13024 Family : Boolean := False) 13025 is 13026 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ); 13027 Decl : Node_Id; 13028 Def : Node_Id; 13029 Insert_Node : Node_Id := Empty; 13030 Obj_Ent : Entity_Id; 13031 13032 procedure Add (Decl : Node_Id); 13033 -- Add a single declaration after Insert_Node. If this is the first 13034 -- addition, Decl is added to the front of Decls and it becomes the 13035 -- insertion node. 13036 13037 function Replace_Bound (Bound : Node_Id) return Node_Id; 13038 -- The bounds of an entry index may depend on discriminants, create a 13039 -- reference to the corresponding prival. Otherwise return a duplicate 13040 -- of the original bound. 13041 13042 --------- 13043 -- Add -- 13044 --------- 13045 13046 procedure Add (Decl : Node_Id) is 13047 begin 13048 if No (Insert_Node) then 13049 Prepend_To (Decls, Decl); 13050 else 13051 Insert_After (Insert_Node, Decl); 13052 end if; 13053 13054 Insert_Node := Decl; 13055 end Add; 13056 13057 -------------------------- 13058 -- Replace_Discriminant -- 13059 -------------------------- 13060 13061 function Replace_Bound (Bound : Node_Id) return Node_Id is 13062 begin 13063 if Nkind (Bound) = N_Identifier 13064 and then Is_Discriminal (Entity (Bound)) 13065 then 13066 return Make_Identifier (Loc, Chars (Entity (Bound))); 13067 else 13068 return Duplicate_Subexpr (Bound); 13069 end if; 13070 end Replace_Bound; 13071 13072 -- Start of processing for Install_Private_Data_Declarations 13073 13074 begin 13075 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote 13076 -- formal parameter _O, _object or _task depending on the context. 13077 13078 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ); 13079 13080 -- Special processing of _O for barrier functions, protected entries 13081 -- and families. 13082 13083 if Barrier 13084 or else 13085 (Is_Protected 13086 and then 13087 (Ekind (Spec_Id) = E_Entry 13088 or else Ekind (Spec_Id) = E_Entry_Family)) 13089 then 13090 declare 13091 Conc_Rec : constant Entity_Id := 13092 Corresponding_Record_Type (Conc_Typ); 13093 Typ_Id : constant Entity_Id := 13094 Make_Defining_Identifier (Loc, 13095 New_External_Name (Chars (Conc_Rec), 'P')); 13096 begin 13097 -- Generate: 13098 -- type prot_typVP is access prot_typV; 13099 13100 Decl := 13101 Make_Full_Type_Declaration (Loc, 13102 Defining_Identifier => Typ_Id, 13103 Type_Definition => 13104 Make_Access_To_Object_Definition (Loc, 13105 Subtype_Indication => 13106 New_Occurrence_Of (Conc_Rec, Loc))); 13107 Add (Decl); 13108 13109 -- Generate: 13110 -- _object : prot_typVP := prot_typV (_O); 13111 13112 Decl := 13113 Make_Object_Declaration (Loc, 13114 Defining_Identifier => 13115 Make_Defining_Identifier (Loc, Name_uObject), 13116 Object_Definition => New_Occurrence_Of (Typ_Id, Loc), 13117 Expression => 13118 Unchecked_Convert_To (Typ_Id, 13119 New_Occurrence_Of (Obj_Ent, Loc))); 13120 Add (Decl); 13121 13122 -- Set the reference to the concurrent object 13123 13124 Obj_Ent := Defining_Identifier (Decl); 13125 end; 13126 end if; 13127 13128 -- Step 2: Create the Protection object and build its declaration for 13129 -- any protected entry (family) of subprogram. Note for the lock-free 13130 -- implementation, the Protection object is not needed anymore. 13131 13132 if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then 13133 declare 13134 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R'); 13135 Prot_Typ : RE_Id; 13136 13137 begin 13138 Set_Protection_Object (Spec_Id, Prot_Ent); 13139 13140 -- Determine the proper protection type 13141 13142 if Has_Attach_Handler (Conc_Typ) 13143 and then not Restricted_Profile 13144 then 13145 Prot_Typ := RE_Static_Interrupt_Protection; 13146 13147 elsif Has_Interrupt_Handler (Conc_Typ) 13148 and then not Restriction_Active (No_Dynamic_Attachment) 13149 then 13150 Prot_Typ := RE_Dynamic_Interrupt_Protection; 13151 13152 else 13153 case Corresponding_Runtime_Package (Conc_Typ) is 13154 when System_Tasking_Protected_Objects_Entries => 13155 Prot_Typ := RE_Protection_Entries; 13156 13157 when System_Tasking_Protected_Objects_Single_Entry => 13158 Prot_Typ := RE_Protection_Entry; 13159 13160 when System_Tasking_Protected_Objects => 13161 Prot_Typ := RE_Protection; 13162 13163 when others => 13164 raise Program_Error; 13165 end case; 13166 end if; 13167 13168 -- Generate: 13169 -- conc_typR : protection_typ renames _object._object; 13170 13171 Decl := 13172 Make_Object_Renaming_Declaration (Loc, 13173 Defining_Identifier => Prot_Ent, 13174 Subtype_Mark => 13175 New_Occurrence_Of (RTE (Prot_Typ), Loc), 13176 Name => 13177 Make_Selected_Component (Loc, 13178 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13179 Selector_Name => Make_Identifier (Loc, Name_uObject))); 13180 Add (Decl); 13181 end; 13182 end if; 13183 13184 -- Step 3: Add discriminant renamings (if any) 13185 13186 if Has_Discriminants (Conc_Typ) then 13187 declare 13188 D : Entity_Id; 13189 13190 begin 13191 D := First_Discriminant (Conc_Typ); 13192 while Present (D) loop 13193 13194 -- Adjust the source location 13195 13196 Set_Sloc (Discriminal (D), Loc); 13197 13198 -- Generate: 13199 -- discr_name : discr_typ renames _object.discr_name; 13200 -- or 13201 -- discr_name : discr_typ renames _task.discr_name; 13202 13203 Decl := 13204 Make_Object_Renaming_Declaration (Loc, 13205 Defining_Identifier => Discriminal (D), 13206 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc), 13207 Name => 13208 Make_Selected_Component (Loc, 13209 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13210 Selector_Name => Make_Identifier (Loc, Chars (D)))); 13211 Add (Decl); 13212 13213 Next_Discriminant (D); 13214 end loop; 13215 end; 13216 end if; 13217 13218 -- Step 4: Add private component renamings (if any) 13219 13220 if Is_Protected then 13221 Def := Protected_Definition (Parent (Conc_Typ)); 13222 13223 if Present (Private_Declarations (Def)) then 13224 declare 13225 Comp : Node_Id; 13226 Comp_Id : Entity_Id; 13227 Decl_Id : Entity_Id; 13228 13229 begin 13230 Comp := First (Private_Declarations (Def)); 13231 while Present (Comp) loop 13232 if Nkind (Comp) = N_Component_Declaration then 13233 Comp_Id := Defining_Identifier (Comp); 13234 Decl_Id := 13235 Make_Defining_Identifier (Loc, Chars (Comp_Id)); 13236 13237 -- Minimal decoration 13238 13239 if Ekind (Spec_Id) = E_Function then 13240 Set_Ekind (Decl_Id, E_Constant); 13241 else 13242 Set_Ekind (Decl_Id, E_Variable); 13243 end if; 13244 13245 Set_Prival (Comp_Id, Decl_Id); 13246 Set_Prival_Link (Decl_Id, Comp_Id); 13247 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id)); 13248 13249 -- Generate: 13250 -- comp_name : comp_typ renames _object.comp_name; 13251 13252 Decl := 13253 Make_Object_Renaming_Declaration (Loc, 13254 Defining_Identifier => Decl_Id, 13255 Subtype_Mark => 13256 New_Occurrence_Of (Etype (Comp_Id), Loc), 13257 Name => 13258 Make_Selected_Component (Loc, 13259 Prefix => 13260 New_Occurrence_Of (Obj_Ent, Loc), 13261 Selector_Name => 13262 Make_Identifier (Loc, Chars (Comp_Id)))); 13263 Add (Decl); 13264 end if; 13265 13266 Next (Comp); 13267 end loop; 13268 end; 13269 end if; 13270 end if; 13271 13272 -- Step 5: Add the declaration of the entry index and the associated 13273 -- type for barrier functions and entry families. 13274 13275 if (Barrier and then Family) 13276 or else Ekind (Spec_Id) = E_Entry_Family 13277 then 13278 declare 13279 E : constant Entity_Id := Index_Object (Spec_Id); 13280 Index : constant Entity_Id := 13281 Defining_Identifier ( 13282 Entry_Index_Specification ( 13283 Entry_Body_Formal_Part (Body_Nod))); 13284 Index_Con : constant Entity_Id := 13285 Make_Defining_Identifier (Loc, Chars (Index)); 13286 High : Node_Id; 13287 Index_Typ : Entity_Id; 13288 Low : Node_Id; 13289 13290 begin 13291 -- Minimal decoration 13292 13293 Set_Ekind (Index_Con, E_Constant); 13294 Set_Entry_Index_Constant (Index, Index_Con); 13295 Set_Discriminal_Link (Index_Con, Index); 13296 13297 -- Retrieve the bounds of the entry family 13298 13299 High := Type_High_Bound (Etype (Index)); 13300 Low := Type_Low_Bound (Etype (Index)); 13301 13302 -- In the simple case the entry family is given by a subtype 13303 -- mark and the index constant has the same type. 13304 13305 if Is_Entity_Name (Original_Node ( 13306 Discrete_Subtype_Definition (Parent (Index)))) 13307 then 13308 Index_Typ := Etype (Index); 13309 13310 -- Otherwise a new subtype declaration is required 13311 13312 else 13313 High := Replace_Bound (High); 13314 Low := Replace_Bound (Low); 13315 13316 Index_Typ := Make_Temporary (Loc, 'J'); 13317 13318 -- Generate: 13319 -- subtype Jnn is <Etype of Index> range Low .. High; 13320 13321 Decl := 13322 Make_Subtype_Declaration (Loc, 13323 Defining_Identifier => Index_Typ, 13324 Subtype_Indication => 13325 Make_Subtype_Indication (Loc, 13326 Subtype_Mark => 13327 New_Occurrence_Of (Base_Type (Etype (Index)), Loc), 13328 Constraint => 13329 Make_Range_Constraint (Loc, 13330 Range_Expression => 13331 Make_Range (Loc, Low, High)))); 13332 Add (Decl); 13333 end if; 13334 13335 Set_Etype (Index_Con, Index_Typ); 13336 13337 -- Create the object which designates the index: 13338 -- J : constant Jnn := 13339 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First)); 13340 -- 13341 -- where Jnn is the subtype created above or the original type of 13342 -- the index, _E is a formal of the protected body subprogram and 13343 -- <index expr> is the index of the first family member. 13344 13345 Decl := 13346 Make_Object_Declaration (Loc, 13347 Defining_Identifier => Index_Con, 13348 Constant_Present => True, 13349 Object_Definition => 13350 New_Occurrence_Of (Index_Typ, Loc), 13351 13352 Expression => 13353 Make_Attribute_Reference (Loc, 13354 Prefix => 13355 New_Occurrence_Of (Index_Typ, Loc), 13356 Attribute_Name => Name_Val, 13357 13358 Expressions => New_List ( 13359 13360 Make_Op_Add (Loc, 13361 Left_Opnd => 13362 Make_Op_Subtract (Loc, 13363 Left_Opnd => 13364 New_Occurrence_Of (E, Loc), 13365 Right_Opnd => 13366 Entry_Index_Expression (Loc, 13367 Defining_Identifier (Body_Nod), 13368 Empty, Conc_Typ)), 13369 13370 Right_Opnd => 13371 Make_Attribute_Reference (Loc, 13372 Prefix => 13373 New_Occurrence_Of (Index_Typ, Loc), 13374 Attribute_Name => Name_Pos, 13375 Expressions => New_List ( 13376 Make_Attribute_Reference (Loc, 13377 Prefix => 13378 New_Occurrence_Of (Index_Typ, Loc), 13379 Attribute_Name => Name_First))))))); 13380 Add (Decl); 13381 end; 13382 end if; 13383 end Install_Private_Data_Declarations; 13384 13385 ----------------------- 13386 -- Is_Exception_Safe -- 13387 ----------------------- 13388 13389 function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is 13390 13391 function Has_Side_Effect (N : Node_Id) return Boolean; 13392 -- Return True whenever encountering a subprogram call or raise 13393 -- statement of any kind in the sequence of statements 13394 13395 --------------------- 13396 -- Has_Side_Effect -- 13397 --------------------- 13398 13399 -- What is this doing buried two levels down in exp_ch9. It seems like a 13400 -- generally useful function, and indeed there may be code duplication 13401 -- going on here ??? 13402 13403 function Has_Side_Effect (N : Node_Id) return Boolean is 13404 Stmt : Node_Id; 13405 Expr : Node_Id; 13406 13407 function Is_Call_Or_Raise (N : Node_Id) return Boolean; 13408 -- Indicate whether N is a subprogram call or a raise statement 13409 13410 ---------------------- 13411 -- Is_Call_Or_Raise -- 13412 ---------------------- 13413 13414 function Is_Call_Or_Raise (N : Node_Id) return Boolean is 13415 begin 13416 return Nkind_In (N, N_Procedure_Call_Statement, 13417 N_Function_Call, 13418 N_Raise_Statement, 13419 N_Raise_Constraint_Error, 13420 N_Raise_Program_Error, 13421 N_Raise_Storage_Error); 13422 end Is_Call_Or_Raise; 13423 13424 -- Start of processing for Has_Side_Effect 13425 13426 begin 13427 Stmt := N; 13428 while Present (Stmt) loop 13429 if Is_Call_Or_Raise (Stmt) then 13430 return True; 13431 end if; 13432 13433 -- An object declaration can also contain a function call or a 13434 -- raise statement. 13435 13436 if Nkind (Stmt) = N_Object_Declaration then 13437 Expr := Expression (Stmt); 13438 13439 if Present (Expr) and then Is_Call_Or_Raise (Expr) then 13440 return True; 13441 end if; 13442 end if; 13443 13444 Next (Stmt); 13445 end loop; 13446 13447 return False; 13448 end Has_Side_Effect; 13449 13450 -- Start of processing for Is_Exception_Safe 13451 13452 begin 13453 -- When exceptions can't be propagated, the subprogram returns normally 13454 13455 if No_Exception_Handlers_Set then 13456 return True; 13457 end if; 13458 13459 -- If the checks handled by the back end are not disabled, we cannot 13460 -- ensure that no exception will be raised. 13461 13462 if not Access_Checks_Suppressed (Empty) 13463 or else not Discriminant_Checks_Suppressed (Empty) 13464 or else not Range_Checks_Suppressed (Empty) 13465 or else not Index_Checks_Suppressed (Empty) 13466 or else Opt.Stack_Checking_Enabled 13467 then 13468 return False; 13469 end if; 13470 13471 if Has_Side_Effect (First (Declarations (Subprogram))) 13472 or else 13473 Has_Side_Effect 13474 (First (Statements (Handled_Statement_Sequence (Subprogram)))) 13475 then 13476 return False; 13477 else 13478 return True; 13479 end if; 13480 end Is_Exception_Safe; 13481 13482 --------------------------------- 13483 -- Is_Potentially_Large_Family -- 13484 --------------------------------- 13485 13486 function Is_Potentially_Large_Family 13487 (Base_Index : Entity_Id; 13488 Conctyp : Entity_Id; 13489 Lo : Node_Id; 13490 Hi : Node_Id) return Boolean 13491 is 13492 begin 13493 return Scope (Base_Index) = Standard_Standard 13494 and then Base_Index = Base_Type (Standard_Integer) 13495 and then Has_Discriminants (Conctyp) 13496 and then 13497 Present (Discriminant_Default_Value (First_Discriminant (Conctyp))) 13498 and then 13499 (Denotes_Discriminant (Lo, True) 13500 or else 13501 Denotes_Discriminant (Hi, True)); 13502 end Is_Potentially_Large_Family; 13503 13504 ------------------------------------- 13505 -- Is_Private_Primitive_Subprogram -- 13506 ------------------------------------- 13507 13508 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is 13509 begin 13510 return 13511 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure) 13512 and then Is_Private_Primitive (Id); 13513 end Is_Private_Primitive_Subprogram; 13514 13515 ------------------ 13516 -- Index_Object -- 13517 ------------------ 13518 13519 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is 13520 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id); 13521 Formal : Entity_Id; 13522 13523 begin 13524 Formal := First_Formal (Bod_Subp); 13525 while Present (Formal) loop 13526 13527 -- Look for formal parameter _E 13528 13529 if Chars (Formal) = Name_uE then 13530 return Formal; 13531 end if; 13532 13533 Next_Formal (Formal); 13534 end loop; 13535 13536 -- A protected body subprogram should always have the parameter in 13537 -- question. 13538 13539 raise Program_Error; 13540 end Index_Object; 13541 13542 -------------------------------- 13543 -- Make_Initialize_Protection -- 13544 -------------------------------- 13545 13546 function Make_Initialize_Protection 13547 (Protect_Rec : Entity_Id) return List_Id 13548 is 13549 Loc : constant Source_Ptr := Sloc (Protect_Rec); 13550 P_Arr : Entity_Id; 13551 Pdec : Node_Id; 13552 Ptyp : constant Node_Id := 13553 Corresponding_Concurrent_Type (Protect_Rec); 13554 Args : List_Id; 13555 L : constant List_Id := New_List; 13556 Has_Entry : constant Boolean := Has_Entries (Ptyp); 13557 Prio_Type : Entity_Id; 13558 Prio_Var : Entity_Id := Empty; 13559 Restricted : constant Boolean := Restricted_Profile; 13560 13561 begin 13562 -- We may need two calls to properly initialize the object, one to 13563 -- Initialize_Protection, and possibly one to Install_Handlers if we 13564 -- have a pragma Attach_Handler. 13565 13566 -- Get protected declaration. In the case of a task type declaration, 13567 -- this is simply the parent of the protected type entity. In the single 13568 -- protected object declaration, this parent will be the implicit type, 13569 -- and we can find the corresponding single protected object declaration 13570 -- by searching forward in the declaration list in the tree. 13571 13572 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes 13573 -- of this type should have been removed during semantic analysis. 13574 13575 Pdec := Parent (Ptyp); 13576 while not Nkind_In (Pdec, N_Protected_Type_Declaration, 13577 N_Single_Protected_Declaration) 13578 loop 13579 Next (Pdec); 13580 end loop; 13581 13582 -- Build the parameter list for the call. Note that _Init is the name 13583 -- of the formal for the object to be initialized, which is the task 13584 -- value record itself. 13585 13586 Args := New_List; 13587 13588 -- For lock-free implementation, skip initializations of the Protection 13589 -- object. 13590 13591 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 13592 -- Object parameter. This is a pointer to the object of type 13593 -- Protection used by the GNARL to control the protected object. 13594 13595 Append_To (Args, 13596 Make_Attribute_Reference (Loc, 13597 Prefix => 13598 Make_Selected_Component (Loc, 13599 Prefix => Make_Identifier (Loc, Name_uInit), 13600 Selector_Name => Make_Identifier (Loc, Name_uObject)), 13601 Attribute_Name => Name_Unchecked_Access)); 13602 13603 -- Priority parameter. Set to Unspecified_Priority unless there is a 13604 -- Priority rep item, in which case we take the value from the pragma 13605 -- or attribute definition clause, or there is an Interrupt_Priority 13606 -- rep item and no Priority rep item, and we set the ceiling to 13607 -- Interrupt_Priority'Last, an implementation-defined value, see 13608 -- (RM D.3(10)). 13609 13610 if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then 13611 declare 13612 Prio_Clause : constant Node_Id := 13613 Get_Rep_Item 13614 (Ptyp, Name_Priority, Check_Parents => False); 13615 13616 Prio : Node_Id; 13617 13618 begin 13619 -- Pragma Priority 13620 13621 if Nkind (Prio_Clause) = N_Pragma then 13622 Prio := 13623 Expression 13624 (First (Pragma_Argument_Associations (Prio_Clause))); 13625 13626 -- Get_Rep_Item returns either priority pragma. 13627 13628 if Pragma_Name (Prio_Clause) = Name_Priority then 13629 Prio_Type := RTE (RE_Any_Priority); 13630 else 13631 Prio_Type := RTE (RE_Interrupt_Priority); 13632 end if; 13633 13634 -- Attribute definition clause Priority 13635 13636 else 13637 if Chars (Prio_Clause) = Name_Priority then 13638 Prio_Type := RTE (RE_Any_Priority); 13639 else 13640 Prio_Type := RTE (RE_Interrupt_Priority); 13641 end if; 13642 13643 Prio := Expression (Prio_Clause); 13644 end if; 13645 13646 -- Always create a locale variable to capture the priority. 13647 -- The priority is also passed to Install_Restriced_Handlers. 13648 -- Note that it is really necessary to create this variable 13649 -- explicitly. It might be thought that removing side effects 13650 -- would the appropriate approach, but that could generate 13651 -- declarations improperly placed in the enclosing scope. 13652 13653 Prio_Var := Make_Temporary (Loc, 'R', Prio); 13654 Append_To (L, 13655 Make_Object_Declaration (Loc, 13656 Defining_Identifier => Prio_Var, 13657 Object_Definition => New_Occurrence_Of (Prio_Type, Loc), 13658 Expression => Relocate_Node (Prio))); 13659 13660 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 13661 end; 13662 13663 -- When no priority is specified but an xx_Handler pragma is, we 13664 -- default to System.Interrupts.Default_Interrupt_Priority, see 13665 -- D.3(10). 13666 13667 elsif Has_Attach_Handler (Ptyp) 13668 or else Has_Interrupt_Handler (Ptyp) 13669 then 13670 Append_To (Args, 13671 New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc)); 13672 13673 -- Normal case, no priority or xx_Handler specified, default priority 13674 13675 else 13676 Append_To (Args, 13677 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 13678 end if; 13679 13680 -- Test for Compiler_Info parameter. This parameter allows entry body 13681 -- procedures and barrier functions to be called from the runtime. It 13682 -- is a pointer to the record generated by the compiler to represent 13683 -- the protected object. 13684 13685 -- A protected type without entries that covers an interface and 13686 -- overrides the abstract routines with protected procedures is 13687 -- considered equivalent to a protected type with entries in the 13688 -- context of dispatching select statements. 13689 13690 -- Protected types with interrupt handlers (when not using a 13691 -- restricted profile) are also considered equivalent to protected 13692 -- types with entries. 13693 13694 -- The types which are used (Static_Interrupt_Protection and 13695 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries. 13696 13697 declare 13698 Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); 13699 13700 Called_Subp : RE_Id; 13701 13702 begin 13703 case Pkg_Id is 13704 when System_Tasking_Protected_Objects_Entries => 13705 Called_Subp := RE_Initialize_Protection_Entries; 13706 13707 -- Argument Compiler_Info 13708 13709 Append_To (Args, 13710 Make_Attribute_Reference (Loc, 13711 Prefix => Make_Identifier (Loc, Name_uInit), 13712 Attribute_Name => Name_Address)); 13713 13714 when System_Tasking_Protected_Objects_Single_Entry => 13715 Called_Subp := RE_Initialize_Protection_Entry; 13716 13717 -- Argument Compiler_Info 13718 13719 Append_To (Args, 13720 Make_Attribute_Reference (Loc, 13721 Prefix => Make_Identifier (Loc, Name_uInit), 13722 Attribute_Name => Name_Address)); 13723 13724 when System_Tasking_Protected_Objects => 13725 Called_Subp := RE_Initialize_Protection; 13726 13727 when others => 13728 raise Program_Error; 13729 end case; 13730 13731 -- Entry_Bodies parameter. This is a pointer to an array of 13732 -- pointers to the entry body procedures and barrier functions of 13733 -- the object. If the protected type has no entries this object 13734 -- will not exist, in this case, pass a null (it can happen when 13735 -- there are protected interrupt handlers or interfaces). 13736 13737 if Has_Entry then 13738 P_Arr := Entry_Bodies_Array (Ptyp); 13739 13740 -- Argument Entry_Body (for single entry) or Entry_Bodies (for 13741 -- multiple entries). 13742 13743 Append_To (Args, 13744 Make_Attribute_Reference (Loc, 13745 Prefix => New_Occurrence_Of (P_Arr, Loc), 13746 Attribute_Name => Name_Unrestricted_Access)); 13747 13748 if Pkg_Id = System_Tasking_Protected_Objects_Entries then 13749 13750 -- Find index mapping function (clumsy but ok for now) 13751 13752 while Ekind (P_Arr) /= E_Function loop 13753 Next_Entity (P_Arr); 13754 end loop; 13755 13756 Append_To (Args, 13757 Make_Attribute_Reference (Loc, 13758 Prefix => New_Occurrence_Of (P_Arr, Loc), 13759 Attribute_Name => Name_Unrestricted_Access)); 13760 end if; 13761 13762 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then 13763 13764 -- This is the case where we have a protected object with 13765 -- interfaces and no entries, and the single entry restriction 13766 -- is in effect. We pass a null pointer for the entry 13767 -- parameter because there is no actual entry. 13768 13769 Append_To (Args, Make_Null (Loc)); 13770 13771 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then 13772 13773 -- This is the case where we have a protected object with no 13774 -- entries and: 13775 -- - either interrupt handlers with non restricted profile, 13776 -- - or interfaces 13777 -- Note that the types which are used for interrupt handlers 13778 -- (Static/Dynamic_Interrupt_Protection) are derived from 13779 -- Protection_Entries. We pass two null pointers because there 13780 -- is no actual entry, and the initialization procedure needs 13781 -- both Entry_Bodies and Find_Body_Index. 13782 13783 Append_To (Args, Make_Null (Loc)); 13784 Append_To (Args, Make_Null (Loc)); 13785 end if; 13786 13787 Append_To (L, 13788 Make_Procedure_Call_Statement (Loc, 13789 Name => New_Occurrence_Of (RTE (Called_Subp), Loc), 13790 Parameter_Associations => Args)); 13791 end; 13792 end if; 13793 13794 if Has_Attach_Handler (Ptyp) then 13795 13796 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to 13797 -- make the following call: 13798 13799 -- Install_Handlers (_object, 13800 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); 13801 13802 -- or, in the case of Ravenscar: 13803 13804 -- Install_Restricted_Handlers 13805 -- (Prio, (Expr1, Proc1'access), ...., (ExprN, ProcN'access)); 13806 13807 declare 13808 Args : constant List_Id := New_List; 13809 Table : constant List_Id := New_List; 13810 Ritem : Node_Id := First_Rep_Item (Ptyp); 13811 13812 begin 13813 -- Build the Priority parameter (only for ravenscar) 13814 13815 if Restricted then 13816 13817 -- Priority comes from a pragma 13818 13819 if Present (Prio_Var) then 13820 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 13821 13822 -- Priority is the default one 13823 13824 else 13825 Append_To (Args, 13826 New_Occurrence_Of 13827 (RTE (RE_Default_Interrupt_Priority), Loc)); 13828 end if; 13829 end if; 13830 13831 -- Build the Attach_Handler table argument 13832 13833 while Present (Ritem) loop 13834 if Nkind (Ritem) = N_Pragma 13835 and then Pragma_Name (Ritem) = Name_Attach_Handler 13836 then 13837 declare 13838 Handler : constant Node_Id := 13839 First (Pragma_Argument_Associations (Ritem)); 13840 13841 Interrupt : constant Node_Id := Next (Handler); 13842 Expr : constant Node_Id := Expression (Interrupt); 13843 13844 begin 13845 Append_To (Table, 13846 Make_Aggregate (Loc, Expressions => New_List ( 13847 Unchecked_Convert_To 13848 (RTE (RE_System_Interrupt_Id), Expr), 13849 Make_Attribute_Reference (Loc, 13850 Prefix => Make_Selected_Component (Loc, 13851 Make_Identifier (Loc, Name_uInit), 13852 Duplicate_Subexpr_No_Checks 13853 (Expression (Handler))), 13854 Attribute_Name => Name_Access)))); 13855 end; 13856 end if; 13857 13858 Next_Rep_Item (Ritem); 13859 end loop; 13860 13861 -- Append the table argument we just built 13862 13863 Append_To (Args, Make_Aggregate (Loc, Table)); 13864 13865 -- Append the Install_Handlers (or Install_Restricted_Handlers) 13866 -- call to the statements. 13867 13868 if Restricted then 13869 -- Call a simplified version of Install_Handlers to be used 13870 -- when the Ravenscar restrictions are in effect 13871 -- (Install_Restricted_Handlers). 13872 13873 Append_To (L, 13874 Make_Procedure_Call_Statement (Loc, 13875 Name => 13876 New_Occurrence_Of 13877 (RTE (RE_Install_Restricted_Handlers), Loc), 13878 Parameter_Associations => Args)); 13879 13880 else 13881 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 13882 -- First, prepends the _object argument 13883 13884 Prepend_To (Args, 13885 Make_Attribute_Reference (Loc, 13886 Prefix => 13887 Make_Selected_Component (Loc, 13888 Prefix => Make_Identifier (Loc, Name_uInit), 13889 Selector_Name => 13890 Make_Identifier (Loc, Name_uObject)), 13891 Attribute_Name => Name_Unchecked_Access)); 13892 end if; 13893 13894 -- Then, insert call to Install_Handlers 13895 13896 Append_To (L, 13897 Make_Procedure_Call_Statement (Loc, 13898 Name => New_Occurrence_Of (RTE (RE_Install_Handlers), Loc), 13899 Parameter_Associations => Args)); 13900 end if; 13901 end; 13902 end if; 13903 13904 return L; 13905 end Make_Initialize_Protection; 13906 13907 --------------------------- 13908 -- Make_Task_Create_Call -- 13909 --------------------------- 13910 13911 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is 13912 Loc : constant Source_Ptr := Sloc (Task_Rec); 13913 Args : List_Id; 13914 Ecount : Node_Id; 13915 Name : Node_Id; 13916 Tdec : Node_Id; 13917 Tdef : Node_Id; 13918 Tnam : Name_Id; 13919 Ttyp : Node_Id; 13920 13921 begin 13922 Ttyp := Corresponding_Concurrent_Type (Task_Rec); 13923 Tnam := Chars (Ttyp); 13924 13925 -- Get task declaration. In the case of a task type declaration, this is 13926 -- simply the parent of the task type entity. In the single task 13927 -- declaration, this parent will be the implicit type, and we can find 13928 -- the corresponding single task declaration by searching forward in the 13929 -- declaration list in the tree. 13930 13931 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of 13932 -- this type should have been removed during semantic analysis. 13933 13934 Tdec := Parent (Ttyp); 13935 while not Nkind_In (Tdec, N_Task_Type_Declaration, 13936 N_Single_Task_Declaration) 13937 loop 13938 Next (Tdec); 13939 end loop; 13940 13941 -- Now we can find the task definition from this declaration 13942 13943 Tdef := Task_Definition (Tdec); 13944 13945 -- Build the parameter list for the call. Note that _Init is the name 13946 -- of the formal for the object to be initialized, which is the task 13947 -- value record itself. 13948 13949 Args := New_List; 13950 13951 -- Priority parameter. Set to Unspecified_Priority unless there is a 13952 -- Priority rep item, in which case we take the value from the rep item. 13953 13954 if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then 13955 Append_To (Args, 13956 Make_Selected_Component (Loc, 13957 Prefix => Make_Identifier (Loc, Name_uInit), 13958 Selector_Name => Make_Identifier (Loc, Name_uPriority))); 13959 else 13960 Append_To (Args, 13961 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 13962 end if; 13963 13964 -- Optional Stack parameter 13965 13966 if Restricted_Profile then 13967 13968 -- If the stack has been preallocated by the expander then 13969 -- pass its address. Otherwise, pass a null address. 13970 13971 if Preallocated_Stacks_On_Target then 13972 Append_To (Args, 13973 Make_Attribute_Reference (Loc, 13974 Prefix => 13975 Make_Selected_Component (Loc, 13976 Prefix => Make_Identifier (Loc, Name_uInit), 13977 Selector_Name => Make_Identifier (Loc, Name_uStack)), 13978 Attribute_Name => Name_Address)); 13979 13980 else 13981 Append_To (Args, 13982 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 13983 end if; 13984 end if; 13985 13986 -- Size parameter. If no Storage_Size pragma is present, then 13987 -- the size is taken from the taskZ variable for the type, which 13988 -- is either Unspecified_Size, or has been reset by the use of 13989 -- a Storage_Size attribute definition clause. If a pragma is 13990 -- present, then the size is taken from the _Size field of the 13991 -- task value record, which was set from the pragma value. 13992 13993 if Present (Tdef) 13994 and then Has_Storage_Size_Pragma (Tdef) 13995 then 13996 Append_To (Args, 13997 Make_Selected_Component (Loc, 13998 Prefix => Make_Identifier (Loc, Name_uInit), 13999 Selector_Name => Make_Identifier (Loc, Name_uSize))); 14000 14001 else 14002 Append_To (Args, 14003 New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc)); 14004 end if; 14005 14006 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a 14007 -- Task_Info pragma, in which case we take the value from the pragma. 14008 14009 if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then 14010 Append_To (Args, 14011 Make_Selected_Component (Loc, 14012 Prefix => Make_Identifier (Loc, Name_uInit), 14013 Selector_Name => Make_Identifier (Loc, Name_uTask_Info))); 14014 14015 else 14016 Append_To (Args, 14017 New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc)); 14018 end if; 14019 14020 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item, 14021 -- in which case we take the value from the rep item. The parameter is 14022 -- passed as an Integer because in the case of unspecified CPU the 14023 -- value is not in the range of CPU_Range. 14024 14025 if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then 14026 Append_To (Args, 14027 Convert_To (Standard_Integer, 14028 Make_Selected_Component (Loc, 14029 Prefix => Make_Identifier (Loc, Name_uInit), 14030 Selector_Name => Make_Identifier (Loc, Name_uCPU)))); 14031 else 14032 Append_To (Args, 14033 New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc)); 14034 end if; 14035 14036 if not Restricted_Profile then 14037 14038 -- Deadline parameter. If no Relative_Deadline pragma is present, 14039 -- then the deadline is Time_Span_Zero. If a pragma is present, then 14040 -- the deadline is taken from the _Relative_Deadline field of the 14041 -- task value record, which was set from the pragma value. Note that 14042 -- this parameter must not be generated for the restricted profiles 14043 -- since Ravenscar does not allow deadlines. 14044 14045 -- Case where pragma Relative_Deadline applies: use given value 14046 14047 if Present (Tdef) 14048 and then Has_Relative_Deadline_Pragma (Tdef) 14049 then 14050 Append_To (Args, 14051 Make_Selected_Component (Loc, 14052 Prefix => 14053 Make_Identifier (Loc, Name_uInit), 14054 Selector_Name => 14055 Make_Identifier (Loc, Name_uRelative_Deadline))); 14056 14057 -- No pragma Relative_Deadline apply to the task 14058 14059 else 14060 Append_To (Args, 14061 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); 14062 end if; 14063 14064 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is 14065 -- present, then the dispatching domain is null. If a rep item is 14066 -- present, then the dispatching domain is taken from the 14067 -- _Dispatching_Domain field of the task value record, which was set 14068 -- from the rep item value. Note that this parameter must not be 14069 -- generated for the restricted profiles since Ravenscar does not 14070 -- allow dispatching domains. 14071 14072 -- Case where Dispatching_Domain rep item applies: use given value 14073 14074 if Has_Rep_Item 14075 (Ttyp, Name_Dispatching_Domain, Check_Parents => False) 14076 then 14077 Append_To (Args, 14078 Make_Selected_Component (Loc, 14079 Prefix => 14080 Make_Identifier (Loc, Name_uInit), 14081 Selector_Name => 14082 Make_Identifier (Loc, Name_uDispatching_Domain))); 14083 14084 -- No pragma or aspect Dispatching_Domain apply to the task 14085 14086 else 14087 Append_To (Args, Make_Null (Loc)); 14088 end if; 14089 14090 -- Number of entries. This is an expression of the form: 14091 14092 -- n + _Init.a'Length + _Init.a'B'Length + ... 14093 14094 -- where a,b... are the entry family names for the task definition 14095 14096 Ecount := 14097 Build_Entry_Count_Expression 14098 (Ttyp, 14099 Component_Items 14100 (Component_List 14101 (Type_Definition 14102 (Parent (Corresponding_Record_Type (Ttyp))))), 14103 Loc); 14104 Append_To (Args, Ecount); 14105 14106 -- Master parameter. This is a reference to the _Master parameter of 14107 -- the initialization procedure, except in the case of the pragma 14108 -- Restrictions (No_Task_Hierarchy) where the value is fixed to 14109 -- System.Tasking.Library_Task_Level. 14110 14111 if Restriction_Active (No_Task_Hierarchy) = False then 14112 Append_To (Args, Make_Identifier (Loc, Name_uMaster)); 14113 else 14114 Append_To (Args, 14115 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 14116 end if; 14117 end if; 14118 14119 -- State parameter. This is a pointer to the task body procedure. The 14120 -- required value is obtained by taking 'Unrestricted_Access of the task 14121 -- body procedure and converting it (with an unchecked conversion) to 14122 -- the type required by the task kernel. For further details, see the 14123 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather 14124 -- than 'Address in order to avoid creating trampolines. 14125 14126 declare 14127 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp); 14128 Subp_Ptr_Typ : constant Node_Id := 14129 Create_Itype (E_Access_Subprogram_Type, Tdec); 14130 Ref : constant Node_Id := Make_Itype_Reference (Loc); 14131 14132 begin 14133 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc); 14134 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); 14135 14136 -- Be sure to freeze a reference to the access-to-subprogram type, 14137 -- otherwise gigi will complain that it's in the wrong scope, because 14138 -- it's actually inside the init procedure for the record type that 14139 -- corresponds to the task type. 14140 14141 -- This processing is causing a crash in the .NET/JVM back ends that 14142 -- is not yet understood, so skip it in these cases ??? 14143 14144 if VM_Target = No_VM then 14145 Set_Itype (Ref, Subp_Ptr_Typ); 14146 Append_Freeze_Action (Task_Rec, Ref); 14147 14148 Append_To (Args, 14149 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), 14150 Make_Qualified_Expression (Loc, 14151 Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc), 14152 Expression => 14153 Make_Attribute_Reference (Loc, 14154 Prefix => 14155 New_Occurrence_Of (Body_Proc, Loc), 14156 Attribute_Name => Name_Unrestricted_Access)))); 14157 14158 -- For the .NET/JVM cases revert to the original code below ??? 14159 14160 else 14161 Append_To (Args, 14162 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), 14163 Make_Attribute_Reference (Loc, 14164 Prefix => 14165 New_Occurrence_Of (Body_Proc, Loc), 14166 Attribute_Name => Name_Address))); 14167 end if; 14168 end; 14169 14170 -- Discriminants parameter. This is just the address of the task 14171 -- value record itself (which contains the discriminant values 14172 14173 Append_To (Args, 14174 Make_Attribute_Reference (Loc, 14175 Prefix => Make_Identifier (Loc, Name_uInit), 14176 Attribute_Name => Name_Address)); 14177 14178 -- Elaborated parameter. This is an access to the elaboration Boolean 14179 14180 Append_To (Args, 14181 Make_Attribute_Reference (Loc, 14182 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')), 14183 Attribute_Name => Name_Unchecked_Access)); 14184 14185 -- Add Chain parameter (not done for sequential elaboration policy, see 14186 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 14187 14188 if Partition_Elaboration_Policy /= 'S' then 14189 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 14190 end if; 14191 14192 -- Task name parameter. Take this from the _Task_Id parameter to the 14193 -- init call unless there is a Task_Name pragma, in which case we take 14194 -- the value from the pragma. 14195 14196 if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then 14197 -- Copy expression in full, because it may be dynamic and have 14198 -- side effects. 14199 14200 Append_To (Args, 14201 New_Copy_Tree 14202 (Expression 14203 (First 14204 (Pragma_Argument_Associations 14205 (Get_Rep_Pragma 14206 (Ttyp, Name_Task_Name, Check_Parents => False)))))); 14207 14208 else 14209 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); 14210 end if; 14211 14212 -- Created_Task parameter. This is the _Task_Id field of the task 14213 -- record value 14214 14215 Append_To (Args, 14216 Make_Selected_Component (Loc, 14217 Prefix => Make_Identifier (Loc, Name_uInit), 14218 Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); 14219 14220 declare 14221 Create_RE : RE_Id; 14222 14223 begin 14224 if Restricted_Profile then 14225 if Partition_Elaboration_Policy = 'S' then 14226 Create_RE := RE_Create_Restricted_Task_Sequential; 14227 else 14228 Create_RE := RE_Create_Restricted_Task; 14229 end if; 14230 else 14231 Create_RE := RE_Create_Task; 14232 end if; 14233 14234 Name := New_Occurrence_Of (RTE (Create_RE), Loc); 14235 end; 14236 14237 return 14238 Make_Procedure_Call_Statement (Loc, 14239 Name => Name, 14240 Parameter_Associations => Args); 14241 end Make_Task_Create_Call; 14242 14243 ------------------------------ 14244 -- Next_Protected_Operation -- 14245 ------------------------------ 14246 14247 function Next_Protected_Operation (N : Node_Id) return Node_Id is 14248 Next_Op : Node_Id; 14249 14250 begin 14251 Next_Op := Next (N); 14252 while Present (Next_Op) 14253 and then not Nkind_In (Next_Op, N_Subprogram_Body, N_Entry_Body) 14254 loop 14255 Next (Next_Op); 14256 end loop; 14257 14258 return Next_Op; 14259 end Next_Protected_Operation; 14260 14261 --------------------- 14262 -- Null_Statements -- 14263 --------------------- 14264 14265 function Null_Statements (Stats : List_Id) return Boolean is 14266 Stmt : Node_Id; 14267 14268 begin 14269 Stmt := First (Stats); 14270 while Nkind (Stmt) /= N_Empty 14271 and then (Nkind_In (Stmt, N_Null_Statement, N_Label) 14272 or else 14273 (Nkind (Stmt) = N_Pragma 14274 and then 14275 Nam_In (Pragma_Name (Stmt), Name_Unreferenced, 14276 Name_Unmodified, 14277 Name_Warnings))) 14278 loop 14279 Next (Stmt); 14280 end loop; 14281 14282 return Nkind (Stmt) = N_Empty; 14283 end Null_Statements; 14284 14285 -------------------------- 14286 -- Parameter_Block_Pack -- 14287 -------------------------- 14288 14289 function Parameter_Block_Pack 14290 (Loc : Source_Ptr; 14291 Blk_Typ : Entity_Id; 14292 Actuals : List_Id; 14293 Formals : List_Id; 14294 Decls : List_Id; 14295 Stmts : List_Id) return Node_Id 14296 is 14297 Actual : Entity_Id; 14298 Expr : Node_Id := Empty; 14299 Formal : Entity_Id; 14300 Has_Param : Boolean := False; 14301 P : Entity_Id; 14302 Params : List_Id; 14303 Temp_Asn : Node_Id; 14304 Temp_Nam : Node_Id; 14305 14306 begin 14307 Actual := First (Actuals); 14308 Formal := Defining_Identifier (First (Formals)); 14309 Params := New_List; 14310 14311 while Present (Actual) loop 14312 if Is_By_Copy_Type (Etype (Actual)) then 14313 -- Generate: 14314 -- Jnn : aliased <formal-type> 14315 14316 Temp_Nam := Make_Temporary (Loc, 'J'); 14317 14318 Append_To (Decls, 14319 Make_Object_Declaration (Loc, 14320 Aliased_Present => 14321 True, 14322 Defining_Identifier => 14323 Temp_Nam, 14324 Object_Definition => 14325 New_Occurrence_Of (Etype (Formal), Loc))); 14326 14327 if Ekind (Formal) /= E_Out_Parameter then 14328 14329 -- Generate: 14330 -- Jnn := <actual> 14331 14332 Temp_Asn := 14333 New_Occurrence_Of (Temp_Nam, Loc); 14334 14335 Set_Assignment_OK (Temp_Asn); 14336 14337 Append_To (Stmts, 14338 Make_Assignment_Statement (Loc, 14339 Name => 14340 Temp_Asn, 14341 Expression => 14342 New_Copy_Tree (Actual))); 14343 end if; 14344 14345 -- Generate: 14346 -- Jnn'unchecked_access 14347 14348 Append_To (Params, 14349 Make_Attribute_Reference (Loc, 14350 Attribute_Name => 14351 Name_Unchecked_Access, 14352 Prefix => 14353 New_Occurrence_Of (Temp_Nam, Loc))); 14354 14355 Has_Param := True; 14356 14357 -- The controlling parameter is omitted 14358 14359 else 14360 if not Is_Controlling_Actual (Actual) then 14361 Append_To (Params, 14362 Make_Reference (Loc, New_Copy_Tree (Actual))); 14363 14364 Has_Param := True; 14365 end if; 14366 end if; 14367 14368 Next_Actual (Actual); 14369 Next_Formal_With_Extras (Formal); 14370 end loop; 14371 14372 if Has_Param then 14373 Expr := Make_Aggregate (Loc, Params); 14374 end if; 14375 14376 -- Generate: 14377 -- P : Ann := ( 14378 -- J1'unchecked_access; 14379 -- <actual2>'reference; 14380 -- ...); 14381 14382 P := Make_Temporary (Loc, 'P'); 14383 14384 Append_To (Decls, 14385 Make_Object_Declaration (Loc, 14386 Defining_Identifier => 14387 P, 14388 Object_Definition => 14389 New_Occurrence_Of (Blk_Typ, Loc), 14390 Expression => 14391 Expr)); 14392 14393 return P; 14394 end Parameter_Block_Pack; 14395 14396 ---------------------------- 14397 -- Parameter_Block_Unpack -- 14398 ---------------------------- 14399 14400 function Parameter_Block_Unpack 14401 (Loc : Source_Ptr; 14402 P : Entity_Id; 14403 Actuals : List_Id; 14404 Formals : List_Id) return List_Id 14405 is 14406 Actual : Entity_Id; 14407 Asnmt : Node_Id; 14408 Formal : Entity_Id; 14409 Has_Asnmt : Boolean := False; 14410 Result : constant List_Id := New_List; 14411 14412 begin 14413 Actual := First (Actuals); 14414 Formal := Defining_Identifier (First (Formals)); 14415 while Present (Actual) loop 14416 if Is_By_Copy_Type (Etype (Actual)) 14417 and then Ekind (Formal) /= E_In_Parameter 14418 then 14419 -- Generate: 14420 -- <actual> := P.<formal>; 14421 14422 Asnmt := 14423 Make_Assignment_Statement (Loc, 14424 Name => 14425 New_Copy (Actual), 14426 Expression => 14427 Make_Explicit_Dereference (Loc, 14428 Make_Selected_Component (Loc, 14429 Prefix => 14430 New_Occurrence_Of (P, Loc), 14431 Selector_Name => 14432 Make_Identifier (Loc, Chars (Formal))))); 14433 14434 Set_Assignment_OK (Name (Asnmt)); 14435 Append_To (Result, Asnmt); 14436 14437 Has_Asnmt := True; 14438 end if; 14439 14440 Next_Actual (Actual); 14441 Next_Formal_With_Extras (Formal); 14442 end loop; 14443 14444 if Has_Asnmt then 14445 return Result; 14446 else 14447 return New_List (Make_Null_Statement (Loc)); 14448 end if; 14449 end Parameter_Block_Unpack; 14450 14451 ---------------------- 14452 -- Set_Discriminals -- 14453 ---------------------- 14454 14455 procedure Set_Discriminals (Dec : Node_Id) is 14456 D : Entity_Id; 14457 Pdef : Entity_Id; 14458 D_Minal : Entity_Id; 14459 14460 begin 14461 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); 14462 Pdef := Defining_Identifier (Dec); 14463 14464 if Has_Discriminants (Pdef) then 14465 D := First_Discriminant (Pdef); 14466 while Present (D) loop 14467 D_Minal := 14468 Make_Defining_Identifier (Sloc (D), 14469 Chars => New_External_Name (Chars (D), 'D')); 14470 14471 Set_Ekind (D_Minal, E_Constant); 14472 Set_Etype (D_Minal, Etype (D)); 14473 Set_Scope (D_Minal, Pdef); 14474 Set_Discriminal (D, D_Minal); 14475 Set_Discriminal_Link (D_Minal, D); 14476 14477 Next_Discriminant (D); 14478 end loop; 14479 end if; 14480 end Set_Discriminals; 14481 14482 ----------------------- 14483 -- Trivial_Accept_OK -- 14484 ----------------------- 14485 14486 function Trivial_Accept_OK return Boolean is 14487 begin 14488 case Opt.Task_Dispatching_Policy is 14489 14490 -- If we have the default task dispatching policy in effect, we can 14491 -- definitely do the optimization (one way of looking at this is to 14492 -- think of the formal definition of the default policy being allowed 14493 -- to run any task it likes after a rendezvous, so even if notionally 14494 -- a full rescheduling occurs, we can say that our dispatching policy 14495 -- (i.e. the default dispatching policy) reorders the queue to be the 14496 -- same as just before the call. 14497 14498 when ' ' => 14499 return True; 14500 14501 -- FIFO_Within_Priorities certainly does not permit this 14502 -- optimization since the Rendezvous is a scheduling action that may 14503 -- require some other task to be run. 14504 14505 when 'F' => 14506 return False; 14507 14508 -- For now, disallow the optimization for all other policies. This 14509 -- may be over-conservative, but it is certainly not incorrect. 14510 14511 when others => 14512 return False; 14513 14514 end case; 14515 end Trivial_Accept_OK; 14516 14517end Exp_Ch9; 14518