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-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Einfo; use Einfo; 28with Elists; use Elists; 29with Exp_Atag; use Exp_Atag; 30with Exp_Disp; use Exp_Disp; 31with Exp_Strm; use Exp_Strm; 32with Exp_Tss; use Exp_Tss; 33with Exp_Util; use Exp_Util; 34with Lib; use Lib; 35with Nlists; use Nlists; 36with Nmake; use Nmake; 37with Opt; use Opt; 38with Rtsfind; use Rtsfind; 39with Sem; use Sem; 40with Sem_Aux; use Sem_Aux; 41with Sem_Cat; use Sem_Cat; 42with Sem_Ch3; use Sem_Ch3; 43with Sem_Ch8; use Sem_Ch8; 44with Sem_Ch12; use Sem_Ch12; 45with Sem_Dist; use Sem_Dist; 46with Sem_Eval; use Sem_Eval; 47with Sem_Util; use Sem_Util; 48with Sinfo; use Sinfo; 49with Stand; use Stand; 50with Stringt; use Stringt; 51with Tbuild; use Tbuild; 52with Ttypes; use Ttypes; 53with Uintp; use Uintp; 54 55with GNAT.HTable; use GNAT.HTable; 56 57package body Exp_Dist is 58 59 -- The following model has been used to implement distributed objects: 60 -- given a designated type D and a RACW type R, then a record of the form: 61 62 -- type Stub is tagged record 63 -- [...declaration similar to s-parint.ads RACW_Stub_Type...] 64 -- end record; 65 66 -- is built. This type has two properties: 67 68 -- 1) Since it has the same structure as RACW_Stub_Type, it can 69 -- be converted to and from this type to make it suitable for 70 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order 71 -- to avoid memory leaks when the same remote object arrives on the 72 -- same partition through several paths; 73 74 -- 2) It also has the same dispatching table as the designated type D, 75 -- and thus can be used as an object designated by a value of type 76 -- R on any partition other than the one on which the object has 77 -- been created, since only dispatching calls will be performed and 78 -- the fields themselves will not be used. We call Derive_Subprograms 79 -- to fake half a derivation to ensure that the subprograms do have 80 -- the same dispatching table. 81 82 First_RCI_Subprogram_Id : constant := 2; 83 -- RCI subprograms are numbered starting at 2. The RCI receiver for 84 -- an RCI package can thus identify calls received through remote 85 -- access-to-subprogram dereferences by the fact that they have a 86 -- (primitive) subprogram id of 0, and 1 is used for the internal RAS 87 -- information lookup operation. (This is for the Garlic code generation, 88 -- where subprograms are identified by numbers; in the PolyORB version, 89 -- they are identified by name, with a numeric suffix for homonyms.) 90 91 type Hash_Index is range 0 .. 50; 92 93 ----------------------- 94 -- Local subprograms -- 95 ----------------------- 96 97 function Hash (F : Entity_Id) return Hash_Index; 98 -- DSA expansion associates stubs to distributed object types using a hash 99 -- table on entity ids. 100 101 function Hash (F : Name_Id) return Hash_Index; 102 -- The generation of subprogram identifiers requires an overload counter 103 -- to be associated with each remote subprogram name. These counters are 104 -- maintained in a hash table on name ids. 105 106 type Subprogram_Identifiers is record 107 Str_Identifier : String_Id; 108 Int_Identifier : Int; 109 end record; 110 111 package Subprogram_Identifier_Table is 112 new Simple_HTable (Header_Num => Hash_Index, 113 Element => Subprogram_Identifiers, 114 No_Element => (No_String, 0), 115 Key => Entity_Id, 116 Hash => Hash, 117 Equal => "="); 118 -- Mapping between a remote subprogram and the corresponding subprogram 119 -- identifiers. 120 121 package Overload_Counter_Table is 122 new Simple_HTable (Header_Num => Hash_Index, 123 Element => Int, 124 No_Element => 0, 125 Key => Name_Id, 126 Hash => Hash, 127 Equal => "="); 128 -- Mapping between a subprogram name and an integer that counts the number 129 -- of defining subprogram names with that Name_Id encountered so far in a 130 -- given context (an interface). 131 132 function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers; 133 function Get_Subprogram_Id (Def : Entity_Id) return String_Id; 134 function Get_Subprogram_Id (Def : Entity_Id) return Int; 135 -- Given a subprogram defined in a RCI package, get its distribution 136 -- subprogram identifiers (the distribution identifiers are a unique 137 -- subprogram number, and the non-qualified subprogram name, in the 138 -- casing used for the subprogram declaration; if the name is overloaded, 139 -- a double underscore and a serial number are appended. 140 -- 141 -- The integer identifier is used to perform remote calls with GARLIC; 142 -- the string identifier is used in the case of PolyORB. 143 -- 144 -- Although the PolyORB DSA receiving stubs will make a caseless comparison 145 -- when receiving a call, the calling stubs will create requests with the 146 -- exact casing of the defining unit name of the called subprogram, so as 147 -- to allow calls to subprograms on distributed nodes that do distinguish 148 -- between casings. 149 -- 150 -- NOTE: Another design would be to allow a representation clause on 151 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar"; 152 153 pragma Warnings (Off, Get_Subprogram_Id); 154 -- One homonym only is unreferenced (specific to the GARLIC version) 155 156 procedure Add_RAS_Dereference_TSS (N : Node_Id); 157 -- Add a subprogram body for RAS Dereference TSS 158 159 procedure Add_RAS_Proxy_And_Analyze 160 (Decls : List_Id; 161 Vis_Decl : Node_Id; 162 All_Calls_Remote_E : Entity_Id; 163 Proxy_Object_Addr : out Entity_Id); 164 -- Add the proxy type required, on the receiving (server) side, to handle 165 -- calls to the subprogram declared by Vis_Decl through a remote access 166 -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma 167 -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type 168 -- is appended to Decls. Proxy_Object_Addr is a constant of type 169 -- System.Address that designates an instance of the proxy object. 170 171 function Build_Remote_Subprogram_Proxy_Type 172 (Loc : Source_Ptr; 173 ACR_Expression : Node_Id) return Node_Id; 174 -- Build and return a tagged record type definition for an RCI subprogram 175 -- proxy type. ACR_Expression is used as the initialization value for the 176 -- All_Calls_Remote component. 177 178 function Build_Get_Unique_RP_Call 179 (Loc : Source_Ptr; 180 Pointer : Entity_Id; 181 Stub_Type : Entity_Id) return List_Id; 182 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a 183 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to 184 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type). 185 186 function Build_Stub_Tag 187 (Loc : Source_Ptr; 188 RACW_Type : Entity_Id) return Node_Id; 189 -- Return an expression denoting the tag of the stub type associated with 190 -- RACW_Type. 191 192 function Build_Subprogram_Calling_Stubs 193 (Vis_Decl : Node_Id; 194 Subp_Id : Node_Id; 195 Asynchronous : Boolean; 196 Dynamically_Asynchronous : Boolean := False; 197 Stub_Type : Entity_Id := Empty; 198 RACW_Type : Entity_Id := Empty; 199 Locator : Entity_Id := Empty; 200 New_Name : Name_Id := No_Name) return Node_Id; 201 -- Build the calling stub for a given subprogram with the subprogram ID 202 -- being Subp_Id. If Stub_Type is given, then the "addr" field of 203 -- parameters of this type will be marshalled instead of the object itself. 204 -- It will then be converted into Stub_Type before performing the real 205 -- call. If Dynamically_Asynchronous is True, then it will be computed at 206 -- run time whether the call is asynchronous or not. Otherwise, the value 207 -- of the formal Asynchronous will be used. If Locator is not Empty, it 208 -- will be used instead of RCI_Cache. If New_Name is given, then it will 209 -- be used instead of the original name. 210 211 function Build_RPC_Receiver_Specification 212 (RPC_Receiver : Entity_Id; 213 Request_Parameter : Entity_Id) return Node_Id; 214 -- Make a subprogram specification for an RPC receiver, with the given 215 -- defining unit name and formal parameter. 216 217 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id; 218 -- Return an ordered parameter list: unconstrained parameters are put 219 -- at the beginning of the list and constrained ones are put after. If 220 -- there are no parameters, an empty list is returned. Special case: 221 -- the controlling formal of the equivalent RACW operation for a RAS 222 -- type is always left in first position. 223 224 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean; 225 -- True when Typ is an unconstrained type, or a null-excluding access type. 226 -- In either case, this means stubs cannot contain a default-initialized 227 -- object declaration of such type. 228 229 procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id); 230 -- Add calling stubs to the declarative part 231 232 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean; 233 -- Return True if nothing prevents the program whose specification is 234 -- given to be asynchronous (i.e. no [IN] OUT parameters). 235 236 function Pack_Entity_Into_Stream_Access 237 (Loc : Source_Ptr; 238 Stream : Node_Id; 239 Object : Entity_Id; 240 Etyp : Entity_Id := Empty) return Node_Id; 241 -- Pack Object (of type Etyp) into Stream. If Etyp is not given, 242 -- then Etype (Object) will be used if present. If the type is 243 -- constrained, then 'Write will be used to output the object, 244 -- If the type is unconstrained, 'Output will be used. 245 246 function Pack_Node_Into_Stream 247 (Loc : Source_Ptr; 248 Stream : Entity_Id; 249 Object : Node_Id; 250 Etyp : Entity_Id) return Node_Id; 251 -- Similar to above, with an arbitrary node instead of an entity 252 253 function Pack_Node_Into_Stream_Access 254 (Loc : Source_Ptr; 255 Stream : Node_Id; 256 Object : Node_Id; 257 Etyp : Entity_Id) return Node_Id; 258 -- Similar to above, with Stream instead of Stream'Access 259 260 function Make_Selected_Component 261 (Loc : Source_Ptr; 262 Prefix : Entity_Id; 263 Selector_Name : Name_Id) return Node_Id; 264 -- Return a selected_component whose prefix denotes the given entity, and 265 -- with the given Selector_Name. 266 267 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id; 268 -- Return the scope represented by a given spec 269 270 procedure Set_Renaming_TSS 271 (Typ : Entity_Id; 272 Nam : Entity_Id; 273 TSS_Nam : TSS_Name_Type); 274 -- Create a renaming declaration of subprogram Nam, and register it as a 275 -- TSS for Typ with name TSS_Nam. 276 277 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean; 278 -- Return True if the current parameter needs an extra formal to reflect 279 -- its constrained status. 280 281 function Is_RACW_Controlling_Formal 282 (Parameter : Node_Id; 283 Stub_Type : Entity_Id) return Boolean; 284 -- Return True if the current parameter is a controlling formal argument 285 -- of type Stub_Type or access to Stub_Type. 286 287 procedure Declare_Create_NVList 288 (Loc : Source_Ptr; 289 NVList : Entity_Id; 290 Decls : List_Id; 291 Stmts : List_Id); 292 -- Append the declaration of NVList to Decls, and its 293 -- initialization to Stmts. 294 295 function Add_Parameter_To_NVList 296 (Loc : Source_Ptr; 297 NVList : Entity_Id; 298 Parameter : Entity_Id; 299 Constrained : Boolean; 300 RACW_Ctrl : Boolean := False; 301 Any : Entity_Id) return Node_Id; 302 -- Return a call to Add_Item to add the Any corresponding to the designated 303 -- formal Parameter (with the indicated Constrained status) to NVList. 304 -- RACW_Ctrl must be set to True for controlling formals of distributed 305 -- object primitive operations. 306 307 -------------------- 308 -- Stub_Structure -- 309 -------------------- 310 311 -- This record describes various tree fragments associated with the 312 -- generation of RACW calling stubs. One such record exists for every 313 -- distributed object type, i.e. each tagged type that is the designated 314 -- type of one or more RACW type. 315 316 type Stub_Structure is record 317 Stub_Type : Entity_Id; 318 -- Stub type: this type has the same primitive operations as the 319 -- designated types, but the provided bodies for these operations 320 -- a remote call to an actual target object potentially located on 321 -- another partition; each value of the stub type encapsulates a 322 -- reference to a remote object. 323 324 Stub_Type_Access : Entity_Id; 325 -- A local access type designating the stub type (this is not an RACW 326 -- type). 327 328 RPC_Receiver_Decl : Node_Id; 329 -- Declaration for the RPC receiver entity associated with the 330 -- designated type. As an exception, in the case of GARLIC, for an RACW 331 -- that implements a RAS, no object RPC receiver is generated. Instead, 332 -- RPC_Receiver_Decl is the declaration after which the RPC receiver 333 -- would have been inserted. 334 335 Body_Decls : List_Id; 336 -- List of subprogram bodies to be included in generated code: bodies 337 -- for the RACW's stream attributes, and for the primitive operations 338 -- of the stub type. 339 340 RACW_Type : Entity_Id; 341 -- One of the RACW types designating this distributed object type 342 -- (they are all interchangeable; we use any one of them in order to 343 -- avoid having to create various anonymous access types). 344 345 end record; 346 347 Empty_Stub_Structure : constant Stub_Structure := 348 (Empty, Empty, Empty, No_List, Empty); 349 350 package Stubs_Table is 351 new Simple_HTable (Header_Num => Hash_Index, 352 Element => Stub_Structure, 353 No_Element => Empty_Stub_Structure, 354 Key => Entity_Id, 355 Hash => Hash, 356 Equal => "="); 357 -- Mapping between a RACW designated type and its stub type 358 359 package Asynchronous_Flags_Table is 360 new Simple_HTable (Header_Num => Hash_Index, 361 Element => Entity_Id, 362 No_Element => Empty, 363 Key => Entity_Id, 364 Hash => Hash, 365 Equal => "="); 366 -- Mapping between a RACW type and a constant having the value True 367 -- if the RACW is asynchronous and False otherwise. 368 369 package RCI_Locator_Table is 370 new Simple_HTable (Header_Num => Hash_Index, 371 Element => Entity_Id, 372 No_Element => Empty, 373 Key => Entity_Id, 374 Hash => Hash, 375 Equal => "="); 376 -- Mapping between a RCI package on which All_Calls_Remote applies and 377 -- the generic instantiation of RCI_Locator for this package. 378 379 package RCI_Calling_Stubs_Table is 380 new Simple_HTable (Header_Num => Hash_Index, 381 Element => Entity_Id, 382 No_Element => Empty, 383 Key => Entity_Id, 384 Hash => Hash, 385 Equal => "="); 386 -- Mapping between a RCI subprogram and the corresponding calling stubs 387 388 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure; 389 -- Return the stub information associated with the given RACW type 390 391 procedure Add_Stub_Type 392 (Designated_Type : Entity_Id; 393 RACW_Type : Entity_Id; 394 Decls : List_Id; 395 Stub_Type : out Entity_Id; 396 Stub_Type_Access : out Entity_Id; 397 RPC_Receiver_Decl : out Node_Id; 398 Body_Decls : out List_Id; 399 Existing : out Boolean); 400 -- Add the declaration of the stub type, the access to stub type and the 401 -- object RPC receiver at the end of Decls. If these already exist, 402 -- then nothing is added in the tree but the right values are returned 403 -- anyhow and Existing is set to True. 404 405 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id; 406 -- Retrieve the Body_Decls list associated to RACW_Type in the stub 407 -- structure table, reset it to No_List, and return the previous value. 408 409 procedure Add_RACW_Asynchronous_Flag 410 (Declarations : List_Id; 411 RACW_Type : Entity_Id); 412 -- Declare a boolean constant associated with RACW_Type whose value 413 -- indicates at run time whether a pragma Asynchronous applies to it. 414 415 procedure Assign_Subprogram_Identifier 416 (Def : Entity_Id; 417 Spn : Int; 418 Id : out String_Id); 419 -- Determine the distribution subprogram identifier to 420 -- be used for remote subprogram Def, return it in Id and 421 -- store it in a hash table for later retrieval by 422 -- Get_Subprogram_Id. Spn is the subprogram number. 423 424 function RCI_Package_Locator 425 (Loc : Source_Ptr; 426 Package_Spec : Node_Id) return Node_Id; 427 -- Instantiate the generic package RCI_Locator in order to locate the 428 -- RCI package whose spec is given as argument. 429 430 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id; 431 -- Surround a node N by a tag check, as in: 432 -- begin 433 -- <N>; 434 -- exception 435 -- when E : Ada.Tags.Tag_Error => 436 -- Raise_Exception (Program_Error'Identity, 437 -- Exception_Message (E)); 438 -- end; 439 440 function Input_With_Tag_Check 441 (Loc : Source_Ptr; 442 Var_Type : Entity_Id; 443 Stream : Node_Id) return Node_Id; 444 -- Return a function with the following form: 445 -- function R return Var_Type is 446 -- begin 447 -- return Var_Type'Input (S); 448 -- exception 449 -- when E : Ada.Tags.Tag_Error => 450 -- Raise_Exception (Program_Error'Identity, 451 -- Exception_Message (E)); 452 -- end R; 453 454 procedure Build_Actual_Object_Declaration 455 (Object : Entity_Id; 456 Etyp : Entity_Id; 457 Variable : Boolean; 458 Expr : Node_Id; 459 Decls : List_Id); 460 -- Build the declaration of an object with the given defining identifier, 461 -- initialized with Expr if provided, to serve as actual parameter in a 462 -- server stub. If Variable is true, the declared object will be a variable 463 -- (case of an out or in out formal), else it will be a constant. Object's 464 -- Ekind is set accordingly. The declaration, as well as any other 465 -- declarations it requires, are appended to Decls. 466 467 -------------------------------------------- 468 -- Hooks for PCS-specific code generation -- 469 -------------------------------------------- 470 471 -- Part of the code generation circuitry for distribution needs to be 472 -- tailored for each implementation of the PCS. For each routine that 473 -- needs to be specialized, a Specific_<routine> wrapper is created, 474 -- which calls the corresponding <routine> in package 475 -- <pcs_implementation>_Support. 476 477 procedure Specific_Add_RACW_Features 478 (RACW_Type : Entity_Id; 479 Desig : Entity_Id; 480 Stub_Type : Entity_Id; 481 Stub_Type_Access : Entity_Id; 482 RPC_Receiver_Decl : Node_Id; 483 Body_Decls : List_Id); 484 -- Add declaration for TSSs for a given RACW type. The declarations are 485 -- added just after the declaration of the RACW type itself. If the RACW 486 -- appears in the main unit, Body_Decls is a list of declarations to which 487 -- the bodies are appended. Else Body_Decls is No_List. 488 -- PCS-specific ancillary subprogram for Add_RACW_Features. 489 490 procedure Specific_Add_RAST_Features 491 (Vis_Decl : Node_Id; 492 RAS_Type : Entity_Id); 493 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary 494 -- subprogram for Add_RAST_Features. 495 496 -- An RPC_Target record is used during construction of calling stubs 497 -- to pass PCS-specific tree fragments corresponding to the information 498 -- necessary to locate the target of a remote subprogram call. 499 500 type RPC_Target (PCS_Kind : PCS_Names) is record 501 case PCS_Kind is 502 when Name_PolyORB_DSA => 503 Object : Node_Id; 504 -- An expression whose value is a PolyORB reference to the target 505 -- object. 506 507 when others => 508 Partition : Entity_Id; 509 -- A variable containing the Partition_ID of the target partition 510 511 RPC_Receiver : Node_Id; 512 -- An expression whose value is the address of the target RPC 513 -- receiver. 514 end case; 515 end record; 516 517 procedure Specific_Build_General_Calling_Stubs 518 (Decls : List_Id; 519 Statements : List_Id; 520 Target : RPC_Target; 521 Subprogram_Id : Node_Id; 522 Asynchronous : Node_Id := Empty; 523 Is_Known_Asynchronous : Boolean := False; 524 Is_Known_Non_Asynchronous : Boolean := False; 525 Is_Function : Boolean; 526 Spec : Node_Id; 527 Stub_Type : Entity_Id := Empty; 528 RACW_Type : Entity_Id := Empty; 529 Nod : Node_Id); 530 -- Build calling stubs for general purpose. The parameters are: 531 -- Decls : a place to put declarations 532 -- Statements : a place to put statements 533 -- Target : PCS-specific target information (see details 534 -- in RPC_Target declaration). 535 -- Subprogram_Id : a node containing the subprogram ID 536 -- Asynchronous : True if an APC must be made instead of an RPC. 537 -- The value needs not be supplied if one of the 538 -- Is_Known_... is True. 539 -- Is_Known_Async... : True if we know that this is asynchronous 540 -- Is_Known_Non_A... : True if we know that this is not asynchronous 541 -- Spec : a node with a Parameter_Specifications and 542 -- a Result_Definition if applicable 543 -- Stub_Type : in case of RACW stubs, parameters of type access 544 -- to Stub_Type will be marshalled using the 545 -- address of the object (the addr field) rather 546 -- than using the 'Write on the stub itself 547 -- Nod : used to provide sloc for generated code 548 549 function Specific_Build_Stub_Target 550 (Loc : Source_Ptr; 551 Decls : List_Id; 552 RCI_Locator : Entity_Id; 553 Controlling_Parameter : Entity_Id) return RPC_Target; 554 -- Build call target information nodes for use within calling stubs. In the 555 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If 556 -- for an RACW, Controlling_Parameter is the entity for the controlling 557 -- formal parameter used to determine the location of the target of the 558 -- call. Decls provides a location where variable declarations can be 559 -- appended to construct the necessary values. 560 561 function Specific_RPC_Receiver_Decl 562 (RACW_Type : Entity_Id) return Node_Id; 563 -- Build the RPC receiver, for RACW, if applicable, else return Empty 564 565 procedure Specific_Build_RPC_Receiver_Body 566 (RPC_Receiver : Entity_Id; 567 Request : out Entity_Id; 568 Subp_Id : out Entity_Id; 569 Subp_Index : out Entity_Id; 570 Stmts : out List_Id; 571 Decl : out Node_Id); 572 -- Make a subprogram body for an RPC receiver, with the given 573 -- defining unit name. On return: 574 -- - Subp_Id is the subprogram identifier from the PCS. 575 -- - Subp_Index is the index in the list of subprograms 576 -- used for dispatching (a variable of type Subprogram_Id). 577 -- - Stmts is the place where the request dispatching 578 -- statements can occur, 579 -- - Decl is the subprogram body declaration. 580 581 function Specific_Build_Subprogram_Receiving_Stubs 582 (Vis_Decl : Node_Id; 583 Asynchronous : Boolean; 584 Dynamically_Asynchronous : Boolean := False; 585 Stub_Type : Entity_Id := Empty; 586 RACW_Type : Entity_Id := Empty; 587 Parent_Primitive : Entity_Id := Empty) return Node_Id; 588 -- Build the receiving stub for a given subprogram. The subprogram 589 -- declaration is also built by this procedure, and the value returned 590 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is 591 -- found in the specification, then its address is read from the stream 592 -- instead of the object itself and converted into an access to 593 -- class-wide type before doing the real call using any of the RACW type 594 -- pointing on the designated type. 595 596 procedure Specific_Add_Obj_RPC_Receiver_Completion 597 (Loc : Source_Ptr; 598 Decls : List_Id; 599 RPC_Receiver : Entity_Id; 600 Stub_Elements : Stub_Structure); 601 -- Add the necessary code to Decls after the completion of generation 602 -- of the RACW RPC receiver described by Stub_Elements. 603 604 procedure Specific_Add_Receiving_Stubs_To_Declarations 605 (Pkg_Spec : Node_Id; 606 Decls : List_Id; 607 Stmts : List_Id); 608 -- Add receiving stubs to the declarative part of an RCI unit 609 610 -------------------- 611 -- GARLIC_Support -- 612 -------------------- 613 614 package GARLIC_Support is 615 616 -- Support for generating DSA code that uses the GARLIC PCS 617 618 -- The subprograms below provide the GARLIC versions of the 619 -- corresponding Specific_<subprogram> routine declared above. 620 621 procedure Add_RACW_Features 622 (RACW_Type : Entity_Id; 623 Stub_Type : Entity_Id; 624 Stub_Type_Access : Entity_Id; 625 RPC_Receiver_Decl : Node_Id; 626 Body_Decls : List_Id); 627 628 procedure Add_RAST_Features 629 (Vis_Decl : Node_Id; 630 RAS_Type : Entity_Id); 631 632 procedure Build_General_Calling_Stubs 633 (Decls : List_Id; 634 Statements : List_Id; 635 Target_Partition : Entity_Id; -- From RPC_Target 636 Target_RPC_Receiver : Node_Id; -- From RPC_Target 637 Subprogram_Id : Node_Id; 638 Asynchronous : Node_Id := Empty; 639 Is_Known_Asynchronous : Boolean := False; 640 Is_Known_Non_Asynchronous : Boolean := False; 641 Is_Function : Boolean; 642 Spec : Node_Id; 643 Stub_Type : Entity_Id := Empty; 644 RACW_Type : Entity_Id := Empty; 645 Nod : Node_Id); 646 647 function Build_Stub_Target 648 (Loc : Source_Ptr; 649 Decls : List_Id; 650 RCI_Locator : Entity_Id; 651 Controlling_Parameter : Entity_Id) return RPC_Target; 652 653 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id; 654 655 function Build_Subprogram_Receiving_Stubs 656 (Vis_Decl : Node_Id; 657 Asynchronous : Boolean; 658 Dynamically_Asynchronous : Boolean := False; 659 Stub_Type : Entity_Id := Empty; 660 RACW_Type : Entity_Id := Empty; 661 Parent_Primitive : Entity_Id := Empty) return Node_Id; 662 663 procedure Add_Obj_RPC_Receiver_Completion 664 (Loc : Source_Ptr; 665 Decls : List_Id; 666 RPC_Receiver : Entity_Id; 667 Stub_Elements : Stub_Structure); 668 669 procedure Add_Receiving_Stubs_To_Declarations 670 (Pkg_Spec : Node_Id; 671 Decls : List_Id; 672 Stmts : List_Id); 673 674 procedure Build_RPC_Receiver_Body 675 (RPC_Receiver : Entity_Id; 676 Request : out Entity_Id; 677 Subp_Id : out Entity_Id; 678 Subp_Index : out Entity_Id; 679 Stmts : out List_Id; 680 Decl : out Node_Id); 681 682 end GARLIC_Support; 683 684 --------------------- 685 -- PolyORB_Support -- 686 --------------------- 687 688 package PolyORB_Support is 689 690 -- Support for generating DSA code that uses the PolyORB PCS 691 692 -- The subprograms below provide the PolyORB versions of the 693 -- corresponding Specific_<subprogram> routine declared above. 694 695 procedure Add_RACW_Features 696 (RACW_Type : Entity_Id; 697 Desig : Entity_Id; 698 Stub_Type : Entity_Id; 699 Stub_Type_Access : Entity_Id; 700 RPC_Receiver_Decl : Node_Id; 701 Body_Decls : List_Id); 702 703 procedure Add_RAST_Features 704 (Vis_Decl : Node_Id; 705 RAS_Type : Entity_Id); 706 707 procedure Build_General_Calling_Stubs 708 (Decls : List_Id; 709 Statements : List_Id; 710 Target_Object : Node_Id; -- From RPC_Target 711 Subprogram_Id : Node_Id; 712 Asynchronous : Node_Id := Empty; 713 Is_Known_Asynchronous : Boolean := False; 714 Is_Known_Non_Asynchronous : Boolean := False; 715 Is_Function : Boolean; 716 Spec : Node_Id; 717 Stub_Type : Entity_Id := Empty; 718 RACW_Type : Entity_Id := Empty; 719 Nod : Node_Id); 720 721 function Build_Stub_Target 722 (Loc : Source_Ptr; 723 Decls : List_Id; 724 RCI_Locator : Entity_Id; 725 Controlling_Parameter : Entity_Id) return RPC_Target; 726 727 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id; 728 729 function Build_Subprogram_Receiving_Stubs 730 (Vis_Decl : Node_Id; 731 Asynchronous : Boolean; 732 Dynamically_Asynchronous : Boolean := False; 733 Stub_Type : Entity_Id := Empty; 734 RACW_Type : Entity_Id := Empty; 735 Parent_Primitive : Entity_Id := Empty) return Node_Id; 736 737 procedure Add_Obj_RPC_Receiver_Completion 738 (Loc : Source_Ptr; 739 Decls : List_Id; 740 RPC_Receiver : Entity_Id; 741 Stub_Elements : Stub_Structure); 742 743 procedure Add_Receiving_Stubs_To_Declarations 744 (Pkg_Spec : Node_Id; 745 Decls : List_Id; 746 Stmts : List_Id); 747 748 procedure Build_RPC_Receiver_Body 749 (RPC_Receiver : Entity_Id; 750 Request : out Entity_Id; 751 Subp_Id : out Entity_Id; 752 Subp_Index : out Entity_Id; 753 Stmts : out List_Id; 754 Decl : out Node_Id); 755 756 procedure Reserve_NamingContext_Methods; 757 -- Mark the method names for interface NamingContext as already used in 758 -- the overload table, so no clashes occur with user code (with the 759 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow 760 -- their methods to be accessed as objects, for the implementation of 761 -- remote access-to-subprogram types). 762 763 ------------- 764 -- Helpers -- 765 ------------- 766 767 package Helpers is 768 769 -- Routines to build distribution helper subprograms for user-defined 770 -- types. For implementation of the Distributed systems annex (DSA) 771 -- over the PolyORB generic middleware components, it is necessary to 772 -- generate several supporting subprograms for each application data 773 -- type used in inter-partition communication. These subprograms are: 774 775 -- A Typecode function returning a high-level description of the 776 -- type's structure; 777 778 -- Two conversion functions allowing conversion of values of the 779 -- type from and to the generic data containers used by PolyORB. 780 -- These generic containers are called 'Any' type values after the 781 -- CORBA terminology, and hence the conversion subprograms are 782 -- named To_Any and From_Any. 783 784 function Build_From_Any_Call 785 (Typ : Entity_Id; 786 N : Node_Id; 787 Decls : List_Id) return Node_Id; 788 -- Build call to From_Any attribute function of type Typ with 789 -- expression N as actual parameter. Decls is the declarations list 790 -- for an appropriate enclosing scope of the point where the call 791 -- will be inserted; if the From_Any attribute for Typ needs to be 792 -- generated at this point, its declaration is appended to Decls. 793 794 procedure Build_From_Any_Function 795 (Loc : Source_Ptr; 796 Typ : Entity_Id; 797 Decl : out Node_Id; 798 Fnam : out Entity_Id); 799 -- Build From_Any attribute function for Typ. Loc is the reference 800 -- location for generated nodes, Typ is the type for which the 801 -- conversion function is generated. On return, Decl and Fnam contain 802 -- the declaration and entity for the newly-created function. 803 804 function Build_To_Any_Call 805 (Loc : Source_Ptr; 806 N : Node_Id; 807 Decls : List_Id) return Node_Id; 808 -- Build call to To_Any attribute function with expression as actual 809 -- parameter. Loc is the reference location ofr generated nodes, 810 -- Decls is the declarations list for an appropriate enclosing scope 811 -- of the point where the call will be inserted; if the To_Any 812 -- attribute for the type of N needs to be generated at this point, 813 -- its declaration is appended to Decls. 814 815 procedure Build_To_Any_Function 816 (Loc : Source_Ptr; 817 Typ : Entity_Id; 818 Decl : out Node_Id; 819 Fnam : out Entity_Id); 820 -- Build To_Any attribute function for Typ. Loc is the reference 821 -- location for generated nodes, Typ is the type for which the 822 -- conversion function is generated. On return, Decl and Fnam contain 823 -- the declaration and entity for the newly-created function. 824 825 function Build_TypeCode_Call 826 (Loc : Source_Ptr; 827 Typ : Entity_Id; 828 Decls : List_Id) return Node_Id; 829 -- Build call to TypeCode attribute function for Typ. Decls is the 830 -- declarations list for an appropriate enclosing scope of the point 831 -- where the call will be inserted; if the To_Any attribute for Typ 832 -- needs to be generated at this point, its declaration is appended 833 -- to Decls. 834 835 procedure Build_TypeCode_Function 836 (Loc : Source_Ptr; 837 Typ : Entity_Id; 838 Decl : out Node_Id; 839 Fnam : out Entity_Id); 840 -- Build TypeCode attribute function for Typ. Loc is the reference 841 -- location for generated nodes, Typ is the type for which the 842 -- typecode function is generated. On return, Decl and Fnam contain 843 -- the declaration and entity for the newly-created function. 844 845 procedure Build_Name_And_Repository_Id 846 (E : Entity_Id; 847 Name_Str : out String_Id; 848 Repo_Id_Str : out String_Id); 849 -- In the PolyORB distribution model, each distributed object type 850 -- and each distributed operation has a globally unique identifier, 851 -- its Repository Id. This subprogram builds and returns two strings 852 -- for entity E (a distributed object type or operation): one 853 -- containing the name of E, the second containing its repository id. 854 855 procedure Assign_Opaque_From_Any 856 (Loc : Source_Ptr; 857 Stms : List_Id; 858 Typ : Entity_Id; 859 N : Node_Id; 860 Target : Entity_Id); 861 -- For a Target object of type Typ, which has opaque representation 862 -- as a sequence of octets determined by stream attributes (which 863 -- includes all limited types), append code to Stmts performing the 864 -- equivalent of: 865 -- Target := Typ'From_Any (N) 866 -- 867 -- or, if Target is Empty: 868 -- return Typ'From_Any (N) 869 870 end Helpers; 871 872 end PolyORB_Support; 873 874 -- The following PolyORB-specific subprograms are made visible to Exp_Attr: 875 876 function Build_From_Any_Call 877 (Typ : Entity_Id; 878 N : Node_Id; 879 Decls : List_Id) return Node_Id 880 renames PolyORB_Support.Helpers.Build_From_Any_Call; 881 882 function Build_To_Any_Call 883 (Loc : Source_Ptr; 884 N : Node_Id; 885 Decls : List_Id) return Node_Id 886 renames PolyORB_Support.Helpers.Build_To_Any_Call; 887 888 function Build_TypeCode_Call 889 (Loc : Source_Ptr; 890 Typ : Entity_Id; 891 Decls : List_Id) return Node_Id 892 renames PolyORB_Support.Helpers.Build_TypeCode_Call; 893 894 ------------------------------------ 895 -- Local variables and structures -- 896 ------------------------------------ 897 898 RCI_Cache : Node_Id; 899 -- Needs comments ??? 900 901 Output_From_Constrained : constant array (Boolean) of Name_Id := 902 (False => Name_Output, 903 True => Name_Write); 904 -- The attribute to choose depending on the fact that the parameter 905 -- is constrained or not. There is no such thing as Input_From_Constrained 906 -- since this require separate mechanisms ('Input is a function while 907 -- 'Read is a procedure). 908 909 generic 910 with procedure Process_Subprogram_Declaration (Decl : Node_Id); 911 -- Generate calling or receiving stub for this subprogram declaration 912 913 procedure Build_Package_Stubs (Pkg_Spec : Node_Id); 914 -- Recursively visit the given RCI Package_Specification, calling 915 -- Process_Subprogram_Declaration for each remote subprogram. 916 917 ------------------------- 918 -- Build_Package_Stubs -- 919 ------------------------- 920 921 procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is 922 Decls : constant List_Id := Visible_Declarations (Pkg_Spec); 923 Decl : Node_Id; 924 925 procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id); 926 -- Recurse for the given nested package declaration 927 928 ----------------------- 929 -- Visit_Nested_Spec -- 930 ----------------------- 931 932 procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is 933 Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl); 934 begin 935 Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec)); 936 Build_Package_Stubs (Nested_Pkg_Spec); 937 Pop_Scope; 938 end Visit_Nested_Pkg; 939 940 -- Start of processing for Build_Package_Stubs 941 942 begin 943 Decl := First (Decls); 944 while Present (Decl) loop 945 case Nkind (Decl) is 946 when N_Subprogram_Declaration => 947 948 -- Note: we test Comes_From_Source on Spec, not Decl, because 949 -- in the case of a subprogram instance, only the specification 950 -- (not the declaration) is marked as coming from source. 951 952 if Comes_From_Source (Specification (Decl)) then 953 Process_Subprogram_Declaration (Decl); 954 end if; 955 956 when N_Package_Declaration => 957 958 -- Case of a nested package or package instantiation coming 959 -- from source. Note that the anonymous wrapper package for 960 -- subprogram instances is not flagged Is_Generic_Instance at 961 -- this point, so there is a distinct circuit to handle them 962 -- (see case N_Subprogram_Instantiation below). 963 964 declare 965 Pkg_Ent : constant Entity_Id := 966 Defining_Unit_Name (Specification (Decl)); 967 begin 968 if Comes_From_Source (Decl) 969 or else 970 (Is_Generic_Instance (Pkg_Ent) 971 and then Comes_From_Source 972 (Get_Package_Instantiation_Node (Pkg_Ent))) 973 then 974 Visit_Nested_Pkg (Decl); 975 end if; 976 end; 977 978 when N_Subprogram_Instantiation => 979 980 -- The subprogram declaration for an instance of a generic 981 -- subprogram is wrapped in a package that does not come from 982 -- source, so we need to explicitly traverse it here. 983 984 if Comes_From_Source (Decl) then 985 Visit_Nested_Pkg (Instance_Spec (Decl)); 986 end if; 987 988 when others => 989 null; 990 end case; 991 Next (Decl); 992 end loop; 993 end Build_Package_Stubs; 994 995 --------------------------------------- 996 -- Add_Calling_Stubs_To_Declarations -- 997 --------------------------------------- 998 999 procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is 1000 Loc : constant Source_Ptr := Sloc (Pkg_Spec); 1001 1002 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; 1003 -- Subprogram id 0 is reserved for calls received from 1004 -- remote access-to-subprogram dereferences. 1005 1006 RCI_Instantiation : Node_Id; 1007 1008 procedure Visit_Subprogram (Decl : Node_Id); 1009 -- Generate calling stub for one remote subprogram 1010 1011 ---------------------- 1012 -- Visit_Subprogram -- 1013 ---------------------- 1014 1015 procedure Visit_Subprogram (Decl : Node_Id) is 1016 Loc : constant Source_Ptr := Sloc (Decl); 1017 Spec : constant Node_Id := Specification (Decl); 1018 Subp_Stubs : Node_Id; 1019 1020 Subp_Str : String_Id; 1021 pragma Warnings (Off, Subp_Str); 1022 1023 begin 1024 -- Disable expansion of stubs if serious errors have been diagnosed, 1025 -- because otherwise some illegal remote subprogram declarations 1026 -- could cause cascaded errors in stubs. 1027 1028 if Serious_Errors_Detected /= 0 then 1029 return; 1030 end if; 1031 1032 Assign_Subprogram_Identifier 1033 (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str); 1034 1035 Subp_Stubs := 1036 Build_Subprogram_Calling_Stubs 1037 (Vis_Decl => Decl, 1038 Subp_Id => 1039 Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)), 1040 Asynchronous => 1041 Nkind (Spec) = N_Procedure_Specification 1042 and then Is_Asynchronous (Defining_Unit_Name (Spec))); 1043 1044 Append_To (List_Containing (Decl), Subp_Stubs); 1045 Analyze (Subp_Stubs); 1046 1047 Current_Subprogram_Number := Current_Subprogram_Number + 1; 1048 end Visit_Subprogram; 1049 1050 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); 1051 1052 -- Start of processing for Add_Calling_Stubs_To_Declarations 1053 1054 begin 1055 Push_Scope (Scope_Of_Spec (Pkg_Spec)); 1056 1057 -- The first thing added is an instantiation of the generic package 1058 -- System.Partition_Interface.RCI_Locator with the name of this remote 1059 -- package. This will act as an interface with the name server to 1060 -- determine the Partition_ID and the RPC_Receiver for the receiver 1061 -- of this package. 1062 1063 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec); 1064 RCI_Cache := Defining_Unit_Name (RCI_Instantiation); 1065 1066 Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation); 1067 Analyze (RCI_Instantiation); 1068 1069 -- For each subprogram declaration visible in the spec, we do build a 1070 -- body. We also increment a counter to assign a different Subprogram_Id 1071 -- to each subprogram. The receiving stubs processing uses the same 1072 -- mechanism and will thus assign the same Id and do the correct 1073 -- dispatching. 1074 1075 Overload_Counter_Table.Reset; 1076 PolyORB_Support.Reserve_NamingContext_Methods; 1077 1078 Visit_Spec (Pkg_Spec); 1079 1080 Pop_Scope; 1081 end Add_Calling_Stubs_To_Declarations; 1082 1083 ----------------------------- 1084 -- Add_Parameter_To_NVList -- 1085 ----------------------------- 1086 1087 function Add_Parameter_To_NVList 1088 (Loc : Source_Ptr; 1089 NVList : Entity_Id; 1090 Parameter : Entity_Id; 1091 Constrained : Boolean; 1092 RACW_Ctrl : Boolean := False; 1093 Any : Entity_Id) return Node_Id 1094 is 1095 Parameter_Name_String : String_Id; 1096 Parameter_Mode : Node_Id; 1097 1098 function Parameter_Passing_Mode 1099 (Loc : Source_Ptr; 1100 Parameter : Entity_Id; 1101 Constrained : Boolean) return Node_Id; 1102 -- Return an expression that denotes the parameter passing mode to be 1103 -- used for Parameter in distribution stubs, where Constrained is 1104 -- Parameter's constrained status. 1105 1106 ---------------------------- 1107 -- Parameter_Passing_Mode -- 1108 ---------------------------- 1109 1110 function Parameter_Passing_Mode 1111 (Loc : Source_Ptr; 1112 Parameter : Entity_Id; 1113 Constrained : Boolean) return Node_Id 1114 is 1115 Lib_RE : RE_Id; 1116 1117 begin 1118 if Out_Present (Parameter) then 1119 if In_Present (Parameter) 1120 or else not Constrained 1121 then 1122 -- Unconstrained formals must be translated 1123 -- to 'in' or 'inout', not 'out', because 1124 -- they need to be constrained by the actual. 1125 1126 Lib_RE := RE_Mode_Inout; 1127 else 1128 Lib_RE := RE_Mode_Out; 1129 end if; 1130 1131 else 1132 Lib_RE := RE_Mode_In; 1133 end if; 1134 1135 return New_Occurrence_Of (RTE (Lib_RE), Loc); 1136 end Parameter_Passing_Mode; 1137 1138 -- Start of processing for Add_Parameter_To_NVList 1139 1140 begin 1141 if Nkind (Parameter) = N_Defining_Identifier then 1142 Get_Name_String (Chars (Parameter)); 1143 else 1144 Get_Name_String (Chars (Defining_Identifier (Parameter))); 1145 end if; 1146 1147 Parameter_Name_String := String_From_Name_Buffer; 1148 1149 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then 1150 1151 -- When the parameter passed to Add_Parameter_To_NVList is an 1152 -- Extra_Constrained parameter, Parameter is an N_Defining_ 1153 -- Identifier, instead of a complete N_Parameter_Specification. 1154 -- Thus, we explicitly set 'in' mode in this case. 1155 1156 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc); 1157 1158 else 1159 Parameter_Mode := 1160 Parameter_Passing_Mode (Loc, Parameter, Constrained); 1161 end if; 1162 1163 return 1164 Make_Procedure_Call_Statement (Loc, 1165 Name => 1166 New_Occurrence_Of 1167 (RTE (RE_NVList_Add_Item), Loc), 1168 Parameter_Associations => New_List ( 1169 New_Occurrence_Of (NVList, Loc), 1170 Make_Function_Call (Loc, 1171 Name => 1172 New_Occurrence_Of 1173 (RTE (RE_To_PolyORB_String), Loc), 1174 Parameter_Associations => New_List ( 1175 Make_String_Literal (Loc, 1176 Strval => Parameter_Name_String))), 1177 New_Occurrence_Of (Any, Loc), 1178 Parameter_Mode)); 1179 end Add_Parameter_To_NVList; 1180 1181 -------------------------------- 1182 -- Add_RACW_Asynchronous_Flag -- 1183 -------------------------------- 1184 1185 procedure Add_RACW_Asynchronous_Flag 1186 (Declarations : List_Id; 1187 RACW_Type : Entity_Id) 1188 is 1189 Loc : constant Source_Ptr := Sloc (RACW_Type); 1190 1191 Asynchronous_Flag : constant Entity_Id := 1192 Make_Defining_Identifier (Loc, 1193 New_External_Name (Chars (RACW_Type), 'A')); 1194 1195 begin 1196 -- Declare the asynchronous flag. This flag will be changed to True 1197 -- whenever it is known that the RACW type is asynchronous. 1198 1199 Append_To (Declarations, 1200 Make_Object_Declaration (Loc, 1201 Defining_Identifier => Asynchronous_Flag, 1202 Constant_Present => True, 1203 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 1204 Expression => New_Occurrence_Of (Standard_False, Loc))); 1205 1206 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag); 1207 end Add_RACW_Asynchronous_Flag; 1208 1209 ----------------------- 1210 -- Add_RACW_Features -- 1211 ----------------------- 1212 1213 procedure Add_RACW_Features (RACW_Type : Entity_Id) is 1214 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type)); 1215 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type); 1216 1217 Pkg_Spec : Node_Id; 1218 Decls : List_Id; 1219 Body_Decls : List_Id; 1220 1221 Stub_Type : Entity_Id; 1222 Stub_Type_Access : Entity_Id; 1223 RPC_Receiver_Decl : Node_Id; 1224 1225 Existing : Boolean; 1226 -- True when appropriate stubs have already been generated (this is the 1227 -- case when another RACW with the same designated type has already been 1228 -- encountered), in which case we reuse the previous stubs rather than 1229 -- generating new ones. 1230 1231 begin 1232 if not Expander_Active then 1233 return; 1234 end if; 1235 1236 -- Mark the current package declaration as containing an RACW, so that 1237 -- the bodies for the calling stubs and the RACW stream subprograms 1238 -- are attached to the tree when the corresponding body is encountered. 1239 1240 Set_Has_RACW (Current_Scope); 1241 1242 -- Look for place to declare the RACW stub type and RACW operations 1243 1244 Pkg_Spec := Empty; 1245 1246 if Same_Scope then 1247 1248 -- Case of declaring the RACW in the same package as its designated 1249 -- type: we know that the designated type is a private type, so we 1250 -- use the private declarations list. 1251 1252 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope); 1253 1254 if Present (Private_Declarations (Pkg_Spec)) then 1255 Decls := Private_Declarations (Pkg_Spec); 1256 else 1257 Decls := Visible_Declarations (Pkg_Spec); 1258 end if; 1259 1260 else 1261 -- Case of declaring the RACW in another package than its designated 1262 -- type: use the private declarations list if present; otherwise 1263 -- use the visible declarations. 1264 1265 Decls := List_Containing (Declaration_Node (RACW_Type)); 1266 1267 end if; 1268 1269 -- If we were unable to find the declarations, that means that the 1270 -- completion of the type was missing. We can safely return and let the 1271 -- error be caught by the semantic analysis. 1272 1273 if No (Decls) then 1274 return; 1275 end if; 1276 1277 Add_Stub_Type 1278 (Designated_Type => Desig, 1279 RACW_Type => RACW_Type, 1280 Decls => Decls, 1281 Stub_Type => Stub_Type, 1282 Stub_Type_Access => Stub_Type_Access, 1283 RPC_Receiver_Decl => RPC_Receiver_Decl, 1284 Body_Decls => Body_Decls, 1285 Existing => Existing); 1286 1287 -- If this RACW is not in the main unit, do not generate primitive or 1288 -- TSS bodies. 1289 1290 if not Entity_Is_In_Main_Unit (RACW_Type) then 1291 Body_Decls := No_List; 1292 end if; 1293 1294 Add_RACW_Asynchronous_Flag 1295 (Declarations => Decls, 1296 RACW_Type => RACW_Type); 1297 1298 Specific_Add_RACW_Features 1299 (RACW_Type => RACW_Type, 1300 Desig => Desig, 1301 Stub_Type => Stub_Type, 1302 Stub_Type_Access => Stub_Type_Access, 1303 RPC_Receiver_Decl => RPC_Receiver_Decl, 1304 Body_Decls => Body_Decls); 1305 1306 -- If we already have stubs for this designated type, nothing to do 1307 1308 if Existing then 1309 return; 1310 end if; 1311 1312 if Is_Frozen (Desig) then 1313 Validate_RACW_Primitives (RACW_Type); 1314 Add_RACW_Primitive_Declarations_And_Bodies 1315 (Designated_Type => Desig, 1316 Insertion_Node => RPC_Receiver_Decl, 1317 Body_Decls => Body_Decls); 1318 1319 else 1320 -- Validate_RACW_Primitives requires the list of all primitives of 1321 -- the designated type, so defer processing until Desig is frozen. 1322 -- See Exp_Ch3.Freeze_Type. 1323 1324 Add_Access_Type_To_Process (E => Desig, A => RACW_Type); 1325 end if; 1326 end Add_RACW_Features; 1327 1328 ------------------------------------------------ 1329 -- Add_RACW_Primitive_Declarations_And_Bodies -- 1330 ------------------------------------------------ 1331 1332 procedure Add_RACW_Primitive_Declarations_And_Bodies 1333 (Designated_Type : Entity_Id; 1334 Insertion_Node : Node_Id; 1335 Body_Decls : List_Id) 1336 is 1337 Loc : constant Source_Ptr := Sloc (Insertion_Node); 1338 -- Set Sloc of generated declaration copy of insertion node Sloc, so 1339 -- the declarations are recognized as belonging to the current package. 1340 1341 Stub_Elements : constant Stub_Structure := 1342 Stubs_Table.Get (Designated_Type); 1343 1344 pragma Assert (Stub_Elements /= Empty_Stub_Structure); 1345 1346 Is_RAS : constant Boolean := 1347 not Comes_From_Source (Stub_Elements.RACW_Type); 1348 -- Case of the RACW generated to implement a remote access-to- 1349 -- subprogram type. 1350 1351 Build_Bodies : constant Boolean := 1352 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type); 1353 -- True when bodies must be prepared in Body_Decls. Bodies are generated 1354 -- only when the main unit is the unit that contains the stub type. 1355 1356 Current_Insertion_Node : Node_Id := Insertion_Node; 1357 1358 RPC_Receiver : Entity_Id; 1359 RPC_Receiver_Statements : List_Id; 1360 RPC_Receiver_Case_Alternatives : constant List_Id := New_List; 1361 RPC_Receiver_Elsif_Parts : List_Id; 1362 RPC_Receiver_Request : Entity_Id; 1363 RPC_Receiver_Subp_Id : Entity_Id; 1364 RPC_Receiver_Subp_Index : Entity_Id; 1365 1366 Subp_Str : String_Id; 1367 1368 Current_Primitive_Elmt : Elmt_Id; 1369 Current_Primitive : Entity_Id; 1370 Current_Primitive_Body : Node_Id; 1371 Current_Primitive_Spec : Node_Id; 1372 Current_Primitive_Decl : Node_Id; 1373 Current_Primitive_Number : Int := 0; 1374 Current_Primitive_Alias : Node_Id; 1375 Current_Receiver : Entity_Id; 1376 Current_Receiver_Body : Node_Id; 1377 RPC_Receiver_Decl : Node_Id; 1378 Possibly_Asynchronous : Boolean; 1379 1380 begin 1381 if not Expander_Active then 1382 return; 1383 end if; 1384 1385 if not Is_RAS then 1386 RPC_Receiver := Make_Temporary (Loc, 'P'); 1387 1388 Specific_Build_RPC_Receiver_Body 1389 (RPC_Receiver => RPC_Receiver, 1390 Request => RPC_Receiver_Request, 1391 Subp_Id => RPC_Receiver_Subp_Id, 1392 Subp_Index => RPC_Receiver_Subp_Index, 1393 Stmts => RPC_Receiver_Statements, 1394 Decl => RPC_Receiver_Decl); 1395 1396 if Get_PCS_Name = Name_PolyORB_DSA then 1397 1398 -- For the case of PolyORB, we need to map a textual operation 1399 -- name into a primitive index. Currently we do so using a simple 1400 -- sequence of string comparisons. 1401 1402 RPC_Receiver_Elsif_Parts := New_List; 1403 end if; 1404 end if; 1405 1406 -- Build callers, receivers for every primitive operations and a RPC 1407 -- receiver for this type. Note that we use Direct_Primitive_Operations, 1408 -- not Primitive_Operations, because we really want just the primitives 1409 -- of the tagged type itself, and in the case of a tagged synchronized 1410 -- type we do not want to get the primitives of the corresponding 1411 -- record type). 1412 1413 if Present (Direct_Primitive_Operations (Designated_Type)) then 1414 Overload_Counter_Table.Reset; 1415 1416 Current_Primitive_Elmt := 1417 First_Elmt (Direct_Primitive_Operations (Designated_Type)); 1418 while Current_Primitive_Elmt /= No_Elmt loop 1419 Current_Primitive := Node (Current_Primitive_Elmt); 1420 1421 -- Copy the primitive of all the parents, except predefined ones 1422 -- that are not remotely dispatching. Also omit hidden primitives 1423 -- (occurs in the case of primitives of interface progenitors 1424 -- other than immediate ancestors of the Designated_Type). 1425 1426 if Chars (Current_Primitive) /= Name_uSize 1427 and then Chars (Current_Primitive) /= Name_uAlignment 1428 and then not 1429 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else 1430 Is_TSS (Current_Primitive, TSS_Stream_Input) or else 1431 Is_TSS (Current_Primitive, TSS_Stream_Output) or else 1432 Is_TSS (Current_Primitive, TSS_Stream_Read) or else 1433 Is_TSS (Current_Primitive, TSS_Stream_Write) 1434 or else 1435 Is_Predefined_Interface_Primitive (Current_Primitive)) 1436 and then not Is_Hidden (Current_Primitive) 1437 then 1438 -- The first thing to do is build an up-to-date copy of the 1439 -- spec with all the formals referencing Controlling_Type 1440 -- transformed into formals referencing Stub_Type. Since this 1441 -- primitive may have been inherited, go back the alias chain 1442 -- until the real primitive has been found. 1443 1444 Current_Primitive_Alias := Ultimate_Alias (Current_Primitive); 1445 1446 -- Copy the spec from the original declaration for the purpose 1447 -- of declaring an overriding subprogram: we need to replace 1448 -- the type of each controlling formal with Stub_Type. The 1449 -- primitive may have been declared for Controlling_Type or 1450 -- inherited from some ancestor type for which we do not have 1451 -- an easily determined Entity_Id. We have no systematic way 1452 -- of knowing which type to substitute Stub_Type for. Instead, 1453 -- Copy_Specification relies on the flag Is_Controlling_Formal 1454 -- to determine which formals to change. 1455 1456 Current_Primitive_Spec := 1457 Copy_Specification (Loc, 1458 Spec => Parent (Current_Primitive_Alias), 1459 Ctrl_Type => Stub_Elements.Stub_Type); 1460 1461 Current_Primitive_Decl := 1462 Make_Subprogram_Declaration (Loc, 1463 Specification => Current_Primitive_Spec); 1464 1465 Insert_After_And_Analyze (Current_Insertion_Node, 1466 Current_Primitive_Decl); 1467 Current_Insertion_Node := Current_Primitive_Decl; 1468 1469 Possibly_Asynchronous := 1470 Nkind (Current_Primitive_Spec) = N_Procedure_Specification 1471 and then Could_Be_Asynchronous (Current_Primitive_Spec); 1472 1473 Assign_Subprogram_Identifier ( 1474 Defining_Unit_Name (Current_Primitive_Spec), 1475 Current_Primitive_Number, 1476 Subp_Str); 1477 1478 if Build_Bodies then 1479 Current_Primitive_Body := 1480 Build_Subprogram_Calling_Stubs 1481 (Vis_Decl => Current_Primitive_Decl, 1482 Subp_Id => 1483 Build_Subprogram_Id (Loc, 1484 Defining_Unit_Name (Current_Primitive_Spec)), 1485 Asynchronous => Possibly_Asynchronous, 1486 Dynamically_Asynchronous => Possibly_Asynchronous, 1487 Stub_Type => Stub_Elements.Stub_Type, 1488 RACW_Type => Stub_Elements.RACW_Type); 1489 Append_To (Body_Decls, Current_Primitive_Body); 1490 1491 -- Analyzing the body here would cause the Stub type to 1492 -- be frozen, thus preventing subsequent primitive 1493 -- declarations. For this reason, it will be analyzed 1494 -- later in the regular flow (and in the context of the 1495 -- appropriate unit body, see Append_RACW_Bodies). 1496 1497 end if; 1498 1499 -- Build the receiver stubs 1500 1501 if Build_Bodies and then not Is_RAS then 1502 Current_Receiver_Body := 1503 Specific_Build_Subprogram_Receiving_Stubs 1504 (Vis_Decl => Current_Primitive_Decl, 1505 Asynchronous => Possibly_Asynchronous, 1506 Dynamically_Asynchronous => Possibly_Asynchronous, 1507 Stub_Type => Stub_Elements.Stub_Type, 1508 RACW_Type => Stub_Elements.RACW_Type, 1509 Parent_Primitive => Current_Primitive); 1510 1511 Current_Receiver := 1512 Defining_Unit_Name (Specification (Current_Receiver_Body)); 1513 1514 Append_To (Body_Decls, Current_Receiver_Body); 1515 1516 -- Add a case alternative to the receiver 1517 1518 if Get_PCS_Name = Name_PolyORB_DSA then 1519 Append_To (RPC_Receiver_Elsif_Parts, 1520 Make_Elsif_Part (Loc, 1521 Condition => 1522 Make_Function_Call (Loc, 1523 Name => 1524 New_Occurrence_Of ( 1525 RTE (RE_Caseless_String_Eq), Loc), 1526 Parameter_Associations => New_List ( 1527 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), 1528 Make_String_Literal (Loc, Subp_Str))), 1529 1530 Then_Statements => New_List ( 1531 Make_Assignment_Statement (Loc, 1532 Name => New_Occurrence_Of ( 1533 RPC_Receiver_Subp_Index, Loc), 1534 Expression => 1535 Make_Integer_Literal (Loc, 1536 Intval => Current_Primitive_Number))))); 1537 end if; 1538 1539 Append_To (RPC_Receiver_Case_Alternatives, 1540 Make_Case_Statement_Alternative (Loc, 1541 Discrete_Choices => New_List ( 1542 Make_Integer_Literal (Loc, Current_Primitive_Number)), 1543 1544 Statements => New_List ( 1545 Make_Procedure_Call_Statement (Loc, 1546 Name => 1547 New_Occurrence_Of (Current_Receiver, Loc), 1548 Parameter_Associations => New_List ( 1549 New_Occurrence_Of (RPC_Receiver_Request, Loc)))))); 1550 end if; 1551 1552 -- Increment the index of current primitive 1553 1554 Current_Primitive_Number := Current_Primitive_Number + 1; 1555 end if; 1556 1557 Next_Elmt (Current_Primitive_Elmt); 1558 end loop; 1559 end if; 1560 1561 -- Build the case statement and the heart of the subprogram 1562 1563 if Build_Bodies and then not Is_RAS then 1564 if Get_PCS_Name = Name_PolyORB_DSA 1565 and then Present (First (RPC_Receiver_Elsif_Parts)) 1566 then 1567 Append_To (RPC_Receiver_Statements, 1568 Make_Implicit_If_Statement (Designated_Type, 1569 Condition => New_Occurrence_Of (Standard_False, Loc), 1570 Then_Statements => New_List, 1571 Elsif_Parts => RPC_Receiver_Elsif_Parts)); 1572 end if; 1573 1574 Append_To (RPC_Receiver_Case_Alternatives, 1575 Make_Case_Statement_Alternative (Loc, 1576 Discrete_Choices => New_List (Make_Others_Choice (Loc)), 1577 Statements => New_List (Make_Null_Statement (Loc)))); 1578 1579 Append_To (RPC_Receiver_Statements, 1580 Make_Case_Statement (Loc, 1581 Expression => 1582 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc), 1583 Alternatives => RPC_Receiver_Case_Alternatives)); 1584 1585 Append_To (Body_Decls, RPC_Receiver_Decl); 1586 Specific_Add_Obj_RPC_Receiver_Completion (Loc, 1587 Body_Decls, RPC_Receiver, Stub_Elements); 1588 1589 -- Do not analyze RPC receiver body at this stage since it references 1590 -- subprograms that have not been analyzed yet. It will be analyzed in 1591 -- the regular flow (see Append_RACW_Bodies). 1592 1593 end if; 1594 end Add_RACW_Primitive_Declarations_And_Bodies; 1595 1596 ----------------------------- 1597 -- Add_RAS_Dereference_TSS -- 1598 ----------------------------- 1599 1600 procedure Add_RAS_Dereference_TSS (N : Node_Id) is 1601 Loc : constant Source_Ptr := Sloc (N); 1602 1603 Type_Def : constant Node_Id := Type_Definition (N); 1604 RAS_Type : constant Entity_Id := Defining_Identifier (N); 1605 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type); 1606 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type); 1607 1608 RACW_Primitive_Name : Node_Id; 1609 1610 Proc : constant Entity_Id := 1611 Make_Defining_Identifier (Loc, 1612 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference)); 1613 1614 Proc_Spec : Node_Id; 1615 Param_Specs : List_Id; 1616 Param_Assoc : constant List_Id := New_List; 1617 Stmts : constant List_Id := New_List; 1618 1619 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P'); 1620 1621 Is_Function : constant Boolean := 1622 Nkind (Type_Def) = N_Access_Function_Definition; 1623 1624 Is_Degenerate : Boolean; 1625 -- Set to True if the subprogram_specification for this RAS has an 1626 -- anonymous access parameter (see Process_Remote_AST_Declaration). 1627 1628 Spec : constant Node_Id := Type_Def; 1629 1630 Current_Parameter : Node_Id; 1631 1632 -- Start of processing for Add_RAS_Dereference_TSS 1633 1634 begin 1635 -- The Dereference TSS for a remote access-to-subprogram type has the 1636 -- form: 1637 1638 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>) 1639 -- [return <>] 1640 1641 -- This is called whenever a value of a RAS type is dereferenced 1642 1643 -- First construct a list of parameter specifications: 1644 1645 -- The first formal is the RAS values 1646 1647 Param_Specs := New_List ( 1648 Make_Parameter_Specification (Loc, 1649 Defining_Identifier => RAS_Parameter, 1650 In_Present => True, 1651 Parameter_Type => 1652 New_Occurrence_Of (Fat_Type, Loc))); 1653 1654 -- The following formals are copied from the type declaration 1655 1656 Is_Degenerate := False; 1657 Current_Parameter := First (Parameter_Specifications (Type_Def)); 1658 Parameters : while Present (Current_Parameter) loop 1659 if Nkind (Parameter_Type (Current_Parameter)) = 1660 N_Access_Definition 1661 then 1662 Is_Degenerate := True; 1663 end if; 1664 1665 Append_To (Param_Specs, 1666 Make_Parameter_Specification (Loc, 1667 Defining_Identifier => 1668 Make_Defining_Identifier (Loc, 1669 Chars => Chars (Defining_Identifier (Current_Parameter))), 1670 In_Present => In_Present (Current_Parameter), 1671 Out_Present => Out_Present (Current_Parameter), 1672 Parameter_Type => 1673 New_Copy_Tree (Parameter_Type (Current_Parameter)), 1674 Expression => 1675 New_Copy_Tree (Expression (Current_Parameter)))); 1676 1677 Append_To (Param_Assoc, 1678 Make_Identifier (Loc, 1679 Chars => Chars (Defining_Identifier (Current_Parameter)))); 1680 1681 Next (Current_Parameter); 1682 end loop Parameters; 1683 1684 if Is_Degenerate then 1685 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc)); 1686 1687 -- Generate a dummy body. This code will never actually be executed, 1688 -- because null is the only legal value for a degenerate RAS type. 1689 -- For legality's sake (in order to avoid generating a function that 1690 -- does not contain a return statement), we include a dummy recursive 1691 -- call on the TSS itself. 1692 1693 Append_To (Stmts, 1694 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); 1695 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc); 1696 1697 else 1698 -- For a normal RAS type, we cast the RAS formal to the corresponding 1699 -- tagged type, and perform a dispatching call to its Call primitive 1700 -- operation. 1701 1702 Prepend_To (Param_Assoc, 1703 Unchecked_Convert_To (RACW_Type, 1704 New_Occurrence_Of (RAS_Parameter, Loc))); 1705 1706 RACW_Primitive_Name := 1707 Make_Selected_Component (Loc, 1708 Prefix => Scope (RACW_Type), 1709 Selector_Name => Name_uCall); 1710 end if; 1711 1712 if Is_Function then 1713 Append_To (Stmts, 1714 Make_Simple_Return_Statement (Loc, 1715 Expression => 1716 Make_Function_Call (Loc, 1717 Name => RACW_Primitive_Name, 1718 Parameter_Associations => Param_Assoc))); 1719 1720 else 1721 Append_To (Stmts, 1722 Make_Procedure_Call_Statement (Loc, 1723 Name => RACW_Primitive_Name, 1724 Parameter_Associations => Param_Assoc)); 1725 end if; 1726 1727 -- Build the complete subprogram 1728 1729 if Is_Function then 1730 Proc_Spec := 1731 Make_Function_Specification (Loc, 1732 Defining_Unit_Name => Proc, 1733 Parameter_Specifications => Param_Specs, 1734 Result_Definition => 1735 New_Occurrence_Of ( 1736 Entity (Result_Definition (Spec)), Loc)); 1737 1738 Set_Ekind (Proc, E_Function); 1739 Set_Etype (Proc, 1740 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc)); 1741 1742 else 1743 Proc_Spec := 1744 Make_Procedure_Specification (Loc, 1745 Defining_Unit_Name => Proc, 1746 Parameter_Specifications => Param_Specs); 1747 1748 Set_Ekind (Proc, E_Procedure); 1749 Set_Etype (Proc, Standard_Void_Type); 1750 end if; 1751 1752 Discard_Node ( 1753 Make_Subprogram_Body (Loc, 1754 Specification => Proc_Spec, 1755 Declarations => New_List, 1756 Handled_Statement_Sequence => 1757 Make_Handled_Sequence_Of_Statements (Loc, 1758 Statements => Stmts))); 1759 1760 Set_TSS (Fat_Type, Proc); 1761 end Add_RAS_Dereference_TSS; 1762 1763 ------------------------------- 1764 -- Add_RAS_Proxy_And_Analyze -- 1765 ------------------------------- 1766 1767 procedure Add_RAS_Proxy_And_Analyze 1768 (Decls : List_Id; 1769 Vis_Decl : Node_Id; 1770 All_Calls_Remote_E : Entity_Id; 1771 Proxy_Object_Addr : out Entity_Id) 1772 is 1773 Loc : constant Source_Ptr := Sloc (Vis_Decl); 1774 1775 Subp_Name : constant Entity_Id := 1776 Defining_Unit_Name (Specification (Vis_Decl)); 1777 1778 Pkg_Name : constant Entity_Id := 1779 Make_Defining_Identifier (Loc, 1780 Chars => New_External_Name (Chars (Subp_Name), 'P', -1)); 1781 1782 Proxy_Type : constant Entity_Id := 1783 Make_Defining_Identifier (Loc, 1784 Chars => 1785 New_External_Name 1786 (Related_Id => Chars (Subp_Name), 1787 Suffix => 'P')); 1788 1789 Proxy_Type_Full_View : constant Entity_Id := 1790 Make_Defining_Identifier (Loc, 1791 Chars (Proxy_Type)); 1792 1793 Subp_Decl_Spec : constant Node_Id := 1794 Build_RAS_Primitive_Specification 1795 (Subp_Spec => Specification (Vis_Decl), 1796 Remote_Object_Type => Proxy_Type); 1797 1798 Subp_Body_Spec : constant Node_Id := 1799 Build_RAS_Primitive_Specification 1800 (Subp_Spec => Specification (Vis_Decl), 1801 Remote_Object_Type => Proxy_Type); 1802 1803 Vis_Decls : constant List_Id := New_List; 1804 Pvt_Decls : constant List_Id := New_List; 1805 Actuals : constant List_Id := New_List; 1806 Formal : Node_Id; 1807 Perform_Call : Node_Id; 1808 1809 begin 1810 -- type subpP is tagged limited private; 1811 1812 Append_To (Vis_Decls, 1813 Make_Private_Type_Declaration (Loc, 1814 Defining_Identifier => Proxy_Type, 1815 Tagged_Present => True, 1816 Limited_Present => True)); 1817 1818 -- [subprogram] Call 1819 -- (Self : access subpP; 1820 -- ...other-formals...) 1821 -- [return T]; 1822 1823 Append_To (Vis_Decls, 1824 Make_Subprogram_Declaration (Loc, 1825 Specification => Subp_Decl_Spec)); 1826 1827 -- A : constant System.Address; 1828 1829 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA); 1830 1831 Append_To (Vis_Decls, 1832 Make_Object_Declaration (Loc, 1833 Defining_Identifier => Proxy_Object_Addr, 1834 Constant_Present => True, 1835 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc))); 1836 1837 -- private 1838 1839 -- type subpP is tagged limited record 1840 -- All_Calls_Remote : Boolean := [All_Calls_Remote?]; 1841 -- ... 1842 -- end record; 1843 1844 Append_To (Pvt_Decls, 1845 Make_Full_Type_Declaration (Loc, 1846 Defining_Identifier => Proxy_Type_Full_View, 1847 Type_Definition => 1848 Build_Remote_Subprogram_Proxy_Type (Loc, 1849 New_Occurrence_Of (All_Calls_Remote_E, Loc)))); 1850 1851 -- Trick semantic analysis into swapping the public and full view when 1852 -- freezing the public view. 1853 1854 Set_Comes_From_Source (Proxy_Type_Full_View, True); 1855 1856 -- procedure Call 1857 -- (Self : access O; 1858 -- ...other-formals...) is 1859 -- begin 1860 -- P (...other-formals...); 1861 -- end Call; 1862 1863 -- function Call 1864 -- (Self : access O; 1865 -- ...other-formals...) 1866 -- return T is 1867 -- begin 1868 -- return F (...other-formals...); 1869 -- end Call; 1870 1871 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then 1872 Perform_Call := 1873 Make_Procedure_Call_Statement (Loc, 1874 Name => New_Occurrence_Of (Subp_Name, Loc), 1875 Parameter_Associations => Actuals); 1876 else 1877 Perform_Call := 1878 Make_Simple_Return_Statement (Loc, 1879 Expression => 1880 Make_Function_Call (Loc, 1881 Name => New_Occurrence_Of (Subp_Name, Loc), 1882 Parameter_Associations => Actuals)); 1883 end if; 1884 1885 Formal := First (Parameter_Specifications (Subp_Decl_Spec)); 1886 pragma Assert (Present (Formal)); 1887 loop 1888 Next (Formal); 1889 exit when No (Formal); 1890 Append_To (Actuals, 1891 New_Occurrence_Of (Defining_Identifier (Formal), Loc)); 1892 end loop; 1893 1894 -- O : aliased subpP; 1895 1896 Append_To (Pvt_Decls, 1897 Make_Object_Declaration (Loc, 1898 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO), 1899 Aliased_Present => True, 1900 Object_Definition => New_Occurrence_Of (Proxy_Type, Loc))); 1901 1902 -- A : constant System.Address := O'Address; 1903 1904 Append_To (Pvt_Decls, 1905 Make_Object_Declaration (Loc, 1906 Defining_Identifier => 1907 Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)), 1908 Constant_Present => True, 1909 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc), 1910 Expression => 1911 Make_Attribute_Reference (Loc, 1912 Prefix => New_Occurrence_Of ( 1913 Defining_Identifier (Last (Pvt_Decls)), Loc), 1914 Attribute_Name => Name_Address))); 1915 1916 Append_To (Decls, 1917 Make_Package_Declaration (Loc, 1918 Specification => Make_Package_Specification (Loc, 1919 Defining_Unit_Name => Pkg_Name, 1920 Visible_Declarations => Vis_Decls, 1921 Private_Declarations => Pvt_Decls, 1922 End_Label => Empty))); 1923 Analyze (Last (Decls)); 1924 1925 Append_To (Decls, 1926 Make_Package_Body (Loc, 1927 Defining_Unit_Name => 1928 Make_Defining_Identifier (Loc, Chars (Pkg_Name)), 1929 Declarations => New_List ( 1930 Make_Subprogram_Body (Loc, 1931 Specification => Subp_Body_Spec, 1932 Declarations => New_List, 1933 Handled_Statement_Sequence => 1934 Make_Handled_Sequence_Of_Statements (Loc, 1935 Statements => New_List (Perform_Call)))))); 1936 Analyze (Last (Decls)); 1937 end Add_RAS_Proxy_And_Analyze; 1938 1939 ----------------------- 1940 -- Add_RAST_Features -- 1941 ----------------------- 1942 1943 procedure Add_RAST_Features (Vis_Decl : Node_Id) is 1944 RAS_Type : constant Entity_Id := 1945 Equivalent_Type (Defining_Identifier (Vis_Decl)); 1946 begin 1947 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access))); 1948 Add_RAS_Dereference_TSS (Vis_Decl); 1949 Specific_Add_RAST_Features (Vis_Decl, RAS_Type); 1950 end Add_RAST_Features; 1951 1952 ------------------- 1953 -- Add_Stub_Type -- 1954 ------------------- 1955 1956 procedure Add_Stub_Type 1957 (Designated_Type : Entity_Id; 1958 RACW_Type : Entity_Id; 1959 Decls : List_Id; 1960 Stub_Type : out Entity_Id; 1961 Stub_Type_Access : out Entity_Id; 1962 RPC_Receiver_Decl : out Node_Id; 1963 Body_Decls : out List_Id; 1964 Existing : out Boolean) 1965 is 1966 Loc : constant Source_Ptr := Sloc (RACW_Type); 1967 1968 Stub_Elements : constant Stub_Structure := 1969 Stubs_Table.Get (Designated_Type); 1970 Stub_Type_Decl : Node_Id; 1971 Stub_Type_Access_Decl : Node_Id; 1972 1973 begin 1974 if Stub_Elements /= Empty_Stub_Structure then 1975 Stub_Type := Stub_Elements.Stub_Type; 1976 Stub_Type_Access := Stub_Elements.Stub_Type_Access; 1977 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl; 1978 Body_Decls := Stub_Elements.Body_Decls; 1979 Existing := True; 1980 return; 1981 end if; 1982 1983 Existing := False; 1984 Stub_Type := Make_Temporary (Loc, 'S'); 1985 Set_Ekind (Stub_Type, E_Record_Type); 1986 Set_Is_RACW_Stub_Type (Stub_Type); 1987 Stub_Type_Access := 1988 Make_Defining_Identifier (Loc, 1989 Chars => New_External_Name 1990 (Related_Id => Chars (Stub_Type), Suffix => 'A')); 1991 1992 RPC_Receiver_Decl := Specific_RPC_Receiver_Decl (RACW_Type); 1993 1994 -- Create new stub type, copying components from generic RACW_Stub_Type 1995 1996 Stub_Type_Decl := 1997 Make_Full_Type_Declaration (Loc, 1998 Defining_Identifier => Stub_Type, 1999 Type_Definition => 2000 Make_Record_Definition (Loc, 2001 Tagged_Present => True, 2002 Limited_Present => True, 2003 Component_List => 2004 Make_Component_List (Loc, 2005 Component_Items => 2006 Copy_Component_List (RTE (RE_RACW_Stub_Type), Loc)))); 2007 2008 -- Does the stub type need to explicitly implement interfaces from the 2009 -- designated type??? 2010 2011 -- In particular are there issues in the case where the designated type 2012 -- is a synchronized interface??? 2013 2014 Stub_Type_Access_Decl := 2015 Make_Full_Type_Declaration (Loc, 2016 Defining_Identifier => Stub_Type_Access, 2017 Type_Definition => 2018 Make_Access_To_Object_Definition (Loc, 2019 All_Present => True, 2020 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc))); 2021 2022 Append_To (Decls, Stub_Type_Decl); 2023 Analyze (Last (Decls)); 2024 Append_To (Decls, Stub_Type_Access_Decl); 2025 Analyze (Last (Decls)); 2026 2027 -- We can't directly derive the stub type from the designated type, 2028 -- because we don't want any components or discriminants from the real 2029 -- type, so instead we manually fake a derivation to get an appropriate 2030 -- dispatch table. 2031 2032 Derive_Subprograms (Parent_Type => Designated_Type, 2033 Derived_Type => Stub_Type); 2034 2035 if Present (RPC_Receiver_Decl) then 2036 Append_To (Decls, RPC_Receiver_Decl); 2037 2038 else 2039 -- Kludge, requires comment??? 2040 2041 RPC_Receiver_Decl := Last (Decls); 2042 end if; 2043 2044 Body_Decls := New_List; 2045 2046 Stubs_Table.Set (Designated_Type, 2047 (Stub_Type => Stub_Type, 2048 Stub_Type_Access => Stub_Type_Access, 2049 RPC_Receiver_Decl => RPC_Receiver_Decl, 2050 Body_Decls => Body_Decls, 2051 RACW_Type => RACW_Type)); 2052 end Add_Stub_Type; 2053 2054 ------------------------ 2055 -- Append_RACW_Bodies -- 2056 ------------------------ 2057 2058 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is 2059 E : Entity_Id; 2060 2061 begin 2062 E := First_Entity (Spec_Id); 2063 while Present (E) loop 2064 if Is_Remote_Access_To_Class_Wide_Type (E) then 2065 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E)); 2066 end if; 2067 2068 Next_Entity (E); 2069 end loop; 2070 end Append_RACW_Bodies; 2071 2072 ---------------------------------- 2073 -- Assign_Subprogram_Identifier -- 2074 ---------------------------------- 2075 2076 procedure Assign_Subprogram_Identifier 2077 (Def : Entity_Id; 2078 Spn : Int; 2079 Id : out String_Id) 2080 is 2081 N : constant Name_Id := Chars (Def); 2082 2083 Overload_Order : constant Int := Overload_Counter_Table.Get (N) + 1; 2084 2085 begin 2086 Overload_Counter_Table.Set (N, Overload_Order); 2087 2088 Get_Name_String (N); 2089 2090 -- Homonym handling: as in Exp_Dbug, but much simpler, because the only 2091 -- entities for which we have to generate names here need only to be 2092 -- disambiguated within their own scope. 2093 2094 if Overload_Order > 1 then 2095 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__"; 2096 Name_Len := Name_Len + 2; 2097 Add_Nat_To_Name_Buffer (Overload_Order); 2098 end if; 2099 2100 Id := String_From_Name_Buffer; 2101 Subprogram_Identifier_Table.Set 2102 (Def, 2103 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn)); 2104 end Assign_Subprogram_Identifier; 2105 2106 ------------------------------------- 2107 -- Build_Actual_Object_Declaration -- 2108 ------------------------------------- 2109 2110 procedure Build_Actual_Object_Declaration 2111 (Object : Entity_Id; 2112 Etyp : Entity_Id; 2113 Variable : Boolean; 2114 Expr : Node_Id; 2115 Decls : List_Id) 2116 is 2117 Loc : constant Source_Ptr := Sloc (Object); 2118 2119 begin 2120 -- Declare a temporary object for the actual, possibly initialized with 2121 -- a 'Input/From_Any call. 2122 2123 -- Complication arises in the case of limited types, for which such a 2124 -- declaration is illegal in Ada 95. In that case, we first generate a 2125 -- renaming declaration of the 'Input call, and then if needed we 2126 -- generate an overlaid non-constant view. 2127 2128 if Ada_Version <= Ada_95 2129 and then Is_Limited_Type (Etyp) 2130 and then Present (Expr) 2131 then 2132 2133 -- Object : Etyp renames <func-call> 2134 2135 Append_To (Decls, 2136 Make_Object_Renaming_Declaration (Loc, 2137 Defining_Identifier => Object, 2138 Subtype_Mark => New_Occurrence_Of (Etyp, Loc), 2139 Name => Expr)); 2140 2141 if Variable then 2142 2143 -- The name defined by the renaming declaration denotes a 2144 -- constant view; create a non-constant object at the same address 2145 -- to be used as the actual. 2146 2147 declare 2148 Constant_Object : constant Entity_Id := 2149 Make_Temporary (Loc, 'P'); 2150 2151 begin 2152 Set_Defining_Identifier 2153 (Last (Decls), Constant_Object); 2154 2155 -- We have an unconstrained Etyp: build the actual constrained 2156 -- subtype for the value we just read from the stream. 2157 2158 -- subtype S is <actual subtype of Constant_Object>; 2159 2160 Append_To (Decls, 2161 Build_Actual_Subtype (Etyp, 2162 New_Occurrence_Of (Constant_Object, Loc))); 2163 2164 -- Object : S; 2165 2166 Append_To (Decls, 2167 Make_Object_Declaration (Loc, 2168 Defining_Identifier => Object, 2169 Object_Definition => 2170 New_Occurrence_Of 2171 (Defining_Identifier (Last (Decls)), Loc))); 2172 Set_Ekind (Object, E_Variable); 2173 2174 -- Suppress default initialization: 2175 -- pragma Import (Ada, Object); 2176 2177 Append_To (Decls, 2178 Make_Pragma (Loc, 2179 Chars => Name_Import, 2180 Pragma_Argument_Associations => New_List ( 2181 Make_Pragma_Argument_Association (Loc, 2182 Chars => Name_Convention, 2183 Expression => Make_Identifier (Loc, Name_Ada)), 2184 Make_Pragma_Argument_Association (Loc, 2185 Chars => Name_Entity, 2186 Expression => New_Occurrence_Of (Object, Loc))))); 2187 2188 -- for Object'Address use Constant_Object'Address; 2189 2190 Append_To (Decls, 2191 Make_Attribute_Definition_Clause (Loc, 2192 Name => New_Occurrence_Of (Object, Loc), 2193 Chars => Name_Address, 2194 Expression => 2195 Make_Attribute_Reference (Loc, 2196 Prefix => New_Occurrence_Of (Constant_Object, Loc), 2197 Attribute_Name => Name_Address))); 2198 end; 2199 end if; 2200 2201 else 2202 -- General case of a regular object declaration. Object is flagged 2203 -- constant unless it has mode out or in out, to allow the backend 2204 -- to optimize where possible. 2205 2206 -- Object : [constant] Etyp [:= <expr>]; 2207 2208 Append_To (Decls, 2209 Make_Object_Declaration (Loc, 2210 Defining_Identifier => Object, 2211 Constant_Present => Present (Expr) and then not Variable, 2212 Object_Definition => New_Occurrence_Of (Etyp, Loc), 2213 Expression => Expr)); 2214 2215 if Constant_Present (Last (Decls)) then 2216 Set_Ekind (Object, E_Constant); 2217 else 2218 Set_Ekind (Object, E_Variable); 2219 end if; 2220 end if; 2221 end Build_Actual_Object_Declaration; 2222 2223 ------------------------------ 2224 -- Build_Get_Unique_RP_Call -- 2225 ------------------------------ 2226 2227 function Build_Get_Unique_RP_Call 2228 (Loc : Source_Ptr; 2229 Pointer : Entity_Id; 2230 Stub_Type : Entity_Id) return List_Id 2231 is 2232 begin 2233 return New_List ( 2234 Make_Procedure_Call_Statement (Loc, 2235 Name => 2236 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc), 2237 Parameter_Associations => New_List ( 2238 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), 2239 New_Occurrence_Of (Pointer, Loc)))), 2240 2241 Make_Assignment_Statement (Loc, 2242 Name => 2243 Make_Selected_Component (Loc, 2244 Prefix => New_Occurrence_Of (Pointer, Loc), 2245 Selector_Name => 2246 New_Occurrence_Of (First_Tag_Component 2247 (Designated_Type (Etype (Pointer))), Loc)), 2248 Expression => 2249 Make_Attribute_Reference (Loc, 2250 Prefix => New_Occurrence_Of (Stub_Type, Loc), 2251 Attribute_Name => Name_Tag))); 2252 2253 -- Note: The assignment to Pointer._Tag is safe here because 2254 -- we carefully ensured that Stub_Type has exactly the same layout 2255 -- as System.Partition_Interface.RACW_Stub_Type. 2256 2257 end Build_Get_Unique_RP_Call; 2258 2259 ----------------------------------- 2260 -- Build_Ordered_Parameters_List -- 2261 ----------------------------------- 2262 2263 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is 2264 Constrained_List : List_Id; 2265 Unconstrained_List : List_Id; 2266 Current_Parameter : Node_Id; 2267 Ptyp : Node_Id; 2268 2269 First_Parameter : Node_Id; 2270 For_RAS : Boolean := False; 2271 2272 begin 2273 if No (Parameter_Specifications (Spec)) then 2274 return New_List; 2275 end if; 2276 2277 Constrained_List := New_List; 2278 Unconstrained_List := New_List; 2279 First_Parameter := First (Parameter_Specifications (Spec)); 2280 2281 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition 2282 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS 2283 then 2284 For_RAS := True; 2285 end if; 2286 2287 -- Loop through the parameters and add them to the right list. Note that 2288 -- we treat a parameter of a null-excluding access type as unconstrained 2289 -- because we can't declare an object of such a type with default 2290 -- initialization. 2291 2292 Current_Parameter := First_Parameter; 2293 while Present (Current_Parameter) loop 2294 Ptyp := Parameter_Type (Current_Parameter); 2295 2296 if (Nkind (Ptyp) = N_Access_Definition 2297 or else not Transmit_As_Unconstrained (Etype (Ptyp))) 2298 and then not (For_RAS and then Current_Parameter = First_Parameter) 2299 then 2300 Append_To (Constrained_List, New_Copy (Current_Parameter)); 2301 else 2302 Append_To (Unconstrained_List, New_Copy (Current_Parameter)); 2303 end if; 2304 2305 Next (Current_Parameter); 2306 end loop; 2307 2308 -- Unconstrained parameters are returned first 2309 2310 Append_List_To (Unconstrained_List, Constrained_List); 2311 2312 return Unconstrained_List; 2313 end Build_Ordered_Parameters_List; 2314 2315 ---------------------------------- 2316 -- Build_Passive_Partition_Stub -- 2317 ---------------------------------- 2318 2319 procedure Build_Passive_Partition_Stub (U : Node_Id) is 2320 Pkg_Spec : Node_Id; 2321 Pkg_Name : String_Id; 2322 L : List_Id; 2323 Reg : Node_Id; 2324 Loc : constant Source_Ptr := Sloc (U); 2325 2326 begin 2327 -- Verify that the implementation supports distribution, by accessing 2328 -- a type defined in the proper version of system.rpc 2329 2330 declare 2331 Dist_OK : Entity_Id; 2332 pragma Warnings (Off, Dist_OK); 2333 begin 2334 Dist_OK := RTE (RE_Params_Stream_Type); 2335 end; 2336 2337 -- Use body if present, spec otherwise 2338 2339 if Nkind (U) = N_Package_Declaration then 2340 Pkg_Spec := Specification (U); 2341 L := Visible_Declarations (Pkg_Spec); 2342 else 2343 Pkg_Spec := Parent (Corresponding_Spec (U)); 2344 L := Declarations (U); 2345 end if; 2346 2347 Get_Library_Unit_Name_String (Pkg_Spec); 2348 Pkg_Name := String_From_Name_Buffer; 2349 Reg := 2350 Make_Procedure_Call_Statement (Loc, 2351 Name => 2352 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), 2353 Parameter_Associations => New_List ( 2354 Make_String_Literal (Loc, Pkg_Name), 2355 Make_Attribute_Reference (Loc, 2356 Prefix => 2357 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), 2358 Attribute_Name => Name_Version))); 2359 Append_To (L, Reg); 2360 Analyze (Reg); 2361 end Build_Passive_Partition_Stub; 2362 2363 -------------------------------------- 2364 -- Build_RPC_Receiver_Specification -- 2365 -------------------------------------- 2366 2367 function Build_RPC_Receiver_Specification 2368 (RPC_Receiver : Entity_Id; 2369 Request_Parameter : Entity_Id) return Node_Id 2370 is 2371 Loc : constant Source_Ptr := Sloc (RPC_Receiver); 2372 begin 2373 return 2374 Make_Procedure_Specification (Loc, 2375 Defining_Unit_Name => RPC_Receiver, 2376 Parameter_Specifications => New_List ( 2377 Make_Parameter_Specification (Loc, 2378 Defining_Identifier => Request_Parameter, 2379 Parameter_Type => 2380 New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); 2381 end Build_RPC_Receiver_Specification; 2382 2383 ---------------------------------------- 2384 -- Build_Remote_Subprogram_Proxy_Type -- 2385 ---------------------------------------- 2386 2387 function Build_Remote_Subprogram_Proxy_Type 2388 (Loc : Source_Ptr; 2389 ACR_Expression : Node_Id) return Node_Id 2390 is 2391 begin 2392 return 2393 Make_Record_Definition (Loc, 2394 Tagged_Present => True, 2395 Limited_Present => True, 2396 Component_List => 2397 Make_Component_List (Loc, 2398 Component_Items => New_List ( 2399 Make_Component_Declaration (Loc, 2400 Defining_Identifier => 2401 Make_Defining_Identifier (Loc, 2402 Name_All_Calls_Remote), 2403 Component_Definition => 2404 Make_Component_Definition (Loc, 2405 Subtype_Indication => 2406 New_Occurrence_Of (Standard_Boolean, Loc)), 2407 Expression => 2408 ACR_Expression), 2409 2410 Make_Component_Declaration (Loc, 2411 Defining_Identifier => 2412 Make_Defining_Identifier (Loc, 2413 Name_Receiver), 2414 Component_Definition => 2415 Make_Component_Definition (Loc, 2416 Subtype_Indication => 2417 New_Occurrence_Of (RTE (RE_Address), Loc)), 2418 Expression => 2419 New_Occurrence_Of (RTE (RE_Null_Address), Loc)), 2420 2421 Make_Component_Declaration (Loc, 2422 Defining_Identifier => 2423 Make_Defining_Identifier (Loc, 2424 Name_Subp_Id), 2425 Component_Definition => 2426 Make_Component_Definition (Loc, 2427 Subtype_Indication => 2428 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); 2429 end Build_Remote_Subprogram_Proxy_Type; 2430 2431 -------------------- 2432 -- Build_Stub_Tag -- 2433 -------------------- 2434 2435 function Build_Stub_Tag 2436 (Loc : Source_Ptr; 2437 RACW_Type : Entity_Id) return Node_Id 2438 is 2439 Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type); 2440 begin 2441 return 2442 Make_Attribute_Reference (Loc, 2443 Prefix => New_Occurrence_Of (Stub_Type, Loc), 2444 Attribute_Name => Name_Tag); 2445 end Build_Stub_Tag; 2446 2447 ------------------------------------ 2448 -- Build_Subprogram_Calling_Stubs -- 2449 ------------------------------------ 2450 2451 function Build_Subprogram_Calling_Stubs 2452 (Vis_Decl : Node_Id; 2453 Subp_Id : Node_Id; 2454 Asynchronous : Boolean; 2455 Dynamically_Asynchronous : Boolean := False; 2456 Stub_Type : Entity_Id := Empty; 2457 RACW_Type : Entity_Id := Empty; 2458 Locator : Entity_Id := Empty; 2459 New_Name : Name_Id := No_Name) return Node_Id 2460 is 2461 Loc : constant Source_Ptr := Sloc (Vis_Decl); 2462 2463 Decls : constant List_Id := New_List; 2464 Statements : constant List_Id := New_List; 2465 2466 Subp_Spec : Node_Id; 2467 -- The specification of the body 2468 2469 Controlling_Parameter : Entity_Id := Empty; 2470 2471 Asynchronous_Expr : Node_Id := Empty; 2472 2473 RCI_Locator : Entity_Id; 2474 2475 Spec_To_Use : Node_Id; 2476 2477 procedure Insert_Partition_Check (Parameter : Node_Id); 2478 -- Check that the parameter has been elaborated on the same partition 2479 -- than the controlling parameter (E.4(19)). 2480 2481 ---------------------------- 2482 -- Insert_Partition_Check -- 2483 ---------------------------- 2484 2485 procedure Insert_Partition_Check (Parameter : Node_Id) is 2486 Parameter_Entity : constant Entity_Id := 2487 Defining_Identifier (Parameter); 2488 begin 2489 -- The expression that will be built is of the form: 2490 2491 -- if not Same_Partition (Parameter, Controlling_Parameter) then 2492 -- raise Constraint_Error; 2493 -- end if; 2494 2495 -- We do not check that Parameter is in Stub_Type since such a check 2496 -- has been inserted at the point of call already (a tag check since 2497 -- we have multiple controlling operands). 2498 2499 Append_To (Decls, 2500 Make_Raise_Constraint_Error (Loc, 2501 Condition => 2502 Make_Op_Not (Loc, 2503 Right_Opnd => 2504 Make_Function_Call (Loc, 2505 Name => 2506 New_Occurrence_Of (RTE (RE_Same_Partition), Loc), 2507 Parameter_Associations => 2508 New_List ( 2509 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), 2510 New_Occurrence_Of (Parameter_Entity, Loc)), 2511 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), 2512 New_Occurrence_Of (Controlling_Parameter, Loc))))), 2513 Reason => CE_Partition_Check_Failed)); 2514 end Insert_Partition_Check; 2515 2516 -- Start of processing for Build_Subprogram_Calling_Stubs 2517 2518 begin 2519 Subp_Spec := 2520 Copy_Specification (Loc, 2521 Spec => Specification (Vis_Decl), 2522 New_Name => New_Name); 2523 2524 if Locator = Empty then 2525 RCI_Locator := RCI_Cache; 2526 Spec_To_Use := Specification (Vis_Decl); 2527 else 2528 RCI_Locator := Locator; 2529 Spec_To_Use := Subp_Spec; 2530 end if; 2531 2532 -- Find a controlling argument if we have a stub type. Also check 2533 -- if this subprogram can be made asynchronous. 2534 2535 if Present (Stub_Type) 2536 and then Present (Parameter_Specifications (Spec_To_Use)) 2537 then 2538 declare 2539 Current_Parameter : Node_Id := 2540 First (Parameter_Specifications 2541 (Spec_To_Use)); 2542 begin 2543 while Present (Current_Parameter) loop 2544 if 2545 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) 2546 then 2547 if Controlling_Parameter = Empty then 2548 Controlling_Parameter := 2549 Defining_Identifier (Current_Parameter); 2550 else 2551 Insert_Partition_Check (Current_Parameter); 2552 end if; 2553 end if; 2554 2555 Next (Current_Parameter); 2556 end loop; 2557 end; 2558 end if; 2559 2560 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter)); 2561 2562 if Dynamically_Asynchronous then 2563 Asynchronous_Expr := Make_Selected_Component (Loc, 2564 Prefix => Controlling_Parameter, 2565 Selector_Name => Name_Asynchronous); 2566 end if; 2567 2568 Specific_Build_General_Calling_Stubs 2569 (Decls => Decls, 2570 Statements => Statements, 2571 Target => Specific_Build_Stub_Target (Loc, 2572 Decls, RCI_Locator, Controlling_Parameter), 2573 Subprogram_Id => Subp_Id, 2574 Asynchronous => Asynchronous_Expr, 2575 Is_Known_Asynchronous => Asynchronous 2576 and then not Dynamically_Asynchronous, 2577 Is_Known_Non_Asynchronous 2578 => not Asynchronous 2579 and then not Dynamically_Asynchronous, 2580 Is_Function => Nkind (Spec_To_Use) = 2581 N_Function_Specification, 2582 Spec => Spec_To_Use, 2583 Stub_Type => Stub_Type, 2584 RACW_Type => RACW_Type, 2585 Nod => Vis_Decl); 2586 2587 RCI_Calling_Stubs_Table.Set 2588 (Defining_Unit_Name (Specification (Vis_Decl)), 2589 Defining_Unit_Name (Spec_To_Use)); 2590 2591 return 2592 Make_Subprogram_Body (Loc, 2593 Specification => Subp_Spec, 2594 Declarations => Decls, 2595 Handled_Statement_Sequence => 2596 Make_Handled_Sequence_Of_Statements (Loc, Statements)); 2597 end Build_Subprogram_Calling_Stubs; 2598 2599 ------------------------- 2600 -- Build_Subprogram_Id -- 2601 ------------------------- 2602 2603 function Build_Subprogram_Id 2604 (Loc : Source_Ptr; 2605 E : Entity_Id) return Node_Id 2606 is 2607 begin 2608 if Get_Subprogram_Ids (E).Str_Identifier = No_String then 2609 declare 2610 Current_Declaration : Node_Id; 2611 Current_Subp : Entity_Id; 2612 Current_Subp_Str : String_Id; 2613 Current_Subp_Number : Int := First_RCI_Subprogram_Id; 2614 2615 pragma Warnings (Off, Current_Subp_Str); 2616 2617 begin 2618 -- Build_Subprogram_Id is called outside of the context of 2619 -- generating calling or receiving stubs. Hence we are processing 2620 -- an 'Access attribute_reference for an RCI subprogram, for the 2621 -- purpose of obtaining a RAS value. 2622 2623 pragma Assert 2624 (Is_Remote_Call_Interface (Scope (E)) 2625 and then 2626 (Nkind (Parent (E)) = N_Procedure_Specification 2627 or else 2628 Nkind (Parent (E)) = N_Function_Specification)); 2629 2630 Current_Declaration := 2631 First (Visible_Declarations 2632 (Package_Specification_Of_Scope (Scope (E)))); 2633 while Present (Current_Declaration) loop 2634 if Nkind (Current_Declaration) = N_Subprogram_Declaration 2635 and then Comes_From_Source (Current_Declaration) 2636 then 2637 Current_Subp := Defining_Unit_Name (Specification ( 2638 Current_Declaration)); 2639 2640 Assign_Subprogram_Identifier 2641 (Current_Subp, Current_Subp_Number, Current_Subp_Str); 2642 2643 Current_Subp_Number := Current_Subp_Number + 1; 2644 end if; 2645 2646 Next (Current_Declaration); 2647 end loop; 2648 end; 2649 end if; 2650 2651 case Get_PCS_Name is 2652 when Name_PolyORB_DSA => 2653 return Make_String_Literal (Loc, Get_Subprogram_Id (E)); 2654 when others => 2655 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E)); 2656 end case; 2657 end Build_Subprogram_Id; 2658 2659 ------------------------ 2660 -- Copy_Specification -- 2661 ------------------------ 2662 2663 function Copy_Specification 2664 (Loc : Source_Ptr; 2665 Spec : Node_Id; 2666 Ctrl_Type : Entity_Id := Empty; 2667 New_Name : Name_Id := No_Name) return Node_Id 2668 is 2669 Parameters : List_Id := No_List; 2670 2671 Current_Parameter : Node_Id; 2672 Current_Identifier : Entity_Id; 2673 Current_Type : Node_Id; 2674 2675 Name_For_New_Spec : Name_Id; 2676 2677 New_Identifier : Entity_Id; 2678 2679 -- Comments needed in body below ??? 2680 2681 begin 2682 if New_Name = No_Name then 2683 pragma Assert (Nkind (Spec) = N_Function_Specification 2684 or else Nkind (Spec) = N_Procedure_Specification); 2685 2686 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec)); 2687 else 2688 Name_For_New_Spec := New_Name; 2689 end if; 2690 2691 if Present (Parameter_Specifications (Spec)) then 2692 Parameters := New_List; 2693 Current_Parameter := First (Parameter_Specifications (Spec)); 2694 while Present (Current_Parameter) loop 2695 Current_Identifier := Defining_Identifier (Current_Parameter); 2696 Current_Type := Parameter_Type (Current_Parameter); 2697 2698 if Nkind (Current_Type) = N_Access_Definition then 2699 if Present (Ctrl_Type) then 2700 pragma Assert (Is_Controlling_Formal (Current_Identifier)); 2701 Current_Type := 2702 Make_Access_Definition (Loc, 2703 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc), 2704 Null_Exclusion_Present => 2705 Null_Exclusion_Present (Current_Type)); 2706 2707 else 2708 Current_Type := 2709 Make_Access_Definition (Loc, 2710 Subtype_Mark => 2711 New_Copy_Tree (Subtype_Mark (Current_Type)), 2712 Null_Exclusion_Present => 2713 Null_Exclusion_Present (Current_Type)); 2714 end if; 2715 2716 else 2717 if Present (Ctrl_Type) 2718 and then Is_Controlling_Formal (Current_Identifier) 2719 then 2720 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc); 2721 else 2722 Current_Type := New_Copy_Tree (Current_Type); 2723 end if; 2724 end if; 2725 2726 New_Identifier := Make_Defining_Identifier (Loc, 2727 Chars (Current_Identifier)); 2728 2729 Append_To (Parameters, 2730 Make_Parameter_Specification (Loc, 2731 Defining_Identifier => New_Identifier, 2732 Parameter_Type => Current_Type, 2733 In_Present => In_Present (Current_Parameter), 2734 Out_Present => Out_Present (Current_Parameter), 2735 Expression => 2736 New_Copy_Tree (Expression (Current_Parameter)))); 2737 2738 -- For a regular formal parameter (that needs to be marshalled 2739 -- in the context of remote calls), set the Etype now, because 2740 -- marshalling processing might need it. 2741 2742 if Is_Entity_Name (Current_Type) then 2743 Set_Etype (New_Identifier, Entity (Current_Type)); 2744 2745 -- Current_Type is an access definition, special processing 2746 -- (not requiring etype) will occur for marshalling. 2747 2748 else 2749 null; 2750 end if; 2751 2752 Next (Current_Parameter); 2753 end loop; 2754 end if; 2755 2756 case Nkind (Spec) is 2757 2758 when N_Function_Specification | N_Access_Function_Definition => 2759 return 2760 Make_Function_Specification (Loc, 2761 Defining_Unit_Name => 2762 Make_Defining_Identifier (Loc, 2763 Chars => Name_For_New_Spec), 2764 Parameter_Specifications => Parameters, 2765 Result_Definition => 2766 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc)); 2767 2768 when N_Procedure_Specification | N_Access_Procedure_Definition => 2769 return 2770 Make_Procedure_Specification (Loc, 2771 Defining_Unit_Name => 2772 Make_Defining_Identifier (Loc, 2773 Chars => Name_For_New_Spec), 2774 Parameter_Specifications => Parameters); 2775 2776 when others => 2777 raise Program_Error; 2778 end case; 2779 end Copy_Specification; 2780 2781 ----------------------------- 2782 -- Corresponding_Stub_Type -- 2783 ----------------------------- 2784 2785 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is 2786 Desig : constant Entity_Id := 2787 Etype (Designated_Type (RACW_Type)); 2788 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); 2789 begin 2790 return Stub_Elements.Stub_Type; 2791 end Corresponding_Stub_Type; 2792 2793 --------------------------- 2794 -- Could_Be_Asynchronous -- 2795 --------------------------- 2796 2797 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is 2798 Current_Parameter : Node_Id; 2799 2800 begin 2801 if Present (Parameter_Specifications (Spec)) then 2802 Current_Parameter := First (Parameter_Specifications (Spec)); 2803 while Present (Current_Parameter) loop 2804 if Out_Present (Current_Parameter) then 2805 return False; 2806 end if; 2807 2808 Next (Current_Parameter); 2809 end loop; 2810 end if; 2811 2812 return True; 2813 end Could_Be_Asynchronous; 2814 2815 --------------------------- 2816 -- Declare_Create_NVList -- 2817 --------------------------- 2818 2819 procedure Declare_Create_NVList 2820 (Loc : Source_Ptr; 2821 NVList : Entity_Id; 2822 Decls : List_Id; 2823 Stmts : List_Id) 2824 is 2825 begin 2826 Append_To (Decls, 2827 Make_Object_Declaration (Loc, 2828 Defining_Identifier => NVList, 2829 Aliased_Present => False, 2830 Object_Definition => 2831 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc))); 2832 2833 Append_To (Stmts, 2834 Make_Procedure_Call_Statement (Loc, 2835 Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc), 2836 Parameter_Associations => New_List ( 2837 New_Occurrence_Of (NVList, Loc)))); 2838 end Declare_Create_NVList; 2839 2840 --------------------------------------------- 2841 -- Expand_All_Calls_Remote_Subprogram_Call -- 2842 --------------------------------------------- 2843 2844 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is 2845 Loc : constant Source_Ptr := Sloc (N); 2846 Called_Subprogram : constant Entity_Id := Entity (Name (N)); 2847 RCI_Package : constant Entity_Id := Scope (Called_Subprogram); 2848 RCI_Locator_Decl : Node_Id; 2849 RCI_Locator : Entity_Id; 2850 Calling_Stubs : Node_Id; 2851 E_Calling_Stubs : Entity_Id; 2852 2853 begin 2854 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); 2855 2856 if E_Calling_Stubs = Empty then 2857 RCI_Locator := RCI_Locator_Table.Get (RCI_Package); 2858 2859 -- The RCI_Locator package and calling stub are is inserted at the 2860 -- top level in the current unit, and must appear in the proper scope 2861 -- so that it is not prematurely removed by the GCC back end. 2862 2863 declare 2864 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 2865 begin 2866 if Ekind (Scop) = E_Package_Body then 2867 Push_Scope (Spec_Entity (Scop)); 2868 elsif Ekind (Scop) = E_Subprogram_Body then 2869 Push_Scope 2870 (Corresponding_Spec (Unit_Declaration_Node (Scop))); 2871 else 2872 Push_Scope (Scop); 2873 end if; 2874 end; 2875 2876 if RCI_Locator = Empty then 2877 RCI_Locator_Decl := 2878 RCI_Package_Locator 2879 (Loc, Specification (Unit_Declaration_Node (RCI_Package))); 2880 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl); 2881 Analyze (RCI_Locator_Decl); 2882 RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl); 2883 2884 else 2885 RCI_Locator_Decl := Parent (RCI_Locator); 2886 end if; 2887 2888 Calling_Stubs := Build_Subprogram_Calling_Stubs 2889 (Vis_Decl => Parent (Parent (Called_Subprogram)), 2890 Subp_Id => 2891 Build_Subprogram_Id (Loc, Called_Subprogram), 2892 Asynchronous => Nkind (N) = N_Procedure_Call_Statement 2893 and then 2894 Is_Asynchronous (Called_Subprogram), 2895 Locator => RCI_Locator, 2896 New_Name => New_Internal_Name ('S')); 2897 Insert_After (RCI_Locator_Decl, Calling_Stubs); 2898 Analyze (Calling_Stubs); 2899 Pop_Scope; 2900 2901 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); 2902 end if; 2903 2904 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc)); 2905 end Expand_All_Calls_Remote_Subprogram_Call; 2906 2907 --------------------------------- 2908 -- Expand_Calling_Stubs_Bodies -- 2909 --------------------------------- 2910 2911 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is 2912 Spec : constant Node_Id := Specification (Unit_Node); 2913 begin 2914 Add_Calling_Stubs_To_Declarations (Spec); 2915 end Expand_Calling_Stubs_Bodies; 2916 2917 ----------------------------------- 2918 -- Expand_Receiving_Stubs_Bodies -- 2919 ----------------------------------- 2920 2921 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is 2922 Spec : Node_Id; 2923 Decls : List_Id; 2924 Stubs_Decls : List_Id; 2925 Stubs_Stmts : List_Id; 2926 2927 begin 2928 if Nkind (Unit_Node) = N_Package_Declaration then 2929 Spec := Specification (Unit_Node); 2930 Decls := Private_Declarations (Spec); 2931 2932 if No (Decls) then 2933 Decls := Visible_Declarations (Spec); 2934 end if; 2935 2936 Push_Scope (Scope_Of_Spec (Spec)); 2937 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls); 2938 2939 else 2940 Spec := 2941 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node)); 2942 Decls := Declarations (Unit_Node); 2943 2944 Push_Scope (Scope_Of_Spec (Unit_Node)); 2945 Stubs_Decls := New_List; 2946 Stubs_Stmts := New_List; 2947 Specific_Add_Receiving_Stubs_To_Declarations 2948 (Spec, Stubs_Decls, Stubs_Stmts); 2949 2950 Insert_List_Before (First (Decls), Stubs_Decls); 2951 2952 declare 2953 HSS_Stmts : constant List_Id := 2954 Statements (Handled_Statement_Sequence (Unit_Node)); 2955 2956 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts); 2957 2958 begin 2959 if No (First_HSS_Stmt) then 2960 Append_List_To (HSS_Stmts, Stubs_Stmts); 2961 else 2962 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts); 2963 end if; 2964 end; 2965 end if; 2966 2967 Pop_Scope; 2968 end Expand_Receiving_Stubs_Bodies; 2969 2970 -------------------- 2971 -- GARLIC_Support -- 2972 -------------------- 2973 2974 package body GARLIC_Support is 2975 2976 -- Local subprograms 2977 2978 procedure Add_RACW_Read_Attribute 2979 (RACW_Type : Entity_Id; 2980 Stub_Type : Entity_Id; 2981 Stub_Type_Access : Entity_Id; 2982 Body_Decls : List_Id); 2983 -- Add Read attribute for the RACW type. The declaration and attribute 2984 -- definition clauses are inserted right after the declaration of 2985 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is 2986 -- appended to it (case where the RACW declaration is in the main unit). 2987 2988 procedure Add_RACW_Write_Attribute 2989 (RACW_Type : Entity_Id; 2990 Stub_Type : Entity_Id; 2991 Stub_Type_Access : Entity_Id; 2992 RPC_Receiver : Node_Id; 2993 Body_Decls : List_Id); 2994 -- Same as above for the Write attribute 2995 2996 function Stream_Parameter return Node_Id; 2997 function Result return Node_Id; 2998 function Object return Node_Id renames Result; 2999 -- Functions to create occurrences of the formal parameter names of the 3000 -- 'Read and 'Write attributes. 3001 3002 Loc : Source_Ptr; 3003 -- Shared source location used by Add_{Read,Write}_Read_Attribute and 3004 -- their ancillary subroutines (set on entry by Add_RACW_Features). 3005 3006 procedure Add_RAS_Access_TSS (N : Node_Id); 3007 -- Add a subprogram body for RAS Access TSS 3008 3009 ------------------------------------- 3010 -- Add_Obj_RPC_Receiver_Completion -- 3011 ------------------------------------- 3012 3013 procedure Add_Obj_RPC_Receiver_Completion 3014 (Loc : Source_Ptr; 3015 Decls : List_Id; 3016 RPC_Receiver : Entity_Id; 3017 Stub_Elements : Stub_Structure) 3018 is 3019 begin 3020 -- The RPC receiver body should not be the completion of the 3021 -- declaration recorded in the stub structure, because then the 3022 -- occurrences of the formal parameters within the body should refer 3023 -- to the entities from the declaration, not from the completion, to 3024 -- which we do not have easy access. Instead, the RPC receiver body 3025 -- acts as its own declaration, and the RPC receiver declaration is 3026 -- completed by a renaming-as-body. 3027 3028 Append_To (Decls, 3029 Make_Subprogram_Renaming_Declaration (Loc, 3030 Specification => 3031 Copy_Specification (Loc, 3032 Specification (Stub_Elements.RPC_Receiver_Decl)), 3033 Name => New_Occurrence_Of (RPC_Receiver, Loc))); 3034 end Add_Obj_RPC_Receiver_Completion; 3035 3036 ----------------------- 3037 -- Add_RACW_Features -- 3038 ----------------------- 3039 3040 procedure Add_RACW_Features 3041 (RACW_Type : Entity_Id; 3042 Stub_Type : Entity_Id; 3043 Stub_Type_Access : Entity_Id; 3044 RPC_Receiver_Decl : Node_Id; 3045 Body_Decls : List_Id) 3046 is 3047 RPC_Receiver : Node_Id; 3048 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); 3049 3050 begin 3051 Loc := Sloc (RACW_Type); 3052 3053 if Is_RAS then 3054 3055 -- For a RAS, the RPC receiver is that of the RCI unit, not that 3056 -- of the corresponding distributed object type. We retrieve its 3057 -- address from the local proxy object. 3058 3059 RPC_Receiver := Make_Selected_Component (Loc, 3060 Prefix => 3061 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object), 3062 Selector_Name => Make_Identifier (Loc, Name_Receiver)); 3063 3064 else 3065 RPC_Receiver := Make_Attribute_Reference (Loc, 3066 Prefix => New_Occurrence_Of ( 3067 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc), 3068 Attribute_Name => Name_Address); 3069 end if; 3070 3071 Add_RACW_Write_Attribute 3072 (RACW_Type, 3073 Stub_Type, 3074 Stub_Type_Access, 3075 RPC_Receiver, 3076 Body_Decls); 3077 3078 Add_RACW_Read_Attribute 3079 (RACW_Type, 3080 Stub_Type, 3081 Stub_Type_Access, 3082 Body_Decls); 3083 end Add_RACW_Features; 3084 3085 ----------------------------- 3086 -- Add_RACW_Read_Attribute -- 3087 ----------------------------- 3088 3089 procedure Add_RACW_Read_Attribute 3090 (RACW_Type : Entity_Id; 3091 Stub_Type : Entity_Id; 3092 Stub_Type_Access : Entity_Id; 3093 Body_Decls : List_Id) 3094 is 3095 Proc_Decl : Node_Id; 3096 Attr_Decl : Node_Id; 3097 3098 Body_Node : Node_Id; 3099 3100 Statements : constant List_Id := New_List; 3101 Decls : List_Id; 3102 Local_Statements : List_Id; 3103 Remote_Statements : List_Id; 3104 -- Various parts of the procedure 3105 3106 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); 3107 Asynchronous_Flag : constant Entity_Id := 3108 Asynchronous_Flags_Table.Get (RACW_Type); 3109 pragma Assert (Present (Asynchronous_Flag)); 3110 3111 -- Prepare local identifiers 3112 3113 Source_Partition : Entity_Id; 3114 Source_Receiver : Entity_Id; 3115 Source_Address : Entity_Id; 3116 Local_Stub : Entity_Id; 3117 Stubbed_Result : Entity_Id; 3118 3119 -- Start of processing for Add_RACW_Read_Attribute 3120 3121 begin 3122 Build_Stream_Procedure (Loc, 3123 RACW_Type, Body_Node, Pnam, Statements, Outp => True); 3124 Proc_Decl := Make_Subprogram_Declaration (Loc, 3125 Copy_Specification (Loc, Specification (Body_Node))); 3126 3127 Attr_Decl := 3128 Make_Attribute_Definition_Clause (Loc, 3129 Name => New_Occurrence_Of (RACW_Type, Loc), 3130 Chars => Name_Read, 3131 Expression => 3132 New_Occurrence_Of ( 3133 Defining_Unit_Name (Specification (Proc_Decl)), Loc)); 3134 3135 Insert_After (Declaration_Node (RACW_Type), Proc_Decl); 3136 Insert_After (Proc_Decl, Attr_Decl); 3137 3138 if No (Body_Decls) then 3139 3140 -- Case of processing an RACW type from another unit than the 3141 -- main one: do not generate a body. 3142 3143 return; 3144 end if; 3145 3146 -- Prepare local identifiers 3147 3148 Source_Partition := Make_Temporary (Loc, 'P'); 3149 Source_Receiver := Make_Temporary (Loc, 'S'); 3150 Source_Address := Make_Temporary (Loc, 'P'); 3151 Local_Stub := Make_Temporary (Loc, 'L'); 3152 Stubbed_Result := Make_Temporary (Loc, 'S'); 3153 3154 -- Generate object declarations 3155 3156 Decls := New_List ( 3157 Make_Object_Declaration (Loc, 3158 Defining_Identifier => Source_Partition, 3159 Object_Definition => 3160 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), 3161 3162 Make_Object_Declaration (Loc, 3163 Defining_Identifier => Source_Receiver, 3164 Object_Definition => 3165 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), 3166 3167 Make_Object_Declaration (Loc, 3168 Defining_Identifier => Source_Address, 3169 Object_Definition => 3170 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), 3171 3172 Make_Object_Declaration (Loc, 3173 Defining_Identifier => Local_Stub, 3174 Aliased_Present => True, 3175 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), 3176 3177 Make_Object_Declaration (Loc, 3178 Defining_Identifier => Stubbed_Result, 3179 Object_Definition => 3180 New_Occurrence_Of (Stub_Type_Access, Loc), 3181 Expression => 3182 Make_Attribute_Reference (Loc, 3183 Prefix => 3184 New_Occurrence_Of (Local_Stub, Loc), 3185 Attribute_Name => 3186 Name_Unchecked_Access))); 3187 3188 -- Read the source Partition_ID and RPC_Receiver from incoming stream 3189 3190 Append_List_To (Statements, New_List ( 3191 Make_Attribute_Reference (Loc, 3192 Prefix => 3193 New_Occurrence_Of (RTE (RE_Partition_ID), Loc), 3194 Attribute_Name => Name_Read, 3195 Expressions => New_List ( 3196 Stream_Parameter, 3197 New_Occurrence_Of (Source_Partition, Loc))), 3198 3199 Make_Attribute_Reference (Loc, 3200 Prefix => 3201 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), 3202 Attribute_Name => 3203 Name_Read, 3204 Expressions => New_List ( 3205 Stream_Parameter, 3206 New_Occurrence_Of (Source_Receiver, Loc))), 3207 3208 Make_Attribute_Reference (Loc, 3209 Prefix => 3210 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), 3211 Attribute_Name => 3212 Name_Read, 3213 Expressions => New_List ( 3214 Stream_Parameter, 3215 New_Occurrence_Of (Source_Address, Loc))))); 3216 3217 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result 3218 3219 Set_Etype (Stubbed_Result, Stub_Type_Access); 3220 3221 -- If the Address is Null_Address, then return a null object, unless 3222 -- RACW_Type is null-excluding, in which case unconditionally raise 3223 -- CONSTRAINT_ERROR instead. 3224 3225 declare 3226 Zero_Statements : List_Id; 3227 -- Statements executed when a zero value is received 3228 3229 begin 3230 if Can_Never_Be_Null (RACW_Type) then 3231 Zero_Statements := New_List ( 3232 Make_Raise_Constraint_Error (Loc, 3233 Reason => CE_Null_Not_Allowed)); 3234 else 3235 Zero_Statements := New_List ( 3236 Make_Assignment_Statement (Loc, 3237 Name => Result, 3238 Expression => Make_Null (Loc)), 3239 Make_Simple_Return_Statement (Loc)); 3240 end if; 3241 3242 Append_To (Statements, 3243 Make_Implicit_If_Statement (RACW_Type, 3244 Condition => 3245 Make_Op_Eq (Loc, 3246 Left_Opnd => New_Occurrence_Of (Source_Address, Loc), 3247 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), 3248 Then_Statements => Zero_Statements)); 3249 end; 3250 3251 -- If the RACW denotes an object created on the current partition, 3252 -- Local_Statements will be executed. The real object will be used. 3253 3254 Local_Statements := New_List ( 3255 Make_Assignment_Statement (Loc, 3256 Name => Result, 3257 Expression => 3258 Unchecked_Convert_To (RACW_Type, 3259 OK_Convert_To (RTE (RE_Address), 3260 New_Occurrence_Of (Source_Address, Loc))))); 3261 3262 -- If the object is located on another partition, then a stub object 3263 -- will be created with all the information needed to rebuild the 3264 -- real object at the other end. 3265 3266 Remote_Statements := New_List ( 3267 3268 Make_Assignment_Statement (Loc, 3269 Name => Make_Selected_Component (Loc, 3270 Prefix => Stubbed_Result, 3271 Selector_Name => Name_Origin), 3272 Expression => 3273 New_Occurrence_Of (Source_Partition, Loc)), 3274 3275 Make_Assignment_Statement (Loc, 3276 Name => Make_Selected_Component (Loc, 3277 Prefix => Stubbed_Result, 3278 Selector_Name => Name_Receiver), 3279 Expression => 3280 New_Occurrence_Of (Source_Receiver, Loc)), 3281 3282 Make_Assignment_Statement (Loc, 3283 Name => Make_Selected_Component (Loc, 3284 Prefix => Stubbed_Result, 3285 Selector_Name => Name_Addr), 3286 Expression => 3287 New_Occurrence_Of (Source_Address, Loc))); 3288 3289 Append_To (Remote_Statements, 3290 Make_Assignment_Statement (Loc, 3291 Name => Make_Selected_Component (Loc, 3292 Prefix => Stubbed_Result, 3293 Selector_Name => Name_Asynchronous), 3294 Expression => 3295 New_Occurrence_Of (Asynchronous_Flag, Loc))); 3296 3297 Append_List_To (Remote_Statements, 3298 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type)); 3299 -- ??? Issue with asynchronous calls here: the Asynchronous flag is 3300 -- set on the stub type if, and only if, the RACW type has a pragma 3301 -- Asynchronous. This is incorrect for RACWs that implement RAS 3302 -- types, because in that case the /designated subprogram/ (not the 3303 -- type) might be asynchronous, and that causes the stub to need to 3304 -- be asynchronous too. A solution is to transport a RAS as a struct 3305 -- containing a RACW and an asynchronous flag, and to properly alter 3306 -- the Asynchronous component in the stub type in the RAS's Input 3307 -- TSS. 3308 3309 Append_To (Remote_Statements, 3310 Make_Assignment_Statement (Loc, 3311 Name => Result, 3312 Expression => Unchecked_Convert_To (RACW_Type, 3313 New_Occurrence_Of (Stubbed_Result, Loc)))); 3314 3315 -- Distinguish between the local and remote cases, and execute the 3316 -- appropriate piece of code. 3317 3318 Append_To (Statements, 3319 Make_Implicit_If_Statement (RACW_Type, 3320 Condition => 3321 Make_Op_Eq (Loc, 3322 Left_Opnd => 3323 Make_Function_Call (Loc, 3324 Name => New_Occurrence_Of ( 3325 RTE (RE_Get_Local_Partition_Id), Loc)), 3326 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)), 3327 Then_Statements => Local_Statements, 3328 Else_Statements => Remote_Statements)); 3329 3330 Set_Declarations (Body_Node, Decls); 3331 Append_To (Body_Decls, Body_Node); 3332 end Add_RACW_Read_Attribute; 3333 3334 ------------------------------ 3335 -- Add_RACW_Write_Attribute -- 3336 ------------------------------ 3337 3338 procedure Add_RACW_Write_Attribute 3339 (RACW_Type : Entity_Id; 3340 Stub_Type : Entity_Id; 3341 Stub_Type_Access : Entity_Id; 3342 RPC_Receiver : Node_Id; 3343 Body_Decls : List_Id) 3344 is 3345 Body_Node : Node_Id; 3346 Proc_Decl : Node_Id; 3347 Attr_Decl : Node_Id; 3348 3349 Statements : constant List_Id := New_List; 3350 Local_Statements : List_Id; 3351 Remote_Statements : List_Id; 3352 Null_Statements : List_Id; 3353 3354 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); 3355 3356 begin 3357 Build_Stream_Procedure 3358 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); 3359 3360 Proc_Decl := Make_Subprogram_Declaration (Loc, 3361 Copy_Specification (Loc, Specification (Body_Node))); 3362 3363 Attr_Decl := 3364 Make_Attribute_Definition_Clause (Loc, 3365 Name => New_Occurrence_Of (RACW_Type, Loc), 3366 Chars => Name_Write, 3367 Expression => 3368 New_Occurrence_Of ( 3369 Defining_Unit_Name (Specification (Proc_Decl)), Loc)); 3370 3371 Insert_After (Declaration_Node (RACW_Type), Proc_Decl); 3372 Insert_After (Proc_Decl, Attr_Decl); 3373 3374 if No (Body_Decls) then 3375 return; 3376 end if; 3377 3378 -- Build the code fragment corresponding to the marshalling of a 3379 -- local object. 3380 3381 Local_Statements := New_List ( 3382 3383 Pack_Entity_Into_Stream_Access (Loc, 3384 Stream => Stream_Parameter, 3385 Object => RTE (RE_Get_Local_Partition_Id)), 3386 3387 Pack_Node_Into_Stream_Access (Loc, 3388 Stream => Stream_Parameter, 3389 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), 3390 Etyp => RTE (RE_Unsigned_64)), 3391 3392 Pack_Node_Into_Stream_Access (Loc, 3393 Stream => Stream_Parameter, 3394 Object => OK_Convert_To (RTE (RE_Unsigned_64), 3395 Make_Attribute_Reference (Loc, 3396 Prefix => 3397 Make_Explicit_Dereference (Loc, 3398 Prefix => Object), 3399 Attribute_Name => Name_Address)), 3400 Etyp => RTE (RE_Unsigned_64))); 3401 3402 -- Build the code fragment corresponding to the marshalling of 3403 -- a remote object. 3404 3405 Remote_Statements := New_List ( 3406 Pack_Node_Into_Stream_Access (Loc, 3407 Stream => Stream_Parameter, 3408 Object => 3409 Make_Selected_Component (Loc, 3410 Prefix => 3411 Unchecked_Convert_To (Stub_Type_Access, Object), 3412 Selector_Name => Make_Identifier (Loc, Name_Origin)), 3413 Etyp => RTE (RE_Partition_ID)), 3414 3415 Pack_Node_Into_Stream_Access (Loc, 3416 Stream => Stream_Parameter, 3417 Object => 3418 Make_Selected_Component (Loc, 3419 Prefix => 3420 Unchecked_Convert_To (Stub_Type_Access, Object), 3421 Selector_Name => Make_Identifier (Loc, Name_Receiver)), 3422 Etyp => RTE (RE_Unsigned_64)), 3423 3424 Pack_Node_Into_Stream_Access (Loc, 3425 Stream => Stream_Parameter, 3426 Object => 3427 Make_Selected_Component (Loc, 3428 Prefix => 3429 Unchecked_Convert_To (Stub_Type_Access, Object), 3430 Selector_Name => Make_Identifier (Loc, Name_Addr)), 3431 Etyp => RTE (RE_Unsigned_64))); 3432 3433 -- Build code fragment corresponding to marshalling of a null object 3434 3435 Null_Statements := New_List ( 3436 3437 Pack_Entity_Into_Stream_Access (Loc, 3438 Stream => Stream_Parameter, 3439 Object => RTE (RE_Get_Local_Partition_Id)), 3440 3441 Pack_Node_Into_Stream_Access (Loc, 3442 Stream => Stream_Parameter, 3443 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), 3444 Etyp => RTE (RE_Unsigned_64)), 3445 3446 Pack_Node_Into_Stream_Access (Loc, 3447 Stream => Stream_Parameter, 3448 Object => Make_Integer_Literal (Loc, Uint_0), 3449 Etyp => RTE (RE_Unsigned_64))); 3450 3451 Append_To (Statements, 3452 Make_Implicit_If_Statement (RACW_Type, 3453 Condition => 3454 Make_Op_Eq (Loc, 3455 Left_Opnd => Object, 3456 Right_Opnd => Make_Null (Loc)), 3457 3458 Then_Statements => Null_Statements, 3459 3460 Elsif_Parts => New_List ( 3461 Make_Elsif_Part (Loc, 3462 Condition => 3463 Make_Op_Eq (Loc, 3464 Left_Opnd => 3465 Make_Attribute_Reference (Loc, 3466 Prefix => Object, 3467 Attribute_Name => Name_Tag), 3468 3469 Right_Opnd => 3470 Make_Attribute_Reference (Loc, 3471 Prefix => New_Occurrence_Of (Stub_Type, Loc), 3472 Attribute_Name => Name_Tag)), 3473 Then_Statements => Remote_Statements)), 3474 Else_Statements => Local_Statements)); 3475 3476 Append_To (Body_Decls, Body_Node); 3477 end Add_RACW_Write_Attribute; 3478 3479 ------------------------ 3480 -- Add_RAS_Access_TSS -- 3481 ------------------------ 3482 3483 procedure Add_RAS_Access_TSS (N : Node_Id) is 3484 Loc : constant Source_Ptr := Sloc (N); 3485 3486 Ras_Type : constant Entity_Id := Defining_Identifier (N); 3487 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); 3488 -- Ras_Type is the access to subprogram type while Fat_Type is the 3489 -- corresponding record type. 3490 3491 RACW_Type : constant Entity_Id := 3492 Underlying_RACW_Type (Ras_Type); 3493 Desig : constant Entity_Id := 3494 Etype (Designated_Type (RACW_Type)); 3495 3496 Stub_Elements : constant Stub_Structure := 3497 Stubs_Table.Get (Desig); 3498 pragma Assert (Stub_Elements /= Empty_Stub_Structure); 3499 3500 Proc : constant Entity_Id := 3501 Make_Defining_Identifier (Loc, 3502 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); 3503 3504 Proc_Spec : Node_Id; 3505 3506 -- Formal parameters 3507 3508 Package_Name : constant Entity_Id := 3509 Make_Defining_Identifier (Loc, 3510 Chars => Name_P); 3511 -- Target package 3512 3513 Subp_Id : constant Entity_Id := 3514 Make_Defining_Identifier (Loc, 3515 Chars => Name_S); 3516 -- Target subprogram 3517 3518 Asynch_P : constant Entity_Id := 3519 Make_Defining_Identifier (Loc, 3520 Chars => Name_Asynchronous); 3521 -- Is the procedure to which the 'Access applies asynchronous? 3522 3523 All_Calls_Remote : constant Entity_Id := 3524 Make_Defining_Identifier (Loc, 3525 Chars => Name_All_Calls_Remote); 3526 -- True if an All_Calls_Remote pragma applies to the RCI unit 3527 -- that contains the subprogram. 3528 3529 -- Common local variables 3530 3531 Proc_Decls : List_Id; 3532 Proc_Statements : List_Id; 3533 3534 Origin : constant Entity_Id := Make_Temporary (Loc, 'P'); 3535 3536 -- Additional local variables for the local case 3537 3538 Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P'); 3539 3540 -- Additional local variables for the remote case 3541 3542 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); 3543 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); 3544 3545 function Set_Field 3546 (Field_Name : Name_Id; 3547 Value : Node_Id) return Node_Id; 3548 -- Construct an assignment that sets the named component in the 3549 -- returned record 3550 3551 --------------- 3552 -- Set_Field -- 3553 --------------- 3554 3555 function Set_Field 3556 (Field_Name : Name_Id; 3557 Value : Node_Id) return Node_Id 3558 is 3559 begin 3560 return 3561 Make_Assignment_Statement (Loc, 3562 Name => 3563 Make_Selected_Component (Loc, 3564 Prefix => Stub_Ptr, 3565 Selector_Name => Field_Name), 3566 Expression => Value); 3567 end Set_Field; 3568 3569 -- Start of processing for Add_RAS_Access_TSS 3570 3571 begin 3572 Proc_Decls := New_List ( 3573 3574 -- Common declarations 3575 3576 Make_Object_Declaration (Loc, 3577 Defining_Identifier => Origin, 3578 Constant_Present => True, 3579 Object_Definition => 3580 New_Occurrence_Of (RTE (RE_Partition_ID), Loc), 3581 Expression => 3582 Make_Function_Call (Loc, 3583 Name => 3584 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc), 3585 Parameter_Associations => New_List ( 3586 New_Occurrence_Of (Package_Name, Loc)))), 3587 3588 -- Declaration use only in the local case: proxy address 3589 3590 Make_Object_Declaration (Loc, 3591 Defining_Identifier => Proxy_Addr, 3592 Object_Definition => 3593 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), 3594 3595 -- Declarations used only in the remote case: stub object and 3596 -- stub pointer. 3597 3598 Make_Object_Declaration (Loc, 3599 Defining_Identifier => Local_Stub, 3600 Aliased_Present => True, 3601 Object_Definition => 3602 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), 3603 3604 Make_Object_Declaration (Loc, 3605 Defining_Identifier => 3606 Stub_Ptr, 3607 Object_Definition => 3608 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), 3609 Expression => 3610 Make_Attribute_Reference (Loc, 3611 Prefix => New_Occurrence_Of (Local_Stub, Loc), 3612 Attribute_Name => Name_Unchecked_Access))); 3613 3614 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); 3615 3616 -- Build_Get_Unique_RP_Call needs above information 3617 3618 -- Note: Here we assume that the Fat_Type is a record 3619 -- containing just a pointer to a proxy or stub object. 3620 3621 Proc_Statements := New_List ( 3622 3623 -- Generate: 3624 3625 -- Get_RAS_Info (Pkg, Subp, PA); 3626 -- if Origin = Local_Partition_Id 3627 -- and then not All_Calls_Remote 3628 -- then 3629 -- return Fat_Type!(PA); 3630 -- end if; 3631 3632 Make_Procedure_Call_Statement (Loc, 3633 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), 3634 Parameter_Associations => New_List ( 3635 New_Occurrence_Of (Package_Name, Loc), 3636 New_Occurrence_Of (Subp_Id, Loc), 3637 New_Occurrence_Of (Proxy_Addr, Loc))), 3638 3639 Make_Implicit_If_Statement (N, 3640 Condition => 3641 Make_And_Then (Loc, 3642 Left_Opnd => 3643 Make_Op_Eq (Loc, 3644 Left_Opnd => 3645 New_Occurrence_Of (Origin, Loc), 3646 Right_Opnd => 3647 Make_Function_Call (Loc, 3648 New_Occurrence_Of ( 3649 RTE (RE_Get_Local_Partition_Id), Loc))), 3650 3651 Right_Opnd => 3652 Make_Op_Not (Loc, 3653 New_Occurrence_Of (All_Calls_Remote, Loc))), 3654 3655 Then_Statements => New_List ( 3656 Make_Simple_Return_Statement (Loc, 3657 Unchecked_Convert_To (Fat_Type, 3658 OK_Convert_To (RTE (RE_Address), 3659 New_Occurrence_Of (Proxy_Addr, Loc)))))), 3660 3661 Set_Field (Name_Origin, 3662 New_Occurrence_Of (Origin, Loc)), 3663 3664 Set_Field (Name_Receiver, 3665 Make_Function_Call (Loc, 3666 Name => 3667 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc), 3668 Parameter_Associations => New_List ( 3669 New_Occurrence_Of (Package_Name, Loc)))), 3670 3671 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), 3672 3673 -- E.4.1(9) A remote call is asynchronous if it is a call to 3674 -- a procedure or a call through a value of an access-to-procedure 3675 -- type to which a pragma Asynchronous applies. 3676 3677 -- Asynch_P is true when the procedure is asynchronous; 3678 -- Asynch_T is true when the type is asynchronous. 3679 3680 Set_Field (Name_Asynchronous, 3681 Make_Or_Else (Loc, 3682 New_Occurrence_Of (Asynch_P, Loc), 3683 New_Occurrence_Of (Boolean_Literals ( 3684 Is_Asynchronous (Ras_Type)), Loc)))); 3685 3686 Append_List_To (Proc_Statements, 3687 Build_Get_Unique_RP_Call 3688 (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); 3689 3690 -- Return the newly created value 3691 3692 Append_To (Proc_Statements, 3693 Make_Simple_Return_Statement (Loc, 3694 Expression => 3695 Unchecked_Convert_To (Fat_Type, 3696 New_Occurrence_Of (Stub_Ptr, Loc)))); 3697 3698 Proc_Spec := 3699 Make_Function_Specification (Loc, 3700 Defining_Unit_Name => Proc, 3701 Parameter_Specifications => New_List ( 3702 Make_Parameter_Specification (Loc, 3703 Defining_Identifier => Package_Name, 3704 Parameter_Type => 3705 New_Occurrence_Of (Standard_String, Loc)), 3706 3707 Make_Parameter_Specification (Loc, 3708 Defining_Identifier => Subp_Id, 3709 Parameter_Type => 3710 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)), 3711 3712 Make_Parameter_Specification (Loc, 3713 Defining_Identifier => Asynch_P, 3714 Parameter_Type => 3715 New_Occurrence_Of (Standard_Boolean, Loc)), 3716 3717 Make_Parameter_Specification (Loc, 3718 Defining_Identifier => All_Calls_Remote, 3719 Parameter_Type => 3720 New_Occurrence_Of (Standard_Boolean, Loc))), 3721 3722 Result_Definition => 3723 New_Occurrence_Of (Fat_Type, Loc)); 3724 3725 -- Set the kind and return type of the function to prevent 3726 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. 3727 3728 Set_Ekind (Proc, E_Function); 3729 Set_Etype (Proc, Fat_Type); 3730 3731 Discard_Node ( 3732 Make_Subprogram_Body (Loc, 3733 Specification => Proc_Spec, 3734 Declarations => Proc_Decls, 3735 Handled_Statement_Sequence => 3736 Make_Handled_Sequence_Of_Statements (Loc, 3737 Statements => Proc_Statements))); 3738 3739 Set_TSS (Fat_Type, Proc); 3740 end Add_RAS_Access_TSS; 3741 3742 ----------------------- 3743 -- Add_RAST_Features -- 3744 ----------------------- 3745 3746 procedure Add_RAST_Features 3747 (Vis_Decl : Node_Id; 3748 RAS_Type : Entity_Id) 3749 is 3750 pragma Unreferenced (RAS_Type); 3751 begin 3752 Add_RAS_Access_TSS (Vis_Decl); 3753 end Add_RAST_Features; 3754 3755 ----------------------------------------- 3756 -- Add_Receiving_Stubs_To_Declarations -- 3757 ----------------------------------------- 3758 3759 procedure Add_Receiving_Stubs_To_Declarations 3760 (Pkg_Spec : Node_Id; 3761 Decls : List_Id; 3762 Stmts : List_Id) 3763 is 3764 Loc : constant Source_Ptr := Sloc (Pkg_Spec); 3765 3766 Request_Parameter : Node_Id; 3767 3768 Pkg_RPC_Receiver : constant Entity_Id := 3769 Make_Temporary (Loc, 'H'); 3770 Pkg_RPC_Receiver_Statements : List_Id; 3771 Pkg_RPC_Receiver_Cases : constant List_Id := New_List; 3772 Pkg_RPC_Receiver_Body : Node_Id; 3773 -- A Pkg_RPC_Receiver is built to decode the request 3774 3775 Lookup_RAS : Node_Id; 3776 Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R'); 3777 -- A remote subprogram is created to allow peers to look up RAS 3778 -- information using subprogram ids. 3779 3780 Subp_Id : Entity_Id; 3781 Subp_Index : Entity_Id; 3782 -- Subprogram_Id as read from the incoming stream 3783 3784 Current_Subp_Number : Int := First_RCI_Subprogram_Id; 3785 Current_Stubs : Node_Id; 3786 3787 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); 3788 Subp_Info_List : constant List_Id := New_List; 3789 3790 Register_Pkg_Actuals : constant List_Id := New_List; 3791 3792 All_Calls_Remote_E : Entity_Id; 3793 Proxy_Object_Addr : Entity_Id; 3794 3795 procedure Append_Stubs_To 3796 (RPC_Receiver_Cases : List_Id; 3797 Stubs : Node_Id; 3798 Subprogram_Number : Int); 3799 -- Add one case to the specified RPC receiver case list 3800 -- associating Subprogram_Number with the subprogram declared 3801 -- by Declaration, for which we have receiving stubs in Stubs. 3802 3803 procedure Visit_Subprogram (Decl : Node_Id); 3804 -- Generate receiving stub for one remote subprogram 3805 3806 --------------------- 3807 -- Append_Stubs_To -- 3808 --------------------- 3809 3810 procedure Append_Stubs_To 3811 (RPC_Receiver_Cases : List_Id; 3812 Stubs : Node_Id; 3813 Subprogram_Number : Int) 3814 is 3815 begin 3816 Append_To (RPC_Receiver_Cases, 3817 Make_Case_Statement_Alternative (Loc, 3818 Discrete_Choices => 3819 New_List (Make_Integer_Literal (Loc, Subprogram_Number)), 3820 Statements => 3821 New_List ( 3822 Make_Procedure_Call_Statement (Loc, 3823 Name => 3824 New_Occurrence_Of (Defining_Entity (Stubs), Loc), 3825 Parameter_Associations => New_List ( 3826 New_Occurrence_Of (Request_Parameter, Loc)))))); 3827 end Append_Stubs_To; 3828 3829 ---------------------- 3830 -- Visit_Subprogram -- 3831 ---------------------- 3832 3833 procedure Visit_Subprogram (Decl : Node_Id) is 3834 Loc : constant Source_Ptr := Sloc (Decl); 3835 Spec : constant Node_Id := Specification (Decl); 3836 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); 3837 3838 Subp_Val : String_Id; 3839 pragma Warnings (Off, Subp_Val); 3840 3841 begin 3842 -- Disable expansion of stubs if serious errors have been 3843 -- diagnosed, because otherwise some illegal remote subprogram 3844 -- declarations could cause cascaded errors in stubs. 3845 3846 if Serious_Errors_Detected /= 0 then 3847 return; 3848 end if; 3849 3850 -- Build receiving stub 3851 3852 Current_Stubs := 3853 Build_Subprogram_Receiving_Stubs 3854 (Vis_Decl => Decl, 3855 Asynchronous => 3856 Nkind (Spec) = N_Procedure_Specification 3857 and then Is_Asynchronous (Subp_Def)); 3858 3859 Append_To (Decls, Current_Stubs); 3860 Analyze (Current_Stubs); 3861 3862 -- Build RAS proxy 3863 3864 Add_RAS_Proxy_And_Analyze (Decls, 3865 Vis_Decl => Decl, 3866 All_Calls_Remote_E => All_Calls_Remote_E, 3867 Proxy_Object_Addr => Proxy_Object_Addr); 3868 3869 -- Compute distribution identifier 3870 3871 Assign_Subprogram_Identifier 3872 (Subp_Def, Current_Subp_Number, Subp_Val); 3873 3874 pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); 3875 3876 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms 3877 -- table for this receiver. This aggregate must be kept consistent 3878 -- with the declaration of RCI_Subp_Info in 3879 -- System.Partition_Interface. 3880 3881 Append_To (Subp_Info_List, 3882 Make_Component_Association (Loc, 3883 Choices => New_List ( 3884 Make_Integer_Literal (Loc, Current_Subp_Number)), 3885 3886 Expression => 3887 Make_Aggregate (Loc, 3888 Component_Associations => New_List ( 3889 3890 -- Addr => 3891 3892 Make_Component_Association (Loc, 3893 Choices => 3894 New_List (Make_Identifier (Loc, Name_Addr)), 3895 Expression => 3896 New_Occurrence_Of (Proxy_Object_Addr, Loc)))))); 3897 3898 Append_Stubs_To (Pkg_RPC_Receiver_Cases, 3899 Stubs => Current_Stubs, 3900 Subprogram_Number => Current_Subp_Number); 3901 3902 Current_Subp_Number := Current_Subp_Number + 1; 3903 end Visit_Subprogram; 3904 3905 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); 3906 3907 -- Start of processing for Add_Receiving_Stubs_To_Declarations 3908 3909 begin 3910 -- Building receiving stubs consist in several operations: 3911 3912 -- - a package RPC receiver must be built. This subprogram 3913 -- will get a Subprogram_Id from the incoming stream 3914 -- and will dispatch the call to the right subprogram; 3915 3916 -- - a receiving stub for each subprogram visible in the package 3917 -- spec. This stub will read all the parameters from the stream, 3918 -- and put the result as well as the exception occurrence in the 3919 -- output stream; 3920 3921 -- - a dummy package with an empty spec and a body made of an 3922 -- elaboration part, whose job is to register the receiving 3923 -- part of this RCI package on the name server. This is done 3924 -- by calling System.Partition_Interface.Register_Receiving_Stub. 3925 3926 Build_RPC_Receiver_Body ( 3927 RPC_Receiver => Pkg_RPC_Receiver, 3928 Request => Request_Parameter, 3929 Subp_Id => Subp_Id, 3930 Subp_Index => Subp_Index, 3931 Stmts => Pkg_RPC_Receiver_Statements, 3932 Decl => Pkg_RPC_Receiver_Body); 3933 pragma Assert (Subp_Id = Subp_Index); 3934 3935 -- A null subp_id denotes a call through a RAS, in which case the 3936 -- next Uint_64 element in the stream is the address of the local 3937 -- proxy object, from which we can retrieve the actual subprogram id. 3938 3939 Append_To (Pkg_RPC_Receiver_Statements, 3940 Make_Implicit_If_Statement (Pkg_Spec, 3941 Condition => 3942 Make_Op_Eq (Loc, 3943 New_Occurrence_Of (Subp_Id, Loc), 3944 Make_Integer_Literal (Loc, 0)), 3945 3946 Then_Statements => New_List ( 3947 Make_Assignment_Statement (Loc, 3948 Name => 3949 New_Occurrence_Of (Subp_Id, Loc), 3950 3951 Expression => 3952 Make_Selected_Component (Loc, 3953 Prefix => 3954 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), 3955 OK_Convert_To (RTE (RE_Address), 3956 Make_Attribute_Reference (Loc, 3957 Prefix => 3958 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), 3959 Attribute_Name => 3960 Name_Input, 3961 Expressions => New_List ( 3962 Make_Selected_Component (Loc, 3963 Prefix => Request_Parameter, 3964 Selector_Name => Name_Params))))), 3965 3966 Selector_Name => Make_Identifier (Loc, Name_Subp_Id)))))); 3967 3968 -- Build a subprogram for RAS information lookups 3969 3970 Lookup_RAS := 3971 Make_Subprogram_Declaration (Loc, 3972 Specification => 3973 Make_Function_Specification (Loc, 3974 Defining_Unit_Name => 3975 Lookup_RAS_Info, 3976 Parameter_Specifications => New_List ( 3977 Make_Parameter_Specification (Loc, 3978 Defining_Identifier => 3979 Make_Defining_Identifier (Loc, Name_Subp_Id), 3980 In_Present => 3981 True, 3982 Parameter_Type => 3983 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), 3984 Result_Definition => 3985 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); 3986 Append_To (Decls, Lookup_RAS); 3987 Analyze (Lookup_RAS); 3988 3989 Current_Stubs := Build_Subprogram_Receiving_Stubs 3990 (Vis_Decl => Lookup_RAS, 3991 Asynchronous => False); 3992 Append_To (Decls, Current_Stubs); 3993 Analyze (Current_Stubs); 3994 3995 Append_Stubs_To (Pkg_RPC_Receiver_Cases, 3996 Stubs => Current_Stubs, 3997 Subprogram_Number => 1); 3998 3999 -- For each subprogram, the receiving stub will be built and a 4000 -- case statement will be made on the Subprogram_Id to dispatch 4001 -- to the right subprogram. 4002 4003 All_Calls_Remote_E := 4004 Boolean_Literals 4005 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); 4006 4007 Overload_Counter_Table.Reset; 4008 4009 Visit_Spec (Pkg_Spec); 4010 4011 -- If we receive an invalid Subprogram_Id, it is best to do nothing 4012 -- rather than raising an exception since we do not want someone 4013 -- to crash a remote partition by sending invalid subprogram ids. 4014 -- This is consistent with the other parts of the case statement 4015 -- since even in presence of incorrect parameters in the stream, 4016 -- every exception will be caught and (if the subprogram is not an 4017 -- APC) put into the result stream and sent away. 4018 4019 Append_To (Pkg_RPC_Receiver_Cases, 4020 Make_Case_Statement_Alternative (Loc, 4021 Discrete_Choices => New_List (Make_Others_Choice (Loc)), 4022 Statements => New_List (Make_Null_Statement (Loc)))); 4023 4024 Append_To (Pkg_RPC_Receiver_Statements, 4025 Make_Case_Statement (Loc, 4026 Expression => New_Occurrence_Of (Subp_Id, Loc), 4027 Alternatives => Pkg_RPC_Receiver_Cases)); 4028 4029 Append_To (Decls, 4030 Make_Object_Declaration (Loc, 4031 Defining_Identifier => Subp_Info_Array, 4032 Constant_Present => True, 4033 Aliased_Present => True, 4034 Object_Definition => 4035 Make_Subtype_Indication (Loc, 4036 Subtype_Mark => 4037 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), 4038 Constraint => 4039 Make_Index_Or_Discriminant_Constraint (Loc, 4040 New_List ( 4041 Make_Range (Loc, 4042 Low_Bound => Make_Integer_Literal (Loc, 4043 First_RCI_Subprogram_Id), 4044 High_Bound => 4045 Make_Integer_Literal (Loc, 4046 Intval => 4047 First_RCI_Subprogram_Id 4048 + List_Length (Subp_Info_List) - 1))))))); 4049 4050 -- For a degenerate RCI with no visible subprograms, Subp_Info_List 4051 -- has zero length, and the declaration is for an empty array, in 4052 -- which case no initialization aggregate must be generated. 4053 4054 if Present (First (Subp_Info_List)) then 4055 Set_Expression (Last (Decls), 4056 Make_Aggregate (Loc, 4057 Component_Associations => Subp_Info_List)); 4058 4059 -- No initialization provided: remove CONSTANT so that the 4060 -- declaration is not an incomplete deferred constant. 4061 4062 else 4063 Set_Constant_Present (Last (Decls), False); 4064 end if; 4065 4066 Analyze (Last (Decls)); 4067 4068 declare 4069 Subp_Info_Addr : Node_Id; 4070 -- Return statement for Lookup_RAS_Info: address of the subprogram 4071 -- information record for the requested subprogram id. 4072 4073 begin 4074 if Present (First (Subp_Info_List)) then 4075 Subp_Info_Addr := 4076 Make_Selected_Component (Loc, 4077 Prefix => 4078 Make_Indexed_Component (Loc, 4079 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), 4080 Expressions => New_List ( 4081 Convert_To (Standard_Integer, 4082 Make_Identifier (Loc, Name_Subp_Id)))), 4083 Selector_Name => Make_Identifier (Loc, Name_Addr)); 4084 4085 -- Case of no visible subprogram: just raise Constraint_Error, we 4086 -- know for sure we got junk from a remote partition. 4087 4088 else 4089 Subp_Info_Addr := 4090 Make_Raise_Constraint_Error (Loc, 4091 Reason => CE_Range_Check_Failed); 4092 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64)); 4093 end if; 4094 4095 Append_To (Decls, 4096 Make_Subprogram_Body (Loc, 4097 Specification => 4098 Copy_Specification (Loc, Parent (Lookup_RAS_Info)), 4099 Declarations => No_List, 4100 Handled_Statement_Sequence => 4101 Make_Handled_Sequence_Of_Statements (Loc, 4102 Statements => New_List ( 4103 Make_Simple_Return_Statement (Loc, 4104 Expression => 4105 OK_Convert_To 4106 (RTE (RE_Unsigned_64), Subp_Info_Addr)))))); 4107 end; 4108 4109 Analyze (Last (Decls)); 4110 4111 Append_To (Decls, Pkg_RPC_Receiver_Body); 4112 Analyze (Last (Decls)); 4113 4114 Get_Library_Unit_Name_String (Pkg_Spec); 4115 4116 -- Name 4117 4118 Append_To (Register_Pkg_Actuals, 4119 Make_String_Literal (Loc, 4120 Strval => String_From_Name_Buffer)); 4121 4122 -- Receiver 4123 4124 Append_To (Register_Pkg_Actuals, 4125 Make_Attribute_Reference (Loc, 4126 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), 4127 Attribute_Name => Name_Unrestricted_Access)); 4128 4129 -- Version 4130 4131 Append_To (Register_Pkg_Actuals, 4132 Make_Attribute_Reference (Loc, 4133 Prefix => 4134 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), 4135 Attribute_Name => Name_Version)); 4136 4137 -- Subp_Info 4138 4139 Append_To (Register_Pkg_Actuals, 4140 Make_Attribute_Reference (Loc, 4141 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), 4142 Attribute_Name => Name_Address)); 4143 4144 -- Subp_Info_Len 4145 4146 Append_To (Register_Pkg_Actuals, 4147 Make_Attribute_Reference (Loc, 4148 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), 4149 Attribute_Name => Name_Length)); 4150 4151 -- Generate the call 4152 4153 Append_To (Stmts, 4154 Make_Procedure_Call_Statement (Loc, 4155 Name => 4156 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc), 4157 Parameter_Associations => Register_Pkg_Actuals)); 4158 Analyze (Last (Stmts)); 4159 end Add_Receiving_Stubs_To_Declarations; 4160 4161 --------------------------------- 4162 -- Build_General_Calling_Stubs -- 4163 --------------------------------- 4164 4165 procedure Build_General_Calling_Stubs 4166 (Decls : List_Id; 4167 Statements : List_Id; 4168 Target_Partition : Entity_Id; 4169 Target_RPC_Receiver : Node_Id; 4170 Subprogram_Id : Node_Id; 4171 Asynchronous : Node_Id := Empty; 4172 Is_Known_Asynchronous : Boolean := False; 4173 Is_Known_Non_Asynchronous : Boolean := False; 4174 Is_Function : Boolean; 4175 Spec : Node_Id; 4176 Stub_Type : Entity_Id := Empty; 4177 RACW_Type : Entity_Id := Empty; 4178 Nod : Node_Id) 4179 is 4180 Loc : constant Source_Ptr := Sloc (Nod); 4181 4182 Stream_Parameter : Node_Id; 4183 -- Name of the stream used to transmit parameters to the remote 4184 -- package. 4185 4186 Result_Parameter : Node_Id; 4187 -- Name of the result parameter (in non-APC cases) which get the 4188 -- result of the remote subprogram. 4189 4190 Exception_Return_Parameter : Node_Id; 4191 -- Name of the parameter which will hold the exception sent by the 4192 -- remote subprogram. 4193 4194 Current_Parameter : Node_Id; 4195 -- Current parameter being handled 4196 4197 Ordered_Parameters_List : constant List_Id := 4198 Build_Ordered_Parameters_List (Spec); 4199 4200 Asynchronous_Statements : List_Id := No_List; 4201 Non_Asynchronous_Statements : List_Id := No_List; 4202 -- Statements specifics to the Asynchronous/Non-Asynchronous cases 4203 4204 Extra_Formal_Statements : constant List_Id := New_List; 4205 -- List of statements for extra formal parameters. It will appear 4206 -- after the regular statements for writing out parameters. 4207 4208 pragma Unreferenced (RACW_Type); 4209 -- Used only for the PolyORB case 4210 4211 begin 4212 -- The general form of a calling stub for a given subprogram is: 4213 4214 -- procedure X (...) is P : constant Partition_ID := 4215 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased 4216 -- System.RPC.Params_Stream_Type (0); begin 4217 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver 4218 -- comes from RCI_Cache.Get_RCI_Package_Receiver) 4219 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC 4220 -- (Stream, Result); Read_Exception_Occurrence_From_Result; 4221 -- Raise_It; 4222 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X; 4223 4224 -- There are some variations: Do_APC is called for an asynchronous 4225 -- procedure and the part after the call is completely ommitted as 4226 -- well as the declaration of Result. For a function call, 'Input is 4227 -- always used to read the result even if it is constrained. 4228 4229 Stream_Parameter := Make_Temporary (Loc, 'S'); 4230 4231 Append_To (Decls, 4232 Make_Object_Declaration (Loc, 4233 Defining_Identifier => Stream_Parameter, 4234 Aliased_Present => True, 4235 Object_Definition => 4236 Make_Subtype_Indication (Loc, 4237 Subtype_Mark => 4238 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), 4239 Constraint => 4240 Make_Index_Or_Discriminant_Constraint (Loc, 4241 Constraints => 4242 New_List (Make_Integer_Literal (Loc, 0)))))); 4243 4244 if not Is_Known_Asynchronous then 4245 Result_Parameter := Make_Temporary (Loc, 'R'); 4246 4247 Append_To (Decls, 4248 Make_Object_Declaration (Loc, 4249 Defining_Identifier => Result_Parameter, 4250 Aliased_Present => True, 4251 Object_Definition => 4252 Make_Subtype_Indication (Loc, 4253 Subtype_Mark => 4254 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), 4255 Constraint => 4256 Make_Index_Or_Discriminant_Constraint (Loc, 4257 Constraints => 4258 New_List (Make_Integer_Literal (Loc, 0)))))); 4259 4260 Exception_Return_Parameter := Make_Temporary (Loc, 'E'); 4261 4262 Append_To (Decls, 4263 Make_Object_Declaration (Loc, 4264 Defining_Identifier => Exception_Return_Parameter, 4265 Object_Definition => 4266 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); 4267 4268 else 4269 Result_Parameter := Empty; 4270 Exception_Return_Parameter := Empty; 4271 end if; 4272 4273 -- Put first the RPC receiver corresponding to the remote package 4274 4275 Append_To (Statements, 4276 Make_Attribute_Reference (Loc, 4277 Prefix => 4278 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), 4279 Attribute_Name => Name_Write, 4280 Expressions => New_List ( 4281 Make_Attribute_Reference (Loc, 4282 Prefix => New_Occurrence_Of (Stream_Parameter, Loc), 4283 Attribute_Name => Name_Access), 4284 Target_RPC_Receiver))); 4285 4286 -- Then put the Subprogram_Id of the subprogram we want to call in 4287 -- the stream. 4288 4289 Append_To (Statements, 4290 Make_Attribute_Reference (Loc, 4291 Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), 4292 Attribute_Name => Name_Write, 4293 Expressions => New_List ( 4294 Make_Attribute_Reference (Loc, 4295 Prefix => New_Occurrence_Of (Stream_Parameter, Loc), 4296 Attribute_Name => Name_Access), 4297 Subprogram_Id))); 4298 4299 Current_Parameter := First (Ordered_Parameters_List); 4300 while Present (Current_Parameter) loop 4301 declare 4302 Typ : constant Node_Id := 4303 Parameter_Type (Current_Parameter); 4304 Etyp : Entity_Id; 4305 Constrained : Boolean; 4306 Value : Node_Id; 4307 Extra_Parameter : Entity_Id; 4308 4309 begin 4310 if Is_RACW_Controlling_Formal 4311 (Current_Parameter, Stub_Type) 4312 then 4313 -- In the case of a controlling formal argument, we marshall 4314 -- its addr field rather than the local stub. 4315 4316 Append_To (Statements, 4317 Pack_Node_Into_Stream (Loc, 4318 Stream => Stream_Parameter, 4319 Object => 4320 Make_Selected_Component (Loc, 4321 Prefix => 4322 Defining_Identifier (Current_Parameter), 4323 Selector_Name => Name_Addr), 4324 Etyp => RTE (RE_Unsigned_64))); 4325 4326 else 4327 Value := 4328 New_Occurrence_Of 4329 (Defining_Identifier (Current_Parameter), Loc); 4330 4331 -- Access type parameters are transmitted as in out 4332 -- parameters. However, a dereference is needed so that 4333 -- we marshall the designated object. 4334 4335 if Nkind (Typ) = N_Access_Definition then 4336 Value := Make_Explicit_Dereference (Loc, Value); 4337 Etyp := Etype (Subtype_Mark (Typ)); 4338 else 4339 Etyp := Etype (Typ); 4340 end if; 4341 4342 Constrained := not Transmit_As_Unconstrained (Etyp); 4343 4344 -- Any parameter but unconstrained out parameters are 4345 -- transmitted to the peer. 4346 4347 if In_Present (Current_Parameter) 4348 or else not Out_Present (Current_Parameter) 4349 or else not Constrained 4350 then 4351 Append_To (Statements, 4352 Make_Attribute_Reference (Loc, 4353 Prefix => New_Occurrence_Of (Etyp, Loc), 4354 Attribute_Name => 4355 Output_From_Constrained (Constrained), 4356 Expressions => New_List ( 4357 Make_Attribute_Reference (Loc, 4358 Prefix => 4359 New_Occurrence_Of (Stream_Parameter, Loc), 4360 Attribute_Name => Name_Access), 4361 Value))); 4362 end if; 4363 end if; 4364 4365 -- If the current parameter has a dynamic constrained status, 4366 -- then this status is transmitted as well. 4367 -- This should be done for accessibility as well ??? 4368 4369 if Nkind (Typ) /= N_Access_Definition 4370 and then Need_Extra_Constrained (Current_Parameter) 4371 then 4372 -- In this block, we do not use the extra formal that has 4373 -- been created because it does not exist at the time of 4374 -- expansion when building calling stubs for remote access 4375 -- to subprogram types. We create an extra variable of this 4376 -- type and push it in the stream after the regular 4377 -- parameters. 4378 4379 Extra_Parameter := Make_Temporary (Loc, 'P'); 4380 4381 Append_To (Decls, 4382 Make_Object_Declaration (Loc, 4383 Defining_Identifier => Extra_Parameter, 4384 Constant_Present => True, 4385 Object_Definition => 4386 New_Occurrence_Of (Standard_Boolean, Loc), 4387 Expression => 4388 Make_Attribute_Reference (Loc, 4389 Prefix => 4390 New_Occurrence_Of ( 4391 Defining_Identifier (Current_Parameter), Loc), 4392 Attribute_Name => Name_Constrained))); 4393 4394 Append_To (Extra_Formal_Statements, 4395 Make_Attribute_Reference (Loc, 4396 Prefix => 4397 New_Occurrence_Of (Standard_Boolean, Loc), 4398 Attribute_Name => Name_Write, 4399 Expressions => New_List ( 4400 Make_Attribute_Reference (Loc, 4401 Prefix => 4402 New_Occurrence_Of 4403 (Stream_Parameter, Loc), Attribute_Name => 4404 Name_Access), 4405 New_Occurrence_Of (Extra_Parameter, Loc)))); 4406 end if; 4407 4408 Next (Current_Parameter); 4409 end; 4410 end loop; 4411 4412 -- Append the formal statements list to the statements 4413 4414 Append_List_To (Statements, Extra_Formal_Statements); 4415 4416 if not Is_Known_Non_Asynchronous then 4417 4418 -- Build the call to System.RPC.Do_APC 4419 4420 Asynchronous_Statements := New_List ( 4421 Make_Procedure_Call_Statement (Loc, 4422 Name => 4423 New_Occurrence_Of (RTE (RE_Do_Apc), Loc), 4424 Parameter_Associations => New_List ( 4425 New_Occurrence_Of (Target_Partition, Loc), 4426 Make_Attribute_Reference (Loc, 4427 Prefix => 4428 New_Occurrence_Of (Stream_Parameter, Loc), 4429 Attribute_Name => Name_Access)))); 4430 else 4431 Asynchronous_Statements := No_List; 4432 end if; 4433 4434 if not Is_Known_Asynchronous then 4435 4436 -- Build the call to System.RPC.Do_RPC 4437 4438 Non_Asynchronous_Statements := New_List ( 4439 Make_Procedure_Call_Statement (Loc, 4440 Name => 4441 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc), 4442 Parameter_Associations => New_List ( 4443 New_Occurrence_Of (Target_Partition, Loc), 4444 4445 Make_Attribute_Reference (Loc, 4446 Prefix => 4447 New_Occurrence_Of (Stream_Parameter, Loc), 4448 Attribute_Name => Name_Access), 4449 4450 Make_Attribute_Reference (Loc, 4451 Prefix => 4452 New_Occurrence_Of (Result_Parameter, Loc), 4453 Attribute_Name => Name_Access)))); 4454 4455 -- Read the exception occurrence from the result stream and 4456 -- reraise it. It does no harm if this is a Null_Occurrence since 4457 -- this does nothing. 4458 4459 Append_To (Non_Asynchronous_Statements, 4460 Make_Attribute_Reference (Loc, 4461 Prefix => 4462 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), 4463 4464 Attribute_Name => Name_Read, 4465 4466 Expressions => New_List ( 4467 Make_Attribute_Reference (Loc, 4468 Prefix => 4469 New_Occurrence_Of (Result_Parameter, Loc), 4470 Attribute_Name => Name_Access), 4471 New_Occurrence_Of (Exception_Return_Parameter, Loc)))); 4472 4473 Append_To (Non_Asynchronous_Statements, 4474 Make_Procedure_Call_Statement (Loc, 4475 Name => 4476 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), 4477 Parameter_Associations => New_List ( 4478 New_Occurrence_Of (Exception_Return_Parameter, Loc)))); 4479 4480 if Is_Function then 4481 4482 -- If this is a function call, then read the value and return 4483 -- it. The return value is written/read using 'Output/'Input. 4484 4485 Append_To (Non_Asynchronous_Statements, 4486 Make_Tag_Check (Loc, 4487 Make_Simple_Return_Statement (Loc, 4488 Expression => 4489 Make_Attribute_Reference (Loc, 4490 Prefix => 4491 New_Occurrence_Of ( 4492 Etype (Result_Definition (Spec)), Loc), 4493 4494 Attribute_Name => Name_Input, 4495 4496 Expressions => New_List ( 4497 Make_Attribute_Reference (Loc, 4498 Prefix => 4499 New_Occurrence_Of (Result_Parameter, Loc), 4500 Attribute_Name => Name_Access)))))); 4501 4502 else 4503 -- Loop around parameters and assign out (or in out) 4504 -- parameters. In the case of RACW, controlling arguments 4505 -- cannot possibly have changed since they are remote, so 4506 -- we do not read them from the stream. 4507 4508 Current_Parameter := First (Ordered_Parameters_List); 4509 while Present (Current_Parameter) loop 4510 declare 4511 Typ : constant Node_Id := 4512 Parameter_Type (Current_Parameter); 4513 Etyp : Entity_Id; 4514 Value : Node_Id; 4515 4516 begin 4517 Value := 4518 New_Occurrence_Of 4519 (Defining_Identifier (Current_Parameter), Loc); 4520 4521 if Nkind (Typ) = N_Access_Definition then 4522 Value := Make_Explicit_Dereference (Loc, Value); 4523 Etyp := Etype (Subtype_Mark (Typ)); 4524 else 4525 Etyp := Etype (Typ); 4526 end if; 4527 4528 if (Out_Present (Current_Parameter) 4529 or else Nkind (Typ) = N_Access_Definition) 4530 and then Etyp /= Stub_Type 4531 then 4532 Append_To (Non_Asynchronous_Statements, 4533 Make_Attribute_Reference (Loc, 4534 Prefix => 4535 New_Occurrence_Of (Etyp, Loc), 4536 4537 Attribute_Name => Name_Read, 4538 4539 Expressions => New_List ( 4540 Make_Attribute_Reference (Loc, 4541 Prefix => 4542 New_Occurrence_Of (Result_Parameter, Loc), 4543 Attribute_Name => Name_Access), 4544 Value))); 4545 end if; 4546 end; 4547 4548 Next (Current_Parameter); 4549 end loop; 4550 end if; 4551 end if; 4552 4553 if Is_Known_Asynchronous then 4554 Append_List_To (Statements, Asynchronous_Statements); 4555 4556 elsif Is_Known_Non_Asynchronous then 4557 Append_List_To (Statements, Non_Asynchronous_Statements); 4558 4559 else 4560 pragma Assert (Present (Asynchronous)); 4561 Prepend_To (Asynchronous_Statements, 4562 Make_Attribute_Reference (Loc, 4563 Prefix => New_Occurrence_Of (Standard_Boolean, Loc), 4564 Attribute_Name => Name_Write, 4565 Expressions => New_List ( 4566 Make_Attribute_Reference (Loc, 4567 Prefix => 4568 New_Occurrence_Of (Stream_Parameter, Loc), 4569 Attribute_Name => Name_Access), 4570 New_Occurrence_Of (Standard_True, Loc)))); 4571 4572 Prepend_To (Non_Asynchronous_Statements, 4573 Make_Attribute_Reference (Loc, 4574 Prefix => New_Occurrence_Of (Standard_Boolean, Loc), 4575 Attribute_Name => Name_Write, 4576 Expressions => New_List ( 4577 Make_Attribute_Reference (Loc, 4578 Prefix => 4579 New_Occurrence_Of (Stream_Parameter, Loc), 4580 Attribute_Name => Name_Access), 4581 New_Occurrence_Of (Standard_False, Loc)))); 4582 4583 Append_To (Statements, 4584 Make_Implicit_If_Statement (Nod, 4585 Condition => Asynchronous, 4586 Then_Statements => Asynchronous_Statements, 4587 Else_Statements => Non_Asynchronous_Statements)); 4588 end if; 4589 end Build_General_Calling_Stubs; 4590 4591 ----------------------------- 4592 -- Build_RPC_Receiver_Body -- 4593 ----------------------------- 4594 4595 procedure Build_RPC_Receiver_Body 4596 (RPC_Receiver : Entity_Id; 4597 Request : out Entity_Id; 4598 Subp_Id : out Entity_Id; 4599 Subp_Index : out Entity_Id; 4600 Stmts : out List_Id; 4601 Decl : out Node_Id) 4602 is 4603 Loc : constant Source_Ptr := Sloc (RPC_Receiver); 4604 4605 RPC_Receiver_Spec : Node_Id; 4606 RPC_Receiver_Decls : List_Id; 4607 4608 begin 4609 Request := Make_Defining_Identifier (Loc, Name_R); 4610 4611 RPC_Receiver_Spec := 4612 Build_RPC_Receiver_Specification 4613 (RPC_Receiver => RPC_Receiver, 4614 Request_Parameter => Request); 4615 4616 Subp_Id := Make_Temporary (Loc, 'P'); 4617 Subp_Index := Subp_Id; 4618 4619 -- Subp_Id may not be a constant, because in the case of the RPC 4620 -- receiver for an RCI package, when a call is received from a RAS 4621 -- dereference, it will be assigned during subsequent processing. 4622 4623 RPC_Receiver_Decls := New_List ( 4624 Make_Object_Declaration (Loc, 4625 Defining_Identifier => Subp_Id, 4626 Object_Definition => 4627 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), 4628 Expression => 4629 Make_Attribute_Reference (Loc, 4630 Prefix => 4631 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), 4632 Attribute_Name => Name_Input, 4633 Expressions => New_List ( 4634 Make_Selected_Component (Loc, 4635 Prefix => Request, 4636 Selector_Name => Name_Params))))); 4637 4638 Stmts := New_List; 4639 4640 Decl := 4641 Make_Subprogram_Body (Loc, 4642 Specification => RPC_Receiver_Spec, 4643 Declarations => RPC_Receiver_Decls, 4644 Handled_Statement_Sequence => 4645 Make_Handled_Sequence_Of_Statements (Loc, 4646 Statements => Stmts)); 4647 end Build_RPC_Receiver_Body; 4648 4649 ----------------------- 4650 -- Build_Stub_Target -- 4651 ----------------------- 4652 4653 function Build_Stub_Target 4654 (Loc : Source_Ptr; 4655 Decls : List_Id; 4656 RCI_Locator : Entity_Id; 4657 Controlling_Parameter : Entity_Id) return RPC_Target 4658 is 4659 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA); 4660 4661 begin 4662 Target_Info.Partition := Make_Temporary (Loc, 'P'); 4663 4664 if Present (Controlling_Parameter) then 4665 Append_To (Decls, 4666 Make_Object_Declaration (Loc, 4667 Defining_Identifier => Target_Info.Partition, 4668 Constant_Present => True, 4669 Object_Definition => 4670 New_Occurrence_Of (RTE (RE_Partition_ID), Loc), 4671 4672 Expression => 4673 Make_Selected_Component (Loc, 4674 Prefix => Controlling_Parameter, 4675 Selector_Name => Name_Origin))); 4676 4677 Target_Info.RPC_Receiver := 4678 Make_Selected_Component (Loc, 4679 Prefix => Controlling_Parameter, 4680 Selector_Name => Name_Receiver); 4681 4682 else 4683 Append_To (Decls, 4684 Make_Object_Declaration (Loc, 4685 Defining_Identifier => Target_Info.Partition, 4686 Constant_Present => True, 4687 Object_Definition => 4688 New_Occurrence_Of (RTE (RE_Partition_ID), Loc), 4689 4690 Expression => 4691 Make_Function_Call (Loc, 4692 Name => Make_Selected_Component (Loc, 4693 Prefix => 4694 Make_Identifier (Loc, Chars (RCI_Locator)), 4695 Selector_Name => 4696 Make_Identifier (Loc, 4697 Name_Get_Active_Partition_ID))))); 4698 4699 Target_Info.RPC_Receiver := 4700 Make_Selected_Component (Loc, 4701 Prefix => 4702 Make_Identifier (Loc, Chars (RCI_Locator)), 4703 Selector_Name => 4704 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver)); 4705 end if; 4706 return Target_Info; 4707 end Build_Stub_Target; 4708 4709 -------------------------------------- 4710 -- Build_Subprogram_Receiving_Stubs -- 4711 -------------------------------------- 4712 4713 function Build_Subprogram_Receiving_Stubs 4714 (Vis_Decl : Node_Id; 4715 Asynchronous : Boolean; 4716 Dynamically_Asynchronous : Boolean := False; 4717 Stub_Type : Entity_Id := Empty; 4718 RACW_Type : Entity_Id := Empty; 4719 Parent_Primitive : Entity_Id := Empty) return Node_Id 4720 is 4721 Loc : constant Source_Ptr := Sloc (Vis_Decl); 4722 4723 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); 4724 -- Formal parameter for receiving stubs: a descriptor for an incoming 4725 -- request. 4726 4727 Decls : constant List_Id := New_List; 4728 -- All the parameters will get declared before calling the real 4729 -- subprograms. Also the out parameters will be declared. 4730 4731 Statements : constant List_Id := New_List; 4732 4733 Extra_Formal_Statements : constant List_Id := New_List; 4734 -- Statements concerning extra formal parameters 4735 4736 After_Statements : constant List_Id := New_List; 4737 -- Statements to be executed after the subprogram call 4738 4739 Inner_Decls : List_Id := No_List; 4740 -- In case of a function, the inner declarations are needed since 4741 -- the result may be unconstrained. 4742 4743 Excep_Handlers : List_Id := No_List; 4744 Excep_Choice : Entity_Id; 4745 Excep_Code : List_Id; 4746 4747 Parameter_List : constant List_Id := New_List; 4748 -- List of parameters to be passed to the subprogram 4749 4750 Current_Parameter : Node_Id; 4751 4752 Ordered_Parameters_List : constant List_Id := 4753 Build_Ordered_Parameters_List 4754 (Specification (Vis_Decl)); 4755 4756 Subp_Spec : Node_Id; 4757 -- Subprogram specification 4758 4759 Called_Subprogram : Node_Id; 4760 -- The subprogram to call 4761 4762 Null_Raise_Statement : Node_Id; 4763 4764 Dynamic_Async : Entity_Id; 4765 4766 begin 4767 if Present (RACW_Type) then 4768 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc); 4769 else 4770 Called_Subprogram := 4771 New_Occurrence_Of 4772 (Defining_Unit_Name (Specification (Vis_Decl)), Loc); 4773 end if; 4774 4775 if Dynamically_Asynchronous then 4776 Dynamic_Async := Make_Temporary (Loc, 'S'); 4777 else 4778 Dynamic_Async := Empty; 4779 end if; 4780 4781 if not Asynchronous or Dynamically_Asynchronous then 4782 4783 -- The first statement after the subprogram call is a statement to 4784 -- write a Null_Occurrence into the result stream. 4785 4786 Null_Raise_Statement := 4787 Make_Attribute_Reference (Loc, 4788 Prefix => 4789 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), 4790 Attribute_Name => Name_Write, 4791 Expressions => New_List ( 4792 Make_Selected_Component (Loc, 4793 Prefix => Request_Parameter, 4794 Selector_Name => Name_Result), 4795 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); 4796 4797 if Dynamically_Asynchronous then 4798 Null_Raise_Statement := 4799 Make_Implicit_If_Statement (Vis_Decl, 4800 Condition => 4801 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), 4802 Then_Statements => New_List (Null_Raise_Statement)); 4803 end if; 4804 4805 Append_To (After_Statements, Null_Raise_Statement); 4806 end if; 4807 4808 -- Loop through every parameter and get its value from the stream. If 4809 -- the parameter is unconstrained, then the parameter is read using 4810 -- 'Input at the point of declaration. 4811 4812 Current_Parameter := First (Ordered_Parameters_List); 4813 while Present (Current_Parameter) loop 4814 declare 4815 Etyp : Entity_Id; 4816 Constrained : Boolean; 4817 4818 Need_Extra_Constrained : Boolean; 4819 -- True when an Extra_Constrained actual is required 4820 4821 Object : constant Entity_Id := Make_Temporary (Loc, 'P'); 4822 4823 Expr : Node_Id := Empty; 4824 4825 Is_Controlling_Formal : constant Boolean := 4826 Is_RACW_Controlling_Formal 4827 (Current_Parameter, Stub_Type); 4828 4829 begin 4830 if Is_Controlling_Formal then 4831 4832 -- We have a controlling formal parameter. Read its address 4833 -- rather than a real object. The address is in Unsigned_64 4834 -- form. 4835 4836 Etyp := RTE (RE_Unsigned_64); 4837 else 4838 Etyp := Etype (Parameter_Type (Current_Parameter)); 4839 end if; 4840 4841 Constrained := not Transmit_As_Unconstrained (Etyp); 4842 4843 if In_Present (Current_Parameter) 4844 or else not Out_Present (Current_Parameter) 4845 or else not Constrained 4846 or else Is_Controlling_Formal 4847 then 4848 -- If an input parameter is constrained, then the read of 4849 -- the parameter is deferred until the beginning of the 4850 -- subprogram body. If it is unconstrained, then an 4851 -- expression is built for the object declaration and the 4852 -- variable is set using 'Input instead of 'Read. Note that 4853 -- this deferral does not change the order in which the 4854 -- actuals are read because Build_Ordered_Parameter_List 4855 -- puts them unconstrained first. 4856 4857 if Constrained then 4858 Append_To (Statements, 4859 Make_Attribute_Reference (Loc, 4860 Prefix => New_Occurrence_Of (Etyp, Loc), 4861 Attribute_Name => Name_Read, 4862 Expressions => New_List ( 4863 Make_Selected_Component (Loc, 4864 Prefix => Request_Parameter, 4865 Selector_Name => Name_Params), 4866 New_Occurrence_Of (Object, Loc)))); 4867 4868 else 4869 4870 -- Build and append Input_With_Tag_Check function 4871 4872 Append_To (Decls, 4873 Input_With_Tag_Check (Loc, 4874 Var_Type => Etyp, 4875 Stream => 4876 Make_Selected_Component (Loc, 4877 Prefix => Request_Parameter, 4878 Selector_Name => Name_Params))); 4879 4880 -- Prepare function call expression 4881 4882 Expr := 4883 Make_Function_Call (Loc, 4884 Name => 4885 New_Occurrence_Of 4886 (Defining_Unit_Name 4887 (Specification (Last (Decls))), Loc)); 4888 end if; 4889 end if; 4890 4891 Need_Extra_Constrained := 4892 Nkind (Parameter_Type (Current_Parameter)) /= 4893 N_Access_Definition 4894 and then 4895 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void 4896 and then 4897 Present (Extra_Constrained 4898 (Defining_Identifier (Current_Parameter))); 4899 4900 -- We may not associate an extra constrained actual to a 4901 -- constant object, so if one is needed, declare the actual 4902 -- as a variable even if it won't be modified. 4903 4904 Build_Actual_Object_Declaration 4905 (Object => Object, 4906 Etyp => Etyp, 4907 Variable => Need_Extra_Constrained 4908 or else Out_Present (Current_Parameter), 4909 Expr => Expr, 4910 Decls => Decls); 4911 4912 -- An out parameter may be written back using a 'Write 4913 -- attribute instead of a 'Output because it has been 4914 -- constrained by the parameter given to the caller. Note that 4915 -- out controlling arguments in the case of a RACW are not put 4916 -- back in the stream because the pointer on them has not 4917 -- changed. 4918 4919 if Out_Present (Current_Parameter) 4920 and then 4921 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type 4922 then 4923 Append_To (After_Statements, 4924 Make_Attribute_Reference (Loc, 4925 Prefix => New_Occurrence_Of (Etyp, Loc), 4926 Attribute_Name => Name_Write, 4927 Expressions => New_List ( 4928 Make_Selected_Component (Loc, 4929 Prefix => Request_Parameter, 4930 Selector_Name => Name_Result), 4931 New_Occurrence_Of (Object, Loc)))); 4932 end if; 4933 4934 -- For RACW controlling formals, the Etyp of Object is always 4935 -- an RACW, even if the parameter is not of an anonymous access 4936 -- type. In such case, we need to dereference it at call time. 4937 4938 if Is_Controlling_Formal then 4939 if Nkind (Parameter_Type (Current_Parameter)) /= 4940 N_Access_Definition 4941 then 4942 Append_To (Parameter_List, 4943 Make_Parameter_Association (Loc, 4944 Selector_Name => 4945 New_Occurrence_Of ( 4946 Defining_Identifier (Current_Parameter), Loc), 4947 Explicit_Actual_Parameter => 4948 Make_Explicit_Dereference (Loc, 4949 Unchecked_Convert_To (RACW_Type, 4950 OK_Convert_To (RTE (RE_Address), 4951 New_Occurrence_Of (Object, Loc)))))); 4952 4953 else 4954 Append_To (Parameter_List, 4955 Make_Parameter_Association (Loc, 4956 Selector_Name => 4957 New_Occurrence_Of ( 4958 Defining_Identifier (Current_Parameter), Loc), 4959 Explicit_Actual_Parameter => 4960 Unchecked_Convert_To (RACW_Type, 4961 OK_Convert_To (RTE (RE_Address), 4962 New_Occurrence_Of (Object, Loc))))); 4963 end if; 4964 4965 else 4966 Append_To (Parameter_List, 4967 Make_Parameter_Association (Loc, 4968 Selector_Name => 4969 New_Occurrence_Of ( 4970 Defining_Identifier (Current_Parameter), Loc), 4971 Explicit_Actual_Parameter => 4972 New_Occurrence_Of (Object, Loc))); 4973 end if; 4974 4975 -- If the current parameter needs an extra formal, then read it 4976 -- from the stream and set the corresponding semantic field in 4977 -- the variable. If the kind of the parameter identifier is 4978 -- E_Void, then this is a compiler generated parameter that 4979 -- doesn't need an extra constrained status. 4980 4981 -- The case of Extra_Accessibility should also be handled ??? 4982 4983 if Need_Extra_Constrained then 4984 declare 4985 Extra_Parameter : constant Entity_Id := 4986 Extra_Constrained 4987 (Defining_Identifier 4988 (Current_Parameter)); 4989 4990 Formal_Entity : constant Entity_Id := 4991 Make_Defining_Identifier 4992 (Loc, Chars (Extra_Parameter)); 4993 4994 Formal_Type : constant Entity_Id := 4995 Etype (Extra_Parameter); 4996 4997 begin 4998 Append_To (Decls, 4999 Make_Object_Declaration (Loc, 5000 Defining_Identifier => Formal_Entity, 5001 Object_Definition => 5002 New_Occurrence_Of (Formal_Type, Loc))); 5003 5004 Append_To (Extra_Formal_Statements, 5005 Make_Attribute_Reference (Loc, 5006 Prefix => New_Occurrence_Of ( 5007 Formal_Type, Loc), 5008 Attribute_Name => Name_Read, 5009 Expressions => New_List ( 5010 Make_Selected_Component (Loc, 5011 Prefix => Request_Parameter, 5012 Selector_Name => Name_Params), 5013 New_Occurrence_Of (Formal_Entity, Loc)))); 5014 5015 -- Note: the call to Set_Extra_Constrained below relies 5016 -- on the fact that Object's Ekind has been set by 5017 -- Build_Actual_Object_Declaration. 5018 5019 Set_Extra_Constrained (Object, Formal_Entity); 5020 end; 5021 end if; 5022 end; 5023 5024 Next (Current_Parameter); 5025 end loop; 5026 5027 -- Append the formal statements list at the end of regular statements 5028 5029 Append_List_To (Statements, Extra_Formal_Statements); 5030 5031 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then 5032 5033 -- The remote subprogram is a function. We build an inner block to 5034 -- be able to hold a potentially unconstrained result in a 5035 -- variable. 5036 5037 declare 5038 Etyp : constant Entity_Id := 5039 Etype (Result_Definition (Specification (Vis_Decl))); 5040 Result : constant Node_Id := Make_Temporary (Loc, 'R'); 5041 5042 begin 5043 Inner_Decls := New_List ( 5044 Make_Object_Declaration (Loc, 5045 Defining_Identifier => Result, 5046 Constant_Present => True, 5047 Object_Definition => New_Occurrence_Of (Etyp, Loc), 5048 Expression => 5049 Make_Function_Call (Loc, 5050 Name => Called_Subprogram, 5051 Parameter_Associations => Parameter_List))); 5052 5053 if Is_Class_Wide_Type (Etyp) then 5054 5055 -- For a remote call to a function with a class-wide type, 5056 -- check that the returned value satisfies the requirements 5057 -- of E.4(18). 5058 5059 Append_To (Inner_Decls, 5060 Make_Transportable_Check (Loc, 5061 New_Occurrence_Of (Result, Loc))); 5062 5063 end if; 5064 5065 Append_To (After_Statements, 5066 Make_Attribute_Reference (Loc, 5067 Prefix => New_Occurrence_Of (Etyp, Loc), 5068 Attribute_Name => Name_Output, 5069 Expressions => New_List ( 5070 Make_Selected_Component (Loc, 5071 Prefix => Request_Parameter, 5072 Selector_Name => Name_Result), 5073 New_Occurrence_Of (Result, Loc)))); 5074 end; 5075 5076 Append_To (Statements, 5077 Make_Block_Statement (Loc, 5078 Declarations => Inner_Decls, 5079 Handled_Statement_Sequence => 5080 Make_Handled_Sequence_Of_Statements (Loc, 5081 Statements => After_Statements))); 5082 5083 else 5084 -- The remote subprogram is a procedure. We do not need any inner 5085 -- block in this case. 5086 5087 if Dynamically_Asynchronous then 5088 Append_To (Decls, 5089 Make_Object_Declaration (Loc, 5090 Defining_Identifier => Dynamic_Async, 5091 Object_Definition => 5092 New_Occurrence_Of (Standard_Boolean, Loc))); 5093 5094 Append_To (Statements, 5095 Make_Attribute_Reference (Loc, 5096 Prefix => New_Occurrence_Of (Standard_Boolean, Loc), 5097 Attribute_Name => Name_Read, 5098 Expressions => New_List ( 5099 Make_Selected_Component (Loc, 5100 Prefix => Request_Parameter, 5101 Selector_Name => Name_Params), 5102 New_Occurrence_Of (Dynamic_Async, Loc)))); 5103 end if; 5104 5105 Append_To (Statements, 5106 Make_Procedure_Call_Statement (Loc, 5107 Name => Called_Subprogram, 5108 Parameter_Associations => Parameter_List)); 5109 5110 Append_List_To (Statements, After_Statements); 5111 end if; 5112 5113 if Asynchronous and then not Dynamically_Asynchronous then 5114 5115 -- For an asynchronous procedure, add a null exception handler 5116 5117 Excep_Handlers := New_List ( 5118 Make_Implicit_Exception_Handler (Loc, 5119 Exception_Choices => New_List (Make_Others_Choice (Loc)), 5120 Statements => New_List (Make_Null_Statement (Loc)))); 5121 5122 else 5123 -- In the other cases, if an exception is raised, then the 5124 -- exception occurrence is copied into the output stream and 5125 -- no other output parameter is written. 5126 5127 Excep_Choice := Make_Temporary (Loc, 'E'); 5128 5129 Excep_Code := New_List ( 5130 Make_Attribute_Reference (Loc, 5131 Prefix => 5132 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), 5133 Attribute_Name => Name_Write, 5134 Expressions => New_List ( 5135 Make_Selected_Component (Loc, 5136 Prefix => Request_Parameter, 5137 Selector_Name => Name_Result), 5138 New_Occurrence_Of (Excep_Choice, Loc)))); 5139 5140 if Dynamically_Asynchronous then 5141 Excep_Code := New_List ( 5142 Make_Implicit_If_Statement (Vis_Decl, 5143 Condition => Make_Op_Not (Loc, 5144 New_Occurrence_Of (Dynamic_Async, Loc)), 5145 Then_Statements => Excep_Code)); 5146 end if; 5147 5148 Excep_Handlers := New_List ( 5149 Make_Implicit_Exception_Handler (Loc, 5150 Choice_Parameter => Excep_Choice, 5151 Exception_Choices => New_List (Make_Others_Choice (Loc)), 5152 Statements => Excep_Code)); 5153 5154 end if; 5155 5156 Subp_Spec := 5157 Make_Procedure_Specification (Loc, 5158 Defining_Unit_Name => Make_Temporary (Loc, 'F'), 5159 5160 Parameter_Specifications => New_List ( 5161 Make_Parameter_Specification (Loc, 5162 Defining_Identifier => Request_Parameter, 5163 Parameter_Type => 5164 New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); 5165 5166 return 5167 Make_Subprogram_Body (Loc, 5168 Specification => Subp_Spec, 5169 Declarations => Decls, 5170 Handled_Statement_Sequence => 5171 Make_Handled_Sequence_Of_Statements (Loc, 5172 Statements => Statements, 5173 Exception_Handlers => Excep_Handlers)); 5174 end Build_Subprogram_Receiving_Stubs; 5175 5176 ------------ 5177 -- Result -- 5178 ------------ 5179 5180 function Result return Node_Id is 5181 begin 5182 return Make_Identifier (Loc, Name_V); 5183 end Result; 5184 5185 ----------------------- 5186 -- RPC_Receiver_Decl -- 5187 ----------------------- 5188 5189 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is 5190 Loc : constant Source_Ptr := Sloc (RACW_Type); 5191 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); 5192 5193 begin 5194 -- No RPC receiver for remote access-to-subprogram 5195 5196 if Is_RAS then 5197 return Empty; 5198 end if; 5199 5200 return 5201 Make_Subprogram_Declaration (Loc, 5202 Build_RPC_Receiver_Specification 5203 (RPC_Receiver => Make_Temporary (Loc, 'R'), 5204 Request_Parameter => Make_Defining_Identifier (Loc, Name_R))); 5205 end RPC_Receiver_Decl; 5206 5207 ---------------------- 5208 -- Stream_Parameter -- 5209 ---------------------- 5210 5211 function Stream_Parameter return Node_Id is 5212 begin 5213 return Make_Identifier (Loc, Name_S); 5214 end Stream_Parameter; 5215 5216 end GARLIC_Support; 5217 5218 ------------------------------- 5219 -- Get_And_Reset_RACW_Bodies -- 5220 ------------------------------- 5221 5222 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is 5223 Desig : constant Entity_Id := 5224 Etype (Designated_Type (RACW_Type)); 5225 5226 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig); 5227 5228 Body_Decls : List_Id; 5229 -- Returned list of declarations 5230 5231 begin 5232 if Stub_Elements = Empty_Stub_Structure then 5233 5234 -- Stub elements may be missing as a consequence of a previously 5235 -- detected error. 5236 5237 return No_List; 5238 end if; 5239 5240 Body_Decls := Stub_Elements.Body_Decls; 5241 Stub_Elements.Body_Decls := No_List; 5242 Stubs_Table.Set (Desig, Stub_Elements); 5243 return Body_Decls; 5244 end Get_And_Reset_RACW_Bodies; 5245 5246 ----------------------- 5247 -- Get_Stub_Elements -- 5248 ----------------------- 5249 5250 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is 5251 Desig : constant Entity_Id := 5252 Etype (Designated_Type (RACW_Type)); 5253 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); 5254 begin 5255 pragma Assert (Stub_Elements /= Empty_Stub_Structure); 5256 return Stub_Elements; 5257 end Get_Stub_Elements; 5258 5259 ----------------------- 5260 -- Get_Subprogram_Id -- 5261 ----------------------- 5262 5263 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is 5264 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier; 5265 begin 5266 pragma Assert (Result /= No_String); 5267 return Result; 5268 end Get_Subprogram_Id; 5269 5270 ----------------------- 5271 -- Get_Subprogram_Id -- 5272 ----------------------- 5273 5274 function Get_Subprogram_Id (Def : Entity_Id) return Int is 5275 begin 5276 return Get_Subprogram_Ids (Def).Int_Identifier; 5277 end Get_Subprogram_Id; 5278 5279 ------------------------ 5280 -- Get_Subprogram_Ids -- 5281 ------------------------ 5282 5283 function Get_Subprogram_Ids 5284 (Def : Entity_Id) return Subprogram_Identifiers 5285 is 5286 begin 5287 return Subprogram_Identifier_Table.Get (Def); 5288 end Get_Subprogram_Ids; 5289 5290 ---------- 5291 -- Hash -- 5292 ---------- 5293 5294 function Hash (F : Entity_Id) return Hash_Index is 5295 begin 5296 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); 5297 end Hash; 5298 5299 function Hash (F : Name_Id) return Hash_Index is 5300 begin 5301 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); 5302 end Hash; 5303 5304 -------------------------- 5305 -- Input_With_Tag_Check -- 5306 -------------------------- 5307 5308 function Input_With_Tag_Check 5309 (Loc : Source_Ptr; 5310 Var_Type : Entity_Id; 5311 Stream : Node_Id) return Node_Id 5312 is 5313 begin 5314 return 5315 Make_Subprogram_Body (Loc, 5316 Specification => 5317 Make_Function_Specification (Loc, 5318 Defining_Unit_Name => Make_Temporary (Loc, 'S'), 5319 Result_Definition => New_Occurrence_Of (Var_Type, Loc)), 5320 Declarations => No_List, 5321 Handled_Statement_Sequence => 5322 Make_Handled_Sequence_Of_Statements (Loc, New_List ( 5323 Make_Tag_Check (Loc, 5324 Make_Simple_Return_Statement (Loc, 5325 Make_Attribute_Reference (Loc, 5326 Prefix => New_Occurrence_Of (Var_Type, Loc), 5327 Attribute_Name => Name_Input, 5328 Expressions => 5329 New_List (Stream))))))); 5330 end Input_With_Tag_Check; 5331 5332 -------------------------------- 5333 -- Is_RACW_Controlling_Formal -- 5334 -------------------------------- 5335 5336 function Is_RACW_Controlling_Formal 5337 (Parameter : Node_Id; 5338 Stub_Type : Entity_Id) return Boolean 5339 is 5340 Typ : Entity_Id; 5341 5342 begin 5343 -- If the kind of the parameter is E_Void, then it is not a controlling 5344 -- formal (this can happen in the context of RAS). 5345 5346 if Ekind (Defining_Identifier (Parameter)) = E_Void then 5347 return False; 5348 end if; 5349 5350 -- If the parameter is not a controlling formal, then it cannot be 5351 -- possibly a RACW_Controlling_Formal. 5352 5353 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then 5354 return False; 5355 end if; 5356 5357 Typ := Parameter_Type (Parameter); 5358 return (Nkind (Typ) = N_Access_Definition 5359 and then Etype (Subtype_Mark (Typ)) = Stub_Type) 5360 or else Etype (Typ) = Stub_Type; 5361 end Is_RACW_Controlling_Formal; 5362 5363 ------------------------------ 5364 -- Make_Transportable_Check -- 5365 ------------------------------ 5366 5367 function Make_Transportable_Check 5368 (Loc : Source_Ptr; 5369 Expr : Node_Id) return Node_Id is 5370 begin 5371 return 5372 Make_Raise_Program_Error (Loc, 5373 Condition => 5374 Make_Op_Not (Loc, 5375 Build_Get_Transportable (Loc, 5376 Make_Selected_Component (Loc, 5377 Prefix => Expr, 5378 Selector_Name => Make_Identifier (Loc, Name_uTag)))), 5379 Reason => PE_Non_Transportable_Actual); 5380 end Make_Transportable_Check; 5381 5382 ----------------------------- 5383 -- Make_Selected_Component -- 5384 ----------------------------- 5385 5386 function Make_Selected_Component 5387 (Loc : Source_Ptr; 5388 Prefix : Entity_Id; 5389 Selector_Name : Name_Id) return Node_Id 5390 is 5391 begin 5392 return Make_Selected_Component (Loc, 5393 Prefix => New_Occurrence_Of (Prefix, Loc), 5394 Selector_Name => Make_Identifier (Loc, Selector_Name)); 5395 end Make_Selected_Component; 5396 5397 -------------------- 5398 -- Make_Tag_Check -- 5399 -------------------- 5400 5401 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is 5402 Occ : constant Entity_Id := Make_Temporary (Loc, 'E'); 5403 5404 begin 5405 return Make_Block_Statement (Loc, 5406 Handled_Statement_Sequence => 5407 Make_Handled_Sequence_Of_Statements (Loc, 5408 Statements => New_List (N), 5409 5410 Exception_Handlers => New_List ( 5411 Make_Implicit_Exception_Handler (Loc, 5412 Choice_Parameter => Occ, 5413 5414 Exception_Choices => 5415 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)), 5416 5417 Statements => 5418 New_List (Make_Procedure_Call_Statement (Loc, 5419 New_Occurrence_Of 5420 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc), 5421 New_List (New_Occurrence_Of (Occ, Loc)))))))); 5422 end Make_Tag_Check; 5423 5424 ---------------------------- 5425 -- Need_Extra_Constrained -- 5426 ---------------------------- 5427 5428 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is 5429 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter)); 5430 begin 5431 return Out_Present (Parameter) 5432 and then Has_Discriminants (Etyp) 5433 and then not Is_Constrained (Etyp) 5434 and then not Is_Indefinite_Subtype (Etyp); 5435 end Need_Extra_Constrained; 5436 5437 ------------------------------------ 5438 -- Pack_Entity_Into_Stream_Access -- 5439 ------------------------------------ 5440 5441 function Pack_Entity_Into_Stream_Access 5442 (Loc : Source_Ptr; 5443 Stream : Node_Id; 5444 Object : Entity_Id; 5445 Etyp : Entity_Id := Empty) return Node_Id 5446 is 5447 Typ : Entity_Id; 5448 5449 begin 5450 if Present (Etyp) then 5451 Typ := Etyp; 5452 else 5453 Typ := Etype (Object); 5454 end if; 5455 5456 return 5457 Pack_Node_Into_Stream_Access (Loc, 5458 Stream => Stream, 5459 Object => New_Occurrence_Of (Object, Loc), 5460 Etyp => Typ); 5461 end Pack_Entity_Into_Stream_Access; 5462 5463 --------------------------- 5464 -- Pack_Node_Into_Stream -- 5465 --------------------------- 5466 5467 function Pack_Node_Into_Stream 5468 (Loc : Source_Ptr; 5469 Stream : Entity_Id; 5470 Object : Node_Id; 5471 Etyp : Entity_Id) return Node_Id 5472 is 5473 Write_Attribute : Name_Id := Name_Write; 5474 5475 begin 5476 if not Is_Constrained (Etyp) then 5477 Write_Attribute := Name_Output; 5478 end if; 5479 5480 return 5481 Make_Attribute_Reference (Loc, 5482 Prefix => New_Occurrence_Of (Etyp, Loc), 5483 Attribute_Name => Write_Attribute, 5484 Expressions => New_List ( 5485 Make_Attribute_Reference (Loc, 5486 Prefix => New_Occurrence_Of (Stream, Loc), 5487 Attribute_Name => Name_Access), 5488 Object)); 5489 end Pack_Node_Into_Stream; 5490 5491 ---------------------------------- 5492 -- Pack_Node_Into_Stream_Access -- 5493 ---------------------------------- 5494 5495 function Pack_Node_Into_Stream_Access 5496 (Loc : Source_Ptr; 5497 Stream : Node_Id; 5498 Object : Node_Id; 5499 Etyp : Entity_Id) return Node_Id 5500 is 5501 Write_Attribute : Name_Id := Name_Write; 5502 5503 begin 5504 if not Is_Constrained (Etyp) then 5505 Write_Attribute := Name_Output; 5506 end if; 5507 5508 return 5509 Make_Attribute_Reference (Loc, 5510 Prefix => New_Occurrence_Of (Etyp, Loc), 5511 Attribute_Name => Write_Attribute, 5512 Expressions => New_List ( 5513 Stream, 5514 Object)); 5515 end Pack_Node_Into_Stream_Access; 5516 5517 --------------------- 5518 -- PolyORB_Support -- 5519 --------------------- 5520 5521 package body PolyORB_Support is 5522 5523 -- Local subprograms 5524 5525 procedure Add_RACW_Read_Attribute 5526 (RACW_Type : Entity_Id; 5527 Stub_Type : Entity_Id; 5528 Stub_Type_Access : Entity_Id; 5529 Body_Decls : List_Id); 5530 -- Add Read attribute for the RACW type. The declaration and attribute 5531 -- definition clauses are inserted right after the declaration of 5532 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is 5533 -- appended to it (case where the RACW declaration is in the main unit). 5534 5535 procedure Add_RACW_Write_Attribute 5536 (RACW_Type : Entity_Id; 5537 Stub_Type : Entity_Id; 5538 Stub_Type_Access : Entity_Id; 5539 Body_Decls : List_Id); 5540 -- Same as above for the Write attribute 5541 5542 procedure Add_RACW_From_Any 5543 (RACW_Type : Entity_Id; 5544 Body_Decls : List_Id); 5545 -- Add the From_Any TSS for this RACW type 5546 5547 procedure Add_RACW_To_Any 5548 (RACW_Type : Entity_Id; 5549 Body_Decls : List_Id); 5550 -- Add the To_Any TSS for this RACW type 5551 5552 procedure Add_RACW_TypeCode 5553 (Designated_Type : Entity_Id; 5554 RACW_Type : Entity_Id; 5555 Body_Decls : List_Id); 5556 -- Add the TypeCode TSS for this RACW type 5557 5558 procedure Add_RAS_From_Any (RAS_Type : Entity_Id); 5559 -- Add the From_Any TSS for this RAS type 5560 5561 procedure Add_RAS_To_Any (RAS_Type : Entity_Id); 5562 -- Add the To_Any TSS for this RAS type 5563 5564 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id); 5565 -- Add the TypeCode TSS for this RAS type 5566 5567 procedure Add_RAS_Access_TSS (N : Node_Id); 5568 -- Add a subprogram body for RAS Access TSS 5569 5570 ------------------------------------- 5571 -- Add_Obj_RPC_Receiver_Completion -- 5572 ------------------------------------- 5573 5574 procedure Add_Obj_RPC_Receiver_Completion 5575 (Loc : Source_Ptr; 5576 Decls : List_Id; 5577 RPC_Receiver : Entity_Id; 5578 Stub_Elements : Stub_Structure) 5579 is 5580 Desig : constant Entity_Id := 5581 Etype (Designated_Type (Stub_Elements.RACW_Type)); 5582 begin 5583 Append_To (Decls, 5584 Make_Procedure_Call_Statement (Loc, 5585 Name => 5586 New_Occurrence_Of ( 5587 RTE (RE_Register_Obj_Receiving_Stub), Loc), 5588 5589 Parameter_Associations => New_List ( 5590 5591 -- Name 5592 5593 Make_String_Literal (Loc, 5594 Fully_Qualified_Name_String (Desig)), 5595 5596 -- Handler 5597 5598 Make_Attribute_Reference (Loc, 5599 Prefix => 5600 New_Occurrence_Of ( 5601 Defining_Unit_Name (Parent (RPC_Receiver)), Loc), 5602 Attribute_Name => 5603 Name_Access), 5604 5605 -- Receiver 5606 5607 Make_Attribute_Reference (Loc, 5608 Prefix => 5609 New_Occurrence_Of ( 5610 Defining_Identifier ( 5611 Stub_Elements.RPC_Receiver_Decl), Loc), 5612 Attribute_Name => 5613 Name_Access)))); 5614 end Add_Obj_RPC_Receiver_Completion; 5615 5616 ----------------------- 5617 -- Add_RACW_Features -- 5618 ----------------------- 5619 5620 procedure Add_RACW_Features 5621 (RACW_Type : Entity_Id; 5622 Desig : Entity_Id; 5623 Stub_Type : Entity_Id; 5624 Stub_Type_Access : Entity_Id; 5625 RPC_Receiver_Decl : Node_Id; 5626 Body_Decls : List_Id) 5627 is 5628 pragma Unreferenced (RPC_Receiver_Decl); 5629 5630 begin 5631 Add_RACW_From_Any 5632 (RACW_Type => RACW_Type, 5633 Body_Decls => Body_Decls); 5634 5635 Add_RACW_To_Any 5636 (RACW_Type => RACW_Type, 5637 Body_Decls => Body_Decls); 5638 5639 Add_RACW_Write_Attribute 5640 (RACW_Type => RACW_Type, 5641 Stub_Type => Stub_Type, 5642 Stub_Type_Access => Stub_Type_Access, 5643 Body_Decls => Body_Decls); 5644 5645 Add_RACW_Read_Attribute 5646 (RACW_Type => RACW_Type, 5647 Stub_Type => Stub_Type, 5648 Stub_Type_Access => Stub_Type_Access, 5649 Body_Decls => Body_Decls); 5650 5651 Add_RACW_TypeCode 5652 (Designated_Type => Desig, 5653 RACW_Type => RACW_Type, 5654 Body_Decls => Body_Decls); 5655 end Add_RACW_Features; 5656 5657 ----------------------- 5658 -- Add_RACW_From_Any -- 5659 ----------------------- 5660 5661 procedure Add_RACW_From_Any 5662 (RACW_Type : Entity_Id; 5663 Body_Decls : List_Id) 5664 is 5665 Loc : constant Source_Ptr := Sloc (RACW_Type); 5666 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); 5667 Fnam : constant Entity_Id := 5668 Make_Defining_Identifier (Loc, 5669 Chars => New_External_Name (Chars (RACW_Type), 'F')); 5670 5671 Func_Spec : Node_Id; 5672 Func_Decl : Node_Id; 5673 Func_Body : Node_Id; 5674 5675 Statements : List_Id; 5676 -- Various parts of the subprogram 5677 5678 Any_Parameter : constant Entity_Id := 5679 Make_Defining_Identifier (Loc, Name_A); 5680 5681 Asynchronous_Flag : constant Entity_Id := 5682 Asynchronous_Flags_Table.Get (RACW_Type); 5683 -- The flag object declared in Add_RACW_Asynchronous_Flag 5684 5685 begin 5686 Func_Spec := 5687 Make_Function_Specification (Loc, 5688 Defining_Unit_Name => 5689 Fnam, 5690 Parameter_Specifications => New_List ( 5691 Make_Parameter_Specification (Loc, 5692 Defining_Identifier => 5693 Any_Parameter, 5694 Parameter_Type => 5695 New_Occurrence_Of (RTE (RE_Any), Loc))), 5696 Result_Definition => New_Occurrence_Of (RACW_Type, Loc)); 5697 5698 -- NOTE: The usage occurrences of RACW_Parameter must refer to the 5699 -- entity in the declaration spec, not those of the body spec. 5700 5701 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); 5702 Insert_After (Declaration_Node (RACW_Type), Func_Decl); 5703 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any); 5704 5705 if No (Body_Decls) then 5706 return; 5707 end if; 5708 5709 -- ??? Issue with asynchronous calls here: the Asynchronous flag is 5710 -- set on the stub type if, and only if, the RACW type has a pragma 5711 -- Asynchronous. This is incorrect for RACWs that implement RAS 5712 -- types, because in that case the /designated subprogram/ (not the 5713 -- type) might be asynchronous, and that causes the stub to need to 5714 -- be asynchronous too. A solution is to transport a RAS as a struct 5715 -- containing a RACW and an asynchronous flag, and to properly alter 5716 -- the Asynchronous component in the stub type in the RAS's _From_Any 5717 -- TSS. 5718 5719 Statements := New_List ( 5720 Make_Simple_Return_Statement (Loc, 5721 Expression => Unchecked_Convert_To (RACW_Type, 5722 Make_Function_Call (Loc, 5723 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc), 5724 Parameter_Associations => New_List ( 5725 Make_Function_Call (Loc, 5726 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), 5727 Parameter_Associations => New_List ( 5728 New_Occurrence_Of (Any_Parameter, Loc))), 5729 Build_Stub_Tag (Loc, RACW_Type), 5730 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), 5731 New_Occurrence_Of (Asynchronous_Flag, Loc)))))); 5732 5733 Func_Body := 5734 Make_Subprogram_Body (Loc, 5735 Specification => Copy_Specification (Loc, Func_Spec), 5736 Declarations => No_List, 5737 Handled_Statement_Sequence => 5738 Make_Handled_Sequence_Of_Statements (Loc, 5739 Statements => Statements)); 5740 5741 Append_To (Body_Decls, Func_Body); 5742 end Add_RACW_From_Any; 5743 5744 ----------------------------- 5745 -- Add_RACW_Read_Attribute -- 5746 ----------------------------- 5747 5748 procedure Add_RACW_Read_Attribute 5749 (RACW_Type : Entity_Id; 5750 Stub_Type : Entity_Id; 5751 Stub_Type_Access : Entity_Id; 5752 Body_Decls : List_Id) 5753 is 5754 pragma Unreferenced (Stub_Type, Stub_Type_Access); 5755 5756 Loc : constant Source_Ptr := Sloc (RACW_Type); 5757 5758 Proc_Decl : Node_Id; 5759 Attr_Decl : Node_Id; 5760 5761 Body_Node : Node_Id; 5762 5763 Decls : constant List_Id := New_List; 5764 Statements : constant List_Id := New_List; 5765 Reference : constant Entity_Id := 5766 Make_Defining_Identifier (Loc, Name_R); 5767 -- Various parts of the procedure 5768 5769 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); 5770 5771 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); 5772 5773 Asynchronous_Flag : constant Entity_Id := 5774 Asynchronous_Flags_Table.Get (RACW_Type); 5775 pragma Assert (Present (Asynchronous_Flag)); 5776 5777 function Stream_Parameter return Node_Id; 5778 function Result return Node_Id; 5779 5780 -- Functions to create occurrences of the formal parameter names 5781 5782 ------------ 5783 -- Result -- 5784 ------------ 5785 5786 function Result return Node_Id is 5787 begin 5788 return Make_Identifier (Loc, Name_V); 5789 end Result; 5790 5791 ---------------------- 5792 -- Stream_Parameter -- 5793 ---------------------- 5794 5795 function Stream_Parameter return Node_Id is 5796 begin 5797 return Make_Identifier (Loc, Name_S); 5798 end Stream_Parameter; 5799 5800 -- Start of processing for Add_RACW_Read_Attribute 5801 5802 begin 5803 Build_Stream_Procedure 5804 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True); 5805 5806 Proc_Decl := Make_Subprogram_Declaration (Loc, 5807 Copy_Specification (Loc, Specification (Body_Node))); 5808 5809 Attr_Decl := 5810 Make_Attribute_Definition_Clause (Loc, 5811 Name => New_Occurrence_Of (RACW_Type, Loc), 5812 Chars => Name_Read, 5813 Expression => 5814 New_Occurrence_Of ( 5815 Defining_Unit_Name (Specification (Proc_Decl)), Loc)); 5816 5817 Insert_After (Declaration_Node (RACW_Type), Proc_Decl); 5818 Insert_After (Proc_Decl, Attr_Decl); 5819 5820 if No (Body_Decls) then 5821 return; 5822 end if; 5823 5824 Append_To (Decls, 5825 Make_Object_Declaration (Loc, 5826 Defining_Identifier => 5827 Reference, 5828 Object_Definition => 5829 New_Occurrence_Of (RTE (RE_Object_Ref), Loc))); 5830 5831 Append_List_To (Statements, New_List ( 5832 Make_Attribute_Reference (Loc, 5833 Prefix => 5834 New_Occurrence_Of (RTE (RE_Object_Ref), Loc), 5835 Attribute_Name => Name_Read, 5836 Expressions => New_List ( 5837 Stream_Parameter, 5838 New_Occurrence_Of (Reference, Loc))), 5839 5840 Make_Assignment_Statement (Loc, 5841 Name => 5842 Result, 5843 Expression => 5844 Unchecked_Convert_To (RACW_Type, 5845 Make_Function_Call (Loc, 5846 Name => 5847 New_Occurrence_Of (RTE (RE_Get_RACW), Loc), 5848 Parameter_Associations => New_List ( 5849 New_Occurrence_Of (Reference, Loc), 5850 Build_Stub_Tag (Loc, RACW_Type), 5851 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), 5852 New_Occurrence_Of (Asynchronous_Flag, Loc))))))); 5853 5854 Set_Declarations (Body_Node, Decls); 5855 Append_To (Body_Decls, Body_Node); 5856 end Add_RACW_Read_Attribute; 5857 5858 --------------------- 5859 -- Add_RACW_To_Any -- 5860 --------------------- 5861 5862 procedure Add_RACW_To_Any 5863 (RACW_Type : Entity_Id; 5864 Body_Decls : List_Id) 5865 is 5866 Loc : constant Source_Ptr := Sloc (RACW_Type); 5867 5868 Fnam : constant Entity_Id := 5869 Make_Defining_Identifier (Loc, 5870 Chars => New_External_Name (Chars (RACW_Type), 'T')); 5871 5872 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); 5873 5874 Stub_Elements : constant Stub_Structure := 5875 Get_Stub_Elements (RACW_Type); 5876 5877 Func_Spec : Node_Id; 5878 Func_Decl : Node_Id; 5879 Func_Body : Node_Id; 5880 5881 Decls : List_Id; 5882 Statements : List_Id; 5883 -- Various parts of the subprogram 5884 5885 RACW_Parameter : constant Entity_Id := 5886 Make_Defining_Identifier (Loc, Name_R); 5887 5888 Reference : constant Entity_Id := Make_Temporary (Loc, 'R'); 5889 Any : constant Entity_Id := Make_Temporary (Loc, 'A'); 5890 5891 begin 5892 Func_Spec := 5893 Make_Function_Specification (Loc, 5894 Defining_Unit_Name => 5895 Fnam, 5896 Parameter_Specifications => New_List ( 5897 Make_Parameter_Specification (Loc, 5898 Defining_Identifier => 5899 RACW_Parameter, 5900 Parameter_Type => 5901 New_Occurrence_Of (RACW_Type, Loc))), 5902 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); 5903 5904 -- NOTE: The usage occurrences of RACW_Parameter must refer to the 5905 -- entity in the declaration spec, not in the body spec. 5906 5907 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); 5908 5909 Insert_After (Declaration_Node (RACW_Type), Func_Decl); 5910 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any); 5911 5912 if No (Body_Decls) then 5913 return; 5914 end if; 5915 5916 -- Generate: 5917 5918 -- R : constant Object_Ref := 5919 -- Get_Reference 5920 -- (Address!(RACW), 5921 -- "typ", 5922 -- Stub_Type'Tag, 5923 -- Is_RAS, 5924 -- RPC_Receiver'Access); 5925 -- A : Any; 5926 5927 Decls := New_List ( 5928 Make_Object_Declaration (Loc, 5929 Defining_Identifier => Reference, 5930 Constant_Present => True, 5931 Object_Definition => 5932 New_Occurrence_Of (RTE (RE_Object_Ref), Loc), 5933 Expression => 5934 Make_Function_Call (Loc, 5935 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), 5936 Parameter_Associations => New_List ( 5937 Unchecked_Convert_To (RTE (RE_Address), 5938 New_Occurrence_Of (RACW_Parameter, Loc)), 5939 Make_String_Literal (Loc, 5940 Strval => Fully_Qualified_Name_String 5941 (Etype (Designated_Type (RACW_Type)))), 5942 Build_Stub_Tag (Loc, RACW_Type), 5943 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), 5944 Make_Attribute_Reference (Loc, 5945 Prefix => 5946 New_Occurrence_Of 5947 (Defining_Identifier 5948 (Stub_Elements.RPC_Receiver_Decl), Loc), 5949 Attribute_Name => Name_Access)))), 5950 5951 Make_Object_Declaration (Loc, 5952 Defining_Identifier => Any, 5953 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc))); 5954 5955 -- Generate: 5956 5957 -- Any := TA_ObjRef (Reference); 5958 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode); 5959 -- return Any; 5960 5961 Statements := New_List ( 5962 Make_Assignment_Statement (Loc, 5963 Name => New_Occurrence_Of (Any, Loc), 5964 Expression => 5965 Make_Function_Call (Loc, 5966 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), 5967 Parameter_Associations => New_List ( 5968 New_Occurrence_Of (Reference, Loc)))), 5969 5970 Make_Procedure_Call_Statement (Loc, 5971 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), 5972 Parameter_Associations => New_List ( 5973 New_Occurrence_Of (Any, Loc), 5974 Make_Selected_Component (Loc, 5975 Prefix => 5976 Defining_Identifier ( 5977 Stub_Elements.RPC_Receiver_Decl), 5978 Selector_Name => Name_Obj_TypeCode))), 5979 5980 Make_Simple_Return_Statement (Loc, 5981 Expression => New_Occurrence_Of (Any, Loc))); 5982 5983 Func_Body := 5984 Make_Subprogram_Body (Loc, 5985 Specification => Copy_Specification (Loc, Func_Spec), 5986 Declarations => Decls, 5987 Handled_Statement_Sequence => 5988 Make_Handled_Sequence_Of_Statements (Loc, 5989 Statements => Statements)); 5990 Append_To (Body_Decls, Func_Body); 5991 end Add_RACW_To_Any; 5992 5993 ----------------------- 5994 -- Add_RACW_TypeCode -- 5995 ----------------------- 5996 5997 procedure Add_RACW_TypeCode 5998 (Designated_Type : Entity_Id; 5999 RACW_Type : Entity_Id; 6000 Body_Decls : List_Id) 6001 is 6002 Loc : constant Source_Ptr := Sloc (RACW_Type); 6003 6004 Fnam : constant Entity_Id := 6005 Make_Defining_Identifier (Loc, 6006 Chars => New_External_Name (Chars (RACW_Type), 'Y')); 6007 6008 Stub_Elements : constant Stub_Structure := 6009 Stubs_Table.Get (Designated_Type); 6010 pragma Assert (Stub_Elements /= Empty_Stub_Structure); 6011 6012 Func_Spec : Node_Id; 6013 Func_Decl : Node_Id; 6014 Func_Body : Node_Id; 6015 6016 begin 6017 -- The spec for this subprogram has a dummy 'access RACW' argument, 6018 -- which serves only for overloading purposes. 6019 6020 Func_Spec := 6021 Make_Function_Specification (Loc, 6022 Defining_Unit_Name => Fnam, 6023 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); 6024 6025 -- NOTE: The usage occurrences of RACW_Parameter must refer to the 6026 -- entity in the declaration spec, not those of the body spec. 6027 6028 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); 6029 Insert_After (Declaration_Node (RACW_Type), Func_Decl); 6030 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode); 6031 6032 if No (Body_Decls) then 6033 return; 6034 end if; 6035 6036 Func_Body := 6037 Make_Subprogram_Body (Loc, 6038 Specification => Copy_Specification (Loc, Func_Spec), 6039 Declarations => Empty_List, 6040 Handled_Statement_Sequence => 6041 Make_Handled_Sequence_Of_Statements (Loc, 6042 Statements => New_List ( 6043 Make_Simple_Return_Statement (Loc, 6044 Expression => 6045 Make_Selected_Component (Loc, 6046 Prefix => 6047 Defining_Identifier 6048 (Stub_Elements.RPC_Receiver_Decl), 6049 Selector_Name => Name_Obj_TypeCode))))); 6050 6051 Append_To (Body_Decls, Func_Body); 6052 end Add_RACW_TypeCode; 6053 6054 ------------------------------ 6055 -- Add_RACW_Write_Attribute -- 6056 ------------------------------ 6057 6058 procedure Add_RACW_Write_Attribute 6059 (RACW_Type : Entity_Id; 6060 Stub_Type : Entity_Id; 6061 Stub_Type_Access : Entity_Id; 6062 Body_Decls : List_Id) 6063 is 6064 pragma Unreferenced (Stub_Type, Stub_Type_Access); 6065 6066 Loc : constant Source_Ptr := Sloc (RACW_Type); 6067 6068 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); 6069 6070 Stub_Elements : constant Stub_Structure := 6071 Get_Stub_Elements (RACW_Type); 6072 6073 Body_Node : Node_Id; 6074 Proc_Decl : Node_Id; 6075 Attr_Decl : Node_Id; 6076 6077 Statements : constant List_Id := New_List; 6078 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); 6079 6080 function Stream_Parameter return Node_Id; 6081 function Object return Node_Id; 6082 -- Functions to create occurrences of the formal parameter names 6083 6084 ------------ 6085 -- Object -- 6086 ------------ 6087 6088 function Object return Node_Id is 6089 begin 6090 return Make_Identifier (Loc, Name_V); 6091 end Object; 6092 6093 ---------------------- 6094 -- Stream_Parameter -- 6095 ---------------------- 6096 6097 function Stream_Parameter return Node_Id is 6098 begin 6099 return Make_Identifier (Loc, Name_S); 6100 end Stream_Parameter; 6101 6102 -- Start of processing for Add_RACW_Write_Attribute 6103 6104 begin 6105 Build_Stream_Procedure 6106 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); 6107 6108 Proc_Decl := 6109 Make_Subprogram_Declaration (Loc, 6110 Copy_Specification (Loc, Specification (Body_Node))); 6111 6112 Attr_Decl := 6113 Make_Attribute_Definition_Clause (Loc, 6114 Name => New_Occurrence_Of (RACW_Type, Loc), 6115 Chars => Name_Write, 6116 Expression => 6117 New_Occurrence_Of ( 6118 Defining_Unit_Name (Specification (Proc_Decl)), Loc)); 6119 6120 Insert_After (Declaration_Node (RACW_Type), Proc_Decl); 6121 Insert_After (Proc_Decl, Attr_Decl); 6122 6123 if No (Body_Decls) then 6124 return; 6125 end if; 6126 6127 Append_To (Statements, 6128 Pack_Node_Into_Stream_Access (Loc, 6129 Stream => Stream_Parameter, 6130 Object => 6131 Make_Function_Call (Loc, 6132 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), 6133 Parameter_Associations => New_List ( 6134 Unchecked_Convert_To (RTE (RE_Address), Object), 6135 Make_String_Literal (Loc, 6136 Strval => Fully_Qualified_Name_String 6137 (Etype (Designated_Type (RACW_Type)))), 6138 Build_Stub_Tag (Loc, RACW_Type), 6139 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), 6140 Make_Attribute_Reference (Loc, 6141 Prefix => 6142 New_Occurrence_Of 6143 (Defining_Identifier 6144 (Stub_Elements.RPC_Receiver_Decl), Loc), 6145 Attribute_Name => Name_Access))), 6146 6147 Etyp => RTE (RE_Object_Ref))); 6148 6149 Append_To (Body_Decls, Body_Node); 6150 end Add_RACW_Write_Attribute; 6151 6152 ----------------------- 6153 -- Add_RAST_Features -- 6154 ----------------------- 6155 6156 procedure Add_RAST_Features 6157 (Vis_Decl : Node_Id; 6158 RAS_Type : Entity_Id) 6159 is 6160 begin 6161 Add_RAS_Access_TSS (Vis_Decl); 6162 6163 Add_RAS_From_Any (RAS_Type); 6164 Add_RAS_TypeCode (RAS_Type); 6165 6166 -- To_Any uses TypeCode, and therefore needs to be generated last 6167 6168 Add_RAS_To_Any (RAS_Type); 6169 end Add_RAST_Features; 6170 6171 ------------------------ 6172 -- Add_RAS_Access_TSS -- 6173 ------------------------ 6174 6175 procedure Add_RAS_Access_TSS (N : Node_Id) is 6176 Loc : constant Source_Ptr := Sloc (N); 6177 6178 Ras_Type : constant Entity_Id := Defining_Identifier (N); 6179 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); 6180 -- Ras_Type is the access to subprogram type; Fat_Type is the 6181 -- corresponding record type. 6182 6183 RACW_Type : constant Entity_Id := 6184 Underlying_RACW_Type (Ras_Type); 6185 6186 Stub_Elements : constant Stub_Structure := 6187 Get_Stub_Elements (RACW_Type); 6188 6189 Proc : constant Entity_Id := 6190 Make_Defining_Identifier (Loc, 6191 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); 6192 6193 Proc_Spec : Node_Id; 6194 6195 -- Formal parameters 6196 6197 Package_Name : constant Entity_Id := 6198 Make_Defining_Identifier (Loc, 6199 Chars => Name_P); 6200 6201 -- Target package 6202 6203 Subp_Id : constant Entity_Id := 6204 Make_Defining_Identifier (Loc, 6205 Chars => Name_S); 6206 6207 -- Target subprogram 6208 6209 Asynch_P : constant Entity_Id := 6210 Make_Defining_Identifier (Loc, 6211 Chars => Name_Asynchronous); 6212 -- Is the procedure to which the 'Access applies asynchronous? 6213 6214 All_Calls_Remote : constant Entity_Id := 6215 Make_Defining_Identifier (Loc, 6216 Chars => Name_All_Calls_Remote); 6217 -- True if an All_Calls_Remote pragma applies to the RCI unit 6218 -- that contains the subprogram. 6219 6220 -- Common local variables 6221 6222 Proc_Decls : List_Id; 6223 Proc_Statements : List_Id; 6224 6225 Subp_Ref : constant Entity_Id := 6226 Make_Defining_Identifier (Loc, Name_R); 6227 -- Reference that designates the target subprogram (returned 6228 -- by Get_RAS_Info). 6229 6230 Is_Local : constant Entity_Id := 6231 Make_Defining_Identifier (Loc, Name_L); 6232 Local_Addr : constant Entity_Id := 6233 Make_Defining_Identifier (Loc, Name_A); 6234 -- For the call to Get_Local_Address 6235 6236 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); 6237 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); 6238 -- Additional local variables for the remote case 6239 6240 function Set_Field 6241 (Field_Name : Name_Id; 6242 Value : Node_Id) return Node_Id; 6243 -- Construct an assignment that sets the named component in the 6244 -- returned record 6245 6246 --------------- 6247 -- Set_Field -- 6248 --------------- 6249 6250 function Set_Field 6251 (Field_Name : Name_Id; 6252 Value : Node_Id) return Node_Id 6253 is 6254 begin 6255 return 6256 Make_Assignment_Statement (Loc, 6257 Name => 6258 Make_Selected_Component (Loc, 6259 Prefix => Stub_Ptr, 6260 Selector_Name => Field_Name), 6261 Expression => Value); 6262 end Set_Field; 6263 6264 -- Start of processing for Add_RAS_Access_TSS 6265 6266 begin 6267 Proc_Decls := New_List ( 6268 6269 -- Common declarations 6270 6271 Make_Object_Declaration (Loc, 6272 Defining_Identifier => Subp_Ref, 6273 Object_Definition => 6274 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)), 6275 6276 Make_Object_Declaration (Loc, 6277 Defining_Identifier => Is_Local, 6278 Object_Definition => 6279 New_Occurrence_Of (Standard_Boolean, Loc)), 6280 6281 Make_Object_Declaration (Loc, 6282 Defining_Identifier => Local_Addr, 6283 Object_Definition => 6284 New_Occurrence_Of (RTE (RE_Address), Loc)), 6285 6286 Make_Object_Declaration (Loc, 6287 Defining_Identifier => Local_Stub, 6288 Aliased_Present => True, 6289 Object_Definition => 6290 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), 6291 6292 Make_Object_Declaration (Loc, 6293 Defining_Identifier => Stub_Ptr, 6294 Object_Definition => 6295 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), 6296 Expression => 6297 Make_Attribute_Reference (Loc, 6298 Prefix => New_Occurrence_Of (Local_Stub, Loc), 6299 Attribute_Name => Name_Unchecked_Access))); 6300 6301 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); 6302 -- Build_Get_Unique_RP_Call needs this information 6303 6304 -- Get_RAS_Info (Pkg, Subp, R); 6305 -- Obtain a reference to the target subprogram 6306 6307 Proc_Statements := New_List ( 6308 Make_Procedure_Call_Statement (Loc, 6309 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), 6310 Parameter_Associations => New_List ( 6311 New_Occurrence_Of (Package_Name, Loc), 6312 New_Occurrence_Of (Subp_Id, Loc), 6313 New_Occurrence_Of (Subp_Ref, Loc))), 6314 6315 -- Get_Local_Address (R, L, A); 6316 -- Determine whether the subprogram is local (L), and if so 6317 -- obtain the local address of its proxy (A). 6318 6319 Make_Procedure_Call_Statement (Loc, 6320 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), 6321 Parameter_Associations => New_List ( 6322 New_Occurrence_Of (Subp_Ref, Loc), 6323 New_Occurrence_Of (Is_Local, Loc), 6324 New_Occurrence_Of (Local_Addr, Loc)))); 6325 6326 -- Note: Here we assume that the Fat_Type is a record containing just 6327 -- an access to a proxy or stub object. 6328 6329 Append_To (Proc_Statements, 6330 6331 -- if L then 6332 6333 Make_Implicit_If_Statement (N, 6334 Condition => New_Occurrence_Of (Is_Local, Loc), 6335 6336 Then_Statements => New_List ( 6337 6338 -- if A.Target = null then 6339 6340 Make_Implicit_If_Statement (N, 6341 Condition => 6342 Make_Op_Eq (Loc, 6343 Make_Selected_Component (Loc, 6344 Prefix => 6345 Unchecked_Convert_To 6346 (RTE (RE_RAS_Proxy_Type_Access), 6347 New_Occurrence_Of (Local_Addr, Loc)), 6348 Selector_Name => Make_Identifier (Loc, Name_Target)), 6349 Make_Null (Loc)), 6350 6351 Then_Statements => New_List ( 6352 6353 -- A.Target := Entity_Of (Ref); 6354 6355 Make_Assignment_Statement (Loc, 6356 Name => 6357 Make_Selected_Component (Loc, 6358 Prefix => 6359 Unchecked_Convert_To 6360 (RTE (RE_RAS_Proxy_Type_Access), 6361 New_Occurrence_Of (Local_Addr, Loc)), 6362 Selector_Name => Make_Identifier (Loc, Name_Target)), 6363 Expression => 6364 Make_Function_Call (Loc, 6365 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), 6366 Parameter_Associations => New_List ( 6367 New_Occurrence_Of (Subp_Ref, Loc)))), 6368 6369 -- Inc_Usage (A.Target); 6370 -- end if; 6371 6372 Make_Procedure_Call_Statement (Loc, 6373 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), 6374 Parameter_Associations => New_List ( 6375 Make_Selected_Component (Loc, 6376 Prefix => 6377 Unchecked_Convert_To 6378 (RTE (RE_RAS_Proxy_Type_Access), 6379 New_Occurrence_Of (Local_Addr, Loc)), 6380 Selector_Name => 6381 Make_Identifier (Loc, Name_Target)))))), 6382 6383 -- if not All_Calls_Remote then 6384 -- return Fat_Type!(A); 6385 -- end if; 6386 6387 Make_Implicit_If_Statement (N, 6388 Condition => 6389 Make_Op_Not (Loc, 6390 Right_Opnd => 6391 New_Occurrence_Of (All_Calls_Remote, Loc)), 6392 6393 Then_Statements => New_List ( 6394 Make_Simple_Return_Statement (Loc, 6395 Expression => 6396 Unchecked_Convert_To 6397 (Fat_Type, New_Occurrence_Of (Local_Addr, Loc)))))))); 6398 6399 Append_List_To (Proc_Statements, New_List ( 6400 6401 -- Stub.Target := Entity_Of (Ref); 6402 6403 Set_Field (Name_Target, 6404 Make_Function_Call (Loc, 6405 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc), 6406 Parameter_Associations => New_List ( 6407 New_Occurrence_Of (Subp_Ref, Loc)))), 6408 6409 -- Inc_Usage (Stub.Target); 6410 6411 Make_Procedure_Call_Statement (Loc, 6412 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), 6413 Parameter_Associations => New_List ( 6414 Make_Selected_Component (Loc, 6415 Prefix => Stub_Ptr, 6416 Selector_Name => Name_Target))), 6417 6418 -- E.4.1(9) A remote call is asynchronous if it is a call to 6419 -- a procedure, or a call through a value of an access-to-procedure 6420 -- type, to which a pragma Asynchronous applies. 6421 6422 -- Parameter Asynch_P is true when the procedure is asynchronous; 6423 -- Expression Asynch_T is true when the type is asynchronous. 6424 6425 Set_Field (Name_Asynchronous, 6426 Make_Or_Else (Loc, 6427 Left_Opnd => New_Occurrence_Of (Asynch_P, Loc), 6428 Right_Opnd => 6429 New_Occurrence_Of 6430 (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc))))); 6431 6432 Append_List_To (Proc_Statements, 6433 Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); 6434 6435 Append_To (Proc_Statements, 6436 Make_Simple_Return_Statement (Loc, 6437 Expression => 6438 Unchecked_Convert_To (Fat_Type, 6439 New_Occurrence_Of (Stub_Ptr, Loc)))); 6440 6441 Proc_Spec := 6442 Make_Function_Specification (Loc, 6443 Defining_Unit_Name => Proc, 6444 Parameter_Specifications => New_List ( 6445 Make_Parameter_Specification (Loc, 6446 Defining_Identifier => Package_Name, 6447 Parameter_Type => 6448 New_Occurrence_Of (Standard_String, Loc)), 6449 6450 Make_Parameter_Specification (Loc, 6451 Defining_Identifier => Subp_Id, 6452 Parameter_Type => 6453 New_Occurrence_Of (Standard_String, Loc)), 6454 6455 Make_Parameter_Specification (Loc, 6456 Defining_Identifier => Asynch_P, 6457 Parameter_Type => 6458 New_Occurrence_Of (Standard_Boolean, Loc)), 6459 6460 Make_Parameter_Specification (Loc, 6461 Defining_Identifier => All_Calls_Remote, 6462 Parameter_Type => 6463 New_Occurrence_Of (Standard_Boolean, Loc))), 6464 6465 Result_Definition => 6466 New_Occurrence_Of (Fat_Type, Loc)); 6467 6468 -- Set the kind and return type of the function to prevent 6469 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. 6470 6471 Set_Ekind (Proc, E_Function); 6472 Set_Etype (Proc, Fat_Type); 6473 6474 Discard_Node ( 6475 Make_Subprogram_Body (Loc, 6476 Specification => Proc_Spec, 6477 Declarations => Proc_Decls, 6478 Handled_Statement_Sequence => 6479 Make_Handled_Sequence_Of_Statements (Loc, 6480 Statements => Proc_Statements))); 6481 6482 Set_TSS (Fat_Type, Proc); 6483 end Add_RAS_Access_TSS; 6484 6485 ---------------------- 6486 -- Add_RAS_From_Any -- 6487 ---------------------- 6488 6489 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is 6490 Loc : constant Source_Ptr := Sloc (RAS_Type); 6491 6492 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, 6493 Make_TSS_Name (RAS_Type, TSS_From_Any)); 6494 6495 Func_Spec : Node_Id; 6496 6497 Statements : List_Id; 6498 6499 Any_Parameter : constant Entity_Id := 6500 Make_Defining_Identifier (Loc, Name_A); 6501 6502 begin 6503 Statements := New_List ( 6504 Make_Simple_Return_Statement (Loc, 6505 Expression => 6506 Make_Aggregate (Loc, 6507 Component_Associations => New_List ( 6508 Make_Component_Association (Loc, 6509 Choices => New_List (Make_Identifier (Loc, Name_Ras)), 6510 Expression => 6511 PolyORB_Support.Helpers.Build_From_Any_Call 6512 (Underlying_RACW_Type (RAS_Type), 6513 New_Occurrence_Of (Any_Parameter, Loc), 6514 No_List)))))); 6515 6516 Func_Spec := 6517 Make_Function_Specification (Loc, 6518 Defining_Unit_Name => Fnam, 6519 Parameter_Specifications => New_List ( 6520 Make_Parameter_Specification (Loc, 6521 Defining_Identifier => Any_Parameter, 6522 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), 6523 Result_Definition => New_Occurrence_Of (RAS_Type, Loc)); 6524 6525 Discard_Node ( 6526 Make_Subprogram_Body (Loc, 6527 Specification => Func_Spec, 6528 Declarations => No_List, 6529 Handled_Statement_Sequence => 6530 Make_Handled_Sequence_Of_Statements (Loc, 6531 Statements => Statements))); 6532 Set_TSS (RAS_Type, Fnam); 6533 end Add_RAS_From_Any; 6534 6535 -------------------- 6536 -- Add_RAS_To_Any -- 6537 -------------------- 6538 6539 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is 6540 Loc : constant Source_Ptr := Sloc (RAS_Type); 6541 6542 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, 6543 Make_TSS_Name (RAS_Type, TSS_To_Any)); 6544 6545 Decls : List_Id; 6546 Statements : List_Id; 6547 6548 Func_Spec : Node_Id; 6549 6550 Any : constant Entity_Id := Make_Temporary (Loc, 'A'); 6551 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); 6552 RACW_Parameter : constant Node_Id := 6553 Make_Selected_Component (Loc, 6554 Prefix => RAS_Parameter, 6555 Selector_Name => Name_Ras); 6556 6557 begin 6558 -- Object declarations 6559 6560 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type)); 6561 Decls := New_List ( 6562 Make_Object_Declaration (Loc, 6563 Defining_Identifier => Any, 6564 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc), 6565 Expression => 6566 PolyORB_Support.Helpers.Build_To_Any_Call 6567 (Loc, RACW_Parameter, No_List))); 6568 6569 Statements := New_List ( 6570 Make_Procedure_Call_Statement (Loc, 6571 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), 6572 Parameter_Associations => New_List ( 6573 New_Occurrence_Of (Any, Loc), 6574 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, 6575 RAS_Type, Decls))), 6576 6577 Make_Simple_Return_Statement (Loc, 6578 Expression => New_Occurrence_Of (Any, Loc))); 6579 6580 Func_Spec := 6581 Make_Function_Specification (Loc, 6582 Defining_Unit_Name => Fnam, 6583 Parameter_Specifications => New_List ( 6584 Make_Parameter_Specification (Loc, 6585 Defining_Identifier => RAS_Parameter, 6586 Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))), 6587 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); 6588 6589 Discard_Node ( 6590 Make_Subprogram_Body (Loc, 6591 Specification => Func_Spec, 6592 Declarations => Decls, 6593 Handled_Statement_Sequence => 6594 Make_Handled_Sequence_Of_Statements (Loc, 6595 Statements => Statements))); 6596 Set_TSS (RAS_Type, Fnam); 6597 end Add_RAS_To_Any; 6598 6599 ---------------------- 6600 -- Add_RAS_TypeCode -- 6601 ---------------------- 6602 6603 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is 6604 Loc : constant Source_Ptr := Sloc (RAS_Type); 6605 6606 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc, 6607 Make_TSS_Name (RAS_Type, TSS_TypeCode)); 6608 6609 Func_Spec : Node_Id; 6610 Decls : constant List_Id := New_List; 6611 Name_String : String_Id; 6612 Repo_Id_String : String_Id; 6613 6614 begin 6615 Func_Spec := 6616 Make_Function_Specification (Loc, 6617 Defining_Unit_Name => Fnam, 6618 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); 6619 6620 PolyORB_Support.Helpers.Build_Name_And_Repository_Id 6621 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String); 6622 6623 Discard_Node ( 6624 Make_Subprogram_Body (Loc, 6625 Specification => Func_Spec, 6626 Declarations => Decls, 6627 Handled_Statement_Sequence => 6628 Make_Handled_Sequence_Of_Statements (Loc, 6629 Statements => New_List ( 6630 Make_Simple_Return_Statement (Loc, 6631 Expression => 6632 Make_Function_Call (Loc, 6633 Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc), 6634 Parameter_Associations => New_List ( 6635 New_Occurrence_Of (RTE (RE_TC_Object), Loc), 6636 Make_Aggregate (Loc, 6637 Expressions => 6638 New_List ( 6639 Make_Function_Call (Loc, 6640 Name => 6641 New_Occurrence_Of 6642 (RTE (RE_TA_Std_String), Loc), 6643 Parameter_Associations => New_List ( 6644 Make_String_Literal (Loc, Name_String))), 6645 Make_Function_Call (Loc, 6646 Name => 6647 New_Occurrence_Of 6648 (RTE (RE_TA_Std_String), Loc), 6649 Parameter_Associations => New_List ( 6650 Make_String_Literal (Loc, 6651 Strval => Repo_Id_String)))))))))))); 6652 Set_TSS (RAS_Type, Fnam); 6653 end Add_RAS_TypeCode; 6654 6655 ----------------------------------------- 6656 -- Add_Receiving_Stubs_To_Declarations -- 6657 ----------------------------------------- 6658 6659 procedure Add_Receiving_Stubs_To_Declarations 6660 (Pkg_Spec : Node_Id; 6661 Decls : List_Id; 6662 Stmts : List_Id) 6663 is 6664 Loc : constant Source_Ptr := Sloc (Pkg_Spec); 6665 6666 Pkg_RPC_Receiver : constant Entity_Id := 6667 Make_Temporary (Loc, 'H'); 6668 Pkg_RPC_Receiver_Object : Node_Id; 6669 Pkg_RPC_Receiver_Body : Node_Id; 6670 Pkg_RPC_Receiver_Decls : List_Id; 6671 Pkg_RPC_Receiver_Statements : List_Id; 6672 6673 Pkg_RPC_Receiver_Cases : constant List_Id := New_List; 6674 -- A Pkg_RPC_Receiver is built to decode the request 6675 6676 Request : Node_Id; 6677 -- Request object received from neutral layer 6678 6679 Subp_Id : Entity_Id; 6680 -- Subprogram identifier as received from the neutral distribution 6681 -- core. 6682 6683 Subp_Index : Entity_Id; 6684 -- Internal index as determined by matching either the method name 6685 -- from the request structure, or the local subprogram address (in 6686 -- case of a RAS). 6687 6688 Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L'); 6689 6690 Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A'); 6691 -- Address of a local subprogram designated by a reference 6692 -- corresponding to a RAS. 6693 6694 Dispatch_On_Address : constant List_Id := New_List; 6695 Dispatch_On_Name : constant List_Id := New_List; 6696 6697 Current_Subp_Number : Int := First_RCI_Subprogram_Id; 6698 6699 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); 6700 Subp_Info_List : constant List_Id := New_List; 6701 6702 Register_Pkg_Actuals : constant List_Id := New_List; 6703 6704 All_Calls_Remote_E : Entity_Id; 6705 6706 procedure Append_Stubs_To 6707 (RPC_Receiver_Cases : List_Id; 6708 Declaration : Node_Id; 6709 Stubs : Node_Id; 6710 Subp_Number : Int; 6711 Subp_Dist_Name : Entity_Id; 6712 Subp_Proxy_Addr : Entity_Id); 6713 -- Add one case to the specified RPC receiver case list associating 6714 -- Subprogram_Number with the subprogram declared by Declaration, for 6715 -- which we have receiving stubs in Stubs. Subp_Number is an internal 6716 -- subprogram index. Subp_Dist_Name is the string used to call the 6717 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy 6718 -- object, used in the context of calls through remote 6719 -- access-to-subprogram types. 6720 6721 procedure Visit_Subprogram (Decl : Node_Id); 6722 -- Generate receiving stub for one remote subprogram 6723 6724 --------------------- 6725 -- Append_Stubs_To -- 6726 --------------------- 6727 6728 procedure Append_Stubs_To 6729 (RPC_Receiver_Cases : List_Id; 6730 Declaration : Node_Id; 6731 Stubs : Node_Id; 6732 Subp_Number : Int; 6733 Subp_Dist_Name : Entity_Id; 6734 Subp_Proxy_Addr : Entity_Id) 6735 is 6736 Case_Stmts : List_Id; 6737 begin 6738 Case_Stmts := New_List ( 6739 Make_Procedure_Call_Statement (Loc, 6740 Name => 6741 New_Occurrence_Of ( 6742 Defining_Entity (Stubs), Loc), 6743 Parameter_Associations => 6744 New_List (New_Occurrence_Of (Request, Loc)))); 6745 6746 if Nkind (Specification (Declaration)) = N_Function_Specification 6747 or else not 6748 Is_Asynchronous (Defining_Entity (Specification (Declaration))) 6749 then 6750 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc)); 6751 end if; 6752 6753 Append_To (RPC_Receiver_Cases, 6754 Make_Case_Statement_Alternative (Loc, 6755 Discrete_Choices => 6756 New_List (Make_Integer_Literal (Loc, Subp_Number)), 6757 Statements => Case_Stmts)); 6758 6759 Append_To (Dispatch_On_Name, 6760 Make_Elsif_Part (Loc, 6761 Condition => 6762 Make_Function_Call (Loc, 6763 Name => 6764 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc), 6765 Parameter_Associations => New_List ( 6766 New_Occurrence_Of (Subp_Id, Loc), 6767 New_Occurrence_Of (Subp_Dist_Name, Loc))), 6768 6769 Then_Statements => New_List ( 6770 Make_Assignment_Statement (Loc, 6771 New_Occurrence_Of (Subp_Index, Loc), 6772 Make_Integer_Literal (Loc, Subp_Number))))); 6773 6774 Append_To (Dispatch_On_Address, 6775 Make_Elsif_Part (Loc, 6776 Condition => 6777 Make_Op_Eq (Loc, 6778 Left_Opnd => New_Occurrence_Of (Local_Address, Loc), 6779 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)), 6780 6781 Then_Statements => New_List ( 6782 Make_Assignment_Statement (Loc, 6783 New_Occurrence_Of (Subp_Index, Loc), 6784 Make_Integer_Literal (Loc, Subp_Number))))); 6785 end Append_Stubs_To; 6786 6787 ---------------------- 6788 -- Visit_Subprogram -- 6789 ---------------------- 6790 6791 procedure Visit_Subprogram (Decl : Node_Id) is 6792 Loc : constant Source_Ptr := Sloc (Decl); 6793 Spec : constant Node_Id := Specification (Decl); 6794 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); 6795 6796 Subp_Val : String_Id; 6797 6798 Subp_Dist_Name : constant Entity_Id := 6799 Make_Defining_Identifier (Loc, 6800 Chars => 6801 New_External_Name 6802 (Related_Id => Chars (Subp_Def), 6803 Suffix => 'D', 6804 Suffix_Index => -1)); 6805 6806 Current_Stubs : Node_Id; 6807 Proxy_Obj_Addr : Entity_Id; 6808 6809 begin 6810 -- Disable expansion of stubs if serious errors have been 6811 -- diagnosed, because otherwise some illegal remote subprogram 6812 -- declarations could cause cascaded errors in stubs. 6813 6814 if Serious_Errors_Detected /= 0 then 6815 return; 6816 end if; 6817 6818 -- Build receiving stub 6819 6820 Current_Stubs := 6821 Build_Subprogram_Receiving_Stubs 6822 (Vis_Decl => Decl, 6823 Asynchronous => Nkind (Spec) = N_Procedure_Specification 6824 and then Is_Asynchronous (Subp_Def)); 6825 6826 Append_To (Decls, Current_Stubs); 6827 Analyze (Current_Stubs); 6828 6829 -- Build RAS proxy 6830 6831 Add_RAS_Proxy_And_Analyze (Decls, 6832 Vis_Decl => Decl, 6833 All_Calls_Remote_E => All_Calls_Remote_E, 6834 Proxy_Object_Addr => Proxy_Obj_Addr); 6835 6836 -- Compute distribution identifier 6837 6838 Assign_Subprogram_Identifier 6839 (Subp_Def, Current_Subp_Number, Subp_Val); 6840 6841 pragma Assert 6842 (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); 6843 6844 Append_To (Decls, 6845 Make_Object_Declaration (Loc, 6846 Defining_Identifier => Subp_Dist_Name, 6847 Constant_Present => True, 6848 Object_Definition => 6849 New_Occurrence_Of (Standard_String, Loc), 6850 Expression => 6851 Make_String_Literal (Loc, Subp_Val))); 6852 Analyze (Last (Decls)); 6853 6854 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms 6855 -- table for this receiver. The aggregate below must be kept 6856 -- consistent with the declaration of RCI_Subp_Info in 6857 -- System.Partition_Interface. 6858 6859 Append_To (Subp_Info_List, 6860 Make_Component_Association (Loc, 6861 Choices => 6862 New_List (Make_Integer_Literal (Loc, Current_Subp_Number)), 6863 6864 Expression => 6865 Make_Aggregate (Loc, 6866 Expressions => New_List ( 6867 6868 -- Name => 6869 6870 Make_Attribute_Reference (Loc, 6871 Prefix => 6872 New_Occurrence_Of (Subp_Dist_Name, Loc), 6873 Attribute_Name => Name_Address), 6874 6875 -- Name_Length => 6876 6877 Make_Attribute_Reference (Loc, 6878 Prefix => 6879 New_Occurrence_Of (Subp_Dist_Name, Loc), 6880 Attribute_Name => Name_Length), 6881 6882 -- Addr => 6883 6884 New_Occurrence_Of (Proxy_Obj_Addr, Loc))))); 6885 6886 Append_Stubs_To (Pkg_RPC_Receiver_Cases, 6887 Declaration => Decl, 6888 Stubs => Current_Stubs, 6889 Subp_Number => Current_Subp_Number, 6890 Subp_Dist_Name => Subp_Dist_Name, 6891 Subp_Proxy_Addr => Proxy_Obj_Addr); 6892 6893 Current_Subp_Number := Current_Subp_Number + 1; 6894 end Visit_Subprogram; 6895 6896 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); 6897 6898 -- Start of processing for Add_Receiving_Stubs_To_Declarations 6899 6900 begin 6901 -- Building receiving stubs consist in several operations: 6902 6903 -- - a package RPC receiver must be built. This subprogram will get 6904 -- a Subprogram_Id from the incoming stream and will dispatch the 6905 -- call to the right subprogram; 6906 6907 -- - a receiving stub for each subprogram visible in the package 6908 -- spec. This stub will read all the parameters from the stream, 6909 -- and put the result as well as the exception occurrence in the 6910 -- output stream; 6911 6912 Build_RPC_Receiver_Body ( 6913 RPC_Receiver => Pkg_RPC_Receiver, 6914 Request => Request, 6915 Subp_Id => Subp_Id, 6916 Subp_Index => Subp_Index, 6917 Stmts => Pkg_RPC_Receiver_Statements, 6918 Decl => Pkg_RPC_Receiver_Body); 6919 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body); 6920 6921 -- Extract local address information from the target reference: 6922 -- if non-null, that means that this is a reference that denotes 6923 -- one particular operation, and hence that the operation name 6924 -- must not be taken into account for dispatching. 6925 6926 Append_To (Pkg_RPC_Receiver_Decls, 6927 Make_Object_Declaration (Loc, 6928 Defining_Identifier => Is_Local, 6929 Object_Definition => 6930 New_Occurrence_Of (Standard_Boolean, Loc))); 6931 6932 Append_To (Pkg_RPC_Receiver_Decls, 6933 Make_Object_Declaration (Loc, 6934 Defining_Identifier => Local_Address, 6935 Object_Definition => 6936 New_Occurrence_Of (RTE (RE_Address), Loc))); 6937 6938 Append_To (Pkg_RPC_Receiver_Statements, 6939 Make_Procedure_Call_Statement (Loc, 6940 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), 6941 Parameter_Associations => New_List ( 6942 Make_Selected_Component (Loc, 6943 Prefix => Request, 6944 Selector_Name => Name_Target), 6945 New_Occurrence_Of (Is_Local, Loc), 6946 New_Occurrence_Of (Local_Address, Loc)))); 6947 6948 -- For each subprogram, the receiving stub will be built and a case 6949 -- statement will be made on the Subprogram_Id to dispatch to the 6950 -- right subprogram. 6951 6952 All_Calls_Remote_E := Boolean_Literals ( 6953 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); 6954 6955 Overload_Counter_Table.Reset; 6956 Reserve_NamingContext_Methods; 6957 6958 Visit_Spec (Pkg_Spec); 6959 6960 Append_To (Decls, 6961 Make_Object_Declaration (Loc, 6962 Defining_Identifier => Subp_Info_Array, 6963 Constant_Present => True, 6964 Aliased_Present => True, 6965 Object_Definition => 6966 Make_Subtype_Indication (Loc, 6967 Subtype_Mark => 6968 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), 6969 Constraint => 6970 Make_Index_Or_Discriminant_Constraint (Loc, 6971 New_List ( 6972 Make_Range (Loc, 6973 Low_Bound => 6974 Make_Integer_Literal (Loc, 6975 Intval => First_RCI_Subprogram_Id), 6976 High_Bound => 6977 Make_Integer_Literal (Loc, 6978 Intval => 6979 First_RCI_Subprogram_Id 6980 + List_Length (Subp_Info_List) - 1))))))); 6981 6982 if Present (First (Subp_Info_List)) then 6983 Set_Expression (Last (Decls), 6984 Make_Aggregate (Loc, 6985 Component_Associations => Subp_Info_List)); 6986 6987 -- Generate the dispatch statement to determine the subprogram id 6988 -- of the called subprogram. 6989 6990 -- We first test whether the reference that was used to make the 6991 -- call was the base RCI reference (in which case Local_Address is 6992 -- zero, and the method identifier from the request must be used 6993 -- to determine which subprogram is called) or a reference 6994 -- identifying one particular subprogram (in which case 6995 -- Local_Address is the address of that subprogram, and the 6996 -- method name from the request is ignored). The latter occurs 6997 -- for the case of a call through a remote access-to-subprogram. 6998 6999 -- In each case, cascaded elsifs are used to determine the proper 7000 -- subprogram index. Using hash tables might be more efficient. 7001 7002 Append_To (Pkg_RPC_Receiver_Statements, 7003 Make_Implicit_If_Statement (Pkg_Spec, 7004 Condition => 7005 Make_Op_Ne (Loc, 7006 Left_Opnd => New_Occurrence_Of (Local_Address, Loc), 7007 Right_Opnd => New_Occurrence_Of 7008 (RTE (RE_Null_Address), Loc)), 7009 7010 Then_Statements => New_List ( 7011 Make_Implicit_If_Statement (Pkg_Spec, 7012 Condition => New_Occurrence_Of (Standard_False, Loc), 7013 Then_Statements => New_List ( 7014 Make_Null_Statement (Loc)), 7015 Elsif_Parts => Dispatch_On_Address)), 7016 7017 Else_Statements => New_List ( 7018 Make_Implicit_If_Statement (Pkg_Spec, 7019 Condition => New_Occurrence_Of (Standard_False, Loc), 7020 Then_Statements => New_List (Make_Null_Statement (Loc)), 7021 Elsif_Parts => Dispatch_On_Name)))); 7022 7023 else 7024 -- For a degenerate RCI with no visible subprograms, 7025 -- Subp_Info_List has zero length, and the declaration is for an 7026 -- empty array, in which case no initialization aggregate must be 7027 -- generated. We do not generate a Dispatch_Statement either. 7028 7029 -- No initialization provided: remove CONSTANT so that the 7030 -- declaration is not an incomplete deferred constant. 7031 7032 Set_Constant_Present (Last (Decls), False); 7033 end if; 7034 7035 -- Analyze Subp_Info_Array declaration 7036 7037 Analyze (Last (Decls)); 7038 7039 -- If we receive an invalid Subprogram_Id, it is best to do nothing 7040 -- rather than raising an exception since we do not want someone 7041 -- to crash a remote partition by sending invalid subprogram ids. 7042 -- This is consistent with the other parts of the case statement 7043 -- since even in presence of incorrect parameters in the stream, 7044 -- every exception will be caught and (if the subprogram is not an 7045 -- APC) put into the result stream and sent away. 7046 7047 Append_To (Pkg_RPC_Receiver_Cases, 7048 Make_Case_Statement_Alternative (Loc, 7049 Discrete_Choices => New_List (Make_Others_Choice (Loc)), 7050 Statements => New_List (Make_Null_Statement (Loc)))); 7051 7052 Append_To (Pkg_RPC_Receiver_Statements, 7053 Make_Case_Statement (Loc, 7054 Expression => New_Occurrence_Of (Subp_Index, Loc), 7055 Alternatives => Pkg_RPC_Receiver_Cases)); 7056 7057 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and 7058 -- analyze it. 7059 7060 Append_To (Decls, Pkg_RPC_Receiver_Body); 7061 Analyze (Last (Decls)); 7062 7063 Pkg_RPC_Receiver_Object := 7064 Make_Object_Declaration (Loc, 7065 Defining_Identifier => Make_Temporary (Loc, 'R'), 7066 Aliased_Present => True, 7067 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); 7068 Append_To (Decls, Pkg_RPC_Receiver_Object); 7069 Analyze (Last (Decls)); 7070 7071 Get_Library_Unit_Name_String (Pkg_Spec); 7072 7073 -- Name 7074 7075 Append_To (Register_Pkg_Actuals, 7076 Make_String_Literal (Loc, 7077 Strval => String_From_Name_Buffer)); 7078 7079 -- Version 7080 7081 Append_To (Register_Pkg_Actuals, 7082 Make_Attribute_Reference (Loc, 7083 Prefix => 7084 New_Occurrence_Of 7085 (Defining_Entity (Pkg_Spec), Loc), 7086 Attribute_Name => Name_Version)); 7087 7088 -- Handler 7089 7090 Append_To (Register_Pkg_Actuals, 7091 Make_Attribute_Reference (Loc, 7092 Prefix => 7093 New_Occurrence_Of (Pkg_RPC_Receiver, Loc), 7094 Attribute_Name => Name_Access)); 7095 7096 -- Receiver 7097 7098 Append_To (Register_Pkg_Actuals, 7099 Make_Attribute_Reference (Loc, 7100 Prefix => 7101 New_Occurrence_Of ( 7102 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc), 7103 Attribute_Name => Name_Access)); 7104 7105 -- Subp_Info 7106 7107 Append_To (Register_Pkg_Actuals, 7108 Make_Attribute_Reference (Loc, 7109 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), 7110 Attribute_Name => Name_Address)); 7111 7112 -- Subp_Info_Len 7113 7114 Append_To (Register_Pkg_Actuals, 7115 Make_Attribute_Reference (Loc, 7116 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), 7117 Attribute_Name => Name_Length)); 7118 7119 -- Is_All_Calls_Remote 7120 7121 Append_To (Register_Pkg_Actuals, 7122 New_Occurrence_Of (All_Calls_Remote_E, Loc)); 7123 7124 -- Finally call Register_Pkg_Receiving_Stub with the above parameters 7125 7126 Append_To (Stmts, 7127 Make_Procedure_Call_Statement (Loc, 7128 Name => 7129 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc), 7130 Parameter_Associations => Register_Pkg_Actuals)); 7131 Analyze (Last (Stmts)); 7132 end Add_Receiving_Stubs_To_Declarations; 7133 7134 --------------------------------- 7135 -- Build_General_Calling_Stubs -- 7136 --------------------------------- 7137 7138 procedure Build_General_Calling_Stubs 7139 (Decls : List_Id; 7140 Statements : List_Id; 7141 Target_Object : Node_Id; 7142 Subprogram_Id : Node_Id; 7143 Asynchronous : Node_Id := Empty; 7144 Is_Known_Asynchronous : Boolean := False; 7145 Is_Known_Non_Asynchronous : Boolean := False; 7146 Is_Function : Boolean; 7147 Spec : Node_Id; 7148 Stub_Type : Entity_Id := Empty; 7149 RACW_Type : Entity_Id := Empty; 7150 Nod : Node_Id) 7151 is 7152 Loc : constant Source_Ptr := Sloc (Nod); 7153 7154 Request : constant Entity_Id := Make_Temporary (Loc, 'R'); 7155 -- The request object constructed by these stubs 7156 -- Could we use Name_R instead??? (see GLADE client stubs) 7157 7158 function Make_Request_RTE_Call 7159 (RE : RE_Id; 7160 Actuals : List_Id := New_List) return Node_Id; 7161 -- Generate a procedure call statement calling RE with the given 7162 -- actuals. Request'Access is appended to the list. 7163 7164 --------------------------- 7165 -- Make_Request_RTE_Call -- 7166 --------------------------- 7167 7168 function Make_Request_RTE_Call 7169 (RE : RE_Id; 7170 Actuals : List_Id := New_List) return Node_Id 7171 is 7172 begin 7173 Append_To (Actuals, 7174 Make_Attribute_Reference (Loc, 7175 Prefix => New_Occurrence_Of (Request, Loc), 7176 Attribute_Name => Name_Access)); 7177 return Make_Procedure_Call_Statement (Loc, 7178 Name => 7179 New_Occurrence_Of (RTE (RE), Loc), 7180 Parameter_Associations => Actuals); 7181 end Make_Request_RTE_Call; 7182 7183 Arguments : Node_Id; 7184 -- Name of the named values list used to transmit parameters 7185 -- to the remote package 7186 7187 Result : Node_Id; 7188 -- Name of the result named value (in non-APC cases) which get the 7189 -- result of the remote subprogram. 7190 7191 Result_TC : Node_Id; 7192 -- Typecode expression for the result of the request (void 7193 -- typecode for procedures). 7194 7195 Exception_Return_Parameter : Node_Id; 7196 -- Name of the parameter which will hold the exception sent by the 7197 -- remote subprogram. 7198 7199 Current_Parameter : Node_Id; 7200 -- Current parameter being handled 7201 7202 Ordered_Parameters_List : constant List_Id := 7203 Build_Ordered_Parameters_List (Spec); 7204 7205 Asynchronous_P : Node_Id; 7206 -- A Boolean expression indicating whether this call is asynchronous 7207 7208 Asynchronous_Statements : List_Id := No_List; 7209 Non_Asynchronous_Statements : List_Id := No_List; 7210 -- Statements specifics to the Asynchronous/Non-Asynchronous cases 7211 7212 Extra_Formal_Statements : constant List_Id := New_List; 7213 -- List of statements for extra formal parameters. It will appear 7214 -- after the regular statements for writing out parameters. 7215 7216 After_Statements : constant List_Id := New_List; 7217 -- Statements to be executed after call returns (to assign IN OUT or 7218 -- OUT parameter values). 7219 7220 Etyp : Entity_Id; 7221 -- The type of the formal parameter being processed 7222 7223 Is_Controlling_Formal : Boolean; 7224 Is_First_Controlling_Formal : Boolean; 7225 First_Controlling_Formal_Seen : Boolean := False; 7226 -- Controlling formal parameters of distributed object primitives 7227 -- require special handling, and the first such parameter needs even 7228 -- more special handling. 7229 7230 begin 7231 -- ??? document general form of stub subprograms for the PolyORB case 7232 7233 Append_To (Decls, 7234 Make_Object_Declaration (Loc, 7235 Defining_Identifier => Request, 7236 Aliased_Present => True, 7237 Object_Definition => 7238 New_Occurrence_Of (RTE (RE_Request), Loc))); 7239 7240 Result := Make_Temporary (Loc, 'R'); 7241 7242 if Is_Function then 7243 Result_TC := 7244 PolyORB_Support.Helpers.Build_TypeCode_Call 7245 (Loc, Etype (Result_Definition (Spec)), Decls); 7246 else 7247 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc); 7248 end if; 7249 7250 Append_To (Decls, 7251 Make_Object_Declaration (Loc, 7252 Defining_Identifier => Result, 7253 Aliased_Present => False, 7254 Object_Definition => 7255 New_Occurrence_Of (RTE (RE_NamedValue), Loc), 7256 Expression => 7257 Make_Aggregate (Loc, 7258 Component_Associations => New_List ( 7259 Make_Component_Association (Loc, 7260 Choices => New_List (Make_Identifier (Loc, Name_Name)), 7261 Expression => 7262 New_Occurrence_Of (RTE (RE_Result_Name), Loc)), 7263 Make_Component_Association (Loc, 7264 Choices => New_List ( 7265 Make_Identifier (Loc, Name_Argument)), 7266 Expression => 7267 Make_Function_Call (Loc, 7268 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), 7269 Parameter_Associations => New_List (Result_TC))), 7270 Make_Component_Association (Loc, 7271 Choices => New_List ( 7272 Make_Identifier (Loc, Name_Arg_Modes)), 7273 Expression => Make_Integer_Literal (Loc, 0)))))); 7274 7275 if not Is_Known_Asynchronous then 7276 Exception_Return_Parameter := Make_Temporary (Loc, 'E'); 7277 7278 Append_To (Decls, 7279 Make_Object_Declaration (Loc, 7280 Defining_Identifier => Exception_Return_Parameter, 7281 Object_Definition => 7282 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); 7283 7284 else 7285 Exception_Return_Parameter := Empty; 7286 end if; 7287 7288 -- Initialize and fill in arguments list 7289 7290 Arguments := Make_Temporary (Loc, 'A'); 7291 Declare_Create_NVList (Loc, Arguments, Decls, Statements); 7292 7293 Current_Parameter := First (Ordered_Parameters_List); 7294 while Present (Current_Parameter) loop 7295 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then 7296 Is_Controlling_Formal := True; 7297 Is_First_Controlling_Formal := 7298 not First_Controlling_Formal_Seen; 7299 First_Controlling_Formal_Seen := True; 7300 7301 else 7302 Is_Controlling_Formal := False; 7303 Is_First_Controlling_Formal := False; 7304 end if; 7305 7306 if Is_Controlling_Formal then 7307 7308 -- For a controlling formal argument, we send its reference 7309 7310 Etyp := RACW_Type; 7311 7312 else 7313 Etyp := Etype (Parameter_Type (Current_Parameter)); 7314 end if; 7315 7316 -- The first controlling formal parameter is treated specially: 7317 -- it is used to set the target object of the call. 7318 7319 if not Is_First_Controlling_Formal then 7320 declare 7321 Constrained : constant Boolean := 7322 Is_Constrained (Etyp) 7323 or else Is_Elementary_Type (Etyp); 7324 7325 Any : constant Entity_Id := Make_Temporary (Loc, 'A'); 7326 7327 Actual_Parameter : Node_Id := 7328 New_Occurrence_Of ( 7329 Defining_Identifier ( 7330 Current_Parameter), Loc); 7331 7332 Expr : Node_Id; 7333 7334 begin 7335 if Is_Controlling_Formal then 7336 7337 -- For a controlling formal parameter (other than the 7338 -- first one), use the corresponding RACW. If the 7339 -- parameter is not an anonymous access parameter, that 7340 -- involves taking its 'Unrestricted_Access. 7341 7342 if Nkind (Parameter_Type (Current_Parameter)) 7343 = N_Access_Definition 7344 then 7345 Actual_Parameter := OK_Convert_To 7346 (Etyp, Actual_Parameter); 7347 else 7348 Actual_Parameter := OK_Convert_To (Etyp, 7349 Make_Attribute_Reference (Loc, 7350 Prefix => Actual_Parameter, 7351 Attribute_Name => Name_Unrestricted_Access)); 7352 end if; 7353 7354 end if; 7355 7356 if In_Present (Current_Parameter) 7357 or else not Out_Present (Current_Parameter) 7358 or else not Constrained 7359 or else Is_Controlling_Formal 7360 then 7361 -- The parameter has an input value, is constrained at 7362 -- runtime by an input value, or is a controlling formal 7363 -- parameter (always passed as a reference) other than 7364 -- the first one. 7365 7366 Expr := PolyORB_Support.Helpers.Build_To_Any_Call 7367 (Loc, Actual_Parameter, Decls); 7368 7369 else 7370 Expr := Make_Function_Call (Loc, 7371 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), 7372 Parameter_Associations => New_List ( 7373 PolyORB_Support.Helpers.Build_TypeCode_Call 7374 (Loc, Etyp, Decls))); 7375 end if; 7376 7377 Append_To (Decls, 7378 Make_Object_Declaration (Loc, 7379 Defining_Identifier => Any, 7380 Aliased_Present => False, 7381 Object_Definition => 7382 New_Occurrence_Of (RTE (RE_Any), Loc), 7383 Expression => Expr)); 7384 7385 Append_To (Statements, 7386 Add_Parameter_To_NVList (Loc, 7387 Parameter => Current_Parameter, 7388 NVList => Arguments, 7389 Constrained => Constrained, 7390 Any => Any)); 7391 7392 if Out_Present (Current_Parameter) 7393 and then not Is_Controlling_Formal 7394 then 7395 if Is_Limited_Type (Etyp) then 7396 Helpers.Assign_Opaque_From_Any (Loc, 7397 Stms => After_Statements, 7398 Typ => Etyp, 7399 N => New_Occurrence_Of (Any, Loc), 7400 Target => 7401 Defining_Identifier (Current_Parameter)); 7402 else 7403 Append_To (After_Statements, 7404 Make_Assignment_Statement (Loc, 7405 Name => 7406 New_Occurrence_Of ( 7407 Defining_Identifier (Current_Parameter), Loc), 7408 Expression => 7409 PolyORB_Support.Helpers.Build_From_Any_Call 7410 (Etyp, 7411 New_Occurrence_Of (Any, Loc), 7412 Decls))); 7413 end if; 7414 end if; 7415 end; 7416 end if; 7417 7418 -- If the current parameter has a dynamic constrained status, then 7419 -- this status is transmitted as well. 7420 7421 -- This should be done for accessibility as well ??? 7422 7423 if Nkind (Parameter_Type (Current_Parameter)) /= 7424 N_Access_Definition 7425 and then Need_Extra_Constrained (Current_Parameter) 7426 then 7427 -- In this block, we do not use the extra formal that has been 7428 -- created because it does not exist at the time of expansion 7429 -- when building calling stubs for remote access to subprogram 7430 -- types. We create an extra variable of this type and push it 7431 -- in the stream after the regular parameters. 7432 7433 declare 7434 Extra_Any_Parameter : constant Entity_Id := 7435 Make_Temporary (Loc, 'P'); 7436 7437 Parameter_Exp : constant Node_Id := 7438 Make_Attribute_Reference (Loc, 7439 Prefix => New_Occurrence_Of ( 7440 Defining_Identifier (Current_Parameter), Loc), 7441 Attribute_Name => Name_Constrained); 7442 7443 begin 7444 Set_Etype (Parameter_Exp, Etype (Standard_Boolean)); 7445 7446 Append_To (Decls, 7447 Make_Object_Declaration (Loc, 7448 Defining_Identifier => Extra_Any_Parameter, 7449 Aliased_Present => False, 7450 Object_Definition => 7451 New_Occurrence_Of (RTE (RE_Any), Loc), 7452 Expression => 7453 PolyORB_Support.Helpers.Build_To_Any_Call 7454 (Loc, Parameter_Exp, Decls))); 7455 7456 Append_To (Extra_Formal_Statements, 7457 Add_Parameter_To_NVList (Loc, 7458 Parameter => Extra_Any_Parameter, 7459 NVList => Arguments, 7460 Constrained => True, 7461 Any => Extra_Any_Parameter)); 7462 end; 7463 end if; 7464 7465 Next (Current_Parameter); 7466 end loop; 7467 7468 -- Append the formal statements list to the statements 7469 7470 Append_List_To (Statements, Extra_Formal_Statements); 7471 7472 Append_To (Statements, 7473 Make_Procedure_Call_Statement (Loc, 7474 Name => 7475 New_Occurrence_Of (RTE (RE_Request_Setup), Loc), 7476 Parameter_Associations => New_List ( 7477 New_Occurrence_Of (Request, Loc), 7478 Target_Object, 7479 Subprogram_Id, 7480 New_Occurrence_Of (Arguments, Loc), 7481 New_Occurrence_Of (Result, Loc), 7482 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc)))); 7483 7484 pragma Assert 7485 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); 7486 7487 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then 7488 Asynchronous_P := 7489 New_Occurrence_Of 7490 (Boolean_Literals (Is_Known_Asynchronous), Loc); 7491 7492 else 7493 pragma Assert (Present (Asynchronous)); 7494 Asynchronous_P := New_Copy_Tree (Asynchronous); 7495 7496 -- The expression node Asynchronous will be used to build an 'if' 7497 -- statement at the end of Build_General_Calling_Stubs: we need to 7498 -- make a copy here. 7499 end if; 7500 7501 Append_To (Parameter_Associations (Last (Statements)), 7502 Make_Indexed_Component (Loc, 7503 Prefix => 7504 New_Occurrence_Of ( 7505 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc), 7506 Expressions => New_List (Asynchronous_P))); 7507 7508 Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke)); 7509 7510 -- Asynchronous case 7511 7512 if not Is_Known_Non_Asynchronous then 7513 Asynchronous_Statements := New_List (Make_Null_Statement (Loc)); 7514 end if; 7515 7516 -- Non-asynchronous case 7517 7518 if not Is_Known_Asynchronous then 7519 -- Reraise an exception occurrence from the completed request. 7520 -- If the exception occurrence is empty, this is a no-op. 7521 7522 Non_Asynchronous_Statements := New_List ( 7523 Make_Procedure_Call_Statement (Loc, 7524 Name => 7525 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc), 7526 Parameter_Associations => New_List ( 7527 New_Occurrence_Of (Request, Loc)))); 7528 7529 if Is_Function then 7530 -- If this is a function call, read the value and return it 7531 7532 Append_To (Non_Asynchronous_Statements, 7533 Make_Tag_Check (Loc, 7534 Make_Simple_Return_Statement (Loc, 7535 PolyORB_Support.Helpers.Build_From_Any_Call 7536 (Etype (Result_Definition (Spec)), 7537 Make_Selected_Component (Loc, 7538 Prefix => Result, 7539 Selector_Name => Name_Argument), 7540 Decls)))); 7541 7542 else 7543 7544 -- Case of a procedure: deal with IN OUT and OUT formals 7545 7546 Append_List_To (Non_Asynchronous_Statements, After_Statements); 7547 end if; 7548 end if; 7549 7550 if Is_Known_Asynchronous then 7551 Append_List_To (Statements, Asynchronous_Statements); 7552 7553 elsif Is_Known_Non_Asynchronous then 7554 Append_List_To (Statements, Non_Asynchronous_Statements); 7555 7556 else 7557 pragma Assert (Present (Asynchronous)); 7558 Append_To (Statements, 7559 Make_Implicit_If_Statement (Nod, 7560 Condition => Asynchronous, 7561 Then_Statements => Asynchronous_Statements, 7562 Else_Statements => Non_Asynchronous_Statements)); 7563 end if; 7564 end Build_General_Calling_Stubs; 7565 7566 ----------------------- 7567 -- Build_Stub_Target -- 7568 ----------------------- 7569 7570 function Build_Stub_Target 7571 (Loc : Source_Ptr; 7572 Decls : List_Id; 7573 RCI_Locator : Entity_Id; 7574 Controlling_Parameter : Entity_Id) return RPC_Target 7575 is 7576 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA); 7577 Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T'); 7578 7579 begin 7580 if Present (Controlling_Parameter) then 7581 Append_To (Decls, 7582 Make_Object_Declaration (Loc, 7583 Defining_Identifier => Target_Reference, 7584 7585 Object_Definition => 7586 New_Occurrence_Of (RTE (RE_Object_Ref), Loc), 7587 7588 Expression => 7589 Make_Function_Call (Loc, 7590 Name => 7591 New_Occurrence_Of (RTE (RE_Make_Ref), Loc), 7592 Parameter_Associations => New_List ( 7593 Make_Selected_Component (Loc, 7594 Prefix => Controlling_Parameter, 7595 Selector_Name => Name_Target))))); 7596 7597 -- Note: Controlling_Parameter has the same components as 7598 -- System.Partition_Interface.RACW_Stub_Type. 7599 7600 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc); 7601 7602 else 7603 Target_Info.Object := 7604 Make_Selected_Component (Loc, 7605 Prefix => 7606 Make_Identifier (Loc, Chars (RCI_Locator)), 7607 Selector_Name => 7608 Make_Identifier (Loc, Name_Get_RCI_Package_Ref)); 7609 end if; 7610 7611 return Target_Info; 7612 end Build_Stub_Target; 7613 7614 ----------------------------- 7615 -- Build_RPC_Receiver_Body -- 7616 ----------------------------- 7617 7618 procedure Build_RPC_Receiver_Body 7619 (RPC_Receiver : Entity_Id; 7620 Request : out Entity_Id; 7621 Subp_Id : out Entity_Id; 7622 Subp_Index : out Entity_Id; 7623 Stmts : out List_Id; 7624 Decl : out Node_Id) 7625 is 7626 Loc : constant Source_Ptr := Sloc (RPC_Receiver); 7627 7628 RPC_Receiver_Spec : Node_Id; 7629 RPC_Receiver_Decls : List_Id; 7630 7631 begin 7632 Request := Make_Defining_Identifier (Loc, Name_R); 7633 7634 RPC_Receiver_Spec := 7635 Build_RPC_Receiver_Specification 7636 (RPC_Receiver => RPC_Receiver, 7637 Request_Parameter => Request); 7638 7639 Subp_Id := Make_Defining_Identifier (Loc, Name_P); 7640 Subp_Index := Make_Defining_Identifier (Loc, Name_I); 7641 7642 RPC_Receiver_Decls := New_List ( 7643 Make_Object_Renaming_Declaration (Loc, 7644 Defining_Identifier => Subp_Id, 7645 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), 7646 Name => 7647 Make_Explicit_Dereference (Loc, 7648 Prefix => 7649 Make_Selected_Component (Loc, 7650 Prefix => Request, 7651 Selector_Name => Name_Operation))), 7652 7653 Make_Object_Declaration (Loc, 7654 Defining_Identifier => Subp_Index, 7655 Object_Definition => 7656 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), 7657 Expression => 7658 Make_Attribute_Reference (Loc, 7659 Prefix => 7660 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), 7661 Attribute_Name => Name_Last))); 7662 7663 Stmts := New_List; 7664 7665 Decl := 7666 Make_Subprogram_Body (Loc, 7667 Specification => RPC_Receiver_Spec, 7668 Declarations => RPC_Receiver_Decls, 7669 Handled_Statement_Sequence => 7670 Make_Handled_Sequence_Of_Statements (Loc, 7671 Statements => Stmts)); 7672 end Build_RPC_Receiver_Body; 7673 7674 -------------------------------------- 7675 -- Build_Subprogram_Receiving_Stubs -- 7676 -------------------------------------- 7677 7678 function Build_Subprogram_Receiving_Stubs 7679 (Vis_Decl : Node_Id; 7680 Asynchronous : Boolean; 7681 Dynamically_Asynchronous : Boolean := False; 7682 Stub_Type : Entity_Id := Empty; 7683 RACW_Type : Entity_Id := Empty; 7684 Parent_Primitive : Entity_Id := Empty) return Node_Id 7685 is 7686 Loc : constant Source_Ptr := Sloc (Vis_Decl); 7687 7688 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); 7689 -- Formal parameter for receiving stubs: a descriptor for an incoming 7690 -- request. 7691 7692 Outer_Decls : constant List_Id := New_List; 7693 -- At the outermost level, an NVList and Any's are declared for all 7694 -- parameters. The Dynamic_Async flag also needs to be declared there 7695 -- to be visible from the exception handling code. 7696 7697 Outer_Statements : constant List_Id := New_List; 7698 -- Statements that occur prior to the declaration of the actual 7699 -- parameter variables. 7700 7701 Outer_Extra_Formal_Statements : constant List_Id := New_List; 7702 -- Statements concerning extra formal parameters, prior to the 7703 -- declaration of the actual parameter variables. 7704 7705 Decls : constant List_Id := New_List; 7706 -- All the parameters will get declared before calling the real 7707 -- subprograms. Also the out parameters will be declared. At this 7708 -- level, parameters may be unconstrained. 7709 7710 Statements : constant List_Id := New_List; 7711 7712 After_Statements : constant List_Id := New_List; 7713 -- Statements to be executed after the subprogram call 7714 7715 Inner_Decls : List_Id := No_List; 7716 -- In case of a function, the inner declarations are needed since 7717 -- the result may be unconstrained. 7718 7719 Excep_Handlers : List_Id := No_List; 7720 7721 Parameter_List : constant List_Id := New_List; 7722 -- List of parameters to be passed to the subprogram 7723 7724 First_Controlling_Formal_Seen : Boolean := False; 7725 7726 Current_Parameter : Node_Id; 7727 7728 Ordered_Parameters_List : constant List_Id := 7729 Build_Ordered_Parameters_List 7730 (Specification (Vis_Decl)); 7731 7732 Arguments : constant Entity_Id := Make_Temporary (Loc, 'A'); 7733 -- Name of the named values list used to retrieve parameters 7734 7735 Subp_Spec : Node_Id; 7736 -- Subprogram specification 7737 7738 Called_Subprogram : Node_Id; 7739 -- The subprogram to call 7740 7741 begin 7742 if Present (RACW_Type) then 7743 Called_Subprogram := 7744 New_Occurrence_Of (Parent_Primitive, Loc); 7745 else 7746 Called_Subprogram := 7747 New_Occurrence_Of 7748 (Defining_Unit_Name (Specification (Vis_Decl)), Loc); 7749 end if; 7750 7751 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements); 7752 7753 -- Loop through every parameter and get its value from the stream. If 7754 -- the parameter is unconstrained, then the parameter is read using 7755 -- 'Input at the point of declaration. 7756 7757 Current_Parameter := First (Ordered_Parameters_List); 7758 while Present (Current_Parameter) loop 7759 declare 7760 Etyp : Entity_Id; 7761 Constrained : Boolean; 7762 Any : Entity_Id := Empty; 7763 Object : constant Entity_Id := Make_Temporary (Loc, 'P'); 7764 Expr : Node_Id := Empty; 7765 7766 Is_Controlling_Formal : constant Boolean := 7767 Is_RACW_Controlling_Formal 7768 (Current_Parameter, Stub_Type); 7769 7770 Is_First_Controlling_Formal : Boolean := False; 7771 7772 Need_Extra_Constrained : Boolean; 7773 -- True when an extra constrained actual is required 7774 7775 begin 7776 if Is_Controlling_Formal then 7777 7778 -- Controlling formals in distributed object primitive 7779 -- operations are handled specially: 7780 7781 -- - the first controlling formal is used as the 7782 -- target of the call; 7783 7784 -- - the remaining controlling formals are transmitted 7785 -- as RACWs. 7786 7787 Etyp := RACW_Type; 7788 Is_First_Controlling_Formal := 7789 not First_Controlling_Formal_Seen; 7790 First_Controlling_Formal_Seen := True; 7791 7792 else 7793 Etyp := Etype (Parameter_Type (Current_Parameter)); 7794 end if; 7795 7796 Constrained := 7797 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); 7798 7799 if not Is_First_Controlling_Formal then 7800 Any := Make_Temporary (Loc, 'A'); 7801 7802 Append_To (Outer_Decls, 7803 Make_Object_Declaration (Loc, 7804 Defining_Identifier => Any, 7805 Object_Definition => 7806 New_Occurrence_Of (RTE (RE_Any), Loc), 7807 Expression => 7808 Make_Function_Call (Loc, 7809 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), 7810 Parameter_Associations => New_List ( 7811 PolyORB_Support.Helpers.Build_TypeCode_Call 7812 (Loc, Etyp, Outer_Decls))))); 7813 7814 Append_To (Outer_Statements, 7815 Add_Parameter_To_NVList (Loc, 7816 Parameter => Current_Parameter, 7817 NVList => Arguments, 7818 Constrained => Constrained, 7819 Any => Any)); 7820 end if; 7821 7822 if Is_First_Controlling_Formal then 7823 declare 7824 Addr : constant Entity_Id := Make_Temporary (Loc, 'A'); 7825 7826 Is_Local : constant Entity_Id := 7827 Make_Temporary (Loc, 'L'); 7828 7829 begin 7830 -- Special case: obtain the first controlling formal 7831 -- from the target of the remote call, instead of the 7832 -- argument list. 7833 7834 Append_To (Outer_Decls, 7835 Make_Object_Declaration (Loc, 7836 Defining_Identifier => Addr, 7837 Object_Definition => 7838 New_Occurrence_Of (RTE (RE_Address), Loc))); 7839 7840 Append_To (Outer_Decls, 7841 Make_Object_Declaration (Loc, 7842 Defining_Identifier => Is_Local, 7843 Object_Definition => 7844 New_Occurrence_Of (Standard_Boolean, Loc))); 7845 7846 Append_To (Outer_Statements, 7847 Make_Procedure_Call_Statement (Loc, 7848 Name => 7849 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), 7850 Parameter_Associations => New_List ( 7851 Make_Selected_Component (Loc, 7852 Prefix => 7853 New_Occurrence_Of ( 7854 Request_Parameter, Loc), 7855 Selector_Name => 7856 Make_Identifier (Loc, Name_Target)), 7857 New_Occurrence_Of (Is_Local, Loc), 7858 New_Occurrence_Of (Addr, Loc)))); 7859 7860 Expr := Unchecked_Convert_To (RACW_Type, 7861 New_Occurrence_Of (Addr, Loc)); 7862 end; 7863 7864 elsif In_Present (Current_Parameter) 7865 or else not Out_Present (Current_Parameter) 7866 or else not Constrained 7867 then 7868 -- If an input parameter is constrained, then its reading is 7869 -- deferred until the beginning of the subprogram body. If 7870 -- it is unconstrained, then an expression is built for 7871 -- the object declaration and the variable is set using 7872 -- 'Input instead of 'Read. 7873 7874 if Constrained and then Is_Limited_Type (Etyp) then 7875 Helpers.Assign_Opaque_From_Any (Loc, 7876 Stms => Statements, 7877 Typ => Etyp, 7878 N => New_Occurrence_Of (Any, Loc), 7879 Target => Object); 7880 7881 else 7882 Expr := Helpers.Build_From_Any_Call 7883 (Etyp, New_Occurrence_Of (Any, Loc), Decls); 7884 7885 if Constrained then 7886 Append_To (Statements, 7887 Make_Assignment_Statement (Loc, 7888 Name => New_Occurrence_Of (Object, Loc), 7889 Expression => Expr)); 7890 Expr := Empty; 7891 7892 else 7893 -- Expr will be used to initialize (and constrain) the 7894 -- parameter when it is declared. 7895 null; 7896 end if; 7897 7898 null; 7899 end if; 7900 end if; 7901 7902 Need_Extra_Constrained := 7903 Nkind (Parameter_Type (Current_Parameter)) /= 7904 N_Access_Definition 7905 and then 7906 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void 7907 and then 7908 Present (Extra_Constrained 7909 (Defining_Identifier (Current_Parameter))); 7910 7911 -- We may not associate an extra constrained actual to a 7912 -- constant object, so if one is needed, declare the actual 7913 -- as a variable even if it won't be modified. 7914 7915 Build_Actual_Object_Declaration 7916 (Object => Object, 7917 Etyp => Etyp, 7918 Variable => Need_Extra_Constrained 7919 or else Out_Present (Current_Parameter), 7920 Expr => Expr, 7921 Decls => Decls); 7922 Set_Etype (Object, Etyp); 7923 7924 -- An out parameter may be written back using a 'Write 7925 -- attribute instead of a 'Output because it has been 7926 -- constrained by the parameter given to the caller. Note that 7927 -- out controlling arguments in the case of a RACW are not put 7928 -- back in the stream because the pointer on them has not 7929 -- changed. 7930 7931 if Out_Present (Current_Parameter) 7932 and then not Is_Controlling_Formal 7933 then 7934 Append_To (After_Statements, 7935 Make_Procedure_Call_Statement (Loc, 7936 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc), 7937 Parameter_Associations => New_List ( 7938 New_Occurrence_Of (Any, Loc), 7939 PolyORB_Support.Helpers.Build_To_Any_Call 7940 (Loc, New_Occurrence_Of (Object, Loc), Decls)))); 7941 end if; 7942 7943 -- For RACW controlling formals, the Etyp of Object is always 7944 -- an RACW, even if the parameter is not of an anonymous access 7945 -- type. In such case, we need to dereference it at call time. 7946 7947 if Is_Controlling_Formal then 7948 if Nkind (Parameter_Type (Current_Parameter)) /= 7949 N_Access_Definition 7950 then 7951 Append_To (Parameter_List, 7952 Make_Parameter_Association (Loc, 7953 Selector_Name => 7954 New_Occurrence_Of 7955 (Defining_Identifier (Current_Parameter), Loc), 7956 Explicit_Actual_Parameter => 7957 Make_Explicit_Dereference (Loc, 7958 Prefix => New_Occurrence_Of (Object, Loc)))); 7959 7960 else 7961 Append_To (Parameter_List, 7962 Make_Parameter_Association (Loc, 7963 Selector_Name => 7964 New_Occurrence_Of 7965 (Defining_Identifier (Current_Parameter), Loc), 7966 7967 Explicit_Actual_Parameter => 7968 New_Occurrence_Of (Object, Loc))); 7969 end if; 7970 7971 else 7972 Append_To (Parameter_List, 7973 Make_Parameter_Association (Loc, 7974 Selector_Name => 7975 New_Occurrence_Of ( 7976 Defining_Identifier (Current_Parameter), Loc), 7977 Explicit_Actual_Parameter => 7978 New_Occurrence_Of (Object, Loc))); 7979 end if; 7980 7981 -- If the current parameter needs an extra formal, then read it 7982 -- from the stream and set the corresponding semantic field in 7983 -- the variable. If the kind of the parameter identifier is 7984 -- E_Void, then this is a compiler generated parameter that 7985 -- doesn't need an extra constrained status. 7986 7987 -- The case of Extra_Accessibility should also be handled ??? 7988 7989 if Need_Extra_Constrained then 7990 declare 7991 Extra_Parameter : constant Entity_Id := 7992 Extra_Constrained 7993 (Defining_Identifier 7994 (Current_Parameter)); 7995 7996 Extra_Any : constant Entity_Id := 7997 Make_Temporary (Loc, 'A'); 7998 7999 Formal_Entity : constant Entity_Id := 8000 Make_Defining_Identifier (Loc, 8001 Chars => Chars (Extra_Parameter)); 8002 8003 Formal_Type : constant Entity_Id := 8004 Etype (Extra_Parameter); 8005 8006 begin 8007 Append_To (Outer_Decls, 8008 Make_Object_Declaration (Loc, 8009 Defining_Identifier => Extra_Any, 8010 Object_Definition => 8011 New_Occurrence_Of (RTE (RE_Any), Loc), 8012 Expression => 8013 Make_Function_Call (Loc, 8014 Name => 8015 New_Occurrence_Of (RTE (RE_Create_Any), Loc), 8016 Parameter_Associations => New_List ( 8017 PolyORB_Support.Helpers.Build_TypeCode_Call 8018 (Loc, Formal_Type, Outer_Decls))))); 8019 8020 Append_To (Outer_Extra_Formal_Statements, 8021 Add_Parameter_To_NVList (Loc, 8022 Parameter => Extra_Parameter, 8023 NVList => Arguments, 8024 Constrained => True, 8025 Any => Extra_Any)); 8026 8027 Append_To (Decls, 8028 Make_Object_Declaration (Loc, 8029 Defining_Identifier => Formal_Entity, 8030 Object_Definition => 8031 New_Occurrence_Of (Formal_Type, Loc))); 8032 8033 Append_To (Statements, 8034 Make_Assignment_Statement (Loc, 8035 Name => New_Occurrence_Of (Formal_Entity, Loc), 8036 Expression => 8037 PolyORB_Support.Helpers.Build_From_Any_Call 8038 (Formal_Type, 8039 New_Occurrence_Of (Extra_Any, Loc), 8040 Decls))); 8041 Set_Extra_Constrained (Object, Formal_Entity); 8042 end; 8043 end if; 8044 end; 8045 8046 Next (Current_Parameter); 8047 end loop; 8048 8049 -- Extra Formals should go after all the other parameters 8050 8051 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements); 8052 8053 Append_To (Outer_Statements, 8054 Make_Procedure_Call_Statement (Loc, 8055 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc), 8056 Parameter_Associations => New_List ( 8057 New_Occurrence_Of (Request_Parameter, Loc), 8058 New_Occurrence_Of (Arguments, Loc)))); 8059 8060 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then 8061 8062 -- The remote subprogram is a function: Build an inner block to be 8063 -- able to hold a potentially unconstrained result in a variable. 8064 8065 declare 8066 Etyp : constant Entity_Id := 8067 Etype (Result_Definition (Specification (Vis_Decl))); 8068 Result : constant Node_Id := Make_Temporary (Loc, 'R'); 8069 8070 begin 8071 Inner_Decls := New_List ( 8072 Make_Object_Declaration (Loc, 8073 Defining_Identifier => Result, 8074 Constant_Present => True, 8075 Object_Definition => New_Occurrence_Of (Etyp, Loc), 8076 Expression => 8077 Make_Function_Call (Loc, 8078 Name => Called_Subprogram, 8079 Parameter_Associations => Parameter_List))); 8080 8081 if Is_Class_Wide_Type (Etyp) then 8082 8083 -- For a remote call to a function with a class-wide type, 8084 -- check that the returned value satisfies the requirements 8085 -- of (RM E.4(18)). 8086 8087 Append_To (Inner_Decls, 8088 Make_Transportable_Check (Loc, 8089 New_Occurrence_Of (Result, Loc))); 8090 8091 end if; 8092 8093 Set_Etype (Result, Etyp); 8094 Append_To (After_Statements, 8095 Make_Procedure_Call_Statement (Loc, 8096 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc), 8097 Parameter_Associations => New_List ( 8098 New_Occurrence_Of (Request_Parameter, Loc), 8099 PolyORB_Support.Helpers.Build_To_Any_Call 8100 (Loc, New_Occurrence_Of (Result, Loc), Decls)))); 8101 8102 -- A DSA function does not have out or inout arguments 8103 end; 8104 8105 Append_To (Statements, 8106 Make_Block_Statement (Loc, 8107 Declarations => Inner_Decls, 8108 Handled_Statement_Sequence => 8109 Make_Handled_Sequence_Of_Statements (Loc, 8110 Statements => After_Statements))); 8111 8112 else 8113 -- The remote subprogram is a procedure. We do not need any inner 8114 -- block in this case. No specific processing is required here for 8115 -- the dynamically asynchronous case: the indication of whether 8116 -- call is asynchronous or not is managed by the Sync_Scope 8117 -- attibute of the request, and is handled entirely in the 8118 -- protocol layer. 8119 8120 Append_To (After_Statements, 8121 Make_Procedure_Call_Statement (Loc, 8122 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc), 8123 Parameter_Associations => New_List ( 8124 New_Occurrence_Of (Request_Parameter, Loc)))); 8125 8126 Append_To (Statements, 8127 Make_Procedure_Call_Statement (Loc, 8128 Name => Called_Subprogram, 8129 Parameter_Associations => Parameter_List)); 8130 8131 Append_List_To (Statements, After_Statements); 8132 end if; 8133 8134 Subp_Spec := 8135 Make_Procedure_Specification (Loc, 8136 Defining_Unit_Name => Make_Temporary (Loc, 'F'), 8137 8138 Parameter_Specifications => New_List ( 8139 Make_Parameter_Specification (Loc, 8140 Defining_Identifier => Request_Parameter, 8141 Parameter_Type => 8142 New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); 8143 8144 -- An exception raised during the execution of an incoming remote 8145 -- subprogram call and that needs to be sent back to the caller is 8146 -- propagated by the receiving stubs, and will be handled by the 8147 -- caller (the distribution runtime). 8148 8149 if Asynchronous and then not Dynamically_Asynchronous then 8150 8151 -- For an asynchronous procedure, add a null exception handler 8152 8153 Excep_Handlers := New_List ( 8154 Make_Implicit_Exception_Handler (Loc, 8155 Exception_Choices => New_List (Make_Others_Choice (Loc)), 8156 Statements => New_List (Make_Null_Statement (Loc)))); 8157 8158 else 8159 -- In the other cases, if an exception is raised, then the 8160 -- exception occurrence is propagated. 8161 8162 null; 8163 end if; 8164 8165 Append_To (Outer_Statements, 8166 Make_Block_Statement (Loc, 8167 Declarations => Decls, 8168 Handled_Statement_Sequence => 8169 Make_Handled_Sequence_Of_Statements (Loc, 8170 Statements => Statements))); 8171 8172 return 8173 Make_Subprogram_Body (Loc, 8174 Specification => Subp_Spec, 8175 Declarations => Outer_Decls, 8176 Handled_Statement_Sequence => 8177 Make_Handled_Sequence_Of_Statements (Loc, 8178 Statements => Outer_Statements, 8179 Exception_Handlers => Excep_Handlers)); 8180 end Build_Subprogram_Receiving_Stubs; 8181 8182 ------------- 8183 -- Helpers -- 8184 ------------- 8185 8186 package body Helpers is 8187 8188 ----------------------- 8189 -- Local Subprograms -- 8190 ----------------------- 8191 8192 function Find_Numeric_Representation 8193 (Typ : Entity_Id) return Entity_Id; 8194 -- Given a numeric type Typ, return the smallest integer or modular 8195 -- type from Interfaces, or the smallest floating point type from 8196 -- Standard whose range encompasses that of Typ. 8197 8198 function Make_Helper_Function_Name 8199 (Loc : Source_Ptr; 8200 Typ : Entity_Id; 8201 Nam : Name_Id) return Entity_Id; 8202 -- Return the name to be assigned for helper subprogram Nam of Typ 8203 8204 ------------------------------------------------------------ 8205 -- Common subprograms for building various tree fragments -- 8206 ------------------------------------------------------------ 8207 8208 function Build_Get_Aggregate_Element 8209 (Loc : Source_Ptr; 8210 Any : Entity_Id; 8211 TC : Node_Id; 8212 Idx : Node_Id) return Node_Id; 8213 -- Build a call to Get_Aggregate_Element on Any for typecode TC, 8214 -- returning the Idx'th element. 8215 8216 generic 8217 Subprogram : Entity_Id; 8218 -- Reference location for constructed nodes 8219 8220 Arry : Entity_Id; 8221 -- For 'Range and Etype 8222 8223 Indexes : List_Id; 8224 -- For the construction of the innermost element expression 8225 8226 with procedure Add_Process_Element 8227 (Stmts : List_Id; 8228 Any : Entity_Id; 8229 Counter : Entity_Id; 8230 Datum : Node_Id); 8231 8232 procedure Append_Array_Traversal 8233 (Stmts : List_Id; 8234 Any : Entity_Id; 8235 Counter : Entity_Id := Empty; 8236 Depth : Pos := 1); 8237 -- Build nested loop statements that iterate over the elements of an 8238 -- array Arry. The statement(s) built by Add_Process_Element are 8239 -- executed for each element; Indexes is the list of indexes to be 8240 -- used in the construction of the indexed component that denotes the 8241 -- current element. Subprogram is the entity for the subprogram for 8242 -- which this iterator is generated. The generated statements are 8243 -- appended to Stmts. 8244 8245 generic 8246 Rec : Entity_Id; 8247 -- The record entity being dealt with 8248 8249 with procedure Add_Process_Element 8250 (Stmts : List_Id; 8251 Container : Node_Or_Entity_Id; 8252 Counter : in out Int; 8253 Rec : Entity_Id; 8254 Field : Node_Id); 8255 -- Rec is the instance of the record type, or Empty. 8256 -- Field is either the N_Defining_Identifier for a component, 8257 -- or an N_Variant_Part. 8258 8259 procedure Append_Record_Traversal 8260 (Stmts : List_Id; 8261 Clist : Node_Id; 8262 Container : Node_Or_Entity_Id; 8263 Counter : in out Int); 8264 -- Process component list Clist. Individual fields are passed 8265 -- to Field_Processing. Each variant part is also processed. 8266 -- Container is the outer Any (for From_Any/To_Any), 8267 -- the outer typecode (for TC) to which the operation applies. 8268 8269 ----------------------------- 8270 -- Append_Record_Traversal -- 8271 ----------------------------- 8272 8273 procedure Append_Record_Traversal 8274 (Stmts : List_Id; 8275 Clist : Node_Id; 8276 Container : Node_Or_Entity_Id; 8277 Counter : in out Int) 8278 is 8279 CI : List_Id; 8280 VP : Node_Id; 8281 -- Clist's Component_Items and Variant_Part 8282 8283 Item : Node_Id; 8284 Def : Entity_Id; 8285 8286 begin 8287 if No (Clist) then 8288 return; 8289 end if; 8290 8291 CI := Component_Items (Clist); 8292 VP := Variant_Part (Clist); 8293 8294 Item := First (CI); 8295 while Present (Item) loop 8296 Def := Defining_Identifier (Item); 8297 8298 if not Is_Internal_Name (Chars (Def)) then 8299 Add_Process_Element 8300 (Stmts, Container, Counter, Rec, Def); 8301 end if; 8302 8303 Next (Item); 8304 end loop; 8305 8306 if Present (VP) then 8307 Add_Process_Element (Stmts, Container, Counter, Rec, VP); 8308 end if; 8309 end Append_Record_Traversal; 8310 8311 ----------------------------- 8312 -- Assign_Opaque_From_Any -- 8313 ----------------------------- 8314 8315 procedure Assign_Opaque_From_Any 8316 (Loc : Source_Ptr; 8317 Stms : List_Id; 8318 Typ : Entity_Id; 8319 N : Node_Id; 8320 Target : Entity_Id) 8321 is 8322 Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); 8323 Expr : Node_Id; 8324 8325 Read_Call_List : List_Id; 8326 -- List on which to place the 'Read attribute reference 8327 8328 begin 8329 -- Strm : Buffer_Stream_Type; 8330 8331 Append_To (Stms, 8332 Make_Object_Declaration (Loc, 8333 Defining_Identifier => Strm, 8334 Aliased_Present => True, 8335 Object_Definition => 8336 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); 8337 8338 -- Any_To_BS (Strm, A); 8339 8340 Append_To (Stms, 8341 Make_Procedure_Call_Statement (Loc, 8342 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), 8343 Parameter_Associations => New_List ( 8344 N, 8345 New_Occurrence_Of (Strm, Loc)))); 8346 8347 if Transmit_As_Unconstrained (Typ) then 8348 Expr := 8349 Make_Attribute_Reference (Loc, 8350 Prefix => New_Occurrence_Of (Typ, Loc), 8351 Attribute_Name => Name_Input, 8352 Expressions => New_List ( 8353 Make_Attribute_Reference (Loc, 8354 Prefix => New_Occurrence_Of (Strm, Loc), 8355 Attribute_Name => Name_Access))); 8356 8357 -- Target := Typ'Input (Strm'Access) 8358 8359 if Present (Target) then 8360 Append_To (Stms, 8361 Make_Assignment_Statement (Loc, 8362 Name => New_Occurrence_Of (Target, Loc), 8363 Expression => Expr)); 8364 8365 -- return Typ'Input (Strm'Access); 8366 8367 else 8368 Append_To (Stms, 8369 Make_Simple_Return_Statement (Loc, 8370 Expression => Expr)); 8371 end if; 8372 8373 else 8374 if Present (Target) then 8375 Read_Call_List := Stms; 8376 Expr := New_Occurrence_Of (Target, Loc); 8377 8378 else 8379 declare 8380 Temp : constant Entity_Id := Make_Temporary (Loc, 'R'); 8381 8382 begin 8383 Read_Call_List := New_List; 8384 Expr := New_Occurrence_Of (Temp, Loc); 8385 8386 Append_To (Stms, Make_Block_Statement (Loc, 8387 Declarations => New_List ( 8388 Make_Object_Declaration (Loc, 8389 Defining_Identifier => 8390 Temp, 8391 Object_Definition => 8392 New_Occurrence_Of (Typ, Loc))), 8393 8394 Handled_Statement_Sequence => 8395 Make_Handled_Sequence_Of_Statements (Loc, 8396 Statements => Read_Call_List))); 8397 end; 8398 end if; 8399 8400 -- Typ'Read (Strm'Access, [Target|Temp]) 8401 8402 Append_To (Read_Call_List, 8403 Make_Attribute_Reference (Loc, 8404 Prefix => New_Occurrence_Of (Typ, Loc), 8405 Attribute_Name => Name_Read, 8406 Expressions => New_List ( 8407 Make_Attribute_Reference (Loc, 8408 Prefix => New_Occurrence_Of (Strm, Loc), 8409 Attribute_Name => Name_Access), 8410 Expr))); 8411 8412 if No (Target) then 8413 8414 -- return Temp 8415 8416 Append_To (Read_Call_List, 8417 Make_Simple_Return_Statement (Loc, 8418 Expression => New_Copy (Expr))); 8419 end if; 8420 end if; 8421 end Assign_Opaque_From_Any; 8422 8423 ------------------------- 8424 -- Build_From_Any_Call -- 8425 ------------------------- 8426 8427 function Build_From_Any_Call 8428 (Typ : Entity_Id; 8429 N : Node_Id; 8430 Decls : List_Id) return Node_Id 8431 is 8432 Loc : constant Source_Ptr := Sloc (N); 8433 8434 U_Type : Entity_Id := Underlying_Type (Typ); 8435 8436 Fnam : Entity_Id := Empty; 8437 Lib_RE : RE_Id := RE_Null; 8438 Result : Node_Id; 8439 8440 begin 8441 -- First simple case where the From_Any function is present 8442 -- in the type's TSS. 8443 8444 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any); 8445 8446 -- For the subtype representing a generic actual type, go to the 8447 -- actual type. 8448 8449 if Is_Generic_Actual_Type (U_Type) then 8450 U_Type := Underlying_Type (Base_Type (U_Type)); 8451 end if; 8452 8453 -- For a standard subtype, go to the base type 8454 8455 if Sloc (U_Type) <= Standard_Location then 8456 U_Type := Base_Type (U_Type); 8457 8458 -- For a user subtype, go to first subtype 8459 8460 elsif Comes_From_Source (U_Type) 8461 and then Nkind (Declaration_Node (U_Type)) 8462 = N_Subtype_Declaration 8463 then 8464 U_Type := First_Subtype (U_Type); 8465 end if; 8466 8467 -- Check first for Boolean and Character. These are enumeration 8468 -- types, but we treat them specially, since they may require 8469 -- special handling in the transfer protocol. However, this 8470 -- special handling only applies if they have standard 8471 -- representation, otherwise they are treated like any other 8472 -- enumeration type. 8473 8474 if Present (Fnam) then 8475 null; 8476 8477 elsif U_Type = Standard_Boolean then 8478 Lib_RE := RE_FA_B; 8479 8480 elsif U_Type = Standard_Character then 8481 Lib_RE := RE_FA_C; 8482 8483 elsif U_Type = Standard_Wide_Character then 8484 Lib_RE := RE_FA_WC; 8485 8486 elsif U_Type = Standard_Wide_Wide_Character then 8487 Lib_RE := RE_FA_WWC; 8488 8489 -- Floating point types 8490 8491 elsif U_Type = Standard_Short_Float then 8492 Lib_RE := RE_FA_SF; 8493 8494 elsif U_Type = Standard_Float then 8495 Lib_RE := RE_FA_F; 8496 8497 elsif U_Type = Standard_Long_Float then 8498 Lib_RE := RE_FA_LF; 8499 8500 elsif U_Type = Standard_Long_Long_Float then 8501 Lib_RE := RE_FA_LLF; 8502 8503 -- Integer types 8504 8505 elsif U_Type = RTE (RE_Integer_8) then 8506 Lib_RE := RE_FA_I8; 8507 8508 elsif U_Type = RTE (RE_Integer_16) then 8509 Lib_RE := RE_FA_I16; 8510 8511 elsif U_Type = RTE (RE_Integer_32) then 8512 Lib_RE := RE_FA_I32; 8513 8514 elsif U_Type = RTE (RE_Integer_64) then 8515 Lib_RE := RE_FA_I64; 8516 8517 -- Unsigned integer types 8518 8519 elsif U_Type = RTE (RE_Unsigned_8) then 8520 Lib_RE := RE_FA_U8; 8521 8522 elsif U_Type = RTE (RE_Unsigned_16) then 8523 Lib_RE := RE_FA_U16; 8524 8525 elsif U_Type = RTE (RE_Unsigned_32) then 8526 Lib_RE := RE_FA_U32; 8527 8528 elsif U_Type = RTE (RE_Unsigned_64) then 8529 Lib_RE := RE_FA_U64; 8530 8531 elsif Is_RTE (U_Type, RE_Unbounded_String) then 8532 Lib_RE := RE_FA_String; 8533 8534 -- Special DSA types 8535 8536 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then 8537 Lib_RE := RE_FA_A; 8538 8539 -- Other (non-primitive) types 8540 8541 else 8542 declare 8543 Decl : Entity_Id; 8544 8545 begin 8546 Build_From_Any_Function (Loc, U_Type, Decl, Fnam); 8547 Append_To (Decls, Decl); 8548 end; 8549 end if; 8550 8551 -- Call the function 8552 8553 if Lib_RE /= RE_Null then 8554 pragma Assert (No (Fnam)); 8555 Fnam := RTE (Lib_RE); 8556 end if; 8557 8558 Result := 8559 Make_Function_Call (Loc, 8560 Name => New_Occurrence_Of (Fnam, Loc), 8561 Parameter_Associations => New_List (N)); 8562 8563 -- We must set the type of Result, so the unchecked conversion 8564 -- from the underlying type to the base type is properly done. 8565 8566 Set_Etype (Result, U_Type); 8567 8568 return Unchecked_Convert_To (Typ, Result); 8569 end Build_From_Any_Call; 8570 8571 ----------------------------- 8572 -- Build_From_Any_Function -- 8573 ----------------------------- 8574 8575 procedure Build_From_Any_Function 8576 (Loc : Source_Ptr; 8577 Typ : Entity_Id; 8578 Decl : out Node_Id; 8579 Fnam : out Entity_Id) 8580 is 8581 Spec : Node_Id; 8582 Decls : constant List_Id := New_List; 8583 Stms : constant List_Id := New_List; 8584 8585 Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A'); 8586 8587 Use_Opaque_Representation : Boolean; 8588 8589 begin 8590 -- For a derived type, we can't go past the base type (to the 8591 -- parent type) here, because that would cause the attribute's 8592 -- formal parameter to have the wrong type; hence the Base_Type 8593 -- check here. 8594 8595 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then 8596 Build_From_Any_Function 8597 (Loc => Loc, 8598 Typ => Etype (Typ), 8599 Decl => Decl, 8600 Fnam => Fnam); 8601 return; 8602 end if; 8603 8604 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any); 8605 8606 Spec := 8607 Make_Function_Specification (Loc, 8608 Defining_Unit_Name => Fnam, 8609 Parameter_Specifications => New_List ( 8610 Make_Parameter_Specification (Loc, 8611 Defining_Identifier => Any_Parameter, 8612 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), 8613 Result_Definition => New_Occurrence_Of (Typ, Loc)); 8614 8615 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any 8616 8617 pragma Assert 8618 (not (Is_Remote_Access_To_Class_Wide_Type (Typ))); 8619 8620 Use_Opaque_Representation := False; 8621 8622 if Has_Stream_Attribute_Definition 8623 (Typ, TSS_Stream_Output, At_Any_Place => True) 8624 or else 8625 Has_Stream_Attribute_Definition 8626 (Typ, TSS_Stream_Write, At_Any_Place => True) 8627 then 8628 -- If user-defined stream attributes are specified for this 8629 -- type, use them and transmit data as an opaque sequence of 8630 -- stream elements. 8631 8632 Use_Opaque_Representation := True; 8633 8634 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then 8635 Append_To (Stms, 8636 Make_Simple_Return_Statement (Loc, 8637 Expression => 8638 OK_Convert_To (Typ, 8639 Build_From_Any_Call 8640 (Root_Type (Typ), 8641 New_Occurrence_Of (Any_Parameter, Loc), 8642 Decls)))); 8643 8644 elsif Is_Record_Type (Typ) 8645 and then not Is_Derived_Type (Typ) 8646 and then not Is_Tagged_Type (Typ) 8647 then 8648 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then 8649 Append_To (Stms, 8650 Make_Simple_Return_Statement (Loc, 8651 Expression => 8652 Build_From_Any_Call 8653 (Etype (Typ), 8654 New_Occurrence_Of (Any_Parameter, Loc), 8655 Decls))); 8656 8657 else 8658 declare 8659 Disc : Entity_Id := Empty; 8660 Discriminant_Associations : List_Id; 8661 Rdef : constant Node_Id := 8662 Type_Definition 8663 (Declaration_Node (Typ)); 8664 Component_Counter : Int := 0; 8665 8666 -- The returned object 8667 8668 Res : constant Entity_Id := Make_Temporary (Loc, 'R'); 8669 8670 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc); 8671 8672 procedure FA_Rec_Add_Process_Element 8673 (Stmts : List_Id; 8674 Any : Entity_Id; 8675 Counter : in out Int; 8676 Rec : Entity_Id; 8677 Field : Node_Id); 8678 8679 procedure FA_Append_Record_Traversal is 8680 new Append_Record_Traversal 8681 (Rec => Res, 8682 Add_Process_Element => FA_Rec_Add_Process_Element); 8683 8684 -------------------------------- 8685 -- FA_Rec_Add_Process_Element -- 8686 -------------------------------- 8687 8688 procedure FA_Rec_Add_Process_Element 8689 (Stmts : List_Id; 8690 Any : Entity_Id; 8691 Counter : in out Int; 8692 Rec : Entity_Id; 8693 Field : Node_Id) 8694 is 8695 Ctyp : Entity_Id; 8696 begin 8697 if Nkind (Field) = N_Defining_Identifier then 8698 -- A regular component 8699 8700 Ctyp := Etype (Field); 8701 8702 Append_To (Stmts, 8703 Make_Assignment_Statement (Loc, 8704 Name => Make_Selected_Component (Loc, 8705 Prefix => 8706 New_Occurrence_Of (Rec, Loc), 8707 Selector_Name => 8708 New_Occurrence_Of (Field, Loc)), 8709 8710 Expression => 8711 Build_From_Any_Call (Ctyp, 8712 Build_Get_Aggregate_Element (Loc, 8713 Any => Any, 8714 TC => 8715 Build_TypeCode_Call (Loc, Ctyp, Decls), 8716 Idx => 8717 Make_Integer_Literal (Loc, Counter)), 8718 Decls))); 8719 8720 else 8721 -- A variant part 8722 8723 declare 8724 Variant : Node_Id; 8725 Struct_Counter : Int := 0; 8726 8727 Block_Decls : constant List_Id := New_List; 8728 Block_Stmts : constant List_Id := New_List; 8729 VP_Stmts : List_Id; 8730 8731 Alt_List : constant List_Id := New_List; 8732 Choice_List : List_Id; 8733 8734 Struct_Any : constant Entity_Id := 8735 Make_Temporary (Loc, 'S'); 8736 8737 begin 8738 Append_To (Decls, 8739 Make_Object_Declaration (Loc, 8740 Defining_Identifier => Struct_Any, 8741 Constant_Present => True, 8742 Object_Definition => 8743 New_Occurrence_Of (RTE (RE_Any), Loc), 8744 Expression => 8745 Make_Function_Call (Loc, 8746 Name => 8747 New_Occurrence_Of 8748 (RTE (RE_Extract_Union_Value), Loc), 8749 8750 Parameter_Associations => New_List ( 8751 Build_Get_Aggregate_Element (Loc, 8752 Any => Any, 8753 TC => 8754 Make_Function_Call (Loc, 8755 Name => New_Occurrence_Of ( 8756 RTE (RE_Any_Member_Type), Loc), 8757 Parameter_Associations => 8758 New_List ( 8759 New_Occurrence_Of (Any, Loc), 8760 Make_Integer_Literal (Loc, 8761 Intval => Counter))), 8762 Idx => 8763 Make_Integer_Literal (Loc, 8764 Intval => Counter)))))); 8765 8766 Append_To (Stmts, 8767 Make_Block_Statement (Loc, 8768 Declarations => Block_Decls, 8769 Handled_Statement_Sequence => 8770 Make_Handled_Sequence_Of_Statements (Loc, 8771 Statements => Block_Stmts))); 8772 8773 Append_To (Block_Stmts, 8774 Make_Case_Statement (Loc, 8775 Expression => 8776 Make_Selected_Component (Loc, 8777 Prefix => Rec, 8778 Selector_Name => Chars (Name (Field))), 8779 Alternatives => Alt_List)); 8780 8781 Variant := First_Non_Pragma (Variants (Field)); 8782 while Present (Variant) loop 8783 Choice_List := 8784 New_Copy_List_Tree 8785 (Discrete_Choices (Variant)); 8786 8787 VP_Stmts := New_List; 8788 8789 -- Struct_Counter should be reset before 8790 -- handling a variant part. Indeed only one 8791 -- of the case statement alternatives will be 8792 -- executed at run time, so the counter must 8793 -- start at 0 for every case statement. 8794 8795 Struct_Counter := 0; 8796 8797 FA_Append_Record_Traversal ( 8798 Stmts => VP_Stmts, 8799 Clist => Component_List (Variant), 8800 Container => Struct_Any, 8801 Counter => Struct_Counter); 8802 8803 Append_To (Alt_List, 8804 Make_Case_Statement_Alternative (Loc, 8805 Discrete_Choices => Choice_List, 8806 Statements => VP_Stmts)); 8807 Next_Non_Pragma (Variant); 8808 end loop; 8809 end; 8810 end if; 8811 8812 Counter := Counter + 1; 8813 end FA_Rec_Add_Process_Element; 8814 8815 begin 8816 -- First all discriminants 8817 8818 if Has_Discriminants (Typ) then 8819 Discriminant_Associations := New_List; 8820 8821 Disc := First_Discriminant (Typ); 8822 while Present (Disc) loop 8823 declare 8824 Disc_Var_Name : constant Entity_Id := 8825 Make_Defining_Identifier (Loc, 8826 Chars => Chars (Disc)); 8827 Disc_Type : constant Entity_Id := 8828 Etype (Disc); 8829 8830 begin 8831 Append_To (Decls, 8832 Make_Object_Declaration (Loc, 8833 Defining_Identifier => Disc_Var_Name, 8834 Constant_Present => True, 8835 Object_Definition => 8836 New_Occurrence_Of (Disc_Type, Loc), 8837 8838 Expression => 8839 Build_From_Any_Call (Disc_Type, 8840 Build_Get_Aggregate_Element (Loc, 8841 Any => Any_Parameter, 8842 TC => Build_TypeCode_Call 8843 (Loc, Disc_Type, Decls), 8844 Idx => Make_Integer_Literal (Loc, 8845 Intval => Component_Counter)), 8846 Decls))); 8847 8848 Component_Counter := Component_Counter + 1; 8849 8850 Append_To (Discriminant_Associations, 8851 Make_Discriminant_Association (Loc, 8852 Selector_Names => New_List ( 8853 New_Occurrence_Of (Disc, Loc)), 8854 Expression => 8855 New_Occurrence_Of (Disc_Var_Name, Loc))); 8856 end; 8857 Next_Discriminant (Disc); 8858 end loop; 8859 8860 Res_Definition := 8861 Make_Subtype_Indication (Loc, 8862 Subtype_Mark => Res_Definition, 8863 Constraint => 8864 Make_Index_Or_Discriminant_Constraint (Loc, 8865 Discriminant_Associations)); 8866 end if; 8867 8868 -- Now we have all the discriminants in variables, we can 8869 -- declared a constrained object. Note that we are not 8870 -- initializing (non-discriminant) components directly in 8871 -- the object declarations, because which fields to 8872 -- initialize depends (at run time) on the discriminant 8873 -- values. 8874 8875 Append_To (Decls, 8876 Make_Object_Declaration (Loc, 8877 Defining_Identifier => Res, 8878 Object_Definition => Res_Definition)); 8879 8880 -- ... then all components 8881 8882 FA_Append_Record_Traversal (Stms, 8883 Clist => Component_List (Rdef), 8884 Container => Any_Parameter, 8885 Counter => Component_Counter); 8886 8887 Append_To (Stms, 8888 Make_Simple_Return_Statement (Loc, 8889 Expression => New_Occurrence_Of (Res, Loc))); 8890 end; 8891 end if; 8892 8893 elsif Is_Array_Type (Typ) then 8894 declare 8895 Constrained : constant Boolean := Is_Constrained (Typ); 8896 8897 procedure FA_Ary_Add_Process_Element 8898 (Stmts : List_Id; 8899 Any : Entity_Id; 8900 Counter : Entity_Id; 8901 Datum : Node_Id); 8902 -- Assign the current element (as identified by Counter) of 8903 -- Any to the variable denoted by name Datum, and advance 8904 -- Counter by 1. If Datum is not an Any, a call to From_Any 8905 -- for its type is inserted. 8906 8907 -------------------------------- 8908 -- FA_Ary_Add_Process_Element -- 8909 -------------------------------- 8910 8911 procedure FA_Ary_Add_Process_Element 8912 (Stmts : List_Id; 8913 Any : Entity_Id; 8914 Counter : Entity_Id; 8915 Datum : Node_Id) 8916 is 8917 Assignment : constant Node_Id := 8918 Make_Assignment_Statement (Loc, 8919 Name => Datum, 8920 Expression => Empty); 8921 8922 Element_Any : Node_Id; 8923 8924 begin 8925 declare 8926 Element_TC : Node_Id; 8927 8928 begin 8929 if Etype (Datum) = RTE (RE_Any) then 8930 8931 -- When Datum is an Any the Etype field is not 8932 -- sufficient to determine the typecode of Datum 8933 -- (which can be a TC_SEQUENCE or TC_ARRAY 8934 -- depending on the value of Constrained). 8935 8936 -- Therefore we retrieve the typecode which has 8937 -- been constructed in Append_Array_Traversal with 8938 -- a call to Get_Any_Type. 8939 8940 Element_TC := 8941 Make_Function_Call (Loc, 8942 Name => New_Occurrence_Of ( 8943 RTE (RE_Get_Any_Type), Loc), 8944 Parameter_Associations => New_List ( 8945 New_Occurrence_Of (Entity (Datum), Loc))); 8946 else 8947 -- For non Any Datum we simply construct a typecode 8948 -- matching the Etype of the Datum. 8949 8950 Element_TC := Build_TypeCode_Call 8951 (Loc, Etype (Datum), Decls); 8952 end if; 8953 8954 Element_Any := 8955 Build_Get_Aggregate_Element (Loc, 8956 Any => Any, 8957 TC => Element_TC, 8958 Idx => New_Occurrence_Of (Counter, Loc)); 8959 end; 8960 8961 -- Note: here we *prepend* statements to Stmts, so 8962 -- we must do it in reverse order. 8963 8964 Prepend_To (Stmts, 8965 Make_Assignment_Statement (Loc, 8966 Name => 8967 New_Occurrence_Of (Counter, Loc), 8968 Expression => 8969 Make_Op_Add (Loc, 8970 Left_Opnd => New_Occurrence_Of (Counter, Loc), 8971 Right_Opnd => Make_Integer_Literal (Loc, 1)))); 8972 8973 if Nkind (Datum) /= N_Attribute_Reference then 8974 8975 -- We ignore the value of the length of each 8976 -- dimension, since the target array has already been 8977 -- constrained anyway. 8978 8979 if Etype (Datum) /= RTE (RE_Any) then 8980 Set_Expression (Assignment, 8981 Build_From_Any_Call 8982 (Component_Type (Typ), Element_Any, Decls)); 8983 else 8984 Set_Expression (Assignment, Element_Any); 8985 end if; 8986 8987 Prepend_To (Stmts, Assignment); 8988 end if; 8989 end FA_Ary_Add_Process_Element; 8990 8991 ------------------------ 8992 -- Local Declarations -- 8993 ------------------------ 8994 8995 Counter : constant Entity_Id := 8996 Make_Defining_Identifier (Loc, Name_J); 8997 8998 Initial_Counter_Value : Int := 0; 8999 9000 Component_TC : constant Entity_Id := 9001 Make_Defining_Identifier (Loc, Name_T); 9002 9003 Res : constant Entity_Id := 9004 Make_Defining_Identifier (Loc, Name_R); 9005 9006 procedure Append_From_Any_Array_Iterator is 9007 new Append_Array_Traversal ( 9008 Subprogram => Fnam, 9009 Arry => Res, 9010 Indexes => New_List, 9011 Add_Process_Element => FA_Ary_Add_Process_Element); 9012 9013 Res_Subtype_Indication : Node_Id := 9014 New_Occurrence_Of (Typ, Loc); 9015 9016 begin 9017 if not Constrained then 9018 declare 9019 Ndim : constant Int := Number_Dimensions (Typ); 9020 Lnam : Name_Id; 9021 Hnam : Name_Id; 9022 Indx : Node_Id := First_Index (Typ); 9023 Indt : Entity_Id; 9024 9025 Ranges : constant List_Id := New_List; 9026 9027 begin 9028 for J in 1 .. Ndim loop 9029 Lnam := New_External_Name ('L', J); 9030 Hnam := New_External_Name ('H', J); 9031 9032 -- Note, for empty arrays bounds may be out of 9033 -- the range of Etype (Indx). 9034 9035 Indt := Base_Type (Etype (Indx)); 9036 9037 Append_To (Decls, 9038 Make_Object_Declaration (Loc, 9039 Defining_Identifier => 9040 Make_Defining_Identifier (Loc, Lnam), 9041 Constant_Present => True, 9042 Object_Definition => 9043 New_Occurrence_Of (Indt, Loc), 9044 Expression => 9045 Build_From_Any_Call 9046 (Indt, 9047 Build_Get_Aggregate_Element (Loc, 9048 Any => Any_Parameter, 9049 TC => Build_TypeCode_Call 9050 (Loc, Indt, Decls), 9051 Idx => 9052 Make_Integer_Literal (Loc, J - 1)), 9053 Decls))); 9054 9055 Append_To (Decls, 9056 Make_Object_Declaration (Loc, 9057 Defining_Identifier => 9058 Make_Defining_Identifier (Loc, Hnam), 9059 9060 Constant_Present => True, 9061 9062 Object_Definition => 9063 New_Occurrence_Of (Indt, Loc), 9064 9065 Expression => Make_Attribute_Reference (Loc, 9066 Prefix => 9067 New_Occurrence_Of (Indt, Loc), 9068 9069 Attribute_Name => Name_Val, 9070 9071 Expressions => New_List ( 9072 Make_Op_Subtract (Loc, 9073 Left_Opnd => 9074 Make_Op_Add (Loc, 9075 Left_Opnd => 9076 OK_Convert_To 9077 (Standard_Long_Integer, 9078 Make_Identifier (Loc, Lnam)), 9079 9080 Right_Opnd => 9081 OK_Convert_To 9082 (Standard_Long_Integer, 9083 Make_Function_Call (Loc, 9084 Name => 9085 New_Occurrence_Of (RTE ( 9086 RE_Get_Nested_Sequence_Length 9087 ), Loc), 9088 Parameter_Associations => 9089 New_List ( 9090 New_Occurrence_Of ( 9091 Any_Parameter, Loc), 9092 Make_Integer_Literal (Loc, 9093 Intval => J))))), 9094 9095 Right_Opnd => 9096 Make_Integer_Literal (Loc, 1)))))); 9097 9098 Append_To (Ranges, 9099 Make_Range (Loc, 9100 Low_Bound => Make_Identifier (Loc, Lnam), 9101 High_Bound => Make_Identifier (Loc, Hnam))); 9102 9103 Next_Index (Indx); 9104 end loop; 9105 9106 -- Now we have all the necessary bound information: 9107 -- apply the set of range constraints to the 9108 -- (unconstrained) nominal subtype of Res. 9109 9110 Initial_Counter_Value := Ndim; 9111 Res_Subtype_Indication := Make_Subtype_Indication (Loc, 9112 Subtype_Mark => Res_Subtype_Indication, 9113 Constraint => 9114 Make_Index_Or_Discriminant_Constraint (Loc, 9115 Constraints => Ranges)); 9116 end; 9117 end if; 9118 9119 Append_To (Decls, 9120 Make_Object_Declaration (Loc, 9121 Defining_Identifier => Res, 9122 Object_Definition => Res_Subtype_Indication)); 9123 Set_Etype (Res, Typ); 9124 9125 Append_To (Decls, 9126 Make_Object_Declaration (Loc, 9127 Defining_Identifier => Counter, 9128 Object_Definition => 9129 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc), 9130 Expression => 9131 Make_Integer_Literal (Loc, Initial_Counter_Value))); 9132 9133 Append_To (Decls, 9134 Make_Object_Declaration (Loc, 9135 Defining_Identifier => Component_TC, 9136 Constant_Present => True, 9137 Object_Definition => 9138 New_Occurrence_Of (RTE (RE_TypeCode), Loc), 9139 Expression => 9140 Build_TypeCode_Call (Loc, 9141 Component_Type (Typ), Decls))); 9142 9143 Append_From_Any_Array_Iterator 9144 (Stms, Any_Parameter, Counter); 9145 9146 Append_To (Stms, 9147 Make_Simple_Return_Statement (Loc, 9148 Expression => New_Occurrence_Of (Res, Loc))); 9149 end; 9150 9151 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then 9152 Append_To (Stms, 9153 Make_Simple_Return_Statement (Loc, 9154 Expression => 9155 Unchecked_Convert_To (Typ, 9156 Build_From_Any_Call 9157 (Find_Numeric_Representation (Typ), 9158 New_Occurrence_Of (Any_Parameter, Loc), 9159 Decls)))); 9160 9161 else 9162 Use_Opaque_Representation := True; 9163 end if; 9164 9165 if Use_Opaque_Representation then 9166 Assign_Opaque_From_Any (Loc, 9167 Stms => Stms, 9168 Typ => Typ, 9169 N => New_Occurrence_Of (Any_Parameter, Loc), 9170 Target => Empty); 9171 end if; 9172 9173 Decl := 9174 Make_Subprogram_Body (Loc, 9175 Specification => Spec, 9176 Declarations => Decls, 9177 Handled_Statement_Sequence => 9178 Make_Handled_Sequence_Of_Statements (Loc, 9179 Statements => Stms)); 9180 end Build_From_Any_Function; 9181 9182 --------------------------------- 9183 -- Build_Get_Aggregate_Element -- 9184 --------------------------------- 9185 9186 function Build_Get_Aggregate_Element 9187 (Loc : Source_Ptr; 9188 Any : Entity_Id; 9189 TC : Node_Id; 9190 Idx : Node_Id) return Node_Id 9191 is 9192 begin 9193 return Make_Function_Call (Loc, 9194 Name => 9195 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc), 9196 Parameter_Associations => New_List ( 9197 New_Occurrence_Of (Any, Loc), 9198 TC, 9199 Idx)); 9200 end Build_Get_Aggregate_Element; 9201 9202 ------------------------- 9203 -- Build_Reposiroty_Id -- 9204 ------------------------- 9205 9206 procedure Build_Name_And_Repository_Id 9207 (E : Entity_Id; 9208 Name_Str : out String_Id; 9209 Repo_Id_Str : out String_Id) 9210 is 9211 begin 9212 Start_String; 9213 Store_String_Chars ("DSA:"); 9214 Get_Library_Unit_Name_String (Scope (E)); 9215 Store_String_Chars 9216 (Name_Buffer (Name_Buffer'First .. 9217 Name_Buffer'First + Name_Len - 1)); 9218 Store_String_Char ('.'); 9219 Get_Name_String (Chars (E)); 9220 Store_String_Chars 9221 (Name_Buffer (Name_Buffer'First .. 9222 Name_Buffer'First + Name_Len - 1)); 9223 Store_String_Chars (":1.0"); 9224 Repo_Id_Str := End_String; 9225 Name_Str := String_From_Name_Buffer; 9226 end Build_Name_And_Repository_Id; 9227 9228 ----------------------- 9229 -- Build_To_Any_Call -- 9230 ----------------------- 9231 9232 function Build_To_Any_Call 9233 (Loc : Source_Ptr; 9234 N : Node_Id; 9235 Decls : List_Id) return Node_Id 9236 is 9237 Typ : Entity_Id := Etype (N); 9238 U_Type : Entity_Id; 9239 C_Type : Entity_Id; 9240 Fnam : Entity_Id := Empty; 9241 Lib_RE : RE_Id := RE_Null; 9242 9243 begin 9244 -- If N is a selected component, then maybe its Etype has not been 9245 -- set yet: try to use Etype of the selector_name in that case. 9246 9247 if No (Typ) and then Nkind (N) = N_Selected_Component then 9248 Typ := Etype (Selector_Name (N)); 9249 end if; 9250 9251 pragma Assert (Present (Typ)); 9252 9253 -- Get full view for private type, completion for incomplete type 9254 9255 U_Type := Underlying_Type (Typ); 9256 9257 -- First simple case where the To_Any function is present in the 9258 -- type's TSS. 9259 9260 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any); 9261 9262 -- For the subtype representing a generic actual type, go to the 9263 -- actual type. 9264 9265 if Is_Generic_Actual_Type (U_Type) then 9266 U_Type := Underlying_Type (Base_Type (U_Type)); 9267 end if; 9268 9269 -- For a standard subtype, go to the base type 9270 9271 if Sloc (U_Type) <= Standard_Location then 9272 U_Type := Base_Type (U_Type); 9273 9274 -- For a user subtype, go to first subtype 9275 9276 elsif Comes_From_Source (U_Type) 9277 and then Nkind (Declaration_Node (U_Type)) 9278 = N_Subtype_Declaration 9279 then 9280 U_Type := First_Subtype (U_Type); 9281 end if; 9282 9283 if Present (Fnam) then 9284 null; 9285 9286 -- Check first for Boolean and Character. These are enumeration 9287 -- types, but we treat them specially, since they may require 9288 -- special handling in the transfer protocol. However, this 9289 -- special handling only applies if they have standard 9290 -- representation, otherwise they are treated like any other 9291 -- enumeration type. 9292 9293 elsif U_Type = Standard_Boolean then 9294 Lib_RE := RE_TA_B; 9295 9296 elsif U_Type = Standard_Character then 9297 Lib_RE := RE_TA_C; 9298 9299 elsif U_Type = Standard_Wide_Character then 9300 Lib_RE := RE_TA_WC; 9301 9302 elsif U_Type = Standard_Wide_Wide_Character then 9303 Lib_RE := RE_TA_WWC; 9304 9305 -- Floating point types 9306 9307 elsif U_Type = Standard_Short_Float then 9308 Lib_RE := RE_TA_SF; 9309 9310 elsif U_Type = Standard_Float then 9311 Lib_RE := RE_TA_F; 9312 9313 elsif U_Type = Standard_Long_Float then 9314 Lib_RE := RE_TA_LF; 9315 9316 elsif U_Type = Standard_Long_Long_Float then 9317 Lib_RE := RE_TA_LLF; 9318 9319 -- Integer types 9320 9321 elsif U_Type = RTE (RE_Integer_8) then 9322 Lib_RE := RE_TA_I8; 9323 9324 elsif U_Type = RTE (RE_Integer_16) then 9325 Lib_RE := RE_TA_I16; 9326 9327 elsif U_Type = RTE (RE_Integer_32) then 9328 Lib_RE := RE_TA_I32; 9329 9330 elsif U_Type = RTE (RE_Integer_64) then 9331 Lib_RE := RE_TA_I64; 9332 9333 -- Unsigned integer types 9334 9335 elsif U_Type = RTE (RE_Unsigned_8) then 9336 Lib_RE := RE_TA_U8; 9337 9338 elsif U_Type = RTE (RE_Unsigned_16) then 9339 Lib_RE := RE_TA_U16; 9340 9341 elsif U_Type = RTE (RE_Unsigned_32) then 9342 Lib_RE := RE_TA_U32; 9343 9344 elsif U_Type = RTE (RE_Unsigned_64) then 9345 Lib_RE := RE_TA_U64; 9346 9347 elsif Is_RTE (U_Type, RE_Unbounded_String) then 9348 Lib_RE := RE_TA_String; 9349 9350 -- Special DSA types 9351 9352 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then 9353 Lib_RE := RE_TA_A; 9354 U_Type := Typ; 9355 9356 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then 9357 9358 -- No corresponding FA_TC ??? 9359 9360 Lib_RE := RE_TA_TC; 9361 9362 -- Other (non-primitive) types 9363 9364 else 9365 declare 9366 Decl : Entity_Id; 9367 begin 9368 Build_To_Any_Function (Loc, U_Type, Decl, Fnam); 9369 Append_To (Decls, Decl); 9370 end; 9371 end if; 9372 9373 -- Call the function 9374 9375 if Lib_RE /= RE_Null then 9376 pragma Assert (No (Fnam)); 9377 Fnam := RTE (Lib_RE); 9378 end if; 9379 9380 -- If Fnam is already analyzed, find the proper expected type, 9381 -- else we have a newly constructed To_Any function and we know 9382 -- that the expected type of its parameter is U_Type. 9383 9384 if Ekind (Fnam) = E_Function 9385 and then Present (First_Formal (Fnam)) 9386 then 9387 C_Type := Etype (First_Formal (Fnam)); 9388 else 9389 C_Type := U_Type; 9390 end if; 9391 9392 return 9393 Make_Function_Call (Loc, 9394 Name => New_Occurrence_Of (Fnam, Loc), 9395 Parameter_Associations => 9396 New_List (OK_Convert_To (C_Type, N))); 9397 end Build_To_Any_Call; 9398 9399 --------------------------- 9400 -- Build_To_Any_Function -- 9401 --------------------------- 9402 9403 procedure Build_To_Any_Function 9404 (Loc : Source_Ptr; 9405 Typ : Entity_Id; 9406 Decl : out Node_Id; 9407 Fnam : out Entity_Id) 9408 is 9409 Spec : Node_Id; 9410 Decls : constant List_Id := New_List; 9411 Stms : constant List_Id := New_List; 9412 9413 Expr_Parameter : Entity_Id; 9414 Any : Entity_Id; 9415 Result_TC : Node_Id; 9416 9417 Any_Decl : Node_Id; 9418 9419 Use_Opaque_Representation : Boolean; 9420 -- When True, use stream attributes and represent type as an 9421 -- opaque sequence of bytes. 9422 9423 begin 9424 -- For a derived type, we can't go past the base type (to the 9425 -- parent type) here, because that would cause the attribute's 9426 -- formal parameter to have the wrong type; hence the Base_Type 9427 -- check here. 9428 9429 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then 9430 Build_To_Any_Function 9431 (Loc => Loc, 9432 Typ => Etype (Typ), 9433 Decl => Decl, 9434 Fnam => Fnam); 9435 return; 9436 end if; 9437 9438 Expr_Parameter := Make_Defining_Identifier (Loc, Name_E); 9439 Any := Make_Defining_Identifier (Loc, Name_A); 9440 Result_TC := Build_TypeCode_Call (Loc, Typ, Decls); 9441 9442 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any); 9443 9444 Spec := 9445 Make_Function_Specification (Loc, 9446 Defining_Unit_Name => Fnam, 9447 Parameter_Specifications => New_List ( 9448 Make_Parameter_Specification (Loc, 9449 Defining_Identifier => Expr_Parameter, 9450 Parameter_Type => New_Occurrence_Of (Typ, Loc))), 9451 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); 9452 Set_Etype (Expr_Parameter, Typ); 9453 9454 Any_Decl := 9455 Make_Object_Declaration (Loc, 9456 Defining_Identifier => Any, 9457 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); 9458 9459 Use_Opaque_Representation := False; 9460 9461 if Has_Stream_Attribute_Definition 9462 (Typ, TSS_Stream_Output, At_Any_Place => True) 9463 or else 9464 Has_Stream_Attribute_Definition 9465 (Typ, TSS_Stream_Write, At_Any_Place => True) 9466 then 9467 -- If user-defined stream attributes are specified for this 9468 -- type, use them and transmit data as an opaque sequence of 9469 -- stream elements. 9470 9471 Use_Opaque_Representation := True; 9472 9473 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then 9474 9475 -- Non-tagged derived type: convert to root type 9476 9477 declare 9478 Rt_Type : constant Entity_Id := Root_Type (Typ); 9479 Expr : constant Node_Id := 9480 OK_Convert_To 9481 (Rt_Type, 9482 New_Occurrence_Of (Expr_Parameter, Loc)); 9483 begin 9484 Set_Expression (Any_Decl, 9485 Build_To_Any_Call (Loc, Expr, Decls)); 9486 end; 9487 9488 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then 9489 9490 -- Non-tagged record type 9491 9492 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then 9493 declare 9494 Rt_Type : constant Entity_Id := Etype (Typ); 9495 Expr : constant Node_Id := 9496 OK_Convert_To (Rt_Type, 9497 New_Occurrence_Of (Expr_Parameter, Loc)); 9498 9499 begin 9500 Set_Expression 9501 (Any_Decl, Build_To_Any_Call (Loc, Expr, Decls)); 9502 end; 9503 9504 -- Comment needed here (and label on declare block ???) 9505 9506 else 9507 declare 9508 Disc : Entity_Id := Empty; 9509 Rdef : constant Node_Id := 9510 Type_Definition (Declaration_Node (Typ)); 9511 Counter : Int := 0; 9512 Elements : constant List_Id := New_List; 9513 9514 procedure TA_Rec_Add_Process_Element 9515 (Stmts : List_Id; 9516 Container : Node_Or_Entity_Id; 9517 Counter : in out Int; 9518 Rec : Entity_Id; 9519 Field : Node_Id); 9520 -- Processing routine for traversal below 9521 9522 procedure TA_Append_Record_Traversal is 9523 new Append_Record_Traversal 9524 (Rec => Expr_Parameter, 9525 Add_Process_Element => TA_Rec_Add_Process_Element); 9526 9527 -------------------------------- 9528 -- TA_Rec_Add_Process_Element -- 9529 -------------------------------- 9530 9531 procedure TA_Rec_Add_Process_Element 9532 (Stmts : List_Id; 9533 Container : Node_Or_Entity_Id; 9534 Counter : in out Int; 9535 Rec : Entity_Id; 9536 Field : Node_Id) 9537 is 9538 Field_Ref : Node_Id; 9539 9540 begin 9541 if Nkind (Field) = N_Defining_Identifier then 9542 9543 -- A regular component 9544 9545 Field_Ref := Make_Selected_Component (Loc, 9546 Prefix => New_Occurrence_Of (Rec, Loc), 9547 Selector_Name => New_Occurrence_Of (Field, Loc)); 9548 Set_Etype (Field_Ref, Etype (Field)); 9549 9550 Append_To (Stmts, 9551 Make_Procedure_Call_Statement (Loc, 9552 Name => 9553 New_Occurrence_Of ( 9554 RTE (RE_Add_Aggregate_Element), Loc), 9555 Parameter_Associations => New_List ( 9556 New_Occurrence_Of (Container, Loc), 9557 Build_To_Any_Call (Loc, Field_Ref, Decls)))); 9558 9559 else 9560 -- A variant part 9561 9562 Variant_Part : declare 9563 Variant : Node_Id; 9564 Struct_Counter : Int := 0; 9565 9566 Block_Decls : constant List_Id := New_List; 9567 Block_Stmts : constant List_Id := New_List; 9568 VP_Stmts : List_Id; 9569 9570 Alt_List : constant List_Id := New_List; 9571 Choice_List : List_Id; 9572 9573 Union_Any : constant Entity_Id := 9574 Make_Temporary (Loc, 'V'); 9575 9576 Struct_Any : constant Entity_Id := 9577 Make_Temporary (Loc, 'S'); 9578 9579 function Make_Discriminant_Reference 9580 return Node_Id; 9581 -- Build reference to the discriminant for this 9582 -- variant part. 9583 9584 --------------------------------- 9585 -- Make_Discriminant_Reference -- 9586 --------------------------------- 9587 9588 function Make_Discriminant_Reference 9589 return Node_Id 9590 is 9591 Nod : constant Node_Id := 9592 Make_Selected_Component (Loc, 9593 Prefix => Rec, 9594 Selector_Name => 9595 Chars (Name (Field))); 9596 begin 9597 Set_Etype (Nod, Etype (Name (Field))); 9598 return Nod; 9599 end Make_Discriminant_Reference; 9600 9601 -- Start of processing for Variant_Part 9602 9603 begin 9604 Append_To (Stmts, 9605 Make_Block_Statement (Loc, 9606 Declarations => 9607 Block_Decls, 9608 Handled_Statement_Sequence => 9609 Make_Handled_Sequence_Of_Statements (Loc, 9610 Statements => Block_Stmts))); 9611 9612 -- Declare variant part aggregate (Union_Any). 9613 -- Knowing the position of this VP in the 9614 -- variant record, we can fetch the VP typecode 9615 -- from Container. 9616 9617 Append_To (Block_Decls, 9618 Make_Object_Declaration (Loc, 9619 Defining_Identifier => Union_Any, 9620 Object_Definition => 9621 New_Occurrence_Of (RTE (RE_Any), Loc), 9622 Expression => 9623 Make_Function_Call (Loc, 9624 Name => New_Occurrence_Of ( 9625 RTE (RE_Create_Any), Loc), 9626 Parameter_Associations => New_List ( 9627 Make_Function_Call (Loc, 9628 Name => 9629 New_Occurrence_Of ( 9630 RTE (RE_Any_Member_Type), Loc), 9631 Parameter_Associations => New_List ( 9632 New_Occurrence_Of (Container, Loc), 9633 Make_Integer_Literal (Loc, 9634 Counter))))))); 9635 9636 -- Declare inner struct aggregate (which 9637 -- contains the components of this VP). 9638 9639 Append_To (Block_Decls, 9640 Make_Object_Declaration (Loc, 9641 Defining_Identifier => Struct_Any, 9642 Object_Definition => 9643 New_Occurrence_Of (RTE (RE_Any), Loc), 9644 Expression => 9645 Make_Function_Call (Loc, 9646 Name => New_Occurrence_Of ( 9647 RTE (RE_Create_Any), Loc), 9648 Parameter_Associations => New_List ( 9649 Make_Function_Call (Loc, 9650 Name => 9651 New_Occurrence_Of ( 9652 RTE (RE_Any_Member_Type), Loc), 9653 Parameter_Associations => New_List ( 9654 New_Occurrence_Of (Union_Any, Loc), 9655 Make_Integer_Literal (Loc, 9656 Uint_1))))))); 9657 9658 -- Build case statement 9659 9660 Append_To (Block_Stmts, 9661 Make_Case_Statement (Loc, 9662 Expression => Make_Discriminant_Reference, 9663 Alternatives => Alt_List)); 9664 9665 Variant := First_Non_Pragma (Variants (Field)); 9666 while Present (Variant) loop 9667 Choice_List := New_Copy_List_Tree 9668 (Discrete_Choices (Variant)); 9669 9670 VP_Stmts := New_List; 9671 9672 -- Append discriminant val to union aggregate 9673 9674 Append_To (VP_Stmts, 9675 Make_Procedure_Call_Statement (Loc, 9676 Name => 9677 New_Occurrence_Of ( 9678 RTE (RE_Add_Aggregate_Element), Loc), 9679 Parameter_Associations => New_List ( 9680 New_Occurrence_Of (Union_Any, Loc), 9681 Build_To_Any_Call 9682 (Loc, 9683 Make_Discriminant_Reference, 9684 Block_Decls)))); 9685 9686 -- Populate inner struct aggregate 9687 9688 -- Struct_Counter should be reset before 9689 -- handling a variant part. Indeed only one 9690 -- of the case statement alternatives will be 9691 -- executed at run time, so the counter must 9692 -- start at 0 for every case statement. 9693 9694 Struct_Counter := 0; 9695 9696 TA_Append_Record_Traversal 9697 (Stmts => VP_Stmts, 9698 Clist => Component_List (Variant), 9699 Container => Struct_Any, 9700 Counter => Struct_Counter); 9701 9702 -- Append inner struct to union aggregate 9703 9704 Append_To (VP_Stmts, 9705 Make_Procedure_Call_Statement (Loc, 9706 Name => 9707 New_Occurrence_Of 9708 (RTE (RE_Add_Aggregate_Element), Loc), 9709 Parameter_Associations => New_List ( 9710 New_Occurrence_Of (Union_Any, Loc), 9711 New_Occurrence_Of (Struct_Any, Loc)))); 9712 9713 -- Append union to outer aggregate 9714 9715 Append_To (VP_Stmts, 9716 Make_Procedure_Call_Statement (Loc, 9717 Name => 9718 New_Occurrence_Of 9719 (RTE (RE_Add_Aggregate_Element), Loc), 9720 Parameter_Associations => New_List ( 9721 New_Occurrence_Of (Container, Loc), 9722 New_Occurrence_Of 9723 (Union_Any, Loc)))); 9724 9725 Append_To (Alt_List, 9726 Make_Case_Statement_Alternative (Loc, 9727 Discrete_Choices => Choice_List, 9728 Statements => VP_Stmts)); 9729 9730 Next_Non_Pragma (Variant); 9731 end loop; 9732 end Variant_Part; 9733 end if; 9734 9735 Counter := Counter + 1; 9736 end TA_Rec_Add_Process_Element; 9737 9738 begin 9739 -- Records are encoded in a TC_STRUCT aggregate: 9740 9741 -- -- Outer aggregate (TC_STRUCT) 9742 -- | [discriminant1] 9743 -- | [discriminant2] 9744 -- | ... 9745 -- | 9746 -- | [component1] 9747 -- | [component2] 9748 -- | ... 9749 9750 -- A component can be a common component or variant part 9751 9752 -- A variant part is encoded as a TC_UNION aggregate: 9753 9754 -- -- Variant Part Aggregate (TC_UNION) 9755 -- | [discriminant choice for this Variant Part] 9756 -- | 9757 -- | -- Inner struct (TC_STRUCT) 9758 -- | | [component1] 9759 -- | | [component2] 9760 -- | | ... 9761 9762 -- Let's start by building the outer aggregate. First we 9763 -- construct Elements array containing all discriminants. 9764 9765 if Has_Discriminants (Typ) then 9766 Disc := First_Discriminant (Typ); 9767 while Present (Disc) loop 9768 declare 9769 Discriminant : constant Entity_Id := 9770 Make_Selected_Component (Loc, 9771 Prefix => 9772 Expr_Parameter, 9773 Selector_Name => 9774 Chars (Disc)); 9775 9776 begin 9777 Set_Etype (Discriminant, Etype (Disc)); 9778 9779 Append_To (Elements, 9780 Make_Component_Association (Loc, 9781 Choices => New_List ( 9782 Make_Integer_Literal (Loc, Counter)), 9783 Expression => 9784 Build_To_Any_Call (Loc, 9785 Discriminant, Decls))); 9786 end; 9787 9788 Counter := Counter + 1; 9789 Next_Discriminant (Disc); 9790 end loop; 9791 9792 else 9793 -- If there are no discriminants, we declare an empty 9794 -- Elements array. 9795 9796 declare 9797 Dummy_Any : constant Entity_Id := 9798 Make_Temporary (Loc, 'A'); 9799 9800 begin 9801 Append_To (Decls, 9802 Make_Object_Declaration (Loc, 9803 Defining_Identifier => Dummy_Any, 9804 Object_Definition => 9805 New_Occurrence_Of (RTE (RE_Any), Loc))); 9806 9807 Append_To (Elements, 9808 Make_Component_Association (Loc, 9809 Choices => New_List ( 9810 Make_Range (Loc, 9811 Low_Bound => 9812 Make_Integer_Literal (Loc, 1), 9813 High_Bound => 9814 Make_Integer_Literal (Loc, 0))), 9815 Expression => 9816 New_Occurrence_Of (Dummy_Any, Loc))); 9817 end; 9818 end if; 9819 9820 -- We build the result aggregate with discriminants 9821 -- as the first elements. 9822 9823 Set_Expression (Any_Decl, 9824 Make_Function_Call (Loc, 9825 Name => New_Occurrence_Of 9826 (RTE (RE_Any_Aggregate_Build), Loc), 9827 Parameter_Associations => New_List ( 9828 Result_TC, 9829 Make_Aggregate (Loc, 9830 Component_Associations => Elements)))); 9831 Result_TC := Empty; 9832 9833 -- Then we append all the components to the result 9834 -- aggregate. 9835 9836 TA_Append_Record_Traversal (Stms, 9837 Clist => Component_List (Rdef), 9838 Container => Any, 9839 Counter => Counter); 9840 end; 9841 end if; 9842 9843 elsif Is_Array_Type (Typ) then 9844 9845 -- Constrained and unconstrained array types 9846 9847 declare 9848 Constrained : constant Boolean := Is_Constrained (Typ); 9849 9850 procedure TA_Ary_Add_Process_Element 9851 (Stmts : List_Id; 9852 Any : Entity_Id; 9853 Counter : Entity_Id; 9854 Datum : Node_Id); 9855 9856 -------------------------------- 9857 -- TA_Ary_Add_Process_Element -- 9858 -------------------------------- 9859 9860 procedure TA_Ary_Add_Process_Element 9861 (Stmts : List_Id; 9862 Any : Entity_Id; 9863 Counter : Entity_Id; 9864 Datum : Node_Id) 9865 is 9866 pragma Unreferenced (Counter); 9867 9868 Element_Any : Node_Id; 9869 9870 begin 9871 if Etype (Datum) = RTE (RE_Any) then 9872 Element_Any := Datum; 9873 else 9874 Element_Any := Build_To_Any_Call (Loc, Datum, Decls); 9875 end if; 9876 9877 Append_To (Stmts, 9878 Make_Procedure_Call_Statement (Loc, 9879 Name => New_Occurrence_Of ( 9880 RTE (RE_Add_Aggregate_Element), Loc), 9881 Parameter_Associations => New_List ( 9882 New_Occurrence_Of (Any, Loc), 9883 Element_Any))); 9884 end TA_Ary_Add_Process_Element; 9885 9886 procedure Append_To_Any_Array_Iterator is 9887 new Append_Array_Traversal ( 9888 Subprogram => Fnam, 9889 Arry => Expr_Parameter, 9890 Indexes => New_List, 9891 Add_Process_Element => TA_Ary_Add_Process_Element); 9892 9893 Index : Node_Id; 9894 9895 begin 9896 Set_Expression (Any_Decl, 9897 Make_Function_Call (Loc, 9898 Name => 9899 New_Occurrence_Of (RTE (RE_Create_Any), Loc), 9900 Parameter_Associations => New_List (Result_TC))); 9901 Result_TC := Empty; 9902 9903 if not Constrained then 9904 Index := First_Index (Typ); 9905 for J in 1 .. Number_Dimensions (Typ) loop 9906 Append_To (Stms, 9907 Make_Procedure_Call_Statement (Loc, 9908 Name => 9909 New_Occurrence_Of ( 9910 RTE (RE_Add_Aggregate_Element), Loc), 9911 Parameter_Associations => New_List ( 9912 New_Occurrence_Of (Any, Loc), 9913 Build_To_Any_Call (Loc, 9914 OK_Convert_To (Etype (Index), 9915 Make_Attribute_Reference (Loc, 9916 Prefix => 9917 New_Occurrence_Of (Expr_Parameter, Loc), 9918 Attribute_Name => Name_First, 9919 Expressions => New_List ( 9920 Make_Integer_Literal (Loc, J)))), 9921 Decls)))); 9922 Next_Index (Index); 9923 end loop; 9924 end if; 9925 9926 Append_To_Any_Array_Iterator (Stms, Any); 9927 end; 9928 9929 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then 9930 9931 -- Integer types 9932 9933 Set_Expression (Any_Decl, 9934 Build_To_Any_Call (Loc, 9935 OK_Convert_To ( 9936 Find_Numeric_Representation (Typ), 9937 New_Occurrence_Of (Expr_Parameter, Loc)), 9938 Decls)); 9939 9940 else 9941 -- Default case, including tagged types: opaque representation 9942 9943 Use_Opaque_Representation := True; 9944 end if; 9945 9946 if Use_Opaque_Representation then 9947 declare 9948 Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); 9949 -- Stream used to store data representation produced by 9950 -- stream attribute. 9951 9952 begin 9953 -- Generate: 9954 -- Strm : aliased Buffer_Stream_Type; 9955 9956 Append_To (Decls, 9957 Make_Object_Declaration (Loc, 9958 Defining_Identifier => 9959 Strm, 9960 Aliased_Present => 9961 True, 9962 Object_Definition => 9963 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); 9964 9965 -- Generate: 9966 -- T'Output (Strm'Access, E); 9967 9968 Append_To (Stms, 9969 Make_Attribute_Reference (Loc, 9970 Prefix => New_Occurrence_Of (Typ, Loc), 9971 Attribute_Name => Name_Output, 9972 Expressions => New_List ( 9973 Make_Attribute_Reference (Loc, 9974 Prefix => New_Occurrence_Of (Strm, Loc), 9975 Attribute_Name => Name_Access), 9976 New_Occurrence_Of (Expr_Parameter, Loc)))); 9977 9978 -- Generate: 9979 -- BS_To_Any (Strm, A); 9980 9981 Append_To (Stms, 9982 Make_Procedure_Call_Statement (Loc, 9983 Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc), 9984 Parameter_Associations => New_List ( 9985 New_Occurrence_Of (Strm, Loc), 9986 New_Occurrence_Of (Any, Loc)))); 9987 9988 -- Generate: 9989 -- Release_Buffer (Strm); 9990 9991 Append_To (Stms, 9992 Make_Procedure_Call_Statement (Loc, 9993 Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), 9994 Parameter_Associations => New_List ( 9995 New_Occurrence_Of (Strm, Loc)))); 9996 end; 9997 end if; 9998 9999 Append_To (Decls, Any_Decl); 10000 10001 if Present (Result_TC) then 10002 Append_To (Stms, 10003 Make_Procedure_Call_Statement (Loc, 10004 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), 10005 Parameter_Associations => New_List ( 10006 New_Occurrence_Of (Any, Loc), 10007 Result_TC))); 10008 end if; 10009 10010 Append_To (Stms, 10011 Make_Simple_Return_Statement (Loc, 10012 Expression => New_Occurrence_Of (Any, Loc))); 10013 10014 Decl := 10015 Make_Subprogram_Body (Loc, 10016 Specification => Spec, 10017 Declarations => Decls, 10018 Handled_Statement_Sequence => 10019 Make_Handled_Sequence_Of_Statements (Loc, 10020 Statements => Stms)); 10021 end Build_To_Any_Function; 10022 10023 ------------------------- 10024 -- Build_TypeCode_Call -- 10025 ------------------------- 10026 10027 function Build_TypeCode_Call 10028 (Loc : Source_Ptr; 10029 Typ : Entity_Id; 10030 Decls : List_Id) return Node_Id 10031 is 10032 U_Type : Entity_Id := Underlying_Type (Typ); 10033 -- The full view, if Typ is private; the completion, 10034 -- if Typ is incomplete. 10035 10036 Fnam : Entity_Id := Empty; 10037 Lib_RE : RE_Id := RE_Null; 10038 Expr : Node_Id; 10039 10040 begin 10041 -- Special case System.PolyORB.Interface.Any: its primitives have 10042 -- not been set yet, so can't call Find_Inherited_TSS. 10043 10044 if Typ = RTE (RE_Any) then 10045 Fnam := RTE (RE_TC_A); 10046 10047 else 10048 -- First simple case where the TypeCode is present 10049 -- in the type's TSS. 10050 10051 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode); 10052 end if; 10053 10054 -- For the subtype representing a generic actual type, go to the 10055 -- actual type. 10056 10057 if Is_Generic_Actual_Type (U_Type) then 10058 U_Type := Underlying_Type (Base_Type (U_Type)); 10059 end if; 10060 10061 -- For a standard subtype, go to the base type 10062 10063 if Sloc (U_Type) <= Standard_Location then 10064 U_Type := Base_Type (U_Type); 10065 10066 -- For a user subtype, go to first subtype 10067 10068 elsif Comes_From_Source (U_Type) 10069 and then Nkind (Declaration_Node (U_Type)) 10070 = N_Subtype_Declaration 10071 then 10072 U_Type := First_Subtype (U_Type); 10073 end if; 10074 10075 if No (Fnam) then 10076 if U_Type = Standard_Boolean then 10077 Lib_RE := RE_TC_B; 10078 10079 elsif U_Type = Standard_Character then 10080 Lib_RE := RE_TC_C; 10081 10082 elsif U_Type = Standard_Wide_Character then 10083 Lib_RE := RE_TC_WC; 10084 10085 elsif U_Type = Standard_Wide_Wide_Character then 10086 Lib_RE := RE_TC_WWC; 10087 10088 -- Floating point types 10089 10090 elsif U_Type = Standard_Short_Float then 10091 Lib_RE := RE_TC_SF; 10092 10093 elsif U_Type = Standard_Float then 10094 Lib_RE := RE_TC_F; 10095 10096 elsif U_Type = Standard_Long_Float then 10097 Lib_RE := RE_TC_LF; 10098 10099 elsif U_Type = Standard_Long_Long_Float then 10100 Lib_RE := RE_TC_LLF; 10101 10102 -- Integer types (walk back to the base type) 10103 10104 elsif U_Type = RTE (RE_Integer_8) then 10105 Lib_RE := RE_TC_I8; 10106 10107 elsif U_Type = RTE (RE_Integer_16) then 10108 Lib_RE := RE_TC_I16; 10109 10110 elsif U_Type = RTE (RE_Integer_32) then 10111 Lib_RE := RE_TC_I32; 10112 10113 elsif U_Type = RTE (RE_Integer_64) then 10114 Lib_RE := RE_TC_I64; 10115 10116 -- Unsigned integer types 10117 10118 elsif U_Type = RTE (RE_Unsigned_8) then 10119 Lib_RE := RE_TC_U8; 10120 10121 elsif U_Type = RTE (RE_Unsigned_16) then 10122 Lib_RE := RE_TC_U16; 10123 10124 elsif U_Type = RTE (RE_Unsigned_32) then 10125 Lib_RE := RE_TC_U32; 10126 10127 elsif U_Type = RTE (RE_Unsigned_64) then 10128 Lib_RE := RE_TC_U64; 10129 10130 elsif Is_RTE (U_Type, RE_Unbounded_String) then 10131 Lib_RE := RE_TC_String; 10132 10133 -- Special DSA types 10134 10135 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then 10136 Lib_RE := RE_TC_A; 10137 10138 -- Other (non-primitive) types 10139 10140 else 10141 declare 10142 Decl : Entity_Id; 10143 begin 10144 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam); 10145 Append_To (Decls, Decl); 10146 end; 10147 end if; 10148 10149 if Lib_RE /= RE_Null then 10150 Fnam := RTE (Lib_RE); 10151 end if; 10152 end if; 10153 10154 -- Call the function 10155 10156 Expr := 10157 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc)); 10158 10159 -- Allow Expr to be used as arg to Build_To_Any_Call immediately 10160 10161 Set_Etype (Expr, RTE (RE_TypeCode)); 10162 10163 return Expr; 10164 end Build_TypeCode_Call; 10165 10166 ----------------------------- 10167 -- Build_TypeCode_Function -- 10168 ----------------------------- 10169 10170 procedure Build_TypeCode_Function 10171 (Loc : Source_Ptr; 10172 Typ : Entity_Id; 10173 Decl : out Node_Id; 10174 Fnam : out Entity_Id) 10175 is 10176 Spec : Node_Id; 10177 Decls : constant List_Id := New_List; 10178 Stms : constant List_Id := New_List; 10179 10180 TCNam : constant Entity_Id := 10181 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode); 10182 10183 Parameters : List_Id; 10184 10185 procedure Add_String_Parameter 10186 (S : String_Id; 10187 Parameter_List : List_Id); 10188 -- Add a literal for S to Parameters 10189 10190 procedure Add_TypeCode_Parameter 10191 (TC_Node : Node_Id; 10192 Parameter_List : List_Id); 10193 -- Add the typecode for Typ to Parameters 10194 10195 procedure Add_Long_Parameter 10196 (Expr_Node : Node_Id; 10197 Parameter_List : List_Id); 10198 -- Add a signed long integer expression to Parameters 10199 10200 procedure Initialize_Parameter_List 10201 (Name_String : String_Id; 10202 Repo_Id_String : String_Id; 10203 Parameter_List : out List_Id); 10204 -- Return a list that contains the first two parameters 10205 -- for a parameterized typecode: name and repository id. 10206 10207 function Make_Constructed_TypeCode 10208 (Kind : Entity_Id; 10209 Parameters : List_Id) return Node_Id; 10210 -- Call TC_Build with the given kind and parameters 10211 10212 procedure Return_Constructed_TypeCode (Kind : Entity_Id); 10213 -- Make a return statement that calls TC_Build with the given 10214 -- typecode kind, and the constructed parameters list. 10215 10216 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id); 10217 -- Return a typecode that is a TC_Alias for the given typecode 10218 10219 -------------------------- 10220 -- Add_String_Parameter -- 10221 -------------------------- 10222 10223 procedure Add_String_Parameter 10224 (S : String_Id; 10225 Parameter_List : List_Id) 10226 is 10227 begin 10228 Append_To (Parameter_List, 10229 Make_Function_Call (Loc, 10230 Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc), 10231 Parameter_Associations => New_List ( 10232 Make_String_Literal (Loc, S)))); 10233 end Add_String_Parameter; 10234 10235 ---------------------------- 10236 -- Add_TypeCode_Parameter -- 10237 ---------------------------- 10238 10239 procedure Add_TypeCode_Parameter 10240 (TC_Node : Node_Id; 10241 Parameter_List : List_Id) 10242 is 10243 begin 10244 Append_To (Parameter_List, 10245 Make_Function_Call (Loc, 10246 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc), 10247 Parameter_Associations => New_List (TC_Node))); 10248 end Add_TypeCode_Parameter; 10249 10250 ------------------------ 10251 -- Add_Long_Parameter -- 10252 ------------------------ 10253 10254 procedure Add_Long_Parameter 10255 (Expr_Node : Node_Id; 10256 Parameter_List : List_Id) 10257 is 10258 begin 10259 Append_To (Parameter_List, 10260 Make_Function_Call (Loc, 10261 Name => 10262 New_Occurrence_Of (RTE (RE_TA_I32), Loc), 10263 Parameter_Associations => New_List (Expr_Node))); 10264 end Add_Long_Parameter; 10265 10266 ------------------------------- 10267 -- Initialize_Parameter_List -- 10268 ------------------------------- 10269 10270 procedure Initialize_Parameter_List 10271 (Name_String : String_Id; 10272 Repo_Id_String : String_Id; 10273 Parameter_List : out List_Id) 10274 is 10275 begin 10276 Parameter_List := New_List; 10277 Add_String_Parameter (Name_String, Parameter_List); 10278 Add_String_Parameter (Repo_Id_String, Parameter_List); 10279 end Initialize_Parameter_List; 10280 10281 --------------------------- 10282 -- Return_Alias_TypeCode -- 10283 --------------------------- 10284 10285 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id) is 10286 begin 10287 Add_TypeCode_Parameter (Base_TypeCode, Parameters); 10288 Return_Constructed_TypeCode (RTE (RE_TC_Alias)); 10289 end Return_Alias_TypeCode; 10290 10291 ------------------------------- 10292 -- Make_Constructed_TypeCode -- 10293 ------------------------------- 10294 10295 function Make_Constructed_TypeCode 10296 (Kind : Entity_Id; 10297 Parameters : List_Id) return Node_Id 10298 is 10299 Constructed_TC : constant Node_Id := 10300 Make_Function_Call (Loc, 10301 Name => 10302 New_Occurrence_Of (RTE (RE_TC_Build), Loc), 10303 Parameter_Associations => New_List ( 10304 New_Occurrence_Of (Kind, Loc), 10305 Make_Aggregate (Loc, 10306 Expressions => Parameters))); 10307 begin 10308 Set_Etype (Constructed_TC, RTE (RE_TypeCode)); 10309 return Constructed_TC; 10310 end Make_Constructed_TypeCode; 10311 10312 --------------------------------- 10313 -- Return_Constructed_TypeCode -- 10314 --------------------------------- 10315 10316 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is 10317 begin 10318 Append_To (Stms, 10319 Make_Simple_Return_Statement (Loc, 10320 Expression => 10321 Make_Constructed_TypeCode (Kind, Parameters))); 10322 end Return_Constructed_TypeCode; 10323 10324 ------------------ 10325 -- Record types -- 10326 ------------------ 10327 10328 procedure TC_Rec_Add_Process_Element 10329 (Params : List_Id; 10330 Any : Entity_Id; 10331 Counter : in out Int; 10332 Rec : Entity_Id; 10333 Field : Node_Id); 10334 10335 procedure TC_Append_Record_Traversal is 10336 new Append_Record_Traversal ( 10337 Rec => Empty, 10338 Add_Process_Element => TC_Rec_Add_Process_Element); 10339 10340 -------------------------------- 10341 -- TC_Rec_Add_Process_Element -- 10342 -------------------------------- 10343 10344 procedure TC_Rec_Add_Process_Element 10345 (Params : List_Id; 10346 Any : Entity_Id; 10347 Counter : in out Int; 10348 Rec : Entity_Id; 10349 Field : Node_Id) 10350 is 10351 pragma Unreferenced (Any, Counter, Rec); 10352 10353 begin 10354 if Nkind (Field) = N_Defining_Identifier then 10355 10356 -- A regular component 10357 10358 Add_TypeCode_Parameter 10359 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params); 10360 Get_Name_String (Chars (Field)); 10361 Add_String_Parameter (String_From_Name_Buffer, Params); 10362 10363 else 10364 10365 -- A variant part 10366 10367 Variant_Part : declare 10368 Disc_Type : constant Entity_Id := Etype (Name (Field)); 10369 10370 Is_Enum : constant Boolean := 10371 Is_Enumeration_Type (Disc_Type); 10372 10373 Union_TC_Params : List_Id; 10374 10375 U_Name : constant Name_Id := 10376 New_External_Name (Chars (Typ), 'V', -1); 10377 10378 Name_Str : String_Id; 10379 Struct_TC_Params : List_Id; 10380 10381 Variant : Node_Id; 10382 Choice : Node_Id; 10383 Default : constant Node_Id := 10384 Make_Integer_Literal (Loc, -1); 10385 10386 Dummy_Counter : Int := 0; 10387 10388 Choice_Index : Int := 0; 10389 -- Index of current choice in TypeCode, used to identify 10390 -- it as the default choice if it is a "when others". 10391 10392 procedure Add_Params_For_Variant_Components; 10393 -- Add a struct TypeCode and a corresponding member name 10394 -- to the union parameter list. 10395 10396 -- Ordering of declarations is a complete mess in this 10397 -- area, it is supposed to be types/variables, then 10398 -- subprogram specs, then subprogram bodies ??? 10399 10400 --------------------------------------- 10401 -- Add_Params_For_Variant_Components -- 10402 --------------------------------------- 10403 10404 procedure Add_Params_For_Variant_Components is 10405 S_Name : constant Name_Id := 10406 New_External_Name (U_Name, 'S', -1); 10407 10408 begin 10409 Get_Name_String (S_Name); 10410 Name_Str := String_From_Name_Buffer; 10411 Initialize_Parameter_List 10412 (Name_Str, Name_Str, Struct_TC_Params); 10413 10414 -- Build struct parameters 10415 10416 TC_Append_Record_Traversal (Struct_TC_Params, 10417 Component_List (Variant), 10418 Empty, 10419 Dummy_Counter); 10420 10421 Add_TypeCode_Parameter 10422 (Make_Constructed_TypeCode 10423 (RTE (RE_TC_Struct), Struct_TC_Params), 10424 Union_TC_Params); 10425 10426 Add_String_Parameter (Name_Str, Union_TC_Params); 10427 end Add_Params_For_Variant_Components; 10428 10429 -- Start of processing for Variant_Part 10430 10431 begin 10432 Get_Name_String (U_Name); 10433 Name_Str := String_From_Name_Buffer; 10434 10435 Initialize_Parameter_List 10436 (Name_Str, Name_Str, Union_TC_Params); 10437 10438 -- Add union in enclosing parameter list 10439 10440 Add_TypeCode_Parameter 10441 (Make_Constructed_TypeCode 10442 (RTE (RE_TC_Union), Union_TC_Params), 10443 Params); 10444 10445 Add_String_Parameter (Name_Str, Params); 10446 10447 -- Build union parameters 10448 10449 Add_TypeCode_Parameter 10450 (Build_TypeCode_Call (Loc, Disc_Type, Decls), 10451 Union_TC_Params); 10452 10453 Add_Long_Parameter (Default, Union_TC_Params); 10454 10455 Variant := First_Non_Pragma (Variants (Field)); 10456 while Present (Variant) loop 10457 Choice := First (Discrete_Choices (Variant)); 10458 while Present (Choice) loop 10459 case Nkind (Choice) is 10460 when N_Range => 10461 declare 10462 L : constant Uint := 10463 Expr_Value (Low_Bound (Choice)); 10464 H : constant Uint := 10465 Expr_Value (High_Bound (Choice)); 10466 J : Uint := L; 10467 -- 3.8.1(8) guarantees that the bounds of 10468 -- this range are static. 10469 10470 Expr : Node_Id; 10471 10472 begin 10473 while J <= H loop 10474 if Is_Enum then 10475 Expr := Get_Enum_Lit_From_Pos 10476 (Disc_Type, J, Loc); 10477 else 10478 Expr := 10479 Make_Integer_Literal (Loc, J); 10480 end if; 10481 10482 Set_Etype (Expr, Disc_Type); 10483 Append_To (Union_TC_Params, 10484 Build_To_Any_Call (Loc, Expr, Decls)); 10485 10486 Add_Params_For_Variant_Components; 10487 J := J + Uint_1; 10488 end loop; 10489 10490 Choice_Index := 10491 Choice_Index + UI_To_Int (H - L) + 1; 10492 end; 10493 10494 when N_Others_Choice => 10495 10496 -- This variant has a default choice. We must 10497 -- therefore set the default parameter to the 10498 -- current choice index. This parameter is by 10499 -- construction the 4th in Union_TC_Params. 10500 10501 Replace 10502 (Pick (Union_TC_Params, 4), 10503 Make_Function_Call (Loc, 10504 Name => 10505 New_Occurrence_Of 10506 (RTE (RE_TA_I32), Loc), 10507 Parameter_Associations => 10508 New_List ( 10509 Make_Integer_Literal (Loc, 10510 Intval => Choice_Index)))); 10511 10512 -- Add a placeholder member label for the 10513 -- default case, which must have the 10514 -- discriminant type. 10515 10516 declare 10517 Exp : constant Node_Id := 10518 Make_Attribute_Reference (Loc, 10519 Prefix => New_Occurrence_Of 10520 (Disc_Type, Loc), 10521 Attribute_Name => Name_First); 10522 begin 10523 Set_Etype (Exp, Disc_Type); 10524 Append_To (Union_TC_Params, 10525 Build_To_Any_Call (Loc, Exp, Decls)); 10526 end; 10527 10528 Add_Params_For_Variant_Components; 10529 Choice_Index := Choice_Index + 1; 10530 10531 -- Case of an explicit choice 10532 10533 when others => 10534 declare 10535 Exp : constant Node_Id := 10536 New_Copy_Tree (Choice); 10537 begin 10538 Append_To (Union_TC_Params, 10539 Build_To_Any_Call (Loc, Exp, Decls)); 10540 end; 10541 10542 Add_Params_For_Variant_Components; 10543 Choice_Index := Choice_Index + 1; 10544 end case; 10545 10546 Next (Choice); 10547 end loop; 10548 10549 Next_Non_Pragma (Variant); 10550 end loop; 10551 end Variant_Part; 10552 end if; 10553 end TC_Rec_Add_Process_Element; 10554 10555 Type_Name_Str : String_Id; 10556 Type_Repo_Id_Str : String_Id; 10557 10558 -- Start of processing for Build_TypeCode_Function 10559 10560 begin 10561 -- For a derived type, we can't go past the base type (to the 10562 -- parent type) here, because that would cause the attribute's 10563 -- formal parameter to have the wrong type; hence the Base_Type 10564 -- check here. 10565 10566 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then 10567 Build_TypeCode_Function 10568 (Loc => Loc, 10569 Typ => Etype (Typ), 10570 Decl => Decl, 10571 Fnam => Fnam); 10572 return; 10573 end if; 10574 10575 Fnam := TCNam; 10576 10577 Spec := 10578 Make_Function_Specification (Loc, 10579 Defining_Unit_Name => Fnam, 10580 Parameter_Specifications => Empty_List, 10581 Result_Definition => 10582 New_Occurrence_Of (RTE (RE_TypeCode), Loc)); 10583 10584 Build_Name_And_Repository_Id (Typ, 10585 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str); 10586 10587 Initialize_Parameter_List 10588 (Type_Name_Str, Type_Repo_Id_Str, Parameters); 10589 10590 if Has_Stream_Attribute_Definition 10591 (Typ, TSS_Stream_Output, At_Any_Place => True) 10592 or else 10593 Has_Stream_Attribute_Definition 10594 (Typ, TSS_Stream_Write, At_Any_Place => True) 10595 then 10596 -- If user-defined stream attributes are specified for this 10597 -- type, use them and transmit data as an opaque sequence of 10598 -- stream elements. 10599 10600 Return_Alias_TypeCode 10601 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); 10602 10603 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then 10604 Return_Alias_TypeCode ( 10605 Build_TypeCode_Call (Loc, Etype (Typ), Decls)); 10606 10607 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then 10608 Return_Alias_TypeCode ( 10609 Build_TypeCode_Call (Loc, 10610 Find_Numeric_Representation (Typ), Decls)); 10611 10612 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then 10613 10614 -- Record typecodes are encoded as follows: 10615 -- -- TC_STRUCT 10616 -- | 10617 -- | [Name] 10618 -- | [Repository Id] 10619 -- 10620 -- Then for each discriminant: 10621 -- 10622 -- | [Discriminant Type Code] 10623 -- | [Discriminant Name] 10624 -- | ... 10625 -- 10626 -- Then for each component: 10627 -- 10628 -- | [Component Type Code] 10629 -- | [Component Name] 10630 -- | ... 10631 -- 10632 -- Variants components type codes are encoded as follows: 10633 -- -- TC_UNION 10634 -- | 10635 -- | [Name] 10636 -- | [Repository Id] 10637 -- | [Discriminant Type Code] 10638 -- | [Index of Default Variant Part or -1 for no default] 10639 -- 10640 -- Then for each Variant Part : 10641 -- 10642 -- | [VP Label] 10643 -- | 10644 -- | -- TC_STRUCT 10645 -- | | [Variant Part Name] 10646 -- | | [Variant Part Repository Id] 10647 -- | | 10648 -- | Then for each VP component: 10649 -- | | [VP component Typecode] 10650 -- | | [VP component Name] 10651 -- | | ... 10652 -- | -- 10653 -- | 10654 -- | [VP Name] 10655 10656 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then 10657 Return_Alias_TypeCode 10658 (Build_TypeCode_Call (Loc, Etype (Typ), Decls)); 10659 10660 else 10661 declare 10662 Disc : Entity_Id := Empty; 10663 Rdef : constant Node_Id := 10664 Type_Definition (Declaration_Node (Typ)); 10665 Dummy_Counter : Int := 0; 10666 10667 begin 10668 -- Construct the discriminants typecodes 10669 10670 if Has_Discriminants (Typ) then 10671 Disc := First_Discriminant (Typ); 10672 end if; 10673 10674 while Present (Disc) loop 10675 Add_TypeCode_Parameter ( 10676 Build_TypeCode_Call (Loc, Etype (Disc), Decls), 10677 Parameters); 10678 Get_Name_String (Chars (Disc)); 10679 Add_String_Parameter ( 10680 String_From_Name_Buffer, 10681 Parameters); 10682 Next_Discriminant (Disc); 10683 end loop; 10684 10685 -- then the components typecodes 10686 10687 TC_Append_Record_Traversal 10688 (Parameters, Component_List (Rdef), 10689 Empty, Dummy_Counter); 10690 Return_Constructed_TypeCode (RTE (RE_TC_Struct)); 10691 end; 10692 end if; 10693 10694 elsif Is_Array_Type (Typ) then 10695 declare 10696 Ndim : constant Pos := Number_Dimensions (Typ); 10697 Inner_TypeCode : Node_Id; 10698 Constrained : constant Boolean := Is_Constrained (Typ); 10699 Indx : Node_Id := First_Index (Typ); 10700 10701 begin 10702 Inner_TypeCode := 10703 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls); 10704 10705 for J in 1 .. Ndim loop 10706 if Constrained then 10707 Inner_TypeCode := Make_Constructed_TypeCode 10708 (RTE (RE_TC_Array), New_List ( 10709 Build_To_Any_Call (Loc, 10710 OK_Convert_To (RTE (RE_Unsigned_32), 10711 Make_Attribute_Reference (Loc, 10712 Prefix => New_Occurrence_Of (Typ, Loc), 10713 Attribute_Name => Name_Length, 10714 Expressions => New_List ( 10715 Make_Integer_Literal (Loc, 10716 Intval => Ndim - J + 1)))), 10717 Decls), 10718 Build_To_Any_Call (Loc, Inner_TypeCode, Decls))); 10719 10720 else 10721 -- Unconstrained case: add low bound for each 10722 -- dimension. 10723 10724 Add_TypeCode_Parameter 10725 (Build_TypeCode_Call (Loc, Etype (Indx), Decls), 10726 Parameters); 10727 Get_Name_String (New_External_Name ('L', J)); 10728 Add_String_Parameter ( 10729 String_From_Name_Buffer, 10730 Parameters); 10731 Next_Index (Indx); 10732 10733 Inner_TypeCode := Make_Constructed_TypeCode 10734 (RTE (RE_TC_Sequence), New_List ( 10735 Build_To_Any_Call (Loc, 10736 OK_Convert_To (RTE (RE_Unsigned_32), 10737 Make_Integer_Literal (Loc, 0)), 10738 Decls), 10739 Build_To_Any_Call (Loc, Inner_TypeCode, Decls))); 10740 end if; 10741 end loop; 10742 10743 if Constrained then 10744 Return_Alias_TypeCode (Inner_TypeCode); 10745 else 10746 Add_TypeCode_Parameter (Inner_TypeCode, Parameters); 10747 Start_String; 10748 Store_String_Char ('V'); 10749 Add_String_Parameter (End_String, Parameters); 10750 Return_Constructed_TypeCode (RTE (RE_TC_Struct)); 10751 end if; 10752 end; 10753 10754 else 10755 -- Default: type is represented as an opaque sequence of bytes 10756 10757 Return_Alias_TypeCode 10758 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); 10759 end if; 10760 10761 Decl := 10762 Make_Subprogram_Body (Loc, 10763 Specification => Spec, 10764 Declarations => Decls, 10765 Handled_Statement_Sequence => 10766 Make_Handled_Sequence_Of_Statements (Loc, 10767 Statements => Stms)); 10768 end Build_TypeCode_Function; 10769 10770 --------------------------------- 10771 -- Find_Numeric_Representation -- 10772 --------------------------------- 10773 10774 function Find_Numeric_Representation 10775 (Typ : Entity_Id) return Entity_Id 10776 is 10777 FST : constant Entity_Id := First_Subtype (Typ); 10778 P_Size : constant Uint := Esize (FST); 10779 10780 begin 10781 -- Special case: for Stream_Element_Offset and Storage_Offset, 10782 -- always force transmission as a 64-bit value. 10783 10784 if Is_RTE (FST, RE_Stream_Element_Offset) 10785 or else 10786 Is_RTE (FST, RE_Storage_Offset) 10787 then 10788 return RTE (RE_Unsigned_64); 10789 end if; 10790 10791 if Is_Unsigned_Type (Typ) then 10792 if P_Size <= 8 then 10793 return RTE (RE_Unsigned_8); 10794 10795 elsif P_Size <= 16 then 10796 return RTE (RE_Unsigned_16); 10797 10798 elsif P_Size <= 32 then 10799 return RTE (RE_Unsigned_32); 10800 10801 else 10802 return RTE (RE_Unsigned_64); 10803 end if; 10804 10805 elsif Is_Integer_Type (Typ) then 10806 if P_Size <= 8 then 10807 return RTE (RE_Integer_8); 10808 10809 elsif P_Size <= Standard_Short_Integer_Size then 10810 return RTE (RE_Integer_16); 10811 10812 elsif P_Size <= Standard_Integer_Size then 10813 return RTE (RE_Integer_32); 10814 10815 else 10816 return RTE (RE_Integer_64); 10817 end if; 10818 10819 elsif Is_Floating_Point_Type (Typ) then 10820 if P_Size <= Standard_Short_Float_Size then 10821 return Standard_Short_Float; 10822 10823 elsif P_Size <= Standard_Float_Size then 10824 return Standard_Float; 10825 10826 elsif P_Size <= Standard_Long_Float_Size then 10827 return Standard_Long_Float; 10828 10829 else 10830 return Standard_Long_Long_Float; 10831 end if; 10832 10833 else 10834 raise Program_Error; 10835 end if; 10836 10837 -- TBD: fixed point types??? 10838 -- TBverified numeric types with a biased representation??? 10839 10840 end Find_Numeric_Representation; 10841 10842 --------------------------- 10843 -- Append_Array_Traversal -- 10844 --------------------------- 10845 10846 procedure Append_Array_Traversal 10847 (Stmts : List_Id; 10848 Any : Entity_Id; 10849 Counter : Entity_Id := Empty; 10850 Depth : Pos := 1) 10851 is 10852 Loc : constant Source_Ptr := Sloc (Subprogram); 10853 Typ : constant Entity_Id := Etype (Arry); 10854 Constrained : constant Boolean := Is_Constrained (Typ); 10855 Ndim : constant Pos := Number_Dimensions (Typ); 10856 10857 Inner_Any, Inner_Counter : Entity_Id; 10858 10859 Loop_Stm : Node_Id; 10860 Inner_Stmts : constant List_Id := New_List; 10861 10862 begin 10863 if Depth > Ndim then 10864 10865 -- Processing for one element of an array 10866 10867 declare 10868 Element_Expr : constant Node_Id := 10869 Make_Indexed_Component (Loc, 10870 New_Occurrence_Of (Arry, Loc), 10871 Indexes); 10872 begin 10873 Set_Etype (Element_Expr, Component_Type (Typ)); 10874 Add_Process_Element (Stmts, 10875 Any => Any, 10876 Counter => Counter, 10877 Datum => Element_Expr); 10878 end; 10879 10880 return; 10881 end if; 10882 10883 Append_To (Indexes, 10884 Make_Identifier (Loc, New_External_Name ('L', Depth))); 10885 10886 if not Constrained or else Depth > 1 then 10887 Inner_Any := Make_Defining_Identifier (Loc, 10888 New_External_Name ('A', Depth)); 10889 Set_Etype (Inner_Any, RTE (RE_Any)); 10890 else 10891 Inner_Any := Empty; 10892 end if; 10893 10894 if Present (Counter) then 10895 Inner_Counter := Make_Defining_Identifier (Loc, 10896 New_External_Name ('J', Depth)); 10897 else 10898 Inner_Counter := Empty; 10899 end if; 10900 10901 declare 10902 Loop_Any : Node_Id := Inner_Any; 10903 10904 begin 10905 -- For the first dimension of a constrained array, we add 10906 -- elements directly in the corresponding Any; there is no 10907 -- intervening inner Any. 10908 10909 if No (Loop_Any) then 10910 Loop_Any := Any; 10911 end if; 10912 10913 Append_Array_Traversal (Inner_Stmts, 10914 Any => Loop_Any, 10915 Counter => Inner_Counter, 10916 Depth => Depth + 1); 10917 end; 10918 10919 Loop_Stm := 10920 Make_Implicit_Loop_Statement (Subprogram, 10921 Iteration_Scheme => 10922 Make_Iteration_Scheme (Loc, 10923 Loop_Parameter_Specification => 10924 Make_Loop_Parameter_Specification (Loc, 10925 Defining_Identifier => 10926 Make_Defining_Identifier (Loc, 10927 Chars => New_External_Name ('L', Depth)), 10928 10929 Discrete_Subtype_Definition => 10930 Make_Attribute_Reference (Loc, 10931 Prefix => New_Occurrence_Of (Arry, Loc), 10932 Attribute_Name => Name_Range, 10933 10934 Expressions => New_List ( 10935 Make_Integer_Literal (Loc, Depth))))), 10936 Statements => Inner_Stmts); 10937 10938 declare 10939 Decls : constant List_Id := New_List; 10940 Dimen_Stmts : constant List_Id := New_List; 10941 Length_Node : Node_Id; 10942 10943 Inner_Any_TypeCode : constant Entity_Id := 10944 Make_Defining_Identifier (Loc, 10945 New_External_Name ('T', Depth)); 10946 10947 Inner_Any_TypeCode_Expr : Node_Id; 10948 10949 begin 10950 if Depth = 1 then 10951 if Constrained then 10952 Inner_Any_TypeCode_Expr := 10953 Make_Function_Call (Loc, 10954 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc), 10955 Parameter_Associations => New_List ( 10956 New_Occurrence_Of (Any, Loc))); 10957 10958 else 10959 Inner_Any_TypeCode_Expr := 10960 Make_Function_Call (Loc, 10961 Name => 10962 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc), 10963 Parameter_Associations => New_List ( 10964 New_Occurrence_Of (Any, Loc), 10965 Make_Integer_Literal (Loc, Ndim))); 10966 end if; 10967 10968 else 10969 Inner_Any_TypeCode_Expr := 10970 Make_Function_Call (Loc, 10971 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc), 10972 Parameter_Associations => New_List ( 10973 Make_Identifier (Loc, 10974 Chars => New_External_Name ('T', Depth - 1)))); 10975 end if; 10976 10977 Append_To (Decls, 10978 Make_Object_Declaration (Loc, 10979 Defining_Identifier => Inner_Any_TypeCode, 10980 Constant_Present => True, 10981 Object_Definition => New_Occurrence_Of ( 10982 RTE (RE_TypeCode), Loc), 10983 Expression => Inner_Any_TypeCode_Expr)); 10984 10985 if Present (Inner_Any) then 10986 Append_To (Decls, 10987 Make_Object_Declaration (Loc, 10988 Defining_Identifier => Inner_Any, 10989 Object_Definition => 10990 New_Occurrence_Of (RTE (RE_Any), Loc), 10991 Expression => 10992 Make_Function_Call (Loc, 10993 Name => 10994 New_Occurrence_Of ( 10995 RTE (RE_Create_Any), Loc), 10996 Parameter_Associations => New_List ( 10997 New_Occurrence_Of (Inner_Any_TypeCode, Loc))))); 10998 end if; 10999 11000 if Present (Inner_Counter) then 11001 Append_To (Decls, 11002 Make_Object_Declaration (Loc, 11003 Defining_Identifier => Inner_Counter, 11004 Object_Definition => 11005 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc), 11006 Expression => 11007 Make_Integer_Literal (Loc, 0))); 11008 end if; 11009 11010 if not Constrained then 11011 Length_Node := Make_Attribute_Reference (Loc, 11012 Prefix => New_Occurrence_Of (Arry, Loc), 11013 Attribute_Name => Name_Length, 11014 Expressions => 11015 New_List (Make_Integer_Literal (Loc, Depth))); 11016 Set_Etype (Length_Node, RTE (RE_Unsigned_32)); 11017 11018 Add_Process_Element (Dimen_Stmts, 11019 Datum => Length_Node, 11020 Any => Inner_Any, 11021 Counter => Inner_Counter); 11022 end if; 11023 11024 -- Loop_Stm does appropriate processing for each element 11025 -- of Inner_Any. 11026 11027 Append_To (Dimen_Stmts, Loop_Stm); 11028 11029 -- Link outer and inner any 11030 11031 if Present (Inner_Any) then 11032 Add_Process_Element (Dimen_Stmts, 11033 Any => Any, 11034 Counter => Counter, 11035 Datum => New_Occurrence_Of (Inner_Any, Loc)); 11036 end if; 11037 11038 Append_To (Stmts, 11039 Make_Block_Statement (Loc, 11040 Declarations => 11041 Decls, 11042 Handled_Statement_Sequence => 11043 Make_Handled_Sequence_Of_Statements (Loc, 11044 Statements => Dimen_Stmts))); 11045 end; 11046 end Append_Array_Traversal; 11047 11048 ------------------------------- 11049 -- Make_Helper_Function_Name -- 11050 ------------------------------- 11051 11052 function Make_Helper_Function_Name 11053 (Loc : Source_Ptr; 11054 Typ : Entity_Id; 11055 Nam : Name_Id) return Entity_Id 11056 is 11057 begin 11058 declare 11059 Serial : Nat := 0; 11060 -- For tagged types that aren't frozen yet, generate the helper 11061 -- under its canonical name so that it matches the primitive 11062 -- spec. For all other cases, we use a serialized name so that 11063 -- multiple generations of the same procedure do not clash. 11064 11065 begin 11066 if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then 11067 null; 11068 else 11069 Serial := Increment_Serial_Number; 11070 end if; 11071 11072 -- Use prefixed underscore to avoid potential clash with user 11073 -- identifier (we use attribute names for Nam). 11074 11075 return 11076 Make_Defining_Identifier (Loc, 11077 Chars => 11078 New_External_Name 11079 (Related_Id => Nam, 11080 Suffix => ' ', 11081 Suffix_Index => Serial, 11082 Prefix => '_')); 11083 end; 11084 end Make_Helper_Function_Name; 11085 end Helpers; 11086 11087 ----------------------------------- 11088 -- Reserve_NamingContext_Methods -- 11089 ----------------------------------- 11090 11091 procedure Reserve_NamingContext_Methods is 11092 Str_Resolve : constant String := "resolve"; 11093 begin 11094 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve; 11095 Name_Len := Str_Resolve'Length; 11096 Overload_Counter_Table.Set (Name_Find, 1); 11097 end Reserve_NamingContext_Methods; 11098 11099 ----------------------- 11100 -- RPC_Receiver_Decl -- 11101 ----------------------- 11102 11103 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is 11104 Loc : constant Source_Ptr := Sloc (RACW_Type); 11105 begin 11106 return 11107 Make_Object_Declaration (Loc, 11108 Defining_Identifier => Make_Temporary (Loc, 'R'), 11109 Aliased_Present => True, 11110 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); 11111 end RPC_Receiver_Decl; 11112 11113 end PolyORB_Support; 11114 11115 ------------------------------- 11116 -- RACW_Type_Is_Asynchronous -- 11117 ------------------------------- 11118 11119 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is 11120 Asynchronous_Flag : constant Entity_Id := 11121 Asynchronous_Flags_Table.Get (RACW_Type); 11122 begin 11123 Replace (Expression (Parent (Asynchronous_Flag)), 11124 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag))); 11125 end RACW_Type_Is_Asynchronous; 11126 11127 ------------------------- 11128 -- RCI_Package_Locator -- 11129 ------------------------- 11130 11131 function RCI_Package_Locator 11132 (Loc : Source_Ptr; 11133 Package_Spec : Node_Id) return Node_Id 11134 is 11135 Inst : Node_Id; 11136 Pkg_Name : String_Id; 11137 11138 begin 11139 Get_Library_Unit_Name_String (Package_Spec); 11140 Pkg_Name := String_From_Name_Buffer; 11141 Inst := 11142 Make_Package_Instantiation (Loc, 11143 Defining_Unit_Name => Make_Temporary (Loc, 'R'), 11144 11145 Name => 11146 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc), 11147 11148 Generic_Associations => New_List ( 11149 Make_Generic_Association (Loc, 11150 Selector_Name => 11151 Make_Identifier (Loc, Name_RCI_Name), 11152 Explicit_Generic_Actual_Parameter => 11153 Make_String_Literal (Loc, 11154 Strval => Pkg_Name)), 11155 11156 Make_Generic_Association (Loc, 11157 Selector_Name => 11158 Make_Identifier (Loc, Name_Version), 11159 Explicit_Generic_Actual_Parameter => 11160 Make_Attribute_Reference (Loc, 11161 Prefix => 11162 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc), 11163 Attribute_Name => 11164 Name_Version)))); 11165 11166 RCI_Locator_Table.Set 11167 (Defining_Unit_Name (Package_Spec), 11168 Defining_Unit_Name (Inst)); 11169 return Inst; 11170 end RCI_Package_Locator; 11171 11172 ----------------------------------------------- 11173 -- Remote_Types_Tagged_Full_View_Encountered -- 11174 ----------------------------------------------- 11175 11176 procedure Remote_Types_Tagged_Full_View_Encountered 11177 (Full_View : Entity_Id) 11178 is 11179 Stub_Elements : constant Stub_Structure := 11180 Stubs_Table.Get (Full_View); 11181 11182 begin 11183 -- For an RACW encountered before the freeze point of its designated 11184 -- type, the stub type is generated at the point of the RACW declaration 11185 -- but the primitives are generated only once the designated type is 11186 -- frozen. That freeze can occur in another scope, for example when the 11187 -- RACW is declared in a nested package. In that case we need to 11188 -- reestablish the stub type's scope prior to generating its primitive 11189 -- operations. 11190 11191 if Stub_Elements /= Empty_Stub_Structure then 11192 declare 11193 Saved_Scope : constant Entity_Id := Current_Scope; 11194 Stubs_Scope : constant Entity_Id := 11195 Scope (Stub_Elements.Stub_Type); 11196 11197 begin 11198 if Current_Scope /= Stubs_Scope then 11199 Push_Scope (Stubs_Scope); 11200 end if; 11201 11202 Add_RACW_Primitive_Declarations_And_Bodies 11203 (Full_View, 11204 Stub_Elements.RPC_Receiver_Decl, 11205 Stub_Elements.Body_Decls); 11206 11207 if Current_Scope /= Saved_Scope then 11208 Pop_Scope; 11209 end if; 11210 end; 11211 end if; 11212 end Remote_Types_Tagged_Full_View_Encountered; 11213 11214 ------------------- 11215 -- Scope_Of_Spec -- 11216 ------------------- 11217 11218 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is 11219 Unit_Name : Node_Id; 11220 11221 begin 11222 Unit_Name := Defining_Unit_Name (Spec); 11223 while Nkind (Unit_Name) /= N_Defining_Identifier loop 11224 Unit_Name := Defining_Identifier (Unit_Name); 11225 end loop; 11226 11227 return Unit_Name; 11228 end Scope_Of_Spec; 11229 11230 ---------------------- 11231 -- Set_Renaming_TSS -- 11232 ---------------------- 11233 11234 procedure Set_Renaming_TSS 11235 (Typ : Entity_Id; 11236 Nam : Entity_Id; 11237 TSS_Nam : TSS_Name_Type) 11238 is 11239 Loc : constant Source_Ptr := Sloc (Nam); 11240 Spec : constant Node_Id := Parent (Nam); 11241 11242 TSS_Node : constant Node_Id := 11243 Make_Subprogram_Renaming_Declaration (Loc, 11244 Specification => 11245 Copy_Specification (Loc, 11246 Spec => Spec, 11247 New_Name => Make_TSS_Name (Typ, TSS_Nam)), 11248 Name => New_Occurrence_Of (Nam, Loc)); 11249 11250 Snam : constant Entity_Id := 11251 Defining_Unit_Name (Specification (TSS_Node)); 11252 11253 begin 11254 if Nkind (Spec) = N_Function_Specification then 11255 Set_Ekind (Snam, E_Function); 11256 Set_Etype (Snam, Entity (Result_Definition (Spec))); 11257 else 11258 Set_Ekind (Snam, E_Procedure); 11259 Set_Etype (Snam, Standard_Void_Type); 11260 end if; 11261 11262 Set_TSS (Typ, Snam); 11263 end Set_Renaming_TSS; 11264 11265 ---------------------------------------------- 11266 -- Specific_Add_Obj_RPC_Receiver_Completion -- 11267 ---------------------------------------------- 11268 11269 procedure Specific_Add_Obj_RPC_Receiver_Completion 11270 (Loc : Source_Ptr; 11271 Decls : List_Id; 11272 RPC_Receiver : Entity_Id; 11273 Stub_Elements : Stub_Structure) 11274 is 11275 begin 11276 case Get_PCS_Name is 11277 when Name_PolyORB_DSA => 11278 PolyORB_Support.Add_Obj_RPC_Receiver_Completion 11279 (Loc, Decls, RPC_Receiver, Stub_Elements); 11280 when others => 11281 GARLIC_Support.Add_Obj_RPC_Receiver_Completion 11282 (Loc, Decls, RPC_Receiver, Stub_Elements); 11283 end case; 11284 end Specific_Add_Obj_RPC_Receiver_Completion; 11285 11286 -------------------------------- 11287 -- Specific_Add_RACW_Features -- 11288 -------------------------------- 11289 11290 procedure Specific_Add_RACW_Features 11291 (RACW_Type : Entity_Id; 11292 Desig : Entity_Id; 11293 Stub_Type : Entity_Id; 11294 Stub_Type_Access : Entity_Id; 11295 RPC_Receiver_Decl : Node_Id; 11296 Body_Decls : List_Id) 11297 is 11298 begin 11299 case Get_PCS_Name is 11300 when Name_PolyORB_DSA => 11301 PolyORB_Support.Add_RACW_Features 11302 (RACW_Type, 11303 Desig, 11304 Stub_Type, 11305 Stub_Type_Access, 11306 RPC_Receiver_Decl, 11307 Body_Decls); 11308 11309 when others => 11310 GARLIC_Support.Add_RACW_Features 11311 (RACW_Type, 11312 Stub_Type, 11313 Stub_Type_Access, 11314 RPC_Receiver_Decl, 11315 Body_Decls); 11316 end case; 11317 end Specific_Add_RACW_Features; 11318 11319 -------------------------------- 11320 -- Specific_Add_RAST_Features -- 11321 -------------------------------- 11322 11323 procedure Specific_Add_RAST_Features 11324 (Vis_Decl : Node_Id; 11325 RAS_Type : Entity_Id) 11326 is 11327 begin 11328 case Get_PCS_Name is 11329 when Name_PolyORB_DSA => 11330 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type); 11331 when others => 11332 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type); 11333 end case; 11334 end Specific_Add_RAST_Features; 11335 11336 -------------------------------------------------- 11337 -- Specific_Add_Receiving_Stubs_To_Declarations -- 11338 -------------------------------------------------- 11339 11340 procedure Specific_Add_Receiving_Stubs_To_Declarations 11341 (Pkg_Spec : Node_Id; 11342 Decls : List_Id; 11343 Stmts : List_Id) 11344 is 11345 begin 11346 case Get_PCS_Name is 11347 when Name_PolyORB_DSA => 11348 PolyORB_Support.Add_Receiving_Stubs_To_Declarations 11349 (Pkg_Spec, Decls, Stmts); 11350 when others => 11351 GARLIC_Support.Add_Receiving_Stubs_To_Declarations 11352 (Pkg_Spec, Decls, Stmts); 11353 end case; 11354 end Specific_Add_Receiving_Stubs_To_Declarations; 11355 11356 ------------------------------------------ 11357 -- Specific_Build_General_Calling_Stubs -- 11358 ------------------------------------------ 11359 11360 procedure Specific_Build_General_Calling_Stubs 11361 (Decls : List_Id; 11362 Statements : List_Id; 11363 Target : RPC_Target; 11364 Subprogram_Id : Node_Id; 11365 Asynchronous : Node_Id := Empty; 11366 Is_Known_Asynchronous : Boolean := False; 11367 Is_Known_Non_Asynchronous : Boolean := False; 11368 Is_Function : Boolean; 11369 Spec : Node_Id; 11370 Stub_Type : Entity_Id := Empty; 11371 RACW_Type : Entity_Id := Empty; 11372 Nod : Node_Id) 11373 is 11374 begin 11375 case Get_PCS_Name is 11376 when Name_PolyORB_DSA => 11377 PolyORB_Support.Build_General_Calling_Stubs 11378 (Decls, 11379 Statements, 11380 Target.Object, 11381 Subprogram_Id, 11382 Asynchronous, 11383 Is_Known_Asynchronous, 11384 Is_Known_Non_Asynchronous, 11385 Is_Function, 11386 Spec, 11387 Stub_Type, 11388 RACW_Type, 11389 Nod); 11390 11391 when others => 11392 GARLIC_Support.Build_General_Calling_Stubs 11393 (Decls, 11394 Statements, 11395 Target.Partition, 11396 Target.RPC_Receiver, 11397 Subprogram_Id, 11398 Asynchronous, 11399 Is_Known_Asynchronous, 11400 Is_Known_Non_Asynchronous, 11401 Is_Function, 11402 Spec, 11403 Stub_Type, 11404 RACW_Type, 11405 Nod); 11406 end case; 11407 end Specific_Build_General_Calling_Stubs; 11408 11409 -------------------------------------- 11410 -- Specific_Build_RPC_Receiver_Body -- 11411 -------------------------------------- 11412 11413 procedure Specific_Build_RPC_Receiver_Body 11414 (RPC_Receiver : Entity_Id; 11415 Request : out Entity_Id; 11416 Subp_Id : out Entity_Id; 11417 Subp_Index : out Entity_Id; 11418 Stmts : out List_Id; 11419 Decl : out Node_Id) 11420 is 11421 begin 11422 case Get_PCS_Name is 11423 when Name_PolyORB_DSA => 11424 PolyORB_Support.Build_RPC_Receiver_Body 11425 (RPC_Receiver, 11426 Request, 11427 Subp_Id, 11428 Subp_Index, 11429 Stmts, 11430 Decl); 11431 11432 when others => 11433 GARLIC_Support.Build_RPC_Receiver_Body 11434 (RPC_Receiver, 11435 Request, 11436 Subp_Id, 11437 Subp_Index, 11438 Stmts, 11439 Decl); 11440 end case; 11441 end Specific_Build_RPC_Receiver_Body; 11442 11443 -------------------------------- 11444 -- Specific_Build_Stub_Target -- 11445 -------------------------------- 11446 11447 function Specific_Build_Stub_Target 11448 (Loc : Source_Ptr; 11449 Decls : List_Id; 11450 RCI_Locator : Entity_Id; 11451 Controlling_Parameter : Entity_Id) return RPC_Target 11452 is 11453 begin 11454 case Get_PCS_Name is 11455 when Name_PolyORB_DSA => 11456 return 11457 PolyORB_Support.Build_Stub_Target 11458 (Loc, Decls, RCI_Locator, Controlling_Parameter); 11459 11460 when others => 11461 return 11462 GARLIC_Support.Build_Stub_Target 11463 (Loc, Decls, RCI_Locator, Controlling_Parameter); 11464 end case; 11465 end Specific_Build_Stub_Target; 11466 11467 -------------------------------- 11468 -- Specific_RPC_Receiver_Decl -- 11469 -------------------------------- 11470 11471 function Specific_RPC_Receiver_Decl 11472 (RACW_Type : Entity_Id) return Node_Id 11473 is 11474 begin 11475 case Get_PCS_Name is 11476 when Name_PolyORB_DSA => 11477 return PolyORB_Support.RPC_Receiver_Decl (RACW_Type); 11478 11479 when others => 11480 return GARLIC_Support.RPC_Receiver_Decl (RACW_Type); 11481 end case; 11482 end Specific_RPC_Receiver_Decl; 11483 11484 ----------------------------------------------- 11485 -- Specific_Build_Subprogram_Receiving_Stubs -- 11486 ----------------------------------------------- 11487 11488 function Specific_Build_Subprogram_Receiving_Stubs 11489 (Vis_Decl : Node_Id; 11490 Asynchronous : Boolean; 11491 Dynamically_Asynchronous : Boolean := False; 11492 Stub_Type : Entity_Id := Empty; 11493 RACW_Type : Entity_Id := Empty; 11494 Parent_Primitive : Entity_Id := Empty) return Node_Id 11495 is 11496 begin 11497 case Get_PCS_Name is 11498 when Name_PolyORB_DSA => 11499 return 11500 PolyORB_Support.Build_Subprogram_Receiving_Stubs 11501 (Vis_Decl, 11502 Asynchronous, 11503 Dynamically_Asynchronous, 11504 Stub_Type, 11505 RACW_Type, 11506 Parent_Primitive); 11507 11508 when others => 11509 return 11510 GARLIC_Support.Build_Subprogram_Receiving_Stubs 11511 (Vis_Decl, 11512 Asynchronous, 11513 Dynamically_Asynchronous, 11514 Stub_Type, 11515 RACW_Type, 11516 Parent_Primitive); 11517 end case; 11518 end Specific_Build_Subprogram_Receiving_Stubs; 11519 11520 ------------------------------- 11521 -- Transmit_As_Unconstrained -- 11522 ------------------------------- 11523 11524 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is 11525 begin 11526 return 11527 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ)) 11528 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ)); 11529 end Transmit_As_Unconstrained; 11530 11531 -------------------------- 11532 -- Underlying_RACW_Type -- 11533 -------------------------- 11534 11535 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is 11536 Record_Type : Entity_Id; 11537 11538 begin 11539 if Ekind (RAS_Typ) = E_Record_Type then 11540 Record_Type := RAS_Typ; 11541 else 11542 pragma Assert (Present (Equivalent_Type (RAS_Typ))); 11543 Record_Type := Equivalent_Type (RAS_Typ); 11544 end if; 11545 11546 return 11547 Etype (Subtype_Indication 11548 (Component_Definition 11549 (First (Component_Items 11550 (Component_List 11551 (Type_Definition 11552 (Declaration_Node (Record_Type)))))))); 11553 end Underlying_RACW_Type; 11554 11555end Exp_Dist; 11556