1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P_ D I S T -- 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 Einfo; use Einfo; 29with Elists; use Elists; 30with Exp_Strm; use Exp_Strm; 31with Exp_Tss; use Exp_Tss; 32with Exp_Util; use Exp_Util; 33with GNAT.HTable; use GNAT.HTable; 34with Lib; use Lib; 35with Namet; use Namet; 36with Nlists; use Nlists; 37with Nmake; use Nmake; 38with Opt; use Opt; 39with Rtsfind; use Rtsfind; 40with Sem; use Sem; 41with Sem_Ch3; use Sem_Ch3; 42with Sem_Ch8; use Sem_Ch8; 43with Sem_Dist; use Sem_Dist; 44with Sem_Util; use Sem_Util; 45with Sinfo; use Sinfo; 46with Snames; use Snames; 47with Stand; use Stand; 48with Stringt; use Stringt; 49with Tbuild; use Tbuild; 50with Uintp; use Uintp; 51with Uname; use Uname; 52 53package body Exp_Dist is 54 55 -- The following model has been used to implement distributed objects: 56 -- given a designated type D and a RACW type R, then a record of the 57 -- form: 58 59 -- type Stub is tagged record 60 -- [...declaration similar to s-parint.ads RACW_Stub_Type...] 61 -- end record; 62 63 -- is built. This type has two properties: 64 65 -- 1) Since it has the same structure than RACW_Stub_Type, it can be 66 -- converted to and from this type to make it suitable for 67 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order 68 -- to avoid memory leaks when the same remote object arrive on the 69 -- same partition by following different pathes 70 71 -- 2) It also has the same dispatching table as the designated type D, 72 -- and thus can be used as an object designated by a value of type 73 -- R on any partition other than the one on which the object has 74 -- been created, since only dispatching calls will be performed and 75 -- the fields themselves will not be used. We call Derive_Subprograms 76 -- to fake half a derivation to ensure that the subprograms do have 77 -- the same dispatching table. 78 79 ----------------------- 80 -- Local subprograms -- 81 ----------------------- 82 83 procedure Build_General_Calling_Stubs 84 (Decls : in List_Id; 85 Statements : in List_Id; 86 Target_Partition : in Entity_Id; 87 RPC_Receiver : in Node_Id; 88 Subprogram_Id : in Node_Id; 89 Asynchronous : in Node_Id := Empty; 90 Is_Known_Asynchronous : in Boolean := False; 91 Is_Known_Non_Asynchronous : in Boolean := False; 92 Is_Function : in Boolean; 93 Spec : in Node_Id; 94 Object_Type : in Entity_Id := Empty; 95 Nod : in Node_Id); 96 -- Build calling stubs for general purpose. The parameters are: 97 -- Decls : a place to put declarations 98 -- Statements : a place to put statements 99 -- Target_Partition : a node containing the target partition that must 100 -- be a N_Defining_Identifier 101 -- RPC_Receiver : a node containing the RPC receiver 102 -- Subprogram_Id : a node containing the subprogram ID 103 -- Asynchronous : True if an APC must be made instead of an RPC. 104 -- The value needs not be supplied if one of the 105 -- Is_Known_... is True. 106 -- Is_Known_Async... : True if we know that this is asynchronous 107 -- Is_Known_Non_A... : True if we know that this is not asynchronous 108 -- Spec : a node with a Parameter_Specifications and 109 -- a Subtype_Mark if applicable 110 -- Object_Type : in case of a RACW, parameters of type access to 111 -- Object_Type will be marshalled using the 112 -- address of this object (the addr field) rather 113 -- than using the 'Write on the object itself 114 -- Nod : used to provide sloc for generated code 115 116 function Build_Subprogram_Calling_Stubs 117 (Vis_Decl : Node_Id; 118 Subp_Id : Int; 119 Asynchronous : Boolean; 120 Dynamically_Asynchronous : Boolean := False; 121 Stub_Type : Entity_Id := Empty; 122 Locator : Entity_Id := Empty; 123 New_Name : Name_Id := No_Name) 124 return Node_Id; 125 -- Build the calling stub for a given subprogram with the subprogram ID 126 -- being Subp_Id. If Stub_Type is given, then the "addr" field of 127 -- parameters of this type will be marshalled instead of the object 128 -- itself. It will then be converted into Stub_Type before performing 129 -- the real call. If Dynamically_Asynchronous is True, then it will be 130 -- computed at run time whether the call is asynchronous or not. 131 -- Otherwise, the value of the formal Asynchronous will be used. 132 -- If Locator is not Empty, it will be used instead of RCI_Cache. If 133 -- New_Name is given, then it will be used instead of the original name. 134 135 function Build_Subprogram_Receiving_Stubs 136 (Vis_Decl : Node_Id; 137 Asynchronous : Boolean; 138 Dynamically_Asynchronous : Boolean := False; 139 Stub_Type : Entity_Id := Empty; 140 RACW_Type : Entity_Id := Empty; 141 Parent_Primitive : Entity_Id := Empty) 142 return Node_Id; 143 -- Build the receiving stub for a given subprogram. The subprogram 144 -- declaration is also built by this procedure, and the value returned 145 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is 146 -- found in the specification, then its address is read from the stream 147 -- instead of the object itself and converted into an access to 148 -- class-wide type before doing the real call using any of the RACW type 149 -- pointing on the designated type. 150 151 function Build_RPC_Receiver_Specification 152 (RPC_Receiver : Entity_Id; 153 Stream_Parameter : Entity_Id; 154 Result_Parameter : Entity_Id) 155 return Node_Id; 156 -- Make a subprogram specification for an RPC receiver, 157 -- with the given defining unit name and formal parameters. 158 159 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id; 160 -- Return an ordered parameter list: unconstrained parameters are put 161 -- at the beginning of the list and constrained ones are put after. If 162 -- there are no parameters, an empty list is returned. 163 164 procedure Add_Calling_Stubs_To_Declarations 165 (Pkg_Spec : in Node_Id; 166 Decls : in List_Id); 167 -- Add calling stubs to the declarative part 168 169 procedure Add_Receiving_Stubs_To_Declarations 170 (Pkg_Spec : in Node_Id; 171 Decls : in List_Id); 172 -- Add receiving stubs to the declarative part 173 174 procedure Add_RAS_Dereference_Attribute (N : in Node_Id); 175 -- Add a subprogram body for RAS dereference 176 177 procedure Add_RAS_Access_Attribute (N : in Node_Id); 178 -- Add a subprogram body for RAS Access attribute 179 180 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean; 181 -- Return True if nothing prevents the program whose specification is 182 -- given to be asynchronous (i.e. no out parameter). 183 184 function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id; 185 function Get_String_Id (Val : String) return String_Id; 186 -- Ugly functions used to retrieve a package name. Inherited from the 187 -- old exp_dist.adb and not rewritten yet ??? 188 189 function Pack_Entity_Into_Stream_Access 190 (Loc : Source_Ptr; 191 Stream : Node_Id; 192 Object : Entity_Id; 193 Etyp : Entity_Id := Empty) 194 return Node_Id; 195 -- Pack Object (of type Etyp) into Stream. If Etyp is not given, 196 -- then Etype (Object) will be used if present. If the type is 197 -- constrained, then 'Write will be used to output the object, 198 -- If the type is unconstrained, 'Output will be used. 199 200 function Pack_Node_Into_Stream 201 (Loc : Source_Ptr; 202 Stream : Entity_Id; 203 Object : Node_Id; 204 Etyp : Entity_Id) 205 return Node_Id; 206 -- Similar to above, with an arbitrary node instead of an entity 207 208 function Pack_Node_Into_Stream_Access 209 (Loc : Source_Ptr; 210 Stream : Node_Id; 211 Object : Node_Id; 212 Etyp : Entity_Id) 213 return Node_Id; 214 -- Similar to above, with Stream instead of Stream'Access 215 216 function Copy_Specification 217 (Loc : Source_Ptr; 218 Spec : Node_Id; 219 Object_Type : Entity_Id := Empty; 220 Stub_Type : Entity_Id := Empty; 221 New_Name : Name_Id := No_Name) 222 return Node_Id; 223 -- Build a specification from another one. If Object_Type is not Empty 224 -- and any access to Object_Type is found, then it is replaced by an 225 -- access to Stub_Type. If New_Name is given, then it will be used as 226 -- the name for the newly created spec. 227 228 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id; 229 -- Return the scope represented by a given spec 230 231 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean; 232 -- Return True if the current parameter needs an extra formal to reflect 233 -- its constrained status. 234 235 function Is_RACW_Controlling_Formal 236 (Parameter : Node_Id; Stub_Type : Entity_Id) 237 return Boolean; 238 -- Return True if the current parameter is a controlling formal argument 239 -- of type Stub_Type or access to Stub_Type. 240 241 type Stub_Structure is record 242 Stub_Type : Entity_Id; 243 Stub_Type_Access : Entity_Id; 244 Object_RPC_Receiver : Entity_Id; 245 RPC_Receiver_Stream : Entity_Id; 246 RPC_Receiver_Result : Entity_Id; 247 RACW_Type : Entity_Id; 248 end record; 249 -- This structure is necessary because of the two phases analysis of 250 -- a RACW declaration occurring in the same Remote_Types package as the 251 -- designated type. RACW_Type is any of the RACW types pointing on this 252 -- designated type, it is used here to save an anonymous type creation 253 -- for each primitive operation. 254 255 Empty_Stub_Structure : constant Stub_Structure := 256 (Empty, Empty, Empty, Empty, Empty, Empty); 257 258 type Hash_Index is range 0 .. 50; 259 function Hash (F : Entity_Id) return Hash_Index; 260 261 package Stubs_Table is 262 new Simple_HTable (Header_Num => Hash_Index, 263 Element => Stub_Structure, 264 No_Element => Empty_Stub_Structure, 265 Key => Entity_Id, 266 Hash => Hash, 267 Equal => "="); 268 -- Mapping between a RACW designated type and its stub type 269 270 package Asynchronous_Flags_Table is 271 new Simple_HTable (Header_Num => Hash_Index, 272 Element => Node_Id, 273 No_Element => Empty, 274 Key => Entity_Id, 275 Hash => Hash, 276 Equal => "="); 277 -- Mapping between a RACW type and the node holding the value True if 278 -- the RACW is asynchronous and False otherwise. 279 280 package RCI_Locator_Table is 281 new Simple_HTable (Header_Num => Hash_Index, 282 Element => Entity_Id, 283 No_Element => Empty, 284 Key => Entity_Id, 285 Hash => Hash, 286 Equal => "="); 287 -- Mapping between a RCI package on which All_Calls_Remote applies and 288 -- the generic instantiation of RCI_Info for this package. 289 290 package RCI_Calling_Stubs_Table is 291 new Simple_HTable (Header_Num => Hash_Index, 292 Element => Entity_Id, 293 No_Element => Empty, 294 Key => Entity_Id, 295 Hash => Hash, 296 Equal => "="); 297 -- Mapping between a RCI subprogram and the corresponding calling stubs 298 299 procedure Add_Stub_Type 300 (Designated_Type : in Entity_Id; 301 RACW_Type : in Entity_Id; 302 Decls : in List_Id; 303 Stub_Type : out Entity_Id; 304 Stub_Type_Access : out Entity_Id; 305 Object_RPC_Receiver : out Entity_Id; 306 Existing : out Boolean); 307 -- Add the declaration of the stub type, the access to stub type and the 308 -- object RPC receiver at the end of Decls. If these already exist, 309 -- then nothing is added in the tree but the right values are returned 310 -- anyhow and Existing is set to True. 311 312 procedure Add_RACW_Read_Attribute 313 (RACW_Type : in Entity_Id; 314 Stub_Type : in Entity_Id; 315 Stub_Type_Access : in Entity_Id; 316 Declarations : in List_Id); 317 -- Add Read attribute in Decls for the RACW type. The Read attribute 318 -- is added right after the RACW_Type declaration while the body is 319 -- inserted after Declarations. 320 321 procedure Add_RACW_Write_Attribute 322 (RACW_Type : in Entity_Id; 323 Stub_Type : in Entity_Id; 324 Stub_Type_Access : in Entity_Id; 325 Object_RPC_Receiver : in Entity_Id; 326 Declarations : in List_Id); 327 -- Same thing for the Write attribute 328 329 procedure Add_RACW_Read_Write_Attributes 330 (RACW_Type : in Entity_Id; 331 Stub_Type : in Entity_Id; 332 Stub_Type_Access : in Entity_Id; 333 Object_RPC_Receiver : in Entity_Id; 334 Declarations : in List_Id); 335 -- Add Read and Write attributes declarations and bodies for a given 336 -- RACW type. The declarations are added just after the declaration 337 -- of the RACW type itself, while the bodies are inserted at the end 338 -- of Decls. 339 340 function RCI_Package_Locator 341 (Loc : Source_Ptr; 342 Package_Spec : Node_Id) 343 return Node_Id; 344 -- Instantiate the generic package RCI_Info in order to locate the 345 -- RCI package whose spec is given as argument. 346 347 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id; 348 -- Surround a node N by a tag check, as in: 349 -- begin 350 -- <N>; 351 -- exception 352 -- when E : Ada.Tags.Tag_Error => 353 -- Raise_Exception (Program_Error'Identity, 354 -- Exception_Message (E)); 355 -- end; 356 357 function Input_With_Tag_Check 358 (Loc : Source_Ptr; 359 Var_Type : Entity_Id; 360 Stream : Entity_Id) 361 return Node_Id; 362 -- Return a function with the following form: 363 -- function R return Var_Type is 364 -- begin 365 -- return Var_Type'Input (S); 366 -- exception 367 -- when E : Ada.Tags.Tag_Error => 368 -- Raise_Exception (Program_Error'Identity, 369 -- Exception_Message (E)); 370 -- end R; 371 372 ------------------------------------ 373 -- Local variables and structures -- 374 ------------------------------------ 375 376 RCI_Cache : Node_Id; 377 378 Output_From_Constrained : constant array (Boolean) of Name_Id := 379 (False => Name_Output, 380 True => Name_Write); 381 -- The attribute to choose depending on the fact that the parameter 382 -- is constrained or not. There is no such thing as Input_From_Constrained 383 -- since this require separate mechanisms ('Input is a function while 384 -- 'Read is a procedure). 385 386 --------------------------------------- 387 -- Add_Calling_Stubs_To_Declarations -- 388 --------------------------------------- 389 390 procedure Add_Calling_Stubs_To_Declarations 391 (Pkg_Spec : in Node_Id; 392 Decls : in List_Id) 393 is 394 Current_Subprogram_Number : Int := 0; 395 Current_Declaration : Node_Id; 396 397 Loc : constant Source_Ptr := Sloc (Pkg_Spec); 398 399 RCI_Instantiation : Node_Id; 400 401 Subp_Stubs : Node_Id; 402 403 begin 404 -- The first thing added is an instantiation of the generic package 405 -- System.Partition_interface.RCI_Info with the name of the (current) 406 -- remote package. This will act as an interface with the name server 407 -- to determine the Partition_ID and the RPC_Receiver for the 408 -- receiver of this package. 409 410 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec); 411 RCI_Cache := Defining_Unit_Name (RCI_Instantiation); 412 413 Append_To (Decls, RCI_Instantiation); 414 Analyze (RCI_Instantiation); 415 416 -- For each subprogram declaration visible in the spec, we do 417 -- build a body. We also increment a counter to assign a different 418 -- Subprogram_Id to each subprograms. The receiving stubs processing 419 -- do use the same mechanism and will thus assign the same Id and 420 -- do the correct dispatching. 421 422 Current_Declaration := First (Visible_Declarations (Pkg_Spec)); 423 424 while Current_Declaration /= Empty loop 425 426 if Nkind (Current_Declaration) = N_Subprogram_Declaration 427 and then Comes_From_Source (Current_Declaration) 428 then 429 pragma Assert (Current_Subprogram_Number = 430 Get_Subprogram_Id (Defining_Unit_Name (Specification ( 431 Current_Declaration)))); 432 433 Subp_Stubs := 434 Build_Subprogram_Calling_Stubs ( 435 Vis_Decl => Current_Declaration, 436 Subp_Id => Current_Subprogram_Number, 437 Asynchronous => 438 Nkind (Specification (Current_Declaration)) = 439 N_Procedure_Specification 440 and then 441 Is_Asynchronous (Defining_Unit_Name (Specification 442 (Current_Declaration)))); 443 444 Append_To (Decls, Subp_Stubs); 445 Analyze (Subp_Stubs); 446 447 Current_Subprogram_Number := Current_Subprogram_Number + 1; 448 end if; 449 450 Next (Current_Declaration); 451 end loop; 452 453 end Add_Calling_Stubs_To_Declarations; 454 455 ----------------------- 456 -- Add_RACW_Features -- 457 ----------------------- 458 459 procedure Add_RACW_Features (RACW_Type : in Entity_Id) 460 is 461 Desig : constant Entity_Id := 462 Etype (Designated_Type (RACW_Type)); 463 Decls : List_Id := 464 List_Containing (Declaration_Node (RACW_Type)); 465 466 Same_Scope : constant Boolean := 467 Scope (Desig) = Scope (RACW_Type); 468 469 Stub_Type : Entity_Id; 470 Stub_Type_Access : Entity_Id; 471 Object_RPC_Receiver : Entity_Id; 472 Existing : Boolean; 473 474 begin 475 if not Expander_Active then 476 return; 477 end if; 478 479 if Same_Scope then 480 481 -- We are declaring a RACW in the same package than its designated 482 -- type, so the list to use for late declarations must be the 483 -- private part of the package. We do know that this private part 484 -- exists since the designated type has to be a private one. 485 486 Decls := Private_Declarations 487 (Package_Specification_Of_Scope (Current_Scope)); 488 489 elsif Nkind (Parent (Decls)) = N_Package_Specification 490 and then Present (Private_Declarations (Parent (Decls))) 491 then 492 Decls := Private_Declarations (Parent (Decls)); 493 end if; 494 495 -- If we were unable to find the declarations, that means that the 496 -- completion of the type was missing. We can safely return and let 497 -- the error be caught by the semantic analysis. 498 499 if No (Decls) then 500 return; 501 end if; 502 503 Add_Stub_Type 504 (Designated_Type => Desig, 505 RACW_Type => RACW_Type, 506 Decls => Decls, 507 Stub_Type => Stub_Type, 508 Stub_Type_Access => Stub_Type_Access, 509 Object_RPC_Receiver => Object_RPC_Receiver, 510 Existing => Existing); 511 512 Add_RACW_Read_Write_Attributes 513 (RACW_Type => RACW_Type, 514 Stub_Type => Stub_Type, 515 Stub_Type_Access => Stub_Type_Access, 516 Object_RPC_Receiver => Object_RPC_Receiver, 517 Declarations => Decls); 518 519 if not Same_Scope and then not Existing then 520 521 -- The RACW has been declared in another scope than the designated 522 -- type and has not been handled by another RACW in the same 523 -- package as the first one, so add primitive for the stub type 524 -- here. 525 526 Add_RACW_Primitive_Declarations_And_Bodies 527 (Designated_Type => Desig, 528 Insertion_Node => 529 Parent (Declaration_Node (Object_RPC_Receiver)), 530 Decls => Decls); 531 532 else 533 Add_Access_Type_To_Process (E => Desig, A => RACW_Type); 534 end if; 535 end Add_RACW_Features; 536 537 ------------------------------------------------- 538 -- Add_RACW_Primitive_Declarations_And_Bodies -- 539 ------------------------------------------------- 540 541 procedure Add_RACW_Primitive_Declarations_And_Bodies 542 (Designated_Type : in Entity_Id; 543 Insertion_Node : in Node_Id; 544 Decls : in List_Id) 545 is 546 -- Set sloc of generated declaration to be that of the 547 -- insertion node, so the declarations are recognized as 548 -- belonging to the current package. 549 550 Loc : constant Source_Ptr := Sloc (Insertion_Node); 551 552 Stub_Elements : constant Stub_Structure := 553 Stubs_Table.Get (Designated_Type); 554 555 pragma Assert (Stub_Elements /= Empty_Stub_Structure); 556 557 Current_Insertion_Node : Node_Id := Insertion_Node; 558 559 RPC_Receiver_Declarations : List_Id; 560 RPC_Receiver_Statements : List_Id; 561 RPC_Receiver_Case_Alternatives : constant List_Id := New_List; 562 RPC_Receiver_Subp_Id : Entity_Id; 563 564 Current_Primitive_Elmt : Elmt_Id; 565 Current_Primitive : Entity_Id; 566 Current_Primitive_Body : Node_Id; 567 Current_Primitive_Spec : Node_Id; 568 Current_Primitive_Decl : Node_Id; 569 Current_Primitive_Number : Int := 0; 570 571 Current_Primitive_Alias : Node_Id; 572 573 Current_Receiver : Entity_Id; 574 Current_Receiver_Body : Node_Id; 575 576 RPC_Receiver_Decl : Node_Id; 577 578 Possibly_Asynchronous : Boolean; 579 580 begin 581 if not Expander_Active then 582 return; 583 end if; 584 585 -- Build callers, receivers for every primitive operations and a RPC 586 -- receiver for this type. 587 588 if Present (Primitive_Operations (Designated_Type)) then 589 590 Current_Primitive_Elmt := 591 First_Elmt (Primitive_Operations (Designated_Type)); 592 593 while Current_Primitive_Elmt /= No_Elmt loop 594 595 Current_Primitive := Node (Current_Primitive_Elmt); 596 597 -- Copy the primitive of all the parents, except predefined 598 -- ones that are not remotely dispatching. 599 600 if Chars (Current_Primitive) /= Name_uSize 601 and then Chars (Current_Primitive) /= Name_uAlignment 602 and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize) 603 then 604 -- The first thing to do is build an up-to-date copy of 605 -- the spec with all the formals referencing Designated_Type 606 -- transformed into formals referencing Stub_Type. Since this 607 -- primitive may have been inherited, go back the alias chain 608 -- until the real primitive has been found. 609 610 Current_Primitive_Alias := Current_Primitive; 611 while Present (Alias (Current_Primitive_Alias)) loop 612 pragma Assert 613 (Current_Primitive_Alias 614 /= Alias (Current_Primitive_Alias)); 615 Current_Primitive_Alias := Alias (Current_Primitive_Alias); 616 end loop; 617 618 Current_Primitive_Spec := 619 Copy_Specification (Loc, 620 Spec => Parent (Current_Primitive_Alias), 621 Object_Type => Designated_Type, 622 Stub_Type => Stub_Elements.Stub_Type); 623 624 Current_Primitive_Decl := 625 Make_Subprogram_Declaration (Loc, 626 Specification => Current_Primitive_Spec); 627 628 Insert_After (Current_Insertion_Node, Current_Primitive_Decl); 629 Analyze (Current_Primitive_Decl); 630 Current_Insertion_Node := Current_Primitive_Decl; 631 632 Possibly_Asynchronous := 633 Nkind (Current_Primitive_Spec) = N_Procedure_Specification 634 and then Could_Be_Asynchronous (Current_Primitive_Spec); 635 636 Current_Primitive_Body := 637 Build_Subprogram_Calling_Stubs 638 (Vis_Decl => Current_Primitive_Decl, 639 Subp_Id => Current_Primitive_Number, 640 Asynchronous => Possibly_Asynchronous, 641 Dynamically_Asynchronous => Possibly_Asynchronous, 642 Stub_Type => Stub_Elements.Stub_Type); 643 Append_To (Decls, Current_Primitive_Body); 644 645 -- Analyzing the body here would cause the Stub type to be 646 -- frozen, thus preventing subsequent primitive declarations. 647 -- For this reason, it will be analyzed later in the 648 -- regular flow. 649 650 -- Build the receiver stubs 651 652 Current_Receiver_Body := 653 Build_Subprogram_Receiving_Stubs 654 (Vis_Decl => Current_Primitive_Decl, 655 Asynchronous => Possibly_Asynchronous, 656 Dynamically_Asynchronous => Possibly_Asynchronous, 657 Stub_Type => Stub_Elements.Stub_Type, 658 RACW_Type => Stub_Elements.RACW_Type, 659 Parent_Primitive => Current_Primitive); 660 661 Current_Receiver := 662 Defining_Unit_Name (Specification (Current_Receiver_Body)); 663 664 Append_To (Decls, Current_Receiver_Body); 665 666 -- Add a case alternative to the receiver 667 668 Append_To (RPC_Receiver_Case_Alternatives, 669 Make_Case_Statement_Alternative (Loc, 670 Discrete_Choices => New_List ( 671 Make_Integer_Literal (Loc, Current_Primitive_Number)), 672 673 Statements => New_List ( 674 Make_Procedure_Call_Statement (Loc, 675 Name => 676 New_Occurrence_Of (Current_Receiver, Loc), 677 Parameter_Associations => New_List ( 678 New_Occurrence_Of 679 (Stub_Elements.RPC_Receiver_Stream, Loc), 680 New_Occurrence_Of 681 (Stub_Elements.RPC_Receiver_Result, Loc)))))); 682 683 -- Increment the index of current primitive 684 685 Current_Primitive_Number := Current_Primitive_Number + 1; 686 end if; 687 688 Next_Elmt (Current_Primitive_Elmt); 689 end loop; 690 end if; 691 692 -- Build the case statement and the heart of the subprogram 693 694 Append_To (RPC_Receiver_Case_Alternatives, 695 Make_Case_Statement_Alternative (Loc, 696 Discrete_Choices => New_List (Make_Others_Choice (Loc)), 697 Statements => New_List (Make_Null_Statement (Loc)))); 698 699 RPC_Receiver_Subp_Id := 700 Make_Defining_Identifier (Loc, New_Internal_Name ('S')); 701 702 RPC_Receiver_Declarations := New_List ( 703 Make_Object_Declaration (Loc, 704 Defining_Identifier => RPC_Receiver_Subp_Id, 705 Object_Definition => 706 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))); 707 708 RPC_Receiver_Statements := New_List ( 709 Make_Attribute_Reference (Loc, 710 Prefix => 711 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), 712 Attribute_Name => 713 Name_Read, 714 Expressions => New_List ( 715 New_Occurrence_Of (Stub_Elements.RPC_Receiver_Stream, Loc), 716 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc)))); 717 718 Append_To (RPC_Receiver_Statements, 719 Make_Case_Statement (Loc, 720 Expression => 721 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), 722 Alternatives => RPC_Receiver_Case_Alternatives)); 723 724 RPC_Receiver_Decl := 725 Make_Subprogram_Body (Loc, 726 Specification => 727 Copy_Specification (Loc, 728 Parent (Stub_Elements.Object_RPC_Receiver)), 729 Declarations => RPC_Receiver_Declarations, 730 Handled_Statement_Sequence => 731 Make_Handled_Sequence_Of_Statements (Loc, 732 Statements => RPC_Receiver_Statements)); 733 734 Append_To (Decls, RPC_Receiver_Decl); 735 736 -- Do not analyze RPC receiver at this stage since it will otherwise 737 -- reference subprograms that have not been analyzed yet. It will 738 -- be analyzed in the regular flow. 739 740 end Add_RACW_Primitive_Declarations_And_Bodies; 741 742 ----------------------------- 743 -- Add_RACW_Read_Attribute -- 744 ----------------------------- 745 746 procedure Add_RACW_Read_Attribute 747 (RACW_Type : in Entity_Id; 748 Stub_Type : in Entity_Id; 749 Stub_Type_Access : in Entity_Id; 750 Declarations : in List_Id) 751 is 752 Loc : constant Source_Ptr := Sloc (RACW_Type); 753 754 Proc_Decl : Node_Id; 755 Attr_Decl : Node_Id; 756 757 Body_Node : Node_Id; 758 759 Decls : List_Id; 760 Statements : List_Id; 761 Local_Statements : List_Id; 762 Remote_Statements : List_Id; 763 -- Various parts of the procedure 764 765 Procedure_Name : constant Name_Id := 766 New_Internal_Name ('R'); 767 Source_Partition : constant Entity_Id := 768 Make_Defining_Identifier 769 (Loc, New_Internal_Name ('P')); 770 Source_Receiver : constant Entity_Id := 771 Make_Defining_Identifier 772 (Loc, New_Internal_Name ('S')); 773 Source_Address : constant Entity_Id := 774 Make_Defining_Identifier 775 (Loc, New_Internal_Name ('P')); 776 Stubbed_Result : constant Entity_Id := 777 Make_Defining_Identifier 778 (Loc, New_Internal_Name ('S')); 779 Asynchronous_Flag : constant Entity_Id := 780 Make_Defining_Identifier 781 (Loc, New_Internal_Name ('S')); 782 Asynchronous_Node : constant Node_Id := 783 New_Occurrence_Of (Standard_False, Loc); 784 785 -- Functions to create occurrences of the formal 786 -- parameter names. 787 788 function Stream_Parameter return Node_Id; 789 function Result return Node_Id; 790 791 function Stream_Parameter return Node_Id is 792 begin 793 return Make_Identifier (Loc, Name_S); 794 end Stream_Parameter; 795 796 function Result return Node_Id is 797 begin 798 return Make_Identifier (Loc, Name_V); 799 end Result; 800 801 begin 802 -- Declare the asynchronous flag. This flag will be changed to True 803 -- whenever it is known that the RACW type is asynchronous. Also, the 804 -- node gets stored since it may be rewritten when we process the 805 -- asynchronous pragma. 806 807 Append_To (Declarations, 808 Make_Object_Declaration (Loc, 809 Defining_Identifier => Asynchronous_Flag, 810 Constant_Present => True, 811 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 812 Expression => Asynchronous_Node)); 813 814 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Node); 815 816 -- Object declarations 817 818 Decls := New_List ( 819 Make_Object_Declaration (Loc, 820 Defining_Identifier => Source_Partition, 821 Object_Definition => 822 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), 823 824 Make_Object_Declaration (Loc, 825 Defining_Identifier => Source_Receiver, 826 Object_Definition => 827 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), 828 829 Make_Object_Declaration (Loc, 830 Defining_Identifier => Source_Address, 831 Object_Definition => 832 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), 833 834 Make_Object_Declaration (Loc, 835 Defining_Identifier => Stubbed_Result, 836 Object_Definition => 837 New_Occurrence_Of (Stub_Type_Access, Loc))); 838 839 -- Read the source Partition_ID and RPC_Receiver from incoming stream 840 841 Statements := New_List ( 842 Make_Attribute_Reference (Loc, 843 Prefix => 844 New_Occurrence_Of (RTE (RE_Partition_ID), Loc), 845 Attribute_Name => Name_Read, 846 Expressions => New_List ( 847 Stream_Parameter, 848 New_Occurrence_Of (Source_Partition, Loc))), 849 850 Make_Attribute_Reference (Loc, 851 Prefix => 852 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), 853 Attribute_Name => 854 Name_Read, 855 Expressions => New_List ( 856 Stream_Parameter, 857 New_Occurrence_Of (Source_Receiver, Loc))), 858 859 Make_Attribute_Reference (Loc, 860 Prefix => 861 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), 862 Attribute_Name => 863 Name_Read, 864 Expressions => New_List ( 865 Stream_Parameter, 866 New_Occurrence_Of (Source_Address, Loc)))); 867 868 -- If the Address is Null_Address, then return a null object 869 870 Append_To (Statements, 871 Make_Implicit_If_Statement (RACW_Type, 872 Condition => 873 Make_Op_Eq (Loc, 874 Left_Opnd => New_Occurrence_Of (Source_Address, Loc), 875 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), 876 Then_Statements => New_List ( 877 Make_Assignment_Statement (Loc, 878 Name => Result, 879 Expression => Make_Null (Loc)), 880 Make_Return_Statement (Loc)))); 881 882 -- If the RACW denotes an object created on the current partition, then 883 -- Local_Statements will be executed. The real object will be used. 884 885 Local_Statements := New_List ( 886 Make_Assignment_Statement (Loc, 887 Name => Result, 888 Expression => 889 Unchecked_Convert_To (RACW_Type, 890 OK_Convert_To (RTE (RE_Address), 891 New_Occurrence_Of (Source_Address, Loc))))); 892 893 -- If the object is located on another partition, then a stub object 894 -- will be created with all the information needed to rebuild the 895 -- real object at the other end. 896 897 Remote_Statements := New_List ( 898 899 Make_Assignment_Statement (Loc, 900 Name => New_Occurrence_Of (Stubbed_Result, Loc), 901 Expression => 902 Make_Allocator (Loc, 903 New_Occurrence_Of (Stub_Type, Loc))), 904 905 Make_Assignment_Statement (Loc, 906 Name => Make_Selected_Component (Loc, 907 Prefix => New_Occurrence_Of (Stubbed_Result, Loc), 908 Selector_Name => Make_Identifier (Loc, Name_Origin)), 909 Expression => 910 New_Occurrence_Of (Source_Partition, Loc)), 911 912 Make_Assignment_Statement (Loc, 913 Name => Make_Selected_Component (Loc, 914 Prefix => New_Occurrence_Of (Stubbed_Result, Loc), 915 Selector_Name => Make_Identifier (Loc, Name_Receiver)), 916 Expression => 917 New_Occurrence_Of (Source_Receiver, Loc)), 918 919 Make_Assignment_Statement (Loc, 920 Name => Make_Selected_Component (Loc, 921 Prefix => New_Occurrence_Of (Stubbed_Result, Loc), 922 Selector_Name => Make_Identifier (Loc, Name_Addr)), 923 Expression => 924 New_Occurrence_Of (Source_Address, Loc))); 925 926 Append_To (Remote_Statements, 927 Make_Assignment_Statement (Loc, 928 Name => Make_Selected_Component (Loc, 929 Prefix => New_Occurrence_Of (Stubbed_Result, Loc), 930 Selector_Name => Make_Identifier (Loc, Name_Asynchronous)), 931 Expression => 932 New_Occurrence_Of (Asynchronous_Flag, Loc))); 933 934 Append_To (Remote_Statements, 935 Make_Procedure_Call_Statement (Loc, 936 Name => 937 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc), 938 Parameter_Associations => New_List ( 939 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), 940 New_Occurrence_Of (Stubbed_Result, Loc))))); 941 942 Append_To (Remote_Statements, 943 Make_Assignment_Statement (Loc, 944 Name => Result, 945 Expression => Unchecked_Convert_To (RACW_Type, 946 New_Occurrence_Of (Stubbed_Result, Loc)))); 947 948 -- Distinguish between the local and remote cases, and execute the 949 -- appropriate piece of code. 950 951 Append_To (Statements, 952 Make_Implicit_If_Statement (RACW_Type, 953 Condition => 954 Make_Op_Eq (Loc, 955 Left_Opnd => 956 Make_Function_Call (Loc, 957 Name => 958 New_Occurrence_Of (RTE (RE_Get_Local_Partition_Id), Loc)), 959 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)), 960 Then_Statements => Local_Statements, 961 Else_Statements => Remote_Statements)); 962 963 Build_Stream_Procedure 964 (Loc, RACW_Type, Body_Node, 965 Make_Defining_Identifier (Loc, Procedure_Name), 966 Statements, Outp => True); 967 Set_Declarations (Body_Node, Decls); 968 969 Proc_Decl := Make_Subprogram_Declaration (Loc, 970 Copy_Specification (Loc, Specification (Body_Node))); 971 972 Attr_Decl := 973 Make_Attribute_Definition_Clause (Loc, 974 Name => New_Occurrence_Of (RACW_Type, Loc), 975 Chars => Name_Read, 976 Expression => 977 New_Occurrence_Of ( 978 Defining_Unit_Name (Specification (Proc_Decl)), Loc)); 979 980 Insert_After (Declaration_Node (RACW_Type), Proc_Decl); 981 Insert_After (Proc_Decl, Attr_Decl); 982 Append_To (Declarations, Body_Node); 983 end Add_RACW_Read_Attribute; 984 985 ------------------------------------ 986 -- Add_RACW_Read_Write_Attributes -- 987 ------------------------------------ 988 989 procedure Add_RACW_Read_Write_Attributes 990 (RACW_Type : in Entity_Id; 991 Stub_Type : in Entity_Id; 992 Stub_Type_Access : in Entity_Id; 993 Object_RPC_Receiver : in Entity_Id; 994 Declarations : in List_Id) 995 is 996 begin 997 Add_RACW_Write_Attribute 998 (RACW_Type => RACW_Type, 999 Stub_Type => Stub_Type, 1000 Stub_Type_Access => Stub_Type_Access, 1001 Object_RPC_Receiver => Object_RPC_Receiver, 1002 Declarations => Declarations); 1003 1004 Add_RACW_Read_Attribute 1005 (RACW_Type => RACW_Type, 1006 Stub_Type => Stub_Type, 1007 Stub_Type_Access => Stub_Type_Access, 1008 Declarations => Declarations); 1009 end Add_RACW_Read_Write_Attributes; 1010 1011 ------------------------------ 1012 -- Add_RACW_Write_Attribute -- 1013 ------------------------------ 1014 1015 procedure Add_RACW_Write_Attribute 1016 (RACW_Type : in Entity_Id; 1017 Stub_Type : in Entity_Id; 1018 Stub_Type_Access : in Entity_Id; 1019 Object_RPC_Receiver : in Entity_Id; 1020 Declarations : in List_Id) 1021 is 1022 Loc : constant Source_Ptr := Sloc (RACW_Type); 1023 1024 Body_Node : Node_Id; 1025 Proc_Decl : Node_Id; 1026 Attr_Decl : Node_Id; 1027 1028 Statements : List_Id; 1029 Local_Statements : List_Id; 1030 Remote_Statements : List_Id; 1031 Null_Statements : List_Id; 1032 1033 Procedure_Name : constant Name_Id := New_Internal_Name ('R'); 1034 1035 -- Functions to create occurrences of the formal 1036 -- parameter names. 1037 1038 function Stream_Parameter return Node_Id; 1039 function Object return Node_Id; 1040 1041 function Stream_Parameter return Node_Id is 1042 begin 1043 return Make_Identifier (Loc, Name_S); 1044 end Stream_Parameter; 1045 1046 function Object return Node_Id is 1047 begin 1048 return Make_Identifier (Loc, Name_V); 1049 end Object; 1050 1051 begin 1052 -- Build the code fragment corresponding to the marshalling of a 1053 -- local object. 1054 1055 Local_Statements := New_List ( 1056 1057 Pack_Entity_Into_Stream_Access (Loc, 1058 Stream => Stream_Parameter, 1059 Object => RTE (RE_Get_Local_Partition_Id)), 1060 1061 Pack_Node_Into_Stream_Access (Loc, 1062 Stream => Stream_Parameter, 1063 Object => OK_Convert_To (RTE (RE_Unsigned_64), 1064 Make_Attribute_Reference (Loc, 1065 Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc), 1066 Attribute_Name => Name_Address)), 1067 Etyp => RTE (RE_Unsigned_64)), 1068 1069 Pack_Node_Into_Stream_Access (Loc, 1070 Stream => Stream_Parameter, 1071 Object => OK_Convert_To (RTE (RE_Unsigned_64), 1072 Make_Attribute_Reference (Loc, 1073 Prefix => 1074 Make_Explicit_Dereference (Loc, 1075 Prefix => Object), 1076 Attribute_Name => Name_Address)), 1077 Etyp => RTE (RE_Unsigned_64))); 1078 1079 -- Build the code fragment corresponding to the marshalling of 1080 -- a remote object. 1081 1082 Remote_Statements := New_List ( 1083 1084 Pack_Node_Into_Stream_Access (Loc, 1085 Stream => Stream_Parameter, 1086 Object => 1087 Make_Selected_Component (Loc, 1088 Prefix => Unchecked_Convert_To (Stub_Type_Access, 1089 Object), 1090 Selector_Name => 1091 Make_Identifier (Loc, Name_Origin)), 1092 Etyp => RTE (RE_Partition_ID)), 1093 1094 Pack_Node_Into_Stream_Access (Loc, 1095 Stream => Stream_Parameter, 1096 Object => 1097 Make_Selected_Component (Loc, 1098 Prefix => Unchecked_Convert_To (Stub_Type_Access, 1099 Object), 1100 Selector_Name => 1101 Make_Identifier (Loc, Name_Receiver)), 1102 Etyp => RTE (RE_Unsigned_64)), 1103 1104 Pack_Node_Into_Stream_Access (Loc, 1105 Stream => Stream_Parameter, 1106 Object => 1107 Make_Selected_Component (Loc, 1108 Prefix => Unchecked_Convert_To (Stub_Type_Access, 1109 Object), 1110 Selector_Name => 1111 Make_Identifier (Loc, Name_Addr)), 1112 Etyp => RTE (RE_Unsigned_64))); 1113 1114 -- Build the code fragment corresponding to the marshalling of a null 1115 -- object. 1116 1117 Null_Statements := New_List ( 1118 1119 Pack_Entity_Into_Stream_Access (Loc, 1120 Stream => Stream_Parameter, 1121 Object => RTE (RE_Get_Local_Partition_Id)), 1122 1123 Pack_Node_Into_Stream_Access (Loc, 1124 Stream => Stream_Parameter, 1125 Object => OK_Convert_To (RTE (RE_Unsigned_64), 1126 Make_Attribute_Reference (Loc, 1127 Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc), 1128 Attribute_Name => Name_Address)), 1129 Etyp => RTE (RE_Unsigned_64)), 1130 1131 Pack_Node_Into_Stream_Access (Loc, 1132 Stream => Stream_Parameter, 1133 Object => Make_Integer_Literal (Loc, Uint_0), 1134 Etyp => RTE (RE_Unsigned_64))); 1135 1136 Statements := New_List ( 1137 Make_Implicit_If_Statement (RACW_Type, 1138 Condition => 1139 Make_Op_Eq (Loc, 1140 Left_Opnd => Object, 1141 Right_Opnd => Make_Null (Loc)), 1142 Then_Statements => Null_Statements, 1143 Elsif_Parts => New_List ( 1144 Make_Elsif_Part (Loc, 1145 Condition => 1146 Make_Op_Eq (Loc, 1147 Left_Opnd => 1148 Make_Attribute_Reference (Loc, 1149 Prefix => Object, 1150 Attribute_Name => Name_Tag), 1151 Right_Opnd => 1152 Make_Attribute_Reference (Loc, 1153 Prefix => New_Occurrence_Of (Stub_Type, Loc), 1154 Attribute_Name => Name_Tag)), 1155 Then_Statements => Remote_Statements)), 1156 Else_Statements => Local_Statements)); 1157 1158 Build_Stream_Procedure 1159 (Loc, RACW_Type, Body_Node, 1160 Make_Defining_Identifier (Loc, Procedure_Name), 1161 Statements, Outp => False); 1162 1163 Proc_Decl := Make_Subprogram_Declaration (Loc, 1164 Copy_Specification (Loc, Specification (Body_Node))); 1165 1166 Attr_Decl := 1167 Make_Attribute_Definition_Clause (Loc, 1168 Name => New_Occurrence_Of (RACW_Type, Loc), 1169 Chars => Name_Write, 1170 Expression => 1171 New_Occurrence_Of ( 1172 Defining_Unit_Name (Specification (Proc_Decl)), Loc)); 1173 1174 Insert_After (Declaration_Node (RACW_Type), Proc_Decl); 1175 Insert_After (Proc_Decl, Attr_Decl); 1176 Append_To (Declarations, Body_Node); 1177 end Add_RACW_Write_Attribute; 1178 1179 ------------------------------ 1180 -- Add_RAS_Access_Attribute -- 1181 ------------------------------ 1182 1183 procedure Add_RAS_Access_Attribute (N : in Node_Id) is 1184 Ras_Type : constant Entity_Id := Defining_Identifier (N); 1185 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); 1186 -- Ras_Type is the access to subprogram type while Fat_Type points to 1187 -- the record type corresponding to a remote access to subprogram type. 1188 1189 Proc_Decls : constant List_Id := New_List; 1190 Proc_Statements : constant List_Id := New_List; 1191 1192 Proc_Spec : Node_Id; 1193 1194 Proc : Node_Id; 1195 1196 Param : Node_Id; 1197 Package_Name : Node_Id; 1198 Subp_Id : Node_Id; 1199 Asynchronous : Node_Id; 1200 Return_Value : Node_Id; 1201 1202 Loc : constant Source_Ptr := Sloc (N); 1203 1204 procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id); 1205 -- Set a field name for the return value 1206 1207 procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id) 1208 is 1209 begin 1210 Append_To (Proc_Statements, 1211 Make_Assignment_Statement (Loc, 1212 Name => 1213 Make_Selected_Component (Loc, 1214 Prefix => New_Occurrence_Of (Return_Value, Loc), 1215 Selector_Name => Make_Identifier (Loc, Field_Name)), 1216 Expression => Value)); 1217 end Set_Field; 1218 1219 -- Start of processing for Add_RAS_Access_Attribute 1220 1221 begin 1222 Param := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 1223 Package_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); 1224 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('N')); 1225 Asynchronous := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); 1226 Return_Value := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 1227 1228 -- Create the object which will be returned of type Fat_Type 1229 1230 Append_To (Proc_Decls, 1231 Make_Object_Declaration (Loc, 1232 Defining_Identifier => Return_Value, 1233 Object_Definition => 1234 New_Occurrence_Of (Fat_Type, Loc))); 1235 1236 -- Initialize the fields of the record type with the appropriate data 1237 1238 Set_Field (Name_Ras, 1239 OK_Convert_To (RTE (RE_Unsigned_64), New_Occurrence_Of (Param, Loc))); 1240 1241 Set_Field (Name_Origin, 1242 Unchecked_Convert_To (Standard_Integer, 1243 Make_Function_Call (Loc, 1244 Name => 1245 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc), 1246 Parameter_Associations => New_List ( 1247 New_Occurrence_Of (Package_Name, Loc))))); 1248 1249 Set_Field (Name_Receiver, 1250 Make_Function_Call (Loc, 1251 Name => 1252 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc), 1253 Parameter_Associations => New_List ( 1254 New_Occurrence_Of (Package_Name, Loc)))); 1255 1256 Set_Field (Name_Subp_Id, 1257 New_Occurrence_Of (Subp_Id, Loc)); 1258 1259 Set_Field (Name_Async, 1260 New_Occurrence_Of (Asynchronous, Loc)); 1261 1262 -- Return the newly created value 1263 1264 Append_To (Proc_Statements, 1265 Make_Return_Statement (Loc, 1266 Expression => 1267 New_Occurrence_Of (Return_Value, Loc))); 1268 1269 Proc := 1270 Make_Defining_Identifier (Loc, 1271 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); 1272 1273 Proc_Spec := 1274 Make_Function_Specification (Loc, 1275 Defining_Unit_Name => Proc, 1276 Parameter_Specifications => New_List ( 1277 Make_Parameter_Specification (Loc, 1278 Defining_Identifier => Param, 1279 Parameter_Type => 1280 New_Occurrence_Of (RTE (RE_Address), Loc)), 1281 1282 Make_Parameter_Specification (Loc, 1283 Defining_Identifier => Package_Name, 1284 Parameter_Type => 1285 New_Occurrence_Of (Standard_String, Loc)), 1286 1287 Make_Parameter_Specification (Loc, 1288 Defining_Identifier => Subp_Id, 1289 Parameter_Type => 1290 New_Occurrence_Of (Standard_Natural, Loc)), 1291 1292 Make_Parameter_Specification (Loc, 1293 Defining_Identifier => Asynchronous, 1294 Parameter_Type => 1295 New_Occurrence_Of (Standard_Boolean, Loc))), 1296 1297 Subtype_Mark => 1298 New_Occurrence_Of (Fat_Type, Loc)); 1299 1300 -- Set the kind and return type of the function to prevent ambiguities 1301 -- between Ras_Type and Fat_Type in subsequent analysis. 1302 1303 Set_Ekind (Proc, E_Function); 1304 Set_Etype (Proc, New_Occurrence_Of (Fat_Type, Loc)); 1305 1306 Discard_Node ( 1307 Make_Subprogram_Body (Loc, 1308 Specification => Proc_Spec, 1309 Declarations => Proc_Decls, 1310 Handled_Statement_Sequence => 1311 Make_Handled_Sequence_Of_Statements (Loc, 1312 Statements => Proc_Statements))); 1313 1314 Set_TSS (Fat_Type, Proc); 1315 1316 end Add_RAS_Access_Attribute; 1317 1318 ----------------------------------- 1319 -- Add_RAS_Dereference_Attribute -- 1320 ----------------------------------- 1321 1322 procedure Add_RAS_Dereference_Attribute (N : in Node_Id) is 1323 Loc : constant Source_Ptr := Sloc (N); 1324 1325 Type_Def : constant Node_Id := Type_Definition (N); 1326 1327 Ras_Type : constant Entity_Id := Defining_Identifier (N); 1328 1329 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); 1330 1331 Proc_Decls : constant List_Id := New_List; 1332 Proc_Statements : constant List_Id := New_List; 1333 1334 Inner_Decls : constant List_Id := New_List; 1335 Inner_Statements : constant List_Id := New_List; 1336 1337 Direct_Statements : constant List_Id := New_List; 1338 1339 Proc : Node_Id; 1340 Proc_Spec : Node_Id; 1341 Param_Specs : constant List_Id := New_List; 1342 Param_Assoc : constant List_Id := New_List; 1343 1344 Pointer : Node_Id; 1345 1346 Converted_Ras : Node_Id; 1347 Target_Partition : Node_Id; 1348 RPC_Receiver : Node_Id; 1349 Subprogram_Id : Node_Id; 1350 Asynchronous : Node_Id; 1351 1352 Is_Function : constant Boolean := 1353 Nkind (Type_Def) = N_Access_Function_Definition; 1354 1355 Spec : constant Node_Id := Type_Def; 1356 1357 Current_Parameter : Node_Id; 1358 1359 begin 1360 -- The way to do it is test if the Ras field is non-null and then if 1361 -- the Origin field is equal to the current partition ID (which is in 1362 -- fact Current_Package'Partition_ID). If this is the case, then it 1363 -- is safe to dereference the Ras field directly rather than 1364 -- performing a remote call. 1365 1366 Pointer := 1367 Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 1368 1369 Target_Partition := 1370 Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 1371 1372 Append_To (Proc_Decls, 1373 Make_Object_Declaration (Loc, 1374 Defining_Identifier => Target_Partition, 1375 Constant_Present => True, 1376 Object_Definition => 1377 New_Occurrence_Of (RTE (RE_Partition_ID), Loc), 1378 Expression => 1379 Unchecked_Convert_To (RTE (RE_Partition_ID), 1380 Make_Selected_Component (Loc, 1381 Prefix => 1382 New_Occurrence_Of (Pointer, Loc), 1383 Selector_Name => 1384 Make_Identifier (Loc, Name_Origin))))); 1385 1386 RPC_Receiver := 1387 Make_Selected_Component (Loc, 1388 Prefix => 1389 New_Occurrence_Of (Pointer, Loc), 1390 Selector_Name => 1391 Make_Identifier (Loc, Name_Receiver)); 1392 1393 Subprogram_Id := 1394 Unchecked_Convert_To (RTE (RE_Subprogram_Id), 1395 Make_Selected_Component (Loc, 1396 Prefix => 1397 New_Occurrence_Of (Pointer, Loc), 1398 Selector_Name => 1399 Make_Identifier (Loc, Name_Subp_Id))); 1400 1401 -- A function is never asynchronous. A procedure may or may not be 1402 -- asynchronous depending on whether a pragma Asynchronous applies 1403 -- on it. Since a RAST may point onto various subprograms, this is 1404 -- only known at runtime so both versions (synchronous and asynchronous) 1405 -- must be built every times it is not a function. 1406 1407 if Is_Function then 1408 Asynchronous := Empty; 1409 1410 else 1411 Asynchronous := 1412 Make_Selected_Component (Loc, 1413 Prefix => 1414 New_Occurrence_Of (Pointer, Loc), 1415 Selector_Name => 1416 Make_Identifier (Loc, Name_Async)); 1417 1418 end if; 1419 1420 if Present (Parameter_Specifications (Type_Def)) then 1421 Current_Parameter := First (Parameter_Specifications (Type_Def)); 1422 1423 while Current_Parameter /= Empty loop 1424 Append_To (Param_Specs, 1425 Make_Parameter_Specification (Loc, 1426 Defining_Identifier => 1427 Make_Defining_Identifier (Loc, 1428 Chars => 1429 Chars (Defining_Identifier (Current_Parameter))), 1430 In_Present => In_Present (Current_Parameter), 1431 Out_Present => Out_Present (Current_Parameter), 1432 Parameter_Type => 1433 New_Copy_Tree (Parameter_Type (Current_Parameter)), 1434 Expression => 1435 New_Copy_Tree (Expression (Current_Parameter)))); 1436 1437 Append_To (Param_Assoc, 1438 Make_Identifier (Loc, 1439 Chars => Chars (Defining_Identifier (Current_Parameter)))); 1440 1441 Next (Current_Parameter); 1442 end loop; 1443 end if; 1444 1445 Proc := 1446 Make_Defining_Identifier (Loc, 1447 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Dereference)); 1448 1449 if Is_Function then 1450 Proc_Spec := 1451 Make_Function_Specification (Loc, 1452 Defining_Unit_Name => Proc, 1453 Parameter_Specifications => Param_Specs, 1454 Subtype_Mark => 1455 New_Occurrence_Of ( 1456 Entity (Subtype_Mark (Spec)), Loc)); 1457 1458 Set_Ekind (Proc, E_Function); 1459 1460 Set_Etype (Proc, 1461 New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc)); 1462 1463 else 1464 Proc_Spec := 1465 Make_Procedure_Specification (Loc, 1466 Defining_Unit_Name => Proc, 1467 Parameter_Specifications => Param_Specs); 1468 1469 Set_Ekind (Proc, E_Procedure); 1470 Set_Etype (Proc, Standard_Void_Type); 1471 end if; 1472 1473 -- Build the calling stubs for the dereference of the RAS 1474 1475 Build_General_Calling_Stubs 1476 (Decls => Inner_Decls, 1477 Statements => Inner_Statements, 1478 Target_Partition => Target_Partition, 1479 RPC_Receiver => RPC_Receiver, 1480 Subprogram_Id => Subprogram_Id, 1481 Asynchronous => Asynchronous, 1482 Is_Known_Non_Asynchronous => Is_Function, 1483 Is_Function => Is_Function, 1484 Spec => Proc_Spec, 1485 Nod => N); 1486 1487 Converted_Ras := 1488 Unchecked_Convert_To (Ras_Type, 1489 OK_Convert_To (RTE (RE_Address), 1490 Make_Selected_Component (Loc, 1491 Prefix => New_Occurrence_Of (Pointer, Loc), 1492 Selector_Name => Make_Identifier (Loc, Name_Ras)))); 1493 1494 if Is_Function then 1495 Append_To (Direct_Statements, 1496 Make_Return_Statement (Loc, 1497 Expression => 1498 Make_Function_Call (Loc, 1499 Name => 1500 Make_Explicit_Dereference (Loc, 1501 Prefix => Converted_Ras), 1502 Parameter_Associations => Param_Assoc))); 1503 1504 else 1505 Append_To (Direct_Statements, 1506 Make_Procedure_Call_Statement (Loc, 1507 Name => 1508 Make_Explicit_Dereference (Loc, 1509 Prefix => Converted_Ras), 1510 Parameter_Associations => Param_Assoc)); 1511 end if; 1512 1513 Prepend_To (Param_Specs, 1514 Make_Parameter_Specification (Loc, 1515 Defining_Identifier => Pointer, 1516 In_Present => True, 1517 Parameter_Type => 1518 New_Occurrence_Of (Fat_Type, Loc))); 1519 1520 Append_To (Proc_Statements, 1521 Make_Implicit_If_Statement (N, 1522 Condition => 1523 Make_And_Then (Loc, 1524 Left_Opnd => 1525 Make_Op_Ne (Loc, 1526 Left_Opnd => 1527 Make_Selected_Component (Loc, 1528 Prefix => New_Occurrence_Of (Pointer, Loc), 1529 Selector_Name => Make_Identifier (Loc, Name_Ras)), 1530 Right_Opnd => 1531 Make_Integer_Literal (Loc, Uint_0)), 1532 1533 Right_Opnd => 1534 Make_Op_Eq (Loc, 1535 Left_Opnd => 1536 New_Occurrence_Of (Target_Partition, Loc), 1537 Right_Opnd => 1538 Make_Function_Call (Loc, 1539 New_Occurrence_Of ( 1540 RTE (RE_Get_Local_Partition_Id), Loc)))), 1541 1542 Then_Statements => 1543 Direct_Statements, 1544 1545 Else_Statements => New_List ( 1546 Make_Block_Statement (Loc, 1547 Declarations => Inner_Decls, 1548 Handled_Statement_Sequence => 1549 Make_Handled_Sequence_Of_Statements (Loc, 1550 Statements => Inner_Statements))))); 1551 1552 Discard_Node ( 1553 Make_Subprogram_Body (Loc, 1554 Specification => Proc_Spec, 1555 Declarations => Proc_Decls, 1556 Handled_Statement_Sequence => 1557 Make_Handled_Sequence_Of_Statements (Loc, 1558 Statements => Proc_Statements))); 1559 1560 Set_TSS (Fat_Type, Defining_Unit_Name (Proc_Spec)); 1561 1562 end Add_RAS_Dereference_Attribute; 1563 1564 ----------------------- 1565 -- Add_RAST_Features -- 1566 ----------------------- 1567 1568 procedure Add_RAST_Features (Vis_Decl : Node_Id) is 1569 begin 1570 -- Do not add attributes more than once in any case. This should 1571 -- be replaced by an assert or this comment removed if we decide 1572 -- that this is normal to be called several times ??? 1573 1574 if Present (TSS (Equivalent_Type (Defining_Identifier (Vis_Decl)), 1575 TSS_RAS_Access)) 1576 then 1577 return; 1578 end if; 1579 1580 Add_RAS_Dereference_Attribute (Vis_Decl); 1581 Add_RAS_Access_Attribute (Vis_Decl); 1582 end Add_RAST_Features; 1583 1584 ----------------------------------------- 1585 -- Add_Receiving_Stubs_To_Declarations -- 1586 ----------------------------------------- 1587 1588 procedure Add_Receiving_Stubs_To_Declarations 1589 (Pkg_Spec : in Node_Id; 1590 Decls : in List_Id) 1591 is 1592 Loc : constant Source_Ptr := Sloc (Pkg_Spec); 1593 1594 Stream_Parameter : Node_Id; 1595 Result_Parameter : Node_Id; 1596 1597 Pkg_RPC_Receiver : Node_Id; 1598 Pkg_RPC_Receiver_Spec : Node_Id; 1599 Pkg_RPC_Receiver_Decls : List_Id; 1600 Pkg_RPC_Receiver_Statements : List_Id; 1601 Pkg_RPC_Receiver_Cases : constant List_Id := New_List; 1602 Pkg_RPC_Receiver_Body : Node_Id; 1603 -- A Pkg_RPC_Receiver is built to decode the request 1604 1605 Subp_Id : Node_Id; 1606 -- Subprogram_Id as read from the incoming stream 1607 1608 Current_Declaration : Node_Id; 1609 Current_Subprogram_Number : Int := 0; 1610 Current_Stubs : Node_Id; 1611 1612 Actuals : List_Id; 1613 1614 Dummy_Register_Name : Name_Id; 1615 Dummy_Register_Spec : Node_Id; 1616 Dummy_Register_Decl : Node_Id; 1617 Dummy_Register_Body : Node_Id; 1618 1619 begin 1620 -- Building receiving stubs consist in several operations: 1621 1622 -- - a package RPC receiver must be built. This subprogram 1623 -- will get a Subprogram_Id from the incoming stream 1624 -- and will dispatch the call to the right subprogram 1625 1626 -- - a receiving stub for any subprogram visible in the package 1627 -- spec. This stub will read all the parameters from the stream, 1628 -- and put the result as well as the exception occurrence in the 1629 -- output stream 1630 1631 -- - a dummy package with an empty spec and a body made of an 1632 -- elaboration part, whose job is to register the receiving 1633 -- part of this RCI package on the name server. This is done 1634 -- by calling System.Partition_Interface.Register_Receiving_Stub 1635 1636 Stream_Parameter := 1637 Make_Defining_Identifier (Loc, New_Internal_Name ('S')); 1638 Result_Parameter := 1639 Make_Defining_Identifier (Loc, New_Internal_Name ('R')); 1640 Subp_Id := 1641 Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 1642 1643 Pkg_RPC_Receiver := 1644 Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 1645 1646 -- The parameters of the package RPC receiver are made of two 1647 -- streams, an input one and an output one. 1648 1649 Pkg_RPC_Receiver_Spec := 1650 Build_RPC_Receiver_Specification 1651 (RPC_Receiver => Pkg_RPC_Receiver, 1652 Stream_Parameter => Stream_Parameter, 1653 Result_Parameter => Result_Parameter); 1654 1655 Pkg_RPC_Receiver_Decls := New_List ( 1656 Make_Object_Declaration (Loc, 1657 Defining_Identifier => Subp_Id, 1658 Object_Definition => 1659 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))); 1660 1661 Pkg_RPC_Receiver_Statements := New_List ( 1662 Make_Attribute_Reference (Loc, 1663 Prefix => 1664 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), 1665 Attribute_Name => 1666 Name_Read, 1667 Expressions => New_List ( 1668 New_Occurrence_Of (Stream_Parameter, Loc), 1669 New_Occurrence_Of (Subp_Id, Loc)))); 1670 1671 -- For each subprogram, the receiving stub will be built and a 1672 -- case statement will be made on the Subprogram_Id to dispatch 1673 -- to the right subprogram. 1674 1675 Current_Declaration := First (Visible_Declarations (Pkg_Spec)); 1676 1677 while Current_Declaration /= Empty loop 1678 1679 if Nkind (Current_Declaration) = N_Subprogram_Declaration 1680 and then Comes_From_Source (Current_Declaration) 1681 then 1682 pragma Assert (Current_Subprogram_Number = 1683 Get_Subprogram_Id (Defining_Unit_Name (Specification ( 1684 Current_Declaration)))); 1685 1686 Current_Stubs := 1687 Build_Subprogram_Receiving_Stubs 1688 (Vis_Decl => Current_Declaration, 1689 Asynchronous => 1690 Nkind (Specification (Current_Declaration)) = 1691 N_Procedure_Specification 1692 and then Is_Asynchronous 1693 (Defining_Unit_Name (Specification 1694 (Current_Declaration)))); 1695 1696 Append_To (Decls, Current_Stubs); 1697 1698 Analyze (Current_Stubs); 1699 1700 Actuals := New_List (New_Occurrence_Of (Stream_Parameter, Loc)); 1701 1702 if Nkind (Specification (Current_Declaration)) 1703 = N_Function_Specification 1704 or else 1705 not Is_Asynchronous ( 1706 Defining_Entity (Specification (Current_Declaration))) 1707 then 1708 -- An asynchronous procedure does not want an output parameter 1709 -- since no result and no exception will ever be returned. 1710 1711 Append_To (Actuals, 1712 New_Occurrence_Of (Result_Parameter, Loc)); 1713 1714 end if; 1715 1716 Append_To (Pkg_RPC_Receiver_Cases, 1717 Make_Case_Statement_Alternative (Loc, 1718 Discrete_Choices => 1719 New_List ( 1720 Make_Integer_Literal (Loc, Current_Subprogram_Number)), 1721 1722 Statements => 1723 New_List ( 1724 Make_Procedure_Call_Statement (Loc, 1725 Name => 1726 New_Occurrence_Of ( 1727 Defining_Entity (Current_Stubs), Loc), 1728 Parameter_Associations => 1729 Actuals)))); 1730 1731 Current_Subprogram_Number := Current_Subprogram_Number + 1; 1732 end if; 1733 1734 Next (Current_Declaration); 1735 end loop; 1736 1737 -- If we receive an invalid Subprogram_Id, it is best to do nothing 1738 -- rather than raising an exception since we do not want someone 1739 -- to crash a remote partition by sending invalid subprogram ids. 1740 -- This is consistent with the other parts of the case statement 1741 -- since even in presence of incorrect parameters in the stream, 1742 -- every exception will be caught and (if the subprogram is not an 1743 -- APC) put into the result stream and sent away. 1744 1745 Append_To (Pkg_RPC_Receiver_Cases, 1746 Make_Case_Statement_Alternative (Loc, 1747 Discrete_Choices => 1748 New_List (Make_Others_Choice (Loc)), 1749 Statements => 1750 New_List (Make_Null_Statement (Loc)))); 1751 1752 Append_To (Pkg_RPC_Receiver_Statements, 1753 Make_Case_Statement (Loc, 1754 Expression => 1755 New_Occurrence_Of (Subp_Id, Loc), 1756 Alternatives => Pkg_RPC_Receiver_Cases)); 1757 1758 Pkg_RPC_Receiver_Body := 1759 Make_Subprogram_Body (Loc, 1760 Specification => Pkg_RPC_Receiver_Spec, 1761 Declarations => Pkg_RPC_Receiver_Decls, 1762 Handled_Statement_Sequence => 1763 Make_Handled_Sequence_Of_Statements (Loc, 1764 Statements => Pkg_RPC_Receiver_Statements)); 1765 1766 Append_To (Decls, Pkg_RPC_Receiver_Body); 1767 Analyze (Pkg_RPC_Receiver_Body); 1768 1769 -- Construction of the dummy package used to register the package 1770 -- receiving stubs on the nameserver. 1771 1772 Dummy_Register_Name := New_Internal_Name ('P'); 1773 1774 Dummy_Register_Spec := 1775 Make_Package_Specification (Loc, 1776 Defining_Unit_Name => 1777 Make_Defining_Identifier (Loc, Dummy_Register_Name), 1778 Visible_Declarations => No_List, 1779 End_Label => Empty); 1780 1781 Dummy_Register_Decl := 1782 Make_Package_Declaration (Loc, 1783 Specification => Dummy_Register_Spec); 1784 1785 Append_To (Decls, 1786 Dummy_Register_Decl); 1787 Analyze (Dummy_Register_Decl); 1788 1789 Dummy_Register_Body := 1790 Make_Package_Body (Loc, 1791 Defining_Unit_Name => 1792 Make_Defining_Identifier (Loc, Dummy_Register_Name), 1793 Declarations => No_List, 1794 1795 Handled_Statement_Sequence => 1796 Make_Handled_Sequence_Of_Statements (Loc, 1797 Statements => New_List ( 1798 Make_Procedure_Call_Statement (Loc, 1799 Name => 1800 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc), 1801 1802 Parameter_Associations => New_List ( 1803 Make_String_Literal (Loc, 1804 Strval => Get_Pkg_Name_String_Id (Pkg_Spec)), 1805 Make_Attribute_Reference (Loc, 1806 Prefix => 1807 New_Occurrence_Of (Pkg_RPC_Receiver, Loc), 1808 Attribute_Name => 1809 Name_Unrestricted_Access), 1810 Make_Attribute_Reference (Loc, 1811 Prefix => 1812 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), 1813 Attribute_Name => 1814 Name_Version)))))); 1815 1816 Append_To (Decls, Dummy_Register_Body); 1817 Analyze (Dummy_Register_Body); 1818 end Add_Receiving_Stubs_To_Declarations; 1819 1820 ------------------- 1821 -- Add_Stub_Type -- 1822 ------------------- 1823 1824 procedure Add_Stub_Type 1825 (Designated_Type : in Entity_Id; 1826 RACW_Type : in Entity_Id; 1827 Decls : in List_Id; 1828 Stub_Type : out Entity_Id; 1829 Stub_Type_Access : out Entity_Id; 1830 Object_RPC_Receiver : out Entity_Id; 1831 Existing : out Boolean) 1832 is 1833 Loc : constant Source_Ptr := Sloc (RACW_Type); 1834 1835 Stub_Elements : constant Stub_Structure := 1836 Stubs_Table.Get (Designated_Type); 1837 1838 Stub_Type_Declaration : Node_Id; 1839 Stub_Type_Access_Declaration : Node_Id; 1840 Object_RPC_Receiver_Declaration : Node_Id; 1841 1842 RPC_Receiver_Stream : Entity_Id; 1843 RPC_Receiver_Result : Entity_Id; 1844 1845 begin 1846 if Stub_Elements /= Empty_Stub_Structure then 1847 Stub_Type := Stub_Elements.Stub_Type; 1848 Stub_Type_Access := Stub_Elements.Stub_Type_Access; 1849 Object_RPC_Receiver := Stub_Elements.Object_RPC_Receiver; 1850 Existing := True; 1851 return; 1852 end if; 1853 1854 Existing := False; 1855 Stub_Type := 1856 Make_Defining_Identifier (Loc, New_Internal_Name ('S')); 1857 Stub_Type_Access := 1858 Make_Defining_Identifier (Loc, New_Internal_Name ('S')); 1859 Object_RPC_Receiver := 1860 Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 1861 RPC_Receiver_Stream := 1862 Make_Defining_Identifier (Loc, New_Internal_Name ('S')); 1863 RPC_Receiver_Result := 1864 Make_Defining_Identifier (Loc, New_Internal_Name ('S')); 1865 Stubs_Table.Set (Designated_Type, 1866 (Stub_Type => Stub_Type, 1867 Stub_Type_Access => Stub_Type_Access, 1868 Object_RPC_Receiver => Object_RPC_Receiver, 1869 RPC_Receiver_Stream => RPC_Receiver_Stream, 1870 RPC_Receiver_Result => RPC_Receiver_Result, 1871 RACW_Type => RACW_Type)); 1872 1873 -- The stub type definition below must match exactly the one in 1874 -- s-parint.ads, since unchecked conversions will be used in 1875 -- s-parint.adb to modify pointers passed to Get_Unique_Remote_Pointer. 1876 1877 Stub_Type_Declaration := 1878 Make_Full_Type_Declaration (Loc, 1879 Defining_Identifier => Stub_Type, 1880 Type_Definition => 1881 Make_Record_Definition (Loc, 1882 Tagged_Present => True, 1883 Limited_Present => True, 1884 Component_List => 1885 Make_Component_List (Loc, 1886 Component_Items => New_List ( 1887 1888 Make_Component_Declaration (Loc, 1889 Defining_Identifier => 1890 Make_Defining_Identifier (Loc, Name_Origin), 1891 Component_Definition => 1892 Make_Component_Definition (Loc, 1893 Aliased_Present => False, 1894 Subtype_Indication => 1895 New_Occurrence_Of (RTE (RE_Partition_ID), Loc))), 1896 1897 Make_Component_Declaration (Loc, 1898 Defining_Identifier => 1899 Make_Defining_Identifier (Loc, Name_Receiver), 1900 Component_Definition => 1901 Make_Component_Definition (Loc, 1902 Aliased_Present => False, 1903 Subtype_Indication => 1904 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), 1905 1906 Make_Component_Declaration (Loc, 1907 Defining_Identifier => 1908 Make_Defining_Identifier (Loc, Name_Addr), 1909 Component_Definition => 1910 Make_Component_Definition (Loc, 1911 Aliased_Present => False, 1912 Subtype_Indication => 1913 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), 1914 1915 Make_Component_Declaration (Loc, 1916 Defining_Identifier => 1917 Make_Defining_Identifier (Loc, Name_Asynchronous), 1918 Component_Definition => 1919 Make_Component_Definition (Loc, 1920 Aliased_Present => False, 1921 Subtype_Indication => 1922 New_Occurrence_Of (Standard_Boolean, Loc))))))); 1923 1924 Append_To (Decls, Stub_Type_Declaration); 1925 Analyze (Stub_Type_Declaration); 1926 1927 -- This is in no way a type derivation, but we fake it to make 1928 -- sure that the dispatching table gets built with the corresponding 1929 -- primitive operations at the right place. 1930 1931 Derive_Subprograms (Parent_Type => Designated_Type, 1932 Derived_Type => Stub_Type); 1933 1934 Stub_Type_Access_Declaration := 1935 Make_Full_Type_Declaration (Loc, 1936 Defining_Identifier => Stub_Type_Access, 1937 Type_Definition => 1938 Make_Access_To_Object_Definition (Loc, 1939 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc))); 1940 1941 Append_To (Decls, Stub_Type_Access_Declaration); 1942 Analyze (Stub_Type_Access_Declaration); 1943 1944 Object_RPC_Receiver_Declaration := 1945 Make_Subprogram_Declaration (Loc, 1946 Build_RPC_Receiver_Specification ( 1947 RPC_Receiver => Object_RPC_Receiver, 1948 Stream_Parameter => RPC_Receiver_Stream, 1949 Result_Parameter => RPC_Receiver_Result)); 1950 1951 Append_To (Decls, Object_RPC_Receiver_Declaration); 1952 end Add_Stub_Type; 1953 1954 --------------------------------- 1955 -- Build_General_Calling_Stubs -- 1956 --------------------------------- 1957 1958 procedure Build_General_Calling_Stubs 1959 (Decls : List_Id; 1960 Statements : List_Id; 1961 Target_Partition : Entity_Id; 1962 RPC_Receiver : Node_Id; 1963 Subprogram_Id : Node_Id; 1964 Asynchronous : Node_Id := Empty; 1965 Is_Known_Asynchronous : Boolean := False; 1966 Is_Known_Non_Asynchronous : Boolean := False; 1967 Is_Function : Boolean; 1968 Spec : Node_Id; 1969 Object_Type : Entity_Id := Empty; 1970 Nod : Node_Id) 1971 is 1972 Loc : constant Source_Ptr := Sloc (Nod); 1973 1974 Stream_Parameter : Node_Id; 1975 -- Name of the stream used to transmit parameters to the remote package 1976 1977 Result_Parameter : Node_Id; 1978 -- Name of the result parameter (in non-APC cases) which get the 1979 -- result of the remote subprogram. 1980 1981 Exception_Return_Parameter : Node_Id; 1982 -- Name of the parameter which will hold the exception sent by the 1983 -- remote subprogram. 1984 1985 Current_Parameter : Node_Id; 1986 -- Current parameter being handled 1987 1988 Ordered_Parameters_List : constant List_Id := 1989 Build_Ordered_Parameters_List (Spec); 1990 1991 Asynchronous_Statements : List_Id := No_List; 1992 Non_Asynchronous_Statements : List_Id := No_List; 1993 -- Statements specifics to the Asynchronous/Non-Asynchronous cases. 1994 1995 Extra_Formal_Statements : constant List_Id := New_List; 1996 -- List of statements for extra formal parameters. It will appear after 1997 -- the regular statements for writing out parameters. 1998 1999 begin 2000 -- The general form of a calling stub for a given subprogram is: 2001 2002 -- procedure X (...) is 2003 -- P : constant Partition_ID := RCI_Cache.Get_Active_Partition_ID; 2004 -- Stream, Result : aliased System.RPC.Params_Stream_Type (0); 2005 -- begin 2006 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver 2007 -- comes from RCI_Cache.Get_RCI_Package_Receiver) 2008 -- Put_Subprogram_Id_In_Stream; 2009 -- Put_Parameters_In_Stream; 2010 -- Do_RPC (Stream, Result); 2011 -- Read_Exception_Occurrence_From_Result; Raise_It; 2012 -- Read_Out_Parameters_And_Function_Return_From_Stream; 2013 -- end X; 2014 2015 -- There are some variations: Do_APC is called for an asynchronous 2016 -- procedure and the part after the call is completely ommitted 2017 -- as well as the declaration of Result. For a function call, 2018 -- 'Input is always used to read the result even if it is constrained. 2019 2020 Stream_Parameter := 2021 Make_Defining_Identifier (Loc, New_Internal_Name ('S')); 2022 2023 Append_To (Decls, 2024 Make_Object_Declaration (Loc, 2025 Defining_Identifier => Stream_Parameter, 2026 Aliased_Present => True, 2027 Object_Definition => 2028 Make_Subtype_Indication (Loc, 2029 Subtype_Mark => 2030 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), 2031 Constraint => 2032 Make_Index_Or_Discriminant_Constraint (Loc, 2033 Constraints => 2034 New_List (Make_Integer_Literal (Loc, 0)))))); 2035 2036 if not Is_Known_Asynchronous then 2037 Result_Parameter := 2038 Make_Defining_Identifier (Loc, New_Internal_Name ('R')); 2039 2040 Append_To (Decls, 2041 Make_Object_Declaration (Loc, 2042 Defining_Identifier => Result_Parameter, 2043 Aliased_Present => True, 2044 Object_Definition => 2045 Make_Subtype_Indication (Loc, 2046 Subtype_Mark => 2047 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), 2048 Constraint => 2049 Make_Index_Or_Discriminant_Constraint (Loc, 2050 Constraints => 2051 New_List (Make_Integer_Literal (Loc, 0)))))); 2052 2053 Exception_Return_Parameter := 2054 Make_Defining_Identifier (Loc, New_Internal_Name ('E')); 2055 2056 Append_To (Decls, 2057 Make_Object_Declaration (Loc, 2058 Defining_Identifier => Exception_Return_Parameter, 2059 Object_Definition => 2060 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); 2061 2062 else 2063 Result_Parameter := Empty; 2064 Exception_Return_Parameter := Empty; 2065 end if; 2066 2067 -- Put first the RPC receiver corresponding to the remote package 2068 2069 Append_To (Statements, 2070 Make_Attribute_Reference (Loc, 2071 Prefix => 2072 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), 2073 Attribute_Name => Name_Write, 2074 Expressions => New_List ( 2075 Make_Attribute_Reference (Loc, 2076 Prefix => 2077 New_Occurrence_Of (Stream_Parameter, Loc), 2078 Attribute_Name => 2079 Name_Access), 2080 RPC_Receiver))); 2081 2082 -- Then put the Subprogram_Id of the subprogram we want to call in 2083 -- the stream. 2084 2085 Append_To (Statements, 2086 Make_Attribute_Reference (Loc, 2087 Prefix => 2088 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), 2089 Attribute_Name => 2090 Name_Write, 2091 Expressions => New_List ( 2092 Make_Attribute_Reference (Loc, 2093 Prefix => 2094 New_Occurrence_Of (Stream_Parameter, Loc), 2095 Attribute_Name => Name_Access), 2096 Subprogram_Id))); 2097 2098 Current_Parameter := First (Ordered_Parameters_List); 2099 2100 while Current_Parameter /= Empty loop 2101 2102 declare 2103 Typ : constant Node_Id := 2104 Parameter_Type (Current_Parameter); 2105 Etyp : Entity_Id; 2106 Constrained : Boolean; 2107 Value : Node_Id; 2108 Extra_Parameter : Entity_Id; 2109 2110 begin 2111 2112 if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then 2113 2114 -- In the case of a controlling formal argument, we marshall 2115 -- its addr field rather than the local stub. 2116 2117 Append_To (Statements, 2118 Pack_Node_Into_Stream (Loc, 2119 Stream => Stream_Parameter, 2120 Object => 2121 Make_Selected_Component (Loc, 2122 Prefix => 2123 New_Occurrence_Of ( 2124 Defining_Identifier (Current_Parameter), Loc), 2125 Selector_Name => 2126 Make_Identifier (Loc, Name_Addr)), 2127 Etyp => RTE (RE_Unsigned_64))); 2128 2129 else 2130 Value := New_Occurrence_Of 2131 (Defining_Identifier (Current_Parameter), Loc); 2132 2133 -- Access type parameters are transmitted as in out 2134 -- parameters. However, a dereference is needed so that 2135 -- we marshall the designated object. 2136 2137 if Nkind (Typ) = N_Access_Definition then 2138 Value := Make_Explicit_Dereference (Loc, Value); 2139 Etyp := Etype (Subtype_Mark (Typ)); 2140 else 2141 Etyp := Etype (Typ); 2142 end if; 2143 2144 Constrained := 2145 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); 2146 2147 -- Any parameter but unconstrained out parameters are 2148 -- transmitted to the peer. 2149 2150 if In_Present (Current_Parameter) 2151 or else not Out_Present (Current_Parameter) 2152 or else not Constrained 2153 then 2154 Append_To (Statements, 2155 Make_Attribute_Reference (Loc, 2156 Prefix => 2157 New_Occurrence_Of (Etyp, Loc), 2158 Attribute_Name => Output_From_Constrained (Constrained), 2159 Expressions => New_List ( 2160 Make_Attribute_Reference (Loc, 2161 Prefix => 2162 New_Occurrence_Of (Stream_Parameter, Loc), 2163 Attribute_Name => Name_Access), 2164 Value))); 2165 end if; 2166 end if; 2167 2168 -- If the current parameter has a dynamic constrained status, 2169 -- then this status is transmitted as well. 2170 -- This should be done for accessibility as well ??? 2171 2172 if Nkind (Typ) /= N_Access_Definition 2173 and then Need_Extra_Constrained (Current_Parameter) 2174 then 2175 -- In this block, we do not use the extra formal that has been 2176 -- created because it does not exist at the time of expansion 2177 -- when building calling stubs for remote access to subprogram 2178 -- types. We create an extra variable of this type and push it 2179 -- in the stream after the regular parameters. 2180 2181 Extra_Parameter := Make_Defining_Identifier 2182 (Loc, New_Internal_Name ('P')); 2183 2184 Append_To (Decls, 2185 Make_Object_Declaration (Loc, 2186 Defining_Identifier => Extra_Parameter, 2187 Constant_Present => True, 2188 Object_Definition => 2189 New_Occurrence_Of (Standard_Boolean, Loc), 2190 Expression => 2191 Make_Attribute_Reference (Loc, 2192 Prefix => 2193 New_Occurrence_Of ( 2194 Defining_Identifier (Current_Parameter), Loc), 2195 Attribute_Name => Name_Constrained))); 2196 2197 Append_To (Extra_Formal_Statements, 2198 Make_Attribute_Reference (Loc, 2199 Prefix => 2200 New_Occurrence_Of (Standard_Boolean, Loc), 2201 Attribute_Name => 2202 Name_Write, 2203 Expressions => New_List ( 2204 Make_Attribute_Reference (Loc, 2205 Prefix => 2206 New_Occurrence_Of (Stream_Parameter, Loc), 2207 Attribute_Name => 2208 Name_Access), 2209 New_Occurrence_Of (Extra_Parameter, Loc)))); 2210 end if; 2211 2212 Next (Current_Parameter); 2213 end; 2214 end loop; 2215 2216 -- Append the formal statements list to the statements 2217 2218 Append_List_To (Statements, Extra_Formal_Statements); 2219 2220 if not Is_Known_Non_Asynchronous then 2221 2222 -- Build the call to System.RPC.Do_APC 2223 2224 Asynchronous_Statements := New_List ( 2225 Make_Procedure_Call_Statement (Loc, 2226 Name => 2227 New_Occurrence_Of (RTE (RE_Do_Apc), Loc), 2228 Parameter_Associations => New_List ( 2229 New_Occurrence_Of (Target_Partition, Loc), 2230 Make_Attribute_Reference (Loc, 2231 Prefix => 2232 New_Occurrence_Of (Stream_Parameter, Loc), 2233 Attribute_Name => 2234 Name_Access)))); 2235 else 2236 Asynchronous_Statements := No_List; 2237 end if; 2238 2239 if not Is_Known_Asynchronous then 2240 2241 -- Build the call to System.RPC.Do_RPC 2242 2243 Non_Asynchronous_Statements := New_List ( 2244 Make_Procedure_Call_Statement (Loc, 2245 Name => 2246 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc), 2247 Parameter_Associations => New_List ( 2248 New_Occurrence_Of (Target_Partition, Loc), 2249 2250 Make_Attribute_Reference (Loc, 2251 Prefix => 2252 New_Occurrence_Of (Stream_Parameter, Loc), 2253 Attribute_Name => 2254 Name_Access), 2255 2256 Make_Attribute_Reference (Loc, 2257 Prefix => 2258 New_Occurrence_Of (Result_Parameter, Loc), 2259 Attribute_Name => 2260 Name_Access)))); 2261 2262 -- Read the exception occurrence from the result stream and 2263 -- reraise it. It does no harm if this is a Null_Occurrence since 2264 -- this does nothing. 2265 2266 Append_To (Non_Asynchronous_Statements, 2267 Make_Attribute_Reference (Loc, 2268 Prefix => 2269 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), 2270 2271 Attribute_Name => 2272 Name_Read, 2273 2274 Expressions => New_List ( 2275 Make_Attribute_Reference (Loc, 2276 Prefix => 2277 New_Occurrence_Of (Result_Parameter, Loc), 2278 Attribute_Name => 2279 Name_Access), 2280 New_Occurrence_Of (Exception_Return_Parameter, Loc)))); 2281 2282 Append_To (Non_Asynchronous_Statements, 2283 Make_Procedure_Call_Statement (Loc, 2284 Name => 2285 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), 2286 Parameter_Associations => New_List ( 2287 New_Occurrence_Of (Exception_Return_Parameter, Loc)))); 2288 2289 if Is_Function then 2290 2291 -- If this is a function call, then read the value and return 2292 -- it. The return value is written/read using 'Output/'Input. 2293 2294 Append_To (Non_Asynchronous_Statements, 2295 Make_Tag_Check (Loc, 2296 Make_Return_Statement (Loc, 2297 Expression => 2298 Make_Attribute_Reference (Loc, 2299 Prefix => 2300 New_Occurrence_Of ( 2301 Etype (Subtype_Mark (Spec)), Loc), 2302 2303 Attribute_Name => Name_Input, 2304 2305 Expressions => New_List ( 2306 Make_Attribute_Reference (Loc, 2307 Prefix => 2308 New_Occurrence_Of (Result_Parameter, Loc), 2309 Attribute_Name => Name_Access)))))); 2310 2311 else 2312 -- Loop around parameters and assign out (or in out) parameters. 2313 -- In the case of RACW, controlling arguments cannot possibly 2314 -- have changed since they are remote, so we do not read them 2315 -- from the stream. 2316 2317 Current_Parameter := 2318 First (Ordered_Parameters_List); 2319 2320 while Current_Parameter /= Empty loop 2321 2322 declare 2323 Typ : constant Node_Id := 2324 Parameter_Type (Current_Parameter); 2325 Etyp : Entity_Id; 2326 Value : Node_Id; 2327 begin 2328 Value := New_Occurrence_Of 2329 (Defining_Identifier (Current_Parameter), Loc); 2330 2331 if Nkind (Typ) = N_Access_Definition then 2332 Value := Make_Explicit_Dereference (Loc, Value); 2333 Etyp := Etype (Subtype_Mark (Typ)); 2334 else 2335 Etyp := Etype (Typ); 2336 end if; 2337 2338 if (Out_Present (Current_Parameter) 2339 or else Nkind (Typ) = N_Access_Definition) 2340 and then Etyp /= Object_Type 2341 then 2342 Append_To (Non_Asynchronous_Statements, 2343 Make_Attribute_Reference (Loc, 2344 Prefix => 2345 New_Occurrence_Of (Etyp, Loc), 2346 2347 Attribute_Name => Name_Read, 2348 2349 Expressions => New_List ( 2350 Make_Attribute_Reference (Loc, 2351 Prefix => 2352 New_Occurrence_Of (Result_Parameter, Loc), 2353 Attribute_Name => 2354 Name_Access), 2355 Value))); 2356 end if; 2357 end; 2358 2359 Next (Current_Parameter); 2360 end loop; 2361 end if; 2362 end if; 2363 2364 if Is_Known_Asynchronous then 2365 Append_List_To (Statements, Asynchronous_Statements); 2366 2367 elsif Is_Known_Non_Asynchronous then 2368 Append_List_To (Statements, Non_Asynchronous_Statements); 2369 2370 else 2371 pragma Assert (Asynchronous /= Empty); 2372 Prepend_To (Asynchronous_Statements, 2373 Make_Attribute_Reference (Loc, 2374 Prefix => New_Occurrence_Of (Standard_Boolean, Loc), 2375 Attribute_Name => Name_Write, 2376 Expressions => New_List ( 2377 Make_Attribute_Reference (Loc, 2378 Prefix => New_Occurrence_Of (Stream_Parameter, Loc), 2379 Attribute_Name => Name_Access), 2380 New_Occurrence_Of (Standard_True, Loc)))); 2381 Prepend_To (Non_Asynchronous_Statements, 2382 Make_Attribute_Reference (Loc, 2383 Prefix => New_Occurrence_Of (Standard_Boolean, Loc), 2384 Attribute_Name => Name_Write, 2385 Expressions => New_List ( 2386 Make_Attribute_Reference (Loc, 2387 Prefix => New_Occurrence_Of (Stream_Parameter, Loc), 2388 Attribute_Name => Name_Access), 2389 New_Occurrence_Of (Standard_False, Loc)))); 2390 Append_To (Statements, 2391 Make_Implicit_If_Statement (Nod, 2392 Condition => Asynchronous, 2393 Then_Statements => Asynchronous_Statements, 2394 Else_Statements => Non_Asynchronous_Statements)); 2395 end if; 2396 end Build_General_Calling_Stubs; 2397 2398 ----------------------------------- 2399 -- Build_Ordered_Parameters_List -- 2400 ----------------------------------- 2401 2402 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is 2403 Constrained_List : List_Id; 2404 Unconstrained_List : List_Id; 2405 Current_Parameter : Node_Id; 2406 2407 begin 2408 if not Present (Parameter_Specifications (Spec)) then 2409 return New_List; 2410 end if; 2411 2412 Constrained_List := New_List; 2413 Unconstrained_List := New_List; 2414 2415 -- Loop through the parameters and add them to the right list 2416 2417 Current_Parameter := First (Parameter_Specifications (Spec)); 2418 while Current_Parameter /= Empty loop 2419 2420 if Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition 2421 or else 2422 Is_Constrained (Etype (Parameter_Type (Current_Parameter))) 2423 or else 2424 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))) 2425 then 2426 Append_To (Constrained_List, New_Copy (Current_Parameter)); 2427 else 2428 Append_To (Unconstrained_List, New_Copy (Current_Parameter)); 2429 end if; 2430 2431 Next (Current_Parameter); 2432 end loop; 2433 2434 -- Unconstrained parameters are returned first 2435 2436 Append_List_To (Unconstrained_List, Constrained_List); 2437 2438 return Unconstrained_List; 2439 2440 end Build_Ordered_Parameters_List; 2441 2442 ---------------------------------- 2443 -- Build_Passive_Partition_Stub -- 2444 ---------------------------------- 2445 2446 procedure Build_Passive_Partition_Stub (U : Node_Id) is 2447 Pkg_Spec : Node_Id; 2448 L : List_Id; 2449 Reg : Node_Id; 2450 Loc : constant Source_Ptr := Sloc (U); 2451 2452 begin 2453 -- Verify that the implementation supports distribution, by accessing 2454 -- a type defined in the proper version of system.rpc 2455 2456 declare 2457 Dist_OK : Entity_Id; 2458 pragma Warnings (Off, Dist_OK); 2459 2460 begin 2461 Dist_OK := RTE (RE_Params_Stream_Type); 2462 end; 2463 2464 -- Use body if present, spec otherwise 2465 2466 if Nkind (U) = N_Package_Declaration then 2467 Pkg_Spec := Specification (U); 2468 L := Visible_Declarations (Pkg_Spec); 2469 else 2470 Pkg_Spec := Parent (Corresponding_Spec (U)); 2471 L := Declarations (U); 2472 end if; 2473 2474 Reg := 2475 Make_Procedure_Call_Statement (Loc, 2476 Name => 2477 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), 2478 Parameter_Associations => New_List ( 2479 Make_String_Literal (Loc, Get_Pkg_Name_String_Id (Pkg_Spec)), 2480 Make_Attribute_Reference (Loc, 2481 Prefix => 2482 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), 2483 Attribute_Name => 2484 Name_Version))); 2485 Append_To (L, Reg); 2486 Analyze (Reg); 2487 end Build_Passive_Partition_Stub; 2488 2489 -------------------------------------- 2490 -- Build_RPC_Receiver_Specification -- 2491 -------------------------------------- 2492 2493 function Build_RPC_Receiver_Specification 2494 (RPC_Receiver : Entity_Id; 2495 Stream_Parameter : Entity_Id; 2496 Result_Parameter : Entity_Id) 2497 return Node_Id 2498 is 2499 Loc : constant Source_Ptr := Sloc (RPC_Receiver); 2500 2501 begin 2502 return 2503 Make_Procedure_Specification (Loc, 2504 Defining_Unit_Name => RPC_Receiver, 2505 Parameter_Specifications => New_List ( 2506 Make_Parameter_Specification (Loc, 2507 Defining_Identifier => Stream_Parameter, 2508 Parameter_Type => 2509 Make_Access_Definition (Loc, 2510 Subtype_Mark => 2511 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), 2512 2513 Make_Parameter_Specification (Loc, 2514 Defining_Identifier => Result_Parameter, 2515 Parameter_Type => 2516 Make_Access_Definition (Loc, 2517 Subtype_Mark => 2518 New_Occurrence_Of 2519 (RTE (RE_Params_Stream_Type), Loc))))); 2520 end Build_RPC_Receiver_Specification; 2521 2522 ------------------------------------ 2523 -- Build_Subprogram_Calling_Stubs -- 2524 ------------------------------------ 2525 2526 function Build_Subprogram_Calling_Stubs 2527 (Vis_Decl : Node_Id; 2528 Subp_Id : Int; 2529 Asynchronous : Boolean; 2530 Dynamically_Asynchronous : Boolean := False; 2531 Stub_Type : Entity_Id := Empty; 2532 Locator : Entity_Id := Empty; 2533 New_Name : Name_Id := No_Name) 2534 return Node_Id 2535 is 2536 Loc : constant Source_Ptr := Sloc (Vis_Decl); 2537 2538 Target_Partition : Node_Id; 2539 -- Contains the name of the target partition 2540 2541 Decls : constant List_Id := New_List; 2542 Statements : constant List_Id := New_List; 2543 2544 Subp_Spec : Node_Id; 2545 -- The specification of the body 2546 2547 Controlling_Parameter : Entity_Id := Empty; 2548 RPC_Receiver : Node_Id; 2549 2550 Asynchronous_Expr : Node_Id := Empty; 2551 2552 RCI_Locator : Entity_Id; 2553 2554 Spec_To_Use : Node_Id; 2555 2556 procedure Insert_Partition_Check (Parameter : in Node_Id); 2557 -- Check that the parameter has been elaborated on the same partition 2558 -- than the controlling parameter (E.4(19)). 2559 2560 ---------------------------- 2561 -- Insert_Partition_Check -- 2562 ---------------------------- 2563 2564 procedure Insert_Partition_Check (Parameter : in Node_Id) is 2565 Parameter_Entity : constant Entity_Id := 2566 Defining_Identifier (Parameter); 2567 Condition : Node_Id; 2568 2569 Designated_Object : Node_Id; 2570 pragma Warnings (Off, Designated_Object); 2571 -- Is it really right that this is unreferenced ??? 2572 2573 begin 2574 -- The expression that will be built is of the form: 2575 -- if not (Parameter in Stub_Type and then 2576 -- Parameter.Origin = Controlling.Origin) 2577 -- then 2578 -- raise Constraint_Error; 2579 -- end if; 2580 -- 2581 -- Condition contains the reversed condition. Also, Parameter is 2582 -- dereferenced if it is an access type. We do not check that 2583 -- Parameter is in Stub_Type since such a check has been inserted 2584 -- at the point of call already (a tag check since we have multiple 2585 -- controlling operands). 2586 2587 if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then 2588 Designated_Object := 2589 Make_Explicit_Dereference (Loc, 2590 Prefix => New_Occurrence_Of (Parameter_Entity, Loc)); 2591 else 2592 Designated_Object := New_Occurrence_Of (Parameter_Entity, Loc); 2593 end if; 2594 2595 Condition := 2596 Make_Op_Eq (Loc, 2597 Left_Opnd => 2598 Make_Selected_Component (Loc, 2599 Prefix => 2600 New_Occurrence_Of (Parameter_Entity, Loc), 2601 Selector_Name => 2602 Make_Identifier (Loc, Name_Origin)), 2603 2604 Right_Opnd => 2605 Make_Selected_Component (Loc, 2606 Prefix => 2607 New_Occurrence_Of (Controlling_Parameter, Loc), 2608 Selector_Name => 2609 Make_Identifier (Loc, Name_Origin))); 2610 2611 Append_To (Decls, 2612 Make_Raise_Constraint_Error (Loc, 2613 Condition => 2614 Make_Op_Not (Loc, Right_Opnd => Condition), 2615 Reason => CE_Partition_Check_Failed)); 2616 end Insert_Partition_Check; 2617 2618 -- Start of processing for Build_Subprogram_Calling_Stubs 2619 2620 begin 2621 Target_Partition := 2622 Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 2623 2624 Subp_Spec := Copy_Specification (Loc, 2625 Spec => Specification (Vis_Decl), 2626 New_Name => New_Name); 2627 2628 if Locator = Empty then 2629 RCI_Locator := RCI_Cache; 2630 Spec_To_Use := Specification (Vis_Decl); 2631 else 2632 RCI_Locator := Locator; 2633 Spec_To_Use := Subp_Spec; 2634 end if; 2635 2636 -- Find a controlling argument if we have a stub type. Also check 2637 -- if this subprogram can be made asynchronous. 2638 2639 if Stub_Type /= Empty 2640 and then Present (Parameter_Specifications (Spec_To_Use)) 2641 then 2642 declare 2643 Current_Parameter : Node_Id := 2644 First (Parameter_Specifications 2645 (Spec_To_Use)); 2646 begin 2647 while Current_Parameter /= Empty loop 2648 2649 if 2650 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) 2651 then 2652 if Controlling_Parameter = Empty then 2653 Controlling_Parameter := 2654 Defining_Identifier (Current_Parameter); 2655 else 2656 Insert_Partition_Check (Current_Parameter); 2657 end if; 2658 end if; 2659 2660 Next (Current_Parameter); 2661 end loop; 2662 end; 2663 end if; 2664 2665 if Stub_Type /= Empty then 2666 pragma Assert (Controlling_Parameter /= Empty); 2667 2668 Append_To (Decls, 2669 Make_Object_Declaration (Loc, 2670 Defining_Identifier => Target_Partition, 2671 Constant_Present => True, 2672 Object_Definition => 2673 New_Occurrence_Of (RTE (RE_Partition_ID), Loc), 2674 2675 Expression => 2676 Make_Selected_Component (Loc, 2677 Prefix => 2678 New_Occurrence_Of (Controlling_Parameter, Loc), 2679 Selector_Name => 2680 Make_Identifier (Loc, Name_Origin)))); 2681 2682 RPC_Receiver := 2683 Make_Selected_Component (Loc, 2684 Prefix => 2685 New_Occurrence_Of (Controlling_Parameter, Loc), 2686 Selector_Name => 2687 Make_Identifier (Loc, Name_Receiver)); 2688 2689 else 2690 Append_To (Decls, 2691 Make_Object_Declaration (Loc, 2692 Defining_Identifier => Target_Partition, 2693 Constant_Present => True, 2694 Object_Definition => 2695 New_Occurrence_Of (RTE (RE_Partition_ID), Loc), 2696 2697 Expression => 2698 Make_Function_Call (Loc, 2699 Name => Make_Selected_Component (Loc, 2700 Prefix => 2701 Make_Identifier (Loc, Chars (RCI_Locator)), 2702 Selector_Name => 2703 Make_Identifier (Loc, Name_Get_Active_Partition_ID))))); 2704 2705 RPC_Receiver := 2706 Make_Selected_Component (Loc, 2707 Prefix => 2708 Make_Identifier (Loc, Chars (RCI_Locator)), 2709 Selector_Name => 2710 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver)); 2711 end if; 2712 2713 if Dynamically_Asynchronous then 2714 Asynchronous_Expr := 2715 Make_Selected_Component (Loc, 2716 Prefix => 2717 New_Occurrence_Of (Controlling_Parameter, Loc), 2718 Selector_Name => 2719 Make_Identifier (Loc, Name_Asynchronous)); 2720 end if; 2721 2722 Build_General_Calling_Stubs 2723 (Decls => Decls, 2724 Statements => Statements, 2725 Target_Partition => Target_Partition, 2726 RPC_Receiver => RPC_Receiver, 2727 Subprogram_Id => Make_Integer_Literal (Loc, Subp_Id), 2728 Asynchronous => Asynchronous_Expr, 2729 Is_Known_Asynchronous => Asynchronous 2730 and then not Dynamically_Asynchronous, 2731 Is_Known_Non_Asynchronous 2732 => not Asynchronous 2733 and then not Dynamically_Asynchronous, 2734 Is_Function => Nkind (Spec_To_Use) = 2735 N_Function_Specification, 2736 Spec => Spec_To_Use, 2737 Object_Type => Stub_Type, 2738 Nod => Vis_Decl); 2739 2740 RCI_Calling_Stubs_Table.Set 2741 (Defining_Unit_Name (Specification (Vis_Decl)), 2742 Defining_Unit_Name (Spec_To_Use)); 2743 2744 return 2745 Make_Subprogram_Body (Loc, 2746 Specification => Subp_Spec, 2747 Declarations => Decls, 2748 Handled_Statement_Sequence => 2749 Make_Handled_Sequence_Of_Statements (Loc, Statements)); 2750 end Build_Subprogram_Calling_Stubs; 2751 2752 -------------------------------------- 2753 -- Build_Subprogram_Receiving_Stubs -- 2754 -------------------------------------- 2755 2756 function Build_Subprogram_Receiving_Stubs 2757 (Vis_Decl : Node_Id; 2758 Asynchronous : Boolean; 2759 Dynamically_Asynchronous : Boolean := False; 2760 Stub_Type : Entity_Id := Empty; 2761 RACW_Type : Entity_Id := Empty; 2762 Parent_Primitive : Entity_Id := Empty) 2763 return Node_Id 2764 is 2765 Loc : constant Source_Ptr := Sloc (Vis_Decl); 2766 2767 Stream_Parameter : Node_Id; 2768 Result_Parameter : Node_Id; 2769 -- See explanations of those in Build_Subprogram_Calling_Stubs 2770 2771 Decls : constant List_Id := New_List; 2772 -- All the parameters will get declared before calling the real 2773 -- subprograms. Also the out parameters will be declared. 2774 2775 Statements : constant List_Id := New_List; 2776 2777 Extra_Formal_Statements : constant List_Id := New_List; 2778 -- Statements concerning extra formal parameters 2779 2780 After_Statements : constant List_Id := New_List; 2781 -- Statements to be executed after the subprogram call 2782 2783 Inner_Decls : List_Id := No_List; 2784 -- In case of a function, the inner declarations are needed since 2785 -- the result may be unconstrained. 2786 2787 Excep_Handler : Node_Id; 2788 Excep_Choice : Entity_Id; 2789 Excep_Code : List_Id; 2790 2791 Parameter_List : constant List_Id := New_List; 2792 -- List of parameters to be passed to the subprogram. 2793 2794 Current_Parameter : Node_Id; 2795 2796 Ordered_Parameters_List : constant List_Id := 2797 Build_Ordered_Parameters_List 2798 (Specification (Vis_Decl)); 2799 2800 Subp_Spec : Node_Id; 2801 -- Subprogram specification 2802 2803 Called_Subprogram : Node_Id; 2804 -- The subprogram to call 2805 2806 Null_Raise_Statement : Node_Id; 2807 2808 Dynamic_Async : Entity_Id; 2809 2810 begin 2811 if RACW_Type /= Empty then 2812 Called_Subprogram := 2813 New_Occurrence_Of (Parent_Primitive, Loc); 2814 else 2815 Called_Subprogram := 2816 New_Occurrence_Of ( 2817 Defining_Unit_Name (Specification (Vis_Decl)), Loc); 2818 end if; 2819 2820 Stream_Parameter := 2821 Make_Defining_Identifier (Loc, New_Internal_Name ('S')); 2822 2823 if Dynamically_Asynchronous then 2824 Dynamic_Async := 2825 Make_Defining_Identifier (Loc, New_Internal_Name ('S')); 2826 else 2827 Dynamic_Async := Empty; 2828 end if; 2829 2830 if not Asynchronous or else Dynamically_Asynchronous then 2831 Result_Parameter := 2832 Make_Defining_Identifier (Loc, New_Internal_Name ('S')); 2833 2834 -- The first statement after the subprogram call is a statement to 2835 -- writes a Null_Occurrence into the result stream. 2836 2837 Null_Raise_Statement := 2838 Make_Attribute_Reference (Loc, 2839 Prefix => 2840 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), 2841 Attribute_Name => Name_Write, 2842 Expressions => New_List ( 2843 New_Occurrence_Of (Result_Parameter, Loc), 2844 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); 2845 2846 if Dynamically_Asynchronous then 2847 Null_Raise_Statement := 2848 Make_Implicit_If_Statement (Vis_Decl, 2849 Condition => 2850 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), 2851 Then_Statements => New_List (Null_Raise_Statement)); 2852 end if; 2853 2854 Append_To (After_Statements, Null_Raise_Statement); 2855 2856 else 2857 Result_Parameter := Empty; 2858 end if; 2859 2860 -- Loop through every parameter and get its value from the stream. If 2861 -- the parameter is unconstrained, then the parameter is read using 2862 -- 'Input at the point of declaration. 2863 2864 Current_Parameter := First (Ordered_Parameters_List); 2865 2866 while Current_Parameter /= Empty loop 2867 2868 declare 2869 Etyp : Entity_Id; 2870 Constrained : Boolean; 2871 Object : Entity_Id; 2872 Expr : Node_Id := Empty; 2873 2874 begin 2875 Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); 2876 Set_Ekind (Object, E_Variable); 2877 2878 if 2879 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) 2880 then 2881 -- We have a controlling formal parameter. Read its address 2882 -- rather than a real object. The address is in Unsigned_64 2883 -- form. 2884 2885 Etyp := RTE (RE_Unsigned_64); 2886 else 2887 Etyp := Etype (Parameter_Type (Current_Parameter)); 2888 end if; 2889 2890 Constrained := 2891 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); 2892 2893 if In_Present (Current_Parameter) 2894 or else not Out_Present (Current_Parameter) 2895 or else not Constrained 2896 then 2897 -- If an input parameter is contrained, then its reading is 2898 -- deferred until the beginning of the subprogram body. If 2899 -- it is unconstrained, then an expression is built for 2900 -- the object declaration and the variable is set using 2901 -- 'Input instead of 'Read. 2902 2903 if Constrained then 2904 Append_To (Statements, 2905 Make_Attribute_Reference (Loc, 2906 Prefix => New_Occurrence_Of (Etyp, Loc), 2907 Attribute_Name => Name_Read, 2908 Expressions => New_List ( 2909 New_Occurrence_Of (Stream_Parameter, Loc), 2910 New_Occurrence_Of (Object, Loc)))); 2911 2912 else 2913 Expr := Input_With_Tag_Check (Loc, 2914 Var_Type => Etyp, 2915 Stream => Stream_Parameter); 2916 Append_To (Decls, Expr); 2917 Expr := Make_Function_Call (Loc, 2918 New_Occurrence_Of (Defining_Unit_Name 2919 (Specification (Expr)), Loc)); 2920 end if; 2921 end if; 2922 2923 -- If we do not have to output the current parameter, then 2924 -- it can well be flagged as constant. This may allow further 2925 -- optimizations done by the back end. 2926 2927 Append_To (Decls, 2928 Make_Object_Declaration (Loc, 2929 Defining_Identifier => Object, 2930 Constant_Present => 2931 not Constrained and then not Out_Present (Current_Parameter), 2932 Object_Definition => 2933 New_Occurrence_Of (Etyp, Loc), 2934 Expression => Expr)); 2935 2936 -- An out parameter may be written back using a 'Write 2937 -- attribute instead of a 'Output because it has been 2938 -- constrained by the parameter given to the caller. Note that 2939 -- out controlling arguments in the case of a RACW are not put 2940 -- back in the stream because the pointer on them has not 2941 -- changed. 2942 2943 if Out_Present (Current_Parameter) 2944 and then 2945 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type 2946 then 2947 Append_To (After_Statements, 2948 Make_Attribute_Reference (Loc, 2949 Prefix => New_Occurrence_Of (Etyp, Loc), 2950 Attribute_Name => Name_Write, 2951 Expressions => New_List ( 2952 New_Occurrence_Of (Result_Parameter, Loc), 2953 New_Occurrence_Of (Object, Loc)))); 2954 end if; 2955 2956 if 2957 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) 2958 then 2959 2960 if Nkind (Parameter_Type (Current_Parameter)) /= 2961 N_Access_Definition 2962 then 2963 Append_To (Parameter_List, 2964 Make_Parameter_Association (Loc, 2965 Selector_Name => 2966 New_Occurrence_Of ( 2967 Defining_Identifier (Current_Parameter), Loc), 2968 Explicit_Actual_Parameter => 2969 Make_Explicit_Dereference (Loc, 2970 Unchecked_Convert_To (RACW_Type, 2971 OK_Convert_To (RTE (RE_Address), 2972 New_Occurrence_Of (Object, Loc)))))); 2973 else 2974 Append_To (Parameter_List, 2975 Make_Parameter_Association (Loc, 2976 Selector_Name => 2977 New_Occurrence_Of ( 2978 Defining_Identifier (Current_Parameter), Loc), 2979 Explicit_Actual_Parameter => 2980 Unchecked_Convert_To (RACW_Type, 2981 OK_Convert_To (RTE (RE_Address), 2982 New_Occurrence_Of (Object, Loc))))); 2983 end if; 2984 else 2985 Append_To (Parameter_List, 2986 Make_Parameter_Association (Loc, 2987 Selector_Name => 2988 New_Occurrence_Of ( 2989 Defining_Identifier (Current_Parameter), Loc), 2990 Explicit_Actual_Parameter => 2991 New_Occurrence_Of (Object, Loc))); 2992 end if; 2993 2994 -- If the current parameter needs an extra formal, then read it 2995 -- from the stream and set the corresponding semantic field in 2996 -- the variable. If the kind of the parameter identifier is 2997 -- E_Void, then this is a compiler generated parameter that 2998 -- doesn't need an extra constrained status. 2999 3000 -- The case of Extra_Accessibility should also be handled ??? 3001 3002 if Nkind (Parameter_Type (Current_Parameter)) /= 3003 N_Access_Definition 3004 and then 3005 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void 3006 and then 3007 Present (Extra_Constrained 3008 (Defining_Identifier (Current_Parameter))) 3009 then 3010 declare 3011 Extra_Parameter : constant Entity_Id := 3012 Extra_Constrained 3013 (Defining_Identifier 3014 (Current_Parameter)); 3015 3016 Formal_Entity : constant Entity_Id := 3017 Make_Defining_Identifier 3018 (Loc, Chars (Extra_Parameter)); 3019 3020 Formal_Type : constant Entity_Id := 3021 Etype (Extra_Parameter); 3022 3023 begin 3024 Append_To (Decls, 3025 Make_Object_Declaration (Loc, 3026 Defining_Identifier => Formal_Entity, 3027 Object_Definition => 3028 New_Occurrence_Of (Formal_Type, Loc))); 3029 3030 Append_To (Extra_Formal_Statements, 3031 Make_Attribute_Reference (Loc, 3032 Prefix => New_Occurrence_Of (Formal_Type, Loc), 3033 Attribute_Name => Name_Read, 3034 Expressions => New_List ( 3035 New_Occurrence_Of (Stream_Parameter, Loc), 3036 New_Occurrence_Of (Formal_Entity, Loc)))); 3037 Set_Extra_Constrained (Object, Formal_Entity); 3038 end; 3039 end if; 3040 end; 3041 3042 Next (Current_Parameter); 3043 end loop; 3044 3045 -- Append the formal statements list at the end of regular statements 3046 3047 Append_List_To (Statements, Extra_Formal_Statements); 3048 3049 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then 3050 3051 -- The remote subprogram is a function. We build an inner block to 3052 -- be able to hold a potentially unconstrained result in a variable. 3053 3054 declare 3055 Etyp : constant Entity_Id := 3056 Etype (Subtype_Mark (Specification (Vis_Decl))); 3057 Result : constant Node_Id := 3058 Make_Defining_Identifier (Loc, New_Internal_Name ('R')); 3059 3060 begin 3061 Inner_Decls := New_List ( 3062 Make_Object_Declaration (Loc, 3063 Defining_Identifier => Result, 3064 Constant_Present => True, 3065 Object_Definition => New_Occurrence_Of (Etyp, Loc), 3066 Expression => 3067 Make_Function_Call (Loc, 3068 Name => Called_Subprogram, 3069 Parameter_Associations => Parameter_List))); 3070 3071 Append_To (After_Statements, 3072 Make_Attribute_Reference (Loc, 3073 Prefix => New_Occurrence_Of (Etyp, Loc), 3074 Attribute_Name => Name_Output, 3075 Expressions => New_List ( 3076 New_Occurrence_Of (Result_Parameter, Loc), 3077 New_Occurrence_Of (Result, Loc)))); 3078 end; 3079 3080 Append_To (Statements, 3081 Make_Block_Statement (Loc, 3082 Declarations => Inner_Decls, 3083 Handled_Statement_Sequence => 3084 Make_Handled_Sequence_Of_Statements (Loc, 3085 Statements => After_Statements))); 3086 3087 else 3088 -- The remote subprogram is a procedure. We do not need any inner 3089 -- block in this case. 3090 3091 if Dynamically_Asynchronous then 3092 Append_To (Decls, 3093 Make_Object_Declaration (Loc, 3094 Defining_Identifier => Dynamic_Async, 3095 Object_Definition => 3096 New_Occurrence_Of (Standard_Boolean, Loc))); 3097 3098 Append_To (Statements, 3099 Make_Attribute_Reference (Loc, 3100 Prefix => New_Occurrence_Of (Standard_Boolean, Loc), 3101 Attribute_Name => Name_Read, 3102 Expressions => New_List ( 3103 New_Occurrence_Of (Stream_Parameter, Loc), 3104 New_Occurrence_Of (Dynamic_Async, Loc)))); 3105 end if; 3106 3107 Append_To (Statements, 3108 Make_Procedure_Call_Statement (Loc, 3109 Name => Called_Subprogram, 3110 Parameter_Associations => Parameter_List)); 3111 3112 Append_List_To (Statements, After_Statements); 3113 3114 end if; 3115 3116 if Asynchronous and then not Dynamically_Asynchronous then 3117 3118 -- An asynchronous procedure does not want a Result 3119 -- parameter. Also, we put an exception handler with an others 3120 -- clause that does nothing. 3121 3122 Subp_Spec := 3123 Make_Procedure_Specification (Loc, 3124 Defining_Unit_Name => 3125 Make_Defining_Identifier (Loc, New_Internal_Name ('F')), 3126 Parameter_Specifications => New_List ( 3127 Make_Parameter_Specification (Loc, 3128 Defining_Identifier => Stream_Parameter, 3129 Parameter_Type => 3130 Make_Access_Definition (Loc, 3131 Subtype_Mark => 3132 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); 3133 3134 Excep_Handler := 3135 Make_Exception_Handler (Loc, 3136 Exception_Choices => 3137 New_List (Make_Others_Choice (Loc)), 3138 Statements => New_List ( 3139 Make_Null_Statement (Loc))); 3140 3141 else 3142 -- In the other cases, if an exception is raised, then the 3143 -- exception occurrence is copied into the output stream and 3144 -- no other output parameter is written. 3145 3146 Excep_Choice := 3147 Make_Defining_Identifier (Loc, New_Internal_Name ('E')); 3148 3149 Excep_Code := New_List ( 3150 Make_Attribute_Reference (Loc, 3151 Prefix => 3152 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), 3153 Attribute_Name => Name_Write, 3154 Expressions => New_List ( 3155 New_Occurrence_Of (Result_Parameter, Loc), 3156 New_Occurrence_Of (Excep_Choice, Loc)))); 3157 3158 if Dynamically_Asynchronous then 3159 Excep_Code := New_List ( 3160 Make_Implicit_If_Statement (Vis_Decl, 3161 Condition => Make_Op_Not (Loc, 3162 New_Occurrence_Of (Dynamic_Async, Loc)), 3163 Then_Statements => Excep_Code)); 3164 end if; 3165 3166 Excep_Handler := 3167 Make_Exception_Handler (Loc, 3168 Choice_Parameter => Excep_Choice, 3169 Exception_Choices => New_List (Make_Others_Choice (Loc)), 3170 Statements => Excep_Code); 3171 3172 Subp_Spec := 3173 Make_Procedure_Specification (Loc, 3174 Defining_Unit_Name => 3175 Make_Defining_Identifier (Loc, New_Internal_Name ('F')), 3176 3177 Parameter_Specifications => New_List ( 3178 Make_Parameter_Specification (Loc, 3179 Defining_Identifier => Stream_Parameter, 3180 Parameter_Type => 3181 Make_Access_Definition (Loc, 3182 Subtype_Mark => 3183 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), 3184 3185 Make_Parameter_Specification (Loc, 3186 Defining_Identifier => Result_Parameter, 3187 Parameter_Type => 3188 Make_Access_Definition (Loc, 3189 Subtype_Mark => 3190 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); 3191 end if; 3192 3193 return 3194 Make_Subprogram_Body (Loc, 3195 Specification => Subp_Spec, 3196 Declarations => Decls, 3197 Handled_Statement_Sequence => 3198 Make_Handled_Sequence_Of_Statements (Loc, 3199 Statements => Statements, 3200 Exception_Handlers => New_List (Excep_Handler))); 3201 3202 end Build_Subprogram_Receiving_Stubs; 3203 3204 ------------------------ 3205 -- Copy_Specification -- 3206 ------------------------ 3207 3208 function Copy_Specification 3209 (Loc : Source_Ptr; 3210 Spec : Node_Id; 3211 Object_Type : Entity_Id := Empty; 3212 Stub_Type : Entity_Id := Empty; 3213 New_Name : Name_Id := No_Name) 3214 return Node_Id 3215 is 3216 Parameters : List_Id := No_List; 3217 3218 Current_Parameter : Node_Id; 3219 Current_Type : Node_Id; 3220 Current_Etype : Entity_Id; 3221 3222 Name_For_New_Spec : Name_Id; 3223 3224 New_Identifier : Entity_Id; 3225 3226 begin 3227 if New_Name = No_Name then 3228 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec)); 3229 else 3230 Name_For_New_Spec := New_Name; 3231 end if; 3232 3233 if Present (Parameter_Specifications (Spec)) then 3234 3235 Parameters := New_List; 3236 Current_Parameter := First (Parameter_Specifications (Spec)); 3237 3238 while Current_Parameter /= Empty loop 3239 3240 Current_Type := Parameter_Type (Current_Parameter); 3241 3242 if Nkind (Current_Type) = N_Access_Definition then 3243 Current_Etype := Entity (Subtype_Mark (Current_Type)); 3244 3245 if Object_Type = Empty then 3246 Current_Type := 3247 Make_Access_Definition (Loc, 3248 Subtype_Mark => 3249 New_Occurrence_Of (Current_Etype, Loc)); 3250 else 3251 pragma Assert 3252 (Root_Type (Current_Etype) = Root_Type (Object_Type)); 3253 Current_Type := 3254 Make_Access_Definition (Loc, 3255 Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc)); 3256 end if; 3257 3258 else 3259 Current_Etype := Entity (Current_Type); 3260 3261 if Object_Type /= Empty 3262 and then Current_Etype = Object_Type 3263 then 3264 Current_Type := New_Occurrence_Of (Stub_Type, Loc); 3265 else 3266 Current_Type := New_Occurrence_Of (Current_Etype, Loc); 3267 end if; 3268 end if; 3269 3270 New_Identifier := Make_Defining_Identifier (Loc, 3271 Chars (Defining_Identifier (Current_Parameter))); 3272 3273 Append_To (Parameters, 3274 Make_Parameter_Specification (Loc, 3275 Defining_Identifier => New_Identifier, 3276 Parameter_Type => Current_Type, 3277 In_Present => In_Present (Current_Parameter), 3278 Out_Present => Out_Present (Current_Parameter), 3279 Expression => 3280 New_Copy_Tree (Expression (Current_Parameter)))); 3281 3282 Next (Current_Parameter); 3283 end loop; 3284 end if; 3285 3286 if Nkind (Spec) = N_Function_Specification then 3287 return 3288 Make_Function_Specification (Loc, 3289 Defining_Unit_Name => 3290 Make_Defining_Identifier (Loc, 3291 Chars => Name_For_New_Spec), 3292 Parameter_Specifications => Parameters, 3293 Subtype_Mark => 3294 New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc)); 3295 3296 else 3297 return 3298 Make_Procedure_Specification (Loc, 3299 Defining_Unit_Name => 3300 Make_Defining_Identifier (Loc, 3301 Chars => Name_For_New_Spec), 3302 Parameter_Specifications => Parameters); 3303 end if; 3304 3305 end Copy_Specification; 3306 3307 --------------------------- 3308 -- Could_Be_Asynchronous -- 3309 --------------------------- 3310 3311 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is 3312 Current_Parameter : Node_Id; 3313 3314 begin 3315 if Present (Parameter_Specifications (Spec)) then 3316 Current_Parameter := First (Parameter_Specifications (Spec)); 3317 while Current_Parameter /= Empty loop 3318 if Out_Present (Current_Parameter) then 3319 return False; 3320 end if; 3321 3322 Next (Current_Parameter); 3323 end loop; 3324 end if; 3325 3326 return True; 3327 end Could_Be_Asynchronous; 3328 3329 --------------------------------------------- 3330 -- Expand_All_Calls_Remote_Subprogram_Call -- 3331 --------------------------------------------- 3332 3333 procedure Expand_All_Calls_Remote_Subprogram_Call (N : in Node_Id) is 3334 Called_Subprogram : constant Entity_Id := Entity (Name (N)); 3335 RCI_Package : constant Entity_Id := Scope (Called_Subprogram); 3336 Loc : constant Source_Ptr := Sloc (N); 3337 RCI_Locator : Node_Id; 3338 RCI_Cache : Entity_Id; 3339 Calling_Stubs : Node_Id; 3340 E_Calling_Stubs : Entity_Id; 3341 3342 begin 3343 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); 3344 3345 if E_Calling_Stubs = Empty then 3346 RCI_Cache := RCI_Locator_Table.Get (RCI_Package); 3347 3348 if RCI_Cache = Empty then 3349 RCI_Locator := 3350 RCI_Package_Locator 3351 (Loc, Specification (Unit_Declaration_Node (RCI_Package))); 3352 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator); 3353 3354 -- The RCI_Locator package is inserted at the top level in the 3355 -- current unit, and must appear in the proper scope, so that it 3356 -- is not prematurely removed by the GCC back-end. 3357 3358 declare 3359 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 3360 3361 begin 3362 if Ekind (Scop) = E_Package_Body then 3363 New_Scope (Spec_Entity (Scop)); 3364 3365 elsif Ekind (Scop) = E_Subprogram_Body then 3366 New_Scope 3367 (Corresponding_Spec (Unit_Declaration_Node (Scop))); 3368 3369 else 3370 New_Scope (Scop); 3371 end if; 3372 3373 Analyze (RCI_Locator); 3374 Pop_Scope; 3375 end; 3376 3377 RCI_Cache := Defining_Unit_Name (RCI_Locator); 3378 3379 else 3380 RCI_Locator := Parent (RCI_Cache); 3381 end if; 3382 3383 Calling_Stubs := Build_Subprogram_Calling_Stubs 3384 (Vis_Decl => Parent (Parent (Called_Subprogram)), 3385 Subp_Id => Get_Subprogram_Id (Called_Subprogram), 3386 Asynchronous => Nkind (N) = N_Procedure_Call_Statement 3387 and then 3388 Is_Asynchronous (Called_Subprogram), 3389 Locator => RCI_Cache, 3390 New_Name => New_Internal_Name ('S')); 3391 Insert_After (RCI_Locator, Calling_Stubs); 3392 Analyze (Calling_Stubs); 3393 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); 3394 end if; 3395 3396 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc)); 3397 end Expand_All_Calls_Remote_Subprogram_Call; 3398 3399 --------------------------------- 3400 -- Expand_Calling_Stubs_Bodies -- 3401 --------------------------------- 3402 3403 procedure Expand_Calling_Stubs_Bodies (Unit_Node : in Node_Id) is 3404 Spec : constant Node_Id := Specification (Unit_Node); 3405 Decls : constant List_Id := Visible_Declarations (Spec); 3406 3407 begin 3408 New_Scope (Scope_Of_Spec (Spec)); 3409 Add_Calling_Stubs_To_Declarations (Specification (Unit_Node), 3410 Decls); 3411 Pop_Scope; 3412 end Expand_Calling_Stubs_Bodies; 3413 3414 ----------------------------------- 3415 -- Expand_Receiving_Stubs_Bodies -- 3416 ----------------------------------- 3417 3418 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : in Node_Id) is 3419 Spec : Node_Id; 3420 Decls : List_Id; 3421 Temp : List_Id; 3422 3423 begin 3424 if Nkind (Unit_Node) = N_Package_Declaration then 3425 Spec := Specification (Unit_Node); 3426 Decls := Visible_Declarations (Spec); 3427 New_Scope (Scope_Of_Spec (Spec)); 3428 Add_Receiving_Stubs_To_Declarations (Spec, Decls); 3429 3430 else 3431 Spec := 3432 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node)); 3433 Decls := Declarations (Unit_Node); 3434 New_Scope (Scope_Of_Spec (Unit_Node)); 3435 Temp := New_List; 3436 Add_Receiving_Stubs_To_Declarations (Spec, Temp); 3437 Insert_List_Before (First (Decls), Temp); 3438 end if; 3439 3440 Pop_Scope; 3441 end Expand_Receiving_Stubs_Bodies; 3442 3443 ---------------------------- 3444 -- Get_Pkg_Name_string_Id -- 3445 ---------------------------- 3446 3447 function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id is 3448 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); 3449 3450 begin 3451 Get_Unit_Name_String (Unit_Name_Id); 3452 3453 -- Remove seven last character (" (spec)" or " (body)"). 3454 3455 Name_Len := Name_Len - 7; 3456 pragma Assert (Name_Buffer (Name_Len + 1) = ' '); 3457 3458 return Get_String_Id (Name_Buffer (1 .. Name_Len)); 3459 end Get_Pkg_Name_String_Id; 3460 3461 ------------------- 3462 -- Get_String_Id -- 3463 ------------------- 3464 3465 function Get_String_Id (Val : String) return String_Id is 3466 begin 3467 Start_String; 3468 Store_String_Chars (Val); 3469 return End_String; 3470 end Get_String_Id; 3471 3472 ---------- 3473 -- Hash -- 3474 ---------- 3475 3476 function Hash (F : Entity_Id) return Hash_Index is 3477 begin 3478 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); 3479 end Hash; 3480 3481 -------------------------- 3482 -- Input_With_Tag_Check -- 3483 -------------------------- 3484 3485 function Input_With_Tag_Check 3486 (Loc : Source_Ptr; 3487 Var_Type : Entity_Id; 3488 Stream : Entity_Id) 3489 return Node_Id 3490 is 3491 begin 3492 return 3493 Make_Subprogram_Body (Loc, 3494 Specification => Make_Function_Specification (Loc, 3495 Defining_Unit_Name => 3496 Make_Defining_Identifier (Loc, New_Internal_Name ('S')), 3497 Subtype_Mark => New_Occurrence_Of (Var_Type, Loc)), 3498 Declarations => No_List, 3499 Handled_Statement_Sequence => 3500 Make_Handled_Sequence_Of_Statements (Loc, New_List ( 3501 Make_Tag_Check (Loc, 3502 Make_Return_Statement (Loc, 3503 Make_Attribute_Reference (Loc, 3504 Prefix => New_Occurrence_Of (Var_Type, Loc), 3505 Attribute_Name => Name_Input, 3506 Expressions => 3507 New_List (New_Occurrence_Of (Stream, Loc)))))))); 3508 end Input_With_Tag_Check; 3509 3510 -------------------------------- 3511 -- Is_RACW_Controlling_Formal -- 3512 -------------------------------- 3513 3514 function Is_RACW_Controlling_Formal 3515 (Parameter : Node_Id; 3516 Stub_Type : Entity_Id) 3517 return Boolean 3518 is 3519 Typ : Entity_Id; 3520 3521 begin 3522 -- If the kind of the parameter is E_Void, then it is not a 3523 -- controlling formal (this can happen in the context of RAS). 3524 3525 if Ekind (Defining_Identifier (Parameter)) = E_Void then 3526 return False; 3527 end if; 3528 3529 -- If the parameter is not a controlling formal, then it cannot 3530 -- be possibly a RACW_Controlling_Formal. 3531 3532 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then 3533 return False; 3534 end if; 3535 3536 Typ := Parameter_Type (Parameter); 3537 return (Nkind (Typ) = N_Access_Definition 3538 and then Etype (Subtype_Mark (Typ)) = Stub_Type) 3539 or else Etype (Typ) = Stub_Type; 3540 end Is_RACW_Controlling_Formal; 3541 3542 -------------------- 3543 -- Make_Tag_Check -- 3544 -------------------- 3545 3546 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is 3547 Occ : constant Entity_Id := 3548 Make_Defining_Identifier (Loc, New_Internal_Name ('E')); 3549 3550 begin 3551 return Make_Block_Statement (Loc, 3552 Handled_Statement_Sequence => 3553 Make_Handled_Sequence_Of_Statements (Loc, 3554 Statements => New_List (N), 3555 3556 Exception_Handlers => New_List ( 3557 Make_Exception_Handler (Loc, 3558 Choice_Parameter => Occ, 3559 3560 Exception_Choices => 3561 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)), 3562 3563 Statements => 3564 New_List (Make_Procedure_Call_Statement (Loc, 3565 New_Occurrence_Of 3566 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc), 3567 New_List (New_Occurrence_Of (Occ, Loc)))))))); 3568 end Make_Tag_Check; 3569 3570 ---------------------------- 3571 -- Need_Extra_Constrained -- 3572 ---------------------------- 3573 3574 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is 3575 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter)); 3576 3577 begin 3578 return Out_Present (Parameter) 3579 and then Has_Discriminants (Etyp) 3580 and then not Is_Constrained (Etyp) 3581 and then not Is_Indefinite_Subtype (Etyp); 3582 end Need_Extra_Constrained; 3583 3584 ------------------------------------ 3585 -- Pack_Entity_Into_Stream_Access -- 3586 ------------------------------------ 3587 3588 function Pack_Entity_Into_Stream_Access 3589 (Loc : Source_Ptr; 3590 Stream : Node_Id; 3591 Object : Entity_Id; 3592 Etyp : Entity_Id := Empty) 3593 return Node_Id 3594 is 3595 Typ : Entity_Id; 3596 3597 begin 3598 if Etyp /= Empty then 3599 Typ := Etyp; 3600 else 3601 Typ := Etype (Object); 3602 end if; 3603 3604 return 3605 Pack_Node_Into_Stream_Access (Loc, 3606 Stream => Stream, 3607 Object => New_Occurrence_Of (Object, Loc), 3608 Etyp => Typ); 3609 end Pack_Entity_Into_Stream_Access; 3610 3611 --------------------------- 3612 -- Pack_Node_Into_Stream -- 3613 --------------------------- 3614 3615 function Pack_Node_Into_Stream 3616 (Loc : Source_Ptr; 3617 Stream : Entity_Id; 3618 Object : Node_Id; 3619 Etyp : Entity_Id) 3620 return Node_Id 3621 is 3622 Write_Attribute : Name_Id := Name_Write; 3623 3624 begin 3625 if not Is_Constrained (Etyp) then 3626 Write_Attribute := Name_Output; 3627 end if; 3628 3629 return 3630 Make_Attribute_Reference (Loc, 3631 Prefix => New_Occurrence_Of (Etyp, Loc), 3632 Attribute_Name => Write_Attribute, 3633 Expressions => New_List ( 3634 Make_Attribute_Reference (Loc, 3635 Prefix => New_Occurrence_Of (Stream, Loc), 3636 Attribute_Name => Name_Access), 3637 Object)); 3638 end Pack_Node_Into_Stream; 3639 3640 ---------------------------------- 3641 -- Pack_Node_Into_Stream_Access -- 3642 ---------------------------------- 3643 3644 function Pack_Node_Into_Stream_Access 3645 (Loc : Source_Ptr; 3646 Stream : Node_Id; 3647 Object : Node_Id; 3648 Etyp : Entity_Id) 3649 return Node_Id 3650 is 3651 Write_Attribute : Name_Id := Name_Write; 3652 3653 begin 3654 if not Is_Constrained (Etyp) then 3655 Write_Attribute := Name_Output; 3656 end if; 3657 3658 return 3659 Make_Attribute_Reference (Loc, 3660 Prefix => New_Occurrence_Of (Etyp, Loc), 3661 Attribute_Name => Write_Attribute, 3662 Expressions => New_List ( 3663 Stream, 3664 Object)); 3665 end Pack_Node_Into_Stream_Access; 3666 3667 ------------------------------- 3668 -- RACW_Type_Is_Asynchronous -- 3669 ------------------------------- 3670 3671 procedure RACW_Type_Is_Asynchronous (RACW_Type : in Entity_Id) is 3672 N : constant Node_Id := Asynchronous_Flags_Table.Get (RACW_Type); 3673 pragma Assert (N /= Empty); 3674 3675 begin 3676 Replace (N, New_Occurrence_Of (Standard_True, Sloc (N))); 3677 end RACW_Type_Is_Asynchronous; 3678 3679 ------------------------- 3680 -- RCI_Package_Locator -- 3681 ------------------------- 3682 3683 function RCI_Package_Locator 3684 (Loc : Source_Ptr; 3685 Package_Spec : Node_Id) 3686 return Node_Id 3687 is 3688 Inst : constant Node_Id := 3689 Make_Package_Instantiation (Loc, 3690 Defining_Unit_Name => 3691 Make_Defining_Identifier (Loc, New_Internal_Name ('R')), 3692 Name => 3693 New_Occurrence_Of (RTE (RE_RCI_Info), Loc), 3694 Generic_Associations => New_List ( 3695 Make_Generic_Association (Loc, 3696 Selector_Name => 3697 Make_Identifier (Loc, Name_RCI_Name), 3698 Explicit_Generic_Actual_Parameter => 3699 Make_String_Literal (Loc, 3700 Strval => Get_Pkg_Name_String_Id (Package_Spec))))); 3701 3702 begin 3703 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec), 3704 Defining_Unit_Name (Inst)); 3705 return Inst; 3706 end RCI_Package_Locator; 3707 3708 ----------------------------------------------- 3709 -- Remote_Types_Tagged_Full_View_Encountered -- 3710 ----------------------------------------------- 3711 3712 procedure Remote_Types_Tagged_Full_View_Encountered 3713 (Full_View : in Entity_Id) 3714 is 3715 Stub_Elements : constant Stub_Structure := 3716 Stubs_Table.Get (Full_View); 3717 3718 begin 3719 if Stub_Elements /= Empty_Stub_Structure then 3720 Add_RACW_Primitive_Declarations_And_Bodies 3721 (Full_View, 3722 Parent (Declaration_Node (Stub_Elements.Object_RPC_Receiver)), 3723 List_Containing (Declaration_Node (Full_View))); 3724 end if; 3725 end Remote_Types_Tagged_Full_View_Encountered; 3726 3727 ------------------- 3728 -- Scope_Of_Spec -- 3729 ------------------- 3730 3731 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is 3732 Unit_Name : Node_Id := Defining_Unit_Name (Spec); 3733 3734 begin 3735 while Nkind (Unit_Name) /= N_Defining_Identifier loop 3736 Unit_Name := Defining_Identifier (Unit_Name); 3737 end loop; 3738 3739 return Unit_Name; 3740 end Scope_Of_Spec; 3741 3742end Exp_Dist; 3743