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-2004, 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Checks; use Checks; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Ch3; use Exp_Ch3; 33with Exp_Ch11; use Exp_Ch11; 34with Exp_Ch6; use Exp_Ch6; 35with Exp_Dbug; use Exp_Dbug; 36with Exp_Smem; use Exp_Smem; 37with Exp_Tss; use Exp_Tss; 38with Exp_Util; use Exp_Util; 39with Freeze; use Freeze; 40with Hostparm; 41with Namet; use Namet; 42with Nlists; use Nlists; 43with Nmake; use Nmake; 44with Opt; use Opt; 45with Restrict; use Restrict; 46with Rtsfind; use Rtsfind; 47with Sem; use Sem; 48with Sem_Ch6; 49with Sem_Ch8; use Sem_Ch8; 50with Sem_Ch11; use Sem_Ch11; 51with Sem_Elab; use Sem_Elab; 52with Sem_Res; use Sem_Res; 53with Sem_Util; use Sem_Util; 54with Sinfo; use Sinfo; 55with Snames; use Snames; 56with Stand; use Stand; 57with Tbuild; use Tbuild; 58with Types; use Types; 59with Uintp; use Uintp; 60with Opt; 61 62package body Exp_Ch9 is 63 64 ----------------------- 65 -- Local Subprograms -- 66 ----------------------- 67 68 function Actual_Index_Expression 69 (Sloc : Source_Ptr; 70 Ent : Entity_Id; 71 Index : Node_Id; 72 Tsk : Entity_Id) return Node_Id; 73 -- Compute the index position for an entry call. Tsk is the target 74 -- task. If the bounds of some entry family depend on discriminants, 75 -- the expression computed by this function uses the discriminants 76 -- of the target task. 77 78 function Index_Constant_Declaration 79 (N : Node_Id; 80 Index_Id : Entity_Id; 81 Prot : Entity_Id) return List_Id; 82 -- For an entry family and its barrier function, we define a local entity 83 -- that maps the index in the call into the entry index into the object: 84 -- 85 -- I : constant Index_Type := Index_Type'Val ( 86 -- E - <<index of first family member>> + 87 -- Protected_Entry_Index (Index_Type'Pos (Index_Type'First))); 88 89 procedure Add_Object_Pointer 90 (Decls : List_Id; 91 Pid : Entity_Id; 92 Loc : Source_Ptr); 93 -- Prepend an object pointer declaration to the declaration list 94 -- Decls. This object pointer is initialized to a type conversion 95 -- of the System.Address pointer passed to entry barrier functions 96 -- and entry body procedures. 97 98 function Build_Accept_Body (Astat : Node_Id) return Node_Id; 99 -- Transform accept statement into a block with added exception handler. 100 -- Used both for simple accept statements and for accept alternatives in 101 -- select statements. Astat is the accept statement. 102 103 function Build_Barrier_Function 104 (N : Node_Id; 105 Ent : Entity_Id; 106 Pid : Node_Id) return Node_Id; 107 -- Build the function body returning the value of the barrier expression 108 -- for the specified entry body. 109 110 function Build_Barrier_Function_Specification 111 (Def_Id : Entity_Id; 112 Loc : Source_Ptr) return Node_Id; 113 -- Build a specification for a function implementing 114 -- the protected entry barrier of the specified entry body. 115 116 function Build_Corresponding_Record 117 (N : Node_Id; 118 Ctyp : Node_Id; 119 Loc : Source_Ptr) return Node_Id; 120 -- Common to tasks and protected types. Copy discriminant specifications, 121 -- build record declaration. N is the type declaration, Ctyp is the 122 -- concurrent entity (task type or protected type). 123 124 function Build_Entry_Count_Expression 125 (Concurrent_Type : Node_Id; 126 Component_List : List_Id; 127 Loc : Source_Ptr) return Node_Id; 128 -- Compute number of entries for concurrent object. This is a count of 129 -- simple entries, followed by an expression that computes the length 130 -- of the range of each entry family. A single array with that size is 131 -- allocated for each concurrent object of the type. 132 133 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; 134 -- Build the function that translates the entry index in the call 135 -- (which depends on the size of entry families) into an index into the 136 -- Entry_Bodies_Array, to determine the body and barrier function used 137 -- in a protected entry call. A pointer to this function appears in every 138 -- protected object. 139 140 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id; 141 -- Build subprogram declaration for previous one 142 143 function Build_Protected_Entry 144 (N : Node_Id; 145 Ent : Entity_Id; 146 Pid : Node_Id) return Node_Id; 147 -- Build the procedure implementing the statement sequence of 148 -- the specified entry body. 149 150 function Build_Protected_Entry_Specification 151 (Def_Id : Entity_Id; 152 Ent_Id : Entity_Id; 153 Loc : Source_Ptr) return Node_Id; 154 -- Build a specification for a procedure implementing 155 -- the statement sequence of the specified entry body. 156 -- Add attributes associating it with the entry defining identifier 157 -- Ent_Id. 158 159 function Build_Protected_Subprogram_Body 160 (N : Node_Id; 161 Pid : Node_Id; 162 N_Op_Spec : Node_Id) return Node_Id; 163 -- This function is used to construct the protected version of a protected 164 -- subprogram. Its statement sequence first defers abortion, then locks 165 -- the associated protected object, and then enters a block that contains 166 -- a call to the unprotected version of the subprogram (for details, see 167 -- Build_Unprotected_Subprogram_Body). This block statement requires 168 -- a cleanup handler that unlocks the object in all cases. 169 -- (see Exp_Ch7.Expand_Cleanup_Actions). 170 171 function Build_Protected_Spec 172 (N : Node_Id; 173 Obj_Type : Entity_Id; 174 Unprotected : Boolean := False; 175 Ident : Entity_Id) return List_Id; 176 -- Utility shared by Build_Protected_Sub_Spec and Expand_Access_Protected_ 177 -- Subprogram_Type. Builds signature of protected subprogram, adding the 178 -- formal that corresponds to the object itself. For an access to protected 179 -- subprogram, there is no object type to specify, so the additional 180 -- parameter has type Address and mode In. An indirect call through such 181 -- a pointer converts the address to a reference to the actual object. 182 -- The object is a limited record and therefore a by_reference type. 183 184 function Build_Selected_Name 185 (Prefix, Selector : Name_Id; 186 Append_Char : Character := ' ') return Name_Id; 187 -- Build a name in the form of Prefix__Selector, with an optional 188 -- character appended. This is used for internal subprograms generated 189 -- for operations of protected types, including barrier functions. In 190 -- order to simplify the work of the debugger, the prefix includes the 191 -- characters PT. For the subprograms generated for entry bodies and 192 -- entry barriers, the generated name includes a sequence number that 193 -- makes names unique in the presence of entry overloading. This is 194 -- necessary because entry body procedures and barrier functions all 195 -- have the same signature. 196 197 procedure Build_Simple_Entry_Call 198 (N : Node_Id; 199 Concval : Node_Id; 200 Ename : Node_Id; 201 Index : Node_Id); 202 -- Some comments here would be useful ??? 203 204 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id; 205 -- This routine constructs a specification for the procedure that we will 206 -- build for the task body for task type T. The spec has the form: 207 -- 208 -- procedure tnameB (_Task : access tnameV); 209 -- 210 -- where name is the character name taken from the task type entity that 211 -- is passed as the argument to the procedure, and tnameV is the task 212 -- value type that is associated with the task type. 213 214 function Build_Unprotected_Subprogram_Body 215 (N : Node_Id; 216 Pid : Node_Id) return Node_Id; 217 -- This routine constructs the unprotected version of a protected 218 -- subprogram body, which is contains all of the code in the 219 -- original, unexpanded body. This is the version of the protected 220 -- subprogram that is called from all protected operations on the same 221 -- object, including the protected version of the same subprogram. 222 223 procedure Collect_Entry_Families 224 (Loc : Source_Ptr; 225 Cdecls : List_Id; 226 Current_Node : in out Node_Id; 227 Conctyp : Entity_Id); 228 -- For each entry family in a concurrent type, create an anonymous array 229 -- type of the right size, and add a component to the corresponding_record. 230 231 function Family_Offset 232 (Loc : Source_Ptr; 233 Hi : Node_Id; 234 Lo : Node_Id; 235 Ttyp : Entity_Id) return Node_Id; 236 -- Compute (Hi - Lo) for two entry family indices. Hi is the index in 237 -- an accept statement, or the upper bound in the discrete subtype of 238 -- an entry declaration. Lo is the corresponding lower bound. Ttyp is 239 -- the concurrent type of the entry. 240 241 function Family_Size 242 (Loc : Source_Ptr; 243 Hi : Node_Id; 244 Lo : Node_Id; 245 Ttyp : Entity_Id) return Node_Id; 246 -- Compute (Hi - Lo) + 1 Max 0, to determine the number of entries in 247 -- a family, and handle properly the superflat case. This is equivalent 248 -- to the use of 'Length on the index type, but must use Family_Offset 249 -- to handle properly the case of bounds that depend on discriminants. 250 251 procedure Extract_Entry 252 (N : Node_Id; 253 Concval : out Node_Id; 254 Ename : out Node_Id; 255 Index : out Node_Id); 256 -- Given an entry call, returns the associated concurrent object, 257 -- the entry name, and the entry family index. 258 259 function Find_Task_Or_Protected_Pragma 260 (T : Node_Id; 261 P : Name_Id) return Node_Id; 262 -- Searches the task or protected definition T for the first occurrence 263 -- of the pragma whose name is given by P. The caller has ensured that 264 -- the pragma is present in the task definition. A special case is that 265 -- when P is Name_uPriority, the call will also find Interrupt_Priority. 266 -- ??? Should be implemented with the rep item chain mechanism. 267 268 procedure Update_Prival_Subtypes (N : Node_Id); 269 -- The actual subtypes of the privals will differ from the type of the 270 -- private declaration in the original protected type, if the protected 271 -- type has discriminants or if the prival has constrained components. 272 -- This is because the privals are generated out of sequence w.r.t. the 273 -- analysis of a protected body. After generating the bodies for protected 274 -- operations, we set correctly the type of all references to privals, by 275 -- means of a recursive tree traversal, which is heavy-handed but 276 -- correct. 277 278 ----------------------------- 279 -- Actual_Index_Expression -- 280 ----------------------------- 281 282 function Actual_Index_Expression 283 (Sloc : Source_Ptr; 284 Ent : Entity_Id; 285 Index : Node_Id; 286 Tsk : Entity_Id) return Node_Id 287 is 288 Ttyp : constant Entity_Id := Etype (Tsk); 289 Expr : Node_Id; 290 Num : Node_Id; 291 Lo : Node_Id; 292 Hi : Node_Id; 293 Prev : Entity_Id; 294 S : Node_Id; 295 296 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id; 297 -- Compute difference between bounds of entry family. 298 299 -------------------------- 300 -- Actual_Family_Offset -- 301 -------------------------- 302 303 function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is 304 305 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; 306 -- Replace a reference to a discriminant with a selected component 307 -- denoting the discriminant of the target task. 308 309 ----------------------------- 310 -- Actual_Discriminant_Ref -- 311 ----------------------------- 312 313 function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is 314 Typ : constant Entity_Id := Etype (Bound); 315 B : Node_Id; 316 317 begin 318 if not Is_Entity_Name (Bound) 319 or else Ekind (Entity (Bound)) /= E_Discriminant 320 then 321 if Nkind (Bound) = N_Attribute_Reference then 322 return Bound; 323 else 324 B := New_Copy_Tree (Bound); 325 end if; 326 327 else 328 B := 329 Make_Selected_Component (Sloc, 330 Prefix => New_Copy_Tree (Tsk), 331 Selector_Name => New_Occurrence_Of (Entity (Bound), Sloc)); 332 333 Analyze_And_Resolve (B, Typ); 334 end if; 335 336 return 337 Make_Attribute_Reference (Sloc, 338 Attribute_Name => Name_Pos, 339 Prefix => New_Occurrence_Of (Etype (Bound), Sloc), 340 Expressions => New_List (B)); 341 end Actual_Discriminant_Ref; 342 343 -- Start of processing for Actual_Family_Offset 344 345 begin 346 return 347 Make_Op_Subtract (Sloc, 348 Left_Opnd => Actual_Discriminant_Ref (Hi), 349 Right_Opnd => Actual_Discriminant_Ref (Lo)); 350 end Actual_Family_Offset; 351 352 -- Start of processing for Actual_Index_Expression 353 354 begin 355 -- The queues of entries and entry families appear in textual 356 -- order in the associated record. The entry index is computed as 357 -- the sum of the number of queues for all entries that precede the 358 -- designated one, to which is added the index expression, if this 359 -- expression denotes a member of a family. 360 361 -- The following is a place holder for the count of simple entries. 362 363 Num := Make_Integer_Literal (Sloc, 1); 364 365 -- We construct an expression which is a series of addition 366 -- operations. See comments in Entry_Index_Expression, which is 367 -- identical in structure. 368 369 if Present (Index) then 370 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); 371 372 Expr := 373 Make_Op_Add (Sloc, 374 Left_Opnd => Num, 375 376 Right_Opnd => 377 Actual_Family_Offset ( 378 Make_Attribute_Reference (Sloc, 379 Attribute_Name => Name_Pos, 380 Prefix => New_Reference_To (Base_Type (S), Sloc), 381 Expressions => New_List (Relocate_Node (Index))), 382 Type_Low_Bound (S))); 383 else 384 Expr := Num; 385 end if; 386 387 -- Now add lengths of preceding entries and entry families. 388 389 Prev := First_Entity (Ttyp); 390 391 while Chars (Prev) /= Chars (Ent) 392 or else (Ekind (Prev) /= Ekind (Ent)) 393 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 394 loop 395 if Ekind (Prev) = E_Entry then 396 Set_Intval (Num, Intval (Num) + 1); 397 398 elsif Ekind (Prev) = E_Entry_Family then 399 S := 400 Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); 401 Lo := Type_Low_Bound (S); 402 Hi := Type_High_Bound (S); 403 404 Expr := 405 Make_Op_Add (Sloc, 406 Left_Opnd => Expr, 407 Right_Opnd => 408 Make_Op_Add (Sloc, 409 Left_Opnd => 410 Actual_Family_Offset (Hi, Lo), 411 Right_Opnd => 412 Make_Integer_Literal (Sloc, 1))); 413 414 -- Other components are anonymous types to be ignored. 415 416 else 417 null; 418 end if; 419 420 Next_Entity (Prev); 421 end loop; 422 423 return Expr; 424 end Actual_Index_Expression; 425 426 ---------------------------------- 427 -- Add_Discriminal_Declarations -- 428 ---------------------------------- 429 430 procedure Add_Discriminal_Declarations 431 (Decls : List_Id; 432 Typ : Entity_Id; 433 Name : Name_Id; 434 Loc : Source_Ptr) 435 is 436 D : Entity_Id; 437 438 begin 439 if Has_Discriminants (Typ) then 440 D := First_Discriminant (Typ); 441 442 while Present (D) loop 443 444 Prepend_To (Decls, 445 Make_Object_Renaming_Declaration (Loc, 446 Defining_Identifier => Discriminal (D), 447 Subtype_Mark => New_Reference_To (Etype (D), Loc), 448 Name => 449 Make_Selected_Component (Loc, 450 Prefix => Make_Identifier (Loc, Name), 451 Selector_Name => Make_Identifier (Loc, Chars (D))))); 452 453 Next_Discriminant (D); 454 end loop; 455 end if; 456 end Add_Discriminal_Declarations; 457 458 ------------------------ 459 -- Add_Object_Pointer -- 460 ------------------------ 461 462 procedure Add_Object_Pointer 463 (Decls : List_Id; 464 Pid : Entity_Id; 465 Loc : Source_Ptr) 466 is 467 Obj_Ptr : Node_Id; 468 469 begin 470 -- Prepend the declaration of _object. This must be first in the 471 -- declaration list, since it is used by the discriminal and 472 -- prival declarations. 473 -- ??? An attempt to make this a renaming was unsuccessful. 474 -- 475 -- type poVP is access poV; 476 -- _object : poVP := poVP!O; 477 478 Obj_Ptr := 479 Make_Defining_Identifier (Loc, 480 Chars => 481 New_External_Name 482 (Chars (Corresponding_Record_Type (Pid)), 'P')); 483 484 Prepend_To (Decls, 485 Make_Object_Declaration (Loc, 486 Defining_Identifier => 487 Make_Defining_Identifier (Loc, Name_uObject), 488 Object_Definition => New_Reference_To (Obj_Ptr, Loc), 489 Expression => 490 Unchecked_Convert_To (Obj_Ptr, 491 Make_Identifier (Loc, Name_uO)))); 492 493 Prepend_To (Decls, 494 Make_Full_Type_Declaration (Loc, 495 Defining_Identifier => Obj_Ptr, 496 Type_Definition => Make_Access_To_Object_Definition (Loc, 497 Subtype_Indication => 498 New_Reference_To (Corresponding_Record_Type (Pid), Loc)))); 499 end Add_Object_Pointer; 500 501 ------------------------------ 502 -- Add_Private_Declarations -- 503 ------------------------------ 504 505 procedure Add_Private_Declarations 506 (Decls : List_Id; 507 Typ : Entity_Id; 508 Name : Name_Id; 509 Loc : Source_Ptr) 510 is 511 Def : constant Node_Id := Protected_Definition (Parent (Typ)); 512 Body_Ent : constant Entity_Id := Corresponding_Body (Parent (Typ)); 513 P : Node_Id; 514 Pdef : Entity_Id; 515 516 begin 517 pragma Assert (Nkind (Def) = N_Protected_Definition); 518 519 if Present (Private_Declarations (Def)) then 520 P := First (Private_Declarations (Def)); 521 522 while Present (P) loop 523 if Nkind (P) = N_Component_Declaration then 524 Pdef := Defining_Identifier (P); 525 Prepend_To (Decls, 526 Make_Object_Renaming_Declaration (Loc, 527 Defining_Identifier => Prival (Pdef), 528 Subtype_Mark => New_Reference_To (Etype (Pdef), Loc), 529 Name => 530 Make_Selected_Component (Loc, 531 Prefix => Make_Identifier (Loc, Name), 532 Selector_Name => Make_Identifier (Loc, Chars (Pdef))))); 533 end if; 534 Next (P); 535 end loop; 536 end if; 537 538 -- One more "prival" for the object itself, with the right protection 539 -- type. 540 541 declare 542 Protection_Type : RE_Id; 543 begin 544 if Has_Attach_Handler (Typ) then 545 if Restricted_Profile then 546 if Has_Entries (Typ) then 547 Protection_Type := RE_Protection_Entry; 548 else 549 Protection_Type := RE_Protection; 550 end if; 551 else 552 Protection_Type := RE_Static_Interrupt_Protection; 553 end if; 554 555 elsif Has_Interrupt_Handler (Typ) then 556 Protection_Type := RE_Dynamic_Interrupt_Protection; 557 558 elsif Has_Entries (Typ) then 559 if Abort_Allowed 560 or else Restrictions (No_Entry_Queue) = False 561 or else Number_Entries (Typ) > 1 562 then 563 Protection_Type := RE_Protection_Entries; 564 else 565 Protection_Type := RE_Protection_Entry; 566 end if; 567 568 else 569 Protection_Type := RE_Protection; 570 end if; 571 572 Prepend_To (Decls, 573 Make_Object_Renaming_Declaration (Loc, 574 Defining_Identifier => Object_Ref (Body_Ent), 575 Subtype_Mark => New_Reference_To (RTE (Protection_Type), Loc), 576 Name => 577 Make_Selected_Component (Loc, 578 Prefix => Make_Identifier (Loc, Name), 579 Selector_Name => Make_Identifier (Loc, Name_uObject)))); 580 end; 581 end Add_Private_Declarations; 582 583 ----------------------- 584 -- Build_Accept_Body -- 585 ----------------------- 586 587 function Build_Accept_Body (Astat : Node_Id) return Node_Id is 588 Loc : constant Source_Ptr := Sloc (Astat); 589 Stats : constant Node_Id := Handled_Statement_Sequence (Astat); 590 New_S : Node_Id; 591 Hand : Node_Id; 592 Call : Node_Id; 593 Ohandle : Node_Id; 594 595 begin 596 -- At the end of the statement sequence, Complete_Rendezvous is called. 597 -- A label skipping the Complete_Rendezvous, and all other 598 -- accept processing, has already been added for the expansion 599 -- of requeue statements. 600 601 Call := Build_Runtime_Call (Loc, RE_Complete_Rendezvous); 602 Insert_Before (Last (Statements (Stats)), Call); 603 Analyze (Call); 604 605 -- If exception handlers are present, then append Complete_Rendezvous 606 -- calls to the handlers, and construct the required outer block. 607 608 if Present (Exception_Handlers (Stats)) then 609 Hand := First (Exception_Handlers (Stats)); 610 611 while Present (Hand) loop 612 Call := Build_Runtime_Call (Loc, RE_Complete_Rendezvous); 613 Append (Call, Statements (Hand)); 614 Analyze (Call); 615 Next (Hand); 616 end loop; 617 618 New_S := 619 Make_Handled_Sequence_Of_Statements (Loc, 620 Statements => New_List ( 621 Make_Block_Statement (Loc, 622 Handled_Statement_Sequence => Stats))); 623 624 else 625 New_S := Stats; 626 end if; 627 628 -- At this stage we know that the new statement sequence does not 629 -- have an exception handler part, so we supply one to call 630 -- Exceptional_Complete_Rendezvous. This handler is 631 632 -- when all others => 633 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 634 635 -- We handle Abort_Signal to make sure that we properly catch the abort 636 -- case and wake up the caller. 637 638 Ohandle := Make_Others_Choice (Loc); 639 Set_All_Others (Ohandle); 640 641 Set_Exception_Handlers (New_S, 642 New_List ( 643 Make_Exception_Handler (Loc, 644 Exception_Choices => New_List (Ohandle), 645 646 Statements => New_List ( 647 Make_Procedure_Call_Statement (Loc, 648 Name => New_Reference_To ( 649 RTE (RE_Exceptional_Complete_Rendezvous), Loc), 650 Parameter_Associations => New_List ( 651 Make_Function_Call (Loc, 652 Name => New_Reference_To ( 653 RTE (RE_Get_GNAT_Exception), Loc)))))))); 654 655 Set_Parent (New_S, Astat); -- temp parent for Analyze call 656 Analyze_Exception_Handlers (Exception_Handlers (New_S)); 657 Expand_Exception_Handlers (New_S); 658 659 -- Exceptional_Complete_Rendezvous must be called with abort 660 -- still deferred, which is the case for a "when all others" handler. 661 662 return New_S; 663 end Build_Accept_Body; 664 665 ----------------------------------- 666 -- Build_Activation_Chain_Entity -- 667 ----------------------------------- 668 669 procedure Build_Activation_Chain_Entity (N : Node_Id) is 670 P : Node_Id; 671 B : Node_Id; 672 Decls : List_Id; 673 674 begin 675 -- Loop to find enclosing construct containing activation chain variable 676 677 P := Parent (N); 678 679 while Nkind (P) /= N_Subprogram_Body 680 and then Nkind (P) /= N_Package_Declaration 681 and then Nkind (P) /= N_Package_Body 682 and then Nkind (P) /= N_Block_Statement 683 and then Nkind (P) /= N_Task_Body 684 loop 685 P := Parent (P); 686 end loop; 687 688 -- If we are in a package body, the activation chain variable is 689 -- allocated in the corresponding spec. First, we save the package 690 -- body node because we enter the new entity in its Declarations list. 691 692 B := P; 693 694 if Nkind (P) = N_Package_Body then 695 P := Unit_Declaration_Node (Corresponding_Spec (P)); 696 Decls := Declarations (B); 697 698 elsif Nkind (P) = N_Package_Declaration then 699 Decls := Visible_Declarations (Specification (B)); 700 701 else 702 Decls := Declarations (B); 703 end if; 704 705 -- If activation chain entity not already declared, declare it 706 707 if No (Activation_Chain_Entity (P)) then 708 Set_Activation_Chain_Entity 709 (P, Make_Defining_Identifier (Sloc (N), Name_uChain)); 710 711 Prepend_To (Decls, 712 Make_Object_Declaration (Sloc (P), 713 Defining_Identifier => Activation_Chain_Entity (P), 714 Aliased_Present => True, 715 Object_Definition => 716 New_Reference_To (RTE (RE_Activation_Chain), Sloc (P)))); 717 718 Analyze (First (Decls)); 719 end if; 720 end Build_Activation_Chain_Entity; 721 722 ---------------------------- 723 -- Build_Barrier_Function -- 724 ---------------------------- 725 726 function Build_Barrier_Function 727 (N : Node_Id; 728 Ent : Entity_Id; 729 Pid : Node_Id) return Node_Id 730 is 731 Loc : constant Source_Ptr := Sloc (N); 732 Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); 733 Index_Spec : constant Node_Id := Entry_Index_Specification 734 (Ent_Formals); 735 Op_Decls : constant List_Id := New_List; 736 Bdef : Entity_Id; 737 Bspec : Node_Id; 738 739 begin 740 Bdef := 741 Make_Defining_Identifier (Loc, Chars (Barrier_Function (Ent))); 742 Bspec := Build_Barrier_Function_Specification (Bdef, Loc); 743 744 -- <object pointer declaration> 745 -- <discriminant renamings> 746 -- <private object renamings> 747 -- Add discriminal and private renamings. These names have 748 -- already been used to expand references to discriminants 749 -- and private data. 750 751 Add_Discriminal_Declarations (Op_Decls, Pid, Name_uObject, Loc); 752 Add_Private_Declarations (Op_Decls, Pid, Name_uObject, Loc); 753 Add_Object_Pointer (Op_Decls, Pid, Loc); 754 755 -- If this is the barrier for an entry family, the entry index is 756 -- visible in the body of the barrier. Create a local variable that 757 -- converts the entry index (which is the last formal of the barrier 758 -- function) into the appropriate offset into the entry array. The 759 -- entry index constant must be set, as for the entry body, so that 760 -- local references to the entry index are correctly replaced with 761 -- the local variable. This parallels what is done for entry bodies. 762 763 if Present (Index_Spec) then 764 declare 765 Index_Id : constant Entity_Id := Defining_Identifier (Index_Spec); 766 Index_Con : constant Entity_Id := 767 Make_Defining_Identifier (Loc, 768 Chars => New_Internal_Name ('J')); 769 770 begin 771 Set_Entry_Index_Constant (Index_Id, Index_Con); 772 Append_List_To (Op_Decls, 773 Index_Constant_Declaration (N, Index_Id, Pid)); 774 end; 775 end if; 776 777 -- Note: the condition in the barrier function needs to be properly 778 -- processed for the C/Fortran boolean possibility, but this happens 779 -- automatically since the return statement does this normalization. 780 781 return 782 Make_Subprogram_Body (Loc, 783 Specification => Bspec, 784 Declarations => Op_Decls, 785 Handled_Statement_Sequence => 786 Make_Handled_Sequence_Of_Statements (Loc, 787 Statements => New_List ( 788 Make_Return_Statement (Loc, 789 Expression => Condition (Ent_Formals))))); 790 end Build_Barrier_Function; 791 792 ------------------------------------------ 793 -- Build_Barrier_Function_Specification -- 794 ------------------------------------------ 795 796 function Build_Barrier_Function_Specification 797 (Def_Id : Entity_Id; 798 Loc : Source_Ptr) return Node_Id 799 is 800 begin 801 return Make_Function_Specification (Loc, 802 Defining_Unit_Name => Def_Id, 803 Parameter_Specifications => New_List ( 804 Make_Parameter_Specification (Loc, 805 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), 806 Parameter_Type => 807 New_Reference_To (RTE (RE_Address), Loc)), 808 809 Make_Parameter_Specification (Loc, 810 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE), 811 Parameter_Type => 812 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), 813 814 Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)); 815 end Build_Barrier_Function_Specification; 816 817 -------------------------- 818 -- Build_Call_With_Task -- 819 -------------------------- 820 821 function Build_Call_With_Task 822 (N : Node_Id; 823 E : Entity_Id) return Node_Id 824 is 825 Loc : constant Source_Ptr := Sloc (N); 826 827 begin 828 return 829 Make_Function_Call (Loc, 830 Name => New_Reference_To (E, Loc), 831 Parameter_Associations => New_List (Concurrent_Ref (N))); 832 end Build_Call_With_Task; 833 834 -------------------------------- 835 -- Build_Corresponding_Record -- 836 -------------------------------- 837 838 function Build_Corresponding_Record 839 (N : Node_Id; 840 Ctyp : Entity_Id; 841 Loc : Source_Ptr) return Node_Id 842 is 843 Rec_Ent : constant Entity_Id := 844 Make_Defining_Identifier 845 (Loc, New_External_Name (Chars (Ctyp), 'V')); 846 Disc : Entity_Id; 847 Dlist : List_Id; 848 New_Disc : Entity_Id; 849 Cdecls : List_Id; 850 851 begin 852 Set_Corresponding_Record_Type (Ctyp, Rec_Ent); 853 Set_Ekind (Rec_Ent, E_Record_Type); 854 Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp)); 855 Set_Is_Concurrent_Record_Type (Rec_Ent, True); 856 Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp); 857 Set_Stored_Constraint (Rec_Ent, No_Elist); 858 Cdecls := New_List; 859 860 -- Use discriminals to create list of discriminants for record, and 861 -- create new discriminals for use in default expressions, etc. It is 862 -- worth noting that a task discriminant gives rise to 5 entities; 863 864 -- a) The original discriminant. 865 -- b) The discriminal for use in the task. 866 -- c) The discriminant of the corresponding record. 867 -- d) The discriminal for the init proc of the corresponding record. 868 -- e) The local variable that renames the discriminant in the procedure 869 -- for the task body. 870 871 -- In fact the discriminals b) are used in the renaming declarations 872 -- for e). See details in einfo (Handling of Discriminants). 873 874 if Present (Discriminant_Specifications (N)) then 875 Dlist := New_List; 876 Disc := First_Discriminant (Ctyp); 877 878 while Present (Disc) loop 879 New_Disc := CR_Discriminant (Disc); 880 881 Append_To (Dlist, 882 Make_Discriminant_Specification (Loc, 883 Defining_Identifier => New_Disc, 884 Discriminant_Type => 885 New_Occurrence_Of (Etype (Disc), Loc), 886 Expression => 887 New_Copy (Discriminant_Default_Value (Disc)))); 888 889 Next_Discriminant (Disc); 890 end loop; 891 892 else 893 Dlist := No_List; 894 end if; 895 896 -- Now we can construct the record type declaration. Note that this 897 -- record is limited, reflecting the underlying limitedness of the 898 -- task or protected object that it represents, and ensuring for 899 -- example that it is properly passed by reference. 900 901 return 902 Make_Full_Type_Declaration (Loc, 903 Defining_Identifier => Rec_Ent, 904 Discriminant_Specifications => Dlist, 905 Type_Definition => 906 Make_Record_Definition (Loc, 907 Component_List => 908 Make_Component_List (Loc, 909 Component_Items => Cdecls), 910 Limited_Present => True)); 911 end Build_Corresponding_Record; 912 913 ---------------------------------- 914 -- Build_Entry_Count_Expression -- 915 ---------------------------------- 916 917 function Build_Entry_Count_Expression 918 (Concurrent_Type : Node_Id; 919 Component_List : List_Id; 920 Loc : Source_Ptr) return Node_Id 921 is 922 Eindx : Nat; 923 Ent : Entity_Id; 924 Ecount : Node_Id; 925 Comp : Node_Id; 926 Lo : Node_Id; 927 Hi : Node_Id; 928 Typ : Entity_Id; 929 930 begin 931 Ent := First_Entity (Concurrent_Type); 932 Eindx := 0; 933 934 -- Count number of non-family entries 935 936 while Present (Ent) loop 937 if Ekind (Ent) = E_Entry then 938 Eindx := Eindx + 1; 939 end if; 940 941 Next_Entity (Ent); 942 end loop; 943 944 Ecount := Make_Integer_Literal (Loc, Eindx); 945 946 -- Loop through entry families building the addition nodes 947 948 Ent := First_Entity (Concurrent_Type); 949 Comp := First (Component_List); 950 951 while Present (Ent) loop 952 if Ekind (Ent) = E_Entry_Family then 953 while Chars (Ent) /= Chars (Defining_Identifier (Comp)) loop 954 Next (Comp); 955 end loop; 956 957 Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); 958 Hi := Type_High_Bound (Typ); 959 Lo := Type_Low_Bound (Typ); 960 961 Ecount := 962 Make_Op_Add (Loc, 963 Left_Opnd => Ecount, 964 Right_Opnd => Family_Size (Loc, Hi, Lo, Concurrent_Type)); 965 end if; 966 967 Next_Entity (Ent); 968 end loop; 969 970 return Ecount; 971 end Build_Entry_Count_Expression; 972 973 --------------------------- 974 -- Build_Find_Body_Index -- 975 --------------------------- 976 977 function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id is 978 Loc : constant Source_Ptr := Sloc (Typ); 979 Ent : Entity_Id; 980 E_Typ : Entity_Id; 981 Has_F : Boolean := False; 982 Index : Nat; 983 If_St : Node_Id := Empty; 984 Lo : Node_Id; 985 Hi : Node_Id; 986 Decls : List_Id := New_List; 987 Ret : Node_Id; 988 Spec : Node_Id; 989 Siz : Node_Id := Empty; 990 991 procedure Add_If_Clause (Expr : Node_Id); 992 -- Add test for range of current entry. 993 994 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 995 -- If a bound of an entry is given by a discriminant, retrieve the 996 -- actual value of the discriminant from the enclosing object. 997 998 ------------------- 999 -- Add_If_Clause -- 1000 ------------------- 1001 1002 procedure Add_If_Clause (Expr : Node_Id) is 1003 Cond : Node_Id; 1004 Stats : constant List_Id := 1005 New_List ( 1006 Make_Return_Statement (Loc, 1007 Expression => Make_Integer_Literal (Loc, Index + 1))); 1008 1009 begin 1010 -- Index for current entry body. 1011 1012 Index := Index + 1; 1013 1014 -- Compute total length of entry queues so far. 1015 1016 if No (Siz) then 1017 Siz := Expr; 1018 else 1019 Siz := 1020 Make_Op_Add (Loc, 1021 Left_Opnd => Siz, 1022 Right_Opnd => Expr); 1023 end if; 1024 1025 Cond := 1026 Make_Op_Le (Loc, 1027 Left_Opnd => Make_Identifier (Loc, Name_uE), 1028 Right_Opnd => Siz); 1029 1030 -- Map entry queue indices in the range of the current family 1031 -- into the current index, that designates the entry body. 1032 1033 if No (If_St) then 1034 If_St := 1035 Make_Implicit_If_Statement (Typ, 1036 Condition => Cond, 1037 Then_Statements => Stats, 1038 Elsif_Parts => New_List); 1039 1040 Ret := If_St; 1041 1042 else 1043 Append ( 1044 Make_Elsif_Part (Loc, 1045 Condition => Cond, 1046 Then_Statements => Stats), 1047 Elsif_Parts (If_St)); 1048 end if; 1049 end Add_If_Clause; 1050 1051 ------------------------------ 1052 -- Convert_Discriminant_Ref -- 1053 ------------------------------ 1054 1055 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 1056 B : Node_Id; 1057 1058 begin 1059 if Is_Entity_Name (Bound) 1060 and then Ekind (Entity (Bound)) = E_Discriminant 1061 then 1062 B := 1063 Make_Selected_Component (Loc, 1064 Prefix => 1065 Unchecked_Convert_To (Corresponding_Record_Type (Typ), 1066 Make_Explicit_Dereference (Loc, 1067 Make_Identifier (Loc, Name_uObject))), 1068 Selector_Name => Make_Identifier (Loc, Chars (Bound))); 1069 Set_Etype (B, Etype (Entity (Bound))); 1070 else 1071 B := New_Copy_Tree (Bound); 1072 end if; 1073 1074 return B; 1075 end Convert_Discriminant_Ref; 1076 1077 -- Start of processing for Build_Find_Body_Index 1078 1079 begin 1080 Spec := Build_Find_Body_Index_Spec (Typ); 1081 1082 Ent := First_Entity (Typ); 1083 1084 while Present (Ent) loop 1085 1086 if Ekind (Ent) = E_Entry_Family then 1087 Has_F := True; 1088 exit; 1089 end if; 1090 1091 Next_Entity (Ent); 1092 end loop; 1093 1094 if not Has_F then 1095 1096 -- If the protected type has no entry families, there is a one-one 1097 -- correspondence between entry queue and entry body. 1098 1099 Ret := 1100 Make_Return_Statement (Loc, 1101 Expression => Make_Identifier (Loc, Name_uE)); 1102 1103 else 1104 -- Suppose entries e1, e2, ... have size l1, l2, ... we generate 1105 -- the following: 1106 -- 1107 -- if E <= l1 then return 1; 1108 -- elsif E <= l1 + l2 then return 2; 1109 -- ... 1110 1111 Index := 0; 1112 Siz := Empty; 1113 Ent := First_Entity (Typ); 1114 1115 Add_Object_Pointer (Decls, Typ, Loc); 1116 1117 while Present (Ent) loop 1118 1119 if Ekind (Ent) = E_Entry then 1120 Add_If_Clause (Make_Integer_Literal (Loc, 1)); 1121 1122 elsif Ekind (Ent) = E_Entry_Family then 1123 1124 E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent))); 1125 Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ)); 1126 Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ)); 1127 Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ)); 1128 end if; 1129 1130 Next_Entity (Ent); 1131 end loop; 1132 1133 if Index = 1 then 1134 Decls := New_List; 1135 Ret := 1136 Make_Return_Statement (Loc, 1137 Expression => Make_Integer_Literal (Loc, 1)); 1138 1139 elsif Nkind (Ret) = N_If_Statement then 1140 1141 -- Ranges are in increasing order, so last one doesn't need a 1142 -- guard. 1143 1144 declare 1145 Nod : constant Node_Id := Last (Elsif_Parts (Ret)); 1146 1147 begin 1148 Remove (Nod); 1149 Set_Else_Statements (Ret, Then_Statements (Nod)); 1150 end; 1151 end if; 1152 end if; 1153 1154 return 1155 Make_Subprogram_Body (Loc, 1156 Specification => Spec, 1157 Declarations => Decls, 1158 Handled_Statement_Sequence => 1159 Make_Handled_Sequence_Of_Statements (Loc, 1160 Statements => New_List (Ret))); 1161 end Build_Find_Body_Index; 1162 1163 -------------------------------- 1164 -- Build_Find_Body_Index_Spec -- 1165 -------------------------------- 1166 1167 function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is 1168 Loc : constant Source_Ptr := Sloc (Typ); 1169 Id : constant Entity_Id := 1170 Make_Defining_Identifier (Loc, 1171 Chars => New_External_Name (Chars (Typ), 'F')); 1172 Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO); 1173 Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE); 1174 1175 begin 1176 return 1177 Make_Function_Specification (Loc, 1178 Defining_Unit_Name => Id, 1179 Parameter_Specifications => New_List ( 1180 Make_Parameter_Specification (Loc, 1181 Defining_Identifier => Parm1, 1182 Parameter_Type => 1183 New_Reference_To (RTE (RE_Address), Loc)), 1184 1185 Make_Parameter_Specification (Loc, 1186 Defining_Identifier => Parm2, 1187 Parameter_Type => 1188 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), 1189 Subtype_Mark => New_Occurrence_Of ( 1190 RTE (RE_Protected_Entry_Index), Loc)); 1191 end Build_Find_Body_Index_Spec; 1192 1193 ------------------------- 1194 -- Build_Master_Entity -- 1195 ------------------------- 1196 1197 procedure Build_Master_Entity (E : Entity_Id) is 1198 Loc : constant Source_Ptr := Sloc (E); 1199 P : Node_Id; 1200 Decl : Node_Id; 1201 1202 begin 1203 -- Nothing to do if we already built a master entity for this scope 1204 -- or if there is no task hierarchy. 1205 1206 if Has_Master_Entity (Scope (E)) 1207 or else Restrictions (No_Task_Hierarchy) 1208 then 1209 return; 1210 end if; 1211 1212 -- Otherwise first build the master entity 1213 -- _Master : constant Master_Id := Current_Master.all; 1214 -- and insert it just before the current declaration 1215 1216 Decl := 1217 Make_Object_Declaration (Loc, 1218 Defining_Identifier => 1219 Make_Defining_Identifier (Loc, Name_uMaster), 1220 Constant_Present => True, 1221 Object_Definition => New_Reference_To (RTE (RE_Master_Id), Loc), 1222 Expression => 1223 Make_Explicit_Dereference (Loc, 1224 New_Reference_To (RTE (RE_Current_Master), Loc))); 1225 1226 P := Parent (E); 1227 Insert_Before (P, Decl); 1228 Analyze (Decl); 1229 Set_Has_Master_Entity (Scope (E)); 1230 1231 -- Now mark the containing scope as a task master 1232 1233 while Nkind (P) /= N_Compilation_Unit loop 1234 P := Parent (P); 1235 1236 -- If we fall off the top, we are at the outer level, and the 1237 -- environment task is our effective master, so nothing to mark. 1238 1239 if Nkind (P) = N_Task_Body 1240 or else Nkind (P) = N_Block_Statement 1241 or else Nkind (P) = N_Subprogram_Body 1242 then 1243 Set_Is_Task_Master (P, True); 1244 return; 1245 1246 elsif Nkind (Parent (P)) = N_Subunit then 1247 P := Corresponding_Stub (Parent (P)); 1248 end if; 1249 end loop; 1250 end Build_Master_Entity; 1251 1252 --------------------------- 1253 -- Build_Protected_Entry -- 1254 --------------------------- 1255 1256 function Build_Protected_Entry 1257 (N : Node_Id; 1258 Ent : Entity_Id; 1259 Pid : Node_Id) return Node_Id 1260 is 1261 Loc : constant Source_Ptr := Sloc (N); 1262 Op_Decls : constant List_Id := New_List; 1263 Edef : Entity_Id; 1264 Espec : Node_Id; 1265 Op_Stats : List_Id; 1266 Ohandle : Node_Id; 1267 Complete : Node_Id; 1268 1269 begin 1270 Edef := 1271 Make_Defining_Identifier (Loc, 1272 Chars => Chars (Protected_Body_Subprogram (Ent))); 1273 Espec := Build_Protected_Entry_Specification (Edef, Empty, Loc); 1274 1275 -- <object pointer declaration> 1276 -- Add object pointer declaration. This is needed by the 1277 -- discriminal and prival renamings, which should already 1278 -- have been inserted into the declaration list. 1279 1280 Add_Object_Pointer (Op_Decls, Pid, Loc); 1281 1282 if Abort_Allowed 1283 or else Restrictions (No_Entry_Queue) = False 1284 or else Number_Entries (Pid) > 1 1285 then 1286 Complete := New_Reference_To (RTE (RE_Complete_Entry_Body), Loc); 1287 else 1288 Complete := 1289 New_Reference_To (RTE (RE_Complete_Single_Entry_Body), Loc); 1290 end if; 1291 1292 Op_Stats := New_List ( 1293 Make_Block_Statement (Loc, 1294 Declarations => Declarations (N), 1295 Handled_Statement_Sequence => 1296 Handled_Statement_Sequence (N)), 1297 1298 Make_Procedure_Call_Statement (Loc, 1299 Name => Complete, 1300 Parameter_Associations => New_List ( 1301 Make_Attribute_Reference (Loc, 1302 Prefix => 1303 Make_Selected_Component (Loc, 1304 Prefix => 1305 Make_Identifier (Loc, Name_uObject), 1306 1307 Selector_Name => 1308 Make_Identifier (Loc, Name_uObject)), 1309 Attribute_Name => Name_Unchecked_Access)))); 1310 1311 if Restrictions (No_Exception_Handlers) then 1312 return 1313 Make_Subprogram_Body (Loc, 1314 Specification => Espec, 1315 Declarations => Op_Decls, 1316 Handled_Statement_Sequence => 1317 Make_Handled_Sequence_Of_Statements (Loc, Op_Stats)); 1318 1319 else 1320 Ohandle := Make_Others_Choice (Loc); 1321 Set_All_Others (Ohandle); 1322 1323 if Abort_Allowed 1324 or else Restrictions (No_Entry_Queue) = False 1325 or else Number_Entries (Pid) > 1 1326 then 1327 Complete := 1328 New_Reference_To (RTE (RE_Exceptional_Complete_Entry_Body), Loc); 1329 1330 else 1331 Complete := New_Reference_To ( 1332 RTE (RE_Exceptional_Complete_Single_Entry_Body), Loc); 1333 end if; 1334 1335 return 1336 Make_Subprogram_Body (Loc, 1337 Specification => Espec, 1338 Declarations => Op_Decls, 1339 Handled_Statement_Sequence => 1340 Make_Handled_Sequence_Of_Statements (Loc, 1341 Statements => Op_Stats, 1342 Exception_Handlers => New_List ( 1343 Make_Exception_Handler (Loc, 1344 Exception_Choices => New_List (Ohandle), 1345 1346 Statements => New_List ( 1347 Make_Procedure_Call_Statement (Loc, 1348 Name => Complete, 1349 Parameter_Associations => New_List ( 1350 Make_Attribute_Reference (Loc, 1351 Prefix => 1352 Make_Selected_Component (Loc, 1353 Prefix => 1354 Make_Identifier (Loc, Name_uObject), 1355 Selector_Name => 1356 Make_Identifier (Loc, Name_uObject)), 1357 Attribute_Name => Name_Unchecked_Access), 1358 1359 Make_Function_Call (Loc, 1360 Name => New_Reference_To ( 1361 RTE (RE_Get_GNAT_Exception), Loc))))))))); 1362 end if; 1363 end Build_Protected_Entry; 1364 1365 ----------------------------------------- 1366 -- Build_Protected_Entry_Specification -- 1367 ----------------------------------------- 1368 1369 function Build_Protected_Entry_Specification 1370 (Def_Id : Entity_Id; 1371 Ent_Id : Entity_Id; 1372 Loc : Source_Ptr) return Node_Id 1373 is 1374 P : Entity_Id; 1375 1376 begin 1377 P := Make_Defining_Identifier (Loc, Name_uP); 1378 1379 if Present (Ent_Id) then 1380 Append_Elmt (P, Accept_Address (Ent_Id)); 1381 end if; 1382 1383 return Make_Procedure_Specification (Loc, 1384 Defining_Unit_Name => Def_Id, 1385 Parameter_Specifications => New_List ( 1386 Make_Parameter_Specification (Loc, 1387 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), 1388 Parameter_Type => 1389 New_Reference_To (RTE (RE_Address), Loc)), 1390 1391 Make_Parameter_Specification (Loc, 1392 Defining_Identifier => P, 1393 Parameter_Type => 1394 New_Reference_To (RTE (RE_Address), Loc)), 1395 1396 Make_Parameter_Specification (Loc, 1397 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uE), 1398 Parameter_Type => 1399 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc)))); 1400 end Build_Protected_Entry_Specification; 1401 1402 -------------------------- 1403 -- Build_Protected_Spec -- 1404 -------------------------- 1405 1406 function Build_Protected_Spec 1407 (N : Node_Id; 1408 Obj_Type : Entity_Id; 1409 Unprotected : Boolean := False; 1410 Ident : Entity_Id) return List_Id 1411 is 1412 Loc : constant Source_Ptr := Sloc (N); 1413 Formal : Entity_Id; 1414 New_Plist : List_Id; 1415 New_Param : Node_Id; 1416 1417 begin 1418 New_Plist := New_List; 1419 Formal := First_Formal (Ident); 1420 1421 while Present (Formal) loop 1422 New_Param := 1423 Make_Parameter_Specification (Loc, 1424 Defining_Identifier => 1425 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 1426 In_Present => In_Present (Parent (Formal)), 1427 Out_Present => Out_Present (Parent (Formal)), 1428 Parameter_Type => 1429 New_Reference_To (Etype (Formal), Loc)); 1430 1431 if Unprotected then 1432 Set_Protected_Formal (Formal, Defining_Identifier (New_Param)); 1433 end if; 1434 1435 Append (New_Param, New_Plist); 1436 Next_Formal (Formal); 1437 end loop; 1438 1439 -- If the subprogram is a procedure and the context is not an access 1440 -- to protected subprogram, the parameter is in-out. Otherwise it is 1441 -- an in parameter. 1442 1443 Prepend_To (New_Plist, 1444 Make_Parameter_Specification (Loc, 1445 Defining_Identifier => 1446 Make_Defining_Identifier (Loc, Name_uObject), 1447 In_Present => True, 1448 Out_Present => 1449 (Etype (Ident) = Standard_Void_Type 1450 and then not Is_RTE (Obj_Type, RE_Address)), 1451 Parameter_Type => New_Reference_To (Obj_Type, Loc))); 1452 1453 return New_Plist; 1454 end Build_Protected_Spec; 1455 1456 --------------------------------------- 1457 -- Build_Protected_Sub_Specification -- 1458 --------------------------------------- 1459 1460 function Build_Protected_Sub_Specification 1461 (N : Node_Id; 1462 Prottyp : Entity_Id; 1463 Unprotected : Boolean := False) return Node_Id 1464 is 1465 Loc : constant Source_Ptr := Sloc (N); 1466 Decl : Node_Id; 1467 Protnm : constant Name_Id := Chars (Prottyp); 1468 Ident : Entity_Id; 1469 Nam : Name_Id; 1470 New_Plist : List_Id; 1471 Append_Char : Character; 1472 New_Spec : Node_Id; 1473 1474 begin 1475 if Ekind 1476 (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body 1477 then 1478 Decl := Unit_Declaration_Node (Corresponding_Spec (N)); 1479 else 1480 Decl := N; 1481 end if; 1482 1483 Ident := Defining_Unit_Name (Specification (Decl)); 1484 Nam := Chars (Ident); 1485 1486 New_Plist := Build_Protected_Spec 1487 (Decl, Corresponding_Record_Type (Prottyp), 1488 Unprotected, Ident); 1489 1490 if Unprotected then 1491 Append_Char := 'N'; 1492 else 1493 Append_Char := 'P'; 1494 end if; 1495 1496 if Nkind (Specification (Decl)) = N_Procedure_Specification then 1497 return 1498 Make_Procedure_Specification (Loc, 1499 Defining_Unit_Name => 1500 Make_Defining_Identifier (Loc, 1501 Chars => Build_Selected_Name (Protnm, Nam, Append_Char)), 1502 Parameter_Specifications => New_Plist); 1503 1504 else 1505 New_Spec := 1506 Make_Function_Specification (Loc, 1507 Defining_Unit_Name => 1508 Make_Defining_Identifier (Loc, 1509 Chars => Build_Selected_Name (Protnm, Nam, Append_Char)), 1510 Parameter_Specifications => New_Plist, 1511 Subtype_Mark => New_Copy (Subtype_Mark (Specification (Decl)))); 1512 Set_Return_Present (Defining_Unit_Name (New_Spec)); 1513 return New_Spec; 1514 end if; 1515 end Build_Protected_Sub_Specification; 1516 1517 ------------------------------------- 1518 -- Build_Protected_Subprogram_Body -- 1519 ------------------------------------- 1520 1521 function Build_Protected_Subprogram_Body 1522 (N : Node_Id; 1523 Pid : Node_Id; 1524 N_Op_Spec : Node_Id) return Node_Id 1525 is 1526 Loc : constant Source_Ptr := Sloc (N); 1527 Op_Spec : Node_Id; 1528 P_Op_Spec : Node_Id; 1529 Uactuals : List_Id; 1530 Pformal : Node_Id; 1531 Unprot_Call : Node_Id; 1532 Sub_Body : Node_Id; 1533 Lock_Name : Node_Id; 1534 Lock_Stmt : Node_Id; 1535 Unlock_Name : Node_Id; 1536 Unlock_Stmt : Node_Id; 1537 Service_Name : Node_Id; 1538 Service_Stmt : Node_Id; 1539 R : Node_Id; 1540 Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning 1541 Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning 1542 Stmts : List_Id; 1543 Object_Parm : Node_Id; 1544 Exc_Safe : Boolean; 1545 1546 function Is_Exception_Safe (Subprogram : Node_Id) return Boolean; 1547 -- Tell whether a given subprogram cannot raise an exception 1548 1549 ----------------------- 1550 -- Is_Exception_Safe -- 1551 ----------------------- 1552 1553 function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is 1554 1555 function Has_Side_Effect (N : Node_Id) return Boolean; 1556 -- Return True whenever encountering a subprogram call or a 1557 -- raise statement of any kind in the sequence of statements N 1558 1559 --------------------- 1560 -- Has_Side_Effect -- 1561 --------------------- 1562 1563 -- What is this doing buried two levels down in exp_ch9. It 1564 -- seems like a generally useful function, and indeed there 1565 -- may be code duplication going on here ??? 1566 1567 function Has_Side_Effect (N : Node_Id) return Boolean is 1568 Stmt : Node_Id := N; 1569 Expr : Node_Id; 1570 1571 function Is_Call_Or_Raise (N : Node_Id) return Boolean; 1572 -- Indicate whether N is a subprogram call or a raise statement 1573 1574 function Is_Call_Or_Raise (N : Node_Id) return Boolean is 1575 begin 1576 return Nkind (N) = N_Procedure_Call_Statement 1577 or else Nkind (N) = N_Function_Call 1578 or else Nkind (N) = N_Raise_Statement 1579 or else Nkind (N) = N_Raise_Constraint_Error 1580 or else Nkind (N) = N_Raise_Program_Error 1581 or else Nkind (N) = N_Raise_Storage_Error; 1582 end Is_Call_Or_Raise; 1583 1584 -- Start of processing for Has_Side_Effect 1585 1586 begin 1587 while Present (Stmt) loop 1588 if Is_Call_Or_Raise (Stmt) then 1589 return True; 1590 end if; 1591 1592 -- An object declaration can also contain a function call 1593 -- or a raise statement 1594 1595 if Nkind (Stmt) = N_Object_Declaration then 1596 Expr := Expression (Stmt); 1597 1598 if Present (Expr) and then Is_Call_Or_Raise (Expr) then 1599 return True; 1600 end if; 1601 end if; 1602 1603 Next (Stmt); 1604 end loop; 1605 1606 return False; 1607 end Has_Side_Effect; 1608 1609 -- Start of processing for Is_Exception_Safe 1610 1611 begin 1612 -- If the checks handled by the back end are not disabled, we cannot 1613 -- ensure that no exception will be raised. 1614 1615 if not Access_Checks_Suppressed (Empty) 1616 or else not Discriminant_Checks_Suppressed (Empty) 1617 or else not Range_Checks_Suppressed (Empty) 1618 or else not Index_Checks_Suppressed (Empty) 1619 or else Opt.Stack_Checking_Enabled 1620 then 1621 return False; 1622 end if; 1623 1624 if Has_Side_Effect (First (Declarations (Subprogram))) 1625 or else 1626 Has_Side_Effect ( 1627 First (Statements (Handled_Statement_Sequence (Subprogram)))) 1628 then 1629 return False; 1630 else 1631 return True; 1632 end if; 1633 end Is_Exception_Safe; 1634 1635 -- Start of processing for Build_Protected_Subprogram_Body 1636 1637 begin 1638 Op_Spec := Specification (N); 1639 Exc_Safe := Is_Exception_Safe (N); 1640 1641 P_Op_Spec := 1642 Build_Protected_Sub_Specification (N, 1643 Pid, Unprotected => False); 1644 1645 -- Build a list of the formal parameters of the protected 1646 -- version of the subprogram to use as the actual parameters 1647 -- of the unprotected version. 1648 1649 Uactuals := New_List; 1650 Pformal := First (Parameter_Specifications (P_Op_Spec)); 1651 1652 while Present (Pformal) loop 1653 Append ( 1654 Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))), 1655 Uactuals); 1656 Next (Pformal); 1657 end loop; 1658 1659 -- Make a call to the unprotected version of the subprogram 1660 -- built above for use by the protected version built below. 1661 1662 if Nkind (Op_Spec) = N_Function_Specification then 1663 if Exc_Safe then 1664 R := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); 1665 Unprot_Call := 1666 Make_Object_Declaration (Loc, 1667 Defining_Identifier => R, 1668 Constant_Present => True, 1669 Object_Definition => New_Copy (Subtype_Mark (N_Op_Spec)), 1670 Expression => 1671 Make_Function_Call (Loc, 1672 Name => Make_Identifier (Loc, 1673 Chars (Defining_Unit_Name (N_Op_Spec))), 1674 Parameter_Associations => Uactuals)); 1675 Return_Stmt := Make_Return_Statement (Loc, 1676 Expression => New_Reference_To (R, Loc)); 1677 1678 else 1679 Unprot_Call := Make_Return_Statement (Loc, 1680 Expression => Make_Function_Call (Loc, 1681 Name => 1682 Make_Identifier (Loc, 1683 Chars (Defining_Unit_Name (N_Op_Spec))), 1684 Parameter_Associations => Uactuals)); 1685 end if; 1686 1687 else 1688 Unprot_Call := Make_Procedure_Call_Statement (Loc, 1689 Name => 1690 Make_Identifier (Loc, 1691 Chars (Defining_Unit_Name (N_Op_Spec))), 1692 Parameter_Associations => Uactuals); 1693 end if; 1694 1695 -- Wrap call in block that will be covered by an at_end handler. 1696 1697 if not Exc_Safe then 1698 Unprot_Call := Make_Block_Statement (Loc, 1699 Handled_Statement_Sequence => 1700 Make_Handled_Sequence_Of_Statements (Loc, 1701 Statements => New_List (Unprot_Call))); 1702 end if; 1703 1704 -- Make the protected subprogram body. This locks the protected 1705 -- object and calls the unprotected version of the subprogram. 1706 1707 -- If the protected object is controlled (i.e it has entries or 1708 -- needs finalization for interrupt handling), call Lock_Entries, 1709 -- except if the protected object follows the Ravenscar profile, in 1710 -- which case call Lock_Entry, otherwise call the simplified version, 1711 -- Lock. 1712 1713 if Has_Entries (Pid) 1714 or else Has_Interrupt_Handler (Pid) 1715 or else (Has_Attach_Handler (Pid) and then not Restricted_Profile) 1716 then 1717 if Abort_Allowed 1718 or else Restrictions (No_Entry_Queue) = False 1719 or else Number_Entries (Pid) > 1 1720 then 1721 Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc); 1722 Unlock_Name := New_Reference_To (RTE (RE_Unlock_Entries), Loc); 1723 Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc); 1724 1725 else 1726 Lock_Name := New_Reference_To (RTE (RE_Lock_Entry), Loc); 1727 Unlock_Name := New_Reference_To (RTE (RE_Unlock_Entry), Loc); 1728 Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc); 1729 end if; 1730 1731 else 1732 Lock_Name := New_Reference_To (RTE (RE_Lock), Loc); 1733 Unlock_Name := New_Reference_To (RTE (RE_Unlock), Loc); 1734 Service_Name := Empty; 1735 end if; 1736 1737 Object_Parm := 1738 Make_Attribute_Reference (Loc, 1739 Prefix => 1740 Make_Selected_Component (Loc, 1741 Prefix => 1742 Make_Identifier (Loc, Name_uObject), 1743 Selector_Name => 1744 Make_Identifier (Loc, Name_uObject)), 1745 Attribute_Name => Name_Unchecked_Access); 1746 1747 Lock_Stmt := Make_Procedure_Call_Statement (Loc, 1748 Name => Lock_Name, 1749 Parameter_Associations => New_List (Object_Parm)); 1750 1751 if Abort_Allowed then 1752 Stmts := New_List ( 1753 Make_Procedure_Call_Statement (Loc, 1754 Name => New_Reference_To (RTE (RE_Abort_Defer), Loc), 1755 Parameter_Associations => Empty_List), 1756 Lock_Stmt); 1757 1758 else 1759 Stmts := New_List (Lock_Stmt); 1760 end if; 1761 1762 if not Exc_Safe then 1763 Append (Unprot_Call, Stmts); 1764 else 1765 if Nkind (Op_Spec) = N_Function_Specification then 1766 Pre_Stmts := Stmts; 1767 Stmts := Empty_List; 1768 else 1769 Append (Unprot_Call, Stmts); 1770 end if; 1771 1772 if Service_Name /= Empty then 1773 Service_Stmt := Make_Procedure_Call_Statement (Loc, 1774 Name => Service_Name, 1775 Parameter_Associations => 1776 New_List (New_Copy_Tree (Object_Parm))); 1777 Append (Service_Stmt, Stmts); 1778 end if; 1779 1780 Unlock_Stmt := 1781 Make_Procedure_Call_Statement (Loc, 1782 Name => Unlock_Name, 1783 Parameter_Associations => New_List ( 1784 New_Copy_Tree (Object_Parm))); 1785 Append (Unlock_Stmt, Stmts); 1786 1787 if Abort_Allowed then 1788 Append ( 1789 Make_Procedure_Call_Statement (Loc, 1790 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc), 1791 Parameter_Associations => Empty_List), 1792 Stmts); 1793 end if; 1794 1795 if Nkind (Op_Spec) = N_Function_Specification then 1796 Append (Return_Stmt, Stmts); 1797 Append (Make_Block_Statement (Loc, 1798 Declarations => New_List (Unprot_Call), 1799 Handled_Statement_Sequence => 1800 Make_Handled_Sequence_Of_Statements (Loc, 1801 Statements => Stmts)), Pre_Stmts); 1802 Stmts := Pre_Stmts; 1803 end if; 1804 end if; 1805 1806 Sub_Body := 1807 Make_Subprogram_Body (Loc, 1808 Declarations => Empty_List, 1809 Specification => P_Op_Spec, 1810 Handled_Statement_Sequence => 1811 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); 1812 1813 if not Exc_Safe then 1814 Set_Is_Protected_Subprogram_Body (Sub_Body); 1815 end if; 1816 1817 return Sub_Body; 1818 end Build_Protected_Subprogram_Body; 1819 1820 ------------------------------------- 1821 -- Build_Protected_Subprogram_Call -- 1822 ------------------------------------- 1823 1824 procedure Build_Protected_Subprogram_Call 1825 (N : Node_Id; 1826 Name : Node_Id; 1827 Rec : Node_Id; 1828 External : Boolean := True) 1829 is 1830 Loc : constant Source_Ptr := Sloc (N); 1831 Sub : constant Entity_Id := Entity (Name); 1832 New_Sub : Node_Id; 1833 Params : List_Id; 1834 1835 begin 1836 if External then 1837 New_Sub := New_Occurrence_Of (External_Subprogram (Sub), Loc); 1838 else 1839 New_Sub := 1840 New_Occurrence_Of (Protected_Body_Subprogram (Sub), Loc); 1841 end if; 1842 1843 if Present (Parameter_Associations (N)) then 1844 Params := New_Copy_List_Tree (Parameter_Associations (N)); 1845 else 1846 Params := New_List; 1847 end if; 1848 1849 Prepend (Rec, Params); 1850 1851 if Ekind (Sub) = E_Procedure then 1852 Rewrite (N, 1853 Make_Procedure_Call_Statement (Loc, 1854 Name => New_Sub, 1855 Parameter_Associations => Params)); 1856 1857 else 1858 pragma Assert (Ekind (Sub) = E_Function); 1859 Rewrite (N, 1860 Make_Function_Call (Loc, 1861 Name => New_Sub, 1862 Parameter_Associations => Params)); 1863 end if; 1864 1865 if External 1866 and then Nkind (Rec) = N_Unchecked_Type_Conversion 1867 and then Is_Entity_Name (Expression (Rec)) 1868 and then Is_Shared_Passive (Entity (Expression (Rec))) 1869 then 1870 Add_Shared_Var_Lock_Procs (N); 1871 end if; 1872 end Build_Protected_Subprogram_Call; 1873 1874 ------------------------- 1875 -- Build_Selected_Name -- 1876 ------------------------- 1877 1878 function Build_Selected_Name 1879 (Prefix, Selector : Name_Id; 1880 Append_Char : Character := ' ') return Name_Id 1881 is 1882 Select_Buffer : String (1 .. Hostparm.Max_Name_Length); 1883 Select_Len : Natural; 1884 1885 begin 1886 Get_Name_String (Selector); 1887 Select_Len := Name_Len; 1888 Select_Buffer (1 .. Select_Len) := Name_Buffer (1 .. Name_Len); 1889 Get_Name_String (Prefix); 1890 1891 -- If scope is anonymous type, discard suffix to recover name of 1892 -- single protected object. Otherwise use protected type name. 1893 1894 if Name_Buffer (Name_Len) = 'T' then 1895 Name_Len := Name_Len - 1; 1896 end if; 1897 1898 Name_Buffer (Name_Len + 1) := 'P'; 1899 Name_Buffer (Name_Len + 2) := 'T'; 1900 Name_Buffer (Name_Len + 3) := '_'; 1901 Name_Buffer (Name_Len + 4) := '_'; 1902 1903 Name_Len := Name_Len + 4; 1904 for J in 1 .. Select_Len loop 1905 Name_Len := Name_Len + 1; 1906 Name_Buffer (Name_Len) := Select_Buffer (J); 1907 end loop; 1908 1909 if Append_Char /= ' ' then 1910 Name_Len := Name_Len + 1; 1911 Name_Buffer (Name_Len) := Append_Char; 1912 end if; 1913 1914 return Name_Find; 1915 end Build_Selected_Name; 1916 1917 ----------------------------- 1918 -- Build_Simple_Entry_Call -- 1919 ----------------------------- 1920 1921 -- A task entry call is converted to a call to Call_Simple 1922 1923 -- declare 1924 -- P : parms := (parm, parm, parm); 1925 -- begin 1926 -- Call_Simple (acceptor-task, entry-index, P'Address); 1927 -- parm := P.param; 1928 -- parm := P.param; 1929 -- ... 1930 -- end; 1931 1932 -- Here Pnn is an aggregate of the type constructed for the entry to hold 1933 -- the parameters, and the constructed aggregate value contains either the 1934 -- parameters or, in the case of non-elementary types, references to these 1935 -- parameters. Then the address of this aggregate is passed to the runtime 1936 -- routine, along with the task id value and the task entry index value. 1937 -- Pnn is only required if parameters are present. 1938 1939 -- The assignments after the call are present only in the case of in-out 1940 -- or out parameters for elementary types, and are used to assign back the 1941 -- resulting values of such parameters. 1942 1943 -- Note: the reason that we insert a block here is that in the context 1944 -- of selects, conditional entry calls etc. the entry call statement 1945 -- appears on its own, not as an element of a list. 1946 1947 -- A protected entry call is converted to a Protected_Entry_Call: 1948 1949 -- declare 1950 -- P : E1_Params := (param, param, param); 1951 -- Pnn : Boolean; 1952 -- Bnn : Communications_Block; 1953 1954 -- declare 1955 -- P : E1_Params := (param, param, param); 1956 -- Bnn : Communications_Block; 1957 1958 -- begin 1959 -- Protected_Entry_Call ( 1960 -- Object => po._object'Access, 1961 -- E => <entry index>; 1962 -- Uninterpreted_Data => P'Address; 1963 -- Mode => Simple_Call; 1964 -- Block => Bnn); 1965 -- parm := P.param; 1966 -- parm := P.param; 1967 -- ... 1968 -- end; 1969 1970 procedure Build_Simple_Entry_Call 1971 (N : Node_Id; 1972 Concval : Node_Id; 1973 Ename : Node_Id; 1974 Index : Node_Id) 1975 is 1976 begin 1977 Expand_Call (N); 1978 1979 -- Convert entry call to Call_Simple call 1980 1981 declare 1982 Loc : constant Source_Ptr := Sloc (N); 1983 Parms : constant List_Id := Parameter_Associations (N); 1984 Stats : constant List_Id := New_List; 1985 Pdecl : Node_Id; 1986 Xdecl : Node_Id; 1987 Decls : List_Id; 1988 Conctyp : Node_Id; 1989 Ent : Entity_Id; 1990 Ent_Acc : Entity_Id; 1991 P : Entity_Id; 1992 X : Entity_Id; 1993 Plist : List_Id; 1994 Parm1 : Node_Id; 1995 Parm2 : Node_Id; 1996 Parm3 : Node_Id; 1997 Call : Node_Id; 1998 Actual : Node_Id; 1999 Formal : Node_Id; 2000 N_Node : Node_Id; 2001 N_Var : Node_Id; 2002 Comm_Name : Entity_Id; 2003 2004 begin 2005 -- Simple entry and entry family cases merge here 2006 2007 Ent := Entity (Ename); 2008 Ent_Acc := Entry_Parameters_Type (Ent); 2009 Conctyp := Etype (Concval); 2010 2011 -- If prefix is an access type, dereference to obtain the task type 2012 2013 if Is_Access_Type (Conctyp) then 2014 Conctyp := Designated_Type (Conctyp); 2015 end if; 2016 2017 -- Special case for protected subprogram calls. 2018 2019 if Is_Protected_Type (Conctyp) 2020 and then Is_Subprogram (Entity (Ename)) 2021 then 2022 Build_Protected_Subprogram_Call 2023 (N, Ename, Convert_Concurrent (Concval, Conctyp)); 2024 Analyze (N); 2025 return; 2026 end if; 2027 2028 -- First parameter is the Task_Id value from the task value or the 2029 -- Object from the protected object value, obtained by selecting 2030 -- the _Task_Id or _Object from the result of doing an unchecked 2031 -- conversion to convert the value to the corresponding record type. 2032 2033 Parm1 := Concurrent_Ref (Concval); 2034 2035 -- Second parameter is the entry index, computed by the routine 2036 -- provided for this purpose. The value of this expression is 2037 -- assigned to an intermediate variable to assure that any entry 2038 -- family index expressions are evaluated before the entry 2039 -- parameters. 2040 2041 if Abort_Allowed 2042 or else Restrictions (No_Entry_Queue) = False 2043 or else not Is_Protected_Type (Conctyp) 2044 or else Number_Entries (Conctyp) > 1 2045 then 2046 X := Make_Defining_Identifier (Loc, Name_uX); 2047 2048 Xdecl := 2049 Make_Object_Declaration (Loc, 2050 Defining_Identifier => X, 2051 Object_Definition => 2052 New_Reference_To (RTE (RE_Task_Entry_Index), Loc), 2053 Expression => Actual_Index_Expression ( 2054 Loc, Entity (Ename), Index, Concval)); 2055 2056 Decls := New_List (Xdecl); 2057 Parm2 := New_Reference_To (X, Loc); 2058 2059 else 2060 Xdecl := Empty; 2061 Decls := New_List; 2062 Parm2 := Empty; 2063 end if; 2064 2065 -- The third parameter is the packaged parameters. If there are 2066 -- none, then it is just the null address, since nothing is passed 2067 2068 if No (Parms) then 2069 Parm3 := New_Reference_To (RTE (RE_Null_Address), Loc); 2070 P := Empty; 2071 2072 -- Case of parameters present, where third argument is the address 2073 -- of a packaged record containing the required parameter values. 2074 2075 else 2076 -- First build a list of parameter values, which are 2077 -- references to objects of the parameter types. 2078 2079 Plist := New_List; 2080 2081 Actual := First_Actual (N); 2082 Formal := First_Formal (Ent); 2083 2084 while Present (Actual) loop 2085 2086 -- If it is a by_copy_type, copy it to a new variable. The 2087 -- packaged record has a field that points to this variable. 2088 2089 if Is_By_Copy_Type (Etype (Actual)) then 2090 N_Node := 2091 Make_Object_Declaration (Loc, 2092 Defining_Identifier => 2093 Make_Defining_Identifier (Loc, 2094 Chars => New_Internal_Name ('J')), 2095 Aliased_Present => True, 2096 Object_Definition => 2097 New_Reference_To (Etype (Formal), Loc)); 2098 2099 -- We have to make an assignment statement separate for 2100 -- the case of limited type. We can not assign it unless 2101 -- the Assignment_OK flag is set first. 2102 2103 if Ekind (Formal) /= E_Out_Parameter then 2104 N_Var := 2105 New_Reference_To (Defining_Identifier (N_Node), Loc); 2106 Set_Assignment_OK (N_Var); 2107 Append_To (Stats, 2108 Make_Assignment_Statement (Loc, 2109 Name => N_Var, 2110 Expression => Relocate_Node (Actual))); 2111 end if; 2112 2113 Append (N_Node, Decls); 2114 2115 Append_To (Plist, 2116 Make_Attribute_Reference (Loc, 2117 Attribute_Name => Name_Unchecked_Access, 2118 Prefix => 2119 New_Reference_To (Defining_Identifier (N_Node), Loc))); 2120 else 2121 Append_To (Plist, 2122 Make_Reference (Loc, Prefix => Relocate_Node (Actual))); 2123 end if; 2124 2125 Next_Actual (Actual); 2126 Next_Formal_With_Extras (Formal); 2127 end loop; 2128 2129 -- Now build the declaration of parameters initialized with the 2130 -- aggregate containing this constructed parameter list. 2131 2132 P := Make_Defining_Identifier (Loc, Name_uP); 2133 2134 Pdecl := 2135 Make_Object_Declaration (Loc, 2136 Defining_Identifier => P, 2137 Object_Definition => 2138 New_Reference_To (Designated_Type (Ent_Acc), Loc), 2139 Expression => 2140 Make_Aggregate (Loc, Expressions => Plist)); 2141 2142 Parm3 := 2143 Make_Attribute_Reference (Loc, 2144 Attribute_Name => Name_Address, 2145 Prefix => New_Reference_To (P, Loc)); 2146 2147 Append (Pdecl, Decls); 2148 end if; 2149 2150 -- Now we can create the call, case of protected type 2151 2152 if Is_Protected_Type (Conctyp) then 2153 if Abort_Allowed 2154 or else Restrictions (No_Entry_Queue) = False 2155 or else Number_Entries (Conctyp) > 1 2156 then 2157 -- Change the type of the index declaration 2158 2159 Set_Object_Definition (Xdecl, 2160 New_Reference_To (RTE (RE_Protected_Entry_Index), Loc)); 2161 2162 -- Some additional declarations for protected entry calls 2163 2164 if No (Decls) then 2165 Decls := New_List; 2166 end if; 2167 2168 -- Bnn : Communications_Block; 2169 2170 Comm_Name := 2171 Make_Defining_Identifier (Loc, New_Internal_Name ('B')); 2172 2173 Append_To (Decls, 2174 Make_Object_Declaration (Loc, 2175 Defining_Identifier => Comm_Name, 2176 Object_Definition => 2177 New_Reference_To (RTE (RE_Communication_Block), Loc))); 2178 2179 -- Some additional statements for protected entry calls 2180 2181 -- Protected_Entry_Call ( 2182 -- Object => po._object'Access, 2183 -- E => <entry index>; 2184 -- Uninterpreted_Data => P'Address; 2185 -- Mode => Simple_Call; 2186 -- Block => Bnn); 2187 2188 Call := 2189 Make_Procedure_Call_Statement (Loc, 2190 Name => 2191 New_Reference_To (RTE (RE_Protected_Entry_Call), Loc), 2192 2193 Parameter_Associations => New_List ( 2194 Make_Attribute_Reference (Loc, 2195 Attribute_Name => Name_Unchecked_Access, 2196 Prefix => Parm1), 2197 Parm2, 2198 Parm3, 2199 New_Reference_To (RTE (RE_Simple_Call), Loc), 2200 New_Occurrence_Of (Comm_Name, Loc))); 2201 2202 else 2203 -- Protected_Single_Entry_Call ( 2204 -- Object => po._object'Access, 2205 -- Uninterpreted_Data => P'Address; 2206 -- Mode => Simple_Call); 2207 2208 Call := 2209 Make_Procedure_Call_Statement (Loc, 2210 Name => New_Reference_To ( 2211 RTE (RE_Protected_Single_Entry_Call), Loc), 2212 2213 Parameter_Associations => New_List ( 2214 Make_Attribute_Reference (Loc, 2215 Attribute_Name => Name_Unchecked_Access, 2216 Prefix => Parm1), 2217 Parm3, 2218 New_Reference_To (RTE (RE_Simple_Call), Loc))); 2219 end if; 2220 2221 -- Case of task type 2222 2223 else 2224 Call := 2225 Make_Procedure_Call_Statement (Loc, 2226 Name => New_Reference_To (RTE (RE_Call_Simple), Loc), 2227 Parameter_Associations => New_List (Parm1, Parm2, Parm3)); 2228 2229 end if; 2230 2231 Append_To (Stats, Call); 2232 2233 -- If there are out or in/out parameters by copy 2234 -- add assignment statements for the result values. 2235 2236 if Present (Parms) then 2237 Actual := First_Actual (N); 2238 Formal := First_Formal (Ent); 2239 2240 Set_Assignment_OK (Actual); 2241 while Present (Actual) loop 2242 if Is_By_Copy_Type (Etype (Actual)) 2243 and then Ekind (Formal) /= E_In_Parameter 2244 then 2245 N_Node := 2246 Make_Assignment_Statement (Loc, 2247 Name => New_Copy (Actual), 2248 Expression => 2249 Make_Explicit_Dereference (Loc, 2250 Make_Selected_Component (Loc, 2251 Prefix => New_Reference_To (P, Loc), 2252 Selector_Name => 2253 Make_Identifier (Loc, Chars (Formal))))); 2254 2255 -- In all cases (including limited private types) we 2256 -- want the assignment to be valid. 2257 2258 Set_Assignment_OK (Name (N_Node)); 2259 2260 -- If the call is the triggering alternative in an 2261 -- asynchronous select, or the entry_call alternative 2262 -- of a conditional entry call, the assignments for in-out 2263 -- parameters are incorporated into the statement list 2264 -- that follows, so that there are executed only if the 2265 -- entry call succeeds. 2266 2267 if (Nkind (Parent (N)) = N_Triggering_Alternative 2268 and then N = Triggering_Statement (Parent (N))) 2269 or else 2270 (Nkind (Parent (N)) = N_Entry_Call_Alternative 2271 and then N = Entry_Call_Statement (Parent (N))) 2272 then 2273 if No (Statements (Parent (N))) then 2274 Set_Statements (Parent (N), New_List); 2275 end if; 2276 2277 Prepend (N_Node, Statements (Parent (N))); 2278 2279 else 2280 Insert_After (Call, N_Node); 2281 end if; 2282 end if; 2283 2284 Next_Actual (Actual); 2285 Next_Formal_With_Extras (Formal); 2286 end loop; 2287 end if; 2288 2289 -- Finally, create block and analyze it 2290 2291 Rewrite (N, 2292 Make_Block_Statement (Loc, 2293 Declarations => Decls, 2294 Handled_Statement_Sequence => 2295 Make_Handled_Sequence_Of_Statements (Loc, 2296 Statements => Stats))); 2297 2298 Analyze (N); 2299 end; 2300 end Build_Simple_Entry_Call; 2301 2302 -------------------------------- 2303 -- Build_Task_Activation_Call -- 2304 -------------------------------- 2305 2306 procedure Build_Task_Activation_Call (N : Node_Id) is 2307 Loc : constant Source_Ptr := Sloc (N); 2308 Chain : Entity_Id; 2309 Call : Node_Id; 2310 Name : Node_Id; 2311 P : Node_Id; 2312 2313 begin 2314 -- Get the activation chain entity. Except in the case of a package 2315 -- body, this is in the node that w as passed. For a package body, we 2316 -- have to find the corresponding package declaration node. 2317 2318 if Nkind (N) = N_Package_Body then 2319 P := Corresponding_Spec (N); 2320 2321 loop 2322 P := Parent (P); 2323 exit when Nkind (P) = N_Package_Declaration; 2324 end loop; 2325 2326 Chain := Activation_Chain_Entity (P); 2327 2328 else 2329 Chain := Activation_Chain_Entity (N); 2330 end if; 2331 2332 if Present (Chain) then 2333 if Restricted_Profile then 2334 Name := New_Reference_To (RTE (RE_Activate_Restricted_Tasks), Loc); 2335 else 2336 Name := New_Reference_To (RTE (RE_Activate_Tasks), Loc); 2337 end if; 2338 2339 Call := 2340 Make_Procedure_Call_Statement (Loc, 2341 Name => Name, 2342 Parameter_Associations => 2343 New_List (Make_Attribute_Reference (Loc, 2344 Prefix => New_Occurrence_Of (Chain, Loc), 2345 Attribute_Name => Name_Unchecked_Access))); 2346 2347 if Nkind (N) = N_Package_Declaration then 2348 if Present (Corresponding_Body (N)) then 2349 null; 2350 2351 elsif Present (Private_Declarations (Specification (N))) then 2352 Append (Call, Private_Declarations (Specification (N))); 2353 2354 else 2355 Append (Call, Visible_Declarations (Specification (N))); 2356 end if; 2357 2358 else 2359 if Present (Handled_Statement_Sequence (N)) then 2360 2361 -- The call goes at the start of the statement sequence, but 2362 -- after the start of exception range label if one is present. 2363 2364 declare 2365 Stm : Node_Id; 2366 2367 begin 2368 Stm := First (Statements (Handled_Statement_Sequence (N))); 2369 2370 if Nkind (Stm) = N_Label and then Exception_Junk (Stm) then 2371 Next (Stm); 2372 end if; 2373 2374 Insert_Before (Stm, Call); 2375 end; 2376 2377 else 2378 Set_Handled_Statement_Sequence (N, 2379 Make_Handled_Sequence_Of_Statements (Loc, 2380 Statements => New_List (Call))); 2381 end if; 2382 end if; 2383 2384 Analyze (Call); 2385 Check_Task_Activation (N); 2386 end if; 2387 end Build_Task_Activation_Call; 2388 2389 ------------------------------- 2390 -- Build_Task_Allocate_Block -- 2391 ------------------------------- 2392 2393 procedure Build_Task_Allocate_Block 2394 (Actions : List_Id; 2395 N : Node_Id; 2396 Args : List_Id) 2397 is 2398 T : constant Entity_Id := Entity (Expression (N)); 2399 Init : constant Entity_Id := Base_Init_Proc (T); 2400 Loc : constant Source_Ptr := Sloc (N); 2401 Chain : constant Entity_Id := 2402 Make_Defining_Identifier (Loc, Name_uChain); 2403 2404 Blkent : Entity_Id; 2405 Block : Node_Id; 2406 2407 begin 2408 Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); 2409 2410 Block := 2411 Make_Block_Statement (Loc, 2412 Identifier => New_Reference_To (Blkent, Loc), 2413 Declarations => New_List ( 2414 2415 -- _Chain : Activation_Chain; 2416 2417 Make_Object_Declaration (Loc, 2418 Defining_Identifier => Chain, 2419 Aliased_Present => True, 2420 Object_Definition => 2421 New_Reference_To (RTE (RE_Activation_Chain), Loc))), 2422 2423 Handled_Statement_Sequence => 2424 Make_Handled_Sequence_Of_Statements (Loc, 2425 2426 Statements => New_List ( 2427 2428 -- Init (Args); 2429 2430 Make_Procedure_Call_Statement (Loc, 2431 Name => New_Reference_To (Init, Loc), 2432 Parameter_Associations => Args), 2433 2434 -- Activate_Tasks (_Chain); 2435 2436 Make_Procedure_Call_Statement (Loc, 2437 Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc), 2438 Parameter_Associations => New_List ( 2439 Make_Attribute_Reference (Loc, 2440 Prefix => New_Reference_To (Chain, Loc), 2441 Attribute_Name => Name_Unchecked_Access))))), 2442 2443 Has_Created_Identifier => True, 2444 Is_Task_Allocation_Block => True); 2445 2446 Append_To (Actions, 2447 Make_Implicit_Label_Declaration (Loc, 2448 Defining_Identifier => Blkent, 2449 Label_Construct => Block)); 2450 2451 Append_To (Actions, Block); 2452 2453 Set_Activation_Chain_Entity (Block, Chain); 2454 end Build_Task_Allocate_Block; 2455 2456 ----------------------------------------------- 2457 -- Build_Task_Allocate_Block_With_Init_Stmts -- 2458 ----------------------------------------------- 2459 2460 procedure Build_Task_Allocate_Block_With_Init_Stmts 2461 (Actions : List_Id; 2462 N : Node_Id; 2463 Init_Stmts : List_Id) 2464 is 2465 Loc : constant Source_Ptr := Sloc (N); 2466 Chain : constant Entity_Id := 2467 Make_Defining_Identifier (Loc, Name_uChain); 2468 Blkent : Entity_Id; 2469 Block : Node_Id; 2470 2471 begin 2472 Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); 2473 2474 Append_To (Init_Stmts, 2475 Make_Procedure_Call_Statement (Loc, 2476 Name => New_Reference_To (RTE (RE_Activate_Tasks), Loc), 2477 Parameter_Associations => New_List ( 2478 Make_Attribute_Reference (Loc, 2479 Prefix => New_Reference_To (Chain, Loc), 2480 Attribute_Name => Name_Unchecked_Access)))); 2481 2482 Block := 2483 Make_Block_Statement (Loc, 2484 Identifier => New_Reference_To (Blkent, Loc), 2485 Declarations => New_List ( 2486 2487 -- _Chain : Activation_Chain; 2488 2489 Make_Object_Declaration (Loc, 2490 Defining_Identifier => Chain, 2491 Aliased_Present => True, 2492 Object_Definition => 2493 New_Reference_To (RTE (RE_Activation_Chain), Loc))), 2494 2495 Handled_Statement_Sequence => 2496 Make_Handled_Sequence_Of_Statements (Loc, Init_Stmts), 2497 2498 Has_Created_Identifier => True, 2499 Is_Task_Allocation_Block => True); 2500 2501 Append_To (Actions, 2502 Make_Implicit_Label_Declaration (Loc, 2503 Defining_Identifier => Blkent, 2504 Label_Construct => Block)); 2505 2506 Append_To (Actions, Block); 2507 2508 Set_Activation_Chain_Entity (Block, Chain); 2509 end Build_Task_Allocate_Block_With_Init_Stmts; 2510 2511 ----------------------------------- 2512 -- Build_Task_Proc_Specification -- 2513 ----------------------------------- 2514 2515 function Build_Task_Proc_Specification (T : Entity_Id) return Node_Id is 2516 Loc : constant Source_Ptr := Sloc (T); 2517 Nam : constant Name_Id := Chars (T); 2518 Tdec : constant Node_Id := Declaration_Node (T); 2519 Ent : Entity_Id; 2520 2521 begin 2522 Ent := 2523 Make_Defining_Identifier (Loc, 2524 Chars => New_External_Name (Nam, 'B')); 2525 Set_Is_Internal (Ent); 2526 2527 -- Associate the procedure with the task, if this is the declaration 2528 -- (and not the body) of the procedure. 2529 2530 if No (Task_Body_Procedure (Tdec)) then 2531 Set_Task_Body_Procedure (Tdec, Ent); 2532 end if; 2533 2534 return 2535 Make_Procedure_Specification (Loc, 2536 Defining_Unit_Name => Ent, 2537 Parameter_Specifications => 2538 New_List ( 2539 Make_Parameter_Specification (Loc, 2540 Defining_Identifier => 2541 Make_Defining_Identifier (Loc, Name_uTask), 2542 Parameter_Type => 2543 Make_Access_Definition (Loc, 2544 Subtype_Mark => 2545 New_Reference_To 2546 (Corresponding_Record_Type (T), Loc))))); 2547 end Build_Task_Proc_Specification; 2548 2549 --------------------------------------- 2550 -- Build_Unprotected_Subprogram_Body -- 2551 --------------------------------------- 2552 2553 function Build_Unprotected_Subprogram_Body 2554 (N : Node_Id; 2555 Pid : Node_Id) return Node_Id 2556 is 2557 Loc : constant Source_Ptr := Sloc (N); 2558 N_Op_Spec : Node_Id; 2559 Op_Decls : List_Id; 2560 2561 begin 2562 -- Make an unprotected version of the subprogram for use 2563 -- within the same object, with a new name and an additional 2564 -- parameter representing the object. 2565 2566 Op_Decls := Declarations (N); 2567 N_Op_Spec := 2568 Build_Protected_Sub_Specification 2569 (N, Pid, Unprotected => True); 2570 2571 return 2572 Make_Subprogram_Body (Loc, 2573 Specification => N_Op_Spec, 2574 Declarations => Op_Decls, 2575 Handled_Statement_Sequence => 2576 Handled_Statement_Sequence (N)); 2577 end Build_Unprotected_Subprogram_Body; 2578 2579 ---------------------------- 2580 -- Collect_Entry_Families -- 2581 ---------------------------- 2582 2583 procedure Collect_Entry_Families 2584 (Loc : Source_Ptr; 2585 Cdecls : List_Id; 2586 Current_Node : in out Node_Id; 2587 Conctyp : Entity_Id) 2588 is 2589 Efam : Entity_Id; 2590 Efam_Decl : Node_Id; 2591 Efam_Type : Entity_Id; 2592 2593 begin 2594 Efam := First_Entity (Conctyp); 2595 2596 while Present (Efam) loop 2597 2598 if Ekind (Efam) = E_Entry_Family then 2599 Efam_Type := 2600 Make_Defining_Identifier (Loc, 2601 Chars => New_Internal_Name ('F')); 2602 2603 Efam_Decl := 2604 Make_Full_Type_Declaration (Loc, 2605 Defining_Identifier => Efam_Type, 2606 Type_Definition => 2607 Make_Unconstrained_Array_Definition (Loc, 2608 Subtype_Marks => (New_List ( 2609 New_Occurrence_Of ( 2610 Base_Type 2611 (Etype (Discrete_Subtype_Definition 2612 (Parent (Efam)))), Loc))), 2613 2614 Component_Definition => 2615 Make_Component_Definition (Loc, 2616 Aliased_Present => False, 2617 Subtype_Indication => 2618 New_Reference_To (Standard_Character, Loc)))); 2619 2620 Insert_After (Current_Node, Efam_Decl); 2621 Current_Node := Efam_Decl; 2622 Analyze (Efam_Decl); 2623 2624 Append_To (Cdecls, 2625 Make_Component_Declaration (Loc, 2626 Defining_Identifier => 2627 Make_Defining_Identifier (Loc, Chars (Efam)), 2628 2629 Component_Definition => 2630 Make_Component_Definition (Loc, 2631 Aliased_Present => False, 2632 2633 Subtype_Indication => 2634 Make_Subtype_Indication (Loc, 2635 Subtype_Mark => 2636 New_Occurrence_Of (Efam_Type, Loc), 2637 2638 Constraint => 2639 Make_Index_Or_Discriminant_Constraint (Loc, 2640 Constraints => New_List ( 2641 New_Occurrence_Of 2642 (Etype (Discrete_Subtype_Definition 2643 (Parent (Efam))), Loc))))))); 2644 2645 2646 end if; 2647 2648 Next_Entity (Efam); 2649 end loop; 2650 end Collect_Entry_Families; 2651 2652 -------------------- 2653 -- Concurrent_Ref -- 2654 -------------------- 2655 2656 -- The expression returned for a reference to a concurrent 2657 -- object has the form: 2658 2659 -- taskV!(name)._Task_Id 2660 2661 -- for a task, and 2662 2663 -- objectV!(name)._Object 2664 2665 -- for a protected object. 2666 2667 -- For the case of an access to a concurrent object, 2668 -- there is an extra explicit dereference: 2669 2670 -- taskV!(name.all)._Task_Id 2671 -- objectV!(name.all)._Object 2672 2673 -- here taskV and objectV are the types for the associated records, which 2674 -- contain the required _Task_Id and _Object fields for tasks and 2675 -- protected objects, respectively. 2676 2677 -- For the case of a task type name, the expression is 2678 2679 -- Self; 2680 2681 -- i.e. a call to the Self function which returns precisely this Task_Id 2682 2683 -- For the case of a protected type name, the expression is 2684 2685 -- objectR 2686 2687 -- which is a renaming of the _object field of the current object 2688 -- object record, passed into protected operations as a parameter. 2689 2690 function Concurrent_Ref (N : Node_Id) return Node_Id is 2691 Loc : constant Source_Ptr := Sloc (N); 2692 Ntyp : constant Entity_Id := Etype (N); 2693 Dtyp : Entity_Id; 2694 Sel : Name_Id; 2695 2696 function Is_Current_Task (T : Entity_Id) return Boolean; 2697 -- Check whether the reference is to the immediately enclosing task 2698 -- type, or to an outer one (rare but legal). 2699 2700 --------------------- 2701 -- Is_Current_Task -- 2702 --------------------- 2703 2704 function Is_Current_Task (T : Entity_Id) return Boolean is 2705 Scop : Entity_Id; 2706 2707 begin 2708 Scop := Current_Scope; 2709 while Present (Scop) 2710 and then Scop /= Standard_Standard 2711 loop 2712 2713 if Scop = T then 2714 return True; 2715 2716 elsif Is_Task_Type (Scop) then 2717 return False; 2718 2719 -- If this is a procedure nested within the task type, we must 2720 -- assume that it can be called from an inner task, and therefore 2721 -- cannot treat it as a local reference. 2722 2723 elsif Is_Overloadable (Scop) 2724 and then In_Open_Scopes (T) 2725 then 2726 return False; 2727 2728 else 2729 Scop := Scope (Scop); 2730 end if; 2731 end loop; 2732 2733 -- We know that we are within the task body, so should have 2734 -- found it in scope. 2735 2736 raise Program_Error; 2737 end Is_Current_Task; 2738 2739 -- Start of processing for Concurrent_Ref 2740 2741 begin 2742 if Is_Access_Type (Ntyp) then 2743 Dtyp := Designated_Type (Ntyp); 2744 2745 if Is_Protected_Type (Dtyp) then 2746 Sel := Name_uObject; 2747 else 2748 Sel := Name_uTask_Id; 2749 end if; 2750 2751 return 2752 Make_Selected_Component (Loc, 2753 Prefix => 2754 Unchecked_Convert_To (Corresponding_Record_Type (Dtyp), 2755 Make_Explicit_Dereference (Loc, N)), 2756 Selector_Name => Make_Identifier (Loc, Sel)); 2757 2758 elsif Is_Entity_Name (N) 2759 and then Is_Concurrent_Type (Entity (N)) 2760 then 2761 if Is_Task_Type (Entity (N)) then 2762 2763 if Is_Current_Task (Entity (N)) then 2764 return 2765 Make_Function_Call (Loc, 2766 Name => New_Reference_To (RTE (RE_Self), Loc)); 2767 2768 else 2769 declare 2770 Decl : Node_Id; 2771 T_Self : constant Entity_Id 2772 := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); 2773 T_Body : constant Node_Id 2774 := Parent (Corresponding_Body (Parent (Entity (N)))); 2775 2776 begin 2777 Decl := Make_Object_Declaration (Loc, 2778 Defining_Identifier => T_Self, 2779 Object_Definition => 2780 New_Occurrence_Of (RTE (RO_ST_Task_ID), Loc), 2781 Expression => 2782 Make_Function_Call (Loc, 2783 Name => New_Reference_To (RTE (RE_Self), Loc))); 2784 Prepend (Decl, Declarations (T_Body)); 2785 Analyze (Decl); 2786 Set_Scope (T_Self, Entity (N)); 2787 return New_Occurrence_Of (T_Self, Loc); 2788 end; 2789 end if; 2790 2791 else 2792 pragma Assert (Is_Protected_Type (Entity (N))); 2793 return 2794 New_Reference_To ( 2795 Object_Ref (Corresponding_Body (Parent (Base_Type (Ntyp)))), 2796 Loc); 2797 end if; 2798 2799 else 2800 pragma Assert (Is_Concurrent_Type (Ntyp)); 2801 2802 if Is_Protected_Type (Ntyp) then 2803 Sel := Name_uObject; 2804 else 2805 Sel := Name_uTask_Id; 2806 end if; 2807 2808 return 2809 Make_Selected_Component (Loc, 2810 Prefix => 2811 Unchecked_Convert_To (Corresponding_Record_Type (Ntyp), 2812 New_Copy_Tree (N)), 2813 Selector_Name => Make_Identifier (Loc, Sel)); 2814 end if; 2815 end Concurrent_Ref; 2816 2817 ------------------------ 2818 -- Convert_Concurrent -- 2819 ------------------------ 2820 2821 function Convert_Concurrent 2822 (N : Node_Id; 2823 Typ : Entity_Id) return Node_Id 2824 is 2825 begin 2826 if not Is_Concurrent_Type (Typ) then 2827 return N; 2828 else 2829 return 2830 Unchecked_Convert_To (Corresponding_Record_Type (Typ), 2831 New_Copy_Tree (N)); 2832 end if; 2833 end Convert_Concurrent; 2834 2835 ---------------------------- 2836 -- Entry_Index_Expression -- 2837 ---------------------------- 2838 2839 function Entry_Index_Expression 2840 (Sloc : Source_Ptr; 2841 Ent : Entity_Id; 2842 Index : Node_Id; 2843 Ttyp : Entity_Id) return Node_Id 2844 is 2845 Expr : Node_Id; 2846 Num : Node_Id; 2847 Lo : Node_Id; 2848 Hi : Node_Id; 2849 Prev : Entity_Id; 2850 S : Node_Id; 2851 2852 begin 2853 -- The queues of entries and entry families appear in textual 2854 -- order in the associated record. The entry index is computed as 2855 -- the sum of the number of queues for all entries that precede the 2856 -- designated one, to which is added the index expression, if this 2857 -- expression denotes a member of a family. 2858 2859 -- The following is a place holder for the count of simple entries. 2860 2861 Num := Make_Integer_Literal (Sloc, 1); 2862 2863 -- We construct an expression which is a series of addition 2864 -- operations. The first operand is the number of single entries that 2865 -- precede this one, the second operand is the index value relative 2866 -- to the start of the referenced family, and the remaining operands 2867 -- are the lengths of the entry families that precede this entry, i.e. 2868 -- the constructed expression is: 2869 2870 -- number_simple_entries + 2871 -- (s'pos (index-value) - s'pos (family'first)) + 1 + 2872 -- family'length + ... 2873 2874 -- where index-value is the given index value, and s is the index 2875 -- subtype (we have to use pos because the subtype might be an 2876 -- enumeration type preventing direct subtraction). 2877 -- Note that the task entry array is one-indexed. 2878 2879 -- The upper bound of the entry family may be a discriminant, so we 2880 -- retrieve the lower bound explicitly to compute offset, rather than 2881 -- using the index subtype which may mention a discriminant. 2882 2883 if Present (Index) then 2884 S := Etype (Discrete_Subtype_Definition (Declaration_Node (Ent))); 2885 2886 Expr := 2887 Make_Op_Add (Sloc, 2888 Left_Opnd => Num, 2889 2890 Right_Opnd => 2891 Family_Offset ( 2892 Sloc, 2893 Make_Attribute_Reference (Sloc, 2894 Attribute_Name => Name_Pos, 2895 Prefix => New_Reference_To (Base_Type (S), Sloc), 2896 Expressions => New_List (Relocate_Node (Index))), 2897 Type_Low_Bound (S), 2898 Ttyp)); 2899 else 2900 Expr := Num; 2901 end if; 2902 2903 -- Now add lengths of preceding entries and entry families. 2904 2905 Prev := First_Entity (Ttyp); 2906 2907 while Chars (Prev) /= Chars (Ent) 2908 or else (Ekind (Prev) /= Ekind (Ent)) 2909 or else not Sem_Ch6.Type_Conformant (Ent, Prev) 2910 loop 2911 if Ekind (Prev) = E_Entry then 2912 Set_Intval (Num, Intval (Num) + 1); 2913 2914 elsif Ekind (Prev) = E_Entry_Family then 2915 S := 2916 Etype (Discrete_Subtype_Definition (Declaration_Node (Prev))); 2917 Lo := Type_Low_Bound (S); 2918 Hi := Type_High_Bound (S); 2919 2920 Expr := 2921 Make_Op_Add (Sloc, 2922 Left_Opnd => Expr, 2923 Right_Opnd => Family_Size (Sloc, Hi, Lo, Ttyp)); 2924 2925 -- Other components are anonymous types to be ignored. 2926 2927 else 2928 null; 2929 end if; 2930 2931 Next_Entity (Prev); 2932 end loop; 2933 2934 return Expr; 2935 end Entry_Index_Expression; 2936 2937 --------------------------- 2938 -- Establish_Task_Master -- 2939 --------------------------- 2940 2941 procedure Establish_Task_Master (N : Node_Id) is 2942 Call : Node_Id; 2943 2944 begin 2945 if Restrictions (No_Task_Hierarchy) = False then 2946 Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master); 2947 Prepend_To (Declarations (N), Call); 2948 Analyze (Call); 2949 end if; 2950 end Establish_Task_Master; 2951 2952 -------------------------------- 2953 -- Expand_Accept_Declarations -- 2954 -------------------------------- 2955 2956 -- Part of the expansion of an accept statement involves the creation of 2957 -- a declaration that can be referenced from the statement sequence of 2958 -- the accept: 2959 2960 -- Ann : Address; 2961 2962 -- This declaration is inserted immediately before the accept statement 2963 -- and it is important that it be inserted before the statements of the 2964 -- statement sequence are analyzed. Thus it would be too late to create 2965 -- this declaration in the Expand_N_Accept_Statement routine, which is 2966 -- why there is a separate procedure to be called directly from Sem_Ch9. 2967 2968 -- Ann is used to hold the address of the record containing the parameters 2969 -- (see Expand_N_Entry_Call for more details on how this record is built). 2970 -- References to the parameters do an unchecked conversion of this address 2971 -- to a pointer to the required record type, and then access the field that 2972 -- holds the value of the required parameter. The entity for the address 2973 -- variable is held as the top stack element (i.e. the last element) of the 2974 -- Accept_Address stack in the corresponding entry entity, and this element 2975 -- must be set in place before the statements are processed. 2976 2977 -- The above description applies to the case of a stand alone accept 2978 -- statement, i.e. one not appearing as part of a select alternative. 2979 2980 -- For the case of an accept that appears as part of a select alternative 2981 -- of a selective accept, we must still create the declaration right away, 2982 -- since Ann is needed immediately, but there is an important difference: 2983 2984 -- The declaration is inserted before the selective accept, not before 2985 -- the accept statement (which is not part of a list anyway, and so would 2986 -- not accommodate inserted declarations) 2987 2988 -- We only need one address variable for the entire selective accept. So 2989 -- the Ann declaration is created only for the first accept alternative, 2990 -- and subsequent accept alternatives reference the same Ann variable. 2991 2992 -- We can distinguish the two cases by seeing whether the accept statement 2993 -- is part of a list. If not, then it must be in an accept alternative. 2994 2995 -- To expand the requeue statement, a label is provided at the end of 2996 -- the accept statement or alternative of which it is a part, so that 2997 -- the statement can be skipped after the requeue is complete. 2998 -- This label is created here rather than during the expansion of the 2999 -- accept statement, because it will be needed by any requeue 3000 -- statements within the accept, which are expanded before the 3001 -- accept. 3002 3003 procedure Expand_Accept_Declarations (N : Node_Id; Ent : Entity_Id) is 3004 Loc : constant Source_Ptr := Sloc (N); 3005 Ann : Entity_Id := Empty; 3006 Adecl : Node_Id; 3007 Lab_Id : Node_Id; 3008 Lab : Node_Id; 3009 Ldecl : Node_Id; 3010 Ldecl2 : Node_Id; 3011 3012 begin 3013 if Expander_Active then 3014 3015 -- If we have no handled statement sequence, then build a dummy 3016 -- sequence consisting of a null statement. This is only done if 3017 -- pragma FIFO_Within_Priorities is specified. The issue here is 3018 -- that even a null accept body has an effect on the called task 3019 -- in terms of its position in the queue, so we cannot optimize 3020 -- the context switch away. However, if FIFO_Within_Priorities 3021 -- is not active, the optimization is legitimate, since we can 3022 -- say that our dispatching policy (i.e. the default dispatching 3023 -- policy) reorders the queue to be the same as just before the 3024 -- call. In the absence of a specified dispatching policy, we are 3025 -- allowed to modify queue orders for a given priority at will! 3026 3027 if Opt.Task_Dispatching_Policy = 'F' and then 3028 not Present (Handled_Statement_Sequence (N)) 3029 then 3030 Set_Handled_Statement_Sequence (N, 3031 Make_Handled_Sequence_Of_Statements (Loc, 3032 New_List (Make_Null_Statement (Loc)))); 3033 end if; 3034 3035 -- Create and declare two labels to be placed at the end of the 3036 -- accept statement. The first label is used to allow requeues to 3037 -- skip the remainder of entry processing. The second label is 3038 -- used to skip the remainder of entry processing if the rendezvous 3039 -- completes in the middle of the accept body. 3040 3041 if Present (Handled_Statement_Sequence (N)) then 3042 Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L')); 3043 Set_Entity (Lab_Id, 3044 Make_Defining_Identifier (Loc, Chars (Lab_Id))); 3045 Lab := Make_Label (Loc, Lab_Id); 3046 Ldecl := 3047 Make_Implicit_Label_Declaration (Loc, 3048 Defining_Identifier => Entity (Lab_Id), 3049 Label_Construct => Lab); 3050 Append (Lab, Statements (Handled_Statement_Sequence (N))); 3051 3052 Lab_Id := Make_Identifier (Loc, New_Internal_Name ('L')); 3053 Set_Entity (Lab_Id, 3054 Make_Defining_Identifier (Loc, Chars (Lab_Id))); 3055 Lab := Make_Label (Loc, Lab_Id); 3056 Ldecl2 := 3057 Make_Implicit_Label_Declaration (Loc, 3058 Defining_Identifier => Entity (Lab_Id), 3059 Label_Construct => Lab); 3060 Append (Lab, Statements (Handled_Statement_Sequence (N))); 3061 3062 else 3063 Ldecl := Empty; 3064 Ldecl2 := Empty; 3065 end if; 3066 3067 -- Case of stand alone accept statement 3068 3069 if Is_List_Member (N) then 3070 3071 if Present (Handled_Statement_Sequence (N)) then 3072 Ann := 3073 Make_Defining_Identifier (Loc, 3074 Chars => New_Internal_Name ('A')); 3075 3076 Adecl := 3077 Make_Object_Declaration (Loc, 3078 Defining_Identifier => Ann, 3079 Object_Definition => 3080 New_Reference_To (RTE (RE_Address), Loc)); 3081 3082 Insert_Before (N, Adecl); 3083 Analyze (Adecl); 3084 3085 Insert_Before (N, Ldecl); 3086 Analyze (Ldecl); 3087 3088 Insert_Before (N, Ldecl2); 3089 Analyze (Ldecl2); 3090 end if; 3091 3092 -- Case of accept statement which is in an accept alternative 3093 3094 else 3095 declare 3096 Acc_Alt : constant Node_Id := Parent (N); 3097 Sel_Acc : constant Node_Id := Parent (Acc_Alt); 3098 Alt : Node_Id; 3099 3100 begin 3101 pragma Assert (Nkind (Acc_Alt) = N_Accept_Alternative); 3102 pragma Assert (Nkind (Sel_Acc) = N_Selective_Accept); 3103 3104 -- ??? Consider a single label for select statements. 3105 3106 if Present (Handled_Statement_Sequence (N)) then 3107 Prepend (Ldecl2, 3108 Statements (Handled_Statement_Sequence (N))); 3109 Analyze (Ldecl2); 3110 3111 Prepend (Ldecl, 3112 Statements (Handled_Statement_Sequence (N))); 3113 Analyze (Ldecl); 3114 end if; 3115 3116 -- Find first accept alternative of the selective accept. A 3117 -- valid selective accept must have at least one accept in it. 3118 3119 Alt := First (Select_Alternatives (Sel_Acc)); 3120 3121 while Nkind (Alt) /= N_Accept_Alternative loop 3122 Next (Alt); 3123 end loop; 3124 3125 -- If we are the first accept statement, then we have to 3126 -- create the Ann variable, as for the stand alone case, 3127 -- except that it is inserted before the selective accept. 3128 -- Similarly, a label for requeue expansion must be 3129 -- declared. 3130 3131 if N = Accept_Statement (Alt) then 3132 Ann := 3133 Make_Defining_Identifier (Loc, New_Internal_Name ('A')); 3134 3135 Adecl := 3136 Make_Object_Declaration (Loc, 3137 Defining_Identifier => Ann, 3138 Object_Definition => 3139 New_Reference_To (RTE (RE_Address), Loc)); 3140 3141 Insert_Before (Sel_Acc, Adecl); 3142 Analyze (Adecl); 3143 3144 -- If we are not the first accept statement, then find the 3145 -- Ann variable allocated by the first accept and use it. 3146 3147 else 3148 Ann := 3149 Node (Last_Elmt (Accept_Address 3150 (Entity (Entry_Direct_Name (Accept_Statement (Alt)))))); 3151 end if; 3152 end; 3153 end if; 3154 3155 -- Merge here with Ann either created or referenced, and Adecl 3156 -- pointing to the corresponding declaration. Remaining processing 3157 -- is the same for the two cases. 3158 3159 if Present (Ann) then 3160 Append_Elmt (Ann, Accept_Address (Ent)); 3161 Set_Needs_Debug_Info (Ann); 3162 end if; 3163 3164 -- Create renaming declarations for the entry formals. Each 3165 -- reference to a formal becomes a dereference of a component 3166 -- of the parameter block, whose address is held in Ann. 3167 -- These declarations are eventually inserted into the accept 3168 -- block, and analyzed there so that they have the proper scope 3169 -- for gdb and do not conflict with other declarations. 3170 3171 if Present (Parameter_Specifications (N)) 3172 and then Present (Handled_Statement_Sequence (N)) 3173 then 3174 declare 3175 Formal : Entity_Id; 3176 New_F : Entity_Id; 3177 Comp : Entity_Id; 3178 Decl : Node_Id; 3179 3180 begin 3181 New_Scope (Ent); 3182 Formal := First_Formal (Ent); 3183 3184 while Present (Formal) loop 3185 Comp := Entry_Component (Formal); 3186 New_F := 3187 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); 3188 Set_Etype (New_F, Etype (Formal)); 3189 Set_Scope (New_F, Ent); 3190 Set_Needs_Debug_Info (New_F); -- That's the whole point. 3191 3192 if Ekind (Formal) = E_In_Parameter then 3193 Set_Ekind (New_F, E_Constant); 3194 else 3195 Set_Ekind (New_F, E_Variable); 3196 Set_Extra_Constrained (New_F, Extra_Constrained (Formal)); 3197 end if; 3198 3199 Set_Actual_Subtype (New_F, Actual_Subtype (Formal)); 3200 3201 Decl := 3202 Make_Object_Renaming_Declaration (Loc, 3203 Defining_Identifier => New_F, 3204 Subtype_Mark => New_Reference_To (Etype (Formal), Loc), 3205 Name => 3206 Make_Explicit_Dereference (Loc, 3207 Make_Selected_Component (Loc, 3208 Prefix => 3209 Unchecked_Convert_To (Entry_Parameters_Type (Ent), 3210 New_Reference_To (Ann, Loc)), 3211 Selector_Name => 3212 New_Reference_To (Comp, Loc)))); 3213 3214 if No (Declarations (N)) then 3215 Set_Declarations (N, New_List); 3216 end if; 3217 3218 Append (Decl, Declarations (N)); 3219 Set_Renamed_Object (Formal, New_F); 3220 Next_Formal (Formal); 3221 end loop; 3222 3223 End_Scope; 3224 end; 3225 end if; 3226 end if; 3227 end Expand_Accept_Declarations; 3228 3229 --------------------------------------------- 3230 -- Expand_Access_Protected_Subprogram_Type -- 3231 --------------------------------------------- 3232 3233 procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is 3234 Loc : constant Source_Ptr := Sloc (N); 3235 Comps : List_Id; 3236 T : constant Entity_Id := Defining_Identifier (N); 3237 D_T : constant Entity_Id := Designated_Type (T); 3238 D_T2 : constant Entity_Id := Make_Defining_Identifier 3239 (Loc, New_Internal_Name ('D')); 3240 E_T : constant Entity_Id := Make_Defining_Identifier 3241 (Loc, New_Internal_Name ('E')); 3242 P_List : constant List_Id := Build_Protected_Spec 3243 (N, RTE (RE_Address), False, D_T); 3244 Decl1 : Node_Id; 3245 Decl2 : Node_Id; 3246 Def1 : Node_Id; 3247 3248 begin 3249 -- Create access to protected subprogram with full signature. 3250 3251 if Nkind (Type_Definition (N)) = N_Access_Function_Definition then 3252 Def1 := 3253 Make_Access_Function_Definition (Loc, 3254 Parameter_Specifications => P_List, 3255 Subtype_Mark => New_Copy (Subtype_Mark (Type_Definition (N)))); 3256 3257 else 3258 Def1 := 3259 Make_Access_Procedure_Definition (Loc, 3260 Parameter_Specifications => P_List); 3261 end if; 3262 3263 Decl1 := 3264 Make_Full_Type_Declaration (Loc, 3265 Defining_Identifier => D_T2, 3266 Type_Definition => Def1); 3267 3268 Insert_After (N, Decl1); 3269 3270 -- Create Equivalent_Type, a record with two components for an 3271 -- an access to object an an access to subprogram. 3272 3273 Comps := New_List ( 3274 Make_Component_Declaration (Loc, 3275 Defining_Identifier => 3276 Make_Defining_Identifier (Loc, New_Internal_Name ('P')), 3277 Component_Definition => 3278 Make_Component_Definition (Loc, 3279 Aliased_Present => False, 3280 Subtype_Indication => 3281 New_Occurrence_Of (RTE (RE_Address), Loc))), 3282 3283 Make_Component_Declaration (Loc, 3284 Defining_Identifier => 3285 Make_Defining_Identifier (Loc, New_Internal_Name ('S')), 3286 Component_Definition => 3287 Make_Component_Definition (Loc, 3288 Aliased_Present => False, 3289 Subtype_Indication => New_Occurrence_Of (D_T2, Loc)))); 3290 3291 Decl2 := 3292 Make_Full_Type_Declaration (Loc, 3293 Defining_Identifier => E_T, 3294 Type_Definition => 3295 Make_Record_Definition (Loc, 3296 Component_List => 3297 Make_Component_List (Loc, 3298 Component_Items => Comps))); 3299 3300 Insert_After (Decl1, Decl2); 3301 Set_Equivalent_Type (T, E_T); 3302 end Expand_Access_Protected_Subprogram_Type; 3303 3304 -------------------------- 3305 -- Expand_Entry_Barrier -- 3306 -------------------------- 3307 3308 procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is 3309 Loc : constant Source_Ptr := Sloc (N); 3310 Prot : constant Entity_Id := Scope (Ent); 3311 Spec_Decl : constant Node_Id := Parent (Prot); 3312 Cond : constant Node_Id := 3313 Condition (Entry_Body_Formal_Part (N)); 3314 Func : Node_Id; 3315 B_F : Node_Id; 3316 Body_Decl : Node_Id; 3317 3318 begin 3319 if No_Run_Time_Mode then 3320 Error_Msg_CRT ("entry barrier", N); 3321 return; 3322 end if; 3323 3324 -- The body of the entry barrier must be analyzed in the context of 3325 -- the protected object, but its scope is external to it, just as any 3326 -- other unprotected version of a protected operation. The specification 3327 -- has been produced when the protected type declaration was elaborated. 3328 -- We build the body, insert it in the enclosing scope, but analyze it 3329 -- in the current context. A more uniform approach would be to treat a 3330 -- barrier just as a protected function, and discard the protected 3331 -- version of it because it is never called. 3332 3333 if Expander_Active then 3334 B_F := Build_Barrier_Function (N, Ent, Prot); 3335 Func := Barrier_Function (Ent); 3336 Set_Corresponding_Spec (B_F, Func); 3337 3338 Body_Decl := Parent (Corresponding_Body (Spec_Decl)); 3339 3340 if Nkind (Parent (Body_Decl)) = N_Subunit then 3341 Body_Decl := Corresponding_Stub (Parent (Body_Decl)); 3342 end if; 3343 3344 Insert_Before_And_Analyze (Body_Decl, B_F); 3345 3346 Update_Prival_Subtypes (B_F); 3347 3348 Set_Privals (Spec_Decl, N, Loc); 3349 Set_Discriminals (Spec_Decl); 3350 Set_Scope (Func, Scope (Prot)); 3351 3352 else 3353 Analyze (Cond); 3354 end if; 3355 3356 -- The Ravenscar profile restricts barriers to simple variables 3357 -- declared within the protected object. We also allow Boolean 3358 -- constants, since these appear in several published examples 3359 -- and are also allowed by the Aonix compiler. 3360 3361 -- Note that after analysis variables in this context will be 3362 -- replaced by the corresponding prival, that is to say a renaming 3363 -- of a selected component of the form _Object.Var. If expansion is 3364 -- disabled, as within a generic, we check that the entity appears in 3365 -- the current scope. 3366 3367 if Is_Entity_Name (Cond) then 3368 3369 if Entity (Cond) = Standard_False 3370 or else 3371 Entity (Cond) = Standard_True 3372 then 3373 return; 3374 3375 elsif not Expander_Active 3376 and then Scope (Entity (Cond)) = Current_Scope 3377 then 3378 return; 3379 3380 -- Check for case of _object.all.field (note that the explicit 3381 -- dereference gets inserted by analyze/expand of _object.field) 3382 3383 elsif Present (Renamed_Object (Entity (Cond))) 3384 and then 3385 Nkind (Renamed_Object (Entity (Cond))) = N_Selected_Component 3386 and then 3387 Chars 3388 (Prefix 3389 (Prefix (Renamed_Object (Entity (Cond))))) = Name_uObject 3390 then 3391 return; 3392 end if; 3393 end if; 3394 3395 -- It is not a boolean variable or literal, so check the restriction 3396 3397 Check_Restriction (Boolean_Entry_Barriers, Cond); 3398 end Expand_Entry_Barrier; 3399 3400 ------------------------------------ 3401 -- Expand_Entry_Body_Declarations -- 3402 ------------------------------------ 3403 3404 procedure Expand_Entry_Body_Declarations (N : Node_Id) is 3405 Loc : constant Source_Ptr := Sloc (N); 3406 Index_Spec : Node_Id; 3407 3408 begin 3409 if Expander_Active then 3410 3411 -- Expand entry bodies corresponding to entry families 3412 -- by assigning a placeholder for the constant that will 3413 -- be used to expand references to the entry index parameter. 3414 3415 Index_Spec := 3416 Entry_Index_Specification (Entry_Body_Formal_Part (N)); 3417 3418 if Present (Index_Spec) then 3419 Set_Entry_Index_Constant ( 3420 Defining_Identifier (Index_Spec), 3421 Make_Defining_Identifier (Loc, New_Internal_Name ('J'))); 3422 end if; 3423 end if; 3424 end Expand_Entry_Body_Declarations; 3425 3426 ------------------------------ 3427 -- Expand_N_Abort_Statement -- 3428 ------------------------------ 3429 3430 -- Expand abort T1, T2, .. Tn; into: 3431 -- Abort_Tasks (Task_List'(1 => T1.Task_Id, 2 => T2.Task_Id ...)) 3432 3433 procedure Expand_N_Abort_Statement (N : Node_Id) is 3434 Loc : constant Source_Ptr := Sloc (N); 3435 Tlist : constant List_Id := Names (N); 3436 Count : Nat; 3437 Aggr : Node_Id; 3438 Tasknm : Node_Id; 3439 3440 begin 3441 Aggr := Make_Aggregate (Loc, Component_Associations => New_List); 3442 Count := 0; 3443 3444 Tasknm := First (Tlist); 3445 3446 while Present (Tasknm) loop 3447 Count := Count + 1; 3448 Append_To (Component_Associations (Aggr), 3449 Make_Component_Association (Loc, 3450 Choices => New_List ( 3451 Make_Integer_Literal (Loc, Count)), 3452 Expression => Concurrent_Ref (Tasknm))); 3453 Next (Tasknm); 3454 end loop; 3455 3456 Rewrite (N, 3457 Make_Procedure_Call_Statement (Loc, 3458 Name => New_Reference_To (RTE (RE_Abort_Tasks), Loc), 3459 Parameter_Associations => New_List ( 3460 Make_Qualified_Expression (Loc, 3461 Subtype_Mark => New_Reference_To (RTE (RE_Task_List), Loc), 3462 Expression => Aggr)))); 3463 3464 Analyze (N); 3465 end Expand_N_Abort_Statement; 3466 3467 ------------------------------- 3468 -- Expand_N_Accept_Statement -- 3469 ------------------------------- 3470 3471 -- This procedure handles expansion of accept statements that stand 3472 -- alone, i.e. they are not part of an accept alternative. The expansion 3473 -- of accept statement in accept alternatives is handled by the routines 3474 -- Expand_N_Accept_Alternative and Expand_N_Selective_Accept. The 3475 -- following description applies only to stand alone accept statements. 3476 3477 -- If there is no handled statement sequence, or only null statements, 3478 -- then this is called a trivial accept, and the expansion is: 3479 3480 -- Accept_Trivial (entry-index) 3481 3482 -- If there is a handled statement sequence, then the expansion is: 3483 3484 -- Ann : Address; 3485 -- {Lnn : Label} 3486 3487 -- begin 3488 -- begin 3489 -- Accept_Call (entry-index, Ann); 3490 -- Renaming_Declarations for formals 3491 -- <statement sequence from N_Accept_Statement node> 3492 -- Complete_Rendezvous; 3493 -- <<Lnn>> 3494 -- 3495 -- exception 3496 -- when ... => 3497 -- <exception handler from N_Accept_Statement node> 3498 -- Complete_Rendezvous; 3499 -- when ... => 3500 -- <exception handler from N_Accept_Statement node> 3501 -- Complete_Rendezvous; 3502 -- ... 3503 -- end; 3504 3505 -- exception 3506 -- when all others => 3507 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 3508 -- end; 3509 3510 -- The first three declarations were already inserted ahead of the 3511 -- accept statement by the Expand_Accept_Declarations procedure, which 3512 -- was called directly from the semantics during analysis of the accept. 3513 -- statement, before analyzing its contained statements. 3514 3515 -- The declarations from the N_Accept_Statement, as noted in Sinfo, come 3516 -- from possible expansion activity (the original source of course does 3517 -- not have any declarations associated with the accept statement, since 3518 -- an accept statement has no declarative part). In particular, if the 3519 -- expander is active, the first such declaration is the declaration of 3520 -- the Accept_Params_Ptr entity (see Sem_Ch9.Analyze_Accept_Statement). 3521 -- 3522 -- The two blocks are merged into a single block if the inner block has 3523 -- no exception handlers, but otherwise two blocks are required, since 3524 -- exceptions might be raised in the exception handlers of the inner 3525 -- block, and Exceptional_Complete_Rendezvous must be called. 3526 3527 procedure Expand_N_Accept_Statement (N : Node_Id) is 3528 Loc : constant Source_Ptr := Sloc (N); 3529 Stats : constant Node_Id := Handled_Statement_Sequence (N); 3530 Ename : constant Node_Id := Entry_Direct_Name (N); 3531 Eindx : constant Node_Id := Entry_Index (N); 3532 Eent : constant Entity_Id := Entity (Ename); 3533 Acstack : constant Elist_Id := Accept_Address (Eent); 3534 Ann : constant Entity_Id := Node (Last_Elmt (Acstack)); 3535 Ttyp : constant Entity_Id := Etype (Scope (Eent)); 3536 Blkent : Entity_Id; 3537 Call : Node_Id; 3538 Block : Node_Id; 3539 3540 function Null_Statements (Stats : List_Id) return Boolean; 3541 -- Check for null statement sequence (i.e a list of labels and 3542 -- null statements) 3543 3544 function Null_Statements (Stats : List_Id) return Boolean is 3545 Stmt : Node_Id; 3546 3547 begin 3548 Stmt := First (Stats); 3549 while Nkind (Stmt) /= N_Empty 3550 and then (Nkind (Stmt) = N_Null_Statement 3551 or else 3552 Nkind (Stmt) = N_Label) 3553 loop 3554 Next (Stmt); 3555 end loop; 3556 3557 return Nkind (Stmt) = N_Empty; 3558 end Null_Statements; 3559 3560 -- Start of processing for Expand_N_Accept_Statement 3561 3562 begin 3563 -- If accept statement is not part of a list, then its parent must be 3564 -- an accept alternative, and, as described above, we do not do any 3565 -- expansion for such accept statements at this level. 3566 3567 if not Is_List_Member (N) then 3568 pragma Assert (Nkind (Parent (N)) = N_Accept_Alternative); 3569 return; 3570 3571 -- Trivial accept case (no statement sequence, or null statements). 3572 -- If the accept statement has declarations, then just insert them 3573 -- before the procedure call. 3574 3575 -- We avoid this optimization when FIFO_Within_Priorities is active, 3576 -- since it is not correct according to annex D semantics. The problem 3577 -- is that the call is required to reorder the acceptors position on 3578 -- its ready queue, even though there is nothing to be done. However, 3579 -- if no policy is specified, then we decide that our dispatching 3580 -- policy always reorders the queue right after the RV to look the 3581 -- way they were just before the RV. Since we are allowed to freely 3582 -- reorder same-priority queues (this is part of what dispatching 3583 -- policies are all about), the optimization is legitimate. 3584 3585 elsif Opt.Task_Dispatching_Policy /= 'F' 3586 and then (No (Stats) or else Null_Statements (Statements (Stats))) 3587 then 3588 -- Remove declarations for renamings, because the parameter block 3589 -- will not be assigned. 3590 3591 declare 3592 D : Node_Id; 3593 Next_D : Node_Id; 3594 3595 begin 3596 D := First (Declarations (N)); 3597 3598 while Present (D) loop 3599 Next_D := Next (D); 3600 if Nkind (D) = N_Object_Renaming_Declaration then 3601 Remove (D); 3602 end if; 3603 3604 D := Next_D; 3605 end loop; 3606 end; 3607 3608 if Present (Declarations (N)) then 3609 Insert_Actions (N, Declarations (N)); 3610 end if; 3611 3612 Rewrite (N, 3613 Make_Procedure_Call_Statement (Loc, 3614 Name => New_Reference_To (RTE (RE_Accept_Trivial), Loc), 3615 Parameter_Associations => New_List ( 3616 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp)))); 3617 3618 Analyze (N); 3619 3620 -- Discard Entry_Address that was created for it, so it will not be 3621 -- emitted if this accept statement is in the statement part of a 3622 -- delay alternative. 3623 3624 if Present (Stats) then 3625 Remove_Last_Elmt (Acstack); 3626 end if; 3627 3628 -- Case of statement sequence present 3629 3630 else 3631 -- Construct the block, using the declarations from the accept 3632 -- statement if any to initialize the declarations of the block. 3633 3634 Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); 3635 Set_Ekind (Blkent, E_Block); 3636 Set_Etype (Blkent, Standard_Void_Type); 3637 Set_Scope (Blkent, Current_Scope); 3638 3639 Block := 3640 Make_Block_Statement (Loc, 3641 Identifier => New_Reference_To (Blkent, Loc), 3642 Declarations => Declarations (N), 3643 Handled_Statement_Sequence => Build_Accept_Body (N)); 3644 3645 -- Prepend call to Accept_Call to main statement sequence 3646 -- If the accept has exception handlers, the statement sequence 3647 -- is wrapped in a block. Insert call and renaming declarations 3648 -- in the declarations of the block, so they are elaborated before 3649 -- the handlers. 3650 3651 Call := 3652 Make_Procedure_Call_Statement (Loc, 3653 Name => New_Reference_To (RTE (RE_Accept_Call), Loc), 3654 Parameter_Associations => New_List ( 3655 Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp), 3656 New_Reference_To (Ann, Loc))); 3657 3658 if Parent (Stats) = N then 3659 Prepend (Call, Statements (Stats)); 3660 else 3661 Set_Declarations 3662 (Parent (Stats), 3663 New_List (Call)); 3664 end if; 3665 3666 Analyze (Call); 3667 3668 New_Scope (Blkent); 3669 3670 declare 3671 D : Node_Id; 3672 Next_D : Node_Id; 3673 Typ : Entity_Id; 3674 begin 3675 D := First (Declarations (N)); 3676 3677 while Present (D) loop 3678 Next_D := Next (D); 3679 3680 if Nkind (D) = N_Object_Renaming_Declaration then 3681 -- The renaming declarations for the formals were 3682 -- created during analysis of the accept statement, 3683 -- and attached to the list of declarations. Place 3684 -- them now in the context of the accept block or 3685 -- subprogram. 3686 3687 Remove (D); 3688 Typ := Entity (Subtype_Mark (D)); 3689 Insert_After (Call, D); 3690 Analyze (D); 3691 3692 -- If the formal is class_wide, it does not have an 3693 -- actual subtype. The analysis of the renaming declaration 3694 -- creates one, but we need to retain the class-wide 3695 -- nature of the entity. 3696 3697 if Is_Class_Wide_Type (Typ) then 3698 Set_Etype (Defining_Identifier (D), Typ); 3699 end if; 3700 3701 end if; 3702 3703 D := Next_D; 3704 end loop; 3705 end; 3706 3707 End_Scope; 3708 3709 -- Replace the accept statement by the new block 3710 3711 Rewrite (N, Block); 3712 Analyze (N); 3713 3714 -- Last step is to unstack the Accept_Address value 3715 3716 Remove_Last_Elmt (Acstack); 3717 end if; 3718 end Expand_N_Accept_Statement; 3719 3720 ---------------------------------- 3721 -- Expand_N_Asynchronous_Select -- 3722 ---------------------------------- 3723 3724 -- This procedure assumes that the trigger statement is an entry 3725 -- call. A delay alternative should already have been expanded 3726 -- into an entry call to the appropriate delay object Wait entry. 3727 3728 -- If the trigger is a task entry call, the select is implemented 3729 -- with Task_Entry_Call: 3730 3731 -- declare 3732 -- B : Boolean; 3733 -- C : Boolean; 3734 -- P : parms := (parm, parm, parm); 3735 3736 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions. 3737 3738 -- procedure _clean is 3739 -- begin 3740 -- ... 3741 -- Cancel_Task_Entry_Call (C); 3742 -- ... 3743 -- end _clean; 3744 3745 -- begin 3746 -- Abort_Defer; 3747 -- Task_Entry_Call 3748 -- (acceptor-task, 3749 -- entry-index, 3750 -- P'Address, 3751 -- Asynchronous_Call, 3752 -- B); 3753 3754 -- begin 3755 -- begin 3756 -- Abort_Undefer; 3757 -- abortable-part 3758 -- at end 3759 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions. 3760 -- end; 3761 3762 -- exception 3763 -- when Abort_Signal => Abort_Undefer; 3764 -- end; 3765 -- parm := P.param; 3766 -- parm := P.param; 3767 -- ... 3768 -- if not C then 3769 -- triggered-statements 3770 -- end if; 3771 -- end; 3772 3773 -- Note that Build_Simple_Entry_Call is used to expand the entry 3774 -- of the asynchronous entry call (by the 3775 -- Expand_N_Entry_Call_Statement procedure) as follows: 3776 3777 -- declare 3778 -- P : parms := (parm, parm, parm); 3779 -- begin 3780 -- Call_Simple (acceptor-task, entry-index, P'Address); 3781 -- parm := P.param; 3782 -- parm := P.param; 3783 -- ... 3784 -- end; 3785 3786 -- so the task at hand is to convert the latter expansion into the former 3787 3788 -- If the trigger is a protected entry call, the select is 3789 -- implemented with Protected_Entry_Call: 3790 3791 -- declare 3792 -- P : E1_Params := (param, param, param); 3793 -- Bnn : Communications_Block; 3794 3795 -- begin 3796 -- declare 3797 -- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions. 3798 -- procedure _clean is 3799 -- begin 3800 -- ... 3801 -- if Enqueued (Bnn) then 3802 -- Cancel_Protected_Entry_Call (Bnn); 3803 -- end if; 3804 -- ... 3805 -- end _clean; 3806 3807 -- begin 3808 -- begin 3809 -- Protected_Entry_Call ( 3810 -- Object => po._object'Access, 3811 -- E => <entry index>; 3812 -- Uninterpreted_Data => P'Address; 3813 -- Mode => Asynchronous_Call; 3814 -- Block => Bnn); 3815 -- if Enqueued (Bnn) then 3816 -- <abortable part> 3817 -- end if; 3818 -- at end 3819 -- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions. 3820 -- end; 3821 3822 -- exception 3823 -- when Abort_Signal => 3824 -- Abort_Undefer; 3825 -- null; 3826 -- end; 3827 3828 -- if not Cancelled (Bnn) then 3829 -- triggered statements 3830 -- end if; 3831 -- end; 3832 3833 -- Build_Simple_Entry_Call is used to expand the all to a simple 3834 -- protected entry call: 3835 3836 -- declare 3837 -- P : E1_Params := (param, param, param); 3838 -- Bnn : Communications_Block; 3839 3840 -- begin 3841 -- Protected_Entry_Call ( 3842 -- Object => po._object'Access, 3843 -- E => <entry index>; 3844 -- Uninterpreted_Data => P'Address; 3845 -- Mode => Simple_Call; 3846 -- Block => Bnn); 3847 -- parm := P.param; 3848 -- parm := P.param; 3849 -- ... 3850 -- end; 3851 3852 -- The job is to convert this to the asynchronous form. 3853 3854 -- If the trigger is a delay statement, it will have been expanded 3855 -- into a call to one of the GNARL delay procedures. This routine 3856 -- will convert this into a protected entry call on a delay object 3857 -- and then continue processing as for a protected entry call trigger. 3858 -- This requires declaring a Delay_Block object and adding a pointer 3859 -- to this object to the parameter list of the delay procedure to form 3860 -- the parameter list of the entry call. This object is used by 3861 -- the runtime to queue the delay request. 3862 3863 -- For a description of the use of P and the assignments after the 3864 -- call, see Expand_N_Entry_Call_Statement. 3865 3866 procedure Expand_N_Asynchronous_Select (N : Node_Id) is 3867 Loc : constant Source_Ptr := Sloc (N); 3868 Trig : constant Node_Id := Triggering_Alternative (N); 3869 Abrt : constant Node_Id := Abortable_Part (N); 3870 Tstats : constant List_Id := Statements (Trig); 3871 Astats : constant List_Id := Statements (Abrt); 3872 3873 Ecall : Node_Id; 3874 Concval : Node_Id; 3875 Ename : Node_Id; 3876 Index : Node_Id; 3877 Hdle : List_Id; 3878 Decls : List_Id; 3879 Decl : Node_Id; 3880 Parms : List_Id; 3881 Parm : Node_Id; 3882 Call : Node_Id; 3883 Stmts : List_Id; 3884 Enqueue_Call : Node_Id; 3885 Stmt : Node_Id; 3886 B : Entity_Id; 3887 Pdef : Entity_Id; 3888 Dblock_Ent : Entity_Id; 3889 N_Orig : Node_Id; 3890 Abortable_Block : Node_Id; 3891 Cancel_Param : Entity_Id; 3892 Blkent : Entity_Id; 3893 Target_Undefer : RE_Id; 3894 Undefer_Args : List_Id := No_List; 3895 3896 begin 3897 Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); 3898 Ecall := Triggering_Statement (Trig); 3899 3900 -- The arguments in the call may require dynamic allocation, and the 3901 -- call statement may have been transformed into a block. The block 3902 -- may contain additional declarations for internal entities, and the 3903 -- original call is found by sequential search. 3904 3905 if Nkind (Ecall) = N_Block_Statement then 3906 Ecall := First (Statements (Handled_Statement_Sequence (Ecall))); 3907 3908 while Nkind (Ecall) /= N_Procedure_Call_Statement 3909 and then Nkind (Ecall) /= N_Entry_Call_Statement 3910 loop 3911 Next (Ecall); 3912 end loop; 3913 end if; 3914 3915 -- If a delay was used as a trigger, it will have been expanded 3916 -- into a procedure call. Convert it to the appropriate sequence of 3917 -- statements, similar to what is done for a task entry call. 3918 -- Note that this currently supports only Duration, Real_Time.Time, 3919 -- and Calendar.Time. 3920 3921 if Nkind (Ecall) = N_Procedure_Call_Statement then 3922 3923 -- Add a Delay_Block object to the parameter list of the 3924 -- delay procedure to form the parameter list of the Wait 3925 -- entry call. 3926 3927 Dblock_Ent := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); 3928 3929 Pdef := Entity (Name (Ecall)); 3930 3931 if Is_RTE (Pdef, RO_CA_Delay_For) then 3932 Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Duration), Loc); 3933 3934 elsif Is_RTE (Pdef, RO_CA_Delay_Until) then 3935 Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_Calendar), Loc); 3936 3937 else pragma Assert (Is_RTE (Pdef, RO_RT_Delay_Until)); 3938 Enqueue_Call := New_Reference_To (RTE (RE_Enqueue_RT), Loc); 3939 end if; 3940 3941 Append_To (Parameter_Associations (Ecall), 3942 Make_Attribute_Reference (Loc, 3943 Prefix => New_Reference_To (Dblock_Ent, Loc), 3944 Attribute_Name => Name_Unchecked_Access)); 3945 3946 -- Create the inner block to protect the abortable part. 3947 3948 Hdle := New_List ( 3949 Make_Exception_Handler (Loc, 3950 Exception_Choices => 3951 New_List (New_Reference_To (Stand.Abort_Signal, Loc)), 3952 Statements => New_List ( 3953 Make_Procedure_Call_Statement (Loc, 3954 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))))); 3955 3956 Prepend_To (Astats, 3957 Make_Procedure_Call_Statement (Loc, 3958 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))); 3959 3960 Abortable_Block := 3961 Make_Block_Statement (Loc, 3962 Identifier => New_Reference_To (Blkent, Loc), 3963 Handled_Statement_Sequence => 3964 Make_Handled_Sequence_Of_Statements (Loc, 3965 Statements => Astats), 3966 Has_Created_Identifier => True, 3967 Is_Asynchronous_Call_Block => True); 3968 3969 -- Append call to if Enqueue (When, DB'Unchecked_Access) then 3970 3971 Rewrite (Ecall, 3972 Make_Implicit_If_Statement (N, 3973 Condition => Make_Function_Call (Loc, 3974 Name => Enqueue_Call, 3975 Parameter_Associations => Parameter_Associations (Ecall)), 3976 Then_Statements => 3977 New_List (Make_Block_Statement (Loc, 3978 Handled_Statement_Sequence => 3979 Make_Handled_Sequence_Of_Statements (Loc, 3980 Statements => New_List ( 3981 Make_Implicit_Label_Declaration (Loc, 3982 Defining_Identifier => Blkent, 3983 Label_Construct => Abortable_Block), 3984 Abortable_Block), 3985 Exception_Handlers => Hdle))))); 3986 3987 Stmts := New_List (Ecall); 3988 3989 -- Construct statement sequence for new block 3990 3991 Append_To (Stmts, 3992 Make_Implicit_If_Statement (N, 3993 Condition => Make_Function_Call (Loc, 3994 Name => New_Reference_To ( 3995 RTE (RE_Timed_Out), Loc), 3996 Parameter_Associations => New_List ( 3997 Make_Attribute_Reference (Loc, 3998 Prefix => New_Reference_To (Dblock_Ent, Loc), 3999 Attribute_Name => Name_Unchecked_Access))), 4000 Then_Statements => Tstats)); 4001 4002 -- The result is the new block 4003 4004 Set_Entry_Cancel_Parameter (Blkent, Dblock_Ent); 4005 4006 Rewrite (N, 4007 Make_Block_Statement (Loc, 4008 Declarations => New_List ( 4009 Make_Object_Declaration (Loc, 4010 Defining_Identifier => Dblock_Ent, 4011 Aliased_Present => True, 4012 Object_Definition => New_Reference_To ( 4013 RTE (RE_Delay_Block), Loc))), 4014 4015 Handled_Statement_Sequence => 4016 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 4017 4018 Analyze (N); 4019 return; 4020 4021 else 4022 N_Orig := N; 4023 end if; 4024 4025 Extract_Entry (Ecall, Concval, Ename, Index); 4026 Build_Simple_Entry_Call (Ecall, Concval, Ename, Index); 4027 4028 Stmts := Statements (Handled_Statement_Sequence (Ecall)); 4029 Decls := Declarations (Ecall); 4030 4031 if Is_Protected_Type (Etype (Concval)) then 4032 4033 -- Get the declarations of the block expanded from the entry call 4034 4035 Decl := First (Decls); 4036 while Present (Decl) 4037 and then (Nkind (Decl) /= N_Object_Declaration 4038 or else not Is_RTE 4039 (Etype (Object_Definition (Decl)), RE_Communication_Block)) 4040 loop 4041 Next (Decl); 4042 end loop; 4043 4044 pragma Assert (Present (Decl)); 4045 Cancel_Param := Defining_Identifier (Decl); 4046 4047 -- Change the mode of the Protected_Entry_Call call. 4048 -- Protected_Entry_Call ( 4049 -- Object => po._object'Access, 4050 -- E => <entry index>; 4051 -- Uninterpreted_Data => P'Address; 4052 -- Mode => Asynchronous_Call; 4053 -- Block => Bnn); 4054 4055 Stmt := First (Stmts); 4056 4057 -- Skip assignments to temporaries created for in-out parameters. 4058 -- This makes unwarranted assumptions about the shape of the expanded 4059 -- tree for the call, and should be cleaned up ??? 4060 4061 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 4062 Next (Stmt); 4063 end loop; 4064 4065 Call := Stmt; 4066 4067 Parm := First (Parameter_Associations (Call)); 4068 while Present (Parm) 4069 and then not Is_RTE (Etype (Parm), RE_Call_Modes) 4070 loop 4071 Next (Parm); 4072 end loop; 4073 4074 pragma Assert (Present (Parm)); 4075 Rewrite (Parm, New_Reference_To (RTE (RE_Asynchronous_Call), Loc)); 4076 Analyze (Parm); 4077 4078 -- Append an if statement to execute the abortable part. 4079 -- if Enqueued (Bnn) then 4080 4081 Append_To (Stmts, 4082 Make_Implicit_If_Statement (N, 4083 Condition => Make_Function_Call (Loc, 4084 Name => New_Reference_To ( 4085 RTE (RE_Enqueued), Loc), 4086 Parameter_Associations => New_List ( 4087 New_Reference_To (Cancel_Param, Loc))), 4088 Then_Statements => Astats)); 4089 4090 Abortable_Block := 4091 Make_Block_Statement (Loc, 4092 Identifier => New_Reference_To (Blkent, Loc), 4093 Handled_Statement_Sequence => 4094 Make_Handled_Sequence_Of_Statements (Loc, 4095 Statements => Stmts), 4096 Has_Created_Identifier => True, 4097 Is_Asynchronous_Call_Block => True); 4098 4099 -- For the JVM call Update_Exception instead of Abort_Undefer. 4100 -- See 4jexcept.ads for an explanation. 4101 4102 if Hostparm.Java_VM then 4103 Target_Undefer := RE_Update_Exception; 4104 Undefer_Args := 4105 New_List (Make_Function_Call (Loc, 4106 Name => New_Occurrence_Of 4107 (RTE (RE_Current_Target_Exception), Loc))); 4108 else 4109 Target_Undefer := RE_Abort_Undefer; 4110 end if; 4111 4112 Stmts := New_List ( 4113 Make_Block_Statement (Loc, 4114 Handled_Statement_Sequence => 4115 Make_Handled_Sequence_Of_Statements (Loc, 4116 Statements => New_List ( 4117 Make_Implicit_Label_Declaration (Loc, 4118 Defining_Identifier => Blkent, 4119 Label_Construct => Abortable_Block), 4120 Abortable_Block), 4121 4122 -- exception 4123 4124 Exception_Handlers => New_List ( 4125 Make_Exception_Handler (Loc, 4126 4127 -- when Abort_Signal => 4128 -- Abort_Undefer.all; 4129 4130 Exception_Choices => 4131 New_List (New_Reference_To (Stand.Abort_Signal, Loc)), 4132 Statements => New_List ( 4133 Make_Procedure_Call_Statement (Loc, 4134 Name => New_Reference_To ( 4135 RTE (Target_Undefer), Loc), 4136 Parameter_Associations => Undefer_Args)))))), 4137 4138 -- if not Cancelled (Bnn) then 4139 -- triggered statements 4140 -- end if; 4141 4142 Make_Implicit_If_Statement (N, 4143 Condition => Make_Op_Not (Loc, 4144 Right_Opnd => 4145 Make_Function_Call (Loc, 4146 Name => New_Occurrence_Of (RTE (RE_Cancelled), Loc), 4147 Parameter_Associations => New_List ( 4148 New_Occurrence_Of (Cancel_Param, Loc)))), 4149 Then_Statements => Tstats)); 4150 4151 -- Asynchronous task entry call 4152 4153 else 4154 if No (Decls) then 4155 Decls := New_List; 4156 end if; 4157 4158 B := Make_Defining_Identifier (Loc, Name_uB); 4159 4160 -- Insert declaration of B in declarations of existing block 4161 4162 Prepend_To (Decls, 4163 Make_Object_Declaration (Loc, 4164 Defining_Identifier => B, 4165 Object_Definition => New_Reference_To (Standard_Boolean, Loc))); 4166 4167 Cancel_Param := Make_Defining_Identifier (Loc, Name_uC); 4168 4169 -- Insert declaration of C in declarations of existing block 4170 4171 Prepend_To (Decls, 4172 Make_Object_Declaration (Loc, 4173 Defining_Identifier => Cancel_Param, 4174 Object_Definition => New_Reference_To (Standard_Boolean, Loc))); 4175 4176 -- Remove and save the call to Call_Simple. 4177 4178 Stmt := First (Stmts); 4179 4180 -- Skip assignments to temporaries created for in-out parameters. 4181 -- This makes unwarranted assumptions about the shape of the expanded 4182 -- tree for the call, and should be cleaned up ??? 4183 4184 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 4185 Next (Stmt); 4186 end loop; 4187 4188 Call := Stmt; 4189 4190 -- Create the inner block to protect the abortable part. 4191 4192 Hdle := New_List ( 4193 Make_Exception_Handler (Loc, 4194 Exception_Choices => 4195 New_List (New_Reference_To (Stand.Abort_Signal, Loc)), 4196 Statements => New_List ( 4197 Make_Procedure_Call_Statement (Loc, 4198 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))))); 4199 4200 Prepend_To (Astats, 4201 Make_Procedure_Call_Statement (Loc, 4202 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc))); 4203 4204 Abortable_Block := 4205 Make_Block_Statement (Loc, 4206 Identifier => New_Reference_To (Blkent, Loc), 4207 Handled_Statement_Sequence => 4208 Make_Handled_Sequence_Of_Statements (Loc, 4209 Statements => Astats), 4210 Has_Created_Identifier => True, 4211 Is_Asynchronous_Call_Block => True); 4212 4213 Insert_After (Call, 4214 Make_Block_Statement (Loc, 4215 Handled_Statement_Sequence => 4216 Make_Handled_Sequence_Of_Statements (Loc, 4217 Statements => New_List ( 4218 Make_Implicit_Label_Declaration (Loc, 4219 Defining_Identifier => Blkent, 4220 Label_Construct => Abortable_Block), 4221 Abortable_Block), 4222 Exception_Handlers => Hdle))); 4223 4224 -- Create new call statement 4225 4226 Parms := Parameter_Associations (Call); 4227 Append_To (Parms, New_Reference_To (RTE (RE_Asynchronous_Call), Loc)); 4228 Append_To (Parms, New_Reference_To (B, Loc)); 4229 Rewrite (Call, 4230 Make_Procedure_Call_Statement (Loc, 4231 Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc), 4232 Parameter_Associations => Parms)); 4233 4234 -- Construct statement sequence for new block 4235 4236 Append_To (Stmts, 4237 Make_Implicit_If_Statement (N, 4238 Condition => Make_Op_Not (Loc, 4239 New_Reference_To (Cancel_Param, Loc)), 4240 Then_Statements => Tstats)); 4241 4242 -- Protected the call against abortion 4243 4244 Prepend_To (Stmts, 4245 Make_Procedure_Call_Statement (Loc, 4246 Name => New_Reference_To (RTE (RE_Abort_Defer), Loc), 4247 Parameter_Associations => Empty_List)); 4248 end if; 4249 4250 Set_Entry_Cancel_Parameter (Blkent, Cancel_Param); 4251 4252 -- The result is the new block 4253 4254 Rewrite (N_Orig, 4255 Make_Block_Statement (Loc, 4256 Declarations => Decls, 4257 Handled_Statement_Sequence => 4258 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 4259 4260 Analyze (N_Orig); 4261 end Expand_N_Asynchronous_Select; 4262 4263 ------------------------------------- 4264 -- Expand_N_Conditional_Entry_Call -- 4265 ------------------------------------- 4266 4267 -- The conditional task entry call is converted to a call to 4268 -- Task_Entry_Call: 4269 4270 -- declare 4271 -- B : Boolean; 4272 -- P : parms := (parm, parm, parm); 4273 4274 -- begin 4275 -- Task_Entry_Call 4276 -- (acceptor-task, 4277 -- entry-index, 4278 -- P'Address, 4279 -- Conditional_Call, 4280 -- B); 4281 -- parm := P.param; 4282 -- parm := P.param; 4283 -- ... 4284 -- if B then 4285 -- normal-statements 4286 -- else 4287 -- else-statements 4288 -- end if; 4289 -- end; 4290 4291 -- For a description of the use of P and the assignments after the 4292 -- call, see Expand_N_Entry_Call_Statement. Note that the entry call 4293 -- of the conditional entry call has already been expanded (by the 4294 -- Expand_N_Entry_Call_Statement procedure) as follows: 4295 4296 -- declare 4297 -- P : parms := (parm, parm, parm); 4298 -- begin 4299 -- ... info for in-out parameters 4300 -- Call_Simple (acceptor-task, entry-index, P'Address); 4301 -- parm := P.param; 4302 -- parm := P.param; 4303 -- ... 4304 -- end; 4305 4306 -- so the task at hand is to convert the latter expansion into the former 4307 4308 -- The conditional protected entry call is converted to a call to 4309 -- Protected_Entry_Call: 4310 4311 -- declare 4312 -- P : parms := (parm, parm, parm); 4313 -- Bnn : Communications_Block; 4314 4315 -- begin 4316 -- Protected_Entry_Call ( 4317 -- Object => po._object'Access, 4318 -- E => <entry index>; 4319 -- Uninterpreted_Data => P'Address; 4320 -- Mode => Conditional_Call; 4321 -- Block => Bnn); 4322 -- parm := P.param; 4323 -- parm := P.param; 4324 -- ... 4325 -- if Cancelled (Bnn) then 4326 -- else-statements 4327 -- else 4328 -- normal-statements 4329 -- end if; 4330 -- end; 4331 4332 -- As for tasks, the entry call of the conditional entry call has 4333 -- already been expanded (by the Expand_N_Entry_Call_Statement procedure) 4334 -- as follows: 4335 4336 -- declare 4337 -- P : E1_Params := (param, param, param); 4338 -- Bnn : Communications_Block; 4339 4340 -- begin 4341 -- Protected_Entry_Call ( 4342 -- Object => po._object'Access, 4343 -- E => <entry index>; 4344 -- Uninterpreted_Data => P'Address; 4345 -- Mode => Simple_Call; 4346 -- Block => Bnn); 4347 -- parm := P.param; 4348 -- parm := P.param; 4349 -- ... 4350 -- end; 4351 4352 procedure Expand_N_Conditional_Entry_Call (N : Node_Id) is 4353 Loc : constant Source_Ptr := Sloc (N); 4354 Alt : constant Node_Id := Entry_Call_Alternative (N); 4355 Blk : Node_Id := Entry_Call_Statement (Alt); 4356 Transient_Blk : Node_Id; 4357 4358 Parms : List_Id; 4359 Parm : Node_Id; 4360 Call : Node_Id; 4361 Stmts : List_Id; 4362 B : Entity_Id; 4363 Decl : Node_Id; 4364 Stmt : Node_Id; 4365 4366 begin 4367 -- As described above, The entry alternative is transformed into a 4368 -- block that contains the gnulli call, and possibly assignment 4369 -- statements for in-out parameters. The gnulli call may itself be 4370 -- rewritten into a transient block if some unconstrained parameters 4371 -- require it. We need to retrieve the call to complete its parameter 4372 -- list. 4373 4374 Transient_Blk := 4375 First_Real_Statement (Handled_Statement_Sequence (Blk)); 4376 4377 if Present (Transient_Blk) 4378 and then 4379 Nkind (Transient_Blk) = N_Block_Statement 4380 then 4381 Blk := Transient_Blk; 4382 end if; 4383 4384 Stmts := Statements (Handled_Statement_Sequence (Blk)); 4385 4386 Stmt := First (Stmts); 4387 4388 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 4389 Next (Stmt); 4390 end loop; 4391 4392 Call := Stmt; 4393 4394 Parms := Parameter_Associations (Call); 4395 4396 if Is_RTE (Entity (Name (Call)), RE_Protected_Entry_Call) then 4397 4398 -- Substitute Conditional_Entry_Call for Simple_Call 4399 -- parameter. 4400 4401 Parm := First (Parms); 4402 while Present (Parm) 4403 and then not Is_RTE (Etype (Parm), RE_Call_Modes) 4404 loop 4405 Next (Parm); 4406 end loop; 4407 4408 pragma Assert (Present (Parm)); 4409 Rewrite (Parm, New_Reference_To (RTE (RE_Conditional_Call), Loc)); 4410 4411 Analyze (Parm); 4412 4413 -- Find the Communication_Block parameter for the call 4414 -- to the Cancelled function. 4415 4416 Decl := First (Declarations (Blk)); 4417 while Present (Decl) 4418 and then not 4419 Is_RTE (Etype (Object_Definition (Decl)), RE_Communication_Block) 4420 loop 4421 Next (Decl); 4422 end loop; 4423 4424 -- Add an if statement to execute the else part if the call 4425 -- does not succeed (as indicated by the Cancelled predicate). 4426 4427 Append_To (Stmts, 4428 Make_Implicit_If_Statement (N, 4429 Condition => Make_Function_Call (Loc, 4430 Name => New_Reference_To (RTE (RE_Cancelled), Loc), 4431 Parameter_Associations => New_List ( 4432 New_Reference_To (Defining_Identifier (Decl), Loc))), 4433 Then_Statements => Else_Statements (N), 4434 Else_Statements => Statements (Alt))); 4435 4436 else 4437 B := Make_Defining_Identifier (Loc, Name_uB); 4438 4439 -- Insert declaration of B in declarations of existing block 4440 4441 if No (Declarations (Blk)) then 4442 Set_Declarations (Blk, New_List); 4443 end if; 4444 4445 Prepend_To (Declarations (Blk), 4446 Make_Object_Declaration (Loc, 4447 Defining_Identifier => B, 4448 Object_Definition => New_Reference_To (Standard_Boolean, Loc))); 4449 4450 -- Create new call statement 4451 4452 Append_To (Parms, New_Reference_To (RTE (RE_Conditional_Call), Loc)); 4453 Append_To (Parms, New_Reference_To (B, Loc)); 4454 4455 Rewrite (Call, 4456 Make_Procedure_Call_Statement (Loc, 4457 Name => New_Reference_To (RTE (RE_Task_Entry_Call), Loc), 4458 Parameter_Associations => Parms)); 4459 4460 -- Construct statement sequence for new block 4461 4462 Append_To (Stmts, 4463 Make_Implicit_If_Statement (N, 4464 Condition => New_Reference_To (B, Loc), 4465 Then_Statements => Statements (Alt), 4466 Else_Statements => Else_Statements (N))); 4467 4468 end if; 4469 4470 -- The result is the new block 4471 4472 Rewrite (N, 4473 Make_Block_Statement (Loc, 4474 Declarations => Declarations (Blk), 4475 Handled_Statement_Sequence => 4476 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 4477 4478 Analyze (N); 4479 end Expand_N_Conditional_Entry_Call; 4480 4481 --------------------------------------- 4482 -- Expand_N_Delay_Relative_Statement -- 4483 --------------------------------------- 4484 4485 -- Delay statement is implemented as a procedure call to Delay_For 4486 -- defined in Ada.Calendar.Delays in order to reduce the overhead of 4487 -- simple delays imposed by the use of Protected Objects. 4488 4489 procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is 4490 Loc : constant Source_Ptr := Sloc (N); 4491 4492 begin 4493 Rewrite (N, 4494 Make_Procedure_Call_Statement (Loc, 4495 Name => New_Reference_To (RTE (RO_CA_Delay_For), Loc), 4496 Parameter_Associations => New_List (Expression (N)))); 4497 Analyze (N); 4498 end Expand_N_Delay_Relative_Statement; 4499 4500 ------------------------------------ 4501 -- Expand_N_Delay_Until_Statement -- 4502 ------------------------------------ 4503 4504 -- Delay Until statement is implemented as a procedure call to 4505 -- Delay_Until defined in Ada.Calendar.Delays and Ada.Real_Time.Delays. 4506 4507 procedure Expand_N_Delay_Until_Statement (N : Node_Id) is 4508 Loc : constant Source_Ptr := Sloc (N); 4509 Typ : Entity_Id; 4510 4511 begin 4512 if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then 4513 Typ := RTE (RO_CA_Delay_Until); 4514 else 4515 Typ := RTE (RO_RT_Delay_Until); 4516 end if; 4517 4518 Rewrite (N, 4519 Make_Procedure_Call_Statement (Loc, 4520 Name => New_Reference_To (Typ, Loc), 4521 Parameter_Associations => New_List (Expression (N)))); 4522 4523 Analyze (N); 4524 end Expand_N_Delay_Until_Statement; 4525 4526 ------------------------- 4527 -- Expand_N_Entry_Body -- 4528 ------------------------- 4529 4530 procedure Expand_N_Entry_Body (N : Node_Id) is 4531 Loc : constant Source_Ptr := Sloc (N); 4532 Dec : constant Node_Id := Parent (Current_Scope); 4533 Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); 4534 Index_Spec : constant Node_Id := 4535 Entry_Index_Specification (Ent_Formals); 4536 Next_Op : Node_Id; 4537 First_Decl : constant Node_Id := First (Declarations (N)); 4538 Index_Decl : List_Id; 4539 4540 begin 4541 -- Add the renamings for private declarations and discriminants. 4542 4543 Add_Discriminal_Declarations 4544 (Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc); 4545 Add_Private_Declarations 4546 (Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc); 4547 4548 if Present (Index_Spec) then 4549 Index_Decl := 4550 Index_Constant_Declaration 4551 (N, 4552 Defining_Identifier (Index_Spec), Defining_Identifier (Dec)); 4553 4554 -- If the entry has local declarations, insert index declaration 4555 -- before them, because the index may be used therein. 4556 4557 if Present (First_Decl) then 4558 Insert_List_Before (First_Decl, Index_Decl); 4559 else 4560 Append_List_To (Declarations (N), Index_Decl); 4561 end if; 4562 end if; 4563 4564 -- Associate privals and discriminals with the next protected 4565 -- operation body to be expanded. These are used to expand 4566 -- references to private data objects and discriminants, 4567 -- respectively. 4568 4569 Next_Op := Next_Protected_Operation (N); 4570 4571 if Present (Next_Op) then 4572 Set_Privals (Dec, Next_Op, Loc); 4573 Set_Discriminals (Dec); 4574 end if; 4575 end Expand_N_Entry_Body; 4576 4577 ----------------------------------- 4578 -- Expand_N_Entry_Call_Statement -- 4579 ----------------------------------- 4580 4581 -- An entry call is expanded into GNARLI calls to implement 4582 -- a simple entry call (see Build_Simple_Entry_Call). 4583 4584 procedure Expand_N_Entry_Call_Statement (N : Node_Id) is 4585 Concval : Node_Id; 4586 Ename : Node_Id; 4587 Index : Node_Id; 4588 4589 begin 4590 if No_Run_Time_Mode then 4591 Error_Msg_CRT ("entry call", N); 4592 return; 4593 end if; 4594 4595 -- If this entry call is part of an asynchronous select, don't 4596 -- expand it here; it will be expanded with the select statement. 4597 -- Don't expand timed entry calls either, as they are translated 4598 -- into asynchronous entry calls. 4599 4600 -- ??? This whole approach is questionable; it may be better 4601 -- to go back to allowing the expansion to take place and then 4602 -- attempting to fix it up in Expand_N_Asynchronous_Select. 4603 -- The tricky part is figuring out whether the expanded 4604 -- call is on a task or protected entry. 4605 4606 if (Nkind (Parent (N)) /= N_Triggering_Alternative 4607 or else N /= Triggering_Statement (Parent (N))) 4608 and then (Nkind (Parent (N)) /= N_Entry_Call_Alternative 4609 or else N /= Entry_Call_Statement (Parent (N)) 4610 or else Nkind (Parent (Parent (N))) /= N_Timed_Entry_Call) 4611 then 4612 Extract_Entry (N, Concval, Ename, Index); 4613 Build_Simple_Entry_Call (N, Concval, Ename, Index); 4614 end if; 4615 end Expand_N_Entry_Call_Statement; 4616 4617 -------------------------------- 4618 -- Expand_N_Entry_Declaration -- 4619 -------------------------------- 4620 4621 -- If there are parameters, then first, each of the formals is marked 4622 -- by setting Is_Entry_Formal. Next a record type is built which is 4623 -- used to hold the parameter values. The name of this record type is 4624 -- entryP where entry is the name of the entry, with an additional 4625 -- corresponding access type called entryPA. The record type has matching 4626 -- components for each formal (the component names are the same as the 4627 -- formal names). For elementary types, the component type matches the 4628 -- formal type. For composite types, an access type is declared (with 4629 -- the name formalA) which designates the formal type, and the type of 4630 -- the component is this access type. Finally the Entry_Component of 4631 -- each formal is set to reference the corresponding record component. 4632 4633 procedure Expand_N_Entry_Declaration (N : Node_Id) is 4634 Loc : constant Source_Ptr := Sloc (N); 4635 Entry_Ent : constant Entity_Id := Defining_Identifier (N); 4636 Components : List_Id; 4637 Formal : Node_Id; 4638 Ftype : Entity_Id; 4639 Last_Decl : Node_Id; 4640 Component : Entity_Id; 4641 Ctype : Entity_Id; 4642 Decl : Node_Id; 4643 Rec_Ent : Entity_Id; 4644 Acc_Ent : Entity_Id; 4645 4646 begin 4647 Formal := First_Formal (Entry_Ent); 4648 Last_Decl := N; 4649 4650 -- Most processing is done only if parameters are present 4651 4652 if Present (Formal) then 4653 Components := New_List; 4654 4655 -- Loop through formals 4656 4657 while Present (Formal) loop 4658 Set_Is_Entry_Formal (Formal); 4659 Component := 4660 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)); 4661 Set_Entry_Component (Formal, Component); 4662 Set_Entry_Formal (Component, Formal); 4663 Ftype := Etype (Formal); 4664 4665 -- Declare new access type and then append 4666 4667 Ctype := 4668 Make_Defining_Identifier (Loc, New_Internal_Name ('A')); 4669 4670 Decl := 4671 Make_Full_Type_Declaration (Loc, 4672 Defining_Identifier => Ctype, 4673 Type_Definition => 4674 Make_Access_To_Object_Definition (Loc, 4675 All_Present => True, 4676 Constant_Present => Ekind (Formal) = E_In_Parameter, 4677 Subtype_Indication => New_Reference_To (Ftype, Loc))); 4678 4679 Insert_After (Last_Decl, Decl); 4680 Last_Decl := Decl; 4681 4682 Append_To (Components, 4683 Make_Component_Declaration (Loc, 4684 Defining_Identifier => Component, 4685 Component_Definition => 4686 Make_Component_Definition (Loc, 4687 Aliased_Present => False, 4688 Subtype_Indication => New_Reference_To (Ctype, Loc)))); 4689 4690 Next_Formal_With_Extras (Formal); 4691 end loop; 4692 4693 -- Create the Entry_Parameter_Record declaration 4694 4695 Rec_Ent := 4696 Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 4697 4698 Decl := 4699 Make_Full_Type_Declaration (Loc, 4700 Defining_Identifier => Rec_Ent, 4701 Type_Definition => 4702 Make_Record_Definition (Loc, 4703 Component_List => 4704 Make_Component_List (Loc, 4705 Component_Items => Components))); 4706 4707 Insert_After (Last_Decl, Decl); 4708 Last_Decl := Decl; 4709 4710 -- Construct and link in the corresponding access type 4711 4712 Acc_Ent := 4713 Make_Defining_Identifier (Loc, New_Internal_Name ('A')); 4714 4715 Set_Entry_Parameters_Type (Entry_Ent, Acc_Ent); 4716 4717 Decl := 4718 Make_Full_Type_Declaration (Loc, 4719 Defining_Identifier => Acc_Ent, 4720 Type_Definition => 4721 Make_Access_To_Object_Definition (Loc, 4722 All_Present => True, 4723 Subtype_Indication => New_Reference_To (Rec_Ent, Loc))); 4724 4725 Insert_After (Last_Decl, Decl); 4726 Last_Decl := Decl; 4727 end if; 4728 end Expand_N_Entry_Declaration; 4729 4730 ----------------------------- 4731 -- Expand_N_Protected_Body -- 4732 ----------------------------- 4733 4734 -- Protected bodies are expanded to the completion of the subprograms 4735 -- created for the corresponding protected type. These are a protected 4736 -- and unprotected version of each protected subprogram in the object, 4737 -- a function to calculate each entry barrier, and a procedure to 4738 -- execute the sequence of statements of each protected entry body. 4739 -- For example, for protected type ptype: 4740 4741 -- function entB 4742 -- (O : System.Address; 4743 -- E : Protected_Entry_Index) 4744 -- return Boolean 4745 -- is 4746 -- <discriminant renamings> 4747 -- <private object renamings> 4748 -- begin 4749 -- return <barrier expression>; 4750 -- end entB; 4751 4752 -- procedure pprocN (_object : in out poV;...) is 4753 -- <discriminant renamings> 4754 -- <private object renamings> 4755 -- begin 4756 -- <sequence of statements> 4757 -- end pprocN; 4758 4759 -- procedure pproc (_object : in out poV;...) is 4760 -- procedure _clean is 4761 -- Pn : Boolean; 4762 -- begin 4763 -- ptypeS (_object, Pn); 4764 -- Unlock (_object._object'Access); 4765 -- Abort_Undefer.all; 4766 -- end _clean; 4767 4768 -- begin 4769 -- Abort_Defer.all; 4770 -- Lock (_object._object'Access); 4771 -- pprocN (_object;...); 4772 -- at end 4773 -- _clean; 4774 -- end pproc; 4775 4776 -- function pfuncN (_object : poV;...) return Return_Type is 4777 -- <discriminant renamings> 4778 -- <private object renamings> 4779 -- begin 4780 -- <sequence of statements> 4781 -- end pfuncN; 4782 4783 -- function pfunc (_object : poV) return Return_Type is 4784 -- procedure _clean is 4785 -- begin 4786 -- Unlock (_object._object'Access); 4787 -- Abort_Undefer.all; 4788 -- end _clean; 4789 4790 -- begin 4791 -- Abort_Defer.all; 4792 -- Lock (_object._object'Access); 4793 -- return pfuncN (_object); 4794 4795 -- at end 4796 -- _clean; 4797 -- end pfunc; 4798 4799 -- procedure entE 4800 -- (O : System.Address; 4801 -- P : System.Address; 4802 -- E : Protected_Entry_Index) 4803 -- is 4804 -- <discriminant renamings> 4805 -- <private object renamings> 4806 -- type poVP is access poV; 4807 -- _Object : ptVP := ptVP!(O); 4808 4809 -- begin 4810 -- begin 4811 -- <statement sequence> 4812 -- Complete_Entry_Body (_Object._Object); 4813 -- exception 4814 -- when all others => 4815 -- Exceptional_Complete_Entry_Body ( 4816 -- _Object._Object, Get_GNAT_Exception); 4817 -- end; 4818 -- end entE; 4819 4820 -- The type poV is the record created for the protected type to hold 4821 -- the state of the protected object. 4822 4823 procedure Expand_N_Protected_Body (N : Node_Id) is 4824 Pid : constant Entity_Id := Corresponding_Spec (N); 4825 Has_Entries : Boolean := False; 4826 Op_Decl : Node_Id; 4827 Op_Body : Node_Id; 4828 Op_Id : Entity_Id; 4829 New_Op_Body : Node_Id; 4830 Current_Node : Node_Id; 4831 Num_Entries : Natural := 0; 4832 4833 begin 4834 if No_Run_Time_Mode then 4835 Error_Msg_CRT ("protected body", N); 4836 return; 4837 end if; 4838 4839 if Nkind (Parent (N)) = N_Subunit then 4840 4841 -- This is the proper body corresponding to a stub. The declarations 4842 -- must be inserted at the point of the stub, which is in the decla- 4843 -- rative part of the parent unit. 4844 4845 Current_Node := Corresponding_Stub (Parent (N)); 4846 4847 else 4848 Current_Node := N; 4849 end if; 4850 4851 Op_Body := First (Declarations (N)); 4852 4853 -- The protected body is replaced with the bodies of its 4854 -- protected operations, and the declarations for internal objects 4855 -- that may have been created for entry family bounds. 4856 4857 Rewrite (N, Make_Null_Statement (Sloc (N))); 4858 Analyze (N); 4859 4860 while Present (Op_Body) loop 4861 case Nkind (Op_Body) is 4862 when N_Subprogram_Declaration => 4863 null; 4864 4865 when N_Subprogram_Body => 4866 4867 -- Exclude functions created to analyze defaults. 4868 4869 if not Is_Eliminated (Defining_Entity (Op_Body)) then 4870 New_Op_Body := 4871 Build_Unprotected_Subprogram_Body (Op_Body, Pid); 4872 4873 Insert_After (Current_Node, New_Op_Body); 4874 Current_Node := New_Op_Body; 4875 Analyze (New_Op_Body); 4876 4877 Update_Prival_Subtypes (New_Op_Body); 4878 4879 -- Build the corresponding protected operation only if 4880 -- this is a visible operation of the type, or if it is 4881 -- an interrupt handler. Otherwise it is only callable 4882 -- from within the object, and the unprotected version 4883 -- is sufficient. 4884 4885 if Present (Corresponding_Spec (Op_Body)) then 4886 Op_Decl := 4887 Unit_Declaration_Node (Corresponding_Spec (Op_Body)); 4888 4889 if Nkind (Parent (Op_Decl)) = N_Protected_Definition 4890 and then 4891 (List_Containing (Op_Decl) = 4892 Visible_Declarations (Parent (Op_Decl)) 4893 or else 4894 Is_Interrupt_Handler 4895 (Corresponding_Spec (Op_Body))) 4896 then 4897 New_Op_Body := 4898 Build_Protected_Subprogram_Body ( 4899 Op_Body, Pid, Specification (New_Op_Body)); 4900 4901 Insert_After (Current_Node, New_Op_Body); 4902 Analyze (New_Op_Body); 4903 end if; 4904 end if; 4905 end if; 4906 4907 when N_Entry_Body => 4908 Op_Id := Defining_Identifier (Op_Body); 4909 Has_Entries := True; 4910 Num_Entries := Num_Entries + 1; 4911 4912 New_Op_Body := Build_Protected_Entry (Op_Body, Op_Id, Pid); 4913 4914 Insert_After (Current_Node, New_Op_Body); 4915 Current_Node := New_Op_Body; 4916 Analyze (New_Op_Body); 4917 4918 Update_Prival_Subtypes (New_Op_Body); 4919 4920 when N_Implicit_Label_Declaration => 4921 null; 4922 4923 when N_Itype_Reference => 4924 Insert_After (Current_Node, New_Copy (Op_Body)); 4925 4926 when N_Freeze_Entity => 4927 New_Op_Body := New_Copy (Op_Body); 4928 4929 if Present (Entity (Op_Body)) 4930 and then Freeze_Node (Entity (Op_Body)) = Op_Body 4931 then 4932 Set_Freeze_Node (Entity (Op_Body), New_Op_Body); 4933 end if; 4934 4935 Insert_After (Current_Node, New_Op_Body); 4936 Current_Node := New_Op_Body; 4937 Analyze (New_Op_Body); 4938 4939 when N_Pragma => 4940 New_Op_Body := New_Copy (Op_Body); 4941 Insert_After (Current_Node, New_Op_Body); 4942 Current_Node := New_Op_Body; 4943 Analyze (New_Op_Body); 4944 4945 when N_Object_Declaration => 4946 pragma Assert (not Comes_From_Source (Op_Body)); 4947 New_Op_Body := New_Copy (Op_Body); 4948 Insert_After (Current_Node, New_Op_Body); 4949 Current_Node := New_Op_Body; 4950 Analyze (New_Op_Body); 4951 4952 when others => 4953 raise Program_Error; 4954 4955 end case; 4956 4957 Next (Op_Body); 4958 end loop; 4959 4960 -- Finally, create the body of the function that maps an entry index 4961 -- into the corresponding body index, except when there is no entry, 4962 -- or in a ravenscar-like profile (no abort, no entry queue, 1 entry) 4963 4964 if Has_Entries 4965 and then (Abort_Allowed 4966 or else Restrictions (No_Entry_Queue) = False 4967 or else Num_Entries > 1) 4968 then 4969 New_Op_Body := Build_Find_Body_Index (Pid); 4970 Insert_After (Current_Node, New_Op_Body); 4971 Analyze (New_Op_Body); 4972 end if; 4973 end Expand_N_Protected_Body; 4974 4975 ----------------------------------------- 4976 -- Expand_N_Protected_Type_Declaration -- 4977 ----------------------------------------- 4978 4979 -- First we create a corresponding record type declaration used to 4980 -- represent values of this protected type. 4981 -- The general form of this type declaration is 4982 4983 -- type poV (discriminants) is record 4984 -- _Object : aliased <kind>Protection 4985 -- [(<entry count> [, <handler count>])]; 4986 -- [entry_family : array (bounds) of Void;] 4987 -- <private data fields> 4988 -- end record; 4989 4990 -- The discriminants are present only if the corresponding protected 4991 -- type has discriminants, and they exactly mirror the protected type 4992 -- discriminants. The private data fields similarly mirror the 4993 -- private declarations of the protected type. 4994 4995 -- The Object field is always present. It contains RTS specific data 4996 -- used to control the protected object. It is declared as Aliased 4997 -- so that it can be passed as a pointer to the RTS. This allows the 4998 -- protected record to be referenced within RTS data structures. 4999 -- An appropriate Protection type and discriminant are generated. 5000 5001 -- The Service field is present for protected objects with entries. It 5002 -- contains sufficient information to allow the entry service procedure 5003 -- for this object to be called when the object is not known till runtime. 5004 5005 -- One entry_family component is present for each entry family in the 5006 -- task definition (see Expand_N_Task_Type_Declaration). 5007 5008 -- When a protected object is declared, an instance of the protected type 5009 -- value record is created. The elaboration of this declaration creates 5010 -- the correct bounds for the entry families, and also evaluates the 5011 -- priority expression if needed. The initialization routine for 5012 -- the protected type itself then calls Initialize_Protection with 5013 -- appropriate parameters to initialize the value of the Task_Id field. 5014 -- Install_Handlers may be also called if a pragma Attach_Handler applies. 5015 5016 -- Note: this record is passed to the subprograms created by the 5017 -- expansion of protected subprograms and entries. It is an in parameter 5018 -- to protected functions and an in out parameter to procedures and 5019 -- entry bodies. The Entity_Id for this created record type is placed 5020 -- in the Corresponding_Record_Type field of the associated protected 5021 -- type entity. 5022 5023 -- Next we create a procedure specifications for protected subprograms 5024 -- and entry bodies. For each protected subprograms two subprograms are 5025 -- created, an unprotected and a protected version. The unprotected 5026 -- version is called from within other operations of the same protected 5027 -- object. 5028 5029 -- We also build the call to register the procedure if a pragma 5030 -- Interrupt_Handler applies. 5031 5032 -- A single subprogram is created to service all entry bodies; it has an 5033 -- additional boolean out parameter indicating that the previous entry 5034 -- call made by the current task was serviced immediately, i.e. not by 5035 -- proxy. The O parameter contains a pointer to a record object of the 5036 -- type described above. An untyped interface is used here to allow this 5037 -- procedure to be called in places where the type of the object to be 5038 -- serviced is not known. This must be done, for example, when a call 5039 -- that may have been requeued is cancelled; the corresponding object 5040 -- must be serviced, but which object that is not known till runtime. 5041 5042 -- procedure ptypeS 5043 -- (O : System.Address; P : out Boolean); 5044 -- procedure pprocN (_object : in out poV); 5045 -- procedure pproc (_object : in out poV); 5046 -- function pfuncN (_object : poV); 5047 -- function pfunc (_object : poV); 5048 -- ... 5049 5050 -- Note that this must come after the record type declaration, since 5051 -- the specs refer to this type. 5052 5053 procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is 5054 Loc : constant Source_Ptr := Sloc (N); 5055 Prottyp : constant Entity_Id := Defining_Identifier (N); 5056 Protnm : constant Name_Id := Chars (Prottyp); 5057 5058 Pdef : constant Node_Id := Protected_Definition (N); 5059 -- This contains two lists; one for visible and one for private decls 5060 5061 Rec_Decl : Node_Id; 5062 Cdecls : List_Id; 5063 Discr_Map : constant Elist_Id := New_Elmt_List; 5064 Priv : Node_Id; 5065 Pent : Entity_Id; 5066 New_Priv : Node_Id; 5067 Comp : Node_Id; 5068 Comp_Id : Entity_Id; 5069 Sub : Node_Id; 5070 Current_Node : Node_Id := N; 5071 Bdef : Entity_Id := Empty; -- avoid uninit warning 5072 Edef : Entity_Id := Empty; -- avoid uninit warning 5073 Entries_Aggr : Node_Id; 5074 Body_Id : Entity_Id; 5075 Body_Arr : Node_Id; 5076 E_Count : Int; 5077 Object_Comp : Node_Id; 5078 5079 procedure Register_Handler; 5080 -- for a protected operation that is an interrupt handler, add the 5081 -- freeze action that will register it as such. 5082 5083 ---------------------- 5084 -- Register_Handler -- 5085 ---------------------- 5086 5087 procedure Register_Handler is 5088 5089 -- All semantic checks already done in Sem_Prag 5090 5091 Prot_Proc : constant Entity_Id := 5092 Defining_Unit_Name 5093 (Specification (Current_Node)); 5094 5095 Proc_Address : constant Node_Id := 5096 Make_Attribute_Reference (Loc, 5097 Prefix => New_Reference_To (Prot_Proc, Loc), 5098 Attribute_Name => Name_Address); 5099 5100 RTS_Call : constant Entity_Id := 5101 Make_Procedure_Call_Statement (Loc, 5102 Name => 5103 New_Reference_To ( 5104 RTE (RE_Register_Interrupt_Handler), Loc), 5105 Parameter_Associations => 5106 New_List (Proc_Address)); 5107 begin 5108 Append_Freeze_Action (Prot_Proc, RTS_Call); 5109 end Register_Handler; 5110 5111 -- Start of processing for Expand_N_Protected_Type_Declaration 5112 5113 begin 5114 if Present (Corresponding_Record_Type (Prottyp)) then 5115 return; 5116 else 5117 Rec_Decl := Build_Corresponding_Record (N, Prottyp, Loc); 5118 Cdecls := Component_Items 5119 (Component_List (Type_Definition (Rec_Decl))); 5120 end if; 5121 5122 Qualify_Entity_Names (N); 5123 5124 -- If the type has discriminants, their occurrences in the declaration 5125 -- have been replaced by the corresponding discriminals. For components 5126 -- that are constrained by discriminants, their homologues in the 5127 -- corresponding record type must refer to the discriminants of that 5128 -- record, so we must apply a new renaming to subtypes_indications: 5129 5130 -- protected discriminant => discriminal => record discriminant. 5131 -- This replacement is not applied to default expressions, for which 5132 -- the discriminal is correct. 5133 5134 if Has_Discriminants (Prottyp) then 5135 declare 5136 Disc : Entity_Id; 5137 Decl : Node_Id; 5138 5139 begin 5140 Disc := First_Discriminant (Prottyp); 5141 Decl := First (Discriminant_Specifications (Rec_Decl)); 5142 5143 while Present (Disc) loop 5144 Append_Elmt (Discriminal (Disc), Discr_Map); 5145 Append_Elmt (Defining_Identifier (Decl), Discr_Map); 5146 Next_Discriminant (Disc); 5147 Next (Decl); 5148 end loop; 5149 end; 5150 end if; 5151 5152 -- Fill in the component declarations 5153 5154 -- Add components for entry families. For each entry family, 5155 -- create an anonymous type declaration with the same size, and 5156 -- analyze the type. 5157 5158 Collect_Entry_Families (Loc, Cdecls, Current_Node, Prottyp); 5159 5160 -- Prepend the _Object field with the right type to the component 5161 -- list. We need to compute the number of entries, and in some cases 5162 -- the number of Attach_Handler pragmas. 5163 5164 declare 5165 Ritem : Node_Id; 5166 Num_Attach_Handler : Int := 0; 5167 Protection_Subtype : Node_Id; 5168 Entry_Count_Expr : constant Node_Id := 5169 Build_Entry_Count_Expression 5170 (Prottyp, Cdecls, Loc); 5171 5172 begin 5173 if Has_Attach_Handler (Prottyp) then 5174 Ritem := First_Rep_Item (Prottyp); 5175 while Present (Ritem) loop 5176 if Nkind (Ritem) = N_Pragma 5177 and then Chars (Ritem) = Name_Attach_Handler 5178 then 5179 Num_Attach_Handler := Num_Attach_Handler + 1; 5180 end if; 5181 5182 Next_Rep_Item (Ritem); 5183 end loop; 5184 5185 if Restricted_Profile then 5186 if Has_Entries (Prottyp) then 5187 Protection_Subtype := 5188 New_Reference_To (RTE (RE_Protection_Entry), Loc); 5189 else 5190 Protection_Subtype := 5191 New_Reference_To (RTE (RE_Protection), Loc); 5192 end if; 5193 else 5194 Protection_Subtype := 5195 Make_Subtype_Indication 5196 (Sloc => Loc, 5197 Subtype_Mark => 5198 New_Reference_To 5199 (RTE (RE_Static_Interrupt_Protection), Loc), 5200 Constraint => 5201 Make_Index_Or_Discriminant_Constraint ( 5202 Sloc => Loc, 5203 Constraints => New_List ( 5204 Entry_Count_Expr, 5205 Make_Integer_Literal (Loc, Num_Attach_Handler)))); 5206 end if; 5207 5208 elsif Has_Interrupt_Handler (Prottyp) then 5209 Protection_Subtype := 5210 Make_Subtype_Indication ( 5211 Sloc => Loc, 5212 Subtype_Mark => New_Reference_To 5213 (RTE (RE_Dynamic_Interrupt_Protection), Loc), 5214 Constraint => 5215 Make_Index_Or_Discriminant_Constraint ( 5216 Sloc => Loc, 5217 Constraints => New_List (Entry_Count_Expr))); 5218 5219 elsif Has_Entries (Prottyp) then 5220 if Abort_Allowed 5221 or else Restrictions (No_Entry_Queue) = False 5222 or else Number_Entries (Prottyp) > 1 5223 then 5224 Protection_Subtype := 5225 Make_Subtype_Indication ( 5226 Sloc => Loc, 5227 Subtype_Mark => 5228 New_Reference_To (RTE (RE_Protection_Entries), Loc), 5229 Constraint => 5230 Make_Index_Or_Discriminant_Constraint ( 5231 Sloc => Loc, 5232 Constraints => New_List (Entry_Count_Expr))); 5233 5234 else 5235 Protection_Subtype := 5236 New_Reference_To (RTE (RE_Protection_Entry), Loc); 5237 end if; 5238 5239 else 5240 Protection_Subtype := New_Reference_To (RTE (RE_Protection), Loc); 5241 end if; 5242 5243 Object_Comp := 5244 Make_Component_Declaration (Loc, 5245 Defining_Identifier => 5246 Make_Defining_Identifier (Loc, Name_uObject), 5247 Component_Definition => 5248 Make_Component_Definition (Loc, 5249 Aliased_Present => True, 5250 Subtype_Indication => Protection_Subtype)); 5251 end; 5252 5253 pragma Assert (Present (Pdef)); 5254 5255 -- Add private field components 5256 5257 if Present (Private_Declarations (Pdef)) then 5258 Priv := First (Private_Declarations (Pdef)); 5259 5260 while Present (Priv) loop 5261 5262 if Nkind (Priv) = N_Component_Declaration then 5263 Pent := Defining_Identifier (Priv); 5264 New_Priv := 5265 Make_Component_Declaration (Loc, 5266 Defining_Identifier => 5267 Make_Defining_Identifier (Sloc (Pent), Chars (Pent)), 5268 Component_Definition => 5269 Make_Component_Definition (Sloc (Pent), 5270 Aliased_Present => False, 5271 Subtype_Indication => 5272 New_Copy_Tree (Subtype_Indication 5273 (Component_Definition (Priv)), 5274 Discr_Map)), 5275 Expression => Expression (Priv)); 5276 5277 Append_To (Cdecls, New_Priv); 5278 5279 elsif Nkind (Priv) = N_Subprogram_Declaration then 5280 5281 -- Make the unprotected version of the subprogram available 5282 -- for expansion of intra object calls. There is need for 5283 -- a protected version only if the subprogram is an interrupt 5284 -- handler, otherwise this operation can only be called from 5285 -- within the body. 5286 5287 Sub := 5288 Make_Subprogram_Declaration (Loc, 5289 Specification => 5290 Build_Protected_Sub_Specification 5291 (Priv, Prottyp, Unprotected => True)); 5292 5293 Insert_After (Current_Node, Sub); 5294 Analyze (Sub); 5295 5296 Set_Protected_Body_Subprogram 5297 (Defining_Unit_Name (Specification (Priv)), 5298 Defining_Unit_Name (Specification (Sub))); 5299 5300 Current_Node := Sub; 5301 if Is_Interrupt_Handler 5302 (Defining_Unit_Name (Specification (Priv))) 5303 then 5304 Sub := 5305 Make_Subprogram_Declaration (Loc, 5306 Specification => 5307 Build_Protected_Sub_Specification 5308 (Priv, Prottyp, Unprotected => False)); 5309 5310 Insert_After (Current_Node, Sub); 5311 Analyze (Sub); 5312 Current_Node := Sub; 5313 5314 if not Restricted_Profile then 5315 Register_Handler; 5316 end if; 5317 end if; 5318 end if; 5319 5320 Next (Priv); 5321 end loop; 5322 end if; 5323 5324 -- Put the _Object component after the private component so that it 5325 -- be finalized early as required by 9.4 (20) 5326 5327 Append_To (Cdecls, Object_Comp); 5328 5329 Insert_After (Current_Node, Rec_Decl); 5330 Current_Node := Rec_Decl; 5331 5332 -- Analyze the record declaration immediately after construction, 5333 -- because the initialization procedure is needed for single object 5334 -- declarations before the next entity is analyzed (the freeze call 5335 -- that generates this initialization procedure is found below). 5336 5337 Analyze (Rec_Decl, Suppress => All_Checks); 5338 5339 -- Collect pointers to entry bodies and their barriers, to be placed 5340 -- in the Entry_Bodies_Array for the type. For each entry/family we 5341 -- add an expression to the aggregate which is the initial value of 5342 -- this array. The array is declared after all protected subprograms. 5343 5344 if Has_Entries (Prottyp) then 5345 Entries_Aggr := 5346 Make_Aggregate (Loc, Expressions => New_List); 5347 5348 else 5349 Entries_Aggr := Empty; 5350 end if; 5351 5352 -- Build two new procedure specifications for each protected 5353 -- subprogram; one to call from outside the object and one to 5354 -- call from inside. Build a barrier function and an entry 5355 -- body action procedure specification for each protected entry. 5356 -- Initialize the entry body array. 5357 5358 E_Count := 0; 5359 5360 Comp := First (Visible_Declarations (Pdef)); 5361 5362 while Present (Comp) loop 5363 if Nkind (Comp) = N_Subprogram_Declaration then 5364 Sub := 5365 Make_Subprogram_Declaration (Loc, 5366 Specification => 5367 Build_Protected_Sub_Specification 5368 (Comp, Prottyp, Unprotected => True)); 5369 5370 Insert_After (Current_Node, Sub); 5371 Analyze (Sub); 5372 5373 Set_Protected_Body_Subprogram 5374 (Defining_Unit_Name (Specification (Comp)), 5375 Defining_Unit_Name (Specification (Sub))); 5376 5377 -- Make the protected version of the subprogram available 5378 -- for expansion of external calls. 5379 5380 Current_Node := Sub; 5381 5382 Sub := 5383 Make_Subprogram_Declaration (Loc, 5384 Specification => 5385 Build_Protected_Sub_Specification 5386 (Comp, Prottyp, Unprotected => False)); 5387 5388 Insert_After (Current_Node, Sub); 5389 Analyze (Sub); 5390 Current_Node := Sub; 5391 5392 -- If a pragma Interrupt_Handler applies, build and add 5393 -- a call to Register_Interrupt_Handler to the freezing actions 5394 -- of the protected version (Current_Node) of the subprogram: 5395 -- system.interrupts.register_interrupt_handler 5396 -- (prot_procP'address); 5397 5398 if not Restricted_Profile 5399 and then Is_Interrupt_Handler 5400 (Defining_Unit_Name (Specification (Comp))) 5401 then 5402 Register_Handler; 5403 end if; 5404 5405 elsif Nkind (Comp) = N_Entry_Declaration then 5406 E_Count := E_Count + 1; 5407 Comp_Id := Defining_Identifier (Comp); 5408 Set_Privals_Chain (Comp_Id, New_Elmt_List); 5409 Edef := 5410 Make_Defining_Identifier (Loc, 5411 Build_Selected_Name 5412 (Protnm, 5413 New_External_Name (Chars (Comp_Id), Suffix_Index => -1), 5414 'E')); 5415 Sub := 5416 Make_Subprogram_Declaration (Loc, 5417 Specification => 5418 Build_Protected_Entry_Specification (Edef, Comp_Id, Loc)); 5419 5420 Insert_After (Current_Node, Sub); 5421 Analyze (Sub); 5422 5423 Set_Protected_Body_Subprogram ( 5424 Defining_Identifier (Comp), 5425 Defining_Unit_Name (Specification (Sub))); 5426 5427 Current_Node := Sub; 5428 5429 Bdef := 5430 Make_Defining_Identifier (Loc, 5431 Build_Selected_Name 5432 (Protnm, 5433 New_External_Name (Chars (Comp_Id), Suffix_Index => -1), 5434 'B')); 5435 Sub := 5436 Make_Subprogram_Declaration (Loc, 5437 Specification => 5438 Build_Barrier_Function_Specification (Bdef, Loc)); 5439 5440 Insert_After (Current_Node, Sub); 5441 Analyze (Sub); 5442 Set_Protected_Body_Subprogram (Bdef, Bdef); 5443 Set_Barrier_Function (Comp_Id, Bdef); 5444 Set_Scope (Bdef, Scope (Comp_Id)); 5445 Current_Node := Sub; 5446 5447 -- Collect pointers to the protected subprogram and the barrier 5448 -- of the current entry, for insertion into Entry_Bodies_Array. 5449 5450 Append ( 5451 Make_Aggregate (Loc, 5452 Expressions => New_List ( 5453 Make_Attribute_Reference (Loc, 5454 Prefix => New_Reference_To (Bdef, Loc), 5455 Attribute_Name => Name_Unrestricted_Access), 5456 Make_Attribute_Reference (Loc, 5457 Prefix => New_Reference_To (Edef, Loc), 5458 Attribute_Name => Name_Unrestricted_Access))), 5459 Expressions (Entries_Aggr)); 5460 5461 end if; 5462 5463 Next (Comp); 5464 end loop; 5465 5466 -- If there are some private entry declarations, expand it as if they 5467 -- were visible entries. 5468 5469 if Present (Private_Declarations (Pdef)) then 5470 Comp := First (Private_Declarations (Pdef)); 5471 5472 while Present (Comp) loop 5473 if Nkind (Comp) = N_Entry_Declaration then 5474 E_Count := E_Count + 1; 5475 Comp_Id := Defining_Identifier (Comp); 5476 Set_Privals_Chain (Comp_Id, New_Elmt_List); 5477 Edef := 5478 Make_Defining_Identifier (Loc, 5479 Build_Selected_Name 5480 (Protnm, 5481 New_External_Name (Chars (Comp_Id), Suffix_Index => -1), 5482 'E')); 5483 5484 Sub := 5485 Make_Subprogram_Declaration (Loc, 5486 Specification => 5487 Build_Protected_Entry_Specification (Edef, Comp_Id, Loc)); 5488 5489 Insert_After (Current_Node, Sub); 5490 Analyze (Sub); 5491 5492 Set_Protected_Body_Subprogram ( 5493 Defining_Identifier (Comp), 5494 Defining_Unit_Name (Specification (Sub))); 5495 5496 Current_Node := Sub; 5497 5498 Bdef := 5499 Make_Defining_Identifier (Loc, 5500 Build_Selected_Name 5501 (Protnm, 5502 New_External_Name (Chars (Comp_Id), Suffix_Index => -1), 5503 'B')); 5504 Sub := 5505 Make_Subprogram_Declaration (Loc, 5506 Specification => 5507 Build_Barrier_Function_Specification (Bdef, Loc)); 5508 5509 Insert_After (Current_Node, Sub); 5510 Analyze (Sub); 5511 Set_Protected_Body_Subprogram (Bdef, Bdef); 5512 Set_Barrier_Function (Comp_Id, Bdef); 5513 Set_Scope (Bdef, Scope (Comp_Id)); 5514 Current_Node := Sub; 5515 5516 -- Collect pointers to the protected subprogram and the 5517 -- barrier of the current entry, for insertion into 5518 -- Entry_Bodies_Array. 5519 5520 Append ( 5521 Make_Aggregate (Loc, 5522 Expressions => New_List ( 5523 Make_Attribute_Reference (Loc, 5524 Prefix => New_Reference_To (Bdef, Loc), 5525 Attribute_Name => Name_Unrestricted_Access), 5526 Make_Attribute_Reference (Loc, 5527 Prefix => New_Reference_To (Edef, Loc), 5528 Attribute_Name => Name_Unrestricted_Access))), 5529 Expressions (Entries_Aggr)); 5530 end if; 5531 5532 Next (Comp); 5533 end loop; 5534 end if; 5535 5536 -- Emit declaration for Entry_Bodies_Array, now that the addresses of 5537 -- all protected subprograms have been collected. 5538 5539 if Has_Entries (Prottyp) then 5540 Body_Id := Make_Defining_Identifier (Sloc (Prottyp), 5541 New_External_Name (Chars (Prottyp), 'A')); 5542 5543 if Abort_Allowed 5544 or else Restrictions (No_Entry_Queue) = False 5545 or else E_Count > 1 5546 then 5547 Body_Arr := Make_Object_Declaration (Loc, 5548 Defining_Identifier => Body_Id, 5549 Aliased_Present => True, 5550 Object_Definition => 5551 Make_Subtype_Indication (Loc, 5552 Subtype_Mark => New_Reference_To ( 5553 RTE (RE_Protected_Entry_Body_Array), Loc), 5554 Constraint => 5555 Make_Index_Or_Discriminant_Constraint (Loc, 5556 Constraints => New_List ( 5557 Make_Range (Loc, 5558 Make_Integer_Literal (Loc, 1), 5559 Make_Integer_Literal (Loc, E_Count))))), 5560 Expression => Entries_Aggr); 5561 5562 else 5563 Body_Arr := Make_Object_Declaration (Loc, 5564 Defining_Identifier => Body_Id, 5565 Aliased_Present => True, 5566 Object_Definition => New_Reference_To (RTE (RE_Entry_Body), Loc), 5567 Expression => 5568 Make_Aggregate (Loc, 5569 Expressions => New_List ( 5570 Make_Attribute_Reference (Loc, 5571 Prefix => New_Reference_To (Bdef, Loc), 5572 Attribute_Name => Name_Unrestricted_Access), 5573 Make_Attribute_Reference (Loc, 5574 Prefix => New_Reference_To (Edef, Loc), 5575 Attribute_Name => Name_Unrestricted_Access)))); 5576 end if; 5577 5578 -- A pointer to this array will be placed in the corresponding 5579 -- record by its initialization procedure, so this needs to be 5580 -- analyzed here. 5581 5582 Insert_After (Current_Node, Body_Arr); 5583 Current_Node := Body_Arr; 5584 Analyze (Body_Arr); 5585 5586 Set_Entry_Bodies_Array (Prottyp, Body_Id); 5587 5588 -- Finally, build the function that maps an entry index into the 5589 -- corresponding body. A pointer to this function is placed in each 5590 -- object of the type. Except for a ravenscar-like profile (no abort, 5591 -- no entry queue, 1 entry) 5592 5593 if Abort_Allowed 5594 or else Restrictions (No_Entry_Queue) = False 5595 or else E_Count > 1 5596 then 5597 Sub := 5598 Make_Subprogram_Declaration (Loc, 5599 Specification => Build_Find_Body_Index_Spec (Prottyp)); 5600 Insert_After (Current_Node, Sub); 5601 Analyze (Sub); 5602 end if; 5603 end if; 5604 end Expand_N_Protected_Type_Declaration; 5605 5606 -------------------------------- 5607 -- Expand_N_Requeue_Statement -- 5608 -------------------------------- 5609 5610 -- A requeue statement is expanded into one of four GNARLI operations, 5611 -- depending on the source and destination (task or protected object). 5612 -- In addition, code must be generated to jump around the remainder of 5613 -- processing for the original entry and, if the destination is a 5614 -- (different) protected object, to attempt to service it. 5615 -- The following illustrates the various cases: 5616 5617 -- procedure entE 5618 -- (O : System.Address; 5619 -- P : System.Address; 5620 -- E : Protected_Entry_Index) 5621 -- is 5622 -- <discriminant renamings> 5623 -- <private object renamings> 5624 -- type poVP is access poV; 5625 -- _Object : ptVP := ptVP!(O); 5626 5627 -- begin 5628 -- begin 5629 -- <start of statement sequence for entry> 5630 5631 -- -- Requeue from one protected entry body to another protected 5632 -- -- entry. 5633 5634 -- Requeue_Protected_Entry ( 5635 -- _object._object'Access, 5636 -- new._object'Access, 5637 -- E, 5638 -- Abort_Present); 5639 -- return; 5640 5641 -- <some more of the statement sequence for entry> 5642 5643 -- -- Requeue from an entry body to a task entry. 5644 5645 -- Requeue_Protected_To_Task_Entry ( 5646 -- New._task_id, 5647 -- E, 5648 -- Abort_Present); 5649 -- return; 5650 5651 -- <rest of statement sequence for entry> 5652 -- Complete_Entry_Body (_Object._Object); 5653 5654 -- exception 5655 -- when all others => 5656 -- Exceptional_Complete_Entry_Body ( 5657 -- _Object._Object, Get_GNAT_Exception); 5658 -- end; 5659 -- end entE; 5660 5661 -- Requeue of a task entry call to a task entry. 5662 5663 -- Accept_Call (E, Ann); 5664 -- <start of statement sequence for accept statement> 5665 -- Requeue_Task_Entry (New._task_id, E, Abort_Present); 5666 -- goto Lnn; 5667 -- <rest of statement sequence for accept statement> 5668 -- <<Lnn>> 5669 -- Complete_Rendezvous; 5670 5671 -- exception 5672 -- when all others => 5673 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 5674 5675 -- Requeue of a task entry call to a protected entry. 5676 5677 -- Accept_Call (E, Ann); 5678 -- <start of statement sequence for accept statement> 5679 -- Requeue_Task_To_Protected_Entry ( 5680 -- new._object'Access, 5681 -- E, 5682 -- Abort_Present); 5683 -- newS (new, Pnn); 5684 -- goto Lnn; 5685 -- <rest of statement sequence for accept statement> 5686 -- <<Lnn>> 5687 -- Complete_Rendezvous; 5688 5689 -- exception 5690 -- when all others => 5691 -- Exceptional_Complete_Rendezvous (Get_GNAT_Exception); 5692 5693 -- Further details on these expansions can be found in 5694 -- Expand_N_Protected_Body and Expand_N_Accept_Statement. 5695 5696 procedure Expand_N_Requeue_Statement (N : Node_Id) is 5697 Loc : constant Source_Ptr := Sloc (N); 5698 Acc_Stat : Node_Id; 5699 Concval : Node_Id; 5700 Ename : Node_Id; 5701 Index : Node_Id; 5702 Conctyp : Entity_Id; 5703 Oldtyp : Entity_Id; 5704 Lab_Node : Node_Id; 5705 Rcall : Node_Id; 5706 Abortable : Node_Id; 5707 Skip_Stat : Node_Id; 5708 Self_Param : Node_Id; 5709 New_Param : Node_Id; 5710 Params : List_Id; 5711 RTS_Call : Entity_Id; 5712 5713 begin 5714 if Abort_Present (N) then 5715 Abortable := New_Occurrence_Of (Standard_True, Loc); 5716 else 5717 Abortable := New_Occurrence_Of (Standard_False, Loc); 5718 end if; 5719 5720 -- Set up the target object. 5721 5722 Extract_Entry (N, Concval, Ename, Index); 5723 Conctyp := Etype (Concval); 5724 New_Param := Concurrent_Ref (Concval); 5725 5726 -- The target entry index and abortable flag are the same for all cases. 5727 5728 Params := New_List ( 5729 Entry_Index_Expression (Loc, Entity (Ename), Index, Conctyp), 5730 Abortable); 5731 5732 -- Determine proper GNARLI call and required additional parameters 5733 -- Loop to find nearest enclosing task type or protected type 5734 5735 Oldtyp := Current_Scope; 5736 loop 5737 if Is_Task_Type (Oldtyp) then 5738 if Is_Task_Type (Conctyp) then 5739 RTS_Call := RTE (RE_Requeue_Task_Entry); 5740 5741 else 5742 pragma Assert (Is_Protected_Type (Conctyp)); 5743 RTS_Call := RTE (RE_Requeue_Task_To_Protected_Entry); 5744 New_Param := 5745 Make_Attribute_Reference (Loc, 5746 Prefix => New_Param, 5747 Attribute_Name => Name_Unchecked_Access); 5748 end if; 5749 5750 Prepend (New_Param, Params); 5751 exit; 5752 5753 elsif Is_Protected_Type (Oldtyp) then 5754 Self_Param := 5755 Make_Attribute_Reference (Loc, 5756 Prefix => Concurrent_Ref (New_Occurrence_Of (Oldtyp, Loc)), 5757 Attribute_Name => Name_Unchecked_Access); 5758 5759 if Is_Task_Type (Conctyp) then 5760 RTS_Call := RTE (RE_Requeue_Protected_To_Task_Entry); 5761 5762 else 5763 pragma Assert (Is_Protected_Type (Conctyp)); 5764 RTS_Call := RTE (RE_Requeue_Protected_Entry); 5765 New_Param := 5766 Make_Attribute_Reference (Loc, 5767 Prefix => New_Param, 5768 Attribute_Name => Name_Unchecked_Access); 5769 end if; 5770 5771 Prepend (New_Param, Params); 5772 Prepend (Self_Param, Params); 5773 exit; 5774 5775 -- If neither task type or protected type, must be in some 5776 -- inner enclosing block, so move on out 5777 5778 else 5779 Oldtyp := Scope (Oldtyp); 5780 end if; 5781 end loop; 5782 5783 -- Create the GNARLI call. 5784 5785 Rcall := Make_Procedure_Call_Statement (Loc, 5786 Name => 5787 New_Occurrence_Of (RTS_Call, Loc), 5788 Parameter_Associations => Params); 5789 5790 Rewrite (N, Rcall); 5791 Analyze (N); 5792 5793 if Is_Protected_Type (Oldtyp) then 5794 5795 -- Build the return statement to skip the rest of the entry body 5796 5797 Skip_Stat := Make_Return_Statement (Loc); 5798 5799 else 5800 -- If the requeue is within a task, find the end label of the 5801 -- enclosing accept statement. 5802 5803 Acc_Stat := Parent (N); 5804 while Nkind (Acc_Stat) /= N_Accept_Statement loop 5805 Acc_Stat := Parent (Acc_Stat); 5806 end loop; 5807 5808 -- The last statement is the second label, used for completing the 5809 -- rendezvous the usual way. 5810 -- The label we are looking for is right before it. 5811 5812 Lab_Node := 5813 Prev (Last (Statements (Handled_Statement_Sequence (Acc_Stat)))); 5814 5815 pragma Assert (Nkind (Lab_Node) = N_Label); 5816 5817 -- Build the goto statement to skip the rest of the accept 5818 -- statement. 5819 5820 Skip_Stat := 5821 Make_Goto_Statement (Loc, 5822 Name => New_Occurrence_Of (Entity (Identifier (Lab_Node)), Loc)); 5823 end if; 5824 5825 Set_Analyzed (Skip_Stat); 5826 5827 Insert_After (N, Skip_Stat); 5828 end Expand_N_Requeue_Statement; 5829 5830 ------------------------------- 5831 -- Expand_N_Selective_Accept -- 5832 ------------------------------- 5833 5834 procedure Expand_N_Selective_Accept (N : Node_Id) is 5835 Loc : constant Source_Ptr := Sloc (N); 5836 Alts : constant List_Id := Select_Alternatives (N); 5837 5838 -- Note: in the below declarations a lot of new lists are allocated 5839 -- unconditionally which may well not end up being used. That's 5840 -- not a good idea since it wastes space gratuitously ??? 5841 5842 Accept_Case : List_Id; 5843 Accept_List : constant List_Id := New_List; 5844 5845 Alt : Node_Id; 5846 Alt_List : constant List_Id := New_List; 5847 Alt_Stats : List_Id; 5848 Ann : Entity_Id := Empty; 5849 5850 Block : Node_Id; 5851 Check_Guard : Boolean := True; 5852 5853 Decls : constant List_Id := New_List; 5854 Stats : constant List_Id := New_List; 5855 Body_List : constant List_Id := New_List; 5856 Trailing_List : constant List_Id := New_List; 5857 5858 Choices : List_Id; 5859 Else_Present : Boolean := False; 5860 Terminate_Alt : Node_Id := Empty; 5861 Select_Mode : Node_Id; 5862 5863 Delay_Case : List_Id; 5864 Delay_Count : Integer := 0; 5865 Delay_Val : Entity_Id; 5866 Delay_Index : Entity_Id; 5867 Delay_Min : Entity_Id; 5868 Delay_Num : Int := 1; 5869 Delay_Alt_List : List_Id := New_List; 5870 Delay_List : constant List_Id := New_List; 5871 D : Entity_Id; 5872 M : Entity_Id; 5873 5874 First_Delay : Boolean := True; 5875 Guard_Open : Entity_Id; 5876 5877 End_Lab : Node_Id; 5878 Index : Int := 1; 5879 Lab : Node_Id; 5880 Num_Alts : Int; 5881 Num_Accept : Nat := 0; 5882 Proc : Node_Id; 5883 Q : Node_Id; 5884 Time_Type : Entity_Id; 5885 X : Node_Id; 5886 Select_Call : Node_Id; 5887 5888 Qnam : constant Entity_Id := 5889 Make_Defining_Identifier (Loc, New_External_Name ('S', 0)); 5890 5891 Xnam : constant Entity_Id := 5892 Make_Defining_Identifier (Loc, New_External_Name ('J', 1)); 5893 5894 ----------------------- 5895 -- Local subprograms -- 5896 ----------------------- 5897 5898 function Accept_Or_Raise return List_Id; 5899 -- For the rare case where delay alternatives all have guards, and 5900 -- all of them are closed, it is still possible that there were open 5901 -- accept alternatives with no callers. We must reexamine the 5902 -- Accept_List, and execute a selective wait with no else if some 5903 -- accept is open. If none, we raise program_error. 5904 5905 procedure Add_Accept (Alt : Node_Id); 5906 -- Process a single accept statement in a select alternative. Build 5907 -- procedure for body of accept, and add entry to dispatch table with 5908 -- expression for guard, in preparation for call to run time select. 5909 5910 function Make_And_Declare_Label (Num : Int) return Node_Id; 5911 -- Manufacture a label using Num as a serial number and declare it. 5912 -- The declaration is appended to Decls. The label marks the trailing 5913 -- statements of an accept or delay alternative. 5914 5915 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id; 5916 -- Build call to Selective_Wait runtime routine. 5917 5918 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int); 5919 -- Add code to compare value of delay with previous values, and 5920 -- generate case entry for trailing statements. 5921 5922 procedure Process_Accept_Alternative 5923 (Alt : Node_Id; 5924 Index : Int; 5925 Proc : Node_Id); 5926 -- Add code to call corresponding procedure, and branch to 5927 -- trailing statements, if any. 5928 5929 --------------------- 5930 -- Accept_Or_Raise -- 5931 --------------------- 5932 5933 function Accept_Or_Raise return List_Id is 5934 Cond : Node_Id; 5935 Stats : List_Id; 5936 J : constant Entity_Id := Make_Defining_Identifier (Loc, 5937 New_Internal_Name ('J')); 5938 5939 begin 5940 -- We generate the following: 5941 5942 -- for J in q'range loop 5943 -- if q(J).S /=null_task_entry then 5944 -- selective_wait (simple_mode,...); 5945 -- done := True; 5946 -- exit; 5947 -- end if; 5948 -- end loop; 5949 -- 5950 -- if no rendez_vous then 5951 -- raise program_error; 5952 -- end if; 5953 5954 -- Note that the code needs to know that the selector name 5955 -- in an Accept_Alternative is named S. 5956 5957 Cond := Make_Op_Ne (Loc, 5958 Left_Opnd => 5959 Make_Selected_Component (Loc, 5960 Prefix => Make_Indexed_Component (Loc, 5961 Prefix => New_Reference_To (Qnam, Loc), 5962 Expressions => New_List (New_Reference_To (J, Loc))), 5963 Selector_Name => Make_Identifier (Loc, Name_S)), 5964 Right_Opnd => 5965 New_Reference_To (RTE (RE_Null_Task_Entry), Loc)); 5966 5967 Stats := New_List ( 5968 Make_Implicit_Loop_Statement (N, 5969 Identifier => Empty, 5970 Iteration_Scheme => 5971 Make_Iteration_Scheme (Loc, 5972 Loop_Parameter_Specification => 5973 Make_Loop_Parameter_Specification (Loc, 5974 Defining_Identifier => J, 5975 Discrete_Subtype_Definition => 5976 Make_Attribute_Reference (Loc, 5977 Prefix => New_Reference_To (Qnam, Loc), 5978 Attribute_Name => Name_Range, 5979 Expressions => New_List ( 5980 Make_Integer_Literal (Loc, 1))))), 5981 5982 Statements => New_List ( 5983 Make_Implicit_If_Statement (N, 5984 Condition => Cond, 5985 Then_Statements => New_List ( 5986 Make_Select_Call ( 5987 New_Reference_To (RTE (RE_Simple_Mode), Loc)), 5988 Make_Exit_Statement (Loc)))))); 5989 5990 Append_To (Stats, 5991 Make_Raise_Program_Error (Loc, 5992 Condition => Make_Op_Eq (Loc, 5993 Left_Opnd => New_Reference_To (Xnam, Loc), 5994 Right_Opnd => 5995 New_Reference_To (RTE (RE_No_Rendezvous), Loc)), 5996 Reason => PE_All_Guards_Closed)); 5997 5998 return Stats; 5999 end Accept_Or_Raise; 6000 6001 ---------------- 6002 -- Add_Accept -- 6003 ---------------- 6004 6005 procedure Add_Accept (Alt : Node_Id) is 6006 Acc_Stm : constant Node_Id := Accept_Statement (Alt); 6007 Ename : constant Node_Id := Entry_Direct_Name (Acc_Stm); 6008 Eent : constant Entity_Id := Entity (Ename); 6009 Index : constant Node_Id := Entry_Index (Acc_Stm); 6010 Null_Body : Node_Id; 6011 Proc_Body : Node_Id; 6012 PB_Ent : Entity_Id; 6013 Expr : Node_Id; 6014 Call : Node_Id; 6015 6016 begin 6017 if No (Ann) then 6018 Ann := Node (Last_Elmt (Accept_Address (Eent))); 6019 end if; 6020 6021 if Present (Condition (Alt)) then 6022 Expr := 6023 Make_Conditional_Expression (Loc, New_List ( 6024 Condition (Alt), 6025 Entry_Index_Expression (Loc, Eent, Index, Scope (Eent)), 6026 New_Reference_To (RTE (RE_Null_Task_Entry), Loc))); 6027 else 6028 Expr := 6029 Entry_Index_Expression 6030 (Loc, Eent, Index, Scope (Eent)); 6031 end if; 6032 6033 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then 6034 Null_Body := New_Reference_To (Standard_False, Loc); 6035 6036 if Abort_Allowed then 6037 Call := Make_Procedure_Call_Statement (Loc, 6038 Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc)); 6039 Insert_Before (First (Statements (Handled_Statement_Sequence ( 6040 Accept_Statement (Alt)))), Call); 6041 Analyze (Call); 6042 end if; 6043 6044 PB_Ent := 6045 Make_Defining_Identifier (Sloc (Ename), 6046 New_External_Name (Chars (Ename), 'A', Num_Accept)); 6047 6048 Set_Needs_Debug_Info (PB_Ent, Comes_From_Source (Alt)); 6049 6050 Proc_Body := 6051 Make_Subprogram_Body (Loc, 6052 Specification => 6053 Make_Procedure_Specification (Loc, 6054 Defining_Unit_Name => PB_Ent), 6055 Declarations => Declarations (Acc_Stm), 6056 Handled_Statement_Sequence => 6057 Build_Accept_Body (Accept_Statement (Alt))); 6058 6059 -- During the analysis of the body of the accept statement, any 6060 -- zero cost exception handler records were collected in the 6061 -- Accept_Handler_Records field of the N_Accept_Alternative 6062 -- node. This is where we move them to where they belong, 6063 -- namely the newly created procedure. 6064 6065 Set_Handler_Records (PB_Ent, Accept_Handler_Records (Alt)); 6066 Append (Proc_Body, Body_List); 6067 6068 else 6069 Null_Body := New_Reference_To (Standard_True, Loc); 6070 6071 -- if accept statement has declarations, insert above, given 6072 -- that we are not creating a body for the accept. 6073 6074 if Present (Declarations (Acc_Stm)) then 6075 Insert_Actions (N, Declarations (Acc_Stm)); 6076 end if; 6077 end if; 6078 6079 Append_To (Accept_List, 6080 Make_Aggregate (Loc, Expressions => New_List (Null_Body, Expr))); 6081 6082 Num_Accept := Num_Accept + 1; 6083 end Add_Accept; 6084 6085 ---------------------------- 6086 -- Make_And_Declare_Label -- 6087 ---------------------------- 6088 6089 function Make_And_Declare_Label (Num : Int) return Node_Id is 6090 Lab_Id : Node_Id; 6091 6092 begin 6093 Lab_Id := Make_Identifier (Loc, New_External_Name ('L', Num)); 6094 Lab := 6095 Make_Label (Loc, Lab_Id); 6096 6097 Append_To (Decls, 6098 Make_Implicit_Label_Declaration (Loc, 6099 Defining_Identifier => 6100 Make_Defining_Identifier (Loc, Chars (Lab_Id)), 6101 Label_Construct => Lab)); 6102 6103 return Lab; 6104 end Make_And_Declare_Label; 6105 6106 ---------------------- 6107 -- Make_Select_Call -- 6108 ---------------------- 6109 6110 function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is 6111 Params : constant List_Id := New_List; 6112 6113 begin 6114 Append ( 6115 Make_Attribute_Reference (Loc, 6116 Prefix => New_Reference_To (Qnam, Loc), 6117 Attribute_Name => Name_Unchecked_Access), 6118 Params); 6119 Append (Select_Mode, Params); 6120 Append (New_Reference_To (Ann, Loc), Params); 6121 Append (New_Reference_To (Xnam, Loc), Params); 6122 6123 return 6124 Make_Procedure_Call_Statement (Loc, 6125 Name => New_Reference_To (RTE (RE_Selective_Wait), Loc), 6126 Parameter_Associations => Params); 6127 end Make_Select_Call; 6128 6129 -------------------------------- 6130 -- Process_Accept_Alternative -- 6131 -------------------------------- 6132 6133 procedure Process_Accept_Alternative 6134 (Alt : Node_Id; 6135 Index : Int; 6136 Proc : Node_Id) 6137 is 6138 Choices : List_Id := No_List; 6139 Alt_Stats : List_Id; 6140 6141 begin 6142 Adjust_Condition (Condition (Alt)); 6143 Alt_Stats := No_List; 6144 6145 if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then 6146 Choices := New_List ( 6147 Make_Integer_Literal (Loc, Index)); 6148 6149 Alt_Stats := New_List ( 6150 Make_Procedure_Call_Statement (Loc, 6151 Name => New_Reference_To ( 6152 Defining_Unit_Name (Specification (Proc)), Loc))); 6153 end if; 6154 6155 if Statements (Alt) /= Empty_List then 6156 6157 if No (Alt_Stats) then 6158 6159 -- Accept with no body, followed by trailing statements. 6160 6161 Choices := New_List ( 6162 Make_Integer_Literal (Loc, Index)); 6163 6164 Alt_Stats := New_List; 6165 end if; 6166 6167 -- After the call, if any, branch to to trailing statements. 6168 -- We create a label for each, as well as the corresponding 6169 -- label declaration. 6170 6171 Lab := Make_And_Declare_Label (Index); 6172 Append_To (Alt_Stats, 6173 Make_Goto_Statement (Loc, 6174 Name => New_Copy (Identifier (Lab)))); 6175 6176 Append (Lab, Trailing_List); 6177 Append_List (Statements (Alt), Trailing_List); 6178 Append_To (Trailing_List, 6179 Make_Goto_Statement (Loc, 6180 Name => New_Copy (Identifier (End_Lab)))); 6181 end if; 6182 6183 if Present (Alt_Stats) then 6184 6185 -- Procedure call. and/or trailing statements 6186 6187 Append_To (Alt_List, 6188 Make_Case_Statement_Alternative (Loc, 6189 Discrete_Choices => Choices, 6190 Statements => Alt_Stats)); 6191 end if; 6192 end Process_Accept_Alternative; 6193 6194 ------------------------------- 6195 -- Process_Delay_Alternative -- 6196 ------------------------------- 6197 6198 procedure Process_Delay_Alternative (Alt : Node_Id; Index : Int) is 6199 Choices : List_Id; 6200 Cond : Node_Id; 6201 Delay_Alt : List_Id; 6202 6203 begin 6204 -- Deal with C/Fortran boolean as delay condition 6205 6206 Adjust_Condition (Condition (Alt)); 6207 6208 -- Determine the smallest specified delay. 6209 -- for each delay alternative generate: 6210 6211 -- if guard-expression then 6212 -- Delay_Val := delay-expression; 6213 -- Guard_Open := True; 6214 -- if Delay_Val < Delay_Min then 6215 -- Delay_Min := Delay_Val; 6216 -- Delay_Index := Index; 6217 -- end if; 6218 -- end if; 6219 6220 -- The enclosing if-statement is omitted if there is no guard. 6221 6222 if Delay_Count = 1 6223 or else First_Delay 6224 then 6225 First_Delay := False; 6226 6227 Delay_Alt := New_List ( 6228 Make_Assignment_Statement (Loc, 6229 Name => New_Reference_To (Delay_Min, Loc), 6230 Expression => Expression (Delay_Statement (Alt)))); 6231 6232 if Delay_Count > 1 then 6233 Append_To (Delay_Alt, 6234 Make_Assignment_Statement (Loc, 6235 Name => New_Reference_To (Delay_Index, Loc), 6236 Expression => Make_Integer_Literal (Loc, Index))); 6237 end if; 6238 6239 else 6240 Delay_Alt := New_List ( 6241 Make_Assignment_Statement (Loc, 6242 Name => New_Reference_To (Delay_Val, Loc), 6243 Expression => Expression (Delay_Statement (Alt)))); 6244 6245 if Time_Type = Standard_Duration then 6246 Cond := 6247 Make_Op_Lt (Loc, 6248 Left_Opnd => New_Reference_To (Delay_Val, Loc), 6249 Right_Opnd => New_Reference_To (Delay_Min, Loc)); 6250 6251 else 6252 -- The scope of the time type must define a comparison 6253 -- operator. The scope itself may not be visible, so we 6254 -- construct a node with entity information to insure that 6255 -- semantic analysis can find the proper operator. 6256 6257 Cond := 6258 Make_Function_Call (Loc, 6259 Name => Make_Selected_Component (Loc, 6260 Prefix => New_Reference_To (Scope (Time_Type), Loc), 6261 Selector_Name => 6262 Make_Operator_Symbol (Loc, 6263 Chars => Name_Op_Lt, 6264 Strval => No_String)), 6265 Parameter_Associations => 6266 New_List ( 6267 New_Reference_To (Delay_Val, Loc), 6268 New_Reference_To (Delay_Min, Loc))); 6269 6270 Set_Entity (Prefix (Name (Cond)), Scope (Time_Type)); 6271 end if; 6272 6273 Append_To (Delay_Alt, 6274 Make_Implicit_If_Statement (N, 6275 Condition => Cond, 6276 Then_Statements => New_List ( 6277 Make_Assignment_Statement (Loc, 6278 Name => New_Reference_To (Delay_Min, Loc), 6279 Expression => New_Reference_To (Delay_Val, Loc)), 6280 6281 Make_Assignment_Statement (Loc, 6282 Name => New_Reference_To (Delay_Index, Loc), 6283 Expression => Make_Integer_Literal (Loc, Index))))); 6284 end if; 6285 6286 if Check_Guard then 6287 Append_To (Delay_Alt, 6288 Make_Assignment_Statement (Loc, 6289 Name => New_Reference_To (Guard_Open, Loc), 6290 Expression => New_Reference_To (Standard_True, Loc))); 6291 end if; 6292 6293 if Present (Condition (Alt)) then 6294 Delay_Alt := New_List ( 6295 Make_Implicit_If_Statement (N, 6296 Condition => Condition (Alt), 6297 Then_Statements => Delay_Alt)); 6298 end if; 6299 6300 Append_List (Delay_Alt, Delay_List); 6301 6302 -- If the delay alternative has a statement part, add a 6303 -- choice to the case statements for delays. 6304 6305 if Present (Statements (Alt)) then 6306 6307 if Delay_Count = 1 then 6308 Append_List (Statements (Alt), Delay_Alt_List); 6309 6310 else 6311 Choices := New_List ( 6312 Make_Integer_Literal (Loc, Index)); 6313 6314 Append_To (Delay_Alt_List, 6315 Make_Case_Statement_Alternative (Loc, 6316 Discrete_Choices => Choices, 6317 Statements => Statements (Alt))); 6318 end if; 6319 6320 elsif Delay_Count = 1 then 6321 6322 -- If the single delay has no trailing statements, add a branch 6323 -- to the exit label to the selective wait. 6324 6325 Delay_Alt_List := New_List ( 6326 Make_Goto_Statement (Loc, 6327 Name => New_Copy (Identifier (End_Lab)))); 6328 6329 end if; 6330 end Process_Delay_Alternative; 6331 6332 -- Start of processing for Expand_N_Selective_Accept 6333 6334 begin 6335 -- First insert some declarations before the select. The first is: 6336 6337 -- Ann : Address 6338 6339 -- This variable holds the parameters passed to the accept body. This 6340 -- declaration has already been inserted by the time we get here by 6341 -- a call to Expand_Accept_Declarations made from the semantics when 6342 -- processing the first accept statement contained in the select. We 6343 -- can find this entity as Accept_Address (E), where E is any of the 6344 -- entries references by contained accept statements. 6345 6346 -- The first step is to scan the list of Selective_Accept_Statements 6347 -- to find this entity, and also count the number of accepts, and 6348 -- determine if terminated, delay or else is present: 6349 6350 Num_Alts := 0; 6351 6352 Alt := First (Alts); 6353 while Present (Alt) loop 6354 6355 if Nkind (Alt) = N_Accept_Alternative then 6356 Add_Accept (Alt); 6357 6358 elsif Nkind (Alt) = N_Delay_Alternative then 6359 Delay_Count := Delay_Count + 1; 6360 6361 -- If the delays are relative delays, the delay expressions have 6362 -- type Standard_Duration. Otherwise they must have some time type 6363 -- recognized by GNAT. 6364 6365 if Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement then 6366 Time_Type := Standard_Duration; 6367 else 6368 Time_Type := Etype (Expression (Delay_Statement (Alt))); 6369 6370 if Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) 6371 or else Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time) 6372 then 6373 null; 6374 else 6375 Error_Msg_NE ( 6376 "& is not a time type ('R'M 9.6(6))", 6377 Expression (Delay_Statement (Alt)), Time_Type); 6378 Time_Type := Standard_Duration; 6379 Set_Etype (Expression (Delay_Statement (Alt)), Any_Type); 6380 end if; 6381 end if; 6382 6383 if No (Condition (Alt)) then 6384 6385 -- This guard will always be open. 6386 6387 Check_Guard := False; 6388 end if; 6389 6390 elsif Nkind (Alt) = N_Terminate_Alternative then 6391 Adjust_Condition (Condition (Alt)); 6392 Terminate_Alt := Alt; 6393 end if; 6394 6395 Num_Alts := Num_Alts + 1; 6396 Next (Alt); 6397 end loop; 6398 6399 Else_Present := Present (Else_Statements (N)); 6400 6401 -- At the same time (see procedure Add_Accept) we build the accept list: 6402 6403 -- Qnn : Accept_List (1 .. num-select) := ( 6404 -- (null-body, entry-index), 6405 -- (null-body, entry-index), 6406 -- .. 6407 -- (null_body, entry-index)); 6408 6409 -- In the above declaration, null-body is True if the corresponding 6410 -- accept has no body, and false otherwise. The entry is either the 6411 -- entry index expression if there is no guard, or if a guard is 6412 -- present, then a conditional expression of the form: 6413 6414 -- (if guard then entry-index else Null_Task_Entry) 6415 6416 -- If a guard is statically known to be false, the entry can simply 6417 -- be omitted from the accept list. 6418 6419 Q := 6420 Make_Object_Declaration (Loc, 6421 Defining_Identifier => Qnam, 6422 Object_Definition => 6423 New_Reference_To (RTE (RE_Accept_List), Loc), 6424 Aliased_Present => True, 6425 6426 Expression => 6427 Make_Qualified_Expression (Loc, 6428 Subtype_Mark => 6429 New_Reference_To (RTE (RE_Accept_List), Loc), 6430 Expression => 6431 Make_Aggregate (Loc, Expressions => Accept_List))); 6432 6433 Append (Q, Decls); 6434 6435 -- Then we declare the variable that holds the index for the accept 6436 -- that will be selected for service: 6437 6438 -- Xnn : Select_Index; 6439 6440 X := 6441 Make_Object_Declaration (Loc, 6442 Defining_Identifier => Xnam, 6443 Object_Definition => 6444 New_Reference_To (RTE (RE_Select_Index), Loc), 6445 Expression => 6446 New_Reference_To (RTE (RE_No_Rendezvous), Loc)); 6447 6448 Append (X, Decls); 6449 6450 -- After this follow procedure declarations for each accept body. 6451 6452 -- procedure Pnn is 6453 -- begin 6454 -- ... 6455 -- end; 6456 6457 -- where the ... are statements from the corresponding procedure body. 6458 -- No parameters are involved, since the parameters are passed via Ann 6459 -- and the parameter references have already been expanded to be direct 6460 -- references to Ann (see Exp_Ch2.Expand_Entry_Parameter). Furthermore, 6461 -- any embedded tasking statements (which would normally be illegal in 6462 -- procedures, have been converted to calls to the tasking runtime so 6463 -- there is no problem in putting them into procedures. 6464 6465 -- The original accept statement has been expanded into a block in 6466 -- the same fashion as for simple accepts (see Build_Accept_Body). 6467 6468 -- Note: we don't really need to build these procedures for the case 6469 -- where no delay statement is present, but it is just as easy to 6470 -- build them unconditionally, and not significantly inefficient, 6471 -- since if they are short they will be inlined anyway. 6472 6473 -- The procedure declarations have been assembled in Body_List. 6474 6475 -- If delays are present, we must compute the required delay. 6476 -- We first generate the declarations: 6477 6478 -- Delay_Index : Boolean := 0; 6479 -- Delay_Min : Some_Time_Type.Time; 6480 -- Delay_Val : Some_Time_Type.Time; 6481 6482 -- Delay_Index will be set to the index of the minimum delay, i.e. the 6483 -- active delay that is actually chosen as the basis for the possible 6484 -- delay if an immediate rendez-vous is not possible. 6485 -- In the most common case there is a single delay statement, and this 6486 -- is handled specially. 6487 6488 if Delay_Count > 0 then 6489 6490 -- Generate the required declarations 6491 6492 Delay_Val := 6493 Make_Defining_Identifier (Loc, New_External_Name ('D', 1)); 6494 Delay_Index := 6495 Make_Defining_Identifier (Loc, New_External_Name ('D', 2)); 6496 Delay_Min := 6497 Make_Defining_Identifier (Loc, New_External_Name ('D', 3)); 6498 6499 Append_To (Decls, 6500 Make_Object_Declaration (Loc, 6501 Defining_Identifier => Delay_Val, 6502 Object_Definition => New_Reference_To (Time_Type, Loc))); 6503 6504 Append_To (Decls, 6505 Make_Object_Declaration (Loc, 6506 Defining_Identifier => Delay_Index, 6507 Object_Definition => New_Reference_To (Standard_Integer, Loc), 6508 Expression => Make_Integer_Literal (Loc, 0))); 6509 6510 Append_To (Decls, 6511 Make_Object_Declaration (Loc, 6512 Defining_Identifier => Delay_Min, 6513 Object_Definition => New_Reference_To (Time_Type, Loc), 6514 Expression => 6515 Unchecked_Convert_To (Time_Type, 6516 Make_Attribute_Reference (Loc, 6517 Prefix => 6518 New_Occurrence_Of (Underlying_Type (Time_Type), Loc), 6519 Attribute_Name => Name_Last)))); 6520 6521 -- Create Duration and Delay_Mode objects used for passing a delay 6522 -- value to RTS 6523 6524 D := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); 6525 M := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); 6526 6527 declare 6528 Discr : Entity_Id; 6529 6530 begin 6531 -- Note that these values are defined in s-osprim.ads and must 6532 -- be kept in sync: 6533 -- 6534 -- Relative : constant := 0; 6535 -- Absolute_Calendar : constant := 1; 6536 -- Absolute_RT : constant := 2; 6537 6538 if Time_Type = Standard_Duration then 6539 Discr := Make_Integer_Literal (Loc, 0); 6540 6541 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 6542 Discr := Make_Integer_Literal (Loc, 1); 6543 6544 else 6545 pragma Assert 6546 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 6547 Discr := Make_Integer_Literal (Loc, 2); 6548 end if; 6549 6550 Append_To (Decls, 6551 Make_Object_Declaration (Loc, 6552 Defining_Identifier => D, 6553 Object_Definition => 6554 New_Reference_To (Standard_Duration, Loc))); 6555 6556 Append_To (Decls, 6557 Make_Object_Declaration (Loc, 6558 Defining_Identifier => M, 6559 Object_Definition => 6560 New_Reference_To (Standard_Integer, Loc), 6561 Expression => Discr)); 6562 end; 6563 6564 if Check_Guard then 6565 Guard_Open := 6566 Make_Defining_Identifier (Loc, New_External_Name ('G', 1)); 6567 6568 Append_To (Decls, 6569 Make_Object_Declaration (Loc, 6570 Defining_Identifier => Guard_Open, 6571 Object_Definition => New_Reference_To (Standard_Boolean, Loc), 6572 Expression => New_Reference_To (Standard_False, Loc))); 6573 end if; 6574 6575 -- Delay_Count is zero, don't need M and D set (suppress warning) 6576 6577 else 6578 M := Empty; 6579 D := Empty; 6580 end if; 6581 6582 if Present (Terminate_Alt) then 6583 6584 -- If the terminate alternative guard is False, use 6585 -- Simple_Mode; otherwise use Terminate_Mode. 6586 6587 if Present (Condition (Terminate_Alt)) then 6588 Select_Mode := Make_Conditional_Expression (Loc, 6589 New_List (Condition (Terminate_Alt), 6590 New_Reference_To (RTE (RE_Terminate_Mode), Loc), 6591 New_Reference_To (RTE (RE_Simple_Mode), Loc))); 6592 else 6593 Select_Mode := New_Reference_To (RTE (RE_Terminate_Mode), Loc); 6594 end if; 6595 6596 elsif Else_Present or Delay_Count > 0 then 6597 Select_Mode := New_Reference_To (RTE (RE_Else_Mode), Loc); 6598 6599 else 6600 Select_Mode := New_Reference_To (RTE (RE_Simple_Mode), Loc); 6601 end if; 6602 6603 Select_Call := Make_Select_Call (Select_Mode); 6604 Append (Select_Call, Stats); 6605 6606 -- Now generate code to act on the result. There is an entry 6607 -- in this case for each accept statement with a non-null body, 6608 -- followed by a branch to the statements that follow the Accept. 6609 -- In the absence of delay alternatives, we generate: 6610 6611 -- case X is 6612 -- when No_Rendezvous => -- omitted if simple mode 6613 -- goto Lab0; 6614 6615 -- when 1 => 6616 -- P1n; 6617 -- goto Lab1; 6618 6619 -- when 2 => 6620 -- P2n; 6621 -- goto Lab2; 6622 6623 -- when others => 6624 -- goto Exit; 6625 -- end case; 6626 -- 6627 -- Lab0: Else_Statements; 6628 -- goto exit; 6629 6630 -- Lab1: Trailing_Statements1; 6631 -- goto Exit; 6632 -- 6633 -- Lab2: Trailing_Statements2; 6634 -- goto Exit; 6635 -- ... 6636 -- Exit: 6637 6638 -- Generate label for common exit. 6639 6640 End_Lab := Make_And_Declare_Label (Num_Alts + 1); 6641 6642 -- First entry is the default case, when no rendezvous is possible. 6643 6644 Choices := New_List (New_Reference_To (RTE (RE_No_Rendezvous), Loc)); 6645 6646 if Else_Present then 6647 6648 -- If no rendezvous is possible, the else part is executed. 6649 6650 Lab := Make_And_Declare_Label (0); 6651 Alt_Stats := New_List ( 6652 Make_Goto_Statement (Loc, 6653 Name => New_Copy (Identifier (Lab)))); 6654 6655 Append (Lab, Trailing_List); 6656 Append_List (Else_Statements (N), Trailing_List); 6657 Append_To (Trailing_List, 6658 Make_Goto_Statement (Loc, 6659 Name => New_Copy (Identifier (End_Lab)))); 6660 else 6661 Alt_Stats := New_List ( 6662 Make_Goto_Statement (Loc, 6663 Name => New_Copy (Identifier (End_Lab)))); 6664 end if; 6665 6666 Append_To (Alt_List, 6667 Make_Case_Statement_Alternative (Loc, 6668 Discrete_Choices => Choices, 6669 Statements => Alt_Stats)); 6670 6671 -- We make use of the fact that Accept_Index is an integer type, 6672 -- and generate successive literals for entries for each accept. 6673 -- Only those for which there is a body or trailing statements are 6674 -- given a case entry. 6675 6676 Alt := First (Select_Alternatives (N)); 6677 Proc := First (Body_List); 6678 6679 while Present (Alt) loop 6680 6681 if Nkind (Alt) = N_Accept_Alternative then 6682 Process_Accept_Alternative (Alt, Index, Proc); 6683 Index := Index + 1; 6684 6685 if Present 6686 (Handled_Statement_Sequence (Accept_Statement (Alt))) 6687 then 6688 Next (Proc); 6689 end if; 6690 6691 elsif Nkind (Alt) = N_Delay_Alternative then 6692 Process_Delay_Alternative (Alt, Delay_Num); 6693 Delay_Num := Delay_Num + 1; 6694 end if; 6695 6696 Next (Alt); 6697 end loop; 6698 6699 -- An others choice is always added to the main case, as well 6700 -- as the delay case (to satisfy the compiler). 6701 6702 Append_To (Alt_List, 6703 Make_Case_Statement_Alternative (Loc, 6704 Discrete_Choices => 6705 New_List (Make_Others_Choice (Loc)), 6706 Statements => 6707 New_List (Make_Goto_Statement (Loc, 6708 Name => New_Copy (Identifier (End_Lab)))))); 6709 6710 Accept_Case := New_List ( 6711 Make_Case_Statement (Loc, 6712 Expression => New_Reference_To (Xnam, Loc), 6713 Alternatives => Alt_List)); 6714 6715 Append_List (Trailing_List, Accept_Case); 6716 Append (End_Lab, Accept_Case); 6717 Append_List (Body_List, Decls); 6718 6719 -- Construct case statement for trailing statements of delay 6720 -- alternatives, if there are several of them. 6721 6722 if Delay_Count > 1 then 6723 Append_To (Delay_Alt_List, 6724 Make_Case_Statement_Alternative (Loc, 6725 Discrete_Choices => 6726 New_List (Make_Others_Choice (Loc)), 6727 Statements => 6728 New_List (Make_Null_Statement (Loc)))); 6729 6730 Delay_Case := New_List ( 6731 Make_Case_Statement (Loc, 6732 Expression => New_Reference_To (Delay_Index, Loc), 6733 Alternatives => Delay_Alt_List)); 6734 else 6735 Delay_Case := Delay_Alt_List; 6736 end if; 6737 6738 -- If there are no delay alternatives, we append the case statement 6739 -- to the statement list. 6740 6741 if Delay_Count = 0 then 6742 Append_List (Accept_Case, Stats); 6743 6744 -- Delay alternatives present 6745 6746 else 6747 -- If delay alternatives are present we generate: 6748 6749 -- find minimum delay. 6750 -- DX := minimum delay; 6751 -- M := <delay mode>; 6752 -- Timed_Selective_Wait (Q'Unchecked_Access, Delay_Mode, P, 6753 -- DX, MX, X); 6754 -- 6755 -- if X = No_Rendezvous then 6756 -- case statement for delay statements. 6757 -- else 6758 -- case statement for accept alternatives. 6759 -- end if; 6760 6761 declare 6762 Cases : Node_Id; 6763 Stmt : Node_Id; 6764 Parms : List_Id; 6765 Parm : Node_Id; 6766 Conv : Node_Id; 6767 6768 begin 6769 -- The type of the delay expression is known to be legal 6770 6771 if Time_Type = Standard_Duration then 6772 Conv := New_Reference_To (Delay_Min, Loc); 6773 6774 elsif Is_RTE (Base_Type (Etype (Time_Type)), RO_CA_Time) then 6775 Conv := Make_Function_Call (Loc, 6776 New_Reference_To (RTE (RO_CA_To_Duration), Loc), 6777 New_List (New_Reference_To (Delay_Min, Loc))); 6778 6779 else 6780 pragma Assert 6781 (Is_RTE (Base_Type (Etype (Time_Type)), RO_RT_Time)); 6782 6783 Conv := Make_Function_Call (Loc, 6784 New_Reference_To (RTE (RO_RT_To_Duration), Loc), 6785 New_List (New_Reference_To (Delay_Min, Loc))); 6786 end if; 6787 6788 Stmt := Make_Assignment_Statement (Loc, 6789 Name => New_Reference_To (D, Loc), 6790 Expression => Conv); 6791 6792 -- Change the value for Accept_Modes. (Else_Mode -> Delay_Mode) 6793 6794 Parms := Parameter_Associations (Select_Call); 6795 Parm := First (Parms); 6796 6797 while Present (Parm) 6798 and then Parm /= Select_Mode 6799 loop 6800 Next (Parm); 6801 end loop; 6802 6803 pragma Assert (Present (Parm)); 6804 Rewrite (Parm, New_Reference_To (RTE (RE_Delay_Mode), Loc)); 6805 Analyze (Parm); 6806 6807 -- Prepare two new parameters of Duration and Delay_Mode type 6808 -- which represent the value and the mode of the minimum delay. 6809 6810 Next (Parm); 6811 Insert_After (Parm, New_Reference_To (M, Loc)); 6812 Insert_After (Parm, New_Reference_To (D, Loc)); 6813 6814 -- Create a call to RTS. 6815 6816 Rewrite (Select_Call, 6817 Make_Procedure_Call_Statement (Loc, 6818 Name => New_Reference_To (RTE (RE_Timed_Selective_Wait), Loc), 6819 Parameter_Associations => Parms)); 6820 6821 -- This new call should follow the calculation of the 6822 -- minimum delay. 6823 6824 Insert_List_Before (Select_Call, Delay_List); 6825 6826 if Check_Guard then 6827 Stmt := 6828 Make_Implicit_If_Statement (N, 6829 Condition => New_Reference_To (Guard_Open, Loc), 6830 Then_Statements => 6831 New_List (New_Copy_Tree (Stmt), 6832 New_Copy_Tree (Select_Call)), 6833 Else_Statements => Accept_Or_Raise); 6834 Rewrite (Select_Call, Stmt); 6835 else 6836 Insert_Before (Select_Call, Stmt); 6837 end if; 6838 6839 Cases := 6840 Make_Implicit_If_Statement (N, 6841 Condition => Make_Op_Eq (Loc, 6842 Left_Opnd => New_Reference_To (Xnam, Loc), 6843 Right_Opnd => 6844 New_Reference_To (RTE (RE_No_Rendezvous), Loc)), 6845 6846 Then_Statements => Delay_Case, 6847 Else_Statements => Accept_Case); 6848 6849 Append (Cases, Stats); 6850 end; 6851 end if; 6852 6853 -- Replace accept statement with appropriate block 6854 6855 Block := 6856 Make_Block_Statement (Loc, 6857 Declarations => Decls, 6858 Handled_Statement_Sequence => 6859 Make_Handled_Sequence_Of_Statements (Loc, 6860 Statements => Stats)); 6861 6862 Rewrite (N, Block); 6863 Analyze (N); 6864 6865 -- Note: have to worry more about abort deferral in above code ??? 6866 6867 -- Final step is to unstack the Accept_Address entries for all accept 6868 -- statements appearing in accept alternatives in the select statement 6869 6870 Alt := First (Alts); 6871 while Present (Alt) loop 6872 if Nkind (Alt) = N_Accept_Alternative then 6873 Remove_Last_Elmt (Accept_Address 6874 (Entity (Entry_Direct_Name (Accept_Statement (Alt))))); 6875 end if; 6876 6877 Next (Alt); 6878 end loop; 6879 end Expand_N_Selective_Accept; 6880 6881 -------------------------------------- 6882 -- Expand_N_Single_Task_Declaration -- 6883 -------------------------------------- 6884 6885 -- Single task declarations should never be present after semantic 6886 -- analysis, since we expect them to be replaced by a declaration of 6887 -- an anonymous task type, followed by a declaration of the task 6888 -- object. We include this routine to make sure that is happening! 6889 6890 procedure Expand_N_Single_Task_Declaration (N : Node_Id) is 6891 begin 6892 raise Program_Error; 6893 end Expand_N_Single_Task_Declaration; 6894 6895 ------------------------ 6896 -- Expand_N_Task_Body -- 6897 ------------------------ 6898 6899 -- Given a task body 6900 6901 -- task body tname is 6902 -- <declarations> 6903 -- begin 6904 -- <statements> 6905 -- end x; 6906 6907 -- This expansion routine converts it into a procedure and sets the 6908 -- elaboration flag for the procedure to true, to represent the fact 6909 -- that the task body is now elaborated: 6910 6911 -- procedure tnameB (_Task : access tnameV) is 6912 -- discriminal : dtype renames _Task.discriminant; 6913 6914 -- procedure _clean is 6915 -- begin 6916 -- Abort_Defer.all; 6917 -- Complete_Task; 6918 -- Abort_Undefer.all; 6919 -- return; 6920 -- end _clean; 6921 6922 -- begin 6923 -- Abort_Undefer.all; 6924 -- <declarations> 6925 -- System.Task_Stages.Complete_Activation; 6926 -- <statements> 6927 -- at end 6928 -- _clean; 6929 -- end tnameB; 6930 6931 -- tnameE := True; 6932 6933 -- In addition, if the task body is an activator, then a call to 6934 -- activate tasks is added at the start of the statements, before 6935 -- the call to Complete_Activation, and if in addition the task is 6936 -- a master then it must be established as a master. These calls are 6937 -- inserted and analyzed in Expand_Cleanup_Actions, when the 6938 -- Handled_Sequence_Of_Statements is expanded. 6939 6940 -- There is one discriminal declaration line generated for each 6941 -- discriminant that is present to provide an easy reference point 6942 -- for discriminant references inside the body (see Exp_Ch2.Expand_Name). 6943 6944 -- Note on relationship to GNARLI definition. In the GNARLI definition, 6945 -- task body procedures have a profile (Arg : System.Address). That is 6946 -- needed because GNARLI has to use the same access-to-subprogram type 6947 -- for all task types. We depend here on knowing that in GNAT, passing 6948 -- an address argument by value is identical to passing a record value 6949 -- by access (in either case a single pointer is passed), so even though 6950 -- this procedure has the wrong profile. In fact it's all OK, since the 6951 -- callings sequence is identical. 6952 6953 procedure Expand_N_Task_Body (N : Node_Id) is 6954 Loc : constant Source_Ptr := Sloc (N); 6955 Ttyp : constant Entity_Id := Corresponding_Spec (N); 6956 Call : Node_Id; 6957 New_N : Node_Id; 6958 6959 begin 6960 -- Here we start the expansion by generating discriminal declarations 6961 6962 Add_Discriminal_Declarations (Declarations (N), Ttyp, Name_uTask, Loc); 6963 6964 -- Add a call to Abort_Undefer at the very beginning of the task 6965 -- body since this body is called with abort still deferred. 6966 6967 if Abort_Allowed then 6968 Call := Build_Runtime_Call (Loc, RE_Abort_Undefer); 6969 Insert_Before 6970 (First (Statements (Handled_Statement_Sequence (N))), Call); 6971 Analyze (Call); 6972 end if; 6973 6974 -- The statement part has already been protected with an at_end and 6975 -- cleanup actions. The call to Complete_Activation must be placed 6976 -- at the head of the sequence of statements of that block. The 6977 -- declarations have been merged in this sequence of statements but 6978 -- the first real statement is accessible from the First_Real_Statement 6979 -- field (which was set for exactly this purpose). 6980 6981 if Restricted_Profile then 6982 Call := Build_Runtime_Call (Loc, RE_Complete_Restricted_Activation); 6983 else 6984 Call := Build_Runtime_Call (Loc, RE_Complete_Activation); 6985 end if; 6986 6987 Insert_Before 6988 (First_Real_Statement (Handled_Statement_Sequence (N)), Call); 6989 Analyze (Call); 6990 6991 New_N := 6992 Make_Subprogram_Body (Loc, 6993 Specification => Build_Task_Proc_Specification (Ttyp), 6994 Declarations => Declarations (N), 6995 Handled_Statement_Sequence => Handled_Statement_Sequence (N)); 6996 6997 -- If the task contains generic instantiations, cleanup actions 6998 -- are delayed until after instantiation. Transfer the activation 6999 -- chain to the subprogram, to insure that the activation call is 7000 -- properly generated. It the task body contains inner tasks, indicate 7001 -- that the subprogram is a task master. 7002 7003 if Delay_Cleanups (Ttyp) then 7004 Set_Activation_Chain_Entity (New_N, Activation_Chain_Entity (N)); 7005 Set_Is_Task_Master (New_N, Is_Task_Master (N)); 7006 end if; 7007 7008 Rewrite (N, New_N); 7009 Analyze (N); 7010 7011 -- Set elaboration flag immediately after task body. If the body 7012 -- is a subunit, the flag is set in the declarative part that 7013 -- contains the stub. 7014 7015 if Nkind (Parent (N)) /= N_Subunit then 7016 Insert_After (N, 7017 Make_Assignment_Statement (Loc, 7018 Name => 7019 Make_Identifier (Loc, New_External_Name (Chars (Ttyp), 'E')), 7020 Expression => New_Reference_To (Standard_True, Loc))); 7021 end if; 7022 end Expand_N_Task_Body; 7023 7024 ------------------------------------ 7025 -- Expand_N_Task_Type_Declaration -- 7026 ------------------------------------ 7027 7028 -- We have several things to do. First we must create a Boolean flag used 7029 -- to mark if the body is elaborated yet. This variable gets set to True 7030 -- when the body of the task is elaborated (we can't rely on the normal 7031 -- ABE mechanism for the task body, since we need to pass an access to 7032 -- this elaboration boolean to the runtime routines). 7033 7034 -- taskE : aliased Boolean := False; 7035 7036 -- Next a variable is declared to hold the task stack size (either 7037 -- the default : Unspecified_Size, or a value that is set by a pragma 7038 -- Storage_Size). If the value of the pragma Storage_Size is static, then 7039 -- the variable is initialized with this value: 7040 7041 -- taskZ : Size_Type := Unspecified_Size; 7042 -- or 7043 -- taskZ : Size_Type := Size_Type (size_expression); 7044 7045 -- Next we create a corresponding record type declaration used to represent 7046 -- values of this task. The general form of this type declaration is 7047 7048 -- type taskV (discriminants) is record 7049 -- _Task_Id : Task_Id; 7050 -- entry_family : array (bounds) of Void; 7051 -- _Priority : Integer := priority_expression; 7052 -- _Size : Size_Type := Size_Type (size_expression); 7053 -- _Task_Info : Task_Info_Type := task_info_expression; 7054 -- end record; 7055 7056 -- The discriminants are present only if the corresponding task type has 7057 -- discriminants, and they exactly mirror the task type discriminants. 7058 7059 -- The Id field is always present. It contains the Task_Id value, as 7060 -- set by the call to Create_Task. Note that although the task is 7061 -- limited, the task value record type is not limited, so there is no 7062 -- problem in passing this field as an out parameter to Create_Task. 7063 7064 -- One entry_family component is present for each entry family in the 7065 -- task definition. The bounds correspond to the bounds of the entry 7066 -- family (which may depend on discriminants). The element type is 7067 -- void, since we only need the bounds information for determining 7068 -- the entry index. Note that the use of an anonymous array would 7069 -- normally be illegal in this context, but this is a parser check, 7070 -- and the semantics is quite prepared to handle such a case. 7071 7072 -- The _Size field is present only if a Storage_Size pragma appears in 7073 -- the task definition. The expression captures the argument that was 7074 -- present in the pragma, and is used to override the task stack size 7075 -- otherwise associated with the task type. 7076 7077 -- The _Priority field is present only if a Priority or Interrupt_Priority 7078 -- pragma appears in the task definition. The expression captures the 7079 -- argument that was present in the pragma, and is used to provide 7080 -- the Size parameter to the call to Create_Task. 7081 7082 -- The _Task_Info field is present only if a Task_Info pragma appears in 7083 -- the task definition. The expression captures the argument that was 7084 -- present in the pragma, and is used to provide the Task_Image parameter 7085 -- to the call to Create_Task. 7086 7087 -- When a task is declared, an instance of the task value record is 7088 -- created. The elaboration of this declaration creates the correct 7089 -- bounds for the entry families, and also evaluates the size, priority, 7090 -- and task_Info expressions if needed. The initialization routine for 7091 -- the task type itself then calls Create_Task with appropriate 7092 -- parameters to initialize the value of the Task_Id field. 7093 7094 -- Note: the address of this record is passed as the "Discriminants" 7095 -- parameter for Create_Task. Since Create_Task merely passes this onto 7096 -- the body procedure, it does not matter that it does not quite match 7097 -- the GNARLI model of what is being passed (the record contains more 7098 -- than just the discriminants, but the discriminants can be found from 7099 -- the record value). 7100 7101 -- The Entity_Id for this created record type is placed in the 7102 -- Corresponding_Record_Type field of the associated task type entity. 7103 7104 -- Next we create a procedure specification for the task body procedure: 7105 7106 -- procedure taskB (_Task : access taskV); 7107 7108 -- Note that this must come after the record type declaration, since 7109 -- the spec refers to this type. It turns out that the initialization 7110 -- procedure for the value type references the task body spec, but that's 7111 -- fine, since it won't be generated till the freeze point for the type, 7112 -- which is certainly after the task body spec declaration. 7113 7114 -- Finally, we set the task index value field of the entry attribute in 7115 -- the case of a simple entry. 7116 7117 procedure Expand_N_Task_Type_Declaration (N : Node_Id) is 7118 Loc : constant Source_Ptr := Sloc (N); 7119 Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N)); 7120 Tasknm : constant Name_Id := Chars (Tasktyp); 7121 Taskdef : constant Node_Id := Task_Definition (N); 7122 7123 Proc_Spec : Node_Id; 7124 Rec_Decl : Node_Id; 7125 Rec_Ent : Entity_Id; 7126 Cdecls : List_Id; 7127 Elab_Decl : Node_Id; 7128 Size_Decl : Node_Id; 7129 Body_Decl : Node_Id; 7130 7131 begin 7132 -- If already expanded, nothing to do 7133 7134 if Present (Corresponding_Record_Type (Tasktyp)) then 7135 return; 7136 end if; 7137 7138 -- Here we will do the expansion 7139 7140 Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc); 7141 Rec_Ent := Defining_Identifier (Rec_Decl); 7142 Cdecls := Component_Items (Component_List 7143 (Type_Definition (Rec_Decl))); 7144 7145 Qualify_Entity_Names (N); 7146 7147 -- First create the elaboration variable 7148 7149 Elab_Decl := 7150 Make_Object_Declaration (Loc, 7151 Defining_Identifier => 7152 Make_Defining_Identifier (Sloc (Tasktyp), 7153 Chars => New_External_Name (Tasknm, 'E')), 7154 Aliased_Present => True, 7155 Object_Definition => New_Reference_To (Standard_Boolean, Loc), 7156 Expression => New_Reference_To (Standard_False, Loc)); 7157 Insert_After (N, Elab_Decl); 7158 7159 -- Next create the declaration of the size variable (tasknmZ) 7160 7161 Set_Storage_Size_Variable (Tasktyp, 7162 Make_Defining_Identifier (Sloc (Tasktyp), 7163 Chars => New_External_Name (Tasknm, 'Z'))); 7164 7165 if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) and then 7166 Is_Static_Expression (Expression (First ( 7167 Pragma_Argument_Associations (Find_Task_Or_Protected_Pragma ( 7168 Taskdef, Name_Storage_Size))))) 7169 then 7170 Size_Decl := 7171 Make_Object_Declaration (Loc, 7172 Defining_Identifier => Storage_Size_Variable (Tasktyp), 7173 Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc), 7174 Expression => 7175 Convert_To (RTE (RE_Size_Type), 7176 Relocate_Node ( 7177 Expression (First ( 7178 Pragma_Argument_Associations ( 7179 Find_Task_Or_Protected_Pragma 7180 (Taskdef, Name_Storage_Size))))))); 7181 7182 else 7183 Size_Decl := 7184 Make_Object_Declaration (Loc, 7185 Defining_Identifier => Storage_Size_Variable (Tasktyp), 7186 Object_Definition => New_Reference_To (RTE (RE_Size_Type), Loc), 7187 Expression => New_Reference_To (RTE (RE_Unspecified_Size), Loc)); 7188 end if; 7189 7190 Insert_After (Elab_Decl, Size_Decl); 7191 7192 -- Next build the rest of the corresponding record declaration. 7193 -- This is done last, since the corresponding record initialization 7194 -- procedure will reference the previously created entities. 7195 7196 -- Fill in the component declarations. First the _Task_Id field. 7197 7198 Append_To (Cdecls, 7199 Make_Component_Declaration (Loc, 7200 Defining_Identifier => 7201 Make_Defining_Identifier (Loc, Name_uTask_Id), 7202 Component_Definition => 7203 Make_Component_Definition (Loc, 7204 Aliased_Present => False, 7205 Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_ID), 7206 Loc)))); 7207 7208 -- Add components for entry families 7209 7210 Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); 7211 7212 -- Add the _Priority component if a Priority pragma is present 7213 7214 if Present (Taskdef) and then Has_Priority_Pragma (Taskdef) then 7215 declare 7216 Prag : constant Node_Id := 7217 Find_Task_Or_Protected_Pragma (Taskdef, Name_Priority); 7218 Expr : Node_Id; 7219 7220 begin 7221 Expr := First (Pragma_Argument_Associations (Prag)); 7222 7223 if Nkind (Expr) = N_Pragma_Argument_Association then 7224 Expr := Expression (Expr); 7225 end if; 7226 7227 Expr := New_Copy (Expr); 7228 7229 -- Add conversion to proper type to do range check if required 7230 -- Note that for runtime units, we allow out of range interrupt 7231 -- priority values to be used in a priority pragma. This is for 7232 -- the benefit of some versions of System.Interrupts which use 7233 -- a special server task with maximum interrupt priority. 7234 7235 if Chars (Prag) = Name_Priority 7236 and then not GNAT_Mode 7237 then 7238 Rewrite (Expr, Convert_To (RTE (RE_Priority), Expr)); 7239 else 7240 Rewrite (Expr, Convert_To (RTE (RE_Any_Priority), Expr)); 7241 end if; 7242 7243 Append_To (Cdecls, 7244 Make_Component_Declaration (Loc, 7245 Defining_Identifier => 7246 Make_Defining_Identifier (Loc, Name_uPriority), 7247 Component_Definition => 7248 Make_Component_Definition (Loc, 7249 Aliased_Present => False, 7250 Subtype_Indication => New_Reference_To (Standard_Integer, 7251 Loc)), 7252 Expression => Expr)); 7253 end; 7254 end if; 7255 7256 -- Add the _Task_Size component if a Storage_Size pragma is present 7257 7258 if Present (Taskdef) 7259 and then Has_Storage_Size_Pragma (Taskdef) 7260 then 7261 Append_To (Cdecls, 7262 Make_Component_Declaration (Loc, 7263 Defining_Identifier => 7264 Make_Defining_Identifier (Loc, Name_uSize), 7265 7266 Component_Definition => 7267 Make_Component_Definition (Loc, 7268 Aliased_Present => False, 7269 Subtype_Indication => New_Reference_To (RTE (RE_Size_Type), 7270 Loc)), 7271 7272 Expression => 7273 Convert_To (RTE (RE_Size_Type), 7274 Relocate_Node ( 7275 Expression (First ( 7276 Pragma_Argument_Associations ( 7277 Find_Task_Or_Protected_Pragma 7278 (Taskdef, Name_Storage_Size)))))))); 7279 end if; 7280 7281 -- Add the _Task_Info component if a Task_Info pragma is present 7282 7283 if Present (Taskdef) and then Has_Task_Info_Pragma (Taskdef) then 7284 Append_To (Cdecls, 7285 Make_Component_Declaration (Loc, 7286 Defining_Identifier => 7287 Make_Defining_Identifier (Loc, Name_uTask_Info), 7288 7289 Component_Definition => 7290 Make_Component_Definition (Loc, 7291 Aliased_Present => False, 7292 Subtype_Indication => 7293 New_Reference_To (RTE (RE_Task_Info_Type), Loc)), 7294 7295 Expression => New_Copy ( 7296 Expression (First ( 7297 Pragma_Argument_Associations ( 7298 Find_Task_Or_Protected_Pragma 7299 (Taskdef, Name_Task_Info))))))); 7300 end if; 7301 7302 Insert_After (Size_Decl, Rec_Decl); 7303 7304 -- Analyze the record declaration immediately after construction, 7305 -- because the initialization procedure is needed for single task 7306 -- declarations before the next entity is analyzed. 7307 7308 Analyze (Rec_Decl); 7309 7310 -- Create the declaration of the task body procedure 7311 7312 Proc_Spec := Build_Task_Proc_Specification (Tasktyp); 7313 Body_Decl := 7314 Make_Subprogram_Declaration (Loc, 7315 Specification => Proc_Spec); 7316 7317 Insert_After (Rec_Decl, Body_Decl); 7318 7319 -- The subprogram does not comes from source, so we have to indicate 7320 -- the need for debugging information explicitly. 7321 7322 Set_Needs_Debug_Info 7323 (Defining_Entity (Proc_Spec), Comes_From_Source (Original_Node (N))); 7324 7325 -- Now we can freeze the corresponding record. This needs manually 7326 -- freezing, since it is really part of the task type, and the task 7327 -- type is frozen at this stage. We of course need the initialization 7328 -- procedure for this corresponding record type and we won't get it 7329 -- in time if we don't freeze now. 7330 7331 declare 7332 L : constant List_Id := Freeze_Entity (Rec_Ent, Loc); 7333 7334 begin 7335 if Is_Non_Empty_List (L) then 7336 Insert_List_After (Body_Decl, L); 7337 end if; 7338 end; 7339 7340 -- Complete the expansion of access types to the current task 7341 -- type, if any were declared. 7342 7343 Expand_Previous_Access_Type (Tasktyp); 7344 end Expand_N_Task_Type_Declaration; 7345 7346 ------------------------------- 7347 -- Expand_N_Timed_Entry_Call -- 7348 ------------------------------- 7349 7350 -- A timed entry call in normal case is not implemented using ATC 7351 -- mechanism anymore for efficiency reason. 7352 7353 -- select 7354 -- T.E; 7355 -- S1; 7356 -- or 7357 -- Delay D; 7358 -- S2; 7359 -- end select; 7360 7361 -- is expanded as follow: 7362 7363 -- 1) When T.E is a task entry_call; 7364 7365 -- declare 7366 -- B : Boolean; 7367 -- X : Task_Entry_Index := <entry index>; 7368 -- DX : Duration := To_Duration (D); 7369 -- M : Delay_Mode := <discriminant>; 7370 -- P : parms := (parm, parm, parm); 7371 7372 -- begin 7373 -- Timed_Protected_Entry_Call (<acceptor-task>, X, P'Address, 7374 -- DX, M, B); 7375 -- if B then 7376 -- S1; 7377 -- else 7378 -- S2; 7379 -- end if; 7380 -- end; 7381 7382 -- 2) When T.E is a protected entry_call; 7383 7384 -- declare 7385 -- B : Boolean; 7386 -- X : Protected_Entry_Index := <entry index>; 7387 -- DX : Duration := To_Duration (D); 7388 -- M : Delay_Mode := <discriminant>; 7389 -- P : parms := (parm, parm, parm); 7390 7391 -- begin 7392 -- Timed_Protected_Entry_Call (<object>'unchecked_access, X, 7393 -- P'Address, DX, M, B); 7394 -- if B then 7395 -- S1; 7396 -- else 7397 -- S2; 7398 -- end if; 7399 -- end; 7400 7401 procedure Expand_N_Timed_Entry_Call (N : Node_Id) is 7402 Loc : constant Source_Ptr := Sloc (N); 7403 7404 E_Call : Node_Id := 7405 Entry_Call_Statement (Entry_Call_Alternative (N)); 7406 E_Stats : constant List_Id := 7407 Statements (Entry_Call_Alternative (N)); 7408 D_Stat : constant Node_Id := 7409 Delay_Statement (Delay_Alternative (N)); 7410 D_Stats : constant List_Id := 7411 Statements (Delay_Alternative (N)); 7412 7413 Stmts : List_Id; 7414 Stmt : Node_Id; 7415 Parms : List_Id; 7416 Parm : Node_Id; 7417 7418 Concval : Node_Id; 7419 Ename : Node_Id; 7420 Index : Node_Id; 7421 7422 Decls : List_Id; 7423 Disc : Node_Id; 7424 Conv : Node_Id; 7425 B : Entity_Id; 7426 D : Entity_Id; 7427 Dtyp : Entity_Id; 7428 M : Entity_Id; 7429 7430 Call : Node_Id; 7431 Dummy : Node_Id; 7432 7433 begin 7434 -- The arguments in the call may require dynamic allocation, and the 7435 -- call statement may have been transformed into a block. The block 7436 -- may contain additional declarations for internal entities, and the 7437 -- original call is found by sequential search. 7438 7439 if Nkind (E_Call) = N_Block_Statement then 7440 E_Call := First (Statements (Handled_Statement_Sequence (E_Call))); 7441 7442 while Nkind (E_Call) /= N_Procedure_Call_Statement 7443 and then Nkind (E_Call) /= N_Entry_Call_Statement 7444 loop 7445 Next (E_Call); 7446 end loop; 7447 end if; 7448 7449 -- Build an entry call using Simple_Entry_Call. We will use this as the 7450 -- base for creating appropriate calls. 7451 7452 Extract_Entry (E_Call, Concval, Ename, Index); 7453 Build_Simple_Entry_Call (E_Call, Concval, Ename, Index); 7454 7455 Stmts := Statements (Handled_Statement_Sequence (E_Call)); 7456 Decls := Declarations (E_Call); 7457 7458 if No (Decls) then 7459 Decls := New_List; 7460 end if; 7461 7462 Dtyp := Base_Type (Etype (Expression (D_Stat))); 7463 7464 -- Use the type of the delay expression (Calendar or Real_Time) 7465 -- to generate the appropriate conversion. 7466 7467 if Nkind (D_Stat) = N_Delay_Relative_Statement then 7468 Disc := Make_Integer_Literal (Loc, 0); 7469 Conv := Relocate_Node (Expression (D_Stat)); 7470 7471 elsif Is_RTE (Dtyp, RO_CA_Time) then 7472 Disc := Make_Integer_Literal (Loc, 1); 7473 Conv := Make_Function_Call (Loc, 7474 New_Reference_To (RTE (RO_CA_To_Duration), Loc), 7475 New_List (New_Copy (Expression (D_Stat)))); 7476 7477 else pragma Assert (Is_RTE (Dtyp, RO_RT_Time)); 7478 Disc := Make_Integer_Literal (Loc, 2); 7479 Conv := Make_Function_Call (Loc, 7480 New_Reference_To (RTE (RO_RT_To_Duration), Loc), 7481 New_List (New_Copy (Expression (D_Stat)))); 7482 end if; 7483 7484 -- Create Duration and Delay_Mode objects for passing a delay value 7485 7486 D := Make_Defining_Identifier (Loc, New_Internal_Name ('D')); 7487 M := Make_Defining_Identifier (Loc, New_Internal_Name ('M')); 7488 7489 Append_To (Decls, 7490 Make_Object_Declaration (Loc, 7491 Defining_Identifier => D, 7492 Object_Definition => New_Reference_To (Standard_Duration, Loc))); 7493 7494 Append_To (Decls, 7495 Make_Object_Declaration (Loc, 7496 Defining_Identifier => M, 7497 Object_Definition => New_Reference_To (Standard_Integer, Loc), 7498 Expression => Disc)); 7499 7500 B := Make_Defining_Identifier (Loc, Name_uB); 7501 7502 -- Create a boolean object used for a return parameter. 7503 7504 Prepend_To (Decls, 7505 Make_Object_Declaration (Loc, 7506 Defining_Identifier => B, 7507 Object_Definition => New_Reference_To (Standard_Boolean, Loc))); 7508 7509 Stmt := First (Stmts); 7510 7511 -- Skip assignments to temporaries created for in-out parameters. 7512 -- This makes unwarranted assumptions about the shape of the expanded 7513 -- tree for the call, and should be cleaned up ??? 7514 7515 while Nkind (Stmt) /= N_Procedure_Call_Statement loop 7516 Next (Stmt); 7517 end loop; 7518 7519 -- Do the assignement at this stage only because the evaluation of the 7520 -- expression must not occur before (see ACVC C97302A). 7521 7522 Insert_Before (Stmt, 7523 Make_Assignment_Statement (Loc, 7524 Name => New_Reference_To (D, Loc), 7525 Expression => Conv)); 7526 7527 Call := Stmt; 7528 7529 Parms := Parameter_Associations (Call); 7530 7531 -- For a protected type, we build a Timed_Protected_Entry_Call 7532 7533 if Is_Protected_Type (Etype (Concval)) then 7534 7535 -- Create a new call statement 7536 7537 Parm := First (Parms); 7538 7539 while Present (Parm) 7540 and then not Is_RTE (Etype (Parm), RE_Call_Modes) 7541 loop 7542 Next (Parm); 7543 end loop; 7544 7545 Dummy := Remove_Next (Next (Parm)); 7546 7547 -- In case some garbage is following the Cancel_Param, remove. 7548 7549 Dummy := Next (Parm); 7550 7551 -- Remove the mode of the Protected_Entry_Call call, the 7552 -- Communication_Block of the Protected_Entry_Call call, and add a 7553 -- Duration and a Delay_Mode parameter 7554 7555 pragma Assert (Present (Parm)); 7556 Rewrite (Parm, New_Reference_To (D, Loc)); 7557 7558 Rewrite (Dummy, New_Reference_To (M, Loc)); 7559 7560 -- Add a Boolean flag for successful entry call. 7561 7562 Append_To (Parms, New_Reference_To (B, Loc)); 7563 7564 if Abort_Allowed 7565 or else Restrictions (No_Entry_Queue) = False 7566 or else Number_Entries (Etype (Concval)) > 1 7567 then 7568 Rewrite (Call, 7569 Make_Procedure_Call_Statement (Loc, 7570 Name => 7571 New_Reference_To (RTE (RE_Timed_Protected_Entry_Call), Loc), 7572 Parameter_Associations => Parms)); 7573 7574 else 7575 Parm := First (Parms); 7576 7577 while Present (Parm) 7578 and then not Is_RTE (Etype (Parm), RE_Protected_Entry_Index) 7579 loop 7580 Next (Parm); 7581 end loop; 7582 7583 Remove (Parm); 7584 7585 Rewrite (Call, 7586 Make_Procedure_Call_Statement (Loc, 7587 Name => New_Reference_To ( 7588 RTE (RE_Timed_Protected_Single_Entry_Call), Loc), 7589 Parameter_Associations => Parms)); 7590 end if; 7591 7592 -- For the task case, build a Timed_Task_Entry_Call 7593 7594 else 7595 -- Create a new call statement 7596 7597 Append_To (Parms, New_Reference_To (D, Loc)); 7598 Append_To (Parms, New_Reference_To (M, Loc)); 7599 Append_To (Parms, New_Reference_To (B, Loc)); 7600 7601 Rewrite (Call, 7602 Make_Procedure_Call_Statement (Loc, 7603 Name => New_Reference_To (RTE (RE_Timed_Task_Entry_Call), Loc), 7604 Parameter_Associations => Parms)); 7605 7606 end if; 7607 7608 Append_To (Stmts, 7609 Make_Implicit_If_Statement (N, 7610 Condition => New_Reference_To (B, Loc), 7611 Then_Statements => E_Stats, 7612 Else_Statements => D_Stats)); 7613 7614 Rewrite (N, 7615 Make_Block_Statement (Loc, 7616 Declarations => Decls, 7617 Handled_Statement_Sequence => 7618 Make_Handled_Sequence_Of_Statements (Loc, Stmts))); 7619 7620 Analyze (N); 7621 end Expand_N_Timed_Entry_Call; 7622 7623 ---------------------------------------- 7624 -- Expand_Protected_Body_Declarations -- 7625 ---------------------------------------- 7626 7627 -- Part of the expansion of a protected body involves the creation of 7628 -- a declaration that can be referenced from the statement sequences of 7629 -- the entry bodies: 7630 7631 -- A : Address; 7632 7633 -- This declaration is inserted in the declarations of the service 7634 -- entries procedure for the protected body, and it is important that 7635 -- it be inserted before the statements of the entry body statement 7636 -- sequences are analyzed. Thus it would be too late to create this 7637 -- declaration in the Expand_N_Protected_Body routine, which is why 7638 -- there is a separate procedure to be called directly from Sem_Ch9. 7639 7640 -- Ann is used to hold the address of the record containing the parameters 7641 -- (see Expand_N_Entry_Call for more details on how this record is built). 7642 -- References to the parameters do an unchecked conversion of this address 7643 -- to a pointer to the required record type, and then access the field that 7644 -- holds the value of the required parameter. The entity for the address 7645 -- variable is held as the top stack element (i.e. the last element) of the 7646 -- Accept_Address stack in the corresponding entry entity, and this element 7647 -- must be set in place before the statements are processed. 7648 7649 -- No stack is needed for entry bodies, since they cannot be nested, but 7650 -- it is kept for consistency between protected and task entries. The 7651 -- stack will never contain more than one element. There is also only one 7652 -- such variable for a given protected body, but this is placed on the 7653 -- Accept_Address stack of all of the entries, again for consistency. 7654 7655 -- To expand the requeue statement, a label is provided at the end of 7656 -- the loop in the entry service routine created by the expander (see 7657 -- Expand_N_Protected_Body for details), so that the statement can be 7658 -- skipped after the requeue is complete. This label is created during the 7659 -- expansion of the entry body, which will take place after the expansion 7660 -- of the requeue statements that it contains, so a placeholder defining 7661 -- identifier is associated with the task type here. 7662 7663 -- Another label is provided following case statement created by the 7664 -- expander. This label is need for implementing return statement from 7665 -- entry body so that a return can be expanded as a goto to this label. 7666 -- This label is created during the expansion of the entry body, which 7667 -- will take place after the expansion of the return statements that it 7668 -- contains. Therefore, just like the label for expanding requeues, we 7669 -- need another placeholder for the label. 7670 7671 procedure Expand_Protected_Body_Declarations 7672 (N : Node_Id; 7673 Spec_Id : Entity_Id) 7674 is 7675 Op : Node_Id; 7676 7677 begin 7678 if No_Run_Time_Mode then 7679 Error_Msg_CRT ("protected body", N); 7680 return; 7681 7682 elsif Expander_Active then 7683 7684 -- Associate privals with the first subprogram or entry 7685 -- body to be expanded. These are used to expand references 7686 -- to private data objects. 7687 7688 Op := First_Protected_Operation (Declarations (N)); 7689 7690 if Present (Op) then 7691 Set_Discriminals (Parent (Spec_Id)); 7692 Set_Privals (Parent (Spec_Id), Op, Sloc (N)); 7693 end if; 7694 end if; 7695 end Expand_Protected_Body_Declarations; 7696 7697 ------------------------- 7698 -- External_Subprogram -- 7699 ------------------------- 7700 7701 function External_Subprogram (E : Entity_Id) return Entity_Id is 7702 Subp : constant Entity_Id := Protected_Body_Subprogram (E); 7703 Decl : constant Node_Id := Unit_Declaration_Node (E); 7704 7705 begin 7706 -- If the protected operation is defined in the visible part of the 7707 -- protected type, or if it is an interrupt handler, the internal and 7708 -- external subprograms follow each other on the entity chain. If the 7709 -- operation is defined in the private part of the type, there is no 7710 -- need for a separate locking version of the operation, and internal 7711 -- calls use the protected_body_subprogram directly. 7712 7713 if List_Containing (Decl) = Visible_Declarations (Parent (Decl)) 7714 or else Is_Interrupt_Handler (E) 7715 then 7716 return Next_Entity (Subp); 7717 else 7718 return (Subp); 7719 end if; 7720 end External_Subprogram; 7721 7722 ------------------- 7723 -- Extract_Entry -- 7724 ------------------- 7725 7726 procedure Extract_Entry 7727 (N : Node_Id; 7728 Concval : out Node_Id; 7729 Ename : out Node_Id; 7730 Index : out Node_Id) 7731 is 7732 Nam : constant Node_Id := Name (N); 7733 7734 begin 7735 -- For a simple entry, the name is a selected component, with the 7736 -- prefix being the task value, and the selector being the entry. 7737 7738 if Nkind (Nam) = N_Selected_Component then 7739 Concval := Prefix (Nam); 7740 Ename := Selector_Name (Nam); 7741 Index := Empty; 7742 7743 -- For a member of an entry family, the name is an indexed 7744 -- component where the prefix is a selected component, 7745 -- whose prefix in turn is the task value, and whose 7746 -- selector is the entry family. The single expression in 7747 -- the expressions list of the indexed component is the 7748 -- subscript for the family. 7749 7750 else 7751 pragma Assert (Nkind (Nam) = N_Indexed_Component); 7752 Concval := Prefix (Prefix (Nam)); 7753 Ename := Selector_Name (Prefix (Nam)); 7754 Index := First (Expressions (Nam)); 7755 end if; 7756 end Extract_Entry; 7757 7758 ------------------- 7759 -- Family_Offset -- 7760 ------------------- 7761 7762 function Family_Offset 7763 (Loc : Source_Ptr; 7764 Hi : Node_Id; 7765 Lo : Node_Id; 7766 Ttyp : Entity_Id) return Node_Id 7767 is 7768 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id; 7769 -- If one of the bounds is a reference to a discriminant, replace 7770 -- with corresponding discriminal of type. Within the body of a task 7771 -- retrieve the renamed discriminant by simple visibility, using its 7772 -- generated name. Within a protected object, find the original dis- 7773 -- criminant and replace it with the discriminal of the current prot- 7774 -- ected operation. 7775 7776 ------------------------------ 7777 -- Convert_Discriminant_Ref -- 7778 ------------------------------ 7779 7780 function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is 7781 Loc : constant Source_Ptr := Sloc (Bound); 7782 B : Node_Id; 7783 D : Entity_Id; 7784 7785 begin 7786 if Is_Entity_Name (Bound) 7787 and then Ekind (Entity (Bound)) = E_Discriminant 7788 then 7789 if Is_Task_Type (Ttyp) 7790 and then Has_Completion (Ttyp) 7791 then 7792 B := Make_Identifier (Loc, Chars (Entity (Bound))); 7793 Find_Direct_Name (B); 7794 7795 elsif Is_Protected_Type (Ttyp) then 7796 D := First_Discriminant (Ttyp); 7797 7798 while Chars (D) /= Chars (Entity (Bound)) loop 7799 Next_Discriminant (D); 7800 end loop; 7801 7802 B := New_Reference_To (Discriminal (D), Loc); 7803 7804 else 7805 B := New_Reference_To (Discriminal (Entity (Bound)), Loc); 7806 end if; 7807 7808 elsif Nkind (Bound) = N_Attribute_Reference then 7809 return Bound; 7810 7811 else 7812 B := New_Copy_Tree (Bound); 7813 end if; 7814 7815 return 7816 Make_Attribute_Reference (Loc, 7817 Attribute_Name => Name_Pos, 7818 Prefix => New_Occurrence_Of (Etype (Bound), Loc), 7819 Expressions => New_List (B)); 7820 end Convert_Discriminant_Ref; 7821 7822 -- Start of processing for Family_Offset 7823 7824 begin 7825 return 7826 Make_Op_Subtract (Loc, 7827 Left_Opnd => Convert_Discriminant_Ref (Hi), 7828 Right_Opnd => Convert_Discriminant_Ref (Lo)); 7829 end Family_Offset; 7830 7831 ----------------- 7832 -- Family_Size -- 7833 ----------------- 7834 7835 function Family_Size 7836 (Loc : Source_Ptr; 7837 Hi : Node_Id; 7838 Lo : Node_Id; 7839 Ttyp : Entity_Id) return Node_Id 7840 is 7841 Ityp : Entity_Id; 7842 7843 begin 7844 if Is_Task_Type (Ttyp) then 7845 Ityp := RTE (RE_Task_Entry_Index); 7846 else 7847 Ityp := RTE (RE_Protected_Entry_Index); 7848 end if; 7849 7850 return 7851 Make_Attribute_Reference (Loc, 7852 Prefix => New_Reference_To (Ityp, Loc), 7853 Attribute_Name => Name_Max, 7854 Expressions => New_List ( 7855 Make_Op_Add (Loc, 7856 Left_Opnd => 7857 Family_Offset (Loc, Hi, Lo, Ttyp), 7858 Right_Opnd => 7859 Make_Integer_Literal (Loc, 1)), 7860 Make_Integer_Literal (Loc, 0))); 7861 end Family_Size; 7862 7863 ----------------------------------- 7864 -- Find_Task_Or_Protected_Pragma -- 7865 ----------------------------------- 7866 7867 function Find_Task_Or_Protected_Pragma 7868 (T : Node_Id; 7869 P : Name_Id) return Node_Id 7870 is 7871 N : Node_Id; 7872 7873 begin 7874 N := First (Visible_Declarations (T)); 7875 7876 while Present (N) loop 7877 if Nkind (N) = N_Pragma then 7878 if Chars (N) = P then 7879 return N; 7880 7881 elsif P = Name_Priority 7882 and then Chars (N) = Name_Interrupt_Priority 7883 then 7884 return N; 7885 7886 else 7887 Next (N); 7888 end if; 7889 7890 else 7891 Next (N); 7892 end if; 7893 end loop; 7894 7895 N := First (Private_Declarations (T)); 7896 7897 while Present (N) loop 7898 if Nkind (N) = N_Pragma then 7899 if Chars (N) = P then 7900 return N; 7901 7902 elsif P = Name_Priority 7903 and then Chars (N) = Name_Interrupt_Priority 7904 then 7905 return N; 7906 7907 else 7908 Next (N); 7909 end if; 7910 7911 else 7912 Next (N); 7913 end if; 7914 end loop; 7915 7916 raise Program_Error; 7917 end Find_Task_Or_Protected_Pragma; 7918 7919 ------------------------------- 7920 -- First_Protected_Operation -- 7921 ------------------------------- 7922 7923 function First_Protected_Operation (D : List_Id) return Node_Id is 7924 First_Op : Node_Id; 7925 7926 begin 7927 First_Op := First (D); 7928 while Present (First_Op) 7929 and then Nkind (First_Op) /= N_Subprogram_Body 7930 and then Nkind (First_Op) /= N_Entry_Body 7931 loop 7932 Next (First_Op); 7933 end loop; 7934 7935 return First_Op; 7936 end First_Protected_Operation; 7937 7938 -------------------------------- 7939 -- Index_Constant_Declaration -- 7940 -------------------------------- 7941 7942 function Index_Constant_Declaration 7943 (N : Node_Id; 7944 Index_Id : Entity_Id; 7945 Prot : Entity_Id) return List_Id 7946 is 7947 Loc : constant Source_Ptr := Sloc (N); 7948 Decls : constant List_Id := New_List; 7949 Index_Con : constant Entity_Id := Entry_Index_Constant (Index_Id); 7950 Index_Typ : Entity_Id; 7951 7952 Hi : Node_Id := Type_High_Bound (Etype (Index_Id)); 7953 Lo : Node_Id := Type_Low_Bound (Etype (Index_Id)); 7954 7955 function Replace_Discriminant (Bound : Node_Id) return Node_Id; 7956 -- The bounds of the entry index may depend on discriminants, so 7957 -- each declaration of an entry_index_constant must have its own 7958 -- subtype declaration, using the local renaming of the object discri- 7959 -- minant. 7960 7961 -------------------------- 7962 -- Replace_Discriminant -- 7963 -------------------------- 7964 7965 function Replace_Discriminant (Bound : Node_Id) return Node_Id is 7966 begin 7967 if Nkind (Bound) = N_Identifier 7968 and then Ekind (Entity (Bound)) = E_Constant 7969 and then Present (Discriminal_Link (Entity (Bound))) 7970 then 7971 return Make_Identifier (Loc, Chars (Entity (Bound))); 7972 else 7973 return Duplicate_Subexpr (Bound); 7974 end if; 7975 end Replace_Discriminant; 7976 7977 -- Start of processing for Index_Constant_Declaration 7978 7979 begin 7980 Set_Discriminal_Link (Index_Con, Index_Id); 7981 7982 if Is_Entity_Name ( 7983 Original_Node (Discrete_Subtype_Definition (Parent (Index_Id)))) 7984 then 7985 -- Simple case: entry family is given by a subtype mark, and index 7986 -- constant has the same type, no replacement needed. 7987 7988 Index_Typ := Etype (Index_Id); 7989 7990 else 7991 Hi := Replace_Discriminant (Hi); 7992 Lo := Replace_Discriminant (Lo); 7993 7994 Index_Typ := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); 7995 7996 Append ( 7997 Make_Subtype_Declaration (Loc, 7998 Defining_Identifier => Index_Typ, 7999 Subtype_Indication => 8000 Make_Subtype_Indication (Loc, 8001 Subtype_Mark => 8002 New_Occurrence_Of (Base_Type (Etype (Index_Id)), Loc), 8003 Constraint => 8004 Make_Range_Constraint (Loc, 8005 Range_Expression => Make_Range (Loc, Lo, Hi)))), 8006 Decls); 8007 8008 end if; 8009 8010 Append ( 8011 Make_Object_Declaration (Loc, 8012 Defining_Identifier => Index_Con, 8013 Constant_Present => True, 8014 Object_Definition => New_Occurrence_Of (Index_Typ, Loc), 8015 8016 Expression => 8017 Make_Attribute_Reference (Loc, 8018 Prefix => New_Reference_To (Index_Typ, Loc), 8019 Attribute_Name => Name_Val, 8020 8021 Expressions => New_List ( 8022 8023 Make_Op_Add (Loc, 8024 Left_Opnd => 8025 Make_Op_Subtract (Loc, 8026 Left_Opnd => Make_Identifier (Loc, Name_uE), 8027 Right_Opnd => 8028 Entry_Index_Expression (Loc, 8029 Defining_Identifier (N), Empty, Prot)), 8030 8031 Right_Opnd => 8032 Make_Attribute_Reference (Loc, 8033 Prefix => New_Reference_To (Index_Typ, Loc), 8034 Attribute_Name => Name_Pos, 8035 Expressions => New_List ( 8036 Make_Attribute_Reference (Loc, 8037 Prefix => New_Reference_To (Index_Typ, Loc), 8038 Attribute_Name => Name_First))))))), 8039 Decls); 8040 8041 return Decls; 8042 end Index_Constant_Declaration; 8043 8044 -------------------------------- 8045 -- Make_Initialize_Protection -- 8046 -------------------------------- 8047 8048 function Make_Initialize_Protection 8049 (Protect_Rec : Entity_Id) return List_Id 8050 is 8051 Loc : constant Source_Ptr := Sloc (Protect_Rec); 8052 P_Arr : Entity_Id; 8053 Pdef : Node_Id; 8054 Pdec : Node_Id; 8055 Ptyp : constant Node_Id := 8056 Corresponding_Concurrent_Type (Protect_Rec); 8057 Args : List_Id; 8058 L : constant List_Id := New_List; 8059 Has_Entry : constant Boolean := Has_Entries (Ptyp); 8060 Restricted : constant Boolean := Restricted_Profile; 8061 8062 begin 8063 -- We may need two calls to properly initialize the object, one 8064 -- to Initialize_Protection, and possibly one to Install_Handlers 8065 -- if we have a pragma Attach_Handler. 8066 8067 -- Get protected declaration. In the case of a task type declaration, 8068 -- this is simply the parent of the protected type entity. 8069 -- In the single protected object 8070 -- declaration, this parent will be the implicit type, and we can find 8071 -- the corresponding single protected object declaration by 8072 -- searching forward in the declaration list in the tree. 8073 -- ??? I am not sure that the test for N_Single_Protected_Declaration 8074 -- is needed here. Nodes of this type should have been removed 8075 -- during semantic analysis. 8076 8077 Pdec := Parent (Ptyp); 8078 8079 while Nkind (Pdec) /= N_Protected_Type_Declaration 8080 and then Nkind (Pdec) /= N_Single_Protected_Declaration 8081 loop 8082 Next (Pdec); 8083 end loop; 8084 8085 -- Now we can find the object definition from this declaration 8086 8087 Pdef := Protected_Definition (Pdec); 8088 8089 -- Build the parameter list for the call. Note that _Init is the name 8090 -- of the formal for the object to be initialized, which is the task 8091 -- value record itself. 8092 8093 Args := New_List; 8094 8095 -- Object parameter. This is a pointer to the object of type 8096 -- Protection used by the GNARL to control the protected object. 8097 8098 Append_To (Args, 8099 Make_Attribute_Reference (Loc, 8100 Prefix => 8101 Make_Selected_Component (Loc, 8102 Prefix => Make_Identifier (Loc, Name_uInit), 8103 Selector_Name => Make_Identifier (Loc, Name_uObject)), 8104 Attribute_Name => Name_Unchecked_Access)); 8105 8106 -- Priority parameter. Set to Unspecified_Priority unless there is a 8107 -- priority pragma, in which case we take the value from the pragma, 8108 -- or there is an interrupt pragma and no priority pragma, and we 8109 -- set the ceiling to Interrupt_Priority'Last, an implementation- 8110 -- defined value, see D.3(10). 8111 8112 if Present (Pdef) 8113 and then Has_Priority_Pragma (Pdef) 8114 then 8115 Append_To (Args, 8116 Duplicate_Subexpr_No_Checks 8117 (Expression 8118 (First 8119 (Pragma_Argument_Associations 8120 (Find_Task_Or_Protected_Pragma (Pdef, Name_Priority)))))); 8121 8122 elsif Has_Interrupt_Handler (Ptyp) 8123 or else Has_Attach_Handler (Ptyp) 8124 then 8125 -- When no priority is specified but an xx_Handler pragma is, 8126 -- we default to System.Interrupts.Default_Interrupt_Priority, 8127 -- see D.3(10). 8128 8129 Append_To (Args, 8130 New_Reference_To (RTE (RE_Default_Interrupt_Priority), Loc)); 8131 8132 else 8133 Append_To (Args, 8134 New_Reference_To (RTE (RE_Unspecified_Priority), Loc)); 8135 end if; 8136 8137 if Has_Entry 8138 or else Has_Interrupt_Handler (Ptyp) 8139 or else Has_Attach_Handler (Ptyp) 8140 then 8141 -- Compiler_Info parameter. This parameter allows entry body 8142 -- procedures and barrier functions to be called from the runtime. 8143 -- It is a pointer to the record generated by the compiler to 8144 -- represent the protected object. 8145 8146 if Has_Entry or else not Restricted then 8147 Append_To (Args, 8148 Make_Attribute_Reference (Loc, 8149 Prefix => Make_Identifier (Loc, Name_uInit), 8150 Attribute_Name => Name_Address)); 8151 end if; 8152 8153 if Has_Entry then 8154 -- Entry_Bodies parameter. This is a pointer to an array of 8155 -- pointers to the entry body procedures and barrier functions 8156 -- of the object. If the protected type has no entries this 8157 -- object will not exist; in this case, pass a null. 8158 8159 P_Arr := Entry_Bodies_Array (Ptyp); 8160 8161 Append_To (Args, 8162 Make_Attribute_Reference (Loc, 8163 Prefix => New_Reference_To (P_Arr, Loc), 8164 Attribute_Name => Name_Unrestricted_Access)); 8165 8166 if Abort_Allowed 8167 or else Restrictions (No_Entry_Queue) = False 8168 or else Number_Entries (Ptyp) > 1 8169 then 8170 -- Find index mapping function (clumsy but ok for now). 8171 8172 while Ekind (P_Arr) /= E_Function loop 8173 Next_Entity (P_Arr); 8174 end loop; 8175 8176 Append_To (Args, 8177 Make_Attribute_Reference (Loc, 8178 Prefix => 8179 New_Reference_To (P_Arr, Loc), 8180 Attribute_Name => Name_Unrestricted_Access)); 8181 end if; 8182 8183 elsif not Restricted then 8184 Append_To (Args, Make_Null (Loc)); 8185 Append_To (Args, Make_Null (Loc)); 8186 end if; 8187 8188 if Abort_Allowed 8189 or else Restrictions (No_Entry_Queue) = False 8190 or else Number_Entries (Ptyp) > 1 8191 then 8192 Append_To (L, 8193 Make_Procedure_Call_Statement (Loc, 8194 Name => New_Reference_To ( 8195 RTE (RE_Initialize_Protection_Entries), Loc), 8196 Parameter_Associations => Args)); 8197 8198 elsif not Has_Entry and then Restricted then 8199 Append_To (L, 8200 Make_Procedure_Call_Statement (Loc, 8201 Name => New_Reference_To ( 8202 RTE (RE_Initialize_Protection), Loc), 8203 Parameter_Associations => Args)); 8204 8205 else 8206 Append_To (L, 8207 Make_Procedure_Call_Statement (Loc, 8208 Name => New_Reference_To ( 8209 RTE (RE_Initialize_Protection_Entry), Loc), 8210 Parameter_Associations => Args)); 8211 end if; 8212 8213 else 8214 Append_To (L, 8215 Make_Procedure_Call_Statement (Loc, 8216 Name => New_Reference_To (RTE (RE_Initialize_Protection), Loc), 8217 Parameter_Associations => Args)); 8218 end if; 8219 8220 if Has_Attach_Handler (Ptyp) then 8221 8222 -- We have a list of N Attach_Handler (ProcI, ExprI), 8223 -- and we have to make the following call: 8224 -- Install_Handlers (_object, 8225 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); 8226 -- or, in the case of Ravenscar: 8227 -- Install_Handlers 8228 -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)); 8229 8230 declare 8231 Args : constant List_Id := New_List; 8232 Table : constant List_Id := New_List; 8233 Ritem : Node_Id := First_Rep_Item (Ptyp); 8234 8235 begin 8236 if not Restricted then 8237 -- Appends the _object argument 8238 8239 Append_To (Args, 8240 Make_Attribute_Reference (Loc, 8241 Prefix => 8242 Make_Selected_Component (Loc, 8243 Prefix => Make_Identifier (Loc, Name_uInit), 8244 Selector_Name => Make_Identifier (Loc, Name_uObject)), 8245 Attribute_Name => Name_Unchecked_Access)); 8246 end if; 8247 8248 -- Build the Attach_Handler table argument 8249 8250 while Present (Ritem) loop 8251 if Nkind (Ritem) = N_Pragma 8252 and then Chars (Ritem) = Name_Attach_Handler 8253 then 8254 declare 8255 Handler : constant Node_Id := 8256 First (Pragma_Argument_Associations (Ritem)); 8257 8258 Interrupt : constant Node_Id := Next (Handler); 8259 Expr : constant Node_Id := Expression (Interrupt); 8260 8261 begin 8262 Append_To (Table, 8263 Make_Aggregate (Loc, Expressions => New_List ( 8264 Unchecked_Convert_To 8265 (RTE (RE_System_Interrupt_Id), Expr), 8266 Make_Attribute_Reference (Loc, 8267 Prefix => Make_Selected_Component (Loc, 8268 Make_Identifier (Loc, Name_uInit), 8269 Duplicate_Subexpr_No_Checks 8270 (Expression (Handler))), 8271 Attribute_Name => Name_Access)))); 8272 end; 8273 end if; 8274 8275 Next_Rep_Item (Ritem); 8276 end loop; 8277 8278 -- Appends the table argument we just built. 8279 Append_To (Args, Make_Aggregate (Loc, Table)); 8280 8281 -- Appends the Install_Handler call to the statements. 8282 Append_To (L, 8283 Make_Procedure_Call_Statement (Loc, 8284 Name => New_Reference_To (RTE (RE_Install_Handlers), Loc), 8285 Parameter_Associations => Args)); 8286 end; 8287 end if; 8288 8289 return L; 8290 end Make_Initialize_Protection; 8291 8292 --------------------------- 8293 -- Make_Task_Create_Call -- 8294 --------------------------- 8295 8296 function Make_Task_Create_Call (Task_Rec : Entity_Id) return Node_Id is 8297 Loc : constant Source_Ptr := Sloc (Task_Rec); 8298 Name : Node_Id; 8299 Tdef : Node_Id; 8300 Tdec : Node_Id; 8301 Ttyp : Node_Id; 8302 Tnam : Name_Id; 8303 Args : List_Id; 8304 Ecount : Node_Id; 8305 8306 begin 8307 Ttyp := Corresponding_Concurrent_Type (Task_Rec); 8308 Tnam := Chars (Ttyp); 8309 8310 -- Get task declaration. In the case of a task type declaration, this 8311 -- is simply the parent of the task type entity. In the single task 8312 -- declaration, this parent will be the implicit type, and we can find 8313 -- the corresponding single task declaration by searching forward in 8314 -- the declaration list in the tree. 8315 -- ??? I am not sure that the test for N_Single_Task_Declaration 8316 -- is needed here. Nodes of this type should have been removed 8317 -- during semantic analysis. 8318 8319 Tdec := Parent (Ttyp); 8320 8321 while Nkind (Tdec) /= N_Task_Type_Declaration 8322 and then Nkind (Tdec) /= N_Single_Task_Declaration 8323 loop 8324 Next (Tdec); 8325 end loop; 8326 8327 -- Now we can find the task definition from this declaration 8328 8329 Tdef := Task_Definition (Tdec); 8330 8331 -- Build the parameter list for the call. Note that _Init is the name 8332 -- of the formal for the object to be initialized, which is the task 8333 -- value record itself. 8334 8335 Args := New_List; 8336 8337 -- Priority parameter. Set to Unspecified_Priority unless there is a 8338 -- priority pragma, in which case we take the value from the pragma. 8339 8340 if Present (Tdef) 8341 and then Has_Priority_Pragma (Tdef) 8342 then 8343 Append_To (Args, 8344 Make_Selected_Component (Loc, 8345 Prefix => Make_Identifier (Loc, Name_uInit), 8346 Selector_Name => Make_Identifier (Loc, Name_uPriority))); 8347 8348 else 8349 Append_To (Args, 8350 New_Reference_To (RTE (RE_Unspecified_Priority), Loc)); 8351 end if; 8352 8353 -- Size parameter. If no Storage_Size pragma is present, then 8354 -- the size is taken from the taskZ variable for the type, which 8355 -- is either Unspecified_Size, or has been reset by the use of 8356 -- a Storage_Size attribute definition clause. If a pragma is 8357 -- present, then the size is taken from the _Size field of the 8358 -- task value record, which was set from the pragma value. 8359 8360 if Present (Tdef) 8361 and then Has_Storage_Size_Pragma (Tdef) 8362 then 8363 Append_To (Args, 8364 Make_Selected_Component (Loc, 8365 Prefix => Make_Identifier (Loc, Name_uInit), 8366 Selector_Name => Make_Identifier (Loc, Name_uSize))); 8367 8368 else 8369 Append_To (Args, 8370 New_Reference_To (Storage_Size_Variable (Ttyp), Loc)); 8371 end if; 8372 8373 -- Task_Info parameter. Set to Unspecified_Task_Info unless there is a 8374 -- Task_Info pragma, in which case we take the value from the pragma. 8375 8376 if Present (Tdef) 8377 and then Has_Task_Info_Pragma (Tdef) 8378 then 8379 Append_To (Args, 8380 Make_Selected_Component (Loc, 8381 Prefix => Make_Identifier (Loc, Name_uInit), 8382 Selector_Name => Make_Identifier (Loc, Name_uTask_Info))); 8383 8384 else 8385 Append_To (Args, 8386 New_Reference_To (RTE (RE_Unspecified_Task_Info), Loc)); 8387 end if; 8388 8389 if not Restricted_Profile then 8390 8391 -- Number of entries. This is an expression of the form: 8392 -- 8393 -- n + _Init.a'Length + _Init.a'B'Length + ... 8394 -- 8395 -- where a,b... are the entry family names for the task definition 8396 8397 Ecount := Build_Entry_Count_Expression ( 8398 Ttyp, 8399 Component_Items (Component_List ( 8400 Type_Definition (Parent ( 8401 Corresponding_Record_Type (Ttyp))))), 8402 Loc); 8403 Append_To (Args, Ecount); 8404 8405 -- Master parameter. This is a reference to the _Master parameter of 8406 -- the initialization procedure, except in the case of the pragma 8407 -- Restrictions (No_Task_Hierarchy) where the value is fixed to 3. 8408 -- See comments in System.Tasking.Initialization.Init_RTS for the 8409 -- value 3. 8410 8411 if Restrictions (No_Task_Hierarchy) = False then 8412 Append_To (Args, Make_Identifier (Loc, Name_uMaster)); 8413 else 8414 Append_To (Args, Make_Integer_Literal (Loc, 3)); 8415 end if; 8416 end if; 8417 8418 -- State parameter. This is a pointer to the task body procedure. The 8419 -- required value is obtained by taking the address of the task body 8420 -- procedure and converting it (with an unchecked conversion) to the 8421 -- type required by the task kernel. For further details, see the 8422 -- description of Expand_Task_Body 8423 8424 Append_To (Args, 8425 Unchecked_Convert_To (RTE (RE_Task_Procedure_Access), 8426 Make_Attribute_Reference (Loc, 8427 Prefix => 8428 New_Occurrence_Of (Get_Task_Body_Procedure (Ttyp), Loc), 8429 Attribute_Name => Name_Address))); 8430 8431 -- Discriminants parameter. This is just the address of the task 8432 -- value record itself (which contains the discriminant values 8433 8434 Append_To (Args, 8435 Make_Attribute_Reference (Loc, 8436 Prefix => Make_Identifier (Loc, Name_uInit), 8437 Attribute_Name => Name_Address)); 8438 8439 -- Elaborated parameter. This is an access to the elaboration Boolean 8440 8441 Append_To (Args, 8442 Make_Attribute_Reference (Loc, 8443 Prefix => Make_Identifier (Loc, New_External_Name (Tnam, 'E')), 8444 Attribute_Name => Name_Unchecked_Access)); 8445 8446 -- Chain parameter. This is a reference to the _Chain parameter of 8447 -- the initialization procedure. 8448 8449 Append_To (Args, Make_Identifier (Loc, Name_uChain)); 8450 8451 -- Task name parameter. Take this from the _Task_Id parameter to the 8452 -- init call unless there is a Task_Name pragma, in which case we take 8453 -- the value from the pragma. 8454 8455 if Present (Tdef) 8456 and then Has_Task_Name_Pragma (Tdef) 8457 then 8458 Append_To (Args, 8459 New_Copy ( 8460 Expression (First ( 8461 Pragma_Argument_Associations ( 8462 Find_Task_Or_Protected_Pragma 8463 (Tdef, Name_Task_Name)))))); 8464 8465 else 8466 Append_To (Args, Make_Identifier (Loc, Name_uTask_Name)); 8467 end if; 8468 8469 -- Created_Task parameter. This is the _Task_Id field of the task 8470 -- record value 8471 8472 Append_To (Args, 8473 Make_Selected_Component (Loc, 8474 Prefix => Make_Identifier (Loc, Name_uInit), 8475 Selector_Name => Make_Identifier (Loc, Name_uTask_Id))); 8476 8477 if Restricted_Profile then 8478 Name := New_Reference_To (RTE (RE_Create_Restricted_Task), Loc); 8479 else 8480 Name := New_Reference_To (RTE (RE_Create_Task), Loc); 8481 end if; 8482 8483 return Make_Procedure_Call_Statement (Loc, 8484 Name => Name, Parameter_Associations => Args); 8485 end Make_Task_Create_Call; 8486 8487 ------------------------------ 8488 -- Next_Protected_Operation -- 8489 ------------------------------ 8490 8491 function Next_Protected_Operation (N : Node_Id) return Node_Id is 8492 Next_Op : Node_Id; 8493 8494 begin 8495 Next_Op := Next (N); 8496 8497 while Present (Next_Op) 8498 and then Nkind (Next_Op) /= N_Subprogram_Body 8499 and then Nkind (Next_Op) /= N_Entry_Body 8500 loop 8501 Next (Next_Op); 8502 end loop; 8503 8504 return Next_Op; 8505 end Next_Protected_Operation; 8506 8507 ---------------------- 8508 -- Set_Discriminals -- 8509 ---------------------- 8510 8511 procedure Set_Discriminals (Dec : Node_Id) is 8512 D : Entity_Id; 8513 Pdef : Entity_Id; 8514 D_Minal : Entity_Id; 8515 8516 begin 8517 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); 8518 Pdef := Defining_Identifier (Dec); 8519 8520 if Has_Discriminants (Pdef) then 8521 D := First_Discriminant (Pdef); 8522 8523 while Present (D) loop 8524 D_Minal := 8525 Make_Defining_Identifier (Sloc (D), 8526 Chars => New_External_Name (Chars (D), 'D')); 8527 8528 Set_Ekind (D_Minal, E_Constant); 8529 Set_Etype (D_Minal, Etype (D)); 8530 Set_Scope (D_Minal, Pdef); 8531 Set_Discriminal (D, D_Minal); 8532 Set_Discriminal_Link (D_Minal, D); 8533 8534 Next_Discriminant (D); 8535 end loop; 8536 end if; 8537 end Set_Discriminals; 8538 8539 ----------------- 8540 -- Set_Privals -- 8541 ----------------- 8542 8543 procedure Set_Privals 8544 (Dec : Node_Id; 8545 Op : Node_Id; 8546 Loc : Source_Ptr) 8547 is 8548 P_Decl : Node_Id; 8549 P_Id : Entity_Id; 8550 Priv : Entity_Id; 8551 Def : Node_Id; 8552 Body_Ent : Entity_Id; 8553 Prec_Decl : constant Node_Id := 8554 Parent (Corresponding_Record_Type 8555 (Defining_Identifier (Dec))); 8556 Prec_Def : constant Entity_Id := Type_Definition (Prec_Decl); 8557 Obj_Decl : Node_Id; 8558 P_Subtype : Entity_Id; 8559 Assoc_L : constant Elist_Id := New_Elmt_List; 8560 Op_Id : Entity_Id; 8561 8562 begin 8563 pragma Assert (Nkind (Dec) = N_Protected_Type_Declaration); 8564 pragma Assert 8565 (Nkind (Op) = N_Subprogram_Body or else Nkind (Op) = N_Entry_Body); 8566 8567 Def := Protected_Definition (Dec); 8568 8569 if Present (Private_Declarations (Def)) then 8570 8571 P_Decl := First (Private_Declarations (Def)); 8572 8573 while Present (P_Decl) loop 8574 if Nkind (P_Decl) = N_Component_Declaration then 8575 P_Id := Defining_Identifier (P_Decl); 8576 Priv := 8577 Make_Defining_Identifier (Loc, 8578 New_External_Name (Chars (P_Id), 'P')); 8579 8580 Set_Ekind (Priv, E_Variable); 8581 Set_Etype (Priv, Etype (P_Id)); 8582 Set_Scope (Priv, Scope (P_Id)); 8583 Set_Esize (Priv, Esize (Etype (P_Id))); 8584 Set_Alignment (Priv, Alignment (Etype (P_Id))); 8585 8586 -- If the type of the component is an itype, we must 8587 -- create a new itype for the corresponding prival in 8588 -- each protected operation, to avoid scoping problems. 8589 -- We create new itypes by copying the tree for the 8590 -- component definition. 8591 8592 if Is_Itype (Etype (P_Id)) then 8593 Append_Elmt (P_Id, Assoc_L); 8594 Append_Elmt (Priv, Assoc_L); 8595 8596 if Nkind (Op) = N_Entry_Body then 8597 Op_Id := Defining_Identifier (Op); 8598 else 8599 Op_Id := Defining_Unit_Name (Specification (Op)); 8600 end if; 8601 8602 Discard_Node 8603 (New_Copy_Tree (P_Decl, Assoc_L, New_Scope => Op_Id)); 8604 end if; 8605 8606 Set_Protected_Operation (P_Id, Op); 8607 Set_Prival (P_Id, Priv); 8608 end if; 8609 8610 Next (P_Decl); 8611 end loop; 8612 end if; 8613 8614 -- There is one more implicit private declaration: the object 8615 -- itself. A "prival" for this is attached to the protected 8616 -- body defining identifier. 8617 8618 Body_Ent := Corresponding_Body (Dec); 8619 8620 Priv := 8621 Make_Defining_Identifier (Sloc (Body_Ent), 8622 Chars => New_External_Name (Chars (Body_Ent), 'R')); 8623 8624 -- Set the Etype to the implicit subtype of Protection created when 8625 -- the protected type declaration was expanded. This node will not 8626 -- be analyzed until it is used as the defining identifier for the 8627 -- renaming declaration in the protected operation body, and it will 8628 -- be needed in the references expanded before that body is expanded. 8629 -- Since the Protection field is aliased, set Is_Aliased as well. 8630 8631 Obj_Decl := First (Component_Items (Component_List (Prec_Def))); 8632 while Chars (Defining_Identifier (Obj_Decl)) /= Name_uObject loop 8633 Next (Obj_Decl); 8634 end loop; 8635 8636 P_Subtype := Etype (Defining_Identifier (Obj_Decl)); 8637 Set_Etype (Priv, P_Subtype); 8638 Set_Is_Aliased (Priv); 8639 Set_Object_Ref (Body_Ent, Priv); 8640 end Set_Privals; 8641 8642 ---------------------------- 8643 -- Update_Prival_Subtypes -- 8644 ---------------------------- 8645 8646 procedure Update_Prival_Subtypes (N : Node_Id) is 8647 8648 function Process (N : Node_Id) return Traverse_Result; 8649 -- Update the etype of occurrences of privals whose etype does not 8650 -- match the current Etype of the prival entity itself. 8651 8652 procedure Update_Array_Bounds (E : Entity_Id); 8653 -- Itypes generated for array expressions may depend on the 8654 -- determinants of the protected object, and need to be processed 8655 -- separately because they are not attached to the tree. 8656 8657 procedure Update_Index_Types (N : Node_Id); 8658 -- Similarly, update the types of expressions in indexed components 8659 -- which may depend on other discriminants. 8660 8661 ------------- 8662 -- Process -- 8663 ------------- 8664 8665 function Process (N : Node_Id) return Traverse_Result is 8666 begin 8667 if Is_Entity_Name (N) then 8668 declare 8669 E : constant Entity_Id := Entity (N); 8670 8671 begin 8672 if Present (E) 8673 and then (Ekind (E) = E_Constant 8674 or else Ekind (E) = E_Variable) 8675 and then Nkind (Parent (E)) = N_Object_Renaming_Declaration 8676 and then not Is_Scalar_Type (Etype (E)) 8677 and then Etype (N) /= Etype (E) 8678 then 8679 Set_Etype (N, Etype (Entity (Original_Node (N)))); 8680 Update_Index_Types (N); 8681 8682 elsif Present (E) 8683 and then Ekind (E) = E_Constant 8684 and then Present (Discriminal_Link (E)) 8685 then 8686 Set_Etype (N, Etype (E)); 8687 end if; 8688 end; 8689 8690 return OK; 8691 8692 elsif Nkind (N) = N_Defining_Identifier 8693 or else Nkind (N) = N_Defining_Operator_Symbol 8694 or else Nkind (N) = N_Defining_Character_Literal 8695 then 8696 return Skip; 8697 8698 elsif Nkind (N) = N_String_Literal then 8699 -- array type, but bounds are constant. 8700 return OK; 8701 8702 elsif Nkind (N) = N_Object_Declaration 8703 and then Is_Itype (Etype (Defining_Identifier (N))) 8704 and then Is_Array_Type (Etype (Defining_Identifier (N))) 8705 then 8706 Update_Array_Bounds (Etype (Defining_Identifier (N))); 8707 return OK; 8708 8709 -- For array components of discriminated records, use the 8710 -- base type directly, because it may depend indirectly 8711 -- on the discriminants of the protected type. Cleaner would 8712 -- be a systematic mechanism to compute actual subtypes of 8713 -- private components ??? 8714 8715 elsif Nkind (N) in N_Has_Etype 8716 and then Present (Etype (N)) 8717 and then Is_Array_Type (Etype (N)) 8718 and then Nkind (N) = N_Selected_Component 8719 and then Has_Discriminants (Etype (Prefix (N))) 8720 then 8721 Set_Etype (N, Base_Type (Etype (N))); 8722 Update_Index_Types (N); 8723 return OK; 8724 8725 else 8726 if Nkind (N) in N_Has_Etype 8727 and then Present (Etype (N)) 8728 and then Is_Itype (Etype (N)) then 8729 8730 if Is_Array_Type (Etype (N)) then 8731 Update_Array_Bounds (Etype (N)); 8732 8733 elsif Is_Scalar_Type (Etype (N)) then 8734 Update_Prival_Subtypes (Type_Low_Bound (Etype (N))); 8735 Update_Prival_Subtypes (Type_High_Bound (Etype (N))); 8736 end if; 8737 end if; 8738 8739 return OK; 8740 end if; 8741 end Process; 8742 8743 ------------------------- 8744 -- Update_Array_Bounds -- 8745 ------------------------- 8746 8747 procedure Update_Array_Bounds (E : Entity_Id) is 8748 Ind : Node_Id; 8749 8750 begin 8751 Ind := First_Index (E); 8752 8753 while Present (Ind) loop 8754 Update_Prival_Subtypes (Type_Low_Bound (Etype (Ind))); 8755 Update_Prival_Subtypes (Type_High_Bound (Etype (Ind))); 8756 Next_Index (Ind); 8757 end loop; 8758 end Update_Array_Bounds; 8759 8760 ------------------------ 8761 -- Update_Index_Types -- 8762 ------------------------ 8763 8764 procedure Update_Index_Types (N : Node_Id) is 8765 Indx1 : Node_Id; 8766 I_Typ : Node_Id; 8767 begin 8768 -- If the prefix has an actual subtype that is different 8769 -- from the nominal one, update the types of the indices, 8770 -- so that the proper constraints are applied. Do not 8771 -- apply this transformation to a packed array, where the 8772 -- index type is computed for a byte array and is different 8773 -- from the source index. 8774 8775 if Nkind (Parent (N)) = N_Indexed_Component 8776 and then 8777 not Is_Bit_Packed_Array (Etype (Prefix (Parent (N)))) 8778 then 8779 Indx1 := First (Expressions (Parent (N))); 8780 I_Typ := First_Index (Etype (N)); 8781 8782 while Present (Indx1) and then Present (I_Typ) loop 8783 8784 if not Is_Entity_Name (Indx1) then 8785 Set_Etype (Indx1, Base_Type (Etype (I_Typ))); 8786 end if; 8787 8788 Next (Indx1); 8789 Next_Index (I_Typ); 8790 end loop; 8791 end if; 8792 end Update_Index_Types; 8793 8794 procedure Traverse is new Traverse_Proc; 8795 8796 -- Start of processing for Update_Prival_Subtypes 8797 8798 begin 8799 Traverse (N); 8800 end Update_Prival_Subtypes; 8801 8802end Exp_Ch9; 8803