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 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id); 132 -- Build the body of a wrapper procedure for an entry or entry family that 133 -- has contract cases, preconditions, or postconditions. The body gathers 134 -- the executable contract items and expands them in the usual way, and 135 -- performs the entry call itself. This way preconditions are evaluated 136 -- before the call is queued. E is the entry in question, and Decl is the 137 -- enclosing synchronized type declaration at whose freeze point the 138 -- generated body is analyzed. 139 140 function Build_Corresponding_Record 141 (N : Node_Id; 142 Ctyp : Node_Id; 143 Loc : Source_Ptr) return Node_Id; 144 -- Common to tasks and protected types. Copy discriminant specifications, 145 -- build record declaration. N is the type declaration, Ctyp is the 146 -- concurrent entity (task type or protected type). 147 148 function Build_Dispatching_Tag_Check 149 (K : Entity_Id; 150 N : Node_Id) return Node_Id; 151 -- Utility to create the tree to check whether the dispatching call in 152 -- a timed entry call, a conditional entry call, or an asynchronous 153 -- transfer of control is a call to a primitive of a non-synchronized type. 154 -- K is the temporary that holds the tagged kind of the target object, and 155 -- N is the enclosing construct. 156 157 function Build_Entry_Count_Expression 158 (Concurrent_Type : Node_Id; 159 Component_List : List_Id; 160 Loc : Source_Ptr) return Node_Id; 161 -- Compute number of entries for concurrent object. This is a count of 162 -- simple entries, followed by an expression that computes the length 163 -- of the range of each entry family. A single array with that size is 164 -- allocated for each concurrent object of the type. 165 166 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; 167 -- Build the function that translates the entry index in the call 168 -- (which depends on the size of entry families) into an index into the 169 -- Entry_Bodies_Array, to determine the body and barrier function used 170 -- in a protected entry call. A pointer to this function appears in every 171 -- protected object. 172 173 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id; 174 -- Build subprogram declaration for previous one 175 176 function Build_Lock_Free_Protected_Subprogram_Body 177 (N : Node_Id; 178 Prot_Typ : Node_Id; 179 Unprot_Spec : Node_Id) return Node_Id; 180 -- N denotes a subprogram body of protected type Prot_Typ. Unprot_Spec is 181 -- the subprogram specification of the unprotected version of N. Transform 182 -- N such that it invokes the unprotected version of the body. 183 184 function Build_Lock_Free_Unprotected_Subprogram_Body 185 (N : Node_Id; 186 Prot_Typ : Node_Id) return Node_Id; 187 -- N denotes a subprogram body of protected type Prot_Typ. Build a version 188 -- of N where the original statements of N are synchronized through atomic 189 -- actions such as compare and exchange. Prior to invoking this routine, it 190 -- has been established that N can be implemented in a lock-free fashion. 191 192 function Build_Parameter_Block 193 (Loc : Source_Ptr; 194 Actuals : List_Id; 195 Formals : List_Id; 196 Decls : List_Id) return Entity_Id; 197 -- Generate an access type for each actual parameter in the list Actuals. 198 -- Create an encapsulating record that contains all the actuals and return 199 -- its type. Generate: 200 -- type Ann1 is access all <actual1-type> 201 -- ... 202 -- type AnnN is access all <actualN-type> 203 -- type Pnn is record 204 -- <formal1> : Ann1; 205 -- ... 206 -- <formalN> : AnnN; 207 -- end record; 208 209 function Build_Protected_Entry 210 (N : Node_Id; 211 Ent : Entity_Id; 212 Pid : Node_Id) return Node_Id; 213 -- Build the procedure implementing the statement sequence of the specified 214 -- entry body. 215 216 function Build_Protected_Entry_Specification 217 (Loc : Source_Ptr; 218 Def_Id : Entity_Id; 219 Ent_Id : Entity_Id) return Node_Id; 220 -- Build a specification for the procedure implementing the statements of 221 -- the specified entry body. Add attributes associating it with the entry 222 -- defining identifier Ent_Id. 223 224 function Build_Protected_Spec 225 (N : Node_Id; 226 Obj_Type : Entity_Id; 227 Ident : Entity_Id; 228 Unprotected : Boolean := False) return List_Id; 229 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_ 230 -- Subprogram_Type. Builds signature of protected subprogram, adding the 231 -- formal that corresponds to the object itself. For an access to protected 232 -- subprogram, there is no object type to specify, so the parameter has 233 -- type Address and mode In. An indirect call through such a pointer will 234 -- convert the address to a reference to the actual object. The object is 235 -- a limited record and therefore a by_reference type. 236 237 function Build_Protected_Subprogram_Body 238 (N : Node_Id; 239 Pid : Node_Id; 240 N_Op_Spec : Node_Id) return Node_Id; 241 -- This function is used to construct the protected version of a protected 242 -- subprogram. Its statement sequence first defers abort, then locks the 243 -- associated protected object, and then enters a block that contains a 244 -- call to the unprotected version of the subprogram (for details, see 245 -- Build_Unprotected_Subprogram_Body). This block statement requires a 246 -- cleanup handler that unlocks the object in all cases. For details, 247 -- see Exp_Ch7.Expand_Cleanup_Actions. 248 249 function Build_Renamed_Formal_Declaration 250 (New_F : Entity_Id; 251 Formal : Entity_Id; 252 Comp : Entity_Id; 253 Renamed_Formal : Node_Id) return Node_Id; 254 -- Create a renaming declaration for a formal, within a protected entry 255 -- body or an accept body. The renamed object is a component of the 256 -- parameter block that is a parameter in the entry call. 257 -- 258 -- In Ada 2012, if the formal is an incomplete tagged type, the renaming 259 -- does not dereference the corresponding component to prevent an illegal 260 -- use of the incomplete type (AI05-0151). 261 262 function Build_Selected_Name 263 (Prefix : Entity_Id; 264 Selector : Entity_Id; 265 Append_Char : Character := ' ') return Name_Id; 266 -- Build a name in the form of Prefix__Selector, with an optional character 267 -- appended. This is used for internal subprograms generated for operations 268 -- of protected types, including barrier functions. For the subprograms 269 -- generated for entry bodies and entry barriers, the generated name 270 -- includes a sequence number that makes names unique in the presence of 271 -- entry overloading. This is necessary because entry body procedures and 272 -- barrier functions all have the same signature. 273 274 procedure Build_Simple_Entry_Call 275 (N : Node_Id; 276 Concval : Node_Id; 277 Ename : Node_Id; 278 Index : Node_Id); 279 -- Some comments here would be useful ??? 280 281 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id; 282 -- This routine constructs a specification for the procedure that we will 283 -- build for the task body for task type T. The spec has the form: 284 -- 285 -- procedure tnameB (_Task : access tnameV); 286 -- 287 -- where name is the character name taken from the task type entity that 288 -- is passed as the argument to the procedure, and tnameV is the task 289 -- value type that is associated with the task type. 290 291 function Build_Unprotected_Subprogram_Body 292 (N : Node_Id; 293 Pid : Node_Id) return Node_Id; 294 -- This routine constructs the unprotected version of a protected 295 -- subprogram body, which is contains all of the code in the original, 296 -- unexpanded body. This is the version of the protected subprogram that is 297 -- called from all protected operations on the same object, including the 298 -- protected version of the same subprogram. 299 300 procedure Build_Wrapper_Bodies 301 (Loc : Source_Ptr; 302 Typ : Entity_Id; 303 N : Node_Id); 304 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding 305 -- record of a concurrent type. N is the insertion node where all bodies 306 -- will be placed. This routine builds the bodies of the subprograms which 307 -- serve as an indirection mechanism to overriding primitives of concurrent 308 -- types, entries and protected procedures. Any new body is analyzed. 309 310 procedure Build_Wrapper_Specs 311 (Loc : Source_Ptr; 312 Typ : Entity_Id; 313 N : in out Node_Id); 314 -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding 315 -- record of a concurrent type. N is the insertion node where all specs 316 -- will be placed. This routine builds the specs of the subprograms which 317 -- serve as an indirection mechanism to overriding primitives of concurrent 318 -- types, entries and protected procedures. Any new spec is analyzed. 319 320 procedure Collect_Entry_Families 321 (Loc : Source_Ptr; 322 Cdecls : List_Id; 323 Current_Node : in out Node_Id; 324 Conctyp : Entity_Id); 325 -- For each entry family in a concurrent type, create an anonymous array 326 -- type of the right size, and add a component to the corresponding_record. 327 328 function Concurrent_Object 329 (Spec_Id : Entity_Id; 330 Conc_Typ : Entity_Id) return Entity_Id; 331 -- Given a subprogram entity Spec_Id and concurrent type Conc_Typ, return 332 -- the entity associated with the concurrent object in the Protected_Body_ 333 -- Subprogram or the Task_Body_Procedure of Spec_Id. The returned entity 334 -- denotes formal parameter _O, _object or _task. 335 336 function Copy_Result_Type (Res : Node_Id) return Node_Id; 337 -- Copy the result type of a function specification, when building the 338 -- internal operation corresponding to a protected function, or when 339 -- expanding an access to protected function. If the result is an anonymous 340 -- access to subprogram itself, we need to create a new signature with the 341 -- same parameter names and the same resolved types, but with new entities 342 -- for the formals. 343 344 procedure Debug_Private_Data_Declarations (Decls : List_Id); 345 -- Decls is a list which may contain the declarations created by Install_ 346 -- Private_Data_Declarations. All generated entities are marked as needing 347 -- debug info and debug nodes are manually generation where necessary. This 348 -- step of the expansion must to be done after private data has been moved 349 -- to its final resting scope to ensure proper visibility of debug objects. 350 351 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id); 352 -- If control flow optimizations are suppressed, and Alt is an accept, 353 -- delay, or entry call alternative with no trailing statements, insert 354 -- a null trailing statement with the given Loc (which is the sloc of 355 -- the accept, delay, or entry call statement). There might not be any 356 -- generated code for the accept, delay, or entry call itself (the effect 357 -- of these statements is part of the general processsing done for the 358 -- enclosing selective accept, timed entry call, or asynchronous select), 359 -- and the null statement is there to carry the sloc of that statement to 360 -- the back-end for trace-based coverage analysis purposes. 361 362 procedure Extract_Dispatching_Call 363 (N : Node_Id; 364 Call_Ent : out Entity_Id; 365 Object : out Entity_Id; 366 Actuals : out List_Id; 367 Formals : out List_Id); 368 -- Given a dispatching call, extract the entity of the name of the call, 369 -- its actual dispatching object, its actual parameters and the formal 370 -- parameters of the overridden interface-level version. If the type of 371 -- the dispatching object is an access type then an explicit dereference 372 -- is returned in Object. 373 374 procedure Extract_Entry 375 (N : Node_Id; 376 Concval : out Node_Id; 377 Ename : out Node_Id; 378 Index : out Node_Id); 379 -- Given an entry call, returns the associated concurrent object, the entry 380 -- name, and the entry family index. 381 382 function Family_Offset 383 (Loc : Source_Ptr; 384 Hi : Node_Id; 385 Lo : Node_Id; 386 Ttyp : Entity_Id; 387 Cap : Boolean) return Node_Id; 388 -- Compute (Hi - Lo) for two entry family indexes. Hi is the index in an 389 -- accept statement, or the upper bound in the discrete subtype of an entry 390 -- declaration. Lo is the corresponding lower bound. Ttyp is the concurrent 391 -- type of the entry. If Cap is true, the result is capped according to 392 -- Entry_Family_Bound. 393 394 function Family_Size 395 (Loc : Source_Ptr; 396 Hi : Node_Id; 397 Lo : Node_Id; 398 Ttyp : Entity_Id; 399 Cap : Boolean) return Node_Id; 400 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in a 401 -- family, and handle properly the superflat case. This is equivalent to 402 -- the use of 'Length on the index type, but must use Family_Offset to 403 -- handle properly the case of bounds that depend on discriminants. If 404 -- Cap is true, the result is capped according to Entry_Family_Bound. 405 406 procedure Find_Enclosing_Context 407 (N : Node_Id; 408 Context : out Node_Id; 409 Context_Id : out Entity_Id; 410 Context_Decls : out List_Id); 411 -- Subsidiary routine to procedures Build_Activation_Chain_Entity and 412 -- Build_Master_Entity. Given an arbitrary node in the tree, find the 413 -- nearest enclosing body, block, package, or return statement and return 414 -- its constituents. Context is the enclosing construct, Context_Id is 415 -- the scope of Context_Id and Context_Decls is the declarative list of 416 -- Context. 417 418 function Index_Object (Spec_Id : Entity_Id) return Entity_Id; 419 -- Given a subprogram identifier, return the entity which is associated 420 -- with the protection entry index in the Protected_Body_Subprogram or 421 -- the Task_Body_Procedure of Spec_Id. The returned entity denotes formal 422 -- parameter _E. 423 424 function Is_Exception_Safe (Subprogram : Node_Id) return Boolean; 425 -- Tell whether a given subprogram cannot raise an exception 426 427 function Is_Potentially_Large_Family 428 (Base_Index : Entity_Id; 429 Conctyp : Entity_Id; 430 Lo : Node_Id; 431 Hi : Node_Id) return Boolean; 432 433 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean; 434 -- Determine whether Id is a function or a procedure and is marked as a 435 -- private primitive. 436 437 function Null_Statements (Stats : List_Id) return Boolean; 438 -- Used to check DO-END sequence. Checks for equivalent of DO NULL; END. 439 -- Allows labels, and pragma Warnings/Unreferenced in the sequence as well 440 -- to still count as null. Returns True for a null sequence. The argument 441 -- is the list of statements from the DO-END sequence. 442 443 function Parameter_Block_Pack 444 (Loc : Source_Ptr; 445 Blk_Typ : Entity_Id; 446 Actuals : List_Id; 447 Formals : List_Id; 448 Decls : List_Id; 449 Stmts : List_Id) return Entity_Id; 450 -- Set the components of the generated parameter block with the values 451 -- of the actual parameters. Generate aliased temporaries to capture the 452 -- values for types that are passed by copy. Otherwise generate a reference 453 -- to the actual's value. Return the address of the aggregate block. 454 -- Generate: 455 -- Jnn1 : alias <formal-type1>; 456 -- Jnn1 := <actual1>; 457 -- ... 458 -- P : Blk_Typ := ( 459 -- Jnn1'unchecked_access; 460 -- <actual2>'reference; 461 -- ...); 462 463 function Parameter_Block_Unpack 464 (Loc : Source_Ptr; 465 P : Entity_Id; 466 Actuals : List_Id; 467 Formals : List_Id) return List_Id; 468 -- Retrieve the values of the components from the parameter block and 469 -- assign then to the original actual parameters. Generate: 470 -- <actual1> := P.<formal1>; 471 -- ... 472 -- <actualN> := P.<formalN>; 473 474 function Trivial_Accept_OK return Boolean; 475 -- If there is no DO-END block for an accept, or if the DO-END block has 476 -- only null statements, then it is possible to do the Rendezvous with much 477 -- less overhead using the Accept_Trivial routine in the run-time library. 478 -- However, this is not always a valid optimization. Whether it is valid or 479 -- not depends on the Task_Dispatching_Policy. The issue is whether a full 480 -- rescheduling action is required or not. In FIFO_Within_Priorities, such 481 -- a rescheduling is required, so this optimization is not allowed. This 482 -- function returns True if the optimization is permitted. 483 484 ----------------------------- 485 -- Actual_Index_Expression -- 486 ----------------------------- 487 488 function Actual_Index_Expression 489 (Sloc : Source_Ptr; 490 Ent : Entity_Id; 491 Index : Node_Id; 492 Tsk : Entity_Id) return Node_Id 493 is 494 Ttyp : constant Entity_Id := Etype (Tsk); 495 Expr : Node_Id; 496 Num : Node_Id; 497 Lo : Node_Id; 498 Hi : Node_Id; 499 Prev : Entity_Id; 500 S : Node_Id; 501 502 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id; 503 -- Compute difference between bounds of entry family 504 505 -------------------------- 506 -- Actual_Family_Offset -- 507 -------------------------- 508 509 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is 510 511 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; 512 -- Replace a reference to a discriminant with a selected component 513 -- denoting the discriminant of the target task. 514 515 ----------------------------- 516 -- Actual_Discriminant_Ref -- 517 ----------------------------- 518 519 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is 520 Typ : constant Entity_Id := Etype (Bound); 521 B : Node_Id; 522 523 begin 524 if not Is_Entity_Name (Bound) 525 or else Ekind (Entity (Bound)) /= E_Discriminant 526 then 527 if Nkind (Bound) = N_Attribute_Reference then 528 return Bound; 529 else 530 B := New_Copy_Tree (Bound); 531 end if; 532 533 else 534 B := 535 Make_Selected_Component (Sloc, 536 Prefix => New_Copy_Tree (Tsk), 537 Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc)); 538 539 Analyze_And_Resolve (B, Typ); 540 end if; 541 542 return 543 Make_Attribute_Reference (Sloc, 544 Attribute_Name => Name_Pos, 545 Prefix => New_Occurrence_Of (Etype (Bound), Sloc), 546 Expressions => New_List (B)); 547 end Actual_Discriminant_Ref; 548 549 -- Start of processing for Actual_Family_Offset 550 551 begin 552 return 553 Make_Op_Subtract (Sloc, 554 Left_Opnd => Actual_Discriminant_Ref (Hi), 555 Right_Opnd => Actual_Discriminant_Ref (Lo)); 556 end Actual_Family_Offset; 557 558 -- Start of processing for Actual_Index_Expression 559 560 begin 561 -- The queues of entries and entry families appear in textual order in 562 -- the associated record. The entry index is computed as the sum of the 563 -- number of queues for all entries that precede the designated one, to 564 -- which is added the index expression, if this expression denotes a 565 -- member of a family. 566 567 -- The following is a place holder for the count of simple entries 568 569 Num := Make_Integer_Literal (Sloc, 1); 570 571 -- We construct an expression which is a series of addition operations. 572 -- See comments in Entry_Index_Expression, which is identical in 573 -- structure. 574 575 if Present (Index) then 576 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); 577 578 Expr := 579 Make_Op_Add (Sloc, 580 Left_Opnd => Num, 581 Right_Opnd => 582 Actual_Family_Offset ( 583 Make_Attribute_Reference (Sloc, 584 Attribute_Name => Name_Pos, 585 Prefix => New_Occurrence_Of (Base_Type (S), Sloc), 586 Expressions => New_List (Relocate_Node (Index))), 587 Type_Low_Bound (S))); 588 else 589 Expr := Num; 590 end if; 591 592 -- Now add lengths of preceding entries and entry families 593 594 Prev := First_Entity (Ttyp); 595 while Chars (Prev) /= Chars (Ent) 596 or else (Ekind (Prev) /= Ekind (Ent)) 597 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 598 loop 599 if Ekind (Prev) = E_Entry then 600 Set_Intval (Num, Intval (Num) + 1); 601 602 elsif Ekind (Prev) = E_Entry_Family then 603 S := 604 Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); 605 606 -- The need for the following full view retrieval stems from this 607 -- complex case of nested generics and tasking: 608 609 -- generic 610 -- type Formal_Index is range <>; 611 -- ... 612 -- package Outer is 613 -- type Index is private; 614 -- generic 615 -- ... 616 -- package Inner is 617 -- procedure P; 618 -- end Inner; 619 -- private 620 -- type Index is new Formal_Index range 1 .. 10; 621 -- end Outer; 622 623 -- package body Outer is 624 -- task type T is 625 -- entry Fam (Index); -- (2) 626 -- entry E; 627 -- end T; 628 -- package body Inner is -- (3) 629 -- procedure P is 630 -- begin 631 -- T.E; -- (1) 632 -- end P; 633 -- end Inner; 634 -- ... 635 636 -- We are currently building the index expression for the entry 637 -- call "T.E" (1). Part of the expansion must mention the range 638 -- of the discrete type "Index" (2) of entry family "Fam". 639 640 -- However only the private view of type "Index" is available to 641 -- the inner generic (3) because there was no prior mention of 642 -- the type inside "Inner". This visibility requirement is 643 -- implicit and cannot be detected during the construction of 644 -- the generic trees and needs special handling. 645 646 if In_Instance_Body 647 and then Is_Private_Type (S) 648 and then Present (Full_View (S)) 649 then 650 S := Full_View (S); 651 end if; 652 653 Lo := Type_Low_Bound (S); 654 Hi := Type_High_Bound (S); 655 656 Expr := 657 Make_Op_Add (Sloc, 658 Left_Opnd => Expr, 659 Right_Opnd => 660 Make_Op_Add (Sloc, 661 Left_Opnd => Actual_Family_Offset (Hi, Lo), 662 Right_Opnd => Make_Integer_Literal (Sloc, 1))); 663 664 -- Other components are anonymous types to be ignored 665 666 else 667 null; 668 end if; 669 670 Next_Entity (Prev); 671 end loop; 672 673 return Expr; 674 end Actual_Index_Expression; 675 676 -------------------------- 677 -- Add_Formal_Renamings -- 678 -------------------------- 679 680 procedure Add_Formal_Renamings 681 (Spec : Node_Id; 682 Decls : List_Id; 683 Ent : Entity_Id; 684 Loc : Source_Ptr) 685 is 686 Ptr : constant Entity_Id := 687 Defining_Identifier 688 (Next (First (Parameter_Specifications (Spec)))); 689 -- The name of the formal that holds the address of the parameter block 690 -- for the call. 691 692 Comp : Entity_Id; 693 Decl : Node_Id; 694 Formal : Entity_Id; 695 New_F : Entity_Id; 696 Renamed_Formal : Node_Id; 697 698 begin 699 Formal := First_Formal (Ent); 700 while Present (Formal) loop 701 Comp := Entry_Component (Formal); 702 New_F := 703 Make_Defining_Identifier (Sloc (Formal), 704 Chars => Chars (Formal)); 705 Set_Etype (New_F, Etype (Formal)); 706 Set_Scope (New_F, Ent); 707 708 -- Now we set debug info needed on New_F even though it does not come 709 -- from source, so that the debugger will get the right information 710 -- for these generated names. 711 712 Set_Debug_Info_Needed (New_F); 713 714 if Ekind (Formal) = E_In_Parameter then 715 Set_Ekind (New_F, E_Constant); 716 else 717 Set_Ekind (New_F, E_Variable); 718 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 719 end if; 720 721 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 722 723 Renamed_Formal := 724 Make_Selected_Component (Loc, 725 Prefix => 726 Unchecked_Convert_To (Entry_Parameters_Type (Ent), 727 Make_Identifier (Loc, Chars (Ptr))), 728 Selector_Name => New_Occurrence_Of (Comp, Loc)); 729 730 Decl := 731 Build_Renamed_Formal_Declaration 732 (New_F, Formal, Comp, Renamed_Formal); 733 734 Append (Decl, Decls); 735 Set_Renamed_Object (Formal, New_F); 736 Next_Formal (Formal); 737 end loop; 738 end Add_Formal_Renamings; 739 740 ------------------------ 741 -- Add_Object_Pointer -- 742 ------------------------ 743 744 procedure Add_Object_Pointer 745 (Loc : Source_Ptr; 746 Conc_Typ : Entity_Id; 747 Decls : List_Id) 748 is 749 Rec_Typ : constant Entity_Id := Corresponding_Record_Type (Conc_Typ); 750 Decl : Node_Id; 751 Obj_Ptr : Node_Id; 752 753 begin 754 -- Create the renaming declaration for the Protection object of a 755 -- protected type. _Object is used by Complete_Entry_Body. 756 -- ??? An attempt to make this a renaming was unsuccessful. 757 758 -- Build the entity for the access type 759 760 Obj_Ptr := 761 Make_Defining_Identifier (Loc, 762 New_External_Name (Chars (Rec_Typ), 'P')); 763 764 -- Generate: 765 -- _object : poVP := poVP!O; 766 767 Decl := 768 Make_Object_Declaration (Loc, 769 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uObject), 770 Object_Definition => New_Occurrence_Of (Obj_Ptr, Loc), 771 Expression => 772 Unchecked_Convert_To (Obj_Ptr, Make_Identifier (Loc, Name_uO))); 773 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 774 Prepend_To (Decls, Decl); 775 776 -- Generate: 777 -- type poVP is access poV; 778 779 Decl := 780 Make_Full_Type_Declaration (Loc, 781 Defining_Identifier => 782 Obj_Ptr, 783 Type_Definition => 784 Make_Access_To_Object_Definition (Loc, 785 Subtype_Indication => 786 New_Occurrence_Of (Rec_Typ, Loc))); 787 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 788 Prepend_To (Decls, Decl); 789 end Add_Object_Pointer; 790 791 ----------------------- 792 -- Build_Accept_Body -- 793 ----------------------- 794 795 function Build_Accept_Body (Astat : Node_Id) return Node_Id is 796 Loc : constant Source_Ptr := Sloc (Astat); 797 Stats : constant Node_Id := Handled_Statement_Sequence (Astat); 798 New_S : Node_Id; 799 Hand : Node_Id; 800 Call : Node_Id; 801 Ohandle : Node_Id; 802 803 begin 804 -- At the end of the statement sequence, Complete_Rendezvous is called. 805 -- A label skipping the Complete_Rendezvous, and all other accept 806 -- processing, has already been added for the expansion of requeue 807 -- statements. The Sloc is copied from the last statement since it 808 -- is really part of this last statement. 809 810 Call := 811 Build_Runtime_Call 812 (Sloc (Last (Statements (Stats))), RE_Complete_Rendezvous); 813 Insert_Before (Last (Statements (Stats)), Call); 814 Analyze (Call); 815 816 -- If exception handlers are present, then append Complete_Rendezvous 817 -- calls to the handlers, and construct the required outer block. As 818 -- above, the Sloc is copied from the last statement in the sequence. 819 820 if Present (Exception_Handlers (Stats)) then 821 Hand := First (Exception_Handlers (Stats)); 822 while Present (Hand) loop 823 Call := 824 Build_Runtime_Call 825 (Sloc (Last (Statements (Hand))), RE_Complete_Rendezvous); 826 Append (Call, Statements (Hand)); 827 Analyze (Call); 828 Next (Hand); 829 end loop; 830 831 New_S := 832 Make_Handled_Sequence_Of_Statements (Loc, 833 Statements => New_List ( 834 Make_Block_Statement (Loc, 835 Handled_Statement_Sequence => Stats))); 836 837 else 838 New_S := Stats; 839 end if; 840 841 -- At this stage we know that the new statement sequence does 842 -- not have an exception handler part, so we supply one to call 843 -- Exceptional_Complete_Rendezvous. This handler is 844 845 -- when all others => 846 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 847 848 -- We handle Abort_Signal to make sure that we properly catch the abort 849 -- case and wake up the caller. 850 851 Ohandle := Make_Others_Choice (Loc); 852 Set_All_Others (Ohandle); 853 854 Set_Exception_Handlers (New_S, 855 New_List ( 856 Make_Implicit_Exception_Handler (Loc, 857 Exception_Choices => New_List (Ohandle), 858 859 Statements => New_List ( 860 Make_Procedure_Call_Statement (Sloc (Stats), 861 Name => New_Occurrence_Of ( 862 RTE (RE_Exceptional_Complete_Rendezvous), Sloc (Stats)), 863 Parameter_Associations => New_List ( 864 Make_Function_Call (Sloc (Stats), 865 Name => 866 New_Occurrence_Of 867 (RTE (RE_Get_GNAT_Exception), Sloc (Stats))))))))); 868 869 Set_Parent (New_S, Astat); -- temp parent for Analyze call 870 Analyze_Exception_Handlers (Exception_Handlers (New_S)); 871 Expand_Exception_Handlers (New_S); 872 873 -- Exceptional_Complete_Rendezvous must be called with abort still 874 -- deferred, which is the case for a "when all others" handler. 875 876 return New_S; 877 end Build_Accept_Body; 878 879 ----------------------------------- 880 -- Build_Activation_Chain_Entity -- 881 ----------------------------------- 882 883 procedure Build_Activation_Chain_Entity (N : Node_Id) is 884 function Has_Activation_Chain (Stmt : Node_Id) return Boolean; 885 -- Determine whether an extended return statement has activation chain 886 887 -------------------------- 888 -- Has_Activation_Chain -- 889 -------------------------- 890 891 function Has_Activation_Chain (Stmt : Node_Id) return Boolean is 892 Decl : Node_Id; 893 894 begin 895 Decl := First (Return_Object_Declarations (Stmt)); 896 while Present (Decl) loop 897 if Nkind (Decl) = N_Object_Declaration 898 and then Chars (Defining_Identifier (Decl)) = Name_uChain 899 then 900 return True; 901 end if; 902 903 Next (Decl); 904 end loop; 905 906 return False; 907 end Has_Activation_Chain; 908 909 -- Local variables 910 911 Context : Node_Id; 912 Context_Id : Entity_Id; 913 Decls : List_Id; 914 915 -- Start of processing for Build_Activation_Chain_Entity 916 917 begin 918 -- Activation chain is never used for sequential elaboration policy, see 919 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 920 921 if Partition_Elaboration_Policy = 'S' then 922 return; 923 end if; 924 925 Find_Enclosing_Context (N, Context, Context_Id, Decls); 926 927 -- If activation chain entity has not been declared already, create one 928 929 if Nkind (Context) = N_Extended_Return_Statement 930 or else No (Activation_Chain_Entity (Context)) 931 then 932 -- Since extended return statements do not store the entity of the 933 -- chain, examine the return object declarations to avoid creating 934 -- a duplicate. 935 936 if Nkind (Context) = N_Extended_Return_Statement 937 and then Has_Activation_Chain (Context) 938 then 939 return; 940 end if; 941 942 declare 943 Loc : constant Source_Ptr := Sloc (Context); 944 Chain : Entity_Id; 945 Decl : Node_Id; 946 947 begin 948 Chain := Make_Defining_Identifier (Sloc (N), Name_uChain); 949 950 -- Note: An extended return statement is not really a task 951 -- activator, but it does have an activation chain on which to 952 -- store the tasks temporarily. On successful return, the tasks 953 -- on this chain are moved to the chain passed in by the caller. 954 -- We do not build an Activation_Chain_Entity for an extended 955 -- return statement, because we do not want to build a call to 956 -- Activate_Tasks. Task activation is the responsibility of the 957 -- caller. 958 959 if Nkind (Context) /= N_Extended_Return_Statement then 960 Set_Activation_Chain_Entity (Context, Chain); 961 end if; 962 963 Decl := 964 Make_Object_Declaration (Loc, 965 Defining_Identifier => Chain, 966 Aliased_Present => True, 967 Object_Definition => 968 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc)); 969 970 Prepend_To (Decls, Decl); 971 972 -- Ensure that _chain appears in the proper scope of the context 973 974 if Context_Id /= Current_Scope then 975 Push_Scope (Context_Id); 976 Analyze (Decl); 977 Pop_Scope; 978 else 979 Analyze (Decl); 980 end if; 981 end; 982 end if; 983 end Build_Activation_Chain_Entity; 984 985 ---------------------------- 986 -- Build_Barrier_Function -- 987 ---------------------------- 988 989 function Build_Barrier_Function 990 (N : Node_Id; 991 Ent : Entity_Id; 992 Pid : Node_Id) return Node_Id 993 is 994 Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); 995 Cond : constant Node_Id := Condition (Ent_Formals); 996 Loc : constant Source_Ptr := Sloc (Cond); 997 Func_Id : constant Entity_Id := Barrier_Function (Ent); 998 Op_Decls : constant List_Id := New_List; 999 Stmt : Node_Id; 1000 Func_Body : Node_Id; 1001 1002 begin 1003 -- Add a declaration for the Protection object, renaming declarations 1004 -- for the discriminals and privals and finally a declaration for the 1005 -- entry family index (if applicable). 1006 1007 Install_Private_Data_Declarations (Sloc (N), 1008 Spec_Id => Func_Id, 1009 Conc_Typ => Pid, 1010 Body_Nod => N, 1011 Decls => Op_Decls, 1012 Barrier => True, 1013 Family => Ekind (Ent) = E_Entry_Family); 1014 1015 -- If compiling with -fpreserve-control-flow, make sure we insert an 1016 -- IF statement so that the back-end knows to generate a conditional 1017 -- branch instruction, even if the condition is just the name of a 1018 -- boolean object. Note that Expand_N_If_Statement knows to preserve 1019 -- such redundant IF statements under -fpreserve-control-flow 1020 -- (whether coming from this routine, or directly from source). 1021 1022 if Opt.Suppress_Control_Flow_Optimizations then 1023 Stmt := 1024 Make_Implicit_If_Statement (Cond, 1025 Condition => Cond, 1026 Then_Statements => New_List ( 1027 Make_Simple_Return_Statement (Loc, 1028 New_Occurrence_Of (Standard_True, Loc))), 1029 1030 Else_Statements => New_List ( 1031 Make_Simple_Return_Statement (Loc, 1032 New_Occurrence_Of (Standard_False, Loc)))); 1033 1034 else 1035 Stmt := Make_Simple_Return_Statement (Loc, Cond); 1036 end if; 1037 1038 -- Note: the condition in the barrier function needs to be properly 1039 -- processed for the C/Fortran boolean possibility, but this happens 1040 -- automatically since the return statement does this normalization. 1041 1042 Func_Body := 1043 Make_Subprogram_Body (Loc, 1044 Specification => 1045 Build_Barrier_Function_Specification (Loc, 1046 Make_Defining_Identifier (Loc, Chars (Func_Id))), 1047 Declarations => Op_Decls, 1048 Handled_Statement_Sequence => 1049 Make_Handled_Sequence_Of_Statements (Loc, 1050 Statements => New_List (Stmt))); 1051 Set_Is_Entry_Barrier_Function (Func_Body); 1052 1053 return Func_Body; 1054 end Build_Barrier_Function; 1055 1056 ------------------------------------------ 1057 -- Build_Barrier_Function_Specification -- 1058 ------------------------------------------ 1059 1060 function Build_Barrier_Function_Specification 1061 (Loc : Source_Ptr; 1062 Def_Id : Entity_Id) return Node_Id 1063 is 1064 begin 1065 Set_Debug_Info_Needed (Def_Id); 1066 1067 return 1068 Make_Function_Specification (Loc, 1069 Defining_Unit_Name => Def_Id, 1070 Parameter_Specifications => New_List ( 1071 Make_Parameter_Specification (Loc, 1072 Defining_Identifier => 1073 Make_Defining_Identifier (Loc, Name_uO), 1074 Parameter_Type => 1075 New_Occurrence_Of (RTE (RE_Address), Loc)), 1076 1077 Make_Parameter_Specification (Loc, 1078 Defining_Identifier => 1079 Make_Defining_Identifier (Loc, Name_uE), 1080 Parameter_Type => 1081 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), 1082 1083 Result_Definition => 1084 New_Occurrence_Of (Standard_Boolean, Loc)); 1085 end Build_Barrier_Function_Specification; 1086 1087 -------------------------- 1088 -- Build_Call_With_Task -- 1089 -------------------------- 1090 1091 function Build_Call_With_Task 1092 (N : Node_Id; 1093 E : Entity_Id) return Node_Id 1094 is 1095 Loc : constant Source_Ptr := Sloc (N); 1096 begin 1097 return 1098 Make_Function_Call (Loc, 1099 Name => New_Occurrence_Of (E, Loc), 1100 Parameter_Associations => New_List (Concurrent_Ref (N))); 1101 end Build_Call_With_Task; 1102 1103 ----------------------------- 1104 -- Build_Class_Wide_Master -- 1105 ----------------------------- 1106 1107 procedure Build_Class_Wide_Master (Typ : Entity_Id) is 1108 Loc : constant Source_Ptr := Sloc (Typ); 1109 Master_Id : Entity_Id; 1110 Master_Scope : Entity_Id; 1111 Name_Id : Node_Id; 1112 Related_Node : Node_Id; 1113 Ren_Decl : Node_Id; 1114 1115 begin 1116 -- Nothing to do if there is no task hierarchy 1117 1118 if Restriction_Active (No_Task_Hierarchy) then 1119 return; 1120 end if; 1121 1122 -- Find the declaration that created the access type, which is either a 1123 -- type declaration, or an object declaration with an access definition, 1124 -- in which case the type is anonymous. 1125 1126 if Is_Itype (Typ) then 1127 Related_Node := Associated_Node_For_Itype (Typ); 1128 else 1129 Related_Node := Parent (Typ); 1130 end if; 1131 1132 Master_Scope := Find_Master_Scope (Typ); 1133 1134 -- Nothing to do if the master scope already contains a _master entity. 1135 -- The only exception to this is the following scenario: 1136 1137 -- Source_Scope 1138 -- Transient_Scope_1 1139 -- _master 1140 1141 -- Transient_Scope_2 1142 -- use of master 1143 1144 -- In this case the source scope is marked as having the master entity 1145 -- even though the actual declaration appears inside an inner scope. If 1146 -- the second transient scope requires a _master, it cannot use the one 1147 -- already declared because the entity is not visible. 1148 1149 Name_Id := Make_Identifier (Loc, Name_uMaster); 1150 1151 if not Has_Master_Entity (Master_Scope) 1152 or else No (Current_Entity_In_Scope (Name_Id)) 1153 then 1154 declare 1155 Master_Decl : Node_Id; 1156 begin 1157 Set_Has_Master_Entity (Master_Scope); 1158 1159 -- Generate: 1160 -- _master : constant Integer := Current_Master.all; 1161 1162 Master_Decl := 1163 Make_Object_Declaration (Loc, 1164 Defining_Identifier => 1165 Make_Defining_Identifier (Loc, Name_uMaster), 1166 Constant_Present => True, 1167 Object_Definition => 1168 New_Occurrence_Of (Standard_Integer, Loc), 1169 Expression => 1170 Make_Explicit_Dereference (Loc, 1171 New_Occurrence_Of (RTE (RE_Current_Master), Loc))); 1172 1173 Insert_Action (Find_Hook_Context (Related_Node), Master_Decl); 1174 Analyze (Master_Decl); 1175 1176 -- Mark the containing scope as a task master. Masters associated 1177 -- with return statements are already marked at this stage (see 1178 -- Analyze_Subprogram_Body). 1179 1180 if Ekind (Current_Scope) /= E_Return_Statement then 1181 declare 1182 Par : Node_Id := Related_Node; 1183 1184 begin 1185 while Nkind (Par) /= N_Compilation_Unit loop 1186 Par := Parent (Par); 1187 1188 -- If we fall off the top, we are at the outer level, 1189 -- and the environment task is our effective master, 1190 -- so nothing to mark. 1191 1192 if Nkind_In (Par, N_Block_Statement, 1193 N_Subprogram_Body, 1194 N_Task_Body) 1195 then 1196 Set_Is_Task_Master (Par); 1197 exit; 1198 end if; 1199 end loop; 1200 end; 1201 end if; 1202 end; 1203 end if; 1204 1205 Master_Id := 1206 Make_Defining_Identifier (Loc, New_External_Name (Chars (Typ), 'M')); 1207 1208 -- Generate: 1209 -- typeMnn renames _master; 1210 1211 Ren_Decl := 1212 Make_Object_Renaming_Declaration (Loc, 1213 Defining_Identifier => Master_Id, 1214 Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc), 1215 Name => Name_Id); 1216 1217 Insert_Action (Related_Node, Ren_Decl); 1218 1219 Set_Master_Id (Typ, Master_Id); 1220 end Build_Class_Wide_Master; 1221 1222 ---------------------------- 1223 -- Build_Contract_Wrapper -- 1224 ---------------------------- 1225 1226 procedure Build_Contract_Wrapper (E : Entity_Id; Decl : Node_Id) is 1227 Conc_Typ : constant Entity_Id := Scope (E); 1228 Loc : constant Source_Ptr := Sloc (E); 1229 1230 procedure Add_Discriminant_Renamings 1231 (Obj_Id : Entity_Id; 1232 Decls : List_Id); 1233 -- Add renaming declarations for all discriminants of concurrent type 1234 -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which 1235 -- represents the concurrent object. 1236 1237 procedure Add_Matching_Formals 1238 (Formals : List_Id; 1239 Actuals : in out List_Id); 1240 -- Add formal parameters that match those of entry E to list Formals. 1241 -- The routine also adds matching actuals for the new formals to list 1242 -- Actuals. 1243 1244 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id); 1245 -- Relocate pragma Prag to list To. The routine creates a new list if 1246 -- To does not exist. 1247 1248 -------------------------------- 1249 -- Add_Discriminant_Renamings -- 1250 -------------------------------- 1251 1252 procedure Add_Discriminant_Renamings 1253 (Obj_Id : Entity_Id; 1254 Decls : List_Id) 1255 is 1256 Discr : Entity_Id; 1257 1258 begin 1259 -- Inspect the discriminants of the concurrent type and generate a 1260 -- renaming for each one. 1261 1262 if Has_Discriminants (Conc_Typ) then 1263 Discr := First_Discriminant (Conc_Typ); 1264 while Present (Discr) loop 1265 Prepend_To (Decls, 1266 Make_Object_Renaming_Declaration (Loc, 1267 Defining_Identifier => 1268 Make_Defining_Identifier (Loc, Chars (Discr)), 1269 Subtype_Mark => 1270 New_Occurrence_Of (Etype (Discr), Loc), 1271 Name => 1272 Make_Selected_Component (Loc, 1273 Prefix => New_Occurrence_Of (Obj_Id, Loc), 1274 Selector_Name => 1275 Make_Identifier (Loc, Chars (Discr))))); 1276 1277 Next_Discriminant (Discr); 1278 end loop; 1279 end if; 1280 end Add_Discriminant_Renamings; 1281 1282 -------------------------- 1283 -- Add_Matching_Formals -- 1284 -------------------------- 1285 1286 procedure Add_Matching_Formals 1287 (Formals : List_Id; 1288 Actuals : in out List_Id) 1289 is 1290 Formal : Entity_Id; 1291 New_Formal : Entity_Id; 1292 1293 begin 1294 -- Inspect the formal parameters of the entry and generate a new 1295 -- matching formal with the same name for the wrapper. A reference 1296 -- to the new formal becomes an actual in the entry call. 1297 1298 Formal := First_Formal (E); 1299 while Present (Formal) loop 1300 New_Formal := Make_Defining_Identifier (Loc, Chars (Formal)); 1301 Append_To (Formals, 1302 Make_Parameter_Specification (Loc, 1303 Defining_Identifier => New_Formal, 1304 In_Present => In_Present (Parent (Formal)), 1305 Out_Present => Out_Present (Parent (Formal)), 1306 Parameter_Type => 1307 New_Occurrence_Of (Etype (Formal), Loc))); 1308 1309 if No (Actuals) then 1310 Actuals := New_List; 1311 end if; 1312 1313 Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); 1314 Next_Formal (Formal); 1315 end loop; 1316 end Add_Matching_Formals; 1317 1318 --------------------- 1319 -- Transfer_Pragma -- 1320 --------------------- 1321 1322 procedure Transfer_Pragma (Prag : Node_Id; To : in out List_Id) is 1323 New_Prag : Node_Id; 1324 1325 begin 1326 if No (To) then 1327 To := New_List; 1328 end if; 1329 1330 New_Prag := Relocate_Node (Prag); 1331 1332 Set_Analyzed (New_Prag, False); 1333 Append (New_Prag, To); 1334 end Transfer_Pragma; 1335 1336 -- Local variables 1337 1338 Items : constant Node_Id := Contract (E); 1339 Actuals : List_Id := No_List; 1340 Call : Node_Id; 1341 Call_Nam : Node_Id; 1342 Decls : List_Id := No_List; 1343 Formals : List_Id; 1344 Has_Pragma : Boolean := False; 1345 Index_Id : Entity_Id; 1346 Obj_Id : Entity_Id; 1347 Prag : Node_Id; 1348 Wrapper_Id : Entity_Id; 1349 1350 -- Start of processing for Build_Contract_Wrapper 1351 1352 begin 1353 -- This routine generates a specialized wrapper for a protected or task 1354 -- entry [family] which implements precondition/postcondition semantics. 1355 -- Preconditions and case guards of contract cases are checked before 1356 -- the protected action or rendezvous takes place. Postconditions and 1357 -- consequences of contract cases are checked after the protected action 1358 -- or rendezvous takes place. The structure of the generated wrapper is 1359 -- as follows: 1360 1361 -- procedure Wrapper 1362 -- (Obj_Id : Conc_Typ; -- concurrent object 1363 -- [Index : Index_Typ;] -- index of entry family 1364 -- [Formal_1 : ...; -- parameters of original entry 1365 -- Formal_N : ...]) 1366 -- is 1367 -- [Discr_1 : ... renames Obj_Id.Discr_1; -- discriminant 1368 -- Discr_N : ... renames Obj_Id.Discr_N;] -- renamings 1369 1370 -- <precondition checks> 1371 -- <case guard checks> 1372 1373 -- procedure _Postconditions is 1374 -- begin 1375 -- <postcondition checks> 1376 -- <consequence checks> 1377 -- end _Postconditions; 1378 1379 -- begin 1380 -- Entry_Call (Obj_Id, [Index,] [Formal_1, Formal_N]); 1381 -- _Postconditions; 1382 -- end Wrapper; 1383 1384 -- Create the wrapper only when the entry has at least one executable 1385 -- contract item such as contract cases, precondition or postcondition. 1386 1387 if Present (Items) then 1388 1389 -- Inspect the list of pre/postconditions and transfer all available 1390 -- pragmas to the declarative list of the wrapper. 1391 1392 Prag := Pre_Post_Conditions (Items); 1393 while Present (Prag) loop 1394 if Nam_In (Pragma_Name (Prag), Name_Postcondition, 1395 Name_Precondition) 1396 and then Is_Checked (Prag) 1397 then 1398 Has_Pragma := True; 1399 Transfer_Pragma (Prag, To => Decls); 1400 end if; 1401 1402 Prag := Next_Pragma (Prag); 1403 end loop; 1404 1405 -- Inspect the list of test/contract cases and transfer only contract 1406 -- cases pragmas to the declarative part of the wrapper. 1407 1408 Prag := Contract_Test_Cases (Items); 1409 while Present (Prag) loop 1410 if Pragma_Name (Prag) = Name_Contract_Cases 1411 and then Is_Checked (Prag) 1412 then 1413 Has_Pragma := True; 1414 Transfer_Pragma (Prag, To => Decls); 1415 end if; 1416 1417 Prag := Next_Pragma (Prag); 1418 end loop; 1419 end if; 1420 1421 -- The entry lacks executable contract items and a wrapper is not needed 1422 1423 if not Has_Pragma then 1424 return; 1425 end if; 1426 1427 -- Create the profile of the wrapper. The first formal parameter is the 1428 -- concurrent object. 1429 1430 Obj_Id := 1431 Make_Defining_Identifier (Loc, 1432 Chars => New_External_Name (Chars (Conc_Typ), 'A')); 1433 1434 Formals := New_List ( 1435 Make_Parameter_Specification (Loc, 1436 Defining_Identifier => Obj_Id, 1437 Out_Present => True, 1438 In_Present => True, 1439 Parameter_Type => New_Occurrence_Of (Conc_Typ, Loc))); 1440 1441 -- Construct the call to the original entry. The call will be gradually 1442 -- augmented with an optional entry index and extra parameters. 1443 1444 Call_Nam := 1445 Make_Selected_Component (Loc, 1446 Prefix => New_Occurrence_Of (Obj_Id, Loc), 1447 Selector_Name => New_Occurrence_Of (E, Loc)); 1448 1449 -- When creating a wrapper for an entry family, the second formal is the 1450 -- entry index. 1451 1452 if Ekind (E) = E_Entry_Family then 1453 Index_Id := Make_Defining_Identifier (Loc, Name_I); 1454 1455 Append_To (Formals, 1456 Make_Parameter_Specification (Loc, 1457 Defining_Identifier => Index_Id, 1458 Parameter_Type => 1459 New_Occurrence_Of (Entry_Index_Type (E), Loc))); 1460 1461 -- The call to the original entry becomes an indexed component to 1462 -- accommodate the entry index. 1463 1464 Call_Nam := 1465 Make_Indexed_Component (Loc, 1466 Prefix => Call_Nam, 1467 Expressions => New_List (New_Occurrence_Of (Index_Id, Loc))); 1468 end if; 1469 1470 -- Add formal parameters to match those of the entry and build actuals 1471 -- for the entry call. 1472 1473 Add_Matching_Formals (Formals, Actuals); 1474 1475 Call := 1476 Make_Procedure_Call_Statement (Loc, 1477 Name => Call_Nam, 1478 Parameter_Associations => Actuals); 1479 1480 -- Add renaming declarations for the discriminants of the enclosing type 1481 -- as the various contract items may reference them. 1482 1483 Add_Discriminant_Renamings (Obj_Id, Decls); 1484 1485 Wrapper_Id := 1486 Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E')); 1487 Set_Contract_Wrapper (E, Wrapper_Id); 1488 1489 -- The wrapper body is analyzed when the enclosing type is frozen 1490 1491 Append_Freeze_Action (Defining_Entity (Decl), 1492 Make_Subprogram_Body (Loc, 1493 Specification => 1494 Make_Procedure_Specification (Loc, 1495 Defining_Unit_Name => Wrapper_Id, 1496 Parameter_Specifications => Formals), 1497 Declarations => Decls, 1498 Handled_Statement_Sequence => 1499 Make_Handled_Sequence_Of_Statements (Loc, 1500 Statements => New_List (Call)))); 1501 end Build_Contract_Wrapper; 1502 1503 -------------------------------- 1504 -- Build_Corresponding_Record -- 1505 -------------------------------- 1506 1507 function Build_Corresponding_Record 1508 (N : Node_Id; 1509 Ctyp : Entity_Id; 1510 Loc : Source_Ptr) return Node_Id 1511 is 1512 Rec_Ent : constant Entity_Id := 1513 Make_Defining_Identifier 1514 (Loc, New_External_Name (Chars (Ctyp), 'V')); 1515 Disc : Entity_Id; 1516 Dlist : List_Id; 1517 New_Disc : Entity_Id; 1518 Cdecls : List_Id; 1519 1520 begin 1521 Set_Corresponding_Record_Type (Ctyp, Rec_Ent); 1522 Set_Ekind (Rec_Ent, E_Record_Type); 1523 Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp)); 1524 Set_Is_Concurrent_Record_Type (Rec_Ent, True); 1525 Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp); 1526 Set_Stored_Constraint (Rec_Ent, No_Elist); 1527 Cdecls := New_List; 1528 1529 -- Propagate type invariants to the corresponding record type 1530 1531 Set_Has_Invariants (Rec_Ent, Has_Invariants (Ctyp)); 1532 Set_Has_Inheritable_Invariants (Rec_Ent, 1533 Has_Inheritable_Invariants (Ctyp)); 1534 1535 -- Use discriminals to create list of discriminants for record, and 1536 -- create new discriminals for use in default expressions, etc. It is 1537 -- worth noting that a task discriminant gives rise to 5 entities; 1538 1539 -- a) The original discriminant. 1540 -- b) The discriminal for use in the task. 1541 -- c) The discriminant of the corresponding record. 1542 -- d) The discriminal for the init proc of the corresponding record. 1543 -- e) The local variable that renames the discriminant in the procedure 1544 -- for the task body. 1545 1546 -- In fact the discriminals b) are used in the renaming declarations 1547 -- for e). See details in einfo (Handling of Discriminants). 1548 1549 if Present (Discriminant_Specifications (N)) then 1550 Dlist := New_List; 1551 Disc := First_Discriminant (Ctyp); 1552 1553 while Present (Disc) loop 1554 New_Disc := CR_Discriminant (Disc); 1555 1556 Append_To (Dlist, 1557 Make_Discriminant_Specification (Loc, 1558 Defining_Identifier => New_Disc, 1559 Discriminant_Type => 1560 New_Occurrence_Of (Etype (Disc), Loc), 1561 Expression => 1562 New_Copy (Discriminant_Default_Value (Disc)))); 1563 1564 Next_Discriminant (Disc); 1565 end loop; 1566 1567 else 1568 Dlist := No_List; 1569 end if; 1570 1571 -- Now we can construct the record type declaration. Note that this 1572 -- record is "limited tagged". It is "limited" to reflect the underlying 1573 -- limitedness of the task or protected object that it represents, and 1574 -- ensuring for example that it is properly passed by reference. It is 1575 -- "tagged" to give support to dispatching calls through interfaces. We 1576 -- propagate here the list of interfaces covered by the concurrent type 1577 -- (Ada 2005: AI-345). 1578 1579 return 1580 Make_Full_Type_Declaration (Loc, 1581 Defining_Identifier => Rec_Ent, 1582 Discriminant_Specifications => Dlist, 1583 Type_Definition => 1584 Make_Record_Definition (Loc, 1585 Component_List => 1586 Make_Component_List (Loc, Component_Items => Cdecls), 1587 Tagged_Present => 1588 Ada_Version >= Ada_2005 and then Is_Tagged_Type (Ctyp), 1589 Interface_List => Interface_List (N), 1590 Limited_Present => True)); 1591 end Build_Corresponding_Record; 1592 1593 --------------------------------- 1594 -- Build_Dispatching_Tag_Check -- 1595 --------------------------------- 1596 1597 function Build_Dispatching_Tag_Check 1598 (K : Entity_Id; 1599 N : Node_Id) return Node_Id 1600 is 1601 Loc : constant Source_Ptr := Sloc (N); 1602 1603 begin 1604 return 1605 Make_Op_Or (Loc, 1606 Make_Op_Eq (Loc, 1607 Left_Opnd => 1608 New_Occurrence_Of (K, Loc), 1609 Right_Opnd => 1610 New_Occurrence_Of (RTE (RE_TK_Limited_Tagged), Loc)), 1611 1612 Make_Op_Eq (Loc, 1613 Left_Opnd => 1614 New_Occurrence_Of (K, Loc), 1615 Right_Opnd => 1616 New_Occurrence_Of (RTE (RE_TK_Tagged), Loc))); 1617 end Build_Dispatching_Tag_Check; 1618 1619 ---------------------------------- 1620 -- Build_Entry_Count_Expression -- 1621 ---------------------------------- 1622 1623 function Build_Entry_Count_Expression 1624 (Concurrent_Type : Node_Id; 1625 Component_List : List_Id; 1626 Loc : Source_Ptr) return Node_Id 1627 is 1628 Eindx : Nat; 1629 Ent : Entity_Id; 1630 Ecount : Node_Id; 1631 Comp : Node_Id; 1632 Lo : Node_Id; 1633 Hi : Node_Id; 1634 Typ : Entity_Id; 1635 Large : Boolean; 1636 1637 begin 1638 -- Count number of non-family entries 1639 1640 Eindx := 0; 1641 Ent := First_Entity (Concurrent_Type); 1642 while Present (Ent) loop 1643 if Ekind (Ent) = E_Entry then 1644 Eindx := Eindx + 1; 1645 end if; 1646 1647 Next_Entity (Ent); 1648 end loop; 1649 1650 Ecount := Make_Integer_Literal (Loc, Eindx); 1651 1652 -- Loop through entry families building the addition nodes 1653 1654 Ent := First_Entity (Concurrent_Type); 1655 Comp := First (Component_List); 1656 while Present (Ent) loop 1657 if Ekind (Ent) = E_Entry_Family then 1658 while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop 1659 Next (Comp); 1660 end loop; 1661 1662 Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); 1663 Hi := Type_High_Bound (Typ); 1664 Lo := Type_Low_Bound (Typ); 1665 Large := Is_Potentially_Large_Family 1666 (Base_Type (Typ), Concurrent_Type, Lo, Hi); 1667 Ecount := 1668 Make_Op_Add (Loc, 1669 Left_Opnd => Ecount, 1670 Right_Opnd => 1671 Family_Size (Loc, Hi, Lo, Concurrent_Type, Large)); 1672 end if; 1673 1674 Next_Entity (Ent); 1675 end loop; 1676 1677 return Ecount; 1678 end Build_Entry_Count_Expression; 1679 1680 ----------------------- 1681 -- Build_Entry_Names -- 1682 ----------------------- 1683 1684 procedure Build_Entry_Names 1685 (Obj_Ref : Node_Id; 1686 Obj_Typ : Entity_Id; 1687 Stmts : List_Id) 1688 is 1689 Loc : constant Source_Ptr := Sloc (Obj_Ref); 1690 Data : Entity_Id := Empty; 1691 Index : Entity_Id := Empty; 1692 Typ : Entity_Id := Obj_Typ; 1693 1694 procedure Build_Entry_Name (Comp_Id : Entity_Id); 1695 -- Given an entry [family], create a static string which denotes the 1696 -- name of Comp_Id and assign it to the underlying data structure which 1697 -- contains the entry names of a concurrent object. 1698 1699 function Object_Reference return Node_Id; 1700 -- Return a reference to field _object or _task_id depending on the 1701 -- concurrent object being processed. 1702 1703 ---------------------- 1704 -- Build_Entry_Name -- 1705 ---------------------- 1706 1707 procedure Build_Entry_Name (Comp_Id : Entity_Id) is 1708 function Build_Range (Def : Node_Id) return Node_Id; 1709 -- Given a discrete subtype definition of an entry family, generate a 1710 -- range node which covers the range of Def's type. 1711 1712 procedure Create_Index_And_Data; 1713 -- Generate the declarations of variables Index and Data. Subsequent 1714 -- calls do nothing. 1715 1716 function Increment_Index return Node_Id; 1717 -- Increment the index used in the assignment of string names to the 1718 -- Data array. 1719 1720 function Name_Declaration (Def_Id : Entity_Id) return Node_Id; 1721 -- Given the name of a temporary variable, create the following 1722 -- declaration for it: 1723 -- 1724 -- Def_Id : aliased constant String := <String_Name_From_Buffer>; 1725 1726 function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id; 1727 -- Given the name of a temporary variable, place it in the array of 1728 -- string names. Generate: 1729 -- 1730 -- Data (Index) := Def_Id'Unchecked_Access; 1731 1732 ----------------- 1733 -- Build_Range -- 1734 ----------------- 1735 1736 function Build_Range (Def : Node_Id) return Node_Id is 1737 High : Node_Id := Type_High_Bound (Etype (Def)); 1738 Low : Node_Id := Type_Low_Bound (Etype (Def)); 1739 1740 begin 1741 -- If a bound references a discriminant, generate an identifier 1742 -- with the same name. Resolution will map it to the formals of 1743 -- the init proc. 1744 1745 if Is_Entity_Name (Low) 1746 and then Ekind (Entity (Low)) = E_Discriminant 1747 then 1748 Low := 1749 Make_Selected_Component (Loc, 1750 Prefix => New_Copy_Tree (Obj_Ref), 1751 Selector_Name => Make_Identifier (Loc, Chars (Low))); 1752 else 1753 Low := New_Copy_Tree (Low); 1754 end if; 1755 1756 if Is_Entity_Name (High) 1757 and then Ekind (Entity (High)) = E_Discriminant 1758 then 1759 High := 1760 Make_Selected_Component (Loc, 1761 Prefix => New_Copy_Tree (Obj_Ref), 1762 Selector_Name => Make_Identifier (Loc, Chars (High))); 1763 else 1764 High := New_Copy_Tree (High); 1765 end if; 1766 1767 return 1768 Make_Range (Loc, 1769 Low_Bound => Low, 1770 High_Bound => High); 1771 end Build_Range; 1772 1773 --------------------------- 1774 -- Create_Index_And_Data -- 1775 --------------------------- 1776 1777 procedure Create_Index_And_Data is 1778 begin 1779 if No (Index) and then No (Data) then 1780 declare 1781 Count : RE_Id; 1782 Data_Typ : RE_Id; 1783 Size : Entity_Id; 1784 1785 begin 1786 if Is_Protected_Type (Typ) then 1787 Count := RO_PE_Number_Of_Entries; 1788 Data_Typ := RE_Protected_Entry_Names_Array; 1789 else 1790 Count := RO_ST_Number_Of_Entries; 1791 Data_Typ := RE_Task_Entry_Names_Array; 1792 end if; 1793 1794 -- Step 1: Generate the declaration of the index variable: 1795 1796 -- Index : Entry_Index := 1; 1797 1798 Index := Make_Temporary (Loc, 'I'); 1799 1800 Append_To (Stmts, 1801 Make_Object_Declaration (Loc, 1802 Defining_Identifier => Index, 1803 Object_Definition => 1804 New_Occurrence_Of (RTE (RE_Entry_Index), Loc), 1805 Expression => Make_Integer_Literal (Loc, 1))); 1806 1807 -- Step 2: Generate the declaration of an array to house all 1808 -- names: 1809 1810 -- Size : constant Entry_Index := <Count> (Obj_Ref); 1811 -- Data : aliased <Data_Typ> := (1 .. Size => null); 1812 1813 Size := Make_Temporary (Loc, 'S'); 1814 1815 Append_To (Stmts, 1816 Make_Object_Declaration (Loc, 1817 Defining_Identifier => Size, 1818 Constant_Present => True, 1819 Object_Definition => 1820 New_Occurrence_Of (RTE (RE_Entry_Index), Loc), 1821 Expression => 1822 Make_Function_Call (Loc, 1823 Name => 1824 New_Occurrence_Of (RTE (Count), Loc), 1825 Parameter_Associations => 1826 New_List (Object_Reference)))); 1827 1828 Data := Make_Temporary (Loc, 'A'); 1829 1830 Append_To (Stmts, 1831 Make_Object_Declaration (Loc, 1832 Defining_Identifier => Data, 1833 Aliased_Present => True, 1834 Object_Definition => 1835 New_Occurrence_Of (RTE (Data_Typ), Loc), 1836 Expression => 1837 Make_Aggregate (Loc, 1838 Component_Associations => New_List ( 1839 Make_Component_Association (Loc, 1840 Choices => New_List ( 1841 Make_Range (Loc, 1842 Low_Bound => 1843 Make_Integer_Literal (Loc, 1), 1844 High_Bound => 1845 New_Occurrence_Of (Size, Loc))), 1846 Expression => Make_Null (Loc)))))); 1847 end; 1848 end if; 1849 end Create_Index_And_Data; 1850 1851 --------------------- 1852 -- Increment_Index -- 1853 --------------------- 1854 1855 function Increment_Index return Node_Id is 1856 begin 1857 return 1858 Make_Assignment_Statement (Loc, 1859 Name => New_Occurrence_Of (Index, Loc), 1860 Expression => 1861 Make_Op_Add (Loc, 1862 Left_Opnd => New_Occurrence_Of (Index, Loc), 1863 Right_Opnd => Make_Integer_Literal (Loc, 1))); 1864 end Increment_Index; 1865 1866 ---------------------- 1867 -- Name_Declaration -- 1868 ---------------------- 1869 1870 function Name_Declaration (Def_Id : Entity_Id) return Node_Id is 1871 begin 1872 return 1873 Make_Object_Declaration (Loc, 1874 Defining_Identifier => Def_Id, 1875 Aliased_Present => True, 1876 Constant_Present => True, 1877 Object_Definition => 1878 New_Occurrence_Of (Standard_String, Loc), 1879 Expression => 1880 Make_String_Literal (Loc, String_From_Name_Buffer)); 1881 end Name_Declaration; 1882 1883 -------------------- 1884 -- Set_Entry_Name -- 1885 -------------------- 1886 1887 function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id is 1888 begin 1889 return 1890 Make_Assignment_Statement (Loc, 1891 Name => 1892 Make_Indexed_Component (Loc, 1893 Prefix => New_Occurrence_Of (Data, Loc), 1894 Expressions => New_List (New_Occurrence_Of (Index, Loc))), 1895 1896 Expression => 1897 Make_Attribute_Reference (Loc, 1898 Prefix => New_Occurrence_Of (Def_Id, Loc), 1899 Attribute_Name => Name_Unchecked_Access)); 1900 end Set_Entry_Name; 1901 1902 -- Local variables 1903 1904 Temp_Id : Entity_Id; 1905 Subt_Def : Node_Id; 1906 1907 -- Start of processing for Build_Entry_Name 1908 1909 begin 1910 if Ekind (Comp_Id) = E_Entry_Family then 1911 Subt_Def := Discrete_Subtype_Definition (Parent (Comp_Id)); 1912 1913 Create_Index_And_Data; 1914 1915 -- Step 1: Create the string name of the entry family. 1916 -- Generate: 1917 -- Temp : aliased constant String := "name ()"; 1918 1919 Temp_Id := Make_Temporary (Loc, 'S'); 1920 Get_Name_String (Chars (Comp_Id)); 1921 Add_Char_To_Name_Buffer (' '); 1922 Add_Char_To_Name_Buffer ('('); 1923 Add_Char_To_Name_Buffer (')'); 1924 1925 Append_To (Stmts, Name_Declaration (Temp_Id)); 1926 1927 -- Generate: 1928 -- for Member in Family_Low .. Family_High loop 1929 -- Set_Entry_Name (...); 1930 -- Index := Index + 1; 1931 -- end loop; 1932 1933 Append_To (Stmts, 1934 Make_Loop_Statement (Loc, 1935 Iteration_Scheme => 1936 Make_Iteration_Scheme (Loc, 1937 Loop_Parameter_Specification => 1938 Make_Loop_Parameter_Specification (Loc, 1939 Defining_Identifier => 1940 Make_Temporary (Loc, 'L'), 1941 Discrete_Subtype_Definition => 1942 Build_Range (Subt_Def))), 1943 1944 Statements => New_List ( 1945 Set_Entry_Name (Temp_Id), 1946 Increment_Index), 1947 End_Label => Empty)); 1948 1949 -- Entry 1950 1951 else 1952 Create_Index_And_Data; 1953 1954 -- Step 1: Create the string name of the entry. Generate: 1955 -- Temp : aliased constant String := "name"; 1956 1957 Temp_Id := Make_Temporary (Loc, 'S'); 1958 Get_Name_String (Chars (Comp_Id)); 1959 1960 Append_To (Stmts, Name_Declaration (Temp_Id)); 1961 1962 -- Step 2: Associate the string name with the underlying data 1963 -- structure. 1964 1965 Append_To (Stmts, Set_Entry_Name (Temp_Id)); 1966 Append_To (Stmts, Increment_Index); 1967 end if; 1968 end Build_Entry_Name; 1969 1970 ---------------------- 1971 -- Object_Reference -- 1972 ---------------------- 1973 1974 function Object_Reference return Node_Id is 1975 Conc_Typ : constant Entity_Id := Corresponding_Record_Type (Typ); 1976 Field : Name_Id; 1977 Ref : Node_Id; 1978 1979 begin 1980 if Is_Protected_Type (Typ) then 1981 Field := Name_uObject; 1982 else 1983 Field := Name_uTask_Id; 1984 end if; 1985 1986 Ref := 1987 Make_Selected_Component (Loc, 1988 Prefix => 1989 Unchecked_Convert_To (Conc_Typ, New_Copy_Tree (Obj_Ref)), 1990 Selector_Name => Make_Identifier (Loc, Field)); 1991 1992 if Is_Protected_Type (Typ) then 1993 Ref := 1994 Make_Attribute_Reference (Loc, 1995 Prefix => Ref, 1996 Attribute_Name => Name_Unchecked_Access); 1997 end if; 1998 1999 return Ref; 2000 end Object_Reference; 2001 2002 -- Local variables 2003 2004 Comp : Node_Id; 2005 Proc : RE_Id; 2006 2007 -- Start of processing for Build_Entry_Names 2008 2009 begin 2010 -- Retrieve the original concurrent type 2011 2012 if Is_Concurrent_Record_Type (Typ) then 2013 Typ := Corresponding_Concurrent_Type (Typ); 2014 end if; 2015 2016 pragma Assert (Is_Concurrent_Type (Typ)); 2017 2018 -- Nothing to do if the type has no entries 2019 2020 if not Has_Entries (Typ) then 2021 return; 2022 end if; 2023 2024 -- Avoid generating entry names for a protected type with only one entry 2025 2026 if Is_Protected_Type (Typ) 2027 and then Find_Protection_Type (Base_Type (Typ)) /= 2028 RTE (RE_Protection_Entries) 2029 then 2030 return; 2031 end if; 2032 2033 -- Step 1: Populate the array with statically generated strings denoting 2034 -- entries and entry family names. 2035 2036 Comp := First_Entity (Typ); 2037 while Present (Comp) loop 2038 if Comes_From_Source (Comp) 2039 and then Ekind_In (Comp, E_Entry, E_Entry_Family) 2040 then 2041 Build_Entry_Name (Comp); 2042 end if; 2043 2044 Next_Entity (Comp); 2045 end loop; 2046 2047 -- Step 2: Associate the array with the related concurrent object: 2048 2049 -- Set_Entry_Names (Obj_Ref, <Data>'Unchecked_Access); 2050 2051 if Present (Data) then 2052 if Is_Protected_Type (Typ) then 2053 Proc := RO_PE_Set_Entry_Names; 2054 else 2055 Proc := RO_ST_Set_Entry_Names; 2056 end if; 2057 2058 Append_To (Stmts, 2059 Make_Procedure_Call_Statement (Loc, 2060 Name => New_Occurrence_Of (RTE (Proc), Loc), 2061 Parameter_Associations => New_List ( 2062 Object_Reference, 2063 Make_Attribute_Reference (Loc, 2064 Prefix => New_Occurrence_Of (Data, Loc), 2065 Attribute_Name => Name_Unchecked_Access)))); 2066 end if; 2067 end Build_Entry_Names; 2068 2069 --------------------------- 2070 -- Build_Parameter_Block -- 2071 --------------------------- 2072 2073 function Build_Parameter_Block 2074 (Loc : Source_Ptr; 2075 Actuals : List_Id; 2076 Formals : List_Id; 2077 Decls : List_Id) return Entity_Id 2078 is 2079 Actual : Entity_Id; 2080 Comp_Nam : Node_Id; 2081 Comps : List_Id; 2082 Formal : Entity_Id; 2083 Has_Comp : Boolean := False; 2084 Rec_Nam : Node_Id; 2085 2086 begin 2087 Actual := First (Actuals); 2088 Comps := New_List; 2089 Formal := Defining_Identifier (First (Formals)); 2090 2091 while Present (Actual) loop 2092 if not Is_Controlling_Actual (Actual) then 2093 2094 -- Generate: 2095 -- type Ann is access all <actual-type> 2096 2097 Comp_Nam := Make_Temporary (Loc, 'A'); 2098 Set_Is_Param_Block_Component_Type (Comp_Nam); 2099 2100 Append_To (Decls, 2101 Make_Full_Type_Declaration (Loc, 2102 Defining_Identifier => Comp_Nam, 2103 Type_Definition => 2104 Make_Access_To_Object_Definition (Loc, 2105 All_Present => True, 2106 Constant_Present => Ekind (Formal) = E_In_Parameter, 2107 Subtype_Indication => 2108 New_Occurrence_Of (Etype (Actual), Loc)))); 2109 2110 -- Generate: 2111 -- Param : Ann; 2112 2113 Append_To (Comps, 2114 Make_Component_Declaration (Loc, 2115 Defining_Identifier => 2116 Make_Defining_Identifier (Loc, Chars (Formal)), 2117 Component_Definition => 2118 Make_Component_Definition (Loc, 2119 Aliased_Present => 2120 False, 2121 Subtype_Indication => 2122 New_Occurrence_Of (Comp_Nam, Loc)))); 2123 2124 Has_Comp := True; 2125 end if; 2126 2127 Next_Actual (Actual); 2128 Next_Formal_With_Extras (Formal); 2129 end loop; 2130 2131 Rec_Nam := Make_Temporary (Loc, 'P'); 2132 2133 if Has_Comp then 2134 2135 -- Generate: 2136 -- type Pnn is record 2137 -- Param1 : Ann1; 2138 -- ... 2139 -- ParamN : AnnN; 2140 2141 -- where Pnn is a parameter wrapping record, Param1 .. ParamN are 2142 -- the original parameter names and Ann1 .. AnnN are the access to 2143 -- actual types. 2144 2145 Append_To (Decls, 2146 Make_Full_Type_Declaration (Loc, 2147 Defining_Identifier => 2148 Rec_Nam, 2149 Type_Definition => 2150 Make_Record_Definition (Loc, 2151 Component_List => 2152 Make_Component_List (Loc, Comps)))); 2153 else 2154 -- Generate: 2155 -- type Pnn is null record; 2156 2157 Append_To (Decls, 2158 Make_Full_Type_Declaration (Loc, 2159 Defining_Identifier => 2160 Rec_Nam, 2161 Type_Definition => 2162 Make_Record_Definition (Loc, 2163 Null_Present => True, 2164 Component_List => Empty))); 2165 end if; 2166 2167 return Rec_Nam; 2168 end Build_Parameter_Block; 2169 2170 -------------------------------------- 2171 -- Build_Renamed_Formal_Declaration -- 2172 -------------------------------------- 2173 2174 function Build_Renamed_Formal_Declaration 2175 (New_F : Entity_Id; 2176 Formal : Entity_Id; 2177 Comp : Entity_Id; 2178 Renamed_Formal : Node_Id) return Node_Id 2179 is 2180 Loc : constant Source_Ptr := Sloc (New_F); 2181 Decl : Node_Id; 2182 2183 begin 2184 -- If the formal is a tagged incomplete type, it is already passed 2185 -- by reference, so it is sufficient to rename the pointer component 2186 -- that corresponds to the actual. Otherwise we need to dereference 2187 -- the pointer component to obtain the actual. 2188 2189 if Is_Incomplete_Type (Etype (Formal)) 2190 and then Is_Tagged_Type (Etype (Formal)) 2191 then 2192 Decl := 2193 Make_Object_Renaming_Declaration (Loc, 2194 Defining_Identifier => New_F, 2195 Subtype_Mark => New_Occurrence_Of (Etype (Comp), Loc), 2196 Name => Renamed_Formal); 2197 2198 else 2199 Decl := 2200 Make_Object_Renaming_Declaration (Loc, 2201 Defining_Identifier => New_F, 2202 Subtype_Mark => New_Occurrence_Of (Etype (Formal), Loc), 2203 Name => 2204 Make_Explicit_Dereference (Loc, Renamed_Formal)); 2205 end if; 2206 2207 return Decl; 2208 end Build_Renamed_Formal_Declaration; 2209 2210 -------------------------- 2211 -- Build_Wrapper_Bodies -- 2212 -------------------------- 2213 2214 procedure Build_Wrapper_Bodies 2215 (Loc : Source_Ptr; 2216 Typ : Entity_Id; 2217 N : Node_Id) 2218 is 2219 Rec_Typ : Entity_Id; 2220 2221 function Build_Wrapper_Body 2222 (Loc : Source_Ptr; 2223 Subp_Id : Entity_Id; 2224 Obj_Typ : Entity_Id; 2225 Formals : List_Id) return Node_Id; 2226 -- Ada 2005 (AI-345): Build the body that wraps a primitive operation 2227 -- associated with a protected or task type. Subp_Id is the subprogram 2228 -- name which will be wrapped. Obj_Typ is the type of the new formal 2229 -- parameter which handles dispatching and object notation. Formals are 2230 -- the original formals of Subp_Id which will be explicitly replicated. 2231 2232 ------------------------ 2233 -- Build_Wrapper_Body -- 2234 ------------------------ 2235 2236 function Build_Wrapper_Body 2237 (Loc : Source_Ptr; 2238 Subp_Id : Entity_Id; 2239 Obj_Typ : Entity_Id; 2240 Formals : List_Id) return Node_Id 2241 is 2242 Body_Spec : Node_Id; 2243 2244 begin 2245 Body_Spec := Build_Wrapper_Spec (Subp_Id, Obj_Typ, Formals); 2246 2247 -- The subprogram is not overriding or is not a primitive declared 2248 -- between two views. 2249 2250 if No (Body_Spec) then 2251 return Empty; 2252 end if; 2253 2254 declare 2255 Actuals : List_Id := No_List; 2256 Conv_Id : Node_Id; 2257 First_Form : Node_Id; 2258 Formal : Node_Id; 2259 Nam : Node_Id; 2260 2261 begin 2262 -- Map formals to actuals. Use the list built for the wrapper 2263 -- spec, skipping the object notation parameter. 2264 2265 First_Form := First (Parameter_Specifications (Body_Spec)); 2266 2267 Formal := First_Form; 2268 Next (Formal); 2269 2270 if Present (Formal) then 2271 Actuals := New_List; 2272 while Present (Formal) loop 2273 Append_To (Actuals, 2274 Make_Identifier (Loc, 2275 Chars => Chars (Defining_Identifier (Formal)))); 2276 Next (Formal); 2277 end loop; 2278 end if; 2279 2280 -- Special processing for primitives declared between a private 2281 -- type and its completion: the wrapper needs a properly typed 2282 -- parameter if the wrapped operation has a controlling first 2283 -- parameter. Note that this might not be the case for a function 2284 -- with a controlling result. 2285 2286 if Is_Private_Primitive_Subprogram (Subp_Id) then 2287 if No (Actuals) then 2288 Actuals := New_List; 2289 end if; 2290 2291 if Is_Controlling_Formal (First_Formal (Subp_Id)) then 2292 Prepend_To (Actuals, 2293 Unchecked_Convert_To 2294 (Corresponding_Concurrent_Type (Obj_Typ), 2295 Make_Identifier (Loc, Name_uO))); 2296 2297 else 2298 Prepend_To (Actuals, 2299 Make_Identifier (Loc, 2300 Chars => Chars (Defining_Identifier (First_Form)))); 2301 end if; 2302 2303 Nam := New_Occurrence_Of (Subp_Id, Loc); 2304 else 2305 -- An access-to-variable object parameter requires an explicit 2306 -- dereference in the unchecked conversion. This case occurs 2307 -- when a protected entry wrapper must override an interface 2308 -- level procedure with interface access as first parameter. 2309 2310 -- O.all.Subp_Id (Formal_1, ..., Formal_N) 2311 2312 if Nkind (Parameter_Type (First_Form)) = 2313 N_Access_Definition 2314 then 2315 Conv_Id := 2316 Make_Explicit_Dereference (Loc, 2317 Prefix => Make_Identifier (Loc, Name_uO)); 2318 else 2319 Conv_Id := Make_Identifier (Loc, Name_uO); 2320 end if; 2321 2322 Nam := 2323 Make_Selected_Component (Loc, 2324 Prefix => 2325 Unchecked_Convert_To 2326 (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id), 2327 Selector_Name => New_Occurrence_Of (Subp_Id, Loc)); 2328 end if; 2329 2330 -- Create the subprogram body. For a function, the call to the 2331 -- actual subprogram has to be converted to the corresponding 2332 -- record if it is a controlling result. 2333 2334 if Ekind (Subp_Id) = E_Function then 2335 declare 2336 Res : Node_Id; 2337 2338 begin 2339 Res := 2340 Make_Function_Call (Loc, 2341 Name => Nam, 2342 Parameter_Associations => Actuals); 2343 2344 if Has_Controlling_Result (Subp_Id) then 2345 Res := 2346 Unchecked_Convert_To 2347 (Corresponding_Record_Type (Etype (Subp_Id)), Res); 2348 end if; 2349 2350 return 2351 Make_Subprogram_Body (Loc, 2352 Specification => Body_Spec, 2353 Declarations => Empty_List, 2354 Handled_Statement_Sequence => 2355 Make_Handled_Sequence_Of_Statements (Loc, 2356 Statements => New_List ( 2357 Make_Simple_Return_Statement (Loc, Res)))); 2358 end; 2359 2360 else 2361 return 2362 Make_Subprogram_Body (Loc, 2363 Specification => Body_Spec, 2364 Declarations => Empty_List, 2365 Handled_Statement_Sequence => 2366 Make_Handled_Sequence_Of_Statements (Loc, 2367 Statements => New_List ( 2368 Make_Procedure_Call_Statement (Loc, 2369 Name => Nam, 2370 Parameter_Associations => Actuals)))); 2371 end if; 2372 end; 2373 end Build_Wrapper_Body; 2374 2375 -- Start of processing for Build_Wrapper_Bodies 2376 2377 begin 2378 if Is_Concurrent_Type (Typ) then 2379 Rec_Typ := Corresponding_Record_Type (Typ); 2380 else 2381 Rec_Typ := Typ; 2382 end if; 2383 2384 -- Generate wrapper bodies for a concurrent type which implements an 2385 -- interface. 2386 2387 if Present (Interfaces (Rec_Typ)) then 2388 declare 2389 Insert_Nod : Node_Id; 2390 Prim : Entity_Id; 2391 Prim_Elmt : Elmt_Id; 2392 Prim_Decl : Node_Id; 2393 Subp : Entity_Id; 2394 Wrap_Body : Node_Id; 2395 Wrap_Id : Entity_Id; 2396 2397 begin 2398 Insert_Nod := N; 2399 2400 -- Examine all primitive operations of the corresponding record 2401 -- type, looking for wrapper specs. Generate bodies in order to 2402 -- complete them. 2403 2404 Prim_Elmt := First_Elmt (Primitive_Operations (Rec_Typ)); 2405 while Present (Prim_Elmt) loop 2406 Prim := Node (Prim_Elmt); 2407 2408 if (Ekind (Prim) = E_Function 2409 or else Ekind (Prim) = E_Procedure) 2410 and then Is_Primitive_Wrapper (Prim) 2411 then 2412 Subp := Wrapped_Entity (Prim); 2413 Prim_Decl := Parent (Parent (Prim)); 2414 2415 Wrap_Body := 2416 Build_Wrapper_Body (Loc, 2417 Subp_Id => Subp, 2418 Obj_Typ => Rec_Typ, 2419 Formals => Parameter_Specifications (Parent (Subp))); 2420 Wrap_Id := Defining_Unit_Name (Specification (Wrap_Body)); 2421 2422 Set_Corresponding_Spec (Wrap_Body, Prim); 2423 Set_Corresponding_Body (Prim_Decl, Wrap_Id); 2424 2425 Insert_After (Insert_Nod, Wrap_Body); 2426 Insert_Nod := Wrap_Body; 2427 2428 Analyze (Wrap_Body); 2429 end if; 2430 2431 Next_Elmt (Prim_Elmt); 2432 end loop; 2433 end; 2434 end if; 2435 end Build_Wrapper_Bodies; 2436 2437 ------------------------ 2438 -- Build_Wrapper_Spec -- 2439 ------------------------ 2440 2441 function Build_Wrapper_Spec 2442 (Subp_Id : Entity_Id; 2443 Obj_Typ : Entity_Id; 2444 Formals : List_Id) return Node_Id 2445 is 2446 Loc : constant Source_Ptr := Sloc (Subp_Id); 2447 First_Param : Node_Id; 2448 Iface : Entity_Id; 2449 Iface_Elmt : Elmt_Id; 2450 Iface_Op : Entity_Id; 2451 Iface_Op_Elmt : Elmt_Id; 2452 2453 function Overriding_Possible 2454 (Iface_Op : Entity_Id; 2455 Wrapper : Entity_Id) return Boolean; 2456 -- Determine whether a primitive operation can be overridden by Wrapper. 2457 -- Iface_Op is the candidate primitive operation of an interface type, 2458 -- Wrapper is the generated entry wrapper. 2459 2460 function Replicate_Formals 2461 (Loc : Source_Ptr; 2462 Formals : List_Id) return List_Id; 2463 -- An explicit parameter replication is required due to the Is_Entry_ 2464 -- Formal flag being set for all the formals of an entry. The explicit 2465 -- replication removes the flag that would otherwise cause a different 2466 -- path of analysis. 2467 2468 ------------------------- 2469 -- Overriding_Possible -- 2470 ------------------------- 2471 2472 function Overriding_Possible 2473 (Iface_Op : Entity_Id; 2474 Wrapper : Entity_Id) return Boolean 2475 is 2476 Iface_Op_Spec : constant Node_Id := Parent (Iface_Op); 2477 Wrapper_Spec : constant Node_Id := Parent (Wrapper); 2478 2479 function Type_Conformant_Parameters 2480 (Iface_Op_Params : List_Id; 2481 Wrapper_Params : List_Id) return Boolean; 2482 -- Determine whether the parameters of the generated entry wrapper 2483 -- and those of a primitive operation are type conformant. During 2484 -- this check, the first parameter of the primitive operation is 2485 -- skipped if it is a controlling argument: protected functions 2486 -- may have a controlling result. 2487 2488 -------------------------------- 2489 -- Type_Conformant_Parameters -- 2490 -------------------------------- 2491 2492 function Type_Conformant_Parameters 2493 (Iface_Op_Params : List_Id; 2494 Wrapper_Params : List_Id) return Boolean 2495 is 2496 Iface_Op_Param : Node_Id; 2497 Iface_Op_Typ : Entity_Id; 2498 Wrapper_Param : Node_Id; 2499 Wrapper_Typ : Entity_Id; 2500 2501 begin 2502 -- Skip the first (controlling) parameter of primitive operation 2503 2504 Iface_Op_Param := First (Iface_Op_Params); 2505 2506 if Present (First_Formal (Iface_Op)) 2507 and then Is_Controlling_Formal (First_Formal (Iface_Op)) 2508 then 2509 Iface_Op_Param := Next (Iface_Op_Param); 2510 end if; 2511 2512 Wrapper_Param := First (Wrapper_Params); 2513 while Present (Iface_Op_Param) 2514 and then Present (Wrapper_Param) 2515 loop 2516 Iface_Op_Typ := Find_Parameter_Type (Iface_Op_Param); 2517 Wrapper_Typ := Find_Parameter_Type (Wrapper_Param); 2518 2519 -- The two parameters must be mode conformant 2520 2521 if not Conforming_Types 2522 (Iface_Op_Typ, Wrapper_Typ, Mode_Conformant) 2523 then 2524 return False; 2525 end if; 2526 2527 Next (Iface_Op_Param); 2528 Next (Wrapper_Param); 2529 end loop; 2530 2531 -- One of the lists is longer than the other 2532 2533 if Present (Iface_Op_Param) or else Present (Wrapper_Param) then 2534 return False; 2535 end if; 2536 2537 return True; 2538 end Type_Conformant_Parameters; 2539 2540 -- Start of processing for Overriding_Possible 2541 2542 begin 2543 if Chars (Iface_Op) /= Chars (Wrapper) then 2544 return False; 2545 end if; 2546 2547 -- If an inherited subprogram is implemented by a protected procedure 2548 -- or an entry, then the first parameter of the inherited subprogram 2549 -- must be of mode OUT or IN OUT, or access-to-variable parameter. 2550 2551 if Ekind (Iface_Op) = E_Procedure 2552 and then Present (Parameter_Specifications (Iface_Op_Spec)) 2553 then 2554 declare 2555 Obj_Param : constant Node_Id := 2556 First (Parameter_Specifications (Iface_Op_Spec)); 2557 begin 2558 if not Out_Present (Obj_Param) 2559 and then Nkind (Parameter_Type (Obj_Param)) /= 2560 N_Access_Definition 2561 then 2562 return False; 2563 end if; 2564 end; 2565 end if; 2566 2567 return 2568 Type_Conformant_Parameters ( 2569 Parameter_Specifications (Iface_Op_Spec), 2570 Parameter_Specifications (Wrapper_Spec)); 2571 end Overriding_Possible; 2572 2573 ----------------------- 2574 -- Replicate_Formals -- 2575 ----------------------- 2576 2577 function Replicate_Formals 2578 (Loc : Source_Ptr; 2579 Formals : List_Id) return List_Id 2580 is 2581 New_Formals : constant List_Id := New_List; 2582 Formal : Node_Id; 2583 Param_Type : Node_Id; 2584 2585 begin 2586 Formal := First (Formals); 2587 2588 -- Skip the object parameter when dealing with primitives declared 2589 -- between two views. 2590 2591 if Is_Private_Primitive_Subprogram (Subp_Id) 2592 and then not Has_Controlling_Result (Subp_Id) 2593 then 2594 Formal := Next (Formal); 2595 end if; 2596 2597 while Present (Formal) loop 2598 2599 -- Create an explicit copy of the entry parameter 2600 2601 -- When creating the wrapper subprogram for a primitive operation 2602 -- of a protected interface we must construct an equivalent 2603 -- signature to that of the overriding operation. For regular 2604 -- parameters we can just use the type of the formal, but for 2605 -- access to subprogram parameters we need to reanalyze the 2606 -- parameter type to create local entities for the signature of 2607 -- the subprogram type. Using the entities of the overriding 2608 -- subprogram will result in out-of-scope errors in the back-end. 2609 2610 if Nkind (Parameter_Type (Formal)) = N_Access_Definition then 2611 Param_Type := Copy_Separate_Tree (Parameter_Type (Formal)); 2612 else 2613 Param_Type := 2614 New_Occurrence_Of (Etype (Parameter_Type (Formal)), Loc); 2615 end if; 2616 2617 Append_To (New_Formals, 2618 Make_Parameter_Specification (Loc, 2619 Defining_Identifier => 2620 Make_Defining_Identifier (Loc, 2621 Chars => Chars 2622 (Defining_Identifier (Formal))), 2623 In_Present => In_Present (Formal), 2624 Out_Present => Out_Present (Formal), 2625 Null_Exclusion_Present => Null_Exclusion_Present (Formal), 2626 Parameter_Type => Param_Type)); 2627 2628 Next (Formal); 2629 end loop; 2630 2631 return New_Formals; 2632 end Replicate_Formals; 2633 2634 -- Start of processing for Build_Wrapper_Spec 2635 2636 begin 2637 -- No point in building wrappers for untagged concurrent types 2638 2639 pragma Assert (Is_Tagged_Type (Obj_Typ)); 2640 2641 -- An entry or a protected procedure can override a routine where the 2642 -- controlling formal is either IN OUT, OUT or is of access-to-variable 2643 -- type. Since the wrapper must have the exact same signature as that of 2644 -- the overridden subprogram, we try to find the overriding candidate 2645 -- and use its controlling formal. 2646 2647 First_Param := Empty; 2648 2649 -- Check every implemented interface 2650 2651 if Present (Interfaces (Obj_Typ)) then 2652 Iface_Elmt := First_Elmt (Interfaces (Obj_Typ)); 2653 Search : while Present (Iface_Elmt) loop 2654 Iface := Node (Iface_Elmt); 2655 2656 -- Check every interface primitive 2657 2658 if Present (Primitive_Operations (Iface)) then 2659 Iface_Op_Elmt := First_Elmt (Primitive_Operations (Iface)); 2660 while Present (Iface_Op_Elmt) loop 2661 Iface_Op := Node (Iface_Op_Elmt); 2662 2663 -- Ignore predefined primitives 2664 2665 if not Is_Predefined_Dispatching_Operation (Iface_Op) then 2666 Iface_Op := Ultimate_Alias (Iface_Op); 2667 2668 -- The current primitive operation can be overridden by 2669 -- the generated entry wrapper. 2670 2671 if Overriding_Possible (Iface_Op, Subp_Id) then 2672 First_Param := 2673 First (Parameter_Specifications (Parent (Iface_Op))); 2674 2675 exit Search; 2676 end if; 2677 end if; 2678 2679 Next_Elmt (Iface_Op_Elmt); 2680 end loop; 2681 end if; 2682 2683 Next_Elmt (Iface_Elmt); 2684 end loop Search; 2685 end if; 2686 2687 -- Ada 2012 (AI05-0090-1): If no interface primitive is covered by 2688 -- this subprogram and this is not a primitive declared between two 2689 -- views then force the generation of a wrapper. As an optimization, 2690 -- previous versions of the frontend avoid generating the wrapper; 2691 -- however, the wrapper facilitates locating and reporting an error 2692 -- when a duplicate declaration is found later. See example in 2693 -- AI05-0090-1. 2694 2695 if No (First_Param) 2696 and then not Is_Private_Primitive_Subprogram (Subp_Id) 2697 then 2698 if Is_Task_Type 2699 (Corresponding_Concurrent_Type (Obj_Typ)) 2700 then 2701 First_Param := 2702 Make_Parameter_Specification (Loc, 2703 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), 2704 In_Present => True, 2705 Out_Present => False, 2706 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); 2707 2708 -- For entries and procedures of protected types the mode of 2709 -- the controlling argument must be in-out. 2710 2711 else 2712 First_Param := 2713 Make_Parameter_Specification (Loc, 2714 Defining_Identifier => 2715 Make_Defining_Identifier (Loc, 2716 Chars => Name_uO), 2717 In_Present => True, 2718 Out_Present => (Ekind (Subp_Id) /= E_Function), 2719 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); 2720 end if; 2721 end if; 2722 2723 declare 2724 Wrapper_Id : constant Entity_Id := 2725 Make_Defining_Identifier (Loc, Chars (Subp_Id)); 2726 New_Formals : List_Id; 2727 Obj_Param : Node_Id; 2728 Obj_Param_Typ : Entity_Id; 2729 2730 begin 2731 -- Minimum decoration is needed to catch the entity in 2732 -- Sem_Ch6.Override_Dispatching_Operation. 2733 2734 if Ekind (Subp_Id) = E_Function then 2735 Set_Ekind (Wrapper_Id, E_Function); 2736 else 2737 Set_Ekind (Wrapper_Id, E_Procedure); 2738 end if; 2739 2740 Set_Is_Primitive_Wrapper (Wrapper_Id); 2741 Set_Wrapped_Entity (Wrapper_Id, Subp_Id); 2742 Set_Is_Private_Primitive (Wrapper_Id, 2743 Is_Private_Primitive_Subprogram (Subp_Id)); 2744 2745 -- Process the formals 2746 2747 New_Formals := Replicate_Formals (Loc, Formals); 2748 2749 -- A function with a controlling result and no first controlling 2750 -- formal needs no additional parameter. 2751 2752 if Has_Controlling_Result (Subp_Id) 2753 and then 2754 (No (First_Formal (Subp_Id)) 2755 or else not Is_Controlling_Formal (First_Formal (Subp_Id))) 2756 then 2757 null; 2758 2759 -- Routine Subp_Id has been found to override an interface primitive. 2760 -- If the interface operation has an access parameter, create a copy 2761 -- of it, with the same null exclusion indicator if present. 2762 2763 elsif Present (First_Param) then 2764 if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then 2765 Obj_Param_Typ := 2766 Make_Access_Definition (Loc, 2767 Subtype_Mark => 2768 New_Occurrence_Of (Obj_Typ, Loc), 2769 Null_Exclusion_Present => 2770 Null_Exclusion_Present (Parameter_Type (First_Param)), 2771 Constant_Present => 2772 Constant_Present (Parameter_Type (First_Param))); 2773 else 2774 Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc); 2775 end if; 2776 2777 Obj_Param := 2778 Make_Parameter_Specification (Loc, 2779 Defining_Identifier => 2780 Make_Defining_Identifier (Loc, 2781 Chars => Name_uO), 2782 In_Present => In_Present (First_Param), 2783 Out_Present => Out_Present (First_Param), 2784 Parameter_Type => Obj_Param_Typ); 2785 2786 Prepend_To (New_Formals, Obj_Param); 2787 2788 -- If we are dealing with a primitive declared between two views, 2789 -- implemented by a synchronized operation, we need to create 2790 -- a default parameter. The mode of the parameter must match that 2791 -- of the primitive operation. 2792 2793 else 2794 pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id)); 2795 Obj_Param := 2796 Make_Parameter_Specification (Loc, 2797 Defining_Identifier => 2798 Make_Defining_Identifier (Loc, Name_uO), 2799 In_Present => In_Present (Parent (First_Entity (Subp_Id))), 2800 Out_Present => Ekind (Subp_Id) /= E_Function, 2801 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)); 2802 Prepend_To (New_Formals, Obj_Param); 2803 end if; 2804 2805 -- Build the final spec. If it is a function with a controlling 2806 -- result, it is a primitive operation of the corresponding 2807 -- record type, so mark the spec accordingly. 2808 2809 if Ekind (Subp_Id) = E_Function then 2810 declare 2811 Res_Def : Node_Id; 2812 2813 begin 2814 if Has_Controlling_Result (Subp_Id) then 2815 Res_Def := 2816 New_Occurrence_Of 2817 (Corresponding_Record_Type (Etype (Subp_Id)), Loc); 2818 else 2819 Res_Def := New_Copy (Result_Definition (Parent (Subp_Id))); 2820 end if; 2821 2822 return 2823 Make_Function_Specification (Loc, 2824 Defining_Unit_Name => Wrapper_Id, 2825 Parameter_Specifications => New_Formals, 2826 Result_Definition => Res_Def); 2827 end; 2828 else 2829 return 2830 Make_Procedure_Specification (Loc, 2831 Defining_Unit_Name => Wrapper_Id, 2832 Parameter_Specifications => New_Formals); 2833 end if; 2834 end; 2835 end Build_Wrapper_Spec; 2836 2837 ------------------------- 2838 -- Build_Wrapper_Specs -- 2839 ------------------------- 2840 2841 procedure Build_Wrapper_Specs 2842 (Loc : Source_Ptr; 2843 Typ : Entity_Id; 2844 N : in out Node_Id) 2845 is 2846 Def : Node_Id; 2847 Rec_Typ : Entity_Id; 2848 procedure Scan_Declarations (L : List_Id); 2849 -- Common processing for visible and private declarations 2850 -- of a protected type. 2851 2852 procedure Scan_Declarations (L : List_Id) is 2853 Decl : Node_Id; 2854 Wrap_Decl : Node_Id; 2855 Wrap_Spec : Node_Id; 2856 2857 begin 2858 if No (L) then 2859 return; 2860 end if; 2861 2862 Decl := First (L); 2863 while Present (Decl) loop 2864 Wrap_Spec := Empty; 2865 2866 if Nkind (Decl) = N_Entry_Declaration 2867 and then Ekind (Defining_Identifier (Decl)) = E_Entry 2868 then 2869 Wrap_Spec := 2870 Build_Wrapper_Spec 2871 (Subp_Id => Defining_Identifier (Decl), 2872 Obj_Typ => Rec_Typ, 2873 Formals => Parameter_Specifications (Decl)); 2874 2875 elsif Nkind (Decl) = N_Subprogram_Declaration then 2876 Wrap_Spec := 2877 Build_Wrapper_Spec 2878 (Subp_Id => Defining_Unit_Name (Specification (Decl)), 2879 Obj_Typ => Rec_Typ, 2880 Formals => 2881 Parameter_Specifications (Specification (Decl))); 2882 end if; 2883 2884 if Present (Wrap_Spec) then 2885 Wrap_Decl := 2886 Make_Subprogram_Declaration (Loc, 2887 Specification => Wrap_Spec); 2888 2889 Insert_After (N, Wrap_Decl); 2890 N := Wrap_Decl; 2891 2892 Analyze (Wrap_Decl); 2893 end if; 2894 2895 Next (Decl); 2896 end loop; 2897 end Scan_Declarations; 2898 2899 -- start of processing for Build_Wrapper_Specs 2900 2901 begin 2902 if Is_Protected_Type (Typ) then 2903 Def := Protected_Definition (Parent (Typ)); 2904 else pragma Assert (Is_Task_Type (Typ)); 2905 Def := Task_Definition (Parent (Typ)); 2906 end if; 2907 2908 Rec_Typ := Corresponding_Record_Type (Typ); 2909 2910 -- Generate wrapper specs for a concurrent type which implements an 2911 -- interface. Operations in both the visible and private parts may 2912 -- implement progenitor operations. 2913 2914 if Present (Interfaces (Rec_Typ)) and then Present (Def) then 2915 Scan_Declarations (Visible_Declarations (Def)); 2916 Scan_Declarations (Private_Declarations (Def)); 2917 end if; 2918 end Build_Wrapper_Specs; 2919 2920 --------------------------- 2921 -- Build_Find_Body_Index -- 2922 --------------------------- 2923 2924 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is 2925 Loc : constant Source_Ptr := Sloc (Typ); 2926 Ent : Entity_Id; 2927 E_Typ : Entity_Id; 2928 Has_F : Boolean := False; 2929 Index : Nat; 2930 If_St : Node_Id := Empty; 2931 Lo : Node_Id; 2932 Hi : Node_Id; 2933 Decls : List_Id := New_List; 2934 Ret : Node_Id; 2935 Spec : Node_Id; 2936 Siz : Node_Id := Empty; 2937 2938 procedure Add_If_Clause (Expr : Node_Id); 2939 -- Add test for range of current entry 2940 2941 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 2942 -- If a bound of an entry is given by a discriminant, retrieve the 2943 -- actual value of the discriminant from the enclosing object. 2944 2945 ------------------- 2946 -- Add_If_Clause -- 2947 ------------------- 2948 2949 procedure Add_If_Clause (Expr : Node_Id) is 2950 Cond : Node_Id; 2951 Stats : constant List_Id := 2952 New_List ( 2953 Make_Simple_Return_Statement (Loc, 2954 Expression => Make_Integer_Literal (Loc, Index + 1))); 2955 2956 begin 2957 -- Index for current entry body 2958 2959 Index := Index + 1; 2960 2961 -- Compute total length of entry queues so far 2962 2963 if No (Siz) then 2964 Siz := Expr; 2965 else 2966 Siz := 2967 Make_Op_Add (Loc, 2968 Left_Opnd => Siz, 2969 Right_Opnd => Expr); 2970 end if; 2971 2972 Cond := 2973 Make_Op_Le (Loc, 2974 Left_Opnd => Make_Identifier (Loc, Name_uE), 2975 Right_Opnd => Siz); 2976 2977 -- Map entry queue indexes in the range of the current family 2978 -- into the current index, that designates the entry body. 2979 2980 if No (If_St) then 2981 If_St := 2982 Make_Implicit_If_Statement (Typ, 2983 Condition => Cond, 2984 Then_Statements => Stats, 2985 Elsif_Parts => New_List); 2986 Ret := If_St; 2987 2988 else 2989 Append_To (Elsif_Parts (If_St), 2990 Make_Elsif_Part (Loc, 2991 Condition => Cond, 2992 Then_Statements => Stats)); 2993 end if; 2994 end Add_If_Clause; 2995 2996 ------------------------------ 2997 -- Convert_Discriminant_Ref -- 2998 ------------------------------ 2999 3000 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 3001 B : Node_Id; 3002 3003 begin 3004 if Is_Entity_Name (Bound) 3005 and then Ekind (Entity (Bound)) = E_Discriminant 3006 then 3007 B := 3008 Make_Selected_Component (Loc, 3009 Prefix => 3010 Unchecked_Convert_To (Corresponding_Record_Type (Typ), 3011 Make_Explicit_Dereference (Loc, 3012 Make_Identifier (Loc, Name_uObject))), 3013 Selector_Name => Make_Identifier (Loc, Chars (Bound))); 3014 Set_Etype (B, Etype (Entity (Bound))); 3015 else 3016 B := New_Copy_Tree (Bound); 3017 end if; 3018 3019 return B; 3020 end Convert_Discriminant_Ref; 3021 3022 -- Start of processing for Build_Find_Body_Index 3023 3024 begin 3025 Spec := Build_Find_Body_Index_Spec (Typ); 3026 3027 Ent := First_Entity (Typ); 3028 while Present (Ent) loop 3029 if Ekind (Ent) = E_Entry_Family then 3030 Has_F := True; 3031 exit; 3032 end if; 3033 3034 Next_Entity (Ent); 3035 end loop; 3036 3037 if not Has_F then 3038 3039 -- If the protected type has no entry families, there is a one-one 3040 -- correspondence between entry queue and entry body. 3041 3042 Ret := 3043 Make_Simple_Return_Statement (Loc, 3044 Expression => Make_Identifier (Loc, Name_uE)); 3045 3046 else 3047 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate 3048 -- the following: 3049 3050 -- if E <= l1 then return 1; 3051 -- elsif E <= l1 + l2 then return 2; 3052 -- ... 3053 3054 Index := 0; 3055 Siz := Empty; 3056 Ent := First_Entity (Typ); 3057 3058 Add_Object_Pointer (Loc, Typ, Decls); 3059 3060 while Present (Ent) loop 3061 if Ekind (Ent) = E_Entry then 3062 Add_If_Clause (Make_Integer_Literal (Loc, 1)); 3063 3064 elsif Ekind (Ent) = E_Entry_Family then 3065 E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); 3066 Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); 3067 Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); 3068 Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False)); 3069 end if; 3070 3071 Next_Entity (Ent); 3072 end loop; 3073 3074 if Index = 1 then 3075 Decls := New_List; 3076 Ret := 3077 Make_Simple_Return_Statement (Loc, 3078 Expression => Make_Integer_Literal (Loc, 1)); 3079 3080 elsif Nkind (Ret) = N_If_Statement then 3081 3082 -- Ranges are in increasing order, so last one doesn't need guard 3083 3084 declare 3085 Nod : constant Node_Id := Last (Elsif_Parts (Ret)); 3086 begin 3087 Remove (Nod); 3088 Set_Else_Statements (Ret, Then_Statements (Nod)); 3089 end; 3090 end if; 3091 end if; 3092 3093 return 3094 Make_Subprogram_Body (Loc, 3095 Specification => Spec, 3096 Declarations => Decls, 3097 Handled_Statement_Sequence => 3098 Make_Handled_Sequence_Of_Statements (Loc, 3099 Statements => New_List (Ret))); 3100 end Build_Find_Body_Index; 3101 3102 -------------------------------- 3103 -- Build_Find_Body_Index_Spec -- 3104 -------------------------------- 3105 3106 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is 3107 Loc : constant Source_Ptr := Sloc (Typ); 3108 Id : constant Entity_Id := 3109 Make_Defining_Identifier (Loc, 3110 Chars => New_External_Name (Chars (Typ), 'F')); 3111 Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO); 3112 Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE); 3113 3114 begin 3115 return 3116 Make_Function_Specification (Loc, 3117 Defining_Unit_Name => Id, 3118 Parameter_Specifications => New_List ( 3119 Make_Parameter_Specification (Loc, 3120 Defining_Identifier => Parm1, 3121 Parameter_Type => 3122 New_Occurrence_Of (RTE (RE_Address), Loc)), 3123 3124 Make_Parameter_Specification (Loc, 3125 Defining_Identifier => Parm2, 3126 Parameter_Type => 3127 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc))), 3128 3129 Result_Definition => New_Occurrence_Of ( 3130 RTE (RE_Protected_Entry_Index), Loc)); 3131 end Build_Find_Body_Index_Spec; 3132 3133 ----------------------------------------------- 3134 -- Build_Lock_Free_Protected_Subprogram_Body -- 3135 ----------------------------------------------- 3136 3137 function Build_Lock_Free_Protected_Subprogram_Body 3138 (N : Node_Id; 3139 Prot_Typ : Node_Id; 3140 Unprot_Spec : Node_Id) return Node_Id 3141 is 3142 Actuals : constant List_Id := New_List; 3143 Loc : constant Source_Ptr := Sloc (N); 3144 Spec : constant Node_Id := Specification (N); 3145 Unprot_Id : constant Entity_Id := Defining_Unit_Name (Unprot_Spec); 3146 Formal : Node_Id; 3147 Prot_Spec : Node_Id; 3148 Stmt : Node_Id; 3149 3150 begin 3151 -- Create the protected version of the body 3152 3153 Prot_Spec := 3154 Build_Protected_Sub_Specification (N, Prot_Typ, Protected_Mode); 3155 3156 -- Build the actual parameters which appear in the call to the 3157 -- unprotected version of the body. 3158 3159 Formal := First (Parameter_Specifications (Prot_Spec)); 3160 while Present (Formal) loop 3161 Append_To (Actuals, 3162 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 3163 3164 Next (Formal); 3165 end loop; 3166 3167 -- Function case, generate: 3168 -- return <Unprot_Func_Call>; 3169 3170 if Nkind (Spec) = N_Function_Specification then 3171 Stmt := 3172 Make_Simple_Return_Statement (Loc, 3173 Expression => 3174 Make_Function_Call (Loc, 3175 Name => 3176 Make_Identifier (Loc, Chars (Unprot_Id)), 3177 Parameter_Associations => Actuals)); 3178 3179 -- Procedure case, call the unprotected version 3180 3181 else 3182 Stmt := 3183 Make_Procedure_Call_Statement (Loc, 3184 Name => 3185 Make_Identifier (Loc, Chars (Unprot_Id)), 3186 Parameter_Associations => Actuals); 3187 end if; 3188 3189 return 3190 Make_Subprogram_Body (Loc, 3191 Declarations => Empty_List, 3192 Specification => Prot_Spec, 3193 Handled_Statement_Sequence => 3194 Make_Handled_Sequence_Of_Statements (Loc, 3195 Statements => New_List (Stmt))); 3196 end Build_Lock_Free_Protected_Subprogram_Body; 3197 3198 ------------------------------------------------- 3199 -- Build_Lock_Free_Unprotected_Subprogram_Body -- 3200 ------------------------------------------------- 3201 3202 -- Procedures which meet the lock-free implementation requirements and 3203 -- reference a unique scalar component Comp are expanded in the following 3204 -- manner: 3205 3206 -- procedure P (...) is 3207 -- Expected_Comp : constant Comp_Type := 3208 -- Comp_Type 3209 -- (System.Atomic_Primitives.Lock_Free_Read_N 3210 -- (_Object.Comp'Address)); 3211 -- begin 3212 -- loop 3213 -- declare 3214 -- <original declarations before the object renaming declaration 3215 -- of Comp> 3216 -- 3217 -- Desired_Comp : Comp_Type := Expected_Comp; 3218 -- Comp : Comp_Type renames Desired_Comp; 3219 -- 3220 -- <original delarations after the object renaming declaration 3221 -- of Comp> 3222 -- 3223 -- begin 3224 -- <original statements> 3225 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N 3226 -- (_Object.Comp'Address, 3227 -- Interfaces.Unsigned_N (Expected_Comp), 3228 -- Interfaces.Unsigned_N (Desired_Comp)); 3229 -- end; 3230 -- end loop; 3231 -- end P; 3232 3233 -- Each return and raise statement of P is transformed into an atomic 3234 -- status check: 3235 3236 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 3237 -- (_Object.Comp'Address, 3238 -- Interfaces.Unsigned_N (Expected_Comp), 3239 -- Interfaces.Unsigned_N (Desired_Comp)); 3240 -- then 3241 -- <original statement> 3242 -- else 3243 -- goto L0; 3244 -- end if; 3245 3246 -- Functions which meet the lock-free implementation requirements and 3247 -- reference a unique scalar component Comp are expanded in the following 3248 -- manner: 3249 3250 -- function F (...) return ... is 3251 -- <original declarations before the object renaming declaration 3252 -- of Comp> 3253 -- 3254 -- Expected_Comp : constant Comp_Type := 3255 -- Comp_Type 3256 -- (System.Atomic_Primitives.Lock_Free_Read_N 3257 -- (_Object.Comp'Address)); 3258 -- Comp : Comp_Type renames Expected_Comp; 3259 -- 3260 -- <original delarations after the object renaming declaration of 3261 -- Comp> 3262 -- 3263 -- begin 3264 -- <original statements> 3265 -- end F; 3266 3267 function Build_Lock_Free_Unprotected_Subprogram_Body 3268 (N : Node_Id; 3269 Prot_Typ : Node_Id) return Node_Id 3270 is 3271 function Referenced_Component (N : Node_Id) return Entity_Id; 3272 -- Subprograms which meet the lock-free implementation criteria are 3273 -- allowed to reference only one unique component. Return the prival 3274 -- of the said component. 3275 3276 -------------------------- 3277 -- Referenced_Component -- 3278 -------------------------- 3279 3280 function Referenced_Component (N : Node_Id) return Entity_Id is 3281 Comp : Entity_Id; 3282 Decl : Node_Id; 3283 Source_Comp : Entity_Id := Empty; 3284 3285 begin 3286 -- Find the unique source component which N references in its 3287 -- statements. 3288 3289 for Index in 1 .. Lock_Free_Subprogram_Table.Last loop 3290 declare 3291 Element : Lock_Free_Subprogram renames 3292 Lock_Free_Subprogram_Table.Table (Index); 3293 begin 3294 if Element.Sub_Body = N then 3295 Source_Comp := Element.Comp_Id; 3296 exit; 3297 end if; 3298 end; 3299 end loop; 3300 3301 if No (Source_Comp) then 3302 return Empty; 3303 end if; 3304 3305 -- Find the prival which corresponds to the source component within 3306 -- the declarations of N. 3307 3308 Decl := First (Declarations (N)); 3309 while Present (Decl) loop 3310 3311 -- Privals appear as object renamings 3312 3313 if Nkind (Decl) = N_Object_Renaming_Declaration then 3314 Comp := Defining_Identifier (Decl); 3315 3316 if Present (Prival_Link (Comp)) 3317 and then Prival_Link (Comp) = Source_Comp 3318 then 3319 return Comp; 3320 end if; 3321 end if; 3322 3323 Next (Decl); 3324 end loop; 3325 3326 return Empty; 3327 end Referenced_Component; 3328 3329 -- Local variables 3330 3331 Comp : constant Entity_Id := Referenced_Component (N); 3332 Loc : constant Source_Ptr := Sloc (N); 3333 Hand_Stmt_Seq : Node_Id := Handled_Statement_Sequence (N); 3334 Decls : List_Id := Declarations (N); 3335 3336 -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body 3337 3338 begin 3339 -- Add renamings for the protection object, discriminals, privals, and 3340 -- the entry index constant for use by debugger. 3341 3342 Debug_Private_Data_Declarations (Decls); 3343 3344 -- Perform the lock-free expansion when the subprogram references a 3345 -- protected component. 3346 3347 if Present (Comp) then 3348 Protected_Component_Ref : declare 3349 Comp_Decl : constant Node_Id := Parent (Comp); 3350 Comp_Sel_Nam : constant Node_Id := Name (Comp_Decl); 3351 Comp_Type : constant Entity_Id := Etype (Comp); 3352 3353 Is_Procedure : constant Boolean := 3354 Ekind (Corresponding_Spec (N)) = E_Procedure; 3355 -- Indicates if N is a protected procedure body 3356 3357 Block_Decls : List_Id; 3358 Try_Write : Entity_Id; 3359 Desired_Comp : Entity_Id; 3360 Decl : Node_Id; 3361 Label : Node_Id; 3362 Label_Id : Entity_Id := Empty; 3363 Read : Entity_Id; 3364 Expected_Comp : Entity_Id; 3365 Stmt : Node_Id; 3366 Stmts : List_Id := 3367 New_Copy_List (Statements (Hand_Stmt_Seq)); 3368 Typ_Size : Int; 3369 Unsigned : Entity_Id; 3370 3371 function Process_Node (N : Node_Id) return Traverse_Result; 3372 -- Transform a single node if it is a return statement, a raise 3373 -- statement or a reference to Comp. 3374 3375 procedure Process_Stmts (Stmts : List_Id); 3376 -- Given a statement sequence Stmts, wrap any return or raise 3377 -- statements in the following manner: 3378 -- 3379 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 3380 -- (_Object.Comp'Address, 3381 -- Interfaces.Unsigned_N (Expected_Comp), 3382 -- Interfaces.Unsigned_N (Desired_Comp)) 3383 -- then 3384 -- <Stmt>; 3385 -- else 3386 -- goto L0; 3387 -- end if; 3388 3389 ------------------ 3390 -- Process_Node -- 3391 ------------------ 3392 3393 function Process_Node (N : Node_Id) return Traverse_Result is 3394 3395 procedure Wrap_Statement (Stmt : Node_Id); 3396 -- Wrap an arbitrary statement inside an if statement where the 3397 -- condition does an atomic check on the state of the object. 3398 3399 -------------------- 3400 -- Wrap_Statement -- 3401 -------------------- 3402 3403 procedure Wrap_Statement (Stmt : Node_Id) is 3404 begin 3405 -- The first time through, create the declaration of a label 3406 -- which is used to skip the remainder of source statements 3407 -- if the state of the object has changed. 3408 3409 if No (Label_Id) then 3410 Label_Id := 3411 Make_Identifier (Loc, New_External_Name ('L', 0)); 3412 Set_Entity (Label_Id, 3413 Make_Defining_Identifier (Loc, Chars (Label_Id))); 3414 end if; 3415 3416 -- Generate: 3417 -- if System.Atomic_Primitives.Lock_Free_Try_Write_N 3418 -- (_Object.Comp'Address, 3419 -- Interfaces.Unsigned_N (Expected_Comp), 3420 -- Interfaces.Unsigned_N (Desired_Comp)) 3421 -- then 3422 -- <Stmt>; 3423 -- else 3424 -- goto L0; 3425 -- end if; 3426 3427 Rewrite (Stmt, 3428 Make_Implicit_If_Statement (N, 3429 Condition => 3430 Make_Function_Call (Loc, 3431 Name => 3432 New_Occurrence_Of (Try_Write, Loc), 3433 Parameter_Associations => New_List ( 3434 Make_Attribute_Reference (Loc, 3435 Prefix => Relocate_Node (Comp_Sel_Nam), 3436 Attribute_Name => Name_Address), 3437 3438 Unchecked_Convert_To (Unsigned, 3439 New_Occurrence_Of (Expected_Comp, Loc)), 3440 3441 Unchecked_Convert_To (Unsigned, 3442 New_Occurrence_Of (Desired_Comp, Loc)))), 3443 3444 Then_Statements => New_List (Relocate_Node (Stmt)), 3445 3446 Else_Statements => New_List ( 3447 Make_Goto_Statement (Loc, 3448 Name => 3449 New_Occurrence_Of (Entity (Label_Id), Loc))))); 3450 end Wrap_Statement; 3451 3452 -- Start of processing for Process_Node 3453 3454 begin 3455 -- Wrap each return and raise statement that appear inside a 3456 -- procedure. Skip the last return statement which is added by 3457 -- default since it is transformed into an exit statement. 3458 3459 if Is_Procedure 3460 and then ((Nkind (N) = N_Simple_Return_Statement 3461 and then N /= Last (Stmts)) 3462 or else Nkind (N) = N_Extended_Return_Statement 3463 or else (Nkind_In (N, N_Raise_Constraint_Error, 3464 N_Raise_Program_Error, 3465 N_Raise_Statement, 3466 N_Raise_Storage_Error) 3467 and then Comes_From_Source (N))) 3468 then 3469 Wrap_Statement (N); 3470 return Skip; 3471 end if; 3472 3473 -- Force reanalysis 3474 3475 Set_Analyzed (N, False); 3476 3477 return OK; 3478 end Process_Node; 3479 3480 procedure Process_Nodes is new Traverse_Proc (Process_Node); 3481 3482 ------------------- 3483 -- Process_Stmts -- 3484 ------------------- 3485 3486 procedure Process_Stmts (Stmts : List_Id) is 3487 Stmt : Node_Id; 3488 begin 3489 Stmt := First (Stmts); 3490 while Present (Stmt) loop 3491 Process_Nodes (Stmt); 3492 Next (Stmt); 3493 end loop; 3494 end Process_Stmts; 3495 3496 -- Start of processing for Protected_Component_Ref 3497 3498 begin 3499 -- Get the type size 3500 3501 if Known_Static_Esize (Comp_Type) then 3502 Typ_Size := UI_To_Int (Esize (Comp_Type)); 3503 3504 -- If the Esize (Object_Size) is unknown at compile time, look at 3505 -- the RM_Size (Value_Size) since it may have been set by an 3506 -- explicit representation clause. 3507 3508 elsif Known_Static_RM_Size (Comp_Type) then 3509 Typ_Size := UI_To_Int (RM_Size (Comp_Type)); 3510 3511 -- Should not happen since this has already been checked in 3512 -- Allows_Lock_Free_Implementation (see Sem_Ch9). 3513 3514 else 3515 raise Program_Error; 3516 end if; 3517 3518 -- Retrieve all relevant atomic routines and types 3519 3520 case Typ_Size is 3521 when 8 => 3522 Try_Write := RTE (RE_Lock_Free_Try_Write_8); 3523 Read := RTE (RE_Lock_Free_Read_8); 3524 Unsigned := RTE (RE_Uint8); 3525 3526 when 16 => 3527 Try_Write := RTE (RE_Lock_Free_Try_Write_16); 3528 Read := RTE (RE_Lock_Free_Read_16); 3529 Unsigned := RTE (RE_Uint16); 3530 3531 when 32 => 3532 Try_Write := RTE (RE_Lock_Free_Try_Write_32); 3533 Read := RTE (RE_Lock_Free_Read_32); 3534 Unsigned := RTE (RE_Uint32); 3535 3536 when 64 => 3537 Try_Write := RTE (RE_Lock_Free_Try_Write_64); 3538 Read := RTE (RE_Lock_Free_Read_64); 3539 Unsigned := RTE (RE_Uint64); 3540 3541 when others => 3542 raise Program_Error; 3543 end case; 3544 3545 -- Generate: 3546 -- Expected_Comp : constant Comp_Type := 3547 -- Comp_Type 3548 -- (System.Atomic_Primitives.Lock_Free_Read_N 3549 -- (_Object.Comp'Address)); 3550 3551 Expected_Comp := 3552 Make_Defining_Identifier (Loc, 3553 New_External_Name (Chars (Comp), Suffix => "_saved")); 3554 3555 Decl := 3556 Make_Object_Declaration (Loc, 3557 Defining_Identifier => Expected_Comp, 3558 Object_Definition => New_Occurrence_Of (Comp_Type, Loc), 3559 Constant_Present => True, 3560 Expression => 3561 Unchecked_Convert_To (Comp_Type, 3562 Make_Function_Call (Loc, 3563 Name => New_Occurrence_Of (Read, Loc), 3564 Parameter_Associations => New_List ( 3565 Make_Attribute_Reference (Loc, 3566 Prefix => Relocate_Node (Comp_Sel_Nam), 3567 Attribute_Name => Name_Address))))); 3568 3569 -- Protected procedures 3570 3571 if Is_Procedure then 3572 -- Move the original declarations inside the generated block 3573 3574 Block_Decls := Decls; 3575 3576 -- Reset the declarations list of the protected procedure to 3577 -- contain only Decl. 3578 3579 Decls := New_List (Decl); 3580 3581 -- Generate: 3582 -- Desired_Comp : Comp_Type := Expected_Comp; 3583 3584 Desired_Comp := 3585 Make_Defining_Identifier (Loc, 3586 New_External_Name (Chars (Comp), Suffix => "_current")); 3587 3588 -- Insert the declarations of Expected_Comp and Desired_Comp in 3589 -- the block declarations right before the renaming of the 3590 -- protected component. 3591 3592 Insert_Before (Comp_Decl, 3593 Make_Object_Declaration (Loc, 3594 Defining_Identifier => Desired_Comp, 3595 Object_Definition => New_Occurrence_Of (Comp_Type, Loc), 3596 Expression => 3597 New_Occurrence_Of (Expected_Comp, Loc))); 3598 3599 -- Protected function 3600 3601 else 3602 Desired_Comp := Expected_Comp; 3603 3604 -- Insert the declaration of Expected_Comp in the function 3605 -- declarations right before the renaming of the protected 3606 -- component. 3607 3608 Insert_Before (Comp_Decl, Decl); 3609 end if; 3610 3611 -- Rewrite the protected component renaming declaration to be a 3612 -- renaming of Desired_Comp. 3613 3614 -- Generate: 3615 -- Comp : Comp_Type renames Desired_Comp; 3616 3617 Rewrite (Comp_Decl, 3618 Make_Object_Renaming_Declaration (Loc, 3619 Defining_Identifier => 3620 Defining_Identifier (Comp_Decl), 3621 Subtype_Mark => 3622 New_Occurrence_Of (Comp_Type, Loc), 3623 Name => 3624 New_Occurrence_Of (Desired_Comp, Loc))); 3625 3626 -- Wrap any return or raise statements in Stmts in same the manner 3627 -- described in Process_Stmts. 3628 3629 Process_Stmts (Stmts); 3630 3631 -- Generate: 3632 -- exit when System.Atomic_Primitives.Lock_Free_Try_Write_N 3633 -- (_Object.Comp'Address, 3634 -- Interfaces.Unsigned_N (Expected_Comp), 3635 -- Interfaces.Unsigned_N (Desired_Comp)) 3636 3637 if Is_Procedure then 3638 Stmt := 3639 Make_Exit_Statement (Loc, 3640 Condition => 3641 Make_Function_Call (Loc, 3642 Name => 3643 New_Occurrence_Of (Try_Write, Loc), 3644 Parameter_Associations => New_List ( 3645 Make_Attribute_Reference (Loc, 3646 Prefix => Relocate_Node (Comp_Sel_Nam), 3647 Attribute_Name => Name_Address), 3648 3649 Unchecked_Convert_To (Unsigned, 3650 New_Occurrence_Of (Expected_Comp, Loc)), 3651 3652 Unchecked_Convert_To (Unsigned, 3653 New_Occurrence_Of (Desired_Comp, Loc))))); 3654 3655 -- Small optimization: transform the default return statement 3656 -- of a procedure into the atomic exit statement. 3657 3658 if Nkind (Last (Stmts)) = N_Simple_Return_Statement then 3659 Rewrite (Last (Stmts), Stmt); 3660 else 3661 Append_To (Stmts, Stmt); 3662 end if; 3663 end if; 3664 3665 -- Create the declaration of the label used to skip the rest of 3666 -- the source statements when the object state changes. 3667 3668 if Present (Label_Id) then 3669 Label := Make_Label (Loc, Label_Id); 3670 Append_To (Decls, 3671 Make_Implicit_Label_Declaration (Loc, 3672 Defining_Identifier => Entity (Label_Id), 3673 Label_Construct => Label)); 3674 Append_To (Stmts, Label); 3675 end if; 3676 3677 -- Generate: 3678 -- loop 3679 -- declare 3680 -- <Decls> 3681 -- begin 3682 -- <Stmts> 3683 -- end; 3684 -- end loop; 3685 3686 if Is_Procedure then 3687 Stmts := 3688 New_List ( 3689 Make_Loop_Statement (Loc, 3690 Statements => New_List ( 3691 Make_Block_Statement (Loc, 3692 Declarations => Block_Decls, 3693 Handled_Statement_Sequence => 3694 Make_Handled_Sequence_Of_Statements (Loc, 3695 Statements => Stmts))), 3696 End_Label => Empty)); 3697 end if; 3698 3699 Hand_Stmt_Seq := 3700 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts); 3701 end Protected_Component_Ref; 3702 end if; 3703 3704 -- Make an unprotected version of the subprogram for use within the same 3705 -- object, with new name and extra parameter representing the object. 3706 3707 return 3708 Make_Subprogram_Body (Loc, 3709 Specification => 3710 Build_Protected_Sub_Specification (N, Prot_Typ, Unprotected_Mode), 3711 Declarations => Decls, 3712 Handled_Statement_Sequence => Hand_Stmt_Seq); 3713 end Build_Lock_Free_Unprotected_Subprogram_Body; 3714 3715 ------------------------- 3716 -- Build_Master_Entity -- 3717 ------------------------- 3718 3719 procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id) is 3720 Loc : constant Source_Ptr := Sloc (Obj_Or_Typ); 3721 Context : Node_Id; 3722 Context_Id : Entity_Id; 3723 Decl : Node_Id; 3724 Decls : List_Id; 3725 Par : Node_Id; 3726 3727 begin 3728 if Is_Itype (Obj_Or_Typ) then 3729 Par := Associated_Node_For_Itype (Obj_Or_Typ); 3730 else 3731 Par := Parent (Obj_Or_Typ); 3732 end if; 3733 3734 -- When creating a master for a record component which is either a task 3735 -- or access-to-task, the enclosing record is the master scope and the 3736 -- proper insertion point is the component list. 3737 3738 if Is_Record_Type (Current_Scope) then 3739 Context := Par; 3740 Context_Id := Current_Scope; 3741 Decls := List_Containing (Context); 3742 3743 -- Default case for object declarations and access types. Note that the 3744 -- context is updated to the nearest enclosing body, block, package, or 3745 -- return statement. 3746 3747 else 3748 Find_Enclosing_Context (Par, Context, Context_Id, Decls); 3749 end if; 3750 3751 -- Do not create a master if one already exists or there is no task 3752 -- hierarchy. 3753 3754 if Has_Master_Entity (Context_Id) 3755 or else Restriction_Active (No_Task_Hierarchy) 3756 then 3757 return; 3758 end if; 3759 3760 -- Create a master, generate: 3761 -- _Master : constant Master_Id := Current_Master.all; 3762 3763 Decl := 3764 Make_Object_Declaration (Loc, 3765 Defining_Identifier => 3766 Make_Defining_Identifier (Loc, Name_uMaster), 3767 Constant_Present => True, 3768 Object_Definition => New_Occurrence_Of (RTE (RE_Master_Id), Loc), 3769 Expression => 3770 Make_Explicit_Dereference (Loc, 3771 New_Occurrence_Of (RTE (RE_Current_Master), Loc))); 3772 3773 -- The master is inserted at the start of the declarative list of the 3774 -- context. 3775 3776 Prepend_To (Decls, Decl); 3777 3778 -- In certain cases where transient scopes are involved, the immediate 3779 -- scope is not always the proper master scope. Ensure that the master 3780 -- declaration and entity appear in the same context. 3781 3782 if Context_Id /= Current_Scope then 3783 Push_Scope (Context_Id); 3784 Analyze (Decl); 3785 Pop_Scope; 3786 else 3787 Analyze (Decl); 3788 end if; 3789 3790 -- Mark the enclosing scope and its associated construct as being task 3791 -- masters. 3792 3793 Set_Has_Master_Entity (Context_Id); 3794 3795 while Present (Context) 3796 and then Nkind (Context) /= N_Compilation_Unit 3797 loop 3798 if Nkind_In (Context, N_Block_Statement, 3799 N_Subprogram_Body, 3800 N_Task_Body) 3801 then 3802 Set_Is_Task_Master (Context); 3803 exit; 3804 3805 elsif Nkind (Parent (Context)) = N_Subunit then 3806 Context := Corresponding_Stub (Parent (Context)); 3807 end if; 3808 3809 Context := Parent (Context); 3810 end loop; 3811 end Build_Master_Entity; 3812 3813 --------------------------- 3814 -- Build_Master_Renaming -- 3815 --------------------------- 3816 3817 procedure Build_Master_Renaming 3818 (Ptr_Typ : Entity_Id; 3819 Ins_Nod : Node_Id := Empty) 3820 is 3821 Loc : constant Source_Ptr := Sloc (Ptr_Typ); 3822 Context : Node_Id; 3823 Master_Decl : Node_Id; 3824 Master_Id : Entity_Id; 3825 3826 begin 3827 -- Nothing to do if there is no task hierarchy 3828 3829 if Restriction_Active (No_Task_Hierarchy) then 3830 return; 3831 end if; 3832 3833 -- Determine the proper context to insert the master renaming 3834 3835 if Present (Ins_Nod) then 3836 Context := Ins_Nod; 3837 elsif Is_Itype (Ptr_Typ) then 3838 Context := Associated_Node_For_Itype (Ptr_Typ); 3839 else 3840 Context := Parent (Ptr_Typ); 3841 end if; 3842 3843 -- Generate: 3844 -- <Ptr_Typ>M : Master_Id renames _Master; 3845 3846 Master_Id := 3847 Make_Defining_Identifier (Loc, 3848 New_External_Name (Chars (Ptr_Typ), 'M')); 3849 3850 Master_Decl := 3851 Make_Object_Renaming_Declaration (Loc, 3852 Defining_Identifier => Master_Id, 3853 Subtype_Mark => New_Occurrence_Of (RTE (RE_Master_Id), Loc), 3854 Name => Make_Identifier (Loc, Name_uMaster)); 3855 3856 Insert_Action (Context, Master_Decl); 3857 3858 -- The renamed master now services the access type 3859 3860 Set_Master_Id (Ptr_Typ, Master_Id); 3861 end Build_Master_Renaming; 3862 3863 ----------------------------------------- 3864 -- Build_Private_Protected_Declaration -- 3865 ----------------------------------------- 3866 3867 function Build_Private_Protected_Declaration 3868 (N : Node_Id) return Entity_Id 3869 is 3870 Loc : constant Source_Ptr := Sloc (N); 3871 Body_Id : constant Entity_Id := Defining_Entity (N); 3872 Decl : Node_Id; 3873 Plist : List_Id; 3874 Formal : Entity_Id; 3875 New_Spec : Node_Id; 3876 Spec_Id : Entity_Id; 3877 3878 begin 3879 Formal := First_Formal (Body_Id); 3880 3881 -- The protected operation always has at least one formal, namely the 3882 -- object itself, but it is only placed in the parameter list if 3883 -- expansion is enabled. 3884 3885 if Present (Formal) or else Expander_Active then 3886 Plist := Copy_Parameter_List (Body_Id); 3887 else 3888 Plist := No_List; 3889 end if; 3890 3891 if Nkind (Specification (N)) = N_Procedure_Specification then 3892 New_Spec := 3893 Make_Procedure_Specification (Loc, 3894 Defining_Unit_Name => 3895 Make_Defining_Identifier (Sloc (Body_Id), 3896 Chars => Chars (Body_Id)), 3897 Parameter_Specifications => 3898 Plist); 3899 else 3900 New_Spec := 3901 Make_Function_Specification (Loc, 3902 Defining_Unit_Name => 3903 Make_Defining_Identifier (Sloc (Body_Id), 3904 Chars => Chars (Body_Id)), 3905 Parameter_Specifications => Plist, 3906 Result_Definition => 3907 New_Occurrence_Of (Etype (Body_Id), Loc)); 3908 end if; 3909 3910 Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec); 3911 Insert_Before (N, Decl); 3912 Spec_Id := Defining_Unit_Name (New_Spec); 3913 3914 -- Indicate that the entity comes from source, to ensure that cross- 3915 -- reference information is properly generated. The body itself is 3916 -- rewritten during expansion, and the body entity will not appear in 3917 -- calls to the operation. 3918 3919 Set_Comes_From_Source (Spec_Id, True); 3920 Analyze (Decl); 3921 Set_Has_Completion (Spec_Id); 3922 Set_Convention (Spec_Id, Convention_Protected); 3923 return Spec_Id; 3924 end Build_Private_Protected_Declaration; 3925 3926 --------------------------- 3927 -- Build_Protected_Entry -- 3928 --------------------------- 3929 3930 function Build_Protected_Entry 3931 (N : Node_Id; 3932 Ent : Entity_Id; 3933 Pid : Node_Id) return Node_Id 3934 is 3935 Bod_Decls : constant List_Id := New_List; 3936 Decls : constant List_Id := Declarations (N); 3937 End_Lab : constant Node_Id := 3938 End_Label (Handled_Statement_Sequence (N)); 3939 End_Loc : constant Source_Ptr := 3940 Sloc (Last (Statements (Handled_Statement_Sequence (N)))); 3941 -- Used for the generated call to Complete_Entry_Body 3942 3943 Loc : constant Source_Ptr := Sloc (N); 3944 3945 Bod_Id : Entity_Id; 3946 Bod_Spec : Node_Id; 3947 Bod_Stmts : List_Id; 3948 Complete : Node_Id; 3949 Ohandle : Node_Id; 3950 3951 EH_Loc : Source_Ptr; 3952 -- Used for the exception handler, inserted at end of the body 3953 3954 begin 3955 -- Set the source location on the exception handler only when debugging 3956 -- the expanded code (see Make_Implicit_Exception_Handler). 3957 3958 if Debug_Generated_Code then 3959 EH_Loc := End_Loc; 3960 3961 -- Otherwise the inserted code should not be visible to the debugger 3962 3963 else 3964 EH_Loc := No_Location; 3965 end if; 3966 3967 Bod_Id := 3968 Make_Defining_Identifier (Loc, 3969 Chars => Chars (Protected_Body_Subprogram (Ent))); 3970 Bod_Spec := Build_Protected_Entry_Specification (Loc, Bod_Id, Empty); 3971 3972 -- Add the following declarations: 3973 3974 -- type poVP is access poV; 3975 -- _object : poVP := poVP (_O); 3976 3977 -- where _O is the formal parameter associated with the concurrent 3978 -- object. These declarations are needed for Complete_Entry_Body. 3979 3980 Add_Object_Pointer (Loc, Pid, Bod_Decls); 3981 3982 -- Add renamings for all formals, the Protection object, discriminals, 3983 -- privals and the entry index constant for use by debugger. 3984 3985 Add_Formal_Renamings (Bod_Spec, Bod_Decls, Ent, Loc); 3986 Debug_Private_Data_Declarations (Decls); 3987 3988 -- Put the declarations and the statements from the entry 3989 3990 Bod_Stmts := 3991 New_List ( 3992 Make_Block_Statement (Loc, 3993 Declarations => Decls, 3994 Handled_Statement_Sequence => Handled_Statement_Sequence (N))); 3995 3996 case Corresponding_Runtime_Package (Pid) is 3997 when System_Tasking_Protected_Objects_Entries => 3998 Append_To (Bod_Stmts, 3999 Make_Procedure_Call_Statement (End_Loc, 4000 Name => 4001 New_Occurrence_Of (RTE (RE_Complete_Entry_Body), Loc), 4002 Parameter_Associations => New_List ( 4003 Make_Attribute_Reference (End_Loc, 4004 Prefix => 4005 Make_Selected_Component (End_Loc, 4006 Prefix => 4007 Make_Identifier (End_Loc, Name_uObject), 4008 Selector_Name => 4009 Make_Identifier (End_Loc, Name_uObject)), 4010 Attribute_Name => Name_Unchecked_Access)))); 4011 4012 when System_Tasking_Protected_Objects_Single_Entry => 4013 4014 -- Historically, a call to Complete_Single_Entry_Body was 4015 -- inserted, but it was a null procedure. 4016 4017 null; 4018 4019 when others => 4020 raise Program_Error; 4021 end case; 4022 4023 -- When exceptions can not be propagated, we never need to call 4024 -- Exception_Complete_Entry_Body. 4025 4026 if No_Exception_Handlers_Set then 4027 return 4028 Make_Subprogram_Body (Loc, 4029 Specification => Bod_Spec, 4030 Declarations => Bod_Decls, 4031 Handled_Statement_Sequence => 4032 Make_Handled_Sequence_Of_Statements (Loc, 4033 Statements => Bod_Stmts, 4034 End_Label => End_Lab)); 4035 4036 else 4037 Ohandle := Make_Others_Choice (Loc); 4038 Set_All_Others (Ohandle); 4039 4040 case Corresponding_Runtime_Package (Pid) is 4041 when System_Tasking_Protected_Objects_Entries => 4042 Complete := 4043 New_Occurrence_Of 4044 (RTE (RE_Exceptional_Complete_Entry_Body), Loc); 4045 4046 when System_Tasking_Protected_Objects_Single_Entry => 4047 Complete := 4048 New_Occurrence_Of 4049 (RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); 4050 4051 when others => 4052 raise Program_Error; 4053 end case; 4054 4055 -- Establish link between subprogram body entity and source entry 4056 4057 Set_Corresponding_Protected_Entry (Bod_Id, Ent); 4058 4059 -- Create body of entry procedure. The renaming declarations are 4060 -- placed ahead of the block that contains the actual entry body. 4061 4062 return 4063 Make_Subprogram_Body (Loc, 4064 Specification => Bod_Spec, 4065 Declarations => Bod_Decls, 4066 Handled_Statement_Sequence => 4067 Make_Handled_Sequence_Of_Statements (Loc, 4068 Statements => Bod_Stmts, 4069 End_Label => End_Lab, 4070 Exception_Handlers => New_List ( 4071 Make_Implicit_Exception_Handler (EH_Loc, 4072 Exception_Choices => New_List (Ohandle), 4073 4074 Statements => New_List ( 4075 Make_Procedure_Call_Statement (EH_Loc, 4076 Name => Complete, 4077 Parameter_Associations => New_List ( 4078 Make_Attribute_Reference (EH_Loc, 4079 Prefix => 4080 Make_Selected_Component (EH_Loc, 4081 Prefix => 4082 Make_Identifier (EH_Loc, Name_uObject), 4083 Selector_Name => 4084 Make_Identifier (EH_Loc, Name_uObject)), 4085 Attribute_Name => Name_Unchecked_Access), 4086 4087 Make_Function_Call (EH_Loc, 4088 Name => 4089 New_Occurrence_Of 4090 (RTE (RE_Get_GNAT_Exception), Loc))))))))); 4091 end if; 4092 end Build_Protected_Entry; 4093 4094 ----------------------------------------- 4095 -- Build_Protected_Entry_Specification -- 4096 ----------------------------------------- 4097 4098 function Build_Protected_Entry_Specification 4099 (Loc : Source_Ptr; 4100 Def_Id : Entity_Id; 4101 Ent_Id : Entity_Id) return Node_Id 4102 is 4103 P : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uP); 4104 4105 begin 4106 Set_Debug_Info_Needed (Def_Id); 4107 4108 if Present (Ent_Id) then 4109 Append_Elmt (P, Accept_Address (Ent_Id)); 4110 end if; 4111 4112 return 4113 Make_Procedure_Specification (Loc, 4114 Defining_Unit_Name => Def_Id, 4115 Parameter_Specifications => New_List ( 4116 Make_Parameter_Specification (Loc, 4117 Defining_Identifier => 4118 Make_Defining_Identifier (Loc, Name_uO), 4119 Parameter_Type => 4120 New_Occurrence_Of (RTE (RE_Address), Loc)), 4121 4122 Make_Parameter_Specification (Loc, 4123 Defining_Identifier => P, 4124 Parameter_Type => 4125 New_Occurrence_Of (RTE (RE_Address), Loc)), 4126 4127 Make_Parameter_Specification (Loc, 4128 Defining_Identifier => 4129 Make_Defining_Identifier (Loc, Name_uE), 4130 Parameter_Type => 4131 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)))); 4132 end Build_Protected_Entry_Specification; 4133 4134 -------------------------- 4135 -- Build_Protected_Spec -- 4136 -------------------------- 4137 4138 function Build_Protected_Spec 4139 (N : Node_Id; 4140 Obj_Type : Entity_Id; 4141 Ident : Entity_Id; 4142 Unprotected : Boolean := False) return List_Id 4143 is 4144 Loc : constant Source_Ptr := Sloc (N); 4145 Decl : Node_Id; 4146 Formal : Entity_Id; 4147 New_Plist : List_Id; 4148 New_Param : Node_Id; 4149 4150 begin 4151 New_Plist := New_List; 4152 4153 Formal := First_Formal (Ident); 4154 while Present (Formal) loop 4155 New_Param := 4156 Make_Parameter_Specification (Loc, 4157 Defining_Identifier => 4158 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 4159 Aliased_Present => Aliased_Present (Parent (Formal)), 4160 In_Present => In_Present (Parent (Formal)), 4161 Out_Present => Out_Present (Parent (Formal)), 4162 Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc)); 4163 4164 if Unprotected then 4165 Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); 4166 end if; 4167 4168 Append (New_Param, New_Plist); 4169 Next_Formal (Formal); 4170 end loop; 4171 4172 -- If the subprogram is a procedure and the context is not an access 4173 -- to protected subprogram, the parameter is in-out. Otherwise it is 4174 -- an in parameter. 4175 4176 Decl := 4177 Make_Parameter_Specification (Loc, 4178 Defining_Identifier => 4179 Make_Defining_Identifier (Loc, Name_uObject), 4180 In_Present => True, 4181 Out_Present => 4182 (Etype (Ident) = Standard_Void_Type 4183 and then not Is_RTE (Obj_Type, RE_Address)), 4184 Parameter_Type => 4185 New_Occurrence_Of (Obj_Type, Loc)); 4186 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 4187 Prepend_To (New_Plist, Decl); 4188 4189 return New_Plist; 4190 end Build_Protected_Spec; 4191 4192 --------------------------------------- 4193 -- Build_Protected_Sub_Specification -- 4194 --------------------------------------- 4195 4196 function Build_Protected_Sub_Specification 4197 (N : Node_Id; 4198 Prot_Typ : Entity_Id; 4199 Mode : Subprogram_Protection_Mode) return Node_Id 4200 is 4201 Loc : constant Source_Ptr := Sloc (N); 4202 Decl : Node_Id; 4203 Def_Id : Entity_Id; 4204 New_Id : Entity_Id; 4205 New_Plist : List_Id; 4206 New_Spec : Node_Id; 4207 4208 Append_Chr : constant array (Subprogram_Protection_Mode) of Character := 4209 (Dispatching_Mode => ' ', 4210 Protected_Mode => 'P', 4211 Unprotected_Mode => 'N'); 4212 4213 begin 4214 if Ekind (Defining_Unit_Name (Specification (N))) = 4215 E_Subprogram_Body 4216 then 4217 Decl := Unit_Declaration_Node (Corresponding_Spec (N)); 4218 else 4219 Decl := N; 4220 end if; 4221 4222 Def_Id := Defining_Unit_Name (Specification (Decl)); 4223 4224 New_Plist := 4225 Build_Protected_Spec 4226 (Decl, Corresponding_Record_Type (Prot_Typ), Def_Id, 4227 Mode = Unprotected_Mode); 4228 New_Id := 4229 Make_Defining_Identifier (Loc, 4230 Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode))); 4231 4232 -- The unprotected operation carries the user code, and debugging 4233 -- information must be generated for it, even though this spec does 4234 -- not come from source. It is also convenient to allow gdb to step 4235 -- into the protected operation, even though it only contains lock/ 4236 -- unlock calls. 4237 4238 Set_Debug_Info_Needed (New_Id); 4239 4240 -- If a pragma Eliminate applies to the source entity, the internal 4241 -- subprograms will be eliminated as well. 4242 4243 Set_Is_Eliminated (New_Id, Is_Eliminated (Def_Id)); 4244 4245 if Nkind (Specification (Decl)) = N_Procedure_Specification then 4246 New_Spec := 4247 Make_Procedure_Specification (Loc, 4248 Defining_Unit_Name => New_Id, 4249 Parameter_Specifications => New_Plist); 4250 4251 -- Create a new specification for the anonymous subprogram type 4252 4253 else 4254 New_Spec := 4255 Make_Function_Specification (Loc, 4256 Defining_Unit_Name => New_Id, 4257 Parameter_Specifications => New_Plist, 4258 Result_Definition => 4259 Copy_Result_Type (Result_Definition (Specification (Decl)))); 4260 4261 Set_Return_Present (Defining_Unit_Name (New_Spec)); 4262 end if; 4263 4264 return New_Spec; 4265 end Build_Protected_Sub_Specification; 4266 4267 ------------------------------------- 4268 -- Build_Protected_Subprogram_Body -- 4269 ------------------------------------- 4270 4271 function Build_Protected_Subprogram_Body 4272 (N : Node_Id; 4273 Pid : Node_Id; 4274 N_Op_Spec : Node_Id) return Node_Id 4275 is 4276 Loc : constant Source_Ptr := Sloc (N); 4277 Op_Spec : Node_Id; 4278 P_Op_Spec : Node_Id; 4279 Uactuals : List_Id; 4280 Pformal : Node_Id; 4281 Unprot_Call : Node_Id; 4282 Sub_Body : Node_Id; 4283 Lock_Name : Node_Id; 4284 Lock_Stmt : Node_Id; 4285 R : Node_Id; 4286 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning 4287 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning 4288 Stmts : List_Id; 4289 Object_Parm : Node_Id; 4290 Exc_Safe : Boolean; 4291 Lock_Kind : RE_Id; 4292 4293 begin 4294 Op_Spec := Specification (N); 4295 Exc_Safe := Is_Exception_Safe (N); 4296 4297 P_Op_Spec := 4298 Build_Protected_Sub_Specification (N, Pid, Protected_Mode); 4299 4300 -- Build a list of the formal parameters of the protected version of 4301 -- the subprogram to use as the actual parameters of the unprotected 4302 -- version. 4303 4304 Uactuals := New_List; 4305 Pformal := First (Parameter_Specifications (P_Op_Spec)); 4306 while Present (Pformal) loop 4307 Append_To (Uactuals, 4308 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal)))); 4309 Next (Pformal); 4310 end loop; 4311 4312 -- Make a call to the unprotected version of the subprogram built above 4313 -- for use by the protected version built below. 4314 4315 if Nkind (Op_Spec) = N_Function_Specification then 4316 if Exc_Safe then 4317 R := Make_Temporary (Loc, 'R'); 4318 4319 Unprot_Call := 4320 Make_Object_Declaration (Loc, 4321 Defining_Identifier => R, 4322 Constant_Present => True, 4323 Object_Definition => 4324 New_Copy (Result_Definition (N_Op_Spec)), 4325 Expression => 4326 Make_Function_Call (Loc, 4327 Name => 4328 Make_Identifier (Loc, 4329 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 4330 Parameter_Associations => Uactuals)); 4331 4332 Return_Stmt := 4333 Make_Simple_Return_Statement (Loc, 4334 Expression => New_Occurrence_Of (R, Loc)); 4335 4336 else 4337 Unprot_Call := 4338 Make_Simple_Return_Statement (Loc, 4339 Expression => 4340 Make_Function_Call (Loc, 4341 Name => 4342 Make_Identifier (Loc, 4343 Chars => Chars (Defining_Unit_Name (N_Op_Spec))), 4344 Parameter_Associations => Uactuals)); 4345 end if; 4346 4347 Lock_Kind := RE_Lock_Read_Only; 4348 4349 else 4350 Unprot_Call := 4351 Make_Procedure_Call_Statement (Loc, 4352 Name => 4353 Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), 4354 Parameter_Associations => Uactuals); 4355 4356 Lock_Kind := RE_Lock; 4357 end if; 4358 4359 -- Wrap call in block that will be covered by an at_end handler 4360 4361 if not Exc_Safe then 4362 Unprot_Call := 4363 Make_Block_Statement (Loc, 4364 Handled_Statement_Sequence => 4365 Make_Handled_Sequence_Of_Statements (Loc, 4366 Statements => New_List (Unprot_Call))); 4367 end if; 4368 4369 -- Make the protected subprogram body. This locks the protected 4370 -- object and calls the unprotected version of the subprogram. 4371 4372 case Corresponding_Runtime_Package (Pid) is 4373 when System_Tasking_Protected_Objects_Entries => 4374 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entries), Loc); 4375 4376 when System_Tasking_Protected_Objects_Single_Entry => 4377 Lock_Name := New_Occurrence_Of (RTE (RE_Lock_Entry), Loc); 4378 4379 when System_Tasking_Protected_Objects => 4380 Lock_Name := New_Occurrence_Of (RTE (Lock_Kind), Loc); 4381 4382 when others => 4383 raise Program_Error; 4384 end case; 4385 4386 Object_Parm := 4387 Make_Attribute_Reference (Loc, 4388 Prefix => 4389 Make_Selected_Component (Loc, 4390 Prefix => Make_Identifier (Loc, Name_uObject), 4391 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4392 Attribute_Name => Name_Unchecked_Access); 4393 4394 Lock_Stmt := 4395 Make_Procedure_Call_Statement (Loc, 4396 Name => Lock_Name, 4397 Parameter_Associations => New_List (Object_Parm)); 4398 4399 if Abort_Allowed then 4400 Stmts := New_List ( 4401 Build_Runtime_Call (Loc, RE_Abort_Defer), 4402 Lock_Stmt); 4403 4404 else 4405 Stmts := New_List (Lock_Stmt); 4406 end if; 4407 4408 if not Exc_Safe then 4409 Append (Unprot_Call, Stmts); 4410 else 4411 if Nkind (Op_Spec) = N_Function_Specification then 4412 Pre_Stmts := Stmts; 4413 Stmts := Empty_List; 4414 else 4415 Append (Unprot_Call, Stmts); 4416 end if; 4417 4418 -- Historical note: Previously, call to the cleanup was inserted 4419 -- here. This is now done by Build_Protected_Subprogram_Call_Cleanup, 4420 -- which is also shared by the 'not Exc_Safe' path. 4421 4422 Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts); 4423 4424 if Nkind (Op_Spec) = N_Function_Specification then 4425 Append_To (Stmts, Return_Stmt); 4426 Append_To (Pre_Stmts, 4427 Make_Block_Statement (Loc, 4428 Declarations => New_List (Unprot_Call), 4429 Handled_Statement_Sequence => 4430 Make_Handled_Sequence_Of_Statements (Loc, 4431 Statements => Stmts))); 4432 Stmts := Pre_Stmts; 4433 end if; 4434 end if; 4435 4436 Sub_Body := 4437 Make_Subprogram_Body (Loc, 4438 Declarations => Empty_List, 4439 Specification => P_Op_Spec, 4440 Handled_Statement_Sequence => 4441 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); 4442 4443 -- Mark this subprogram as a protected subprogram body so that the 4444 -- cleanup will be inserted. This is done only in the 'not Exc_Safe' 4445 -- path as otherwise the cleanup has already been inserted. 4446 4447 if not Exc_Safe then 4448 Set_Is_Protected_Subprogram_Body (Sub_Body); 4449 end if; 4450 4451 return Sub_Body; 4452 end Build_Protected_Subprogram_Body; 4453 4454 ------------------------------------- 4455 -- Build_Protected_Subprogram_Call -- 4456 ------------------------------------- 4457 4458 procedure Build_Protected_Subprogram_Call 4459 (N : Node_Id; 4460 Name : Node_Id; 4461 Rec : Node_Id; 4462 External : Boolean := True) 4463 is 4464 Loc : constant Source_Ptr := Sloc (N); 4465 Sub : constant Entity_Id := Entity (Name); 4466 New_Sub : Node_Id; 4467 Params : List_Id; 4468 4469 begin 4470 if External then 4471 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc); 4472 else 4473 New_Sub := 4474 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc); 4475 end if; 4476 4477 if Present (Parameter_Associations (N)) then 4478 Params := New_Copy_List_Tree (Parameter_Associations (N)); 4479 else 4480 Params := New_List; 4481 end if; 4482 4483 -- If the type is an untagged derived type, convert to the root type, 4484 -- which is the one on which the operations are defined. 4485 4486 if Nkind (Rec) = N_Unchecked_Type_Conversion 4487 and then not Is_Tagged_Type (Etype (Rec)) 4488 and then Is_Derived_Type (Etype (Rec)) 4489 then 4490 Set_Etype (Rec, Root_Type (Etype (Rec))); 4491 Set_Subtype_Mark (Rec, 4492 New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N))); 4493 end if; 4494 4495 Prepend (Rec, Params); 4496 4497 if Ekind (Sub) = E_Procedure then 4498 Rewrite (N, 4499 Make_Procedure_Call_Statement (Loc, 4500 Name => New_Sub, 4501 Parameter_Associations => Params)); 4502 4503 else 4504 pragma Assert (Ekind (Sub) = E_Function); 4505 Rewrite (N, 4506 Make_Function_Call (Loc, 4507 Name => New_Sub, 4508 Parameter_Associations => Params)); 4509 4510 -- Preserve type of call for subsequent processing (required for 4511 -- call to Wrap_Transient_Expression in the case of a shared passive 4512 -- protected). 4513 4514 Set_Etype (N, Etype (New_Sub)); 4515 end if; 4516 4517 if External 4518 and then Nkind (Rec) = N_Unchecked_Type_Conversion 4519 and then Is_Entity_Name (Expression (Rec)) 4520 and then Is_Shared_Passive (Entity (Expression (Rec))) 4521 then 4522 Add_Shared_Var_Lock_Procs (N); 4523 end if; 4524 end Build_Protected_Subprogram_Call; 4525 4526 --------------------------------------------- 4527 -- Build_Protected_Subprogram_Call_Cleanup -- 4528 --------------------------------------------- 4529 4530 procedure Build_Protected_Subprogram_Call_Cleanup 4531 (Op_Spec : Node_Id; 4532 Conc_Typ : Node_Id; 4533 Loc : Source_Ptr; 4534 Stmts : List_Id) 4535 is 4536 Nam : Node_Id; 4537 4538 begin 4539 -- If the associated protected object has entries, a protected 4540 -- procedure has to service entry queues. In this case generate: 4541 4542 -- Service_Entries (_object._object'Access); 4543 4544 if Nkind (Op_Spec) = N_Procedure_Specification 4545 and then Has_Entries (Conc_Typ) 4546 then 4547 case Corresponding_Runtime_Package (Conc_Typ) is 4548 when System_Tasking_Protected_Objects_Entries => 4549 Nam := New_Occurrence_Of (RTE (RE_Service_Entries), Loc); 4550 4551 when System_Tasking_Protected_Objects_Single_Entry => 4552 Nam := New_Occurrence_Of (RTE (RE_Service_Entry), Loc); 4553 4554 when others => 4555 raise Program_Error; 4556 end case; 4557 4558 Append_To (Stmts, 4559 Make_Procedure_Call_Statement (Loc, 4560 Name => Nam, 4561 Parameter_Associations => New_List ( 4562 Make_Attribute_Reference (Loc, 4563 Prefix => 4564 Make_Selected_Component (Loc, 4565 Prefix => Make_Identifier (Loc, Name_uObject), 4566 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4567 Attribute_Name => Name_Unchecked_Access)))); 4568 4569 else 4570 -- Generate: 4571 -- Unlock (_object._object'Access); 4572 4573 case Corresponding_Runtime_Package (Conc_Typ) is 4574 when System_Tasking_Protected_Objects_Entries => 4575 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entries), Loc); 4576 4577 when System_Tasking_Protected_Objects_Single_Entry => 4578 Nam := New_Occurrence_Of (RTE (RE_Unlock_Entry), Loc); 4579 4580 when System_Tasking_Protected_Objects => 4581 Nam := New_Occurrence_Of (RTE (RE_Unlock), Loc); 4582 4583 when others => 4584 raise Program_Error; 4585 end case; 4586 4587 Append_To (Stmts, 4588 Make_Procedure_Call_Statement (Loc, 4589 Name => Nam, 4590 Parameter_Associations => New_List ( 4591 Make_Attribute_Reference (Loc, 4592 Prefix => 4593 Make_Selected_Component (Loc, 4594 Prefix => Make_Identifier (Loc, Name_uObject), 4595 Selector_Name => Make_Identifier (Loc, Name_uObject)), 4596 Attribute_Name => Name_Unchecked_Access)))); 4597 end if; 4598 4599 -- Generate: 4600 -- Abort_Undefer; 4601 4602 if Abort_Allowed then 4603 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 4604 end if; 4605 end Build_Protected_Subprogram_Call_Cleanup; 4606 4607 ------------------------- 4608 -- Build_Selected_Name -- 4609 ------------------------- 4610 4611 function Build_Selected_Name 4612 (Prefix : Entity_Id; 4613 Selector : Entity_Id; 4614 Append_Char : Character := ' ') return Name_Id 4615 is 4616 Select_Buffer : String (1 .. Hostparm.Max_Name_Length); 4617 Select_Len : Natural; 4618 4619 begin 4620 Get_Name_String (Chars (Selector)); 4621 Select_Len := Name_Len; 4622 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len); 4623 Get_Name_String (Chars (Prefix)); 4624 4625 -- If scope is anonymous type, discard suffix to recover name of 4626 -- single protected object. Otherwise use protected type name. 4627 4628 if Name_Buffer (Name_Len) = 'T' then 4629 Name_Len := Name_Len - 1; 4630 end if; 4631 4632 Add_Str_To_Name_Buffer ("__"); 4633 for J in 1 .. Select_Len loop 4634 Add_Char_To_Name_Buffer (Select_Buffer (J)); 4635 end loop; 4636 4637 -- Now add the Append_Char if specified. The encoding to follow 4638 -- depends on the type of entity. If Append_Char is either 'N' or 'P', 4639 -- then the entity is associated to a protected type subprogram. 4640 -- Otherwise, it is a protected type entry. For each case, the 4641 -- encoding to follow for the suffix is documented in exp_dbug.ads. 4642 4643 -- It would be better to encapsulate this as a routine in Exp_Dbug ??? 4644 4645 if Append_Char /= ' ' then 4646 if Append_Char = 'P' or Append_Char = 'N' then 4647 Add_Char_To_Name_Buffer (Append_Char); 4648 return Name_Find; 4649 else 4650 Add_Str_To_Name_Buffer ((1 => '_', 2 => Append_Char)); 4651 return New_External_Name (Name_Find, ' ', -1); 4652 end if; 4653 else 4654 return Name_Find; 4655 end if; 4656 end Build_Selected_Name; 4657 4658 ----------------------------- 4659 -- Build_Simple_Entry_Call -- 4660 ----------------------------- 4661 4662 -- A task entry call is converted to a call to Call_Simple 4663 4664 -- declare 4665 -- P : parms := (parm, parm, parm); 4666 -- begin 4667 -- Call_Simple (acceptor-task, entry-index, P'Address); 4668 -- parm := P.param; 4669 -- parm := P.param; 4670 -- ... 4671 -- end; 4672 4673 -- Here Pnn is an aggregate of the type constructed for the entry to hold 4674 -- the parameters, and the constructed aggregate value contains either the 4675 -- parameters or, in the case of non-elementary types, references to these 4676 -- parameters. Then the address of this aggregate is passed to the runtime 4677 -- routine, along with the task id value and the task entry index value. 4678 -- Pnn is only required if parameters are present. 4679 4680 -- The assignments after the call are present only in the case of in-out 4681 -- or out parameters for elementary types, and are used to assign back the 4682 -- resulting values of such parameters. 4683 4684 -- Note: the reason that we insert a block here is that in the context 4685 -- of selects, conditional entry calls etc. the entry call statement 4686 -- appears on its own, not as an element of a list. 4687 4688 -- A protected entry call is converted to a Protected_Entry_Call: 4689 4690 -- declare 4691 -- P : E1_Params := (param, param, param); 4692 -- Pnn : Boolean; 4693 -- Bnn : Communications_Block; 4694 4695 -- declare 4696 -- P : E1_Params := (param, param, param); 4697 -- Bnn : Communications_Block; 4698 4699 -- begin 4700 -- Protected_Entry_Call ( 4701 -- Object => po._object'Access, 4702 -- E => <entry index>; 4703 -- Uninterpreted_Data => P'Address; 4704 -- Mode => Simple_Call; 4705 -- Block => Bnn); 4706 -- parm := P.param; 4707 -- parm := P.param; 4708 -- ... 4709 -- end; 4710 4711 procedure Build_Simple_Entry_Call 4712 (N : Node_Id; 4713 Concval : Node_Id; 4714 Ename : Node_Id; 4715 Index : Node_Id) 4716 is 4717 begin 4718 Expand_Call (N); 4719 4720 -- If call has been inlined, nothing left to do 4721 4722 if Nkind (N) = N_Block_Statement then 4723 return; 4724 end if; 4725 4726 -- Convert entry call to Call_Simple call 4727 4728 declare 4729 Loc : constant Source_Ptr := Sloc (N); 4730 Parms : constant List_Id := Parameter_Associations (N); 4731 Stats : constant List_Id := New_List; 4732 Actual : Node_Id; 4733 Call : Node_Id; 4734 Comm_Name : Entity_Id; 4735 Conctyp : Node_Id; 4736 Decls : List_Id; 4737 Ent : Entity_Id; 4738 Ent_Acc : Entity_Id; 4739 Formal : Node_Id; 4740 Iface_Tag : Entity_Id; 4741 Iface_Typ : Entity_Id; 4742 N_Node : Node_Id; 4743 N_Var : Node_Id; 4744 P : Entity_Id; 4745 Parm1 : Node_Id; 4746 Parm2 : Node_Id; 4747 Parm3 : Node_Id; 4748 Pdecl : Node_Id; 4749 Plist : List_Id; 4750 X : Entity_Id; 4751 Xdecl : Node_Id; 4752 4753 begin 4754 -- Simple entry and entry family cases merge here 4755 4756 Ent := Entity (Ename); 4757 Ent_Acc := Entry_Parameters_Type (Ent); 4758 Conctyp := Etype (Concval); 4759 4760 -- If prefix is an access type, dereference to obtain the task type 4761 4762 if Is_Access_Type (Conctyp) then 4763 Conctyp := Designated_Type (Conctyp); 4764 end if; 4765 4766 -- Special case for protected subprogram calls 4767 4768 if Is_Protected_Type (Conctyp) 4769 and then Is_Subprogram (Entity (Ename)) 4770 then 4771 if not Is_Eliminated (Entity (Ename)) then 4772 Build_Protected_Subprogram_Call 4773 (N, Ename, Convert_Concurrent (Concval, Conctyp)); 4774 Analyze (N); 4775 end if; 4776 4777 return; 4778 end if; 4779 4780 -- First parameter is the Task_Id value from the task value or the 4781 -- Object from the protected object value, obtained by selecting 4782 -- the _Task_Id or _Object from the result of doing an unchecked 4783 -- conversion to convert the value to the corresponding record type. 4784 4785 if Nkind (Concval) = N_Function_Call 4786 and then Is_Task_Type (Conctyp) 4787 and then Ada_Version >= Ada_2005 4788 then 4789 declare 4790 ExpR : constant Node_Id := Relocate_Node (Concval); 4791 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', ExpR); 4792 Decl : Node_Id; 4793 4794 begin 4795 Decl := 4796 Make_Object_Declaration (Loc, 4797 Defining_Identifier => Obj, 4798 Object_Definition => New_Occurrence_Of (Conctyp, Loc), 4799 Expression => ExpR); 4800 Set_Etype (Obj, Conctyp); 4801 Decls := New_List (Decl); 4802 Rewrite (Concval, New_Occurrence_Of (Obj, Loc)); 4803 end; 4804 4805 else 4806 Decls := New_List; 4807 end if; 4808 4809 Parm1 := Concurrent_Ref (Concval); 4810 4811 -- Second parameter is the entry index, computed by the routine 4812 -- provided for this purpose. The value of this expression is 4813 -- assigned to an intermediate variable to assure that any entry 4814 -- family index expressions are evaluated before the entry 4815 -- parameters. 4816 4817 if not Is_Protected_Type (Conctyp) 4818 or else 4819 Corresponding_Runtime_Package (Conctyp) = 4820 System_Tasking_Protected_Objects_Entries 4821 then 4822 X := Make_Defining_Identifier (Loc, Name_uX); 4823 4824 Xdecl := 4825 Make_Object_Declaration (Loc, 4826 Defining_Identifier => X, 4827 Object_Definition => 4828 New_Occurrence_Of (RTE (RE_Task_Entry_Index), Loc), 4829 Expression => Actual_Index_Expression ( 4830 Loc, Entity (Ename), Index, Concval)); 4831 4832 Append_To (Decls, Xdecl); 4833 Parm2 := New_Occurrence_Of (X, Loc); 4834 4835 else 4836 Xdecl := Empty; 4837 Parm2 := Empty; 4838 end if; 4839 4840 -- The third parameter is the packaged parameters. If there are 4841 -- none, then it is just the null address, since nothing is passed. 4842 4843 if No (Parms) then 4844 Parm3 := New_Occurrence_Of (RTE (RE_Null_Address), Loc); 4845 P := Empty; 4846 4847 -- Case of parameters present, where third argument is the address 4848 -- of a packaged record containing the required parameter values. 4849 4850 else 4851 -- First build a list of parameter values, which are references to 4852 -- objects of the parameter types. 4853 4854 Plist := New_List; 4855 4856 Actual := First_Actual (N); 4857 Formal := First_Formal (Ent); 4858 while Present (Actual) loop 4859 4860 -- If it is a by-copy type, copy it to a new variable. The 4861 -- packaged record has a field that points to this variable. 4862 4863 if Is_By_Copy_Type (Etype (Actual)) then 4864 N_Node := 4865 Make_Object_Declaration (Loc, 4866 Defining_Identifier => Make_Temporary (Loc, 'J'), 4867 Aliased_Present => True, 4868 Object_Definition => 4869 New_Occurrence_Of (Etype (Formal), Loc)); 4870 4871 -- Mark the object as not needing initialization since the 4872 -- initialization is performed separately, avoiding errors 4873 -- on cases such as formals of null-excluding access types. 4874 4875 Set_No_Initialization (N_Node); 4876 4877 -- We must make a separate assignment statement for the 4878 -- case of limited types. We cannot assign it unless the 4879 -- Assignment_OK flag is set first. An out formal of an 4880 -- access type or whose type has a Default_Value must also 4881 -- be initialized from the actual (see RM 6.4.1 (13-13.1)), 4882 -- but no constraint, predicate, or null-exclusion check is 4883 -- applied before the call. 4884 4885 if Ekind (Formal) /= E_Out_Parameter 4886 or else Is_Access_Type (Etype (Formal)) 4887 or else 4888 (Is_Scalar_Type (Etype (Formal)) 4889 and then 4890 Present (Default_Aspect_Value (Etype (Formal)))) 4891 then 4892 N_Var := 4893 New_Occurrence_Of (Defining_Identifier (N_Node), Loc); 4894 Set_Assignment_OK (N_Var); 4895 Append_To (Stats, 4896 Make_Assignment_Statement (Loc, 4897 Name => N_Var, 4898 Expression => Relocate_Node (Actual))); 4899 4900 -- Mark the object as internal, so we don't later reset 4901 -- No_Initialization flag in Default_Initialize_Object, 4902 -- which would lead to needless default initialization. 4903 -- We don't set this outside the if statement, because 4904 -- out scalar parameters without Default_Value do require 4905 -- default initialization if Initialize_Scalars applies. 4906 4907 Set_Is_Internal (Defining_Identifier (N_Node)); 4908 4909 -- If actual is an out parameter of a null-excluding 4910 -- access type, there is access check on entry, so set 4911 -- Suppress_Assignment_Checks on the generated statement 4912 -- that assigns the actual to the parameter block 4913 4914 Set_Suppress_Assignment_Checks (Last (Stats)); 4915 end if; 4916 4917 Append (N_Node, Decls); 4918 4919 Append_To (Plist, 4920 Make_Attribute_Reference (Loc, 4921 Attribute_Name => Name_Unchecked_Access, 4922 Prefix => 4923 New_Occurrence_Of 4924 (Defining_Identifier (N_Node), Loc))); 4925 4926 else 4927 -- Interface class-wide formal 4928 4929 if Ada_Version >= Ada_2005 4930 and then Ekind (Etype (Formal)) = E_Class_Wide_Type 4931 and then Is_Interface (Etype (Formal)) 4932 then 4933 Iface_Typ := Etype (Etype (Formal)); 4934 4935 -- Generate: 4936 -- formal_iface_type! (actual.iface_tag)'reference 4937 4938 Iface_Tag := 4939 Find_Interface_Tag (Etype (Actual), Iface_Typ); 4940 pragma Assert (Present (Iface_Tag)); 4941 4942 Append_To (Plist, 4943 Make_Reference (Loc, 4944 Unchecked_Convert_To (Iface_Typ, 4945 Make_Selected_Component (Loc, 4946 Prefix => 4947 Relocate_Node (Actual), 4948 Selector_Name => 4949 New_Occurrence_Of (Iface_Tag, Loc))))); 4950 else 4951 -- Generate: 4952 -- actual'reference 4953 4954 Append_To (Plist, 4955 Make_Reference (Loc, Relocate_Node (Actual))); 4956 end if; 4957 end if; 4958 4959 Next_Actual (Actual); 4960 Next_Formal_With_Extras (Formal); 4961 end loop; 4962 4963 -- Now build the declaration of parameters initialized with the 4964 -- aggregate containing this constructed parameter list. 4965 4966 P := Make_Defining_Identifier (Loc, Name_uP); 4967 4968 Pdecl := 4969 Make_Object_Declaration (Loc, 4970 Defining_Identifier => P, 4971 Object_Definition => 4972 New_Occurrence_Of (Designated_Type (Ent_Acc), Loc), 4973 Expression => 4974 Make_Aggregate (Loc, Expressions => Plist)); 4975 4976 Parm3 := 4977 Make_Attribute_Reference (Loc, 4978 Prefix => New_Occurrence_Of (P, Loc), 4979 Attribute_Name => Name_Address); 4980 4981 Append (Pdecl, Decls); 4982 end if; 4983 4984 -- Now we can create the call, case of protected type 4985 4986 if Is_Protected_Type (Conctyp) then 4987 case Corresponding_Runtime_Package (Conctyp) is 4988 when System_Tasking_Protected_Objects_Entries => 4989 4990 -- Change the type of the index declaration 4991 4992 Set_Object_Definition (Xdecl, 4993 New_Occurrence_Of (RTE (RE_Protected_Entry_Index), Loc)); 4994 4995 -- Some additional declarations for protected entry calls 4996 4997 if No (Decls) then 4998 Decls := New_List; 4999 end if; 5000 5001 -- Bnn : Communications_Block; 5002 5003 Comm_Name := Make_Temporary (Loc, 'B'); 5004 5005 Append_To (Decls, 5006 Make_Object_Declaration (Loc, 5007 Defining_Identifier => Comm_Name, 5008 Object_Definition => 5009 New_Occurrence_Of 5010 (RTE (RE_Communication_Block), Loc))); 5011 5012 -- Some additional statements for protected entry calls 5013 5014 -- Protected_Entry_Call ( 5015 -- Object => po._object'Access, 5016 -- E => <entry index>; 5017 -- Uninterpreted_Data => P'Address; 5018 -- Mode => Simple_Call; 5019 -- Block => Bnn); 5020 5021 Call := 5022 Make_Procedure_Call_Statement (Loc, 5023 Name => 5024 New_Occurrence_Of (RTE (RE_Protected_Entry_Call), Loc), 5025 5026 Parameter_Associations => New_List ( 5027 Make_Attribute_Reference (Loc, 5028 Attribute_Name => Name_Unchecked_Access, 5029 Prefix => Parm1), 5030 Parm2, 5031 Parm3, 5032 New_Occurrence_Of (RTE (RE_Simple_Call), Loc), 5033 New_Occurrence_Of (Comm_Name, Loc))); 5034 5035 when System_Tasking_Protected_Objects_Single_Entry => 5036 -- Protected_Single_Entry_Call ( 5037 -- Object => po._object'Access, 5038 -- Uninterpreted_Data => P'Address); 5039 5040 Call := 5041 Make_Procedure_Call_Statement (Loc, 5042 Name => 5043 New_Occurrence_Of 5044 (RTE (RE_Protected_Single_Entry_Call), Loc), 5045 5046 Parameter_Associations => New_List ( 5047 Make_Attribute_Reference (Loc, 5048 Attribute_Name => Name_Unchecked_Access, 5049 Prefix => Parm1), 5050 Parm3)); 5051 5052 when others => 5053 raise Program_Error; 5054 end case; 5055 5056 -- Case of task type 5057 5058 else 5059 Call := 5060 Make_Procedure_Call_Statement (Loc, 5061 Name => 5062 New_Occurrence_Of (RTE (RE_Call_Simple), Loc), 5063 Parameter_Associations => New_List (Parm1, Parm2, Parm3)); 5064 5065 end if; 5066 5067 Append_To (Stats, Call); 5068 5069 -- If there are out or in/out parameters by copy add assignment 5070 -- statements for the result values. 5071 5072 if Present (Parms) then 5073 Actual := First_Actual (N); 5074 Formal := First_Formal (Ent); 5075 5076 Set_Assignment_OK (Actual); 5077 while Present (Actual) loop 5078 if Is_By_Copy_Type (Etype (Actual)) 5079 and then Ekind (Formal) /= E_In_Parameter 5080 then 5081 N_Node := 5082 Make_Assignment_Statement (Loc, 5083 Name => New_Copy (Actual), 5084 Expression => 5085 Make_Explicit_Dereference (Loc, 5086 Make_Selected_Component (Loc, 5087 Prefix => New_Occurrence_Of (P, Loc), 5088 Selector_Name => 5089 Make_Identifier (Loc, Chars (Formal))))); 5090 5091 -- In all cases (including limited private types) we want 5092 -- the assignment to be valid. 5093 5094 Set_Assignment_OK (Name (N_Node)); 5095 5096 -- If the call is the triggering alternative in an 5097 -- asynchronous select, or the entry_call alternative of a 5098 -- conditional entry call, the assignments for in-out 5099 -- parameters are incorporated into the statement list that 5100 -- follows, so that there are executed only if the entry 5101 -- call succeeds. 5102 5103 if (Nkind (Parent (N)) = N_Triggering_Alternative 5104 and then N = Triggering_Statement (Parent (N))) 5105 or else 5106 (Nkind (Parent (N)) = N_Entry_Call_Alternative 5107 and then N = Entry_Call_Statement (Parent (N))) 5108 then 5109 if No (Statements (Parent (N))) then 5110 Set_Statements (Parent (N), New_List); 5111 end if; 5112 5113 Prepend (N_Node, Statements (Parent (N))); 5114 5115 else 5116 Insert_After (Call, N_Node); 5117 end if; 5118 end if; 5119 5120 Next_Actual (Actual); 5121 Next_Formal_With_Extras (Formal); 5122 end loop; 5123 end if; 5124 5125 -- Finally, create block and analyze it 5126 5127 Rewrite (N, 5128 Make_Block_Statement (Loc, 5129 Declarations => Decls, 5130 Handled_Statement_Sequence => 5131 Make_Handled_Sequence_Of_Statements (Loc, 5132 Statements => Stats))); 5133 5134 Analyze (N); 5135 end; 5136 end Build_Simple_Entry_Call; 5137 5138 -------------------------------- 5139 -- Build_Task_Activation_Call -- 5140 -------------------------------- 5141 5142 procedure Build_Task_Activation_Call (N : Node_Id) is 5143 Loc : constant Source_Ptr := Sloc (N); 5144 Chain : Entity_Id; 5145 Call : Node_Id; 5146 Name : Node_Id; 5147 P : Node_Id; 5148 5149 begin 5150 -- For sequential elaboration policy, all the tasks will be activated at 5151 -- the end of the elaboration. 5152 5153 if Partition_Elaboration_Policy = 'S' then 5154 return; 5155 end if; 5156 5157 -- Get the activation chain entity. Except in the case of a package 5158 -- body, this is in the node that was passed. For a package body, we 5159 -- have to find the corresponding package declaration node. 5160 5161 if Nkind (N) = N_Package_Body then 5162 P := Corresponding_Spec (N); 5163 loop 5164 P := Parent (P); 5165 exit when Nkind (P) = N_Package_Declaration; 5166 end loop; 5167 5168 Chain := Activation_Chain_Entity (P); 5169 5170 else 5171 Chain := Activation_Chain_Entity (N); 5172 end if; 5173 5174 if Present (Chain) then 5175 if Restricted_Profile then 5176 Name := New_Occurrence_Of 5177 (RTE (RE_Activate_Restricted_Tasks), Loc); 5178 else 5179 Name := New_Occurrence_Of 5180 (RTE (RE_Activate_Tasks), Loc); 5181 end if; 5182 5183 Call := 5184 Make_Procedure_Call_Statement (Loc, 5185 Name => Name, 5186 Parameter_Associations => 5187 New_List (Make_Attribute_Reference (Loc, 5188 Prefix => New_Occurrence_Of (Chain, Loc), 5189 Attribute_Name => Name_Unchecked_Access))); 5190 5191 if Nkind (N) = N_Package_Declaration then 5192 if Present (Corresponding_Body (N)) then 5193 null; 5194 5195 elsif Present (Private_Declarations (Specification (N))) then 5196 Append (Call, Private_Declarations (Specification (N))); 5197 5198 else 5199 Append (Call, Visible_Declarations (Specification (N))); 5200 end if; 5201 5202 else 5203 if Present (Handled_Statement_Sequence (N)) then 5204 5205 -- The call goes at the start of the statement sequence after 5206 -- the start of exception range label if one is present. 5207 5208 declare 5209 Stm : Node_Id; 5210 5211 begin 5212 Stm := First (Statements (Handled_Statement_Sequence (N))); 5213 5214 -- A special case, skip exception range label if one is 5215 -- present (from front end zcx processing). 5216 5217 if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then 5218 Next (Stm); 5219 end if; 5220 5221 -- Another special case, if the first statement is a block 5222 -- from optimization of a local raise to a goto, then the 5223 -- call goes inside this block. 5224 5225 if Nkind (Stm) = N_Block_Statement 5226 and then Exception_Junk (Stm) 5227 then 5228 Stm := 5229 First (Statements (Handled_Statement_Sequence (Stm))); 5230 end if; 5231 5232 -- Insertion point is after any exception label pushes, 5233 -- since we want it covered by any local handlers. 5234 5235 while Nkind (Stm) in N_Push_xxx_Label loop 5236 Next (Stm); 5237 end loop; 5238 5239 -- Now we have the proper insertion point 5240 5241 Insert_Before (Stm, Call); 5242 end; 5243 5244 else 5245 Set_Handled_Statement_Sequence (N, 5246 Make_Handled_Sequence_Of_Statements (Loc, 5247 Statements => New_List (Call))); 5248 end if; 5249 end if; 5250 5251 Analyze (Call); 5252 Check_Task_Activation (N); 5253 end if; 5254 end Build_Task_Activation_Call; 5255 5256 ------------------------------- 5257 -- Build_Task_Allocate_Block -- 5258 ------------------------------- 5259 5260 procedure Build_Task_Allocate_Block 5261 (Actions : List_Id; 5262 N : Node_Id; 5263 Args : List_Id) 5264 is 5265 T : constant Entity_Id := Entity (Expression (N)); 5266 Init : constant Entity_Id := Base_Init_Proc (T); 5267 Loc : constant Source_Ptr := Sloc (N); 5268 Chain : constant Entity_Id := 5269 Make_Defining_Identifier (Loc, Name_uChain); 5270 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 5271 Block : Node_Id; 5272 5273 begin 5274 Block := 5275 Make_Block_Statement (Loc, 5276 Identifier => New_Occurrence_Of (Blkent, Loc), 5277 Declarations => New_List ( 5278 5279 -- _Chain : Activation_Chain; 5280 5281 Make_Object_Declaration (Loc, 5282 Defining_Identifier => Chain, 5283 Aliased_Present => True, 5284 Object_Definition => 5285 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 5286 5287 Handled_Statement_Sequence => 5288 Make_Handled_Sequence_Of_Statements (Loc, 5289 5290 Statements => New_List ( 5291 5292 -- Init (Args); 5293 5294 Make_Procedure_Call_Statement (Loc, 5295 Name => New_Occurrence_Of (Init, Loc), 5296 Parameter_Associations => Args), 5297 5298 -- Activate_Tasks (_Chain); 5299 5300 Make_Procedure_Call_Statement (Loc, 5301 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 5302 Parameter_Associations => New_List ( 5303 Make_Attribute_Reference (Loc, 5304 Prefix => New_Occurrence_Of (Chain, Loc), 5305 Attribute_Name => Name_Unchecked_Access))))), 5306 5307 Has_Created_Identifier => True, 5308 Is_Task_Allocation_Block => True); 5309 5310 Append_To (Actions, 5311 Make_Implicit_Label_Declaration (Loc, 5312 Defining_Identifier => Blkent, 5313 Label_Construct => Block)); 5314 5315 Append_To (Actions, Block); 5316 5317 Set_Activation_Chain_Entity (Block, Chain); 5318 end Build_Task_Allocate_Block; 5319 5320 ----------------------------------------------- 5321 -- Build_Task_Allocate_Block_With_Init_Stmts -- 5322 ----------------------------------------------- 5323 5324 procedure Build_Task_Allocate_Block_With_Init_Stmts 5325 (Actions : List_Id; 5326 N : Node_Id; 5327 Init_Stmts : List_Id) 5328 is 5329 Loc : constant Source_Ptr := Sloc (N); 5330 Chain : constant Entity_Id := 5331 Make_Defining_Identifier (Loc, Name_uChain); 5332 Blkent : constant Entity_Id := Make_Temporary (Loc, 'A'); 5333 Block : Node_Id; 5334 5335 begin 5336 Append_To (Init_Stmts, 5337 Make_Procedure_Call_Statement (Loc, 5338 Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc), 5339 Parameter_Associations => New_List ( 5340 Make_Attribute_Reference (Loc, 5341 Prefix => New_Occurrence_Of (Chain, Loc), 5342 Attribute_Name => Name_Unchecked_Access)))); 5343 5344 Block := 5345 Make_Block_Statement (Loc, 5346 Identifier => New_Occurrence_Of (Blkent, Loc), 5347 Declarations => New_List ( 5348 5349 -- _Chain : Activation_Chain; 5350 5351 Make_Object_Declaration (Loc, 5352 Defining_Identifier => Chain, 5353 Aliased_Present => True, 5354 Object_Definition => 5355 New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))), 5356 5357 Handled_Statement_Sequence => 5358 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts), 5359 5360 Has_Created_Identifier => True, 5361 Is_Task_Allocation_Block => True); 5362 5363 Append_To (Actions, 5364 Make_Implicit_Label_Declaration (Loc, 5365 Defining_Identifier => Blkent, 5366 Label_Construct => Block)); 5367 5368 Append_To (Actions, Block); 5369 5370 Set_Activation_Chain_Entity (Block, Chain); 5371 end Build_Task_Allocate_Block_With_Init_Stmts; 5372 5373 ----------------------------------- 5374 -- Build_Task_Proc_Specification -- 5375 ----------------------------------- 5376 5377 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is 5378 Loc : constant Source_Ptr := Sloc (T); 5379 Spec_Id : Entity_Id; 5380 5381 begin 5382 -- Case of explicit task type, suffix TB 5383 5384 if Comes_From_Source (T) then 5385 Spec_Id := 5386 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), "TB")); 5387 5388 -- Case of anonymous task type, suffix B 5389 5390 else 5391 Spec_Id := 5392 Make_Defining_Identifier (Loc, New_External_Name (Chars (T), 'B')); 5393 end if; 5394 5395 Set_Is_Internal (Spec_Id); 5396 5397 -- Associate the procedure with the task, if this is the declaration 5398 -- (and not the body) of the procedure. 5399 5400 if No (Task_Body_Procedure (T)) then 5401 Set_Task_Body_Procedure (T, Spec_Id); 5402 end if; 5403 5404 return 5405 Make_Procedure_Specification (Loc, 5406 Defining_Unit_Name => Spec_Id, 5407 Parameter_Specifications => New_List ( 5408 Make_Parameter_Specification (Loc, 5409 Defining_Identifier => 5410 Make_Defining_Identifier (Loc, Name_uTask), 5411 Parameter_Type => 5412 Make_Access_Definition (Loc, 5413 Subtype_Mark => 5414 New_Occurrence_Of (Corresponding_Record_Type (T), Loc))))); 5415 end Build_Task_Proc_Specification; 5416 5417 --------------------------------------- 5418 -- Build_Unprotected_Subprogram_Body -- 5419 --------------------------------------- 5420 5421 function Build_Unprotected_Subprogram_Body 5422 (N : Node_Id; 5423 Pid : Node_Id) return Node_Id 5424 is 5425 Decls : constant List_Id := Declarations (N); 5426 5427 begin 5428 -- Add renamings for the Protection object, discriminals, privals, and 5429 -- the entry index constant for use by debugger. 5430 5431 Debug_Private_Data_Declarations (Decls); 5432 5433 -- Make an unprotected version of the subprogram for use within the same 5434 -- object, with a new name and an additional parameter representing the 5435 -- object. 5436 5437 return 5438 Make_Subprogram_Body (Sloc (N), 5439 Specification => 5440 Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), 5441 Declarations => Decls, 5442 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 5443 end Build_Unprotected_Subprogram_Body; 5444 5445 ---------------------------- 5446 -- Collect_Entry_Families -- 5447 ---------------------------- 5448 5449 procedure Collect_Entry_Families 5450 (Loc : Source_Ptr; 5451 Cdecls : List_Id; 5452 Current_Node : in out Node_Id; 5453 Conctyp : Entity_Id) 5454 is 5455 Efam : Entity_Id; 5456 Efam_Decl : Node_Id; 5457 Efam_Type : Entity_Id; 5458 5459 begin 5460 Efam := First_Entity (Conctyp); 5461 while Present (Efam) loop 5462 if Ekind (Efam) = E_Entry_Family then 5463 Efam_Type := Make_Temporary (Loc, 'F'); 5464 5465 declare 5466 Bas : Entity_Id := 5467 Base_Type 5468 (Etype (Discrete_Subtype_Definition (Parent (Efam)))); 5469 5470 Bas_Decl : Node_Id := Empty; 5471 Lo, Hi : Node_Id; 5472 5473 begin 5474 Get_Index_Bounds 5475 (Discrete_Subtype_Definition (Parent (Efam)), Lo, Hi); 5476 5477 if Is_Potentially_Large_Family (Bas, Conctyp, Lo, Hi) then 5478 Bas := Make_Temporary (Loc, 'B'); 5479 5480 Bas_Decl := 5481 Make_Subtype_Declaration (Loc, 5482 Defining_Identifier => Bas, 5483 Subtype_Indication => 5484 Make_Subtype_Indication (Loc, 5485 Subtype_Mark => 5486 New_Occurrence_Of (Standard_Integer, Loc), 5487 Constraint => 5488 Make_Range_Constraint (Loc, 5489 Range_Expression => Make_Range (Loc, 5490 Make_Integer_Literal 5491 (Loc, -Entry_Family_Bound), 5492 Make_Integer_Literal 5493 (Loc, Entry_Family_Bound - 1))))); 5494 5495 Insert_After (Current_Node, Bas_Decl); 5496 Current_Node := Bas_Decl; 5497 Analyze (Bas_Decl); 5498 end if; 5499 5500 Efam_Decl := 5501 Make_Full_Type_Declaration (Loc, 5502 Defining_Identifier => Efam_Type, 5503 Type_Definition => 5504 Make_Unconstrained_Array_Definition (Loc, 5505 Subtype_Marks => 5506 (New_List (New_Occurrence_Of (Bas, Loc))), 5507 5508 Component_Definition => 5509 Make_Component_Definition (Loc, 5510 Aliased_Present => False, 5511 Subtype_Indication => 5512 New_Occurrence_Of (Standard_Character, Loc)))); 5513 end; 5514 5515 Insert_After (Current_Node, Efam_Decl); 5516 Current_Node := Efam_Decl; 5517 Analyze (Efam_Decl); 5518 5519 Append_To (Cdecls, 5520 Make_Component_Declaration (Loc, 5521 Defining_Identifier => 5522 Make_Defining_Identifier (Loc, Chars (Efam)), 5523 5524 Component_Definition => 5525 Make_Component_Definition (Loc, 5526 Aliased_Present => False, 5527 Subtype_Indication => 5528 Make_Subtype_Indication (Loc, 5529 Subtype_Mark => 5530 New_Occurrence_Of (Efam_Type, Loc), 5531 5532 Constraint => 5533 Make_Index_Or_Discriminant_Constraint (Loc, 5534 Constraints => New_List ( 5535 New_Occurrence_Of 5536 (Etype (Discrete_Subtype_Definition 5537 (Parent (Efam))), Loc))))))); 5538 5539 end if; 5540 5541 Next_Entity (Efam); 5542 end loop; 5543 end Collect_Entry_Families; 5544 5545 ----------------------- 5546 -- Concurrent_Object -- 5547 ----------------------- 5548 5549 function Concurrent_Object 5550 (Spec_Id : Entity_Id; 5551 Conc_Typ : Entity_Id) return Entity_Id 5552 is 5553 begin 5554 -- Parameter _O or _object 5555 5556 if Is_Protected_Type (Conc_Typ) then 5557 return First_Formal (Protected_Body_Subprogram (Spec_Id)); 5558 5559 -- Parameter _task 5560 5561 else 5562 pragma Assert (Is_Task_Type (Conc_Typ)); 5563 return First_Formal (Task_Body_Procedure (Conc_Typ)); 5564 end if; 5565 end Concurrent_Object; 5566 5567 ---------------------- 5568 -- Copy_Result_Type -- 5569 ---------------------- 5570 5571 function Copy_Result_Type (Res : Node_Id) return Node_Id is 5572 New_Res : constant Node_Id := New_Copy_Tree (Res); 5573 Par_Spec : Node_Id; 5574 Formal : Entity_Id; 5575 5576 begin 5577 -- If the result type is an access_to_subprogram, we must create new 5578 -- entities for its spec. 5579 5580 if Nkind (New_Res) = N_Access_Definition 5581 and then Present (Access_To_Subprogram_Definition (New_Res)) 5582 then 5583 -- Provide new entities for the formals 5584 5585 Par_Spec := First (Parameter_Specifications 5586 (Access_To_Subprogram_Definition (New_Res))); 5587 while Present (Par_Spec) loop 5588 Formal := Defining_Identifier (Par_Spec); 5589 Set_Defining_Identifier (Par_Spec, 5590 Make_Defining_Identifier (Sloc (Formal), Chars (Formal))); 5591 Next (Par_Spec); 5592 end loop; 5593 end if; 5594 5595 return New_Res; 5596 end Copy_Result_Type; 5597 5598 -------------------- 5599 -- Concurrent_Ref -- 5600 -------------------- 5601 5602 -- The expression returned for a reference to a concurrent object has the 5603 -- form: 5604 5605 -- taskV!(name)._Task_Id 5606 5607 -- for a task, and 5608 5609 -- objectV!(name)._Object 5610 5611 -- for a protected object. For the case of an access to a concurrent 5612 -- object, there is an extra explicit dereference: 5613 5614 -- taskV!(name.all)._Task_Id 5615 -- objectV!(name.all)._Object 5616 5617 -- here taskV and objectV are the types for the associated records, which 5618 -- contain the required _Task_Id and _Object fields for tasks and protected 5619 -- objects, respectively. 5620 5621 -- For the case of a task type name, the expression is 5622 5623 -- Self; 5624 5625 -- i.e. a call to the Self function which returns precisely this Task_Id 5626 5627 -- For the case of a protected type name, the expression is 5628 5629 -- objectR 5630 5631 -- which is a renaming of the _object field of the current object 5632 -- record, passed into protected operations as a parameter. 5633 5634 function Concurrent_Ref (N : Node_Id) return Node_Id is 5635 Loc : constant Source_Ptr := Sloc (N); 5636 Ntyp : constant Entity_Id := Etype (N); 5637 Dtyp : Entity_Id; 5638 Sel : Name_Id; 5639 5640 function Is_Current_Task (T : Entity_Id) return Boolean; 5641 -- Check whether the reference is to the immediately enclosing task 5642 -- type, or to an outer one (rare but legal). 5643 5644 --------------------- 5645 -- Is_Current_Task -- 5646 --------------------- 5647 5648 function Is_Current_Task (T : Entity_Id) return Boolean is 5649 Scop : Entity_Id; 5650 5651 begin 5652 Scop := Current_Scope; 5653 while Present (Scop) and then Scop /= Standard_Standard loop 5654 if Scop = T then 5655 return True; 5656 5657 elsif Is_Task_Type (Scop) then 5658 return False; 5659 5660 -- If this is a procedure nested within the task type, we must 5661 -- assume that it can be called from an inner task, and therefore 5662 -- cannot treat it as a local reference. 5663 5664 elsif Is_Overloadable (Scop) and then In_Open_Scopes (T) then 5665 return False; 5666 5667 else 5668 Scop := Scope (Scop); 5669 end if; 5670 end loop; 5671 5672 -- We know that we are within the task body, so should have found it 5673 -- in scope. 5674 5675 raise Program_Error; 5676 end Is_Current_Task; 5677 5678 -- Start of processing for Concurrent_Ref 5679 5680 begin 5681 if Is_Access_Type (Ntyp) then 5682 Dtyp := Designated_Type (Ntyp); 5683 5684 if Is_Protected_Type (Dtyp) then 5685 Sel := Name_uObject; 5686 else 5687 Sel := Name_uTask_Id; 5688 end if; 5689 5690 return 5691 Make_Selected_Component (Loc, 5692 Prefix => 5693 Unchecked_Convert_To (Corresponding_Record_Type (Dtyp), 5694 Make_Explicit_Dereference (Loc, N)), 5695 Selector_Name => Make_Identifier (Loc, Sel)); 5696 5697 elsif Is_Entity_Name (N) and then Is_Concurrent_Type (Entity (N)) then 5698 if Is_Task_Type (Entity (N)) then 5699 5700 if Is_Current_Task (Entity (N)) then 5701 return 5702 Make_Function_Call (Loc, 5703 Name => New_Occurrence_Of (RTE (RE_Self), Loc)); 5704 5705 else 5706 declare 5707 Decl : Node_Id; 5708 T_Self : constant Entity_Id := Make_Temporary (Loc, 'T'); 5709 T_Body : constant Node_Id := 5710 Parent (Corresponding_Body (Parent (Entity (N)))); 5711 5712 begin 5713 Decl := 5714 Make_Object_Declaration (Loc, 5715 Defining_Identifier => T_Self, 5716 Object_Definition => 5717 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 5718 Expression => 5719 Make_Function_Call (Loc, 5720 Name => New_Occurrence_Of (RTE (RE_Self), Loc))); 5721 Prepend (Decl, Declarations (T_Body)); 5722 Analyze (Decl); 5723 Set_Scope (T_Self, Entity (N)); 5724 return New_Occurrence_Of (T_Self, Loc); 5725 end; 5726 end if; 5727 5728 else 5729 pragma Assert (Is_Protected_Type (Entity (N))); 5730 5731 return 5732 New_Occurrence_Of (Find_Protection_Object (Current_Scope), Loc); 5733 end if; 5734 5735 else 5736 if Is_Protected_Type (Ntyp) then 5737 Sel := Name_uObject; 5738 elsif Is_Task_Type (Ntyp) then 5739 Sel := Name_uTask_Id; 5740 else 5741 raise Program_Error; 5742 end if; 5743 5744 return 5745 Make_Selected_Component (Loc, 5746 Prefix => 5747 Unchecked_Convert_To (Corresponding_Record_Type (Ntyp), 5748 New_Copy_Tree (N)), 5749 Selector_Name => Make_Identifier (Loc, Sel)); 5750 end if; 5751 end Concurrent_Ref; 5752 5753 ------------------------ 5754 -- Convert_Concurrent -- 5755 ------------------------ 5756 5757 function Convert_Concurrent 5758 (N : Node_Id; 5759 Typ : Entity_Id) return Node_Id 5760 is 5761 begin 5762 if not Is_Concurrent_Type (Typ) then 5763 return N; 5764 else 5765 return 5766 Unchecked_Convert_To 5767 (Corresponding_Record_Type (Typ), New_Copy_Tree (N)); 5768 end if; 5769 end Convert_Concurrent; 5770 5771 ------------------------------------- 5772 -- Debug_Private_Data_Declarations -- 5773 ------------------------------------- 5774 5775 procedure Debug_Private_Data_Declarations (Decls : List_Id) is 5776 Debug_Nod : Node_Id; 5777 Decl : Node_Id; 5778 5779 begin 5780 Decl := First (Decls); 5781 while Present (Decl) and then not Comes_From_Source (Decl) loop 5782 5783 -- Declaration for concurrent entity _object and its access type, 5784 -- along with the entry index subtype: 5785 -- type prot_typVP is access prot_typV; 5786 -- _object : prot_typVP := prot_typV (_O); 5787 -- subtype Jnn is <Type of Index> range Low .. High; 5788 5789 if Nkind_In (Decl, N_Full_Type_Declaration, N_Object_Declaration) then 5790 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5791 5792 -- Declaration for the Protection object, discriminals, privals, and 5793 -- entry index constant: 5794 -- conc_typR : protection_typ renames _object._object; 5795 -- discr_nameD : discr_typ renames _object.discr_name; 5796 -- discr_nameD : discr_typ renames _task.discr_name; 5797 -- prival_name : comp_typ renames _object.comp_name; 5798 -- J : constant Jnn := 5799 -- Jnn'Val (_E - <Index expression> + Jnn'Pos (Jnn'First)); 5800 5801 elsif Nkind (Decl) = N_Object_Renaming_Declaration then 5802 Set_Debug_Info_Needed (Defining_Identifier (Decl)); 5803 Debug_Nod := Debug_Renaming_Declaration (Decl); 5804 5805 if Present (Debug_Nod) then 5806 Insert_After (Decl, Debug_Nod); 5807 end if; 5808 end if; 5809 5810 Next (Decl); 5811 end loop; 5812 end Debug_Private_Data_Declarations; 5813 5814 ------------------------------ 5815 -- Ensure_Statement_Present -- 5816 ------------------------------ 5817 5818 procedure Ensure_Statement_Present (Loc : Source_Ptr; Alt : Node_Id) is 5819 Stmt : Node_Id; 5820 5821 begin 5822 if Opt.Suppress_Control_Flow_Optimizations 5823 and then Is_Empty_List (Statements (Alt)) 5824 then 5825 Stmt := Make_Null_Statement (Loc); 5826 5827 -- Mark NULL statement as coming from source so that it is not 5828 -- eliminated by GIGI. 5829 5830 -- Another covert channel. If this is a requirement, it must be 5831 -- documented in sinfo/einfo ??? 5832 5833 Set_Comes_From_Source (Stmt, True); 5834 5835 Set_Statements (Alt, New_List (Stmt)); 5836 end if; 5837 end Ensure_Statement_Present; 5838 5839 ---------------------------- 5840 -- Entry_Index_Expression -- 5841 ---------------------------- 5842 5843 function Entry_Index_Expression 5844 (Sloc : Source_Ptr; 5845 Ent : Entity_Id; 5846 Index : Node_Id; 5847 Ttyp : Entity_Id) return Node_Id 5848 is 5849 Expr : Node_Id; 5850 Num : Node_Id; 5851 Lo : Node_Id; 5852 Hi : Node_Id; 5853 Prev : Entity_Id; 5854 S : Node_Id; 5855 5856 begin 5857 -- The queues of entries and entry families appear in textual order in 5858 -- the associated record. The entry index is computed as the sum of the 5859 -- number of queues for all entries that precede the designated one, to 5860 -- which is added the index expression, if this expression denotes a 5861 -- member of a family. 5862 5863 -- The following is a place holder for the count of simple entries 5864 5865 Num := Make_Integer_Literal (Sloc, 1); 5866 5867 -- We construct an expression which is a series of addition operations. 5868 -- The first operand is the number of single entries that precede this 5869 -- one, the second operand is the index value relative to the start of 5870 -- the referenced family, and the remaining operands are the lengths of 5871 -- the entry families that precede this entry, i.e. the constructed 5872 -- expression is: 5873 5874 -- number_simple_entries + 5875 -- (s'pos (index-value) - s'pos (family'first)) + 1 + 5876 -- family'length + ... 5877 5878 -- where index-value is the given index value, and s is the index 5879 -- subtype (we have to use pos because the subtype might be an 5880 -- enumeration type preventing direct subtraction). Note that the task 5881 -- entry array is one-indexed. 5882 5883 -- The upper bound of the entry family may be a discriminant, so we 5884 -- retrieve the lower bound explicitly to compute offset, rather than 5885 -- using the index subtype which may mention a discriminant. 5886 5887 if Present (Index) then 5888 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); 5889 5890 Expr := 5891 Make_Op_Add (Sloc, 5892 Left_Opnd => Num, 5893 Right_Opnd => 5894 Family_Offset 5895 (Sloc, 5896 Make_Attribute_Reference (Sloc, 5897 Attribute_Name => Name_Pos, 5898 Prefix => New_Occurrence_Of (Base_Type (S), Sloc), 5899 Expressions => New_List (Relocate_Node (Index))), 5900 Type_Low_Bound (S), 5901 Ttyp, 5902 False)); 5903 else 5904 Expr := Num; 5905 end if; 5906 5907 -- Now add lengths of preceding entries and entry families 5908 5909 Prev := First_Entity (Ttyp); 5910 while Chars (Prev) /= Chars (Ent) 5911 or else (Ekind (Prev) /= Ekind (Ent)) 5912 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 5913 loop 5914 if Ekind (Prev) = E_Entry then 5915 Set_Intval (Num, Intval (Num) + 1); 5916 5917 elsif Ekind (Prev) = E_Entry_Family then 5918 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); 5919 Lo := Type_Low_Bound (S); 5920 Hi := Type_High_Bound (S); 5921 5922 Expr := 5923 Make_Op_Add (Sloc, 5924 Left_Opnd => Expr, 5925 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp, False)); 5926 5927 -- Other components are anonymous types to be ignored 5928 5929 else 5930 null; 5931 end if; 5932 5933 Next_Entity (Prev); 5934 end loop; 5935 5936 return Expr; 5937 end Entry_Index_Expression; 5938 5939 --------------------------- 5940 -- Establish_Task_Master -- 5941 --------------------------- 5942 5943 procedure Establish_Task_Master (N : Node_Id) is 5944 Call : Node_Id; 5945 5946 begin 5947 if Restriction_Active (No_Task_Hierarchy) = False then 5948 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master); 5949 5950 -- The block may have no declarations (and nevertheless be a task 5951 -- master) if it contains a call that may return an object that 5952 -- contains tasks. 5953 5954 if No (Declarations (N)) then 5955 Set_Declarations (N, New_List (Call)); 5956 else 5957 Prepend_To (Declarations (N), Call); 5958 end if; 5959 5960 Analyze (Call); 5961 end if; 5962 end Establish_Task_Master; 5963 5964 -------------------------------- 5965 -- Expand_Accept_Declarations -- 5966 -------------------------------- 5967 5968 -- Part of the expansion of an accept statement involves the creation of 5969 -- a declaration that can be referenced from the statement sequence of 5970 -- the accept: 5971 5972 -- Ann : Address; 5973 5974 -- This declaration is inserted immediately before the accept statement 5975 -- and it is important that it be inserted before the statements of the 5976 -- statement sequence are analyzed. Thus it would be too late to create 5977 -- this declaration in the Expand_N_Accept_Statement routine, which is 5978 -- why there is a separate procedure to be called directly from Sem_Ch9. 5979 5980 -- Ann is used to hold the address of the record containing the parameters 5981 -- (see Expand_N_Entry_Call for more details on how this record is built). 5982 -- References to the parameters do an unchecked conversion of this address 5983 -- to a pointer to the required record type, and then access the field that 5984 -- holds the value of the required parameter. The entity for the address 5985 -- variable is held as the top stack element (i.e. the last element) of the 5986 -- Accept_Address stack in the corresponding entry entity, and this element 5987 -- must be set in place before the statements are processed. 5988 5989 -- The above description applies to the case of a stand alone accept 5990 -- statement, i.e. one not appearing as part of a select alternative. 5991 5992 -- For the case of an accept that appears as part of a select alternative 5993 -- of a selective accept, we must still create the declaration right away, 5994 -- since Ann is needed immediately, but there is an important difference: 5995 5996 -- The declaration is inserted before the selective accept, not before 5997 -- the accept statement (which is not part of a list anyway, and so would 5998 -- not accommodate inserted declarations) 5999 6000 -- We only need one address variable for the entire selective accept. So 6001 -- the Ann declaration is created only for the first accept alternative, 6002 -- and subsequent accept alternatives reference the same Ann variable. 6003 6004 -- We can distinguish the two cases by seeing whether the accept statement 6005 -- is part of a list. If not, then it must be in an accept alternative. 6006 6007 -- To expand the requeue statement, a label is provided at the end of the 6008 -- accept statement or alternative of which it is a part, so that the 6009 -- statement can be skipped after the requeue is complete. This label is 6010 -- created here rather than during the expansion of the accept statement, 6011 -- because it will be needed by any requeue statements within the accept, 6012 -- which are expanded before the accept. 6013 6014 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is 6015 Loc : constant Source_Ptr := Sloc (N); 6016 Stats : constant Node_Id := Handled_Statement_Sequence (N); 6017 Ann : Entity_Id := Empty; 6018 Adecl : Node_Id; 6019 Lab : Node_Id; 6020 Ldecl : Node_Id; 6021 Ldecl2 : Node_Id; 6022 6023 begin 6024 if Expander_Active then 6025 6026 -- If we have no handled statement sequence, we may need to build 6027 -- a dummy sequence consisting of a null statement. This can be 6028 -- skipped if the trivial accept optimization is permitted. 6029 6030 if not Trivial_Accept_OK 6031 and then (No (Stats) or else Null_Statements (Statements (Stats))) 6032 then 6033 Set_Handled_Statement_Sequence (N, 6034 Make_Handled_Sequence_Of_Statements (Loc, 6035 Statements => New_List (Make_Null_Statement (Loc)))); 6036 end if; 6037 6038 -- Create and declare two labels to be placed at the end of the 6039 -- accept statement. The first label is used to allow requeues to 6040 -- skip the remainder of entry processing. The second label is used 6041 -- to skip the remainder of entry processing if the rendezvous 6042 -- completes in the middle of the accept body. 6043 6044 if Present (Handled_Statement_Sequence (N)) then 6045 declare 6046 Ent : Entity_Id; 6047 6048 begin 6049 Ent := Make_Temporary (Loc, 'L'); 6050 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 6051 Ldecl := 6052 Make_Implicit_Label_Declaration (Loc, 6053 Defining_Identifier => Ent, 6054 Label_Construct => Lab); 6055 Append (Lab, Statements (Handled_Statement_Sequence (N))); 6056 6057 Ent := Make_Temporary (Loc, 'L'); 6058 Lab := Make_Label (Loc, New_Occurrence_Of (Ent, Loc)); 6059 Ldecl2 := 6060 Make_Implicit_Label_Declaration (Loc, 6061 Defining_Identifier => Ent, 6062 Label_Construct => Lab); 6063 Append (Lab, Statements (Handled_Statement_Sequence (N))); 6064 end; 6065 6066 else 6067 Ldecl := Empty; 6068 Ldecl2 := Empty; 6069 end if; 6070 6071 -- Case of stand alone accept statement 6072 6073 if Is_List_Member (N) then 6074 6075 if Present (Handled_Statement_Sequence (N)) then 6076 Ann := Make_Temporary (Loc, 'A'); 6077 6078 Adecl := 6079 Make_Object_Declaration (Loc, 6080 Defining_Identifier => Ann, 6081 Object_Definition => 6082 New_Occurrence_Of (RTE (RE_Address), Loc)); 6083 6084 Insert_Before_And_Analyze (N, Adecl); 6085 Insert_Before_And_Analyze (N, Ldecl); 6086 Insert_Before_And_Analyze (N, Ldecl2); 6087 end if; 6088 6089 -- Case of accept statement which is in an accept alternative 6090 6091 else 6092 declare 6093 Acc_Alt : constant Node_Id := Parent (N); 6094 Sel_Acc : constant Node_Id := Parent (Acc_Alt); 6095 Alt : Node_Id; 6096 6097 begin 6098 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative); 6099 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept); 6100 6101 -- ??? Consider a single label for select statements 6102 6103 if Present (Handled_Statement_Sequence (N)) then 6104 Prepend (Ldecl2, 6105 Statements (Handled_Statement_Sequence (N))); 6106 Analyze (Ldecl2); 6107 6108 Prepend (Ldecl, 6109 Statements (Handled_Statement_Sequence (N))); 6110 Analyze (Ldecl); 6111 end if; 6112 6113 -- Find first accept alternative of the selective accept. A 6114 -- valid selective accept must have at least one accept in it. 6115 6116 Alt := First (Select_Alternatives (Sel_Acc)); 6117 6118 while Nkind (Alt) /= N_Accept_Alternative loop 6119 Next (Alt); 6120 end loop; 6121 6122 -- If this is the first accept statement, then we have to 6123 -- create the Ann variable, as for the stand alone case, except 6124 -- that it is inserted before the selective accept. Similarly, 6125 -- a label for requeue expansion must be declared. 6126 6127 if N = Accept_Statement (Alt) then 6128 Ann := Make_Temporary (Loc, 'A'); 6129 Adecl := 6130 Make_Object_Declaration (Loc, 6131 Defining_Identifier => Ann, 6132 Object_Definition => 6133 New_Occurrence_Of (RTE (RE_Address), Loc)); 6134 6135 Insert_Before_And_Analyze (Sel_Acc, Adecl); 6136 6137 -- If this is not the first accept statement, then find the Ann 6138 -- variable allocated by the first accept and use it. 6139 6140 else 6141 Ann := 6142 Node (Last_Elmt (Accept_Address 6143 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))))); 6144 end if; 6145 end; 6146 end if; 6147 6148 -- Merge here with Ann either created or referenced, and Adecl 6149 -- pointing to the corresponding declaration. Remaining processing 6150 -- is the same for the two cases. 6151 6152 if Present (Ann) then 6153 Append_Elmt (Ann, Accept_Address (Ent)); 6154 Set_Debug_Info_Needed (Ann); 6155 end if; 6156 6157 -- Create renaming declarations for the entry formals. Each reference 6158 -- to a formal becomes a dereference of a component of the parameter 6159 -- block, whose address is held in Ann. These declarations are 6160 -- eventually inserted into the accept block, and analyzed there so 6161 -- that they have the proper scope for gdb and do not conflict with 6162 -- other declarations. 6163 6164 if Present (Parameter_Specifications (N)) 6165 and then Present (Handled_Statement_Sequence (N)) 6166 then 6167 declare 6168 Comp : Entity_Id; 6169 Decl : Node_Id; 6170 Formal : Entity_Id; 6171 New_F : Entity_Id; 6172 Renamed_Formal : Node_Id; 6173 6174 begin 6175 Push_Scope (Ent); 6176 Formal := First_Formal (Ent); 6177 6178 while Present (Formal) loop 6179 Comp := Entry_Component (Formal); 6180 New_F := Make_Defining_Identifier (Loc, Chars (Formal)); 6181 6182 Set_Etype (New_F, Etype (Formal)); 6183 Set_Scope (New_F, Ent); 6184 6185 -- Now we set debug info needed on New_F even though it does 6186 -- not come from source, so that the debugger will get the 6187 -- right information for these generated names. 6188 6189 Set_Debug_Info_Needed (New_F); 6190 6191 if Ekind (Formal) = E_In_Parameter then 6192 Set_Ekind (New_F, E_Constant); 6193 else 6194 Set_Ekind (New_F, E_Variable); 6195 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 6196 end if; 6197 6198 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 6199 6200 Renamed_Formal := 6201 Make_Selected_Component (Loc, 6202 Prefix => 6203 Unchecked_Convert_To ( 6204 Entry_Parameters_Type (Ent), 6205 New_Occurrence_Of (Ann, Loc)), 6206 Selector_Name => 6207 New_Occurrence_Of (Comp, Loc)); 6208 6209 Decl := 6210 Build_Renamed_Formal_Declaration 6211 (New_F, Formal, Comp, Renamed_Formal); 6212 6213 if No (Declarations (N)) then 6214 Set_Declarations (N, New_List); 6215 end if; 6216 6217 Append (Decl, Declarations (N)); 6218 Set_Renamed_Object (Formal, New_F); 6219 Next_Formal (Formal); 6220 end loop; 6221 6222 End_Scope; 6223 end; 6224 end if; 6225 end if; 6226 end Expand_Accept_Declarations; 6227 6228 --------------------------------------------- 6229 -- Expand_Access_Protected_Subprogram_Type -- 6230 --------------------------------------------- 6231 6232 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is 6233 Loc : constant Source_Ptr := Sloc (N); 6234 Comps : List_Id; 6235 T : constant Entity_Id := Defining_Identifier (N); 6236 D_T : constant Entity_Id := Designated_Type (T); 6237 D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D'); 6238 E_T : constant Entity_Id := Make_Temporary (Loc, 'E'); 6239 P_List : constant List_Id := Build_Protected_Spec 6240 (N, RTE (RE_Address), D_T, False); 6241 Decl1 : Node_Id; 6242 Decl2 : Node_Id; 6243 Def1 : Node_Id; 6244 6245 begin 6246 -- Create access to subprogram with full signature 6247 6248 if Etype (D_T) /= Standard_Void_Type then 6249 Def1 := 6250 Make_Access_Function_Definition (Loc, 6251 Parameter_Specifications => P_List, 6252 Result_Definition => 6253 Copy_Result_Type (Result_Definition (Type_Definition (N)))); 6254 6255 else 6256 Def1 := 6257 Make_Access_Procedure_Definition (Loc, 6258 Parameter_Specifications => P_List); 6259 end if; 6260 6261 Decl1 := 6262 Make_Full_Type_Declaration (Loc, 6263 Defining_Identifier => D_T2, 6264 Type_Definition => Def1); 6265 6266 Insert_After_And_Analyze (N, Decl1); 6267 6268 -- Associate the access to subprogram with its original access to 6269 -- protected subprogram type. Needed by the backend to know that this 6270 -- type corresponds with an access to protected subprogram type. 6271 6272 Set_Original_Access_Type (D_T2, T); 6273 6274 -- Create Equivalent_Type, a record with two components for an access to 6275 -- object and an access to subprogram. 6276 6277 Comps := New_List ( 6278 Make_Component_Declaration (Loc, 6279 Defining_Identifier => Make_Temporary (Loc, 'P'), 6280 Component_Definition => 6281 Make_Component_Definition (Loc, 6282 Aliased_Present => False, 6283 Subtype_Indication => 6284 New_Occurrence_Of (RTE (RE_Address), Loc))), 6285 6286 Make_Component_Declaration (Loc, 6287 Defining_Identifier => Make_Temporary (Loc, 'S'), 6288 Component_Definition => 6289 Make_Component_Definition (Loc, 6290 Aliased_Present => False, 6291 Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); 6292 6293 Decl2 := 6294 Make_Full_Type_Declaration (Loc, 6295 Defining_Identifier => E_T, 6296 Type_Definition => 6297 Make_Record_Definition (Loc, 6298 Component_List => 6299 Make_Component_List (Loc, Component_Items => Comps))); 6300 6301 Insert_After_And_Analyze (Decl1, Decl2); 6302 Set_Equivalent_Type (T, E_T); 6303 end Expand_Access_Protected_Subprogram_Type; 6304 6305 -------------------------- 6306 -- Expand_Entry_Barrier -- 6307 -------------------------- 6308 6309 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is 6310 Cond : constant Node_Id := 6311 Condition (Entry_Body_Formal_Part (N)); 6312 Prot : constant Entity_Id := Scope (Ent); 6313 Spec_Decl : constant Node_Id := Parent (Prot); 6314 Func : Entity_Id := Empty; 6315 B_F : Node_Id; 6316 Body_Decl : Node_Id; 6317 6318 function Is_Global_Entity (N : Node_Id) return Traverse_Result; 6319 -- Check whether entity in Barrier is external to protected type. 6320 -- If so, barrier may not be properly synchronized. 6321 6322 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result; 6323 -- Check whether N follows the Pure_Barriers restriction. Return OK if 6324 -- so. 6325 6326 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean; 6327 -- Check whether entity name N denotes a component of the protected 6328 -- object. This is used to check the Simple_Barrier restriction. 6329 6330 ---------------------- 6331 -- Is_Global_Entity -- 6332 ---------------------- 6333 6334 function Is_Global_Entity (N : Node_Id) return Traverse_Result is 6335 E : Entity_Id; 6336 S : Entity_Id; 6337 6338 begin 6339 if Is_Entity_Name (N) and then Present (Entity (N)) then 6340 E := Entity (N); 6341 S := Scope (E); 6342 6343 if Ekind (E) = E_Variable then 6344 6345 -- If the variable is local to the barrier function generated 6346 -- during expansion, it is ok. If expansion is not performed, 6347 -- then Func is Empty so this test cannot succeed. 6348 6349 if Scope (E) = Func then 6350 null; 6351 6352 -- A protected call from a barrier to another object is ok 6353 6354 elsif Ekind (Etype (E)) = E_Protected_Type then 6355 null; 6356 6357 -- If the variable is within the package body we consider 6358 -- this safe. This is a common (if dubious) idiom. 6359 6360 elsif S = Scope (Prot) 6361 and then Ekind_In (S, E_Package, E_Generic_Package) 6362 and then Nkind (Parent (E)) = N_Object_Declaration 6363 and then Nkind (Parent (Parent (E))) = N_Package_Body 6364 then 6365 null; 6366 6367 else 6368 Error_Msg_N ("potentially unsynchronized barrier??", N); 6369 Error_Msg_N ("\& should be private component of type??", N); 6370 end if; 6371 end if; 6372 end if; 6373 6374 return OK; 6375 end Is_Global_Entity; 6376 6377 procedure Check_Unprotected_Barrier is 6378 new Traverse_Proc (Is_Global_Entity); 6379 6380 ---------------------------- 6381 -- Is_Simple_Barrier_Name -- 6382 ---------------------------- 6383 6384 function Is_Simple_Barrier_Name (N : Node_Id) return Boolean is 6385 Renamed : Node_Id; 6386 6387 begin 6388 -- Check for case of _object.all.field (note that the explicit 6389 -- dereference gets inserted by analyze/expand of _object.field). 6390 6391 if Expander_Active then 6392 Renamed := Renamed_Object (Entity (N)); 6393 6394 return 6395 Present (Renamed) 6396 and then Nkind (Renamed) = N_Selected_Component 6397 and then Chars (Prefix (Prefix (Renamed))) = Name_uObject; 6398 else 6399 return Scope (Entity (N)) = Current_Scope; 6400 end if; 6401 end Is_Simple_Barrier_Name; 6402 6403 --------------------- 6404 -- Is_Pure_Barrier -- 6405 --------------------- 6406 6407 function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is 6408 begin 6409 case Nkind (N) is 6410 when N_Expanded_Name | 6411 N_Identifier => 6412 if No (Entity (N)) then 6413 return Abandon; 6414 end if; 6415 6416 case Ekind (Entity (N)) is 6417 when E_Constant | 6418 E_Discriminant | 6419 E_Named_Integer | 6420 E_Named_Real | 6421 E_Enumeration_Literal => 6422 return OK; 6423 6424 when E_Component | 6425 E_Variable => 6426 6427 -- A variable in the protected type is expanded as a 6428 -- component. 6429 6430 if Is_Simple_Barrier_Name (N) then 6431 return OK; 6432 end if; 6433 6434 when others => 6435 null; 6436 end case; 6437 6438 when N_Integer_Literal | 6439 N_Real_Literal | 6440 N_Character_Literal => 6441 return OK; 6442 6443 when N_Op_Boolean | 6444 N_Op_Not => 6445 if Ekind (Entity (N)) = E_Operator then 6446 return OK; 6447 end if; 6448 6449 when N_Short_Circuit => 6450 return OK; 6451 6452 when others => 6453 null; 6454 end case; 6455 6456 return Abandon; 6457 end Is_Pure_Barrier; 6458 6459 function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier); 6460 6461 -- Start of processing for Expand_Entry_Barrier 6462 6463 begin 6464 if No_Run_Time_Mode then 6465 Error_Msg_CRT ("entry barrier", N); 6466 return; 6467 end if; 6468 6469 -- The body of the entry barrier must be analyzed in the context of the 6470 -- protected object, but its scope is external to it, just as any other 6471 -- unprotected version of a protected operation. The specification has 6472 -- been produced when the protected type declaration was elaborated. We 6473 -- build the body, insert it in the enclosing scope, but analyze it in 6474 -- the current context. A more uniform approach would be to treat the 6475 -- barrier just as a protected function, and discard the protected 6476 -- version of it because it is never called. 6477 6478 if Expander_Active then 6479 B_F := Build_Barrier_Function (N, Ent, Prot); 6480 Func := Barrier_Function (Ent); 6481 Set_Corresponding_Spec (B_F, Func); 6482 6483 Body_Decl := Parent (Corresponding_Body (Spec_Decl)); 6484 6485 if Nkind (Parent (Body_Decl)) = N_Subunit then 6486 Body_Decl := Corresponding_Stub (Parent (Body_Decl)); 6487 end if; 6488 6489 Insert_Before_And_Analyze (Body_Decl, B_F); 6490 6491 Set_Discriminals (Spec_Decl); 6492 Set_Scope (Func, Scope (Prot)); 6493 6494 else 6495 Analyze_And_Resolve (Cond, Any_Boolean); 6496 end if; 6497 6498 -- Check Pure_Barriers restriction 6499 6500 if Check_Pure_Barriers (Cond) = Abandon then 6501 Check_Restriction (Pure_Barriers, Cond); 6502 end if; 6503 6504 -- The Ravenscar profile restricts barriers to simple variables declared 6505 -- within the protected object. We also allow Boolean constants, since 6506 -- these appear in several published examples and are also allowed by 6507 -- other compilers. 6508 6509 -- Note that after analysis variables in this context will be replaced 6510 -- by the corresponding prival, that is to say a renaming of a selected 6511 -- component of the form _Object.Var. If expansion is disabled, as 6512 -- within a generic, we check that the entity appears in the current 6513 -- scope. 6514 6515 if Is_Entity_Name (Cond) then 6516 6517 -- A small optimization of useless renamings. If the scope of the 6518 -- entity of the condition is not the barrier function, then the 6519 -- condition does not reference any of the generated renamings 6520 -- within the function. 6521 6522 if Expander_Active and then Scope (Entity (Cond)) /= Func then 6523 Set_Declarations (B_F, Empty_List); 6524 end if; 6525 6526 if Entity (Cond) = Standard_False 6527 or else 6528 Entity (Cond) = Standard_True 6529 then 6530 return; 6531 6532 elsif Is_Simple_Barrier_Name (Cond) then 6533 return; 6534 end if; 6535 end if; 6536 6537 -- It is not a boolean variable or literal, so check the restriction. 6538 -- Note that it is safe to be calling Check_Restriction from here, even 6539 -- though this is part of the expander, since Expand_Entry_Barrier is 6540 -- called from Sem_Ch9 even in -gnatc mode. 6541 6542 Check_Restriction (Simple_Barriers, Cond); 6543 6544 -- Emit warning if barrier contains global entities and is thus 6545 -- potentially unsynchronized. 6546 6547 Check_Unprotected_Barrier (Cond); 6548 end Expand_Entry_Barrier; 6549 6550 ------------------------------ 6551 -- Expand_N_Abort_Statement -- 6552 ------------------------------ 6553 6554 -- Expand abort T1, T2, .. Tn; into: 6555 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...)) 6556 6557 procedure Expand_N_Abort_Statement (N : Node_Id) is 6558 Loc : constant Source_Ptr := Sloc (N); 6559 Tlist : constant List_Id := Names (N); 6560 Count : Nat; 6561 Aggr : Node_Id; 6562 Tasknm : Node_Id; 6563 6564 begin 6565 Aggr := Make_Aggregate (Loc, Component_Associations => New_List); 6566 Count := 0; 6567 6568 Tasknm := First (Tlist); 6569 6570 while Present (Tasknm) loop 6571 Count := Count + 1; 6572 6573 -- A task interface class-wide type object is being aborted. Retrieve 6574 -- its _task_id by calling a dispatching routine. 6575 6576 if Ada_Version >= Ada_2005 6577 and then Ekind (Etype (Tasknm)) = E_Class_Wide_Type 6578 and then Is_Interface (Etype (Tasknm)) 6579 and then Is_Task_Interface (Etype (Tasknm)) 6580 then 6581 Append_To (Component_Associations (Aggr), 6582 Make_Component_Association (Loc, 6583 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6584 Expression => 6585 6586 -- Task_Id (Tasknm._disp_get_task_id) 6587 6588 Make_Unchecked_Type_Conversion (Loc, 6589 Subtype_Mark => 6590 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc), 6591 Expression => 6592 Make_Selected_Component (Loc, 6593 Prefix => New_Copy_Tree (Tasknm), 6594 Selector_Name => 6595 Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))); 6596 6597 else 6598 Append_To (Component_Associations (Aggr), 6599 Make_Component_Association (Loc, 6600 Choices => New_List (Make_Integer_Literal (Loc, Count)), 6601 Expression => Concurrent_Ref (Tasknm))); 6602 end if; 6603 6604 Next (Tasknm); 6605 end loop; 6606 6607 Rewrite (N, 6608 Make_Procedure_Call_Statement (Loc, 6609 Name => New_Occurrence_Of (RTE (RE_Abort_Tasks), Loc), 6610 Parameter_Associations => New_List ( 6611 Make_Qualified_Expression (Loc, 6612 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_List), Loc), 6613 Expression => Aggr)))); 6614 6615 Analyze (N); 6616 end Expand_N_Abort_Statement; 6617 6618 ------------------------------- 6619 -- Expand_N_Accept_Statement -- 6620 ------------------------------- 6621 6622 -- This procedure handles expansion of accept statements that stand alone, 6623 -- i.e. they are not part of an accept alternative. The expansion of 6624 -- accept statement in accept alternatives is handled by the routines 6625 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The 6626 -- following description applies only to stand alone accept statements. 6627 6628 -- If there is no handled statement sequence, or only null statements, then 6629 -- this is called a trivial accept, and the expansion is: 6630 6631 -- Accept_Trivial (entry-index) 6632 6633 -- If there is a handled statement sequence, then the expansion is: 6634 6635 -- Ann : Address; 6636 -- {Lnn : Label} 6637 6638 -- begin 6639 -- begin 6640 -- Accept_Call (entry-index, Ann); 6641 -- Renaming_Declarations for formals 6642 -- <statement sequence from N_Accept_Statement node> 6643 -- Complete_Rendezvous; 6644 -- <<Lnn>> 6645 -- 6646 -- exception 6647 -- when ... => 6648 -- <exception handler from N_Accept_Statement node> 6649 -- Complete_Rendezvous; 6650 -- when ... => 6651 -- <exception handler from N_Accept_Statement node> 6652 -- Complete_Rendezvous; 6653 -- ... 6654 -- end; 6655 6656 -- exception 6657 -- when all others => 6658 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 6659 -- end; 6660 6661 -- The first three declarations were already inserted ahead of the accept 6662 -- statement by the Expand_Accept_Declarations procedure, which was called 6663 -- directly from the semantics during analysis of the accept statement, 6664 -- before analyzing its contained statements. 6665 6666 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come 6667 -- from possible expansion activity (the original source of course does 6668 -- not have any declarations associated with the accept statement, since 6669 -- an accept statement has no declarative part). In particular, if the 6670 -- expander is active, the first such declaration is the declaration of 6671 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement). 6672 6673 -- The two blocks are merged into a single block if the inner block has 6674 -- no exception handlers, but otherwise two blocks are required, since 6675 -- exceptions might be raised in the exception handlers of the inner 6676 -- block, and Exceptional_Complete_Rendezvous must be called. 6677 6678 procedure Expand_N_Accept_Statement (N : Node_Id) is 6679 Loc : constant Source_Ptr := Sloc (N); 6680 Stats : constant Node_Id := Handled_Statement_Sequence (N); 6681 Ename : constant Node_Id := Entry_Direct_Name (N); 6682 Eindx : constant Node_Id := Entry_Index (N); 6683 Eent : constant Entity_Id := Entity (Ename); 6684 Acstack : constant Elist_Id := Accept_Address (Eent); 6685 Ann : constant Entity_Id := Node (Last_Elmt (Acstack)); 6686 Ttyp : constant Entity_Id := Etype (Scope (Eent)); 6687 Blkent : Entity_Id; 6688 Call : Node_Id; 6689 Block : Node_Id; 6690 6691 begin 6692 -- If the accept statement is not part of a list, then its parent must 6693 -- be an accept alternative, and, as described above, we do not do any 6694 -- expansion for such accept statements at this level. 6695 6696 if not Is_List_Member (N) then 6697 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative); 6698 return; 6699 6700 -- Trivial accept case (no statement sequence, or null statements). 6701 -- If the accept statement has declarations, then just insert them 6702 -- before the procedure call. 6703 6704 elsif Trivial_Accept_OK 6705 and then (No (Stats) or else Null_Statements (Statements (Stats))) 6706 then 6707 -- Remove declarations for renamings, because the parameter block 6708 -- will not be assigned. 6709 6710 declare 6711 D : Node_Id; 6712 Next_D : Node_Id; 6713 6714 begin 6715 D := First (Declarations (N)); 6716 while Present (D) loop 6717 Next_D := Next (D); 6718 if Nkind (D) = N_Object_Renaming_Declaration then 6719 Remove (D); 6720 end if; 6721 6722 D := Next_D; 6723 end loop; 6724 end; 6725 6726 if Present (Declarations (N)) then 6727 Insert_Actions (N, Declarations (N)); 6728 end if; 6729 6730 Rewrite (N, 6731 Make_Procedure_Call_Statement (Loc, 6732 Name => New_Occurrence_Of (RTE (RE_Accept_Trivial), Loc), 6733 Parameter_Associations => New_List ( 6734 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp)))); 6735 6736 Analyze (N); 6737 6738 -- Discard Entry_Address that was created for it, so it will not be 6739 -- emitted if this accept statement is in the statement part of a 6740 -- delay alternative. 6741 6742 if Present (Stats) then 6743 Remove_Last_Elmt (Acstack); 6744 end if; 6745 6746 -- Case of statement sequence present 6747 6748 else 6749 -- Construct the block, using the declarations from the accept 6750 -- statement if any to initialize the declarations of the block. 6751 6752 Blkent := Make_Temporary (Loc, 'A'); 6753 Set_Ekind (Blkent, E_Block); 6754 Set_Etype (Blkent, Standard_Void_Type); 6755 Set_Scope (Blkent, Current_Scope); 6756 6757 Block := 6758 Make_Block_Statement (Loc, 6759 Identifier => New_Occurrence_Of (Blkent, Loc), 6760 Declarations => Declarations (N), 6761 Handled_Statement_Sequence => Build_Accept_Body (N)); 6762 6763 -- For the analysis of the generated declarations, the parent node 6764 -- must be properly set. 6765 6766 Set_Parent (Block, Parent (N)); 6767 6768 -- Prepend call to Accept_Call to main statement sequence If the 6769 -- accept has exception handlers, the statement sequence is wrapped 6770 -- in a block. Insert call and renaming declarations in the 6771 -- declarations of the block, so they are elaborated before the 6772 -- handlers. 6773 6774 Call := 6775 Make_Procedure_Call_Statement (Loc, 6776 Name => New_Occurrence_Of (RTE (RE_Accept_Call), Loc), 6777 Parameter_Associations => New_List ( 6778 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp), 6779 New_Occurrence_Of (Ann, Loc))); 6780 6781 if Parent (Stats) = N then 6782 Prepend (Call, Statements (Stats)); 6783 else 6784 Set_Declarations (Parent (Stats), New_List (Call)); 6785 end if; 6786 6787 Analyze (Call); 6788 6789 Push_Scope (Blkent); 6790 6791 declare 6792 D : Node_Id; 6793 Next_D : Node_Id; 6794 Typ : Entity_Id; 6795 6796 begin 6797 D := First (Declarations (N)); 6798 while Present (D) loop 6799 Next_D := Next (D); 6800 6801 if Nkind (D) = N_Object_Renaming_Declaration then 6802 6803 -- The renaming declarations for the formals were created 6804 -- during analysis of the accept statement, and attached to 6805 -- the list of declarations. Place them now in the context 6806 -- of the accept block or subprogram. 6807 6808 Remove (D); 6809 Typ := Entity (Subtype_Mark (D)); 6810 Insert_After (Call, D); 6811 Analyze (D); 6812 6813 -- If the formal is class_wide, it does not have an actual 6814 -- subtype. The analysis of the renaming declaration creates 6815 -- one, but we need to retain the class-wide nature of the 6816 -- entity. 6817 6818 if Is_Class_Wide_Type (Typ) then 6819 Set_Etype (Defining_Identifier (D), Typ); 6820 end if; 6821 6822 end if; 6823 6824 D := Next_D; 6825 end loop; 6826 end; 6827 6828 End_Scope; 6829 6830 -- Replace the accept statement by the new block 6831 6832 Rewrite (N, Block); 6833 Analyze (N); 6834 6835 -- Last step is to unstack the Accept_Address value 6836 6837 Remove_Last_Elmt (Acstack); 6838 end if; 6839 end Expand_N_Accept_Statement; 6840 6841 ---------------------------------- 6842 -- Expand_N_Asynchronous_Select -- 6843 ---------------------------------- 6844 6845 -- This procedure assumes that the trigger statement is an entry call or 6846 -- a dispatching procedure call. A delay alternative should already have 6847 -- been expanded into an entry call to the appropriate delay object Wait 6848 -- entry. 6849 6850 -- If the trigger is a task entry call, the select is implemented with 6851 -- a Task_Entry_Call: 6852 6853 -- declare 6854 -- B : Boolean; 6855 -- C : Boolean; 6856 -- P : parms := (parm, parm, parm); 6857 6858 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6859 6860 -- procedure _clean is 6861 -- begin 6862 -- ... 6863 -- Cancel_Task_Entry_Call (C); 6864 -- ... 6865 -- end _clean; 6866 6867 -- begin 6868 -- Abort_Defer; 6869 -- Task_Entry_Call 6870 -- (<acceptor-task>, -- Acceptor 6871 -- <entry-index>, -- E 6872 -- P'Address, -- Uninterpreted_Data 6873 -- Asynchronous_Call, -- Mode 6874 -- B); -- Rendezvous_Successful 6875 6876 -- begin 6877 -- begin 6878 -- Abort_Undefer; 6879 -- <abortable-part> 6880 -- at end 6881 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6882 -- end; 6883 -- exception 6884 -- when Abort_Signal => Abort_Undefer; 6885 -- end; 6886 6887 -- parm := P.param; 6888 -- parm := P.param; 6889 -- ... 6890 -- if not C then 6891 -- <triggered-statements> 6892 -- end if; 6893 -- end; 6894 6895 -- Note that Build_Simple_Entry_Call is used to expand the entry of the 6896 -- asynchronous entry call (by Expand_N_Entry_Call_Statement procedure) 6897 -- as follows: 6898 6899 -- declare 6900 -- P : parms := (parm, parm, parm); 6901 -- begin 6902 -- Call_Simple (acceptor-task, entry-index, P'Address); 6903 -- parm := P.param; 6904 -- parm := P.param; 6905 -- ... 6906 -- end; 6907 6908 -- so the task at hand is to convert the latter expansion into the former 6909 6910 -- If the trigger is a protected entry call, the select is implemented 6911 -- with Protected_Entry_Call: 6912 6913 -- declare 6914 -- P : E1_Params := (param, param, param); 6915 -- Bnn : Communications_Block; 6916 6917 -- begin 6918 -- declare 6919 6920 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions 6921 6922 -- procedure _clean is 6923 -- begin 6924 -- ... 6925 -- if Enqueued (Bnn) then 6926 -- Cancel_Protected_Entry_Call (Bnn); 6927 -- end if; 6928 -- ... 6929 -- end _clean; 6930 6931 -- begin 6932 -- begin 6933 -- Protected_Entry_Call 6934 -- (po._object'Access, -- Object 6935 -- <entry index>, -- E 6936 -- P'Address, -- Uninterpreted_Data 6937 -- Asynchronous_Call, -- Mode 6938 -- Bnn); -- Block 6939 6940 -- if Enqueued (Bnn) then 6941 -- <abortable-part> 6942 -- end if; 6943 -- at end 6944 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 6945 -- end; 6946 -- exception 6947 -- when Abort_Signal => Abort_Undefer; 6948 -- end; 6949 6950 -- if not Cancelled (Bnn) then 6951 -- <triggered-statements> 6952 -- end if; 6953 -- end; 6954 6955 -- Build_Simple_Entry_Call is used to expand the all to a simple protected 6956 -- entry call: 6957 6958 -- declare 6959 -- P : E1_Params := (param, param, param); 6960 -- Bnn : Communications_Block; 6961 6962 -- begin 6963 -- Protected_Entry_Call 6964 -- (po._object'Access, -- Object 6965 -- <entry index>, -- E 6966 -- P'Address, -- Uninterpreted_Data 6967 -- Simple_Call, -- Mode 6968 -- Bnn); -- Block 6969 -- parm := P.param; 6970 -- parm := P.param; 6971 -- ... 6972 -- end; 6973 6974 -- Ada 2005 (AI-345): If the trigger is a dispatching call, the select is 6975 -- expanded into: 6976 6977 -- declare 6978 -- B : Boolean := False; 6979 -- Bnn : Communication_Block; 6980 -- C : Ada.Tags.Prim_Op_Kind; 6981 -- D : System.Storage_Elements.Dummy_Communication_Block; 6982 -- K : Ada.Tags.Tagged_Kind := 6983 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 6984 -- P : Parameters := (Param1 .. ParamN); 6985 -- S : Integer; 6986 -- U : Boolean; 6987 6988 -- begin 6989 -- if K = Ada.Tags.TK_Limited_Tagged 6990 -- or else K = Ada.Tags.TK_Tagged 6991 -- then 6992 -- <dispatching-call>; 6993 -- <triggering-statements>; 6994 6995 -- else 6996 -- S := 6997 -- Ada.Tags.Get_Offset_Index 6998 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 6999 7000 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 7001 7002 -- if C = POK_Protected_Entry then 7003 -- declare 7004 -- procedure _clean is 7005 -- begin 7006 -- if Enqueued (Bnn) then 7007 -- Cancel_Protected_Entry_Call (Bnn); 7008 -- end if; 7009 -- end _clean; 7010 7011 -- begin 7012 -- begin 7013 -- _Disp_Asynchronous_Select 7014 -- (<object>, S, P'Address, D, B); 7015 -- Bnn := Communication_Block (D); 7016 7017 -- Param1 := P.Param1; 7018 -- ... 7019 -- ParamN := P.ParamN; 7020 7021 -- if Enqueued (Bnn) then 7022 -- <abortable-statements> 7023 -- end if; 7024 -- at end 7025 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 7026 -- end; 7027 -- exception 7028 -- when Abort_Signal => Abort_Undefer; 7029 -- end; 7030 7031 -- if not Cancelled (Bnn) then 7032 -- <triggering-statements> 7033 -- end if; 7034 7035 -- elsif C = POK_Task_Entry then 7036 -- declare 7037 -- procedure _clean is 7038 -- begin 7039 -- Cancel_Task_Entry_Call (U); 7040 -- end _clean; 7041 7042 -- begin 7043 -- Abort_Defer; 7044 7045 -- _Disp_Asynchronous_Select 7046 -- (<object>, S, P'Address, D, B); 7047 -- Bnn := Communication_Bloc (D); 7048 7049 -- Param1 := P.Param1; 7050 -- ... 7051 -- ParamN := P.ParamN; 7052 7053 -- begin 7054 -- begin 7055 -- Abort_Undefer; 7056 -- <abortable-statements> 7057 -- at end 7058 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions 7059 -- end; 7060 -- exception 7061 -- when Abort_Signal => Abort_Undefer; 7062 -- end; 7063 7064 -- if not U then 7065 -- <triggering-statements> 7066 -- end if; 7067 -- end; 7068 7069 -- else 7070 -- <dispatching-call>; 7071 -- <triggering-statements> 7072 -- end if; 7073 -- end if; 7074 -- end; 7075 7076 -- The job is to convert this to the asynchronous form 7077 7078 -- If the trigger is a delay statement, it will have been expanded into 7079 -- a call to one of the GNARL delay procedures. This routine will convert 7080 -- this into a protected entry call on a delay object and then continue 7081 -- processing as for a protected entry call trigger. This requires 7082 -- declaring a Delay_Block object and adding a pointer to this object to 7083 -- the parameter list of the delay procedure to form the parameter list of 7084 -- the entry call. This object is used by the runtime to queue the delay 7085 -- request. 7086 7087 -- For a description of the use of P and the assignments after the call, 7088 -- see Expand_N_Entry_Call_Statement. 7089 7090 procedure Expand_N_Asynchronous_Select (N : Node_Id) is 7091 Loc : constant Source_Ptr := Sloc (N); 7092 Abrt : constant Node_Id := Abortable_Part (N); 7093 Trig : constant Node_Id := Triggering_Alternative (N); 7094 7095 Abort_Block_Ent : Entity_Id; 7096 Abortable_Block : Node_Id; 7097 Actuals : List_Id; 7098 Astats : List_Id; 7099 Blk_Ent : constant Entity_Id := Make_Temporary (Loc, 'A'); 7100 Blk_Typ : Entity_Id; 7101 Call : Node_Id; 7102 Call_Ent : Entity_Id; 7103 Cancel_Param : Entity_Id; 7104 Cleanup_Block : Node_Id; 7105 Cleanup_Block_Ent : Entity_Id; 7106 Cleanup_Stmts : List_Id; 7107 Conc_Typ_Stmts : List_Id; 7108 Concval : Node_Id; 7109 Dblock_Ent : Entity_Id; 7110 Decl : Node_Id; 7111 Decls : List_Id; 7112 Ecall : Node_Id; 7113 Ename : Node_Id; 7114 Enqueue_Call : Node_Id; 7115 Formals : List_Id; 7116 Hdle : List_Id; 7117 Handler_Stmt : Node_Id; 7118 Index : Node_Id; 7119 Lim_Typ_Stmts : List_Id; 7120 N_Orig : Node_Id; 7121 Obj : Entity_Id; 7122 Param : Node_Id; 7123 Params : List_Id; 7124 Pdef : Entity_Id; 7125 ProtE_Stmts : List_Id; 7126 ProtP_Stmts : List_Id; 7127 Stmt : Node_Id; 7128 Stmts : List_Id; 7129 TaskE_Stmts : List_Id; 7130 Tstats : List_Id; 7131 7132 B : Entity_Id; -- Call status flag 7133 Bnn : Entity_Id; -- Communication block 7134 C : Entity_Id; -- Call kind 7135 K : Entity_Id; -- Tagged kind 7136 P : Entity_Id; -- Parameter block 7137 S : Entity_Id; -- Primitive operation slot 7138 T : Entity_Id; -- Additional status flag 7139 7140 procedure Rewrite_Abortable_Part; 7141 -- If the trigger is a dispatching call, the expansion inserts multiple 7142 -- copies of the abortable part. This is both inefficient, and may lead 7143 -- to duplicate definitions that the back-end will reject, when the 7144 -- abortable part includes loops. This procedure rewrites the abortable 7145 -- part into a call to a generated procedure. 7146 7147 ---------------------------- 7148 -- Rewrite_Abortable_Part -- 7149 ---------------------------- 7150 7151 procedure Rewrite_Abortable_Part is 7152 Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA); 7153 Decl : Node_Id; 7154 7155 begin 7156 Decl := 7157 Make_Subprogram_Body (Loc, 7158 Specification => 7159 Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc), 7160 Declarations => New_List, 7161 Handled_Statement_Sequence => 7162 Make_Handled_Sequence_Of_Statements (Loc, Astats)); 7163 Insert_Before (N, Decl); 7164 Analyze (Decl); 7165 7166 -- Rewrite abortable part into a call to this procedure. 7167 7168 Astats := 7169 New_List ( 7170 Make_Procedure_Call_Statement (Loc, 7171 Name => New_Occurrence_Of (Proc, Loc))); 7172 end Rewrite_Abortable_Part; 7173 7174 -- Start of processing for Expand_N_Asynchronous_Select 7175 7176 begin 7177 Process_Statements_For_Controlled_Objects (Trig); 7178 Process_Statements_For_Controlled_Objects (Abrt); 7179 7180 Ecall := Triggering_Statement (Trig); 7181 7182 Ensure_Statement_Present (Sloc (Ecall), Trig); 7183 7184 -- Retrieve Astats and Tstats now because the finalization machinery may 7185 -- wrap them in blocks. 7186 7187 Astats := Statements (Abrt); 7188 Tstats := Statements (Trig); 7189 7190 -- The arguments in the call may require dynamic allocation, and the 7191 -- call statement may have been transformed into a block. The block 7192 -- may contain additional declarations for internal entities, and the 7193 -- original call is found by sequential search. 7194 7195 if Nkind (Ecall) = N_Block_Statement then 7196 Ecall := First (Statements (Handled_Statement_Sequence (Ecall))); 7197 while not Nkind_In (Ecall, N_Procedure_Call_Statement, 7198 N_Entry_Call_Statement) 7199 loop 7200 Next (Ecall); 7201 end loop; 7202 end if; 7203 7204 -- This is either a dispatching call or a delay statement used as a 7205 -- trigger which was expanded into a procedure call. 7206 7207 if Nkind (Ecall) = N_Procedure_Call_Statement then 7208 if Ada_Version >= Ada_2005 7209 and then 7210 (No (Original_Node (Ecall)) 7211 or else not Nkind_In (Original_Node (Ecall), 7212 N_Delay_Relative_Statement, 7213 N_Delay_Until_Statement)) 7214 then 7215 Extract_Dispatching_Call (Ecall, Call_Ent, Obj, Actuals, Formals); 7216 7217 Rewrite_Abortable_Part; 7218 Decls := New_List; 7219 Stmts := New_List; 7220 7221 -- Call status flag processing, generate: 7222 -- B : Boolean := False; 7223 7224 B := Build_B (Loc, Decls); 7225 7226 -- Communication block processing, generate: 7227 -- Bnn : Communication_Block; 7228 7229 Bnn := Make_Temporary (Loc, 'B'); 7230 Append_To (Decls, 7231 Make_Object_Declaration (Loc, 7232 Defining_Identifier => Bnn, 7233 Object_Definition => 7234 New_Occurrence_Of (RTE (RE_Communication_Block), Loc))); 7235 7236 -- Call kind processing, generate: 7237 -- C : Ada.Tags.Prim_Op_Kind; 7238 7239 C := Build_C (Loc, Decls); 7240 7241 -- Tagged kind processing, generate: 7242 -- K : Ada.Tags.Tagged_Kind := 7243 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 7244 7245 -- Dummy communication block, generate: 7246 -- D : Dummy_Communication_Block; 7247 7248 Append_To (Decls, 7249 Make_Object_Declaration (Loc, 7250 Defining_Identifier => 7251 Make_Defining_Identifier (Loc, Name_uD), 7252 Object_Definition => 7253 New_Occurrence_Of 7254 (RTE (RE_Dummy_Communication_Block), Loc))); 7255 7256 K := Build_K (Loc, Decls, Obj); 7257 7258 -- Parameter block processing 7259 7260 Blk_Typ := Build_Parameter_Block 7261 (Loc, Actuals, Formals, Decls); 7262 P := Parameter_Block_Pack 7263 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 7264 7265 -- Dispatch table slot processing, generate: 7266 -- S : Integer; 7267 7268 S := Build_S (Loc, Decls); 7269 7270 -- Additional status flag processing, generate: 7271 -- Tnn : Boolean; 7272 7273 T := Make_Temporary (Loc, 'T'); 7274 Append_To (Decls, 7275 Make_Object_Declaration (Loc, 7276 Defining_Identifier => T, 7277 Object_Definition => 7278 New_Occurrence_Of (Standard_Boolean, Loc))); 7279 7280 ------------------------------ 7281 -- Protected entry handling -- 7282 ------------------------------ 7283 7284 -- Generate: 7285 -- Param1 := P.Param1; 7286 -- ... 7287 -- ParamN := P.ParamN; 7288 7289 Cleanup_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7290 7291 -- Generate: 7292 -- Bnn := Communication_Block (D); 7293 7294 Prepend_To (Cleanup_Stmts, 7295 Make_Assignment_Statement (Loc, 7296 Name => New_Occurrence_Of (Bnn, Loc), 7297 Expression => 7298 Make_Unchecked_Type_Conversion (Loc, 7299 Subtype_Mark => 7300 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7301 Expression => Make_Identifier (Loc, Name_uD)))); 7302 7303 -- Generate: 7304 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7305 7306 Prepend_To (Cleanup_Stmts, 7307 Make_Procedure_Call_Statement (Loc, 7308 Name => 7309 New_Occurrence_Of 7310 (Find_Prim_Op 7311 (Etype (Etype (Obj)), Name_uDisp_Asynchronous_Select), 7312 Loc), 7313 Parameter_Associations => 7314 New_List ( 7315 New_Copy_Tree (Obj), -- <object> 7316 New_Occurrence_Of (S, Loc), -- S 7317 Make_Attribute_Reference (Loc, -- P'Address 7318 Prefix => New_Occurrence_Of (P, Loc), 7319 Attribute_Name => Name_Address), 7320 Make_Identifier (Loc, Name_uD), -- D 7321 New_Occurrence_Of (B, Loc)))); -- B 7322 7323 -- Generate: 7324 -- if Enqueued (Bnn) then 7325 -- <abortable-statements> 7326 -- end if; 7327 7328 Append_To (Cleanup_Stmts, 7329 Make_Implicit_If_Statement (N, 7330 Condition => 7331 Make_Function_Call (Loc, 7332 Name => 7333 New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7334 Parameter_Associations => 7335 New_List (New_Occurrence_Of (Bnn, Loc))), 7336 7337 Then_Statements => 7338 New_Copy_List_Tree (Astats))); 7339 7340 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7341 -- will then generate a _clean for the communication block Bnn. 7342 7343 -- Generate: 7344 -- declare 7345 -- procedure _clean is 7346 -- begin 7347 -- if Enqueued (Bnn) then 7348 -- Cancel_Protected_Entry_Call (Bnn); 7349 -- end if; 7350 -- end _clean; 7351 -- begin 7352 -- Cleanup_Stmts 7353 -- at end 7354 -- _clean; 7355 -- end; 7356 7357 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7358 Cleanup_Block := 7359 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, Bnn); 7360 7361 -- Wrap the cleanup block in an exception handling block 7362 7363 -- Generate: 7364 -- begin 7365 -- Cleanup_Block 7366 -- exception 7367 -- when Abort_Signal => Abort_Undefer; 7368 -- end; 7369 7370 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7371 ProtE_Stmts := 7372 New_List ( 7373 Make_Implicit_Label_Declaration (Loc, 7374 Defining_Identifier => Abort_Block_Ent), 7375 7376 Build_Abort_Block 7377 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7378 7379 -- Generate: 7380 -- if not Cancelled (Bnn) then 7381 -- <triggering-statements> 7382 -- end if; 7383 7384 Append_To (ProtE_Stmts, 7385 Make_Implicit_If_Statement (N, 7386 Condition => 7387 Make_Op_Not (Loc, 7388 Right_Opnd => 7389 Make_Function_Call (Loc, 7390 Name => 7391 New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7392 Parameter_Associations => 7393 New_List (New_Occurrence_Of (Bnn, Loc)))), 7394 7395 Then_Statements => 7396 New_Copy_List_Tree (Tstats))); 7397 7398 ------------------------- 7399 -- Task entry handling -- 7400 ------------------------- 7401 7402 -- Generate: 7403 -- Param1 := P.Param1; 7404 -- ... 7405 -- ParamN := P.ParamN; 7406 7407 TaskE_Stmts := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 7408 7409 -- Generate: 7410 -- Bnn := Communication_Block (D); 7411 7412 Append_To (TaskE_Stmts, 7413 Make_Assignment_Statement (Loc, 7414 Name => 7415 New_Occurrence_Of (Bnn, Loc), 7416 Expression => 7417 Make_Unchecked_Type_Conversion (Loc, 7418 Subtype_Mark => 7419 New_Occurrence_Of (RTE (RE_Communication_Block), Loc), 7420 Expression => Make_Identifier (Loc, Name_uD)))); 7421 7422 -- Generate: 7423 -- _Disp_Asynchronous_Select (<object>, S, P'Address, D, B); 7424 7425 Prepend_To (TaskE_Stmts, 7426 Make_Procedure_Call_Statement (Loc, 7427 Name => 7428 New_Occurrence_Of ( 7429 Find_Prim_Op (Etype (Etype (Obj)), 7430 Name_uDisp_Asynchronous_Select), 7431 Loc), 7432 7433 Parameter_Associations => New_List ( 7434 New_Copy_Tree (Obj), -- <object> 7435 New_Occurrence_Of (S, Loc), -- S 7436 Make_Attribute_Reference (Loc, -- P'Address 7437 Prefix => New_Occurrence_Of (P, Loc), 7438 Attribute_Name => Name_Address), 7439 Make_Identifier (Loc, Name_uD), -- D 7440 New_Occurrence_Of (B, Loc)))); -- B 7441 7442 -- Generate: 7443 -- Abort_Defer; 7444 7445 Prepend_To (TaskE_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 7446 7447 -- Generate: 7448 -- Abort_Undefer; 7449 -- <abortable-statements> 7450 7451 Cleanup_Stmts := New_Copy_List_Tree (Astats); 7452 7453 Prepend_To 7454 (Cleanup_Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7455 7456 -- Wrap the statements in a block. Exp_Ch7.Expand_Cleanup_Actions 7457 -- will generate a _clean for the additional status flag. 7458 7459 -- Generate: 7460 -- declare 7461 -- procedure _clean is 7462 -- begin 7463 -- Cancel_Task_Entry_Call (U); 7464 -- end _clean; 7465 -- begin 7466 -- Cleanup_Stmts 7467 -- at end 7468 -- _clean; 7469 -- end; 7470 7471 Cleanup_Block_Ent := Make_Temporary (Loc, 'C'); 7472 Cleanup_Block := 7473 Build_Cleanup_Block (Loc, Cleanup_Block_Ent, Cleanup_Stmts, T); 7474 7475 -- Wrap the cleanup block in an exception handling block 7476 7477 -- Generate: 7478 -- begin 7479 -- Cleanup_Block 7480 -- exception 7481 -- when Abort_Signal => Abort_Undefer; 7482 -- end; 7483 7484 Abort_Block_Ent := Make_Temporary (Loc, 'A'); 7485 7486 Append_To (TaskE_Stmts, 7487 Make_Implicit_Label_Declaration (Loc, 7488 Defining_Identifier => Abort_Block_Ent)); 7489 7490 Append_To (TaskE_Stmts, 7491 Build_Abort_Block 7492 (Loc, Abort_Block_Ent, Cleanup_Block_Ent, Cleanup_Block)); 7493 7494 -- Generate: 7495 -- if not T then 7496 -- <triggering-statements> 7497 -- end if; 7498 7499 Append_To (TaskE_Stmts, 7500 Make_Implicit_If_Statement (N, 7501 Condition => 7502 Make_Op_Not (Loc, Right_Opnd => New_Occurrence_Of (T, Loc)), 7503 7504 Then_Statements => 7505 New_Copy_List_Tree (Tstats))); 7506 7507 ---------------------------------- 7508 -- Protected procedure handling -- 7509 ---------------------------------- 7510 7511 -- Generate: 7512 -- <dispatching-call>; 7513 -- <triggering-statements> 7514 7515 ProtP_Stmts := New_Copy_List_Tree (Tstats); 7516 Prepend_To (ProtP_Stmts, New_Copy_Tree (Ecall)); 7517 7518 -- Generate: 7519 -- S := Ada.Tags.Get_Offset_Index 7520 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 7521 7522 Conc_Typ_Stmts := 7523 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 7524 7525 -- Generate: 7526 -- _Disp_Get_Prim_Op_Kind (<object>, S, C); 7527 7528 Append_To (Conc_Typ_Stmts, 7529 Make_Procedure_Call_Statement (Loc, 7530 Name => 7531 New_Occurrence_Of 7532 (Find_Prim_Op (Etype (Etype (Obj)), 7533 Name_uDisp_Get_Prim_Op_Kind), 7534 Loc), 7535 Parameter_Associations => 7536 New_List ( 7537 New_Copy_Tree (Obj), 7538 New_Occurrence_Of (S, Loc), 7539 New_Occurrence_Of (C, Loc)))); 7540 7541 -- Generate: 7542 -- if C = POK_Procedure_Entry then 7543 -- ProtE_Stmts 7544 -- elsif C = POK_Task_Entry then 7545 -- TaskE_Stmts 7546 -- else 7547 -- ProtP_Stmts 7548 -- end if; 7549 7550 Append_To (Conc_Typ_Stmts, 7551 Make_Implicit_If_Statement (N, 7552 Condition => 7553 Make_Op_Eq (Loc, 7554 Left_Opnd => 7555 New_Occurrence_Of (C, Loc), 7556 Right_Opnd => 7557 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 7558 7559 Then_Statements => 7560 ProtE_Stmts, 7561 7562 Elsif_Parts => 7563 New_List ( 7564 Make_Elsif_Part (Loc, 7565 Condition => 7566 Make_Op_Eq (Loc, 7567 Left_Opnd => 7568 New_Occurrence_Of (C, Loc), 7569 Right_Opnd => 7570 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc)), 7571 7572 Then_Statements => 7573 TaskE_Stmts)), 7574 7575 Else_Statements => 7576 ProtP_Stmts)); 7577 7578 -- Generate: 7579 -- <dispatching-call>; 7580 -- <triggering-statements> 7581 7582 Lim_Typ_Stmts := New_Copy_List_Tree (Tstats); 7583 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Ecall)); 7584 7585 -- Generate: 7586 -- if K = Ada.Tags.TK_Limited_Tagged 7587 -- or else K = Ada.Tags.TK_Tagged 7588 -- then 7589 -- Lim_Typ_Stmts 7590 -- else 7591 -- Conc_Typ_Stmts 7592 -- end if; 7593 7594 Append_To (Stmts, 7595 Make_Implicit_If_Statement (N, 7596 Condition => Build_Dispatching_Tag_Check (K, N), 7597 Then_Statements => Lim_Typ_Stmts, 7598 Else_Statements => Conc_Typ_Stmts)); 7599 7600 Rewrite (N, 7601 Make_Block_Statement (Loc, 7602 Declarations => 7603 Decls, 7604 Handled_Statement_Sequence => 7605 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7606 7607 Analyze (N); 7608 return; 7609 7610 -- Delay triggering statement processing 7611 7612 else 7613 -- Add a Delay_Block object to the parameter list of the delay 7614 -- procedure to form the parameter list of the Wait entry call. 7615 7616 Dblock_Ent := Make_Temporary (Loc, 'D'); 7617 7618 Pdef := Entity (Name (Ecall)); 7619 7620 if Is_RTE (Pdef, RO_CA_Delay_For) then 7621 Enqueue_Call := 7622 New_Occurrence_Of (RTE (RE_Enqueue_Duration), Loc); 7623 7624 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then 7625 Enqueue_Call := 7626 New_Occurrence_Of (RTE (RE_Enqueue_Calendar), Loc); 7627 7628 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); 7629 Enqueue_Call := New_Occurrence_Of (RTE (RE_Enqueue_RT), Loc); 7630 end if; 7631 7632 Append_To (Parameter_Associations (Ecall), 7633 Make_Attribute_Reference (Loc, 7634 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7635 Attribute_Name => Name_Unchecked_Access)); 7636 7637 -- Create the inner block to protect the abortable part 7638 7639 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7640 7641 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7642 7643 Abortable_Block := 7644 Make_Block_Statement (Loc, 7645 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7646 Handled_Statement_Sequence => 7647 Make_Handled_Sequence_Of_Statements (Loc, 7648 Statements => Astats), 7649 Has_Created_Identifier => True, 7650 Is_Asynchronous_Call_Block => True); 7651 7652 -- Append call to if Enqueue (When, DB'Unchecked_Access) then 7653 7654 Rewrite (Ecall, 7655 Make_Implicit_If_Statement (N, 7656 Condition => 7657 Make_Function_Call (Loc, 7658 Name => Enqueue_Call, 7659 Parameter_Associations => Parameter_Associations (Ecall)), 7660 Then_Statements => 7661 New_List (Make_Block_Statement (Loc, 7662 Handled_Statement_Sequence => 7663 Make_Handled_Sequence_Of_Statements (Loc, 7664 Statements => New_List ( 7665 Make_Implicit_Label_Declaration (Loc, 7666 Defining_Identifier => Blk_Ent, 7667 Label_Construct => Abortable_Block), 7668 Abortable_Block), 7669 Exception_Handlers => Hdle))))); 7670 7671 Stmts := New_List (Ecall); 7672 7673 -- Construct statement sequence for new block 7674 7675 Append_To (Stmts, 7676 Make_Implicit_If_Statement (N, 7677 Condition => 7678 Make_Function_Call (Loc, 7679 Name => New_Occurrence_Of ( 7680 RTE (RE_Timed_Out), Loc), 7681 Parameter_Associations => New_List ( 7682 Make_Attribute_Reference (Loc, 7683 Prefix => New_Occurrence_Of (Dblock_Ent, Loc), 7684 Attribute_Name => Name_Unchecked_Access))), 7685 Then_Statements => Tstats)); 7686 7687 -- The result is the new block 7688 7689 Set_Entry_Cancel_Parameter (Blk_Ent, Dblock_Ent); 7690 7691 Rewrite (N, 7692 Make_Block_Statement (Loc, 7693 Declarations => New_List ( 7694 Make_Object_Declaration (Loc, 7695 Defining_Identifier => Dblock_Ent, 7696 Aliased_Present => True, 7697 Object_Definition => 7698 New_Occurrence_Of (RTE (RE_Delay_Block), Loc))), 7699 7700 Handled_Statement_Sequence => 7701 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7702 7703 Analyze (N); 7704 return; 7705 end if; 7706 7707 else 7708 N_Orig := N; 7709 end if; 7710 7711 Extract_Entry (Ecall, Concval, Ename, Index); 7712 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index); 7713 7714 Stmts := Statements (Handled_Statement_Sequence (Ecall)); 7715 Decls := Declarations (Ecall); 7716 7717 if Is_Protected_Type (Etype (Concval)) then 7718 7719 -- Get the declarations of the block expanded from the entry call 7720 7721 Decl := First (Decls); 7722 while Present (Decl) 7723 and then (Nkind (Decl) /= N_Object_Declaration 7724 or else not Is_RTE (Etype (Object_Definition (Decl)), 7725 RE_Communication_Block)) 7726 loop 7727 Next (Decl); 7728 end loop; 7729 7730 pragma Assert (Present (Decl)); 7731 Cancel_Param := Defining_Identifier (Decl); 7732 7733 -- Change the mode of the Protected_Entry_Call call 7734 7735 -- Protected_Entry_Call ( 7736 -- Object => po._object'Access, 7737 -- E => <entry index>; 7738 -- Uninterpreted_Data => P'Address; 7739 -- Mode => Asynchronous_Call; 7740 -- Block => Bnn); 7741 7742 -- Skip assignments to temporaries created for in-out parameters 7743 7744 -- This makes unwarranted assumptions about the shape of the expanded 7745 -- tree for the call, and should be cleaned up ??? 7746 7747 Stmt := First (Stmts); 7748 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7749 Next (Stmt); 7750 end loop; 7751 7752 Call := Stmt; 7753 7754 Param := First (Parameter_Associations (Call)); 7755 while Present (Param) 7756 and then not Is_RTE (Etype (Param), RE_Call_Modes) 7757 loop 7758 Next (Param); 7759 end loop; 7760 7761 pragma Assert (Present (Param)); 7762 Rewrite (Param, New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7763 Analyze (Param); 7764 7765 -- Append an if statement to execute the abortable part 7766 7767 -- Generate: 7768 -- if Enqueued (Bnn) then 7769 7770 Append_To (Stmts, 7771 Make_Implicit_If_Statement (N, 7772 Condition => 7773 Make_Function_Call (Loc, 7774 Name => New_Occurrence_Of (RTE (RE_Enqueued), Loc), 7775 Parameter_Associations => New_List ( 7776 New_Occurrence_Of (Cancel_Param, Loc))), 7777 Then_Statements => Astats)); 7778 7779 Abortable_Block := 7780 Make_Block_Statement (Loc, 7781 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7782 Handled_Statement_Sequence => 7783 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts), 7784 Has_Created_Identifier => True, 7785 Is_Asynchronous_Call_Block => True); 7786 7787 -- Aborts are not deferred at beginning of exception handlers in 7788 -- ZCX mode. 7789 7790 if ZCX_Exceptions then 7791 Handler_Stmt := Make_Null_Statement (Loc); 7792 7793 else 7794 Handler_Stmt := Build_Runtime_Call (Loc, RE_Abort_Undefer); 7795 end if; 7796 7797 Stmts := New_List ( 7798 Make_Block_Statement (Loc, 7799 Handled_Statement_Sequence => 7800 Make_Handled_Sequence_Of_Statements (Loc, 7801 Statements => New_List ( 7802 Make_Implicit_Label_Declaration (Loc, 7803 Defining_Identifier => Blk_Ent, 7804 Label_Construct => Abortable_Block), 7805 Abortable_Block), 7806 7807 -- exception 7808 7809 Exception_Handlers => New_List ( 7810 Make_Implicit_Exception_Handler (Loc, 7811 7812 -- when Abort_Signal => 7813 -- Abort_Undefer.all; 7814 7815 Exception_Choices => 7816 New_List (New_Occurrence_Of (Stand.Abort_Signal, Loc)), 7817 Statements => New_List (Handler_Stmt))))), 7818 7819 -- if not Cancelled (Bnn) then 7820 -- triggered statements 7821 -- end if; 7822 7823 Make_Implicit_If_Statement (N, 7824 Condition => Make_Op_Not (Loc, 7825 Right_Opnd => 7826 Make_Function_Call (Loc, 7827 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 7828 Parameter_Associations => New_List ( 7829 New_Occurrence_Of (Cancel_Param, Loc)))), 7830 Then_Statements => Tstats)); 7831 7832 -- Asynchronous task entry call 7833 7834 else 7835 if No (Decls) then 7836 Decls := New_List; 7837 end if; 7838 7839 B := Make_Defining_Identifier (Loc, Name_uB); 7840 7841 -- Insert declaration of B in declarations of existing block 7842 7843 Prepend_To (Decls, 7844 Make_Object_Declaration (Loc, 7845 Defining_Identifier => B, 7846 Object_Definition => 7847 New_Occurrence_Of (Standard_Boolean, Loc))); 7848 7849 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC); 7850 7851 -- Insert declaration of C in declarations of existing block 7852 7853 Prepend_To (Decls, 7854 Make_Object_Declaration (Loc, 7855 Defining_Identifier => Cancel_Param, 7856 Object_Definition => 7857 New_Occurrence_Of (Standard_Boolean, Loc))); 7858 7859 -- Remove and save the call to Call_Simple 7860 7861 Stmt := First (Stmts); 7862 7863 -- Skip assignments to temporaries created for in-out parameters. 7864 -- This makes unwarranted assumptions about the shape of the expanded 7865 -- tree for the call, and should be cleaned up ??? 7866 7867 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7868 Next (Stmt); 7869 end loop; 7870 7871 Call := Stmt; 7872 7873 -- Create the inner block to protect the abortable part 7874 7875 Hdle := New_List (Build_Abort_Block_Handler (Loc)); 7876 7877 Prepend_To (Astats, Build_Runtime_Call (Loc, RE_Abort_Undefer)); 7878 7879 Abortable_Block := 7880 Make_Block_Statement (Loc, 7881 Identifier => New_Occurrence_Of (Blk_Ent, Loc), 7882 Handled_Statement_Sequence => 7883 Make_Handled_Sequence_Of_Statements (Loc, Statements => Astats), 7884 Has_Created_Identifier => True, 7885 Is_Asynchronous_Call_Block => True); 7886 7887 Insert_After (Call, 7888 Make_Block_Statement (Loc, 7889 Handled_Statement_Sequence => 7890 Make_Handled_Sequence_Of_Statements (Loc, 7891 Statements => New_List ( 7892 Make_Implicit_Label_Declaration (Loc, 7893 Defining_Identifier => Blk_Ent, 7894 Label_Construct => Abortable_Block), 7895 Abortable_Block), 7896 Exception_Handlers => Hdle))); 7897 7898 -- Create new call statement 7899 7900 Params := Parameter_Associations (Call); 7901 7902 Append_To (Params, 7903 New_Occurrence_Of (RTE (RE_Asynchronous_Call), Loc)); 7904 Append_To (Params, New_Occurrence_Of (B, Loc)); 7905 7906 Rewrite (Call, 7907 Make_Procedure_Call_Statement (Loc, 7908 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 7909 Parameter_Associations => Params)); 7910 7911 -- Construct statement sequence for new block 7912 7913 Append_To (Stmts, 7914 Make_Implicit_If_Statement (N, 7915 Condition => 7916 Make_Op_Not (Loc, New_Occurrence_Of (Cancel_Param, Loc)), 7917 Then_Statements => Tstats)); 7918 7919 -- Protected the call against abort 7920 7921 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); 7922 end if; 7923 7924 Set_Entry_Cancel_Parameter (Blk_Ent, Cancel_Param); 7925 7926 -- The result is the new block 7927 7928 Rewrite (N_Orig, 7929 Make_Block_Statement (Loc, 7930 Declarations => Decls, 7931 Handled_Statement_Sequence => 7932 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7933 7934 Analyze (N_Orig); 7935 end Expand_N_Asynchronous_Select; 7936 7937 ------------------------------------- 7938 -- Expand_N_Conditional_Entry_Call -- 7939 ------------------------------------- 7940 7941 -- The conditional task entry call is converted to a call to 7942 -- Task_Entry_Call: 7943 7944 -- declare 7945 -- B : Boolean; 7946 -- P : parms := (parm, parm, parm); 7947 7948 -- begin 7949 -- Task_Entry_Call 7950 -- (<acceptor-task>, -- Acceptor 7951 -- <entry-index>, -- E 7952 -- P'Address, -- Uninterpreted_Data 7953 -- Conditional_Call, -- Mode 7954 -- B); -- Rendezvous_Successful 7955 -- parm := P.param; 7956 -- parm := P.param; 7957 -- ... 7958 -- if B then 7959 -- normal-statements 7960 -- else 7961 -- else-statements 7962 -- end if; 7963 -- end; 7964 7965 -- For a description of the use of P and the assignments after the call, 7966 -- see Expand_N_Entry_Call_Statement. Note that the entry call of the 7967 -- conditional entry call has already been expanded (by the Expand_N_Entry 7968 -- _Call_Statement procedure) as follows: 7969 7970 -- declare 7971 -- P : parms := (parm, parm, parm); 7972 -- begin 7973 -- ... info for in-out parameters 7974 -- Call_Simple (acceptor-task, entry-index, P'Address); 7975 -- parm := P.param; 7976 -- parm := P.param; 7977 -- ... 7978 -- end; 7979 7980 -- so the task at hand is to convert the latter expansion into the former 7981 7982 -- The conditional protected entry call is converted to a call to 7983 -- Protected_Entry_Call: 7984 7985 -- declare 7986 -- P : parms := (parm, parm, parm); 7987 -- Bnn : Communications_Block; 7988 7989 -- begin 7990 -- Protected_Entry_Call 7991 -- (po._object'Access, -- Object 7992 -- <entry index>, -- E 7993 -- P'Address, -- Uninterpreted_Data 7994 -- Conditional_Call, -- Mode 7995 -- Bnn); -- Block 7996 -- parm := P.param; 7997 -- parm := P.param; 7998 -- ... 7999 -- if Cancelled (Bnn) then 8000 -- else-statements 8001 -- else 8002 -- normal-statements 8003 -- end if; 8004 -- end; 8005 8006 -- Ada 2005 (AI-345): A dispatching conditional entry call is converted 8007 -- into: 8008 8009 -- declare 8010 -- B : Boolean := False; 8011 -- C : Ada.Tags.Prim_Op_Kind; 8012 -- K : Ada.Tags.Tagged_Kind := 8013 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 8014 -- P : Parameters := (Param1 .. ParamN); 8015 -- S : Integer; 8016 8017 -- begin 8018 -- if K = Ada.Tags.TK_Limited_Tagged 8019 -- or else K = Ada.Tags.TK_Tagged 8020 -- then 8021 -- <dispatching-call>; 8022 -- <triggering-statements> 8023 8024 -- else 8025 -- S := 8026 -- Ada.Tags.Get_Offset_Index 8027 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 8028 8029 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 8030 8031 -- if C = POK_Protected_Entry 8032 -- or else C = POK_Task_Entry 8033 -- then 8034 -- Param1 := P.Param1; 8035 -- ... 8036 -- ParamN := P.ParamN; 8037 -- end if; 8038 8039 -- if B then 8040 -- if C = POK_Procedure 8041 -- or else C = POK_Protected_Procedure 8042 -- or else C = POK_Task_Procedure 8043 -- then 8044 -- <dispatching-call>; 8045 -- end if; 8046 8047 -- <triggering-statements> 8048 -- else 8049 -- <else-statements> 8050 -- end if; 8051 -- end if; 8052 -- end; 8053 8054 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is 8055 Loc : constant Source_Ptr := Sloc (N); 8056 Alt : constant Node_Id := Entry_Call_Alternative (N); 8057 Blk : Node_Id := Entry_Call_Statement (Alt); 8058 8059 Actuals : List_Id; 8060 Blk_Typ : Entity_Id; 8061 Call : Node_Id; 8062 Call_Ent : Entity_Id; 8063 Conc_Typ_Stmts : List_Id; 8064 Decl : Node_Id; 8065 Decls : List_Id; 8066 Formals : List_Id; 8067 Lim_Typ_Stmts : List_Id; 8068 N_Stats : List_Id; 8069 Obj : Entity_Id; 8070 Param : Node_Id; 8071 Params : List_Id; 8072 Stmt : Node_Id; 8073 Stmts : List_Id; 8074 Transient_Blk : Node_Id; 8075 Unpack : List_Id; 8076 8077 B : Entity_Id; -- Call status flag 8078 C : Entity_Id; -- Call kind 8079 K : Entity_Id; -- Tagged kind 8080 P : Entity_Id; -- Parameter block 8081 S : Entity_Id; -- Primitive operation slot 8082 8083 begin 8084 Process_Statements_For_Controlled_Objects (N); 8085 8086 if Ada_Version >= Ada_2005 8087 and then Nkind (Blk) = N_Procedure_Call_Statement 8088 then 8089 Extract_Dispatching_Call (Blk, Call_Ent, Obj, Actuals, Formals); 8090 8091 Decls := New_List; 8092 Stmts := New_List; 8093 8094 -- Call status flag processing, generate: 8095 -- B : Boolean := False; 8096 8097 B := Build_B (Loc, Decls); 8098 8099 -- Call kind processing, generate: 8100 -- C : Ada.Tags.Prim_Op_Kind; 8101 8102 C := Build_C (Loc, Decls); 8103 8104 -- Tagged kind processing, generate: 8105 -- K : Ada.Tags.Tagged_Kind := 8106 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 8107 8108 K := Build_K (Loc, Decls, Obj); 8109 8110 -- Parameter block processing 8111 8112 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 8113 P := Parameter_Block_Pack 8114 (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 8115 8116 -- Dispatch table slot processing, generate: 8117 -- S : Integer; 8118 8119 S := Build_S (Loc, Decls); 8120 8121 -- Generate: 8122 -- S := Ada.Tags.Get_Offset_Index 8123 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 8124 8125 Conc_Typ_Stmts := 8126 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 8127 8128 -- Generate: 8129 -- _Disp_Conditional_Select (<object>, S, P'Address, C, B); 8130 8131 Append_To (Conc_Typ_Stmts, 8132 Make_Procedure_Call_Statement (Loc, 8133 Name => 8134 New_Occurrence_Of ( 8135 Find_Prim_Op (Etype (Etype (Obj)), 8136 Name_uDisp_Conditional_Select), 8137 Loc), 8138 Parameter_Associations => 8139 New_List ( 8140 New_Copy_Tree (Obj), -- <object> 8141 New_Occurrence_Of (S, Loc), -- S 8142 Make_Attribute_Reference (Loc, -- P'Address 8143 Prefix => New_Occurrence_Of (P, Loc), 8144 Attribute_Name => Name_Address), 8145 New_Occurrence_Of (C, Loc), -- C 8146 New_Occurrence_Of (B, Loc)))); -- B 8147 8148 -- Generate: 8149 -- if C = POK_Protected_Entry 8150 -- or else C = POK_Task_Entry 8151 -- then 8152 -- Param1 := P.Param1; 8153 -- ... 8154 -- ParamN := P.ParamN; 8155 -- end if; 8156 8157 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 8158 8159 -- Generate the if statement only when the packed parameters need 8160 -- explicit assignments to their corresponding actuals. 8161 8162 if Present (Unpack) then 8163 Append_To (Conc_Typ_Stmts, 8164 Make_Implicit_If_Statement (N, 8165 Condition => 8166 Make_Or_Else (Loc, 8167 Left_Opnd => 8168 Make_Op_Eq (Loc, 8169 Left_Opnd => 8170 New_Occurrence_Of (C, Loc), 8171 Right_Opnd => 8172 New_Occurrence_Of (RTE ( 8173 RE_POK_Protected_Entry), Loc)), 8174 8175 Right_Opnd => 8176 Make_Op_Eq (Loc, 8177 Left_Opnd => 8178 New_Occurrence_Of (C, Loc), 8179 Right_Opnd => 8180 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 8181 8182 Then_Statements => Unpack)); 8183 end if; 8184 8185 -- Generate: 8186 -- if B then 8187 -- if C = POK_Procedure 8188 -- or else C = POK_Protected_Procedure 8189 -- or else C = POK_Task_Procedure 8190 -- then 8191 -- <dispatching-call> 8192 -- end if; 8193 -- <normal-statements> 8194 -- else 8195 -- <else-statements> 8196 -- end if; 8197 8198 N_Stats := New_Copy_List_Tree (Statements (Alt)); 8199 8200 Prepend_To (N_Stats, 8201 Make_Implicit_If_Statement (N, 8202 Condition => 8203 Make_Or_Else (Loc, 8204 Left_Opnd => 8205 Make_Op_Eq (Loc, 8206 Left_Opnd => 8207 New_Occurrence_Of (C, Loc), 8208 Right_Opnd => 8209 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 8210 8211 Right_Opnd => 8212 Make_Or_Else (Loc, 8213 Left_Opnd => 8214 Make_Op_Eq (Loc, 8215 Left_Opnd => 8216 New_Occurrence_Of (C, Loc), 8217 Right_Opnd => 8218 New_Occurrence_Of (RTE ( 8219 RE_POK_Protected_Procedure), Loc)), 8220 8221 Right_Opnd => 8222 Make_Op_Eq (Loc, 8223 Left_Opnd => 8224 New_Occurrence_Of (C, Loc), 8225 Right_Opnd => 8226 New_Occurrence_Of (RTE ( 8227 RE_POK_Task_Procedure), Loc)))), 8228 8229 Then_Statements => 8230 New_List (Blk))); 8231 8232 Append_To (Conc_Typ_Stmts, 8233 Make_Implicit_If_Statement (N, 8234 Condition => New_Occurrence_Of (B, Loc), 8235 Then_Statements => N_Stats, 8236 Else_Statements => Else_Statements (N))); 8237 8238 -- Generate: 8239 -- <dispatching-call>; 8240 -- <triggering-statements> 8241 8242 Lim_Typ_Stmts := New_Copy_List_Tree (Statements (Alt)); 8243 Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (Blk)); 8244 8245 -- Generate: 8246 -- if K = Ada.Tags.TK_Limited_Tagged 8247 -- or else K = Ada.Tags.TK_Tagged 8248 -- then 8249 -- Lim_Typ_Stmts 8250 -- else 8251 -- Conc_Typ_Stmts 8252 -- end if; 8253 8254 Append_To (Stmts, 8255 Make_Implicit_If_Statement (N, 8256 Condition => Build_Dispatching_Tag_Check (K, N), 8257 Then_Statements => Lim_Typ_Stmts, 8258 Else_Statements => Conc_Typ_Stmts)); 8259 8260 Rewrite (N, 8261 Make_Block_Statement (Loc, 8262 Declarations => 8263 Decls, 8264 Handled_Statement_Sequence => 8265 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8266 8267 -- As described above, the entry alternative is transformed into a 8268 -- block that contains the gnulli call, and possibly assignment 8269 -- statements for in-out parameters. The gnulli call may itself be 8270 -- rewritten into a transient block if some unconstrained parameters 8271 -- require it. We need to retrieve the call to complete its parameter 8272 -- list. 8273 8274 else 8275 Transient_Blk := 8276 First_Real_Statement (Handled_Statement_Sequence (Blk)); 8277 8278 if Present (Transient_Blk) 8279 and then Nkind (Transient_Blk) = N_Block_Statement 8280 then 8281 Blk := Transient_Blk; 8282 end if; 8283 8284 Stmts := Statements (Handled_Statement_Sequence (Blk)); 8285 Stmt := First (Stmts); 8286 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 8287 Next (Stmt); 8288 end loop; 8289 8290 Call := Stmt; 8291 Params := Parameter_Associations (Call); 8292 8293 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then 8294 8295 -- Substitute Conditional_Entry_Call for Simple_Call parameter 8296 8297 Param := First (Params); 8298 while Present (Param) 8299 and then not Is_RTE (Etype (Param), RE_Call_Modes) 8300 loop 8301 Next (Param); 8302 end loop; 8303 8304 pragma Assert (Present (Param)); 8305 Rewrite (Param, 8306 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8307 8308 Analyze (Param); 8309 8310 -- Find the Communication_Block parameter for the call to the 8311 -- Cancelled function. 8312 8313 Decl := First (Declarations (Blk)); 8314 while Present (Decl) 8315 and then not Is_RTE (Etype (Object_Definition (Decl)), 8316 RE_Communication_Block) 8317 loop 8318 Next (Decl); 8319 end loop; 8320 8321 -- Add an if statement to execute the else part if the call 8322 -- does not succeed (as indicated by the Cancelled predicate). 8323 8324 Append_To (Stmts, 8325 Make_Implicit_If_Statement (N, 8326 Condition => Make_Function_Call (Loc, 8327 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 8328 Parameter_Associations => New_List ( 8329 New_Occurrence_Of (Defining_Identifier (Decl), Loc))), 8330 Then_Statements => Else_Statements (N), 8331 Else_Statements => Statements (Alt))); 8332 8333 else 8334 B := Make_Defining_Identifier (Loc, Name_uB); 8335 8336 -- Insert declaration of B in declarations of existing block 8337 8338 if No (Declarations (Blk)) then 8339 Set_Declarations (Blk, New_List); 8340 end if; 8341 8342 Prepend_To (Declarations (Blk), 8343 Make_Object_Declaration (Loc, 8344 Defining_Identifier => B, 8345 Object_Definition => 8346 New_Occurrence_Of (Standard_Boolean, Loc))); 8347 8348 -- Create new call statement 8349 8350 Append_To (Params, 8351 New_Occurrence_Of (RTE (RE_Conditional_Call), Loc)); 8352 Append_To (Params, New_Occurrence_Of (B, Loc)); 8353 8354 Rewrite (Call, 8355 Make_Procedure_Call_Statement (Loc, 8356 Name => New_Occurrence_Of (RTE (RE_Task_Entry_Call), Loc), 8357 Parameter_Associations => Params)); 8358 8359 -- Construct statement sequence for new block 8360 8361 Append_To (Stmts, 8362 Make_Implicit_If_Statement (N, 8363 Condition => New_Occurrence_Of (B, Loc), 8364 Then_Statements => Statements (Alt), 8365 Else_Statements => Else_Statements (N))); 8366 end if; 8367 8368 -- The result is the new block 8369 8370 Rewrite (N, 8371 Make_Block_Statement (Loc, 8372 Declarations => Declarations (Blk), 8373 Handled_Statement_Sequence => 8374 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 8375 end if; 8376 8377 Analyze (N); 8378 end Expand_N_Conditional_Entry_Call; 8379 8380 --------------------------------------- 8381 -- Expand_N_Delay_Relative_Statement -- 8382 --------------------------------------- 8383 8384 -- Delay statement is implemented as a procedure call to Delay_For 8385 -- defined in Ada.Calendar.Delays in order to reduce the overhead of 8386 -- simple delays imposed by the use of Protected Objects. 8387 8388 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is 8389 Loc : constant Source_Ptr := Sloc (N); 8390 begin 8391 Rewrite (N, 8392 Make_Procedure_Call_Statement (Loc, 8393 Name => New_Occurrence_Of (RTE (RO_CA_Delay_For), Loc), 8394 Parameter_Associations => New_List (Expression (N)))); 8395 Analyze (N); 8396 end Expand_N_Delay_Relative_Statement; 8397 8398 ------------------------------------ 8399 -- Expand_N_Delay_Until_Statement -- 8400 ------------------------------------ 8401 8402 -- Delay Until statement is implemented as a procedure call to 8403 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays. 8404 8405 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is 8406 Loc : constant Source_Ptr := Sloc (N); 8407 Typ : Entity_Id; 8408 8409 begin 8410 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then 8411 Typ := RTE (RO_CA_Delay_Until); 8412 else 8413 Typ := RTE (RO_RT_Delay_Until); 8414 end if; 8415 8416 Rewrite (N, 8417 Make_Procedure_Call_Statement (Loc, 8418 Name => New_Occurrence_Of (Typ, Loc), 8419 Parameter_Associations => New_List (Expression (N)))); 8420 8421 Analyze (N); 8422 end Expand_N_Delay_Until_Statement; 8423 8424 ------------------------- 8425 -- Expand_N_Entry_Body -- 8426 ------------------------- 8427 8428 procedure Expand_N_Entry_Body (N : Node_Id) is 8429 begin 8430 -- Associate discriminals with the next protected operation body to be 8431 -- expanded. 8432 8433 if Present (Next_Protected_Operation (N)) then 8434 Set_Discriminals (Parent (Current_Scope)); 8435 end if; 8436 end Expand_N_Entry_Body; 8437 8438 ----------------------------------- 8439 -- Expand_N_Entry_Call_Statement -- 8440 ----------------------------------- 8441 8442 -- An entry call is expanded into GNARLI calls to implement a simple entry 8443 -- call (see Build_Simple_Entry_Call). 8444 8445 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is 8446 Concval : Node_Id; 8447 Ename : Node_Id; 8448 Index : Node_Id; 8449 8450 begin 8451 if No_Run_Time_Mode then 8452 Error_Msg_CRT ("entry call", N); 8453 return; 8454 end if; 8455 8456 -- If this entry call is part of an asynchronous select, don't expand it 8457 -- here; it will be expanded with the select statement. Don't expand 8458 -- timed entry calls either, as they are translated into asynchronous 8459 -- entry calls. 8460 8461 -- ??? This whole approach is questionable; it may be better to go back 8462 -- to allowing the expansion to take place and then attempting to fix it 8463 -- up in Expand_N_Asynchronous_Select. The tricky part is figuring out 8464 -- whether the expanded call is on a task or protected entry. 8465 8466 if (Nkind (Parent (N)) /= N_Triggering_Alternative 8467 or else N /= Triggering_Statement (Parent (N))) 8468 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative 8469 or else N /= Entry_Call_Statement (Parent (N)) 8470 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call) 8471 then 8472 Extract_Entry (N, Concval, Ename, Index); 8473 Build_Simple_Entry_Call (N, Concval, Ename, Index); 8474 end if; 8475 end Expand_N_Entry_Call_Statement; 8476 8477 -------------------------------- 8478 -- Expand_N_Entry_Declaration -- 8479 -------------------------------- 8480 8481 -- If there are parameters, then first, each of the formals is marked by 8482 -- setting Is_Entry_Formal. Next a record type is built which is used to 8483 -- hold the parameter values. The name of this record type is entryP where 8484 -- entry is the name of the entry, with an additional corresponding access 8485 -- type called entryPA. The record type has matching components for each 8486 -- formal (the component names are the same as the formal names). For 8487 -- elementary types, the component type matches the formal type. For 8488 -- composite types, an access type is declared (with the name formalA) 8489 -- which designates the formal type, and the type of the component is this 8490 -- access type. Finally the Entry_Component of each formal is set to 8491 -- reference the corresponding record component. 8492 8493 procedure Expand_N_Entry_Declaration (N : Node_Id) is 8494 Loc : constant Source_Ptr := Sloc (N); 8495 Entry_Ent : constant Entity_Id := Defining_Identifier (N); 8496 Components : List_Id; 8497 Formal : Node_Id; 8498 Ftype : Entity_Id; 8499 Last_Decl : Node_Id; 8500 Component : Entity_Id; 8501 Ctype : Entity_Id; 8502 Decl : Node_Id; 8503 Rec_Ent : Entity_Id; 8504 Acc_Ent : Entity_Id; 8505 8506 begin 8507 Formal := First_Formal (Entry_Ent); 8508 Last_Decl := N; 8509 8510 -- Most processing is done only if parameters are present 8511 8512 if Present (Formal) then 8513 Components := New_List; 8514 8515 -- Loop through formals 8516 8517 while Present (Formal) loop 8518 Set_Is_Entry_Formal (Formal); 8519 Component := 8520 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); 8521 Set_Entry_Component (Formal, Component); 8522 Set_Entry_Formal (Component, Formal); 8523 Ftype := Etype (Formal); 8524 8525 -- Declare new access type and then append 8526 8527 Ctype := Make_Temporary (Loc, 'A'); 8528 Set_Is_Param_Block_Component_Type (Ctype); 8529 8530 Decl := 8531 Make_Full_Type_Declaration (Loc, 8532 Defining_Identifier => Ctype, 8533 Type_Definition => 8534 Make_Access_To_Object_Definition (Loc, 8535 All_Present => True, 8536 Constant_Present => Ekind (Formal) = E_In_Parameter, 8537 Subtype_Indication => New_Occurrence_Of (Ftype, Loc))); 8538 8539 Insert_After (Last_Decl, Decl); 8540 Last_Decl := Decl; 8541 8542 Append_To (Components, 8543 Make_Component_Declaration (Loc, 8544 Defining_Identifier => Component, 8545 Component_Definition => 8546 Make_Component_Definition (Loc, 8547 Aliased_Present => False, 8548 Subtype_Indication => New_Occurrence_Of (Ctype, Loc)))); 8549 8550 Next_Formal_With_Extras (Formal); 8551 end loop; 8552 8553 -- Create the Entry_Parameter_Record declaration 8554 8555 Rec_Ent := Make_Temporary (Loc, 'P'); 8556 8557 Decl := 8558 Make_Full_Type_Declaration (Loc, 8559 Defining_Identifier => Rec_Ent, 8560 Type_Definition => 8561 Make_Record_Definition (Loc, 8562 Component_List => 8563 Make_Component_List (Loc, 8564 Component_Items => Components))); 8565 8566 Insert_After (Last_Decl, Decl); 8567 Last_Decl := Decl; 8568 8569 -- Construct and link in the corresponding access type 8570 8571 Acc_Ent := Make_Temporary (Loc, 'A'); 8572 8573 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); 8574 8575 Decl := 8576 Make_Full_Type_Declaration (Loc, 8577 Defining_Identifier => Acc_Ent, 8578 Type_Definition => 8579 Make_Access_To_Object_Definition (Loc, 8580 All_Present => True, 8581 Subtype_Indication => New_Occurrence_Of (Rec_Ent, Loc))); 8582 8583 Insert_After (Last_Decl, Decl); 8584 end if; 8585 end Expand_N_Entry_Declaration; 8586 8587 ----------------------------- 8588 -- Expand_N_Protected_Body -- 8589 ----------------------------- 8590 8591 -- Protected bodies are expanded to the completion of the subprograms 8592 -- created for the corresponding protected type. These are a protected and 8593 -- unprotected version of each protected subprogram in the object, a 8594 -- function to calculate each entry barrier, and a procedure to execute the 8595 -- sequence of statements of each protected entry body. For example, for 8596 -- protected type ptype: 8597 8598 -- function entB 8599 -- (O : System.Address; 8600 -- E : Protected_Entry_Index) 8601 -- return Boolean 8602 -- is 8603 -- <discriminant renamings> 8604 -- <private object renamings> 8605 -- begin 8606 -- return <barrier expression>; 8607 -- end entB; 8608 8609 -- procedure pprocN (_object : in out poV;...) is 8610 -- <discriminant renamings> 8611 -- <private object renamings> 8612 -- begin 8613 -- <sequence of statements> 8614 -- end pprocN; 8615 8616 -- procedure pprocP (_object : in out poV;...) is 8617 -- procedure _clean is 8618 -- Pn : Boolean; 8619 -- begin 8620 -- ptypeS (_object, Pn); 8621 -- Unlock (_object._object'Access); 8622 -- Abort_Undefer.all; 8623 -- end _clean; 8624 8625 -- begin 8626 -- Abort_Defer.all; 8627 -- Lock (_object._object'Access); 8628 -- pprocN (_object;...); 8629 -- at end 8630 -- _clean; 8631 -- end pproc; 8632 8633 -- function pfuncN (_object : poV;...) return Return_Type is 8634 -- <discriminant renamings> 8635 -- <private object renamings> 8636 -- begin 8637 -- <sequence of statements> 8638 -- end pfuncN; 8639 8640 -- function pfuncP (_object : poV) return Return_Type is 8641 -- procedure _clean is 8642 -- begin 8643 -- Unlock (_object._object'Access); 8644 -- Abort_Undefer.all; 8645 -- end _clean; 8646 8647 -- begin 8648 -- Abort_Defer.all; 8649 -- Lock (_object._object'Access); 8650 -- return pfuncN (_object); 8651 8652 -- at end 8653 -- _clean; 8654 -- end pfunc; 8655 8656 -- procedure entE 8657 -- (O : System.Address; 8658 -- P : System.Address; 8659 -- E : Protected_Entry_Index) 8660 -- is 8661 -- <discriminant renamings> 8662 -- <private object renamings> 8663 -- type poVP is access poV; 8664 -- _Object : ptVP := ptVP!(O); 8665 8666 -- begin 8667 -- begin 8668 -- <statement sequence> 8669 -- Complete_Entry_Body (_Object._Object); 8670 -- exception 8671 -- when all others => 8672 -- Exceptional_Complete_Entry_Body ( 8673 -- _Object._Object, Get_GNAT_Exception); 8674 -- end; 8675 -- end entE; 8676 8677 -- The type poV is the record created for the protected type to hold 8678 -- the state of the protected object. 8679 8680 procedure Expand_N_Protected_Body (N : Node_Id) is 8681 Loc : constant Source_Ptr := Sloc (N); 8682 Pid : constant Entity_Id := Corresponding_Spec (N); 8683 8684 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Pid); 8685 -- This flag indicates whether the lock free implementation is active 8686 8687 Current_Node : Node_Id; 8688 Disp_Op_Body : Node_Id; 8689 New_Op_Body : Node_Id; 8690 Op_Body : Node_Id; 8691 Op_Id : Entity_Id; 8692 8693 function Build_Dispatching_Subprogram_Body 8694 (N : Node_Id; 8695 Pid : Node_Id; 8696 Prot_Bod : Node_Id) return Node_Id; 8697 -- Build a dispatching version of the protected subprogram body. The 8698 -- newly generated subprogram contains a call to the original protected 8699 -- body. The following code is generated: 8700 -- 8701 -- function <protected-function-name> (Param1 .. ParamN) return 8702 -- <return-type> is 8703 -- begin 8704 -- return <protected-function-name>P (Param1 .. ParamN); 8705 -- end <protected-function-name>; 8706 -- 8707 -- or 8708 -- 8709 -- procedure <protected-procedure-name> (Param1 .. ParamN) is 8710 -- begin 8711 -- <protected-procedure-name>P (Param1 .. ParamN); 8712 -- end <protected-procedure-name> 8713 8714 --------------------------------------- 8715 -- Build_Dispatching_Subprogram_Body -- 8716 --------------------------------------- 8717 8718 function Build_Dispatching_Subprogram_Body 8719 (N : Node_Id; 8720 Pid : Node_Id; 8721 Prot_Bod : Node_Id) return Node_Id 8722 is 8723 Loc : constant Source_Ptr := Sloc (N); 8724 Actuals : List_Id; 8725 Formal : Node_Id; 8726 Spec : Node_Id; 8727 Stmts : List_Id; 8728 8729 begin 8730 -- Generate a specification without a letter suffix in order to 8731 -- override an interface function or procedure. 8732 8733 Spec := Build_Protected_Sub_Specification (N, Pid, Dispatching_Mode); 8734 8735 -- The formal parameters become the actuals of the protected function 8736 -- or procedure call. 8737 8738 Actuals := New_List; 8739 Formal := First (Parameter_Specifications (Spec)); 8740 while Present (Formal) loop 8741 Append_To (Actuals, 8742 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 8743 Next (Formal); 8744 end loop; 8745 8746 if Nkind (Spec) = N_Procedure_Specification then 8747 Stmts := 8748 New_List ( 8749 Make_Procedure_Call_Statement (Loc, 8750 Name => 8751 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8752 Parameter_Associations => Actuals)); 8753 8754 else 8755 pragma Assert (Nkind (Spec) = N_Function_Specification); 8756 8757 Stmts := 8758 New_List ( 8759 Make_Simple_Return_Statement (Loc, 8760 Expression => 8761 Make_Function_Call (Loc, 8762 Name => 8763 New_Occurrence_Of (Corresponding_Spec (Prot_Bod), Loc), 8764 Parameter_Associations => Actuals))); 8765 end if; 8766 8767 return 8768 Make_Subprogram_Body (Loc, 8769 Declarations => Empty_List, 8770 Specification => Spec, 8771 Handled_Statement_Sequence => 8772 Make_Handled_Sequence_Of_Statements (Loc, Stmts)); 8773 end Build_Dispatching_Subprogram_Body; 8774 8775 -- Start of processing for Expand_N_Protected_Body 8776 8777 begin 8778 if No_Run_Time_Mode then 8779 Error_Msg_CRT ("protected body", N); 8780 return; 8781 end if; 8782 8783 -- This is the proper body corresponding to a stub. The declarations 8784 -- must be inserted at the point of the stub, which in turn is in the 8785 -- declarative part of the parent unit. 8786 8787 if Nkind (Parent (N)) = N_Subunit then 8788 Current_Node := Corresponding_Stub (Parent (N)); 8789 else 8790 Current_Node := N; 8791 end if; 8792 8793 Op_Body := First (Declarations (N)); 8794 8795 -- The protected body is replaced with the bodies of its 8796 -- protected operations, and the declarations for internal objects 8797 -- that may have been created for entry family bounds. 8798 8799 Rewrite (N, Make_Null_Statement (Sloc (N))); 8800 Analyze (N); 8801 8802 while Present (Op_Body) loop 8803 case Nkind (Op_Body) is 8804 when N_Subprogram_Declaration => 8805 null; 8806 8807 when N_Subprogram_Body => 8808 8809 -- Do not create bodies for eliminated operations 8810 8811 if not Is_Eliminated (Defining_Entity (Op_Body)) 8812 and then not Is_Eliminated (Corresponding_Spec (Op_Body)) 8813 then 8814 if Lock_Free_Active then 8815 New_Op_Body := 8816 Build_Lock_Free_Unprotected_Subprogram_Body 8817 (Op_Body, Pid); 8818 else 8819 New_Op_Body := 8820 Build_Unprotected_Subprogram_Body (Op_Body, Pid); 8821 end if; 8822 8823 Insert_After (Current_Node, New_Op_Body); 8824 Current_Node := New_Op_Body; 8825 Analyze (New_Op_Body); 8826 8827 -- Build the corresponding protected operation. It may 8828 -- appear that this is needed only if this is a visible 8829 -- operation of the type, or if it is an interrupt handler, 8830 -- and this was the strategy used previously in GNAT. 8831 8832 -- However, the operation may be exported through a 'Access 8833 -- to an external caller. This is the common idiom in code 8834 -- that uses the Ada 2005 Timing_Events package. As a result 8835 -- we need to produce the protected body for both visible 8836 -- and private operations, as well as operations that only 8837 -- have a body in the source, and for which we create a 8838 -- declaration in the protected body itself. 8839 8840 if Present (Corresponding_Spec (Op_Body)) then 8841 if Lock_Free_Active then 8842 New_Op_Body := 8843 Build_Lock_Free_Protected_Subprogram_Body 8844 (Op_Body, Pid, Specification (New_Op_Body)); 8845 else 8846 New_Op_Body := 8847 Build_Protected_Subprogram_Body 8848 (Op_Body, Pid, Specification (New_Op_Body)); 8849 end if; 8850 8851 Insert_After (Current_Node, New_Op_Body); 8852 Analyze (New_Op_Body); 8853 8854 Current_Node := New_Op_Body; 8855 8856 -- Generate an overriding primitive operation body for 8857 -- this subprogram if the protected type implements an 8858 -- interface. 8859 8860 if Ada_Version >= Ada_2005 8861 and then 8862 Present (Interfaces (Corresponding_Record_Type (Pid))) 8863 then 8864 Disp_Op_Body := 8865 Build_Dispatching_Subprogram_Body 8866 (Op_Body, Pid, New_Op_Body); 8867 8868 Insert_After (Current_Node, Disp_Op_Body); 8869 Analyze (Disp_Op_Body); 8870 8871 Current_Node := Disp_Op_Body; 8872 end if; 8873 end if; 8874 end if; 8875 8876 when N_Entry_Body => 8877 Op_Id := Defining_Identifier (Op_Body); 8878 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid); 8879 8880 Insert_After (Current_Node, New_Op_Body); 8881 Current_Node := New_Op_Body; 8882 Analyze (New_Op_Body); 8883 8884 when N_Implicit_Label_Declaration => 8885 null; 8886 8887 when N_Itype_Reference => 8888 Insert_After (Current_Node, New_Copy (Op_Body)); 8889 8890 when N_Freeze_Entity => 8891 New_Op_Body := New_Copy (Op_Body); 8892 8893 if Present (Entity (Op_Body)) 8894 and then Freeze_Node (Entity (Op_Body)) = Op_Body 8895 then 8896 Set_Freeze_Node (Entity (Op_Body), New_Op_Body); 8897 end if; 8898 8899 Insert_After (Current_Node, New_Op_Body); 8900 Current_Node := New_Op_Body; 8901 Analyze (New_Op_Body); 8902 8903 when N_Pragma => 8904 New_Op_Body := New_Copy (Op_Body); 8905 Insert_After (Current_Node, New_Op_Body); 8906 Current_Node := New_Op_Body; 8907 Analyze (New_Op_Body); 8908 8909 when N_Object_Declaration => 8910 pragma Assert (not Comes_From_Source (Op_Body)); 8911 New_Op_Body := New_Copy (Op_Body); 8912 Insert_After (Current_Node, New_Op_Body); 8913 Current_Node := New_Op_Body; 8914 Analyze (New_Op_Body); 8915 8916 when others => 8917 raise Program_Error; 8918 8919 end case; 8920 8921 Next (Op_Body); 8922 end loop; 8923 8924 -- Finally, create the body of the function that maps an entry index 8925 -- into the corresponding body index, except when there is no entry, or 8926 -- in a Ravenscar-like profile. 8927 8928 if Corresponding_Runtime_Package (Pid) = 8929 System_Tasking_Protected_Objects_Entries 8930 then 8931 New_Op_Body := Build_Find_Body_Index (Pid); 8932 Insert_After (Current_Node, New_Op_Body); 8933 Current_Node := New_Op_Body; 8934 Analyze (New_Op_Body); 8935 end if; 8936 8937 -- Ada 2005 (AI-345): Construct the primitive wrapper bodies after the 8938 -- protected body. At this point all wrapper specs have been created, 8939 -- frozen and included in the dispatch table for the protected type. 8940 8941 if Ada_Version >= Ada_2005 then 8942 Build_Wrapper_Bodies (Loc, Pid, Current_Node); 8943 end if; 8944 end Expand_N_Protected_Body; 8945 8946 ----------------------------------------- 8947 -- Expand_N_Protected_Type_Declaration -- 8948 ----------------------------------------- 8949 8950 -- First we create a corresponding record type declaration used to 8951 -- represent values of this protected type. 8952 -- The general form of this type declaration is 8953 8954 -- type poV (discriminants) is record 8955 -- _Object : aliased <kind>Protection 8956 -- [(<entry count> [, <handler count>])]; 8957 -- [entry_family : array (bounds) of Void;] 8958 -- <private data fields> 8959 -- end record; 8960 8961 -- The discriminants are present only if the corresponding protected type 8962 -- has discriminants, and they exactly mirror the protected type 8963 -- discriminants. The private data fields similarly mirror the private 8964 -- declarations of the protected type. 8965 8966 -- The Object field is always present. It contains RTS specific data used 8967 -- to control the protected object. It is declared as Aliased so that it 8968 -- can be passed as a pointer to the RTS. This allows the protected record 8969 -- to be referenced within RTS data structures. An appropriate Protection 8970 -- type and discriminant are generated. 8971 8972 -- The Service field is present for protected objects with entries. It 8973 -- contains sufficient information to allow the entry service procedure for 8974 -- this object to be called when the object is not known till runtime. 8975 8976 -- One entry_family component is present for each entry family in the 8977 -- task definition (see Expand_N_Task_Type_Declaration). 8978 8979 -- When a protected object is declared, an instance of the protected type 8980 -- value record is created. The elaboration of this declaration creates the 8981 -- correct bounds for the entry families, and also evaluates the priority 8982 -- expression if needed. The initialization routine for the protected type 8983 -- itself then calls Initialize_Protection with appropriate parameters to 8984 -- initialize the value of the Task_Id field. Install_Handlers may be also 8985 -- called if a pragma Attach_Handler applies. 8986 8987 -- Note: this record is passed to the subprograms created by the expansion 8988 -- of protected subprograms and entries. It is an in parameter to protected 8989 -- functions and an in out parameter to procedures and entry bodies. The 8990 -- Entity_Id for this created record type is placed in the 8991 -- Corresponding_Record_Type field of the associated protected type entity. 8992 8993 -- Next we create a procedure specifications for protected subprograms and 8994 -- entry bodies. For each protected subprograms two subprograms are 8995 -- created, an unprotected and a protected version. The unprotected version 8996 -- is called from within other operations of the same protected object. 8997 8998 -- We also build the call to register the procedure if a pragma 8999 -- Interrupt_Handler applies. 9000 9001 -- A single subprogram is created to service all entry bodies; it has an 9002 -- additional boolean out parameter indicating that the previous entry call 9003 -- made by the current task was serviced immediately, i.e. not by proxy. 9004 -- The O parameter contains a pointer to a record object of the type 9005 -- described above. An untyped interface is used here to allow this 9006 -- procedure to be called in places where the type of the object to be 9007 -- serviced is not known. This must be done, for example, when a call that 9008 -- may have been requeued is cancelled; the corresponding object must be 9009 -- serviced, but which object that is not known till runtime. 9010 9011 -- procedure ptypeS 9012 -- (O : System.Address; P : out Boolean); 9013 -- procedure pprocN (_object : in out poV); 9014 -- procedure pproc (_object : in out poV); 9015 -- function pfuncN (_object : poV); 9016 -- function pfunc (_object : poV); 9017 -- ... 9018 9019 -- Note that this must come after the record type declaration, since 9020 -- the specs refer to this type. 9021 9022 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is 9023 Discr_Map : constant Elist_Id := New_Elmt_List; 9024 Loc : constant Source_Ptr := Sloc (N); 9025 Prot_Typ : constant Entity_Id := Defining_Identifier (N); 9026 9027 Lock_Free_Active : constant Boolean := Uses_Lock_Free (Prot_Typ); 9028 -- This flag indicates whether the lock free implementation is active 9029 9030 Pdef : constant Node_Id := Protected_Definition (N); 9031 -- This contains two lists; one for visible and one for private decls 9032 9033 Body_Arr : Node_Id; 9034 Body_Id : Entity_Id; 9035 Cdecls : List_Id; 9036 Comp : Node_Id; 9037 Current_Node : Node_Id := N; 9038 E_Count : Int; 9039 Entries_Aggr : Node_Id; 9040 New_Priv : Node_Id; 9041 Object_Comp : Node_Id; 9042 Priv : Node_Id; 9043 Rec_Decl : Node_Id; 9044 9045 procedure Check_Inlining (Subp : Entity_Id); 9046 -- If the original operation has a pragma Inline, propagate the flag 9047 -- to the internal body, for possible inlining later on. The source 9048 -- operation is invisible to the back-end and is never actually called. 9049 9050 function Discriminated_Size (Comp : Entity_Id) return Boolean; 9051 -- If a component size is not static then a warning will be emitted 9052 -- in Ravenscar or other restricted contexts. When a component is non- 9053 -- static because of a discriminant constraint we can specialize the 9054 -- warning by mentioning discriminants explicitly. 9055 9056 procedure Expand_Entry_Declaration (Decl : Node_Id); 9057 -- Create the entry barrier and the procedure body for entry declaration 9058 -- Decl. All generated subprograms are added to Entry_Bodies_Array. 9059 9060 function Static_Component_Size (Comp : Entity_Id) return Boolean; 9061 -- When compiling under the Ravenscar profile, private components must 9062 -- have a static size, or else a protected object will require heap 9063 -- allocation, violating the corresponding restriction. It is preferable 9064 -- to make this check here, because it provides a better error message 9065 -- than the back-end, which refers to the object as a whole. 9066 9067 procedure Register_Handler; 9068 -- For a protected operation that is an interrupt handler, add the 9069 -- freeze action that will register it as such. 9070 9071 -------------------- 9072 -- Check_Inlining -- 9073 -------------------- 9074 9075 procedure Check_Inlining (Subp : Entity_Id) is 9076 begin 9077 if Is_Inlined (Subp) then 9078 Set_Is_Inlined (Protected_Body_Subprogram (Subp)); 9079 Set_Is_Inlined (Subp, False); 9080 end if; 9081 end Check_Inlining; 9082 9083 ------------------------ 9084 -- Discriminated_Size -- 9085 ------------------------ 9086 9087 function Discriminated_Size (Comp : Entity_Id) return Boolean is 9088 Typ : constant Entity_Id := Etype (Comp); 9089 Index : Node_Id; 9090 9091 function Non_Static_Bound (Bound : Node_Id) return Boolean; 9092 -- Check whether the bound of an index is non-static and does denote 9093 -- a discriminant, in which case any protected object of the type 9094 -- will have a non-static size. 9095 9096 ---------------------- 9097 -- Non_Static_Bound -- 9098 ---------------------- 9099 9100 function Non_Static_Bound (Bound : Node_Id) return Boolean is 9101 begin 9102 if Is_OK_Static_Expression (Bound) then 9103 return False; 9104 9105 elsif Is_Entity_Name (Bound) 9106 and then Present (Discriminal_Link (Entity (Bound))) 9107 then 9108 return False; 9109 9110 else 9111 return True; 9112 end if; 9113 end Non_Static_Bound; 9114 9115 -- Start of processing for Discriminated_Size 9116 9117 begin 9118 if not Is_Array_Type (Typ) then 9119 return False; 9120 end if; 9121 9122 if Ekind (Typ) = E_Array_Subtype then 9123 Index := First_Index (Typ); 9124 while Present (Index) loop 9125 if Non_Static_Bound (Low_Bound (Index)) 9126 or else Non_Static_Bound (High_Bound (Index)) 9127 then 9128 return False; 9129 end if; 9130 9131 Next_Index (Index); 9132 end loop; 9133 9134 return True; 9135 end if; 9136 9137 return False; 9138 end Discriminated_Size; 9139 9140 --------------------------- 9141 -- Static_Component_Size -- 9142 --------------------------- 9143 9144 function Static_Component_Size (Comp : Entity_Id) return Boolean is 9145 Typ : constant Entity_Id := Etype (Comp); 9146 C : Entity_Id; 9147 9148 begin 9149 if Is_Scalar_Type (Typ) then 9150 return True; 9151 9152 elsif Is_Array_Type (Typ) then 9153 return Compile_Time_Known_Bounds (Typ); 9154 9155 elsif Is_Record_Type (Typ) then 9156 C := First_Component (Typ); 9157 while Present (C) loop 9158 if not Static_Component_Size (C) then 9159 return False; 9160 end if; 9161 9162 Next_Component (C); 9163 end loop; 9164 9165 return True; 9166 9167 -- Any other type will be checked by the back-end 9168 9169 else 9170 return True; 9171 end if; 9172 end Static_Component_Size; 9173 9174 ------------------------------ 9175 -- Expand_Entry_Declaration -- 9176 ------------------------------ 9177 9178 procedure Expand_Entry_Declaration (Decl : Node_Id) is 9179 Ent_Id : constant Entity_Id := Defining_Entity (Decl); 9180 Bar_Id : Entity_Id; 9181 Bod_Id : Entity_Id; 9182 Subp : Node_Id; 9183 9184 begin 9185 E_Count := E_Count + 1; 9186 9187 -- Create the protected body subprogram 9188 9189 Bod_Id := 9190 Make_Defining_Identifier (Loc, 9191 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E')); 9192 Set_Protected_Body_Subprogram (Ent_Id, Bod_Id); 9193 9194 Subp := 9195 Make_Subprogram_Declaration (Loc, 9196 Specification => 9197 Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id)); 9198 9199 Insert_After (Current_Node, Subp); 9200 Current_Node := Subp; 9201 9202 Analyze (Subp); 9203 9204 -- Build a wrapper procedure to handle contract cases, preconditions, 9205 -- and postconditions. 9206 9207 Build_Contract_Wrapper (Ent_Id, N); 9208 9209 -- Create the barrier function 9210 9211 Bar_Id := 9212 Make_Defining_Identifier (Loc, 9213 Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B')); 9214 Set_Barrier_Function (Ent_Id, Bar_Id); 9215 9216 Subp := 9217 Make_Subprogram_Declaration (Loc, 9218 Specification => 9219 Build_Barrier_Function_Specification (Loc, Bar_Id)); 9220 Set_Is_Entry_Barrier_Function (Subp); 9221 9222 Insert_After (Current_Node, Subp); 9223 Current_Node := Subp; 9224 9225 Analyze (Subp); 9226 9227 Set_Protected_Body_Subprogram (Bar_Id, Bar_Id); 9228 Set_Scope (Bar_Id, Scope (Ent_Id)); 9229 9230 -- Collect pointers to the protected subprogram and the barrier 9231 -- of the current entry, for insertion into Entry_Bodies_Array. 9232 9233 Append_To (Expressions (Entries_Aggr), 9234 Make_Aggregate (Loc, 9235 Expressions => New_List ( 9236 Make_Attribute_Reference (Loc, 9237 Prefix => New_Occurrence_Of (Bar_Id, Loc), 9238 Attribute_Name => Name_Unrestricted_Access), 9239 Make_Attribute_Reference (Loc, 9240 Prefix => New_Occurrence_Of (Bod_Id, Loc), 9241 Attribute_Name => Name_Unrestricted_Access)))); 9242 end Expand_Entry_Declaration; 9243 9244 ---------------------- 9245 -- Register_Handler -- 9246 ---------------------- 9247 9248 procedure Register_Handler is 9249 9250 -- All semantic checks already done in Sem_Prag 9251 9252 Prot_Proc : constant Entity_Id := 9253 Defining_Unit_Name (Specification (Current_Node)); 9254 9255 Proc_Address : constant Node_Id := 9256 Make_Attribute_Reference (Loc, 9257 Prefix => 9258 New_Occurrence_Of (Prot_Proc, Loc), 9259 Attribute_Name => Name_Address); 9260 9261 RTS_Call : constant Entity_Id := 9262 Make_Procedure_Call_Statement (Loc, 9263 Name => 9264 New_Occurrence_Of 9265 (RTE (RE_Register_Interrupt_Handler), Loc), 9266 Parameter_Associations => New_List (Proc_Address)); 9267 begin 9268 Append_Freeze_Action (Prot_Proc, RTS_Call); 9269 end Register_Handler; 9270 9271 -- Local variables 9272 9273 Sub : Node_Id; 9274 9275 -- Start of processing for Expand_N_Protected_Type_Declaration 9276 9277 begin 9278 if Present (Corresponding_Record_Type (Prot_Typ)) then 9279 return; 9280 else 9281 Rec_Decl := Build_Corresponding_Record (N, Prot_Typ, Loc); 9282 end if; 9283 9284 Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl))); 9285 9286 Qualify_Entity_Names (N); 9287 9288 -- If the type has discriminants, their occurrences in the declaration 9289 -- have been replaced by the corresponding discriminals. For components 9290 -- that are constrained by discriminants, their homologues in the 9291 -- corresponding record type must refer to the discriminants of that 9292 -- record, so we must apply a new renaming to subtypes_indications: 9293 9294 -- protected discriminant => discriminal => record discriminant 9295 9296 -- This replacement is not applied to default expressions, for which 9297 -- the discriminal is correct. 9298 9299 if Has_Discriminants (Prot_Typ) then 9300 declare 9301 Disc : Entity_Id; 9302 Decl : Node_Id; 9303 9304 begin 9305 Disc := First_Discriminant (Prot_Typ); 9306 Decl := First (Discriminant_Specifications (Rec_Decl)); 9307 while Present (Disc) loop 9308 Append_Elmt (Discriminal (Disc), Discr_Map); 9309 Append_Elmt (Defining_Identifier (Decl), Discr_Map); 9310 Next_Discriminant (Disc); 9311 Next (Decl); 9312 end loop; 9313 end; 9314 end if; 9315 9316 -- Fill in the component declarations 9317 9318 -- Add components for entry families. For each entry family, create an 9319 -- anonymous type declaration with the same size, and analyze the type. 9320 9321 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prot_Typ); 9322 9323 pragma Assert (Present (Pdef)); 9324 9325 -- Add private field components 9326 9327 if Present (Private_Declarations (Pdef)) then 9328 Priv := First (Private_Declarations (Pdef)); 9329 while Present (Priv) loop 9330 if Nkind (Priv) = N_Component_Declaration then 9331 if not Static_Component_Size (Defining_Identifier (Priv)) then 9332 9333 -- When compiling for a restricted profile, the private 9334 -- components must have a static size. If not, this is an 9335 -- error for a single protected declaration, and rates a 9336 -- warning on a protected type declaration. 9337 9338 if not Comes_From_Source (Prot_Typ) then 9339 9340 -- It's ok to be checking this restriction at expansion 9341 -- time, because this is only for the restricted profile, 9342 -- which is not subject to strict RM conformance, so it 9343 -- is OK to miss this check in -gnatc mode. 9344 9345 Check_Restriction (No_Implicit_Heap_Allocations, Priv); 9346 Check_Restriction 9347 (No_Implicit_Protected_Object_Allocations, Priv); 9348 9349 elsif Restriction_Active (No_Implicit_Heap_Allocations) then 9350 if not Discriminated_Size (Defining_Identifier (Priv)) 9351 then 9352 -- Any object of the type will be non-static. 9353 9354 Error_Msg_N ("component has non-static size??", Priv); 9355 Error_Msg_NE 9356 ("\creation of protected object of type& will " 9357 & "violate restriction " 9358 & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ); 9359 else 9360 9361 -- Object will be non-static if discriminants are. 9362 9363 Error_Msg_NE 9364 ("creation of protected object of type& with " 9365 & "non-static discriminants will violate" 9366 & " restriction No_Implicit_Heap_Allocations??", 9367 Priv, Prot_Typ); 9368 end if; 9369 9370 -- Likewise for No_Implicit_Protected_Object_Allocations 9371 9372 elsif Restriction_Active 9373 (No_Implicit_Protected_Object_Allocations) 9374 then 9375 if not Discriminated_Size (Defining_Identifier (Priv)) 9376 then 9377 -- Any object of the type will be non-static. 9378 9379 Error_Msg_N ("component has non-static size??", Priv); 9380 Error_Msg_NE 9381 ("\creation of protected object of type& will " 9382 & "violate restriction " 9383 & "No_Implicit_Protected_Object_Allocations??", 9384 Priv, Prot_Typ); 9385 else 9386 -- Object will be non-static if discriminants are. 9387 9388 Error_Msg_NE 9389 ("creation of protected object of type& with " 9390 & "non-static discriminants will violate " 9391 & "restriction " 9392 & "No_Implicit_Protected_Object_Allocations??", 9393 Priv, Prot_Typ); 9394 end if; 9395 end if; 9396 end if; 9397 9398 -- The component definition consists of a subtype indication, 9399 -- or (in Ada 2005) an access definition. Make a copy of the 9400 -- proper definition. 9401 9402 declare 9403 Old_Comp : constant Node_Id := Component_Definition (Priv); 9404 Oent : constant Entity_Id := Defining_Identifier (Priv); 9405 Nent : constant Entity_Id := 9406 Make_Defining_Identifier (Sloc (Oent), 9407 Chars => Chars (Oent)); 9408 New_Comp : Node_Id; 9409 9410 begin 9411 if Present (Subtype_Indication (Old_Comp)) then 9412 New_Comp := 9413 Make_Component_Definition (Sloc (Oent), 9414 Aliased_Present => False, 9415 Subtype_Indication => 9416 New_Copy_Tree 9417 (Subtype_Indication (Old_Comp), Discr_Map)); 9418 else 9419 New_Comp := 9420 Make_Component_Definition (Sloc (Oent), 9421 Aliased_Present => False, 9422 Access_Definition => 9423 New_Copy_Tree 9424 (Access_Definition (Old_Comp), Discr_Map)); 9425 end if; 9426 9427 New_Priv := 9428 Make_Component_Declaration (Loc, 9429 Defining_Identifier => Nent, 9430 Component_Definition => New_Comp, 9431 Expression => Expression (Priv)); 9432 9433 Set_Has_Per_Object_Constraint (Nent, 9434 Has_Per_Object_Constraint (Oent)); 9435 9436 Append_To (Cdecls, New_Priv); 9437 end; 9438 9439 elsif Nkind (Priv) = N_Subprogram_Declaration then 9440 9441 -- Make the unprotected version of the subprogram available 9442 -- for expansion of intra object calls. There is need for 9443 -- a protected version only if the subprogram is an interrupt 9444 -- handler, otherwise this operation can only be called from 9445 -- within the body. 9446 9447 Sub := 9448 Make_Subprogram_Declaration (Loc, 9449 Specification => 9450 Build_Protected_Sub_Specification 9451 (Priv, Prot_Typ, Unprotected_Mode)); 9452 9453 Insert_After (Current_Node, Sub); 9454 Analyze (Sub); 9455 9456 Set_Protected_Body_Subprogram 9457 (Defining_Unit_Name (Specification (Priv)), 9458 Defining_Unit_Name (Specification (Sub))); 9459 Check_Inlining (Defining_Unit_Name (Specification (Priv))); 9460 Current_Node := Sub; 9461 9462 Sub := 9463 Make_Subprogram_Declaration (Loc, 9464 Specification => 9465 Build_Protected_Sub_Specification 9466 (Priv, Prot_Typ, Protected_Mode)); 9467 9468 Insert_After (Current_Node, Sub); 9469 Analyze (Sub); 9470 Current_Node := Sub; 9471 9472 if Is_Interrupt_Handler 9473 (Defining_Unit_Name (Specification (Priv))) 9474 then 9475 if not Restricted_Profile then 9476 Register_Handler; 9477 end if; 9478 end if; 9479 end if; 9480 9481 Next (Priv); 9482 end loop; 9483 end if; 9484 9485 -- Except for the lock-free implementation, append the _Object field 9486 -- with the right type to the component list. We need to compute the 9487 -- number of entries, and in some cases the number of Attach_Handler 9488 -- pragmas. 9489 9490 if not Lock_Free_Active then 9491 declare 9492 Entry_Count_Expr : constant Node_Id := 9493 Build_Entry_Count_Expression 9494 (Prot_Typ, Cdecls, Loc); 9495 Num_Attach_Handler : Int := 0; 9496 Protection_Subtype : Node_Id; 9497 Ritem : Node_Id; 9498 9499 begin 9500 if Has_Attach_Handler (Prot_Typ) then 9501 Ritem := First_Rep_Item (Prot_Typ); 9502 while Present (Ritem) loop 9503 if Nkind (Ritem) = N_Pragma 9504 and then Pragma_Name (Ritem) = Name_Attach_Handler 9505 then 9506 Num_Attach_Handler := Num_Attach_Handler + 1; 9507 end if; 9508 9509 Next_Rep_Item (Ritem); 9510 end loop; 9511 end if; 9512 9513 -- Determine the proper protection type. There are two special 9514 -- cases: 1) when the protected type has dynamic interrupt 9515 -- handlers, and 2) when it has static handlers and we use a 9516 -- restricted profile. 9517 9518 if Has_Attach_Handler (Prot_Typ) 9519 and then not Restricted_Profile 9520 then 9521 Protection_Subtype := 9522 Make_Subtype_Indication (Loc, 9523 Subtype_Mark => 9524 New_Occurrence_Of 9525 (RTE (RE_Static_Interrupt_Protection), Loc), 9526 Constraint => 9527 Make_Index_Or_Discriminant_Constraint (Loc, 9528 Constraints => New_List ( 9529 Entry_Count_Expr, 9530 Make_Integer_Literal (Loc, Num_Attach_Handler)))); 9531 9532 elsif Has_Interrupt_Handler (Prot_Typ) 9533 and then not Restriction_Active (No_Dynamic_Attachment) 9534 then 9535 Protection_Subtype := 9536 Make_Subtype_Indication (Loc, 9537 Subtype_Mark => 9538 New_Occurrence_Of 9539 (RTE (RE_Dynamic_Interrupt_Protection), Loc), 9540 Constraint => 9541 Make_Index_Or_Discriminant_Constraint (Loc, 9542 Constraints => New_List (Entry_Count_Expr))); 9543 9544 else 9545 case Corresponding_Runtime_Package (Prot_Typ) is 9546 when System_Tasking_Protected_Objects_Entries => 9547 Protection_Subtype := 9548 Make_Subtype_Indication (Loc, 9549 Subtype_Mark => 9550 New_Occurrence_Of 9551 (RTE (RE_Protection_Entries), Loc), 9552 Constraint => 9553 Make_Index_Or_Discriminant_Constraint (Loc, 9554 Constraints => New_List (Entry_Count_Expr))); 9555 9556 when System_Tasking_Protected_Objects_Single_Entry => 9557 Protection_Subtype := 9558 New_Occurrence_Of (RTE (RE_Protection_Entry), Loc); 9559 9560 when System_Tasking_Protected_Objects => 9561 Protection_Subtype := 9562 New_Occurrence_Of (RTE (RE_Protection), Loc); 9563 9564 when others => 9565 raise Program_Error; 9566 end case; 9567 end if; 9568 9569 Object_Comp := 9570 Make_Component_Declaration (Loc, 9571 Defining_Identifier => 9572 Make_Defining_Identifier (Loc, Name_uObject), 9573 Component_Definition => 9574 Make_Component_Definition (Loc, 9575 Aliased_Present => True, 9576 Subtype_Indication => Protection_Subtype)); 9577 end; 9578 9579 -- Put the _Object component after the private component so that it 9580 -- be finalized early as required by 9.4 (20) 9581 9582 Append_To (Cdecls, Object_Comp); 9583 end if; 9584 9585 Insert_After (Current_Node, Rec_Decl); 9586 Current_Node := Rec_Decl; 9587 9588 -- Analyze the record declaration immediately after construction, 9589 -- because the initialization procedure is needed for single object 9590 -- declarations before the next entity is analyzed (the freeze call 9591 -- that generates this initialization procedure is found below). 9592 9593 Analyze (Rec_Decl, Suppress => All_Checks); 9594 9595 -- Ada 2005 (AI-345): Construct the primitive entry wrappers before 9596 -- the corresponding record is frozen. If any wrappers are generated, 9597 -- Current_Node is updated accordingly. 9598 9599 if Ada_Version >= Ada_2005 then 9600 Build_Wrapper_Specs (Loc, Prot_Typ, Current_Node); 9601 end if; 9602 9603 -- Collect pointers to entry bodies and their barriers, to be placed 9604 -- in the Entry_Bodies_Array for the type. For each entry/family we 9605 -- add an expression to the aggregate which is the initial value of 9606 -- this array. The array is declared after all protected subprograms. 9607 9608 if Has_Entries (Prot_Typ) then 9609 Entries_Aggr := Make_Aggregate (Loc, Expressions => New_List); 9610 else 9611 Entries_Aggr := Empty; 9612 end if; 9613 9614 -- Build two new procedure specifications for each protected subprogram; 9615 -- one to call from outside the object and one to call from inside. 9616 -- Build a barrier function and an entry body action procedure 9617 -- specification for each protected entry. Initialize the entry body 9618 -- array. If subprogram is flagged as eliminated, do not generate any 9619 -- internal operations. 9620 9621 E_Count := 0; 9622 Comp := First (Visible_Declarations (Pdef)); 9623 while Present (Comp) loop 9624 if Nkind (Comp) = N_Subprogram_Declaration then 9625 Sub := 9626 Make_Subprogram_Declaration (Loc, 9627 Specification => 9628 Build_Protected_Sub_Specification 9629 (Comp, Prot_Typ, Unprotected_Mode)); 9630 9631 Insert_After (Current_Node, Sub); 9632 Analyze (Sub); 9633 9634 Set_Protected_Body_Subprogram 9635 (Defining_Unit_Name (Specification (Comp)), 9636 Defining_Unit_Name (Specification (Sub))); 9637 Check_Inlining (Defining_Unit_Name (Specification (Comp))); 9638 9639 -- Make the protected version of the subprogram available for 9640 -- expansion of external calls. 9641 9642 Current_Node := Sub; 9643 9644 Sub := 9645 Make_Subprogram_Declaration (Loc, 9646 Specification => 9647 Build_Protected_Sub_Specification 9648 (Comp, Prot_Typ, Protected_Mode)); 9649 9650 Insert_After (Current_Node, Sub); 9651 Analyze (Sub); 9652 9653 Current_Node := Sub; 9654 9655 -- Generate an overriding primitive operation specification for 9656 -- this subprogram if the protected type implements an interface. 9657 9658 if Ada_Version >= Ada_2005 9659 and then 9660 Present (Interfaces (Corresponding_Record_Type (Prot_Typ))) 9661 then 9662 Sub := 9663 Make_Subprogram_Declaration (Loc, 9664 Specification => 9665 Build_Protected_Sub_Specification 9666 (Comp, Prot_Typ, Dispatching_Mode)); 9667 9668 Insert_After (Current_Node, Sub); 9669 Analyze (Sub); 9670 9671 Current_Node := Sub; 9672 end if; 9673 9674 -- If a pragma Interrupt_Handler applies, build and add a call to 9675 -- Register_Interrupt_Handler to the freezing actions of the 9676 -- protected version (Current_Node) of the subprogram: 9677 9678 -- system.interrupts.register_interrupt_handler 9679 -- (prot_procP'address); 9680 9681 if not Restricted_Profile 9682 and then Is_Interrupt_Handler 9683 (Defining_Unit_Name (Specification (Comp))) 9684 then 9685 Register_Handler; 9686 end if; 9687 9688 elsif Nkind (Comp) = N_Entry_Declaration then 9689 Expand_Entry_Declaration (Comp); 9690 end if; 9691 9692 Next (Comp); 9693 end loop; 9694 9695 -- If there are some private entry declarations, expand it as if they 9696 -- were visible entries. 9697 9698 if Present (Private_Declarations (Pdef)) then 9699 Comp := First (Private_Declarations (Pdef)); 9700 while Present (Comp) loop 9701 if Nkind (Comp) = N_Entry_Declaration then 9702 Expand_Entry_Declaration (Comp); 9703 end if; 9704 9705 Next (Comp); 9706 end loop; 9707 end if; 9708 9709 -- Emit declaration for Entry_Bodies_Array, now that the addresses of 9710 -- all protected subprograms have been collected. 9711 9712 if Has_Entries (Prot_Typ) then 9713 Body_Id := 9714 Make_Defining_Identifier (Sloc (Prot_Typ), 9715 Chars => New_External_Name (Chars (Prot_Typ), 'A')); 9716 9717 case Corresponding_Runtime_Package (Prot_Typ) is 9718 when System_Tasking_Protected_Objects_Entries => 9719 Body_Arr := 9720 Make_Object_Declaration (Loc, 9721 Defining_Identifier => Body_Id, 9722 Aliased_Present => True, 9723 Object_Definition => 9724 Make_Subtype_Indication (Loc, 9725 Subtype_Mark => 9726 New_Occurrence_Of 9727 (RTE (RE_Protected_Entry_Body_Array), Loc), 9728 Constraint => 9729 Make_Index_Or_Discriminant_Constraint (Loc, 9730 Constraints => New_List ( 9731 Make_Range (Loc, 9732 Make_Integer_Literal (Loc, 1), 9733 Make_Integer_Literal (Loc, E_Count))))), 9734 Expression => Entries_Aggr); 9735 9736 when System_Tasking_Protected_Objects_Single_Entry => 9737 Body_Arr := 9738 Make_Object_Declaration (Loc, 9739 Defining_Identifier => Body_Id, 9740 Aliased_Present => True, 9741 Object_Definition => 9742 New_Occurrence_Of (RTE (RE_Entry_Body), Loc), 9743 Expression => Remove_Head (Expressions (Entries_Aggr))); 9744 9745 when others => 9746 raise Program_Error; 9747 end case; 9748 9749 -- A pointer to this array will be placed in the corresponding record 9750 -- by its initialization procedure so this needs to be analyzed here. 9751 9752 Insert_After (Current_Node, Body_Arr); 9753 Current_Node := Body_Arr; 9754 Analyze (Body_Arr); 9755 9756 Set_Entry_Bodies_Array (Prot_Typ, Body_Id); 9757 9758 -- Finally, build the function that maps an entry index into the 9759 -- corresponding body. A pointer to this function is placed in each 9760 -- object of the type. Except for a ravenscar-like profile (no abort, 9761 -- no entry queue, 1 entry) 9762 9763 if Corresponding_Runtime_Package (Prot_Typ) = 9764 System_Tasking_Protected_Objects_Entries 9765 then 9766 Sub := 9767 Make_Subprogram_Declaration (Loc, 9768 Specification => Build_Find_Body_Index_Spec (Prot_Typ)); 9769 Insert_After (Current_Node, Sub); 9770 Analyze (Sub); 9771 end if; 9772 end if; 9773 end Expand_N_Protected_Type_Declaration; 9774 9775 -------------------------------- 9776 -- Expand_N_Requeue_Statement -- 9777 -------------------------------- 9778 9779 -- A non-dispatching requeue statement is expanded into one of four GNARLI 9780 -- operations, depending on the source and destination (task or protected 9781 -- object). A dispatching requeue statement is expanded into a call to the 9782 -- predefined primitive _Disp_Requeue. In addition, code is generated to 9783 -- jump around the remainder of processing for the original entry and, if 9784 -- the destination is (different) protected object, to attempt to service 9785 -- it. The following illustrates the various cases: 9786 9787 -- procedure entE 9788 -- (O : System.Address; 9789 -- P : System.Address; 9790 -- E : Protected_Entry_Index) 9791 -- is 9792 -- <discriminant renamings> 9793 -- <private object renamings> 9794 -- type poVP is access poV; 9795 -- _object : ptVP := ptVP!(O); 9796 9797 -- begin 9798 -- begin 9799 -- <start of statement sequence for entry> 9800 9801 -- -- Requeue from one protected entry body to another protected 9802 -- -- entry. 9803 9804 -- Requeue_Protected_Entry ( 9805 -- _object._object'Access, 9806 -- new._object'Access, 9807 -- E, 9808 -- Abort_Present); 9809 -- return; 9810 9811 -- <some more of the statement sequence for entry> 9812 9813 -- -- Requeue from an entry body to a task entry 9814 9815 -- Requeue_Protected_To_Task_Entry ( 9816 -- New._task_id, 9817 -- E, 9818 -- Abort_Present); 9819 -- return; 9820 9821 -- <rest of statement sequence for entry> 9822 -- Complete_Entry_Body (_object._object); 9823 9824 -- exception 9825 -- when all others => 9826 -- Exceptional_Complete_Entry_Body ( 9827 -- _object._object, Get_GNAT_Exception); 9828 -- end; 9829 -- end entE; 9830 9831 -- Requeue of a task entry call to a task entry 9832 9833 -- Accept_Call (E, Ann); 9834 -- <start of statement sequence for accept statement> 9835 -- Requeue_Task_Entry (New._task_id, E, Abort_Present); 9836 -- goto Lnn; 9837 -- <rest of statement sequence for accept statement> 9838 -- <<Lnn>> 9839 -- Complete_Rendezvous; 9840 9841 -- exception 9842 -- when all others => 9843 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9844 9845 -- Requeue of a task entry call to a protected entry 9846 9847 -- Accept_Call (E, Ann); 9848 -- <start of statement sequence for accept statement> 9849 -- Requeue_Task_To_Protected_Entry ( 9850 -- new._object'Access, 9851 -- E, 9852 -- Abort_Present); 9853 -- newS (new, Pnn); 9854 -- goto Lnn; 9855 -- <rest of statement sequence for accept statement> 9856 -- <<Lnn>> 9857 -- Complete_Rendezvous; 9858 9859 -- exception 9860 -- when all others => 9861 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9862 9863 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9864 -- marked by pragma Implemented (XXX, By_Entry). 9865 9866 -- The requeue is inside a protected entry: 9867 9868 -- procedure entE 9869 -- (O : System.Address; 9870 -- P : System.Address; 9871 -- E : Protected_Entry_Index) 9872 -- is 9873 -- <discriminant renamings> 9874 -- <private object renamings> 9875 -- type poVP is access poV; 9876 -- _object : ptVP := ptVP!(O); 9877 9878 -- begin 9879 -- begin 9880 -- <start of statement sequence for entry> 9881 9882 -- _Disp_Requeue 9883 -- (<interface class-wide object>, 9884 -- True, 9885 -- _object'Address, 9886 -- Ada.Tags.Get_Offset_Index 9887 -- (Tag (_object), 9888 -- <interface dispatch table index of target entry>), 9889 -- Abort_Present); 9890 -- return; 9891 9892 -- <rest of statement sequence for entry> 9893 -- Complete_Entry_Body (_object._object); 9894 9895 -- exception 9896 -- when all others => 9897 -- Exceptional_Complete_Entry_Body ( 9898 -- _object._object, Get_GNAT_Exception); 9899 -- end; 9900 -- end entE; 9901 9902 -- The requeue is inside a task entry: 9903 9904 -- Accept_Call (E, Ann); 9905 -- <start of statement sequence for accept statement> 9906 -- _Disp_Requeue 9907 -- (<interface class-wide object>, 9908 -- False, 9909 -- null, 9910 -- Ada.Tags.Get_Offset_Index 9911 -- (Tag (_object), 9912 -- <interface dispatch table index of target entrt>), 9913 -- Abort_Present); 9914 -- newS (new, Pnn); 9915 -- goto Lnn; 9916 -- <rest of statement sequence for accept statement> 9917 -- <<Lnn>> 9918 -- Complete_Rendezvous; 9919 9920 -- exception 9921 -- when all others => 9922 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 9923 9924 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9925 -- marked by pragma Implemented (XXX, By_Protected_Procedure). The requeue 9926 -- statement is replaced by a dispatching call with actual parameters taken 9927 -- from the inner-most accept statement or entry body. 9928 9929 -- Target.Primitive (Param1, ..., ParamN); 9930 9931 -- Ada 2012 (AI05-0030): Dispatching requeue to an interface primitive 9932 -- marked by pragma Implemented (XXX, By_Any | Optional) or not marked 9933 -- at all. 9934 9935 -- declare 9936 -- S : constant Offset_Index := 9937 -- Get_Offset_Index (Tag (Concval), DT_Position (Ename)); 9938 -- C : constant Prim_Op_Kind := Get_Prim_Op_Kind (Tag (Concval), S); 9939 9940 -- begin 9941 -- if C = POK_Protected_Entry 9942 -- or else C = POK_Task_Entry 9943 -- then 9944 -- <statements for dispatching requeue> 9945 9946 -- elsif C = POK_Protected_Procedure then 9947 -- <dispatching call equivalent> 9948 9949 -- else 9950 -- raise Program_Error; 9951 -- end if; 9952 -- end; 9953 9954 procedure Expand_N_Requeue_Statement (N : Node_Id) is 9955 Loc : constant Source_Ptr := Sloc (N); 9956 Conc_Typ : Entity_Id; 9957 Concval : Node_Id; 9958 Ename : Node_Id; 9959 Index : Node_Id; 9960 Old_Typ : Entity_Id; 9961 9962 function Build_Dispatching_Call_Equivalent return Node_Id; 9963 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9964 -- the form Concval.Ename. It is statically known that Ename is allowed 9965 -- to be implemented by a protected procedure. Create a dispatching call 9966 -- equivalent of Concval.Ename taking the actual parameters from the 9967 -- inner-most accept statement or entry body. 9968 9969 function Build_Dispatching_Requeue return Node_Id; 9970 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9971 -- the form Concval.Ename. It is statically known that Ename is allowed 9972 -- to be implemented by a protected or a task entry. Create a call to 9973 -- primitive _Disp_Requeue which handles the low-level actions. 9974 9975 function Build_Dispatching_Requeue_To_Any return Node_Id; 9976 -- Ada 2012 (AI05-0030): N denotes a dispatching requeue statement of 9977 -- the form Concval.Ename. Ename is either marked by pragma Implemented 9978 -- (XXX, By_Any | Optional) or not marked at all. Create a block which 9979 -- determines at runtime whether Ename denotes an entry or a procedure 9980 -- and perform the appropriate kind of dispatching select. 9981 9982 function Build_Normal_Requeue return Node_Id; 9983 -- N denotes a non-dispatching requeue statement to either a task or a 9984 -- protected entry. Build the appropriate runtime call to perform the 9985 -- action. 9986 9987 function Build_Skip_Statement (Search : Node_Id) return Node_Id; 9988 -- For a protected entry, create a return statement to skip the rest of 9989 -- the entry body. Otherwise, create a goto statement to skip the rest 9990 -- of a task accept statement. The lookup for the enclosing entry body 9991 -- or accept statement starts from Search. 9992 9993 --------------------------------------- 9994 -- Build_Dispatching_Call_Equivalent -- 9995 --------------------------------------- 9996 9997 function Build_Dispatching_Call_Equivalent return Node_Id is 9998 Call_Ent : constant Entity_Id := Entity (Ename); 9999 Obj : constant Node_Id := Original_Node (Concval); 10000 Acc_Ent : Node_Id; 10001 Actuals : List_Id; 10002 Formal : Node_Id; 10003 Formals : List_Id; 10004 10005 begin 10006 -- Climb the parent chain looking for the inner-most entry body or 10007 -- accept statement. 10008 10009 Acc_Ent := N; 10010 while Present (Acc_Ent) 10011 and then not Nkind_In (Acc_Ent, N_Accept_Statement, 10012 N_Entry_Body) 10013 loop 10014 Acc_Ent := Parent (Acc_Ent); 10015 end loop; 10016 10017 -- A requeue statement should be housed inside an entry body or an 10018 -- accept statement at some level. If this is not the case, then the 10019 -- tree is malformed. 10020 10021 pragma Assert (Present (Acc_Ent)); 10022 10023 -- Recover the list of formal parameters 10024 10025 if Nkind (Acc_Ent) = N_Entry_Body then 10026 Acc_Ent := Entry_Body_Formal_Part (Acc_Ent); 10027 end if; 10028 10029 Formals := Parameter_Specifications (Acc_Ent); 10030 10031 -- Create the actual parameters for the dispatching call. These are 10032 -- simply copies of the entry body or accept statement formals in the 10033 -- same order as they appear. 10034 10035 Actuals := No_List; 10036 10037 if Present (Formals) then 10038 Actuals := New_List; 10039 Formal := First (Formals); 10040 while Present (Formal) loop 10041 Append_To (Actuals, 10042 Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); 10043 Next (Formal); 10044 end loop; 10045 end if; 10046 10047 -- Generate: 10048 -- Obj.Call_Ent (Actuals); 10049 10050 return 10051 Make_Procedure_Call_Statement (Loc, 10052 Name => 10053 Make_Selected_Component (Loc, 10054 Prefix => Make_Identifier (Loc, Chars (Obj)), 10055 Selector_Name => Make_Identifier (Loc, Chars (Call_Ent))), 10056 10057 Parameter_Associations => Actuals); 10058 end Build_Dispatching_Call_Equivalent; 10059 10060 ------------------------------- 10061 -- Build_Dispatching_Requeue -- 10062 ------------------------------- 10063 10064 function Build_Dispatching_Requeue return Node_Id is 10065 Params : constant List_Id := New_List; 10066 10067 begin 10068 -- Process the "with abort" parameter 10069 10070 Prepend_To (Params, 10071 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 10072 10073 -- Process the entry wrapper's position in the primary dispatch 10074 -- table parameter. Generate: 10075 10076 -- Ada.Tags.Get_Entry_Index 10077 -- (T => To_Tag_Ptr (Obj'Address).all, 10078 -- Position => 10079 -- Ada.Tags.Get_Offset_Index 10080 -- (Ada.Tags.Tag (Concval), 10081 -- <interface dispatch table position of Ename>)); 10082 10083 -- Note that Obj'Address is recursively expanded into a call to 10084 -- Base_Address (Obj). 10085 10086 if Tagged_Type_Expansion then 10087 Prepend_To (Params, 10088 Make_Function_Call (Loc, 10089 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 10090 Parameter_Associations => New_List ( 10091 10092 Make_Explicit_Dereference (Loc, 10093 Unchecked_Convert_To (RTE (RE_Tag_Ptr), 10094 Make_Attribute_Reference (Loc, 10095 Prefix => New_Copy_Tree (Concval), 10096 Attribute_Name => Name_Address))), 10097 10098 Make_Function_Call (Loc, 10099 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 10100 Parameter_Associations => New_List ( 10101 Unchecked_Convert_To (RTE (RE_Tag), Concval), 10102 Make_Integer_Literal (Loc, 10103 DT_Position (Entity (Ename)))))))); 10104 10105 -- VM targets 10106 10107 else 10108 Prepend_To (Params, 10109 Make_Function_Call (Loc, 10110 Name => New_Occurrence_Of (RTE (RE_Get_Entry_Index), Loc), 10111 Parameter_Associations => New_List ( 10112 10113 Make_Attribute_Reference (Loc, 10114 Prefix => Concval, 10115 Attribute_Name => Name_Tag), 10116 10117 Make_Function_Call (Loc, 10118 Name => New_Occurrence_Of (RTE (RE_Get_Offset_Index), Loc), 10119 10120 Parameter_Associations => New_List ( 10121 10122 -- Obj_Tag 10123 10124 Make_Attribute_Reference (Loc, 10125 Prefix => Concval, 10126 Attribute_Name => Name_Tag), 10127 10128 -- Tag_Typ 10129 10130 Make_Attribute_Reference (Loc, 10131 Prefix => New_Occurrence_Of (Etype (Concval), Loc), 10132 Attribute_Name => Name_Tag), 10133 10134 -- Position 10135 10136 Make_Integer_Literal (Loc, 10137 DT_Position (Entity (Ename)))))))); 10138 end if; 10139 10140 -- Specific actuals for protected to XXX requeue 10141 10142 if Is_Protected_Type (Old_Typ) then 10143 Prepend_To (Params, 10144 Make_Attribute_Reference (Loc, -- _object'Address 10145 Prefix => 10146 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 10147 Attribute_Name => Name_Address)); 10148 10149 Prepend_To (Params, -- True 10150 New_Occurrence_Of (Standard_True, Loc)); 10151 10152 -- Specific actuals for task to XXX requeue 10153 10154 else 10155 pragma Assert (Is_Task_Type (Old_Typ)); 10156 10157 Prepend_To (Params, -- null 10158 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 10159 10160 Prepend_To (Params, -- False 10161 New_Occurrence_Of (Standard_False, Loc)); 10162 end if; 10163 10164 -- Add the object parameter 10165 10166 Prepend_To (Params, New_Copy_Tree (Concval)); 10167 10168 -- Generate: 10169 -- _Disp_Requeue (<Params>); 10170 10171 -- Find entity for Disp_Requeue operation, which belongs to 10172 -- the type and may not be directly visible. 10173 10174 declare 10175 Elmt : Elmt_Id; 10176 Op : Entity_Id; 10177 10178 begin 10179 Elmt := First_Elmt (Primitive_Operations (Etype (Conc_Typ))); 10180 while Present (Elmt) loop 10181 Op := Node (Elmt); 10182 exit when Chars (Op) = Name_uDisp_Requeue; 10183 Next_Elmt (Elmt); 10184 end loop; 10185 10186 return 10187 Make_Procedure_Call_Statement (Loc, 10188 Name => New_Occurrence_Of (Op, Loc), 10189 Parameter_Associations => Params); 10190 end; 10191 end Build_Dispatching_Requeue; 10192 10193 -------------------------------------- 10194 -- Build_Dispatching_Requeue_To_Any -- 10195 -------------------------------------- 10196 10197 function Build_Dispatching_Requeue_To_Any return Node_Id is 10198 Call_Ent : constant Entity_Id := Entity (Ename); 10199 Obj : constant Node_Id := Original_Node (Concval); 10200 Skip : constant Node_Id := Build_Skip_Statement (N); 10201 C : Entity_Id; 10202 Decls : List_Id; 10203 S : Entity_Id; 10204 Stmts : List_Id; 10205 10206 begin 10207 Decls := New_List; 10208 Stmts := New_List; 10209 10210 -- Dispatch table slot processing, generate: 10211 -- S : Integer; 10212 10213 S := Build_S (Loc, Decls); 10214 10215 -- Call kind processing, generate: 10216 -- C : Ada.Tags.Prim_Op_Kind; 10217 10218 C := Build_C (Loc, Decls); 10219 10220 -- Generate: 10221 -- S := Ada.Tags.Get_Offset_Index 10222 -- (Ada.Tags.Tag (Obj), DT_Position (Call_Ent)); 10223 10224 Append_To (Stmts, Build_S_Assignment (Loc, S, Obj, Call_Ent)); 10225 10226 -- Generate: 10227 -- _Disp_Get_Prim_Op_Kind (Obj, S, C); 10228 10229 Append_To (Stmts, 10230 Make_Procedure_Call_Statement (Loc, 10231 Name => 10232 New_Occurrence_Of ( 10233 Find_Prim_Op (Etype (Etype (Obj)), 10234 Name_uDisp_Get_Prim_Op_Kind), 10235 Loc), 10236 Parameter_Associations => New_List ( 10237 New_Copy_Tree (Obj), 10238 New_Occurrence_Of (S, Loc), 10239 New_Occurrence_Of (C, Loc)))); 10240 10241 Append_To (Stmts, 10242 10243 -- if C = POK_Protected_Entry 10244 -- or else C = POK_Task_Entry 10245 -- then 10246 10247 Make_Implicit_If_Statement (N, 10248 Condition => 10249 Make_Op_Or (Loc, 10250 Left_Opnd => 10251 Make_Op_Eq (Loc, 10252 Left_Opnd => 10253 New_Occurrence_Of (C, Loc), 10254 Right_Opnd => 10255 New_Occurrence_Of (RTE (RE_POK_Protected_Entry), Loc)), 10256 10257 Right_Opnd => 10258 Make_Op_Eq (Loc, 10259 Left_Opnd => 10260 New_Occurrence_Of (C, Loc), 10261 Right_Opnd => 10262 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 10263 10264 -- Dispatching requeue equivalent 10265 10266 Then_Statements => New_List ( 10267 Build_Dispatching_Requeue, 10268 Skip), 10269 10270 -- elsif C = POK_Protected_Procedure then 10271 10272 Elsif_Parts => New_List ( 10273 Make_Elsif_Part (Loc, 10274 Condition => 10275 Make_Op_Eq (Loc, 10276 Left_Opnd => 10277 New_Occurrence_Of (C, Loc), 10278 Right_Opnd => 10279 New_Occurrence_Of ( 10280 RTE (RE_POK_Protected_Procedure), Loc)), 10281 10282 -- Dispatching call equivalent 10283 10284 Then_Statements => New_List ( 10285 Build_Dispatching_Call_Equivalent))), 10286 10287 -- else 10288 -- raise Program_Error; 10289 -- end if; 10290 10291 Else_Statements => New_List ( 10292 Make_Raise_Program_Error (Loc, 10293 Reason => PE_Explicit_Raise)))); 10294 10295 -- Wrap everything into a block 10296 10297 return 10298 Make_Block_Statement (Loc, 10299 Declarations => Decls, 10300 Handled_Statement_Sequence => 10301 Make_Handled_Sequence_Of_Statements (Loc, 10302 Statements => Stmts)); 10303 end Build_Dispatching_Requeue_To_Any; 10304 10305 -------------------------- 10306 -- Build_Normal_Requeue -- 10307 -------------------------- 10308 10309 function Build_Normal_Requeue return Node_Id is 10310 Params : constant List_Id := New_List; 10311 Param : Node_Id; 10312 RT_Call : Node_Id; 10313 10314 begin 10315 -- Process the "with abort" parameter 10316 10317 Prepend_To (Params, 10318 New_Occurrence_Of (Boolean_Literals (Abort_Present (N)), Loc)); 10319 10320 -- Add the index expression to the parameters. It is common among all 10321 -- four cases. 10322 10323 Prepend_To (Params, 10324 Entry_Index_Expression (Loc, Entity (Ename), Index, Conc_Typ)); 10325 10326 if Is_Protected_Type (Old_Typ) then 10327 declare 10328 Self_Param : Node_Id; 10329 10330 begin 10331 Self_Param := 10332 Make_Attribute_Reference (Loc, 10333 Prefix => 10334 Concurrent_Ref (New_Occurrence_Of (Old_Typ, Loc)), 10335 Attribute_Name => 10336 Name_Unchecked_Access); 10337 10338 -- Protected to protected requeue 10339 10340 if Is_Protected_Type (Conc_Typ) then 10341 RT_Call := 10342 New_Occurrence_Of ( 10343 RTE (RE_Requeue_Protected_Entry), Loc); 10344 10345 Param := 10346 Make_Attribute_Reference (Loc, 10347 Prefix => 10348 Concurrent_Ref (Concval), 10349 Attribute_Name => 10350 Name_Unchecked_Access); 10351 10352 -- Protected to task requeue 10353 10354 else pragma Assert (Is_Task_Type (Conc_Typ)); 10355 RT_Call := 10356 New_Occurrence_Of ( 10357 RTE (RE_Requeue_Protected_To_Task_Entry), Loc); 10358 10359 Param := Concurrent_Ref (Concval); 10360 end if; 10361 10362 Prepend_To (Params, Param); 10363 Prepend_To (Params, Self_Param); 10364 end; 10365 10366 else pragma Assert (Is_Task_Type (Old_Typ)); 10367 10368 -- Task to protected requeue 10369 10370 if Is_Protected_Type (Conc_Typ) then 10371 RT_Call := 10372 New_Occurrence_Of ( 10373 RTE (RE_Requeue_Task_To_Protected_Entry), Loc); 10374 10375 Param := 10376 Make_Attribute_Reference (Loc, 10377 Prefix => 10378 Concurrent_Ref (Concval), 10379 Attribute_Name => 10380 Name_Unchecked_Access); 10381 10382 -- Task to task requeue 10383 10384 else pragma Assert (Is_Task_Type (Conc_Typ)); 10385 RT_Call := 10386 New_Occurrence_Of (RTE (RE_Requeue_Task_Entry), Loc); 10387 10388 Param := Concurrent_Ref (Concval); 10389 end if; 10390 10391 Prepend_To (Params, Param); 10392 end if; 10393 10394 return 10395 Make_Procedure_Call_Statement (Loc, 10396 Name => RT_Call, 10397 Parameter_Associations => Params); 10398 end Build_Normal_Requeue; 10399 10400 -------------------------- 10401 -- Build_Skip_Statement -- 10402 -------------------------- 10403 10404 function Build_Skip_Statement (Search : Node_Id) return Node_Id is 10405 Skip_Stmt : Node_Id; 10406 10407 begin 10408 -- Build a return statement to skip the rest of the entire body 10409 10410 if Is_Protected_Type (Old_Typ) then 10411 Skip_Stmt := Make_Simple_Return_Statement (Loc); 10412 10413 -- If the requeue is within a task, find the end label of the 10414 -- enclosing accept statement and create a goto statement to it. 10415 10416 else 10417 declare 10418 Acc : Node_Id; 10419 Label : Node_Id; 10420 10421 begin 10422 -- Climb the parent chain looking for the enclosing accept 10423 -- statement. 10424 10425 Acc := Parent (Search); 10426 while Present (Acc) 10427 and then Nkind (Acc) /= N_Accept_Statement 10428 loop 10429 Acc := Parent (Acc); 10430 end loop; 10431 10432 -- The last statement is the second label used for completing 10433 -- the rendezvous the usual way. The label we are looking for 10434 -- is right before it. 10435 10436 Label := 10437 Prev (Last (Statements (Handled_Statement_Sequence (Acc)))); 10438 10439 pragma Assert (Nkind (Label) = N_Label); 10440 10441 -- Generate a goto statement to skip the rest of the accept 10442 10443 Skip_Stmt := 10444 Make_Goto_Statement (Loc, 10445 Name => 10446 New_Occurrence_Of (Entity (Identifier (Label)), Loc)); 10447 end; 10448 end if; 10449 10450 Set_Analyzed (Skip_Stmt); 10451 10452 return Skip_Stmt; 10453 end Build_Skip_Statement; 10454 10455 -- Start of processing for Expand_N_Requeue_Statement 10456 10457 begin 10458 -- Extract the components of the entry call 10459 10460 Extract_Entry (N, Concval, Ename, Index); 10461 Conc_Typ := Etype (Concval); 10462 10463 -- If the prefix is an access to class-wide type, dereference to get 10464 -- object and entry type. 10465 10466 if Is_Access_Type (Conc_Typ) then 10467 Conc_Typ := Designated_Type (Conc_Typ); 10468 Rewrite (Concval, 10469 Make_Explicit_Dereference (Loc, Relocate_Node (Concval))); 10470 Analyze_And_Resolve (Concval, Conc_Typ); 10471 end if; 10472 10473 -- Examine the scope stack in order to find nearest enclosing protected 10474 -- or task type. This will constitute our invocation source. 10475 10476 Old_Typ := Current_Scope; 10477 while Present (Old_Typ) 10478 and then not Is_Protected_Type (Old_Typ) 10479 and then not Is_Task_Type (Old_Typ) 10480 loop 10481 Old_Typ := Scope (Old_Typ); 10482 end loop; 10483 10484 -- Ada 2012 (AI05-0030): We have a dispatching requeue of the form 10485 -- Concval.Ename where the type of Concval is class-wide concurrent 10486 -- interface. 10487 10488 if Ada_Version >= Ada_2012 10489 and then Present (Concval) 10490 and then Is_Class_Wide_Type (Conc_Typ) 10491 and then Is_Concurrent_Interface (Conc_Typ) 10492 then 10493 declare 10494 Has_Impl : Boolean := False; 10495 Impl_Kind : Name_Id := No_Name; 10496 10497 begin 10498 -- Check whether the Ename is flagged by pragma Implemented 10499 10500 if Has_Rep_Pragma (Entity (Ename), Name_Implemented) then 10501 Has_Impl := True; 10502 Impl_Kind := Implementation_Kind (Entity (Ename)); 10503 end if; 10504 10505 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10506 -- an entry. Create a call to predefined primitive _Disp_Requeue. 10507 10508 if Has_Impl and then Impl_Kind = Name_By_Entry then 10509 Rewrite (N, Build_Dispatching_Requeue); 10510 Analyze (N); 10511 Insert_After (N, Build_Skip_Statement (N)); 10512 10513 -- The procedure_or_entry_NAME is guaranteed to be overridden by 10514 -- a protected procedure. In this case the requeue is transformed 10515 -- into a dispatching call. 10516 10517 elsif Has_Impl 10518 and then Impl_Kind = Name_By_Protected_Procedure 10519 then 10520 Rewrite (N, Build_Dispatching_Call_Equivalent); 10521 Analyze (N); 10522 10523 -- The procedure_or_entry_NAME's implementation kind is either 10524 -- By_Any, Optional, or pragma Implemented was not applied at all. 10525 -- In this case a runtime test determines whether Ename denotes an 10526 -- entry or a protected procedure and performs the appropriate 10527 -- call. 10528 10529 else 10530 Rewrite (N, Build_Dispatching_Requeue_To_Any); 10531 Analyze (N); 10532 end if; 10533 end; 10534 10535 -- Processing for regular (non-dispatching) requeues 10536 10537 else 10538 Rewrite (N, Build_Normal_Requeue); 10539 Analyze (N); 10540 Insert_After (N, Build_Skip_Statement (N)); 10541 end if; 10542 end Expand_N_Requeue_Statement; 10543 10544 ------------------------------- 10545 -- Expand_N_Selective_Accept -- 10546 ------------------------------- 10547 10548 procedure Expand_N_Selective_Accept (N : Node_Id) is 10549 Loc : constant Source_Ptr := Sloc (N); 10550 Alts : constant List_Id := Select_Alternatives (N); 10551 10552 -- Note: in the below declarations a lot of new lists are allocated 10553 -- unconditionally which may well not end up being used. That's not 10554 -- a good idea since it wastes space gratuitously ??? 10555 10556 Accept_Case : List_Id; 10557 Accept_List : constant List_Id := New_List; 10558 10559 Alt : Node_Id; 10560 Alt_List : constant List_Id := New_List; 10561 Alt_Stats : List_Id; 10562 Ann : Entity_Id := Empty; 10563 10564 Check_Guard : Boolean := True; 10565 10566 Decls : constant List_Id := New_List; 10567 Stats : constant List_Id := New_List; 10568 Body_List : constant List_Id := New_List; 10569 Trailing_List : constant List_Id := New_List; 10570 10571 Choices : List_Id; 10572 Else_Present : Boolean := False; 10573 Terminate_Alt : Node_Id := Empty; 10574 Select_Mode : Node_Id; 10575 10576 Delay_Case : List_Id; 10577 Delay_Count : Integer := 0; 10578 Delay_Val : Entity_Id; 10579 Delay_Index : Entity_Id; 10580 Delay_Min : Entity_Id; 10581 Delay_Num : Int := 1; 10582 Delay_Alt_List : List_Id := New_List; 10583 Delay_List : constant List_Id := New_List; 10584 D : Entity_Id; 10585 M : Entity_Id; 10586 10587 First_Delay : Boolean := True; 10588 Guard_Open : Entity_Id; 10589 10590 End_Lab : Node_Id; 10591 Index : Int := 1; 10592 Lab : Node_Id; 10593 Num_Alts : Int; 10594 Num_Accept : Nat := 0; 10595 Proc : Node_Id; 10596 Time_Type : Entity_Id; 10597 Select_Call : Node_Id; 10598 10599 Qnam : constant Entity_Id := 10600 Make_Defining_Identifier (Loc, New_External_Name ('S', 0)); 10601 10602 Xnam : constant Entity_Id := 10603 Make_Defining_Identifier (Loc, New_External_Name ('J', 1)); 10604 10605 ----------------------- 10606 -- Local subprograms -- 10607 ----------------------- 10608 10609 function Accept_Or_Raise return List_Id; 10610 -- For the rare case where delay alternatives all have guards, and 10611 -- all of them are closed, it is still possible that there were open 10612 -- accept alternatives with no callers. We must reexamine the 10613 -- Accept_List, and execute a selective wait with no else if some 10614 -- accept is open. If none, we raise program_error. 10615 10616 procedure Add_Accept (Alt : Node_Id); 10617 -- Process a single accept statement in a select alternative. Build 10618 -- procedure for body of accept, and add entry to dispatch table with 10619 -- expression for guard, in preparation for call to run time select. 10620 10621 function Make_And_Declare_Label (Num : Int) return Node_Id; 10622 -- Manufacture a label using Num as a serial number and declare it. 10623 -- The declaration is appended to Decls. The label marks the trailing 10624 -- statements of an accept or delay alternative. 10625 10626 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id; 10627 -- Build call to Selective_Wait runtime routine 10628 10629 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int); 10630 -- Add code to compare value of delay with previous values, and 10631 -- generate case entry for trailing statements. 10632 10633 procedure Process_Accept_Alternative 10634 (Alt : Node_Id; 10635 Index : Int; 10636 Proc : Node_Id); 10637 -- Add code to call corresponding procedure, and branch to 10638 -- trailing statements, if any. 10639 10640 --------------------- 10641 -- Accept_Or_Raise -- 10642 --------------------- 10643 10644 function Accept_Or_Raise return List_Id is 10645 Cond : Node_Id; 10646 Stats : List_Id; 10647 J : constant Entity_Id := Make_Temporary (Loc, 'J'); 10648 10649 begin 10650 -- We generate the following: 10651 10652 -- for J in q'range loop 10653 -- if q(J).S /=null_task_entry then 10654 -- selective_wait (simple_mode,...); 10655 -- done := True; 10656 -- exit; 10657 -- end if; 10658 -- end loop; 10659 -- 10660 -- if no rendez_vous then 10661 -- raise program_error; 10662 -- end if; 10663 10664 -- Note that the code needs to know that the selector name 10665 -- in an Accept_Alternative is named S. 10666 10667 Cond := Make_Op_Ne (Loc, 10668 Left_Opnd => 10669 Make_Selected_Component (Loc, 10670 Prefix => 10671 Make_Indexed_Component (Loc, 10672 Prefix => New_Occurrence_Of (Qnam, Loc), 10673 Expressions => New_List (New_Occurrence_Of (J, Loc))), 10674 Selector_Name => Make_Identifier (Loc, Name_S)), 10675 Right_Opnd => 10676 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Loc)); 10677 10678 Stats := New_List ( 10679 Make_Implicit_Loop_Statement (N, 10680 Iteration_Scheme => 10681 Make_Iteration_Scheme (Loc, 10682 Loop_Parameter_Specification => 10683 Make_Loop_Parameter_Specification (Loc, 10684 Defining_Identifier => J, 10685 Discrete_Subtype_Definition => 10686 Make_Attribute_Reference (Loc, 10687 Prefix => New_Occurrence_Of (Qnam, Loc), 10688 Attribute_Name => Name_Range, 10689 Expressions => New_List ( 10690 Make_Integer_Literal (Loc, 1))))), 10691 10692 Statements => New_List ( 10693 Make_Implicit_If_Statement (N, 10694 Condition => Cond, 10695 Then_Statements => New_List ( 10696 Make_Select_Call ( 10697 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc)), 10698 Make_Exit_Statement (Loc)))))); 10699 10700 Append_To (Stats, 10701 Make_Raise_Program_Error (Loc, 10702 Condition => Make_Op_Eq (Loc, 10703 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 10704 Right_Opnd => 10705 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 10706 Reason => PE_All_Guards_Closed)); 10707 10708 return Stats; 10709 end Accept_Or_Raise; 10710 10711 ---------------- 10712 -- Add_Accept -- 10713 ---------------- 10714 10715 procedure Add_Accept (Alt : Node_Id) is 10716 Acc_Stm : constant Node_Id := Accept_Statement (Alt); 10717 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm); 10718 Eloc : constant Source_Ptr := Sloc (Ename); 10719 Eent : constant Entity_Id := Entity (Ename); 10720 Index : constant Node_Id := Entry_Index (Acc_Stm); 10721 Null_Body : Node_Id; 10722 Proc_Body : Node_Id; 10723 PB_Ent : Entity_Id; 10724 Expr : Node_Id; 10725 Call : Node_Id; 10726 10727 begin 10728 if No (Ann) then 10729 Ann := Node (Last_Elmt (Accept_Address (Eent))); 10730 end if; 10731 10732 if Present (Condition (Alt)) then 10733 Expr := 10734 Make_If_Expression (Eloc, New_List ( 10735 Condition (Alt), 10736 Entry_Index_Expression (Eloc, Eent, Index, Scope (Eent)), 10737 New_Occurrence_Of (RTE (RE_Null_Task_Entry), Eloc))); 10738 else 10739 Expr := 10740 Entry_Index_Expression 10741 (Eloc, Eent, Index, Scope (Eent)); 10742 end if; 10743 10744 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then 10745 Null_Body := New_Occurrence_Of (Standard_False, Eloc); 10746 10747 -- Always add call to Abort_Undefer when generating code, since 10748 -- this is what the runtime expects (abort deferred in 10749 -- Selective_Wait). In CodePeer mode this only confuses the 10750 -- analysis with unknown calls, so don't do it. 10751 10752 if not CodePeer_Mode then 10753 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 10754 Insert_Before 10755 (First (Statements (Handled_Statement_Sequence 10756 (Accept_Statement (Alt)))), 10757 Call); 10758 Analyze (Call); 10759 end if; 10760 10761 PB_Ent := 10762 Make_Defining_Identifier (Eloc, 10763 New_External_Name (Chars (Ename), 'A', Num_Accept)); 10764 10765 if Comes_From_Source (Alt) then 10766 Set_Debug_Info_Needed (PB_Ent); 10767 end if; 10768 10769 Proc_Body := 10770 Make_Subprogram_Body (Eloc, 10771 Specification => 10772 Make_Procedure_Specification (Eloc, 10773 Defining_Unit_Name => PB_Ent), 10774 Declarations => Declarations (Acc_Stm), 10775 Handled_Statement_Sequence => 10776 Build_Accept_Body (Accept_Statement (Alt))); 10777 10778 -- During the analysis of the body of the accept statement, any 10779 -- zero cost exception handler records were collected in the 10780 -- Accept_Handler_Records field of the N_Accept_Alternative node. 10781 -- This is where we move them to where they belong, namely the 10782 -- newly created procedure. 10783 10784 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); 10785 Append (Proc_Body, Body_List); 10786 10787 else 10788 Null_Body := New_Occurrence_Of (Standard_True, Eloc); 10789 10790 -- if accept statement has declarations, insert above, given that 10791 -- we are not creating a body for the accept. 10792 10793 if Present (Declarations (Acc_Stm)) then 10794 Insert_Actions (N, Declarations (Acc_Stm)); 10795 end if; 10796 end if; 10797 10798 Append_To (Accept_List, 10799 Make_Aggregate (Eloc, Expressions => New_List (Null_Body, Expr))); 10800 10801 Num_Accept := Num_Accept + 1; 10802 end Add_Accept; 10803 10804 ---------------------------- 10805 -- Make_And_Declare_Label -- 10806 ---------------------------- 10807 10808 function Make_And_Declare_Label (Num : Int) return Node_Id is 10809 Lab_Id : Node_Id; 10810 10811 begin 10812 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num)); 10813 Lab := 10814 Make_Label (Loc, Lab_Id); 10815 10816 Append_To (Decls, 10817 Make_Implicit_Label_Declaration (Loc, 10818 Defining_Identifier => 10819 Make_Defining_Identifier (Loc, Chars (Lab_Id)), 10820 Label_Construct => Lab)); 10821 10822 return Lab; 10823 end Make_And_Declare_Label; 10824 10825 ---------------------- 10826 -- Make_Select_Call -- 10827 ---------------------- 10828 10829 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is 10830 Params : constant List_Id := New_List; 10831 10832 begin 10833 Append_To (Params, 10834 Make_Attribute_Reference (Loc, 10835 Prefix => New_Occurrence_Of (Qnam, Loc), 10836 Attribute_Name => Name_Unchecked_Access)); 10837 Append_To (Params, Select_Mode); 10838 Append_To (Params, New_Occurrence_Of (Ann, Loc)); 10839 Append_To (Params, New_Occurrence_Of (Xnam, Loc)); 10840 10841 return 10842 Make_Procedure_Call_Statement (Loc, 10843 Name => New_Occurrence_Of (RTE (RE_Selective_Wait), Loc), 10844 Parameter_Associations => Params); 10845 end Make_Select_Call; 10846 10847 -------------------------------- 10848 -- Process_Accept_Alternative -- 10849 -------------------------------- 10850 10851 procedure Process_Accept_Alternative 10852 (Alt : Node_Id; 10853 Index : Int; 10854 Proc : Node_Id) 10855 is 10856 Astmt : constant Node_Id := Accept_Statement (Alt); 10857 Alt_Stats : List_Id; 10858 10859 begin 10860 Adjust_Condition (Condition (Alt)); 10861 10862 -- Accept with body 10863 10864 if Present (Handled_Statement_Sequence (Astmt)) then 10865 Alt_Stats := 10866 New_List ( 10867 Make_Procedure_Call_Statement (Sloc (Proc), 10868 Name => 10869 New_Occurrence_Of 10870 (Defining_Unit_Name (Specification (Proc)), 10871 Sloc (Proc)))); 10872 10873 -- Accept with no body (followed by trailing statements) 10874 10875 else 10876 Alt_Stats := Empty_List; 10877 end if; 10878 10879 Ensure_Statement_Present (Sloc (Astmt), Alt); 10880 10881 -- After the call, if any, branch to trailing statements, if any. 10882 -- We create a label for each, as well as the corresponding label 10883 -- declaration. 10884 10885 if not Is_Empty_List (Statements (Alt)) then 10886 Lab := Make_And_Declare_Label (Index); 10887 Append (Lab, Trailing_List); 10888 Append_List (Statements (Alt), Trailing_List); 10889 Append_To (Trailing_List, 10890 Make_Goto_Statement (Loc, 10891 Name => New_Copy (Identifier (End_Lab)))); 10892 10893 else 10894 Lab := End_Lab; 10895 end if; 10896 10897 Append_To (Alt_Stats, 10898 Make_Goto_Statement (Loc, Name => New_Copy (Identifier (Lab)))); 10899 10900 Append_To (Alt_List, 10901 Make_Case_Statement_Alternative (Loc, 10902 Discrete_Choices => New_List (Make_Integer_Literal (Loc, Index)), 10903 Statements => Alt_Stats)); 10904 end Process_Accept_Alternative; 10905 10906 ------------------------------- 10907 -- Process_Delay_Alternative -- 10908 ------------------------------- 10909 10910 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is 10911 Dloc : constant Source_Ptr := Sloc (Delay_Statement (Alt)); 10912 Cond : Node_Id; 10913 Delay_Alt : List_Id; 10914 10915 begin 10916 -- Deal with C/Fortran boolean as delay condition 10917 10918 Adjust_Condition (Condition (Alt)); 10919 10920 -- Determine the smallest specified delay 10921 10922 -- for each delay alternative generate: 10923 10924 -- if guard-expression then 10925 -- Delay_Val := delay-expression; 10926 -- Guard_Open := True; 10927 -- if Delay_Val < Delay_Min then 10928 -- Delay_Min := Delay_Val; 10929 -- Delay_Index := Index; 10930 -- end if; 10931 -- end if; 10932 10933 -- The enclosing if-statement is omitted if there is no guard 10934 10935 if Delay_Count = 1 or else First_Delay then 10936 First_Delay := False; 10937 10938 Delay_Alt := New_List ( 10939 Make_Assignment_Statement (Loc, 10940 Name => New_Occurrence_Of (Delay_Min, Loc), 10941 Expression => Expression (Delay_Statement (Alt)))); 10942 10943 if Delay_Count > 1 then 10944 Append_To (Delay_Alt, 10945 Make_Assignment_Statement (Loc, 10946 Name => New_Occurrence_Of (Delay_Index, Loc), 10947 Expression => Make_Integer_Literal (Loc, Index))); 10948 end if; 10949 10950 else 10951 Delay_Alt := New_List ( 10952 Make_Assignment_Statement (Loc, 10953 Name => New_Occurrence_Of (Delay_Val, Loc), 10954 Expression => Expression (Delay_Statement (Alt)))); 10955 10956 if Time_Type = Standard_Duration then 10957 Cond := 10958 Make_Op_Lt (Loc, 10959 Left_Opnd => New_Occurrence_Of (Delay_Val, Loc), 10960 Right_Opnd => New_Occurrence_Of (Delay_Min, Loc)); 10961 10962 else 10963 -- The scope of the time type must define a comparison 10964 -- operator. The scope itself may not be visible, so we 10965 -- construct a node with entity information to insure that 10966 -- semantic analysis can find the proper operator. 10967 10968 Cond := 10969 Make_Function_Call (Loc, 10970 Name => Make_Selected_Component (Loc, 10971 Prefix => 10972 New_Occurrence_Of (Scope (Time_Type), Loc), 10973 Selector_Name => 10974 Make_Operator_Symbol (Loc, 10975 Chars => Name_Op_Lt, 10976 Strval => No_String)), 10977 Parameter_Associations => 10978 New_List ( 10979 New_Occurrence_Of (Delay_Val, Loc), 10980 New_Occurrence_Of (Delay_Min, Loc))); 10981 10982 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type)); 10983 end if; 10984 10985 Append_To (Delay_Alt, 10986 Make_Implicit_If_Statement (N, 10987 Condition => Cond, 10988 Then_Statements => New_List ( 10989 Make_Assignment_Statement (Loc, 10990 Name => New_Occurrence_Of (Delay_Min, Loc), 10991 Expression => New_Occurrence_Of (Delay_Val, Loc)), 10992 10993 Make_Assignment_Statement (Loc, 10994 Name => New_Occurrence_Of (Delay_Index, Loc), 10995 Expression => Make_Integer_Literal (Loc, Index))))); 10996 end if; 10997 10998 if Check_Guard then 10999 Append_To (Delay_Alt, 11000 Make_Assignment_Statement (Loc, 11001 Name => New_Occurrence_Of (Guard_Open, Loc), 11002 Expression => New_Occurrence_Of (Standard_True, Loc))); 11003 end if; 11004 11005 if Present (Condition (Alt)) then 11006 Delay_Alt := New_List ( 11007 Make_Implicit_If_Statement (N, 11008 Condition => Condition (Alt), 11009 Then_Statements => Delay_Alt)); 11010 end if; 11011 11012 Append_List (Delay_Alt, Delay_List); 11013 11014 Ensure_Statement_Present (Dloc, Alt); 11015 11016 -- If the delay alternative has a statement part, add choice to the 11017 -- case statements for delays. 11018 11019 if not Is_Empty_List (Statements (Alt)) then 11020 11021 if Delay_Count = 1 then 11022 Append_List (Statements (Alt), Delay_Alt_List); 11023 11024 else 11025 Append_To (Delay_Alt_List, 11026 Make_Case_Statement_Alternative (Loc, 11027 Discrete_Choices => New_List ( 11028 Make_Integer_Literal (Loc, Index)), 11029 Statements => Statements (Alt))); 11030 end if; 11031 11032 elsif Delay_Count = 1 then 11033 11034 -- If the single delay has no trailing statements, add a branch 11035 -- to the exit label to the selective wait. 11036 11037 Delay_Alt_List := New_List ( 11038 Make_Goto_Statement (Loc, 11039 Name => New_Copy (Identifier (End_Lab)))); 11040 11041 end if; 11042 end Process_Delay_Alternative; 11043 11044 -- Start of processing for Expand_N_Selective_Accept 11045 11046 begin 11047 Process_Statements_For_Controlled_Objects (N); 11048 11049 -- First insert some declarations before the select. The first is: 11050 11051 -- Ann : Address 11052 11053 -- This variable holds the parameters passed to the accept body. This 11054 -- declaration has already been inserted by the time we get here by 11055 -- a call to Expand_Accept_Declarations made from the semantics when 11056 -- processing the first accept statement contained in the select. We 11057 -- can find this entity as Accept_Address (E), where E is any of the 11058 -- entries references by contained accept statements. 11059 11060 -- The first step is to scan the list of Selective_Accept_Statements 11061 -- to find this entity, and also count the number of accepts, and 11062 -- determine if terminated, delay or else is present: 11063 11064 Num_Alts := 0; 11065 11066 Alt := First (Alts); 11067 while Present (Alt) loop 11068 Process_Statements_For_Controlled_Objects (Alt); 11069 11070 if Nkind (Alt) = N_Accept_Alternative then 11071 Add_Accept (Alt); 11072 11073 elsif Nkind (Alt) = N_Delay_Alternative then 11074 Delay_Count := Delay_Count + 1; 11075 11076 -- If the delays are relative delays, the delay expressions have 11077 -- type Standard_Duration. Otherwise they must have some time type 11078 -- recognized by GNAT. 11079 11080 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then 11081 Time_Type := Standard_Duration; 11082 else 11083 Time_Type := Etype (Expression (Delay_Statement (Alt))); 11084 11085 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) 11086 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time) 11087 then 11088 null; 11089 else 11090 Error_Msg_NE ( 11091 "& is not a time type (RM 9.6(6))", 11092 Expression (Delay_Statement (Alt)), Time_Type); 11093 Time_Type := Standard_Duration; 11094 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type); 11095 end if; 11096 end if; 11097 11098 if No (Condition (Alt)) then 11099 11100 -- This guard will always be open 11101 11102 Check_Guard := False; 11103 end if; 11104 11105 elsif Nkind (Alt) = N_Terminate_Alternative then 11106 Adjust_Condition (Condition (Alt)); 11107 Terminate_Alt := Alt; 11108 end if; 11109 11110 Num_Alts := Num_Alts + 1; 11111 Next (Alt); 11112 end loop; 11113 11114 Else_Present := Present (Else_Statements (N)); 11115 11116 -- At the same time (see procedure Add_Accept) we build the accept list: 11117 11118 -- Qnn : Accept_List (1 .. num-select) := ( 11119 -- (null-body, entry-index), 11120 -- (null-body, entry-index), 11121 -- .. 11122 -- (null_body, entry-index)); 11123 11124 -- In the above declaration, null-body is True if the corresponding 11125 -- accept has no body, and false otherwise. The entry is either the 11126 -- entry index expression if there is no guard, or if a guard is 11127 -- present, then an if expression of the form: 11128 11129 -- (if guard then entry-index else Null_Task_Entry) 11130 11131 -- If a guard is statically known to be false, the entry can simply 11132 -- be omitted from the accept list. 11133 11134 Append_To (Decls, 11135 Make_Object_Declaration (Loc, 11136 Defining_Identifier => Qnam, 11137 Object_Definition => New_Occurrence_Of (RTE (RE_Accept_List), Loc), 11138 Aliased_Present => True, 11139 Expression => 11140 Make_Qualified_Expression (Loc, 11141 Subtype_Mark => 11142 New_Occurrence_Of (RTE (RE_Accept_List), Loc), 11143 Expression => 11144 Make_Aggregate (Loc, Expressions => Accept_List)))); 11145 11146 -- Then we declare the variable that holds the index for the accept 11147 -- that will be selected for service: 11148 11149 -- Xnn : Select_Index; 11150 11151 Append_To (Decls, 11152 Make_Object_Declaration (Loc, 11153 Defining_Identifier => Xnam, 11154 Object_Definition => 11155 New_Occurrence_Of (RTE (RE_Select_Index), Loc), 11156 Expression => 11157 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc))); 11158 11159 -- After this follow procedure declarations for each accept body 11160 11161 -- procedure Pnn is 11162 -- begin 11163 -- ... 11164 -- end; 11165 11166 -- where the ... are statements from the corresponding procedure body. 11167 -- No parameters are involved, since the parameters are passed via Ann 11168 -- and the parameter references have already been expanded to be direct 11169 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore, 11170 -- any embedded tasking statements (which would normally be illegal in 11171 -- procedures), have been converted to calls to the tasking runtime so 11172 -- there is no problem in putting them into procedures. 11173 11174 -- The original accept statement has been expanded into a block in 11175 -- the same fashion as for simple accepts (see Build_Accept_Body). 11176 11177 -- Note: we don't really need to build these procedures for the case 11178 -- where no delay statement is present, but it is just as easy to 11179 -- build them unconditionally, and not significantly inefficient, 11180 -- since if they are short they will be inlined anyway. 11181 11182 -- The procedure declarations have been assembled in Body_List 11183 11184 -- If delays are present, we must compute the required delay. 11185 -- We first generate the declarations: 11186 11187 -- Delay_Index : Boolean := 0; 11188 -- Delay_Min : Some_Time_Type.Time; 11189 -- Delay_Val : Some_Time_Type.Time; 11190 11191 -- Delay_Index will be set to the index of the minimum delay, i.e. the 11192 -- active delay that is actually chosen as the basis for the possible 11193 -- delay if an immediate rendez-vous is not possible. 11194 11195 -- In the most common case there is a single delay statement, and this 11196 -- is handled specially. 11197 11198 if Delay_Count > 0 then 11199 11200 -- Generate the required declarations 11201 11202 Delay_Val := 11203 Make_Defining_Identifier (Loc, New_External_Name ('D', 1)); 11204 Delay_Index := 11205 Make_Defining_Identifier (Loc, New_External_Name ('D', 2)); 11206 Delay_Min := 11207 Make_Defining_Identifier (Loc, New_External_Name ('D', 3)); 11208 11209 Append_To (Decls, 11210 Make_Object_Declaration (Loc, 11211 Defining_Identifier => Delay_Val, 11212 Object_Definition => New_Occurrence_Of (Time_Type, Loc))); 11213 11214 Append_To (Decls, 11215 Make_Object_Declaration (Loc, 11216 Defining_Identifier => Delay_Index, 11217 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 11218 Expression => Make_Integer_Literal (Loc, 0))); 11219 11220 Append_To (Decls, 11221 Make_Object_Declaration (Loc, 11222 Defining_Identifier => Delay_Min, 11223 Object_Definition => New_Occurrence_Of (Time_Type, Loc), 11224 Expression => 11225 Unchecked_Convert_To (Time_Type, 11226 Make_Attribute_Reference (Loc, 11227 Prefix => 11228 New_Occurrence_Of (Underlying_Type (Time_Type), Loc), 11229 Attribute_Name => Name_Last)))); 11230 11231 -- Create Duration and Delay_Mode objects used for passing a delay 11232 -- value to RTS 11233 11234 D := Make_Temporary (Loc, 'D'); 11235 M := Make_Temporary (Loc, 'M'); 11236 11237 declare 11238 Discr : Entity_Id; 11239 11240 begin 11241 -- Note that these values are defined in s-osprim.ads and must 11242 -- be kept in sync: 11243 -- 11244 -- Relative : constant := 0; 11245 -- Absolute_Calendar : constant := 1; 11246 -- Absolute_RT : constant := 2; 11247 11248 if Time_Type = Standard_Duration then 11249 Discr := Make_Integer_Literal (Loc, 0); 11250 11251 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11252 Discr := Make_Integer_Literal (Loc, 1); 11253 11254 else 11255 pragma Assert 11256 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11257 Discr := Make_Integer_Literal (Loc, 2); 11258 end if; 11259 11260 Append_To (Decls, 11261 Make_Object_Declaration (Loc, 11262 Defining_Identifier => D, 11263 Object_Definition => 11264 New_Occurrence_Of (Standard_Duration, Loc))); 11265 11266 Append_To (Decls, 11267 Make_Object_Declaration (Loc, 11268 Defining_Identifier => M, 11269 Object_Definition => 11270 New_Occurrence_Of (Standard_Integer, Loc), 11271 Expression => Discr)); 11272 end; 11273 11274 if Check_Guard then 11275 Guard_Open := 11276 Make_Defining_Identifier (Loc, New_External_Name ('G', 1)); 11277 11278 Append_To (Decls, 11279 Make_Object_Declaration (Loc, 11280 Defining_Identifier => Guard_Open, 11281 Object_Definition => 11282 New_Occurrence_Of (Standard_Boolean, Loc), 11283 Expression => 11284 New_Occurrence_Of (Standard_False, Loc))); 11285 end if; 11286 11287 -- Delay_Count is zero, don't need M and D set (suppress warning) 11288 11289 else 11290 M := Empty; 11291 D := Empty; 11292 end if; 11293 11294 if Present (Terminate_Alt) then 11295 11296 -- If the terminate alternative guard is False, use 11297 -- Simple_Mode; otherwise use Terminate_Mode. 11298 11299 if Present (Condition (Terminate_Alt)) then 11300 Select_Mode := Make_If_Expression (Loc, 11301 New_List (Condition (Terminate_Alt), 11302 New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc), 11303 New_Occurrence_Of (RTE (RE_Simple_Mode), Loc))); 11304 else 11305 Select_Mode := New_Occurrence_Of (RTE (RE_Terminate_Mode), Loc); 11306 end if; 11307 11308 elsif Else_Present or Delay_Count > 0 then 11309 Select_Mode := New_Occurrence_Of (RTE (RE_Else_Mode), Loc); 11310 11311 else 11312 Select_Mode := New_Occurrence_Of (RTE (RE_Simple_Mode), Loc); 11313 end if; 11314 11315 Select_Call := Make_Select_Call (Select_Mode); 11316 Append (Select_Call, Stats); 11317 11318 -- Now generate code to act on the result. There is an entry 11319 -- in this case for each accept statement with a non-null body, 11320 -- followed by a branch to the statements that follow the Accept. 11321 -- In the absence of delay alternatives, we generate: 11322 11323 -- case X is 11324 -- when No_Rendezvous => -- omitted if simple mode 11325 -- goto Lab0; 11326 11327 -- when 1 => 11328 -- P1n; 11329 -- goto Lab1; 11330 11331 -- when 2 => 11332 -- P2n; 11333 -- goto Lab2; 11334 11335 -- when others => 11336 -- goto Exit; 11337 -- end case; 11338 -- 11339 -- Lab0: Else_Statements; 11340 -- goto exit; 11341 11342 -- Lab1: Trailing_Statements1; 11343 -- goto Exit; 11344 -- 11345 -- Lab2: Trailing_Statements2; 11346 -- goto Exit; 11347 -- ... 11348 -- Exit: 11349 11350 -- Generate label for common exit 11351 11352 End_Lab := Make_And_Declare_Label (Num_Alts + 1); 11353 11354 -- First entry is the default case, when no rendezvous is possible 11355 11356 Choices := New_List (New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)); 11357 11358 if Else_Present then 11359 11360 -- If no rendezvous is possible, the else part is executed 11361 11362 Lab := Make_And_Declare_Label (0); 11363 Alt_Stats := New_List ( 11364 Make_Goto_Statement (Loc, 11365 Name => New_Copy (Identifier (Lab)))); 11366 11367 Append (Lab, Trailing_List); 11368 Append_List (Else_Statements (N), Trailing_List); 11369 Append_To (Trailing_List, 11370 Make_Goto_Statement (Loc, 11371 Name => New_Copy (Identifier (End_Lab)))); 11372 else 11373 Alt_Stats := New_List ( 11374 Make_Goto_Statement (Loc, 11375 Name => New_Copy (Identifier (End_Lab)))); 11376 end if; 11377 11378 Append_To (Alt_List, 11379 Make_Case_Statement_Alternative (Loc, 11380 Discrete_Choices => Choices, 11381 Statements => Alt_Stats)); 11382 11383 -- We make use of the fact that Accept_Index is an integer type, and 11384 -- generate successive literals for entries for each accept. Only those 11385 -- for which there is a body or trailing statements get a case entry. 11386 11387 Alt := First (Select_Alternatives (N)); 11388 Proc := First (Body_List); 11389 while Present (Alt) loop 11390 11391 if Nkind (Alt) = N_Accept_Alternative then 11392 Process_Accept_Alternative (Alt, Index, Proc); 11393 Index := Index + 1; 11394 11395 if Present 11396 (Handled_Statement_Sequence (Accept_Statement (Alt))) 11397 then 11398 Next (Proc); 11399 end if; 11400 11401 elsif Nkind (Alt) = N_Delay_Alternative then 11402 Process_Delay_Alternative (Alt, Delay_Num); 11403 Delay_Num := Delay_Num + 1; 11404 end if; 11405 11406 Next (Alt); 11407 end loop; 11408 11409 -- An others choice is always added to the main case, as well 11410 -- as the delay case (to satisfy the compiler). 11411 11412 Append_To (Alt_List, 11413 Make_Case_Statement_Alternative (Loc, 11414 Discrete_Choices => 11415 New_List (Make_Others_Choice (Loc)), 11416 Statements => 11417 New_List (Make_Goto_Statement (Loc, 11418 Name => New_Copy (Identifier (End_Lab)))))); 11419 11420 Accept_Case := New_List ( 11421 Make_Case_Statement (Loc, 11422 Expression => New_Occurrence_Of (Xnam, Loc), 11423 Alternatives => Alt_List)); 11424 11425 Append_List (Trailing_List, Accept_Case); 11426 Append_List (Body_List, Decls); 11427 11428 -- Construct case statement for trailing statements of delay 11429 -- alternatives, if there are several of them. 11430 11431 if Delay_Count > 1 then 11432 Append_To (Delay_Alt_List, 11433 Make_Case_Statement_Alternative (Loc, 11434 Discrete_Choices => 11435 New_List (Make_Others_Choice (Loc)), 11436 Statements => 11437 New_List (Make_Null_Statement (Loc)))); 11438 11439 Delay_Case := New_List ( 11440 Make_Case_Statement (Loc, 11441 Expression => New_Occurrence_Of (Delay_Index, Loc), 11442 Alternatives => Delay_Alt_List)); 11443 else 11444 Delay_Case := Delay_Alt_List; 11445 end if; 11446 11447 -- If there are no delay alternatives, we append the case statement 11448 -- to the statement list. 11449 11450 if Delay_Count = 0 then 11451 Append_List (Accept_Case, Stats); 11452 11453 -- Delay alternatives present 11454 11455 else 11456 -- If delay alternatives are present we generate: 11457 11458 -- find minimum delay. 11459 -- DX := minimum delay; 11460 -- M := <delay mode>; 11461 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P, 11462 -- DX, MX, X); 11463 -- 11464 -- if X = No_Rendezvous then 11465 -- case statement for delay statements. 11466 -- else 11467 -- case statement for accept alternatives. 11468 -- end if; 11469 11470 declare 11471 Cases : Node_Id; 11472 Stmt : Node_Id; 11473 Parms : List_Id; 11474 Parm : Node_Id; 11475 Conv : Node_Id; 11476 11477 begin 11478 -- The type of the delay expression is known to be legal 11479 11480 if Time_Type = Standard_Duration then 11481 Conv := New_Occurrence_Of (Delay_Min, Loc); 11482 11483 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 11484 Conv := Make_Function_Call (Loc, 11485 New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 11486 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11487 11488 else 11489 pragma Assert 11490 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 11491 11492 Conv := Make_Function_Call (Loc, 11493 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 11494 New_List (New_Occurrence_Of (Delay_Min, Loc))); 11495 end if; 11496 11497 Stmt := Make_Assignment_Statement (Loc, 11498 Name => New_Occurrence_Of (D, Loc), 11499 Expression => Conv); 11500 11501 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode) 11502 11503 Parms := Parameter_Associations (Select_Call); 11504 11505 Parm := First (Parms); 11506 while Present (Parm) and then Parm /= Select_Mode loop 11507 Next (Parm); 11508 end loop; 11509 11510 pragma Assert (Present (Parm)); 11511 Rewrite (Parm, New_Occurrence_Of (RTE (RE_Delay_Mode), Loc)); 11512 Analyze (Parm); 11513 11514 -- Prepare two new parameters of Duration and Delay_Mode type 11515 -- which represent the value and the mode of the minimum delay. 11516 11517 Next (Parm); 11518 Insert_After (Parm, New_Occurrence_Of (M, Loc)); 11519 Insert_After (Parm, New_Occurrence_Of (D, Loc)); 11520 11521 -- Create a call to RTS 11522 11523 Rewrite (Select_Call, 11524 Make_Procedure_Call_Statement (Loc, 11525 Name => New_Occurrence_Of (RTE (RE_Timed_Selective_Wait), Loc), 11526 Parameter_Associations => Parms)); 11527 11528 -- This new call should follow the calculation of the minimum 11529 -- delay. 11530 11531 Insert_List_Before (Select_Call, Delay_List); 11532 11533 if Check_Guard then 11534 Stmt := 11535 Make_Implicit_If_Statement (N, 11536 Condition => New_Occurrence_Of (Guard_Open, Loc), 11537 Then_Statements => New_List ( 11538 New_Copy_Tree (Stmt), 11539 New_Copy_Tree (Select_Call)), 11540 Else_Statements => Accept_Or_Raise); 11541 Rewrite (Select_Call, Stmt); 11542 else 11543 Insert_Before (Select_Call, Stmt); 11544 end if; 11545 11546 Cases := 11547 Make_Implicit_If_Statement (N, 11548 Condition => Make_Op_Eq (Loc, 11549 Left_Opnd => New_Occurrence_Of (Xnam, Loc), 11550 Right_Opnd => 11551 New_Occurrence_Of (RTE (RE_No_Rendezvous), Loc)), 11552 11553 Then_Statements => Delay_Case, 11554 Else_Statements => Accept_Case); 11555 11556 Append (Cases, Stats); 11557 end; 11558 end if; 11559 11560 Append (End_Lab, Stats); 11561 11562 -- Replace accept statement with appropriate block 11563 11564 Rewrite (N, 11565 Make_Block_Statement (Loc, 11566 Declarations => Decls, 11567 Handled_Statement_Sequence => 11568 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats))); 11569 Analyze (N); 11570 11571 -- Note: have to worry more about abort deferral in above code ??? 11572 11573 -- Final step is to unstack the Accept_Address entries for all accept 11574 -- statements appearing in accept alternatives in the select statement 11575 11576 Alt := First (Alts); 11577 while Present (Alt) loop 11578 if Nkind (Alt) = N_Accept_Alternative then 11579 Remove_Last_Elmt (Accept_Address 11580 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))); 11581 end if; 11582 11583 Next (Alt); 11584 end loop; 11585 end Expand_N_Selective_Accept; 11586 11587 ------------------------------------------- 11588 -- Expand_N_Single_Protected_Declaration -- 11589 ------------------------------------------- 11590 11591 -- A single protected declaration should never be present after semantic 11592 -- analysis because it is transformed into a protected type declaration 11593 -- and an accompanying anonymous object. This routine ensures that the 11594 -- transformation takes place. 11595 11596 procedure Expand_N_Single_Protected_Declaration (N : Node_Id) is 11597 begin 11598 raise Program_Error; 11599 end Expand_N_Single_Protected_Declaration; 11600 11601 -------------------------------------- 11602 -- Expand_N_Single_Task_Declaration -- 11603 -------------------------------------- 11604 11605 -- A single task declaration should never be present after semantic 11606 -- analysis because it is transformed into a task type declaration and 11607 -- an accompanying anonymous object. This routine ensures that the 11608 -- transformation takes place. 11609 11610 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is 11611 begin 11612 raise Program_Error; 11613 end Expand_N_Single_Task_Declaration; 11614 11615 ------------------------ 11616 -- Expand_N_Task_Body -- 11617 ------------------------ 11618 11619 -- Given a task body 11620 11621 -- task body tname is 11622 -- <declarations> 11623 -- begin 11624 -- <statements> 11625 -- end x; 11626 11627 -- This expansion routine converts it into a procedure and sets the 11628 -- elaboration flag for the procedure to true, to represent the fact 11629 -- that the task body is now elaborated: 11630 11631 -- procedure tnameB (_Task : access tnameV) is 11632 -- discriminal : dtype renames _Task.discriminant; 11633 11634 -- procedure _clean is 11635 -- begin 11636 -- Abort_Defer.all; 11637 -- Complete_Task; 11638 -- Abort_Undefer.all; 11639 -- return; 11640 -- end _clean; 11641 11642 -- begin 11643 -- Abort_Undefer.all; 11644 -- <declarations> 11645 -- System.Task_Stages.Complete_Activation; 11646 -- <statements> 11647 -- at end 11648 -- _clean; 11649 -- end tnameB; 11650 11651 -- tnameE := True; 11652 11653 -- In addition, if the task body is an activator, then a call to activate 11654 -- tasks is added at the start of the statements, before the call to 11655 -- Complete_Activation, and if in addition the task is a master then it 11656 -- must be established as a master. These calls are inserted and analyzed 11657 -- in Expand_Cleanup_Actions, when the Handled_Sequence_Of_Statements is 11658 -- expanded. 11659 11660 -- There is one discriminal declaration line generated for each 11661 -- discriminant that is present to provide an easy reference point for 11662 -- discriminant references inside the body (see Exp_Ch2.Expand_Name). 11663 11664 -- Note on relationship to GNARLI definition. In the GNARLI definition, 11665 -- task body procedures have a profile (Arg : System.Address). That is 11666 -- needed because GNARLI has to use the same access-to-subprogram type 11667 -- for all task types. We depend here on knowing that in GNAT, passing 11668 -- an address argument by value is identical to passing a record value 11669 -- by access (in either case a single pointer is passed), so even though 11670 -- this procedure has the wrong profile. In fact it's all OK, since the 11671 -- callings sequence is identical. 11672 11673 procedure Expand_N_Task_Body (N : Node_Id) is 11674 Loc : constant Source_Ptr := Sloc (N); 11675 Ttyp : constant Entity_Id := Corresponding_Spec (N); 11676 Call : Node_Id; 11677 New_N : Node_Id; 11678 11679 Insert_Nod : Node_Id; 11680 -- Used to determine the proper location of wrapper body insertions 11681 11682 begin 11683 -- if no task body procedure, means we had an error in configurable 11684 -- run-time mode, and there is no point in proceeding further. 11685 11686 if No (Task_Body_Procedure (Ttyp)) then 11687 return; 11688 end if; 11689 11690 -- Add renaming declarations for discriminals and a declaration for the 11691 -- entry family index (if applicable). 11692 11693 Install_Private_Data_Declarations 11694 (Loc, Task_Body_Procedure (Ttyp), Ttyp, N, Declarations (N)); 11695 11696 -- Add a call to Abort_Undefer at the very beginning of the task 11697 -- body since this body is called with abort still deferred. 11698 11699 if Abort_Allowed then 11700 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 11701 Insert_Before 11702 (First (Statements (Handled_Statement_Sequence (N))), Call); 11703 Analyze (Call); 11704 end if; 11705 11706 -- The statement part has already been protected with an at_end and 11707 -- cleanup actions. The call to Complete_Activation must be placed 11708 -- at the head of the sequence of statements of that block. The 11709 -- declarations have been merged in this sequence of statements but 11710 -- the first real statement is accessible from the First_Real_Statement 11711 -- field (which was set for exactly this purpose). 11712 11713 if Restricted_Profile then 11714 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation); 11715 else 11716 Call := Build_Runtime_Call (Loc, RE_Complete_Activation); 11717 end if; 11718 11719 Insert_Before 11720 (First_Real_Statement (Handled_Statement_Sequence (N)), Call); 11721 Analyze (Call); 11722 11723 New_N := 11724 Make_Subprogram_Body (Loc, 11725 Specification => Build_Task_Proc_Specification (Ttyp), 11726 Declarations => Declarations (N), 11727 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 11728 Set_Is_Task_Body_Procedure (New_N); 11729 11730 -- If the task contains generic instantiations, cleanup actions are 11731 -- delayed until after instantiation. Transfer the activation chain to 11732 -- the subprogram, to insure that the activation call is properly 11733 -- generated. It the task body contains inner tasks, indicate that the 11734 -- subprogram is a task master. 11735 11736 if Delay_Cleanups (Ttyp) then 11737 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); 11738 Set_Is_Task_Master (New_N, Is_Task_Master (N)); 11739 end if; 11740 11741 Rewrite (N, New_N); 11742 Analyze (N); 11743 11744 -- Set elaboration flag immediately after task body. If the body is a 11745 -- subunit, the flag is set in the declarative part containing the stub. 11746 11747 if Nkind (Parent (N)) /= N_Subunit then 11748 Insert_After (N, 11749 Make_Assignment_Statement (Loc, 11750 Name => 11751 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')), 11752 Expression => New_Occurrence_Of (Standard_True, Loc))); 11753 end if; 11754 11755 -- Ada 2005 (AI-345): Construct the primitive entry wrapper bodies after 11756 -- the task body. At this point all wrapper specs have been created, 11757 -- frozen and included in the dispatch table for the task type. 11758 11759 if Ada_Version >= Ada_2005 then 11760 if Nkind (Parent (N)) = N_Subunit then 11761 Insert_Nod := Corresponding_Stub (Parent (N)); 11762 else 11763 Insert_Nod := N; 11764 end if; 11765 11766 Build_Wrapper_Bodies (Loc, Ttyp, Insert_Nod); 11767 end if; 11768 end Expand_N_Task_Body; 11769 11770 ------------------------------------ 11771 -- Expand_N_Task_Type_Declaration -- 11772 ------------------------------------ 11773 11774 -- We have several things to do. First we must create a Boolean flag used 11775 -- to mark if the body is elaborated yet. This variable gets set to True 11776 -- when the body of the task is elaborated (we can't rely on the normal 11777 -- ABE mechanism for the task body, since we need to pass an access to 11778 -- this elaboration boolean to the runtime routines). 11779 11780 -- taskE : aliased Boolean := False; 11781 11782 -- Next a variable is declared to hold the task stack size (either the 11783 -- default : Unspecified_Size, or a value that is set by a pragma 11784 -- Storage_Size). If the value of the pragma Storage_Size is static, then 11785 -- the variable is initialized with this value: 11786 11787 -- taskZ : Size_Type := Unspecified_Size; 11788 -- or 11789 -- taskZ : Size_Type := Size_Type (size_expression); 11790 11791 -- Note: No variable is needed to hold the task relative deadline since 11792 -- its value would never be static because the parameter is of a private 11793 -- type (Ada.Real_Time.Time_Span). 11794 11795 -- Next we create a corresponding record type declaration used to represent 11796 -- values of this task. The general form of this type declaration is 11797 11798 -- type taskV (discriminants) is record 11799 -- _Task_Id : Task_Id; 11800 -- entry_family : array (bounds) of Void; 11801 -- _Priority : Integer := priority_expression; 11802 -- _Size : Size_Type := size_expression; 11803 -- _Task_Info : Task_Info_Type := task_info_expression; 11804 -- _CPU : Integer := cpu_range_expression; 11805 -- _Relative_Deadline : Time_Span := time_span_expression; 11806 -- _Domain : Dispatching_Domain := dd_expression; 11807 -- end record; 11808 11809 -- The discriminants are present only if the corresponding task type has 11810 -- discriminants, and they exactly mirror the task type discriminants. 11811 11812 -- The Id field is always present. It contains the Task_Id value, as set by 11813 -- the call to Create_Task. Note that although the task is limited, the 11814 -- task value record type is not limited, so there is no problem in passing 11815 -- this field as an out parameter to Create_Task. 11816 11817 -- One entry_family component is present for each entry family in the task 11818 -- definition. The bounds correspond to the bounds of the entry family 11819 -- (which may depend on discriminants). The element type is void, since we 11820 -- only need the bounds information for determining the entry index. Note 11821 -- that the use of an anonymous array would normally be illegal in this 11822 -- context, but this is a parser check, and the semantics is quite prepared 11823 -- to handle such a case. 11824 11825 -- The _Size field is present only if a Storage_Size pragma appears in the 11826 -- task definition. The expression captures the argument that was present 11827 -- in the pragma, and is used to override the task stack size otherwise 11828 -- associated with the task type. 11829 11830 -- The _Priority field is present only if the task entity has a Priority or 11831 -- Interrupt_Priority rep item (pragma, aspect specification or attribute 11832 -- definition clause). It will be filled at the freeze point, when the 11833 -- record init proc is built, to capture the expression of the rep item 11834 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11835 -- here since aspect evaluations are delayed till the freeze point. 11836 11837 -- The _Task_Info field is present only if a Task_Info pragma appears in 11838 -- the task definition. The expression captures the argument that was 11839 -- present in the pragma, and is used to provide the Task_Image parameter 11840 -- to the call to Create_Task. 11841 11842 -- The _CPU field is present only if the task entity has a CPU rep item 11843 -- (pragma, aspect specification or attribute definition clause). It will 11844 -- be filled at the freeze point, when the record init proc is built, to 11845 -- capture the expression of the rep item (see Build_Record_Init_Proc in 11846 -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations 11847 -- are delayed till the freeze point. 11848 11849 -- The _Relative_Deadline field is present only if a Relative_Deadline 11850 -- pragma appears in the task definition. The expression captures the 11851 -- argument that was present in the pragma, and is used to provide the 11852 -- Relative_Deadline parameter to the call to Create_Task. 11853 11854 -- The _Domain field is present only if the task entity has a 11855 -- Dispatching_Domain rep item (pragma, aspect specification or attribute 11856 -- definition clause). It will be filled at the freeze point, when the 11857 -- record init proc is built, to capture the expression of the rep item 11858 -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled 11859 -- here since aspect evaluations are delayed till the freeze point. 11860 11861 -- When a task is declared, an instance of the task value record is 11862 -- created. The elaboration of this declaration creates the correct bounds 11863 -- for the entry families, and also evaluates the size, priority, and 11864 -- task_Info expressions if needed. The initialization routine for the task 11865 -- type itself then calls Create_Task with appropriate parameters to 11866 -- initialize the value of the Task_Id field. 11867 11868 -- Note: the address of this record is passed as the "Discriminants" 11869 -- parameter for Create_Task. Since Create_Task merely passes this onto the 11870 -- body procedure, it does not matter that it does not quite match the 11871 -- GNARLI model of what is being passed (the record contains more than just 11872 -- the discriminants, but the discriminants can be found from the record 11873 -- value). 11874 11875 -- The Entity_Id for this created record type is placed in the 11876 -- Corresponding_Record_Type field of the associated task type entity. 11877 11878 -- Next we create a procedure specification for the task body procedure: 11879 11880 -- procedure taskB (_Task : access taskV); 11881 11882 -- Note that this must come after the record type declaration, since 11883 -- the spec refers to this type. It turns out that the initialization 11884 -- procedure for the value type references the task body spec, but that's 11885 -- fine, since it won't be generated till the freeze point for the type, 11886 -- which is certainly after the task body spec declaration. 11887 11888 -- Finally, we set the task index value field of the entry attribute in 11889 -- the case of a simple entry. 11890 11891 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is 11892 Loc : constant Source_Ptr := Sloc (N); 11893 TaskId : constant Entity_Id := Defining_Identifier (N); 11894 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); 11895 Tasknm : constant Name_Id := Chars (Tasktyp); 11896 Taskdef : constant Node_Id := Task_Definition (N); 11897 11898 Body_Decl : Node_Id; 11899 Cdecls : List_Id; 11900 Decl_Stack : Node_Id; 11901 Elab_Decl : Node_Id; 11902 Ent_Stack : Entity_Id; 11903 Proc_Spec : Node_Id; 11904 Rec_Decl : Node_Id; 11905 Rec_Ent : Entity_Id; 11906 Size_Decl : Entity_Id; 11907 Task_Size : Node_Id; 11908 11909 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id; 11910 -- Searches the task definition T for the first occurrence of the pragma 11911 -- Relative Deadline. The caller has ensured that the pragma is present 11912 -- in the task definition. Note that this routine cannot be implemented 11913 -- with the Rep Item chain mechanism since Relative_Deadline pragmas are 11914 -- not chained because their expansion into a procedure call statement 11915 -- would cause a break in the chain. 11916 11917 ---------------------------------- 11918 -- Get_Relative_Deadline_Pragma -- 11919 ---------------------------------- 11920 11921 function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is 11922 N : Node_Id; 11923 11924 begin 11925 N := First (Visible_Declarations (T)); 11926 while Present (N) loop 11927 if Nkind (N) = N_Pragma 11928 and then Pragma_Name (N) = Name_Relative_Deadline 11929 then 11930 return N; 11931 end if; 11932 11933 Next (N); 11934 end loop; 11935 11936 N := First (Private_Declarations (T)); 11937 while Present (N) loop 11938 if Nkind (N) = N_Pragma 11939 and then Pragma_Name (N) = Name_Relative_Deadline 11940 then 11941 return N; 11942 end if; 11943 11944 Next (N); 11945 end loop; 11946 11947 raise Program_Error; 11948 end Get_Relative_Deadline_Pragma; 11949 11950 -- Start of processing for Expand_N_Task_Type_Declaration 11951 11952 begin 11953 -- If already expanded, nothing to do 11954 11955 if Present (Corresponding_Record_Type (Tasktyp)) then 11956 return; 11957 end if; 11958 11959 -- Here we will do the expansion 11960 11961 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); 11962 11963 Rec_Ent := Defining_Identifier (Rec_Decl); 11964 Cdecls := Component_Items (Component_List 11965 (Type_Definition (Rec_Decl))); 11966 11967 Qualify_Entity_Names (N); 11968 11969 -- First create the elaboration variable 11970 11971 Elab_Decl := 11972 Make_Object_Declaration (Loc, 11973 Defining_Identifier => 11974 Make_Defining_Identifier (Sloc (Tasktyp), 11975 Chars => New_External_Name (Tasknm, 'E')), 11976 Aliased_Present => True, 11977 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 11978 Expression => New_Occurrence_Of (Standard_False, Loc)); 11979 11980 Insert_After (N, Elab_Decl); 11981 11982 -- Next create the declaration of the size variable (tasknmZ) 11983 11984 Set_Storage_Size_Variable (Tasktyp, 11985 Make_Defining_Identifier (Sloc (Tasktyp), 11986 Chars => New_External_Name (Tasknm, 'Z'))); 11987 11988 if Present (Taskdef) 11989 and then Has_Storage_Size_Pragma (Taskdef) 11990 and then 11991 Is_OK_Static_Expression 11992 (Expression 11993 (First (Pragma_Argument_Associations 11994 (Get_Rep_Pragma (TaskId, Name_Storage_Size))))) 11995 then 11996 Size_Decl := 11997 Make_Object_Declaration (Loc, 11998 Defining_Identifier => Storage_Size_Variable (Tasktyp), 11999 Object_Definition => 12000 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 12001 Expression => 12002 Convert_To (RTE (RE_Size_Type), 12003 Relocate_Node 12004 (Expression (First (Pragma_Argument_Associations 12005 (Get_Rep_Pragma 12006 (TaskId, Name_Storage_Size))))))); 12007 12008 else 12009 Size_Decl := 12010 Make_Object_Declaration (Loc, 12011 Defining_Identifier => Storage_Size_Variable (Tasktyp), 12012 Object_Definition => 12013 New_Occurrence_Of (RTE (RE_Size_Type), Loc), 12014 Expression => 12015 New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc)); 12016 end if; 12017 12018 Insert_After (Elab_Decl, Size_Decl); 12019 12020 -- Next build the rest of the corresponding record declaration. This is 12021 -- done last, since the corresponding record initialization procedure 12022 -- will reference the previously created entities. 12023 12024 -- Fill in the component declarations -- first the _Task_Id field 12025 12026 Append_To (Cdecls, 12027 Make_Component_Declaration (Loc, 12028 Defining_Identifier => 12029 Make_Defining_Identifier (Loc, Name_uTask_Id), 12030 Component_Definition => 12031 Make_Component_Definition (Loc, 12032 Aliased_Present => False, 12033 Subtype_Indication => New_Occurrence_Of (RTE (RO_ST_Task_Id), 12034 Loc)))); 12035 12036 -- Declare static ATCB (that is, created by the expander) if we are 12037 -- using the Restricted run time. 12038 12039 if Restricted_Profile then 12040 Append_To (Cdecls, 12041 Make_Component_Declaration (Loc, 12042 Defining_Identifier => 12043 Make_Defining_Identifier (Loc, Name_uATCB), 12044 12045 Component_Definition => 12046 Make_Component_Definition (Loc, 12047 Aliased_Present => True, 12048 Subtype_Indication => Make_Subtype_Indication (Loc, 12049 Subtype_Mark => 12050 New_Occurrence_Of (RTE (RE_Ada_Task_Control_Block), Loc), 12051 12052 Constraint => 12053 Make_Index_Or_Discriminant_Constraint (Loc, 12054 Constraints => 12055 New_List (Make_Integer_Literal (Loc, 0))))))); 12056 12057 end if; 12058 12059 -- Declare static stack (that is, created by the expander) if we are 12060 -- using the Restricted run time on a bare board configuration. 12061 12062 if Restricted_Profile and then Preallocated_Stacks_On_Target then 12063 12064 -- First we need to extract the appropriate stack size 12065 12066 Ent_Stack := Make_Defining_Identifier (Loc, Name_uStack); 12067 12068 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 12069 declare 12070 Expr_N : constant Node_Id := 12071 Expression (First ( 12072 Pragma_Argument_Associations ( 12073 Get_Rep_Pragma (TaskId, Name_Storage_Size)))); 12074 Etyp : constant Entity_Id := Etype (Expr_N); 12075 P : constant Node_Id := Parent (Expr_N); 12076 12077 begin 12078 -- The stack is defined inside the corresponding record. 12079 -- Therefore if the size of the stack is set by means of 12080 -- a discriminant, we must reference the discriminant of the 12081 -- corresponding record type. 12082 12083 if Nkind (Expr_N) in N_Has_Entity 12084 and then Present (Discriminal_Link (Entity (Expr_N))) 12085 then 12086 Task_Size := 12087 New_Occurrence_Of 12088 (CR_Discriminant (Discriminal_Link (Entity (Expr_N))), 12089 Loc); 12090 Set_Parent (Task_Size, P); 12091 Set_Etype (Task_Size, Etyp); 12092 Set_Analyzed (Task_Size); 12093 12094 else 12095 Task_Size := Relocate_Node (Expr_N); 12096 end if; 12097 end; 12098 12099 else 12100 Task_Size := 12101 New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc); 12102 end if; 12103 12104 Decl_Stack := Make_Component_Declaration (Loc, 12105 Defining_Identifier => Ent_Stack, 12106 12107 Component_Definition => 12108 Make_Component_Definition (Loc, 12109 Aliased_Present => True, 12110 Subtype_Indication => Make_Subtype_Indication (Loc, 12111 Subtype_Mark => 12112 New_Occurrence_Of (RTE (RE_Storage_Array), Loc), 12113 12114 Constraint => 12115 Make_Index_Or_Discriminant_Constraint (Loc, 12116 Constraints => New_List (Make_Range (Loc, 12117 Low_Bound => Make_Integer_Literal (Loc, 1), 12118 High_Bound => Convert_To (RTE (RE_Storage_Offset), 12119 Task_Size))))))); 12120 12121 Append_To (Cdecls, Decl_Stack); 12122 12123 -- The appropriate alignment for the stack is ensured by the run-time 12124 -- code in charge of task creation. 12125 12126 end if; 12127 12128 -- Add components for entry families 12129 12130 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); 12131 12132 -- Add the _Priority component if a Interrupt_Priority or Priority rep 12133 -- item is present. 12134 12135 if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then 12136 Append_To (Cdecls, 12137 Make_Component_Declaration (Loc, 12138 Defining_Identifier => 12139 Make_Defining_Identifier (Loc, Name_uPriority), 12140 Component_Definition => 12141 Make_Component_Definition (Loc, 12142 Aliased_Present => False, 12143 Subtype_Indication => 12144 New_Occurrence_Of (Standard_Integer, Loc)))); 12145 end if; 12146 12147 -- Add the _Size component if a Storage_Size pragma is present 12148 12149 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) then 12150 Append_To (Cdecls, 12151 Make_Component_Declaration (Loc, 12152 Defining_Identifier => 12153 Make_Defining_Identifier (Loc, Name_uSize), 12154 12155 Component_Definition => 12156 Make_Component_Definition (Loc, 12157 Aliased_Present => False, 12158 Subtype_Indication => 12159 New_Occurrence_Of (RTE (RE_Size_Type), Loc)), 12160 12161 Expression => 12162 Convert_To (RTE (RE_Size_Type), 12163 Relocate_Node ( 12164 Expression (First ( 12165 Pragma_Argument_Associations ( 12166 Get_Rep_Pragma (TaskId, Name_Storage_Size)))))))); 12167 end if; 12168 12169 -- Add the _Task_Info component if a Task_Info pragma is present 12170 12171 if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then 12172 Append_To (Cdecls, 12173 Make_Component_Declaration (Loc, 12174 Defining_Identifier => 12175 Make_Defining_Identifier (Loc, Name_uTask_Info), 12176 12177 Component_Definition => 12178 Make_Component_Definition (Loc, 12179 Aliased_Present => False, 12180 Subtype_Indication => 12181 New_Occurrence_Of (RTE (RE_Task_Info_Type), Loc)), 12182 12183 Expression => New_Copy ( 12184 Expression (First ( 12185 Pragma_Argument_Associations ( 12186 Get_Rep_Pragma 12187 (TaskId, Name_Task_Info, Check_Parents => False))))))); 12188 end if; 12189 12190 -- Add the _CPU component if a CPU rep item is present 12191 12192 if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then 12193 Append_To (Cdecls, 12194 Make_Component_Declaration (Loc, 12195 Defining_Identifier => 12196 Make_Defining_Identifier (Loc, Name_uCPU), 12197 12198 Component_Definition => 12199 Make_Component_Definition (Loc, 12200 Aliased_Present => False, 12201 Subtype_Indication => 12202 New_Occurrence_Of (RTE (RE_CPU_Range), Loc)))); 12203 end if; 12204 12205 -- Add the _Relative_Deadline component if a Relative_Deadline pragma is 12206 -- present. If we are using a restricted run time this component will 12207 -- not be added (deadlines are not allowed by the Ravenscar profile). 12208 12209 if not Restricted_Profile 12210 and then Present (Taskdef) 12211 and then Has_Relative_Deadline_Pragma (Taskdef) 12212 then 12213 Append_To (Cdecls, 12214 Make_Component_Declaration (Loc, 12215 Defining_Identifier => 12216 Make_Defining_Identifier (Loc, Name_uRelative_Deadline), 12217 12218 Component_Definition => 12219 Make_Component_Definition (Loc, 12220 Aliased_Present => False, 12221 Subtype_Indication => 12222 New_Occurrence_Of (RTE (RE_Time_Span), Loc)), 12223 12224 Expression => 12225 Convert_To (RTE (RE_Time_Span), 12226 Relocate_Node ( 12227 Expression (First ( 12228 Pragma_Argument_Associations ( 12229 Get_Relative_Deadline_Pragma (Taskdef)))))))); 12230 end if; 12231 12232 -- Add the _Dispatching_Domain component if a Dispatching_Domain rep 12233 -- item is present. If we are using a restricted run time this component 12234 -- will not be added (dispatching domains are not allowed by the 12235 -- Ravenscar profile). 12236 12237 if not Restricted_Profile 12238 and then 12239 Has_Rep_Item 12240 (TaskId, Name_Dispatching_Domain, Check_Parents => False) 12241 then 12242 Append_To (Cdecls, 12243 Make_Component_Declaration (Loc, 12244 Defining_Identifier => 12245 Make_Defining_Identifier (Loc, Name_uDispatching_Domain), 12246 12247 Component_Definition => 12248 Make_Component_Definition (Loc, 12249 Aliased_Present => False, 12250 Subtype_Indication => 12251 New_Occurrence_Of 12252 (RTE (RE_Dispatching_Domain_Access), Loc)))); 12253 end if; 12254 12255 Insert_After (Size_Decl, Rec_Decl); 12256 12257 -- Analyze the record declaration immediately after construction, 12258 -- because the initialization procedure is needed for single task 12259 -- declarations before the next entity is analyzed. 12260 12261 Analyze (Rec_Decl); 12262 12263 -- Create the declaration of the task body procedure 12264 12265 Proc_Spec := Build_Task_Proc_Specification (Tasktyp); 12266 Body_Decl := 12267 Make_Subprogram_Declaration (Loc, 12268 Specification => Proc_Spec); 12269 Set_Is_Task_Body_Procedure (Body_Decl); 12270 12271 Insert_After (Rec_Decl, Body_Decl); 12272 12273 -- The subprogram does not comes from source, so we have to indicate the 12274 -- need for debugging information explicitly. 12275 12276 if Comes_From_Source (Original_Node (N)) then 12277 Set_Debug_Info_Needed (Defining_Entity (Proc_Spec)); 12278 end if; 12279 12280 -- Ada 2005 (AI-345): Construct the primitive entry wrapper specs before 12281 -- the corresponding record has been frozen. 12282 12283 if Ada_Version >= Ada_2005 then 12284 Build_Wrapper_Specs (Loc, Tasktyp, Rec_Decl); 12285 end if; 12286 12287 -- Ada 2005 (AI-345): We must defer freezing to allow further 12288 -- declaration of primitive subprograms covering task interfaces 12289 12290 if Ada_Version <= Ada_95 then 12291 12292 -- Now we can freeze the corresponding record. This needs manually 12293 -- freezing, since it is really part of the task type, and the task 12294 -- type is frozen at this stage. We of course need the initialization 12295 -- procedure for this corresponding record type and we won't get it 12296 -- in time if we don't freeze now. 12297 12298 declare 12299 L : constant List_Id := Freeze_Entity (Rec_Ent, N); 12300 begin 12301 if Is_Non_Empty_List (L) then 12302 Insert_List_After (Body_Decl, L); 12303 end if; 12304 end; 12305 end if; 12306 12307 -- Complete the expansion of access types to the current task type, if 12308 -- any were declared. 12309 12310 Expand_Previous_Access_Type (Tasktyp); 12311 12312 -- Create wrappers for entries that have contract cases, preconditions 12313 -- and postconditions. 12314 12315 declare 12316 Ent : Entity_Id; 12317 12318 begin 12319 Ent := First_Entity (Tasktyp); 12320 while Present (Ent) loop 12321 if Ekind_In (Ent, E_Entry, E_Entry_Family) then 12322 Build_Contract_Wrapper (Ent, N); 12323 end if; 12324 12325 Next_Entity (Ent); 12326 end loop; 12327 end; 12328 end Expand_N_Task_Type_Declaration; 12329 12330 ------------------------------- 12331 -- Expand_N_Timed_Entry_Call -- 12332 ------------------------------- 12333 12334 -- A timed entry call in normal case is not implemented using ATC mechanism 12335 -- anymore for efficiency reason. 12336 12337 -- select 12338 -- T.E; 12339 -- S1; 12340 -- or 12341 -- delay D; 12342 -- S2; 12343 -- end select; 12344 12345 -- is expanded as follows: 12346 12347 -- 1) When T.E is a task entry_call; 12348 12349 -- declare 12350 -- B : Boolean; 12351 -- X : Task_Entry_Index := <entry index>; 12352 -- DX : Duration := To_Duration (D); 12353 -- M : Delay_Mode := <discriminant>; 12354 -- P : parms := (parm, parm, parm); 12355 12356 -- begin 12357 -- Timed_Protected_Entry_Call 12358 -- (<acceptor-task>, X, P'Address, DX, M, B); 12359 -- if B then 12360 -- S1; 12361 -- else 12362 -- S2; 12363 -- end if; 12364 -- end; 12365 12366 -- 2) When T.E is a protected entry_call; 12367 12368 -- declare 12369 -- B : Boolean; 12370 -- X : Protected_Entry_Index := <entry index>; 12371 -- DX : Duration := To_Duration (D); 12372 -- M : Delay_Mode := <discriminant>; 12373 -- P : parms := (parm, parm, parm); 12374 12375 -- begin 12376 -- Timed_Protected_Entry_Call 12377 -- (<object>'unchecked_access, X, P'Address, DX, M, B); 12378 -- if B then 12379 -- S1; 12380 -- else 12381 -- S2; 12382 -- end if; 12383 -- end; 12384 12385 -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there 12386 -- is no delay and the triggering statements are executed. We first 12387 -- determine the kind of the triggering call and then execute a 12388 -- synchronized operation or a direct call. 12389 12390 -- declare 12391 -- B : Boolean := False; 12392 -- C : Ada.Tags.Prim_Op_Kind; 12393 -- DX : Duration := To_Duration (D) 12394 -- K : Ada.Tags.Tagged_Kind := 12395 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag (<object>)); 12396 -- M : Integer :=...; 12397 -- P : Parameters := (Param1 .. ParamN); 12398 -- S : Integer; 12399 12400 -- begin 12401 -- if K = Ada.Tags.TK_Limited_Tagged 12402 -- or else K = Ada.Tags.TK_Tagged 12403 -- then 12404 -- <dispatching-call>; 12405 -- B := True; 12406 12407 -- else 12408 -- S := 12409 -- Ada.Tags.Get_Offset_Index 12410 -- (Ada.Tags.Tag (<object>), DT_Position (<dispatching-call>)); 12411 12412 -- _Disp_Timed_Select (<object>, S, P'Address, DX, M, C, B); 12413 12414 -- if C = POK_Protected_Entry 12415 -- or else C = POK_Task_Entry 12416 -- then 12417 -- Param1 := P.Param1; 12418 -- ... 12419 -- ParamN := P.ParamN; 12420 -- end if; 12421 12422 -- if B then 12423 -- if C = POK_Procedure 12424 -- or else C = POK_Protected_Procedure 12425 -- or else C = POK_Task_Procedure 12426 -- then 12427 -- <dispatching-call>; 12428 -- end if; 12429 -- end if; 12430 -- end if; 12431 12432 -- if B then 12433 -- <triggering-statements> 12434 -- else 12435 -- <timed-statements> 12436 -- end if; 12437 -- end; 12438 12439 -- The triggering statement and the sequence of timed statements have not 12440 -- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain 12441 -- global references if within an instantiation. 12442 12443 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is 12444 Loc : constant Source_Ptr := Sloc (N); 12445 12446 Actuals : List_Id; 12447 Blk_Typ : Entity_Id; 12448 Call : Node_Id; 12449 Call_Ent : Entity_Id; 12450 Conc_Typ_Stmts : List_Id; 12451 Concval : Node_Id; 12452 D_Alt : constant Node_Id := Delay_Alternative (N); 12453 D_Conv : Node_Id; 12454 D_Disc : Node_Id; 12455 D_Stat : Node_Id := Delay_Statement (D_Alt); 12456 D_Stats : List_Id; 12457 D_Type : Entity_Id; 12458 Decls : List_Id; 12459 Dummy : Node_Id; 12460 E_Alt : constant Node_Id := Entry_Call_Alternative (N); 12461 E_Call : Node_Id := Entry_Call_Statement (E_Alt); 12462 E_Stats : List_Id; 12463 Ename : Node_Id; 12464 Formals : List_Id; 12465 Index : Node_Id; 12466 Is_Disp_Select : Boolean; 12467 Lim_Typ_Stmts : List_Id; 12468 N_Stats : List_Id; 12469 Obj : Entity_Id; 12470 Param : Node_Id; 12471 Params : List_Id; 12472 Stmt : Node_Id; 12473 Stmts : List_Id; 12474 Unpack : List_Id; 12475 12476 B : Entity_Id; -- Call status flag 12477 C : Entity_Id; -- Call kind 12478 D : Entity_Id; -- Delay 12479 K : Entity_Id; -- Tagged kind 12480 M : Entity_Id; -- Delay mode 12481 P : Entity_Id; -- Parameter block 12482 S : Entity_Id; -- Primitive operation slot 12483 12484 -- Start of processing for Expand_N_Timed_Entry_Call 12485 12486 begin 12487 -- Under the Ravenscar profile, timed entry calls are excluded. An error 12488 -- was already reported on spec, so do not attempt to expand the call. 12489 12490 if Restriction_Active (No_Select_Statements) then 12491 return; 12492 end if; 12493 12494 Process_Statements_For_Controlled_Objects (E_Alt); 12495 Process_Statements_For_Controlled_Objects (D_Alt); 12496 12497 Ensure_Statement_Present (Sloc (D_Stat), D_Alt); 12498 12499 -- Retrieve E_Stats and D_Stats now because the finalization machinery 12500 -- may wrap them in blocks. 12501 12502 E_Stats := Statements (E_Alt); 12503 D_Stats := Statements (D_Alt); 12504 12505 -- The arguments in the call may require dynamic allocation, and the 12506 -- call statement may have been transformed into a block. The block 12507 -- may contain additional declarations for internal entities, and the 12508 -- original call is found by sequential search. 12509 12510 if Nkind (E_Call) = N_Block_Statement then 12511 E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); 12512 while not Nkind_In (E_Call, N_Procedure_Call_Statement, 12513 N_Entry_Call_Statement) 12514 loop 12515 Next (E_Call); 12516 end loop; 12517 end if; 12518 12519 Is_Disp_Select := 12520 Ada_Version >= Ada_2005 12521 and then Nkind (E_Call) = N_Procedure_Call_Statement; 12522 12523 if Is_Disp_Select then 12524 Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals); 12525 Decls := New_List; 12526 12527 Stmts := New_List; 12528 12529 -- Generate: 12530 -- B : Boolean := False; 12531 12532 B := Build_B (Loc, Decls); 12533 12534 -- Generate: 12535 -- C : Ada.Tags.Prim_Op_Kind; 12536 12537 C := Build_C (Loc, Decls); 12538 12539 -- Because the analysis of all statements was disabled, manually 12540 -- analyze the delay statement. 12541 12542 Analyze (D_Stat); 12543 D_Stat := Original_Node (D_Stat); 12544 12545 else 12546 -- Build an entry call using Simple_Entry_Call 12547 12548 Extract_Entry (E_Call, Concval, Ename, Index); 12549 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); 12550 12551 Decls := Declarations (E_Call); 12552 Stmts := Statements (Handled_Statement_Sequence (E_Call)); 12553 12554 if No (Decls) then 12555 Decls := New_List; 12556 end if; 12557 12558 -- Generate: 12559 -- B : Boolean; 12560 12561 B := Make_Defining_Identifier (Loc, Name_uB); 12562 12563 Prepend_To (Decls, 12564 Make_Object_Declaration (Loc, 12565 Defining_Identifier => B, 12566 Object_Definition => 12567 New_Occurrence_Of (Standard_Boolean, Loc))); 12568 end if; 12569 12570 -- Duration and mode processing 12571 12572 D_Type := Base_Type (Etype (Expression (D_Stat))); 12573 12574 -- Use the type of the delay expression (Calendar or Real_Time) to 12575 -- generate the appropriate conversion. 12576 12577 if Nkind (D_Stat) = N_Delay_Relative_Statement then 12578 D_Disc := Make_Integer_Literal (Loc, 0); 12579 D_Conv := Relocate_Node (Expression (D_Stat)); 12580 12581 elsif Is_RTE (D_Type, RO_CA_Time) then 12582 D_Disc := Make_Integer_Literal (Loc, 1); 12583 D_Conv := 12584 Make_Function_Call (Loc, 12585 Name => New_Occurrence_Of (RTE (RO_CA_To_Duration), Loc), 12586 Parameter_Associations => 12587 New_List (New_Copy (Expression (D_Stat)))); 12588 12589 else pragma Assert (Is_RTE (D_Type, RO_RT_Time)); 12590 D_Disc := Make_Integer_Literal (Loc, 2); 12591 D_Conv := 12592 Make_Function_Call (Loc, 12593 Name => New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 12594 Parameter_Associations => 12595 New_List (New_Copy (Expression (D_Stat)))); 12596 end if; 12597 12598 D := Make_Temporary (Loc, 'D'); 12599 12600 -- Generate: 12601 -- D : Duration; 12602 12603 Append_To (Decls, 12604 Make_Object_Declaration (Loc, 12605 Defining_Identifier => D, 12606 Object_Definition => New_Occurrence_Of (Standard_Duration, Loc))); 12607 12608 M := Make_Temporary (Loc, 'M'); 12609 12610 -- Generate: 12611 -- M : Integer := (0 | 1 | 2); 12612 12613 Append_To (Decls, 12614 Make_Object_Declaration (Loc, 12615 Defining_Identifier => M, 12616 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), 12617 Expression => D_Disc)); 12618 12619 -- Do the assignment at this stage only because the evaluation of the 12620 -- expression must not occur before (see ACVC C97302A). 12621 12622 Append_To (Stmts, 12623 Make_Assignment_Statement (Loc, 12624 Name => New_Occurrence_Of (D, Loc), 12625 Expression => D_Conv)); 12626 12627 -- Parameter block processing 12628 12629 -- Manually create the parameter block for dispatching calls. In the 12630 -- case of entries, the block has already been created during the call 12631 -- to Build_Simple_Entry_Call. 12632 12633 if Is_Disp_Select then 12634 12635 -- Tagged kind processing, generate: 12636 -- K : Ada.Tags.Tagged_Kind := 12637 -- Ada.Tags.Get_Tagged_Kind (Ada.Tags.Tag <object>)); 12638 12639 K := Build_K (Loc, Decls, Obj); 12640 12641 Blk_Typ := Build_Parameter_Block (Loc, Actuals, Formals, Decls); 12642 P := 12643 Parameter_Block_Pack (Loc, Blk_Typ, Actuals, Formals, Decls, Stmts); 12644 12645 -- Dispatch table slot processing, generate: 12646 -- S : Integer; 12647 12648 S := Build_S (Loc, Decls); 12649 12650 -- Generate: 12651 -- S := Ada.Tags.Get_Offset_Index 12652 -- (Ada.Tags.Tag (<object>), DT_Position (Call_Ent)); 12653 12654 Conc_Typ_Stmts := 12655 New_List (Build_S_Assignment (Loc, S, Obj, Call_Ent)); 12656 12657 -- Generate: 12658 -- _Disp_Timed_Select (<object>, S, P'Address, D, M, C, B); 12659 12660 -- where Obj is the controlling formal parameter, S is the dispatch 12661 -- table slot number of the dispatching operation, P is the wrapped 12662 -- parameter block, D is the duration, M is the duration mode, C is 12663 -- the call kind and B is the call status. 12664 12665 Params := New_List; 12666 12667 Append_To (Params, New_Copy_Tree (Obj)); 12668 Append_To (Params, New_Occurrence_Of (S, Loc)); 12669 Append_To (Params, 12670 Make_Attribute_Reference (Loc, 12671 Prefix => New_Occurrence_Of (P, Loc), 12672 Attribute_Name => Name_Address)); 12673 Append_To (Params, New_Occurrence_Of (D, Loc)); 12674 Append_To (Params, New_Occurrence_Of (M, Loc)); 12675 Append_To (Params, New_Occurrence_Of (C, Loc)); 12676 Append_To (Params, New_Occurrence_Of (B, Loc)); 12677 12678 Append_To (Conc_Typ_Stmts, 12679 Make_Procedure_Call_Statement (Loc, 12680 Name => 12681 New_Occurrence_Of 12682 (Find_Prim_Op 12683 (Etype (Etype (Obj)), Name_uDisp_Timed_Select), Loc), 12684 Parameter_Associations => Params)); 12685 12686 -- Generate: 12687 -- if C = POK_Protected_Entry 12688 -- or else C = POK_Task_Entry 12689 -- then 12690 -- Param1 := P.Param1; 12691 -- ... 12692 -- ParamN := P.ParamN; 12693 -- end if; 12694 12695 Unpack := Parameter_Block_Unpack (Loc, P, Actuals, Formals); 12696 12697 -- Generate the if statement only when the packed parameters need 12698 -- explicit assignments to their corresponding actuals. 12699 12700 if Present (Unpack) then 12701 Append_To (Conc_Typ_Stmts, 12702 Make_Implicit_If_Statement (N, 12703 12704 Condition => 12705 Make_Or_Else (Loc, 12706 Left_Opnd => 12707 Make_Op_Eq (Loc, 12708 Left_Opnd => New_Occurrence_Of (C, Loc), 12709 Right_Opnd => 12710 New_Occurrence_Of 12711 (RTE (RE_POK_Protected_Entry), Loc)), 12712 12713 Right_Opnd => 12714 Make_Op_Eq (Loc, 12715 Left_Opnd => New_Occurrence_Of (C, Loc), 12716 Right_Opnd => 12717 New_Occurrence_Of (RTE (RE_POK_Task_Entry), Loc))), 12718 12719 Then_Statements => Unpack)); 12720 end if; 12721 12722 -- Generate: 12723 12724 -- if B then 12725 -- if C = POK_Procedure 12726 -- or else C = POK_Protected_Procedure 12727 -- or else C = POK_Task_Procedure 12728 -- then 12729 -- <dispatching-call> 12730 -- end if; 12731 -- end if; 12732 12733 N_Stats := New_List ( 12734 Make_Implicit_If_Statement (N, 12735 Condition => 12736 Make_Or_Else (Loc, 12737 Left_Opnd => 12738 Make_Op_Eq (Loc, 12739 Left_Opnd => New_Occurrence_Of (C, Loc), 12740 Right_Opnd => 12741 New_Occurrence_Of (RTE (RE_POK_Procedure), Loc)), 12742 12743 Right_Opnd => 12744 Make_Or_Else (Loc, 12745 Left_Opnd => 12746 Make_Op_Eq (Loc, 12747 Left_Opnd => New_Occurrence_Of (C, Loc), 12748 Right_Opnd => 12749 New_Occurrence_Of (RTE ( 12750 RE_POK_Protected_Procedure), Loc)), 12751 Right_Opnd => 12752 Make_Op_Eq (Loc, 12753 Left_Opnd => New_Occurrence_Of (C, Loc), 12754 Right_Opnd => 12755 New_Occurrence_Of 12756 (RTE (RE_POK_Task_Procedure), Loc)))), 12757 12758 Then_Statements => New_List (E_Call))); 12759 12760 Append_To (Conc_Typ_Stmts, 12761 Make_Implicit_If_Statement (N, 12762 Condition => New_Occurrence_Of (B, Loc), 12763 Then_Statements => N_Stats)); 12764 12765 -- Generate: 12766 -- <dispatching-call>; 12767 -- B := True; 12768 12769 Lim_Typ_Stmts := 12770 New_List (New_Copy_Tree (E_Call), 12771 Make_Assignment_Statement (Loc, 12772 Name => New_Occurrence_Of (B, Loc), 12773 Expression => New_Occurrence_Of (Standard_True, Loc))); 12774 12775 -- Generate: 12776 -- if K = Ada.Tags.TK_Limited_Tagged 12777 -- or else K = Ada.Tags.TK_Tagged 12778 -- then 12779 -- Lim_Typ_Stmts 12780 -- else 12781 -- Conc_Typ_Stmts 12782 -- end if; 12783 12784 Append_To (Stmts, 12785 Make_Implicit_If_Statement (N, 12786 Condition => Build_Dispatching_Tag_Check (K, N), 12787 Then_Statements => Lim_Typ_Stmts, 12788 Else_Statements => Conc_Typ_Stmts)); 12789 12790 -- Generate: 12791 12792 -- if B then 12793 -- <triggering-statements> 12794 -- else 12795 -- <timed-statements> 12796 -- end if; 12797 12798 Append_To (Stmts, 12799 Make_Implicit_If_Statement (N, 12800 Condition => New_Occurrence_Of (B, Loc), 12801 Then_Statements => E_Stats, 12802 Else_Statements => D_Stats)); 12803 12804 else 12805 -- Simple case of a non-dispatching trigger. Skip assignments to 12806 -- temporaries created for in-out parameters. 12807 12808 -- This makes unwarranted assumptions about the shape of the expanded 12809 -- tree for the call, and should be cleaned up ??? 12810 12811 Stmt := First (Stmts); 12812 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 12813 Next (Stmt); 12814 end loop; 12815 12816 -- Do the assignment at this stage only because the evaluation 12817 -- of the expression must not occur before (see ACVC C97302A). 12818 12819 Insert_Before (Stmt, 12820 Make_Assignment_Statement (Loc, 12821 Name => New_Occurrence_Of (D, Loc), 12822 Expression => D_Conv)); 12823 12824 Call := Stmt; 12825 Params := Parameter_Associations (Call); 12826 12827 -- For a protected type, we build a Timed_Protected_Entry_Call 12828 12829 if Is_Protected_Type (Etype (Concval)) then 12830 12831 -- Create a new call statement 12832 12833 Param := First (Params); 12834 while Present (Param) 12835 and then not Is_RTE (Etype (Param), RE_Call_Modes) 12836 loop 12837 Next (Param); 12838 end loop; 12839 12840 Dummy := Remove_Next (Next (Param)); 12841 12842 -- Remove garbage is following the Cancel_Param if present 12843 12844 Dummy := Next (Param); 12845 12846 -- Remove the mode of the Protected_Entry_Call call, then remove 12847 -- the Communication_Block of the Protected_Entry_Call call, and 12848 -- finally add Duration and a Delay_Mode parameter 12849 12850 pragma Assert (Present (Param)); 12851 Rewrite (Param, New_Occurrence_Of (D, Loc)); 12852 12853 Rewrite (Dummy, New_Occurrence_Of (M, Loc)); 12854 12855 -- Add a Boolean flag for successful entry call 12856 12857 Append_To (Params, New_Occurrence_Of (B, Loc)); 12858 12859 case Corresponding_Runtime_Package (Etype (Concval)) is 12860 when System_Tasking_Protected_Objects_Entries => 12861 Rewrite (Call, 12862 Make_Procedure_Call_Statement (Loc, 12863 Name => 12864 New_Occurrence_Of 12865 (RTE (RE_Timed_Protected_Entry_Call), Loc), 12866 Parameter_Associations => Params)); 12867 12868 when others => 12869 raise Program_Error; 12870 end case; 12871 12872 -- For the task case, build a Timed_Task_Entry_Call 12873 12874 else 12875 -- Create a new call statement 12876 12877 Append_To (Params, New_Occurrence_Of (D, Loc)); 12878 Append_To (Params, New_Occurrence_Of (M, Loc)); 12879 Append_To (Params, New_Occurrence_Of (B, Loc)); 12880 12881 Rewrite (Call, 12882 Make_Procedure_Call_Statement (Loc, 12883 Name => 12884 New_Occurrence_Of (RTE (RE_Timed_Task_Entry_Call), Loc), 12885 Parameter_Associations => Params)); 12886 end if; 12887 12888 Append_To (Stmts, 12889 Make_Implicit_If_Statement (N, 12890 Condition => New_Occurrence_Of (B, Loc), 12891 Then_Statements => E_Stats, 12892 Else_Statements => D_Stats)); 12893 end if; 12894 12895 Rewrite (N, 12896 Make_Block_Statement (Loc, 12897 Declarations => Decls, 12898 Handled_Statement_Sequence => 12899 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 12900 12901 Analyze (N); 12902 end Expand_N_Timed_Entry_Call; 12903 12904 ---------------------------------------- 12905 -- Expand_Protected_Body_Declarations -- 12906 ---------------------------------------- 12907 12908 procedure Expand_Protected_Body_Declarations 12909 (N : Node_Id; 12910 Spec_Id : Entity_Id) 12911 is 12912 begin 12913 if No_Run_Time_Mode then 12914 Error_Msg_CRT ("protected body", N); 12915 return; 12916 12917 elsif Expander_Active then 12918 12919 -- Associate discriminals with the first subprogram or entry body to 12920 -- be expanded. 12921 12922 if Present (First_Protected_Operation (Declarations (N))) then 12923 Set_Discriminals (Parent (Spec_Id)); 12924 end if; 12925 end if; 12926 end Expand_Protected_Body_Declarations; 12927 12928 ------------------------- 12929 -- External_Subprogram -- 12930 ------------------------- 12931 12932 function External_Subprogram (E : Entity_Id) return Entity_Id is 12933 Subp : constant Entity_Id := Protected_Body_Subprogram (E); 12934 12935 begin 12936 -- The internal and external subprograms follow each other on the entity 12937 -- chain. Note that previously private operations had no separate 12938 -- external subprogram. We now create one in all cases, because a 12939 -- private operation may actually appear in an external call, through 12940 -- a 'Access reference used for a callback. 12941 12942 -- If the operation is a function that returns an anonymous access type, 12943 -- the corresponding itype appears before the operation, and must be 12944 -- skipped. 12945 12946 -- This mechanism is fragile, there should be a real link between the 12947 -- two versions of the operation, but there is no place to put it ??? 12948 12949 if Is_Access_Type (Next_Entity (Subp)) then 12950 return Next_Entity (Next_Entity (Subp)); 12951 else 12952 return Next_Entity (Subp); 12953 end if; 12954 end External_Subprogram; 12955 12956 ------------------------------ 12957 -- Extract_Dispatching_Call -- 12958 ------------------------------ 12959 12960 procedure Extract_Dispatching_Call 12961 (N : Node_Id; 12962 Call_Ent : out Entity_Id; 12963 Object : out Entity_Id; 12964 Actuals : out List_Id; 12965 Formals : out List_Id) 12966 is 12967 Call_Nam : Node_Id; 12968 12969 begin 12970 pragma Assert (Nkind (N) = N_Procedure_Call_Statement); 12971 12972 if Present (Original_Node (N)) then 12973 Call_Nam := Name (Original_Node (N)); 12974 else 12975 Call_Nam := Name (N); 12976 end if; 12977 12978 -- Retrieve the name of the dispatching procedure. It contains the 12979 -- dispatch table slot number. 12980 12981 loop 12982 case Nkind (Call_Nam) is 12983 when N_Identifier => 12984 exit; 12985 12986 when N_Selected_Component => 12987 Call_Nam := Selector_Name (Call_Nam); 12988 12989 when others => 12990 raise Program_Error; 12991 12992 end case; 12993 end loop; 12994 12995 Actuals := Parameter_Associations (N); 12996 Call_Ent := Entity (Call_Nam); 12997 Formals := Parameter_Specifications (Parent (Call_Ent)); 12998 Object := First (Actuals); 12999 13000 if Present (Original_Node (Object)) then 13001 Object := Original_Node (Object); 13002 end if; 13003 13004 -- If the type of the dispatching object is an access type then return 13005 -- an explicit dereference. 13006 13007 if Is_Access_Type (Etype (Object)) then 13008 Object := Make_Explicit_Dereference (Sloc (N), Object); 13009 Analyze (Object); 13010 end if; 13011 end Extract_Dispatching_Call; 13012 13013 ------------------- 13014 -- Extract_Entry -- 13015 ------------------- 13016 13017 procedure Extract_Entry 13018 (N : Node_Id; 13019 Concval : out Node_Id; 13020 Ename : out Node_Id; 13021 Index : out Node_Id) 13022 is 13023 Nam : constant Node_Id := Name (N); 13024 13025 begin 13026 -- For a simple entry, the name is a selected component, with the 13027 -- prefix being the task value, and the selector being the entry. 13028 13029 if Nkind (Nam) = N_Selected_Component then 13030 Concval := Prefix (Nam); 13031 Ename := Selector_Name (Nam); 13032 Index := Empty; 13033 13034 -- For a member of an entry family, the name is an indexed component 13035 -- where the prefix is a selected component, whose prefix in turn is 13036 -- the task value, and whose selector is the entry family. The single 13037 -- expression in the expressions list of the indexed component is the 13038 -- subscript for the family. 13039 13040 else pragma Assert (Nkind (Nam) = N_Indexed_Component); 13041 Concval := Prefix (Prefix (Nam)); 13042 Ename := Selector_Name (Prefix (Nam)); 13043 Index := First (Expressions (Nam)); 13044 end if; 13045 13046 -- Through indirection, the type may actually be a limited view of a 13047 -- concurrent type. When compiling a call, the non-limited view of the 13048 -- type is visible. 13049 13050 if From_Limited_With (Etype (Concval)) then 13051 Set_Etype (Concval, Non_Limited_View (Etype (Concval))); 13052 end if; 13053 end Extract_Entry; 13054 13055 ------------------- 13056 -- Family_Offset -- 13057 ------------------- 13058 13059 function Family_Offset 13060 (Loc : Source_Ptr; 13061 Hi : Node_Id; 13062 Lo : Node_Id; 13063 Ttyp : Entity_Id; 13064 Cap : Boolean) return Node_Id 13065 is 13066 Ityp : Entity_Id; 13067 Real_Hi : Node_Id; 13068 Real_Lo : Node_Id; 13069 13070 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 13071 -- If one of the bounds is a reference to a discriminant, replace with 13072 -- corresponding discriminal of type. Within the body of a task retrieve 13073 -- the renamed discriminant by simple visibility, using its generated 13074 -- name. Within a protected object, find the original discriminant and 13075 -- replace it with the discriminal of the current protected operation. 13076 13077 ------------------------------ 13078 -- Convert_Discriminant_Ref -- 13079 ------------------------------ 13080 13081 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 13082 Loc : constant Source_Ptr := Sloc (Bound); 13083 B : Node_Id; 13084 D : Entity_Id; 13085 13086 begin 13087 if Is_Entity_Name (Bound) 13088 and then Ekind (Entity (Bound)) = E_Discriminant 13089 then 13090 if Is_Task_Type (Ttyp) and then Has_Completion (Ttyp) then 13091 B := Make_Identifier (Loc, Chars (Entity (Bound))); 13092 Find_Direct_Name (B); 13093 13094 elsif Is_Protected_Type (Ttyp) then 13095 D := First_Discriminant (Ttyp); 13096 while Chars (D) /= Chars (Entity (Bound)) loop 13097 Next_Discriminant (D); 13098 end loop; 13099 13100 B := New_Occurrence_Of (Discriminal (D), Loc); 13101 13102 else 13103 B := New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); 13104 end if; 13105 13106 elsif Nkind (Bound) = N_Attribute_Reference then 13107 return Bound; 13108 13109 else 13110 B := New_Copy_Tree (Bound); 13111 end if; 13112 13113 return 13114 Make_Attribute_Reference (Loc, 13115 Attribute_Name => Name_Pos, 13116 Prefix => New_Occurrence_Of (Etype (Bound), Loc), 13117 Expressions => New_List (B)); 13118 end Convert_Discriminant_Ref; 13119 13120 -- Start of processing for Family_Offset 13121 13122 begin 13123 Real_Hi := Convert_Discriminant_Ref (Hi); 13124 Real_Lo := Convert_Discriminant_Ref (Lo); 13125 13126 if Cap then 13127 if Is_Task_Type (Ttyp) then 13128 Ityp := RTE (RE_Task_Entry_Index); 13129 else 13130 Ityp := RTE (RE_Protected_Entry_Index); 13131 end if; 13132 13133 Real_Hi := 13134 Make_Attribute_Reference (Loc, 13135 Prefix => New_Occurrence_Of (Ityp, Loc), 13136 Attribute_Name => Name_Min, 13137 Expressions => New_List ( 13138 Real_Hi, 13139 Make_Integer_Literal (Loc, Entry_Family_Bound - 1))); 13140 13141 Real_Lo := 13142 Make_Attribute_Reference (Loc, 13143 Prefix => New_Occurrence_Of (Ityp, Loc), 13144 Attribute_Name => Name_Max, 13145 Expressions => New_List ( 13146 Real_Lo, 13147 Make_Integer_Literal (Loc, -Entry_Family_Bound))); 13148 end if; 13149 13150 return Make_Op_Subtract (Loc, Real_Hi, Real_Lo); 13151 end Family_Offset; 13152 13153 ----------------- 13154 -- Family_Size -- 13155 ----------------- 13156 13157 function Family_Size 13158 (Loc : Source_Ptr; 13159 Hi : Node_Id; 13160 Lo : Node_Id; 13161 Ttyp : Entity_Id; 13162 Cap : Boolean) return Node_Id 13163 is 13164 Ityp : Entity_Id; 13165 13166 begin 13167 if Is_Task_Type (Ttyp) then 13168 Ityp := RTE (RE_Task_Entry_Index); 13169 else 13170 Ityp := RTE (RE_Protected_Entry_Index); 13171 end if; 13172 13173 return 13174 Make_Attribute_Reference (Loc, 13175 Prefix => New_Occurrence_Of (Ityp, Loc), 13176 Attribute_Name => Name_Max, 13177 Expressions => New_List ( 13178 Make_Op_Add (Loc, 13179 Left_Opnd => Family_Offset (Loc, Hi, Lo, Ttyp, Cap), 13180 Right_Opnd => Make_Integer_Literal (Loc, 1)), 13181 Make_Integer_Literal (Loc, 0))); 13182 end Family_Size; 13183 13184 ---------------------------- 13185 -- Find_Enclosing_Context -- 13186 ---------------------------- 13187 13188 procedure Find_Enclosing_Context 13189 (N : Node_Id; 13190 Context : out Node_Id; 13191 Context_Id : out Entity_Id; 13192 Context_Decls : out List_Id) 13193 is 13194 begin 13195 -- Traverse the parent chain looking for an enclosing body, block, 13196 -- package or return statement. 13197 13198 Context := Parent (N); 13199 while not Nkind_In (Context, N_Block_Statement, 13200 N_Entry_Body, 13201 N_Extended_Return_Statement, 13202 N_Package_Body, 13203 N_Package_Declaration, 13204 N_Subprogram_Body, 13205 N_Task_Body) 13206 loop 13207 Context := Parent (Context); 13208 end loop; 13209 13210 -- Extract the constituents of the context 13211 13212 if Nkind (Context) = N_Extended_Return_Statement then 13213 Context_Decls := Return_Object_Declarations (Context); 13214 Context_Id := Return_Statement_Entity (Context); 13215 13216 -- Package declarations and bodies use a common library-level activation 13217 -- chain or task master, therefore return the package declaration as the 13218 -- proper carrier for the appropriate flag. 13219 13220 elsif Nkind (Context) = N_Package_Body then 13221 Context_Decls := Declarations (Context); 13222 Context_Id := Corresponding_Spec (Context); 13223 Context := Parent (Context_Id); 13224 13225 if Nkind (Context) = N_Defining_Program_Unit_Name then 13226 Context := Parent (Parent (Context)); 13227 else 13228 Context := Parent (Context); 13229 end if; 13230 13231 elsif Nkind (Context) = N_Package_Declaration then 13232 Context_Decls := Visible_Declarations (Specification (Context)); 13233 Context_Id := Defining_Unit_Name (Specification (Context)); 13234 13235 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13236 Context_Id := Defining_Identifier (Context_Id); 13237 end if; 13238 13239 else 13240 Context_Decls := Declarations (Context); 13241 13242 if Nkind (Context) = N_Block_Statement then 13243 Context_Id := Entity (Identifier (Context)); 13244 13245 elsif Nkind (Context) = N_Entry_Body then 13246 Context_Id := Defining_Identifier (Context); 13247 13248 elsif Nkind (Context) = N_Subprogram_Body then 13249 if Present (Corresponding_Spec (Context)) then 13250 Context_Id := Corresponding_Spec (Context); 13251 else 13252 Context_Id := Defining_Unit_Name (Specification (Context)); 13253 13254 if Nkind (Context_Id) = N_Defining_Program_Unit_Name then 13255 Context_Id := Defining_Identifier (Context_Id); 13256 end if; 13257 end if; 13258 13259 elsif Nkind (Context) = N_Task_Body then 13260 Context_Id := Corresponding_Spec (Context); 13261 13262 else 13263 raise Program_Error; 13264 end if; 13265 end if; 13266 13267 pragma Assert (Present (Context)); 13268 pragma Assert (Present (Context_Id)); 13269 pragma Assert (Present (Context_Decls)); 13270 end Find_Enclosing_Context; 13271 13272 ----------------------- 13273 -- Find_Master_Scope -- 13274 ----------------------- 13275 13276 function Find_Master_Scope (E : Entity_Id) return Entity_Id is 13277 S : Entity_Id; 13278 13279 begin 13280 -- In Ada 2005, the master is the innermost enclosing scope that is not 13281 -- transient. If the enclosing block is the rewriting of a call or the 13282 -- scope is an extended return statement this is valid master. The 13283 -- master in an extended return is only used within the return, and is 13284 -- subsequently overwritten in Move_Activation_Chain, but it must exist 13285 -- now before that overwriting occurs. 13286 13287 S := Scope (E); 13288 13289 if Ada_Version >= Ada_2005 then 13290 while Is_Internal (S) loop 13291 if Nkind (Parent (S)) = N_Block_Statement 13292 and then 13293 Nkind (Original_Node (Parent (S))) = N_Procedure_Call_Statement 13294 then 13295 exit; 13296 13297 elsif Ekind (S) = E_Return_Statement then 13298 exit; 13299 13300 else 13301 S := Scope (S); 13302 end if; 13303 end loop; 13304 end if; 13305 13306 return S; 13307 end Find_Master_Scope; 13308 13309 ------------------------------- 13310 -- First_Protected_Operation -- 13311 ------------------------------- 13312 13313 function First_Protected_Operation (D : List_Id) return Node_Id is 13314 First_Op : Node_Id; 13315 13316 begin 13317 First_Op := First (D); 13318 while Present (First_Op) 13319 and then not Nkind_In (First_Op, N_Subprogram_Body, N_Entry_Body) 13320 loop 13321 Next (First_Op); 13322 end loop; 13323 13324 return First_Op; 13325 end First_Protected_Operation; 13326 13327 --------------------------------------- 13328 -- Install_Private_Data_Declarations -- 13329 --------------------------------------- 13330 13331 procedure Install_Private_Data_Declarations 13332 (Loc : Source_Ptr; 13333 Spec_Id : Entity_Id; 13334 Conc_Typ : Entity_Id; 13335 Body_Nod : Node_Id; 13336 Decls : List_Id; 13337 Barrier : Boolean := False; 13338 Family : Boolean := False) 13339 is 13340 Is_Protected : constant Boolean := Is_Protected_Type (Conc_Typ); 13341 Decl : Node_Id; 13342 Def : Node_Id; 13343 Insert_Node : Node_Id := Empty; 13344 Obj_Ent : Entity_Id; 13345 13346 procedure Add (Decl : Node_Id); 13347 -- Add a single declaration after Insert_Node. If this is the first 13348 -- addition, Decl is added to the front of Decls and it becomes the 13349 -- insertion node. 13350 13351 function Replace_Bound (Bound : Node_Id) return Node_Id; 13352 -- The bounds of an entry index may depend on discriminants, create a 13353 -- reference to the corresponding prival. Otherwise return a duplicate 13354 -- of the original bound. 13355 13356 --------- 13357 -- Add -- 13358 --------- 13359 13360 procedure Add (Decl : Node_Id) is 13361 begin 13362 if No (Insert_Node) then 13363 Prepend_To (Decls, Decl); 13364 else 13365 Insert_After (Insert_Node, Decl); 13366 end if; 13367 13368 Insert_Node := Decl; 13369 end Add; 13370 13371 -------------------------- 13372 -- Replace_Discriminant -- 13373 -------------------------- 13374 13375 function Replace_Bound (Bound : Node_Id) return Node_Id is 13376 begin 13377 if Nkind (Bound) = N_Identifier 13378 and then Is_Discriminal (Entity (Bound)) 13379 then 13380 return Make_Identifier (Loc, Chars (Entity (Bound))); 13381 else 13382 return Duplicate_Subexpr (Bound); 13383 end if; 13384 end Replace_Bound; 13385 13386 -- Start of processing for Install_Private_Data_Declarations 13387 13388 begin 13389 -- Step 1: Retrieve the concurrent object entity. Obj_Ent can denote 13390 -- formal parameter _O, _object or _task depending on the context. 13391 13392 Obj_Ent := Concurrent_Object (Spec_Id, Conc_Typ); 13393 13394 -- Special processing of _O for barrier functions, protected entries 13395 -- and families. 13396 13397 if Barrier 13398 or else 13399 (Is_Protected 13400 and then 13401 (Ekind (Spec_Id) = E_Entry 13402 or else Ekind (Spec_Id) = E_Entry_Family)) 13403 then 13404 declare 13405 Conc_Rec : constant Entity_Id := 13406 Corresponding_Record_Type (Conc_Typ); 13407 Typ_Id : constant Entity_Id := 13408 Make_Defining_Identifier (Loc, 13409 New_External_Name (Chars (Conc_Rec), 'P')); 13410 begin 13411 -- Generate: 13412 -- type prot_typVP is access prot_typV; 13413 13414 Decl := 13415 Make_Full_Type_Declaration (Loc, 13416 Defining_Identifier => Typ_Id, 13417 Type_Definition => 13418 Make_Access_To_Object_Definition (Loc, 13419 Subtype_Indication => 13420 New_Occurrence_Of (Conc_Rec, Loc))); 13421 Add (Decl); 13422 13423 -- Generate: 13424 -- _object : prot_typVP := prot_typV (_O); 13425 13426 Decl := 13427 Make_Object_Declaration (Loc, 13428 Defining_Identifier => 13429 Make_Defining_Identifier (Loc, Name_uObject), 13430 Object_Definition => New_Occurrence_Of (Typ_Id, Loc), 13431 Expression => 13432 Unchecked_Convert_To (Typ_Id, 13433 New_Occurrence_Of (Obj_Ent, Loc))); 13434 Add (Decl); 13435 13436 -- Set the reference to the concurrent object 13437 13438 Obj_Ent := Defining_Identifier (Decl); 13439 end; 13440 end if; 13441 13442 -- Step 2: Create the Protection object and build its declaration for 13443 -- any protected entry (family) of subprogram. Note for the lock-free 13444 -- implementation, the Protection object is not needed anymore. 13445 13446 if Is_Protected and then not Uses_Lock_Free (Conc_Typ) then 13447 declare 13448 Prot_Ent : constant Entity_Id := Make_Temporary (Loc, 'R'); 13449 Prot_Typ : RE_Id; 13450 13451 begin 13452 Set_Protection_Object (Spec_Id, Prot_Ent); 13453 13454 -- Determine the proper protection type 13455 13456 if Has_Attach_Handler (Conc_Typ) 13457 and then not Restricted_Profile 13458 then 13459 Prot_Typ := RE_Static_Interrupt_Protection; 13460 13461 elsif Has_Interrupt_Handler (Conc_Typ) 13462 and then not Restriction_Active (No_Dynamic_Attachment) 13463 then 13464 Prot_Typ := RE_Dynamic_Interrupt_Protection; 13465 13466 else 13467 case Corresponding_Runtime_Package (Conc_Typ) is 13468 when System_Tasking_Protected_Objects_Entries => 13469 Prot_Typ := RE_Protection_Entries; 13470 13471 when System_Tasking_Protected_Objects_Single_Entry => 13472 Prot_Typ := RE_Protection_Entry; 13473 13474 when System_Tasking_Protected_Objects => 13475 Prot_Typ := RE_Protection; 13476 13477 when others => 13478 raise Program_Error; 13479 end case; 13480 end if; 13481 13482 -- Generate: 13483 -- conc_typR : protection_typ renames _object._object; 13484 13485 Decl := 13486 Make_Object_Renaming_Declaration (Loc, 13487 Defining_Identifier => Prot_Ent, 13488 Subtype_Mark => 13489 New_Occurrence_Of (RTE (Prot_Typ), Loc), 13490 Name => 13491 Make_Selected_Component (Loc, 13492 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13493 Selector_Name => Make_Identifier (Loc, Name_uObject))); 13494 Add (Decl); 13495 end; 13496 end if; 13497 13498 -- Step 3: Add discriminant renamings (if any) 13499 13500 if Has_Discriminants (Conc_Typ) then 13501 declare 13502 D : Entity_Id; 13503 13504 begin 13505 D := First_Discriminant (Conc_Typ); 13506 while Present (D) loop 13507 13508 -- Adjust the source location 13509 13510 Set_Sloc (Discriminal (D), Loc); 13511 13512 -- Generate: 13513 -- discr_name : discr_typ renames _object.discr_name; 13514 -- or 13515 -- discr_name : discr_typ renames _task.discr_name; 13516 13517 Decl := 13518 Make_Object_Renaming_Declaration (Loc, 13519 Defining_Identifier => Discriminal (D), 13520 Subtype_Mark => New_Occurrence_Of (Etype (D), Loc), 13521 Name => 13522 Make_Selected_Component (Loc, 13523 Prefix => New_Occurrence_Of (Obj_Ent, Loc), 13524 Selector_Name => Make_Identifier (Loc, Chars (D)))); 13525 Add (Decl); 13526 13527 Next_Discriminant (D); 13528 end loop; 13529 end; 13530 end if; 13531 13532 -- Step 4: Add private component renamings (if any) 13533 13534 if Is_Protected then 13535 Def := Protected_Definition (Parent (Conc_Typ)); 13536 13537 if Present (Private_Declarations (Def)) then 13538 declare 13539 Comp : Node_Id; 13540 Comp_Id : Entity_Id; 13541 Decl_Id : Entity_Id; 13542 13543 begin 13544 Comp := First (Private_Declarations (Def)); 13545 while Present (Comp) loop 13546 if Nkind (Comp) = N_Component_Declaration then 13547 Comp_Id := Defining_Identifier (Comp); 13548 Decl_Id := 13549 Make_Defining_Identifier (Loc, Chars (Comp_Id)); 13550 13551 -- Minimal decoration 13552 13553 if Ekind (Spec_Id) = E_Function then 13554 Set_Ekind (Decl_Id, E_Constant); 13555 else 13556 Set_Ekind (Decl_Id, E_Variable); 13557 end if; 13558 13559 Set_Prival (Comp_Id, Decl_Id); 13560 Set_Prival_Link (Decl_Id, Comp_Id); 13561 Set_Is_Aliased (Decl_Id, Is_Aliased (Comp_Id)); 13562 13563 -- Generate: 13564 -- comp_name : comp_typ renames _object.comp_name; 13565 13566 Decl := 13567 Make_Object_Renaming_Declaration (Loc, 13568 Defining_Identifier => Decl_Id, 13569 Subtype_Mark => 13570 New_Occurrence_Of (Etype (Comp_Id), Loc), 13571 Name => 13572 Make_Selected_Component (Loc, 13573 Prefix => 13574 New_Occurrence_Of (Obj_Ent, Loc), 13575 Selector_Name => 13576 Make_Identifier (Loc, Chars (Comp_Id)))); 13577 Add (Decl); 13578 end if; 13579 13580 Next (Comp); 13581 end loop; 13582 end; 13583 end if; 13584 end if; 13585 13586 -- Step 5: Add the declaration of the entry index and the associated 13587 -- type for barrier functions and entry families. 13588 13589 if (Barrier and Family) or else Ekind (Spec_Id) = E_Entry_Family then 13590 declare 13591 E : constant Entity_Id := Index_Object (Spec_Id); 13592 Index : constant Entity_Id := 13593 Defining_Identifier 13594 (Entry_Index_Specification 13595 (Entry_Body_Formal_Part (Body_Nod))); 13596 Index_Con : constant Entity_Id := 13597 Make_Defining_Identifier (Loc, Chars (Index)); 13598 High : Node_Id; 13599 Index_Typ : Entity_Id; 13600 Low : Node_Id; 13601 13602 begin 13603 -- Minimal decoration 13604 13605 Set_Ekind (Index_Con, E_Constant); 13606 Set_Entry_Index_Constant (Index, Index_Con); 13607 Set_Discriminal_Link (Index_Con, Index); 13608 13609 -- Retrieve the bounds of the entry family 13610 13611 High := Type_High_Bound (Etype (Index)); 13612 Low := Type_Low_Bound (Etype (Index)); 13613 13614 -- In the simple case the entry family is given by a subtype 13615 -- mark and the index constant has the same type. 13616 13617 if Is_Entity_Name (Original_Node ( 13618 Discrete_Subtype_Definition (Parent (Index)))) 13619 then 13620 Index_Typ := Etype (Index); 13621 13622 -- Otherwise a new subtype declaration is required 13623 13624 else 13625 High := Replace_Bound (High); 13626 Low := Replace_Bound (Low); 13627 13628 Index_Typ := Make_Temporary (Loc, 'J'); 13629 13630 -- Generate: 13631 -- subtype Jnn is <Etype of Index> range Low .. High; 13632 13633 Decl := 13634 Make_Subtype_Declaration (Loc, 13635 Defining_Identifier => Index_Typ, 13636 Subtype_Indication => 13637 Make_Subtype_Indication (Loc, 13638 Subtype_Mark => 13639 New_Occurrence_Of (Base_Type (Etype (Index)), Loc), 13640 Constraint => 13641 Make_Range_Constraint (Loc, 13642 Range_Expression => 13643 Make_Range (Loc, Low, High)))); 13644 Add (Decl); 13645 end if; 13646 13647 Set_Etype (Index_Con, Index_Typ); 13648 13649 -- Create the object which designates the index: 13650 -- J : constant Jnn := 13651 -- Jnn'Val (_E - <index expr> + Jnn'Pos (Jnn'First)); 13652 -- 13653 -- where Jnn is the subtype created above or the original type of 13654 -- the index, _E is a formal of the protected body subprogram and 13655 -- <index expr> is the index of the first family member. 13656 13657 Decl := 13658 Make_Object_Declaration (Loc, 13659 Defining_Identifier => Index_Con, 13660 Constant_Present => True, 13661 Object_Definition => 13662 New_Occurrence_Of (Index_Typ, Loc), 13663 13664 Expression => 13665 Make_Attribute_Reference (Loc, 13666 Prefix => 13667 New_Occurrence_Of (Index_Typ, Loc), 13668 Attribute_Name => Name_Val, 13669 13670 Expressions => New_List ( 13671 13672 Make_Op_Add (Loc, 13673 Left_Opnd => 13674 Make_Op_Subtract (Loc, 13675 Left_Opnd => New_Occurrence_Of (E, Loc), 13676 Right_Opnd => 13677 Entry_Index_Expression (Loc, 13678 Defining_Identifier (Body_Nod), 13679 Empty, Conc_Typ)), 13680 13681 Right_Opnd => 13682 Make_Attribute_Reference (Loc, 13683 Prefix => 13684 New_Occurrence_Of (Index_Typ, Loc), 13685 Attribute_Name => Name_Pos, 13686 Expressions => New_List ( 13687 Make_Attribute_Reference (Loc, 13688 Prefix => 13689 New_Occurrence_Of (Index_Typ, Loc), 13690 Attribute_Name => Name_First))))))); 13691 Add (Decl); 13692 end; 13693 end if; 13694 end Install_Private_Data_Declarations; 13695 13696 ----------------------- 13697 -- Is_Exception_Safe -- 13698 ----------------------- 13699 13700 function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is 13701 13702 function Has_Side_Effect (N : Node_Id) return Boolean; 13703 -- Return True whenever encountering a subprogram call or raise 13704 -- statement of any kind in the sequence of statements 13705 13706 --------------------- 13707 -- Has_Side_Effect -- 13708 --------------------- 13709 13710 -- What is this doing buried two levels down in exp_ch9. It seems like a 13711 -- generally useful function, and indeed there may be code duplication 13712 -- going on here ??? 13713 13714 function Has_Side_Effect (N : Node_Id) return Boolean is 13715 Stmt : Node_Id; 13716 Expr : Node_Id; 13717 13718 function Is_Call_Or_Raise (N : Node_Id) return Boolean; 13719 -- Indicate whether N is a subprogram call or a raise statement 13720 13721 ---------------------- 13722 -- Is_Call_Or_Raise -- 13723 ---------------------- 13724 13725 function Is_Call_Or_Raise (N : Node_Id) return Boolean is 13726 begin 13727 return Nkind_In (N, N_Procedure_Call_Statement, 13728 N_Function_Call, 13729 N_Raise_Statement, 13730 N_Raise_Constraint_Error, 13731 N_Raise_Program_Error, 13732 N_Raise_Storage_Error); 13733 end Is_Call_Or_Raise; 13734 13735 -- Start of processing for Has_Side_Effect 13736 13737 begin 13738 Stmt := N; 13739 while Present (Stmt) loop 13740 if Is_Call_Or_Raise (Stmt) then 13741 return True; 13742 end if; 13743 13744 -- An object declaration can also contain a function call or a 13745 -- raise statement. 13746 13747 if Nkind (Stmt) = N_Object_Declaration then 13748 Expr := Expression (Stmt); 13749 13750 if Present (Expr) and then Is_Call_Or_Raise (Expr) then 13751 return True; 13752 end if; 13753 end if; 13754 13755 Next (Stmt); 13756 end loop; 13757 13758 return False; 13759 end Has_Side_Effect; 13760 13761 -- Start of processing for Is_Exception_Safe 13762 13763 begin 13764 -- When exceptions can't be propagated, the subprogram returns normally 13765 13766 if No_Exception_Handlers_Set then 13767 return True; 13768 end if; 13769 13770 -- If the checks handled by the back end are not disabled, we cannot 13771 -- ensure that no exception will be raised. 13772 13773 if not Access_Checks_Suppressed (Empty) 13774 or else not Discriminant_Checks_Suppressed (Empty) 13775 or else not Range_Checks_Suppressed (Empty) 13776 or else not Index_Checks_Suppressed (Empty) 13777 or else Opt.Stack_Checking_Enabled 13778 then 13779 return False; 13780 end if; 13781 13782 if Has_Side_Effect (First (Declarations (Subprogram))) 13783 or else 13784 Has_Side_Effect 13785 (First (Statements (Handled_Statement_Sequence (Subprogram)))) 13786 then 13787 return False; 13788 else 13789 return True; 13790 end if; 13791 end Is_Exception_Safe; 13792 13793 --------------------------------- 13794 -- Is_Potentially_Large_Family -- 13795 --------------------------------- 13796 13797 function Is_Potentially_Large_Family 13798 (Base_Index : Entity_Id; 13799 Conctyp : Entity_Id; 13800 Lo : Node_Id; 13801 Hi : Node_Id) return Boolean 13802 is 13803 begin 13804 return Scope (Base_Index) = Standard_Standard 13805 and then Base_Index = Base_Type (Standard_Integer) 13806 and then Has_Discriminants (Conctyp) 13807 and then 13808 Present (Discriminant_Default_Value (First_Discriminant (Conctyp))) 13809 and then 13810 (Denotes_Discriminant (Lo, True) 13811 or else 13812 Denotes_Discriminant (Hi, True)); 13813 end Is_Potentially_Large_Family; 13814 13815 ------------------------------------- 13816 -- Is_Private_Primitive_Subprogram -- 13817 ------------------------------------- 13818 13819 function Is_Private_Primitive_Subprogram (Id : Entity_Id) return Boolean is 13820 begin 13821 return 13822 (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure) 13823 and then Is_Private_Primitive (Id); 13824 end Is_Private_Primitive_Subprogram; 13825 13826 ------------------ 13827 -- Index_Object -- 13828 ------------------ 13829 13830 function Index_Object (Spec_Id : Entity_Id) return Entity_Id is 13831 Bod_Subp : constant Entity_Id := Protected_Body_Subprogram (Spec_Id); 13832 Formal : Entity_Id; 13833 13834 begin 13835 Formal := First_Formal (Bod_Subp); 13836 while Present (Formal) loop 13837 13838 -- Look for formal parameter _E 13839 13840 if Chars (Formal) = Name_uE then 13841 return Formal; 13842 end if; 13843 13844 Next_Formal (Formal); 13845 end loop; 13846 13847 -- A protected body subprogram should always have the parameter in 13848 -- question. 13849 13850 raise Program_Error; 13851 end Index_Object; 13852 13853 -------------------------------- 13854 -- Make_Initialize_Protection -- 13855 -------------------------------- 13856 13857 function Make_Initialize_Protection 13858 (Protect_Rec : Entity_Id) return List_Id 13859 is 13860 Loc : constant Source_Ptr := Sloc (Protect_Rec); 13861 P_Arr : Entity_Id; 13862 Pdec : Node_Id; 13863 Ptyp : constant Node_Id := 13864 Corresponding_Concurrent_Type (Protect_Rec); 13865 Args : List_Id; 13866 L : constant List_Id := New_List; 13867 Has_Entry : constant Boolean := Has_Entries (Ptyp); 13868 Prio_Type : Entity_Id; 13869 Prio_Var : Entity_Id := Empty; 13870 Restricted : constant Boolean := Restricted_Profile; 13871 13872 begin 13873 -- We may need two calls to properly initialize the object, one to 13874 -- Initialize_Protection, and possibly one to Install_Handlers if we 13875 -- have a pragma Attach_Handler. 13876 13877 -- Get protected declaration. In the case of a task type declaration, 13878 -- this is simply the parent of the protected type entity. In the single 13879 -- protected object declaration, this parent will be the implicit type, 13880 -- and we can find the corresponding single protected object declaration 13881 -- by searching forward in the declaration list in the tree. 13882 13883 -- Is the test for N_Single_Protected_Declaration needed here??? Nodes 13884 -- of this type should have been removed during semantic analysis. 13885 13886 Pdec := Parent (Ptyp); 13887 while not Nkind_In (Pdec, N_Protected_Type_Declaration, 13888 N_Single_Protected_Declaration) 13889 loop 13890 Next (Pdec); 13891 end loop; 13892 13893 -- Build the parameter list for the call. Note that _Init is the name 13894 -- of the formal for the object to be initialized, which is the task 13895 -- value record itself. 13896 13897 Args := New_List; 13898 13899 -- For lock-free implementation, skip initializations of the Protection 13900 -- object. 13901 13902 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 13903 13904 -- Object parameter. This is a pointer to the object of type 13905 -- Protection used by the GNARL to control the protected object. 13906 13907 Append_To (Args, 13908 Make_Attribute_Reference (Loc, 13909 Prefix => 13910 Make_Selected_Component (Loc, 13911 Prefix => Make_Identifier (Loc, Name_uInit), 13912 Selector_Name => Make_Identifier (Loc, Name_uObject)), 13913 Attribute_Name => Name_Unchecked_Access)); 13914 13915 -- Priority parameter. Set to Unspecified_Priority unless there is a 13916 -- Priority rep item, in which case we take the value from the pragma 13917 -- or attribute definition clause, or there is an Interrupt_Priority 13918 -- rep item and no Priority rep item, and we set the ceiling to 13919 -- Interrupt_Priority'Last, an implementation-defined value, see 13920 -- (RM D.3(10)). 13921 13922 if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then 13923 declare 13924 Prio_Clause : constant Node_Id := 13925 Get_Rep_Item 13926 (Ptyp, Name_Priority, Check_Parents => False); 13927 13928 Prio : Node_Id; 13929 13930 begin 13931 -- Pragma Priority 13932 13933 if Nkind (Prio_Clause) = N_Pragma then 13934 Prio := 13935 Expression 13936 (First (Pragma_Argument_Associations (Prio_Clause))); 13937 13938 -- Get_Rep_Item returns either priority pragma. 13939 13940 if Pragma_Name (Prio_Clause) = Name_Priority then 13941 Prio_Type := RTE (RE_Any_Priority); 13942 else 13943 Prio_Type := RTE (RE_Interrupt_Priority); 13944 end if; 13945 13946 -- Attribute definition clause Priority 13947 13948 else 13949 if Chars (Prio_Clause) = Name_Priority then 13950 Prio_Type := RTE (RE_Any_Priority); 13951 else 13952 Prio_Type := RTE (RE_Interrupt_Priority); 13953 end if; 13954 13955 Prio := Expression (Prio_Clause); 13956 end if; 13957 13958 -- Always create a locale variable to capture the priority. 13959 -- The priority is also passed to Install_Restriced_Handlers. 13960 -- Note that it is really necessary to create this variable 13961 -- explicitly. It might be thought that removing side effects 13962 -- would the appropriate approach, but that could generate 13963 -- declarations improperly placed in the enclosing scope. 13964 13965 Prio_Var := Make_Temporary (Loc, 'R', Prio); 13966 Append_To (L, 13967 Make_Object_Declaration (Loc, 13968 Defining_Identifier => Prio_Var, 13969 Object_Definition => New_Occurrence_Of (Prio_Type, Loc), 13970 Expression => Relocate_Node (Prio))); 13971 13972 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 13973 end; 13974 13975 -- When no priority is specified but an xx_Handler pragma is, we 13976 -- default to System.Interrupts.Default_Interrupt_Priority, see 13977 -- D.3(10). 13978 13979 elsif Has_Attach_Handler (Ptyp) 13980 or else Has_Interrupt_Handler (Ptyp) 13981 then 13982 Append_To (Args, 13983 New_Occurrence_Of (RTE (RE_Default_Interrupt_Priority), Loc)); 13984 13985 -- Normal case, no priority or xx_Handler specified, default priority 13986 13987 else 13988 Append_To (Args, 13989 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 13990 end if; 13991 13992 -- Test for Compiler_Info parameter. This parameter allows entry body 13993 -- procedures and barrier functions to be called from the runtime. It 13994 -- is a pointer to the record generated by the compiler to represent 13995 -- the protected object. 13996 13997 -- A protected type without entries that covers an interface and 13998 -- overrides the abstract routines with protected procedures is 13999 -- considered equivalent to a protected type with entries in the 14000 -- context of dispatching select statements. 14001 14002 -- Protected types with interrupt handlers (when not using a 14003 -- restricted profile) are also considered equivalent to protected 14004 -- types with entries. 14005 14006 -- The types which are used (Static_Interrupt_Protection and 14007 -- Dynamic_Interrupt_Protection) are derived from Protection_Entries. 14008 14009 declare 14010 Pkg_Id : constant RTU_Id := Corresponding_Runtime_Package (Ptyp); 14011 14012 Called_Subp : RE_Id; 14013 14014 begin 14015 case Pkg_Id is 14016 when System_Tasking_Protected_Objects_Entries => 14017 Called_Subp := RE_Initialize_Protection_Entries; 14018 14019 -- Argument Compiler_Info 14020 14021 Append_To (Args, 14022 Make_Attribute_Reference (Loc, 14023 Prefix => Make_Identifier (Loc, Name_uInit), 14024 Attribute_Name => Name_Address)); 14025 14026 when System_Tasking_Protected_Objects_Single_Entry => 14027 Called_Subp := RE_Initialize_Protection_Entry; 14028 14029 -- Argument Compiler_Info 14030 14031 Append_To (Args, 14032 Make_Attribute_Reference (Loc, 14033 Prefix => Make_Identifier (Loc, Name_uInit), 14034 Attribute_Name => Name_Address)); 14035 14036 when System_Tasking_Protected_Objects => 14037 Called_Subp := RE_Initialize_Protection; 14038 14039 when others => 14040 raise Program_Error; 14041 end case; 14042 14043 -- Entry_Bodies parameter. This is a pointer to an array of 14044 -- pointers to the entry body procedures and barrier functions of 14045 -- the object. If the protected type has no entries this object 14046 -- will not exist, in this case, pass a null (it can happen when 14047 -- there are protected interrupt handlers or interfaces). 14048 14049 if Has_Entry then 14050 P_Arr := Entry_Bodies_Array (Ptyp); 14051 14052 -- Argument Entry_Body (for single entry) or Entry_Bodies (for 14053 -- multiple entries). 14054 14055 Append_To (Args, 14056 Make_Attribute_Reference (Loc, 14057 Prefix => New_Occurrence_Of (P_Arr, Loc), 14058 Attribute_Name => Name_Unrestricted_Access)); 14059 14060 if Pkg_Id = System_Tasking_Protected_Objects_Entries then 14061 14062 -- Find index mapping function (clumsy but ok for now) 14063 14064 while Ekind (P_Arr) /= E_Function loop 14065 Next_Entity (P_Arr); 14066 end loop; 14067 14068 Append_To (Args, 14069 Make_Attribute_Reference (Loc, 14070 Prefix => New_Occurrence_Of (P_Arr, Loc), 14071 Attribute_Name => Name_Unrestricted_Access)); 14072 end if; 14073 14074 elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry then 14075 14076 -- This is the case where we have a protected object with 14077 -- interfaces and no entries, and the single entry restriction 14078 -- is in effect. We pass a null pointer for the entry 14079 -- parameter because there is no actual entry. 14080 14081 Append_To (Args, Make_Null (Loc)); 14082 14083 elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then 14084 14085 -- This is the case where we have a protected object with no 14086 -- entries and: 14087 -- - either interrupt handlers with non restricted profile, 14088 -- - or interfaces 14089 -- Note that the types which are used for interrupt handlers 14090 -- (Static/Dynamic_Interrupt_Protection) are derived from 14091 -- Protection_Entries. We pass two null pointers because there 14092 -- is no actual entry, and the initialization procedure needs 14093 -- both Entry_Bodies and Find_Body_Index. 14094 14095 Append_To (Args, Make_Null (Loc)); 14096 Append_To (Args, Make_Null (Loc)); 14097 end if; 14098 14099 Append_To (L, 14100 Make_Procedure_Call_Statement (Loc, 14101 Name => 14102 New_Occurrence_Of (RTE (Called_Subp), Loc), 14103 Parameter_Associations => Args)); 14104 end; 14105 end if; 14106 14107 if Has_Attach_Handler (Ptyp) then 14108 14109 -- We have a list of N Attach_Handler (ProcI, ExprI), and we have to 14110 -- make the following call: 14111 14112 -- Install_Handlers (_object, 14113 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); 14114 14115 -- or, in the case of Ravenscar: 14116 14117 -- Install_Restricted_Handlers 14118 -- (Prio, (Expr1, Proc1'access), ...., (ExprN, ProcN'access)); 14119 14120 declare 14121 Args : constant List_Id := New_List; 14122 Table : constant List_Id := New_List; 14123 Ritem : Node_Id := First_Rep_Item (Ptyp); 14124 14125 begin 14126 -- Build the Priority parameter (only for ravenscar) 14127 14128 if Restricted then 14129 14130 -- Priority comes from a pragma 14131 14132 if Present (Prio_Var) then 14133 Append_To (Args, New_Occurrence_Of (Prio_Var, Loc)); 14134 14135 -- Priority is the default one 14136 14137 else 14138 Append_To (Args, 14139 New_Occurrence_Of 14140 (RTE (RE_Default_Interrupt_Priority), Loc)); 14141 end if; 14142 end if; 14143 14144 -- Build the Attach_Handler table argument 14145 14146 while Present (Ritem) loop 14147 if Nkind (Ritem) = N_Pragma 14148 and then Pragma_Name (Ritem) = Name_Attach_Handler 14149 then 14150 declare 14151 Handler : constant Node_Id := 14152 First (Pragma_Argument_Associations (Ritem)); 14153 14154 Interrupt : constant Node_Id := Next (Handler); 14155 Expr : constant Node_Id := Expression (Interrupt); 14156 14157 begin 14158 Append_To (Table, 14159 Make_Aggregate (Loc, Expressions => New_List ( 14160 Unchecked_Convert_To 14161 (RTE (RE_System_Interrupt_Id), Expr), 14162 Make_Attribute_Reference (Loc, 14163 Prefix => 14164 Make_Selected_Component (Loc, 14165 Prefix => 14166 Make_Identifier (Loc, Name_uInit), 14167 Selector_Name => 14168 Duplicate_Subexpr_No_Checks 14169 (Expression (Handler))), 14170 Attribute_Name => Name_Access)))); 14171 end; 14172 end if; 14173 14174 Next_Rep_Item (Ritem); 14175 end loop; 14176 14177 -- Append the table argument we just built 14178 14179 Append_To (Args, Make_Aggregate (Loc, Table)); 14180 14181 -- Append the Install_Handlers (or Install_Restricted_Handlers) 14182 -- call to the statements. 14183 14184 if Restricted then 14185 -- Call a simplified version of Install_Handlers to be used 14186 -- when the Ravenscar restrictions are in effect 14187 -- (Install_Restricted_Handlers). 14188 14189 Append_To (L, 14190 Make_Procedure_Call_Statement (Loc, 14191 Name => 14192 New_Occurrence_Of 14193 (RTE (RE_Install_Restricted_Handlers), Loc), 14194 Parameter_Associations => Args)); 14195 14196 else 14197 if not Uses_Lock_Free (Defining_Identifier (Pdec)) then 14198 14199 -- First, prepends the _object argument 14200 14201 Prepend_To (Args, 14202 Make_Attribute_Reference (Loc, 14203 Prefix => 14204 Make_Selected_Component (Loc, 14205 Prefix => Make_Identifier (Loc, Name_uInit), 14206 Selector_Name => 14207 Make_Identifier (Loc, Name_uObject)), 14208 Attribute_Name => Name_Unchecked_Access)); 14209 end if; 14210 14211 -- Then, insert call to Install_Handlers 14212 14213 Append_To (L, 14214 Make_Procedure_Call_Statement (Loc, 14215 Name => 14216 New_Occurrence_Of (RTE (RE_Install_Handlers), Loc), 14217 Parameter_Associations => Args)); 14218 end if; 14219 end; 14220 end if; 14221 14222 return L; 14223 end Make_Initialize_Protection; 14224 14225 --------------------------- 14226 -- Make_Task_Create_Call -- 14227 --------------------------- 14228 14229 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is 14230 Loc : constant Source_Ptr := Sloc (Task_Rec); 14231 Args : List_Id; 14232 Ecount : Node_Id; 14233 Name : Node_Id; 14234 Tdec : Node_Id; 14235 Tdef : Node_Id; 14236 Tnam : Name_Id; 14237 Ttyp : Node_Id; 14238 14239 begin 14240 Ttyp := Corresponding_Concurrent_Type (Task_Rec); 14241 Tnam := Chars (Ttyp); 14242 14243 -- Get task declaration. In the case of a task type declaration, this is 14244 -- simply the parent of the task type entity. In the single task 14245 -- declaration, this parent will be the implicit type, and we can find 14246 -- the corresponding single task declaration by searching forward in the 14247 -- declaration list in the tree. 14248 14249 -- Is the test for N_Single_Task_Declaration needed here??? Nodes of 14250 -- this type should have been removed during semantic analysis. 14251 14252 Tdec := Parent (Ttyp); 14253 while not Nkind_In (Tdec, N_Task_Type_Declaration, 14254 N_Single_Task_Declaration) 14255 loop 14256 Next (Tdec); 14257 end loop; 14258 14259 -- Now we can find the task definition from this declaration 14260 14261 Tdef := Task_Definition (Tdec); 14262 14263 -- Build the parameter list for the call. Note that _Init is the name 14264 -- of the formal for the object to be initialized, which is the task 14265 -- value record itself. 14266 14267 Args := New_List; 14268 14269 -- Priority parameter. Set to Unspecified_Priority unless there is a 14270 -- Priority rep item, in which case we take the value from the rep item. 14271 14272 if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then 14273 Append_To (Args, 14274 Make_Selected_Component (Loc, 14275 Prefix => Make_Identifier (Loc, Name_uInit), 14276 Selector_Name => Make_Identifier (Loc, Name_uPriority))); 14277 else 14278 Append_To (Args, 14279 New_Occurrence_Of (RTE (RE_Unspecified_Priority), Loc)); 14280 end if; 14281 14282 -- Optional Stack parameter 14283 14284 if Restricted_Profile then 14285 14286 -- If the stack has been preallocated by the expander then 14287 -- pass its address. Otherwise, pass a null address. 14288 14289 if Preallocated_Stacks_On_Target then 14290 Append_To (Args, 14291 Make_Attribute_Reference (Loc, 14292 Prefix => 14293 Make_Selected_Component (Loc, 14294 Prefix => Make_Identifier (Loc, Name_uInit), 14295 Selector_Name => Make_Identifier (Loc, Name_uStack)), 14296 Attribute_Name => Name_Address)); 14297 14298 else 14299 Append_To (Args, 14300 New_Occurrence_Of (RTE (RE_Null_Address), Loc)); 14301 end if; 14302 end if; 14303 14304 -- Size parameter. If no Storage_Size pragma is present, then 14305 -- the size is taken from the taskZ variable for the type, which 14306 -- is either Unspecified_Size, or has been reset by the use of 14307 -- a Storage_Size attribute definition clause. If a pragma is 14308 -- present, then the size is taken from the _Size field of the 14309 -- task value record, which was set from the pragma value. 14310 14311 if Present (Tdef) and then Has_Storage_Size_Pragma (Tdef) then 14312 Append_To (Args, 14313 Make_Selected_Component (Loc, 14314 Prefix => Make_Identifier (Loc, Name_uInit), 14315 Selector_Name => Make_Identifier (Loc, Name_uSize))); 14316 14317 else 14318 Append_To (Args, 14319 New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc)); 14320 end if; 14321 14322 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a 14323 -- Task_Info pragma, in which case we take the value from the pragma. 14324 14325 if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then 14326 Append_To (Args, 14327 Make_Selected_Component (Loc, 14328 Prefix => Make_Identifier (Loc, Name_uInit), 14329 Selector_Name => Make_Identifier (Loc, Name_uTask_Info))); 14330 14331 else 14332 Append_To (Args, 14333 New_Occurrence_Of (RTE (RE_Unspecified_Task_Info), Loc)); 14334 end if; 14335 14336 -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item, 14337 -- in which case we take the value from the rep item. The parameter is 14338 -- passed as an Integer because in the case of unspecified CPU the 14339 -- value is not in the range of CPU_Range. 14340 14341 if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then 14342 Append_To (Args, 14343 Convert_To (Standard_Integer, 14344 Make_Selected_Component (Loc, 14345 Prefix => Make_Identifier (Loc, Name_uInit), 14346 Selector_Name => Make_Identifier (Loc, Name_uCPU)))); 14347 else 14348 Append_To (Args, 14349 New_Occurrence_Of (RTE (RE_Unspecified_CPU), Loc)); 14350 end if; 14351 14352 if not Restricted_Profile then 14353 14354 -- Deadline parameter. If no Relative_Deadline pragma is present, 14355 -- then the deadline is Time_Span_Zero. If a pragma is present, then 14356 -- the deadline is taken from the _Relative_Deadline field of the 14357 -- task value record, which was set from the pragma value. Note that 14358 -- this parameter must not be generated for the restricted profiles 14359 -- since Ravenscar does not allow deadlines. 14360 14361 -- Case where pragma Relative_Deadline applies: use given value 14362 14363 if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then 14364 Append_To (Args, 14365 Make_Selected_Component (Loc, 14366 Prefix => Make_Identifier (Loc, Name_uInit), 14367 Selector_Name => 14368 Make_Identifier (Loc, Name_uRelative_Deadline))); 14369 14370 -- No pragma Relative_Deadline apply to the task 14371 14372 else 14373 Append_To (Args, 14374 New_Occurrence_Of (RTE (RE_Time_Span_Zero), Loc)); 14375 end if; 14376 14377 -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is 14378 -- present, then the dispatching domain is null. If a rep item is 14379 -- present, then the dispatching domain is taken from the 14380 -- _Dispatching_Domain field of the task value record, which was set 14381 -- from the rep item value. 14382 14383 -- Case where Dispatching_Domain rep item applies: use given value 14384 14385 if Has_Rep_Item 14386 (Ttyp, Name_Dispatching_Domain, Check_Parents => False) 14387 then 14388 Append_To (Args, 14389 Make_Selected_Component (Loc, 14390 Prefix => 14391 Make_Identifier (Loc, Name_uInit), 14392 Selector_Name => 14393 Make_Identifier (Loc, Name_uDispatching_Domain))); 14394 14395 -- No pragma or aspect Dispatching_Domain applies to the task 14396 14397 else 14398 Append_To (Args, Make_Null (Loc)); 14399 end if; 14400 14401 -- Number of entries. This is an expression of the form: 14402 14403 -- n + _Init.a'Length + _Init.a'B'Length + ... 14404 14405 -- where a,b... are the entry family names for the task definition 14406 14407 Ecount := 14408 Build_Entry_Count_Expression 14409 (Ttyp, 14410 Component_Items 14411 (Component_List 14412 (Type_Definition 14413 (Parent (Corresponding_Record_Type (Ttyp))))), 14414 Loc); 14415 Append_To (Args, Ecount); 14416 14417 -- Master parameter. This is a reference to the _Master parameter of 14418 -- the initialization procedure, except in the case of the pragma 14419 -- Restrictions (No_Task_Hierarchy) where the value is fixed to 14420 -- System.Tasking.Library_Task_Level. 14421 14422 if Restriction_Active (No_Task_Hierarchy) = False then 14423 Append_To (Args, Make_Identifier (Loc, Name_uMaster)); 14424 else 14425 Append_To (Args, 14426 New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc)); 14427 end if; 14428 end if; 14429 14430 -- State parameter. This is a pointer to the task body procedure. The 14431 -- required value is obtained by taking 'Unrestricted_Access of the task 14432 -- body procedure and converting it (with an unchecked conversion) to 14433 -- the type required by the task kernel. For further details, see the 14434 -- description of Expand_N_Task_Body. We use 'Unrestricted_Access rather 14435 -- than 'Address in order to avoid creating trampolines. 14436 14437 declare 14438 Body_Proc : constant Node_Id := Get_Task_Body_Procedure (Ttyp); 14439 Subp_Ptr_Typ : constant Node_Id := 14440 Create_Itype (E_Access_Subprogram_Type, Tdec); 14441 Ref : constant Node_Id := Make_Itype_Reference (Loc); 14442 14443 begin 14444 Set_Directly_Designated_Type (Subp_Ptr_Typ, Body_Proc); 14445 Set_Etype (Subp_Ptr_Typ, Subp_Ptr_Typ); 14446 14447 -- Be sure to freeze a reference to the access-to-subprogram type, 14448 -- otherwise gigi will complain that it's in the wrong scope, because 14449 -- it's actually inside the init procedure for the record type that 14450 -- corresponds to the task type. 14451 14452 Set_Itype (Ref, Subp_Ptr_Typ); 14453 Append_Freeze_Action (Task_Rec, Ref); 14454 14455 Append_To (Args, 14456 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), 14457 Make_Qualified_Expression (Loc, 14458 Subtype_Mark => New_Occurrence_Of (Subp_Ptr_Typ, Loc), 14459 Expression => 14460 Make_Attribute_Reference (Loc, 14461 Prefix => New_Occurrence_Of (Body_Proc, Loc), 14462 Attribute_Name => Name_Unrestricted_Access)))); 14463 end; 14464 14465 -- Discriminants parameter. This is just the address of the task 14466 -- value record itself (which contains the discriminant values 14467 14468 Append_To (Args, 14469 Make_Attribute_Reference (Loc, 14470 Prefix => Make_Identifier (Loc, Name_uInit), 14471 Attribute_Name => Name_Address)); 14472 14473 -- Elaborated parameter. This is an access to the elaboration Boolean 14474 14475 Append_To (Args, 14476 Make_Attribute_Reference (Loc, 14477 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')), 14478 Attribute_Name => Name_Unchecked_Access)); 14479 14480 -- Add Chain parameter (not done for sequential elaboration policy, see 14481 -- comment for Create_Restricted_Task_Sequential in s-tarest.ads). 14482 14483 if Partition_Elaboration_Policy /= 'S' then 14484 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 14485 end if; 14486 14487 -- Task name parameter. Take this from the _Task_Id parameter to the 14488 -- init call unless there is a Task_Name pragma, in which case we take 14489 -- the value from the pragma. 14490 14491 if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then 14492 -- Copy expression in full, because it may be dynamic and have 14493 -- side effects. 14494 14495 Append_To (Args, 14496 New_Copy_Tree 14497 (Expression 14498 (First 14499 (Pragma_Argument_Associations 14500 (Get_Rep_Pragma 14501 (Ttyp, Name_Task_Name, Check_Parents => False)))))); 14502 14503 else 14504 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); 14505 end if; 14506 14507 -- Created_Task parameter. This is the _Task_Id field of the task 14508 -- record value 14509 14510 Append_To (Args, 14511 Make_Selected_Component (Loc, 14512 Prefix => Make_Identifier (Loc, Name_uInit), 14513 Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); 14514 14515 declare 14516 Create_RE : RE_Id; 14517 14518 begin 14519 if Restricted_Profile then 14520 if Partition_Elaboration_Policy = 'S' then 14521 Create_RE := RE_Create_Restricted_Task_Sequential; 14522 else 14523 Create_RE := RE_Create_Restricted_Task; 14524 end if; 14525 else 14526 Create_RE := RE_Create_Task; 14527 end if; 14528 14529 Name := New_Occurrence_Of (RTE (Create_RE), Loc); 14530 end; 14531 14532 return 14533 Make_Procedure_Call_Statement (Loc, 14534 Name => Name, 14535 Parameter_Associations => Args); 14536 end Make_Task_Create_Call; 14537 14538 ------------------------------ 14539 -- Next_Protected_Operation -- 14540 ------------------------------ 14541 14542 function Next_Protected_Operation (N : Node_Id) return Node_Id is 14543 Next_Op : Node_Id; 14544 14545 begin 14546 -- Check whether there is a subsequent body for a protected operation 14547 -- in the current protected body. In Ada2012 that includes expression 14548 -- functions that are completions. 14549 14550 Next_Op := Next (N); 14551 while Present (Next_Op) 14552 and then not Nkind_In (Next_Op, 14553 N_Subprogram_Body, N_Entry_Body, N_Expression_Function) 14554 loop 14555 Next (Next_Op); 14556 end loop; 14557 14558 return Next_Op; 14559 end Next_Protected_Operation; 14560 14561 --------------------- 14562 -- Null_Statements -- 14563 --------------------- 14564 14565 function Null_Statements (Stats : List_Id) return Boolean is 14566 Stmt : Node_Id; 14567 14568 begin 14569 Stmt := First (Stats); 14570 while Nkind (Stmt) /= N_Empty 14571 and then (Nkind_In (Stmt, N_Null_Statement, N_Label) 14572 or else 14573 (Nkind (Stmt) = N_Pragma 14574 and then 14575 Nam_In (Pragma_Name (Stmt), Name_Unreferenced, 14576 Name_Unmodified, 14577 Name_Warnings))) 14578 loop 14579 Next (Stmt); 14580 end loop; 14581 14582 return Nkind (Stmt) = N_Empty; 14583 end Null_Statements; 14584 14585 -------------------------- 14586 -- Parameter_Block_Pack -- 14587 -------------------------- 14588 14589 function Parameter_Block_Pack 14590 (Loc : Source_Ptr; 14591 Blk_Typ : Entity_Id; 14592 Actuals : List_Id; 14593 Formals : List_Id; 14594 Decls : List_Id; 14595 Stmts : List_Id) return Node_Id 14596 is 14597 Actual : Entity_Id; 14598 Expr : Node_Id := Empty; 14599 Formal : Entity_Id; 14600 Has_Param : Boolean := False; 14601 P : Entity_Id; 14602 Params : List_Id; 14603 Temp_Asn : Node_Id; 14604 Temp_Nam : Node_Id; 14605 14606 begin 14607 Actual := First (Actuals); 14608 Formal := Defining_Identifier (First (Formals)); 14609 Params := New_List; 14610 while Present (Actual) loop 14611 if Is_By_Copy_Type (Etype (Actual)) then 14612 -- Generate: 14613 -- Jnn : aliased <formal-type> 14614 14615 Temp_Nam := Make_Temporary (Loc, 'J'); 14616 14617 Append_To (Decls, 14618 Make_Object_Declaration (Loc, 14619 Aliased_Present => True, 14620 Defining_Identifier => Temp_Nam, 14621 Object_Definition => 14622 New_Occurrence_Of (Etype (Formal), Loc))); 14623 14624 if Ekind (Formal) /= E_Out_Parameter then 14625 14626 -- Generate: 14627 -- Jnn := <actual> 14628 14629 Temp_Asn := 14630 New_Occurrence_Of (Temp_Nam, Loc); 14631 14632 Set_Assignment_OK (Temp_Asn); 14633 14634 Append_To (Stmts, 14635 Make_Assignment_Statement (Loc, 14636 Name => Temp_Asn, 14637 Expression => New_Copy_Tree (Actual))); 14638 end if; 14639 14640 -- Generate: 14641 -- Jnn'unchecked_access 14642 14643 Append_To (Params, 14644 Make_Attribute_Reference (Loc, 14645 Attribute_Name => Name_Unchecked_Access, 14646 Prefix => New_Occurrence_Of (Temp_Nam, Loc))); 14647 14648 Has_Param := True; 14649 14650 -- The controlling parameter is omitted 14651 14652 else 14653 if not Is_Controlling_Actual (Actual) then 14654 Append_To (Params, 14655 Make_Reference (Loc, New_Copy_Tree (Actual))); 14656 14657 Has_Param := True; 14658 end if; 14659 end if; 14660 14661 Next_Actual (Actual); 14662 Next_Formal_With_Extras (Formal); 14663 end loop; 14664 14665 if Has_Param then 14666 Expr := Make_Aggregate (Loc, Params); 14667 end if; 14668 14669 -- Generate: 14670 -- P : Ann := ( 14671 -- J1'unchecked_access; 14672 -- <actual2>'reference; 14673 -- ...); 14674 14675 P := Make_Temporary (Loc, 'P'); 14676 14677 Append_To (Decls, 14678 Make_Object_Declaration (Loc, 14679 Defining_Identifier => P, 14680 Object_Definition => New_Occurrence_Of (Blk_Typ, Loc), 14681 Expression => Expr)); 14682 14683 return P; 14684 end Parameter_Block_Pack; 14685 14686 ---------------------------- 14687 -- Parameter_Block_Unpack -- 14688 ---------------------------- 14689 14690 function Parameter_Block_Unpack 14691 (Loc : Source_Ptr; 14692 P : Entity_Id; 14693 Actuals : List_Id; 14694 Formals : List_Id) return List_Id 14695 is 14696 Actual : Entity_Id; 14697 Asnmt : Node_Id; 14698 Formal : Entity_Id; 14699 Has_Asnmt : Boolean := False; 14700 Result : constant List_Id := New_List; 14701 14702 begin 14703 Actual := First (Actuals); 14704 Formal := Defining_Identifier (First (Formals)); 14705 while Present (Actual) loop 14706 if Is_By_Copy_Type (Etype (Actual)) 14707 and then Ekind (Formal) /= E_In_Parameter 14708 then 14709 -- Generate: 14710 -- <actual> := P.<formal>; 14711 14712 Asnmt := 14713 Make_Assignment_Statement (Loc, 14714 Name => 14715 New_Copy (Actual), 14716 Expression => 14717 Make_Explicit_Dereference (Loc, 14718 Make_Selected_Component (Loc, 14719 Prefix => 14720 New_Occurrence_Of (P, Loc), 14721 Selector_Name => 14722 Make_Identifier (Loc, Chars (Formal))))); 14723 14724 Set_Assignment_OK (Name (Asnmt)); 14725 Append_To (Result, Asnmt); 14726 14727 Has_Asnmt := True; 14728 end if; 14729 14730 Next_Actual (Actual); 14731 Next_Formal_With_Extras (Formal); 14732 end loop; 14733 14734 if Has_Asnmt then 14735 return Result; 14736 else 14737 return New_List (Make_Null_Statement (Loc)); 14738 end if; 14739 end Parameter_Block_Unpack; 14740 14741 ---------------------- 14742 -- Set_Discriminals -- 14743 ---------------------- 14744 14745 procedure Set_Discriminals (Dec : Node_Id) is 14746 D : Entity_Id; 14747 Pdef : Entity_Id; 14748 D_Minal : Entity_Id; 14749 14750 begin 14751 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); 14752 Pdef := Defining_Identifier (Dec); 14753 14754 if Has_Discriminants (Pdef) then 14755 D := First_Discriminant (Pdef); 14756 while Present (D) loop 14757 D_Minal := 14758 Make_Defining_Identifier (Sloc (D), 14759 Chars => New_External_Name (Chars (D), 'D')); 14760 14761 Set_Ekind (D_Minal, E_Constant); 14762 Set_Etype (D_Minal, Etype (D)); 14763 Set_Scope (D_Minal, Pdef); 14764 Set_Discriminal (D, D_Minal); 14765 Set_Discriminal_Link (D_Minal, D); 14766 14767 Next_Discriminant (D); 14768 end loop; 14769 end if; 14770 end Set_Discriminals; 14771 14772 ----------------------- 14773 -- Trivial_Accept_OK -- 14774 ----------------------- 14775 14776 function Trivial_Accept_OK return Boolean is 14777 begin 14778 case Opt.Task_Dispatching_Policy is 14779 14780 -- If we have the default task dispatching policy in effect, we can 14781 -- definitely do the optimization (one way of looking at this is to 14782 -- think of the formal definition of the default policy being allowed 14783 -- to run any task it likes after a rendezvous, so even if notionally 14784 -- a full rescheduling occurs, we can say that our dispatching policy 14785 -- (i.e. the default dispatching policy) reorders the queue to be the 14786 -- same as just before the call. 14787 14788 when ' ' => 14789 return True; 14790 14791 -- FIFO_Within_Priorities certainly does not permit this 14792 -- optimization since the Rendezvous is a scheduling action that may 14793 -- require some other task to be run. 14794 14795 when 'F' => 14796 return False; 14797 14798 -- For now, disallow the optimization for all other policies. This 14799 -- may be over-conservative, but it is certainly not incorrect. 14800 14801 when others => 14802 return False; 14803 14804 end case; 14805 end Trivial_Accept_OK; 14806 14807end Exp_Ch9; 14808