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-2015, 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 original, 295 -- unexpanded body. This is the version of the protected subprogram that is 296 -- called from all protected operations on the same object, including the 297 -- 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 Right_Opnd => 581 Actual_Family_Offset ( 582 Make_Attribute_Reference (Sloc, 583 Attribute_Name => Name_Pos, 584 Prefix => New_Occurrence_Of (Base_Type (S), Sloc), 585 Expressions => New_List (Relocate_Node (Index))), 586 Type_Low_Bound (S))); 587 else 588 Expr := Num; 589 end if; 590 591 -- Now add lengths of preceding entries and entry families 592 593 Prev := First_Entity (Ttyp); 594 while Chars (Prev) /= Chars (Ent) 595 or else (Ekind (Prev) /= Ekind (Ent)) 596 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 597 loop 598 if Ekind (Prev) = E_Entry then 599 Set_Intval (Num, Intval (Num) + 1); 600 601 elsif Ekind (Prev) = E_Entry_Family then 602 S := 603 Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); 604 605 -- The need for the following full view retrieval stems from this 606 -- complex case of nested generics and tasking: 607 608 -- generic 609 -- type Formal_Index is range <>; 610 -- ... 611 -- package Outer is 612 -- type Index is private; 613 -- generic 614 -- ... 615 -- package Inner is 616 -- procedure P; 617 -- end Inner; 618 -- private 619 -- type Index is new Formal_Index range 1 .. 10; 620 -- end Outer; 621 622 -- package body Outer is 623 -- task type T is 624 -- entry Fam (Index); -- (2) 625 -- entry E; 626 -- end T; 627 -- package body Inner is -- (3) 628 -- procedure P is 629 -- begin 630 -- T.E; -- (1) 631 -- end P; 632 -- end Inner; 633 -- ... 634 635 -- We are currently building the index expression for the entry 636 -- call "T.E" (1). Part of the expansion must mention the range 637 -- of the discrete type "Index" (2) of entry family "Fam". 638 639 -- However only the private view of type "Index" is available to 640 -- the inner generic (3) because there was no prior mention of 641 -- the type inside "Inner". This visibility requirement is 642 -- implicit and cannot be detected during the construction of 643 -- the generic trees and needs special handling. 644 645 if In_Instance_Body 646 and then Is_Private_Type (S) 647 and then Present (Full_View (S)) 648 then 649 S := Full_View (S); 650 end if; 651 652 Lo := Type_Low_Bound (S); 653 Hi := Type_High_Bound (S); 654 655 Expr := 656 Make_Op_Add (Sloc, 657 Left_Opnd => Expr, 658 Right_Opnd => 659 Make_Op_Add (Sloc, 660 Left_Opnd => Actual_Family_Offset (Hi, Lo), 661 Right_Opnd => Make_Integer_Literal (Sloc, 1))); 662 663 -- Other components are anonymous types to be ignored 664 665 else 666 null; 667 end if; 668 669 Next_Entity (Prev); 670 end loop; 671 672 return Expr; 673 end Actual_Index_Expression; 674 675 -------------------------- 676 -- Add_Formal_Renamings -- 677 -------------------------- 678 679 procedure Add_Formal_Renamings 680 (Spec : Node_Id; 681 Decls : List_Id; 682 Ent : Entity_Id; 683 Loc : Source_Ptr) 684 is 685 Ptr : constant Entity_Id := 686 Defining_Identifier 687 (Next (First (Parameter_Specifications (Spec)))); 688 -- The name of the formal that holds the address of the parameter block 689 -- for the call. 690 691 Comp : Entity_Id; 692 Decl : Node_Id; 693 Formal : Entity_Id; 694 New_F : Entity_Id; 695 Renamed_Formal : Node_Id; 696 697 begin 698 Formal := First_Formal (Ent); 699 while Present (Formal) loop 700 Comp := Entry_Component (Formal); 701 New_F := 702 Make_Defining_Identifier (Sloc (Formal), 703 Chars => Chars (Formal)); 704 Set_Etype (New_F, Etype (Formal)); 705 Set_Scope (New_F, Ent); 706 707 -- Now we set debug info needed on New_F even though it does not come 708 -- from source, so that the debugger will get the right information 709 -- for these generated names. 710 711 Set_Debug_Info_Needed (New_F); 712 713 if Ekind (Formal) = E_In_Parameter then 714 Set_Ekind (New_F, E_Constant); 715 else 716 Set_Ekind (New_F, E_Variable); 717 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 718 end if; 719 720 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 721 722 Renamed_Formal := 723 Make_Selected_Component (Loc, 724 Prefix => 725 Unchecked_Convert_To (Entry_Parameters_Type (Ent), 726 Make_Identifier (Loc, Chars (Ptr))), 727 Selector_Name => New_Occurrence_Of (Comp, Loc)); 728 729 Decl := 730 Build_Renamed_Formal_Declaration 731 (New_F, Formal, Comp, Renamed_Formal); 732 733 Append (Decl, Decls); 734 Set_Renamed_Object (Formal, New_F); 735 Next_Formal (Formal); 736 end loop; 737 end Add_Formal_Renamings; 738 739 ------------------------ 740 -- Add_Object_Pointer -- 741 ------------------------ 742 743 procedure Add_Object_Pointer 744 (Loc : Source_Ptr; 745 Conc_Typ : Entity_Id; 746 Decls : List_Id) 747 is 748 Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ); 749 Decl : Node_Id; 750 Obj_Ptr : Node_Id; 751 752 begin 753 -- Create the renaming declaration for the Protection object of a 754 -- protected type. _Object is used by Complete_Entry_Body. 755 -- ??? An attempt to make this a renaming was unsuccessful. 756 757 -- Build the entity for the access type 758 759 Obj_Ptr := 760 Make_Defining_Identifier (Loc, 761 New_External_Name (Chars (Rec_Typ), 'P')); 762 763 -- Generate: 764 -- _object : poVP := poVP!O; 765 766 Decl := 767 Make_Object_Declaration (Loc, 768 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uObject), 769 Object_Definition => New_Occurrence_Of (Obj_Ptr, Loc), 770 Expression => 771 Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO))); 772 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 773 Prepend_To (Decls, Decl); 774 775 -- Generate: 776 -- type poVP is access poV; 777 778 Decl := 779 Make_Full_Type_Declaration (Loc, 780 Defining_Identifier => 781 Obj_Ptr, 782 Type_Definition => 783 Make_Access_To_Object_Definition (Loc, 784 Subtype_Indication => 785 New_Occurrence_Of (Rec_Typ, Loc))); 786 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 787 Prepend_To (Decls, Decl); 788 end Add_Object_Pointer; 789 790 ----------------------- 791 -- Build_Accept_Body -- 792 ----------------------- 793 794 function Build_Accept_Body (Astat : Node_Id) return Node_Id is 795 Loc : constant Source_Ptr := Sloc (Astat); 796 Stats : constant Node_Id := Handled_Statement_Sequence (Astat); 797 New_S : Node_Id; 798 Hand : Node_Id; 799 Call : Node_Id; 800 Ohandle : Node_Id; 801 802 begin 803 -- At the end of the statement sequence, Complete_Rendezvous is called. 804 -- A label skipping the Complete_Rendezvous, and all other accept 805 -- processing, has already been added for the expansion of requeue 806 -- statements. The Sloc is copied from the last statement since it 807 -- is really part of this last statement. 808 809 Call := 810 Build_Runtime_Call 811 (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous); 812 Insert_Before (Last (Statements (Stats)), Call); 813 Analyze (Call); 814 815 -- If exception handlers are present, then append Complete_Rendezvous 816 -- calls to the handlers, and construct the required outer block. As 817 -- above, the Sloc is copied from the last statement in the sequence. 818 819 if Present (Exception_Handlers (Stats)) then 820 Hand := First (Exception_Handlers (Stats)); 821 while Present (Hand) loop 822 Call := 823 Build_Runtime_Call 824 (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous); 825 Append (Call, Statements (Hand)); 826 Analyze (Call); 827 Next (Hand); 828 end loop; 829 830 New_S := 831 Make_Handled_Sequence_Of_Statements (Loc, 832 Statements => New_List ( 833 Make_Block_Statement (Loc, 834 Handled_Statement_Sequence => Stats))); 835 836 else 837 New_S := Stats; 838 end if; 839 840 -- At this stage we know that the new statement sequence does 841 -- not have an exception handler part, so we supply one to call 842 -- Exceptional_Complete_Rendezvous. This handler is 843 844 -- when all others => 845 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 846 847 -- We handle Abort_Signal to make sure that we properly catch the abort 848 -- case and wake up the caller. 849 850 Ohandle := Make_Others_Choice (Loc); 851 Set_All_Others (Ohandle); 852 853 Set_Exception_Handlers (New_S, 854 New_List ( 855 Make_Implicit_Exception_Handler (Loc, 856 Exception_Choices => New_List (Ohandle), 857 858 Statements => New_List ( 859 Make_Procedure_Call_Statement (Sloc (Stats), 860 Name => New_Occurrence_Of ( 861 RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)), 862 Parameter_Associations => New_List ( 863 Make_Function_Call (Sloc (Stats), 864 Name => 865 New_Occurrence_Of 866 (RTE (RE_Get_GNAT_Exception), Sloc (Stats))))))))); 867 868 Set_Parent (New_S, Astat); -- temp parent for Analyze call 869 Analyze_Exception_Handlers (Exception_Handlers (New_S)); 870 Expand_Exception_Handlers (New_S); 871 872 -- Exceptional_Complete_Rendezvous must be called with abort still 873 -- deferred, which is the case for a "when all others" handler. 874 875 return New_S; 876 end Build_Accept_Body; 877 878 ----------------------------------- 879 -- Build_Activation_Chain_Entity -- 880 ----------------------------------- 881 882 procedure Build_Activation_Chain_Entity (N : Node_Id) is 883 function Has_Activation_Chain (Stmt : Node_Id) return Boolean; 884 -- Determine whether an extended return statement has activation chain 885 886 -------------------------- 887 -- Has_Activation_Chain -- 888 -------------------------- 889 890 function Has_Activation_Chain (Stmt : Node_Id) return Boolean is 891 Decl : Node_Id; 892 893 begin 894 Decl := First (Return_Object_Declarations (Stmt)); 895 while Present (Decl) loop 896 if Nkind (Decl) = N_Object_Declaration 897 and then Chars (Defining_Identifier (Decl)) = Name_uChain 898 then 899 return True; 900 end if; 901 902 Next (Decl); 903 end loop; 904 905 return False; 906 end Has_Activation_Chain; 907 908 -- Local variables 909 910 Context : Node_Id; 911 Context_Id : Entity_Id; 912 Decls : List_Id; 913 914 -- Start of processing for Build_Activation_Chain_Entity 915 916 begin 917 -- Activation chain is never used for sequential elaboration policy, see 918 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 919 920 if Partition_Elaboration_Policy = 'S' then 921 return; 922 end if; 923 924 Find_Enclosing_Context (N, Context, Context_Id, Decls); 925 926 -- If activation chain entity has not been declared already, create one 927 928 if Nkind (Context) = N_Extended_Return_Statement 929 or else No (Activation_Chain_Entity (Context)) 930 then 931 -- Since extended return statements do not store the entity of the 932 -- chain, examine the return object declarations to avoid creating 933 -- a duplicate. 934 935 if Nkind (Context) = N_Extended_Return_Statement 936 and then Has_Activation_Chain (Context) 937 then 938 return; 939 end if; 940 941 declare 942 Loc : constant Source_Ptr := Sloc (Context); 943 Chain : Entity_Id; 944 Decl : Node_Id; 945 946 begin 947 Chain := Make_Defining_Identifier (Sloc (N), Name_uChain); 948 949 -- Note: An extended return statement is not really a task 950 -- activator, but it does have an activation chain on which to 951 -- store the tasks temporarily. On successful return, the tasks 952 -- on this chain are moved to the chain passed in by the caller. 953 -- We do not build an Activation_Chain_Entity for an extended 954 -- return statement, because we do not want to build a call to 955 -- Activate_Tasks. Task activation is the responsibility of the 956 -- caller. 957 958 if Nkind (Context) /= N_Extended_Return_Statement then 959 Set_Activation_Chain_Entity (Context, Chain); 960 end if; 961 962 Decl := 963 Make_Object_Declaration (Loc, 964 Defining_Identifier => Chain, 965 Aliased_Present => True, 966 Object_Definition => 967 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)); 968 969 Prepend_To (Decls, Decl); 970 971 -- Ensure that _chain appears in the proper scope of the context 972 973 if Context_Id /= Current_Scope then 974 Push_Scope (Context_Id); 975 Analyze (Decl); 976 Pop_Scope; 977 else 978 Analyze (Decl); 979 end if; 980 end; 981 end if; 982 end Build_Activation_Chain_Entity; 983 984 ---------------------------- 985 -- Build_Barrier_Function -- 986 ---------------------------- 987 988 function Build_Barrier_Function 989 (N : Node_Id; 990 Ent : Entity_Id; 991 Pid : Node_Id) return Node_Id 992 is 993 Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); 994 Cond : constant Node_Id := Condition (Ent_Formals); 995 Loc : constant Source_Ptr := Sloc (Cond); 996 Func_Id : constant Entity_Id := Barrier_Function (Ent); 997 Op_Decls : constant List_Id := New_List; 998 Stmt : Node_Id; 999 Func_Body : Node_Id; 1000 1001 begin 1002 -- Add a declaration for the Protection object, renaming declarations 1003 -- for the discriminals and privals and finally a declaration for the 1004 -- entry family index (if applicable). 1005 1006 Install_Private_Data_Declarations (Sloc (N), 1007 Spec_Id => Func_Id, 1008 Conc_Typ => Pid, 1009 Body_Nod => N, 1010 Decls => Op_Decls, 1011 Barrier => True, 1012 Family => Ekind (Ent) = E_Entry_Family); 1013 1014 -- If compiling with -fpreserve-control-flow, make sure we insert an 1015 -- IF statement so that the back-end knows to generate a conditional 1016 -- branch instruction, even if the condition is just the name of a 1017 -- boolean object. Note that Expand_N_If_Statement knows to preserve 1018 -- such redundant IF statements under -fpreserve-control-flow 1019 -- (whether coming from this routine, or directly from source). 1020 1021 if Opt.Suppress_Control_Flow_Optimizations then 1022 Stmt := Make_Implicit_If_Statement (Cond, 1023 Condition => Cond, 1024 Then_Statements => New_List ( 1025 Make_Simple_Return_Statement (Loc, 1026 New_Occurrence_Of (Standard_True, Loc))), 1027 Else_Statements => New_List ( 1028 Make_Simple_Return_Statement (Loc, 1029 New_Occurrence_Of (Standard_False, Loc)))); 1030 1031 else 1032 Stmt := Make_Simple_Return_Statement (Loc, Cond); 1033 end if; 1034 1035 -- Note: the condition in the barrier function needs to be properly 1036 -- processed for the C/Fortran boolean possibility, but this happens 1037 -- automatically since the return statement does this normalization. 1038 1039 Func_Body := 1040 Make_Subprogram_Body (Loc, 1041 Specification => 1042 Build_Barrier_Function_Specification (Loc, 1043 Make_Defining_Identifier (Loc, Chars (Func_Id))), 1044 Declarations => Op_Decls, 1045 Handled_Statement_Sequence => 1046 Make_Handled_Sequence_Of_Statements (Loc, 1047 Statements => New_List (Stmt))); 1048 Set_Is_Entry_Barrier_Function (Func_Body); 1049 1050 return Func_Body; 1051 end Build_Barrier_Function; 1052 1053 ------------------------------------------ 1054 -- Build_Barrier_Function_Specification -- 1055 ------------------------------------------ 1056 1057 function Build_Barrier_Function_Specification 1058 (Loc : Source_Ptr; 1059 Def_Id : Entity_Id) return Node_Id 1060 is 1061 begin 1062 Set_Debug_Info_Needed (Def_Id); 1063 1064 return Make_Function_Specification (Loc, 1065 Defining_Unit_Name => Def_Id, 1066 Parameter_Specifications => New_List ( 1067 Make_Parameter_Specification (Loc, 1068 Defining_Identifier => 1069 Make_Defining_Identifier (Loc, Name_uO), 1070 Parameter_Type => 1071 New_Occurrence_Of (RTE (RE_Address), Loc)), 1072 1073 Make_Parameter_Specification (Loc, 1074 Defining_Identifier => 1075 Make_Defining_Identifier (Loc, Name_uE), 1076 Parameter_Type => 1077 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), 1078 1079 Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)); 1080 end Build_Barrier_Function_Specification; 1081 1082 -------------------------- 1083 -- Build_Call_With_Task -- 1084 -------------------------- 1085 1086 function Build_Call_With_Task 1087 (N : Node_Id; 1088 E : Entity_Id) return Node_Id 1089 is 1090 Loc : constant Source_Ptr := Sloc (N); 1091 begin 1092 return 1093 Make_Function_Call (Loc, 1094 Name => New_Occurrence_Of (E, Loc), 1095 Parameter_Associations => New_List (Concurrent_Ref (N))); 1096 end Build_Call_With_Task; 1097 1098 ----------------------------- 1099 -- Build_Class_Wide_Master -- 1100 ----------------------------- 1101 1102 procedure Build_Class_Wide_Master (Typ : Entity_Id) is 1103 Loc : constant Source_Ptr := Sloc (Typ); 1104 Master_Id : Entity_Id; 1105 Master_Scope : Entity_Id; 1106 Name_Id : Node_Id; 1107 Related_Node : Node_Id; 1108 Ren_Decl : Node_Id; 1109 1110 begin 1111 -- Nothing to do if there is no task hierarchy 1112 1113 if Restriction_Active (No_Task_Hierarchy) then 1114 return; 1115 end if; 1116 1117 -- Find the declaration that created the access type, which is either a 1118 -- type declaration, or an object declaration with an access definition, 1119 -- in which case the type is anonymous. 1120 1121 if Is_Itype (Typ) then 1122 Related_Node := Associated_Node_For_Itype (Typ); 1123 else 1124 Related_Node := Parent (Typ); 1125 end if; 1126 1127 Master_Scope := Find_Master_Scope (Typ); 1128 1129 -- Nothing to do if the master scope already contains a _master entity. 1130 -- The only exception to this is the following scenario: 1131 1132 -- Source_Scope 1133 -- Transient_Scope_1 1134 -- _master 1135 1136 -- Transient_Scope_2 1137 -- use of master 1138 1139 -- In this case the source scope is marked as having the master entity 1140 -- even though the actual declaration appears inside an inner scope. If 1141 -- the second transient scope requires a _master, it cannot use the one 1142 -- already declared because the entity is not visible. 1143 1144 Name_Id := Make_Identifier (Loc, Name_uMaster); 1145 1146 if not Has_Master_Entity (Master_Scope) 1147 or else No (Current_Entity_In_Scope (Name_Id)) 1148 then 1149 declare 1150 Master_Decl : Node_Id; 1151 begin 1152 Set_Has_Master_Entity (Master_Scope); 1153 1154 -- Generate: 1155 -- _master : constant Integer := Current_Master.all; 1156 1157 Master_Decl := 1158 Make_Object_Declaration (Loc, 1159 Defining_Identifier => 1160 Make_Defining_Identifier (Loc, Name_uMaster), 1161 Constant_Present => True, 1162 Object_Definition => 1163 New_Occurrence_Of (Standard_Integer, Loc), 1164 Expression => 1165 Make_Explicit_Dereference (Loc, 1166 New_Occurrence_Of (RTE (RE_Current_Master), Loc))); 1167 1168 Insert_Action (Find_Hook_Context (Related_Node), Master_Decl); 1169 Analyze (Master_Decl); 1170 1171 -- Mark the containing scope as a task master. Masters associated 1172 -- with return statements are already marked at this stage (see 1173 -- Analyze_Subprogram_Body). 1174 1175 if Ekind (Current_Scope) /= E_Return_Statement then 1176 declare 1177 Par : Node_Id := Related_Node; 1178 1179 begin 1180 while Nkind (Par) /= N_Compilation_Unit loop 1181 Par := Parent (Par); 1182 1183 -- If we fall off the top, we are at the outer level, 1184 -- and the environment task is our effective master, 1185 -- so nothing to mark. 1186 1187 if Nkind_In (Par, N_Block_Statement, 1188 N_Subprogram_Body, 1189 N_Task_Body) 1190 then 1191 Set_Is_Task_Master (Par); 1192 exit; 1193 end if; 1194 end loop; 1195 end; 1196 end if; 1197 end; 1198 end if; 1199 1200 Master_Id := 1201 Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'M')); 1202 1203 -- Generate: 1204 -- typeMnn renames _master; 1205 1206 Ren_Decl := 1207 Make_Object_Renaming_Declaration (Loc, 1208 Defining_Identifier => Master_Id, 1209 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), 1210 Name => Name_Id); 1211 1212 Insert_Action (Related_Node, Ren_Decl); 1213 1214 Set_Master_Id (Typ, Master_Id); 1215 end Build_Class_Wide_Master; 1216 1217 -------------------------------- 1218 -- Build_Corresponding_Record -- 1219 -------------------------------- 1220 1221 function Build_Corresponding_Record 1222 (N : Node_Id; 1223 Ctyp : Entity_Id; 1224 Loc : Source_Ptr) return Node_Id 1225 is 1226 Rec_Ent : constant Entity_Id := 1227 Make_Defining_Identifier 1228 (Loc, New_External_Name (Chars (Ctyp), 'V')); 1229 Disc : Entity_Id; 1230 Dlist : List_Id; 1231 New_Disc : Entity_Id; 1232 Cdecls : List_Id; 1233 1234 begin 1235 Set_Corresponding_Record_Type (Ctyp, Rec_Ent); 1236 Set_Ekind (Rec_Ent, E_Record_Type); 1237 Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp)); 1238 Set_Is_Concurrent_Record_Type (Rec_Ent, True); 1239 Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp); 1240 Set_Stored_Constraint (Rec_Ent, No_Elist); 1241 Cdecls := New_List; 1242 1243 -- Propagate type invariants to the corresponding record type 1244 1245 Set_Has_Invariants (Rec_Ent, Has_Invariants (Ctyp)); 1246 Set_Has_Inheritable_Invariants (Rec_Ent, 1247 Has_Inheritable_Invariants (Ctyp)); 1248 1249 -- Use discriminals to create list of discriminants for record, and 1250 -- create new discriminals for use in default expressions, etc. It is 1251 -- worth noting that a task discriminant gives rise to 5 entities; 1252 1253 -- a) The original discriminant. 1254 -- b) The discriminal for use in the task. 1255 -- c) The discriminant of the corresponding record. 1256 -- d) The discriminal for the init proc of the corresponding record. 1257 -- e) The local variable that renames the discriminant in the procedure 1258 -- for the task body. 1259 1260 -- In fact the discriminals b) are used in the renaming declarations 1261 -- for e). See details in einfo (Handling of Discriminants). 1262 1263 if Present (Discriminant_Specifications (N)) then 1264 Dlist := New_List; 1265 Disc := First_Discriminant (Ctyp); 1266 1267 while Present (Disc) loop 1268 New_Disc := CR_Discriminant (Disc); 1269 1270 Append_To (Dlist, 1271 Make_Discriminant_Specification (Loc, 1272 Defining_Identifier => New_Disc, 1273 Discriminant_Type => 1274 New_Occurrence_Of (Etype (Disc), Loc), 1275 Expression => 1276 New_Copy (Discriminant_Default_Value (Disc)))); 1277 1278 Next_Discriminant (Disc); 1279 end loop; 1280 1281 else 1282 Dlist := No_List; 1283 end if; 1284 1285 -- Now we can construct the record type declaration. Note that this 1286 -- record is "limited tagged". It is "limited" to reflect the underlying 1287 -- limitedness of the task or protected object that it represents, and 1288 -- ensuring for example that it is properly passed by reference. It is 1289 -- "tagged" to give support to dispatching calls through interfaces. We 1290 -- propagate here the list of interfaces covered by the concurrent type 1291 -- (Ada 2005: AI-345). 1292 1293 return 1294 Make_Full_Type_Declaration (Loc, 1295 Defining_Identifier => Rec_Ent, 1296 Discriminant_Specifications => Dlist, 1297 Type_Definition => 1298 Make_Record_Definition (Loc, 1299 Component_List => 1300 Make_Component_List (Loc, Component_Items => Cdecls), 1301 Tagged_Present => 1302 Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp), 1303 Interface_List => Interface_List (N), 1304 Limited_Present => True)); 1305 end Build_Corresponding_Record; 1306 1307 --------------------------------- 1308 -- Build_Dispatching_Tag_Check -- 1309 --------------------------------- 1310 1311 function Build_Dispatching_Tag_Check 1312 (K : Entity_Id; 1313 N : Node_Id) return Node_Id 1314 is 1315 Loc : constant Source_Ptr := Sloc (N); 1316 1317 begin 1318 return 1319 Make_Op_Or (Loc, 1320 Make_Op_Eq (Loc, 1321 Left_Opnd => 1322 New_Occurrence_Of (K, Loc), 1323 Right_Opnd => 1324 New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc)), 1325 1326 Make_Op_Eq (Loc, 1327 Left_Opnd => 1328 New_Occurrence_Of (K, Loc), 1329 Right_Opnd => 1330 New_Occurrence_Of (RTE (RE_TK_Tagged), Loc))); 1331 end Build_Dispatching_Tag_Check; 1332 1333 ---------------------------------- 1334 -- Build_Entry_Count_Expression -- 1335 ---------------------------------- 1336 1337 function Build_Entry_Count_Expression 1338 (Concurrent_Type : Node_Id; 1339 Component_List : List_Id; 1340 Loc : Source_Ptr) return Node_Id 1341 is 1342 Eindx : Nat; 1343 Ent : Entity_Id; 1344 Ecount : Node_Id; 1345 Comp : Node_Id; 1346 Lo : Node_Id; 1347 Hi : Node_Id; 1348 Typ : Entity_Id; 1349 Large : Boolean; 1350 1351 begin 1352 -- Count number of non-family entries 1353 1354 Eindx := 0; 1355 Ent := First_Entity (Concurrent_Type); 1356 while Present (Ent) loop 1357 if Ekind (Ent) = E_Entry then 1358 Eindx := Eindx + 1; 1359 end if; 1360 1361 Next_Entity (Ent); 1362 end loop; 1363 1364 Ecount := Make_Integer_Literal (Loc, Eindx); 1365 1366 -- Loop through entry families building the addition nodes 1367 1368 Ent := First_Entity (Concurrent_Type); 1369 Comp := First (Component_List); 1370 while Present (Ent) loop 1371 if Ekind (Ent) = E_Entry_Family then 1372 while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop 1373 Next (Comp); 1374 end loop; 1375 1376 Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); 1377 Hi := Type_High_Bound (Typ); 1378 Lo := Type_Low_Bound (Typ); 1379 Large := Is_Potentially_Large_Family 1380 (Base_Type (Typ), Concurrent_Type, Lo, Hi); 1381 Ecount := 1382 Make_Op_Add (Loc, 1383 Left_Opnd => Ecount, 1384 Right_Opnd => 1385 Family_Size (Loc, Hi, Lo, Concurrent_Type, Large)); 1386 end if; 1387 1388 Next_Entity (Ent); 1389 end loop; 1390 1391 return Ecount; 1392 end Build_Entry_Count_Expression; 1393 1394 ----------------------- 1395 -- Build_Entry_Names -- 1396 ----------------------- 1397 1398 procedure Build_Entry_Names 1399 (Obj_Ref : Node_Id; 1400 Obj_Typ : Entity_Id; 1401 Stmts : List_Id) 1402 is 1403 Loc : constant Source_Ptr := Sloc (Obj_Ref); 1404 Data : Entity_Id := Empty; 1405 Index : Entity_Id := Empty; 1406 Typ : Entity_Id := Obj_Typ; 1407 1408 procedure Build_Entry_Name (Comp_Id : Entity_Id); 1409 -- Given an entry [family], create a static string which denotes the 1410 -- name of Comp_Id and assign it to the underlying data structure which 1411 -- contains the entry names of a concurrent object. 1412 1413 function Object_Reference return Node_Id; 1414 -- Return a reference to field _object or _task_id depending on the 1415 -- concurrent object being processed. 1416 1417 ---------------------- 1418 -- Build_Entry_Name -- 1419 ---------------------- 1420 1421 procedure Build_Entry_Name (Comp_Id : Entity_Id) is 1422 function Build_Range (Def : Node_Id) return Node_Id; 1423 -- Given a discrete subtype definition of an entry family, generate a 1424 -- range node which covers the range of Def's type. 1425 1426 procedure Create_Index_And_Data; 1427 -- Generate the declarations of variables Index and Data. Subsequent 1428 -- calls do nothing. 1429 1430 function Increment_Index return Node_Id; 1431 -- Increment the index used in the assignment of string names to the 1432 -- Data array. 1433 1434 function Name_Declaration (Def_Id : Entity_Id) return Node_Id; 1435 -- Given the name of a temporary variable, create the following 1436 -- declaration for it: 1437 -- 1438 -- Def_Id : aliased constant String := <String_Name_From_Buffer>; 1439 1440 function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id; 1441 -- Given the name of a temporary variable, place it in the array of 1442 -- string names. Generate: 1443 -- 1444 -- Data (Index) := Def_Id'Unchecked_Access; 1445 1446 ----------------- 1447 -- Build_Range -- 1448 ----------------- 1449 1450 function Build_Range (Def : Node_Id) return Node_Id is 1451 High : Node_Id := Type_High_Bound (Etype (Def)); 1452 Low : Node_Id := Type_Low_Bound (Etype (Def)); 1453 1454 begin 1455 -- If a bound references a discriminant, generate an identifier 1456 -- with the same name. Resolution will map it to the formals of 1457 -- the init proc. 1458 1459 if Is_Entity_Name (Low) 1460 and then Ekind (Entity (Low)) = E_Discriminant 1461 then 1462 Low := 1463 Make_Selected_Component (Loc, 1464 Prefix => New_Copy_Tree (Obj_Ref), 1465 Selector_Name => Make_Identifier (Loc, Chars (Low))); 1466 else 1467 Low := New_Copy_Tree (Low); 1468 end if; 1469 1470 if Is_Entity_Name (High) 1471 and then Ekind (Entity (High)) = E_Discriminant 1472 then 1473 High := 1474 Make_Selected_Component (Loc, 1475 Prefix => New_Copy_Tree (Obj_Ref), 1476 Selector_Name => Make_Identifier (Loc, Chars (High))); 1477 else 1478 High := New_Copy_Tree (High); 1479 end if; 1480 1481 return 1482 Make_Range (Loc, 1483 Low_Bound => Low, 1484 High_Bound => High); 1485 end Build_Range; 1486 1487 --------------------------- 1488 -- Create_Index_And_Data -- 1489 --------------------------- 1490 1491 procedure Create_Index_And_Data is 1492 begin 1493 if No (Index) and then No (Data) then 1494 declare 1495 Count : RE_Id; 1496 Data_Typ : RE_Id; 1497 Size : Entity_Id; 1498 1499 begin 1500 if Is_Protected_Type (Typ) then 1501 Count := RO_PE_Number_Of_Entries; 1502 Data_Typ := RE_Protected_Entry_Names_Array; 1503 else 1504 Count := RO_ST_Number_Of_Entries; 1505 Data_Typ := RE_Task_Entry_Names_Array; 1506 end if; 1507 1508 -- Step 1: Generate the declaration of the index variable: 1509 1510 -- Index : Entry_Index := 1; 1511 1512 Index := Make_Temporary (Loc, 'I'); 1513 1514 Append_To (Stmts, 1515 Make_Object_Declaration (Loc, 1516 Defining_Identifier => Index, 1517 Object_Definition => 1518 New_Occurrence_Of (RTE (RE_Entry_Index), Loc), 1519 Expression => Make_Integer_Literal (Loc, 1))); 1520 1521 -- Step 2: Generate the declaration of an array to house all 1522 -- names: 1523 1524 -- Size : constant Entry_Index := <Count> (Obj_Ref); 1525 -- Data : aliased <Data_Typ> := (1 .. Size => null); 1526 1527 Size := Make_Temporary (Loc, 'S'); 1528 1529 Append_To (Stmts, 1530 Make_Object_Declaration (Loc, 1531 Defining_Identifier => Size, 1532 Constant_Present => True, 1533 Object_Definition => 1534 New_Occurrence_Of (RTE (RE_Entry_Index), Loc), 1535 Expression => 1536 Make_Function_Call (Loc, 1537 Name => 1538 New_Occurrence_Of (RTE (Count), Loc), 1539 Parameter_Associations => 1540 New_List (Object_Reference)))); 1541 1542 Data := Make_Temporary (Loc, 'A'); 1543 1544 Append_To (Stmts, 1545 Make_Object_Declaration (Loc, 1546 Defining_Identifier => Data, 1547 Aliased_Present => True, 1548 Object_Definition => 1549 New_Occurrence_Of (RTE (Data_Typ), Loc), 1550 Expression => 1551 Make_Aggregate (Loc, 1552 Component_Associations => New_List ( 1553 Make_Component_Association (Loc, 1554 Choices => New_List ( 1555 Make_Range (Loc, 1556 Low_Bound => 1557 Make_Integer_Literal (Loc, 1), 1558 High_Bound => 1559 New_Occurrence_Of (Size, Loc))), 1560 Expression => Make_Null (Loc)))))); 1561 end; 1562 end if; 1563 end Create_Index_And_Data; 1564 1565 --------------------- 1566 -- Increment_Index -- 1567 --------------------- 1568 1569 function Increment_Index return Node_Id is 1570 begin 1571 return 1572 Make_Assignment_Statement (Loc, 1573 Name => New_Occurrence_Of (Index, Loc), 1574 Expression => 1575 Make_Op_Add (Loc, 1576 Left_Opnd => New_Occurrence_Of (Index, Loc), 1577 Right_Opnd => Make_Integer_Literal (Loc, 1))); 1578 end Increment_Index; 1579 1580 ---------------------- 1581 -- Name_Declaration -- 1582 ---------------------- 1583 1584 function Name_Declaration (Def_Id : Entity_Id) return Node_Id is 1585 begin 1586 return 1587 Make_Object_Declaration (Loc, 1588 Defining_Identifier => Def_Id, 1589 Aliased_Present => True, 1590 Constant_Present => True, 1591 Object_Definition => 1592 New_Occurrence_Of (Standard_String, Loc), 1593 Expression => 1594 Make_String_Literal (Loc, String_From_Name_Buffer)); 1595 end Name_Declaration; 1596 1597 -------------------- 1598 -- Set_Entry_Name -- 1599 -------------------- 1600 1601 function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id is 1602 begin 1603 return 1604 Make_Assignment_Statement (Loc, 1605 Name => 1606 Make_Indexed_Component (Loc, 1607 Prefix => New_Occurrence_Of (Data, Loc), 1608 Expressions => New_List (New_Occurrence_Of (Index, Loc))), 1609 1610 Expression => 1611 Make_Attribute_Reference (Loc, 1612 Prefix => New_Occurrence_Of (Def_Id, Loc), 1613 Attribute_Name => Name_Unchecked_Access)); 1614 end Set_Entry_Name; 1615 1616 -- Local variables 1617 1618 Temp_Id : Entity_Id; 1619 Subt_Def : Node_Id; 1620 1621 -- Start of processing for Build_Entry_Name 1622 1623 begin 1624 if Ekind (Comp_Id) = E_Entry_Family then 1625 Subt_Def := Discrete_Subtype_Definition (Parent (Comp_Id)); 1626 1627 Create_Index_And_Data; 1628 1629 -- Step 1: Create the string name of the entry family. 1630 -- Generate: 1631 -- Temp : aliased constant String := "name ()"; 1632 1633 Temp_Id := Make_Temporary (Loc, 'S'); 1634 Get_Name_String (Chars (Comp_Id)); 1635 Add_Char_To_Name_Buffer (' '); 1636 Add_Char_To_Name_Buffer ('('); 1637 Add_Char_To_Name_Buffer (')'); 1638 1639 Append_To (Stmts, Name_Declaration (Temp_Id)); 1640 1641 -- Generate: 1642 -- for Member in Family_Low .. Family_High loop 1643 -- Set_Entry_Name (...); 1644 -- Index := Index + 1; 1645 -- end loop; 1646 1647 Append_To (Stmts, 1648 Make_Loop_Statement (Loc, 1649 Iteration_Scheme => 1650 Make_Iteration_Scheme (Loc, 1651 Loop_Parameter_Specification => 1652 Make_Loop_Parameter_Specification (Loc, 1653 Defining_Identifier => 1654 Make_Temporary (Loc, 'L'), 1655 Discrete_Subtype_Definition => 1656 Build_Range (Subt_Def))), 1657 1658 Statements => New_List ( 1659 Set_Entry_Name (Temp_Id), 1660 Increment_Index), 1661 End_Label => Empty)); 1662 1663 -- Entry 1664 1665 else 1666 Create_Index_And_Data; 1667 1668 -- Step 1: Create the string name of the entry. Generate: 1669 -- Temp : aliased constant String := "name"; 1670 1671 Temp_Id := Make_Temporary (Loc, 'S'); 1672 Get_Name_String (Chars (Comp_Id)); 1673 1674 Append_To (Stmts, Name_Declaration (Temp_Id)); 1675 1676 -- Step 2: Associate the string name with the underlying data 1677 -- structure. 1678 1679 Append_To (Stmts, Set_Entry_Name (Temp_Id)); 1680 Append_To (Stmts, Increment_Index); 1681 end if; 1682 end Build_Entry_Name; 1683 1684 ---------------------- 1685 -- Object_Reference -- 1686 ---------------------- 1687 1688 function Object_Reference return Node_Id is 1689 Conc_Typ : constant Entity_Id := Corresponding_Record_Type (Typ); 1690 Field : Name_Id; 1691 Ref : Node_Id; 1692 1693 begin 1694 if Is_Protected_Type (Typ) then 1695 Field := Name_uObject; 1696 else 1697 Field := Name_uTask_Id; 1698 end if; 1699 1700 Ref := 1701 Make_Selected_Component (Loc, 1702 Prefix => 1703 Unchecked_Convert_To (Conc_Typ, New_Copy_Tree (Obj_Ref)), 1704 Selector_Name => Make_Identifier (Loc, Field)); 1705 1706 if Is_Protected_Type (Typ) then 1707 Ref := 1708 Make_Attribute_Reference (Loc, 1709 Prefix => Ref, 1710 Attribute_Name => Name_Unchecked_Access); 1711 end if; 1712 1713 return Ref; 1714 end Object_Reference; 1715 1716 -- Local variables 1717 1718 Comp : Node_Id; 1719 Proc : RE_Id; 1720 1721 -- Start of processing for Build_Entry_Names 1722 1723 begin 1724 -- Retrieve the original concurrent type 1725 1726 if Is_Concurrent_Record_Type (Typ) then 1727 Typ := Corresponding_Concurrent_Type (Typ); 1728 end if; 1729 1730 pragma Assert (Is_Concurrent_Type (Typ)); 1731 1732 -- Nothing to do if the type has no entries 1733 1734 if not Has_Entries (Typ) then 1735 return; 1736 end if; 1737 1738 -- Avoid generating entry names for a protected type with only one entry 1739 1740 if Is_Protected_Type (Typ) 1741 and then Find_Protection_Type (Base_Type (Typ)) /= 1742 RTE (RE_Protection_Entries) 1743 then 1744 return; 1745 end if; 1746 1747 -- Step 1: Populate the array with statically generated strings denoting 1748 -- entries and entry family names. 1749 1750 Comp := First_Entity (Typ); 1751 while Present (Comp) loop 1752 if Comes_From_Source (Comp) 1753 and then Ekind_In (Comp, E_Entry, E_Entry_Family) 1754 then 1755 Build_Entry_Name (Comp); 1756 end if; 1757 1758 Next_Entity (Comp); 1759 end loop; 1760 1761 -- Step 2: Associate the array with the related concurrent object: 1762 1763 -- Set_Entry_Names (Obj_Ref, <Data>'Unchecked_Access); 1764 1765 if Present (Data) then 1766 if Is_Protected_Type (Typ) then 1767 Proc := RO_PE_Set_Entry_Names; 1768 else 1769 Proc := RO_ST_Set_Entry_Names; 1770 end if; 1771 1772 Append_To (Stmts, 1773 Make_Procedure_Call_Statement (Loc, 1774 Name => New_Occurrence_Of (RTE (Proc), Loc), 1775 Parameter_Associations => New_List ( 1776 Object_Reference, 1777 Make_Attribute_Reference (Loc, 1778 Prefix => New_Occurrence_Of (Data, Loc), 1779 Attribute_Name => Name_Unchecked_Access)))); 1780 end if; 1781 end Build_Entry_Names; 1782 1783 --------------------------- 1784 -- Build_Parameter_Block -- 1785 --------------------------- 1786 1787 function Build_Parameter_Block 1788 (Loc : Source_Ptr; 1789 Actuals : List_Id; 1790 Formals : List_Id; 1791 Decls : List_Id) return Entity_Id 1792 is 1793 Actual : Entity_Id; 1794 Comp_Nam : Node_Id; 1795 Comps : List_Id; 1796 Formal : Entity_Id; 1797 Has_Comp : Boolean := False; 1798 Rec_Nam : Node_Id; 1799 1800 begin 1801 Actual := First (Actuals); 1802 Comps := New_List; 1803 Formal := Defining_Identifier (First (Formals)); 1804 1805 while Present (Actual) loop 1806 if not Is_Controlling_Actual (Actual) then 1807 1808 -- Generate: 1809 -- type Ann is access all <actual-type> 1810 1811 Comp_Nam := Make_Temporary (Loc, 'A'); 1812 1813 Append_To (Decls, 1814 Make_Full_Type_Declaration (Loc, 1815 Defining_Identifier => Comp_Nam, 1816 Type_Definition => 1817 Make_Access_To_Object_Definition (Loc, 1818 All_Present => True, 1819 Constant_Present => Ekind (Formal) = E_In_Parameter, 1820 Subtype_Indication => 1821 New_Occurrence_Of (Etype (Actual), Loc)))); 1822 1823 -- Generate: 1824 -- Param : Ann; 1825 1826 Append_To (Comps, 1827 Make_Component_Declaration (Loc, 1828 Defining_Identifier => 1829 Make_Defining_Identifier (Loc, Chars (Formal)), 1830 Component_Definition => 1831 Make_Component_Definition (Loc, 1832 Aliased_Present => 1833 False, 1834 Subtype_Indication => 1835 New_Occurrence_Of (Comp_Nam, Loc)))); 1836 1837 Has_Comp := True; 1838 end if; 1839 1840 Next_Actual (Actual); 1841 Next_Formal_With_Extras (Formal); 1842 end loop; 1843 1844 Rec_Nam := Make_Temporary (Loc, 'P'); 1845 1846 if Has_Comp then 1847 1848 -- Generate: 1849 -- type Pnn is record 1850 -- Param1 : Ann1; 1851 -- ... 1852 -- ParamN : AnnN; 1853 1854 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are 1855 -- the original parameter names and Ann1 .. AnnN are the access to 1856 -- actual types. 1857 1858 Append_To (Decls, 1859 Make_Full_Type_Declaration (Loc, 1860 Defining_Identifier => 1861 Rec_Nam, 1862 Type_Definition => 1863 Make_Record_Definition (Loc, 1864 Component_List => 1865 Make_Component_List (Loc, Comps)))); 1866 else 1867 -- Generate: 1868 -- type Pnn is null record; 1869 1870 Append_To (Decls, 1871 Make_Full_Type_Declaration (Loc, 1872 Defining_Identifier => 1873 Rec_Nam, 1874 Type_Definition => 1875 Make_Record_Definition (Loc, 1876 Null_Present => True, 1877 Component_List => Empty))); 1878 end if; 1879 1880 return Rec_Nam; 1881 end Build_Parameter_Block; 1882 1883 -------------------------------------- 1884 -- Build_Renamed_Formal_Declaration -- 1885 -------------------------------------- 1886 1887 function Build_Renamed_Formal_Declaration 1888 (New_F : Entity_Id; 1889 Formal : Entity_Id; 1890 Comp : Entity_Id; 1891 Renamed_Formal : Node_Id) return Node_Id 1892 is 1893 Loc : constant Source_Ptr := Sloc (New_F); 1894 Decl : Node_Id; 1895 1896 begin 1897 -- If the formal is a tagged incomplete type, it is already passed 1898 -- by reference, so it is sufficient to rename the pointer component 1899 -- that corresponds to the actual. Otherwise we need to dereference 1900 -- the pointer component to obtain the actual. 1901 1902 if Is_Incomplete_Type (Etype (Formal)) 1903 and then Is_Tagged_Type (Etype (Formal)) 1904 then 1905 Decl := 1906 Make_Object_Renaming_Declaration (Loc, 1907 Defining_Identifier => New_F, 1908 Subtype_Mark => New_Occurrence_Of (Etype (Comp), Loc), 1909 Name => Renamed_Formal); 1910 1911 else 1912 Decl := 1913 Make_Object_Renaming_Declaration (Loc, 1914 Defining_Identifier => New_F, 1915 Subtype_Mark => New_Occurrence_Of (Etype (Formal), Loc), 1916 Name => 1917 Make_Explicit_Dereference (Loc, Renamed_Formal)); 1918 end if; 1919 1920 return Decl; 1921 end Build_Renamed_Formal_Declaration; 1922 1923 ----------------------- 1924 -- Build_PPC_Wrapper -- 1925 ----------------------- 1926 1927 procedure Build_PPC_Wrapper (E : Entity_Id; Decl : Node_Id) is 1928 Items : constant Node_Id := Contract (E); 1929 Loc : constant Source_Ptr := Sloc (E); 1930 Synch_Type : constant Entity_Id := Scope (E); 1931 Actuals : List_Id; 1932 Decls : List_Id; 1933 Entry_Call : Node_Id; 1934 Entry_Name : Node_Id; 1935 Params : List_Id; 1936 Prag : Node_Id; 1937 Synch_Id : Entity_Id; 1938 Wrapper_Id : Entity_Id; 1939 1940 begin 1941 -- Only build the wrapper if entry has pre/postconditions 1942 -- Should this be done unconditionally instead ??? 1943 1944 if Present (Items) then 1945 Prag := Pre_Post_Conditions (Items); 1946 1947 if No (Prag) then 1948 return; 1949 end if; 1950 1951 -- Transfer ppc pragmas to the declarations of the wrapper 1952 1953 Decls := New_List; 1954 1955 while Present (Prag) loop 1956 if Nam_In (Pragma_Name (Prag), Name_Precondition, 1957 Name_Postcondition) 1958 then 1959 Append (Relocate_Node (Prag), Decls); 1960 Set_Analyzed (Last (Decls), False); 1961 end if; 1962 1963 Prag := Next_Pragma (Prag); 1964 end loop; 1965 else 1966 return; 1967 end if; 1968 1969 Actuals := New_List; 1970 Synch_Id := 1971 Make_Defining_Identifier (Loc, 1972 Chars => New_External_Name (Chars (Scope (E)), 'A')); 1973 1974 -- First formal is synchronized object 1975 1976 Params := New_List ( 1977 Make_Parameter_Specification (Loc, 1978 Defining_Identifier => Synch_Id, 1979 Out_Present => True, 1980 In_Present => True, 1981 Parameter_Type => New_Occurrence_Of (Scope (E), Loc))); 1982 1983 Entry_Name := 1984 Make_Selected_Component (Loc, 1985 Prefix => New_Occurrence_Of (Synch_Id, Loc), 1986 Selector_Name => New_Occurrence_Of (E, Loc)); 1987 1988 -- If entity is entry family, second formal is the corresponding index, 1989 -- and entry name is an indexed component. 1990 1991 if Ekind (E) = E_Entry_Family then 1992 declare 1993 Index : constant Entity_Id := 1994 Make_Defining_Identifier (Loc, Name_I); 1995 begin 1996 Append_To (Params, 1997 Make_Parameter_Specification (Loc, 1998 Defining_Identifier => Index, 1999 Parameter_Type => 2000 New_Occurrence_Of (Entry_Index_Type (E), Loc))); 2001 2002 Entry_Name := 2003 Make_Indexed_Component (Loc, 2004 Prefix => Entry_Name, 2005 Expressions => New_List (New_Occurrence_Of (Index, Loc))); 2006 end; 2007 end if; 2008 2009 Entry_Call := 2010 Make_Procedure_Call_Statement (Loc, 2011 Name => Entry_Name, 2012 Parameter_Associations => Actuals); 2013 2014 -- Now add formals that match those of the entry, and build actuals for 2015 -- the nested entry call. 2016 2017 declare 2018 Form : Entity_Id; 2019 New_Form : Entity_Id; 2020 Parm_Spec : Node_Id; 2021 2022 begin 2023 Form := First_Formal (E); 2024 while Present (Form) loop 2025 New_Form := Make_Defining_Identifier (Loc, Chars (Form)); 2026 Parm_Spec := 2027 Make_Parameter_Specification (Loc, 2028 Defining_Identifier => New_Form, 2029 Out_Present => Out_Present (Parent (Form)), 2030 In_Present => In_Present (Parent (Form)), 2031 Parameter_Type => New_Occurrence_Of (Etype (Form), Loc)); 2032 2033 Append (Parm_Spec, Params); 2034 Append (New_Occurrence_Of (New_Form, Loc), Actuals); 2035 Next_Formal (Form); 2036 end loop; 2037 end; 2038 2039 -- Add renaming declarations for the discriminants of the enclosing 2040 -- type, which may be visible in the preconditions. 2041 2042 if Has_Discriminants (Synch_Type) then 2043 declare 2044 D : Entity_Id; 2045 Decl : Node_Id; 2046 2047 begin 2048 D := First_Discriminant (Synch_Type); 2049 while Present (D) loop 2050 Decl := 2051 Make_Object_Renaming_Declaration (Loc, 2052 Defining_Identifier => 2053 Make_Defining_Identifier (Loc, Chars (D)), 2054 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc), 2055 Name => 2056 Make_Selected_Component (Loc, 2057 Prefix => New_Occurrence_Of (Synch_Id, Loc), 2058 Selector_Name => Make_Identifier (Loc, Chars (D)))); 2059 Prepend (Decl, Decls); 2060 Next_Discriminant (D); 2061 end loop; 2062 end; 2063 end if; 2064 2065 Wrapper_Id := 2066 Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E')); 2067 Set_PPC_Wrapper (E, Wrapper_Id); 2068 2069 -- The wrapper body is analyzed when the enclosing type is frozen 2070 2071 Append_Freeze_Action (Defining_Entity (Decl), 2072 Make_Subprogram_Body (Loc, 2073 Specification => 2074 Make_Procedure_Specification (Loc, 2075 Defining_Unit_Name => Wrapper_Id, 2076 Parameter_Specifications => Params), 2077 Declarations => Decls, 2078 Handled_Statement_Sequence => 2079 Make_Handled_Sequence_Of_Statements (Loc, 2080 Statements => New_List (Entry_Call)))); 2081 end Build_PPC_Wrapper; 2082 2083 -------------------------- 2084 -- Build_Wrapper_Bodies -- 2085 -------------------------- 2086 2087 procedure Build_Wrapper_Bodies 2088 (Loc : Source_Ptr; 2089 Typ : Entity_Id; 2090 N : Node_Id) 2091 is 2092 Rec_Typ : Entity_Id; 2093 2094 function Build_Wrapper_Body 2095 (Loc : Source_Ptr; 2096 Subp_Id : Entity_Id; 2097 Obj_Typ : Entity_Id; 2098 Formals : List_Id) return Node_Id; 2099 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation 2100 -- associated with a protected or task type. Subp_Id is the subprogram 2101 -- name which will be wrapped. Obj_Typ is the type of the new formal 2102 -- parameter which handles dispatching and object notation. Formals are 2103 -- the original formals of Subp_Id which will be explicitly replicated. 2104 2105 ------------------------ 2106 -- Build_Wrapper_Body -- 2107 ------------------------ 2108 2109 function Build_Wrapper_Body 2110 (Loc : Source_Ptr; 2111 Subp_Id : Entity_Id; 2112 Obj_Typ : Entity_Id; 2113 Formals : List_Id) return Node_Id 2114 is 2115 Body_Spec : Node_Id; 2116 2117 begin 2118 Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals); 2119 2120 -- The subprogram is not overriding or is not a primitive declared 2121 -- between two views. 2122 2123 if No (Body_Spec) then 2124 return Empty; 2125 end if; 2126 2127 declare 2128 Actuals : List_Id := No_List; 2129 Conv_Id : Node_Id; 2130 First_Form : Node_Id; 2131 Formal : Node_Id; 2132 Nam : Node_Id; 2133 2134 begin 2135 -- Map formals to actuals. Use the list built for the wrapper 2136 -- spec, skipping the object notation parameter. 2137 2138 First_Form := First (Parameter_Specifications (Body_Spec)); 2139 2140 Formal := First_Form; 2141 Next (Formal); 2142 2143 if Present (Formal) then 2144 Actuals := New_List; 2145 while Present (Formal) loop 2146 Append_To (Actuals, 2147 Make_Identifier (Loc, 2148 Chars => Chars (Defining_Identifier (Formal)))); 2149 Next (Formal); 2150 end loop; 2151 end if; 2152 2153 -- Special processing for primitives declared between a private 2154 -- type and its completion: the wrapper needs a properly typed 2155 -- parameter if the wrapped operation has a controlling first 2156 -- parameter. Note that this might not be the case for a function 2157 -- with a controlling result. 2158 2159 if Is_Private_Primitive_Subprogram (Subp_Id) then 2160 if No (Actuals) then 2161 Actuals := New_List; 2162 end if; 2163 2164 if Is_Controlling_Formal (First_Formal (Subp_Id)) then 2165 Prepend_To (Actuals, 2166 Unchecked_Convert_To 2167 (Corresponding_Concurrent_Type (Obj_Typ), 2168 Make_Identifier (Loc, Name_uO))); 2169 2170 else 2171 Prepend_To (Actuals, 2172 Make_Identifier (Loc, 2173 Chars => Chars (Defining_Identifier (First_Form)))); 2174 end if; 2175 2176 Nam := New_Occurrence_Of (Subp_Id, Loc); 2177 else 2178 -- An access-to-variable object parameter requires an explicit 2179 -- dereference in the unchecked conversion. This case occurs 2180 -- when a protected entry wrapper must override an interface 2181 -- level procedure with interface access as first parameter. 2182 2183 -- O.all.Subp_Id (Formal_1, ..., Formal_N) 2184 2185 if Nkind (Parameter_Type (First_Form)) = 2186 N_Access_Definition 2187 then 2188 Conv_Id := 2189 Make_Explicit_Dereference (Loc, 2190 Prefix => Make_Identifier (Loc, Name_uO)); 2191 else 2192 Conv_Id := Make_Identifier (Loc, Name_uO); 2193 end if; 2194 2195 Nam := 2196 Make_Selected_Component (Loc, 2197 Prefix => 2198 Unchecked_Convert_To 2199 (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id), 2200 Selector_Name => New_Occurrence_Of (Subp_Id, Loc)); 2201 end if; 2202 2203 -- Create the subprogram body. For a function, the call to the 2204 -- actual subprogram has to be converted to the corresponding 2205 -- record if it is a controlling result. 2206 2207 if Ekind (Subp_Id) = E_Function then 2208 declare 2209 Res : Node_Id; 2210 2211 begin 2212 Res := 2213 Make_Function_Call (Loc, 2214 Name => Nam, 2215 Parameter_Associations => Actuals); 2216 2217 if Has_Controlling_Result (Subp_Id) then 2218 Res := 2219 Unchecked_Convert_To 2220 (Corresponding_Record_Type (Etype (Subp_Id)), Res); 2221 end if; 2222 2223 return 2224 Make_Subprogram_Body (Loc, 2225 Specification => Body_Spec, 2226 Declarations => Empty_List, 2227 Handled_Statement_Sequence => 2228 Make_Handled_Sequence_Of_Statements (Loc, 2229 Statements => New_List ( 2230 Make_Simple_Return_Statement (Loc, Res)))); 2231 end; 2232 2233 else 2234 return 2235 Make_Subprogram_Body (Loc, 2236 Specification => Body_Spec, 2237 Declarations => Empty_List, 2238 Handled_Statement_Sequence => 2239 Make_Handled_Sequence_Of_Statements (Loc, 2240 Statements => New_List ( 2241 Make_Procedure_Call_Statement (Loc, 2242 Name => Nam, 2243 Parameter_Associations => Actuals)))); 2244 end if; 2245 end; 2246 end Build_Wrapper_Body; 2247 2248 -- Start of processing for Build_Wrapper_Bodies 2249 2250 begin 2251 if Is_Concurrent_Type (Typ) then 2252 Rec_Typ := Corresponding_Record_Type (Typ); 2253 else 2254 Rec_Typ := Typ; 2255 end if; 2256 2257 -- Generate wrapper bodies for a concurrent type which implements an 2258 -- interface. 2259 2260 if Present (Interfaces (Rec_Typ)) then 2261 declare 2262 Insert_Nod : Node_Id; 2263 Prim : Entity_Id; 2264 Prim_Elmt : Elmt_Id; 2265 Prim_Decl : Node_Id; 2266 Subp : Entity_Id; 2267 Wrap_Body : Node_Id; 2268 Wrap_Id : Entity_Id; 2269 2270 begin 2271 Insert_Nod := N; 2272 2273 -- Examine all primitive operations of the corresponding record 2274 -- type, looking for wrapper specs. Generate bodies in order to 2275 -- complete them. 2276 2277 Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ)); 2278 while Present (Prim_Elmt) loop 2279 Prim := Node (Prim_Elmt); 2280 2281 if (Ekind (Prim) = E_Function 2282 or else Ekind (Prim) = E_Procedure) 2283 and then Is_Primitive_Wrapper (Prim) 2284 then 2285 Subp := Wrapped_Entity (Prim); 2286 Prim_Decl := Parent (Parent (Prim)); 2287 2288 Wrap_Body := 2289 Build_Wrapper_Body (Loc, 2290 Subp_Id => Subp, 2291 Obj_Typ => Rec_Typ, 2292 Formals => Parameter_Specifications (Parent (Subp))); 2293 Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body)); 2294 2295 Set_Corresponding_Spec (Wrap_Body, Prim); 2296 Set_Corresponding_Body (Prim_Decl, Wrap_Id); 2297 2298 Insert_After (Insert_Nod, Wrap_Body); 2299 Insert_Nod := Wrap_Body; 2300 2301 Analyze (Wrap_Body); 2302 end if; 2303 2304 Next_Elmt (Prim_Elmt); 2305 end loop; 2306 end; 2307 end if; 2308 end Build_Wrapper_Bodies; 2309 2310 ------------------------ 2311 -- Build_Wrapper_Spec -- 2312 ------------------------ 2313 2314 function Build_Wrapper_Spec 2315 (Subp_Id : Entity_Id; 2316 Obj_Typ : Entity_Id; 2317 Formals : List_Id) return Node_Id 2318 is 2319 Loc : constant Source_Ptr := Sloc (Subp_Id); 2320 First_Param : Node_Id; 2321 Iface : Entity_Id; 2322 Iface_Elmt : Elmt_Id; 2323 Iface_Op : Entity_Id; 2324 Iface_Op_Elmt : Elmt_Id; 2325 2326 function Overriding_Possible 2327 (Iface_Op : Entity_Id; 2328 Wrapper : Entity_Id) return Boolean; 2329 -- Determine whether a primitive operation can be overridden by Wrapper. 2330 -- Iface_Op is the candidate primitive operation of an interface type, 2331 -- Wrapper is the generated entry wrapper. 2332 2333 function Replicate_Formals 2334 (Loc : Source_Ptr; 2335 Formals : List_Id) return List_Id; 2336 -- An explicit parameter replication is required due to the Is_Entry_ 2337 -- Formal flag being set for all the formals of an entry. The explicit 2338 -- replication removes the flag that would otherwise cause a different 2339 -- path of analysis. 2340 2341 ------------------------- 2342 -- Overriding_Possible -- 2343 ------------------------- 2344 2345 function Overriding_Possible 2346 (Iface_Op : Entity_Id; 2347 Wrapper : Entity_Id) return Boolean 2348 is 2349 Iface_Op_Spec : constant Node_Id := Parent (Iface_Op); 2350 Wrapper_Spec : constant Node_Id := Parent (Wrapper); 2351 2352 function Type_Conformant_Parameters 2353 (Iface_Op_Params : List_Id; 2354 Wrapper_Params : List_Id) return Boolean; 2355 -- Determine whether the parameters of the generated entry wrapper 2356 -- and those of a primitive operation are type conformant. During 2357 -- this check, the first parameter of the primitive operation is 2358 -- skipped if it is a controlling argument: protected functions 2359 -- may have a controlling result. 2360 2361 -------------------------------- 2362 -- Type_Conformant_Parameters -- 2363 -------------------------------- 2364 2365 function Type_Conformant_Parameters 2366 (Iface_Op_Params : List_Id; 2367 Wrapper_Params : List_Id) return Boolean 2368 is 2369 Iface_Op_Param : Node_Id; 2370 Iface_Op_Typ : Entity_Id; 2371 Wrapper_Param : Node_Id; 2372 Wrapper_Typ : Entity_Id; 2373 2374 begin 2375 -- Skip the first (controlling) parameter of primitive operation 2376 2377 Iface_Op_Param := First (Iface_Op_Params); 2378 2379 if Present (First_Formal (Iface_Op)) 2380 and then Is_Controlling_Formal (First_Formal (Iface_Op)) 2381 then 2382 Iface_Op_Param := Next (Iface_Op_Param); 2383 end if; 2384 2385 Wrapper_Param := First (Wrapper_Params); 2386 while Present (Iface_Op_Param) 2387 and then Present (Wrapper_Param) 2388 loop 2389 Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param); 2390 Wrapper_Typ := Find_Parameter_Type (Wrapper_Param); 2391 2392 -- The two parameters must be mode conformant 2393 2394 if not Conforming_Types 2395 (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant) 2396 then 2397 return False; 2398 end if; 2399 2400 Next (Iface_Op_Param); 2401 Next (Wrapper_Param); 2402 end loop; 2403 2404 -- One of the lists is longer than the other 2405 2406 if Present (Iface_Op_Param) or else Present (Wrapper_Param) then 2407 return False; 2408 end if; 2409 2410 return True; 2411 end Type_Conformant_Parameters; 2412 2413 -- Start of processing for Overriding_Possible 2414 2415 begin 2416 if Chars (Iface_Op) /= Chars (Wrapper) then 2417 return False; 2418 end if; 2419 2420 -- If an inherited subprogram is implemented by a protected procedure 2421 -- or an entry, then the first parameter of the inherited subprogram 2422 -- must be of mode OUT or IN OUT, or access-to-variable parameter. 2423 2424 if Ekind (Iface_Op) = E_Procedure 2425 and then Present (Parameter_Specifications (Iface_Op_Spec)) 2426 then 2427 declare 2428 Obj_Param : constant Node_Id := 2429 First (Parameter_Specifications (Iface_Op_Spec)); 2430 begin 2431 if not Out_Present (Obj_Param) 2432 and then Nkind (Parameter_Type (Obj_Param)) /= 2433 N_Access_Definition 2434 then 2435 return False; 2436 end if; 2437 end; 2438 end if; 2439 2440 return 2441 Type_Conformant_Parameters ( 2442 Parameter_Specifications (Iface_Op_Spec), 2443 Parameter_Specifications (Wrapper_Spec)); 2444 end Overriding_Possible; 2445 2446 ----------------------- 2447 -- Replicate_Formals -- 2448 ----------------------- 2449 2450 function Replicate_Formals 2451 (Loc : Source_Ptr; 2452 Formals : List_Id) return List_Id 2453 is 2454 New_Formals : constant List_Id := New_List; 2455 Formal : Node_Id; 2456 Param_Type : Node_Id; 2457 2458 begin 2459 Formal := First (Formals); 2460 2461 -- Skip the object parameter when dealing with primitives declared 2462 -- between two views. 2463 2464 if Is_Private_Primitive_Subprogram (Subp_Id) 2465 and then not Has_Controlling_Result (Subp_Id) 2466 then 2467 Formal := Next (Formal); 2468 end if; 2469 2470 while Present (Formal) loop 2471 2472 -- Create an explicit copy of the entry parameter 2473 2474 -- When creating the wrapper subprogram for a primitive operation 2475 -- of a protected interface we must construct an equivalent 2476 -- signature to that of the overriding operation. For regular 2477 -- parameters we can just use the type of the formal, but for 2478 -- access to subprogram parameters we need to reanalyze the 2479 -- parameter type to create local entities for the signature of 2480 -- the subprogram type. Using the entities of the overriding 2481 -- subprogram will result in out-of-scope errors in the back-end. 2482 2483 if Nkind (Parameter_Type (Formal)) = N_Access_Definition then 2484 Param_Type := Copy_Separate_Tree (Parameter_Type (Formal)); 2485 else 2486 Param_Type := 2487 New_Occurrence_Of (Etype (Parameter_Type (Formal)), Loc); 2488 end if; 2489 2490 Append_To (New_Formals, 2491 Make_Parameter_Specification (Loc, 2492 Defining_Identifier => 2493 Make_Defining_Identifier (Loc, 2494 Chars => Chars 2495 (Defining_Identifier (Formal))), 2496 In_Present => In_Present (Formal), 2497 Out_Present => Out_Present (Formal), 2498 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 2499 Parameter_Type => Param_Type)); 2500 2501 Next (Formal); 2502 end loop; 2503 2504 return New_Formals; 2505 end Replicate_Formals; 2506 2507 -- Start of processing for Build_Wrapper_Spec 2508 2509 begin 2510 -- No point in building wrappers for untagged concurrent types 2511 2512 pragma Assert (Is_Tagged_Type (Obj_Typ)); 2513 2514 -- An entry or a protected procedure can override a routine where the 2515 -- controlling formal is either IN OUT, OUT or is of access-to-variable 2516 -- type. Since the wrapper must have the exact same signature as that of 2517 -- the overridden subprogram, we try to find the overriding candidate 2518 -- and use its controlling formal. 2519 2520 First_Param := Empty; 2521 2522 -- Check every implemented interface 2523 2524 if Present (Interfaces (Obj_Typ)) then 2525 Iface_Elmt := First_Elmt (Interfaces (Obj_Typ)); 2526 Search : while Present (Iface_Elmt) loop 2527 Iface := Node (Iface_Elmt); 2528 2529 -- Check every interface primitive 2530 2531 if Present (Primitive_Operations (Iface)) then 2532 Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); 2533 while Present (Iface_Op_Elmt) loop 2534 Iface_Op := Node (Iface_Op_Elmt); 2535 2536 -- Ignore predefined primitives 2537 2538 if not Is_Predefined_Dispatching_Operation (Iface_Op) then 2539 Iface_Op := Ultimate_Alias (Iface_Op); 2540 2541 -- The current primitive operation can be overridden by 2542 -- the generated entry wrapper. 2543 2544 if Overriding_Possible (Iface_Op, Subp_Id) then 2545 First_Param := 2546 First (Parameter_Specifications (Parent (Iface_Op))); 2547 2548 exit Search; 2549 end if; 2550 end if; 2551 2552 Next_Elmt (Iface_Op_Elmt); 2553 end loop; 2554 end if; 2555 2556 Next_Elmt (Iface_Elmt); 2557 end loop Search; 2558 end if; 2559 2560 -- Ada 2012 (AI05-0090-1): If no interface primitive is covered by 2561 -- this subprogram and this is not a primitive declared between two 2562 -- views then force the generation of a wrapper. As an optimization, 2563 -- previous versions of the frontend avoid generating the wrapper; 2564 -- however, the wrapper facilitates locating and reporting an error 2565 -- when a duplicate declaration is found later. See example in 2566 -- AI05-0090-1. 2567 2568 if No (First_Param) 2569 and then not Is_Private_Primitive_Subprogram (Subp_Id) 2570 then 2571 if Is_Task_Type 2572 (Corresponding_Concurrent_Type (Obj_Typ)) 2573 then 2574 First_Param := 2575 Make_Parameter_Specification (Loc, 2576 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), 2577 In_Present => True, 2578 Out_Present => False, 2579 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); 2580 2581 -- For entries and procedures of protected types the mode of 2582 -- the controlling argument must be in-out. 2583 2584 else 2585 First_Param := 2586 Make_Parameter_Specification (Loc, 2587 Defining_Identifier => 2588 Make_Defining_Identifier (Loc, 2589 Chars => Name_uO), 2590 In_Present => True, 2591 Out_Present => (Ekind (Subp_Id) /= E_Function), 2592 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); 2593 end if; 2594 end if; 2595 2596 declare 2597 Wrapper_Id : constant Entity_Id := 2598 Make_Defining_Identifier (Loc, Chars (Subp_Id)); 2599 New_Formals : List_Id; 2600 Obj_Param : Node_Id; 2601 Obj_Param_Typ : Entity_Id; 2602 2603 begin 2604 -- Minimum decoration is needed to catch the entity in 2605 -- Sem_Ch6.Override_Dispatching_Operation. 2606 2607 if Ekind (Subp_Id) = E_Function then 2608 Set_Ekind (Wrapper_Id, E_Function); 2609 else 2610 Set_Ekind (Wrapper_Id, E_Procedure); 2611 end if; 2612 2613 Set_Is_Primitive_Wrapper (Wrapper_Id); 2614 Set_Wrapped_Entity (Wrapper_Id, Subp_Id); 2615 Set_Is_Private_Primitive (Wrapper_Id, 2616 Is_Private_Primitive_Subprogram (Subp_Id)); 2617 2618 -- Process the formals 2619 2620 New_Formals := Replicate_Formals (Loc, Formals); 2621 2622 -- A function with a controlling result and no first controlling 2623 -- formal needs no additional parameter. 2624 2625 if Has_Controlling_Result (Subp_Id) 2626 and then 2627 (No (First_Formal (Subp_Id)) 2628 or else not Is_Controlling_Formal (First_Formal (Subp_Id))) 2629 then 2630 null; 2631 2632 -- Routine Subp_Id has been found to override an interface primitive. 2633 -- If the interface operation has an access parameter, create a copy 2634 -- of it, with the same null exclusion indicator if present. 2635 2636 elsif Present (First_Param) then 2637 if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then 2638 Obj_Param_Typ := 2639 Make_Access_Definition (Loc, 2640 Subtype_Mark => 2641 New_Occurrence_Of (Obj_Typ, Loc), 2642 Null_Exclusion_Present => 2643 Null_Exclusion_Present (Parameter_Type (First_Param)), 2644 Constant_Present => 2645 Constant_Present (Parameter_Type (First_Param))); 2646 else 2647 Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc); 2648 end if; 2649 2650 Obj_Param := 2651 Make_Parameter_Specification (Loc, 2652 Defining_Identifier => 2653 Make_Defining_Identifier (Loc, 2654 Chars => Name_uO), 2655 In_Present => In_Present (First_Param), 2656 Out_Present => Out_Present (First_Param), 2657 Parameter_Type => Obj_Param_Typ); 2658 2659 Prepend_To (New_Formals, Obj_Param); 2660 2661 -- If we are dealing with a primitive declared between two views, 2662 -- implemented by a synchronized operation, we need to create 2663 -- a default parameter. The mode of the parameter must match that 2664 -- of the primitive operation. 2665 2666 else 2667 pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id)); 2668 Obj_Param := 2669 Make_Parameter_Specification (Loc, 2670 Defining_Identifier => 2671 Make_Defining_Identifier (Loc, Name_uO), 2672 In_Present => In_Present (Parent (First_Entity (Subp_Id))), 2673 Out_Present => Ekind (Subp_Id) /= E_Function, 2674 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); 2675 Prepend_To (New_Formals, Obj_Param); 2676 end if; 2677 2678 -- Build the final spec. If it is a function with a controlling 2679 -- result, it is a primitive operation of the corresponding 2680 -- record type, so mark the spec accordingly. 2681 2682 if Ekind (Subp_Id) = E_Function then 2683 declare 2684 Res_Def : Node_Id; 2685 2686 begin 2687 if Has_Controlling_Result (Subp_Id) then 2688 Res_Def := 2689 New_Occurrence_Of 2690 (Corresponding_Record_Type (Etype (Subp_Id)), Loc); 2691 else 2692 Res_Def := New_Copy (Result_Definition (Parent (Subp_Id))); 2693 end if; 2694 2695 return 2696 Make_Function_Specification (Loc, 2697 Defining_Unit_Name => Wrapper_Id, 2698 Parameter_Specifications => New_Formals, 2699 Result_Definition => Res_Def); 2700 end; 2701 else 2702 return 2703 Make_Procedure_Specification (Loc, 2704 Defining_Unit_Name => Wrapper_Id, 2705 Parameter_Specifications => New_Formals); 2706 end if; 2707 end; 2708 end Build_Wrapper_Spec; 2709 2710 ------------------------- 2711 -- Build_Wrapper_Specs -- 2712 ------------------------- 2713 2714 procedure Build_Wrapper_Specs 2715 (Loc : Source_Ptr; 2716 Typ : Entity_Id; 2717 N : in out Node_Id) 2718 is 2719 Def : Node_Id; 2720 Rec_Typ : Entity_Id; 2721 procedure Scan_Declarations (L : List_Id); 2722 -- Common processing for visible and private declarations 2723 -- of a protected type. 2724 2725 procedure Scan_Declarations (L : List_Id) is 2726 Decl : Node_Id; 2727 Wrap_Decl : Node_Id; 2728 Wrap_Spec : Node_Id; 2729 2730 begin 2731 if No (L) then 2732 return; 2733 end if; 2734 2735 Decl := First (L); 2736 while Present (Decl) loop 2737 Wrap_Spec := Empty; 2738 2739 if Nkind (Decl) = N_Entry_Declaration 2740 and then Ekind (Defining_Identifier (Decl)) = E_Entry 2741 then 2742 Wrap_Spec := 2743 Build_Wrapper_Spec 2744 (Subp_Id => Defining_Identifier (Decl), 2745 Obj_Typ => Rec_Typ, 2746 Formals => Parameter_Specifications (Decl)); 2747 2748 elsif Nkind (Decl) = N_Subprogram_Declaration then 2749 Wrap_Spec := 2750 Build_Wrapper_Spec 2751 (Subp_Id => Defining_Unit_Name (Specification (Decl)), 2752 Obj_Typ => Rec_Typ, 2753 Formals => 2754 Parameter_Specifications (Specification (Decl))); 2755 end if; 2756 2757 if Present (Wrap_Spec) then 2758 Wrap_Decl := 2759 Make_Subprogram_Declaration (Loc, 2760 Specification => Wrap_Spec); 2761 2762 Insert_After (N, Wrap_Decl); 2763 N := Wrap_Decl; 2764 2765 Analyze (Wrap_Decl); 2766 end if; 2767 2768 Next (Decl); 2769 end loop; 2770 end Scan_Declarations; 2771 2772 -- start of processing for Build_Wrapper_Specs 2773 2774 begin 2775 if Is_Protected_Type (Typ) then 2776 Def := Protected_Definition (Parent (Typ)); 2777 else pragma Assert (Is_Task_Type (Typ)); 2778 Def := Task_Definition (Parent (Typ)); 2779 end if; 2780 2781 Rec_Typ := Corresponding_Record_Type (Typ); 2782 2783 -- Generate wrapper specs for a concurrent type which implements an 2784 -- interface. Operations in both the visible and private parts may 2785 -- implement progenitor operations. 2786 2787 if Present (Interfaces (Rec_Typ)) and then Present (Def) then 2788 Scan_Declarations (Visible_Declarations (Def)); 2789 Scan_Declarations (Private_Declarations (Def)); 2790 end if; 2791 end Build_Wrapper_Specs; 2792 2793 --------------------------- 2794 -- Build_Find_Body_Index -- 2795 --------------------------- 2796 2797 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is 2798 Loc : constant Source_Ptr := Sloc (Typ); 2799 Ent : Entity_Id; 2800 E_Typ : Entity_Id; 2801 Has_F : Boolean := False; 2802 Index : Nat; 2803 If_St : Node_Id := Empty; 2804 Lo : Node_Id; 2805 Hi : Node_Id; 2806 Decls : List_Id := New_List; 2807 Ret : Node_Id; 2808 Spec : Node_Id; 2809 Siz : Node_Id := Empty; 2810 2811 procedure Add_If_Clause (Expr : Node_Id); 2812 -- Add test for range of current entry 2813 2814 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 2815 -- If a bound of an entry is given by a discriminant, retrieve the 2816 -- actual value of the discriminant from the enclosing object. 2817 2818 ------------------- 2819 -- Add_If_Clause -- 2820 ------------------- 2821 2822 procedure Add_If_Clause (Expr : Node_Id) is 2823 Cond : Node_Id; 2824 Stats : constant List_Id := 2825 New_List ( 2826 Make_Simple_Return_Statement (Loc, 2827 Expression => Make_Integer_Literal (Loc, Index + 1))); 2828 2829 begin 2830 -- Index for current entry body 2831 2832 Index := Index + 1; 2833 2834 -- Compute total length of entry queues so far 2835 2836 if No (Siz) then 2837 Siz := Expr; 2838 else 2839 Siz := 2840 Make_Op_Add (Loc, 2841 Left_Opnd => Siz, 2842 Right_Opnd => Expr); 2843 end if; 2844 2845 Cond := 2846 Make_Op_Le (Loc, 2847 Left_Opnd => Make_Identifier (Loc, Name_uE), 2848 Right_Opnd => Siz); 2849 2850 -- Map entry queue indexes in the range of the current family 2851 -- into the current index, that designates the entry body. 2852 2853 if No (If_St) then 2854 If_St := 2855 Make_Implicit_If_Statement (Typ, 2856 Condition => Cond, 2857 Then_Statements => Stats, 2858 Elsif_Parts => New_List); 2859 Ret := If_St; 2860 2861 else 2862 Append_To (Elsif_Parts (If_St), 2863 Make_Elsif_Part (Loc, 2864 Condition => Cond, 2865 Then_Statements => Stats)); 2866 end if; 2867 end Add_If_Clause; 2868 2869 ------------------------------ 2870 -- Convert_Discriminant_Ref -- 2871 ------------------------------ 2872 2873 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 2874 B : Node_Id; 2875 2876 begin 2877 if Is_Entity_Name (Bound) 2878 and then Ekind (Entity (Bound)) = E_Discriminant 2879 then 2880 B := 2881 Make_Selected_Component (Loc, 2882 Prefix => 2883 Unchecked_Convert_To (Corresponding_Record_Type (Typ), 2884 Make_Explicit_Dereference (Loc, 2885 Make_Identifier (Loc, Name_uObject))), 2886 Selector_Name => Make_Identifier (Loc, Chars (Bound))); 2887 Set_Etype (B, Etype (Entity (Bound))); 2888 else 2889 B := New_Copy_Tree (Bound); 2890 end if; 2891 2892 return B; 2893 end Convert_Discriminant_Ref; 2894 2895 -- Start of processing for Build_Find_Body_Index 2896 2897 begin 2898 Spec := Build_Find_Body_Index_Spec (Typ); 2899 2900 Ent := First_Entity (Typ); 2901 while Present (Ent) loop 2902 if Ekind (Ent) = E_Entry_Family then 2903 Has_F := True; 2904 exit; 2905 end if; 2906 2907 Next_Entity (Ent); 2908 end loop; 2909 2910 if not Has_F then 2911 2912 -- If the protected type has no entry families, there is a one-one 2913 -- correspondence between entry queue and entry body. 2914 2915 Ret := 2916 Make_Simple_Return_Statement (Loc, 2917 Expression => Make_Identifier (Loc, Name_uE)); 2918 2919 else 2920 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate 2921 -- the following: 2922 2923 -- if E <= l1 then return 1; 2924 -- elsif E <= l1 + l2 then return 2; 2925 -- ... 2926 2927 Index := 0; 2928 Siz := Empty; 2929 Ent := First_Entity (Typ); 2930 2931 Add_Object_Pointer (Loc, Typ, Decls); 2932 2933 while Present (Ent) loop 2934 if Ekind (Ent) = E_Entry then 2935 Add_If_Clause (Make_Integer_Literal (Loc, 1)); 2936 2937 elsif Ekind (Ent) = E_Entry_Family then 2938 E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); 2939 Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); 2940 Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); 2941 Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False)); 2942 end if; 2943 2944 Next_Entity (Ent); 2945 end loop; 2946 2947 if Index = 1 then 2948 Decls := New_List; 2949 Ret := 2950 Make_Simple_Return_Statement (Loc, 2951 Expression => Make_Integer_Literal (Loc, 1)); 2952 2953 elsif Nkind (Ret) = N_If_Statement then 2954 2955 -- Ranges are in increasing order, so last one doesn't need guard 2956 2957 declare 2958 Nod : constant Node_Id := Last (Elsif_Parts (Ret)); 2959 begin 2960 Remove (Nod); 2961 Set_Else_Statements (Ret, Then_Statements (Nod)); 2962 end; 2963 end if; 2964 end if; 2965 2966 return 2967 Make_Subprogram_Body (Loc, 2968 Specification => Spec, 2969 Declarations => Decls, 2970 Handled_Statement_Sequence => 2971 Make_Handled_Sequence_Of_Statements (Loc, 2972 Statements => New_List (Ret))); 2973 end Build_Find_Body_Index; 2974 2975 -------------------------------- 2976 -- Build_Find_Body_Index_Spec -- 2977 -------------------------------- 2978 2979 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is 2980 Loc : constant Source_Ptr := Sloc (Typ); 2981 Id : constant Entity_Id := 2982 Make_Defining_Identifier (Loc, 2983 Chars => New_External_Name (Chars (Typ), 'F')); 2984 Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO); 2985 Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE); 2986 2987 begin 2988 return 2989 Make_Function_Specification (Loc, 2990 Defining_Unit_Name => Id, 2991 Parameter_Specifications => New_List ( 2992 Make_Parameter_Specification (Loc, 2993 Defining_Identifier => Parm1, 2994 Parameter_Type => 2995 New_Occurrence_Of (RTE (RE_Address), Loc)), 2996 2997 Make_Parameter_Specification (Loc, 2998 Defining_Identifier => Parm2, 2999 Parameter_Type => 3000 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), 3001 3002 Result_Definition => New_Occurrence_Of ( 3003 RTE (RE_Protected_Entry_Index), Loc)); 3004 end Build_Find_Body_Index_Spec; 3005 3006 ----------------------------------------------- 3007 -- Build_Lock_Free_Protected_Subprogram_Body -- 3008 ----------------------------------------------- 3009 3010 function Build_Lock_Free_Protected_Subprogram_Body 3011 (N : Node_Id; 3012 Prot_Typ : Node_Id; 3013 Unprot_Spec : Node_Id) return Node_Id 3014 is 3015 Actuals : constant List_Id := New_List; 3016 Loc : constant Source_Ptr := Sloc (N); 3017 Spec : constant Node_Id := Specification (N); 3018 Unprot_Id : constant Entity_Id := Defining_Unit_Name (Unprot_Spec); 3019 Formal : Node_Id; 3020 Prot_Spec : Node_Id; 3021 Stmt : Node_Id; 3022 3023 begin 3024 -- Create the protected version of the body 3025 3026 Prot_Spec := 3027 Build_Protected_Sub_Specification (N, Prot_Typ, Protected_Mode); 3028 3029 -- Build the actual parameters which appear in the call to the 3030 -- unprotected version of the body. 3031 3032 Formal := First (Parameter_Specifications (Prot_Spec)); 3033 while Present (Formal) loop 3034 Append_To (Actuals, 3035 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 3036 3037 Next (Formal); 3038 end loop; 3039 3040 -- Function case, generate: 3041 -- return <Unprot_Func_Call>; 3042 3043 if Nkind (Spec) = N_Function_Specification then 3044 Stmt := 3045 Make_Simple_Return_Statement (Loc, 3046 Expression => 3047 Make_Function_Call (Loc, 3048 Name => 3049 Make_Identifier (Loc, Chars (Unprot_Id)), 3050 Parameter_Associations => Actuals)); 3051 3052 -- Procedure case, call the unprotected version 3053 3054 else 3055 Stmt := 3056 Make_Procedure_Call_Statement (Loc, 3057 Name => 3058 Make_Identifier (Loc, Chars (Unprot_Id)), 3059 Parameter_Associations => Actuals); 3060 end if; 3061 3062 return 3063 Make_Subprogram_Body (Loc, 3064 Declarations => Empty_List, 3065 Specification => Prot_Spec, 3066 Handled_Statement_Sequence => 3067 Make_Handled_Sequence_Of_Statements (Loc, 3068 Statements => New_List (Stmt))); 3069 end Build_Lock_Free_Protected_Subprogram_Body; 3070 3071 ------------------------------------------------- 3072 -- Build_Lock_Free_Unprotected_Subprogram_Body -- 3073 ------------------------------------------------- 3074 3075 -- Procedures which meet the lock-free implementation requirements and 3076 -- reference a unique scalar component Comp are expanded in the following 3077 -- manner: 3078 3079 -- procedure P (...) is 3080 -- Expected_Comp : constant Comp_Type := 3081 -- Comp_Type 3082 -- (System.Atomic_Primitives.Lock_Free_Read_N 3083 -- (_Object.Comp'Address)); 3084 -- begin 3085 -- loop 3086 -- declare 3087 -- <original declarations before the object renaming declaration 3088 -- of Comp> 3089 -- 3090 -- Desired_Comp : Comp_Type := Expected_Comp; 3091 -- Comp : Comp_Type renames Desired_Comp; 3092 -- 3093 -- <original delarations after the object renaming declaration 3094 -- of Comp> 3095 -- 3096 -- begin 3097 -- <original statements> 3098 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N 3099 -- (_Object.Comp'Address, 3100 -- Interfaces.Unsigned_N (Expected_Comp), 3101 -- Interfaces.Unsigned_N (Desired_Comp)); 3102 -- end; 3103 -- end loop; 3104 -- end P; 3105 3106 -- Each return and raise statement of P is transformed into an atomic 3107 -- status check: 3108 3109 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 3110 -- (_Object.Comp'Address, 3111 -- Interfaces.Unsigned_N (Expected_Comp), 3112 -- Interfaces.Unsigned_N (Desired_Comp)); 3113 -- then 3114 -- <original statement> 3115 -- else 3116 -- goto L0; 3117 -- end if; 3118 3119 -- Functions which meet the lock-free implementation requirements and 3120 -- reference a unique scalar component Comp are expanded in the following 3121 -- manner: 3122 3123 -- function F (...) return ... is 3124 -- <original declarations before the object renaming declaration 3125 -- of Comp> 3126 -- 3127 -- Expected_Comp : constant Comp_Type := 3128 -- Comp_Type 3129 -- (System.Atomic_Primitives.Lock_Free_Read_N 3130 -- (_Object.Comp'Address)); 3131 -- Comp : Comp_Type renames Expected_Comp; 3132 -- 3133 -- <original delarations after the object renaming declaration of 3134 -- Comp> 3135 -- 3136 -- begin 3137 -- <original statements> 3138 -- end F; 3139 3140 function Build_Lock_Free_Unprotected_Subprogram_Body 3141 (N : Node_Id; 3142 Prot_Typ : Node_Id) return Node_Id 3143 is 3144 function Referenced_Component (N : Node_Id) return Entity_Id; 3145 -- Subprograms which meet the lock-free implementation criteria are 3146 -- allowed to reference only one unique component. Return the prival 3147 -- of the said component. 3148 3149 -------------------------- 3150 -- Referenced_Component -- 3151 -------------------------- 3152 3153 function Referenced_Component (N : Node_Id) return Entity_Id is 3154 Comp : Entity_Id; 3155 Decl : Node_Id; 3156 Source_Comp : Entity_Id := Empty; 3157 3158 begin 3159 -- Find the unique source component which N references in its 3160 -- statements. 3161 3162 for Index in 1 .. Lock_Free_Subprogram_Table.Last loop 3163 declare 3164 Element : Lock_Free_Subprogram renames 3165 Lock_Free_Subprogram_Table.Table (Index); 3166 begin 3167 if Element.Sub_Body = N then 3168 Source_Comp := Element.Comp_Id; 3169 exit; 3170 end if; 3171 end; 3172 end loop; 3173 3174 if No (Source_Comp) then 3175 return Empty; 3176 end if; 3177 3178 -- Find the prival which corresponds to the source component within 3179 -- the declarations of N. 3180 3181 Decl := First (Declarations (N)); 3182 while Present (Decl) loop 3183 3184 -- Privals appear as object renamings 3185 3186 if Nkind (Decl) = N_Object_Renaming_Declaration then 3187 Comp := Defining_Identifier (Decl); 3188 3189 if Present (Prival_Link (Comp)) 3190 and then Prival_Link (Comp) = Source_Comp 3191 then 3192 return Comp; 3193 end if; 3194 end if; 3195 3196 Next (Decl); 3197 end loop; 3198 3199 return Empty; 3200 end Referenced_Component; 3201 3202 -- Local variables 3203 3204 Comp : constant Entity_Id := Referenced_Component (N); 3205 Loc : constant Source_Ptr := Sloc (N); 3206 Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N); 3207 Decls : List_Id := Declarations (N); 3208 3209 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body 3210 3211 begin 3212 -- Add renamings for the protection object, discriminals, privals and 3213 -- the entry index constant for use by debugger. 3214 3215 Debug_Private_Data_Declarations (Decls); 3216 3217 -- Perform the lock-free expansion when the subprogram references a 3218 -- protected component. 3219 3220 if Present (Comp) then 3221 Protected_Component_Ref : declare 3222 Comp_Decl : constant Node_Id := Parent (Comp); 3223 Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl); 3224 Comp_Type : constant Entity_Id := Etype (Comp); 3225 3226 Is_Procedure : constant Boolean := 3227 Ekind (Corresponding_Spec (N)) = E_Procedure; 3228 -- Indicates if N is a protected procedure body 3229 3230 Block_Decls : List_Id; 3231 Try_Write : Entity_Id; 3232 Desired_Comp : Entity_Id; 3233 Decl : Node_Id; 3234 Label : Node_Id; 3235 Label_Id : Entity_Id := Empty; 3236 Read : Entity_Id; 3237 Expected_Comp : Entity_Id; 3238 Stmt : Node_Id; 3239 Stmts : List_Id := 3240 New_Copy_List (Statements (Hand_Stmt_Seq)); 3241 Typ_Size : Int; 3242 Unsigned : Entity_Id; 3243 3244 function Process_Node (N : Node_Id) return Traverse_Result; 3245 -- Transform a single node if it is a return statement, a raise 3246 -- statement or a reference to Comp. 3247 3248 procedure Process_Stmts (Stmts : List_Id); 3249 -- Given a statement sequence Stmts, wrap any return or raise 3250 -- statements in the following manner: 3251 -- 3252 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 3253 -- (_Object.Comp'Address, 3254 -- Interfaces.Unsigned_N (Expected_Comp), 3255 -- Interfaces.Unsigned_N (Desired_Comp)) 3256 -- then 3257 -- <Stmt>; 3258 -- else 3259 -- goto L0; 3260 -- end if; 3261 3262 ------------------ 3263 -- Process_Node -- 3264 ------------------ 3265 3266 function Process_Node (N : Node_Id) return Traverse_Result is 3267 3268 procedure Wrap_Statement (Stmt : Node_Id); 3269 -- Wrap an arbitrary statement inside an if statement where the 3270 -- condition does an atomic check on the state of the object. 3271 3272 -------------------- 3273 -- Wrap_Statement -- 3274 -------------------- 3275 3276 procedure Wrap_Statement (Stmt : Node_Id) is 3277 begin 3278 -- The first time through, create the declaration of a label 3279 -- which is used to skip the remainder of source statements 3280 -- if the state of the object has changed. 3281 3282 if No (Label_Id) then 3283 Label_Id := 3284 Make_Identifier (Loc, New_External_Name ('L', 0)); 3285 Set_Entity (Label_Id, 3286 Make_Defining_Identifier (Loc, Chars (Label_Id))); 3287 end if; 3288 3289 -- Generate: 3290 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 3291 -- (_Object.Comp'Address, 3292 -- Interfaces.Unsigned_N (Expected_Comp), 3293 -- Interfaces.Unsigned_N (Desired_Comp)) 3294 -- then 3295 -- <Stmt>; 3296 -- else 3297 -- goto L0; 3298 -- end if; 3299 3300 Rewrite (Stmt, 3301 Make_Implicit_If_Statement (N, 3302 Condition => 3303 Make_Function_Call (Loc, 3304 Name => 3305 New_Occurrence_Of (Try_Write, Loc), 3306 Parameter_Associations => New_List ( 3307 Make_Attribute_Reference (Loc, 3308 Prefix => Relocate_Node (Comp_Sel_Nam), 3309 Attribute_Name => Name_Address), 3310 3311 Unchecked_Convert_To (Unsigned, 3312 New_Occurrence_Of (Expected_Comp, Loc)), 3313 3314 Unchecked_Convert_To (Unsigned, 3315 New_Occurrence_Of (Desired_Comp, Loc)))), 3316 3317 Then_Statements => New_List (Relocate_Node (Stmt)), 3318 3319 Else_Statements => New_List ( 3320 Make_Goto_Statement (Loc, 3321 Name => 3322 New_Occurrence_Of (Entity (Label_Id), Loc))))); 3323 end Wrap_Statement; 3324 3325 -- Start of processing for Process_Node 3326 3327 begin 3328 -- Wrap each return and raise statement that appear inside a 3329 -- procedure. Skip the last return statement which is added by 3330 -- default since it is transformed into an exit statement. 3331 3332 if Is_Procedure 3333 and then ((Nkind (N) = N_Simple_Return_Statement 3334 and then N /= Last (Stmts)) 3335 or else Nkind (N) = N_Extended_Return_Statement 3336 or else (Nkind_In (N, N_Raise_Constraint_Error, 3337 N_Raise_Program_Error, 3338 N_Raise_Statement, 3339 N_Raise_Storage_Error) 3340 and then Comes_From_Source (N))) 3341 then 3342 Wrap_Statement (N); 3343 return Skip; 3344 end if; 3345 3346 -- Force reanalysis 3347 3348 Set_Analyzed (N, False); 3349 3350 return OK; 3351 end Process_Node; 3352 3353 procedure Process_Nodes is new Traverse_Proc (Process_Node); 3354 3355 ------------------- 3356 -- Process_Stmts -- 3357 ------------------- 3358 3359 procedure Process_Stmts (Stmts : List_Id) is 3360 Stmt : Node_Id; 3361 begin 3362 Stmt := First (Stmts); 3363 while Present (Stmt) loop 3364 Process_Nodes (Stmt); 3365 Next (Stmt); 3366 end loop; 3367 end Process_Stmts; 3368 3369 -- Start of processing for Protected_Component_Ref 3370 3371 begin 3372 -- Get the type size 3373 3374 if Known_Static_Esize (Comp_Type) then 3375 Typ_Size := UI_To_Int (Esize (Comp_Type)); 3376 3377 -- If the Esize (Object_Size) is unknown at compile time, look at 3378 -- the RM_Size (Value_Size) since it may have been set by an 3379 -- explicit representation clause. 3380 3381 elsif Known_Static_RM_Size (Comp_Type) then 3382 Typ_Size := UI_To_Int (RM_Size (Comp_Type)); 3383 3384 -- Should not happen since this has already been checked in 3385 -- Allows_Lock_Free_Implementation (see Sem_Ch9). 3386 3387 else 3388 raise Program_Error; 3389 end if; 3390 3391 -- Retrieve all relevant atomic routines and types 3392 3393 case Typ_Size is 3394 when 8 => 3395 Try_Write := RTE (RE_Lock_Free_Try_Write_8); 3396 Read := RTE (RE_Lock_Free_Read_8); 3397 Unsigned := RTE (RE_Uint8); 3398 3399 when 16 => 3400 Try_Write := RTE (RE_Lock_Free_Try_Write_16); 3401 Read := RTE (RE_Lock_Free_Read_16); 3402 Unsigned := RTE (RE_Uint16); 3403 3404 when 32 => 3405 Try_Write := RTE (RE_Lock_Free_Try_Write_32); 3406 Read := RTE (RE_Lock_Free_Read_32); 3407 Unsigned := RTE (RE_Uint32); 3408 3409 when 64 => 3410 Try_Write := RTE (RE_Lock_Free_Try_Write_64); 3411 Read := RTE (RE_Lock_Free_Read_64); 3412 Unsigned := RTE (RE_Uint64); 3413 3414 when others => 3415 raise Program_Error; 3416 end case; 3417 3418 -- Generate: 3419 -- Expected_Comp : constant Comp_Type := 3420 -- Comp_Type 3421 -- (System.Atomic_Primitives.Lock_Free_Read_N 3422 -- (_Object.Comp'Address)); 3423 3424 Expected_Comp := 3425 Make_Defining_Identifier (Loc, 3426 New_External_Name (Chars (Comp), Suffix => "_saved")); 3427 3428 Decl := 3429 Make_Object_Declaration (Loc, 3430 Defining_Identifier => Expected_Comp, 3431 Object_Definition => New_Occurrence_Of (Comp_Type, Loc), 3432 Constant_Present => True, 3433 Expression => 3434 Unchecked_Convert_To (Comp_Type, 3435 Make_Function_Call (Loc, 3436 Name => New_Occurrence_Of (Read, Loc), 3437 Parameter_Associations => New_List ( 3438 Make_Attribute_Reference (Loc, 3439 Prefix => Relocate_Node (Comp_Sel_Nam), 3440 Attribute_Name => Name_Address))))); 3441 3442 -- Protected procedures 3443 3444 if Is_Procedure then 3445 -- Move the original declarations inside the generated block 3446 3447 Block_Decls := Decls; 3448 3449 -- Reset the declarations list of the protected procedure to 3450 -- contain only Decl. 3451 3452 Decls := New_List (Decl); 3453 3454 -- Generate: 3455 -- Desired_Comp : Comp_Type := Expected_Comp; 3456 3457 Desired_Comp := 3458 Make_Defining_Identifier (Loc, 3459 New_External_Name (Chars (Comp), Suffix => "_current")); 3460 3461 -- Insert the declarations of Expected_Comp and Desired_Comp in 3462 -- the block declarations right before the renaming of the 3463 -- protected component. 3464 3465 Insert_Before (Comp_Decl, 3466 Make_Object_Declaration (Loc, 3467 Defining_Identifier => Desired_Comp, 3468 Object_Definition => New_Occurrence_Of (Comp_Type, Loc), 3469 Expression => 3470 New_Occurrence_Of (Expected_Comp, Loc))); 3471 3472 -- Protected function 3473 3474 else 3475 Desired_Comp := Expected_Comp; 3476 3477 -- Insert the declaration of Expected_Comp in the function 3478 -- declarations right before the renaming of the protected 3479 -- component. 3480 3481 Insert_Before (Comp_Decl, Decl); 3482 end if; 3483 3484 -- Rewrite the protected component renaming declaration to be a 3485 -- renaming of Desired_Comp. 3486 3487 -- Generate: 3488 -- Comp : Comp_Type renames Desired_Comp; 3489 3490 Rewrite (Comp_Decl, 3491 Make_Object_Renaming_Declaration (Loc, 3492 Defining_Identifier => 3493 Defining_Identifier (Comp_Decl), 3494 Subtype_Mark => 3495 New_Occurrence_Of (Comp_Type, Loc), 3496 Name => 3497 New_Occurrence_Of (Desired_Comp, Loc))); 3498 3499 -- Wrap any return or raise statements in Stmts in same the manner 3500 -- described in Process_Stmts. 3501 3502 Process_Stmts (Stmts); 3503 3504 -- Generate: 3505 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N 3506 -- (_Object.Comp'Address, 3507 -- Interfaces.Unsigned_N (Expected_Comp), 3508 -- Interfaces.Unsigned_N (Desired_Comp)) 3509 3510 if Is_Procedure then 3511 Stmt := 3512 Make_Exit_Statement (Loc, 3513 Condition => 3514 Make_Function_Call (Loc, 3515 Name => 3516 New_Occurrence_Of (Try_Write, Loc), 3517 Parameter_Associations => New_List ( 3518 Make_Attribute_Reference (Loc, 3519 Prefix => Relocate_Node (Comp_Sel_Nam), 3520 Attribute_Name => Name_Address), 3521 3522 Unchecked_Convert_To (Unsigned, 3523 New_Occurrence_Of (Expected_Comp, Loc)), 3524 3525 Unchecked_Convert_To (Unsigned, 3526 New_Occurrence_Of (Desired_Comp, Loc))))); 3527 3528 -- Small optimization: transform the default return statement 3529 -- of a procedure into the atomic exit statement. 3530 3531 if Nkind (Last (Stmts)) = N_Simple_Return_Statement then 3532 Rewrite (Last (Stmts), Stmt); 3533 else 3534 Append_To (Stmts, Stmt); 3535 end if; 3536 end if; 3537 3538 -- Create the declaration of the label used to skip the rest of 3539 -- the source statements when the object state changes. 3540 3541 if Present (Label_Id) then 3542 Label := Make_Label (Loc, Label_Id); 3543 Append_To (Decls, 3544 Make_Implicit_Label_Declaration (Loc, 3545 Defining_Identifier => Entity (Label_Id), 3546 Label_Construct => Label)); 3547 Append_To (Stmts, Label); 3548 end if; 3549 3550 -- Generate: 3551 -- loop 3552 -- declare 3553 -- <Decls> 3554 -- begin 3555 -- <Stmts> 3556 -- end; 3557 -- end loop; 3558 3559 if Is_Procedure then 3560 Stmts := 3561 New_List ( 3562 Make_Loop_Statement (Loc, 3563 Statements => New_List ( 3564 Make_Block_Statement (Loc, 3565 Declarations => Block_Decls, 3566 Handled_Statement_Sequence => 3567 Make_Handled_Sequence_Of_Statements (Loc, 3568 Statements => Stmts))), 3569 End_Label => Empty)); 3570 end if; 3571 3572 Hand_Stmt_Seq := 3573 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts); 3574 end Protected_Component_Ref; 3575 end if; 3576 3577 -- Make an unprotected version of the subprogram for use within the same 3578 -- object, with new name and extra parameter representing the object. 3579 3580 return 3581 Make_Subprogram_Body (Loc, 3582 Specification => 3583 Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode), 3584 Declarations => Decls, 3585 Handled_Statement_Sequence => Hand_Stmt_Seq); 3586 end Build_Lock_Free_Unprotected_Subprogram_Body; 3587 3588 ------------------------- 3589 -- Build_Master_Entity -- 3590 ------------------------- 3591 3592 procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id) is 3593 Loc : constant Source_Ptr := Sloc (Obj_Or_Typ); 3594 Context : Node_Id; 3595 Context_Id : Entity_Id; 3596 Decl : Node_Id; 3597 Decls : List_Id; 3598 Par : Node_Id; 3599 3600 begin 3601 if Is_Itype (Obj_Or_Typ) then 3602 Par := Associated_Node_For_Itype (Obj_Or_Typ); 3603 else 3604 Par := Parent (Obj_Or_Typ); 3605 end if; 3606 3607 -- When creating a master for a record component which is either a task 3608 -- or access-to-task, the enclosing record is the master scope and the 3609 -- proper insertion point is the component list. 3610 3611 if Is_Record_Type (Current_Scope) then 3612 Context := Par; 3613 Context_Id := Current_Scope; 3614 Decls := List_Containing (Context); 3615 3616 -- Default case for object declarations and access types. Note that the 3617 -- context is updated to the nearest enclosing body, block, package or 3618 -- return statement. 3619 3620 else 3621 Find_Enclosing_Context (Par, Context, Context_Id, Decls); 3622 end if; 3623 3624 -- Do not create a master if one already exists or there is no task 3625 -- hierarchy. 3626 3627 if Has_Master_Entity (Context_Id) 3628 or else Restriction_Active (No_Task_Hierarchy) 3629 then 3630 return; 3631 end if; 3632 3633 -- Create a master, generate: 3634 -- _Master : constant Master_Id := Current_Master.all; 3635 3636 Decl := 3637 Make_Object_Declaration (Loc, 3638 Defining_Identifier => 3639 Make_Defining_Identifier (Loc, Name_uMaster), 3640 Constant_Present => True, 3641 Object_Definition => New_Occurrence_Of (RTE (RE_Master_Id), Loc), 3642 Expression => 3643 Make_Explicit_Dereference (Loc, 3644 New_Occurrence_Of (RTE (RE_Current_Master), Loc))); 3645 3646 -- The master is inserted at the start of the declarative list of the 3647 -- context. 3648 3649 Prepend_To (Decls, Decl); 3650 3651 -- In certain cases where transient scopes are involved, the immediate 3652 -- scope is not always the proper master scope. Ensure that the master 3653 -- declaration and entity appear in the same context. 3654 3655 if Context_Id /= Current_Scope then 3656 Push_Scope (Context_Id); 3657 Analyze (Decl); 3658 Pop_Scope; 3659 else 3660 Analyze (Decl); 3661 end if; 3662 3663 -- Mark the enclosing scope and its associated construct as being task 3664 -- masters. 3665 3666 Set_Has_Master_Entity (Context_Id); 3667 3668 while Present (Context) 3669 and then Nkind (Context) /= N_Compilation_Unit 3670 loop 3671 if Nkind_In (Context, N_Block_Statement, 3672 N_Subprogram_Body, 3673 N_Task_Body) 3674 then 3675 Set_Is_Task_Master (Context); 3676 exit; 3677 3678 elsif Nkind (Parent (Context)) = N_Subunit then 3679 Context := Corresponding_Stub (Parent (Context)); 3680 end if; 3681 3682 Context := Parent (Context); 3683 end loop; 3684 end Build_Master_Entity; 3685 3686 --------------------------- 3687 -- Build_Master_Renaming -- 3688 --------------------------- 3689 3690 procedure Build_Master_Renaming 3691 (Ptr_Typ : Entity_Id; 3692 Ins_Nod : Node_Id := Empty) 3693 is 3694 Loc : constant Source_Ptr := Sloc (Ptr_Typ); 3695 Context : Node_Id; 3696 Master_Decl : Node_Id; 3697 Master_Id : Entity_Id; 3698 3699 begin 3700 -- Nothing to do if there is no task hierarchy 3701 3702 if Restriction_Active (No_Task_Hierarchy) then 3703 return; 3704 end if; 3705 3706 -- Determine the proper context to insert the master renaming 3707 3708 if Present (Ins_Nod) then 3709 Context := Ins_Nod; 3710 elsif Is_Itype (Ptr_Typ) then 3711 Context := Associated_Node_For_Itype (Ptr_Typ); 3712 else 3713 Context := Parent (Ptr_Typ); 3714 end if; 3715 3716 -- Generate: 3717 -- <Ptr_Typ>M : Master_Id renames _Master; 3718 3719 Master_Id := 3720 Make_Defining_Identifier (Loc, 3721 New_External_Name (Chars (Ptr_Typ), 'M')); 3722 3723 Master_Decl := 3724 Make_Object_Renaming_Declaration (Loc, 3725 Defining_Identifier => Master_Id, 3726 Subtype_Mark => New_Occurrence_Of (RTE (RE_Master_Id), Loc), 3727 Name => Make_Identifier (Loc, Name_uMaster)); 3728 3729 Insert_Action (Context, Master_Decl); 3730 3731 -- The renamed master now services the access type 3732 3733 Set_Master_Id (Ptr_Typ, Master_Id); 3734 end Build_Master_Renaming; 3735 3736 ----------------------------------------- 3737 -- Build_Private_Protected_Declaration -- 3738 ----------------------------------------- 3739 3740 function Build_Private_Protected_Declaration 3741 (N : Node_Id) return Entity_Id 3742 is 3743 Loc : constant Source_Ptr := Sloc (N); 3744 Body_Id : constant Entity_Id := Defining_Entity (N); 3745 Decl : Node_Id; 3746 Plist : List_Id; 3747 Formal : Entity_Id; 3748 New_Spec : Node_Id; 3749 Spec_Id : Entity_Id; 3750 3751 begin 3752 Formal := First_Formal (Body_Id); 3753 3754 -- The protected operation always has at least one formal, namely the 3755 -- object itself, but it is only placed in the parameter list if 3756 -- expansion is enabled. 3757 3758 if Present (Formal) or else Expander_Active then 3759 Plist := Copy_Parameter_List (Body_Id); 3760 else 3761 Plist := No_List; 3762 end if; 3763 3764 if Nkind (Specification (N)) = N_Procedure_Specification then 3765 New_Spec := 3766 Make_Procedure_Specification (Loc, 3767 Defining_Unit_Name => 3768 Make_Defining_Identifier (Sloc (Body_Id), 3769 Chars => Chars (Body_Id)), 3770 Parameter_Specifications => 3771 Plist); 3772 else 3773 New_Spec := 3774 Make_Function_Specification (Loc, 3775 Defining_Unit_Name => 3776 Make_Defining_Identifier (Sloc (Body_Id), 3777 Chars => Chars (Body_Id)), 3778 Parameter_Specifications => Plist, 3779 Result_Definition => 3780 New_Occurrence_Of (Etype (Body_Id), Loc)); 3781 end if; 3782 3783 Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec); 3784 Insert_Before (N, Decl); 3785 Spec_Id := Defining_Unit_Name (New_Spec); 3786 3787 -- Indicate that the entity comes from source, to ensure that cross- 3788 -- reference information is properly generated. The body itself is 3789 -- rewritten during expansion, and the body entity will not appear in 3790 -- calls to the operation. 3791 3792 Set_Comes_From_Source (Spec_Id, True); 3793 Analyze (Decl); 3794 Set_Has_Completion (Spec_Id); 3795 Set_Convention (Spec_Id, Convention_Protected); 3796 return Spec_Id; 3797 end Build_Private_Protected_Declaration; 3798 3799 --------------------------- 3800 -- Build_Protected_Entry -- 3801 --------------------------- 3802 3803 function Build_Protected_Entry 3804 (N : Node_Id; 3805 Ent : Entity_Id; 3806 Pid : Node_Id) return Node_Id 3807 is 3808 Loc : constant Source_Ptr := Sloc (N); 3809 3810 Decls : constant List_Id := Declarations (N); 3811 End_Lab : constant Node_Id := 3812 End_Label (Handled_Statement_Sequence (N)); 3813 End_Loc : constant Source_Ptr := 3814 Sloc (Last (Statements (Handled_Statement_Sequence (N)))); 3815 -- Used for the generated call to Complete_Entry_Body 3816 3817 Han_Loc : Source_Ptr; 3818 -- Used for the exception handler, inserted at end of the body 3819 3820 Op_Decls : constant List_Id := New_List; 3821 Complete : Node_Id; 3822 Edef : Entity_Id; 3823 Espec : Node_Id; 3824 Ohandle : Node_Id; 3825 Op_Stats : List_Id; 3826 3827 begin 3828 -- Set the source location on the exception handler only when debugging 3829 -- the expanded code (see Make_Implicit_Exception_Handler). 3830 3831 if Debug_Generated_Code then 3832 Han_Loc := End_Loc; 3833 3834 -- Otherwise the inserted code should not be visible to the debugger 3835 3836 else 3837 Han_Loc := No_Location; 3838 end if; 3839 3840 Edef := 3841 Make_Defining_Identifier (Loc, 3842 Chars => Chars (Protected_Body_Subprogram (Ent))); 3843 Espec := 3844 Build_Protected_Entry_Specification (Loc, Edef, Empty); 3845 3846 -- Add the following declarations: 3847 3848 -- type poVP is access poV; 3849 -- _object : poVP := poVP (_O); 3850 3851 -- where _O is the formal parameter associated with the concurrent 3852 -- object. These declarations are needed for Complete_Entry_Body. 3853 3854 Add_Object_Pointer (Loc, Pid, Op_Decls); 3855 3856 -- Add renamings for all formals, the Protection object, discriminals, 3857 -- privals and the entry index constant for use by debugger. 3858 3859 Add_Formal_Renamings (Espec, Op_Decls, Ent, Loc); 3860 Debug_Private_Data_Declarations (Decls); 3861 3862 -- Put the declarations and the statements from the entry 3863 3864 Op_Stats := 3865 New_List ( 3866 Make_Block_Statement (Loc, 3867 Declarations => Decls, 3868 Handled_Statement_Sequence => 3869 Handled_Statement_Sequence (N))); 3870 3871 case Corresponding_Runtime_Package (Pid) is 3872 when System_Tasking_Protected_Objects_Entries => 3873 Append_To (Op_Stats, 3874 Make_Procedure_Call_Statement (End_Loc, 3875 Name => 3876 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc), 3877 Parameter_Associations => New_List ( 3878 Make_Attribute_Reference (End_Loc, 3879 Prefix => 3880 Make_Selected_Component (End_Loc, 3881 Prefix => 3882 Make_Identifier (End_Loc, Name_uObject), 3883 Selector_Name => 3884 Make_Identifier (End_Loc, Name_uObject)), 3885 Attribute_Name => Name_Unchecked_Access)))); 3886 3887 when System_Tasking_Protected_Objects_Single_Entry => 3888 3889 -- Historically, a call to Complete_Single_Entry_Body was 3890 -- inserted, but it was a null procedure. 3891 3892 null; 3893 3894 when others => 3895 raise Program_Error; 3896 end case; 3897 3898 -- When exceptions can not be propagated, we never need to call 3899 -- Exception_Complete_Entry_Body 3900 3901 if No_Exception_Handlers_Set then 3902 return 3903 Make_Subprogram_Body (Loc, 3904 Specification => Espec, 3905 Declarations => Op_Decls, 3906 Handled_Statement_Sequence => 3907 Make_Handled_Sequence_Of_Statements (Loc, 3908 Statements => Op_Stats, 3909 End_Label => End_Lab)); 3910 3911 else 3912 Ohandle := Make_Others_Choice (Loc); 3913 Set_All_Others (Ohandle); 3914 3915 case Corresponding_Runtime_Package (Pid) is 3916 when System_Tasking_Protected_Objects_Entries => 3917 Complete := 3918 New_Occurrence_Of 3919 (RTE (RE_Exceptional_Complete_Entry_Body), Loc); 3920 3921 when System_Tasking_Protected_Objects_Single_Entry => 3922 Complete := 3923 New_Occurrence_Of 3924 (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); 3925 3926 when others => 3927 raise Program_Error; 3928 end case; 3929 3930 -- Establish link between subprogram body entity and source entry 3931 3932 Set_Corresponding_Protected_Entry (Edef, Ent); 3933 3934 -- Create body of entry procedure. The renaming declarations are 3935 -- placed ahead of the block that contains the actual entry body. 3936 3937 return 3938 Make_Subprogram_Body (Loc, 3939 Specification => Espec, 3940 Declarations => Op_Decls, 3941 Handled_Statement_Sequence => 3942 Make_Handled_Sequence_Of_Statements (Loc, 3943 Statements => Op_Stats, 3944 End_Label => End_Lab, 3945 Exception_Handlers => New_List ( 3946 Make_Implicit_Exception_Handler (Han_Loc, 3947 Exception_Choices => New_List (Ohandle), 3948 3949 Statements => New_List ( 3950 Make_Procedure_Call_Statement (Han_Loc, 3951 Name => Complete, 3952 Parameter_Associations => New_List ( 3953 Make_Attribute_Reference (Han_Loc, 3954 Prefix => 3955 Make_Selected_Component (Han_Loc, 3956 Prefix => 3957 Make_Identifier (Han_Loc, Name_uObject), 3958 Selector_Name => 3959 Make_Identifier (Han_Loc, Name_uObject)), 3960 Attribute_Name => Name_Unchecked_Access), 3961 3962 Make_Function_Call (Han_Loc, 3963 Name => New_Occurrence_Of ( 3964 RTE (RE_Get_GNAT_Exception), Loc))))))))); 3965 end if; 3966 end Build_Protected_Entry; 3967 3968 ----------------------------------------- 3969 -- Build_Protected_Entry_Specification -- 3970 ----------------------------------------- 3971 3972 function Build_Protected_Entry_Specification 3973 (Loc : Source_Ptr; 3974 Def_Id : Entity_Id; 3975 Ent_Id : Entity_Id) return Node_Id 3976 is 3977 P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP); 3978 3979 begin 3980 Set_Debug_Info_Needed (Def_Id); 3981 3982 if Present (Ent_Id) then 3983 Append_Elmt (P, Accept_Address (Ent_Id)); 3984 end if; 3985 3986 return 3987 Make_Procedure_Specification (Loc, 3988 Defining_Unit_Name => Def_Id, 3989 Parameter_Specifications => New_List ( 3990 Make_Parameter_Specification (Loc, 3991 Defining_Identifier => 3992 Make_Defining_Identifier (Loc, Name_uO), 3993 Parameter_Type => 3994 New_Occurrence_Of (RTE (RE_Address), Loc)), 3995 3996 Make_Parameter_Specification (Loc, 3997 Defining_Identifier => P, 3998 Parameter_Type => 3999 New_Occurrence_Of (RTE (RE_Address), Loc)), 4000 4001 Make_Parameter_Specification (Loc, 4002 Defining_Identifier => 4003 Make_Defining_Identifier (Loc, Name_uE), 4004 Parameter_Type => 4005 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)))); 4006 end Build_Protected_Entry_Specification; 4007 4008 -------------------------- 4009 -- Build_Protected_Spec -- 4010 -------------------------- 4011 4012 function Build_Protected_Spec 4013 (N : Node_Id; 4014 Obj_Type : Entity_Id; 4015 Ident : Entity_Id; 4016 Unprotected : Boolean := False) return List_Id 4017 is 4018 Loc : constant Source_Ptr := Sloc (N); 4019 Decl : Node_Id; 4020 Formal : Entity_Id; 4021 New_Plist : List_Id; 4022 New_Param : Node_Id; 4023 4024 begin 4025 New_Plist := New_List; 4026 4027 Formal := First_Formal (Ident); 4028 while Present (Formal) loop 4029 New_Param := 4030 Make_Parameter_Specification (Loc, 4031 Defining_Identifier => 4032 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 4033 Aliased_Present => Aliased_Present (Parent (Formal)), 4034 In_Present => In_Present (Parent (Formal)), 4035 Out_Present => Out_Present (Parent (Formal)), 4036 Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc)); 4037 4038 if Unprotected then 4039 Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); 4040 end if; 4041 4042 Append (New_Param, New_Plist); 4043 Next_Formal (Formal); 4044 end loop; 4045 4046 -- If the subprogram is a procedure and the context is not an access 4047 -- to protected subprogram, the parameter is in-out. Otherwise it is 4048 -- an in parameter. 4049 4050 Decl := 4051 Make_Parameter_Specification (Loc, 4052 Defining_Identifier => 4053 Make_Defining_Identifier (Loc, Name_uObject), 4054 In_Present => True, 4055 Out_Present => 4056 (Etype (Ident) = Standard_Void_Type 4057 and then not Is_RTE (Obj_Type, RE_Address)), 4058 Parameter_Type => 4059 New_Occurrence_Of (Obj_Type, Loc)); 4060 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 4061 Prepend_To (New_Plist, Decl); 4062 4063 return New_Plist; 4064 end Build_Protected_Spec; 4065 4066 --------------------------------------- 4067 -- Build_Protected_Sub_Specification -- 4068 --------------------------------------- 4069 4070 function Build_Protected_Sub_Specification 4071 (N : Node_Id; 4072 Prot_Typ : Entity_Id; 4073 Mode : Subprogram_Protection_Mode) return Node_Id 4074 is 4075 Loc : constant Source_Ptr := Sloc (N); 4076 Decl : Node_Id; 4077 Def_Id : Entity_Id; 4078 New_Id : Entity_Id; 4079 New_Plist : List_Id; 4080 New_Spec : Node_Id; 4081 4082 Append_Chr : constant array (Subprogram_Protection_Mode) of Character := 4083 (Dispatching_Mode => ' ', 4084 Protected_Mode => 'P', 4085 Unprotected_Mode => 'N'); 4086 4087 begin 4088 if Ekind (Defining_Unit_Name (Specification (N))) = 4089 E_Subprogram_Body 4090 then 4091 Decl := Unit_Declaration_Node (Corresponding_Spec (N)); 4092 else 4093 Decl := N; 4094 end if; 4095 4096 Def_Id := Defining_Unit_Name (Specification (Decl)); 4097 4098 New_Plist := 4099 Build_Protected_Spec 4100 (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id, 4101 Mode = Unprotected_Mode); 4102 New_Id := 4103 Make_Defining_Identifier (Loc, 4104 Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode))); 4105 4106 -- The unprotected operation carries the user code, and debugging 4107 -- information must be generated for it, even though this spec does 4108 -- not come from source. It is also convenient to allow gdb to step 4109 -- into the protected operation, even though it only contains lock/ 4110 -- unlock calls. 4111 4112 Set_Debug_Info_Needed (New_Id); 4113 4114 -- If a pragma Eliminate applies to the source entity, the internal 4115 -- subprograms will be eliminated as well. 4116 4117 Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id)); 4118 4119 if Nkind (Specification (Decl)) = N_Procedure_Specification then 4120 New_Spec := 4121 Make_Procedure_Specification (Loc, 4122 Defining_Unit_Name => New_Id, 4123 Parameter_Specifications => New_Plist); 4124 4125 -- Create a new specification for the anonymous subprogram type 4126 4127 else 4128 New_Spec := 4129 Make_Function_Specification (Loc, 4130 Defining_Unit_Name => New_Id, 4131 Parameter_Specifications => New_Plist, 4132 Result_Definition => 4133 Copy_Result_Type (Result_Definition (Specification (Decl)))); 4134 4135 Set_Return_Present (Defining_Unit_Name (New_Spec)); 4136 end if; 4137 4138 return New_Spec; 4139 end Build_Protected_Sub_Specification; 4140 4141 ------------------------------------- 4142 -- Build_Protected_Subprogram_Body -- 4143 ------------------------------------- 4144 4145 function Build_Protected_Subprogram_Body 4146 (N : Node_Id; 4147 Pid : Node_Id; 4148 N_Op_Spec : Node_Id) return Node_Id 4149 is 4150 Loc : constant Source_Ptr := Sloc (N); 4151 Op_Spec : Node_Id; 4152 P_Op_Spec : Node_Id; 4153 Uactuals : List_Id; 4154 Pformal : Node_Id; 4155 Unprot_Call : Node_Id; 4156 Sub_Body : Node_Id; 4157 Lock_Name : Node_Id; 4158 Lock_Stmt : Node_Id; 4159 R : Node_Id; 4160 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning 4161 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning 4162 Stmts : List_Id; 4163 Object_Parm : Node_Id; 4164 Exc_Safe : Boolean; 4165 Lock_Kind : RE_Id; 4166 4167 begin 4168 Op_Spec := Specification (N); 4169 Exc_Safe := Is_Exception_Safe (N); 4170 4171 P_Op_Spec := 4172 Build_Protected_Sub_Specification (N, Pid, Protected_Mode); 4173 4174 -- Build a list of the formal parameters of the protected version of 4175 -- the subprogram to use as the actual parameters of the unprotected 4176 -- version. 4177 4178 Uactuals := New_List; 4179 Pformal := First (Parameter_Specifications (P_Op_Spec)); 4180 while Present (Pformal) loop 4181 Append_To (Uactuals, 4182 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal)))); 4183 Next (Pformal); 4184 end loop; 4185 4186 -- Make a call to the unprotected version of the subprogram built above 4187 -- for use by the protected version built below. 4188 4189 if Nkind (Op_Spec) = N_Function_Specification then 4190 if Exc_Safe then 4191 R := Make_Temporary (Loc, 'R'); 4192 Unprot_Call := 4193 Make_Object_Declaration (Loc, 4194 Defining_Identifier => R, 4195 Constant_Present => True, 4196 Object_Definition => New_Copy (Result_Definition (N_Op_Spec)), 4197 Expression => 4198 Make_Function_Call (Loc, 4199 Name => Make_Identifier (Loc, 4200 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 4201 Parameter_Associations => Uactuals)); 4202 4203 Return_Stmt := 4204 Make_Simple_Return_Statement (Loc, 4205 Expression => New_Occurrence_Of (R, Loc)); 4206 4207 else 4208 Unprot_Call := Make_Simple_Return_Statement (Loc, 4209 Expression => Make_Function_Call (Loc, 4210 Name => 4211 Make_Identifier (Loc, 4212 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 4213 Parameter_Associations => Uactuals)); 4214 end if; 4215 4216 Lock_Kind := RE_Lock_Read_Only; 4217 4218 else 4219 Unprot_Call := 4220 Make_Procedure_Call_Statement (Loc, 4221 Name => 4222 Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), 4223 Parameter_Associations => Uactuals); 4224 4225 Lock_Kind := RE_Lock; 4226 end if; 4227 4228 -- Wrap call in block that will be covered by an at_end handler 4229 4230 if not Exc_Safe then 4231 Unprot_Call := Make_Block_Statement (Loc, 4232 Handled_Statement_Sequence => 4233 Make_Handled_Sequence_Of_Statements (Loc, 4234 Statements => New_List (Unprot_Call))); 4235 end if; 4236 4237 -- Make the protected subprogram body. This locks the protected 4238 -- object and calls the unprotected version of the subprogram. 4239 4240 case Corresponding_Runtime_Package (Pid) is 4241 when System_Tasking_Protected_Objects_Entries => 4242 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entries), Loc); 4243 4244 when System_Tasking_Protected_Objects_Single_Entry => 4245 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entry), Loc); 4246 4247 when System_Tasking_Protected_Objects => 4248 Lock_Name := New_Occurrence_Of (RTE (Lock_Kind), Loc); 4249 4250 when others => 4251 raise Program_Error; 4252 end case; 4253 4254 Object_Parm := 4255 Make_Attribute_Reference (Loc, 4256 Prefix => 4257 Make_Selected_Component (Loc, 4258 Prefix => Make_Identifier (Loc, Name_uObject), 4259 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4260 Attribute_Name => Name_Unchecked_Access); 4261 4262 Lock_Stmt := Make_Procedure_Call_Statement (Loc, 4263 Name => Lock_Name, 4264 Parameter_Associations => New_List (Object_Parm)); 4265 4266 if Abort_Allowed then 4267 Stmts := New_List ( 4268 Make_Procedure_Call_Statement (Loc, 4269 Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc), 4270 Parameter_Associations => Empty_List), 4271 Lock_Stmt); 4272 4273 else 4274 Stmts := New_List (Lock_Stmt); 4275 end if; 4276 4277 if not Exc_Safe then 4278 Append (Unprot_Call, Stmts); 4279 else 4280 if Nkind (Op_Spec) = N_Function_Specification then 4281 Pre_Stmts := Stmts; 4282 Stmts := Empty_List; 4283 else 4284 Append (Unprot_Call, Stmts); 4285 end if; 4286 4287 -- Historical note: Previously, call the the cleanup was inserted 4288 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup, 4289 -- which is also shared by the 'not Exc_Safe' path. 4290 4291 Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts); 4292 4293 if Nkind (Op_Spec) = N_Function_Specification then 4294 Append (Return_Stmt, Stmts); 4295 Append (Make_Block_Statement (Loc, 4296 Declarations => New_List (Unprot_Call), 4297 Handled_Statement_Sequence => 4298 Make_Handled_Sequence_Of_Statements (Loc, 4299 Statements => Stmts)), Pre_Stmts); 4300 Stmts := Pre_Stmts; 4301 end if; 4302 end if; 4303 4304 Sub_Body := 4305 Make_Subprogram_Body (Loc, 4306 Declarations => Empty_List, 4307 Specification => P_Op_Spec, 4308 Handled_Statement_Sequence => 4309 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); 4310 4311 -- Mark this subprogram as a protected subprogram body so that the 4312 -- cleanup will be inserted. This is done only in the 'not Exc_Safe' 4313 -- path as otherwise the cleanup has already been inserted. 4314 4315 if not Exc_Safe then 4316 Set_Is_Protected_Subprogram_Body (Sub_Body); 4317 end if; 4318 4319 return Sub_Body; 4320 end Build_Protected_Subprogram_Body; 4321 4322 ------------------------------------- 4323 -- Build_Protected_Subprogram_Call -- 4324 ------------------------------------- 4325 4326 procedure Build_Protected_Subprogram_Call 4327 (N : Node_Id; 4328 Name : Node_Id; 4329 Rec : Node_Id; 4330 External : Boolean := True) 4331 is 4332 Loc : constant Source_Ptr := Sloc (N); 4333 Sub : constant Entity_Id := Entity (Name); 4334 New_Sub : Node_Id; 4335 Params : List_Id; 4336 4337 begin 4338 if External then 4339 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc); 4340 else 4341 New_Sub := 4342 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc); 4343 end if; 4344 4345 if Present (Parameter_Associations (N)) then 4346 Params := New_Copy_List_Tree (Parameter_Associations (N)); 4347 else 4348 Params := New_List; 4349 end if; 4350 4351 -- If the type is an untagged derived type, convert to the root type, 4352 -- which is the one on which the operations are defined. 4353 4354 if Nkind (Rec) = N_Unchecked_Type_Conversion 4355 and then not Is_Tagged_Type (Etype (Rec)) 4356 and then Is_Derived_Type (Etype (Rec)) 4357 then 4358 Set_Etype (Rec, Root_Type (Etype (Rec))); 4359 Set_Subtype_Mark (Rec, 4360 New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N))); 4361 end if; 4362 4363 Prepend (Rec, Params); 4364 4365 if Ekind (Sub) = E_Procedure then 4366 Rewrite (N, 4367 Make_Procedure_Call_Statement (Loc, 4368 Name => New_Sub, 4369 Parameter_Associations => Params)); 4370 4371 else 4372 pragma Assert (Ekind (Sub) = E_Function); 4373 Rewrite (N, 4374 Make_Function_Call (Loc, 4375 Name => New_Sub, 4376 Parameter_Associations => Params)); 4377 4378 -- Preserve type of call for subsequent processing (required for 4379 -- call to Wrap_Transient_Expression in the case of a shared passive 4380 -- protected). 4381 4382 Set_Etype (N, Etype (New_Sub)); 4383 end if; 4384 4385 if External 4386 and then Nkind (Rec) = N_Unchecked_Type_Conversion 4387 and then Is_Entity_Name (Expression (Rec)) 4388 and then Is_Shared_Passive (Entity (Expression (Rec))) 4389 then 4390 Add_Shared_Var_Lock_Procs (N); 4391 end if; 4392 end Build_Protected_Subprogram_Call; 4393 4394 --------------------------------------------- 4395 -- Build_Protected_Subprogram_Call_Cleanup -- 4396 --------------------------------------------- 4397 4398 procedure Build_Protected_Subprogram_Call_Cleanup 4399 (Op_Spec : Node_Id; 4400 Conc_Typ : Node_Id; 4401 Loc : Source_Ptr; 4402 Stmts : List_Id) 4403 is 4404 Nam : Node_Id; 4405 4406 begin 4407 -- If the associated protected object has entries, a protected 4408 -- procedure has to service entry queues. In this case generate: 4409 4410 -- Service_Entries (_object._object'Access); 4411 4412 if Nkind (Op_Spec) = N_Procedure_Specification 4413 and then Has_Entries (Conc_Typ) 4414 then 4415 case Corresponding_Runtime_Package (Conc_Typ) is 4416 when System_Tasking_Protected_Objects_Entries => 4417 Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc); 4418 4419 when System_Tasking_Protected_Objects_Single_Entry => 4420 Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc); 4421 4422 when others => 4423 raise Program_Error; 4424 end case; 4425 4426 Append_To (Stmts, 4427 Make_Procedure_Call_Statement (Loc, 4428 Name => Nam, 4429 Parameter_Associations => New_List ( 4430 Make_Attribute_Reference (Loc, 4431 Prefix => 4432 Make_Selected_Component (Loc, 4433 Prefix => Make_Identifier (Loc, Name_uObject), 4434 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4435 Attribute_Name => Name_Unchecked_Access)))); 4436 4437 else 4438 -- Generate: 4439 -- Unlock (_object._object'Access); 4440 4441 case Corresponding_Runtime_Package (Conc_Typ) is 4442 when System_Tasking_Protected_Objects_Entries => 4443 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc); 4444 4445 when System_Tasking_Protected_Objects_Single_Entry => 4446 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc); 4447 4448 when System_Tasking_Protected_Objects => 4449 Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc); 4450 4451 when others => 4452 raise Program_Error; 4453 end case; 4454 4455 Append_To (Stmts, 4456 Make_Procedure_Call_Statement (Loc, 4457 Name => Nam, 4458 Parameter_Associations => New_List ( 4459 Make_Attribute_Reference (Loc, 4460 Prefix => 4461 Make_Selected_Component (Loc, 4462 Prefix => Make_Identifier (Loc, Name_uObject), 4463 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4464 Attribute_Name => Name_Unchecked_Access)))); 4465 end if; 4466 4467 -- Generate: 4468 -- Abort_Undefer; 4469 4470 if Abort_Allowed then 4471 Append_To (Stmts, 4472 Make_Procedure_Call_Statement (Loc, 4473 Name => 4474 New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), 4475 Parameter_Associations => Empty_List)); 4476 end if; 4477 end Build_Protected_Subprogram_Call_Cleanup; 4478 4479 ------------------------- 4480 -- Build_Selected_Name -- 4481 ------------------------- 4482 4483 function Build_Selected_Name 4484 (Prefix : Entity_Id; 4485 Selector : Entity_Id; 4486 Append_Char : Character := ' ') return Name_Id 4487 is 4488 Select_Buffer : String (1 .. Hostparm.Max_Name_Length); 4489 Select_Len : Natural; 4490 4491 begin 4492 Get_Name_String (Chars (Selector)); 4493 Select_Len := Name_Len; 4494 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len); 4495 Get_Name_String (Chars (Prefix)); 4496 4497 -- If scope is anonymous type, discard suffix to recover name of 4498 -- single protected object. Otherwise use protected type name. 4499 4500 if Name_Buffer (Name_Len) = 'T' then 4501 Name_Len := Name_Len - 1; 4502 end if; 4503 4504 Add_Str_To_Name_Buffer ("__"); 4505 for J in 1 .. Select_Len loop 4506 Add_Char_To_Name_Buffer (Select_Buffer (J)); 4507 end loop; 4508 4509 -- Now add the Append_Char if specified. The encoding to follow 4510 -- depends on the type of entity. If Append_Char is either 'N' or 'P', 4511 -- then the entity is associated to a protected type subprogram. 4512 -- Otherwise, it is a protected type entry. For each case, the 4513 -- encoding to follow for the suffix is documented in exp_dbug.ads. 4514 4515 -- It would be better to encapsulate this as a routine in Exp_Dbug ??? 4516 4517 if Append_Char /= ' ' then 4518 if Append_Char = 'P' or Append_Char = 'N' then 4519 Add_Char_To_Name_Buffer (Append_Char); 4520 return Name_Find; 4521 else 4522 Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char)); 4523 return New_External_Name (Name_Find, ' ', -1); 4524 end if; 4525 else 4526 return Name_Find; 4527 end if; 4528 end Build_Selected_Name; 4529 4530 ----------------------------- 4531 -- Build_Simple_Entry_Call -- 4532 ----------------------------- 4533 4534 -- A task entry call is converted to a call to Call_Simple 4535 4536 -- declare 4537 -- P : parms := (parm, parm, parm); 4538 -- begin 4539 -- Call_Simple (acceptor-task, entry-index, P'Address); 4540 -- parm := P.param; 4541 -- parm := P.param; 4542 -- ... 4543 -- end; 4544 4545 -- Here Pnn is an aggregate of the type constructed for the entry to hold 4546 -- the parameters, and the constructed aggregate value contains either the 4547 -- parameters or, in the case of non-elementary types, references to these 4548 -- parameters. Then the address of this aggregate is passed to the runtime 4549 -- routine, along with the task id value and the task entry index value. 4550 -- Pnn is only required if parameters are present. 4551 4552 -- The assignments after the call are present only in the case of in-out 4553 -- or out parameters for elementary types, and are used to assign back the 4554 -- resulting values of such parameters. 4555 4556 -- Note: the reason that we insert a block here is that in the context 4557 -- of selects, conditional entry calls etc. the entry call statement 4558 -- appears on its own, not as an element of a list. 4559 4560 -- A protected entry call is converted to a Protected_Entry_Call: 4561 4562 -- declare 4563 -- P : E1_Params := (param, param, param); 4564 -- Pnn : Boolean; 4565 -- Bnn : Communications_Block; 4566 4567 -- declare 4568 -- P : E1_Params := (param, param, param); 4569 -- Bnn : Communications_Block; 4570 4571 -- begin 4572 -- Protected_Entry_Call ( 4573 -- Object => po._object'Access, 4574 -- E => <entry index>; 4575 -- Uninterpreted_Data => P'Address; 4576 -- Mode => Simple_Call; 4577 -- Block => Bnn); 4578 -- parm := P.param; 4579 -- parm := P.param; 4580 -- ... 4581 -- end; 4582 4583 procedure Build_Simple_Entry_Call 4584 (N : Node_Id; 4585 Concval : Node_Id; 4586 Ename : Node_Id; 4587 Index : Node_Id) 4588 is 4589 begin 4590 Expand_Call (N); 4591 4592 -- If call has been inlined, nothing left to do 4593 4594 if Nkind (N) = N_Block_Statement then 4595 return; 4596 end if; 4597 4598 -- Convert entry call to Call_Simple call 4599 4600 declare 4601 Loc : constant Source_Ptr := Sloc (N); 4602 Parms : constant List_Id := Parameter_Associations (N); 4603 Stats : constant List_Id := New_List; 4604 Actual : Node_Id; 4605 Call : Node_Id; 4606 Comm_Name : Entity_Id; 4607 Conctyp : Node_Id; 4608 Decls : List_Id; 4609 Ent : Entity_Id; 4610 Ent_Acc : Entity_Id; 4611 Formal : Node_Id; 4612 Iface_Tag : Entity_Id; 4613 Iface_Typ : Entity_Id; 4614 N_Node : Node_Id; 4615 N_Var : Node_Id; 4616 P : Entity_Id; 4617 Parm1 : Node_Id; 4618 Parm2 : Node_Id; 4619 Parm3 : Node_Id; 4620 Pdecl : Node_Id; 4621 Plist : List_Id; 4622 X : Entity_Id; 4623 Xdecl : Node_Id; 4624 4625 begin 4626 -- Simple entry and entry family cases merge here 4627 4628 Ent := Entity (Ename); 4629 Ent_Acc := Entry_Parameters_Type (Ent); 4630 Conctyp := Etype (Concval); 4631 4632 -- If prefix is an access type, dereference to obtain the task type 4633 4634 if Is_Access_Type (Conctyp) then 4635 Conctyp := Designated_Type (Conctyp); 4636 end if; 4637 4638 -- Special case for protected subprogram calls 4639 4640 if Is_Protected_Type (Conctyp) 4641 and then Is_Subprogram (Entity (Ename)) 4642 then 4643 if not Is_Eliminated (Entity (Ename)) then 4644 Build_Protected_Subprogram_Call 4645 (N, Ename, Convert_Concurrent (Concval, Conctyp)); 4646 Analyze (N); 4647 end if; 4648 4649 return; 4650 end if; 4651 4652 -- First parameter is the Task_Id value from the task value or the 4653 -- Object from the protected object value, obtained by selecting 4654 -- the _Task_Id or _Object from the result of doing an unchecked 4655 -- conversion to convert the value to the corresponding record type. 4656 4657 if Nkind (Concval) = N_Function_Call 4658 and then Is_Task_Type (Conctyp) 4659 and then Ada_Version >= Ada_2005 4660 then 4661 declare 4662 ExpR : constant Node_Id := Relocate_Node (Concval); 4663 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR); 4664 Decl : Node_Id; 4665 4666 begin 4667 Decl := 4668 Make_Object_Declaration (Loc, 4669 Defining_Identifier => Obj, 4670 Object_Definition => New_Occurrence_Of (Conctyp, Loc), 4671 Expression => ExpR); 4672 Set_Etype (Obj, Conctyp); 4673 Decls := New_List (Decl); 4674 Rewrite (Concval, New_Occurrence_Of (Obj, Loc)); 4675 end; 4676 4677 else 4678 Decls := New_List; 4679 end if; 4680 4681 Parm1 := Concurrent_Ref (Concval); 4682 4683 -- Second parameter is the entry index, computed by the routine 4684 -- provided for this purpose. The value of this expression is 4685 -- assigned to an intermediate variable to assure that any entry 4686 -- family index expressions are evaluated before the entry 4687 -- parameters. 4688 4689 if not Is_Protected_Type (Conctyp) 4690 or else 4691 Corresponding_Runtime_Package (Conctyp) = 4692 System_Tasking_Protected_Objects_Entries 4693 then 4694 X := Make_Defining_Identifier (Loc, Name_uX); 4695 4696 Xdecl := 4697 Make_Object_Declaration (Loc, 4698 Defining_Identifier => X, 4699 Object_Definition => 4700 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), 4701 Expression => Actual_Index_Expression ( 4702 Loc, Entity (Ename), Index, Concval)); 4703 4704 Append_To (Decls, Xdecl); 4705 Parm2 := New_Occurrence_Of (X, Loc); 4706 4707 else 4708 Xdecl := Empty; 4709 Parm2 := Empty; 4710 end if; 4711 4712 -- The third parameter is the packaged parameters. If there are 4713 -- none, then it is just the null address, since nothing is passed. 4714 4715 if No (Parms) then 4716 Parm3 := New_Occurrence_Of (RTE (RE_Null_Address), Loc); 4717 P := Empty; 4718 4719 -- Case of parameters present, where third argument is the address 4720 -- of a packaged record containing the required parameter values. 4721 4722 else 4723 -- First build a list of parameter values, which are references to 4724 -- objects of the parameter types. 4725 4726 Plist := New_List; 4727 4728 Actual := First_Actual (N); 4729 Formal := First_Formal (Ent); 4730 while Present (Actual) loop 4731 4732 -- If it is a by_copy_type, copy it to a new variable. The 4733 -- packaged record has a field that points to this variable. 4734 4735 if Is_By_Copy_Type (Etype (Actual)) then 4736 N_Node := 4737 Make_Object_Declaration (Loc, 4738 Defining_Identifier => Make_Temporary (Loc, 'J'), 4739 Aliased_Present => True, 4740 Object_Definition => 4741 New_Occurrence_Of (Etype (Formal), Loc)); 4742 4743 -- Mark the object as not needing initialization since the 4744 -- initialization is performed separately, avoiding errors 4745 -- on cases such as formals of null-excluding access types. 4746 4747 Set_No_Initialization (N_Node); 4748 4749 -- We must make an assignment statement separate for the 4750 -- case of limited type. We cannot assign it unless the 4751 -- Assignment_OK flag is set first. An out formal of an 4752 -- access type must also be initialized from the actual, 4753 -- as stated in RM 6.4.1 (13), but no constraint is applied 4754 -- before the call. 4755 4756 if Ekind (Formal) /= E_Out_Parameter 4757 or else Is_Access_Type (Etype (Formal)) 4758 then 4759 N_Var := 4760 New_Occurrence_Of (Defining_Identifier (N_Node), Loc); 4761 Set_Assignment_OK (N_Var); 4762 Append_To (Stats, 4763 Make_Assignment_Statement (Loc, 4764 Name => N_Var, 4765 Expression => Relocate_Node (Actual))); 4766 4767 -- If actual is an out parameter of a null-excluding 4768 -- access type, there is access check on entry, so set 4769 -- Suppress_Assignment_Checks on the generated statement 4770 -- that assigns the actual to the parameter block 4771 4772 Set_Suppress_Assignment_Checks (Last (Stats)); 4773 end if; 4774 4775 Append (N_Node, Decls); 4776 4777 Append_To (Plist, 4778 Make_Attribute_Reference (Loc, 4779 Attribute_Name => Name_Unchecked_Access, 4780 Prefix => 4781 New_Occurrence_Of (Defining_Identifier (N_Node), Loc))); 4782 4783 -- If it is a VM_By_Copy_Actual, copy it to a new variable 4784 4785 elsif Is_VM_By_Copy_Actual (Actual) then 4786 N_Node := 4787 Make_Object_Declaration (Loc, 4788 Defining_Identifier => Make_Temporary (Loc, 'J'), 4789 Aliased_Present => True, 4790 Object_Definition => 4791 New_Occurrence_Of (Etype (Formal), Loc), 4792 Expression => New_Copy_Tree (Actual)); 4793 Set_Assignment_OK (N_Node); 4794 4795 Append (N_Node, Decls); 4796 4797 Append_To (Plist, 4798 Make_Attribute_Reference (Loc, 4799 Attribute_Name => Name_Unchecked_Access, 4800 Prefix => 4801 New_Occurrence_Of (Defining_Identifier (N_Node), Loc))); 4802 4803 else 4804 -- Interface class-wide formal 4805 4806 if Ada_Version >= Ada_2005 4807 and then Ekind (Etype (Formal)) = E_Class_Wide_Type 4808 and then Is_Interface (Etype (Formal)) 4809 then 4810 Iface_Typ := Etype (Etype (Formal)); 4811 4812 -- Generate: 4813 -- formal_iface_type! (actual.iface_tag)'reference 4814 4815 Iface_Tag := 4816 Find_Interface_Tag (Etype (Actual), Iface_Typ); 4817 pragma Assert (Present (Iface_Tag)); 4818 4819 Append_To (Plist, 4820 Make_Reference (Loc, 4821 Unchecked_Convert_To (Iface_Typ, 4822 Make_Selected_Component (Loc, 4823 Prefix => 4824 Relocate_Node (Actual), 4825 Selector_Name => 4826 New_Occurrence_Of (Iface_Tag, Loc))))); 4827 else 4828 -- Generate: 4829 -- actual'reference 4830 4831 Append_To (Plist, 4832 Make_Reference (Loc, Relocate_Node (Actual))); 4833 end if; 4834 end if; 4835 4836 Next_Actual (Actual); 4837 Next_Formal_With_Extras (Formal); 4838 end loop; 4839 4840 -- Now build the declaration of parameters initialized with the 4841 -- aggregate containing this constructed parameter list. 4842 4843 P := Make_Defining_Identifier (Loc, Name_uP); 4844 4845 Pdecl := 4846 Make_Object_Declaration (Loc, 4847 Defining_Identifier => P, 4848 Object_Definition => 4849 New_Occurrence_Of (Designated_Type (Ent_Acc), Loc), 4850 Expression => 4851 Make_Aggregate (Loc, Expressions => Plist)); 4852 4853 Parm3 := 4854 Make_Attribute_Reference (Loc, 4855 Prefix => New_Occurrence_Of (P, Loc), 4856 Attribute_Name => Name_Address); 4857 4858 Append (Pdecl, Decls); 4859 end if; 4860 4861 -- Now we can create the call, case of protected type 4862 4863 if Is_Protected_Type (Conctyp) then 4864 case Corresponding_Runtime_Package (Conctyp) is 4865 when System_Tasking_Protected_Objects_Entries => 4866 4867 -- Change the type of the index declaration 4868 4869 Set_Object_Definition (Xdecl, 4870 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)); 4871 4872 -- Some additional declarations for protected entry calls 4873 4874 if No (Decls) then 4875 Decls := New_List; 4876 end if; 4877 4878 -- Bnn : Communications_Block; 4879 4880 Comm_Name := Make_Temporary (Loc, 'B'); 4881 4882 Append_To (Decls, 4883 Make_Object_Declaration (Loc, 4884 Defining_Identifier => Comm_Name, 4885 Object_Definition => 4886 New_Occurrence_Of 4887 (RTE (RE_Communication_Block), Loc))); 4888 4889 -- Some additional statements for protected entry calls 4890 4891 -- Protected_Entry_Call ( 4892 -- Object => po._object'Access, 4893 -- E => <entry index>; 4894 -- Uninterpreted_Data => P'Address; 4895 -- Mode => Simple_Call; 4896 -- Block => Bnn); 4897 4898 Call := 4899 Make_Procedure_Call_Statement (Loc, 4900 Name => 4901 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), 4902 4903 Parameter_Associations => New_List ( 4904 Make_Attribute_Reference (Loc, 4905 Attribute_Name => Name_Unchecked_Access, 4906 Prefix => Parm1), 4907 Parm2, 4908 Parm3, 4909 New_Occurrence_Of (RTE (RE_Simple_Call), Loc), 4910 New_Occurrence_Of (Comm_Name, Loc))); 4911 4912 when System_Tasking_Protected_Objects_Single_Entry => 4913 -- Protected_Single_Entry_Call ( 4914 -- Object => po._object'Access, 4915 -- Uninterpreted_Data => P'Address); 4916 4917 Call := 4918 Make_Procedure_Call_Statement (Loc, 4919 Name => New_Occurrence_Of ( 4920 RTE (RE_Protected_Single_Entry_Call), Loc), 4921 4922 Parameter_Associations => New_List ( 4923 Make_Attribute_Reference (Loc, 4924 Attribute_Name => Name_Unchecked_Access, 4925 Prefix => Parm1), 4926 Parm3)); 4927 4928 when others => 4929 raise Program_Error; 4930 end case; 4931 4932 -- Case of task type 4933 4934 else 4935 Call := 4936 Make_Procedure_Call_Statement (Loc, 4937 Name => New_Occurrence_Of (RTE (RE_Call_Simple), Loc), 4938 Parameter_Associations => New_List (Parm1, Parm2, Parm3)); 4939 4940 end if; 4941 4942 Append_To (Stats, Call); 4943 4944 -- If there are out or in/out parameters by copy add assignment 4945 -- statements for the result values. 4946 4947 if Present (Parms) then 4948 Actual := First_Actual (N); 4949 Formal := First_Formal (Ent); 4950 4951 Set_Assignment_OK (Actual); 4952 while Present (Actual) loop 4953 if (Is_By_Copy_Type (Etype (Actual)) 4954 or else Is_VM_By_Copy_Actual (Actual)) 4955 and then Ekind (Formal) /= E_In_Parameter 4956 then 4957 N_Node := 4958 Make_Assignment_Statement (Loc, 4959 Name => New_Copy (Actual), 4960 Expression => 4961 Make_Explicit_Dereference (Loc, 4962 Make_Selected_Component (Loc, 4963 Prefix => New_Occurrence_Of (P, Loc), 4964 Selector_Name => 4965 Make_Identifier (Loc, Chars (Formal))))); 4966 4967 -- In all cases (including limited private types) we want 4968 -- the assignment to be valid. 4969 4970 Set_Assignment_OK (Name (N_Node)); 4971 4972 -- If the call is the triggering alternative in an 4973 -- asynchronous select, or the entry_call alternative of a 4974 -- conditional entry call, the assignments for in-out 4975 -- parameters are incorporated into the statement list that 4976 -- follows, so that there are executed only if the entry 4977 -- call succeeds. 4978 4979 if (Nkind (Parent (N)) = N_Triggering_Alternative 4980 and then N = Triggering_Statement (Parent (N))) 4981 or else 4982 (Nkind (Parent (N)) = N_Entry_Call_Alternative 4983 and then N = Entry_Call_Statement (Parent (N))) 4984 then 4985 if No (Statements (Parent (N))) then 4986 Set_Statements (Parent (N), New_List); 4987 end if; 4988 4989 Prepend (N_Node, Statements (Parent (N))); 4990 4991 else 4992 Insert_After (Call, N_Node); 4993 end if; 4994 end if; 4995 4996 Next_Actual (Actual); 4997 Next_Formal_With_Extras (Formal); 4998 end loop; 4999 end if; 5000 5001 -- Finally, create block and analyze it 5002 5003 Rewrite (N, 5004 Make_Block_Statement (Loc, 5005 Declarations => Decls, 5006 Handled_Statement_Sequence => 5007 Make_Handled_Sequence_Of_Statements (Loc, 5008 Statements => Stats))); 5009 5010 Analyze (N); 5011 end; 5012 end Build_Simple_Entry_Call; 5013 5014 -------------------------------- 5015 -- Build_Task_Activation_Call -- 5016 -------------------------------- 5017 5018 procedure Build_Task_Activation_Call (N : Node_Id) is 5019 Loc : constant Source_Ptr := Sloc (N); 5020 Chain : Entity_Id; 5021 Call : Node_Id; 5022 Name : Node_Id; 5023 P : Node_Id; 5024 5025 begin 5026 -- For sequential elaboration policy, all the tasks will be activated at 5027 -- the end of the elaboration. 5028 5029 if Partition_Elaboration_Policy = 'S' then 5030 return; 5031 end if; 5032 5033 -- Get the activation chain entity. Except in the case of a package 5034 -- body, this is in the node that was passed. For a package body, we 5035 -- have to find the corresponding package declaration node. 5036 5037 if Nkind (N) = N_Package_Body then 5038 P := Corresponding_Spec (N); 5039 loop 5040 P := Parent (P); 5041 exit when Nkind (P) = N_Package_Declaration; 5042 end loop; 5043 5044 Chain := Activation_Chain_Entity (P); 5045 5046 else 5047 Chain := Activation_Chain_Entity (N); 5048 end if; 5049 5050 if Present (Chain) then 5051 if Restricted_Profile then 5052 Name := New_Occurrence_Of 5053 (RTE (RE_Activate_Restricted_Tasks), Loc); 5054 else 5055 Name := New_Occurrence_Of 5056 (RTE (RE_Activate_Tasks), Loc); 5057 end if; 5058 5059 Call := 5060 Make_Procedure_Call_Statement (Loc, 5061 Name => Name, 5062 Parameter_Associations => 5063 New_List (Make_Attribute_Reference (Loc, 5064 Prefix => New_Occurrence_Of (Chain, Loc), 5065 Attribute_Name => Name_Unchecked_Access))); 5066 5067 if Nkind (N) = N_Package_Declaration then 5068 if Present (Corresponding_Body (N)) then 5069 null; 5070 5071 elsif Present (Private_Declarations (Specification (N))) then 5072 Append (Call, Private_Declarations (Specification (N))); 5073 5074 else 5075 Append (Call, Visible_Declarations (Specification (N))); 5076 end if; 5077 5078 else 5079 if Present (Handled_Statement_Sequence (N)) then 5080 5081 -- The call goes at the start of the statement sequence after 5082 -- the start of exception range label if one is present. 5083 5084 declare 5085 Stm : Node_Id; 5086 5087 begin 5088 Stm := First (Statements (Handled_Statement_Sequence (N))); 5089 5090 -- A special case, skip exception range label if one is 5091 -- present (from front end zcx processing). 5092 5093 if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then 5094 Next (Stm); 5095 end if; 5096 5097 -- Another special case, if the first statement is a block 5098 -- from optimization of a local raise to a goto, then the 5099 -- call goes inside this block. 5100 5101 if Nkind (Stm) = N_Block_Statement 5102 and then Exception_Junk (Stm) 5103 then 5104 Stm := 5105 First (Statements (Handled_Statement_Sequence (Stm))); 5106 end if; 5107 5108 -- Insertion point is after any exception label pushes, 5109 -- since we want it covered by any local handlers. 5110 5111 while Nkind (Stm) in N_Push_xxx_Label loop 5112 Next (Stm); 5113 end loop; 5114 5115 -- Now we have the proper insertion point 5116 5117 Insert_Before (Stm, Call); 5118 end; 5119 5120 else 5121 Set_Handled_Statement_Sequence (N, 5122 Make_Handled_Sequence_Of_Statements (Loc, 5123 Statements => New_List (Call))); 5124 end if; 5125 end if; 5126 5127 Analyze (Call); 5128 Check_Task_Activation (N); 5129 end if; 5130 end Build_Task_Activation_Call; 5131 5132 ------------------------------- 5133 -- Build_Task_Allocate_Block -- 5134 ------------------------------- 5135 5136 procedure Build_Task_Allocate_Block 5137 (Actions : List_Id; 5138 N : Node_Id; 5139 Args : List_Id) 5140 is 5141 T : constant Entity_Id := Entity (Expression (N)); 5142 Init : constant Entity_Id := Base_Init_Proc (T); 5143 Loc : constant Source_Ptr := Sloc (N); 5144 Chain : constant Entity_Id := 5145 Make_Defining_Identifier (Loc, Name_uChain); 5146 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 5147 Block : Node_Id; 5148 5149 begin 5150 Block := 5151 Make_Block_Statement (Loc, 5152 Identifier => New_Occurrence_Of (Blkent, Loc), 5153 Declarations => New_List ( 5154 5155 -- _Chain : Activation_Chain; 5156 5157 Make_Object_Declaration (Loc, 5158 Defining_Identifier => Chain, 5159 Aliased_Present => True, 5160 Object_Definition => 5161 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 5162 5163 Handled_Statement_Sequence => 5164 Make_Handled_Sequence_Of_Statements (Loc, 5165 5166 Statements => New_List ( 5167 5168 -- Init (Args); 5169 5170 Make_Procedure_Call_Statement (Loc, 5171 Name => New_Occurrence_Of (Init, Loc), 5172 Parameter_Associations => Args), 5173 5174 -- Activate_Tasks (_Chain); 5175 5176 Make_Procedure_Call_Statement (Loc, 5177 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 5178 Parameter_Associations => New_List ( 5179 Make_Attribute_Reference (Loc, 5180 Prefix => New_Occurrence_Of (Chain, Loc), 5181 Attribute_Name => Name_Unchecked_Access))))), 5182 5183 Has_Created_Identifier => True, 5184 Is_Task_Allocation_Block => True); 5185 5186 Append_To (Actions, 5187 Make_Implicit_Label_Declaration (Loc, 5188 Defining_Identifier => Blkent, 5189 Label_Construct => Block)); 5190 5191 Append_To (Actions, Block); 5192 5193 Set_Activation_Chain_Entity (Block, Chain); 5194 end Build_Task_Allocate_Block; 5195 5196 ----------------------------------------------- 5197 -- Build_Task_Allocate_Block_With_Init_Stmts -- 5198 ----------------------------------------------- 5199 5200 procedure Build_Task_Allocate_Block_With_Init_Stmts 5201 (Actions : List_Id; 5202 N : Node_Id; 5203 Init_Stmts : List_Id) 5204 is 5205 Loc : constant Source_Ptr := Sloc (N); 5206 Chain : constant Entity_Id := 5207 Make_Defining_Identifier (Loc, Name_uChain); 5208 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 5209 Block : Node_Id; 5210 5211 begin 5212 Append_To (Init_Stmts, 5213 Make_Procedure_Call_Statement (Loc, 5214 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 5215 Parameter_Associations => New_List ( 5216 Make_Attribute_Reference (Loc, 5217 Prefix => New_Occurrence_Of (Chain, Loc), 5218 Attribute_Name => Name_Unchecked_Access)))); 5219 5220 Block := 5221 Make_Block_Statement (Loc, 5222 Identifier => New_Occurrence_Of (Blkent, Loc), 5223 Declarations => New_List ( 5224 5225 -- _Chain : Activation_Chain; 5226 5227 Make_Object_Declaration (Loc, 5228 Defining_Identifier => Chain, 5229 Aliased_Present => True, 5230 Object_Definition => 5231 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 5232 5233 Handled_Statement_Sequence => 5234 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts), 5235 5236 Has_Created_Identifier => True, 5237 Is_Task_Allocation_Block => True); 5238 5239 Append_To (Actions, 5240 Make_Implicit_Label_Declaration (Loc, 5241 Defining_Identifier => Blkent, 5242 Label_Construct => Block)); 5243 5244 Append_To (Actions, Block); 5245 5246 Set_Activation_Chain_Entity (Block, Chain); 5247 end Build_Task_Allocate_Block_With_Init_Stmts; 5248 5249 ----------------------------------- 5250 -- Build_Task_Proc_Specification -- 5251 ----------------------------------- 5252 5253 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is 5254 Loc : constant Source_Ptr := Sloc (T); 5255 Spec_Id : Entity_Id; 5256 5257 begin 5258 -- Case of explicit task type, suffix TB 5259 5260 if Comes_From_Source (T) then 5261 Spec_Id := 5262 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB")); 5263 5264 -- Case of anonymous task type, suffix B 5265 5266 else 5267 Spec_Id := 5268 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B')); 5269 end if; 5270 5271 Set_Is_Internal (Spec_Id); 5272 5273 -- Associate the procedure with the task, if this is the declaration 5274 -- (and not the body) of the procedure. 5275 5276 if No (Task_Body_Procedure (T)) then 5277 Set_Task_Body_Procedure (T, Spec_Id); 5278 end if; 5279 5280 return 5281 Make_Procedure_Specification (Loc, 5282 Defining_Unit_Name => Spec_Id, 5283 Parameter_Specifications => New_List ( 5284 Make_Parameter_Specification (Loc, 5285 Defining_Identifier => 5286 Make_Defining_Identifier (Loc, Name_uTask), 5287 Parameter_Type => 5288 Make_Access_Definition (Loc, 5289 Subtype_Mark => 5290 New_Occurrence_Of (Corresponding_Record_Type (T), Loc))))); 5291 end Build_Task_Proc_Specification; 5292 5293 --------------------------------------- 5294 -- Build_Unprotected_Subprogram_Body -- 5295 --------------------------------------- 5296 5297 function Build_Unprotected_Subprogram_Body 5298 (N : Node_Id; 5299 Pid : Node_Id) return Node_Id 5300 is 5301 Decls : constant List_Id := Declarations (N); 5302 5303 begin 5304 -- Add renamings for the Protection object, discriminals, privals and 5305 -- the entry index constant for use by debugger. 5306 5307 Debug_Private_Data_Declarations (Decls); 5308 5309 -- Make an unprotected version of the subprogram for use within the same 5310 -- object, with a new name and an additional parameter representing the 5311 -- object. 5312 5313 return 5314 Make_Subprogram_Body (Sloc (N), 5315 Specification => 5316 Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), 5317 Declarations => Decls, 5318 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 5319 end Build_Unprotected_Subprogram_Body; 5320 5321 ---------------------------- 5322 -- Collect_Entry_Families -- 5323 ---------------------------- 5324 5325 procedure Collect_Entry_Families 5326 (Loc : Source_Ptr; 5327 Cdecls : List_Id; 5328 Current_Node : in out Node_Id; 5329 Conctyp : Entity_Id) 5330 is 5331 Efam : Entity_Id; 5332 Efam_Decl : Node_Id; 5333 Efam_Type : Entity_Id; 5334 5335 begin 5336 Efam := First_Entity (Conctyp); 5337 while Present (Efam) loop 5338 if Ekind (Efam) = E_Entry_Family then 5339 Efam_Type := Make_Temporary (Loc, 'F'); 5340 5341 declare 5342 Bas : Entity_Id := 5343 Base_Type 5344 (Etype (Discrete_Subtype_Definition (Parent (Efam)))); 5345 5346 Bas_Decl : Node_Id := Empty; 5347 Lo, Hi : Node_Id; 5348 5349 begin 5350 Get_Index_Bounds 5351 (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi); 5352 5353 if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then 5354 Bas := Make_Temporary (Loc, 'B'); 5355 5356 Bas_Decl := 5357 Make_Subtype_Declaration (Loc, 5358 Defining_Identifier => Bas, 5359 Subtype_Indication => 5360 Make_Subtype_Indication (Loc, 5361 Subtype_Mark => 5362 New_Occurrence_Of (Standard_Integer, Loc), 5363 Constraint => 5364 Make_Range_Constraint (Loc, 5365 Range_Expression => Make_Range (Loc, 5366 Make_Integer_Literal 5367 (Loc, -Entry_Family_Bound), 5368 Make_Integer_Literal 5369 (Loc, Entry_Family_Bound - 1))))); 5370 5371 Insert_After (Current_Node, Bas_Decl); 5372 Current_Node := Bas_Decl; 5373 Analyze (Bas_Decl); 5374 end if; 5375 5376 Efam_Decl := 5377 Make_Full_Type_Declaration (Loc, 5378 Defining_Identifier => Efam_Type, 5379 Type_Definition => 5380 Make_Unconstrained_Array_Definition (Loc, 5381 Subtype_Marks => 5382 (New_List (New_Occurrence_Of (Bas, Loc))), 5383 5384 Component_Definition => 5385 Make_Component_Definition (Loc, 5386 Aliased_Present => False, 5387 Subtype_Indication => 5388 New_Occurrence_Of (Standard_Character, Loc)))); 5389 end; 5390 5391 Insert_After (Current_Node, Efam_Decl); 5392 Current_Node := Efam_Decl; 5393 Analyze (Efam_Decl); 5394 5395 Append_To (Cdecls, 5396 Make_Component_Declaration (Loc, 5397 Defining_Identifier => 5398 Make_Defining_Identifier (Loc, Chars (Efam)), 5399 5400 Component_Definition => 5401 Make_Component_Definition (Loc, 5402 Aliased_Present => False, 5403 Subtype_Indication => 5404 Make_Subtype_Indication (Loc, 5405 Subtype_Mark => 5406 New_Occurrence_Of (Efam_Type, Loc), 5407 5408 Constraint => 5409 Make_Index_Or_Discriminant_Constraint (Loc, 5410 Constraints => New_List ( 5411 New_Occurrence_Of 5412 (Etype (Discrete_Subtype_Definition 5413 (Parent (Efam))), Loc))))))); 5414 5415 end if; 5416 5417 Next_Entity (Efam); 5418 end loop; 5419 end Collect_Entry_Families; 5420 5421 ----------------------- 5422 -- Concurrent_Object -- 5423 ----------------------- 5424 5425 function Concurrent_Object 5426 (Spec_Id : Entity_Id; 5427 Conc_Typ : Entity_Id) return Entity_Id 5428 is 5429 begin 5430 -- Parameter _O or _object 5431 5432 if Is_Protected_Type (Conc_Typ) then 5433 return First_Formal (Protected_Body_Subprogram (Spec_Id)); 5434 5435 -- Parameter _task 5436 5437 else 5438 pragma Assert (Is_Task_Type (Conc_Typ)); 5439 return First_Formal (Task_Body_Procedure (Conc_Typ)); 5440 end if; 5441 end Concurrent_Object; 5442 5443 ---------------------- 5444 -- Copy_Result_Type -- 5445 ---------------------- 5446 5447 function Copy_Result_Type (Res : Node_Id) return Node_Id is 5448 New_Res : constant Node_Id := New_Copy_Tree (Res); 5449 Par_Spec : Node_Id; 5450 Formal : Entity_Id; 5451 5452 begin 5453 -- If the result type is an access_to_subprogram, we must create new 5454 -- entities for its spec. 5455 5456 if Nkind (New_Res) = N_Access_Definition 5457 and then Present (Access_To_Subprogram_Definition (New_Res)) 5458 then 5459 -- Provide new entities for the formals 5460 5461 Par_Spec := First (Parameter_Specifications 5462 (Access_To_Subprogram_Definition (New_Res))); 5463 while Present (Par_Spec) loop 5464 Formal := Defining_Identifier (Par_Spec); 5465 Set_Defining_Identifier (Par_Spec, 5466 Make_Defining_Identifier (Sloc (Formal), Chars (Formal))); 5467 Next (Par_Spec); 5468 end loop; 5469 end if; 5470 5471 return New_Res; 5472 end Copy_Result_Type; 5473 5474 -------------------- 5475 -- Concurrent_Ref -- 5476 -------------------- 5477 5478 -- The expression returned for a reference to a concurrent object has the 5479 -- form: 5480 5481 -- taskV!(name)._Task_Id 5482 5483 -- for a task, and 5484 5485 -- objectV!(name)._Object 5486 5487 -- for a protected object. For the case of an access to a concurrent 5488 -- object, there is an extra explicit dereference: 5489 5490 -- taskV!(name.all)._Task_Id 5491 -- objectV!(name.all)._Object 5492 5493 -- here taskV and objectV are the types for the associated records, which 5494 -- contain the required _Task_Id and _Object fields for tasks and protected 5495 -- objects, respectively. 5496 5497 -- For the case of a task type name, the expression is 5498 5499 -- Self; 5500 5501 -- i.e. a call to the Self function which returns precisely this Task_Id 5502 5503 -- For the case of a protected type name, the expression is 5504 5505 -- objectR 5506 5507 -- which is a renaming of the _object field of the current object 5508 -- record, passed into protected operations as a parameter. 5509 5510 function Concurrent_Ref (N : Node_Id) return Node_Id is 5511 Loc : constant Source_Ptr := Sloc (N); 5512 Ntyp : constant Entity_Id := Etype (N); 5513 Dtyp : Entity_Id; 5514 Sel : Name_Id; 5515 5516 function Is_Current_Task (T : Entity_Id) return Boolean; 5517 -- Check whether the reference is to the immediately enclosing task 5518 -- type, or to an outer one (rare but legal). 5519 5520 --------------------- 5521 -- Is_Current_Task -- 5522 --------------------- 5523 5524 function Is_Current_Task (T : Entity_Id) return Boolean is 5525 Scop : Entity_Id; 5526 5527 begin 5528 Scop := Current_Scope; 5529 while Present (Scop) and then Scop /= Standard_Standard loop 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 5661 -- Declaration for concurrent entity _object and its access type, 5662 -- along with the entry index subtype: 5663 -- type prot_typVP is access prot_typV; 5664 -- _object : prot_typVP := prot_typV (_O); 5665 -- subtype Jnn is <Type of Index> range Low .. High; 5666 5667 if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then 5668 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5669 5670 -- Declaration for the Protection object, discriminals, privals and 5671 -- entry index constant: 5672 -- conc_typR : protection_typ renames _object._object; 5673 -- discr_nameD : discr_typ renames _object.discr_name; 5674 -- discr_nameD : discr_typ renames _task.discr_name; 5675 -- prival_name : comp_typ renames _object.comp_name; 5676 -- J : constant Jnn := 5677 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First)); 5678 5679 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 5680 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5681 Debug_Nod := Debug_Renaming_Declaration (Decl); 5682 5683 if Present (Debug_Nod) then 5684 Insert_After (Decl, Debug_Nod); 5685 end if; 5686 end if; 5687 5688 Next (Decl); 5689 end loop; 5690 end Debug_Private_Data_Declarations; 5691 5692 ------------------------------ 5693 -- Ensure_Statement_Present -- 5694 ------------------------------ 5695 5696 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is 5697 Stmt : Node_Id; 5698 5699 begin 5700 if Opt.Suppress_Control_Flow_Optimizations 5701 and then Is_Empty_List (Statements (Alt)) 5702 then 5703 Stmt := Make_Null_Statement (Loc); 5704 5705 -- Mark NULL statement as coming from source so that it is not 5706 -- eliminated by GIGI. 5707 5708 -- Another covert channel. If this is a requirement, it must be 5709 -- documented in sinfo/einfo ??? 5710 5711 Set_Comes_From_Source (Stmt, True); 5712 5713 Set_Statements (Alt, New_List (Stmt)); 5714 end if; 5715 end Ensure_Statement_Present; 5716 5717 ---------------------------- 5718 -- Entry_Index_Expression -- 5719 ---------------------------- 5720 5721 function Entry_Index_Expression 5722 (Sloc : Source_Ptr; 5723 Ent : Entity_Id; 5724 Index : Node_Id; 5725 Ttyp : Entity_Id) return Node_Id 5726 is 5727 Expr : Node_Id; 5728 Num : Node_Id; 5729 Lo : Node_Id; 5730 Hi : Node_Id; 5731 Prev : Entity_Id; 5732 S : Node_Id; 5733 5734 begin 5735 -- The queues of entries and entry families appear in textual order in 5736 -- the associated record. The entry index is computed as the sum of the 5737 -- number of queues for all entries that precede the designated one, to 5738 -- which is added the index expression, if this expression denotes a 5739 -- member of a family. 5740 5741 -- The following is a place holder for the count of simple entries 5742 5743 Num := Make_Integer_Literal (Sloc, 1); 5744 5745 -- We construct an expression which is a series of addition operations. 5746 -- The first operand is the number of single entries that precede this 5747 -- one, the second operand is the index value relative to the start of 5748 -- the referenced family, and the remaining operands are the lengths of 5749 -- the entry families that precede this entry, i.e. the constructed 5750 -- expression is: 5751 5752 -- number_simple_entries + 5753 -- (s'pos (index-value) - s'pos (family'first)) + 1 + 5754 -- family'length + ... 5755 5756 -- where index-value is the given index value, and s is the index 5757 -- subtype (we have to use pos because the subtype might be an 5758 -- enumeration type preventing direct subtraction). Note that the task 5759 -- entry array is one-indexed. 5760 5761 -- The upper bound of the entry family may be a discriminant, so we 5762 -- retrieve the lower bound explicitly to compute offset, rather than 5763 -- using the index subtype which may mention a discriminant. 5764 5765 if Present (Index) then 5766 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); 5767 5768 Expr := 5769 Make_Op_Add (Sloc, 5770 Left_Opnd => Num, 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 := Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); 5798 Lo := Type_Low_Bound (S); 5799 Hi := Type_High_Bound (S); 5800 5801 Expr := 5802 Make_Op_Add (Sloc, 5803 Left_Opnd => Expr, 5804 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False)); 5805 5806 -- Other components are anonymous types to be ignored 5807 5808 else 5809 null; 5810 end if; 5811 5812 Next_Entity (Prev); 5813 end loop; 5814 5815 return Expr; 5816 end Entry_Index_Expression; 5817 5818 --------------------------- 5819 -- Establish_Task_Master -- 5820 --------------------------- 5821 5822 procedure Establish_Task_Master (N : Node_Id) is 5823 Call : Node_Id; 5824 5825 begin 5826 if Restriction_Active (No_Task_Hierarchy) = False then 5827 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master); 5828 5829 -- The block may have no declarations (and nevertheless be a task 5830 -- master) if it contains a call that may return an object that 5831 -- contains tasks. 5832 5833 if No (Declarations (N)) then 5834 Set_Declarations (N, New_List (Call)); 5835 else 5836 Prepend_To (Declarations (N), Call); 5837 end if; 5838 5839 Analyze (Call); 5840 end if; 5841 end Establish_Task_Master; 5842 5843 -------------------------------- 5844 -- Expand_Accept_Declarations -- 5845 -------------------------------- 5846 5847 -- Part of the expansion of an accept statement involves the creation of 5848 -- a declaration that can be referenced from the statement sequence of 5849 -- the accept: 5850 5851 -- Ann : Address; 5852 5853 -- This declaration is inserted immediately before the accept statement 5854 -- and it is important that it be inserted before the statements of the 5855 -- statement sequence are analyzed. Thus it would be too late to create 5856 -- this declaration in the Expand_N_Accept_Statement routine, which is 5857 -- why there is a separate procedure to be called directly from Sem_Ch9. 5858 5859 -- Ann is used to hold the address of the record containing the parameters 5860 -- (see Expand_N_Entry_Call for more details on how this record is built). 5861 -- References to the parameters do an unchecked conversion of this address 5862 -- to a pointer to the required record type, and then access the field that 5863 -- holds the value of the required parameter. The entity for the address 5864 -- variable is held as the top stack element (i.e. the last element) of the 5865 -- Accept_Address stack in the corresponding entry entity, and this element 5866 -- must be set in place before the statements are processed. 5867 5868 -- The above description applies to the case of a stand alone accept 5869 -- statement, i.e. one not appearing as part of a select alternative. 5870 5871 -- For the case of an accept that appears as part of a select alternative 5872 -- of a selective accept, we must still create the declaration right away, 5873 -- since Ann is needed immediately, but there is an important difference: 5874 5875 -- The declaration is inserted before the selective accept, not before 5876 -- the accept statement (which is not part of a list anyway, and so would 5877 -- not accommodate inserted declarations) 5878 5879 -- We only need one address variable for the entire selective accept. So 5880 -- the Ann declaration is created only for the first accept alternative, 5881 -- and subsequent accept alternatives reference the same Ann variable. 5882 5883 -- We can distinguish the two cases by seeing whether the accept statement 5884 -- is part of a list. If not, then it must be in an accept alternative. 5885 5886 -- To expand the requeue statement, a label is provided at the end of the 5887 -- accept statement or alternative of which it is a part, so that the 5888 -- statement can be skipped after the requeue is complete. This label is 5889 -- created here rather than during the expansion of the accept statement, 5890 -- because it will be needed by any requeue statements within the accept, 5891 -- which are expanded before the accept. 5892 5893 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is 5894 Loc : constant Source_Ptr := Sloc (N); 5895 Stats : constant Node_Id := Handled_Statement_Sequence (N); 5896 Ann : Entity_Id := Empty; 5897 Adecl : Node_Id; 5898 Lab : Node_Id; 5899 Ldecl : Node_Id; 5900 Ldecl2 : Node_Id; 5901 5902 begin 5903 if Expander_Active then 5904 5905 -- If we have no handled statement sequence, we may need to build 5906 -- a dummy sequence consisting of a null statement. This can be 5907 -- skipped if the trivial accept optimization is permitted. 5908 5909 if not Trivial_Accept_OK 5910 and then (No (Stats) or else Null_Statements (Statements (Stats))) 5911 then 5912 Set_Handled_Statement_Sequence (N, 5913 Make_Handled_Sequence_Of_Statements (Loc, 5914 Statements => New_List (Make_Null_Statement (Loc)))); 5915 end if; 5916 5917 -- Create and declare two labels to be placed at the end of the 5918 -- accept statement. The first label is used to allow requeues to 5919 -- skip the remainder of entry processing. The second label is used 5920 -- to skip the remainder of entry processing if the rendezvous 5921 -- completes in the middle of the accept body. 5922 5923 if Present (Handled_Statement_Sequence (N)) then 5924 declare 5925 Ent : Entity_Id; 5926 5927 begin 5928 Ent := Make_Temporary (Loc, 'L'); 5929 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 5930 Ldecl := 5931 Make_Implicit_Label_Declaration (Loc, 5932 Defining_Identifier => Ent, 5933 Label_Construct => Lab); 5934 Append (Lab, Statements (Handled_Statement_Sequence (N))); 5935 5936 Ent := Make_Temporary (Loc, 'L'); 5937 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 5938 Ldecl2 := 5939 Make_Implicit_Label_Declaration (Loc, 5940 Defining_Identifier => Ent, 5941 Label_Construct => Lab); 5942 Append (Lab, Statements (Handled_Statement_Sequence (N))); 5943 end; 5944 5945 else 5946 Ldecl := Empty; 5947 Ldecl2 := Empty; 5948 end if; 5949 5950 -- Case of stand alone accept statement 5951 5952 if Is_List_Member (N) then 5953 5954 if Present (Handled_Statement_Sequence (N)) then 5955 Ann := Make_Temporary (Loc, 'A'); 5956 5957 Adecl := 5958 Make_Object_Declaration (Loc, 5959 Defining_Identifier => Ann, 5960 Object_Definition => 5961 New_Occurrence_Of (RTE (RE_Address), Loc)); 5962 5963 Insert_Before_And_Analyze (N, Adecl); 5964 Insert_Before_And_Analyze (N, Ldecl); 5965 Insert_Before_And_Analyze (N, Ldecl2); 5966 end if; 5967 5968 -- Case of accept statement which is in an accept alternative 5969 5970 else 5971 declare 5972 Acc_Alt : constant Node_Id := Parent (N); 5973 Sel_Acc : constant Node_Id := Parent (Acc_Alt); 5974 Alt : Node_Id; 5975 5976 begin 5977 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative); 5978 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept); 5979 5980 -- ??? Consider a single label for select statements 5981 5982 if Present (Handled_Statement_Sequence (N)) then 5983 Prepend (Ldecl2, 5984 Statements (Handled_Statement_Sequence (N))); 5985 Analyze (Ldecl2); 5986 5987 Prepend (Ldecl, 5988 Statements (Handled_Statement_Sequence (N))); 5989 Analyze (Ldecl); 5990 end if; 5991 5992 -- Find first accept alternative of the selective accept. A 5993 -- valid selective accept must have at least one accept in it. 5994 5995 Alt := First (Select_Alternatives (Sel_Acc)); 5996 5997 while Nkind (Alt) /= N_Accept_Alternative loop 5998 Next (Alt); 5999 end loop; 6000 6001 -- If this is the first accept statement, then we have to 6002 -- create the Ann variable, as for the stand alone case, except 6003 -- that it is inserted before the selective accept. Similarly, 6004 -- a label for requeue expansion must be declared. 6005 6006 if N = Accept_Statement (Alt) then 6007 Ann := Make_Temporary (Loc, 'A'); 6008 Adecl := 6009 Make_Object_Declaration (Loc, 6010 Defining_Identifier => Ann, 6011 Object_Definition => 6012 New_Occurrence_Of (RTE (RE_Address), Loc)); 6013 6014 Insert_Before_And_Analyze (Sel_Acc, Adecl); 6015 6016 -- If this is not the first accept statement, then find the Ann 6017 -- variable allocated by the first accept and use it. 6018 6019 else 6020 Ann := 6021 Node (Last_Elmt (Accept_Address 6022 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))))); 6023 end if; 6024 end; 6025 end if; 6026 6027 -- Merge here with Ann either created or referenced, and Adecl 6028 -- pointing to the corresponding declaration. Remaining processing 6029 -- is the same for the two cases. 6030 6031 if Present (Ann) then 6032 Append_Elmt (Ann, Accept_Address (Ent)); 6033 Set_Debug_Info_Needed (Ann); 6034 end if; 6035 6036 -- Create renaming declarations for the entry formals. Each reference 6037 -- to a formal becomes a dereference of a component of the parameter 6038 -- block, whose address is held in Ann. These declarations are 6039 -- eventually inserted into the accept block, and analyzed there so 6040 -- that they have the proper scope for gdb and do not conflict with 6041 -- other declarations. 6042 6043 if Present (Parameter_Specifications (N)) 6044 and then Present (Handled_Statement_Sequence (N)) 6045 then 6046 declare 6047 Comp : Entity_Id; 6048 Decl : Node_Id; 6049 Formal : Entity_Id; 6050 New_F : Entity_Id; 6051 Renamed_Formal : Node_Id; 6052 6053 begin 6054 Push_Scope (Ent); 6055 Formal := First_Formal (Ent); 6056 6057 while Present (Formal) loop 6058 Comp := Entry_Component (Formal); 6059 New_F := Make_Defining_Identifier (Loc, Chars (Formal)); 6060 6061 Set_Etype (New_F, Etype (Formal)); 6062 Set_Scope (New_F, Ent); 6063 6064 -- Now we set debug info needed on New_F even though it does 6065 -- not come from source, so that the debugger will get the 6066 -- right information for these generated names. 6067 6068 Set_Debug_Info_Needed (New_F); 6069 6070 if Ekind (Formal) = E_In_Parameter then 6071 Set_Ekind (New_F, E_Constant); 6072 else 6073 Set_Ekind (New_F, E_Variable); 6074 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 6075 end if; 6076 6077 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 6078 6079 Renamed_Formal := 6080 Make_Selected_Component (Loc, 6081 Prefix => 6082 Unchecked_Convert_To ( 6083 Entry_Parameters_Type (Ent), 6084 New_Occurrence_Of (Ann, Loc)), 6085 Selector_Name => 6086 New_Occurrence_Of (Comp, Loc)); 6087 6088 Decl := 6089 Build_Renamed_Formal_Declaration 6090 (New_F, Formal, Comp, Renamed_Formal); 6091 6092 if No (Declarations (N)) then 6093 Set_Declarations (N, New_List); 6094 end if; 6095 6096 Append (Decl, Declarations (N)); 6097 Set_Renamed_Object (Formal, New_F); 6098 Next_Formal (Formal); 6099 end loop; 6100 6101 End_Scope; 6102 end; 6103 end if; 6104 end if; 6105 end Expand_Accept_Declarations; 6106 6107 --------------------------------------------- 6108 -- Expand_Access_Protected_Subprogram_Type -- 6109 --------------------------------------------- 6110 6111 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is 6112 Loc : constant Source_Ptr := Sloc (N); 6113 Comps : List_Id; 6114 T : constant Entity_Id := Defining_Identifier (N); 6115 D_T : constant Entity_Id := Designated_Type (T); 6116 D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D'); 6117 E_T : constant Entity_Id := Make_Temporary (Loc, 'E'); 6118 P_List : constant List_Id := Build_Protected_Spec 6119 (N, RTE (RE_Address), D_T, False); 6120 Decl1 : Node_Id; 6121 Decl2 : Node_Id; 6122 Def1 : Node_Id; 6123 6124 begin 6125 -- Create access to subprogram with full signature 6126 6127 if Etype (D_T) /= Standard_Void_Type then 6128 Def1 := 6129 Make_Access_Function_Definition (Loc, 6130 Parameter_Specifications => P_List, 6131 Result_Definition => 6132 Copy_Result_Type (Result_Definition (Type_Definition (N)))); 6133 6134 else 6135 Def1 := 6136 Make_Access_Procedure_Definition (Loc, 6137 Parameter_Specifications => P_List); 6138 end if; 6139 6140 Decl1 := 6141 Make_Full_Type_Declaration (Loc, 6142 Defining_Identifier => D_T2, 6143 Type_Definition => Def1); 6144 6145 Insert_After_And_Analyze (N, Decl1); 6146 6147 -- Associate the access to subprogram with its original access to 6148 -- protected subprogram type. Needed by the backend to know that this 6149 -- type corresponds with an access to protected subprogram type. 6150 6151 Set_Original_Access_Type (D_T2, T); 6152 6153 -- Create Equivalent_Type, a record with two components for an access to 6154 -- object and an access to subprogram. 6155 6156 Comps := New_List ( 6157 Make_Component_Declaration (Loc, 6158 Defining_Identifier => Make_Temporary (Loc, 'P'), 6159 Component_Definition => 6160 Make_Component_Definition (Loc, 6161 Aliased_Present => False, 6162 Subtype_Indication => 6163 New_Occurrence_Of (RTE (RE_Address), Loc))), 6164 6165 Make_Component_Declaration (Loc, 6166 Defining_Identifier => Make_Temporary (Loc, 'S'), 6167 Component_Definition => 6168 Make_Component_Definition (Loc, 6169 Aliased_Present => False, 6170 Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); 6171 6172 Decl2 := 6173 Make_Full_Type_Declaration (Loc, 6174 Defining_Identifier => E_T, 6175 Type_Definition => 6176 Make_Record_Definition (Loc, 6177 Component_List => 6178 Make_Component_List (Loc, Component_Items => Comps))); 6179 6180 Insert_After_And_Analyze (Decl1, Decl2); 6181 Set_Equivalent_Type (T, E_T); 6182 end Expand_Access_Protected_Subprogram_Type; 6183 6184 -------------------------- 6185 -- Expand_Entry_Barrier -- 6186 -------------------------- 6187 6188 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is 6189 Cond : constant Node_Id := 6190 Condition (Entry_Body_Formal_Part (N)); 6191 Prot : constant Entity_Id := Scope (Ent); 6192 Spec_Decl : constant Node_Id := Parent (Prot); 6193 Func : Entity_Id; 6194 B_F : Node_Id; 6195 Body_Decl : Node_Id; 6196 6197 function Is_Global_Entity (N : Node_Id) return Traverse_Result; 6198 -- Check whether entity in Barrier is external to protected type. 6199 -- If so, barrier may not be properly synchronized. 6200 6201 ---------------------- 6202 -- Is_Global_Entity -- 6203 ---------------------- 6204 6205 function Is_Global_Entity (N : Node_Id) return Traverse_Result is 6206 E : Entity_Id; 6207 S : Entity_Id; 6208 6209 begin 6210 if Is_Entity_Name (N) and then Present (Entity (N)) then 6211 E := Entity (N); 6212 S := Scope (E); 6213 6214 if Ekind (E) = E_Variable then 6215 if Scope (E) = Func then 6216 null; 6217 6218 -- A protected call from a barrier to another object is ok 6219 6220 elsif Ekind (Etype (E)) = E_Protected_Type then 6221 null; 6222 6223 -- If the variable is within the package body we consider 6224 -- this safe. This is a common (if dubious) idiom. 6225 6226 elsif S = Scope (Prot) 6227 and then Ekind_In (S, E_Package, E_Generic_Package) 6228 and then Nkind (Parent (E)) = N_Object_Declaration 6229 and then Nkind (Parent (Parent (E))) = N_Package_Body 6230 then 6231 null; 6232 6233 else 6234 Error_Msg_N ("potentially unsynchronized barrier??", N); 6235 Error_Msg_N ("\& should be private component of type??", N); 6236 end if; 6237 end if; 6238 end if; 6239 6240 return OK; 6241 end Is_Global_Entity; 6242 6243 procedure Check_Unprotected_Barrier is 6244 new Traverse_Proc (Is_Global_Entity); 6245 6246 -- Start of processing for Expand_Entry_Barrier 6247 6248 begin 6249 if No_Run_Time_Mode then 6250 Error_Msg_CRT ("entry barrier", N); 6251 return; 6252 end if; 6253 6254 -- The body of the entry barrier must be analyzed in the context of the 6255 -- protected object, but its scope is external to it, just as any other 6256 -- unprotected version of a protected operation. The specification has 6257 -- been produced when the protected type declaration was elaborated. We 6258 -- build the body, insert it in the enclosing scope, but analyze it in 6259 -- the current context. A more uniform approach would be to treat the 6260 -- barrier just as a protected function, and discard the protected 6261 -- version of it because it is never called. 6262 6263 if Expander_Active then 6264 B_F := Build_Barrier_Function (N, Ent, Prot); 6265 Func := Barrier_Function (Ent); 6266 Set_Corresponding_Spec (B_F, Func); 6267 6268 Body_Decl := Parent (Corresponding_Body (Spec_Decl)); 6269 6270 if Nkind (Parent (Body_Decl)) = N_Subunit then 6271 Body_Decl := Corresponding_Stub (Parent (Body_Decl)); 6272 end if; 6273 6274 Insert_Before_And_Analyze (Body_Decl, B_F); 6275 6276 Set_Discriminals (Spec_Decl); 6277 Set_Scope (Func, Scope (Prot)); 6278 6279 else 6280 Analyze_And_Resolve (Cond, Any_Boolean); 6281 end if; 6282 6283 -- The Ravenscar profile restricts barriers to simple variables declared 6284 -- within the protected object. We also allow Boolean constants, since 6285 -- these appear in several published examples and are also allowed by 6286 -- other compilers. 6287 6288 -- Note that after analysis variables in this context will be replaced 6289 -- by the corresponding prival, that is to say a renaming of a selected 6290 -- component of the form _Object.Var. If expansion is disabled, as 6291 -- within a generic, we check that the entity appears in the current 6292 -- scope. 6293 6294 if Is_Entity_Name (Cond) then 6295 6296 -- A small optimization of useless renamings. If the scope of the 6297 -- entity of the condition is not the barrier function, then the 6298 -- condition does not reference any of the generated renamings 6299 -- within the function. 6300 6301 if Expander_Active and then Scope (Entity (Cond)) /= Func then 6302 Set_Declarations (B_F, Empty_List); 6303 end if; 6304 6305 if Entity (Cond) = Standard_False 6306 or else 6307 Entity (Cond) = Standard_True 6308 then 6309 return; 6310 6311 elsif not Expander_Active 6312 and then Scope (Entity (Cond)) = Current_Scope 6313 then 6314 return; 6315 6316 -- Check for case of _object.all.field (note that the explicit 6317 -- dereference gets inserted by analyze/expand of _object.field) 6318 6319 elsif Present (Renamed_Object (Entity (Cond))) 6320 and then 6321 Nkind (Renamed_Object (Entity (Cond))) = N_Selected_Component 6322 and then 6323 Chars 6324 (Prefix 6325 (Prefix (Renamed_Object (Entity (Cond))))) = Name_uObject 6326 then 6327 return; 6328 end if; 6329 end if; 6330 6331 -- It is not a boolean variable or literal, so check the restriction. 6332 -- Note that it is safe to be calling Check_Restriction from here, even 6333 -- though this is part of the expander, since Expand_Entry_Barrier is 6334 -- called from Sem_Ch9 even in -gnatc mode. 6335 6336 Check_Restriction (Simple_Barriers, Cond); 6337 6338 -- Emit warning if barrier contains global entities and is thus 6339 -- potentially unsynchronized. 6340 6341 Check_Unprotected_Barrier (Cond); 6342 end Expand_Entry_Barrier; 6343 6344 ------------------------------ 6345 -- Expand_N_Abort_Statement -- 6346 ------------------------------ 6347 6348 -- Expand abort T1, T2, .. Tn; into: 6349 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...)) 6350 6351 procedure Expand_N_Abort_Statement (N : Node_Id) is 6352 Loc : constant Source_Ptr := Sloc (N); 6353 Tlist : constant List_Id := Names (N); 6354 Count : Nat; 6355 Aggr : Node_Id; 6356 Tasknm : Node_Id; 6357 6358 begin 6359 Aggr := Make_Aggregate (Loc, Component_Associations => New_List); 6360 Count := 0; 6361 6362 Tasknm := First (Tlist); 6363 6364 while Present (Tasknm) loop 6365 Count := Count + 1; 6366 6367 -- A task interface class-wide type object is being aborted. Retrieve 6368 -- its _task_id by calling a dispatching routine. 6369 6370 if Ada_Version >= Ada_2005 6371 and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type 6372 and then Is_Interface (Etype (Tasknm)) 6373 and then Is_Task_Interface (Etype (Tasknm)) 6374 then 6375 Append_To (Component_Associations (Aggr), 6376 Make_Component_Association (Loc, 6377 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6378 Expression => 6379 6380 -- Task_Id (Tasknm._disp_get_task_id) 6381 6382 Make_Unchecked_Type_Conversion (Loc, 6383 Subtype_Mark => 6384 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 6385 Expression => 6386 Make_Selected_Component (Loc, 6387 Prefix => New_Copy_Tree (Tasknm), 6388 Selector_Name => 6389 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))); 6390 6391 else 6392 Append_To (Component_Associations (Aggr), 6393 Make_Component_Association (Loc, 6394 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6395 Expression => Concurrent_Ref (Tasknm))); 6396 end if; 6397 6398 Next (Tasknm); 6399 end loop; 6400 6401 Rewrite (N, 6402 Make_Procedure_Call_Statement (Loc, 6403 Name => New_Occurrence_Of (RTE (RE_Abort_Tasks), Loc), 6404 Parameter_Associations => New_List ( 6405 Make_Qualified_Expression (Loc, 6406 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_List), Loc), 6407 Expression => Aggr)))); 6408 6409 Analyze (N); 6410 end Expand_N_Abort_Statement; 6411 6412 ------------------------------- 6413 -- Expand_N_Accept_Statement -- 6414 ------------------------------- 6415 6416 -- This procedure handles expansion of accept statements that stand alone, 6417 -- i.e. they are not part of an accept alternative. The expansion of 6418 -- accept statement in accept alternatives is handled by the routines 6419 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The 6420 -- following description applies only to stand alone accept statements. 6421 6422 -- If there is no handled statement sequence, or only null statements, then 6423 -- this is called a trivial accept, and the expansion is: 6424 6425 -- Accept_Trivial (entry-index) 6426 6427 -- If there is a handled statement sequence, then the expansion is: 6428 6429 -- Ann : Address; 6430 -- {Lnn : Label} 6431 6432 -- begin 6433 -- begin 6434 -- Accept_Call (entry-index, Ann); 6435 -- Renaming_Declarations for formals 6436 -- <statement sequence from N_Accept_Statement node> 6437 -- Complete_Rendezvous; 6438 -- <<Lnn>> 6439 -- 6440 -- exception 6441 -- when ... => 6442 -- <exception handler from N_Accept_Statement node> 6443 -- Complete_Rendezvous; 6444 -- when ... => 6445 -- <exception handler from N_Accept_Statement node> 6446 -- Complete_Rendezvous; 6447 -- ... 6448 -- end; 6449 6450 -- exception 6451 -- when all others => 6452 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 6453 -- end; 6454 6455 -- The first three declarations were already inserted ahead of the accept 6456 -- statement by the Expand_Accept_Declarations procedure, which was called 6457 -- directly from the semantics during analysis of the accept statement, 6458 -- before analyzing its contained statements. 6459 6460 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come 6461 -- from possible expansion activity (the original source of course does 6462 -- not have any declarations associated with the accept statement, since 6463 -- an accept statement has no declarative part). In particular, if the 6464 -- expander is active, the first such declaration is the declaration of 6465 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement). 6466 6467 -- The two blocks are merged into a single block if the inner block has 6468 -- no exception handlers, but otherwise two blocks are required, since 6469 -- exceptions might be raised in the exception handlers of the inner 6470 -- block, and Exceptional_Complete_Rendezvous must be called. 6471 6472 procedure Expand_N_Accept_Statement (N : Node_Id) is 6473 Loc : constant Source_Ptr := Sloc (N); 6474 Stats : constant Node_Id := Handled_Statement_Sequence (N); 6475 Ename : constant Node_Id := Entry_Direct_Name (N); 6476 Eindx : constant Node_Id := Entry_Index (N); 6477 Eent : constant Entity_Id := Entity (Ename); 6478 Acstack : constant Elist_Id := Accept_Address (Eent); 6479 Ann : constant Entity_Id := Node (Last_Elmt (Acstack)); 6480 Ttyp : constant Entity_Id := Etype (Scope (Eent)); 6481 Blkent : Entity_Id; 6482 Call : Node_Id; 6483 Block : Node_Id; 6484 6485 begin 6486 -- If the accept statement is not part of a list, then its parent must 6487 -- be an accept alternative, and, as described above, we do not do any 6488 -- expansion for such accept statements at this level. 6489 6490 if not Is_List_Member (N) then 6491 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative); 6492 return; 6493 6494 -- Trivial accept case (no statement sequence, or null statements). 6495 -- If the accept statement has declarations, then just insert them 6496 -- before the procedure call. 6497 6498 elsif Trivial_Accept_OK 6499 and then (No (Stats) or else Null_Statements (Statements (Stats))) 6500 then 6501 -- Remove declarations for renamings, because the parameter block 6502 -- will not be assigned. 6503 6504 declare 6505 D : Node_Id; 6506 Next_D : Node_Id; 6507 6508 begin 6509 D := First (Declarations (N)); 6510 while Present (D) loop 6511 Next_D := Next (D); 6512 if Nkind (D) = N_Object_Renaming_Declaration then 6513 Remove (D); 6514 end if; 6515 6516 D := Next_D; 6517 end loop; 6518 end; 6519 6520 if Present (Declarations (N)) then 6521 Insert_Actions (N, Declarations (N)); 6522 end if; 6523 6524 Rewrite (N, 6525 Make_Procedure_Call_Statement (Loc, 6526 Name => New_Occurrence_Of (RTE (RE_Accept_Trivial), Loc), 6527 Parameter_Associations => New_List ( 6528 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp)))); 6529 6530 Analyze (N); 6531 6532 -- Discard Entry_Address that was created for it, so it will not be 6533 -- emitted if this accept statement is in the statement part of a 6534 -- delay alternative. 6535 6536 if Present (Stats) then 6537 Remove_Last_Elmt (Acstack); 6538 end if; 6539 6540 -- Case of statement sequence present 6541 6542 else 6543 -- Construct the block, using the declarations from the accept 6544 -- statement if any to initialize the declarations of the block. 6545 6546 Blkent := Make_Temporary (Loc, 'A'); 6547 Set_Ekind (Blkent, E_Block); 6548 Set_Etype (Blkent, Standard_Void_Type); 6549 Set_Scope (Blkent, Current_Scope); 6550 6551 Block := 6552 Make_Block_Statement (Loc, 6553 Identifier => New_Occurrence_Of (Blkent, Loc), 6554 Declarations => Declarations (N), 6555 Handled_Statement_Sequence => Build_Accept_Body (N)); 6556 6557 -- For the analysis of the generated declarations, the parent node 6558 -- must be properly set. 6559 6560 Set_Parent (Block, Parent (N)); 6561 6562 -- Prepend call to Accept_Call to main statement sequence If the 6563 -- accept has exception handlers, the statement sequence is wrapped 6564 -- in a block. Insert call and renaming declarations in the 6565 -- declarations of the block, so they are elaborated before the 6566 -- handlers. 6567 6568 Call := 6569 Make_Procedure_Call_Statement (Loc, 6570 Name => New_Occurrence_Of (RTE (RE_Accept_Call), Loc), 6571 Parameter_Associations => New_List ( 6572 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp), 6573 New_Occurrence_Of (Ann, Loc))); 6574 6575 if Parent (Stats) = N then 6576 Prepend (Call, Statements (Stats)); 6577 else 6578 Set_Declarations (Parent (Stats), New_List (Call)); 6579 end if; 6580 6581 Analyze (Call); 6582 6583 Push_Scope (Blkent); 6584 6585 declare 6586 D : Node_Id; 6587 Next_D : Node_Id; 6588 Typ : Entity_Id; 6589 6590 begin 6591 D := First (Declarations (N)); 6592 while Present (D) loop 6593 Next_D := Next (D); 6594 6595 if Nkind (D) = N_Object_Renaming_Declaration then 6596 6597 -- The renaming declarations for the formals were created 6598 -- during analysis of the accept statement, and attached to 6599 -- the list of declarations. Place them now in the context 6600 -- of the accept block or subprogram. 6601 6602 Remove (D); 6603 Typ := Entity (Subtype_Mark (D)); 6604 Insert_After (Call, D); 6605 Analyze (D); 6606 6607 -- If the formal is class_wide, it does not have an actual 6608 -- subtype. The analysis of the renaming declaration creates 6609 -- one, but we need to retain the class-wide nature of the 6610 -- entity. 6611 6612 if Is_Class_Wide_Type (Typ) then 6613 Set_Etype (Defining_Identifier (D), Typ); 6614 end if; 6615 6616 end if; 6617 6618 D := Next_D; 6619 end loop; 6620 end; 6621 6622 End_Scope; 6623 6624 -- Replace the accept statement by the new block 6625 6626 Rewrite (N, Block); 6627 Analyze (N); 6628 6629 -- Last step is to unstack the Accept_Address value 6630 6631 Remove_Last_Elmt (Acstack); 6632 end if; 6633 end Expand_N_Accept_Statement; 6634 6635 ---------------------------------- 6636 -- Expand_N_Asynchronous_Select -- 6637 ---------------------------------- 6638 6639 -- This procedure assumes that the trigger statement is an entry call or 6640 -- a dispatching procedure call. A delay alternative should already have 6641 -- been expanded into an entry call to the appropriate delay object Wait 6642 -- entry. 6643 6644 -- If the trigger is a task entry call, the select is implemented with 6645 -- a Task_Entry_Call: 6646 6647 -- declare 6648 -- B : Boolean; 6649 -- C : Boolean; 6650 -- P : parms := (parm, parm, parm); 6651 6652 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6653 6654 -- procedure _clean is 6655 -- begin 6656 -- ... 6657 -- Cancel_Task_Entry_Call (C); 6658 -- ... 6659 -- end _clean; 6660 6661 -- begin 6662 -- Abort_Defer; 6663 -- Task_Entry_Call 6664 -- (<acceptor-task>, -- Acceptor 6665 -- <entry-index>, -- E 6666 -- P'Address, -- Uninterpreted_Data 6667 -- Asynchronous_Call, -- Mode 6668 -- B); -- Rendezvous_Successful 6669 6670 -- begin 6671 -- begin 6672 -- Abort_Undefer; 6673 -- <abortable-part> 6674 -- at end 6675 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6676 -- end; 6677 -- exception 6678 -- when Abort_Signal => Abort_Undefer; 6679 -- end; 6680 6681 -- parm := P.param; 6682 -- parm := P.param; 6683 -- ... 6684 -- if not C then 6685 -- <triggered-statements> 6686 -- end if; 6687 -- end; 6688 6689 -- Note that Build_Simple_Entry_Call is used to expand the entry of the 6690 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure) 6691 -- as follows: 6692 6693 -- declare 6694 -- P : parms := (parm, parm, parm); 6695 -- begin 6696 -- Call_Simple (acceptor-task, entry-index, P'Address); 6697 -- parm := P.param; 6698 -- parm := P.param; 6699 -- ... 6700 -- end; 6701 6702 -- so the task at hand is to convert the latter expansion into the former 6703 6704 -- If the trigger is a protected entry call, the select is implemented 6705 -- with Protected_Entry_Call: 6706 6707 -- declare 6708 -- P : E1_Params := (param, param, param); 6709 -- Bnn : Communications_Block; 6710 6711 -- begin 6712 -- declare 6713 6714 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6715 6716 -- procedure _clean is 6717 -- begin 6718 -- ... 6719 -- if Enqueued (Bnn) then 6720 -- Cancel_Protected_Entry_Call (Bnn); 6721 -- end if; 6722 -- ... 6723 -- end _clean; 6724 6725 -- begin 6726 -- begin 6727 -- Protected_Entry_Call 6728 -- (po._object'Access, -- Object 6729 -- <entry index>, -- E 6730 -- P'Address, -- Uninterpreted_Data 6731 -- Asynchronous_Call, -- Mode 6732 -- Bnn); -- Block 6733 6734 -- if Enqueued (Bnn) then 6735 -- <abortable-part> 6736 -- end if; 6737 -- at end 6738 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6739 -- end; 6740 -- exception 6741 -- when Abort_Signal => Abort_Undefer; 6742 -- end; 6743 6744 -- if not Cancelled (Bnn) then 6745 -- <triggered-statements> 6746 -- end if; 6747 -- end; 6748 6749 -- Build_Simple_Entry_Call is used to expand the all to a simple protected 6750 -- entry call: 6751 6752 -- declare 6753 -- P : E1_Params := (param, param, param); 6754 -- Bnn : Communications_Block; 6755 6756 -- begin 6757 -- Protected_Entry_Call 6758 -- (po._object'Access, -- Object 6759 -- <entry index>, -- E 6760 -- P'Address, -- Uninterpreted_Data 6761 -- Simple_Call, -- Mode 6762 -- Bnn); -- Block 6763 -- parm := P.param; 6764 -- parm := P.param; 6765 -- ... 6766 -- end; 6767 6768 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is 6769 -- expanded into: 6770 6771 -- declare 6772 -- B : Boolean := False; 6773 -- Bnn : Communication_Block; 6774 -- C : Ada.Tags.Prim_Op_Kind; 6775 -- D : System.Storage_Elements.Dummy_Communication_Block; 6776 -- K : Ada.Tags.Tagged_Kind := 6777 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 6778 -- P : Parameters := (Param1 .. ParamN); 6779 -- S : Integer; 6780 -- U : Boolean; 6781 6782 -- begin 6783 -- if K = Ada.Tags.TK_Limited_Tagged 6784 -- or else K = Ada.Tags.TK_Tagged 6785 -- then 6786 -- <dispatching-call>; 6787 -- <triggering-statements>; 6788 6789 -- else 6790 -- S := 6791 -- Ada.Tags.Get_Offset_Index 6792 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 6793 6794 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 6795 6796 -- if C = POK_Protected_Entry then 6797 -- declare 6798 -- procedure _clean is 6799 -- begin 6800 -- if Enqueued (Bnn) then 6801 -- Cancel_Protected_Entry_Call (Bnn); 6802 -- end if; 6803 -- end _clean; 6804 6805 -- begin 6806 -- begin 6807 -- _Disp_Asynchronous_Select 6808 -- (<object>, S, P'Address, D, B); 6809 -- Bnn := Communication_Block (D); 6810 6811 -- Param1 := P.Param1; 6812 -- ... 6813 -- ParamN := P.ParamN; 6814 6815 -- if Enqueued (Bnn) then 6816 -- <abortable-statements> 6817 -- end if; 6818 -- at end 6819 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6820 -- end; 6821 -- exception 6822 -- when Abort_Signal => Abort_Undefer; 6823 -- end; 6824 6825 -- if not Cancelled (Bnn) then 6826 -- <triggering-statements> 6827 -- end if; 6828 6829 -- elsif C = POK_Task_Entry then 6830 -- declare 6831 -- procedure _clean is 6832 -- begin 6833 -- Cancel_Task_Entry_Call (U); 6834 -- end _clean; 6835 6836 -- begin 6837 -- Abort_Defer; 6838 6839 -- _Disp_Asynchronous_Select 6840 -- (<object>, S, P'Address, D, B); 6841 -- Bnn := Communication_Bloc (D); 6842 6843 -- Param1 := P.Param1; 6844 -- ... 6845 -- ParamN := P.ParamN; 6846 6847 -- begin 6848 -- begin 6849 -- Abort_Undefer; 6850 -- <abortable-statements> 6851 -- at end 6852 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6853 -- end; 6854 -- exception 6855 -- when Abort_Signal => Abort_Undefer; 6856 -- end; 6857 6858 -- if not U then 6859 -- <triggering-statements> 6860 -- end if; 6861 -- end; 6862 6863 -- else 6864 -- <dispatching-call>; 6865 -- <triggering-statements> 6866 -- end if; 6867 -- end if; 6868 -- end; 6869 6870 -- The job is to convert this to the asynchronous form 6871 6872 -- If the trigger is a delay statement, it will have been expanded into 6873 -- a call to one of the GNARL delay procedures. This routine will convert 6874 -- this into a protected entry call on a delay object and then continue 6875 -- processing as for a protected entry call trigger. This requires 6876 -- declaring a Delay_Block object and adding a pointer to this object to 6877 -- the parameter list of the delay procedure to form the parameter list of 6878 -- the entry call. This object is used by the runtime to queue the delay 6879 -- request. 6880 6881 -- For a description of the use of P and the assignments after the call, 6882 -- see Expand_N_Entry_Call_Statement. 6883 6884 procedure Expand_N_Asynchronous_Select (N : Node_Id) is 6885 Loc : constant Source_Ptr := Sloc (N); 6886 Abrt : constant Node_Id := Abortable_Part (N); 6887 Trig : constant Node_Id := Triggering_Alternative (N); 6888 6889 Abort_Block_Ent : Entity_Id; 6890 Abortable_Block : Node_Id; 6891 Actuals : List_Id; 6892 Astats : List_Id; 6893 Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A'); 6894 Blk_Typ : Entity_Id; 6895 Call : Node_Id; 6896 Call_Ent : Entity_Id; 6897 Cancel_Param : Entity_Id; 6898 Cleanup_Block : Node_Id; 6899 Cleanup_Block_Ent : Entity_Id; 6900 Cleanup_Stmts : List_Id; 6901 Conc_Typ_Stmts : List_Id; 6902 Concval : Node_Id; 6903 Dblock_Ent : Entity_Id; 6904 Decl : Node_Id; 6905 Decls : List_Id; 6906 Ecall : Node_Id; 6907 Ename : Node_Id; 6908 Enqueue_Call : Node_Id; 6909 Formals : List_Id; 6910 Hdle : List_Id; 6911 Handler_Stmt : Node_Id; 6912 Index : Node_Id; 6913 Lim_Typ_Stmts : List_Id; 6914 N_Orig : Node_Id; 6915 Obj : Entity_Id; 6916 Param : Node_Id; 6917 Params : List_Id; 6918 Pdef : Entity_Id; 6919 ProtE_Stmts : List_Id; 6920 ProtP_Stmts : List_Id; 6921 Stmt : Node_Id; 6922 Stmts : List_Id; 6923 TaskE_Stmts : List_Id; 6924 Tstats : List_Id; 6925 6926 B : Entity_Id; -- Call status flag 6927 Bnn : Entity_Id; -- Communication block 6928 C : Entity_Id; -- Call kind 6929 K : Entity_Id; -- Tagged kind 6930 P : Entity_Id; -- Parameter block 6931 S : Entity_Id; -- Primitive operation slot 6932 T : Entity_Id; -- Additional status flag 6933 6934 procedure Rewrite_Abortable_Part; 6935 -- If the trigger is a dispatching call, the expansion inserts multiple 6936 -- copies of the abortable part. This is both inefficient, and may lead 6937 -- to duplicate definitions that the back-end will reject, when the 6938 -- abortable part includes loops. This procedure rewrites the abortable 6939 -- part into a call to a generated procedure. 6940 6941 ---------------------------- 6942 -- Rewrite_Abortable_Part -- 6943 ---------------------------- 6944 6945 procedure Rewrite_Abortable_Part is 6946 Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 6947 Decl : Node_Id; 6948 6949 begin 6950 Decl := 6951 Make_Subprogram_Body (Loc, 6952 Specification => 6953 Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc), 6954 Declarations => New_List, 6955 Handled_Statement_Sequence => 6956 Make_Handled_Sequence_Of_Statements (Loc, Astats)); 6957 Insert_Before (N, Decl); 6958 Analyze (Decl); 6959 6960 -- Rewrite abortable part into a call to this procedure. 6961 6962 Astats := 6963 New_List ( 6964 Make_Procedure_Call_Statement (Loc, 6965 Name => New_Occurrence_Of (Proc, Loc))); 6966 end Rewrite_Abortable_Part; 6967 6968 begin 6969 Process_Statements_For_Controlled_Objects (Trig); 6970 Process_Statements_For_Controlled_Objects (Abrt); 6971 6972 Ecall := Triggering_Statement (Trig); 6973 6974 Ensure_Statement_Present (Sloc (Ecall), Trig); 6975 6976 -- Retrieve Astats and Tstats now because the finalization machinery may 6977 -- wrap them in blocks. 6978 6979 Astats := Statements (Abrt); 6980 Tstats := Statements (Trig); 6981 6982 -- The arguments in the call may require dynamic allocation, and the 6983 -- call statement may have been transformed into a block. The block 6984 -- may contain additional declarations for internal entities, and the 6985 -- original call is found by sequential search. 6986 6987 if Nkind (Ecall) = N_Block_Statement then 6988 Ecall := First (Statements (Handled_Statement_Sequence (Ecall))); 6989 while not Nkind_In (Ecall, N_Procedure_Call_Statement, 6990 N_Entry_Call_Statement) 6991 loop 6992 Next (Ecall); 6993 end loop; 6994 end if; 6995 6996 -- This is either a dispatching call or a delay statement used as a 6997 -- trigger which was expanded into a procedure call. 6998 6999 if Nkind (Ecall) = N_Procedure_Call_Statement then 7000 if Ada_Version >= Ada_2005 7001 and then 7002 (No (Original_Node (Ecall)) 7003 or else not Nkind_In (Original_Node (Ecall), 7004 N_Delay_Relative_Statement, 7005 N_Delay_Until_Statement)) 7006 then 7007 Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals); 7008 7009 Rewrite_Abortable_Part; 7010 Decls := New_List; 7011 Stmts := New_List; 7012 7013 -- Call status flag processing, generate: 7014 -- B : Boolean := False; 7015 7016 B := Build_B (Loc, Decls); 7017 7018 -- Communication block processing, generate: 7019 -- Bnn : Communication_Block; 7020 7021 Bnn := Make_Temporary (Loc, 'B'); 7022 Append_To (Decls, 7023 Make_Object_Declaration (Loc, 7024 Defining_Identifier => Bnn, 7025 Object_Definition => 7026 New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); 7027 7028 -- Call kind processing, generate: 7029 -- C : Ada.Tags.Prim_Op_Kind; 7030 7031 C := Build_C (Loc, Decls); 7032 7033 -- Tagged kind processing, generate: 7034 -- K : Ada.Tags.Tagged_Kind := 7035 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7036 7037 -- Dummy communication block, generate: 7038 -- D : Dummy_Communication_Block; 7039 7040 Append_To (Decls, 7041 Make_Object_Declaration (Loc, 7042 Defining_Identifier => 7043 Make_Defining_Identifier (Loc, Name_uD), 7044 Object_Definition => 7045 New_Occurrence_Of 7046 (RTE (RE_Dummy_Communication_Block), Loc))); 7047 7048 K := Build_K (Loc, Decls, Obj); 7049 7050 -- Parameter block processing 7051 7052 Blk_Typ := Build_Parameter_Block 7053 (Loc, Actuals, Formals, Decls); 7054 P := Parameter_Block_Pack 7055 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 7056 7057 -- Dispatch table slot processing, generate: 7058 -- S : Integer; 7059 7060 S := Build_S (Loc, Decls); 7061 7062 -- Additional status flag processing, generate: 7063 -- Tnn : Boolean; 7064 7065 T := Make_Temporary (Loc, 'T'); 7066 Append_To (Decls, 7067 Make_Object_Declaration (Loc, 7068 Defining_Identifier => T, 7069 Object_Definition => 7070 New_Occurrence_Of (Standard_Boolean, Loc))); 7071 7072 ------------------------------ 7073 -- Protected entry handling -- 7074 ------------------------------ 7075 7076 -- Generate: 7077 -- Param1 := P.Param1; 7078 -- ... 7079 -- ParamN := P.ParamN; 7080 7081 Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7082 7083 -- Generate: 7084 -- Bnn := Communication_Block (D); 7085 7086 Prepend_To (Cleanup_Stmts, 7087 Make_Assignment_Statement (Loc, 7088 Name => New_Occurrence_Of (Bnn, Loc), 7089 Expression => 7090 Make_Unchecked_Type_Conversion (Loc, 7091 Subtype_Mark => 7092 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7093 Expression => Make_Identifier (Loc, Name_uD)))); 7094 7095 -- Generate: 7096 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7097 7098 Prepend_To (Cleanup_Stmts, 7099 Make_Procedure_Call_Statement (Loc, 7100 Name => 7101 New_Occurrence_Of 7102 (Find_Prim_Op 7103 (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select), 7104 Loc), 7105 Parameter_Associations => 7106 New_List ( 7107 New_Copy_Tree (Obj), -- <object> 7108 New_Occurrence_Of (S, Loc), -- S 7109 Make_Attribute_Reference (Loc, -- P'Address 7110 Prefix => New_Occurrence_Of (P, Loc), 7111 Attribute_Name => Name_Address), 7112 Make_Identifier (Loc, Name_uD), -- D 7113 New_Occurrence_Of (B, Loc)))); -- B 7114 7115 -- Generate: 7116 -- if Enqueued (Bnn) then 7117 -- <abortable-statements> 7118 -- end if; 7119 7120 Append_To (Cleanup_Stmts, 7121 Make_Implicit_If_Statement (N, 7122 Condition => 7123 Make_Function_Call (Loc, 7124 Name => 7125 New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7126 Parameter_Associations => 7127 New_List (New_Occurrence_Of (Bnn, Loc))), 7128 7129 Then_Statements => 7130 New_Copy_List_Tree (Astats))); 7131 7132 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7133 -- will then generate a _clean for the communication block Bnn. 7134 7135 -- Generate: 7136 -- declare 7137 -- procedure _clean is 7138 -- begin 7139 -- if Enqueued (Bnn) then 7140 -- Cancel_Protected_Entry_Call (Bnn); 7141 -- end if; 7142 -- end _clean; 7143 -- begin 7144 -- Cleanup_Stmts 7145 -- at end 7146 -- _clean; 7147 -- end; 7148 7149 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7150 Cleanup_Block := 7151 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn); 7152 7153 -- Wrap the cleanup block in an exception handling block 7154 7155 -- Generate: 7156 -- begin 7157 -- Cleanup_Block 7158 -- exception 7159 -- when Abort_Signal => Abort_Undefer; 7160 -- end; 7161 7162 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7163 ProtE_Stmts := 7164 New_List ( 7165 Make_Implicit_Label_Declaration (Loc, 7166 Defining_Identifier => Abort_Block_Ent), 7167 7168 Build_Abort_Block 7169 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7170 7171 -- Generate: 7172 -- if not Cancelled (Bnn) then 7173 -- <triggering-statements> 7174 -- end if; 7175 7176 Append_To (ProtE_Stmts, 7177 Make_Implicit_If_Statement (N, 7178 Condition => 7179 Make_Op_Not (Loc, 7180 Right_Opnd => 7181 Make_Function_Call (Loc, 7182 Name => 7183 New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7184 Parameter_Associations => 7185 New_List (New_Occurrence_Of (Bnn, Loc)))), 7186 7187 Then_Statements => 7188 New_Copy_List_Tree (Tstats))); 7189 7190 ------------------------- 7191 -- Task entry handling -- 7192 ------------------------- 7193 7194 -- Generate: 7195 -- Param1 := P.Param1; 7196 -- ... 7197 -- ParamN := P.ParamN; 7198 7199 TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7200 7201 -- Generate: 7202 -- Bnn := Communication_Block (D); 7203 7204 Append_To (TaskE_Stmts, 7205 Make_Assignment_Statement (Loc, 7206 Name => 7207 New_Occurrence_Of (Bnn, Loc), 7208 Expression => 7209 Make_Unchecked_Type_Conversion (Loc, 7210 Subtype_Mark => 7211 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7212 Expression => Make_Identifier (Loc, Name_uD)))); 7213 7214 -- Generate: 7215 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7216 7217 Prepend_To (TaskE_Stmts, 7218 Make_Procedure_Call_Statement (Loc, 7219 Name => 7220 New_Occurrence_Of ( 7221 Find_Prim_Op (Etype (Etype (Obj)), 7222 Name_uDisp_Asynchronous_Select), 7223 Loc), 7224 7225 Parameter_Associations => 7226 New_List ( 7227 New_Copy_Tree (Obj), -- <object> 7228 New_Occurrence_Of (S, Loc), -- S 7229 Make_Attribute_Reference (Loc, -- P'Address 7230 Prefix => New_Occurrence_Of (P, Loc), 7231 Attribute_Name => Name_Address), 7232 Make_Identifier (Loc, Name_uD), -- D 7233 New_Occurrence_Of (B, Loc)))); -- B 7234 7235 -- Generate: 7236 -- Abort_Defer; 7237 7238 Prepend_To (TaskE_Stmts, 7239 Make_Procedure_Call_Statement (Loc, 7240 Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc), 7241 Parameter_Associations => No_List)); 7242 7243 -- Generate: 7244 -- Abort_Undefer; 7245 -- <abortable-statements> 7246 7247 Cleanup_Stmts := New_Copy_List_Tree (Astats); 7248 7249 Prepend_To (Cleanup_Stmts, 7250 Make_Procedure_Call_Statement (Loc, 7251 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), 7252 Parameter_Associations => No_List)); 7253 7254 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7255 -- will generate a _clean for the additional status flag. 7256 7257 -- Generate: 7258 -- declare 7259 -- procedure _clean is 7260 -- begin 7261 -- Cancel_Task_Entry_Call (U); 7262 -- end _clean; 7263 -- begin 7264 -- Cleanup_Stmts 7265 -- at end 7266 -- _clean; 7267 -- end; 7268 7269 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7270 Cleanup_Block := 7271 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T); 7272 7273 -- Wrap the cleanup block in an exception handling block 7274 7275 -- Generate: 7276 -- begin 7277 -- Cleanup_Block 7278 -- exception 7279 -- when Abort_Signal => Abort_Undefer; 7280 -- end; 7281 7282 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7283 7284 Append_To (TaskE_Stmts, 7285 Make_Implicit_Label_Declaration (Loc, 7286 Defining_Identifier => Abort_Block_Ent)); 7287 7288 Append_To (TaskE_Stmts, 7289 Build_Abort_Block 7290 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7291 7292 -- Generate: 7293 -- if not T then 7294 -- <triggering-statements> 7295 -- end if; 7296 7297 Append_To (TaskE_Stmts, 7298 Make_Implicit_If_Statement (N, 7299 Condition => 7300 Make_Op_Not (Loc, Right_Opnd => New_Occurrence_Of (T, Loc)), 7301 7302 Then_Statements => 7303 New_Copy_List_Tree (Tstats))); 7304 7305 ---------------------------------- 7306 -- Protected procedure handling -- 7307 ---------------------------------- 7308 7309 -- Generate: 7310 -- <dispatching-call>; 7311 -- <triggering-statements> 7312 7313 ProtP_Stmts := New_Copy_List_Tree (Tstats); 7314 Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall)); 7315 7316 -- Generate: 7317 -- S := Ada.Tags.Get_Offset_Index 7318 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 7319 7320 Conc_Typ_Stmts := 7321 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 7322 7323 -- Generate: 7324 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 7325 7326 Append_To (Conc_Typ_Stmts, 7327 Make_Procedure_Call_Statement (Loc, 7328 Name => 7329 New_Occurrence_Of 7330 (Find_Prim_Op (Etype (Etype (Obj)), 7331 Name_uDisp_Get_Prim_Op_Kind), 7332 Loc), 7333 Parameter_Associations => 7334 New_List ( 7335 New_Copy_Tree (Obj), 7336 New_Occurrence_Of (S, Loc), 7337 New_Occurrence_Of (C, Loc)))); 7338 7339 -- Generate: 7340 -- if C = POK_Procedure_Entry then 7341 -- ProtE_Stmts 7342 -- elsif C = POK_Task_Entry then 7343 -- TaskE_Stmts 7344 -- else 7345 -- ProtP_Stmts 7346 -- end if; 7347 7348 Append_To (Conc_Typ_Stmts, 7349 Make_Implicit_If_Statement (N, 7350 Condition => 7351 Make_Op_Eq (Loc, 7352 Left_Opnd => 7353 New_Occurrence_Of (C, Loc), 7354 Right_Opnd => 7355 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 7356 7357 Then_Statements => 7358 ProtE_Stmts, 7359 7360 Elsif_Parts => 7361 New_List ( 7362 Make_Elsif_Part (Loc, 7363 Condition => 7364 Make_Op_Eq (Loc, 7365 Left_Opnd => 7366 New_Occurrence_Of (C, Loc), 7367 Right_Opnd => 7368 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc)), 7369 7370 Then_Statements => 7371 TaskE_Stmts)), 7372 7373 Else_Statements => 7374 ProtP_Stmts)); 7375 7376 -- Generate: 7377 -- <dispatching-call>; 7378 -- <triggering-statements> 7379 7380 Lim_Typ_Stmts := New_Copy_List_Tree (Tstats); 7381 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall)); 7382 7383 -- Generate: 7384 -- if K = Ada.Tags.TK_Limited_Tagged 7385 -- or else K = Ada.Tags.TK_Tagged 7386 -- then 7387 -- Lim_Typ_Stmts 7388 -- else 7389 -- Conc_Typ_Stmts 7390 -- end if; 7391 7392 Append_To (Stmts, 7393 Make_Implicit_If_Statement (N, 7394 Condition => Build_Dispatching_Tag_Check (K, N), 7395 Then_Statements => Lim_Typ_Stmts, 7396 Else_Statements => Conc_Typ_Stmts)); 7397 7398 Rewrite (N, 7399 Make_Block_Statement (Loc, 7400 Declarations => 7401 Decls, 7402 Handled_Statement_Sequence => 7403 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7404 7405 Analyze (N); 7406 return; 7407 7408 -- Delay triggering statement processing 7409 7410 else 7411 -- Add a Delay_Block object to the parameter list of the delay 7412 -- procedure to form the parameter list of the Wait entry call. 7413 7414 Dblock_Ent := Make_Temporary (Loc, 'D'); 7415 7416 Pdef := Entity (Name (Ecall)); 7417 7418 if Is_RTE (Pdef, RO_CA_Delay_For) then 7419 Enqueue_Call := 7420 New_Occurrence_Of (RTE (RE_Enqueue_Duration), Loc); 7421 7422 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then 7423 Enqueue_Call := 7424 New_Occurrence_Of (RTE (RE_Enqueue_Calendar), Loc); 7425 7426 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); 7427 Enqueue_Call := New_Occurrence_Of (RTE (RE_Enqueue_RT), Loc); 7428 end if; 7429 7430 Append_To (Parameter_Associations (Ecall), 7431 Make_Attribute_Reference (Loc, 7432 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7433 Attribute_Name => Name_Unchecked_Access)); 7434 7435 -- Create the inner block to protect the abortable part 7436 7437 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7438 7439 Prepend_To (Astats, 7440 Make_Procedure_Call_Statement (Loc, 7441 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc))); 7442 7443 Abortable_Block := 7444 Make_Block_Statement (Loc, 7445 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7446 Handled_Statement_Sequence => 7447 Make_Handled_Sequence_Of_Statements (Loc, 7448 Statements => Astats), 7449 Has_Created_Identifier => True, 7450 Is_Asynchronous_Call_Block => True); 7451 7452 -- Append call to if Enqueue (When, DB'Unchecked_Access) then 7453 7454 Rewrite (Ecall, 7455 Make_Implicit_If_Statement (N, 7456 Condition => 7457 Make_Function_Call (Loc, 7458 Name => Enqueue_Call, 7459 Parameter_Associations => Parameter_Associations (Ecall)), 7460 Then_Statements => 7461 New_List (Make_Block_Statement (Loc, 7462 Handled_Statement_Sequence => 7463 Make_Handled_Sequence_Of_Statements (Loc, 7464 Statements => New_List ( 7465 Make_Implicit_Label_Declaration (Loc, 7466 Defining_Identifier => Blk_Ent, 7467 Label_Construct => Abortable_Block), 7468 Abortable_Block), 7469 Exception_Handlers => Hdle))))); 7470 7471 Stmts := New_List (Ecall); 7472 7473 -- Construct statement sequence for new block 7474 7475 Append_To (Stmts, 7476 Make_Implicit_If_Statement (N, 7477 Condition => 7478 Make_Function_Call (Loc, 7479 Name => New_Occurrence_Of ( 7480 RTE (RE_Timed_Out), Loc), 7481 Parameter_Associations => New_List ( 7482 Make_Attribute_Reference (Loc, 7483 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7484 Attribute_Name => Name_Unchecked_Access))), 7485 Then_Statements => Tstats)); 7486 7487 -- The result is the new block 7488 7489 Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent); 7490 7491 Rewrite (N, 7492 Make_Block_Statement (Loc, 7493 Declarations => New_List ( 7494 Make_Object_Declaration (Loc, 7495 Defining_Identifier => Dblock_Ent, 7496 Aliased_Present => True, 7497 Object_Definition => 7498 New_Occurrence_Of (RTE (RE_Delay_Block), Loc))), 7499 7500 Handled_Statement_Sequence => 7501 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7502 7503 Analyze (N); 7504 return; 7505 end if; 7506 7507 else 7508 N_Orig := N; 7509 end if; 7510 7511 Extract_Entry (Ecall, Concval, Ename, Index); 7512 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index); 7513 7514 Stmts := Statements (Handled_Statement_Sequence (Ecall)); 7515 Decls := Declarations (Ecall); 7516 7517 if Is_Protected_Type (Etype (Concval)) then 7518 7519 -- Get the declarations of the block expanded from the entry call 7520 7521 Decl := First (Decls); 7522 while Present (Decl) 7523 and then (Nkind (Decl) /= N_Object_Declaration 7524 or else not Is_RTE (Etype (Object_Definition (Decl)), 7525 RE_Communication_Block)) 7526 loop 7527 Next (Decl); 7528 end loop; 7529 7530 pragma Assert (Present (Decl)); 7531 Cancel_Param := Defining_Identifier (Decl); 7532 7533 -- Change the mode of the Protected_Entry_Call call 7534 7535 -- Protected_Entry_Call ( 7536 -- Object => po._object'Access, 7537 -- E => <entry index>; 7538 -- Uninterpreted_Data => P'Address; 7539 -- Mode => Asynchronous_Call; 7540 -- Block => Bnn); 7541 7542 -- Skip assignments to temporaries created for in-out parameters 7543 7544 -- This makes unwarranted assumptions about the shape of the expanded 7545 -- tree for the call, and should be cleaned up ??? 7546 7547 Stmt := First (Stmts); 7548 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7549 Next (Stmt); 7550 end loop; 7551 7552 Call := Stmt; 7553 7554 Param := First (Parameter_Associations (Call)); 7555 while Present (Param) 7556 and then not Is_RTE (Etype (Param), RE_Call_Modes) 7557 loop 7558 Next (Param); 7559 end loop; 7560 7561 pragma Assert (Present (Param)); 7562 Rewrite (Param, New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7563 Analyze (Param); 7564 7565 -- Append an if statement to execute the abortable part 7566 7567 -- Generate: 7568 -- if Enqueued (Bnn) then 7569 7570 Append_To (Stmts, 7571 Make_Implicit_If_Statement (N, 7572 Condition => 7573 Make_Function_Call (Loc, 7574 Name => New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7575 Parameter_Associations => New_List ( 7576 New_Occurrence_Of (Cancel_Param, Loc))), 7577 Then_Statements => Astats)); 7578 7579 Abortable_Block := 7580 Make_Block_Statement (Loc, 7581 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7582 Handled_Statement_Sequence => 7583 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts), 7584 Has_Created_Identifier => True, 7585 Is_Asynchronous_Call_Block => True); 7586 7587 -- For the VM call Update_Exception instead of Abort_Undefer. 7588 -- See 4jexcept.ads for an explanation. 7589 7590 if VM_Target = No_VM then 7591 if Exception_Mechanism = Back_End_Exceptions then 7592 7593 -- Aborts are not deferred at beginning of exception handlers 7594 -- in ZCX. 7595 7596 Handler_Stmt := Make_Null_Statement (Loc); 7597 7598 else 7599 Handler_Stmt := Make_Procedure_Call_Statement (Loc, 7600 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc), 7601 Parameter_Associations => No_List); 7602 end if; 7603 else 7604 Handler_Stmt := Make_Procedure_Call_Statement (Loc, 7605 Name => New_Occurrence_Of (RTE (RE_Update_Exception), Loc), 7606 Parameter_Associations => New_List ( 7607 Make_Function_Call (Loc, 7608 Name => New_Occurrence_Of 7609 (RTE (RE_Current_Target_Exception), Loc)))); 7610 end if; 7611 7612 Stmts := New_List ( 7613 Make_Block_Statement (Loc, 7614 Handled_Statement_Sequence => 7615 Make_Handled_Sequence_Of_Statements (Loc, 7616 Statements => New_List ( 7617 Make_Implicit_Label_Declaration (Loc, 7618 Defining_Identifier => Blk_Ent, 7619 Label_Construct => Abortable_Block), 7620 Abortable_Block), 7621 7622 -- exception 7623 7624 Exception_Handlers => New_List ( 7625 Make_Implicit_Exception_Handler (Loc, 7626 7627 -- when Abort_Signal => 7628 -- Abort_Undefer.all; 7629 7630 Exception_Choices => 7631 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)), 7632 Statements => New_List (Handler_Stmt))))), 7633 7634 -- if not Cancelled (Bnn) then 7635 -- triggered statements 7636 -- end if; 7637 7638 Make_Implicit_If_Statement (N, 7639 Condition => Make_Op_Not (Loc, 7640 Right_Opnd => 7641 Make_Function_Call (Loc, 7642 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7643 Parameter_Associations => New_List ( 7644 New_Occurrence_Of (Cancel_Param, Loc)))), 7645 Then_Statements => Tstats)); 7646 7647 -- Asynchronous task entry call 7648 7649 else 7650 if No (Decls) then 7651 Decls := New_List; 7652 end if; 7653 7654 B := Make_Defining_Identifier (Loc, Name_uB); 7655 7656 -- Insert declaration of B in declarations of existing block 7657 7658 Prepend_To (Decls, 7659 Make_Object_Declaration (Loc, 7660 Defining_Identifier => B, 7661 Object_Definition => 7662 New_Occurrence_Of (Standard_Boolean, Loc))); 7663 7664 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC); 7665 7666 -- Insert declaration of C in declarations of existing block 7667 7668 Prepend_To (Decls, 7669 Make_Object_Declaration (Loc, 7670 Defining_Identifier => Cancel_Param, 7671 Object_Definition => 7672 New_Occurrence_Of (Standard_Boolean, Loc))); 7673 7674 -- Remove and save the call to Call_Simple 7675 7676 Stmt := First (Stmts); 7677 7678 -- Skip assignments to temporaries created for in-out parameters. 7679 -- This makes unwarranted assumptions about the shape of the expanded 7680 -- tree for the call, and should be cleaned up ??? 7681 7682 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7683 Next (Stmt); 7684 end loop; 7685 7686 Call := Stmt; 7687 7688 -- Create the inner block to protect the abortable part 7689 7690 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7691 7692 Prepend_To (Astats, 7693 Make_Procedure_Call_Statement (Loc, 7694 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Loc))); 7695 7696 Abortable_Block := 7697 Make_Block_Statement (Loc, 7698 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7699 Handled_Statement_Sequence => 7700 Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats), 7701 Has_Created_Identifier => True, 7702 Is_Asynchronous_Call_Block => True); 7703 7704 Insert_After (Call, 7705 Make_Block_Statement (Loc, 7706 Handled_Statement_Sequence => 7707 Make_Handled_Sequence_Of_Statements (Loc, 7708 Statements => New_List ( 7709 Make_Implicit_Label_Declaration (Loc, 7710 Defining_Identifier => Blk_Ent, 7711 Label_Construct => Abortable_Block), 7712 Abortable_Block), 7713 Exception_Handlers => Hdle))); 7714 7715 -- Create new call statement 7716 7717 Params := Parameter_Associations (Call); 7718 7719 Append_To (Params, 7720 New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7721 Append_To (Params, New_Occurrence_Of (B, Loc)); 7722 7723 Rewrite (Call, 7724 Make_Procedure_Call_Statement (Loc, 7725 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 7726 Parameter_Associations => Params)); 7727 7728 -- Construct statement sequence for new block 7729 7730 Append_To (Stmts, 7731 Make_Implicit_If_Statement (N, 7732 Condition => 7733 Make_Op_Not (Loc, New_Occurrence_Of (Cancel_Param, Loc)), 7734 Then_Statements => Tstats)); 7735 7736 -- Protected the call against abort 7737 7738 Prepend_To (Stmts, 7739 Make_Procedure_Call_Statement (Loc, 7740 Name => New_Occurrence_Of (RTE (RE_Abort_Defer), Loc), 7741 Parameter_Associations => Empty_List)); 7742 end if; 7743 7744 Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param); 7745 7746 -- The result is the new block 7747 7748 Rewrite (N_Orig, 7749 Make_Block_Statement (Loc, 7750 Declarations => Decls, 7751 Handled_Statement_Sequence => 7752 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7753 7754 Analyze (N_Orig); 7755 end Expand_N_Asynchronous_Select; 7756 7757 ------------------------------------- 7758 -- Expand_N_Conditional_Entry_Call -- 7759 ------------------------------------- 7760 7761 -- The conditional task entry call is converted to a call to 7762 -- Task_Entry_Call: 7763 7764 -- declare 7765 -- B : Boolean; 7766 -- P : parms := (parm, parm, parm); 7767 7768 -- begin 7769 -- Task_Entry_Call 7770 -- (<acceptor-task>, -- Acceptor 7771 -- <entry-index>, -- E 7772 -- P'Address, -- Uninterpreted_Data 7773 -- Conditional_Call, -- Mode 7774 -- B); -- Rendezvous_Successful 7775 -- parm := P.param; 7776 -- parm := P.param; 7777 -- ... 7778 -- if B then 7779 -- normal-statements 7780 -- else 7781 -- else-statements 7782 -- end if; 7783 -- end; 7784 7785 -- For a description of the use of P and the assignments after the call, 7786 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the 7787 -- conditional entry call has already been expanded (by the Expand_N_Entry 7788 -- _Call_Statement procedure) as follows: 7789 7790 -- declare 7791 -- P : parms := (parm, parm, parm); 7792 -- begin 7793 -- ... info for in-out parameters 7794 -- Call_Simple (acceptor-task, entry-index, P'Address); 7795 -- parm := P.param; 7796 -- parm := P.param; 7797 -- ... 7798 -- end; 7799 7800 -- so the task at hand is to convert the latter expansion into the former 7801 7802 -- The conditional protected entry call is converted to a call to 7803 -- Protected_Entry_Call: 7804 7805 -- declare 7806 -- P : parms := (parm, parm, parm); 7807 -- Bnn : Communications_Block; 7808 7809 -- begin 7810 -- Protected_Entry_Call 7811 -- (po._object'Access, -- Object 7812 -- <entry index>, -- E 7813 -- P'Address, -- Uninterpreted_Data 7814 -- Conditional_Call, -- Mode 7815 -- Bnn); -- Block 7816 -- parm := P.param; 7817 -- parm := P.param; 7818 -- ... 7819 -- if Cancelled (Bnn) then 7820 -- else-statements 7821 -- else 7822 -- normal-statements 7823 -- end if; 7824 -- end; 7825 7826 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted 7827 -- into: 7828 7829 -- declare 7830 -- B : Boolean := False; 7831 -- C : Ada.Tags.Prim_Op_Kind; 7832 -- K : Ada.Tags.Tagged_Kind := 7833 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7834 -- P : Parameters := (Param1 .. ParamN); 7835 -- S : Integer; 7836 7837 -- begin 7838 -- if K = Ada.Tags.TK_Limited_Tagged 7839 -- or else K = Ada.Tags.TK_Tagged 7840 -- then 7841 -- <dispatching-call>; 7842 -- <triggering-statements> 7843 7844 -- else 7845 -- S := 7846 -- Ada.Tags.Get_Offset_Index 7847 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 7848 7849 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 7850 7851 -- if C = POK_Protected_Entry 7852 -- or else C = POK_Task_Entry 7853 -- then 7854 -- Param1 := P.Param1; 7855 -- ... 7856 -- ParamN := P.ParamN; 7857 -- end if; 7858 7859 -- if B then 7860 -- if C = POK_Procedure 7861 -- or else C = POK_Protected_Procedure 7862 -- or else C = POK_Task_Procedure 7863 -- then 7864 -- <dispatching-call>; 7865 -- end if; 7866 7867 -- <triggering-statements> 7868 -- else 7869 -- <else-statements> 7870 -- end if; 7871 -- end if; 7872 -- end; 7873 7874 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is 7875 Loc : constant Source_Ptr := Sloc (N); 7876 Alt : constant Node_Id := Entry_Call_Alternative (N); 7877 Blk : Node_Id := Entry_Call_Statement (Alt); 7878 7879 Actuals : List_Id; 7880 Blk_Typ : Entity_Id; 7881 Call : Node_Id; 7882 Call_Ent : Entity_Id; 7883 Conc_Typ_Stmts : List_Id; 7884 Decl : Node_Id; 7885 Decls : List_Id; 7886 Formals : List_Id; 7887 Lim_Typ_Stmts : List_Id; 7888 N_Stats : List_Id; 7889 Obj : Entity_Id; 7890 Param : Node_Id; 7891 Params : List_Id; 7892 Stmt : Node_Id; 7893 Stmts : List_Id; 7894 Transient_Blk : Node_Id; 7895 Unpack : List_Id; 7896 7897 B : Entity_Id; -- Call status flag 7898 C : Entity_Id; -- Call kind 7899 K : Entity_Id; -- Tagged kind 7900 P : Entity_Id; -- Parameter block 7901 S : Entity_Id; -- Primitive operation slot 7902 7903 begin 7904 Process_Statements_For_Controlled_Objects (N); 7905 7906 if Ada_Version >= Ada_2005 7907 and then Nkind (Blk) = N_Procedure_Call_Statement 7908 then 7909 Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals); 7910 7911 Decls := New_List; 7912 Stmts := New_List; 7913 7914 -- Call status flag processing, generate: 7915 -- B : Boolean := False; 7916 7917 B := Build_B (Loc, Decls); 7918 7919 -- Call kind processing, generate: 7920 -- C : Ada.Tags.Prim_Op_Kind; 7921 7922 C := Build_C (Loc, Decls); 7923 7924 -- Tagged kind processing, generate: 7925 -- K : Ada.Tags.Tagged_Kind := 7926 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7927 7928 K := Build_K (Loc, Decls, Obj); 7929 7930 -- Parameter block processing 7931 7932 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 7933 P := Parameter_Block_Pack 7934 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 7935 7936 -- Dispatch table slot processing, generate: 7937 -- S : Integer; 7938 7939 S := Build_S (Loc, Decls); 7940 7941 -- Generate: 7942 -- S := Ada.Tags.Get_Offset_Index 7943 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 7944 7945 Conc_Typ_Stmts := 7946 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 7947 7948 -- Generate: 7949 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 7950 7951 Append_To (Conc_Typ_Stmts, 7952 Make_Procedure_Call_Statement (Loc, 7953 Name => 7954 New_Occurrence_Of ( 7955 Find_Prim_Op (Etype (Etype (Obj)), 7956 Name_uDisp_Conditional_Select), 7957 Loc), 7958 Parameter_Associations => 7959 New_List ( 7960 New_Copy_Tree (Obj), -- <object> 7961 New_Occurrence_Of (S, Loc), -- S 7962 Make_Attribute_Reference (Loc, -- P'Address 7963 Prefix => New_Occurrence_Of (P, Loc), 7964 Attribute_Name => Name_Address), 7965 New_Occurrence_Of (C, Loc), -- C 7966 New_Occurrence_Of (B, Loc)))); -- B 7967 7968 -- Generate: 7969 -- if C = POK_Protected_Entry 7970 -- or else C = POK_Task_Entry 7971 -- then 7972 -- Param1 := P.Param1; 7973 -- ... 7974 -- ParamN := P.ParamN; 7975 -- end if; 7976 7977 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7978 7979 -- Generate the if statement only when the packed parameters need 7980 -- explicit assignments to their corresponding actuals. 7981 7982 if Present (Unpack) then 7983 Append_To (Conc_Typ_Stmts, 7984 Make_Implicit_If_Statement (N, 7985 Condition => 7986 Make_Or_Else (Loc, 7987 Left_Opnd => 7988 Make_Op_Eq (Loc, 7989 Left_Opnd => 7990 New_Occurrence_Of (C, Loc), 7991 Right_Opnd => 7992 New_Occurrence_Of (RTE ( 7993 RE_POK_Protected_Entry), Loc)), 7994 7995 Right_Opnd => 7996 Make_Op_Eq (Loc, 7997 Left_Opnd => 7998 New_Occurrence_Of (C, Loc), 7999 Right_Opnd => 8000 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 8001 8002 Then_Statements => Unpack)); 8003 end if; 8004 8005 -- Generate: 8006 -- if B then 8007 -- if C = POK_Procedure 8008 -- or else C = POK_Protected_Procedure 8009 -- or else C = POK_Task_Procedure 8010 -- then 8011 -- <dispatching-call> 8012 -- end if; 8013 -- <normal-statements> 8014 -- else 8015 -- <else-statements> 8016 -- end if; 8017 8018 N_Stats := New_Copy_List_Tree (Statements (Alt)); 8019 8020 Prepend_To (N_Stats, 8021 Make_Implicit_If_Statement (N, 8022 Condition => 8023 Make_Or_Else (Loc, 8024 Left_Opnd => 8025 Make_Op_Eq (Loc, 8026 Left_Opnd => 8027 New_Occurrence_Of (C, Loc), 8028 Right_Opnd => 8029 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 8030 8031 Right_Opnd => 8032 Make_Or_Else (Loc, 8033 Left_Opnd => 8034 Make_Op_Eq (Loc, 8035 Left_Opnd => 8036 New_Occurrence_Of (C, Loc), 8037 Right_Opnd => 8038 New_Occurrence_Of (RTE ( 8039 RE_POK_Protected_Procedure), Loc)), 8040 8041 Right_Opnd => 8042 Make_Op_Eq (Loc, 8043 Left_Opnd => 8044 New_Occurrence_Of (C, Loc), 8045 Right_Opnd => 8046 New_Occurrence_Of (RTE ( 8047 RE_POK_Task_Procedure), Loc)))), 8048 8049 Then_Statements => 8050 New_List (Blk))); 8051 8052 Append_To (Conc_Typ_Stmts, 8053 Make_Implicit_If_Statement (N, 8054 Condition => New_Occurrence_Of (B, Loc), 8055 Then_Statements => N_Stats, 8056 Else_Statements => Else_Statements (N))); 8057 8058 -- Generate: 8059 -- <dispatching-call>; 8060 -- <triggering-statements> 8061 8062 Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt)); 8063 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk)); 8064 8065 -- Generate: 8066 -- if K = Ada.Tags.TK_Limited_Tagged 8067 -- or else K = Ada.Tags.TK_Tagged 8068 -- then 8069 -- Lim_Typ_Stmts 8070 -- else 8071 -- Conc_Typ_Stmts 8072 -- end if; 8073 8074 Append_To (Stmts, 8075 Make_Implicit_If_Statement (N, 8076 Condition => Build_Dispatching_Tag_Check (K, N), 8077 Then_Statements => Lim_Typ_Stmts, 8078 Else_Statements => Conc_Typ_Stmts)); 8079 8080 Rewrite (N, 8081 Make_Block_Statement (Loc, 8082 Declarations => 8083 Decls, 8084 Handled_Statement_Sequence => 8085 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8086 8087 -- As described above, the entry alternative is transformed into a 8088 -- block that contains the gnulli call, and possibly assignment 8089 -- statements for in-out parameters. The gnulli call may itself be 8090 -- rewritten into a transient block if some unconstrained parameters 8091 -- require it. We need to retrieve the call to complete its parameter 8092 -- list. 8093 8094 else 8095 Transient_Blk := 8096 First_Real_Statement (Handled_Statement_Sequence (Blk)); 8097 8098 if Present (Transient_Blk) 8099 and then Nkind (Transient_Blk) = N_Block_Statement 8100 then 8101 Blk := Transient_Blk; 8102 end if; 8103 8104 Stmts := Statements (Handled_Statement_Sequence (Blk)); 8105 Stmt := First (Stmts); 8106 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 8107 Next (Stmt); 8108 end loop; 8109 8110 Call := Stmt; 8111 Params := Parameter_Associations (Call); 8112 8113 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then 8114 8115 -- Substitute Conditional_Entry_Call for Simple_Call parameter 8116 8117 Param := First (Params); 8118 while Present (Param) 8119 and then not Is_RTE (Etype (Param), RE_Call_Modes) 8120 loop 8121 Next (Param); 8122 end loop; 8123 8124 pragma Assert (Present (Param)); 8125 Rewrite (Param, 8126 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8127 8128 Analyze (Param); 8129 8130 -- Find the Communication_Block parameter for the call to the 8131 -- Cancelled function. 8132 8133 Decl := First (Declarations (Blk)); 8134 while Present (Decl) 8135 and then not Is_RTE (Etype (Object_Definition (Decl)), 8136 RE_Communication_Block) 8137 loop 8138 Next (Decl); 8139 end loop; 8140 8141 -- Add an if statement to execute the else part if the call 8142 -- does not succeed (as indicated by the Cancelled predicate). 8143 8144 Append_To (Stmts, 8145 Make_Implicit_If_Statement (N, 8146 Condition => Make_Function_Call (Loc, 8147 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 8148 Parameter_Associations => New_List ( 8149 New_Occurrence_Of (Defining_Identifier (Decl), Loc))), 8150 Then_Statements => Else_Statements (N), 8151 Else_Statements => Statements (Alt))); 8152 8153 else 8154 B := Make_Defining_Identifier (Loc, Name_uB); 8155 8156 -- Insert declaration of B in declarations of existing block 8157 8158 if No (Declarations (Blk)) then 8159 Set_Declarations (Blk, New_List); 8160 end if; 8161 8162 Prepend_To (Declarations (Blk), 8163 Make_Object_Declaration (Loc, 8164 Defining_Identifier => B, 8165 Object_Definition => 8166 New_Occurrence_Of (Standard_Boolean, Loc))); 8167 8168 -- Create new call statement 8169 8170 Append_To (Params, 8171 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8172 Append_To (Params, New_Occurrence_Of (B, Loc)); 8173 8174 Rewrite (Call, 8175 Make_Procedure_Call_Statement (Loc, 8176 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 8177 Parameter_Associations => Params)); 8178 8179 -- Construct statement sequence for new block 8180 8181 Append_To (Stmts, 8182 Make_Implicit_If_Statement (N, 8183 Condition => New_Occurrence_Of (B, Loc), 8184 Then_Statements => Statements (Alt), 8185 Else_Statements => Else_Statements (N))); 8186 end if; 8187 8188 -- The result is the new block 8189 8190 Rewrite (N, 8191 Make_Block_Statement (Loc, 8192 Declarations => Declarations (Blk), 8193 Handled_Statement_Sequence => 8194 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8195 end if; 8196 8197 Analyze (N); 8198 end Expand_N_Conditional_Entry_Call; 8199 8200 --------------------------------------- 8201 -- Expand_N_Delay_Relative_Statement -- 8202 --------------------------------------- 8203 8204 -- Delay statement is implemented as a procedure call to Delay_For 8205 -- defined in Ada.Calendar.Delays in order to reduce the overhead of 8206 -- simple delays imposed by the use of Protected Objects. 8207 8208 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is 8209 Loc : constant Source_Ptr := Sloc (N); 8210 begin 8211 Rewrite (N, 8212 Make_Procedure_Call_Statement (Loc, 8213 Name => New_Occurrence_Of (RTE (RO_CA_Delay_For), Loc), 8214 Parameter_Associations => New_List (Expression (N)))); 8215 Analyze (N); 8216 end Expand_N_Delay_Relative_Statement; 8217 8218 ------------------------------------ 8219 -- Expand_N_Delay_Until_Statement -- 8220 ------------------------------------ 8221 8222 -- Delay Until statement is implemented as a procedure call to 8223 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays. 8224 8225 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is 8226 Loc : constant Source_Ptr := Sloc (N); 8227 Typ : Entity_Id; 8228 8229 begin 8230 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then 8231 Typ := RTE (RO_CA_Delay_Until); 8232 else 8233 Typ := RTE (RO_RT_Delay_Until); 8234 end if; 8235 8236 Rewrite (N, 8237 Make_Procedure_Call_Statement (Loc, 8238 Name => New_Occurrence_Of (Typ, Loc), 8239 Parameter_Associations => New_List (Expression (N)))); 8240 8241 Analyze (N); 8242 end Expand_N_Delay_Until_Statement; 8243 8244 ------------------------- 8245 -- Expand_N_Entry_Body -- 8246 ------------------------- 8247 8248 procedure Expand_N_Entry_Body (N : Node_Id) is 8249 begin 8250 -- Associate discriminals with the next protected operation body to be 8251 -- expanded. 8252 8253 if Present (Next_Protected_Operation (N)) then 8254 Set_Discriminals (Parent (Current_Scope)); 8255 end if; 8256 end Expand_N_Entry_Body; 8257 8258 ----------------------------------- 8259 -- Expand_N_Entry_Call_Statement -- 8260 ----------------------------------- 8261 8262 -- An entry call is expanded into GNARLI calls to implement a simple entry 8263 -- call (see Build_Simple_Entry_Call). 8264 8265 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is 8266 Concval : Node_Id; 8267 Ename : Node_Id; 8268 Index : Node_Id; 8269 8270 begin 8271 if No_Run_Time_Mode then 8272 Error_Msg_CRT ("entry call", N); 8273 return; 8274 end if; 8275 8276 -- If this entry call is part of an asynchronous select, don't expand it 8277 -- here; it will be expanded with the select statement. Don't expand 8278 -- timed entry calls either, as they are translated into asynchronous 8279 -- entry calls. 8280 8281 -- ??? This whole approach is questionable; it may be better to go back 8282 -- to allowing the expansion to take place and then attempting to fix it 8283 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out 8284 -- whether the expanded call is on a task or protected entry. 8285 8286 if (Nkind (Parent (N)) /= N_Triggering_Alternative 8287 or else N /= Triggering_Statement (Parent (N))) 8288 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative 8289 or else N /= Entry_Call_Statement (Parent (N)) 8290 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call) 8291 then 8292 Extract_Entry (N, Concval, Ename, Index); 8293 Build_Simple_Entry_Call (N, Concval, Ename, Index); 8294 end if; 8295 end Expand_N_Entry_Call_Statement; 8296 8297 -------------------------------- 8298 -- Expand_N_Entry_Declaration -- 8299 -------------------------------- 8300 8301 -- If there are parameters, then first, each of the formals is marked by 8302 -- setting Is_Entry_Formal. Next a record type is built which is used to 8303 -- hold the parameter values. The name of this record type is entryP where 8304 -- entry is the name of the entry, with an additional corresponding access 8305 -- type called entryPA. The record type has matching components for each 8306 -- formal (the component names are the same as the formal names). For 8307 -- elementary types, the component type matches the formal type. For 8308 -- composite types, an access type is declared (with the name formalA) 8309 -- which designates the formal type, and the type of the component is this 8310 -- access type. Finally the Entry_Component of each formal is set to 8311 -- reference the corresponding record component. 8312 8313 procedure Expand_N_Entry_Declaration (N : Node_Id) is 8314 Loc : constant Source_Ptr := Sloc (N); 8315 Entry_Ent : constant Entity_Id := Defining_Identifier (N); 8316 Components : List_Id; 8317 Formal : Node_Id; 8318 Ftype : Entity_Id; 8319 Last_Decl : Node_Id; 8320 Component : Entity_Id; 8321 Ctype : Entity_Id; 8322 Decl : Node_Id; 8323 Rec_Ent : Entity_Id; 8324 Acc_Ent : Entity_Id; 8325 8326 begin 8327 Formal := First_Formal (Entry_Ent); 8328 Last_Decl := N; 8329 8330 -- Most processing is done only if parameters are present 8331 8332 if Present (Formal) then 8333 Components := New_List; 8334 8335 -- Loop through formals 8336 8337 while Present (Formal) loop 8338 Set_Is_Entry_Formal (Formal); 8339 Component := 8340 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); 8341 Set_Entry_Component (Formal, Component); 8342 Set_Entry_Formal (Component, Formal); 8343 Ftype := Etype (Formal); 8344 8345 -- Declare new access type and then append 8346 8347 Ctype := Make_Temporary (Loc, 'A'); 8348 8349 Decl := 8350 Make_Full_Type_Declaration (Loc, 8351 Defining_Identifier => Ctype, 8352 Type_Definition => 8353 Make_Access_To_Object_Definition (Loc, 8354 All_Present => True, 8355 Constant_Present => Ekind (Formal) = E_In_Parameter, 8356 Subtype_Indication => New_Occurrence_Of (Ftype, Loc))); 8357 8358 Insert_After (Last_Decl, Decl); 8359 Last_Decl := Decl; 8360 8361 Append_To (Components, 8362 Make_Component_Declaration (Loc, 8363 Defining_Identifier => Component, 8364 Component_Definition => 8365 Make_Component_Definition (Loc, 8366 Aliased_Present => False, 8367 Subtype_Indication => New_Occurrence_Of (Ctype, Loc)))); 8368 8369 Next_Formal_With_Extras (Formal); 8370 end loop; 8371 8372 -- Create the Entry_Parameter_Record declaration 8373 8374 Rec_Ent := Make_Temporary (Loc, 'P'); 8375 8376 Decl := 8377 Make_Full_Type_Declaration (Loc, 8378 Defining_Identifier => Rec_Ent, 8379 Type_Definition => 8380 Make_Record_Definition (Loc, 8381 Component_List => 8382 Make_Component_List (Loc, 8383 Component_Items => Components))); 8384 8385 Insert_After (Last_Decl, Decl); 8386 Last_Decl := Decl; 8387 8388 -- Construct and link in the corresponding access type 8389 8390 Acc_Ent := Make_Temporary (Loc, 'A'); 8391 8392 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); 8393 8394 Decl := 8395 Make_Full_Type_Declaration (Loc, 8396 Defining_Identifier => Acc_Ent, 8397 Type_Definition => 8398 Make_Access_To_Object_Definition (Loc, 8399 All_Present => True, 8400 Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc))); 8401 8402 Insert_After (Last_Decl, Decl); 8403 end if; 8404 end Expand_N_Entry_Declaration; 8405 8406 ----------------------------- 8407 -- Expand_N_Protected_Body -- 8408 ----------------------------- 8409 8410 -- Protected bodies are expanded to the completion of the subprograms 8411 -- created for the corresponding protected type. These are a protected and 8412 -- unprotected version of each protected subprogram in the object, a 8413 -- function to calculate each entry barrier, and a procedure to execute the 8414 -- sequence of statements of each protected entry body. For example, for 8415 -- protected type ptype: 8416 8417 -- function entB 8418 -- (O : System.Address; 8419 -- E : Protected_Entry_Index) 8420 -- return Boolean 8421 -- is 8422 -- <discriminant renamings> 8423 -- <private object renamings> 8424 -- begin 8425 -- return <barrier expression>; 8426 -- end entB; 8427 8428 -- procedure pprocN (_object : in out poV;...) is 8429 -- <discriminant renamings> 8430 -- <private object renamings> 8431 -- begin 8432 -- <sequence of statements> 8433 -- end pprocN; 8434 8435 -- procedure pprocP (_object : in out poV;...) is 8436 -- procedure _clean is 8437 -- Pn : Boolean; 8438 -- begin 8439 -- ptypeS (_object, Pn); 8440 -- Unlock (_object._object'Access); 8441 -- Abort_Undefer.all; 8442 -- end _clean; 8443 8444 -- begin 8445 -- Abort_Defer.all; 8446 -- Lock (_object._object'Access); 8447 -- pprocN (_object;...); 8448 -- at end 8449 -- _clean; 8450 -- end pproc; 8451 8452 -- function pfuncN (_object : poV;...) return Return_Type is 8453 -- <discriminant renamings> 8454 -- <private object renamings> 8455 -- begin 8456 -- <sequence of statements> 8457 -- end pfuncN; 8458 8459 -- function pfuncP (_object : poV) return Return_Type is 8460 -- procedure _clean is 8461 -- begin 8462 -- Unlock (_object._object'Access); 8463 -- Abort_Undefer.all; 8464 -- end _clean; 8465 8466 -- begin 8467 -- Abort_Defer.all; 8468 -- Lock (_object._object'Access); 8469 -- return pfuncN (_object); 8470 8471 -- at end 8472 -- _clean; 8473 -- end pfunc; 8474 8475 -- procedure entE 8476 -- (O : System.Address; 8477 -- P : System.Address; 8478 -- E : Protected_Entry_Index) 8479 -- is 8480 -- <discriminant renamings> 8481 -- <private object renamings> 8482 -- type poVP is access poV; 8483 -- _Object : ptVP := ptVP!(O); 8484 8485 -- begin 8486 -- begin 8487 -- <statement sequence> 8488 -- Complete_Entry_Body (_Object._Object); 8489 -- exception 8490 -- when all others => 8491 -- Exceptional_Complete_Entry_Body ( 8492 -- _Object._Object, Get_GNAT_Exception); 8493 -- end; 8494 -- end entE; 8495 8496 -- The type poV is the record created for the protected type to hold 8497 -- the state of the protected object. 8498 8499 procedure Expand_N_Protected_Body (N : Node_Id) is 8500 Loc : constant Source_Ptr := Sloc (N); 8501 Pid : constant Entity_Id := Corresponding_Spec (N); 8502 8503 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid); 8504 -- This flag indicates whether the lock free implementation is active 8505 8506 Current_Node : Node_Id; 8507 Disp_Op_Body : Node_Id; 8508 New_Op_Body : Node_Id; 8509 Op_Body : Node_Id; 8510 Op_Id : Entity_Id; 8511 8512 function Build_Dispatching_Subprogram_Body 8513 (N : Node_Id; 8514 Pid : Node_Id; 8515 Prot_Bod : Node_Id) return Node_Id; 8516 -- Build a dispatching version of the protected subprogram body. The 8517 -- newly generated subprogram contains a call to the original protected 8518 -- body. The following code is generated: 8519 -- 8520 -- function <protected-function-name> (Param1 .. ParamN) return 8521 -- <return-type> is 8522 -- begin 8523 -- return <protected-function-name>P (Param1 .. ParamN); 8524 -- end <protected-function-name>; 8525 -- 8526 -- or 8527 -- 8528 -- procedure <protected-procedure-name> (Param1 .. ParamN) is 8529 -- begin 8530 -- <protected-procedure-name>P (Param1 .. ParamN); 8531 -- end <protected-procedure-name> 8532 8533 --------------------------------------- 8534 -- Build_Dispatching_Subprogram_Body -- 8535 --------------------------------------- 8536 8537 function Build_Dispatching_Subprogram_Body 8538 (N : Node_Id; 8539 Pid : Node_Id; 8540 Prot_Bod : Node_Id) return Node_Id 8541 is 8542 Loc : constant Source_Ptr := Sloc (N); 8543 Actuals : List_Id; 8544 Formal : Node_Id; 8545 Spec : Node_Id; 8546 Stmts : List_Id; 8547 8548 begin 8549 -- Generate a specification without a letter suffix in order to 8550 -- override an interface function or procedure. 8551 8552 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode); 8553 8554 -- The formal parameters become the actuals of the protected function 8555 -- or procedure call. 8556 8557 Actuals := New_List; 8558 Formal := First (Parameter_Specifications (Spec)); 8559 while Present (Formal) loop 8560 Append_To (Actuals, 8561 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 8562 Next (Formal); 8563 end loop; 8564 8565 if Nkind (Spec) = N_Procedure_Specification then 8566 Stmts := 8567 New_List ( 8568 Make_Procedure_Call_Statement (Loc, 8569 Name => 8570 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8571 Parameter_Associations => Actuals)); 8572 8573 else 8574 pragma Assert (Nkind (Spec) = N_Function_Specification); 8575 8576 Stmts := 8577 New_List ( 8578 Make_Simple_Return_Statement (Loc, 8579 Expression => 8580 Make_Function_Call (Loc, 8581 Name => 8582 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8583 Parameter_Associations => Actuals))); 8584 end if; 8585 8586 return 8587 Make_Subprogram_Body (Loc, 8588 Declarations => Empty_List, 8589 Specification => Spec, 8590 Handled_Statement_Sequence => 8591 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 8592 end Build_Dispatching_Subprogram_Body; 8593 8594 -- Start of processing for Expand_N_Protected_Body 8595 8596 begin 8597 if No_Run_Time_Mode then 8598 Error_Msg_CRT ("protected body", N); 8599 return; 8600 end if; 8601 8602 -- This is the proper body corresponding to a stub. The declarations 8603 -- must be inserted at the point of the stub, which in turn is in the 8604 -- declarative part of the parent unit. 8605 8606 if Nkind (Parent (N)) = N_Subunit then 8607 Current_Node := Corresponding_Stub (Parent (N)); 8608 else 8609 Current_Node := N; 8610 end if; 8611 8612 Op_Body := First (Declarations (N)); 8613 8614 -- The protected body is replaced with the bodies of its 8615 -- protected operations, and the declarations for internal objects 8616 -- that may have been created for entry family bounds. 8617 8618 Rewrite (N, Make_Null_Statement (Sloc (N))); 8619 Analyze (N); 8620 8621 while Present (Op_Body) loop 8622 case Nkind (Op_Body) is 8623 when N_Subprogram_Declaration => 8624 null; 8625 8626 when N_Subprogram_Body => 8627 8628 -- Do not create bodies for eliminated operations 8629 8630 if not Is_Eliminated (Defining_Entity (Op_Body)) 8631 and then not Is_Eliminated (Corresponding_Spec (Op_Body)) 8632 then 8633 if Lock_Free_Active then 8634 New_Op_Body := 8635 Build_Lock_Free_Unprotected_Subprogram_Body 8636 (Op_Body, Pid); 8637 else 8638 New_Op_Body := 8639 Build_Unprotected_Subprogram_Body (Op_Body, Pid); 8640 end if; 8641 8642 Insert_After (Current_Node, New_Op_Body); 8643 Current_Node := New_Op_Body; 8644 Analyze (New_Op_Body); 8645 8646 -- Build the corresponding protected operation. It may 8647 -- appear that this is needed only if this is a visible 8648 -- operation of the type, or if it is an interrupt handler, 8649 -- and this was the strategy used previously in GNAT. 8650 8651 -- However, the operation may be exported through a 'Access 8652 -- to an external caller. This is the common idiom in code 8653 -- that uses the Ada 2005 Timing_Events package. As a result 8654 -- we need to produce the protected body for both visible 8655 -- and private operations, as well as operations that only 8656 -- have a body in the source, and for which we create a 8657 -- declaration in the protected body itself. 8658 8659 if Present (Corresponding_Spec (Op_Body)) then 8660 if Lock_Free_Active then 8661 New_Op_Body := 8662 Build_Lock_Free_Protected_Subprogram_Body 8663 (Op_Body, Pid, Specification (New_Op_Body)); 8664 else 8665 New_Op_Body := 8666 Build_Protected_Subprogram_Body 8667 (Op_Body, Pid, Specification (New_Op_Body)); 8668 end if; 8669 8670 Insert_After (Current_Node, New_Op_Body); 8671 Analyze (New_Op_Body); 8672 8673 Current_Node := New_Op_Body; 8674 8675 -- Generate an overriding primitive operation body for 8676 -- this subprogram if the protected type implements an 8677 -- interface. 8678 8679 if Ada_Version >= Ada_2005 8680 and then 8681 Present (Interfaces (Corresponding_Record_Type (Pid))) 8682 then 8683 Disp_Op_Body := 8684 Build_Dispatching_Subprogram_Body 8685 (Op_Body, Pid, New_Op_Body); 8686 8687 Insert_After (Current_Node, Disp_Op_Body); 8688 Analyze (Disp_Op_Body); 8689 8690 Current_Node := Disp_Op_Body; 8691 end if; 8692 end if; 8693 end if; 8694 8695 when N_Entry_Body => 8696 Op_Id := Defining_Identifier (Op_Body); 8697 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid); 8698 8699 Insert_After (Current_Node, New_Op_Body); 8700 Current_Node := New_Op_Body; 8701 Analyze (New_Op_Body); 8702 8703 when N_Implicit_Label_Declaration => 8704 null; 8705 8706 when N_Itype_Reference => 8707 Insert_After (Current_Node, New_Copy (Op_Body)); 8708 8709 when N_Freeze_Entity => 8710 New_Op_Body := New_Copy (Op_Body); 8711 8712 if Present (Entity (Op_Body)) 8713 and then Freeze_Node (Entity (Op_Body)) = Op_Body 8714 then 8715 Set_Freeze_Node (Entity (Op_Body), New_Op_Body); 8716 end if; 8717 8718 Insert_After (Current_Node, New_Op_Body); 8719 Current_Node := New_Op_Body; 8720 Analyze (New_Op_Body); 8721 8722 when N_Pragma => 8723 New_Op_Body := New_Copy (Op_Body); 8724 Insert_After (Current_Node, New_Op_Body); 8725 Current_Node := New_Op_Body; 8726 Analyze (New_Op_Body); 8727 8728 when N_Object_Declaration => 8729 pragma Assert (not Comes_From_Source (Op_Body)); 8730 New_Op_Body := New_Copy (Op_Body); 8731 Insert_After (Current_Node, New_Op_Body); 8732 Current_Node := New_Op_Body; 8733 Analyze (New_Op_Body); 8734 8735 when others => 8736 raise Program_Error; 8737 8738 end case; 8739 8740 Next (Op_Body); 8741 end loop; 8742 8743 -- Finally, create the body of the function that maps an entry index 8744 -- into the corresponding body index, except when there is no entry, or 8745 -- in a Ravenscar-like profile. 8746 8747 if Corresponding_Runtime_Package (Pid) = 8748 System_Tasking_Protected_Objects_Entries 8749 then 8750 New_Op_Body := Build_Find_Body_Index (Pid); 8751 Insert_After (Current_Node, New_Op_Body); 8752 Current_Node := New_Op_Body; 8753 Analyze (New_Op_Body); 8754 end if; 8755 8756 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the 8757 -- protected body. At this point all wrapper specs have been created, 8758 -- frozen and included in the dispatch table for the protected type. 8759 8760 if Ada_Version >= Ada_2005 then 8761 Build_Wrapper_Bodies (Loc, Pid, Current_Node); 8762 end if; 8763 end Expand_N_Protected_Body; 8764 8765 ----------------------------------------- 8766 -- Expand_N_Protected_Type_Declaration -- 8767 ----------------------------------------- 8768 8769 -- First we create a corresponding record type declaration used to 8770 -- represent values of this protected type. 8771 -- The general form of this type declaration is 8772 8773 -- type poV (discriminants) is record 8774 -- _Object : aliased <kind>Protection 8775 -- [(<entry count> [, <handler count>])]; 8776 -- [entry_family : array (bounds) of Void;] 8777 -- <private data fields> 8778 -- end record; 8779 8780 -- The discriminants are present only if the corresponding protected type 8781 -- has discriminants, and they exactly mirror the protected type 8782 -- discriminants. The private data fields similarly mirror the private 8783 -- declarations of the protected type. 8784 8785 -- The Object field is always present. It contains RTS specific data used 8786 -- to control the protected object. It is declared as Aliased so that it 8787 -- can be passed as a pointer to the RTS. This allows the protected record 8788 -- to be referenced within RTS data structures. An appropriate Protection 8789 -- type and discriminant are generated. 8790 8791 -- The Service field is present for protected objects with entries. It 8792 -- contains sufficient information to allow the entry service procedure for 8793 -- this object to be called when the object is not known till runtime. 8794 8795 -- One entry_family component is present for each entry family in the 8796 -- task definition (see Expand_N_Task_Type_Declaration). 8797 8798 -- When a protected object is declared, an instance of the protected type 8799 -- value record is created. The elaboration of this declaration creates the 8800 -- correct bounds for the entry families, and also evaluates the priority 8801 -- expression if needed. The initialization routine for the protected type 8802 -- itself then calls Initialize_Protection with appropriate parameters to 8803 -- initialize the value of the Task_Id field. Install_Handlers may be also 8804 -- called if a pragma Attach_Handler applies. 8805 8806 -- Note: this record is passed to the subprograms created by the expansion 8807 -- of protected subprograms and entries. It is an in parameter to protected 8808 -- functions and an in out parameter to procedures and entry bodies. The 8809 -- Entity_Id for this created record type is placed in the 8810 -- Corresponding_Record_Type field of the associated protected type entity. 8811 8812 -- Next we create a procedure specifications for protected subprograms and 8813 -- entry bodies. For each protected subprograms two subprograms are 8814 -- created, an unprotected and a protected version. The unprotected version 8815 -- is called from within other operations of the same protected object. 8816 8817 -- We also build the call to register the procedure if a pragma 8818 -- Interrupt_Handler applies. 8819 8820 -- A single subprogram is created to service all entry bodies; it has an 8821 -- additional boolean out parameter indicating that the previous entry call 8822 -- made by the current task was serviced immediately, i.e. not by proxy. 8823 -- The O parameter contains a pointer to a record object of the type 8824 -- described above. An untyped interface is used here to allow this 8825 -- procedure to be called in places where the type of the object to be 8826 -- serviced is not known. This must be done, for example, when a call that 8827 -- may have been requeued is cancelled; the corresponding object must be 8828 -- serviced, but which object that is not known till runtime. 8829 8830 -- procedure ptypeS 8831 -- (O : System.Address; P : out Boolean); 8832 -- procedure pprocN (_object : in out poV); 8833 -- procedure pproc (_object : in out poV); 8834 -- function pfuncN (_object : poV); 8835 -- function pfunc (_object : poV); 8836 -- ... 8837 8838 -- Note that this must come after the record type declaration, since 8839 -- the specs refer to this type. 8840 8841 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is 8842 Loc : constant Source_Ptr := Sloc (N); 8843 Prot_Typ : constant Entity_Id := Defining_Identifier (N); 8844 8845 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ); 8846 -- This flag indicates whether the lock free implementation is active 8847 8848 Pdef : constant Node_Id := Protected_Definition (N); 8849 -- This contains two lists; one for visible and one for private decls 8850 8851 Rec_Decl : Node_Id; 8852 Cdecls : List_Id; 8853 Discr_Map : constant Elist_Id := New_Elmt_List; 8854 Priv : Node_Id; 8855 New_Priv : Node_Id; 8856 Comp : Node_Id; 8857 Comp_Id : Entity_Id; 8858 Sub : Node_Id; 8859 Current_Node : Node_Id := N; 8860 Entries_Aggr : Node_Id; 8861 Body_Id : Entity_Id; 8862 Body_Arr : Node_Id; 8863 E_Count : Int; 8864 Object_Comp : Node_Id; 8865 8866 procedure Check_Inlining (Subp : Entity_Id); 8867 -- If the original operation has a pragma Inline, propagate the flag 8868 -- to the internal body, for possible inlining later on. The source 8869 -- operation is invisible to the back-end and is never actually called. 8870 8871 function Discriminated_Size (Comp : Entity_Id) return Boolean; 8872 -- If a component size is not static then a warning will be emitted 8873 -- in Ravenscar or other restricted contexts. When a component is non- 8874 -- static because of a discriminant constraint we can specialize the 8875 -- warning by mentioning discriminants explicitly. 8876 8877 procedure Expand_Entry_Declaration (Comp : Entity_Id); 8878 -- Create the subprograms for the barrier and for the body, and append 8879 -- then to Entry_Bodies_Array. 8880 8881 function Static_Component_Size (Comp : Entity_Id) return Boolean; 8882 -- When compiling under the Ravenscar profile, private components must 8883 -- have a static size, or else a protected object will require heap 8884 -- allocation, violating the corresponding restriction. It is preferable 8885 -- to make this check here, because it provides a better error message 8886 -- than the back-end, which refers to the object as a whole. 8887 8888 procedure Register_Handler; 8889 -- For a protected operation that is an interrupt handler, add the 8890 -- freeze action that will register it as such. 8891 8892 -------------------- 8893 -- Check_Inlining -- 8894 -------------------- 8895 8896 procedure Check_Inlining (Subp : Entity_Id) is 8897 begin 8898 if Is_Inlined (Subp) then 8899 Set_Is_Inlined (Protected_Body_Subprogram (Subp)); 8900 Set_Is_Inlined (Subp, False); 8901 end if; 8902 end Check_Inlining; 8903 8904 ------------------------ 8905 -- Discriminated_Size -- 8906 ------------------------ 8907 8908 function Discriminated_Size (Comp : Entity_Id) return Boolean is 8909 Typ : constant Entity_Id := Etype (Comp); 8910 Index : Node_Id; 8911 8912 function Non_Static_Bound (Bound : Node_Id) return Boolean; 8913 -- Check whether the bound of an index is non-static and does denote 8914 -- a discriminant, in which case any protected object of the type 8915 -- will have a non-static size. 8916 8917 ---------------------- 8918 -- Non_Static_Bound -- 8919 ---------------------- 8920 8921 function Non_Static_Bound (Bound : Node_Id) return Boolean is 8922 begin 8923 if Is_OK_Static_Expression (Bound) then 8924 return False; 8925 8926 elsif Is_Entity_Name (Bound) 8927 and then Present (Discriminal_Link (Entity (Bound))) 8928 then 8929 return False; 8930 8931 else 8932 return True; 8933 end if; 8934 end Non_Static_Bound; 8935 8936 -- Start of processing for Discriminated_Size 8937 8938 begin 8939 if not Is_Array_Type (Typ) then 8940 return False; 8941 end if; 8942 8943 if Ekind (Typ) = E_Array_Subtype then 8944 Index := First_Index (Typ); 8945 while Present (Index) loop 8946 if Non_Static_Bound (Low_Bound (Index)) 8947 or else Non_Static_Bound (High_Bound (Index)) 8948 then 8949 return False; 8950 end if; 8951 8952 Next_Index (Index); 8953 end loop; 8954 8955 return True; 8956 end if; 8957 8958 return False; 8959 end Discriminated_Size; 8960 8961 --------------------------- 8962 -- Static_Component_Size -- 8963 --------------------------- 8964 8965 function Static_Component_Size (Comp : Entity_Id) return Boolean is 8966 Typ : constant Entity_Id := Etype (Comp); 8967 C : Entity_Id; 8968 8969 begin 8970 if Is_Scalar_Type (Typ) then 8971 return True; 8972 8973 elsif Is_Array_Type (Typ) then 8974 return Compile_Time_Known_Bounds (Typ); 8975 8976 elsif Is_Record_Type (Typ) then 8977 C := First_Component (Typ); 8978 while Present (C) loop 8979 if not Static_Component_Size (C) then 8980 return False; 8981 end if; 8982 8983 Next_Component (C); 8984 end loop; 8985 8986 return True; 8987 8988 -- Any other type will be checked by the back-end 8989 8990 else 8991 return True; 8992 end if; 8993 end Static_Component_Size; 8994 8995 ------------------------------ 8996 -- Expand_Entry_Declaration -- 8997 ------------------------------ 8998 8999 procedure Expand_Entry_Declaration (Comp : Entity_Id) is 9000 Bdef : Entity_Id; 9001 Edef : Entity_Id; 9002 9003 begin 9004 E_Count := E_Count + 1; 9005 Comp_Id := Defining_Identifier (Comp); 9006 9007 Edef := 9008 Make_Defining_Identifier (Loc, 9009 Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'E')); 9010 Sub := 9011 Make_Subprogram_Declaration (Loc, 9012 Specification => 9013 Build_Protected_Entry_Specification (Loc, Edef, Comp_Id)); 9014 9015 Insert_After (Current_Node, Sub); 9016 Analyze (Sub); 9017 9018 -- Build wrapper procedure for pre/postconditions 9019 9020 Build_PPC_Wrapper (Comp_Id, N); 9021 9022 Set_Protected_Body_Subprogram 9023 (Defining_Identifier (Comp), 9024 Defining_Unit_Name (Specification (Sub))); 9025 9026 Current_Node := Sub; 9027 9028 Bdef := 9029 Make_Defining_Identifier (Loc, 9030 Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'B')); 9031 Sub := 9032 Make_Subprogram_Declaration (Loc, 9033 Specification => 9034 Build_Barrier_Function_Specification (Loc, Bdef)); 9035 9036 Insert_After (Current_Node, Sub); 9037 Analyze (Sub); 9038 Set_Protected_Body_Subprogram (Bdef, Bdef); 9039 Set_Barrier_Function (Comp_Id, Bdef); 9040 Set_Scope (Bdef, Scope (Comp_Id)); 9041 Current_Node := Sub; 9042 9043 -- Collect pointers to the protected subprogram and the barrier 9044 -- of the current entry, for insertion into Entry_Bodies_Array. 9045 9046 Append_To (Expressions (Entries_Aggr), 9047 Make_Aggregate (Loc, 9048 Expressions => New_List ( 9049 Make_Attribute_Reference (Loc, 9050 Prefix => New_Occurrence_Of (Bdef, Loc), 9051 Attribute_Name => Name_Unrestricted_Access), 9052 Make_Attribute_Reference (Loc, 9053 Prefix => New_Occurrence_Of (Edef, Loc), 9054 Attribute_Name => Name_Unrestricted_Access)))); 9055 end Expand_Entry_Declaration; 9056 9057 ---------------------- 9058 -- Register_Handler -- 9059 ---------------------- 9060 9061 procedure Register_Handler is 9062 9063 -- All semantic checks already done in Sem_Prag 9064 9065 Prot_Proc : constant Entity_Id := 9066 Defining_Unit_Name (Specification (Current_Node)); 9067 9068 Proc_Address : constant Node_Id := 9069 Make_Attribute_Reference (Loc, 9070 Prefix => 9071 New_Occurrence_Of (Prot_Proc, Loc), 9072 Attribute_Name => Name_Address); 9073 9074 RTS_Call : constant Entity_Id := 9075 Make_Procedure_Call_Statement (Loc, 9076 Name => 9077 New_Occurrence_Of 9078 (RTE (RE_Register_Interrupt_Handler), Loc), 9079 Parameter_Associations => New_List (Proc_Address)); 9080 begin 9081 Append_Freeze_Action (Prot_Proc, RTS_Call); 9082 end Register_Handler; 9083 9084 -- Start of processing for Expand_N_Protected_Type_Declaration 9085 9086 begin 9087 if Present (Corresponding_Record_Type (Prot_Typ)) then 9088 return; 9089 else 9090 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc); 9091 end if; 9092 9093 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); 9094 9095 Qualify_Entity_Names (N); 9096 9097 -- If the type has discriminants, their occurrences in the declaration 9098 -- have been replaced by the corresponding discriminals. For components 9099 -- that are constrained by discriminants, their homologues in the 9100 -- corresponding record type must refer to the discriminants of that 9101 -- record, so we must apply a new renaming to subtypes_indications: 9102 9103 -- protected discriminant => discriminal => record discriminant 9104 9105 -- This replacement is not applied to default expressions, for which 9106 -- the discriminal is correct. 9107 9108 if Has_Discriminants (Prot_Typ) then 9109 declare 9110 Disc : Entity_Id; 9111 Decl : Node_Id; 9112 9113 begin 9114 Disc := First_Discriminant (Prot_Typ); 9115 Decl := First (Discriminant_Specifications (Rec_Decl)); 9116 while Present (Disc) loop 9117 Append_Elmt (Discriminal (Disc), Discr_Map); 9118 Append_Elmt (Defining_Identifier (Decl), Discr_Map); 9119 Next_Discriminant (Disc); 9120 Next (Decl); 9121 end loop; 9122 end; 9123 end if; 9124 9125 -- Fill in the component declarations 9126 9127 -- Add components for entry families. For each entry family, create an 9128 -- anonymous type declaration with the same size, and analyze the type. 9129 9130 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ); 9131 9132 pragma Assert (Present (Pdef)); 9133 9134 -- Add private field components 9135 9136 if Present (Private_Declarations (Pdef)) then 9137 Priv := First (Private_Declarations (Pdef)); 9138 while Present (Priv) loop 9139 if Nkind (Priv) = N_Component_Declaration then 9140 if not Static_Component_Size (Defining_Identifier (Priv)) then 9141 9142 -- When compiling for a restricted profile, the private 9143 -- components must have a static size. If not, this is an 9144 -- error for a single protected declaration, and rates a 9145 -- warning on a protected type declaration. 9146 9147 if not Comes_From_Source (Prot_Typ) then 9148 9149 -- It's ok to be checking this restriction at expansion 9150 -- time, because this is only for the restricted profile, 9151 -- which is not subject to strict RM conformance, so it 9152 -- is OK to miss this check in -gnatc mode. 9153 9154 Check_Restriction (No_Implicit_Heap_Allocations, Priv); 9155 9156 elsif Restriction_Active (No_Implicit_Heap_Allocations) then 9157 if not Discriminated_Size (Defining_Identifier (Priv)) 9158 then 9159 9160 -- Any object of the type will be non-static. 9161 9162 Error_Msg_N ("component has non-static size??", Priv); 9163 Error_Msg_NE 9164 ("\creation of protected object of type& will" 9165 & " violate restriction " 9166 & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ); 9167 else 9168 9169 -- Object will be non-static if discriminants are. 9170 9171 Error_Msg_NE 9172 ("creation of protected object of type& with " 9173 & "non-static discriminants will violate" 9174 & " restriction No_Implicit_Heap_Allocations??", 9175 Priv, Prot_Typ); 9176 end if; 9177 end if; 9178 end if; 9179 9180 -- The component definition consists of a subtype indication, 9181 -- or (in Ada 2005) an access definition. Make a copy of the 9182 -- proper definition. 9183 9184 declare 9185 Old_Comp : constant Node_Id := Component_Definition (Priv); 9186 Oent : constant Entity_Id := Defining_Identifier (Priv); 9187 New_Comp : Node_Id; 9188 Nent : constant Entity_Id := 9189 Make_Defining_Identifier (Sloc (Oent), 9190 Chars => Chars (Oent)); 9191 9192 begin 9193 if Present (Subtype_Indication (Old_Comp)) then 9194 New_Comp := 9195 Make_Component_Definition (Sloc (Oent), 9196 Aliased_Present => False, 9197 Subtype_Indication => 9198 New_Copy_Tree (Subtype_Indication (Old_Comp), 9199 Discr_Map)); 9200 else 9201 New_Comp := 9202 Make_Component_Definition (Sloc (Oent), 9203 Aliased_Present => False, 9204 Access_Definition => 9205 New_Copy_Tree (Access_Definition (Old_Comp), 9206 Discr_Map)); 9207 end if; 9208 9209 New_Priv := 9210 Make_Component_Declaration (Loc, 9211 Defining_Identifier => Nent, 9212 Component_Definition => New_Comp, 9213 Expression => Expression (Priv)); 9214 9215 Set_Has_Per_Object_Constraint (Nent, 9216 Has_Per_Object_Constraint (Oent)); 9217 9218 Append_To (Cdecls, New_Priv); 9219 end; 9220 9221 elsif Nkind (Priv) = N_Subprogram_Declaration then 9222 9223 -- Make the unprotected version of the subprogram available 9224 -- for expansion of intra object calls. There is need for 9225 -- a protected version only if the subprogram is an interrupt 9226 -- handler, otherwise this operation can only be called from 9227 -- within the body. 9228 9229 Sub := 9230 Make_Subprogram_Declaration (Loc, 9231 Specification => 9232 Build_Protected_Sub_Specification 9233 (Priv, Prot_Typ, Unprotected_Mode)); 9234 9235 Insert_After (Current_Node, Sub); 9236 Analyze (Sub); 9237 9238 Set_Protected_Body_Subprogram 9239 (Defining_Unit_Name (Specification (Priv)), 9240 Defining_Unit_Name (Specification (Sub))); 9241 Check_Inlining (Defining_Unit_Name (Specification (Priv))); 9242 Current_Node := Sub; 9243 9244 Sub := 9245 Make_Subprogram_Declaration (Loc, 9246 Specification => 9247 Build_Protected_Sub_Specification 9248 (Priv, Prot_Typ, Protected_Mode)); 9249 9250 Insert_After (Current_Node, Sub); 9251 Analyze (Sub); 9252 Current_Node := Sub; 9253 9254 if Is_Interrupt_Handler 9255 (Defining_Unit_Name (Specification (Priv))) 9256 then 9257 if not Restricted_Profile then 9258 Register_Handler; 9259 end if; 9260 end if; 9261 end if; 9262 9263 Next (Priv); 9264 end loop; 9265 end if; 9266 9267 -- Except for the lock-free implementation, append the _Object field 9268 -- with the right type to the component list. We need to compute the 9269 -- number of entries, and in some cases the number of Attach_Handler 9270 -- pragmas. 9271 9272 if not Lock_Free_Active then 9273 declare 9274 Ritem : Node_Id; 9275 Num_Attach_Handler : Int := 0; 9276 Protection_Subtype : Node_Id; 9277 Entry_Count_Expr : constant Node_Id := 9278 Build_Entry_Count_Expression 9279 (Prot_Typ, Cdecls, Loc); 9280 9281 begin 9282 if Has_Attach_Handler (Prot_Typ) then 9283 Ritem := First_Rep_Item (Prot_Typ); 9284 while Present (Ritem) loop 9285 if Nkind (Ritem) = N_Pragma 9286 and then Pragma_Name (Ritem) = Name_Attach_Handler 9287 then 9288 Num_Attach_Handler := Num_Attach_Handler + 1; 9289 end if; 9290 9291 Next_Rep_Item (Ritem); 9292 end loop; 9293 end if; 9294 9295 -- Determine the proper protection type. There are two special 9296 -- cases: 1) when the protected type has dynamic interrupt 9297 -- handlers, and 2) when it has static handlers and we use a 9298 -- restricted profile. 9299 9300 if Has_Attach_Handler (Prot_Typ) 9301 and then not Restricted_Profile 9302 then 9303 Protection_Subtype := 9304 Make_Subtype_Indication (Loc, 9305 Subtype_Mark => 9306 New_Occurrence_Of 9307 (RTE (RE_Static_Interrupt_Protection), Loc), 9308 Constraint => 9309 Make_Index_Or_Discriminant_Constraint (Loc, 9310 Constraints => New_List ( 9311 Entry_Count_Expr, 9312 Make_Integer_Literal (Loc, Num_Attach_Handler)))); 9313 9314 elsif Has_Interrupt_Handler (Prot_Typ) 9315 and then not Restriction_Active (No_Dynamic_Attachment) 9316 then 9317 Protection_Subtype := 9318 Make_Subtype_Indication (Loc, 9319 Subtype_Mark => 9320 New_Occurrence_Of 9321 (RTE (RE_Dynamic_Interrupt_Protection), Loc), 9322 Constraint => 9323 Make_Index_Or_Discriminant_Constraint (Loc, 9324 Constraints => New_List (Entry_Count_Expr))); 9325 9326 else 9327 case Corresponding_Runtime_Package (Prot_Typ) is 9328 when System_Tasking_Protected_Objects_Entries => 9329 Protection_Subtype := 9330 Make_Subtype_Indication (Loc, 9331 Subtype_Mark => 9332 New_Occurrence_Of 9333 (RTE (RE_Protection_Entries), Loc), 9334 Constraint => 9335 Make_Index_Or_Discriminant_Constraint (Loc, 9336 Constraints => New_List (Entry_Count_Expr))); 9337 9338 when System_Tasking_Protected_Objects_Single_Entry => 9339 Protection_Subtype := 9340 New_Occurrence_Of (RTE (RE_Protection_Entry), Loc); 9341 9342 when System_Tasking_Protected_Objects => 9343 Protection_Subtype := 9344 New_Occurrence_Of (RTE (RE_Protection), Loc); 9345 9346 when others => 9347 raise Program_Error; 9348 end case; 9349 end if; 9350 9351 Object_Comp := 9352 Make_Component_Declaration (Loc, 9353 Defining_Identifier => 9354 Make_Defining_Identifier (Loc, Name_uObject), 9355 Component_Definition => 9356 Make_Component_Definition (Loc, 9357 Aliased_Present => True, 9358 Subtype_Indication => Protection_Subtype)); 9359 end; 9360 9361 -- Put the _Object component after the private component so that it 9362 -- be finalized early as required by 9.4 (20) 9363 9364 Append_To (Cdecls, Object_Comp); 9365 end if; 9366 9367 Insert_After (Current_Node, Rec_Decl); 9368 Current_Node := Rec_Decl; 9369 9370 -- Analyze the record declaration immediately after construction, 9371 -- because the initialization procedure is needed for single object 9372 -- declarations before the next entity is analyzed (the freeze call 9373 -- that generates this initialization procedure is found below). 9374 9375 Analyze (Rec_Decl, Suppress => All_Checks); 9376 9377 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before 9378 -- the corresponding record is frozen. If any wrappers are generated, 9379 -- Current_Node is updated accordingly. 9380 9381 if Ada_Version >= Ada_2005 then 9382 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node); 9383 end if; 9384 9385 -- Collect pointers to entry bodies and their barriers, to be placed 9386 -- in the Entry_Bodies_Array for the type. For each entry/family we 9387 -- add an expression to the aggregate which is the initial value of 9388 -- this array. The array is declared after all protected subprograms. 9389 9390 if Has_Entries (Prot_Typ) then 9391 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List); 9392 else 9393 Entries_Aggr := Empty; 9394 end if; 9395 9396 -- Build two new procedure specifications for each protected subprogram; 9397 -- one to call from outside the object and one to call from inside. 9398 -- Build a barrier function and an entry body action procedure 9399 -- specification for each protected entry. Initialize the entry body 9400 -- array. If subprogram is flagged as eliminated, do not generate any 9401 -- internal operations. 9402 9403 E_Count := 0; 9404 Comp := First (Visible_Declarations (Pdef)); 9405 while Present (Comp) loop 9406 if Nkind (Comp) = N_Subprogram_Declaration then 9407 Sub := 9408 Make_Subprogram_Declaration (Loc, 9409 Specification => 9410 Build_Protected_Sub_Specification 9411 (Comp, Prot_Typ, Unprotected_Mode)); 9412 9413 Insert_After (Current_Node, Sub); 9414 Analyze (Sub); 9415 9416 Set_Protected_Body_Subprogram 9417 (Defining_Unit_Name (Specification (Comp)), 9418 Defining_Unit_Name (Specification (Sub))); 9419 Check_Inlining (Defining_Unit_Name (Specification (Comp))); 9420 9421 -- Make the protected version of the subprogram available for 9422 -- expansion of external calls. 9423 9424 Current_Node := Sub; 9425 9426 Sub := 9427 Make_Subprogram_Declaration (Loc, 9428 Specification => 9429 Build_Protected_Sub_Specification 9430 (Comp, Prot_Typ, Protected_Mode)); 9431 9432 Insert_After (Current_Node, Sub); 9433 Analyze (Sub); 9434 9435 Current_Node := Sub; 9436 9437 -- Generate an overriding primitive operation specification for 9438 -- this subprogram if the protected type implements an interface. 9439 9440 if Ada_Version >= Ada_2005 9441 and then 9442 Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) 9443 then 9444 Sub := 9445 Make_Subprogram_Declaration (Loc, 9446 Specification => 9447 Build_Protected_Sub_Specification 9448 (Comp, Prot_Typ, Dispatching_Mode)); 9449 9450 Insert_After (Current_Node, Sub); 9451 Analyze (Sub); 9452 9453 Current_Node := Sub; 9454 end if; 9455 9456 -- If a pragma Interrupt_Handler applies, build and add a call to 9457 -- Register_Interrupt_Handler to the freezing actions of the 9458 -- protected version (Current_Node) of the subprogram: 9459 9460 -- system.interrupts.register_interrupt_handler 9461 -- (prot_procP'address); 9462 9463 if not Restricted_Profile 9464 and then Is_Interrupt_Handler 9465 (Defining_Unit_Name (Specification (Comp))) 9466 then 9467 Register_Handler; 9468 end if; 9469 9470 elsif Nkind (Comp) = N_Entry_Declaration then 9471 9472 Expand_Entry_Declaration (Comp); 9473 9474 end if; 9475 9476 Next (Comp); 9477 end loop; 9478 9479 -- If there are some private entry declarations, expand it as if they 9480 -- were visible entries. 9481 9482 if Present (Private_Declarations (Pdef)) then 9483 Comp := First (Private_Declarations (Pdef)); 9484 while Present (Comp) loop 9485 if Nkind (Comp) = N_Entry_Declaration then 9486 Expand_Entry_Declaration (Comp); 9487 end if; 9488 9489 Next (Comp); 9490 end loop; 9491 end if; 9492 9493 -- Emit declaration for Entry_Bodies_Array, now that the addresses of 9494 -- all protected subprograms have been collected. 9495 9496 if Has_Entries (Prot_Typ) then 9497 Body_Id := 9498 Make_Defining_Identifier (Sloc (Prot_Typ), 9499 Chars => New_External_Name (Chars (Prot_Typ), 'A')); 9500 9501 case Corresponding_Runtime_Package (Prot_Typ) is 9502 when System_Tasking_Protected_Objects_Entries => 9503 Body_Arr := Make_Object_Declaration (Loc, 9504 Defining_Identifier => Body_Id, 9505 Aliased_Present => True, 9506 Object_Definition => 9507 Make_Subtype_Indication (Loc, 9508 Subtype_Mark => New_Occurrence_Of ( 9509 RTE (RE_Protected_Entry_Body_Array), Loc), 9510 Constraint => 9511 Make_Index_Or_Discriminant_Constraint (Loc, 9512 Constraints => New_List ( 9513 Make_Range (Loc, 9514 Make_Integer_Literal (Loc, 1), 9515 Make_Integer_Literal (Loc, E_Count))))), 9516 Expression => Entries_Aggr); 9517 9518 when System_Tasking_Protected_Objects_Single_Entry => 9519 Body_Arr := Make_Object_Declaration (Loc, 9520 Defining_Identifier => Body_Id, 9521 Aliased_Present => True, 9522 Object_Definition => New_Occurrence_Of 9523 (RTE (RE_Entry_Body), Loc), 9524 Expression => Remove_Head (Expressions (Entries_Aggr))); 9525 9526 when others => 9527 raise Program_Error; 9528 end case; 9529 9530 -- A pointer to this array will be placed in the corresponding record 9531 -- by its initialization procedure so this needs to be analyzed here. 9532 9533 Insert_After (Current_Node, Body_Arr); 9534 Current_Node := Body_Arr; 9535 Analyze (Body_Arr); 9536 9537 Set_Entry_Bodies_Array (Prot_Typ, Body_Id); 9538 9539 -- Finally, build the function that maps an entry index into the 9540 -- corresponding body. A pointer to this function is placed in each 9541 -- object of the type. Except for a ravenscar-like profile (no abort, 9542 -- no entry queue, 1 entry) 9543 9544 if Corresponding_Runtime_Package (Prot_Typ) = 9545 System_Tasking_Protected_Objects_Entries 9546 then 9547 Sub := 9548 Make_Subprogram_Declaration (Loc, 9549 Specification => Build_Find_Body_Index_Spec (Prot_Typ)); 9550 Insert_After (Current_Node, Sub); 9551 Analyze (Sub); 9552 end if; 9553 end if; 9554 end Expand_N_Protected_Type_Declaration; 9555 9556 -------------------------------- 9557 -- Expand_N_Requeue_Statement -- 9558 -------------------------------- 9559 9560 -- A non-dispatching requeue statement is expanded into one of four GNARLI 9561 -- operations, depending on the source and destination (task or protected 9562 -- object). A dispatching requeue statement is expanded into a call to the 9563 -- predefined primitive _Disp_Requeue. In addition, code is generated to 9564 -- jump around the remainder of processing for the original entry and, if 9565 -- the destination is (different) protected object, to attempt to service 9566 -- it. The following illustrates the various cases: 9567 9568 -- procedure entE 9569 -- (O : System.Address; 9570 -- P : System.Address; 9571 -- E : Protected_Entry_Index) 9572 -- is 9573 -- <discriminant renamings> 9574 -- <private object renamings> 9575 -- type poVP is access poV; 9576 -- _object : ptVP := ptVP!(O); 9577 9578 -- begin 9579 -- begin 9580 -- <start of statement sequence for entry> 9581 9582 -- -- Requeue from one protected entry body to another protected 9583 -- -- entry. 9584 9585 -- Requeue_Protected_Entry ( 9586 -- _object._object'Access, 9587 -- new._object'Access, 9588 -- E, 9589 -- Abort_Present); 9590 -- return; 9591 9592 -- <some more of the statement sequence for entry> 9593 9594 -- -- Requeue from an entry body to a task entry 9595 9596 -- Requeue_Protected_To_Task_Entry ( 9597 -- New._task_id, 9598 -- E, 9599 -- Abort_Present); 9600 -- return; 9601 9602 -- <rest of statement sequence for entry> 9603 -- Complete_Entry_Body (_object._object); 9604 9605 -- exception 9606 -- when all others => 9607 -- Exceptional_Complete_Entry_Body ( 9608 -- _object._object, Get_GNAT_Exception); 9609 -- end; 9610 -- end entE; 9611 9612 -- Requeue of a task entry call to a task entry 9613 9614 -- Accept_Call (E, Ann); 9615 -- <start of statement sequence for accept statement> 9616 -- Requeue_Task_Entry (New._task_id, E, Abort_Present); 9617 -- goto Lnn; 9618 -- <rest of statement sequence for accept statement> 9619 -- <<Lnn>> 9620 -- Complete_Rendezvous; 9621 9622 -- exception 9623 -- when all others => 9624 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9625 9626 -- Requeue of a task entry call to a protected entry 9627 9628 -- Accept_Call (E, Ann); 9629 -- <start of statement sequence for accept statement> 9630 -- Requeue_Task_To_Protected_Entry ( 9631 -- new._object'Access, 9632 -- E, 9633 -- Abort_Present); 9634 -- newS (new, Pnn); 9635 -- goto Lnn; 9636 -- <rest of statement sequence for accept statement> 9637 -- <<Lnn>> 9638 -- Complete_Rendezvous; 9639 9640 -- exception 9641 -- when all others => 9642 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9643 9644 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9645 -- marked by pragma Implemented (XXX, By_Entry). 9646 9647 -- The requeue is inside a protected entry: 9648 9649 -- procedure entE 9650 -- (O : System.Address; 9651 -- P : System.Address; 9652 -- E : Protected_Entry_Index) 9653 -- is 9654 -- <discriminant renamings> 9655 -- <private object renamings> 9656 -- type poVP is access poV; 9657 -- _object : ptVP := ptVP!(O); 9658 9659 -- begin 9660 -- begin 9661 -- <start of statement sequence for entry> 9662 9663 -- _Disp_Requeue 9664 -- (<interface class-wide object>, 9665 -- True, 9666 -- _object'Address, 9667 -- Ada.Tags.Get_Offset_Index 9668 -- (Tag (_object), 9669 -- <interface dispatch table index of target entry>), 9670 -- Abort_Present); 9671 -- return; 9672 9673 -- <rest of statement sequence for entry> 9674 -- Complete_Entry_Body (_object._object); 9675 9676 -- exception 9677 -- when all others => 9678 -- Exceptional_Complete_Entry_Body ( 9679 -- _object._object, Get_GNAT_Exception); 9680 -- end; 9681 -- end entE; 9682 9683 -- The requeue is inside a task entry: 9684 9685 -- Accept_Call (E, Ann); 9686 -- <start of statement sequence for accept statement> 9687 -- _Disp_Requeue 9688 -- (<interface class-wide object>, 9689 -- False, 9690 -- null, 9691 -- Ada.Tags.Get_Offset_Index 9692 -- (Tag (_object), 9693 -- <interface dispatch table index of target entrt>), 9694 -- Abort_Present); 9695 -- newS (new, Pnn); 9696 -- goto Lnn; 9697 -- <rest of statement sequence for accept statement> 9698 -- <<Lnn>> 9699 -- Complete_Rendezvous; 9700 9701 -- exception 9702 -- when all others => 9703 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9704 9705 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9706 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue 9707 -- statement is replaced by a dispatching call with actual parameters taken 9708 -- from the inner-most accept statement or entry body. 9709 9710 -- Target.Primitive (Param1, ..., ParamN); 9711 9712 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9713 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked 9714 -- at all. 9715 9716 -- declare 9717 -- S : constant Offset_Index := 9718 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename)); 9719 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S); 9720 9721 -- begin 9722 -- if C = POK_Protected_Entry 9723 -- or else C = POK_Task_Entry 9724 -- then 9725 -- <statements for dispatching requeue> 9726 9727 -- elsif C = POK_Protected_Procedure then 9728 -- <dispatching call equivalent> 9729 9730 -- else 9731 -- raise Program_Error; 9732 -- end if; 9733 -- end; 9734 9735 procedure Expand_N_Requeue_Statement (N : Node_Id) is 9736 Loc : constant Source_Ptr := Sloc (N); 9737 Conc_Typ : Entity_Id; 9738 Concval : Node_Id; 9739 Ename : Node_Id; 9740 Index : Node_Id; 9741 Old_Typ : Entity_Id; 9742 9743 function Build_Dispatching_Call_Equivalent return Node_Id; 9744 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9745 -- the form Concval.Ename. It is statically known that Ename is allowed 9746 -- to be implemented by a protected procedure. Create a dispatching call 9747 -- equivalent of Concval.Ename taking the actual parameters from the 9748 -- inner-most accept statement or entry body. 9749 9750 function Build_Dispatching_Requeue return Node_Id; 9751 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9752 -- the form Concval.Ename. It is statically known that Ename is allowed 9753 -- to be implemented by a protected or a task entry. Create a call to 9754 -- primitive _Disp_Requeue which handles the low-level actions. 9755 9756 function Build_Dispatching_Requeue_To_Any return Node_Id; 9757 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9758 -- the form Concval.Ename. Ename is either marked by pragma Implemented 9759 -- (XXX, By_Any | Optional) or not marked at all. Create a block which 9760 -- determines at runtime whether Ename denotes an entry or a procedure 9761 -- and perform the appropriate kind of dispatching select. 9762 9763 function Build_Normal_Requeue return Node_Id; 9764 -- N denotes a non-dispatching requeue statement to either a task or a 9765 -- protected entry. Build the appropriate runtime call to perform the 9766 -- action. 9767 9768 function Build_Skip_Statement (Search : Node_Id) return Node_Id; 9769 -- For a protected entry, create a return statement to skip the rest of 9770 -- the entry body. Otherwise, create a goto statement to skip the rest 9771 -- of a task accept statement. The lookup for the enclosing entry body 9772 -- or accept statement starts from Search. 9773 9774 --------------------------------------- 9775 -- Build_Dispatching_Call_Equivalent -- 9776 --------------------------------------- 9777 9778 function Build_Dispatching_Call_Equivalent return Node_Id is 9779 Call_Ent : constant Entity_Id := Entity (Ename); 9780 Obj : constant Node_Id := Original_Node (Concval); 9781 Acc_Ent : Node_Id; 9782 Actuals : List_Id; 9783 Formal : Node_Id; 9784 Formals : List_Id; 9785 9786 begin 9787 -- Climb the parent chain looking for the inner-most entry body or 9788 -- accept statement. 9789 9790 Acc_Ent := N; 9791 while Present (Acc_Ent) 9792 and then not Nkind_In (Acc_Ent, N_Accept_Statement, 9793 N_Entry_Body) 9794 loop 9795 Acc_Ent := Parent (Acc_Ent); 9796 end loop; 9797 9798 -- A requeue statement should be housed inside an entry body or an 9799 -- accept statement at some level. If this is not the case, then the 9800 -- tree is malformed. 9801 9802 pragma Assert (Present (Acc_Ent)); 9803 9804 -- Recover the list of formal parameters 9805 9806 if Nkind (Acc_Ent) = N_Entry_Body then 9807 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent); 9808 end if; 9809 9810 Formals := Parameter_Specifications (Acc_Ent); 9811 9812 -- Create the actual parameters for the dispatching call. These are 9813 -- simply copies of the entry body or accept statement formals in the 9814 -- same order as they appear. 9815 9816 Actuals := No_List; 9817 9818 if Present (Formals) then 9819 Actuals := New_List; 9820 Formal := First (Formals); 9821 while Present (Formal) loop 9822 Append_To (Actuals, 9823 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 9824 Next (Formal); 9825 end loop; 9826 end if; 9827 9828 -- Generate: 9829 -- Obj.Call_Ent (Actuals); 9830 9831 return 9832 Make_Procedure_Call_Statement (Loc, 9833 Name => 9834 Make_Selected_Component (Loc, 9835 Prefix => Make_Identifier (Loc, Chars (Obj)), 9836 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))), 9837 9838 Parameter_Associations => Actuals); 9839 end Build_Dispatching_Call_Equivalent; 9840 9841 ------------------------------- 9842 -- Build_Dispatching_Requeue -- 9843 ------------------------------- 9844 9845 function Build_Dispatching_Requeue return Node_Id is 9846 Params : constant List_Id := New_List; 9847 9848 begin 9849 -- Process the "with abort" parameter 9850 9851 Prepend_To (Params, 9852 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 9853 9854 -- Process the entry wrapper's position in the primary dispatch 9855 -- table parameter. Generate: 9856 9857 -- Ada.Tags.Get_Entry_Index 9858 -- (T => To_Tag_Ptr (Obj'Address).all, 9859 -- Position => 9860 -- Ada.Tags.Get_Offset_Index 9861 -- (Ada.Tags.Tag (Concval), 9862 -- <interface dispatch table position of Ename>)); 9863 9864 -- Note that Obj'Address is recursively expanded into a call to 9865 -- Base_Address (Obj). 9866 9867 if Tagged_Type_Expansion then 9868 Prepend_To (Params, 9869 Make_Function_Call (Loc, 9870 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 9871 Parameter_Associations => New_List ( 9872 9873 Make_Explicit_Dereference (Loc, 9874 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 9875 Make_Attribute_Reference (Loc, 9876 Prefix => New_Copy_Tree (Concval), 9877 Attribute_Name => Name_Address))), 9878 9879 Make_Function_Call (Loc, 9880 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 9881 Parameter_Associations => New_List ( 9882 Unchecked_Convert_To (RTE (RE_Tag), Concval), 9883 Make_Integer_Literal (Loc, 9884 DT_Position (Entity (Ename)))))))); 9885 9886 -- VM targets 9887 9888 else 9889 Prepend_To (Params, 9890 Make_Function_Call (Loc, 9891 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 9892 Parameter_Associations => New_List ( 9893 9894 Make_Attribute_Reference (Loc, 9895 Prefix => Concval, 9896 Attribute_Name => Name_Tag), 9897 9898 Make_Function_Call (Loc, 9899 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 9900 9901 Parameter_Associations => New_List ( 9902 9903 -- Obj_Tag 9904 9905 Make_Attribute_Reference (Loc, 9906 Prefix => Concval, 9907 Attribute_Name => Name_Tag), 9908 9909 -- Tag_Typ 9910 9911 Make_Attribute_Reference (Loc, 9912 Prefix => New_Occurrence_Of (Etype (Concval), Loc), 9913 Attribute_Name => Name_Tag), 9914 9915 -- Position 9916 9917 Make_Integer_Literal (Loc, 9918 DT_Position (Entity (Ename)))))))); 9919 end if; 9920 9921 -- Specific actuals for protected to XXX requeue 9922 9923 if Is_Protected_Type (Old_Typ) then 9924 Prepend_To (Params, 9925 Make_Attribute_Reference (Loc, -- _object'Address 9926 Prefix => 9927 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 9928 Attribute_Name => Name_Address)); 9929 9930 Prepend_To (Params, -- True 9931 New_Occurrence_Of (Standard_True, Loc)); 9932 9933 -- Specific actuals for task to XXX requeue 9934 9935 else 9936 pragma Assert (Is_Task_Type (Old_Typ)); 9937 9938 Prepend_To (Params, -- null 9939 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 9940 9941 Prepend_To (Params, -- False 9942 New_Occurrence_Of (Standard_False, Loc)); 9943 end if; 9944 9945 -- Add the object parameter 9946 9947 Prepend_To (Params, New_Copy_Tree (Concval)); 9948 9949 -- Generate: 9950 -- _Disp_Requeue (<Params>); 9951 9952 -- Find entity for Disp_Requeue operation, which belongs to 9953 -- the type and may not be directly visible. 9954 9955 declare 9956 Elmt : Elmt_Id; 9957 Op : Entity_Id; 9958 9959 begin 9960 Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ))); 9961 while Present (Elmt) loop 9962 Op := Node (Elmt); 9963 exit when Chars (Op) = Name_uDisp_Requeue; 9964 Next_Elmt (Elmt); 9965 end loop; 9966 9967 return 9968 Make_Procedure_Call_Statement (Loc, 9969 Name => New_Occurrence_Of (Op, Loc), 9970 Parameter_Associations => Params); 9971 end; 9972 end Build_Dispatching_Requeue; 9973 9974 -------------------------------------- 9975 -- Build_Dispatching_Requeue_To_Any -- 9976 -------------------------------------- 9977 9978 function Build_Dispatching_Requeue_To_Any return Node_Id is 9979 Call_Ent : constant Entity_Id := Entity (Ename); 9980 Obj : constant Node_Id := Original_Node (Concval); 9981 Skip : constant Node_Id := Build_Skip_Statement (N); 9982 C : Entity_Id; 9983 Decls : List_Id; 9984 S : Entity_Id; 9985 Stmts : List_Id; 9986 9987 begin 9988 Decls := New_List; 9989 Stmts := New_List; 9990 9991 -- Dispatch table slot processing, generate: 9992 -- S : Integer; 9993 9994 S := Build_S (Loc, Decls); 9995 9996 -- Call kind processing, generate: 9997 -- C : Ada.Tags.Prim_Op_Kind; 9998 9999 C := Build_C (Loc, Decls); 10000 10001 -- Generate: 10002 -- S := Ada.Tags.Get_Offset_Index 10003 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent)); 10004 10005 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent)); 10006 10007 -- Generate: 10008 -- _Disp_Get_Prim_Op_Kind (Obj, S, C); 10009 10010 Append_To (Stmts, 10011 Make_Procedure_Call_Statement (Loc, 10012 Name => 10013 New_Occurrence_Of ( 10014 Find_Prim_Op (Etype (Etype (Obj)), 10015 Name_uDisp_Get_Prim_Op_Kind), 10016 Loc), 10017 Parameter_Associations => New_List ( 10018 New_Copy_Tree (Obj), 10019 New_Occurrence_Of (S, Loc), 10020 New_Occurrence_Of (C, Loc)))); 10021 10022 Append_To (Stmts, 10023 10024 -- if C = POK_Protected_Entry 10025 -- or else C = POK_Task_Entry 10026 -- then 10027 10028 Make_Implicit_If_Statement (N, 10029 Condition => 10030 Make_Op_Or (Loc, 10031 Left_Opnd => 10032 Make_Op_Eq (Loc, 10033 Left_Opnd => 10034 New_Occurrence_Of (C, Loc), 10035 Right_Opnd => 10036 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 10037 10038 Right_Opnd => 10039 Make_Op_Eq (Loc, 10040 Left_Opnd => 10041 New_Occurrence_Of (C, Loc), 10042 Right_Opnd => 10043 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 10044 10045 -- Dispatching requeue equivalent 10046 10047 Then_Statements => New_List ( 10048 Build_Dispatching_Requeue, 10049 Skip), 10050 10051 -- elsif C = POK_Protected_Procedure then 10052 10053 Elsif_Parts => New_List ( 10054 Make_Elsif_Part (Loc, 10055 Condition => 10056 Make_Op_Eq (Loc, 10057 Left_Opnd => 10058 New_Occurrence_Of (C, Loc), 10059 Right_Opnd => 10060 New_Occurrence_Of ( 10061 RTE (RE_POK_Protected_Procedure), Loc)), 10062 10063 -- Dispatching call equivalent 10064 10065 Then_Statements => New_List ( 10066 Build_Dispatching_Call_Equivalent))), 10067 10068 -- else 10069 -- raise Program_Error; 10070 -- end if; 10071 10072 Else_Statements => New_List ( 10073 Make_Raise_Program_Error (Loc, 10074 Reason => PE_Explicit_Raise)))); 10075 10076 -- Wrap everything into a block 10077 10078 return 10079 Make_Block_Statement (Loc, 10080 Declarations => Decls, 10081 Handled_Statement_Sequence => 10082 Make_Handled_Sequence_Of_Statements (Loc, 10083 Statements => Stmts)); 10084 end Build_Dispatching_Requeue_To_Any; 10085 10086 -------------------------- 10087 -- Build_Normal_Requeue -- 10088 -------------------------- 10089 10090 function Build_Normal_Requeue return Node_Id is 10091 Params : constant List_Id := New_List; 10092 Param : Node_Id; 10093 RT_Call : Node_Id; 10094 10095 begin 10096 -- Process the "with abort" parameter 10097 10098 Prepend_To (Params, 10099 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 10100 10101 -- Add the index expression to the parameters. It is common among all 10102 -- four cases. 10103 10104 Prepend_To (Params, 10105 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ)); 10106 10107 if Is_Protected_Type (Old_Typ) then 10108 declare 10109 Self_Param : Node_Id; 10110 10111 begin 10112 Self_Param := 10113 Make_Attribute_Reference (Loc, 10114 Prefix => 10115 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 10116 Attribute_Name => 10117 Name_Unchecked_Access); 10118 10119 -- Protected to protected requeue 10120 10121 if Is_Protected_Type (Conc_Typ) then 10122 RT_Call := 10123 New_Occurrence_Of ( 10124 RTE (RE_Requeue_Protected_Entry), Loc); 10125 10126 Param := 10127 Make_Attribute_Reference (Loc, 10128 Prefix => 10129 Concurrent_Ref (Concval), 10130 Attribute_Name => 10131 Name_Unchecked_Access); 10132 10133 -- Protected to task requeue 10134 10135 else pragma Assert (Is_Task_Type (Conc_Typ)); 10136 RT_Call := 10137 New_Occurrence_Of ( 10138 RTE (RE_Requeue_Protected_To_Task_Entry), Loc); 10139 10140 Param := Concurrent_Ref (Concval); 10141 end if; 10142 10143 Prepend_To (Params, Param); 10144 Prepend_To (Params, Self_Param); 10145 end; 10146 10147 else pragma Assert (Is_Task_Type (Old_Typ)); 10148 10149 -- Task to protected requeue 10150 10151 if Is_Protected_Type (Conc_Typ) then 10152 RT_Call := 10153 New_Occurrence_Of ( 10154 RTE (RE_Requeue_Task_To_Protected_Entry), Loc); 10155 10156 Param := 10157 Make_Attribute_Reference (Loc, 10158 Prefix => 10159 Concurrent_Ref (Concval), 10160 Attribute_Name => 10161 Name_Unchecked_Access); 10162 10163 -- Task to task requeue 10164 10165 else pragma Assert (Is_Task_Type (Conc_Typ)); 10166 RT_Call := 10167 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc); 10168 10169 Param := Concurrent_Ref (Concval); 10170 end if; 10171 10172 Prepend_To (Params, Param); 10173 end if; 10174 10175 return 10176 Make_Procedure_Call_Statement (Loc, 10177 Name => RT_Call, 10178 Parameter_Associations => Params); 10179 end Build_Normal_Requeue; 10180 10181 -------------------------- 10182 -- Build_Skip_Statement -- 10183 -------------------------- 10184 10185 function Build_Skip_Statement (Search : Node_Id) return Node_Id is 10186 Skip_Stmt : Node_Id; 10187 10188 begin 10189 -- Build a return statement to skip the rest of the entire body 10190 10191 if Is_Protected_Type (Old_Typ) then 10192 Skip_Stmt := Make_Simple_Return_Statement (Loc); 10193 10194 -- If the requeue is within a task, find the end label of the 10195 -- enclosing accept statement and create a goto statement to it. 10196 10197 else 10198 declare 10199 Acc : Node_Id; 10200 Label : Node_Id; 10201 10202 begin 10203 -- Climb the parent chain looking for the enclosing accept 10204 -- statement. 10205 10206 Acc := Parent (Search); 10207 while Present (Acc) 10208 and then Nkind (Acc) /= N_Accept_Statement 10209 loop 10210 Acc := Parent (Acc); 10211 end loop; 10212 10213 -- The last statement is the second label used for completing 10214 -- the rendezvous the usual way. The label we are looking for 10215 -- is right before it. 10216 10217 Label := 10218 Prev (Last (Statements (Handled_Statement_Sequence (Acc)))); 10219 10220 pragma Assert (Nkind (Label) = N_Label); 10221 10222 -- Generate a goto statement to skip the rest of the accept 10223 10224 Skip_Stmt := 10225 Make_Goto_Statement (Loc, 10226 Name => 10227 New_Occurrence_Of (Entity (Identifier (Label)), Loc)); 10228 end; 10229 end if; 10230 10231 Set_Analyzed (Skip_Stmt); 10232 10233 return Skip_Stmt; 10234 end Build_Skip_Statement; 10235 10236 -- Start of processing for Expand_N_Requeue_Statement 10237 10238 begin 10239 -- Extract the components of the entry call 10240 10241 Extract_Entry (N, Concval, Ename, Index); 10242 Conc_Typ := Etype (Concval); 10243 10244 -- If the prefix is an access to class-wide type, dereference to get 10245 -- object and entry type. 10246 10247 if Is_Access_Type (Conc_Typ) then 10248 Conc_Typ := Designated_Type (Conc_Typ); 10249 Rewrite (Concval, 10250 Make_Explicit_Dereference (Loc, Relocate_Node (Concval))); 10251 Analyze_And_Resolve (Concval, Conc_Typ); 10252 end if; 10253 10254 -- Examine the scope stack in order to find nearest enclosing protected 10255 -- or task type. This will constitute our invocation source. 10256 10257 Old_Typ := Current_Scope; 10258 while Present (Old_Typ) 10259 and then not Is_Protected_Type (Old_Typ) 10260 and then not Is_Task_Type (Old_Typ) 10261 loop 10262 Old_Typ := Scope (Old_Typ); 10263 end loop; 10264 10265 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form 10266 -- Concval.Ename where the type of Concval is class-wide concurrent 10267 -- interface. 10268 10269 if Ada_Version >= Ada_2012 10270 and then Present (Concval) 10271 and then Is_Class_Wide_Type (Conc_Typ) 10272 and then Is_Concurrent_Interface (Conc_Typ) 10273 then 10274 declare 10275 Has_Impl : Boolean := False; 10276 Impl_Kind : Name_Id := No_Name; 10277 10278 begin 10279 -- Check whether the Ename is flagged by pragma Implemented 10280 10281 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then 10282 Has_Impl := True; 10283 Impl_Kind := Implementation_Kind (Entity (Ename)); 10284 end if; 10285 10286 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10287 -- an entry. Create a call to predefined primitive _Disp_Requeue. 10288 10289 if Has_Impl and then Impl_Kind = Name_By_Entry then 10290 Rewrite (N, Build_Dispatching_Requeue); 10291 Analyze (N); 10292 Insert_After (N, Build_Skip_Statement (N)); 10293 10294 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10295 -- a protected procedure. In this case the requeue is transformed 10296 -- into a dispatching call. 10297 10298 elsif Has_Impl 10299 and then Impl_Kind = Name_By_Protected_Procedure 10300 then 10301 Rewrite (N, Build_Dispatching_Call_Equivalent); 10302 Analyze (N); 10303 10304 -- The procedure_or_entry_NAME's implementation kind is either 10305 -- By_Any, Optional, or pragma Implemented was not applied at all. 10306 -- In this case a runtime test determines whether Ename denotes an 10307 -- entry or a protected procedure and performs the appropriate 10308 -- call. 10309 10310 else 10311 Rewrite (N, Build_Dispatching_Requeue_To_Any); 10312 Analyze (N); 10313 end if; 10314 end; 10315 10316 -- Processing for regular (non-dispatching) requeues 10317 10318 else 10319 Rewrite (N, Build_Normal_Requeue); 10320 Analyze (N); 10321 Insert_After (N, Build_Skip_Statement (N)); 10322 end if; 10323 end Expand_N_Requeue_Statement; 10324 10325 ------------------------------- 10326 -- Expand_N_Selective_Accept -- 10327 ------------------------------- 10328 10329 procedure Expand_N_Selective_Accept (N : Node_Id) is 10330 Loc : constant Source_Ptr := Sloc (N); 10331 Alts : constant List_Id := Select_Alternatives (N); 10332 10333 -- Note: in the below declarations a lot of new lists are allocated 10334 -- unconditionally which may well not end up being used. That's not 10335 -- a good idea since it wastes space gratuitously ??? 10336 10337 Accept_Case : List_Id; 10338 Accept_List : constant List_Id := New_List; 10339 10340 Alt : Node_Id; 10341 Alt_List : constant List_Id := New_List; 10342 Alt_Stats : List_Id; 10343 Ann : Entity_Id := Empty; 10344 10345 Check_Guard : Boolean := True; 10346 10347 Decls : constant List_Id := New_List; 10348 Stats : constant List_Id := New_List; 10349 Body_List : constant List_Id := New_List; 10350 Trailing_List : constant List_Id := New_List; 10351 10352 Choices : List_Id; 10353 Else_Present : Boolean := False; 10354 Terminate_Alt : Node_Id := Empty; 10355 Select_Mode : Node_Id; 10356 10357 Delay_Case : List_Id; 10358 Delay_Count : Integer := 0; 10359 Delay_Val : Entity_Id; 10360 Delay_Index : Entity_Id; 10361 Delay_Min : Entity_Id; 10362 Delay_Num : Int := 1; 10363 Delay_Alt_List : List_Id := New_List; 10364 Delay_List : constant List_Id := New_List; 10365 D : Entity_Id; 10366 M : Entity_Id; 10367 10368 First_Delay : Boolean := True; 10369 Guard_Open : Entity_Id; 10370 10371 End_Lab : Node_Id; 10372 Index : Int := 1; 10373 Lab : Node_Id; 10374 Num_Alts : Int; 10375 Num_Accept : Nat := 0; 10376 Proc : Node_Id; 10377 Time_Type : Entity_Id; 10378 Select_Call : Node_Id; 10379 10380 Qnam : constant Entity_Id := 10381 Make_Defining_Identifier (Loc, New_External_Name ('S', 0)); 10382 10383 Xnam : constant Entity_Id := 10384 Make_Defining_Identifier (Loc, New_External_Name ('J', 1)); 10385 10386 ----------------------- 10387 -- Local subprograms -- 10388 ----------------------- 10389 10390 function Accept_Or_Raise return List_Id; 10391 -- For the rare case where delay alternatives all have guards, and 10392 -- all of them are closed, it is still possible that there were open 10393 -- accept alternatives with no callers. We must reexamine the 10394 -- Accept_List, and execute a selective wait with no else if some 10395 -- accept is open. If none, we raise program_error. 10396 10397 procedure Add_Accept (Alt : Node_Id); 10398 -- Process a single accept statement in a select alternative. Build 10399 -- procedure for body of accept, and add entry to dispatch table with 10400 -- expression for guard, in preparation for call to run time select. 10401 10402 function Make_And_Declare_Label (Num : Int) return Node_Id; 10403 -- Manufacture a label using Num as a serial number and declare it. 10404 -- The declaration is appended to Decls. The label marks the trailing 10405 -- statements of an accept or delay alternative. 10406 10407 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id; 10408 -- Build call to Selective_Wait runtime routine 10409 10410 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int); 10411 -- Add code to compare value of delay with previous values, and 10412 -- generate case entry for trailing statements. 10413 10414 procedure Process_Accept_Alternative 10415 (Alt : Node_Id; 10416 Index : Int; 10417 Proc : Node_Id); 10418 -- Add code to call corresponding procedure, and branch to 10419 -- trailing statements, if any. 10420 10421 --------------------- 10422 -- Accept_Or_Raise -- 10423 --------------------- 10424 10425 function Accept_Or_Raise return List_Id is 10426 Cond : Node_Id; 10427 Stats : List_Id; 10428 J : constant Entity_Id := Make_Temporary (Loc, 'J'); 10429 10430 begin 10431 -- We generate the following: 10432 10433 -- for J in q'range loop 10434 -- if q(J).S /=null_task_entry then 10435 -- selective_wait (simple_mode,...); 10436 -- done := True; 10437 -- exit; 10438 -- end if; 10439 -- end loop; 10440 -- 10441 -- if no rendez_vous then 10442 -- raise program_error; 10443 -- end if; 10444 10445 -- Note that the code needs to know that the selector name 10446 -- in an Accept_Alternative is named S. 10447 10448 Cond := Make_Op_Ne (Loc, 10449 Left_Opnd => 10450 Make_Selected_Component (Loc, 10451 Prefix => 10452 Make_Indexed_Component (Loc, 10453 Prefix => New_Occurrence_Of (Qnam, Loc), 10454 Expressions => New_List (New_Occurrence_Of (J, Loc))), 10455 Selector_Name => Make_Identifier (Loc, Name_S)), 10456 Right_Opnd => 10457 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc)); 10458 10459 Stats := New_List ( 10460 Make_Implicit_Loop_Statement (N, 10461 Iteration_Scheme => 10462 Make_Iteration_Scheme (Loc, 10463 Loop_Parameter_Specification => 10464 Make_Loop_Parameter_Specification (Loc, 10465 Defining_Identifier => J, 10466 Discrete_Subtype_Definition => 10467 Make_Attribute_Reference (Loc, 10468 Prefix => New_Occurrence_Of (Qnam, Loc), 10469 Attribute_Name => Name_Range, 10470 Expressions => New_List ( 10471 Make_Integer_Literal (Loc, 1))))), 10472 10473 Statements => New_List ( 10474 Make_Implicit_If_Statement (N, 10475 Condition => Cond, 10476 Then_Statements => New_List ( 10477 Make_Select_Call ( 10478 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)), 10479 Make_Exit_Statement (Loc)))))); 10480 10481 Append_To (Stats, 10482 Make_Raise_Program_Error (Loc, 10483 Condition => Make_Op_Eq (Loc, 10484 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 10485 Right_Opnd => 10486 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 10487 Reason => PE_All_Guards_Closed)); 10488 10489 return Stats; 10490 end Accept_Or_Raise; 10491 10492 ---------------- 10493 -- Add_Accept -- 10494 ---------------- 10495 10496 procedure Add_Accept (Alt : Node_Id) is 10497 Acc_Stm : constant Node_Id := Accept_Statement (Alt); 10498 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm); 10499 Eloc : constant Source_Ptr := Sloc (Ename); 10500 Eent : constant Entity_Id := Entity (Ename); 10501 Index : constant Node_Id := Entry_Index (Acc_Stm); 10502 Null_Body : Node_Id; 10503 Proc_Body : Node_Id; 10504 PB_Ent : Entity_Id; 10505 Expr : Node_Id; 10506 Call : Node_Id; 10507 10508 begin 10509 if No (Ann) then 10510 Ann := Node (Last_Elmt (Accept_Address (Eent))); 10511 end if; 10512 10513 if Present (Condition (Alt)) then 10514 Expr := 10515 Make_If_Expression (Eloc, New_List ( 10516 Condition (Alt), 10517 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)), 10518 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc))); 10519 else 10520 Expr := 10521 Entry_Index_Expression 10522 (Eloc, Eent, Index, Scope (Eent)); 10523 end if; 10524 10525 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then 10526 Null_Body := New_Occurrence_Of (Standard_False, Eloc); 10527 10528 -- Always add call to Abort_Undefer when generating code, since 10529 -- this is what the runtime expects (abort deferred in 10530 -- Selective_Wait). In CodePeer mode this only confuses the 10531 -- analysis with unknown calls, so don't do it. 10532 10533 if not CodePeer_Mode then 10534 Call := 10535 Make_Procedure_Call_Statement (Eloc, 10536 Name => New_Occurrence_Of (RTE (RE_Abort_Undefer), Eloc)); 10537 Insert_Before 10538 (First (Statements (Handled_Statement_Sequence 10539 (Accept_Statement (Alt)))), 10540 Call); 10541 Analyze (Call); 10542 end if; 10543 10544 PB_Ent := 10545 Make_Defining_Identifier (Eloc, 10546 New_External_Name (Chars (Ename), 'A', Num_Accept)); 10547 10548 if Comes_From_Source (Alt) then 10549 Set_Debug_Info_Needed (PB_Ent); 10550 end if; 10551 10552 Proc_Body := 10553 Make_Subprogram_Body (Eloc, 10554 Specification => 10555 Make_Procedure_Specification (Eloc, 10556 Defining_Unit_Name => PB_Ent), 10557 Declarations => Declarations (Acc_Stm), 10558 Handled_Statement_Sequence => 10559 Build_Accept_Body (Accept_Statement (Alt))); 10560 10561 -- During the analysis of the body of the accept statement, any 10562 -- zero cost exception handler records were collected in the 10563 -- Accept_Handler_Records field of the N_Accept_Alternative node. 10564 -- This is where we move them to where they belong, namely the 10565 -- newly created procedure. 10566 10567 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); 10568 Append (Proc_Body, Body_List); 10569 10570 else 10571 Null_Body := New_Occurrence_Of (Standard_True, Eloc); 10572 10573 -- if accept statement has declarations, insert above, given that 10574 -- we are not creating a body for the accept. 10575 10576 if Present (Declarations (Acc_Stm)) then 10577 Insert_Actions (N, Declarations (Acc_Stm)); 10578 end if; 10579 end if; 10580 10581 Append_To (Accept_List, 10582 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr))); 10583 10584 Num_Accept := Num_Accept + 1; 10585 end Add_Accept; 10586 10587 ---------------------------- 10588 -- Make_And_Declare_Label -- 10589 ---------------------------- 10590 10591 function Make_And_Declare_Label (Num : Int) return Node_Id is 10592 Lab_Id : Node_Id; 10593 10594 begin 10595 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num)); 10596 Lab := 10597 Make_Label (Loc, Lab_Id); 10598 10599 Append_To (Decls, 10600 Make_Implicit_Label_Declaration (Loc, 10601 Defining_Identifier => 10602 Make_Defining_Identifier (Loc, Chars (Lab_Id)), 10603 Label_Construct => Lab)); 10604 10605 return Lab; 10606 end Make_And_Declare_Label; 10607 10608 ---------------------- 10609 -- Make_Select_Call -- 10610 ---------------------- 10611 10612 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is 10613 Params : constant List_Id := New_List; 10614 10615 begin 10616 Append_To (Params, 10617 Make_Attribute_Reference (Loc, 10618 Prefix => New_Occurrence_Of (Qnam, Loc), 10619 Attribute_Name => Name_Unchecked_Access)); 10620 Append_To (Params, Select_Mode); 10621 Append_To (Params, New_Occurrence_Of (Ann, Loc)); 10622 Append_To (Params, New_Occurrence_Of (Xnam, Loc)); 10623 10624 return 10625 Make_Procedure_Call_Statement (Loc, 10626 Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc), 10627 Parameter_Associations => Params); 10628 end Make_Select_Call; 10629 10630 -------------------------------- 10631 -- Process_Accept_Alternative -- 10632 -------------------------------- 10633 10634 procedure Process_Accept_Alternative 10635 (Alt : Node_Id; 10636 Index : Int; 10637 Proc : Node_Id) 10638 is 10639 Astmt : constant Node_Id := Accept_Statement (Alt); 10640 Alt_Stats : List_Id; 10641 10642 begin 10643 Adjust_Condition (Condition (Alt)); 10644 10645 -- Accept with body 10646 10647 if Present (Handled_Statement_Sequence (Astmt)) then 10648 Alt_Stats := 10649 New_List ( 10650 Make_Procedure_Call_Statement (Sloc (Proc), 10651 Name => 10652 New_Occurrence_Of 10653 (Defining_Unit_Name (Specification (Proc)), 10654 Sloc (Proc)))); 10655 10656 -- Accept with no body (followed by trailing statements) 10657 10658 else 10659 Alt_Stats := Empty_List; 10660 end if; 10661 10662 Ensure_Statement_Present (Sloc (Astmt), Alt); 10663 10664 -- After the call, if any, branch to trailing statements, if any. 10665 -- We create a label for each, as well as the corresponding label 10666 -- declaration. 10667 10668 if not Is_Empty_List (Statements (Alt)) then 10669 Lab := Make_And_Declare_Label (Index); 10670 Append (Lab, Trailing_List); 10671 Append_List (Statements (Alt), Trailing_List); 10672 Append_To (Trailing_List, 10673 Make_Goto_Statement (Loc, 10674 Name => New_Copy (Identifier (End_Lab)))); 10675 10676 else 10677 Lab := End_Lab; 10678 end if; 10679 10680 Append_To (Alt_Stats, 10681 Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab)))); 10682 10683 Append_To (Alt_List, 10684 Make_Case_Statement_Alternative (Loc, 10685 Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)), 10686 Statements => Alt_Stats)); 10687 end Process_Accept_Alternative; 10688 10689 ------------------------------- 10690 -- Process_Delay_Alternative -- 10691 ------------------------------- 10692 10693 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is 10694 Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt)); 10695 Cond : Node_Id; 10696 Delay_Alt : List_Id; 10697 10698 begin 10699 -- Deal with C/Fortran boolean as delay condition 10700 10701 Adjust_Condition (Condition (Alt)); 10702 10703 -- Determine the smallest specified delay 10704 10705 -- for each delay alternative generate: 10706 10707 -- if guard-expression then 10708 -- Delay_Val := delay-expression; 10709 -- Guard_Open := True; 10710 -- if Delay_Val < Delay_Min then 10711 -- Delay_Min := Delay_Val; 10712 -- Delay_Index := Index; 10713 -- end if; 10714 -- end if; 10715 10716 -- The enclosing if-statement is omitted if there is no guard 10717 10718 if Delay_Count = 1 or else First_Delay then 10719 First_Delay := False; 10720 10721 Delay_Alt := New_List ( 10722 Make_Assignment_Statement (Loc, 10723 Name => New_Occurrence_Of (Delay_Min, Loc), 10724 Expression => Expression (Delay_Statement (Alt)))); 10725 10726 if Delay_Count > 1 then 10727 Append_To (Delay_Alt, 10728 Make_Assignment_Statement (Loc, 10729 Name => New_Occurrence_Of (Delay_Index, Loc), 10730 Expression => Make_Integer_Literal (Loc, Index))); 10731 end if; 10732 10733 else 10734 Delay_Alt := New_List ( 10735 Make_Assignment_Statement (Loc, 10736 Name => New_Occurrence_Of (Delay_Val, Loc), 10737 Expression => Expression (Delay_Statement (Alt)))); 10738 10739 if Time_Type = Standard_Duration then 10740 Cond := 10741 Make_Op_Lt (Loc, 10742 Left_Opnd => New_Occurrence_Of (Delay_Val, Loc), 10743 Right_Opnd => New_Occurrence_Of (Delay_Min, Loc)); 10744 10745 else 10746 -- The scope of the time type must define a comparison 10747 -- operator. The scope itself may not be visible, so we 10748 -- construct a node with entity information to insure that 10749 -- semantic analysis can find the proper operator. 10750 10751 Cond := 10752 Make_Function_Call (Loc, 10753 Name => Make_Selected_Component (Loc, 10754 Prefix => 10755 New_Occurrence_Of (Scope (Time_Type), Loc), 10756 Selector_Name => 10757 Make_Operator_Symbol (Loc, 10758 Chars => Name_Op_Lt, 10759 Strval => No_String)), 10760 Parameter_Associations => 10761 New_List ( 10762 New_Occurrence_Of (Delay_Val, Loc), 10763 New_Occurrence_Of (Delay_Min, Loc))); 10764 10765 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type)); 10766 end if; 10767 10768 Append_To (Delay_Alt, 10769 Make_Implicit_If_Statement (N, 10770 Condition => Cond, 10771 Then_Statements => New_List ( 10772 Make_Assignment_Statement (Loc, 10773 Name => New_Occurrence_Of (Delay_Min, Loc), 10774 Expression => New_Occurrence_Of (Delay_Val, Loc)), 10775 10776 Make_Assignment_Statement (Loc, 10777 Name => New_Occurrence_Of (Delay_Index, Loc), 10778 Expression => Make_Integer_Literal (Loc, Index))))); 10779 end if; 10780 10781 if Check_Guard then 10782 Append_To (Delay_Alt, 10783 Make_Assignment_Statement (Loc, 10784 Name => New_Occurrence_Of (Guard_Open, Loc), 10785 Expression => New_Occurrence_Of (Standard_True, Loc))); 10786 end if; 10787 10788 if Present (Condition (Alt)) then 10789 Delay_Alt := New_List ( 10790 Make_Implicit_If_Statement (N, 10791 Condition => Condition (Alt), 10792 Then_Statements => Delay_Alt)); 10793 end if; 10794 10795 Append_List (Delay_Alt, Delay_List); 10796 10797 Ensure_Statement_Present (Dloc, Alt); 10798 10799 -- If the delay alternative has a statement part, add choice to the 10800 -- case statements for delays. 10801 10802 if not Is_Empty_List (Statements (Alt)) then 10803 10804 if Delay_Count = 1 then 10805 Append_List (Statements (Alt), Delay_Alt_List); 10806 10807 else 10808 Append_To (Delay_Alt_List, 10809 Make_Case_Statement_Alternative (Loc, 10810 Discrete_Choices => New_List ( 10811 Make_Integer_Literal (Loc, Index)), 10812 Statements => Statements (Alt))); 10813 end if; 10814 10815 elsif Delay_Count = 1 then 10816 10817 -- If the single delay has no trailing statements, add a branch 10818 -- to the exit label to the selective wait. 10819 10820 Delay_Alt_List := New_List ( 10821 Make_Goto_Statement (Loc, 10822 Name => New_Copy (Identifier (End_Lab)))); 10823 10824 end if; 10825 end Process_Delay_Alternative; 10826 10827 -- Start of processing for Expand_N_Selective_Accept 10828 10829 begin 10830 Process_Statements_For_Controlled_Objects (N); 10831 10832 -- First insert some declarations before the select. The first is: 10833 10834 -- Ann : Address 10835 10836 -- This variable holds the parameters passed to the accept body. This 10837 -- declaration has already been inserted by the time we get here by 10838 -- a call to Expand_Accept_Declarations made from the semantics when 10839 -- processing the first accept statement contained in the select. We 10840 -- can find this entity as Accept_Address (E), where E is any of the 10841 -- entries references by contained accept statements. 10842 10843 -- The first step is to scan the list of Selective_Accept_Statements 10844 -- to find this entity, and also count the number of accepts, and 10845 -- determine if terminated, delay or else is present: 10846 10847 Num_Alts := 0; 10848 10849 Alt := First (Alts); 10850 while Present (Alt) loop 10851 Process_Statements_For_Controlled_Objects (Alt); 10852 10853 if Nkind (Alt) = N_Accept_Alternative then 10854 Add_Accept (Alt); 10855 10856 elsif Nkind (Alt) = N_Delay_Alternative then 10857 Delay_Count := Delay_Count + 1; 10858 10859 -- If the delays are relative delays, the delay expressions have 10860 -- type Standard_Duration. Otherwise they must have some time type 10861 -- recognized by GNAT. 10862 10863 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then 10864 Time_Type := Standard_Duration; 10865 else 10866 Time_Type := Etype (Expression (Delay_Statement (Alt))); 10867 10868 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) 10869 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time) 10870 then 10871 null; 10872 else 10873 Error_Msg_NE ( 10874 "& is not a time type (RM 9.6(6))", 10875 Expression (Delay_Statement (Alt)), Time_Type); 10876 Time_Type := Standard_Duration; 10877 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type); 10878 end if; 10879 end if; 10880 10881 if No (Condition (Alt)) then 10882 10883 -- This guard will always be open 10884 10885 Check_Guard := False; 10886 end if; 10887 10888 elsif Nkind (Alt) = N_Terminate_Alternative then 10889 Adjust_Condition (Condition (Alt)); 10890 Terminate_Alt := Alt; 10891 end if; 10892 10893 Num_Alts := Num_Alts + 1; 10894 Next (Alt); 10895 end loop; 10896 10897 Else_Present := Present (Else_Statements (N)); 10898 10899 -- At the same time (see procedure Add_Accept) we build the accept list: 10900 10901 -- Qnn : Accept_List (1 .. num-select) := ( 10902 -- (null-body, entry-index), 10903 -- (null-body, entry-index), 10904 -- .. 10905 -- (null_body, entry-index)); 10906 10907 -- In the above declaration, null-body is True if the corresponding 10908 -- accept has no body, and false otherwise. The entry is either the 10909 -- entry index expression if there is no guard, or if a guard is 10910 -- present, then an if expression of the form: 10911 10912 -- (if guard then entry-index else Null_Task_Entry) 10913 10914 -- If a guard is statically known to be false, the entry can simply 10915 -- be omitted from the accept list. 10916 10917 Append_To (Decls, 10918 Make_Object_Declaration (Loc, 10919 Defining_Identifier => Qnam, 10920 Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc), 10921 Aliased_Present => True, 10922 Expression => 10923 Make_Qualified_Expression (Loc, 10924 Subtype_Mark => 10925 New_Occurrence_Of (RTE (RE_Accept_List), Loc), 10926 Expression => 10927 Make_Aggregate (Loc, Expressions => Accept_List)))); 10928 10929 -- Then we declare the variable that holds the index for the accept 10930 -- that will be selected for service: 10931 10932 -- Xnn : Select_Index; 10933 10934 Append_To (Decls, 10935 Make_Object_Declaration (Loc, 10936 Defining_Identifier => Xnam, 10937 Object_Definition => 10938 New_Occurrence_Of (RTE (RE_Select_Index), Loc), 10939 Expression => 10940 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc))); 10941 10942 -- After this follow procedure declarations for each accept body 10943 10944 -- procedure Pnn is 10945 -- begin 10946 -- ... 10947 -- end; 10948 10949 -- where the ... are statements from the corresponding procedure body. 10950 -- No parameters are involved, since the parameters are passed via Ann 10951 -- and the parameter references have already been expanded to be direct 10952 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore, 10953 -- any embedded tasking statements (which would normally be illegal in 10954 -- procedures), have been converted to calls to the tasking runtime so 10955 -- there is no problem in putting them into procedures. 10956 10957 -- The original accept statement has been expanded into a block in 10958 -- the same fashion as for simple accepts (see Build_Accept_Body). 10959 10960 -- Note: we don't really need to build these procedures for the case 10961 -- where no delay statement is present, but it is just as easy to 10962 -- build them unconditionally, and not significantly inefficient, 10963 -- since if they are short they will be inlined anyway. 10964 10965 -- The procedure declarations have been assembled in Body_List 10966 10967 -- If delays are present, we must compute the required delay. 10968 -- We first generate the declarations: 10969 10970 -- Delay_Index : Boolean := 0; 10971 -- Delay_Min : Some_Time_Type.Time; 10972 -- Delay_Val : Some_Time_Type.Time; 10973 10974 -- Delay_Index will be set to the index of the minimum delay, i.e. the 10975 -- active delay that is actually chosen as the basis for the possible 10976 -- delay if an immediate rendez-vous is not possible. 10977 10978 -- In the most common case there is a single delay statement, and this 10979 -- is handled specially. 10980 10981 if Delay_Count > 0 then 10982 10983 -- Generate the required declarations 10984 10985 Delay_Val := 10986 Make_Defining_Identifier (Loc, New_External_Name ('D', 1)); 10987 Delay_Index := 10988 Make_Defining_Identifier (Loc, New_External_Name ('D', 2)); 10989 Delay_Min := 10990 Make_Defining_Identifier (Loc, New_External_Name ('D', 3)); 10991 10992 Append_To (Decls, 10993 Make_Object_Declaration (Loc, 10994 Defining_Identifier => Delay_Val, 10995 Object_Definition => New_Occurrence_Of (Time_Type, Loc))); 10996 10997 Append_To (Decls, 10998 Make_Object_Declaration (Loc, 10999 Defining_Identifier => Delay_Index, 11000 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 11001 Expression => Make_Integer_Literal (Loc, 0))); 11002 11003 Append_To (Decls, 11004 Make_Object_Declaration (Loc, 11005 Defining_Identifier => Delay_Min, 11006 Object_Definition => New_Occurrence_Of (Time_Type, Loc), 11007 Expression => 11008 Unchecked_Convert_To (Time_Type, 11009 Make_Attribute_Reference (Loc, 11010 Prefix => 11011 New_Occurrence_Of (Underlying_Type (Time_Type), Loc), 11012 Attribute_Name => Name_Last)))); 11013 11014 -- Create Duration and Delay_Mode objects used for passing a delay 11015 -- value to RTS 11016 11017 D := Make_Temporary (Loc, 'D'); 11018 M := Make_Temporary (Loc, 'M'); 11019 11020 declare 11021 Discr : Entity_Id; 11022 11023 begin 11024 -- Note that these values are defined in s-osprim.ads and must 11025 -- be kept in sync: 11026 -- 11027 -- Relative : constant := 0; 11028 -- Absolute_Calendar : constant := 1; 11029 -- Absolute_RT : constant := 2; 11030 11031 if Time_Type = Standard_Duration then 11032 Discr := Make_Integer_Literal (Loc, 0); 11033 11034 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11035 Discr := Make_Integer_Literal (Loc, 1); 11036 11037 else 11038 pragma Assert 11039 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11040 Discr := Make_Integer_Literal (Loc, 2); 11041 end if; 11042 11043 Append_To (Decls, 11044 Make_Object_Declaration (Loc, 11045 Defining_Identifier => D, 11046 Object_Definition => 11047 New_Occurrence_Of (Standard_Duration, Loc))); 11048 11049 Append_To (Decls, 11050 Make_Object_Declaration (Loc, 11051 Defining_Identifier => M, 11052 Object_Definition => 11053 New_Occurrence_Of (Standard_Integer, Loc), 11054 Expression => Discr)); 11055 end; 11056 11057 if Check_Guard then 11058 Guard_Open := 11059 Make_Defining_Identifier (Loc, New_External_Name ('G', 1)); 11060 11061 Append_To (Decls, 11062 Make_Object_Declaration (Loc, 11063 Defining_Identifier => Guard_Open, 11064 Object_Definition => 11065 New_Occurrence_Of (Standard_Boolean, Loc), 11066 Expression => 11067 New_Occurrence_Of (Standard_False, Loc))); 11068 end if; 11069 11070 -- Delay_Count is zero, don't need M and D set (suppress warning) 11071 11072 else 11073 M := Empty; 11074 D := Empty; 11075 end if; 11076 11077 if Present (Terminate_Alt) then 11078 11079 -- If the terminate alternative guard is False, use 11080 -- Simple_Mode; otherwise use Terminate_Mode. 11081 11082 if Present (Condition (Terminate_Alt)) then 11083 Select_Mode := Make_If_Expression (Loc, 11084 New_List (Condition (Terminate_Alt), 11085 New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc), 11086 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc))); 11087 else 11088 Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc); 11089 end if; 11090 11091 elsif Else_Present or Delay_Count > 0 then 11092 Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc); 11093 11094 else 11095 Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc); 11096 end if; 11097 11098 Select_Call := Make_Select_Call (Select_Mode); 11099 Append (Select_Call, Stats); 11100 11101 -- Now generate code to act on the result. There is an entry 11102 -- in this case for each accept statement with a non-null body, 11103 -- followed by a branch to the statements that follow the Accept. 11104 -- In the absence of delay alternatives, we generate: 11105 11106 -- case X is 11107 -- when No_Rendezvous => -- omitted if simple mode 11108 -- goto Lab0; 11109 11110 -- when 1 => 11111 -- P1n; 11112 -- goto Lab1; 11113 11114 -- when 2 => 11115 -- P2n; 11116 -- goto Lab2; 11117 11118 -- when others => 11119 -- goto Exit; 11120 -- end case; 11121 -- 11122 -- Lab0: Else_Statements; 11123 -- goto exit; 11124 11125 -- Lab1: Trailing_Statements1; 11126 -- goto Exit; 11127 -- 11128 -- Lab2: Trailing_Statements2; 11129 -- goto Exit; 11130 -- ... 11131 -- Exit: 11132 11133 -- Generate label for common exit 11134 11135 End_Lab := Make_And_Declare_Label (Num_Alts + 1); 11136 11137 -- First entry is the default case, when no rendezvous is possible 11138 11139 Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)); 11140 11141 if Else_Present then 11142 11143 -- If no rendezvous is possible, the else part is executed 11144 11145 Lab := Make_And_Declare_Label (0); 11146 Alt_Stats := New_List ( 11147 Make_Goto_Statement (Loc, 11148 Name => New_Copy (Identifier (Lab)))); 11149 11150 Append (Lab, Trailing_List); 11151 Append_List (Else_Statements (N), Trailing_List); 11152 Append_To (Trailing_List, 11153 Make_Goto_Statement (Loc, 11154 Name => New_Copy (Identifier (End_Lab)))); 11155 else 11156 Alt_Stats := New_List ( 11157 Make_Goto_Statement (Loc, 11158 Name => New_Copy (Identifier (End_Lab)))); 11159 end if; 11160 11161 Append_To (Alt_List, 11162 Make_Case_Statement_Alternative (Loc, 11163 Discrete_Choices => Choices, 11164 Statements => Alt_Stats)); 11165 11166 -- We make use of the fact that Accept_Index is an integer type, and 11167 -- generate successive literals for entries for each accept. Only those 11168 -- for which there is a body or trailing statements get a case entry. 11169 11170 Alt := First (Select_Alternatives (N)); 11171 Proc := First (Body_List); 11172 while Present (Alt) loop 11173 11174 if Nkind (Alt) = N_Accept_Alternative then 11175 Process_Accept_Alternative (Alt, Index, Proc); 11176 Index := Index + 1; 11177 11178 if Present 11179 (Handled_Statement_Sequence (Accept_Statement (Alt))) 11180 then 11181 Next (Proc); 11182 end if; 11183 11184 elsif Nkind (Alt) = N_Delay_Alternative then 11185 Process_Delay_Alternative (Alt, Delay_Num); 11186 Delay_Num := Delay_Num + 1; 11187 end if; 11188 11189 Next (Alt); 11190 end loop; 11191 11192 -- An others choice is always added to the main case, as well 11193 -- as the delay case (to satisfy the compiler). 11194 11195 Append_To (Alt_List, 11196 Make_Case_Statement_Alternative (Loc, 11197 Discrete_Choices => 11198 New_List (Make_Others_Choice (Loc)), 11199 Statements => 11200 New_List (Make_Goto_Statement (Loc, 11201 Name => New_Copy (Identifier (End_Lab)))))); 11202 11203 Accept_Case := New_List ( 11204 Make_Case_Statement (Loc, 11205 Expression => New_Occurrence_Of (Xnam, Loc), 11206 Alternatives => Alt_List)); 11207 11208 Append_List (Trailing_List, Accept_Case); 11209 Append_List (Body_List, Decls); 11210 11211 -- Construct case statement for trailing statements of delay 11212 -- alternatives, if there are several of them. 11213 11214 if Delay_Count > 1 then 11215 Append_To (Delay_Alt_List, 11216 Make_Case_Statement_Alternative (Loc, 11217 Discrete_Choices => 11218 New_List (Make_Others_Choice (Loc)), 11219 Statements => 11220 New_List (Make_Null_Statement (Loc)))); 11221 11222 Delay_Case := New_List ( 11223 Make_Case_Statement (Loc, 11224 Expression => New_Occurrence_Of (Delay_Index, Loc), 11225 Alternatives => Delay_Alt_List)); 11226 else 11227 Delay_Case := Delay_Alt_List; 11228 end if; 11229 11230 -- If there are no delay alternatives, we append the case statement 11231 -- to the statement list. 11232 11233 if Delay_Count = 0 then 11234 Append_List (Accept_Case, Stats); 11235 11236 -- Delay alternatives present 11237 11238 else 11239 -- If delay alternatives are present we generate: 11240 11241 -- find minimum delay. 11242 -- DX := minimum delay; 11243 -- M := <delay mode>; 11244 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P, 11245 -- DX, MX, X); 11246 -- 11247 -- if X = No_Rendezvous then 11248 -- case statement for delay statements. 11249 -- else 11250 -- case statement for accept alternatives. 11251 -- end if; 11252 11253 declare 11254 Cases : Node_Id; 11255 Stmt : Node_Id; 11256 Parms : List_Id; 11257 Parm : Node_Id; 11258 Conv : Node_Id; 11259 11260 begin 11261 -- The type of the delay expression is known to be legal 11262 11263 if Time_Type = Standard_Duration then 11264 Conv := New_Occurrence_Of (Delay_Min, Loc); 11265 11266 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11267 Conv := Make_Function_Call (Loc, 11268 New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 11269 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11270 11271 else 11272 pragma Assert 11273 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11274 11275 Conv := Make_Function_Call (Loc, 11276 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 11277 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11278 end if; 11279 11280 Stmt := Make_Assignment_Statement (Loc, 11281 Name => New_Occurrence_Of (D, Loc), 11282 Expression => Conv); 11283 11284 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode) 11285 11286 Parms := Parameter_Associations (Select_Call); 11287 11288 Parm := First (Parms); 11289 while Present (Parm) and then Parm /= Select_Mode loop 11290 Next (Parm); 11291 end loop; 11292 11293 pragma Assert (Present (Parm)); 11294 Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc)); 11295 Analyze (Parm); 11296 11297 -- Prepare two new parameters of Duration and Delay_Mode type 11298 -- which represent the value and the mode of the minimum delay. 11299 11300 Next (Parm); 11301 Insert_After (Parm, New_Occurrence_Of (M, Loc)); 11302 Insert_After (Parm, New_Occurrence_Of (D, Loc)); 11303 11304 -- Create a call to RTS 11305 11306 Rewrite (Select_Call, 11307 Make_Procedure_Call_Statement (Loc, 11308 Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc), 11309 Parameter_Associations => Parms)); 11310 11311 -- This new call should follow the calculation of the minimum 11312 -- delay. 11313 11314 Insert_List_Before (Select_Call, Delay_List); 11315 11316 if Check_Guard then 11317 Stmt := 11318 Make_Implicit_If_Statement (N, 11319 Condition => New_Occurrence_Of (Guard_Open, Loc), 11320 Then_Statements => New_List ( 11321 New_Copy_Tree (Stmt), 11322 New_Copy_Tree (Select_Call)), 11323 Else_Statements => Accept_Or_Raise); 11324 Rewrite (Select_Call, Stmt); 11325 else 11326 Insert_Before (Select_Call, Stmt); 11327 end if; 11328 11329 Cases := 11330 Make_Implicit_If_Statement (N, 11331 Condition => Make_Op_Eq (Loc, 11332 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 11333 Right_Opnd => 11334 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 11335 11336 Then_Statements => Delay_Case, 11337 Else_Statements => Accept_Case); 11338 11339 Append (Cases, Stats); 11340 end; 11341 end if; 11342 11343 Append (End_Lab, Stats); 11344 11345 -- Replace accept statement with appropriate block 11346 11347 Rewrite (N, 11348 Make_Block_Statement (Loc, 11349 Declarations => Decls, 11350 Handled_Statement_Sequence => 11351 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats))); 11352 Analyze (N); 11353 11354 -- Note: have to worry more about abort deferral in above code ??? 11355 11356 -- Final step is to unstack the Accept_Address entries for all accept 11357 -- statements appearing in accept alternatives in the select statement 11358 11359 Alt := First (Alts); 11360 while Present (Alt) loop 11361 if Nkind (Alt) = N_Accept_Alternative then 11362 Remove_Last_Elmt (Accept_Address 11363 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))); 11364 end if; 11365 11366 Next (Alt); 11367 end loop; 11368 end Expand_N_Selective_Accept; 11369 11370 -------------------------------------- 11371 -- Expand_N_Single_Task_Declaration -- 11372 -------------------------------------- 11373 11374 -- Single task declarations should never be present after semantic 11375 -- analysis, since we expect them to be replaced by a declaration of an 11376 -- anonymous task type, followed by a declaration of the task object. We 11377 -- include this routine to make sure that is happening. 11378 11379 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is 11380 begin 11381 raise Program_Error; 11382 end Expand_N_Single_Task_Declaration; 11383 11384 ------------------------ 11385 -- Expand_N_Task_Body -- 11386 ------------------------ 11387 11388 -- Given a task body 11389 11390 -- task body tname is 11391 -- <declarations> 11392 -- begin 11393 -- <statements> 11394 -- end x; 11395 11396 -- This expansion routine converts it into a procedure and sets the 11397 -- elaboration flag for the procedure to true, to represent the fact 11398 -- that the task body is now elaborated: 11399 11400 -- procedure tnameB (_Task : access tnameV) is 11401 -- discriminal : dtype renames _Task.discriminant; 11402 11403 -- procedure _clean is 11404 -- begin 11405 -- Abort_Defer.all; 11406 -- Complete_Task; 11407 -- Abort_Undefer.all; 11408 -- return; 11409 -- end _clean; 11410 11411 -- begin 11412 -- Abort_Undefer.all; 11413 -- <declarations> 11414 -- System.Task_Stages.Complete_Activation; 11415 -- <statements> 11416 -- at end 11417 -- _clean; 11418 -- end tnameB; 11419 11420 -- tnameE := True; 11421 11422 -- In addition, if the task body is an activator, then a call to activate 11423 -- tasks is added at the start of the statements, before the call to 11424 -- Complete_Activation, and if in addition the task is a master then it 11425 -- must be established as a master. These calls are inserted and analyzed 11426 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is 11427 -- expanded. 11428 11429 -- There is one discriminal declaration line generated for each 11430 -- discriminant that is present to provide an easy reference point for 11431 -- discriminant references inside the body (see Exp_Ch2.Expand_Name). 11432 11433 -- Note on relationship to GNARLI definition. In the GNARLI definition, 11434 -- task body procedures have a profile (Arg : System.Address). That is 11435 -- needed because GNARLI has to use the same access-to-subprogram type 11436 -- for all task types. We depend here on knowing that in GNAT, passing 11437 -- an address argument by value is identical to passing a record value 11438 -- by access (in either case a single pointer is passed), so even though 11439 -- this procedure has the wrong profile. In fact it's all OK, since the 11440 -- callings sequence is identical. 11441 11442 procedure Expand_N_Task_Body (N : Node_Id) is 11443 Loc : constant Source_Ptr := Sloc (N); 11444 Ttyp : constant Entity_Id := Corresponding_Spec (N); 11445 Call : Node_Id; 11446 New_N : Node_Id; 11447 11448 Insert_Nod : Node_Id; 11449 -- Used to determine the proper location of wrapper body insertions 11450 11451 begin 11452 -- if no task body procedure, means we had an error in configurable 11453 -- run-time mode, and there is no point in proceeding further. 11454 11455 if No (Task_Body_Procedure (Ttyp)) then 11456 return; 11457 end if; 11458 11459 -- Add renaming declarations for discriminals and a declaration for the 11460 -- entry family index (if applicable). 11461 11462 Install_Private_Data_Declarations 11463 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N)); 11464 11465 -- Add a call to Abort_Undefer at the very beginning of the task 11466 -- body since this body is called with abort still deferred. 11467 11468 if Abort_Allowed then 11469 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 11470 Insert_Before 11471 (First (Statements (Handled_Statement_Sequence (N))), Call); 11472 Analyze (Call); 11473 end if; 11474 11475 -- The statement part has already been protected with an at_end and 11476 -- cleanup actions. The call to Complete_Activation must be placed 11477 -- at the head of the sequence of statements of that block. The 11478 -- declarations have been merged in this sequence of statements but 11479 -- the first real statement is accessible from the First_Real_Statement 11480 -- field (which was set for exactly this purpose). 11481 11482 if Restricted_Profile then 11483 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation); 11484 else 11485 Call := Build_Runtime_Call (Loc, RE_Complete_Activation); 11486 end if; 11487 11488 Insert_Before 11489 (First_Real_Statement (Handled_Statement_Sequence (N)), Call); 11490 Analyze (Call); 11491 11492 New_N := 11493 Make_Subprogram_Body (Loc, 11494 Specification => Build_Task_Proc_Specification (Ttyp), 11495 Declarations => Declarations (N), 11496 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 11497 11498 -- If the task contains generic instantiations, cleanup actions are 11499 -- delayed until after instantiation. Transfer the activation chain to 11500 -- the subprogram, to insure that the activation call is properly 11501 -- generated. It the task body contains inner tasks, indicate that the 11502 -- subprogram is a task master. 11503 11504 if Delay_Cleanups (Ttyp) then 11505 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); 11506 Set_Is_Task_Master (New_N, Is_Task_Master (N)); 11507 end if; 11508 11509 Rewrite (N, New_N); 11510 Analyze (N); 11511 11512 -- Set elaboration flag immediately after task body. If the body is a 11513 -- subunit, the flag is set in the declarative part containing the stub. 11514 11515 if Nkind (Parent (N)) /= N_Subunit then 11516 Insert_After (N, 11517 Make_Assignment_Statement (Loc, 11518 Name => 11519 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')), 11520 Expression => New_Occurrence_Of (Standard_True, Loc))); 11521 end if; 11522 11523 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after 11524 -- the task body. At this point all wrapper specs have been created, 11525 -- frozen and included in the dispatch table for the task type. 11526 11527 if Ada_Version >= Ada_2005 then 11528 if Nkind (Parent (N)) = N_Subunit then 11529 Insert_Nod := Corresponding_Stub (Parent (N)); 11530 else 11531 Insert_Nod := N; 11532 end if; 11533 11534 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod); 11535 end if; 11536 end Expand_N_Task_Body; 11537 11538 ------------------------------------ 11539 -- Expand_N_Task_Type_Declaration -- 11540 ------------------------------------ 11541 11542 -- We have several things to do. First we must create a Boolean flag used 11543 -- to mark if the body is elaborated yet. This variable gets set to True 11544 -- when the body of the task is elaborated (we can't rely on the normal 11545 -- ABE mechanism for the task body, since we need to pass an access to 11546 -- this elaboration boolean to the runtime routines). 11547 11548 -- taskE : aliased Boolean := False; 11549 11550 -- Next a variable is declared to hold the task stack size (either the 11551 -- default : Unspecified_Size, or a value that is set by a pragma 11552 -- Storage_Size). If the value of the pragma Storage_Size is static, then 11553 -- the variable is initialized with this value: 11554 11555 -- taskZ : Size_Type := Unspecified_Size; 11556 -- or 11557 -- taskZ : Size_Type := Size_Type (size_expression); 11558 11559 -- Note: No variable is needed to hold the task relative deadline since 11560 -- its value would never be static because the parameter is of a private 11561 -- type (Ada.Real_Time.Time_Span). 11562 11563 -- Next we create a corresponding record type declaration used to represent 11564 -- values of this task. The general form of this type declaration is 11565 11566 -- type taskV (discriminants) is record 11567 -- _Task_Id : Task_Id; 11568 -- entry_family : array (bounds) of Void; 11569 -- _Priority : Integer := priority_expression; 11570 -- _Size : Size_Type := size_expression; 11571 -- _Task_Info : Task_Info_Type := task_info_expression; 11572 -- _CPU : Integer := cpu_range_expression; 11573 -- _Relative_Deadline : Time_Span := time_span_expression; 11574 -- _Domain : Dispatching_Domain := dd_expression; 11575 -- end record; 11576 11577 -- The discriminants are present only if the corresponding task type has 11578 -- discriminants, and they exactly mirror the task type discriminants. 11579 11580 -- The Id field is always present. It contains the Task_Id value, as set by 11581 -- the call to Create_Task. Note that although the task is limited, the 11582 -- task value record type is not limited, so there is no problem in passing 11583 -- this field as an out parameter to Create_Task. 11584 11585 -- One entry_family component is present for each entry family in the task 11586 -- definition. The bounds correspond to the bounds of the entry family 11587 -- (which may depend on discriminants). The element type is void, since we 11588 -- only need the bounds information for determining the entry index. Note 11589 -- that the use of an anonymous array would normally be illegal in this 11590 -- context, but this is a parser check, and the semantics is quite prepared 11591 -- to handle such a case. 11592 11593 -- The _Size field is present only if a Storage_Size pragma appears in the 11594 -- task definition. The expression captures the argument that was present 11595 -- in the pragma, and is used to override the task stack size otherwise 11596 -- associated with the task type. 11597 11598 -- The _Priority field is present only if the task entity has a Priority or 11599 -- Interrupt_Priority rep item (pragma, aspect specification or attribute 11600 -- definition clause). It will be filled at the freeze point, when the 11601 -- record init proc is built, to capture the expression of the rep item 11602 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11603 -- here since aspect evaluations are delayed till the freeze point. 11604 11605 -- The _Task_Info field is present only if a Task_Info pragma appears in 11606 -- the task definition. The expression captures the argument that was 11607 -- present in the pragma, and is used to provide the Task_Image parameter 11608 -- to the call to Create_Task. 11609 11610 -- The _CPU field is present only if the task entity has a CPU rep item 11611 -- (pragma, aspect specification or attribute definition clause). It will 11612 -- be filled at the freeze point, when the record init proc is built, to 11613 -- capture the expression of the rep item (see Build_Record_Init_Proc in 11614 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations 11615 -- are delayed till the freeze point. 11616 11617 -- The _Relative_Deadline field is present only if a Relative_Deadline 11618 -- pragma appears in the task definition. The expression captures the 11619 -- argument that was present in the pragma, and is used to provide the 11620 -- Relative_Deadline parameter to the call to Create_Task. 11621 11622 -- The _Domain field is present only if the task entity has a 11623 -- Dispatching_Domain rep item (pragma, aspect specification or attribute 11624 -- definition clause). It will be filled at the freeze point, when the 11625 -- record init proc is built, to capture the expression of the rep item 11626 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11627 -- here since aspect evaluations are delayed till the freeze point. 11628 11629 -- When a task is declared, an instance of the task value record is 11630 -- created. The elaboration of this declaration creates the correct bounds 11631 -- for the entry families, and also evaluates the size, priority, and 11632 -- task_Info expressions if needed. The initialization routine for the task 11633 -- type itself then calls Create_Task with appropriate parameters to 11634 -- initialize the value of the Task_Id field. 11635 11636 -- Note: the address of this record is passed as the "Discriminants" 11637 -- parameter for Create_Task. Since Create_Task merely passes this onto the 11638 -- body procedure, it does not matter that it does not quite match the 11639 -- GNARLI model of what is being passed (the record contains more than just 11640 -- the discriminants, but the discriminants can be found from the record 11641 -- value). 11642 11643 -- The Entity_Id for this created record type is placed in the 11644 -- Corresponding_Record_Type field of the associated task type entity. 11645 11646 -- Next we create a procedure specification for the task body procedure: 11647 11648 -- procedure taskB (_Task : access taskV); 11649 11650 -- Note that this must come after the record type declaration, since 11651 -- the spec refers to this type. It turns out that the initialization 11652 -- procedure for the value type references the task body spec, but that's 11653 -- fine, since it won't be generated till the freeze point for the type, 11654 -- which is certainly after the task body spec declaration. 11655 11656 -- Finally, we set the task index value field of the entry attribute in 11657 -- the case of a simple entry. 11658 11659 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is 11660 Loc : constant Source_Ptr := Sloc (N); 11661 TaskId : constant Entity_Id := Defining_Identifier (N); 11662 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); 11663 Tasknm : constant Name_Id := Chars (Tasktyp); 11664 Taskdef : constant Node_Id := Task_Definition (N); 11665 11666 Body_Decl : Node_Id; 11667 Cdecls : List_Id; 11668 Decl_Stack : Node_Id; 11669 Elab_Decl : Node_Id; 11670 Ent_Stack : Entity_Id; 11671 Proc_Spec : Node_Id; 11672 Rec_Decl : Node_Id; 11673 Rec_Ent : Entity_Id; 11674 Size_Decl : Entity_Id; 11675 Task_Size : Node_Id; 11676 11677 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id; 11678 -- Searches the task definition T for the first occurrence of the pragma 11679 -- Relative Deadline. The caller has ensured that the pragma is present 11680 -- in the task definition. Note that this routine cannot be implemented 11681 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are 11682 -- not chained because their expansion into a procedure call statement 11683 -- would cause a break in the chain. 11684 11685 ---------------------------------- 11686 -- Get_Relative_Deadline_Pragma -- 11687 ---------------------------------- 11688 11689 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is 11690 N : Node_Id; 11691 11692 begin 11693 N := First (Visible_Declarations (T)); 11694 while Present (N) loop 11695 if Nkind (N) = N_Pragma 11696 and then Pragma_Name (N) = Name_Relative_Deadline 11697 then 11698 return N; 11699 end if; 11700 11701 Next (N); 11702 end loop; 11703 11704 N := First (Private_Declarations (T)); 11705 while Present (N) loop 11706 if Nkind (N) = N_Pragma 11707 and then Pragma_Name (N) = Name_Relative_Deadline 11708 then 11709 return N; 11710 end if; 11711 11712 Next (N); 11713 end loop; 11714 11715 raise Program_Error; 11716 end Get_Relative_Deadline_Pragma; 11717 11718 -- Start of processing for Expand_N_Task_Type_Declaration 11719 11720 begin 11721 -- If already expanded, nothing to do 11722 11723 if Present (Corresponding_Record_Type (Tasktyp)) then 11724 return; 11725 end if; 11726 11727 -- Here we will do the expansion 11728 11729 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); 11730 11731 Rec_Ent := Defining_Identifier (Rec_Decl); 11732 Cdecls := Component_Items (Component_List 11733 (Type_Definition (Rec_Decl))); 11734 11735 Qualify_Entity_Names (N); 11736 11737 -- First create the elaboration variable 11738 11739 Elab_Decl := 11740 Make_Object_Declaration (Loc, 11741 Defining_Identifier => 11742 Make_Defining_Identifier (Sloc (Tasktyp), 11743 Chars => New_External_Name (Tasknm, 'E')), 11744 Aliased_Present => True, 11745 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 11746 Expression => New_Occurrence_Of (Standard_False, Loc)); 11747 11748 Insert_After (N, Elab_Decl); 11749 11750 -- Next create the declaration of the size variable (tasknmZ) 11751 11752 Set_Storage_Size_Variable (Tasktyp, 11753 Make_Defining_Identifier (Sloc (Tasktyp), 11754 Chars => New_External_Name (Tasknm, 'Z'))); 11755 11756 if Present (Taskdef) 11757 and then Has_Storage_Size_Pragma (Taskdef) 11758 and then 11759 Is_OK_Static_Expression 11760 (Expression 11761 (First (Pragma_Argument_Associations 11762 (Get_Rep_Pragma (TaskId, Name_Storage_Size))))) 11763 then 11764 Size_Decl := 11765 Make_Object_Declaration (Loc, 11766 Defining_Identifier => Storage_Size_Variable (Tasktyp), 11767 Object_Definition => 11768 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 11769 Expression => 11770 Convert_To (RTE (RE_Size_Type), 11771 Relocate_Node 11772 (Expression (First (Pragma_Argument_Associations 11773 (Get_Rep_Pragma 11774 (TaskId, Name_Storage_Size))))))); 11775 11776 else 11777 Size_Decl := 11778 Make_Object_Declaration (Loc, 11779 Defining_Identifier => Storage_Size_Variable (Tasktyp), 11780 Object_Definition => 11781 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 11782 Expression => 11783 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); 11784 end if; 11785 11786 Insert_After (Elab_Decl, Size_Decl); 11787 11788 -- Next build the rest of the corresponding record declaration. This is 11789 -- done last, since the corresponding record initialization procedure 11790 -- will reference the previously created entities. 11791 11792 -- Fill in the component declarations -- first the _Task_Id field 11793 11794 Append_To (Cdecls, 11795 Make_Component_Declaration (Loc, 11796 Defining_Identifier => 11797 Make_Defining_Identifier (Loc, Name_uTask_Id), 11798 Component_Definition => 11799 Make_Component_Definition (Loc, 11800 Aliased_Present => False, 11801 Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id), 11802 Loc)))); 11803 11804 -- Declare static ATCB (that is, created by the expander) if we are 11805 -- using the Restricted run time. 11806 11807 if Restricted_Profile then 11808 Append_To (Cdecls, 11809 Make_Component_Declaration (Loc, 11810 Defining_Identifier => 11811 Make_Defining_Identifier (Loc, Name_uATCB), 11812 11813 Component_Definition => 11814 Make_Component_Definition (Loc, 11815 Aliased_Present => True, 11816 Subtype_Indication => Make_Subtype_Indication (Loc, 11817 Subtype_Mark => 11818 New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc), 11819 11820 Constraint => 11821 Make_Index_Or_Discriminant_Constraint (Loc, 11822 Constraints => 11823 New_List (Make_Integer_Literal (Loc, 0))))))); 11824 11825 end if; 11826 11827 -- Declare static stack (that is, created by the expander) if we are 11828 -- using the Restricted run time on a bare board configuration. 11829 11830 if Restricted_Profile and then Preallocated_Stacks_On_Target then 11831 11832 -- First we need to extract the appropriate stack size 11833 11834 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack); 11835 11836 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 11837 declare 11838 Expr_N : constant Node_Id := 11839 Expression (First ( 11840 Pragma_Argument_Associations ( 11841 Get_Rep_Pragma (TaskId, Name_Storage_Size)))); 11842 Etyp : constant Entity_Id := Etype (Expr_N); 11843 P : constant Node_Id := Parent (Expr_N); 11844 11845 begin 11846 -- The stack is defined inside the corresponding record. 11847 -- Therefore if the size of the stack is set by means of 11848 -- a discriminant, we must reference the discriminant of the 11849 -- corresponding record type. 11850 11851 if Nkind (Expr_N) in N_Has_Entity 11852 and then Present (Discriminal_Link (Entity (Expr_N))) 11853 then 11854 Task_Size := 11855 New_Occurrence_Of 11856 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))), 11857 Loc); 11858 Set_Parent (Task_Size, P); 11859 Set_Etype (Task_Size, Etyp); 11860 Set_Analyzed (Task_Size); 11861 11862 else 11863 Task_Size := Relocate_Node (Expr_N); 11864 end if; 11865 end; 11866 11867 else 11868 Task_Size := 11869 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc); 11870 end if; 11871 11872 Decl_Stack := Make_Component_Declaration (Loc, 11873 Defining_Identifier => Ent_Stack, 11874 11875 Component_Definition => 11876 Make_Component_Definition (Loc, 11877 Aliased_Present => True, 11878 Subtype_Indication => Make_Subtype_Indication (Loc, 11879 Subtype_Mark => 11880 New_Occurrence_Of (RTE (RE_Storage_Array), Loc), 11881 11882 Constraint => 11883 Make_Index_Or_Discriminant_Constraint (Loc, 11884 Constraints => New_List (Make_Range (Loc, 11885 Low_Bound => Make_Integer_Literal (Loc, 1), 11886 High_Bound => Convert_To (RTE (RE_Storage_Offset), 11887 Task_Size))))))); 11888 11889 Append_To (Cdecls, Decl_Stack); 11890 11891 -- The appropriate alignment for the stack is ensured by the run-time 11892 -- code in charge of task creation. 11893 11894 end if; 11895 11896 -- Add components for entry families 11897 11898 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); 11899 11900 -- Add the _Priority component if a Interrupt_Priority or Priority rep 11901 -- item is present. 11902 11903 if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then 11904 Append_To (Cdecls, 11905 Make_Component_Declaration (Loc, 11906 Defining_Identifier => 11907 Make_Defining_Identifier (Loc, Name_uPriority), 11908 Component_Definition => 11909 Make_Component_Definition (Loc, 11910 Aliased_Present => False, 11911 Subtype_Indication => 11912 New_Occurrence_Of (Standard_Integer, Loc)))); 11913 end if; 11914 11915 -- Add the _Size component if a Storage_Size pragma is present 11916 11917 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 11918 Append_To (Cdecls, 11919 Make_Component_Declaration (Loc, 11920 Defining_Identifier => 11921 Make_Defining_Identifier (Loc, Name_uSize), 11922 11923 Component_Definition => 11924 Make_Component_Definition (Loc, 11925 Aliased_Present => False, 11926 Subtype_Indication => 11927 New_Occurrence_Of (RTE (RE_Size_Type), Loc)), 11928 11929 Expression => 11930 Convert_To (RTE (RE_Size_Type), 11931 Relocate_Node ( 11932 Expression (First ( 11933 Pragma_Argument_Associations ( 11934 Get_Rep_Pragma (TaskId, Name_Storage_Size)))))))); 11935 end if; 11936 11937 -- Add the _Task_Info component if a Task_Info pragma is present 11938 11939 if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then 11940 Append_To (Cdecls, 11941 Make_Component_Declaration (Loc, 11942 Defining_Identifier => 11943 Make_Defining_Identifier (Loc, Name_uTask_Info), 11944 11945 Component_Definition => 11946 Make_Component_Definition (Loc, 11947 Aliased_Present => False, 11948 Subtype_Indication => 11949 New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)), 11950 11951 Expression => New_Copy ( 11952 Expression (First ( 11953 Pragma_Argument_Associations ( 11954 Get_Rep_Pragma 11955 (TaskId, Name_Task_Info, Check_Parents => False))))))); 11956 end if; 11957 11958 -- Add the _CPU component if a CPU rep item is present 11959 11960 if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then 11961 Append_To (Cdecls, 11962 Make_Component_Declaration (Loc, 11963 Defining_Identifier => 11964 Make_Defining_Identifier (Loc, Name_uCPU), 11965 11966 Component_Definition => 11967 Make_Component_Definition (Loc, 11968 Aliased_Present => False, 11969 Subtype_Indication => 11970 New_Occurrence_Of (RTE (RE_CPU_Range), Loc)))); 11971 end if; 11972 11973 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is 11974 -- present. If we are using a restricted run time this component will 11975 -- not be added (deadlines are not allowed by the Ravenscar profile). 11976 11977 if not Restricted_Profile 11978 and then Present (Taskdef) 11979 and then Has_Relative_Deadline_Pragma (Taskdef) 11980 then 11981 Append_To (Cdecls, 11982 Make_Component_Declaration (Loc, 11983 Defining_Identifier => 11984 Make_Defining_Identifier (Loc, Name_uRelative_Deadline), 11985 11986 Component_Definition => 11987 Make_Component_Definition (Loc, 11988 Aliased_Present => False, 11989 Subtype_Indication => 11990 New_Occurrence_Of (RTE (RE_Time_Span), Loc)), 11991 11992 Expression => 11993 Convert_To (RTE (RE_Time_Span), 11994 Relocate_Node ( 11995 Expression (First ( 11996 Pragma_Argument_Associations ( 11997 Get_Relative_Deadline_Pragma (Taskdef)))))))); 11998 end if; 11999 12000 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep 12001 -- item is present. If we are using a restricted run time this component 12002 -- will not be added (dispatching domains are not allowed by the 12003 -- Ravenscar profile). 12004 12005 if not Restricted_Profile 12006 and then 12007 Has_Rep_Item 12008 (TaskId, Name_Dispatching_Domain, Check_Parents => False) 12009 then 12010 Append_To (Cdecls, 12011 Make_Component_Declaration (Loc, 12012 Defining_Identifier => 12013 Make_Defining_Identifier (Loc, Name_uDispatching_Domain), 12014 12015 Component_Definition => 12016 Make_Component_Definition (Loc, 12017 Aliased_Present => False, 12018 Subtype_Indication => 12019 New_Occurrence_Of 12020 (RTE (RE_Dispatching_Domain_Access), Loc)))); 12021 end if; 12022 12023 Insert_After (Size_Decl, Rec_Decl); 12024 12025 -- Analyze the record declaration immediately after construction, 12026 -- because the initialization procedure is needed for single task 12027 -- declarations before the next entity is analyzed. 12028 12029 Analyze (Rec_Decl); 12030 12031 -- Create the declaration of the task body procedure 12032 12033 Proc_Spec := Build_Task_Proc_Specification (Tasktyp); 12034 Body_Decl := 12035 Make_Subprogram_Declaration (Loc, 12036 Specification => Proc_Spec); 12037 12038 Insert_After (Rec_Decl, Body_Decl); 12039 12040 -- The subprogram does not comes from source, so we have to indicate the 12041 -- need for debugging information explicitly. 12042 12043 if Comes_From_Source (Original_Node (N)) then 12044 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec)); 12045 end if; 12046 12047 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before 12048 -- the corresponding record has been frozen. 12049 12050 if Ada_Version >= Ada_2005 then 12051 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl); 12052 end if; 12053 12054 -- Ada 2005 (AI-345): We must defer freezing to allow further 12055 -- declaration of primitive subprograms covering task interfaces 12056 12057 if Ada_Version <= Ada_95 then 12058 12059 -- Now we can freeze the corresponding record. This needs manually 12060 -- freezing, since it is really part of the task type, and the task 12061 -- type is frozen at this stage. We of course need the initialization 12062 -- procedure for this corresponding record type and we won't get it 12063 -- in time if we don't freeze now. 12064 12065 declare 12066 L : constant List_Id := Freeze_Entity (Rec_Ent, N); 12067 begin 12068 if Is_Non_Empty_List (L) then 12069 Insert_List_After (Body_Decl, L); 12070 end if; 12071 end; 12072 end if; 12073 12074 -- Complete the expansion of access types to the current task type, if 12075 -- any were declared. 12076 12077 Expand_Previous_Access_Type (Tasktyp); 12078 12079 -- Create wrappers for entries that have pre/postconditions 12080 12081 declare 12082 Ent : Entity_Id; 12083 12084 begin 12085 Ent := First_Entity (Tasktyp); 12086 while Present (Ent) loop 12087 if Ekind_In (Ent, E_Entry, E_Entry_Family) 12088 and then Present (Contract (Ent)) 12089 and then Present (Pre_Post_Conditions (Contract (Ent))) 12090 then 12091 Build_PPC_Wrapper (Ent, N); 12092 end if; 12093 12094 Next_Entity (Ent); 12095 end loop; 12096 end; 12097 end Expand_N_Task_Type_Declaration; 12098 12099 ------------------------------- 12100 -- Expand_N_Timed_Entry_Call -- 12101 ------------------------------- 12102 12103 -- A timed entry call in normal case is not implemented using ATC mechanism 12104 -- anymore for efficiency reason. 12105 12106 -- select 12107 -- T.E; 12108 -- S1; 12109 -- or 12110 -- delay D; 12111 -- S2; 12112 -- end select; 12113 12114 -- is expanded as follows: 12115 12116 -- 1) When T.E is a task entry_call; 12117 12118 -- declare 12119 -- B : Boolean; 12120 -- X : Task_Entry_Index := <entry index>; 12121 -- DX : Duration := To_Duration (D); 12122 -- M : Delay_Mode := <discriminant>; 12123 -- P : parms := (parm, parm, parm); 12124 12125 -- begin 12126 -- Timed_Protected_Entry_Call 12127 -- (<acceptor-task>, X, P'Address, DX, M, B); 12128 -- if B then 12129 -- S1; 12130 -- else 12131 -- S2; 12132 -- end if; 12133 -- end; 12134 12135 -- 2) When T.E is a protected entry_call; 12136 12137 -- declare 12138 -- B : Boolean; 12139 -- X : Protected_Entry_Index := <entry index>; 12140 -- DX : Duration := To_Duration (D); 12141 -- M : Delay_Mode := <discriminant>; 12142 -- P : parms := (parm, parm, parm); 12143 12144 -- begin 12145 -- Timed_Protected_Entry_Call 12146 -- (<object>'unchecked_access, X, P'Address, DX, M, B); 12147 -- if B then 12148 -- S1; 12149 -- else 12150 -- S2; 12151 -- end if; 12152 -- end; 12153 12154 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there 12155 -- is no delay and the triggering statements are executed. We first 12156 -- determine the kind of of the triggering call and then execute a 12157 -- synchronized operation or a direct call. 12158 12159 -- declare 12160 -- B : Boolean := False; 12161 -- C : Ada.Tags.Prim_Op_Kind; 12162 -- DX : Duration := To_Duration (D) 12163 -- K : Ada.Tags.Tagged_Kind := 12164 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 12165 -- M : Integer :=...; 12166 -- P : Parameters := (Param1 .. ParamN); 12167 -- S : Integer; 12168 12169 -- begin 12170 -- if K = Ada.Tags.TK_Limited_Tagged 12171 -- or else K = Ada.Tags.TK_Tagged 12172 -- then 12173 -- <dispatching-call>; 12174 -- B := True; 12175 12176 -- else 12177 -- S := 12178 -- Ada.Tags.Get_Offset_Index 12179 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 12180 12181 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B); 12182 12183 -- if C = POK_Protected_Entry 12184 -- or else C = POK_Task_Entry 12185 -- then 12186 -- Param1 := P.Param1; 12187 -- ... 12188 -- ParamN := P.ParamN; 12189 -- end if; 12190 12191 -- if B then 12192 -- if C = POK_Procedure 12193 -- or else C = POK_Protected_Procedure 12194 -- or else C = POK_Task_Procedure 12195 -- then 12196 -- <dispatching-call>; 12197 -- end if; 12198 -- end if; 12199 -- end if; 12200 12201 -- if B then 12202 -- <triggering-statements> 12203 -- else 12204 -- <timed-statements> 12205 -- end if; 12206 -- end; 12207 12208 -- The triggering statement and the sequence of timed statements have not 12209 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain 12210 -- global references if within an instantiation. 12211 12212 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is 12213 Loc : constant Source_Ptr := Sloc (N); 12214 12215 Actuals : List_Id; 12216 Blk_Typ : Entity_Id; 12217 Call : Node_Id; 12218 Call_Ent : Entity_Id; 12219 Conc_Typ_Stmts : List_Id; 12220 Concval : Node_Id; 12221 D_Alt : constant Node_Id := Delay_Alternative (N); 12222 D_Conv : Node_Id; 12223 D_Disc : Node_Id; 12224 D_Stat : Node_Id := Delay_Statement (D_Alt); 12225 D_Stats : List_Id; 12226 D_Type : Entity_Id; 12227 Decls : List_Id; 12228 Dummy : Node_Id; 12229 E_Alt : constant Node_Id := Entry_Call_Alternative (N); 12230 E_Call : Node_Id := Entry_Call_Statement (E_Alt); 12231 E_Stats : List_Id; 12232 Ename : Node_Id; 12233 Formals : List_Id; 12234 Index : Node_Id; 12235 Is_Disp_Select : Boolean; 12236 Lim_Typ_Stmts : List_Id; 12237 N_Stats : List_Id; 12238 Obj : Entity_Id; 12239 Param : Node_Id; 12240 Params : List_Id; 12241 Stmt : Node_Id; 12242 Stmts : List_Id; 12243 Unpack : List_Id; 12244 12245 B : Entity_Id; -- Call status flag 12246 C : Entity_Id; -- Call kind 12247 D : Entity_Id; -- Delay 12248 K : Entity_Id; -- Tagged kind 12249 M : Entity_Id; -- Delay mode 12250 P : Entity_Id; -- Parameter block 12251 S : Entity_Id; -- Primitive operation slot 12252 12253 -- Start of processing for Expand_N_Timed_Entry_Call 12254 12255 begin 12256 -- Under the Ravenscar profile, timed entry calls are excluded. An error 12257 -- was already reported on spec, so do not attempt to expand the call. 12258 12259 if Restriction_Active (No_Select_Statements) then 12260 return; 12261 end if; 12262 12263 Process_Statements_For_Controlled_Objects (E_Alt); 12264 Process_Statements_For_Controlled_Objects (D_Alt); 12265 12266 Ensure_Statement_Present (Sloc (D_Stat), D_Alt); 12267 12268 -- Retrieve E_Stats and D_Stats now because the finalization machinery 12269 -- may wrap them in blocks. 12270 12271 E_Stats := Statements (E_Alt); 12272 D_Stats := Statements (D_Alt); 12273 12274 -- The arguments in the call may require dynamic allocation, and the 12275 -- call statement may have been transformed into a block. The block 12276 -- may contain additional declarations for internal entities, and the 12277 -- original call is found by sequential search. 12278 12279 if Nkind (E_Call) = N_Block_Statement then 12280 E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); 12281 while not Nkind_In (E_Call, N_Procedure_Call_Statement, 12282 N_Entry_Call_Statement) 12283 loop 12284 Next (E_Call); 12285 end loop; 12286 end if; 12287 12288 Is_Disp_Select := 12289 Ada_Version >= Ada_2005 12290 and then Nkind (E_Call) = N_Procedure_Call_Statement; 12291 12292 if Is_Disp_Select then 12293 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals); 12294 Decls := New_List; 12295 12296 Stmts := New_List; 12297 12298 -- Generate: 12299 -- B : Boolean := False; 12300 12301 B := Build_B (Loc, Decls); 12302 12303 -- Generate: 12304 -- C : Ada.Tags.Prim_Op_Kind; 12305 12306 C := Build_C (Loc, Decls); 12307 12308 -- Because the analysis of all statements was disabled, manually 12309 -- analyze the delay statement. 12310 12311 Analyze (D_Stat); 12312 D_Stat := Original_Node (D_Stat); 12313 12314 else 12315 -- Build an entry call using Simple_Entry_Call 12316 12317 Extract_Entry (E_Call, Concval, Ename, Index); 12318 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); 12319 12320 Decls := Declarations (E_Call); 12321 Stmts := Statements (Handled_Statement_Sequence (E_Call)); 12322 12323 if No (Decls) then 12324 Decls := New_List; 12325 end if; 12326 12327 -- Generate: 12328 -- B : Boolean; 12329 12330 B := Make_Defining_Identifier (Loc, Name_uB); 12331 12332 Prepend_To (Decls, 12333 Make_Object_Declaration (Loc, 12334 Defining_Identifier => B, 12335 Object_Definition => 12336 New_Occurrence_Of (Standard_Boolean, Loc))); 12337 end if; 12338 12339 -- Duration and mode processing 12340 12341 D_Type := Base_Type (Etype (Expression (D_Stat))); 12342 12343 -- Use the type of the delay expression (Calendar or Real_Time) to 12344 -- generate the appropriate conversion. 12345 12346 if Nkind (D_Stat) = N_Delay_Relative_Statement then 12347 D_Disc := Make_Integer_Literal (Loc, 0); 12348 D_Conv := Relocate_Node (Expression (D_Stat)); 12349 12350 elsif Is_RTE (D_Type, RO_CA_Time) then 12351 D_Disc := Make_Integer_Literal (Loc, 1); 12352 D_Conv := 12353 Make_Function_Call (Loc, 12354 Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 12355 Parameter_Associations => 12356 New_List (New_Copy (Expression (D_Stat)))); 12357 12358 else pragma Assert (Is_RTE (D_Type, RO_RT_Time)); 12359 D_Disc := Make_Integer_Literal (Loc, 2); 12360 D_Conv := 12361 Make_Function_Call (Loc, 12362 Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 12363 Parameter_Associations => 12364 New_List (New_Copy (Expression (D_Stat)))); 12365 end if; 12366 12367 D := Make_Temporary (Loc, 'D'); 12368 12369 -- Generate: 12370 -- D : Duration; 12371 12372 Append_To (Decls, 12373 Make_Object_Declaration (Loc, 12374 Defining_Identifier => D, 12375 Object_Definition => New_Occurrence_Of (Standard_Duration, Loc))); 12376 12377 M := Make_Temporary (Loc, 'M'); 12378 12379 -- Generate: 12380 -- M : Integer := (0 | 1 | 2); 12381 12382 Append_To (Decls, 12383 Make_Object_Declaration (Loc, 12384 Defining_Identifier => M, 12385 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 12386 Expression => D_Disc)); 12387 12388 -- Do the assignment at this stage only because the evaluation of the 12389 -- expression must not occur before (see ACVC C97302A). 12390 12391 Append_To (Stmts, 12392 Make_Assignment_Statement (Loc, 12393 Name => New_Occurrence_Of (D, Loc), 12394 Expression => D_Conv)); 12395 12396 -- Parameter block processing 12397 12398 -- Manually create the parameter block for dispatching calls. In the 12399 -- case of entries, the block has already been created during the call 12400 -- to Build_Simple_Entry_Call. 12401 12402 if Is_Disp_Select then 12403 12404 -- Tagged kind processing, generate: 12405 -- K : Ada.Tags.Tagged_Kind := 12406 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>)); 12407 12408 K := Build_K (Loc, Decls, Obj); 12409 12410 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 12411 P := 12412 Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 12413 12414 -- Dispatch table slot processing, generate: 12415 -- S : Integer; 12416 12417 S := Build_S (Loc, Decls); 12418 12419 -- Generate: 12420 -- S := Ada.Tags.Get_Offset_Index 12421 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 12422 12423 Conc_Typ_Stmts := 12424 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 12425 12426 -- Generate: 12427 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B); 12428 12429 -- where Obj is the controlling formal parameter, S is the dispatch 12430 -- table slot number of the dispatching operation, P is the wrapped 12431 -- parameter block, D is the duration, M is the duration mode, C is 12432 -- the call kind and B is the call status. 12433 12434 Params := New_List; 12435 12436 Append_To (Params, New_Copy_Tree (Obj)); 12437 Append_To (Params, New_Occurrence_Of (S, Loc)); 12438 Append_To (Params, 12439 Make_Attribute_Reference (Loc, 12440 Prefix => New_Occurrence_Of (P, Loc), 12441 Attribute_Name => Name_Address)); 12442 Append_To (Params, New_Occurrence_Of (D, Loc)); 12443 Append_To (Params, New_Occurrence_Of (M, Loc)); 12444 Append_To (Params, New_Occurrence_Of (C, Loc)); 12445 Append_To (Params, New_Occurrence_Of (B, Loc)); 12446 12447 Append_To (Conc_Typ_Stmts, 12448 Make_Procedure_Call_Statement (Loc, 12449 Name => 12450 New_Occurrence_Of 12451 (Find_Prim_Op 12452 (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc), 12453 Parameter_Associations => Params)); 12454 12455 -- Generate: 12456 -- if C = POK_Protected_Entry 12457 -- or else C = POK_Task_Entry 12458 -- then 12459 -- Param1 := P.Param1; 12460 -- ... 12461 -- ParamN := P.ParamN; 12462 -- end if; 12463 12464 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 12465 12466 -- Generate the if statement only when the packed parameters need 12467 -- explicit assignments to their corresponding actuals. 12468 12469 if Present (Unpack) then 12470 Append_To (Conc_Typ_Stmts, 12471 Make_Implicit_If_Statement (N, 12472 12473 Condition => 12474 Make_Or_Else (Loc, 12475 Left_Opnd => 12476 Make_Op_Eq (Loc, 12477 Left_Opnd => New_Occurrence_Of (C, Loc), 12478 Right_Opnd => 12479 New_Occurrence_Of 12480 (RTE (RE_POK_Protected_Entry), Loc)), 12481 12482 Right_Opnd => 12483 Make_Op_Eq (Loc, 12484 Left_Opnd => New_Occurrence_Of (C, Loc), 12485 Right_Opnd => 12486 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 12487 12488 Then_Statements => Unpack)); 12489 end if; 12490 12491 -- Generate: 12492 12493 -- if B then 12494 -- if C = POK_Procedure 12495 -- or else C = POK_Protected_Procedure 12496 -- or else C = POK_Task_Procedure 12497 -- then 12498 -- <dispatching-call> 12499 -- end if; 12500 -- end if; 12501 12502 N_Stats := New_List ( 12503 Make_Implicit_If_Statement (N, 12504 Condition => 12505 Make_Or_Else (Loc, 12506 Left_Opnd => 12507 Make_Op_Eq (Loc, 12508 Left_Opnd => New_Occurrence_Of (C, Loc), 12509 Right_Opnd => 12510 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 12511 12512 Right_Opnd => 12513 Make_Or_Else (Loc, 12514 Left_Opnd => 12515 Make_Op_Eq (Loc, 12516 Left_Opnd => New_Occurrence_Of (C, Loc), 12517 Right_Opnd => 12518 New_Occurrence_Of (RTE ( 12519 RE_POK_Protected_Procedure), Loc)), 12520 Right_Opnd => 12521 Make_Op_Eq (Loc, 12522 Left_Opnd => New_Occurrence_Of (C, Loc), 12523 Right_Opnd => 12524 New_Occurrence_Of 12525 (RTE (RE_POK_Task_Procedure), Loc)))), 12526 12527 Then_Statements => New_List (E_Call))); 12528 12529 Append_To (Conc_Typ_Stmts, 12530 Make_Implicit_If_Statement (N, 12531 Condition => New_Occurrence_Of (B, Loc), 12532 Then_Statements => N_Stats)); 12533 12534 -- Generate: 12535 -- <dispatching-call>; 12536 -- B := True; 12537 12538 Lim_Typ_Stmts := 12539 New_List (New_Copy_Tree (E_Call), 12540 Make_Assignment_Statement (Loc, 12541 Name => New_Occurrence_Of (B, Loc), 12542 Expression => New_Occurrence_Of (Standard_True, Loc))); 12543 12544 -- Generate: 12545 -- if K = Ada.Tags.TK_Limited_Tagged 12546 -- or else K = Ada.Tags.TK_Tagged 12547 -- then 12548 -- Lim_Typ_Stmts 12549 -- else 12550 -- Conc_Typ_Stmts 12551 -- end if; 12552 12553 Append_To (Stmts, 12554 Make_Implicit_If_Statement (N, 12555 Condition => Build_Dispatching_Tag_Check (K, N), 12556 Then_Statements => Lim_Typ_Stmts, 12557 Else_Statements => Conc_Typ_Stmts)); 12558 12559 -- Generate: 12560 12561 -- if B then 12562 -- <triggering-statements> 12563 -- else 12564 -- <timed-statements> 12565 -- end if; 12566 12567 Append_To (Stmts, 12568 Make_Implicit_If_Statement (N, 12569 Condition => New_Occurrence_Of (B, Loc), 12570 Then_Statements => E_Stats, 12571 Else_Statements => D_Stats)); 12572 12573 else 12574 -- Simple case of a non-dispatching trigger. Skip assignments to 12575 -- temporaries created for in-out parameters. 12576 12577 -- This makes unwarranted assumptions about the shape of the expanded 12578 -- tree for the call, and should be cleaned up ??? 12579 12580 Stmt := First (Stmts); 12581 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 12582 Next (Stmt); 12583 end loop; 12584 12585 -- Do the assignment at this stage only because the evaluation 12586 -- of the expression must not occur before (see ACVC C97302A). 12587 12588 Insert_Before (Stmt, 12589 Make_Assignment_Statement (Loc, 12590 Name => New_Occurrence_Of (D, Loc), 12591 Expression => D_Conv)); 12592 12593 Call := Stmt; 12594 Params := Parameter_Associations (Call); 12595 12596 -- For a protected type, we build a Timed_Protected_Entry_Call 12597 12598 if Is_Protected_Type (Etype (Concval)) then 12599 12600 -- Create a new call statement 12601 12602 Param := First (Params); 12603 while Present (Param) 12604 and then not Is_RTE (Etype (Param), RE_Call_Modes) 12605 loop 12606 Next (Param); 12607 end loop; 12608 12609 Dummy := Remove_Next (Next (Param)); 12610 12611 -- Remove garbage is following the Cancel_Param if present 12612 12613 Dummy := Next (Param); 12614 12615 -- Remove the mode of the Protected_Entry_Call call, then remove 12616 -- the Communication_Block of the Protected_Entry_Call call, and 12617 -- finally add Duration and a Delay_Mode parameter 12618 12619 pragma Assert (Present (Param)); 12620 Rewrite (Param, New_Occurrence_Of (D, Loc)); 12621 12622 Rewrite (Dummy, New_Occurrence_Of (M, Loc)); 12623 12624 -- Add a Boolean flag for successful entry call 12625 12626 Append_To (Params, New_Occurrence_Of (B, Loc)); 12627 12628 case Corresponding_Runtime_Package (Etype (Concval)) is 12629 when System_Tasking_Protected_Objects_Entries => 12630 Rewrite (Call, 12631 Make_Procedure_Call_Statement (Loc, 12632 Name => 12633 New_Occurrence_Of 12634 (RTE (RE_Timed_Protected_Entry_Call), Loc), 12635 Parameter_Associations => Params)); 12636 12637 when others => 12638 raise Program_Error; 12639 end case; 12640 12641 -- For the task case, build a Timed_Task_Entry_Call 12642 12643 else 12644 -- Create a new call statement 12645 12646 Append_To (Params, New_Occurrence_Of (D, Loc)); 12647 Append_To (Params, New_Occurrence_Of (M, Loc)); 12648 Append_To (Params, New_Occurrence_Of (B, Loc)); 12649 12650 Rewrite (Call, 12651 Make_Procedure_Call_Statement (Loc, 12652 Name => 12653 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc), 12654 Parameter_Associations => Params)); 12655 end if; 12656 12657 Append_To (Stmts, 12658 Make_Implicit_If_Statement (N, 12659 Condition => New_Occurrence_Of (B, Loc), 12660 Then_Statements => E_Stats, 12661 Else_Statements => D_Stats)); 12662 end if; 12663 12664 Rewrite (N, 12665 Make_Block_Statement (Loc, 12666 Declarations => Decls, 12667 Handled_Statement_Sequence => 12668 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 12669 12670 Analyze (N); 12671 end Expand_N_Timed_Entry_Call; 12672 12673 ---------------------------------------- 12674 -- Expand_Protected_Body_Declarations -- 12675 ---------------------------------------- 12676 12677 procedure Expand_Protected_Body_Declarations 12678 (N : Node_Id; 12679 Spec_Id : Entity_Id) 12680 is 12681 begin 12682 if No_Run_Time_Mode then 12683 Error_Msg_CRT ("protected body", N); 12684 return; 12685 12686 elsif Expander_Active then 12687 12688 -- Associate discriminals with the first subprogram or entry body to 12689 -- be expanded. 12690 12691 if Present (First_Protected_Operation (Declarations (N))) then 12692 Set_Discriminals (Parent (Spec_Id)); 12693 end if; 12694 end if; 12695 end Expand_Protected_Body_Declarations; 12696 12697 ------------------------- 12698 -- External_Subprogram -- 12699 ------------------------- 12700 12701 function External_Subprogram (E : Entity_Id) return Entity_Id is 12702 Subp : constant Entity_Id := Protected_Body_Subprogram (E); 12703 12704 begin 12705 -- The internal and external subprograms follow each other on the entity 12706 -- chain. Note that previously private operations had no separate 12707 -- external subprogram. We now create one in all cases, because a 12708 -- private operation may actually appear in an external call, through 12709 -- a 'Access reference used for a callback. 12710 12711 -- If the operation is a function that returns an anonymous access type, 12712 -- the corresponding itype appears before the operation, and must be 12713 -- skipped. 12714 12715 -- This mechanism is fragile, there should be a real link between the 12716 -- two versions of the operation, but there is no place to put it ??? 12717 12718 if Is_Access_Type (Next_Entity (Subp)) then 12719 return Next_Entity (Next_Entity (Subp)); 12720 else 12721 return Next_Entity (Subp); 12722 end if; 12723 end External_Subprogram; 12724 12725 ------------------------------ 12726 -- Extract_Dispatching_Call -- 12727 ------------------------------ 12728 12729 procedure Extract_Dispatching_Call 12730 (N : Node_Id; 12731 Call_Ent : out Entity_Id; 12732 Object : out Entity_Id; 12733 Actuals : out List_Id; 12734 Formals : out List_Id) 12735 is 12736 Call_Nam : Node_Id; 12737 12738 begin 12739 pragma Assert (Nkind (N) = N_Procedure_Call_Statement); 12740 12741 if Present (Original_Node (N)) then 12742 Call_Nam := Name (Original_Node (N)); 12743 else 12744 Call_Nam := Name (N); 12745 end if; 12746 12747 -- Retrieve the name of the dispatching procedure. It contains the 12748 -- dispatch table slot number. 12749 12750 loop 12751 case Nkind (Call_Nam) is 12752 when N_Identifier => 12753 exit; 12754 12755 when N_Selected_Component => 12756 Call_Nam := Selector_Name (Call_Nam); 12757 12758 when others => 12759 raise Program_Error; 12760 12761 end case; 12762 end loop; 12763 12764 Actuals := Parameter_Associations (N); 12765 Call_Ent := Entity (Call_Nam); 12766 Formals := Parameter_Specifications (Parent (Call_Ent)); 12767 Object := First (Actuals); 12768 12769 if Present (Original_Node (Object)) then 12770 Object := Original_Node (Object); 12771 end if; 12772 12773 -- If the type of the dispatching object is an access type then return 12774 -- an explicit dereference. 12775 12776 if Is_Access_Type (Etype (Object)) then 12777 Object := Make_Explicit_Dereference (Sloc (N), Object); 12778 Analyze (Object); 12779 end if; 12780 end Extract_Dispatching_Call; 12781 12782 ------------------- 12783 -- Extract_Entry -- 12784 ------------------- 12785 12786 procedure Extract_Entry 12787 (N : Node_Id; 12788 Concval : out Node_Id; 12789 Ename : out Node_Id; 12790 Index : out Node_Id) 12791 is 12792 Nam : constant Node_Id := Name (N); 12793 12794 begin 12795 -- For a simple entry, the name is a selected component, with the 12796 -- prefix being the task value, and the selector being the entry. 12797 12798 if Nkind (Nam) = N_Selected_Component then 12799 Concval := Prefix (Nam); 12800 Ename := Selector_Name (Nam); 12801 Index := Empty; 12802 12803 -- For a member of an entry family, the name is an indexed component 12804 -- where the prefix is a selected component, whose prefix in turn is 12805 -- the task value, and whose selector is the entry family. The single 12806 -- expression in the expressions list of the indexed component is the 12807 -- subscript for the family. 12808 12809 else pragma Assert (Nkind (Nam) = N_Indexed_Component); 12810 Concval := Prefix (Prefix (Nam)); 12811 Ename := Selector_Name (Prefix (Nam)); 12812 Index := First (Expressions (Nam)); 12813 end if; 12814 12815 -- Through indirection, the type may actually be a limited view of a 12816 -- concurrent type. When compiling a call, the non-limited view of the 12817 -- type is visible. 12818 12819 if From_Limited_With (Etype (Concval)) then 12820 Set_Etype (Concval, Non_Limited_View (Etype (Concval))); 12821 end if; 12822 end Extract_Entry; 12823 12824 ------------------- 12825 -- Family_Offset -- 12826 ------------------- 12827 12828 function Family_Offset 12829 (Loc : Source_Ptr; 12830 Hi : Node_Id; 12831 Lo : Node_Id; 12832 Ttyp : Entity_Id; 12833 Cap : Boolean) return Node_Id 12834 is 12835 Ityp : Entity_Id; 12836 Real_Hi : Node_Id; 12837 Real_Lo : Node_Id; 12838 12839 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 12840 -- If one of the bounds is a reference to a discriminant, replace with 12841 -- corresponding discriminal of type. Within the body of a task retrieve 12842 -- the renamed discriminant by simple visibility, using its generated 12843 -- name. Within a protected object, find the original discriminant and 12844 -- replace it with the discriminal of the current protected operation. 12845 12846 ------------------------------ 12847 -- Convert_Discriminant_Ref -- 12848 ------------------------------ 12849 12850 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 12851 Loc : constant Source_Ptr := Sloc (Bound); 12852 B : Node_Id; 12853 D : Entity_Id; 12854 12855 begin 12856 if Is_Entity_Name (Bound) 12857 and then Ekind (Entity (Bound)) = E_Discriminant 12858 then 12859 if Is_Task_Type (Ttyp) and then Has_Completion (Ttyp) then 12860 B := Make_Identifier (Loc, Chars (Entity (Bound))); 12861 Find_Direct_Name (B); 12862 12863 elsif Is_Protected_Type (Ttyp) then 12864 D := First_Discriminant (Ttyp); 12865 while Chars (D) /= Chars (Entity (Bound)) loop 12866 Next_Discriminant (D); 12867 end loop; 12868 12869 B := New_Occurrence_Of (Discriminal (D), Loc); 12870 12871 else 12872 B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); 12873 end if; 12874 12875 elsif Nkind (Bound) = N_Attribute_Reference then 12876 return Bound; 12877 12878 else 12879 B := New_Copy_Tree (Bound); 12880 end if; 12881 12882 return 12883 Make_Attribute_Reference (Loc, 12884 Attribute_Name => Name_Pos, 12885 Prefix => New_Occurrence_Of (Etype (Bound), Loc), 12886 Expressions => New_List (B)); 12887 end Convert_Discriminant_Ref; 12888 12889 -- Start of processing for Family_Offset 12890 12891 begin 12892 Real_Hi := Convert_Discriminant_Ref (Hi); 12893 Real_Lo := Convert_Discriminant_Ref (Lo); 12894 12895 if Cap then 12896 if Is_Task_Type (Ttyp) then 12897 Ityp := RTE (RE_Task_Entry_Index); 12898 else 12899 Ityp := RTE (RE_Protected_Entry_Index); 12900 end if; 12901 12902 Real_Hi := 12903 Make_Attribute_Reference (Loc, 12904 Prefix => New_Occurrence_Of (Ityp, Loc), 12905 Attribute_Name => Name_Min, 12906 Expressions => New_List ( 12907 Real_Hi, 12908 Make_Integer_Literal (Loc, Entry_Family_Bound - 1))); 12909 12910 Real_Lo := 12911 Make_Attribute_Reference (Loc, 12912 Prefix => New_Occurrence_Of (Ityp, Loc), 12913 Attribute_Name => Name_Max, 12914 Expressions => New_List ( 12915 Real_Lo, 12916 Make_Integer_Literal (Loc, -Entry_Family_Bound))); 12917 end if; 12918 12919 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo); 12920 end Family_Offset; 12921 12922 ----------------- 12923 -- Family_Size -- 12924 ----------------- 12925 12926 function Family_Size 12927 (Loc : Source_Ptr; 12928 Hi : Node_Id; 12929 Lo : Node_Id; 12930 Ttyp : Entity_Id; 12931 Cap : Boolean) return Node_Id 12932 is 12933 Ityp : Entity_Id; 12934 12935 begin 12936 if Is_Task_Type (Ttyp) then 12937 Ityp := RTE (RE_Task_Entry_Index); 12938 else 12939 Ityp := RTE (RE_Protected_Entry_Index); 12940 end if; 12941 12942 return 12943 Make_Attribute_Reference (Loc, 12944 Prefix => New_Occurrence_Of (Ityp, Loc), 12945 Attribute_Name => Name_Max, 12946 Expressions => New_List ( 12947 Make_Op_Add (Loc, 12948 Left_Opnd => Family_Offset (Loc, Hi, Lo, Ttyp, Cap), 12949 Right_Opnd => Make_Integer_Literal (Loc, 1)), 12950 Make_Integer_Literal (Loc, 0))); 12951 end Family_Size; 12952 12953 ---------------------------- 12954 -- Find_Enclosing_Context -- 12955 ---------------------------- 12956 12957 procedure Find_Enclosing_Context 12958 (N : Node_Id; 12959 Context : out Node_Id; 12960 Context_Id : out Entity_Id; 12961 Context_Decls : out List_Id) 12962 is 12963 begin 12964 -- Traverse the parent chain looking for an enclosing body, block, 12965 -- package or return statement. 12966 12967 Context := Parent (N); 12968 while not Nkind_In (Context, N_Block_Statement, 12969 N_Entry_Body, 12970 N_Extended_Return_Statement, 12971 N_Package_Body, 12972 N_Package_Declaration, 12973 N_Subprogram_Body, 12974 N_Task_Body) 12975 loop 12976 Context := Parent (Context); 12977 end loop; 12978 12979 -- Extract the constituents of the context 12980 12981 if Nkind (Context) = N_Extended_Return_Statement then 12982 Context_Decls := Return_Object_Declarations (Context); 12983 Context_Id := Return_Statement_Entity (Context); 12984 12985 -- Package declarations and bodies use a common library-level activation 12986 -- chain or task master, therefore return the package declaration as the 12987 -- proper carrier for the appropriate flag. 12988 12989 elsif Nkind (Context) = N_Package_Body then 12990 Context_Decls := Declarations (Context); 12991 Context_Id := Corresponding_Spec (Context); 12992 Context := Parent (Context_Id); 12993 12994 if Nkind (Context) = N_Defining_Program_Unit_Name then 12995 Context := Parent (Parent (Context)); 12996 else 12997 Context := Parent (Context); 12998 end if; 12999 13000 elsif Nkind (Context) = N_Package_Declaration then 13001 Context_Decls := Visible_Declarations (Specification (Context)); 13002 Context_Id := Defining_Unit_Name (Specification (Context)); 13003 13004 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13005 Context_Id := Defining_Identifier (Context_Id); 13006 end if; 13007 13008 else 13009 Context_Decls := Declarations (Context); 13010 13011 if Nkind (Context) = N_Block_Statement then 13012 Context_Id := Entity (Identifier (Context)); 13013 13014 elsif Nkind (Context) = N_Entry_Body then 13015 Context_Id := Defining_Identifier (Context); 13016 13017 elsif Nkind (Context) = N_Subprogram_Body then 13018 if Present (Corresponding_Spec (Context)) then 13019 Context_Id := Corresponding_Spec (Context); 13020 else 13021 Context_Id := Defining_Unit_Name (Specification (Context)); 13022 13023 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13024 Context_Id := Defining_Identifier (Context_Id); 13025 end if; 13026 end if; 13027 13028 elsif Nkind (Context) = N_Task_Body then 13029 Context_Id := Corresponding_Spec (Context); 13030 13031 else 13032 raise Program_Error; 13033 end if; 13034 end if; 13035 13036 pragma Assert (Present (Context)); 13037 pragma Assert (Present (Context_Id)); 13038 pragma Assert (Present (Context_Decls)); 13039 end Find_Enclosing_Context; 13040 13041 ----------------------- 13042 -- Find_Master_Scope -- 13043 ----------------------- 13044 13045 function Find_Master_Scope (E : Entity_Id) return Entity_Id is 13046 S : Entity_Id; 13047 13048 begin 13049 -- In Ada 2005, the master is the innermost enclosing scope that is not 13050 -- transient. If the enclosing block is the rewriting of a call or the 13051 -- scope is an extended return statement this is valid master. The 13052 -- master in an extended return is only used within the return, and is 13053 -- subsequently overwritten in Move_Activation_Chain, but it must exist 13054 -- now before that overwriting occurs. 13055 13056 S := Scope (E); 13057 13058 if Ada_Version >= Ada_2005 then 13059 while Is_Internal (S) loop 13060 if Nkind (Parent (S)) = N_Block_Statement 13061 and then 13062 Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement 13063 then 13064 exit; 13065 13066 elsif Ekind (S) = E_Return_Statement then 13067 exit; 13068 13069 else 13070 S := Scope (S); 13071 end if; 13072 end loop; 13073 end if; 13074 13075 return S; 13076 end Find_Master_Scope; 13077 13078 ------------------------------- 13079 -- First_Protected_Operation -- 13080 ------------------------------- 13081 13082 function First_Protected_Operation (D : List_Id) return Node_Id is 13083 First_Op : Node_Id; 13084 13085 begin 13086 First_Op := First (D); 13087 while Present (First_Op) 13088 and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body) 13089 loop 13090 Next (First_Op); 13091 end loop; 13092 13093 return First_Op; 13094 end First_Protected_Operation; 13095 13096 --------------------------------------- 13097 -- Install_Private_Data_Declarations -- 13098 --------------------------------------- 13099 13100 procedure Install_Private_Data_Declarations 13101 (Loc : Source_Ptr; 13102 Spec_Id : Entity_Id; 13103 Conc_Typ : Entity_Id; 13104 Body_Nod : Node_Id; 13105 Decls : List_Id; 13106 Barrier : Boolean := False; 13107 Family : Boolean := False) 13108 is 13109 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ); 13110 Decl : Node_Id; 13111 Def : Node_Id; 13112 Insert_Node : Node_Id := Empty; 13113 Obj_Ent : Entity_Id; 13114 13115 procedure Add (Decl : Node_Id); 13116 -- Add a single declaration after Insert_Node. If this is the first 13117 -- addition, Decl is added to the front of Decls and it becomes the 13118 -- insertion node. 13119 13120 function Replace_Bound (Bound : Node_Id) return Node_Id; 13121 -- The bounds of an entry index may depend on discriminants, create a 13122 -- reference to the corresponding prival. Otherwise return a duplicate 13123 -- of the original bound. 13124 13125 --------- 13126 -- Add -- 13127 --------- 13128 13129 procedure Add (Decl : Node_Id) is 13130 begin 13131 if No (Insert_Node) then 13132 Prepend_To (Decls, Decl); 13133 else 13134 Insert_After (Insert_Node, Decl); 13135 end if; 13136 13137 Insert_Node := Decl; 13138 end Add; 13139 13140 -------------------------- 13141 -- Replace_Discriminant -- 13142 -------------------------- 13143 13144 function Replace_Bound (Bound : Node_Id) return Node_Id is 13145 begin 13146 if Nkind (Bound) = N_Identifier 13147 and then Is_Discriminal (Entity (Bound)) 13148 then 13149 return Make_Identifier (Loc, Chars (Entity (Bound))); 13150 else 13151 return Duplicate_Subexpr (Bound); 13152 end if; 13153 end Replace_Bound; 13154 13155 -- Start of processing for Install_Private_Data_Declarations 13156 13157 begin 13158 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote 13159 -- formal parameter _O, _object or _task depending on the context. 13160 13161 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ); 13162 13163 -- Special processing of _O for barrier functions, protected entries 13164 -- and families. 13165 13166 if Barrier 13167 or else 13168 (Is_Protected 13169 and then 13170 (Ekind (Spec_Id) = E_Entry 13171 or else Ekind (Spec_Id) = E_Entry_Family)) 13172 then 13173 declare 13174 Conc_Rec : constant Entity_Id := 13175 Corresponding_Record_Type (Conc_Typ); 13176 Typ_Id : constant Entity_Id := 13177 Make_Defining_Identifier (Loc, 13178 New_External_Name (Chars (Conc_Rec), 'P')); 13179 begin 13180 -- Generate: 13181 -- type prot_typVP is access prot_typV; 13182 13183 Decl := 13184 Make_Full_Type_Declaration (Loc, 13185 Defining_Identifier => Typ_Id, 13186 Type_Definition => 13187 Make_Access_To_Object_Definition (Loc, 13188 Subtype_Indication => 13189 New_Occurrence_Of (Conc_Rec, Loc))); 13190 Add (Decl); 13191 13192 -- Generate: 13193 -- _object : prot_typVP := prot_typV (_O); 13194 13195 Decl := 13196 Make_Object_Declaration (Loc, 13197 Defining_Identifier => 13198 Make_Defining_Identifier (Loc, Name_uObject), 13199 Object_Definition => New_Occurrence_Of (Typ_Id, Loc), 13200 Expression => 13201 Unchecked_Convert_To (Typ_Id, 13202 New_Occurrence_Of (Obj_Ent, Loc))); 13203 Add (Decl); 13204 13205 -- Set the reference to the concurrent object 13206 13207 Obj_Ent := Defining_Identifier (Decl); 13208 end; 13209 end if; 13210 13211 -- Step 2: Create the Protection object and build its declaration for 13212 -- any protected entry (family) of subprogram. Note for the lock-free 13213 -- implementation, the Protection object is not needed anymore. 13214 13215 if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then 13216 declare 13217 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R'); 13218 Prot_Typ : RE_Id; 13219 13220 begin 13221 Set_Protection_Object (Spec_Id, Prot_Ent); 13222 13223 -- Determine the proper protection type 13224 13225 if Has_Attach_Handler (Conc_Typ) 13226 and then not Restricted_Profile 13227 then 13228 Prot_Typ := RE_Static_Interrupt_Protection; 13229 13230 elsif Has_Interrupt_Handler (Conc_Typ) 13231 and then not Restriction_Active (No_Dynamic_Attachment) 13232 then 13233 Prot_Typ := RE_Dynamic_Interrupt_Protection; 13234 13235 else 13236 case Corresponding_Runtime_Package (Conc_Typ) is 13237 when System_Tasking_Protected_Objects_Entries => 13238 Prot_Typ := RE_Protection_Entries; 13239 13240 when System_Tasking_Protected_Objects_Single_Entry => 13241 Prot_Typ := RE_Protection_Entry; 13242 13243 when System_Tasking_Protected_Objects => 13244 Prot_Typ := RE_Protection; 13245 13246 when others => 13247 raise Program_Error; 13248 end case; 13249 end if; 13250 13251 -- Generate: 13252 -- conc_typR : protection_typ renames _object._object; 13253 13254 Decl := 13255 Make_Object_Renaming_Declaration (Loc, 13256 Defining_Identifier => Prot_Ent, 13257 Subtype_Mark => 13258 New_Occurrence_Of (RTE (Prot_Typ), Loc), 13259 Name => 13260 Make_Selected_Component (Loc, 13261 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13262 Selector_Name => Make_Identifier (Loc, Name_uObject))); 13263 Add (Decl); 13264 end; 13265 end if; 13266 13267 -- Step 3: Add discriminant renamings (if any) 13268 13269 if Has_Discriminants (Conc_Typ) then 13270 declare 13271 D : Entity_Id; 13272 13273 begin 13274 D := First_Discriminant (Conc_Typ); 13275 while Present (D) loop 13276 13277 -- Adjust the source location 13278 13279 Set_Sloc (Discriminal (D), Loc); 13280 13281 -- Generate: 13282 -- discr_name : discr_typ renames _object.discr_name; 13283 -- or 13284 -- discr_name : discr_typ renames _task.discr_name; 13285 13286 Decl := 13287 Make_Object_Renaming_Declaration (Loc, 13288 Defining_Identifier => Discriminal (D), 13289 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc), 13290 Name => 13291 Make_Selected_Component (Loc, 13292 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13293 Selector_Name => Make_Identifier (Loc, Chars (D)))); 13294 Add (Decl); 13295 13296 Next_Discriminant (D); 13297 end loop; 13298 end; 13299 end if; 13300 13301 -- Step 4: Add private component renamings (if any) 13302 13303 if Is_Protected then 13304 Def := Protected_Definition (Parent (Conc_Typ)); 13305 13306 if Present (Private_Declarations (Def)) then 13307 declare 13308 Comp : Node_Id; 13309 Comp_Id : Entity_Id; 13310 Decl_Id : Entity_Id; 13311 13312 begin 13313 Comp := First (Private_Declarations (Def)); 13314 while Present (Comp) loop 13315 if Nkind (Comp) = N_Component_Declaration then 13316 Comp_Id := Defining_Identifier (Comp); 13317 Decl_Id := 13318 Make_Defining_Identifier (Loc, Chars (Comp_Id)); 13319 13320 -- Minimal decoration 13321 13322 if Ekind (Spec_Id) = E_Function then 13323 Set_Ekind (Decl_Id, E_Constant); 13324 else 13325 Set_Ekind (Decl_Id, E_Variable); 13326 end if; 13327 13328 Set_Prival (Comp_Id, Decl_Id); 13329 Set_Prival_Link (Decl_Id, Comp_Id); 13330 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id)); 13331 13332 -- Generate: 13333 -- comp_name : comp_typ renames _object.comp_name; 13334 13335 Decl := 13336 Make_Object_Renaming_Declaration (Loc, 13337 Defining_Identifier => Decl_Id, 13338 Subtype_Mark => 13339 New_Occurrence_Of (Etype (Comp_Id), Loc), 13340 Name => 13341 Make_Selected_Component (Loc, 13342 Prefix => 13343 New_Occurrence_Of (Obj_Ent, Loc), 13344 Selector_Name => 13345 Make_Identifier (Loc, Chars (Comp_Id)))); 13346 Add (Decl); 13347 end if; 13348 13349 Next (Comp); 13350 end loop; 13351 end; 13352 end if; 13353 end if; 13354 13355 -- Step 5: Add the declaration of the entry index and the associated 13356 -- type for barrier functions and entry families. 13357 13358 if (Barrier and Family) or else Ekind (Spec_Id) = E_Entry_Family then 13359 declare 13360 E : constant Entity_Id := Index_Object (Spec_Id); 13361 Index : constant Entity_Id := 13362 Defining_Identifier 13363 (Entry_Index_Specification 13364 (Entry_Body_Formal_Part (Body_Nod))); 13365 Index_Con : constant Entity_Id := 13366 Make_Defining_Identifier (Loc, Chars (Index)); 13367 High : Node_Id; 13368 Index_Typ : Entity_Id; 13369 Low : Node_Id; 13370 13371 begin 13372 -- Minimal decoration 13373 13374 Set_Ekind (Index_Con, E_Constant); 13375 Set_Entry_Index_Constant (Index, Index_Con); 13376 Set_Discriminal_Link (Index_Con, Index); 13377 13378 -- Retrieve the bounds of the entry family 13379 13380 High := Type_High_Bound (Etype (Index)); 13381 Low := Type_Low_Bound (Etype (Index)); 13382 13383 -- In the simple case the entry family is given by a subtype 13384 -- mark and the index constant has the same type. 13385 13386 if Is_Entity_Name (Original_Node ( 13387 Discrete_Subtype_Definition (Parent (Index)))) 13388 then 13389 Index_Typ := Etype (Index); 13390 13391 -- Otherwise a new subtype declaration is required 13392 13393 else 13394 High := Replace_Bound (High); 13395 Low := Replace_Bound (Low); 13396 13397 Index_Typ := Make_Temporary (Loc, 'J'); 13398 13399 -- Generate: 13400 -- subtype Jnn is <Etype of Index> range Low .. High; 13401 13402 Decl := 13403 Make_Subtype_Declaration (Loc, 13404 Defining_Identifier => Index_Typ, 13405 Subtype_Indication => 13406 Make_Subtype_Indication (Loc, 13407 Subtype_Mark => 13408 New_Occurrence_Of (Base_Type (Etype (Index)), Loc), 13409 Constraint => 13410 Make_Range_Constraint (Loc, 13411 Range_Expression => 13412 Make_Range (Loc, Low, High)))); 13413 Add (Decl); 13414 end if; 13415 13416 Set_Etype (Index_Con, Index_Typ); 13417 13418 -- Create the object which designates the index: 13419 -- J : constant Jnn := 13420 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First)); 13421 -- 13422 -- where Jnn is the subtype created above or the original type of 13423 -- the index, _E is a formal of the protected body subprogram and 13424 -- <index expr> is the index of the first family member. 13425 13426 Decl := 13427 Make_Object_Declaration (Loc, 13428 Defining_Identifier => Index_Con, 13429 Constant_Present => True, 13430 Object_Definition => 13431 New_Occurrence_Of (Index_Typ, Loc), 13432 13433 Expression => 13434 Make_Attribute_Reference (Loc, 13435 Prefix => 13436 New_Occurrence_Of (Index_Typ, Loc), 13437 Attribute_Name => Name_Val, 13438 13439 Expressions => New_List ( 13440 13441 Make_Op_Add (Loc, 13442 Left_Opnd => 13443 Make_Op_Subtract (Loc, 13444 Left_Opnd => New_Occurrence_Of (E, Loc), 13445 Right_Opnd => 13446 Entry_Index_Expression (Loc, 13447 Defining_Identifier (Body_Nod), 13448 Empty, Conc_Typ)), 13449 13450 Right_Opnd => 13451 Make_Attribute_Reference (Loc, 13452 Prefix => 13453 New_Occurrence_Of (Index_Typ, Loc), 13454 Attribute_Name => Name_Pos, 13455 Expressions => New_List ( 13456 Make_Attribute_Reference (Loc, 13457 Prefix => 13458 New_Occurrence_Of (Index_Typ, Loc), 13459 Attribute_Name => Name_First))))))); 13460 Add (Decl); 13461 end; 13462 end if; 13463 end Install_Private_Data_Declarations; 13464 13465 ----------------------- 13466 -- Is_Exception_Safe -- 13467 ----------------------- 13468 13469 function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is 13470 13471 function Has_Side_Effect (N : Node_Id) return Boolean; 13472 -- Return True whenever encountering a subprogram call or raise 13473 -- statement of any kind in the sequence of statements 13474 13475 --------------------- 13476 -- Has_Side_Effect -- 13477 --------------------- 13478 13479 -- What is this doing buried two levels down in exp_ch9. It seems like a 13480 -- generally useful function, and indeed there may be code duplication 13481 -- going on here ??? 13482 13483 function Has_Side_Effect (N : Node_Id) return Boolean is 13484 Stmt : Node_Id; 13485 Expr : Node_Id; 13486 13487 function Is_Call_Or_Raise (N : Node_Id) return Boolean; 13488 -- Indicate whether N is a subprogram call or a raise statement 13489 13490 ---------------------- 13491 -- Is_Call_Or_Raise -- 13492 ---------------------- 13493 13494 function Is_Call_Or_Raise (N : Node_Id) return Boolean is 13495 begin 13496 return Nkind_In (N, N_Procedure_Call_Statement, 13497 N_Function_Call, 13498 N_Raise_Statement, 13499 N_Raise_Constraint_Error, 13500 N_Raise_Program_Error, 13501 N_Raise_Storage_Error); 13502 end Is_Call_Or_Raise; 13503 13504 -- Start of processing for Has_Side_Effect 13505 13506 begin 13507 Stmt := N; 13508 while Present (Stmt) loop 13509 if Is_Call_Or_Raise (Stmt) then 13510 return True; 13511 end if; 13512 13513 -- An object declaration can also contain a function call or a 13514 -- raise statement. 13515 13516 if Nkind (Stmt) = N_Object_Declaration then 13517 Expr := Expression (Stmt); 13518 13519 if Present (Expr) and then Is_Call_Or_Raise (Expr) then 13520 return True; 13521 end if; 13522 end if; 13523 13524 Next (Stmt); 13525 end loop; 13526 13527 return False; 13528 end Has_Side_Effect; 13529 13530 -- Start of processing for Is_Exception_Safe 13531 13532 begin 13533 -- When exceptions can't be propagated, the subprogram returns normally 13534 13535 if No_Exception_Handlers_Set then 13536 return True; 13537 end if; 13538 13539 -- If the checks handled by the back end are not disabled, we cannot 13540 -- ensure that no exception will be raised. 13541 13542 if not Access_Checks_Suppressed (Empty) 13543 or else not Discriminant_Checks_Suppressed (Empty) 13544 or else not Range_Checks_Suppressed (Empty) 13545 or else not Index_Checks_Suppressed (Empty) 13546 or else Opt.Stack_Checking_Enabled 13547 then 13548 return False; 13549 end if; 13550 13551 if Has_Side_Effect (First (Declarations (Subprogram))) 13552 or else 13553 Has_Side_Effect 13554 (First (Statements (Handled_Statement_Sequence (Subprogram)))) 13555 then 13556 return False; 13557 else 13558 return True; 13559 end if; 13560 end Is_Exception_Safe; 13561 13562 --------------------------------- 13563 -- Is_Potentially_Large_Family -- 13564 --------------------------------- 13565 13566 function Is_Potentially_Large_Family 13567 (Base_Index : Entity_Id; 13568 Conctyp : Entity_Id; 13569 Lo : Node_Id; 13570 Hi : Node_Id) return Boolean 13571 is 13572 begin 13573 return Scope (Base_Index) = Standard_Standard 13574 and then Base_Index = Base_Type (Standard_Integer) 13575 and then Has_Discriminants (Conctyp) 13576 and then 13577 Present (Discriminant_Default_Value (First_Discriminant (Conctyp))) 13578 and then 13579 (Denotes_Discriminant (Lo, True) 13580 or else 13581 Denotes_Discriminant (Hi, True)); 13582 end Is_Potentially_Large_Family; 13583 13584 ------------------------------------- 13585 -- Is_Private_Primitive_Subprogram -- 13586 ------------------------------------- 13587 13588 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is 13589 begin 13590 return 13591 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure) 13592 and then Is_Private_Primitive (Id); 13593 end Is_Private_Primitive_Subprogram; 13594 13595 ------------------ 13596 -- Index_Object -- 13597 ------------------ 13598 13599 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is 13600 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id); 13601 Formal : Entity_Id; 13602 13603 begin 13604 Formal := First_Formal (Bod_Subp); 13605 while Present (Formal) loop 13606 13607 -- Look for formal parameter _E 13608 13609 if Chars (Formal) = Name_uE then 13610 return Formal; 13611 end if; 13612 13613 Next_Formal (Formal); 13614 end loop; 13615 13616 -- A protected body subprogram should always have the parameter in 13617 -- question. 13618 13619 raise Program_Error; 13620 end Index_Object; 13621 13622 -------------------------------- 13623 -- Make_Initialize_Protection -- 13624 -------------------------------- 13625 13626 function Make_Initialize_Protection 13627 (Protect_Rec : Entity_Id) return List_Id 13628 is 13629 Loc : constant Source_Ptr := Sloc (Protect_Rec); 13630 P_Arr : Entity_Id; 13631 Pdec : Node_Id; 13632 Ptyp : constant Node_Id := 13633 Corresponding_Concurrent_Type (Protect_Rec); 13634 Args : List_Id; 13635 L : constant List_Id := New_List; 13636 Has_Entry : constant Boolean := Has_Entries (Ptyp); 13637 Prio_Type : Entity_Id; 13638 Prio_Var : Entity_Id := Empty; 13639 Restricted : constant Boolean := Restricted_Profile; 13640 13641 begin 13642 -- We may need two calls to properly initialize the object, one to 13643 -- Initialize_Protection, and possibly one to Install_Handlers if we 13644 -- have a pragma Attach_Handler. 13645 13646 -- Get protected declaration. In the case of a task type declaration, 13647 -- this is simply the parent of the protected type entity. In the single 13648 -- protected object declaration, this parent will be the implicit type, 13649 -- and we can find the corresponding single protected object declaration 13650 -- by searching forward in the declaration list in the tree. 13651 13652 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes 13653 -- of this type should have been removed during semantic analysis. 13654 13655 Pdec := Parent (Ptyp); 13656 while not Nkind_In (Pdec, N_Protected_Type_Declaration, 13657 N_Single_Protected_Declaration) 13658 loop 13659 Next (Pdec); 13660 end loop; 13661 13662 -- Build the parameter list for the call. Note that _Init is the name 13663 -- of the formal for the object to be initialized, which is the task 13664 -- value record itself. 13665 13666 Args := New_List; 13667 13668 -- For lock-free implementation, skip initializations of the Protection 13669 -- object. 13670 13671 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 13672 13673 -- Object parameter. This is a pointer to the object of type 13674 -- Protection used by the GNARL to control the protected object. 13675 13676 Append_To (Args, 13677 Make_Attribute_Reference (Loc, 13678 Prefix => 13679 Make_Selected_Component (Loc, 13680 Prefix => Make_Identifier (Loc, Name_uInit), 13681 Selector_Name => Make_Identifier (Loc, Name_uObject)), 13682 Attribute_Name => Name_Unchecked_Access)); 13683 13684 -- Priority parameter. Set to Unspecified_Priority unless there is a 13685 -- Priority rep item, in which case we take the value from the pragma 13686 -- or attribute definition clause, or there is an Interrupt_Priority 13687 -- rep item and no Priority rep item, and we set the ceiling to 13688 -- Interrupt_Priority'Last, an implementation-defined value, see 13689 -- (RM D.3(10)). 13690 13691 if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then 13692 declare 13693 Prio_Clause : constant Node_Id := 13694 Get_Rep_Item 13695 (Ptyp, Name_Priority, Check_Parents => False); 13696 13697 Prio : Node_Id; 13698 13699 begin 13700 -- Pragma Priority 13701 13702 if Nkind (Prio_Clause) = N_Pragma then 13703 Prio := 13704 Expression 13705 (First (Pragma_Argument_Associations (Prio_Clause))); 13706 13707 -- Get_Rep_Item returns either priority pragma. 13708 13709 if Pragma_Name (Prio_Clause) = Name_Priority then 13710 Prio_Type := RTE (RE_Any_Priority); 13711 else 13712 Prio_Type := RTE (RE_Interrupt_Priority); 13713 end if; 13714 13715 -- Attribute definition clause Priority 13716 13717 else 13718 if Chars (Prio_Clause) = Name_Priority then 13719 Prio_Type := RTE (RE_Any_Priority); 13720 else 13721 Prio_Type := RTE (RE_Interrupt_Priority); 13722 end if; 13723 13724 Prio := Expression (Prio_Clause); 13725 end if; 13726 13727 -- Always create a locale variable to capture the priority. 13728 -- The priority is also passed to Install_Restriced_Handlers. 13729 -- Note that it is really necessary to create this variable 13730 -- explicitly. It might be thought that removing side effects 13731 -- would the appropriate approach, but that could generate 13732 -- declarations improperly placed in the enclosing scope. 13733 13734 Prio_Var := Make_Temporary (Loc, 'R', Prio); 13735 Append_To (L, 13736 Make_Object_Declaration (Loc, 13737 Defining_Identifier => Prio_Var, 13738 Object_Definition => New_Occurrence_Of (Prio_Type, Loc), 13739 Expression => Relocate_Node (Prio))); 13740 13741 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 13742 end; 13743 13744 -- When no priority is specified but an xx_Handler pragma is, we 13745 -- default to System.Interrupts.Default_Interrupt_Priority, see 13746 -- D.3(10). 13747 13748 elsif Has_Attach_Handler (Ptyp) 13749 or else Has_Interrupt_Handler (Ptyp) 13750 then 13751 Append_To (Args, 13752 New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc)); 13753 13754 -- Normal case, no priority or xx_Handler specified, default priority 13755 13756 else 13757 Append_To (Args, 13758 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 13759 end if; 13760 13761 -- Test for Compiler_Info parameter. This parameter allows entry body 13762 -- procedures and barrier functions to be called from the runtime. It 13763 -- is a pointer to the record generated by the compiler to represent 13764 -- the protected object. 13765 13766 -- A protected type without entries that covers an interface and 13767 -- overrides the abstract routines with protected procedures is 13768 -- considered equivalent to a protected type with entries in the 13769 -- context of dispatching select statements. 13770 13771 -- Protected types with interrupt handlers (when not using a 13772 -- restricted profile) are also considered equivalent to protected 13773 -- types with entries. 13774 13775 -- The types which are used (Static_Interrupt_Protection and 13776 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries. 13777 13778 declare 13779 Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); 13780 13781 Called_Subp : RE_Id; 13782 13783 begin 13784 case Pkg_Id is 13785 when System_Tasking_Protected_Objects_Entries => 13786 Called_Subp := RE_Initialize_Protection_Entries; 13787 13788 -- Argument Compiler_Info 13789 13790 Append_To (Args, 13791 Make_Attribute_Reference (Loc, 13792 Prefix => Make_Identifier (Loc, Name_uInit), 13793 Attribute_Name => Name_Address)); 13794 13795 when System_Tasking_Protected_Objects_Single_Entry => 13796 Called_Subp := RE_Initialize_Protection_Entry; 13797 13798 -- Argument Compiler_Info 13799 13800 Append_To (Args, 13801 Make_Attribute_Reference (Loc, 13802 Prefix => Make_Identifier (Loc, Name_uInit), 13803 Attribute_Name => Name_Address)); 13804 13805 when System_Tasking_Protected_Objects => 13806 Called_Subp := RE_Initialize_Protection; 13807 13808 when others => 13809 raise Program_Error; 13810 end case; 13811 13812 -- Entry_Bodies parameter. This is a pointer to an array of 13813 -- pointers to the entry body procedures and barrier functions of 13814 -- the object. If the protected type has no entries this object 13815 -- will not exist, in this case, pass a null (it can happen when 13816 -- there are protected interrupt handlers or interfaces). 13817 13818 if Has_Entry then 13819 P_Arr := Entry_Bodies_Array (Ptyp); 13820 13821 -- Argument Entry_Body (for single entry) or Entry_Bodies (for 13822 -- multiple entries). 13823 13824 Append_To (Args, 13825 Make_Attribute_Reference (Loc, 13826 Prefix => New_Occurrence_Of (P_Arr, Loc), 13827 Attribute_Name => Name_Unrestricted_Access)); 13828 13829 if Pkg_Id = System_Tasking_Protected_Objects_Entries then 13830 13831 -- Find index mapping function (clumsy but ok for now) 13832 13833 while Ekind (P_Arr) /= E_Function loop 13834 Next_Entity (P_Arr); 13835 end loop; 13836 13837 Append_To (Args, 13838 Make_Attribute_Reference (Loc, 13839 Prefix => New_Occurrence_Of (P_Arr, Loc), 13840 Attribute_Name => Name_Unrestricted_Access)); 13841 end if; 13842 13843 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then 13844 13845 -- This is the case where we have a protected object with 13846 -- interfaces and no entries, and the single entry restriction 13847 -- is in effect. We pass a null pointer for the entry 13848 -- parameter because there is no actual entry. 13849 13850 Append_To (Args, Make_Null (Loc)); 13851 13852 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then 13853 13854 -- This is the case where we have a protected object with no 13855 -- entries and: 13856 -- - either interrupt handlers with non restricted profile, 13857 -- - or interfaces 13858 -- Note that the types which are used for interrupt handlers 13859 -- (Static/Dynamic_Interrupt_Protection) are derived from 13860 -- Protection_Entries. We pass two null pointers because there 13861 -- is no actual entry, and the initialization procedure needs 13862 -- both Entry_Bodies and Find_Body_Index. 13863 13864 Append_To (Args, Make_Null (Loc)); 13865 Append_To (Args, Make_Null (Loc)); 13866 end if; 13867 13868 Append_To (L, 13869 Make_Procedure_Call_Statement (Loc, 13870 Name => 13871 New_Occurrence_Of (RTE (Called_Subp), Loc), 13872 Parameter_Associations => Args)); 13873 end; 13874 end if; 13875 13876 if Has_Attach_Handler (Ptyp) then 13877 13878 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to 13879 -- make the following call: 13880 13881 -- Install_Handlers (_object, 13882 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); 13883 13884 -- or, in the case of Ravenscar: 13885 13886 -- Install_Restricted_Handlers 13887 -- (Prio, (Expr1, Proc1'access), ...., (ExprN, ProcN'access)); 13888 13889 declare 13890 Args : constant List_Id := New_List; 13891 Table : constant List_Id := New_List; 13892 Ritem : Node_Id := First_Rep_Item (Ptyp); 13893 13894 begin 13895 -- Build the Priority parameter (only for ravenscar) 13896 13897 if Restricted then 13898 13899 -- Priority comes from a pragma 13900 13901 if Present (Prio_Var) then 13902 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 13903 13904 -- Priority is the default one 13905 13906 else 13907 Append_To (Args, 13908 New_Occurrence_Of 13909 (RTE (RE_Default_Interrupt_Priority), Loc)); 13910 end if; 13911 end if; 13912 13913 -- Build the Attach_Handler table argument 13914 13915 while Present (Ritem) loop 13916 if Nkind (Ritem) = N_Pragma 13917 and then Pragma_Name (Ritem) = Name_Attach_Handler 13918 then 13919 declare 13920 Handler : constant Node_Id := 13921 First (Pragma_Argument_Associations (Ritem)); 13922 13923 Interrupt : constant Node_Id := Next (Handler); 13924 Expr : constant Node_Id := Expression (Interrupt); 13925 13926 begin 13927 Append_To (Table, 13928 Make_Aggregate (Loc, Expressions => New_List ( 13929 Unchecked_Convert_To 13930 (RTE (RE_System_Interrupt_Id), Expr), 13931 Make_Attribute_Reference (Loc, 13932 Prefix => 13933 Make_Selected_Component (Loc, 13934 Prefix => 13935 Make_Identifier (Loc, Name_uInit), 13936 Selector_Name => 13937 Duplicate_Subexpr_No_Checks 13938 (Expression (Handler))), 13939 Attribute_Name => Name_Access)))); 13940 end; 13941 end if; 13942 13943 Next_Rep_Item (Ritem); 13944 end loop; 13945 13946 -- Append the table argument we just built 13947 13948 Append_To (Args, Make_Aggregate (Loc, Table)); 13949 13950 -- Append the Install_Handlers (or Install_Restricted_Handlers) 13951 -- call to the statements. 13952 13953 if Restricted then 13954 -- Call a simplified version of Install_Handlers to be used 13955 -- when the Ravenscar restrictions are in effect 13956 -- (Install_Restricted_Handlers). 13957 13958 Append_To (L, 13959 Make_Procedure_Call_Statement (Loc, 13960 Name => 13961 New_Occurrence_Of 13962 (RTE (RE_Install_Restricted_Handlers), Loc), 13963 Parameter_Associations => Args)); 13964 13965 else 13966 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 13967 13968 -- First, prepends the _object argument 13969 13970 Prepend_To (Args, 13971 Make_Attribute_Reference (Loc, 13972 Prefix => 13973 Make_Selected_Component (Loc, 13974 Prefix => Make_Identifier (Loc, Name_uInit), 13975 Selector_Name => 13976 Make_Identifier (Loc, Name_uObject)), 13977 Attribute_Name => Name_Unchecked_Access)); 13978 end if; 13979 13980 -- Then, insert call to Install_Handlers 13981 13982 Append_To (L, 13983 Make_Procedure_Call_Statement (Loc, 13984 Name => 13985 New_Occurrence_Of (RTE (RE_Install_Handlers), Loc), 13986 Parameter_Associations => Args)); 13987 end if; 13988 end; 13989 end if; 13990 13991 return L; 13992 end Make_Initialize_Protection; 13993 13994 --------------------------- 13995 -- Make_Task_Create_Call -- 13996 --------------------------- 13997 13998 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is 13999 Loc : constant Source_Ptr := Sloc (Task_Rec); 14000 Args : List_Id; 14001 Ecount : Node_Id; 14002 Name : Node_Id; 14003 Tdec : Node_Id; 14004 Tdef : Node_Id; 14005 Tnam : Name_Id; 14006 Ttyp : Node_Id; 14007 14008 begin 14009 Ttyp := Corresponding_Concurrent_Type (Task_Rec); 14010 Tnam := Chars (Ttyp); 14011 14012 -- Get task declaration. In the case of a task type declaration, this is 14013 -- simply the parent of the task type entity. In the single task 14014 -- declaration, this parent will be the implicit type, and we can find 14015 -- the corresponding single task declaration by searching forward in the 14016 -- declaration list in the tree. 14017 14018 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of 14019 -- this type should have been removed during semantic analysis. 14020 14021 Tdec := Parent (Ttyp); 14022 while not Nkind_In (Tdec, N_Task_Type_Declaration, 14023 N_Single_Task_Declaration) 14024 loop 14025 Next (Tdec); 14026 end loop; 14027 14028 -- Now we can find the task definition from this declaration 14029 14030 Tdef := Task_Definition (Tdec); 14031 14032 -- Build the parameter list for the call. Note that _Init is the name 14033 -- of the formal for the object to be initialized, which is the task 14034 -- value record itself. 14035 14036 Args := New_List; 14037 14038 -- Priority parameter. Set to Unspecified_Priority unless there is a 14039 -- Priority rep item, in which case we take the value from the rep item. 14040 14041 if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then 14042 Append_To (Args, 14043 Make_Selected_Component (Loc, 14044 Prefix => Make_Identifier (Loc, Name_uInit), 14045 Selector_Name => Make_Identifier (Loc, Name_uPriority))); 14046 else 14047 Append_To (Args, 14048 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 14049 end if; 14050 14051 -- Optional Stack parameter 14052 14053 if Restricted_Profile then 14054 14055 -- If the stack has been preallocated by the expander then 14056 -- pass its address. Otherwise, pass a null address. 14057 14058 if Preallocated_Stacks_On_Target then 14059 Append_To (Args, 14060 Make_Attribute_Reference (Loc, 14061 Prefix => 14062 Make_Selected_Component (Loc, 14063 Prefix => Make_Identifier (Loc, Name_uInit), 14064 Selector_Name => Make_Identifier (Loc, Name_uStack)), 14065 Attribute_Name => Name_Address)); 14066 14067 else 14068 Append_To (Args, 14069 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 14070 end if; 14071 end if; 14072 14073 -- Size parameter. If no Storage_Size pragma is present, then 14074 -- the size is taken from the taskZ variable for the type, which 14075 -- is either Unspecified_Size, or has been reset by the use of 14076 -- a Storage_Size attribute definition clause. If a pragma is 14077 -- present, then the size is taken from the _Size field of the 14078 -- task value record, which was set from the pragma value. 14079 14080 if Present (Tdef) and then Has_Storage_Size_Pragma (Tdef) then 14081 Append_To (Args, 14082 Make_Selected_Component (Loc, 14083 Prefix => Make_Identifier (Loc, Name_uInit), 14084 Selector_Name => Make_Identifier (Loc, Name_uSize))); 14085 14086 else 14087 Append_To (Args, 14088 New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc)); 14089 end if; 14090 14091 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a 14092 -- Task_Info pragma, in which case we take the value from the pragma. 14093 14094 if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then 14095 Append_To (Args, 14096 Make_Selected_Component (Loc, 14097 Prefix => Make_Identifier (Loc, Name_uInit), 14098 Selector_Name => Make_Identifier (Loc, Name_uTask_Info))); 14099 14100 else 14101 Append_To (Args, 14102 New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc)); 14103 end if; 14104 14105 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item, 14106 -- in which case we take the value from the rep item. The parameter is 14107 -- passed as an Integer because in the case of unspecified CPU the 14108 -- value is not in the range of CPU_Range. 14109 14110 if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then 14111 Append_To (Args, 14112 Convert_To (Standard_Integer, 14113 Make_Selected_Component (Loc, 14114 Prefix => Make_Identifier (Loc, Name_uInit), 14115 Selector_Name => Make_Identifier (Loc, Name_uCPU)))); 14116 else 14117 Append_To (Args, 14118 New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc)); 14119 end if; 14120 14121 if not Restricted_Profile then 14122 14123 -- Deadline parameter. If no Relative_Deadline pragma is present, 14124 -- then the deadline is Time_Span_Zero. If a pragma is present, then 14125 -- the deadline is taken from the _Relative_Deadline field of the 14126 -- task value record, which was set from the pragma value. Note that 14127 -- this parameter must not be generated for the restricted profiles 14128 -- since Ravenscar does not allow deadlines. 14129 14130 -- Case where pragma Relative_Deadline applies: use given value 14131 14132 if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then 14133 Append_To (Args, 14134 Make_Selected_Component (Loc, 14135 Prefix => Make_Identifier (Loc, Name_uInit), 14136 Selector_Name => 14137 Make_Identifier (Loc, Name_uRelative_Deadline))); 14138 14139 -- No pragma Relative_Deadline apply to the task 14140 14141 else 14142 Append_To (Args, 14143 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); 14144 end if; 14145 14146 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is 14147 -- present, then the dispatching domain is null. If a rep item is 14148 -- present, then the dispatching domain is taken from the 14149 -- _Dispatching_Domain field of the task value record, which was set 14150 -- from the rep item value. 14151 14152 -- Case where Dispatching_Domain rep item applies: use given value 14153 14154 if Has_Rep_Item 14155 (Ttyp, Name_Dispatching_Domain, Check_Parents => False) 14156 then 14157 Append_To (Args, 14158 Make_Selected_Component (Loc, 14159 Prefix => 14160 Make_Identifier (Loc, Name_uInit), 14161 Selector_Name => 14162 Make_Identifier (Loc, Name_uDispatching_Domain))); 14163 14164 -- No pragma or aspect Dispatching_Domain applies to the task 14165 14166 else 14167 Append_To (Args, Make_Null (Loc)); 14168 end if; 14169 14170 -- Number of entries. This is an expression of the form: 14171 14172 -- n + _Init.a'Length + _Init.a'B'Length + ... 14173 14174 -- where a,b... are the entry family names for the task definition 14175 14176 Ecount := 14177 Build_Entry_Count_Expression 14178 (Ttyp, 14179 Component_Items 14180 (Component_List 14181 (Type_Definition 14182 (Parent (Corresponding_Record_Type (Ttyp))))), 14183 Loc); 14184 Append_To (Args, Ecount); 14185 14186 -- Master parameter. This is a reference to the _Master parameter of 14187 -- the initialization procedure, except in the case of the pragma 14188 -- Restrictions (No_Task_Hierarchy) where the value is fixed to 14189 -- System.Tasking.Library_Task_Level. 14190 14191 if Restriction_Active (No_Task_Hierarchy) = False then 14192 Append_To (Args, Make_Identifier (Loc, Name_uMaster)); 14193 else 14194 Append_To (Args, 14195 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 14196 end if; 14197 end if; 14198 14199 -- State parameter. This is a pointer to the task body procedure. The 14200 -- required value is obtained by taking 'Unrestricted_Access of the task 14201 -- body procedure and converting it (with an unchecked conversion) to 14202 -- the type required by the task kernel. For further details, see the 14203 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather 14204 -- than 'Address in order to avoid creating trampolines. 14205 14206 declare 14207 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp); 14208 Subp_Ptr_Typ : constant Node_Id := 14209 Create_Itype (E_Access_Subprogram_Type, Tdec); 14210 Ref : constant Node_Id := Make_Itype_Reference (Loc); 14211 14212 begin 14213 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc); 14214 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); 14215 14216 -- Be sure to freeze a reference to the access-to-subprogram type, 14217 -- otherwise gigi will complain that it's in the wrong scope, because 14218 -- it's actually inside the init procedure for the record type that 14219 -- corresponds to the task type. 14220 14221 -- This processing is causing a crash in the .NET/JVM back ends that 14222 -- is not yet understood, so skip it in these cases ??? 14223 14224 if VM_Target = No_VM then 14225 Set_Itype (Ref, Subp_Ptr_Typ); 14226 Append_Freeze_Action (Task_Rec, Ref); 14227 14228 Append_To (Args, 14229 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), 14230 Make_Qualified_Expression (Loc, 14231 Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc), 14232 Expression => 14233 Make_Attribute_Reference (Loc, 14234 Prefix => New_Occurrence_Of (Body_Proc, Loc), 14235 Attribute_Name => Name_Unrestricted_Access)))); 14236 14237 -- For the .NET/JVM cases revert to the original code below ??? 14238 14239 else 14240 Append_To (Args, 14241 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), 14242 Make_Attribute_Reference (Loc, 14243 Prefix => New_Occurrence_Of (Body_Proc, Loc), 14244 Attribute_Name => Name_Address))); 14245 end if; 14246 end; 14247 14248 -- Discriminants parameter. This is just the address of the task 14249 -- value record itself (which contains the discriminant values 14250 14251 Append_To (Args, 14252 Make_Attribute_Reference (Loc, 14253 Prefix => Make_Identifier (Loc, Name_uInit), 14254 Attribute_Name => Name_Address)); 14255 14256 -- Elaborated parameter. This is an access to the elaboration Boolean 14257 14258 Append_To (Args, 14259 Make_Attribute_Reference (Loc, 14260 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')), 14261 Attribute_Name => Name_Unchecked_Access)); 14262 14263 -- Add Chain parameter (not done for sequential elaboration policy, see 14264 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 14265 14266 if Partition_Elaboration_Policy /= 'S' then 14267 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 14268 end if; 14269 14270 -- Task name parameter. Take this from the _Task_Id parameter to the 14271 -- init call unless there is a Task_Name pragma, in which case we take 14272 -- the value from the pragma. 14273 14274 if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then 14275 -- Copy expression in full, because it may be dynamic and have 14276 -- side effects. 14277 14278 Append_To (Args, 14279 New_Copy_Tree 14280 (Expression 14281 (First 14282 (Pragma_Argument_Associations 14283 (Get_Rep_Pragma 14284 (Ttyp, Name_Task_Name, Check_Parents => False)))))); 14285 14286 else 14287 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); 14288 end if; 14289 14290 -- Created_Task parameter. This is the _Task_Id field of the task 14291 -- record value 14292 14293 Append_To (Args, 14294 Make_Selected_Component (Loc, 14295 Prefix => Make_Identifier (Loc, Name_uInit), 14296 Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); 14297 14298 declare 14299 Create_RE : RE_Id; 14300 14301 begin 14302 if Restricted_Profile then 14303 if Partition_Elaboration_Policy = 'S' then 14304 Create_RE := RE_Create_Restricted_Task_Sequential; 14305 else 14306 Create_RE := RE_Create_Restricted_Task; 14307 end if; 14308 else 14309 Create_RE := RE_Create_Task; 14310 end if; 14311 14312 Name := New_Occurrence_Of (RTE (Create_RE), Loc); 14313 end; 14314 14315 return 14316 Make_Procedure_Call_Statement (Loc, 14317 Name => Name, 14318 Parameter_Associations => Args); 14319 end Make_Task_Create_Call; 14320 14321 ------------------------------ 14322 -- Next_Protected_Operation -- 14323 ------------------------------ 14324 14325 function Next_Protected_Operation (N : Node_Id) return Node_Id is 14326 Next_Op : Node_Id; 14327 14328 begin 14329 Next_Op := Next (N); 14330 while Present (Next_Op) 14331 and then not Nkind_In (Next_Op, N_Subprogram_Body, N_Entry_Body) 14332 loop 14333 Next (Next_Op); 14334 end loop; 14335 14336 return Next_Op; 14337 end Next_Protected_Operation; 14338 14339 --------------------- 14340 -- Null_Statements -- 14341 --------------------- 14342 14343 function Null_Statements (Stats : List_Id) return Boolean is 14344 Stmt : Node_Id; 14345 14346 begin 14347 Stmt := First (Stats); 14348 while Nkind (Stmt) /= N_Empty 14349 and then (Nkind_In (Stmt, N_Null_Statement, N_Label) 14350 or else 14351 (Nkind (Stmt) = N_Pragma 14352 and then 14353 Nam_In (Pragma_Name (Stmt), Name_Unreferenced, 14354 Name_Unmodified, 14355 Name_Warnings))) 14356 loop 14357 Next (Stmt); 14358 end loop; 14359 14360 return Nkind (Stmt) = N_Empty; 14361 end Null_Statements; 14362 14363 -------------------------- 14364 -- Parameter_Block_Pack -- 14365 -------------------------- 14366 14367 function Parameter_Block_Pack 14368 (Loc : Source_Ptr; 14369 Blk_Typ : Entity_Id; 14370 Actuals : List_Id; 14371 Formals : List_Id; 14372 Decls : List_Id; 14373 Stmts : List_Id) return Node_Id 14374 is 14375 Actual : Entity_Id; 14376 Expr : Node_Id := Empty; 14377 Formal : Entity_Id; 14378 Has_Param : Boolean := False; 14379 P : Entity_Id; 14380 Params : List_Id; 14381 Temp_Asn : Node_Id; 14382 Temp_Nam : Node_Id; 14383 14384 begin 14385 Actual := First (Actuals); 14386 Formal := Defining_Identifier (First (Formals)); 14387 Params := New_List; 14388 while Present (Actual) loop 14389 if Is_By_Copy_Type (Etype (Actual)) then 14390 -- Generate: 14391 -- Jnn : aliased <formal-type> 14392 14393 Temp_Nam := Make_Temporary (Loc, 'J'); 14394 14395 Append_To (Decls, 14396 Make_Object_Declaration (Loc, 14397 Aliased_Present => True, 14398 Defining_Identifier => Temp_Nam, 14399 Object_Definition => 14400 New_Occurrence_Of (Etype (Formal), Loc))); 14401 14402 if Ekind (Formal) /= E_Out_Parameter then 14403 14404 -- Generate: 14405 -- Jnn := <actual> 14406 14407 Temp_Asn := 14408 New_Occurrence_Of (Temp_Nam, Loc); 14409 14410 Set_Assignment_OK (Temp_Asn); 14411 14412 Append_To (Stmts, 14413 Make_Assignment_Statement (Loc, 14414 Name => Temp_Asn, 14415 Expression => New_Copy_Tree (Actual))); 14416 end if; 14417 14418 -- Generate: 14419 -- Jnn'unchecked_access 14420 14421 Append_To (Params, 14422 Make_Attribute_Reference (Loc, 14423 Attribute_Name => Name_Unchecked_Access, 14424 Prefix => New_Occurrence_Of (Temp_Nam, Loc))); 14425 14426 Has_Param := True; 14427 14428 -- The controlling parameter is omitted 14429 14430 else 14431 if not Is_Controlling_Actual (Actual) then 14432 Append_To (Params, 14433 Make_Reference (Loc, New_Copy_Tree (Actual))); 14434 14435 Has_Param := True; 14436 end if; 14437 end if; 14438 14439 Next_Actual (Actual); 14440 Next_Formal_With_Extras (Formal); 14441 end loop; 14442 14443 if Has_Param then 14444 Expr := Make_Aggregate (Loc, Params); 14445 end if; 14446 14447 -- Generate: 14448 -- P : Ann := ( 14449 -- J1'unchecked_access; 14450 -- <actual2>'reference; 14451 -- ...); 14452 14453 P := Make_Temporary (Loc, 'P'); 14454 14455 Append_To (Decls, 14456 Make_Object_Declaration (Loc, 14457 Defining_Identifier => P, 14458 Object_Definition => New_Occurrence_Of (Blk_Typ, Loc), 14459 Expression => Expr)); 14460 14461 return P; 14462 end Parameter_Block_Pack; 14463 14464 ---------------------------- 14465 -- Parameter_Block_Unpack -- 14466 ---------------------------- 14467 14468 function Parameter_Block_Unpack 14469 (Loc : Source_Ptr; 14470 P : Entity_Id; 14471 Actuals : List_Id; 14472 Formals : List_Id) return List_Id 14473 is 14474 Actual : Entity_Id; 14475 Asnmt : Node_Id; 14476 Formal : Entity_Id; 14477 Has_Asnmt : Boolean := False; 14478 Result : constant List_Id := New_List; 14479 14480 begin 14481 Actual := First (Actuals); 14482 Formal := Defining_Identifier (First (Formals)); 14483 while Present (Actual) loop 14484 if Is_By_Copy_Type (Etype (Actual)) 14485 and then Ekind (Formal) /= E_In_Parameter 14486 then 14487 -- Generate: 14488 -- <actual> := P.<formal>; 14489 14490 Asnmt := 14491 Make_Assignment_Statement (Loc, 14492 Name => 14493 New_Copy (Actual), 14494 Expression => 14495 Make_Explicit_Dereference (Loc, 14496 Make_Selected_Component (Loc, 14497 Prefix => 14498 New_Occurrence_Of (P, Loc), 14499 Selector_Name => 14500 Make_Identifier (Loc, Chars (Formal))))); 14501 14502 Set_Assignment_OK (Name (Asnmt)); 14503 Append_To (Result, Asnmt); 14504 14505 Has_Asnmt := True; 14506 end if; 14507 14508 Next_Actual (Actual); 14509 Next_Formal_With_Extras (Formal); 14510 end loop; 14511 14512 if Has_Asnmt then 14513 return Result; 14514 else 14515 return New_List (Make_Null_Statement (Loc)); 14516 end if; 14517 end Parameter_Block_Unpack; 14518 14519 ---------------------- 14520 -- Set_Discriminals -- 14521 ---------------------- 14522 14523 procedure Set_Discriminals (Dec : Node_Id) is 14524 D : Entity_Id; 14525 Pdef : Entity_Id; 14526 D_Minal : Entity_Id; 14527 14528 begin 14529 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); 14530 Pdef := Defining_Identifier (Dec); 14531 14532 if Has_Discriminants (Pdef) then 14533 D := First_Discriminant (Pdef); 14534 while Present (D) loop 14535 D_Minal := 14536 Make_Defining_Identifier (Sloc (D), 14537 Chars => New_External_Name (Chars (D), 'D')); 14538 14539 Set_Ekind (D_Minal, E_Constant); 14540 Set_Etype (D_Minal, Etype (D)); 14541 Set_Scope (D_Minal, Pdef); 14542 Set_Discriminal (D, D_Minal); 14543 Set_Discriminal_Link (D_Minal, D); 14544 14545 Next_Discriminant (D); 14546 end loop; 14547 end if; 14548 end Set_Discriminals; 14549 14550 ----------------------- 14551 -- Trivial_Accept_OK -- 14552 ----------------------- 14553 14554 function Trivial_Accept_OK return Boolean is 14555 begin 14556 case Opt.Task_Dispatching_Policy is 14557 14558 -- If we have the default task dispatching policy in effect, we can 14559 -- definitely do the optimization (one way of looking at this is to 14560 -- think of the formal definition of the default policy being allowed 14561 -- to run any task it likes after a rendezvous, so even if notionally 14562 -- a full rescheduling occurs, we can say that our dispatching policy 14563 -- (i.e. the default dispatching policy) reorders the queue to be the 14564 -- same as just before the call. 14565 14566 when ' ' => 14567 return True; 14568 14569 -- FIFO_Within_Priorities certainly does not permit this 14570 -- optimization since the Rendezvous is a scheduling action that may 14571 -- require some other task to be run. 14572 14573 when 'F' => 14574 return False; 14575 14576 -- For now, disallow the optimization for all other policies. This 14577 -- may be over-conservative, but it is certainly not incorrect. 14578 14579 when others => 14580 return False; 14581 14582 end case; 14583 end Trivial_Accept_OK; 14584 14585end Exp_Ch9; 14586