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