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_Ent : Entity_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 Pkg_Ent := Defining_Entity (Pkg_Spec); 2347 2348 Reg := 2349 Make_Procedure_Call_Statement (Loc, 2350 Name => 2351 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), 2352 Parameter_Associations => New_List ( 2353 Make_String_Literal (Loc, 2354 Fully_Qualified_Name_String (Pkg_Ent, Append_NUL => False)), 2355 Make_Attribute_Reference (Loc, 2356 Prefix => New_Occurrence_Of (Pkg_Ent, Loc), 2357 Attribute_Name => Name_Version))); 2358 Append_To (L, Reg); 2359 Analyze (Reg); 2360 end Build_Passive_Partition_Stub; 2361 2362 -------------------------------------- 2363 -- Build_RPC_Receiver_Specification -- 2364 -------------------------------------- 2365 2366 function Build_RPC_Receiver_Specification 2367 (RPC_Receiver : Entity_Id; 2368 Request_Parameter : Entity_Id) return Node_Id 2369 is 2370 Loc : constant Source_Ptr := Sloc (RPC_Receiver); 2371 begin 2372 return 2373 Make_Procedure_Specification (Loc, 2374 Defining_Unit_Name => RPC_Receiver, 2375 Parameter_Specifications => New_List ( 2376 Make_Parameter_Specification (Loc, 2377 Defining_Identifier => Request_Parameter, 2378 Parameter_Type => 2379 New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); 2380 end Build_RPC_Receiver_Specification; 2381 2382 ---------------------------------------- 2383 -- Build_Remote_Subprogram_Proxy_Type -- 2384 ---------------------------------------- 2385 2386 function Build_Remote_Subprogram_Proxy_Type 2387 (Loc : Source_Ptr; 2388 ACR_Expression : Node_Id) return Node_Id 2389 is 2390 begin 2391 return 2392 Make_Record_Definition (Loc, 2393 Tagged_Present => True, 2394 Limited_Present => True, 2395 Component_List => 2396 Make_Component_List (Loc, 2397 Component_Items => New_List ( 2398 Make_Component_Declaration (Loc, 2399 Defining_Identifier => 2400 Make_Defining_Identifier (Loc, 2401 Name_All_Calls_Remote), 2402 Component_Definition => 2403 Make_Component_Definition (Loc, 2404 Subtype_Indication => 2405 New_Occurrence_Of (Standard_Boolean, Loc)), 2406 Expression => 2407 ACR_Expression), 2408 2409 Make_Component_Declaration (Loc, 2410 Defining_Identifier => 2411 Make_Defining_Identifier (Loc, 2412 Name_Receiver), 2413 Component_Definition => 2414 Make_Component_Definition (Loc, 2415 Subtype_Indication => 2416 New_Occurrence_Of (RTE (RE_Address), Loc)), 2417 Expression => 2418 New_Occurrence_Of (RTE (RE_Null_Address), Loc)), 2419 2420 Make_Component_Declaration (Loc, 2421 Defining_Identifier => 2422 Make_Defining_Identifier (Loc, 2423 Name_Subp_Id), 2424 Component_Definition => 2425 Make_Component_Definition (Loc, 2426 Subtype_Indication => 2427 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); 2428 end Build_Remote_Subprogram_Proxy_Type; 2429 2430 -------------------- 2431 -- Build_Stub_Tag -- 2432 -------------------- 2433 2434 function Build_Stub_Tag 2435 (Loc : Source_Ptr; 2436 RACW_Type : Entity_Id) return Node_Id 2437 is 2438 Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type); 2439 begin 2440 return 2441 Make_Attribute_Reference (Loc, 2442 Prefix => New_Occurrence_Of (Stub_Type, Loc), 2443 Attribute_Name => Name_Tag); 2444 end Build_Stub_Tag; 2445 2446 ------------------------------------ 2447 -- Build_Subprogram_Calling_Stubs -- 2448 ------------------------------------ 2449 2450 function Build_Subprogram_Calling_Stubs 2451 (Vis_Decl : Node_Id; 2452 Subp_Id : Node_Id; 2453 Asynchronous : Boolean; 2454 Dynamically_Asynchronous : Boolean := False; 2455 Stub_Type : Entity_Id := Empty; 2456 RACW_Type : Entity_Id := Empty; 2457 Locator : Entity_Id := Empty; 2458 New_Name : Name_Id := No_Name) return Node_Id 2459 is 2460 Loc : constant Source_Ptr := Sloc (Vis_Decl); 2461 2462 Decls : constant List_Id := New_List; 2463 Statements : constant List_Id := New_List; 2464 2465 Subp_Spec : Node_Id; 2466 -- The specification of the body 2467 2468 Controlling_Parameter : Entity_Id := Empty; 2469 2470 Asynchronous_Expr : Node_Id := Empty; 2471 2472 RCI_Locator : Entity_Id; 2473 2474 Spec_To_Use : Node_Id; 2475 2476 procedure Insert_Partition_Check (Parameter : Node_Id); 2477 -- Check that the parameter has been elaborated on the same partition 2478 -- than the controlling parameter (E.4(19)). 2479 2480 ---------------------------- 2481 -- Insert_Partition_Check -- 2482 ---------------------------- 2483 2484 procedure Insert_Partition_Check (Parameter : Node_Id) is 2485 Parameter_Entity : constant Entity_Id := 2486 Defining_Identifier (Parameter); 2487 begin 2488 -- The expression that will be built is of the form: 2489 2490 -- if not Same_Partition (Parameter, Controlling_Parameter) then 2491 -- raise Constraint_Error; 2492 -- end if; 2493 2494 -- We do not check that Parameter is in Stub_Type since such a check 2495 -- has been inserted at the point of call already (a tag check since 2496 -- we have multiple controlling operands). 2497 2498 Append_To (Decls, 2499 Make_Raise_Constraint_Error (Loc, 2500 Condition => 2501 Make_Op_Not (Loc, 2502 Right_Opnd => 2503 Make_Function_Call (Loc, 2504 Name => 2505 New_Occurrence_Of (RTE (RE_Same_Partition), Loc), 2506 Parameter_Associations => 2507 New_List ( 2508 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), 2509 New_Occurrence_Of (Parameter_Entity, Loc)), 2510 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), 2511 New_Occurrence_Of (Controlling_Parameter, Loc))))), 2512 Reason => CE_Partition_Check_Failed)); 2513 end Insert_Partition_Check; 2514 2515 -- Start of processing for Build_Subprogram_Calling_Stubs 2516 2517 begin 2518 Subp_Spec := 2519 Copy_Specification (Loc, 2520 Spec => Specification (Vis_Decl), 2521 New_Name => New_Name); 2522 2523 if Locator = Empty then 2524 RCI_Locator := RCI_Cache; 2525 Spec_To_Use := Specification (Vis_Decl); 2526 else 2527 RCI_Locator := Locator; 2528 Spec_To_Use := Subp_Spec; 2529 end if; 2530 2531 -- Find a controlling argument if we have a stub type. Also check 2532 -- if this subprogram can be made asynchronous. 2533 2534 if Present (Stub_Type) 2535 and then Present (Parameter_Specifications (Spec_To_Use)) 2536 then 2537 declare 2538 Current_Parameter : Node_Id := 2539 First (Parameter_Specifications 2540 (Spec_To_Use)); 2541 begin 2542 while Present (Current_Parameter) loop 2543 if 2544 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) 2545 then 2546 if Controlling_Parameter = Empty then 2547 Controlling_Parameter := 2548 Defining_Identifier (Current_Parameter); 2549 else 2550 Insert_Partition_Check (Current_Parameter); 2551 end if; 2552 end if; 2553 2554 Next (Current_Parameter); 2555 end loop; 2556 end; 2557 end if; 2558 2559 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter)); 2560 2561 if Dynamically_Asynchronous then 2562 Asynchronous_Expr := Make_Selected_Component (Loc, 2563 Prefix => Controlling_Parameter, 2564 Selector_Name => Name_Asynchronous); 2565 end if; 2566 2567 Specific_Build_General_Calling_Stubs 2568 (Decls => Decls, 2569 Statements => Statements, 2570 Target => Specific_Build_Stub_Target (Loc, 2571 Decls, RCI_Locator, Controlling_Parameter), 2572 Subprogram_Id => Subp_Id, 2573 Asynchronous => Asynchronous_Expr, 2574 Is_Known_Asynchronous => Asynchronous 2575 and then not Dynamically_Asynchronous, 2576 Is_Known_Non_Asynchronous 2577 => not Asynchronous 2578 and then not Dynamically_Asynchronous, 2579 Is_Function => Nkind (Spec_To_Use) = 2580 N_Function_Specification, 2581 Spec => Spec_To_Use, 2582 Stub_Type => Stub_Type, 2583 RACW_Type => RACW_Type, 2584 Nod => Vis_Decl); 2585 2586 RCI_Calling_Stubs_Table.Set 2587 (Defining_Unit_Name (Specification (Vis_Decl)), 2588 Defining_Unit_Name (Spec_To_Use)); 2589 2590 return 2591 Make_Subprogram_Body (Loc, 2592 Specification => Subp_Spec, 2593 Declarations => Decls, 2594 Handled_Statement_Sequence => 2595 Make_Handled_Sequence_Of_Statements (Loc, Statements)); 2596 end Build_Subprogram_Calling_Stubs; 2597 2598 ------------------------- 2599 -- Build_Subprogram_Id -- 2600 ------------------------- 2601 2602 function Build_Subprogram_Id 2603 (Loc : Source_Ptr; 2604 E : Entity_Id) return Node_Id 2605 is 2606 begin 2607 if Get_Subprogram_Ids (E).Str_Identifier = No_String then 2608 declare 2609 Current_Declaration : Node_Id; 2610 Current_Subp : Entity_Id; 2611 Current_Subp_Str : String_Id; 2612 Current_Subp_Number : Int := First_RCI_Subprogram_Id; 2613 2614 pragma Warnings (Off, Current_Subp_Str); 2615 2616 begin 2617 -- Build_Subprogram_Id is called outside of the context of 2618 -- generating calling or receiving stubs. Hence we are processing 2619 -- an 'Access attribute_reference for an RCI subprogram, for the 2620 -- purpose of obtaining a RAS value. 2621 2622 pragma Assert 2623 (Is_Remote_Call_Interface (Scope (E)) 2624 and then 2625 (Nkind (Parent (E)) = N_Procedure_Specification 2626 or else 2627 Nkind (Parent (E)) = N_Function_Specification)); 2628 2629 Current_Declaration := 2630 First (Visible_Declarations 2631 (Package_Specification_Of_Scope (Scope (E)))); 2632 while Present (Current_Declaration) loop 2633 if Nkind (Current_Declaration) = N_Subprogram_Declaration 2634 and then Comes_From_Source (Current_Declaration) 2635 then 2636 Current_Subp := Defining_Unit_Name (Specification ( 2637 Current_Declaration)); 2638 2639 Assign_Subprogram_Identifier 2640 (Current_Subp, Current_Subp_Number, Current_Subp_Str); 2641 2642 Current_Subp_Number := Current_Subp_Number + 1; 2643 end if; 2644 2645 Next (Current_Declaration); 2646 end loop; 2647 end; 2648 end if; 2649 2650 case Get_PCS_Name is 2651 when Name_PolyORB_DSA => 2652 return Make_String_Literal (Loc, Get_Subprogram_Id (E)); 2653 when others => 2654 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E)); 2655 end case; 2656 end Build_Subprogram_Id; 2657 2658 ------------------------ 2659 -- Copy_Specification -- 2660 ------------------------ 2661 2662 function Copy_Specification 2663 (Loc : Source_Ptr; 2664 Spec : Node_Id; 2665 Ctrl_Type : Entity_Id := Empty; 2666 New_Name : Name_Id := No_Name) return Node_Id 2667 is 2668 Parameters : List_Id := No_List; 2669 2670 Current_Parameter : Node_Id; 2671 Current_Identifier : Entity_Id; 2672 Current_Type : Node_Id; 2673 2674 Name_For_New_Spec : Name_Id; 2675 2676 New_Identifier : Entity_Id; 2677 2678 -- Comments needed in body below ??? 2679 2680 begin 2681 if New_Name = No_Name then 2682 pragma Assert (Nkind (Spec) = N_Function_Specification 2683 or else Nkind (Spec) = N_Procedure_Specification); 2684 2685 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec)); 2686 else 2687 Name_For_New_Spec := New_Name; 2688 end if; 2689 2690 if Present (Parameter_Specifications (Spec)) then 2691 Parameters := New_List; 2692 Current_Parameter := First (Parameter_Specifications (Spec)); 2693 while Present (Current_Parameter) loop 2694 Current_Identifier := Defining_Identifier (Current_Parameter); 2695 Current_Type := Parameter_Type (Current_Parameter); 2696 2697 if Nkind (Current_Type) = N_Access_Definition then 2698 if Present (Ctrl_Type) then 2699 pragma Assert (Is_Controlling_Formal (Current_Identifier)); 2700 Current_Type := 2701 Make_Access_Definition (Loc, 2702 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc), 2703 Null_Exclusion_Present => 2704 Null_Exclusion_Present (Current_Type)); 2705 2706 else 2707 Current_Type := 2708 Make_Access_Definition (Loc, 2709 Subtype_Mark => 2710 New_Copy_Tree (Subtype_Mark (Current_Type)), 2711 Null_Exclusion_Present => 2712 Null_Exclusion_Present (Current_Type)); 2713 end if; 2714 2715 else 2716 if Present (Ctrl_Type) 2717 and then Is_Controlling_Formal (Current_Identifier) 2718 then 2719 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc); 2720 else 2721 Current_Type := New_Copy_Tree (Current_Type); 2722 end if; 2723 end if; 2724 2725 New_Identifier := Make_Defining_Identifier (Loc, 2726 Chars (Current_Identifier)); 2727 2728 Append_To (Parameters, 2729 Make_Parameter_Specification (Loc, 2730 Defining_Identifier => New_Identifier, 2731 Parameter_Type => Current_Type, 2732 In_Present => In_Present (Current_Parameter), 2733 Out_Present => Out_Present (Current_Parameter), 2734 Expression => 2735 New_Copy_Tree (Expression (Current_Parameter)))); 2736 2737 -- For a regular formal parameter (that needs to be marshalled 2738 -- in the context of remote calls), set the Etype now, because 2739 -- marshalling processing might need it. 2740 2741 if Is_Entity_Name (Current_Type) then 2742 Set_Etype (New_Identifier, Entity (Current_Type)); 2743 2744 -- Current_Type is an access definition, special processing 2745 -- (not requiring etype) will occur for marshalling. 2746 2747 else 2748 null; 2749 end if; 2750 2751 Next (Current_Parameter); 2752 end loop; 2753 end if; 2754 2755 case Nkind (Spec) is 2756 2757 when N_Function_Specification | N_Access_Function_Definition => 2758 return 2759 Make_Function_Specification (Loc, 2760 Defining_Unit_Name => 2761 Make_Defining_Identifier (Loc, 2762 Chars => Name_For_New_Spec), 2763 Parameter_Specifications => Parameters, 2764 Result_Definition => 2765 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc)); 2766 2767 when N_Procedure_Specification | N_Access_Procedure_Definition => 2768 return 2769 Make_Procedure_Specification (Loc, 2770 Defining_Unit_Name => 2771 Make_Defining_Identifier (Loc, 2772 Chars => Name_For_New_Spec), 2773 Parameter_Specifications => Parameters); 2774 2775 when others => 2776 raise Program_Error; 2777 end case; 2778 end Copy_Specification; 2779 2780 ----------------------------- 2781 -- Corresponding_Stub_Type -- 2782 ----------------------------- 2783 2784 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is 2785 Desig : constant Entity_Id := 2786 Etype (Designated_Type (RACW_Type)); 2787 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); 2788 begin 2789 return Stub_Elements.Stub_Type; 2790 end Corresponding_Stub_Type; 2791 2792 --------------------------- 2793 -- Could_Be_Asynchronous -- 2794 --------------------------- 2795 2796 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is 2797 Current_Parameter : Node_Id; 2798 2799 begin 2800 if Present (Parameter_Specifications (Spec)) then 2801 Current_Parameter := First (Parameter_Specifications (Spec)); 2802 while Present (Current_Parameter) loop 2803 if Out_Present (Current_Parameter) then 2804 return False; 2805 end if; 2806 2807 Next (Current_Parameter); 2808 end loop; 2809 end if; 2810 2811 return True; 2812 end Could_Be_Asynchronous; 2813 2814 --------------------------- 2815 -- Declare_Create_NVList -- 2816 --------------------------- 2817 2818 procedure Declare_Create_NVList 2819 (Loc : Source_Ptr; 2820 NVList : Entity_Id; 2821 Decls : List_Id; 2822 Stmts : List_Id) 2823 is 2824 begin 2825 Append_To (Decls, 2826 Make_Object_Declaration (Loc, 2827 Defining_Identifier => NVList, 2828 Aliased_Present => False, 2829 Object_Definition => 2830 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc))); 2831 2832 Append_To (Stmts, 2833 Make_Procedure_Call_Statement (Loc, 2834 Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc), 2835 Parameter_Associations => New_List ( 2836 New_Occurrence_Of (NVList, Loc)))); 2837 end Declare_Create_NVList; 2838 2839 --------------------------------------------- 2840 -- Expand_All_Calls_Remote_Subprogram_Call -- 2841 --------------------------------------------- 2842 2843 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is 2844 Loc : constant Source_Ptr := Sloc (N); 2845 Called_Subprogram : constant Entity_Id := Entity (Name (N)); 2846 RCI_Package : constant Entity_Id := Scope (Called_Subprogram); 2847 RCI_Locator_Decl : Node_Id; 2848 RCI_Locator : Entity_Id; 2849 Calling_Stubs : Node_Id; 2850 E_Calling_Stubs : Entity_Id; 2851 2852 begin 2853 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); 2854 2855 if E_Calling_Stubs = Empty then 2856 RCI_Locator := RCI_Locator_Table.Get (RCI_Package); 2857 2858 -- The RCI_Locator package and calling stub are is inserted at the 2859 -- top level in the current unit, and must appear in the proper scope 2860 -- so that it is not prematurely removed by the GCC back end. 2861 2862 declare 2863 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); 2864 begin 2865 if Ekind (Scop) = E_Package_Body then 2866 Push_Scope (Spec_Entity (Scop)); 2867 elsif Ekind (Scop) = E_Subprogram_Body then 2868 Push_Scope 2869 (Corresponding_Spec (Unit_Declaration_Node (Scop))); 2870 else 2871 Push_Scope (Scop); 2872 end if; 2873 end; 2874 2875 if RCI_Locator = Empty then 2876 RCI_Locator_Decl := 2877 RCI_Package_Locator (Loc, Package_Specification (RCI_Package)); 2878 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl); 2879 Analyze (RCI_Locator_Decl); 2880 RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl); 2881 2882 else 2883 RCI_Locator_Decl := Parent (RCI_Locator); 2884 end if; 2885 2886 Calling_Stubs := Build_Subprogram_Calling_Stubs 2887 (Vis_Decl => Parent (Parent (Called_Subprogram)), 2888 Subp_Id => 2889 Build_Subprogram_Id (Loc, Called_Subprogram), 2890 Asynchronous => Nkind (N) = N_Procedure_Call_Statement 2891 and then 2892 Is_Asynchronous (Called_Subprogram), 2893 Locator => RCI_Locator, 2894 New_Name => New_Internal_Name ('S')); 2895 Insert_After (RCI_Locator_Decl, Calling_Stubs); 2896 Analyze (Calling_Stubs); 2897 Pop_Scope; 2898 2899 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); 2900 end if; 2901 2902 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc)); 2903 end Expand_All_Calls_Remote_Subprogram_Call; 2904 2905 --------------------------------- 2906 -- Expand_Calling_Stubs_Bodies -- 2907 --------------------------------- 2908 2909 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is 2910 Spec : constant Node_Id := Specification (Unit_Node); 2911 begin 2912 Add_Calling_Stubs_To_Declarations (Spec); 2913 end Expand_Calling_Stubs_Bodies; 2914 2915 ----------------------------------- 2916 -- Expand_Receiving_Stubs_Bodies -- 2917 ----------------------------------- 2918 2919 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is 2920 Spec : Node_Id; 2921 Decls : List_Id; 2922 Stubs_Decls : List_Id; 2923 Stubs_Stmts : List_Id; 2924 2925 begin 2926 if Nkind (Unit_Node) = N_Package_Declaration then 2927 Spec := Specification (Unit_Node); 2928 Decls := Private_Declarations (Spec); 2929 2930 if No (Decls) then 2931 Decls := Visible_Declarations (Spec); 2932 end if; 2933 2934 Push_Scope (Scope_Of_Spec (Spec)); 2935 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls); 2936 2937 else 2938 Spec := 2939 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node)); 2940 Decls := Declarations (Unit_Node); 2941 2942 Push_Scope (Scope_Of_Spec (Unit_Node)); 2943 Stubs_Decls := New_List; 2944 Stubs_Stmts := New_List; 2945 Specific_Add_Receiving_Stubs_To_Declarations 2946 (Spec, Stubs_Decls, Stubs_Stmts); 2947 2948 Insert_List_Before (First (Decls), Stubs_Decls); 2949 2950 declare 2951 HSS_Stmts : constant List_Id := 2952 Statements (Handled_Statement_Sequence (Unit_Node)); 2953 2954 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts); 2955 2956 begin 2957 if No (First_HSS_Stmt) then 2958 Append_List_To (HSS_Stmts, Stubs_Stmts); 2959 else 2960 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts); 2961 end if; 2962 end; 2963 end if; 2964 2965 Pop_Scope; 2966 end Expand_Receiving_Stubs_Bodies; 2967 2968 -------------------- 2969 -- GARLIC_Support -- 2970 -------------------- 2971 2972 package body GARLIC_Support is 2973 2974 -- Local subprograms 2975 2976 procedure Add_RACW_Read_Attribute 2977 (RACW_Type : Entity_Id; 2978 Stub_Type : Entity_Id; 2979 Stub_Type_Access : Entity_Id; 2980 Body_Decls : List_Id); 2981 -- Add Read attribute for the RACW type. The declaration and attribute 2982 -- definition clauses are inserted right after the declaration of 2983 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is 2984 -- appended to it (case where the RACW declaration is in the main unit). 2985 2986 procedure Add_RACW_Write_Attribute 2987 (RACW_Type : Entity_Id; 2988 Stub_Type : Entity_Id; 2989 Stub_Type_Access : Entity_Id; 2990 RPC_Receiver : Node_Id; 2991 Body_Decls : List_Id); 2992 -- Same as above for the Write attribute 2993 2994 function Stream_Parameter return Node_Id; 2995 function Result return Node_Id; 2996 function Object return Node_Id renames Result; 2997 -- Functions to create occurrences of the formal parameter names of the 2998 -- 'Read and 'Write attributes. 2999 3000 Loc : Source_Ptr; 3001 -- Shared source location used by Add_{Read,Write}_Read_Attribute and 3002 -- their ancillary subroutines (set on entry by Add_RACW_Features). 3003 3004 procedure Add_RAS_Access_TSS (N : Node_Id); 3005 -- Add a subprogram body for RAS Access TSS 3006 3007 ------------------------------------- 3008 -- Add_Obj_RPC_Receiver_Completion -- 3009 ------------------------------------- 3010 3011 procedure Add_Obj_RPC_Receiver_Completion 3012 (Loc : Source_Ptr; 3013 Decls : List_Id; 3014 RPC_Receiver : Entity_Id; 3015 Stub_Elements : Stub_Structure) 3016 is 3017 begin 3018 -- The RPC receiver body should not be the completion of the 3019 -- declaration recorded in the stub structure, because then the 3020 -- occurrences of the formal parameters within the body should refer 3021 -- to the entities from the declaration, not from the completion, to 3022 -- which we do not have easy access. Instead, the RPC receiver body 3023 -- acts as its own declaration, and the RPC receiver declaration is 3024 -- completed by a renaming-as-body. 3025 3026 Append_To (Decls, 3027 Make_Subprogram_Renaming_Declaration (Loc, 3028 Specification => 3029 Copy_Specification (Loc, 3030 Specification (Stub_Elements.RPC_Receiver_Decl)), 3031 Name => New_Occurrence_Of (RPC_Receiver, Loc))); 3032 end Add_Obj_RPC_Receiver_Completion; 3033 3034 ----------------------- 3035 -- Add_RACW_Features -- 3036 ----------------------- 3037 3038 procedure Add_RACW_Features 3039 (RACW_Type : Entity_Id; 3040 Stub_Type : Entity_Id; 3041 Stub_Type_Access : Entity_Id; 3042 RPC_Receiver_Decl : Node_Id; 3043 Body_Decls : List_Id) 3044 is 3045 RPC_Receiver : Node_Id; 3046 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); 3047 3048 begin 3049 Loc := Sloc (RACW_Type); 3050 3051 if Is_RAS then 3052 3053 -- For a RAS, the RPC receiver is that of the RCI unit, not that 3054 -- of the corresponding distributed object type. We retrieve its 3055 -- address from the local proxy object. 3056 3057 RPC_Receiver := Make_Selected_Component (Loc, 3058 Prefix => 3059 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object), 3060 Selector_Name => Make_Identifier (Loc, Name_Receiver)); 3061 3062 else 3063 RPC_Receiver := Make_Attribute_Reference (Loc, 3064 Prefix => New_Occurrence_Of ( 3065 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc), 3066 Attribute_Name => Name_Address); 3067 end if; 3068 3069 Add_RACW_Write_Attribute 3070 (RACW_Type, 3071 Stub_Type, 3072 Stub_Type_Access, 3073 RPC_Receiver, 3074 Body_Decls); 3075 3076 Add_RACW_Read_Attribute 3077 (RACW_Type, 3078 Stub_Type, 3079 Stub_Type_Access, 3080 Body_Decls); 3081 end Add_RACW_Features; 3082 3083 ----------------------------- 3084 -- Add_RACW_Read_Attribute -- 3085 ----------------------------- 3086 3087 procedure Add_RACW_Read_Attribute 3088 (RACW_Type : Entity_Id; 3089 Stub_Type : Entity_Id; 3090 Stub_Type_Access : Entity_Id; 3091 Body_Decls : List_Id) 3092 is 3093 Proc_Decl : Node_Id; 3094 Attr_Decl : Node_Id; 3095 3096 Body_Node : Node_Id; 3097 3098 Statements : constant List_Id := New_List; 3099 Decls : List_Id; 3100 Local_Statements : List_Id; 3101 Remote_Statements : List_Id; 3102 -- Various parts of the procedure 3103 3104 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); 3105 Asynchronous_Flag : constant Entity_Id := 3106 Asynchronous_Flags_Table.Get (RACW_Type); 3107 pragma Assert (Present (Asynchronous_Flag)); 3108 3109 -- Prepare local identifiers 3110 3111 Source_Partition : Entity_Id; 3112 Source_Receiver : Entity_Id; 3113 Source_Address : Entity_Id; 3114 Local_Stub : Entity_Id; 3115 Stubbed_Result : Entity_Id; 3116 3117 -- Start of processing for Add_RACW_Read_Attribute 3118 3119 begin 3120 Build_Stream_Procedure (Loc, 3121 RACW_Type, Body_Node, Pnam, Statements, Outp => True); 3122 Proc_Decl := Make_Subprogram_Declaration (Loc, 3123 Copy_Specification (Loc, Specification (Body_Node))); 3124 3125 Attr_Decl := 3126 Make_Attribute_Definition_Clause (Loc, 3127 Name => New_Occurrence_Of (RACW_Type, Loc), 3128 Chars => Name_Read, 3129 Expression => 3130 New_Occurrence_Of ( 3131 Defining_Unit_Name (Specification (Proc_Decl)), Loc)); 3132 3133 Insert_After (Declaration_Node (RACW_Type), Proc_Decl); 3134 Insert_After (Proc_Decl, Attr_Decl); 3135 3136 if No (Body_Decls) then 3137 3138 -- Case of processing an RACW type from another unit than the 3139 -- main one: do not generate a body. 3140 3141 return; 3142 end if; 3143 3144 -- Prepare local identifiers 3145 3146 Source_Partition := Make_Temporary (Loc, 'P'); 3147 Source_Receiver := Make_Temporary (Loc, 'S'); 3148 Source_Address := Make_Temporary (Loc, 'P'); 3149 Local_Stub := Make_Temporary (Loc, 'L'); 3150 Stubbed_Result := Make_Temporary (Loc, 'S'); 3151 3152 -- Generate object declarations 3153 3154 Decls := New_List ( 3155 Make_Object_Declaration (Loc, 3156 Defining_Identifier => Source_Partition, 3157 Object_Definition => 3158 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), 3159 3160 Make_Object_Declaration (Loc, 3161 Defining_Identifier => Source_Receiver, 3162 Object_Definition => 3163 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), 3164 3165 Make_Object_Declaration (Loc, 3166 Defining_Identifier => Source_Address, 3167 Object_Definition => 3168 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), 3169 3170 Make_Object_Declaration (Loc, 3171 Defining_Identifier => Local_Stub, 3172 Aliased_Present => True, 3173 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), 3174 3175 Make_Object_Declaration (Loc, 3176 Defining_Identifier => Stubbed_Result, 3177 Object_Definition => 3178 New_Occurrence_Of (Stub_Type_Access, Loc), 3179 Expression => 3180 Make_Attribute_Reference (Loc, 3181 Prefix => 3182 New_Occurrence_Of (Local_Stub, Loc), 3183 Attribute_Name => 3184 Name_Unchecked_Access))); 3185 3186 -- Read the source Partition_ID and RPC_Receiver from incoming stream 3187 3188 Append_List_To (Statements, New_List ( 3189 Make_Attribute_Reference (Loc, 3190 Prefix => 3191 New_Occurrence_Of (RTE (RE_Partition_ID), Loc), 3192 Attribute_Name => Name_Read, 3193 Expressions => New_List ( 3194 Stream_Parameter, 3195 New_Occurrence_Of (Source_Partition, Loc))), 3196 3197 Make_Attribute_Reference (Loc, 3198 Prefix => 3199 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), 3200 Attribute_Name => 3201 Name_Read, 3202 Expressions => New_List ( 3203 Stream_Parameter, 3204 New_Occurrence_Of (Source_Receiver, Loc))), 3205 3206 Make_Attribute_Reference (Loc, 3207 Prefix => 3208 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), 3209 Attribute_Name => 3210 Name_Read, 3211 Expressions => New_List ( 3212 Stream_Parameter, 3213 New_Occurrence_Of (Source_Address, Loc))))); 3214 3215 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result 3216 3217 Set_Etype (Stubbed_Result, Stub_Type_Access); 3218 3219 -- If the Address is Null_Address, then return a null object, unless 3220 -- RACW_Type is null-excluding, in which case unconditionally raise 3221 -- CONSTRAINT_ERROR instead. 3222 3223 declare 3224 Zero_Statements : List_Id; 3225 -- Statements executed when a zero value is received 3226 3227 begin 3228 if Can_Never_Be_Null (RACW_Type) then 3229 Zero_Statements := New_List ( 3230 Make_Raise_Constraint_Error (Loc, 3231 Reason => CE_Null_Not_Allowed)); 3232 else 3233 Zero_Statements := New_List ( 3234 Make_Assignment_Statement (Loc, 3235 Name => Result, 3236 Expression => Make_Null (Loc)), 3237 Make_Simple_Return_Statement (Loc)); 3238 end if; 3239 3240 Append_To (Statements, 3241 Make_Implicit_If_Statement (RACW_Type, 3242 Condition => 3243 Make_Op_Eq (Loc, 3244 Left_Opnd => New_Occurrence_Of (Source_Address, Loc), 3245 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), 3246 Then_Statements => Zero_Statements)); 3247 end; 3248 3249 -- If the RACW denotes an object created on the current partition, 3250 -- Local_Statements will be executed. The real object will be used. 3251 3252 Local_Statements := New_List ( 3253 Make_Assignment_Statement (Loc, 3254 Name => Result, 3255 Expression => 3256 Unchecked_Convert_To (RACW_Type, 3257 OK_Convert_To (RTE (RE_Address), 3258 New_Occurrence_Of (Source_Address, Loc))))); 3259 3260 -- If the object is located on another partition, then a stub object 3261 -- will be created with all the information needed to rebuild the 3262 -- real object at the other end. 3263 3264 Remote_Statements := New_List ( 3265 3266 Make_Assignment_Statement (Loc, 3267 Name => Make_Selected_Component (Loc, 3268 Prefix => Stubbed_Result, 3269 Selector_Name => Name_Origin), 3270 Expression => 3271 New_Occurrence_Of (Source_Partition, Loc)), 3272 3273 Make_Assignment_Statement (Loc, 3274 Name => Make_Selected_Component (Loc, 3275 Prefix => Stubbed_Result, 3276 Selector_Name => Name_Receiver), 3277 Expression => 3278 New_Occurrence_Of (Source_Receiver, Loc)), 3279 3280 Make_Assignment_Statement (Loc, 3281 Name => Make_Selected_Component (Loc, 3282 Prefix => Stubbed_Result, 3283 Selector_Name => Name_Addr), 3284 Expression => 3285 New_Occurrence_Of (Source_Address, Loc))); 3286 3287 Append_To (Remote_Statements, 3288 Make_Assignment_Statement (Loc, 3289 Name => Make_Selected_Component (Loc, 3290 Prefix => Stubbed_Result, 3291 Selector_Name => Name_Asynchronous), 3292 Expression => 3293 New_Occurrence_Of (Asynchronous_Flag, Loc))); 3294 3295 Append_List_To (Remote_Statements, 3296 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type)); 3297 -- ??? Issue with asynchronous calls here: the Asynchronous flag is 3298 -- set on the stub type if, and only if, the RACW type has a pragma 3299 -- Asynchronous. This is incorrect for RACWs that implement RAS 3300 -- types, because in that case the /designated subprogram/ (not the 3301 -- type) might be asynchronous, and that causes the stub to need to 3302 -- be asynchronous too. A solution is to transport a RAS as a struct 3303 -- containing a RACW and an asynchronous flag, and to properly alter 3304 -- the Asynchronous component in the stub type in the RAS's Input 3305 -- TSS. 3306 3307 Append_To (Remote_Statements, 3308 Make_Assignment_Statement (Loc, 3309 Name => Result, 3310 Expression => Unchecked_Convert_To (RACW_Type, 3311 New_Occurrence_Of (Stubbed_Result, Loc)))); 3312 3313 -- Distinguish between the local and remote cases, and execute the 3314 -- appropriate piece of code. 3315 3316 Append_To (Statements, 3317 Make_Implicit_If_Statement (RACW_Type, 3318 Condition => 3319 Make_Op_Eq (Loc, 3320 Left_Opnd => 3321 Make_Function_Call (Loc, 3322 Name => New_Occurrence_Of ( 3323 RTE (RE_Get_Local_Partition_Id), Loc)), 3324 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)), 3325 Then_Statements => Local_Statements, 3326 Else_Statements => Remote_Statements)); 3327 3328 Set_Declarations (Body_Node, Decls); 3329 Append_To (Body_Decls, Body_Node); 3330 end Add_RACW_Read_Attribute; 3331 3332 ------------------------------ 3333 -- Add_RACW_Write_Attribute -- 3334 ------------------------------ 3335 3336 procedure Add_RACW_Write_Attribute 3337 (RACW_Type : Entity_Id; 3338 Stub_Type : Entity_Id; 3339 Stub_Type_Access : Entity_Id; 3340 RPC_Receiver : Node_Id; 3341 Body_Decls : List_Id) 3342 is 3343 Body_Node : Node_Id; 3344 Proc_Decl : Node_Id; 3345 Attr_Decl : Node_Id; 3346 3347 Statements : constant List_Id := New_List; 3348 Local_Statements : List_Id; 3349 Remote_Statements : List_Id; 3350 Null_Statements : List_Id; 3351 3352 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); 3353 3354 begin 3355 Build_Stream_Procedure 3356 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); 3357 3358 Proc_Decl := Make_Subprogram_Declaration (Loc, 3359 Copy_Specification (Loc, Specification (Body_Node))); 3360 3361 Attr_Decl := 3362 Make_Attribute_Definition_Clause (Loc, 3363 Name => New_Occurrence_Of (RACW_Type, Loc), 3364 Chars => Name_Write, 3365 Expression => 3366 New_Occurrence_Of ( 3367 Defining_Unit_Name (Specification (Proc_Decl)), Loc)); 3368 3369 Insert_After (Declaration_Node (RACW_Type), Proc_Decl); 3370 Insert_After (Proc_Decl, Attr_Decl); 3371 3372 if No (Body_Decls) then 3373 return; 3374 end if; 3375 3376 -- Build the code fragment corresponding to the marshalling of a 3377 -- local object. 3378 3379 Local_Statements := New_List ( 3380 3381 Pack_Entity_Into_Stream_Access (Loc, 3382 Stream => Stream_Parameter, 3383 Object => RTE (RE_Get_Local_Partition_Id)), 3384 3385 Pack_Node_Into_Stream_Access (Loc, 3386 Stream => Stream_Parameter, 3387 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), 3388 Etyp => RTE (RE_Unsigned_64)), 3389 3390 Pack_Node_Into_Stream_Access (Loc, 3391 Stream => Stream_Parameter, 3392 Object => OK_Convert_To (RTE (RE_Unsigned_64), 3393 Make_Attribute_Reference (Loc, 3394 Prefix => 3395 Make_Explicit_Dereference (Loc, 3396 Prefix => Object), 3397 Attribute_Name => Name_Address)), 3398 Etyp => RTE (RE_Unsigned_64))); 3399 3400 -- Build the code fragment corresponding to the marshalling of 3401 -- a remote object. 3402 3403 Remote_Statements := New_List ( 3404 Pack_Node_Into_Stream_Access (Loc, 3405 Stream => Stream_Parameter, 3406 Object => 3407 Make_Selected_Component (Loc, 3408 Prefix => 3409 Unchecked_Convert_To (Stub_Type_Access, Object), 3410 Selector_Name => Make_Identifier (Loc, Name_Origin)), 3411 Etyp => RTE (RE_Partition_ID)), 3412 3413 Pack_Node_Into_Stream_Access (Loc, 3414 Stream => Stream_Parameter, 3415 Object => 3416 Make_Selected_Component (Loc, 3417 Prefix => 3418 Unchecked_Convert_To (Stub_Type_Access, Object), 3419 Selector_Name => Make_Identifier (Loc, Name_Receiver)), 3420 Etyp => RTE (RE_Unsigned_64)), 3421 3422 Pack_Node_Into_Stream_Access (Loc, 3423 Stream => Stream_Parameter, 3424 Object => 3425 Make_Selected_Component (Loc, 3426 Prefix => 3427 Unchecked_Convert_To (Stub_Type_Access, Object), 3428 Selector_Name => Make_Identifier (Loc, Name_Addr)), 3429 Etyp => RTE (RE_Unsigned_64))); 3430 3431 -- Build code fragment corresponding to marshalling of a null object 3432 3433 Null_Statements := New_List ( 3434 3435 Pack_Entity_Into_Stream_Access (Loc, 3436 Stream => Stream_Parameter, 3437 Object => RTE (RE_Get_Local_Partition_Id)), 3438 3439 Pack_Node_Into_Stream_Access (Loc, 3440 Stream => Stream_Parameter, 3441 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), 3442 Etyp => RTE (RE_Unsigned_64)), 3443 3444 Pack_Node_Into_Stream_Access (Loc, 3445 Stream => Stream_Parameter, 3446 Object => Make_Integer_Literal (Loc, Uint_0), 3447 Etyp => RTE (RE_Unsigned_64))); 3448 3449 Append_To (Statements, 3450 Make_Implicit_If_Statement (RACW_Type, 3451 Condition => 3452 Make_Op_Eq (Loc, 3453 Left_Opnd => Object, 3454 Right_Opnd => Make_Null (Loc)), 3455 3456 Then_Statements => Null_Statements, 3457 3458 Elsif_Parts => New_List ( 3459 Make_Elsif_Part (Loc, 3460 Condition => 3461 Make_Op_Eq (Loc, 3462 Left_Opnd => 3463 Make_Attribute_Reference (Loc, 3464 Prefix => Object, 3465 Attribute_Name => Name_Tag), 3466 3467 Right_Opnd => 3468 Make_Attribute_Reference (Loc, 3469 Prefix => New_Occurrence_Of (Stub_Type, Loc), 3470 Attribute_Name => Name_Tag)), 3471 Then_Statements => Remote_Statements)), 3472 Else_Statements => Local_Statements)); 3473 3474 Append_To (Body_Decls, Body_Node); 3475 end Add_RACW_Write_Attribute; 3476 3477 ------------------------ 3478 -- Add_RAS_Access_TSS -- 3479 ------------------------ 3480 3481 procedure Add_RAS_Access_TSS (N : Node_Id) is 3482 Loc : constant Source_Ptr := Sloc (N); 3483 3484 Ras_Type : constant Entity_Id := Defining_Identifier (N); 3485 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); 3486 -- Ras_Type is the access to subprogram type while Fat_Type is the 3487 -- corresponding record type. 3488 3489 RACW_Type : constant Entity_Id := 3490 Underlying_RACW_Type (Ras_Type); 3491 Desig : constant Entity_Id := 3492 Etype (Designated_Type (RACW_Type)); 3493 3494 Stub_Elements : constant Stub_Structure := 3495 Stubs_Table.Get (Desig); 3496 pragma Assert (Stub_Elements /= Empty_Stub_Structure); 3497 3498 Proc : constant Entity_Id := 3499 Make_Defining_Identifier (Loc, 3500 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); 3501 3502 Proc_Spec : Node_Id; 3503 3504 -- Formal parameters 3505 3506 Package_Name : constant Entity_Id := 3507 Make_Defining_Identifier (Loc, 3508 Chars => Name_P); 3509 -- Target package 3510 3511 Subp_Id : constant Entity_Id := 3512 Make_Defining_Identifier (Loc, 3513 Chars => Name_S); 3514 -- Target subprogram 3515 3516 Asynch_P : constant Entity_Id := 3517 Make_Defining_Identifier (Loc, 3518 Chars => Name_Asynchronous); 3519 -- Is the procedure to which the 'Access applies asynchronous? 3520 3521 All_Calls_Remote : constant Entity_Id := 3522 Make_Defining_Identifier (Loc, 3523 Chars => Name_All_Calls_Remote); 3524 -- True if an All_Calls_Remote pragma applies to the RCI unit 3525 -- that contains the subprogram. 3526 3527 -- Common local variables 3528 3529 Proc_Decls : List_Id; 3530 Proc_Statements : List_Id; 3531 3532 Origin : constant Entity_Id := Make_Temporary (Loc, 'P'); 3533 3534 -- Additional local variables for the local case 3535 3536 Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P'); 3537 3538 -- Additional local variables for the remote case 3539 3540 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L'); 3541 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S'); 3542 3543 function Set_Field 3544 (Field_Name : Name_Id; 3545 Value : Node_Id) return Node_Id; 3546 -- Construct an assignment that sets the named component in the 3547 -- returned record 3548 3549 --------------- 3550 -- Set_Field -- 3551 --------------- 3552 3553 function Set_Field 3554 (Field_Name : Name_Id; 3555 Value : Node_Id) return Node_Id 3556 is 3557 begin 3558 return 3559 Make_Assignment_Statement (Loc, 3560 Name => 3561 Make_Selected_Component (Loc, 3562 Prefix => Stub_Ptr, 3563 Selector_Name => Field_Name), 3564 Expression => Value); 3565 end Set_Field; 3566 3567 -- Start of processing for Add_RAS_Access_TSS 3568 3569 begin 3570 Proc_Decls := New_List ( 3571 3572 -- Common declarations 3573 3574 Make_Object_Declaration (Loc, 3575 Defining_Identifier => Origin, 3576 Constant_Present => True, 3577 Object_Definition => 3578 New_Occurrence_Of (RTE (RE_Partition_ID), Loc), 3579 Expression => 3580 Make_Function_Call (Loc, 3581 Name => 3582 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc), 3583 Parameter_Associations => New_List ( 3584 New_Occurrence_Of (Package_Name, Loc)))), 3585 3586 -- Declaration use only in the local case: proxy address 3587 3588 Make_Object_Declaration (Loc, 3589 Defining_Identifier => Proxy_Addr, 3590 Object_Definition => 3591 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), 3592 3593 -- Declarations used only in the remote case: stub object and 3594 -- stub pointer. 3595 3596 Make_Object_Declaration (Loc, 3597 Defining_Identifier => Local_Stub, 3598 Aliased_Present => True, 3599 Object_Definition => 3600 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), 3601 3602 Make_Object_Declaration (Loc, 3603 Defining_Identifier => 3604 Stub_Ptr, 3605 Object_Definition => 3606 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), 3607 Expression => 3608 Make_Attribute_Reference (Loc, 3609 Prefix => New_Occurrence_Of (Local_Stub, Loc), 3610 Attribute_Name => Name_Unchecked_Access))); 3611 3612 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); 3613 3614 -- Build_Get_Unique_RP_Call needs above information 3615 3616 -- Note: Here we assume that the Fat_Type is a record 3617 -- containing just a pointer to a proxy or stub object. 3618 3619 Proc_Statements := New_List ( 3620 3621 -- Generate: 3622 3623 -- Get_RAS_Info (Pkg, Subp, PA); 3624 -- if Origin = Local_Partition_Id 3625 -- and then not All_Calls_Remote 3626 -- then 3627 -- return Fat_Type!(PA); 3628 -- end if; 3629 3630 Make_Procedure_Call_Statement (Loc, 3631 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), 3632 Parameter_Associations => New_List ( 3633 New_Occurrence_Of (Package_Name, Loc), 3634 New_Occurrence_Of (Subp_Id, Loc), 3635 New_Occurrence_Of (Proxy_Addr, Loc))), 3636 3637 Make_Implicit_If_Statement (N, 3638 Condition => 3639 Make_And_Then (Loc, 3640 Left_Opnd => 3641 Make_Op_Eq (Loc, 3642 Left_Opnd => 3643 New_Occurrence_Of (Origin, Loc), 3644 Right_Opnd => 3645 Make_Function_Call (Loc, 3646 New_Occurrence_Of ( 3647 RTE (RE_Get_Local_Partition_Id), Loc))), 3648 3649 Right_Opnd => 3650 Make_Op_Not (Loc, 3651 New_Occurrence_Of (All_Calls_Remote, Loc))), 3652 3653 Then_Statements => New_List ( 3654 Make_Simple_Return_Statement (Loc, 3655 Unchecked_Convert_To (Fat_Type, 3656 OK_Convert_To (RTE (RE_Address), 3657 New_Occurrence_Of (Proxy_Addr, Loc)))))), 3658 3659 Set_Field (Name_Origin, 3660 New_Occurrence_Of (Origin, Loc)), 3661 3662 Set_Field (Name_Receiver, 3663 Make_Function_Call (Loc, 3664 Name => 3665 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc), 3666 Parameter_Associations => New_List ( 3667 New_Occurrence_Of (Package_Name, Loc)))), 3668 3669 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), 3670 3671 -- E.4.1(9) A remote call is asynchronous if it is a call to 3672 -- a procedure or a call through a value of an access-to-procedure 3673 -- type to which a pragma Asynchronous applies. 3674 3675 -- Asynch_P is true when the procedure is asynchronous; 3676 -- Asynch_T is true when the type is asynchronous. 3677 3678 Set_Field (Name_Asynchronous, 3679 Make_Or_Else (Loc, 3680 New_Occurrence_Of (Asynch_P, Loc), 3681 New_Occurrence_Of (Boolean_Literals ( 3682 Is_Asynchronous (Ras_Type)), Loc)))); 3683 3684 Append_List_To (Proc_Statements, 3685 Build_Get_Unique_RP_Call 3686 (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); 3687 3688 -- Return the newly created value 3689 3690 Append_To (Proc_Statements, 3691 Make_Simple_Return_Statement (Loc, 3692 Expression => 3693 Unchecked_Convert_To (Fat_Type, 3694 New_Occurrence_Of (Stub_Ptr, Loc)))); 3695 3696 Proc_Spec := 3697 Make_Function_Specification (Loc, 3698 Defining_Unit_Name => Proc, 3699 Parameter_Specifications => New_List ( 3700 Make_Parameter_Specification (Loc, 3701 Defining_Identifier => Package_Name, 3702 Parameter_Type => 3703 New_Occurrence_Of (Standard_String, Loc)), 3704 3705 Make_Parameter_Specification (Loc, 3706 Defining_Identifier => Subp_Id, 3707 Parameter_Type => 3708 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)), 3709 3710 Make_Parameter_Specification (Loc, 3711 Defining_Identifier => Asynch_P, 3712 Parameter_Type => 3713 New_Occurrence_Of (Standard_Boolean, Loc)), 3714 3715 Make_Parameter_Specification (Loc, 3716 Defining_Identifier => All_Calls_Remote, 3717 Parameter_Type => 3718 New_Occurrence_Of (Standard_Boolean, Loc))), 3719 3720 Result_Definition => 3721 New_Occurrence_Of (Fat_Type, Loc)); 3722 3723 -- Set the kind and return type of the function to prevent 3724 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. 3725 3726 Set_Ekind (Proc, E_Function); 3727 Set_Etype (Proc, Fat_Type); 3728 3729 Discard_Node ( 3730 Make_Subprogram_Body (Loc, 3731 Specification => Proc_Spec, 3732 Declarations => Proc_Decls, 3733 Handled_Statement_Sequence => 3734 Make_Handled_Sequence_Of_Statements (Loc, 3735 Statements => Proc_Statements))); 3736 3737 Set_TSS (Fat_Type, Proc); 3738 end Add_RAS_Access_TSS; 3739 3740 ----------------------- 3741 -- Add_RAST_Features -- 3742 ----------------------- 3743 3744 procedure Add_RAST_Features 3745 (Vis_Decl : Node_Id; 3746 RAS_Type : Entity_Id) 3747 is 3748 pragma Unreferenced (RAS_Type); 3749 begin 3750 Add_RAS_Access_TSS (Vis_Decl); 3751 end Add_RAST_Features; 3752 3753 ----------------------------------------- 3754 -- Add_Receiving_Stubs_To_Declarations -- 3755 ----------------------------------------- 3756 3757 procedure Add_Receiving_Stubs_To_Declarations 3758 (Pkg_Spec : Node_Id; 3759 Decls : List_Id; 3760 Stmts : List_Id) 3761 is 3762 Loc : constant Source_Ptr := Sloc (Pkg_Spec); 3763 3764 Request_Parameter : Node_Id; 3765 3766 Pkg_RPC_Receiver : constant Entity_Id := 3767 Make_Temporary (Loc, 'H'); 3768 Pkg_RPC_Receiver_Statements : List_Id; 3769 Pkg_RPC_Receiver_Cases : constant List_Id := New_List; 3770 Pkg_RPC_Receiver_Body : Node_Id; 3771 -- A Pkg_RPC_Receiver is built to decode the request 3772 3773 Lookup_RAS : Node_Id; 3774 Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R'); 3775 -- A remote subprogram is created to allow peers to look up RAS 3776 -- information using subprogram ids. 3777 3778 Subp_Id : Entity_Id; 3779 Subp_Index : Entity_Id; 3780 -- Subprogram_Id as read from the incoming stream 3781 3782 Current_Subp_Number : Int := First_RCI_Subprogram_Id; 3783 Current_Stubs : Node_Id; 3784 3785 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); 3786 Subp_Info_List : constant List_Id := New_List; 3787 3788 Register_Pkg_Actuals : constant List_Id := New_List; 3789 3790 All_Calls_Remote_E : Entity_Id; 3791 Proxy_Object_Addr : Entity_Id; 3792 3793 procedure Append_Stubs_To 3794 (RPC_Receiver_Cases : List_Id; 3795 Stubs : Node_Id; 3796 Subprogram_Number : Int); 3797 -- Add one case to the specified RPC receiver case list 3798 -- associating Subprogram_Number with the subprogram declared 3799 -- by Declaration, for which we have receiving stubs in Stubs. 3800 3801 procedure Visit_Subprogram (Decl : Node_Id); 3802 -- Generate receiving stub for one remote subprogram 3803 3804 --------------------- 3805 -- Append_Stubs_To -- 3806 --------------------- 3807 3808 procedure Append_Stubs_To 3809 (RPC_Receiver_Cases : List_Id; 3810 Stubs : Node_Id; 3811 Subprogram_Number : Int) 3812 is 3813 begin 3814 Append_To (RPC_Receiver_Cases, 3815 Make_Case_Statement_Alternative (Loc, 3816 Discrete_Choices => 3817 New_List (Make_Integer_Literal (Loc, Subprogram_Number)), 3818 Statements => 3819 New_List ( 3820 Make_Procedure_Call_Statement (Loc, 3821 Name => 3822 New_Occurrence_Of (Defining_Entity (Stubs), Loc), 3823 Parameter_Associations => New_List ( 3824 New_Occurrence_Of (Request_Parameter, Loc)))))); 3825 end Append_Stubs_To; 3826 3827 ---------------------- 3828 -- Visit_Subprogram -- 3829 ---------------------- 3830 3831 procedure Visit_Subprogram (Decl : Node_Id) is 3832 Loc : constant Source_Ptr := Sloc (Decl); 3833 Spec : constant Node_Id := Specification (Decl); 3834 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); 3835 3836 Subp_Val : String_Id; 3837 pragma Warnings (Off, Subp_Val); 3838 3839 begin 3840 -- Disable expansion of stubs if serious errors have been 3841 -- diagnosed, because otherwise some illegal remote subprogram 3842 -- declarations could cause cascaded errors in stubs. 3843 3844 if Serious_Errors_Detected /= 0 then 3845 return; 3846 end if; 3847 3848 -- Build receiving stub 3849 3850 Current_Stubs := 3851 Build_Subprogram_Receiving_Stubs 3852 (Vis_Decl => Decl, 3853 Asynchronous => 3854 Nkind (Spec) = N_Procedure_Specification 3855 and then Is_Asynchronous (Subp_Def)); 3856 3857 Append_To (Decls, Current_Stubs); 3858 Analyze (Current_Stubs); 3859 3860 -- Build RAS proxy 3861 3862 Add_RAS_Proxy_And_Analyze (Decls, 3863 Vis_Decl => Decl, 3864 All_Calls_Remote_E => All_Calls_Remote_E, 3865 Proxy_Object_Addr => Proxy_Object_Addr); 3866 3867 -- Compute distribution identifier 3868 3869 Assign_Subprogram_Identifier 3870 (Subp_Def, Current_Subp_Number, Subp_Val); 3871 3872 pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); 3873 3874 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms 3875 -- table for this receiver. This aggregate must be kept consistent 3876 -- with the declaration of RCI_Subp_Info in 3877 -- System.Partition_Interface. 3878 3879 Append_To (Subp_Info_List, 3880 Make_Component_Association (Loc, 3881 Choices => New_List ( 3882 Make_Integer_Literal (Loc, Current_Subp_Number)), 3883 3884 Expression => 3885 Make_Aggregate (Loc, 3886 Component_Associations => New_List ( 3887 3888 -- Addr => 3889 3890 Make_Component_Association (Loc, 3891 Choices => 3892 New_List (Make_Identifier (Loc, Name_Addr)), 3893 Expression => 3894 New_Occurrence_Of (Proxy_Object_Addr, Loc)))))); 3895 3896 Append_Stubs_To (Pkg_RPC_Receiver_Cases, 3897 Stubs => Current_Stubs, 3898 Subprogram_Number => Current_Subp_Number); 3899 3900 Current_Subp_Number := Current_Subp_Number + 1; 3901 end Visit_Subprogram; 3902 3903 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); 3904 3905 -- Start of processing for Add_Receiving_Stubs_To_Declarations 3906 3907 begin 3908 -- Building receiving stubs consist in several operations: 3909 3910 -- - a package RPC receiver must be built. This subprogram 3911 -- will get a Subprogram_Id from the incoming stream 3912 -- and will dispatch the call to the right subprogram; 3913 3914 -- - a receiving stub for each subprogram visible in the package 3915 -- spec. This stub will read all the parameters from the stream, 3916 -- and put the result as well as the exception occurrence in the 3917 -- output stream; 3918 3919 -- - a dummy package with an empty spec and a body made of an 3920 -- elaboration part, whose job is to register the receiving 3921 -- part of this RCI package on the name server. This is done 3922 -- by calling System.Partition_Interface.Register_Receiving_Stub. 3923 3924 Build_RPC_Receiver_Body ( 3925 RPC_Receiver => Pkg_RPC_Receiver, 3926 Request => Request_Parameter, 3927 Subp_Id => Subp_Id, 3928 Subp_Index => Subp_Index, 3929 Stmts => Pkg_RPC_Receiver_Statements, 3930 Decl => Pkg_RPC_Receiver_Body); 3931 pragma Assert (Subp_Id = Subp_Index); 3932 3933 -- A null subp_id denotes a call through a RAS, in which case the 3934 -- next Uint_64 element in the stream is the address of the local 3935 -- proxy object, from which we can retrieve the actual subprogram id. 3936 3937 Append_To (Pkg_RPC_Receiver_Statements, 3938 Make_Implicit_If_Statement (Pkg_Spec, 3939 Condition => 3940 Make_Op_Eq (Loc, 3941 New_Occurrence_Of (Subp_Id, Loc), 3942 Make_Integer_Literal (Loc, 0)), 3943 3944 Then_Statements => New_List ( 3945 Make_Assignment_Statement (Loc, 3946 Name => 3947 New_Occurrence_Of (Subp_Id, Loc), 3948 3949 Expression => 3950 Make_Selected_Component (Loc, 3951 Prefix => 3952 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), 3953 OK_Convert_To (RTE (RE_Address), 3954 Make_Attribute_Reference (Loc, 3955 Prefix => 3956 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), 3957 Attribute_Name => 3958 Name_Input, 3959 Expressions => New_List ( 3960 Make_Selected_Component (Loc, 3961 Prefix => Request_Parameter, 3962 Selector_Name => Name_Params))))), 3963 3964 Selector_Name => Make_Identifier (Loc, Name_Subp_Id)))))); 3965 3966 -- Build a subprogram for RAS information lookups 3967 3968 Lookup_RAS := 3969 Make_Subprogram_Declaration (Loc, 3970 Specification => 3971 Make_Function_Specification (Loc, 3972 Defining_Unit_Name => 3973 Lookup_RAS_Info, 3974 Parameter_Specifications => New_List ( 3975 Make_Parameter_Specification (Loc, 3976 Defining_Identifier => 3977 Make_Defining_Identifier (Loc, Name_Subp_Id), 3978 In_Present => 3979 True, 3980 Parameter_Type => 3981 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), 3982 Result_Definition => 3983 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); 3984 Append_To (Decls, Lookup_RAS); 3985 Analyze (Lookup_RAS); 3986 3987 Current_Stubs := Build_Subprogram_Receiving_Stubs 3988 (Vis_Decl => Lookup_RAS, 3989 Asynchronous => False); 3990 Append_To (Decls, Current_Stubs); 3991 Analyze (Current_Stubs); 3992 3993 Append_Stubs_To (Pkg_RPC_Receiver_Cases, 3994 Stubs => Current_Stubs, 3995 Subprogram_Number => 1); 3996 3997 -- For each subprogram, the receiving stub will be built and a 3998 -- case statement will be made on the Subprogram_Id to dispatch 3999 -- to the right subprogram. 4000 4001 All_Calls_Remote_E := 4002 Boolean_Literals 4003 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); 4004 4005 Overload_Counter_Table.Reset; 4006 4007 Visit_Spec (Pkg_Spec); 4008 4009 -- If we receive an invalid Subprogram_Id, it is best to do nothing 4010 -- rather than raising an exception since we do not want someone 4011 -- to crash a remote partition by sending invalid subprogram ids. 4012 -- This is consistent with the other parts of the case statement 4013 -- since even in presence of incorrect parameters in the stream, 4014 -- every exception will be caught and (if the subprogram is not an 4015 -- APC) put into the result stream and sent away. 4016 4017 Append_To (Pkg_RPC_Receiver_Cases, 4018 Make_Case_Statement_Alternative (Loc, 4019 Discrete_Choices => New_List (Make_Others_Choice (Loc)), 4020 Statements => New_List (Make_Null_Statement (Loc)))); 4021 4022 Append_To (Pkg_RPC_Receiver_Statements, 4023 Make_Case_Statement (Loc, 4024 Expression => New_Occurrence_Of (Subp_Id, Loc), 4025 Alternatives => Pkg_RPC_Receiver_Cases)); 4026 4027 Append_To (Decls, 4028 Make_Object_Declaration (Loc, 4029 Defining_Identifier => Subp_Info_Array, 4030 Constant_Present => True, 4031 Aliased_Present => True, 4032 Object_Definition => 4033 Make_Subtype_Indication (Loc, 4034 Subtype_Mark => 4035 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), 4036 Constraint => 4037 Make_Index_Or_Discriminant_Constraint (Loc, 4038 New_List ( 4039 Make_Range (Loc, 4040 Low_Bound => Make_Integer_Literal (Loc, 4041 First_RCI_Subprogram_Id), 4042 High_Bound => 4043 Make_Integer_Literal (Loc, 4044 Intval => 4045 First_RCI_Subprogram_Id 4046 + List_Length (Subp_Info_List) - 1))))))); 4047 4048 -- For a degenerate RCI with no visible subprograms, Subp_Info_List 4049 -- has zero length, and the declaration is for an empty array, in 4050 -- which case no initialization aggregate must be generated. 4051 4052 if Present (First (Subp_Info_List)) then 4053 Set_Expression (Last (Decls), 4054 Make_Aggregate (Loc, 4055 Component_Associations => Subp_Info_List)); 4056 4057 -- No initialization provided: remove CONSTANT so that the 4058 -- declaration is not an incomplete deferred constant. 4059 4060 else 4061 Set_Constant_Present (Last (Decls), False); 4062 end if; 4063 4064 Analyze (Last (Decls)); 4065 4066 declare 4067 Subp_Info_Addr : Node_Id; 4068 -- Return statement for Lookup_RAS_Info: address of the subprogram 4069 -- information record for the requested subprogram id. 4070 4071 begin 4072 if Present (First (Subp_Info_List)) then 4073 Subp_Info_Addr := 4074 Make_Selected_Component (Loc, 4075 Prefix => 4076 Make_Indexed_Component (Loc, 4077 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), 4078 Expressions => New_List ( 4079 Convert_To (Standard_Integer, 4080 Make_Identifier (Loc, Name_Subp_Id)))), 4081 Selector_Name => Make_Identifier (Loc, Name_Addr)); 4082 4083 -- Case of no visible subprogram: just raise Constraint_Error, we 4084 -- know for sure we got junk from a remote partition. 4085 4086 else 4087 Subp_Info_Addr := 4088 Make_Raise_Constraint_Error (Loc, 4089 Reason => CE_Range_Check_Failed); 4090 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64)); 4091 end if; 4092 4093 Append_To (Decls, 4094 Make_Subprogram_Body (Loc, 4095 Specification => 4096 Copy_Specification (Loc, Parent (Lookup_RAS_Info)), 4097 Declarations => No_List, 4098 Handled_Statement_Sequence => 4099 Make_Handled_Sequence_Of_Statements (Loc, 4100 Statements => New_List ( 4101 Make_Simple_Return_Statement (Loc, 4102 Expression => 4103 OK_Convert_To 4104 (RTE (RE_Unsigned_64), Subp_Info_Addr)))))); 4105 end; 4106 4107 Analyze (Last (Decls)); 4108 4109 Append_To (Decls, Pkg_RPC_Receiver_Body); 4110 Analyze (Last (Decls)); 4111 4112 -- Name 4113 4114 Append_To (Register_Pkg_Actuals, 4115 Make_String_Literal (Loc, 4116 Strval => 4117 Fully_Qualified_Name_String 4118 (Defining_Entity (Pkg_Spec), Append_NUL => False))); 4119 4120 -- Receiver 4121 4122 Append_To (Register_Pkg_Actuals, 4123 Make_Attribute_Reference (Loc, 4124 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), 4125 Attribute_Name => Name_Unrestricted_Access)); 4126 4127 -- Version 4128 4129 Append_To (Register_Pkg_Actuals, 4130 Make_Attribute_Reference (Loc, 4131 Prefix => 4132 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), 4133 Attribute_Name => Name_Version)); 4134 4135 -- Subp_Info 4136 4137 Append_To (Register_Pkg_Actuals, 4138 Make_Attribute_Reference (Loc, 4139 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), 4140 Attribute_Name => Name_Address)); 4141 4142 -- Subp_Info_Len 4143 4144 Append_To (Register_Pkg_Actuals, 4145 Make_Attribute_Reference (Loc, 4146 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), 4147 Attribute_Name => Name_Length)); 4148 4149 -- Generate the call 4150 4151 Append_To (Stmts, 4152 Make_Procedure_Call_Statement (Loc, 4153 Name => 4154 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc), 4155 Parameter_Associations => Register_Pkg_Actuals)); 4156 Analyze (Last (Stmts)); 4157 end Add_Receiving_Stubs_To_Declarations; 4158 4159 --------------------------------- 4160 -- Build_General_Calling_Stubs -- 4161 --------------------------------- 4162 4163 procedure Build_General_Calling_Stubs 4164 (Decls : List_Id; 4165 Statements : List_Id; 4166 Target_Partition : Entity_Id; 4167 Target_RPC_Receiver : Node_Id; 4168 Subprogram_Id : Node_Id; 4169 Asynchronous : Node_Id := Empty; 4170 Is_Known_Asynchronous : Boolean := False; 4171 Is_Known_Non_Asynchronous : Boolean := False; 4172 Is_Function : Boolean; 4173 Spec : Node_Id; 4174 Stub_Type : Entity_Id := Empty; 4175 RACW_Type : Entity_Id := Empty; 4176 Nod : Node_Id) 4177 is 4178 Loc : constant Source_Ptr := Sloc (Nod); 4179 4180 Stream_Parameter : Node_Id; 4181 -- Name of the stream used to transmit parameters to the remote 4182 -- package. 4183 4184 Result_Parameter : Node_Id; 4185 -- Name of the result parameter (in non-APC cases) which get the 4186 -- result of the remote subprogram. 4187 4188 Exception_Return_Parameter : Node_Id; 4189 -- Name of the parameter which will hold the exception sent by the 4190 -- remote subprogram. 4191 4192 Current_Parameter : Node_Id; 4193 -- Current parameter being handled 4194 4195 Ordered_Parameters_List : constant List_Id := 4196 Build_Ordered_Parameters_List (Spec); 4197 4198 Asynchronous_Statements : List_Id := No_List; 4199 Non_Asynchronous_Statements : List_Id := No_List; 4200 -- Statements specifics to the Asynchronous/Non-Asynchronous cases 4201 4202 Extra_Formal_Statements : constant List_Id := New_List; 4203 -- List of statements for extra formal parameters. It will appear 4204 -- after the regular statements for writing out parameters. 4205 4206 pragma Unreferenced (RACW_Type); 4207 -- Used only for the PolyORB case 4208 4209 begin 4210 -- The general form of a calling stub for a given subprogram is: 4211 4212 -- procedure X (...) is P : constant Partition_ID := 4213 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased 4214 -- System.RPC.Params_Stream_Type (0); begin 4215 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver 4216 -- comes from RCI_Cache.Get_RCI_Package_Receiver) 4217 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC 4218 -- (Stream, Result); Read_Exception_Occurrence_From_Result; 4219 -- Raise_It; 4220 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X; 4221 4222 -- There are some variations: Do_APC is called for an asynchronous 4223 -- procedure and the part after the call is completely ommitted as 4224 -- well as the declaration of Result. For a function call, 'Input is 4225 -- always used to read the result even if it is constrained. 4226 4227 Stream_Parameter := Make_Temporary (Loc, 'S'); 4228 4229 Append_To (Decls, 4230 Make_Object_Declaration (Loc, 4231 Defining_Identifier => Stream_Parameter, 4232 Aliased_Present => True, 4233 Object_Definition => 4234 Make_Subtype_Indication (Loc, 4235 Subtype_Mark => 4236 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), 4237 Constraint => 4238 Make_Index_Or_Discriminant_Constraint (Loc, 4239 Constraints => 4240 New_List (Make_Integer_Literal (Loc, 0)))))); 4241 4242 if not Is_Known_Asynchronous then 4243 Result_Parameter := Make_Temporary (Loc, 'R'); 4244 4245 Append_To (Decls, 4246 Make_Object_Declaration (Loc, 4247 Defining_Identifier => Result_Parameter, 4248 Aliased_Present => True, 4249 Object_Definition => 4250 Make_Subtype_Indication (Loc, 4251 Subtype_Mark => 4252 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), 4253 Constraint => 4254 Make_Index_Or_Discriminant_Constraint (Loc, 4255 Constraints => 4256 New_List (Make_Integer_Literal (Loc, 0)))))); 4257 4258 Exception_Return_Parameter := Make_Temporary (Loc, 'E'); 4259 4260 Append_To (Decls, 4261 Make_Object_Declaration (Loc, 4262 Defining_Identifier => Exception_Return_Parameter, 4263 Object_Definition => 4264 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); 4265 4266 else 4267 Result_Parameter := Empty; 4268 Exception_Return_Parameter := Empty; 4269 end if; 4270 4271 -- Put first the RPC receiver corresponding to the remote package 4272 4273 Append_To (Statements, 4274 Make_Attribute_Reference (Loc, 4275 Prefix => 4276 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), 4277 Attribute_Name => Name_Write, 4278 Expressions => New_List ( 4279 Make_Attribute_Reference (Loc, 4280 Prefix => New_Occurrence_Of (Stream_Parameter, Loc), 4281 Attribute_Name => Name_Access), 4282 Target_RPC_Receiver))); 4283 4284 -- Then put the Subprogram_Id of the subprogram we want to call in 4285 -- the stream. 4286 4287 Append_To (Statements, 4288 Make_Attribute_Reference (Loc, 4289 Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), 4290 Attribute_Name => Name_Write, 4291 Expressions => New_List ( 4292 Make_Attribute_Reference (Loc, 4293 Prefix => New_Occurrence_Of (Stream_Parameter, Loc), 4294 Attribute_Name => Name_Access), 4295 Subprogram_Id))); 4296 4297 Current_Parameter := First (Ordered_Parameters_List); 4298 while Present (Current_Parameter) loop 4299 declare 4300 Typ : constant Node_Id := 4301 Parameter_Type (Current_Parameter); 4302 Etyp : Entity_Id; 4303 Constrained : Boolean; 4304 Value : Node_Id; 4305 Extra_Parameter : Entity_Id; 4306 4307 begin 4308 if Is_RACW_Controlling_Formal 4309 (Current_Parameter, Stub_Type) 4310 then 4311 -- In the case of a controlling formal argument, we marshall 4312 -- its addr field rather than the local stub. 4313 4314 Append_To (Statements, 4315 Pack_Node_Into_Stream (Loc, 4316 Stream => Stream_Parameter, 4317 Object => 4318 Make_Selected_Component (Loc, 4319 Prefix => 4320 Defining_Identifier (Current_Parameter), 4321 Selector_Name => Name_Addr), 4322 Etyp => RTE (RE_Unsigned_64))); 4323 4324 else 4325 Value := 4326 New_Occurrence_Of 4327 (Defining_Identifier (Current_Parameter), Loc); 4328 4329 -- Access type parameters are transmitted as in out 4330 -- parameters. However, a dereference is needed so that 4331 -- we marshall the designated object. 4332 4333 if Nkind (Typ) = N_Access_Definition then 4334 Value := Make_Explicit_Dereference (Loc, Value); 4335 Etyp := Etype (Subtype_Mark (Typ)); 4336 else 4337 Etyp := Etype (Typ); 4338 end if; 4339 4340 Constrained := not Transmit_As_Unconstrained (Etyp); 4341 4342 -- Any parameter but unconstrained out parameters are 4343 -- transmitted to the peer. 4344 4345 if In_Present (Current_Parameter) 4346 or else not Out_Present (Current_Parameter) 4347 or else not Constrained 4348 then 4349 Append_To (Statements, 4350 Make_Attribute_Reference (Loc, 4351 Prefix => New_Occurrence_Of (Etyp, Loc), 4352 Attribute_Name => 4353 Output_From_Constrained (Constrained), 4354 Expressions => New_List ( 4355 Make_Attribute_Reference (Loc, 4356 Prefix => 4357 New_Occurrence_Of (Stream_Parameter, Loc), 4358 Attribute_Name => Name_Access), 4359 Value))); 4360 end if; 4361 end if; 4362 4363 -- If the current parameter has a dynamic constrained status, 4364 -- then this status is transmitted as well. 4365 -- This should be done for accessibility as well ??? 4366 4367 if Nkind (Typ) /= N_Access_Definition 4368 and then Need_Extra_Constrained (Current_Parameter) 4369 then 4370 -- In this block, we do not use the extra formal that has 4371 -- been created because it does not exist at the time of 4372 -- expansion when building calling stubs for remote access 4373 -- to subprogram types. We create an extra variable of this 4374 -- type and push it in the stream after the regular 4375 -- parameters. 4376 4377 Extra_Parameter := Make_Temporary (Loc, 'P'); 4378 4379 Append_To (Decls, 4380 Make_Object_Declaration (Loc, 4381 Defining_Identifier => Extra_Parameter, 4382 Constant_Present => True, 4383 Object_Definition => 4384 New_Occurrence_Of (Standard_Boolean, Loc), 4385 Expression => 4386 Make_Attribute_Reference (Loc, 4387 Prefix => 4388 New_Occurrence_Of ( 4389 Defining_Identifier (Current_Parameter), Loc), 4390 Attribute_Name => Name_Constrained))); 4391 4392 Append_To (Extra_Formal_Statements, 4393 Make_Attribute_Reference (Loc, 4394 Prefix => 4395 New_Occurrence_Of (Standard_Boolean, Loc), 4396 Attribute_Name => Name_Write, 4397 Expressions => New_List ( 4398 Make_Attribute_Reference (Loc, 4399 Prefix => 4400 New_Occurrence_Of 4401 (Stream_Parameter, Loc), Attribute_Name => 4402 Name_Access), 4403 New_Occurrence_Of (Extra_Parameter, Loc)))); 4404 end if; 4405 4406 Next (Current_Parameter); 4407 end; 4408 end loop; 4409 4410 -- Append the formal statements list to the statements 4411 4412 Append_List_To (Statements, Extra_Formal_Statements); 4413 4414 if not Is_Known_Non_Asynchronous then 4415 4416 -- Build the call to System.RPC.Do_APC 4417 4418 Asynchronous_Statements := New_List ( 4419 Make_Procedure_Call_Statement (Loc, 4420 Name => 4421 New_Occurrence_Of (RTE (RE_Do_Apc), Loc), 4422 Parameter_Associations => New_List ( 4423 New_Occurrence_Of (Target_Partition, Loc), 4424 Make_Attribute_Reference (Loc, 4425 Prefix => 4426 New_Occurrence_Of (Stream_Parameter, Loc), 4427 Attribute_Name => Name_Access)))); 4428 else 4429 Asynchronous_Statements := No_List; 4430 end if; 4431 4432 if not Is_Known_Asynchronous then 4433 4434 -- Build the call to System.RPC.Do_RPC 4435 4436 Non_Asynchronous_Statements := New_List ( 4437 Make_Procedure_Call_Statement (Loc, 4438 Name => 4439 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc), 4440 Parameter_Associations => New_List ( 4441 New_Occurrence_Of (Target_Partition, Loc), 4442 4443 Make_Attribute_Reference (Loc, 4444 Prefix => 4445 New_Occurrence_Of (Stream_Parameter, Loc), 4446 Attribute_Name => Name_Access), 4447 4448 Make_Attribute_Reference (Loc, 4449 Prefix => 4450 New_Occurrence_Of (Result_Parameter, Loc), 4451 Attribute_Name => Name_Access)))); 4452 4453 -- Read the exception occurrence from the result stream and 4454 -- reraise it. It does no harm if this is a Null_Occurrence since 4455 -- this does nothing. 4456 4457 Append_To (Non_Asynchronous_Statements, 4458 Make_Attribute_Reference (Loc, 4459 Prefix => 4460 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), 4461 4462 Attribute_Name => Name_Read, 4463 4464 Expressions => New_List ( 4465 Make_Attribute_Reference (Loc, 4466 Prefix => 4467 New_Occurrence_Of (Result_Parameter, Loc), 4468 Attribute_Name => Name_Access), 4469 New_Occurrence_Of (Exception_Return_Parameter, Loc)))); 4470 4471 Append_To (Non_Asynchronous_Statements, 4472 Make_Procedure_Call_Statement (Loc, 4473 Name => 4474 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), 4475 Parameter_Associations => New_List ( 4476 New_Occurrence_Of (Exception_Return_Parameter, Loc)))); 4477 4478 if Is_Function then 4479 4480 -- If this is a function call, then read the value and return 4481 -- it. The return value is written/read using 'Output/'Input. 4482 4483 Append_To (Non_Asynchronous_Statements, 4484 Make_Tag_Check (Loc, 4485 Make_Simple_Return_Statement (Loc, 4486 Expression => 4487 Make_Attribute_Reference (Loc, 4488 Prefix => 4489 New_Occurrence_Of ( 4490 Etype (Result_Definition (Spec)), Loc), 4491 4492 Attribute_Name => Name_Input, 4493 4494 Expressions => New_List ( 4495 Make_Attribute_Reference (Loc, 4496 Prefix => 4497 New_Occurrence_Of (Result_Parameter, Loc), 4498 Attribute_Name => Name_Access)))))); 4499 4500 else 4501 -- Loop around parameters and assign out (or in out) 4502 -- parameters. In the case of RACW, controlling arguments 4503 -- cannot possibly have changed since they are remote, so 4504 -- we do not read them from the stream. 4505 4506 Current_Parameter := First (Ordered_Parameters_List); 4507 while Present (Current_Parameter) loop 4508 declare 4509 Typ : constant Node_Id := 4510 Parameter_Type (Current_Parameter); 4511 Etyp : Entity_Id; 4512 Value : Node_Id; 4513 4514 begin 4515 Value := 4516 New_Occurrence_Of 4517 (Defining_Identifier (Current_Parameter), Loc); 4518 4519 if Nkind (Typ) = N_Access_Definition then 4520 Value := Make_Explicit_Dereference (Loc, Value); 4521 Etyp := Etype (Subtype_Mark (Typ)); 4522 else 4523 Etyp := Etype (Typ); 4524 end if; 4525 4526 if (Out_Present (Current_Parameter) 4527 or else Nkind (Typ) = N_Access_Definition) 4528 and then Etyp /= Stub_Type 4529 then 4530 Append_To (Non_Asynchronous_Statements, 4531 Make_Attribute_Reference (Loc, 4532 Prefix => 4533 New_Occurrence_Of (Etyp, Loc), 4534 4535 Attribute_Name => Name_Read, 4536 4537 Expressions => New_List ( 4538 Make_Attribute_Reference (Loc, 4539 Prefix => 4540 New_Occurrence_Of (Result_Parameter, Loc), 4541 Attribute_Name => Name_Access), 4542 Value))); 4543 end if; 4544 end; 4545 4546 Next (Current_Parameter); 4547 end loop; 4548 end if; 4549 end if; 4550 4551 if Is_Known_Asynchronous then 4552 Append_List_To (Statements, Asynchronous_Statements); 4553 4554 elsif Is_Known_Non_Asynchronous then 4555 Append_List_To (Statements, Non_Asynchronous_Statements); 4556 4557 else 4558 pragma Assert (Present (Asynchronous)); 4559 Prepend_To (Asynchronous_Statements, 4560 Make_Attribute_Reference (Loc, 4561 Prefix => New_Occurrence_Of (Standard_Boolean, Loc), 4562 Attribute_Name => Name_Write, 4563 Expressions => New_List ( 4564 Make_Attribute_Reference (Loc, 4565 Prefix => 4566 New_Occurrence_Of (Stream_Parameter, Loc), 4567 Attribute_Name => Name_Access), 4568 New_Occurrence_Of (Standard_True, Loc)))); 4569 4570 Prepend_To (Non_Asynchronous_Statements, 4571 Make_Attribute_Reference (Loc, 4572 Prefix => New_Occurrence_Of (Standard_Boolean, Loc), 4573 Attribute_Name => Name_Write, 4574 Expressions => New_List ( 4575 Make_Attribute_Reference (Loc, 4576 Prefix => 4577 New_Occurrence_Of (Stream_Parameter, Loc), 4578 Attribute_Name => Name_Access), 4579 New_Occurrence_Of (Standard_False, Loc)))); 4580 4581 Append_To (Statements, 4582 Make_Implicit_If_Statement (Nod, 4583 Condition => Asynchronous, 4584 Then_Statements => Asynchronous_Statements, 4585 Else_Statements => Non_Asynchronous_Statements)); 4586 end if; 4587 end Build_General_Calling_Stubs; 4588 4589 ----------------------------- 4590 -- Build_RPC_Receiver_Body -- 4591 ----------------------------- 4592 4593 procedure Build_RPC_Receiver_Body 4594 (RPC_Receiver : Entity_Id; 4595 Request : out Entity_Id; 4596 Subp_Id : out Entity_Id; 4597 Subp_Index : out Entity_Id; 4598 Stmts : out List_Id; 4599 Decl : out Node_Id) 4600 is 4601 Loc : constant Source_Ptr := Sloc (RPC_Receiver); 4602 4603 RPC_Receiver_Spec : Node_Id; 4604 RPC_Receiver_Decls : List_Id; 4605 4606 begin 4607 Request := Make_Defining_Identifier (Loc, Name_R); 4608 4609 RPC_Receiver_Spec := 4610 Build_RPC_Receiver_Specification 4611 (RPC_Receiver => RPC_Receiver, 4612 Request_Parameter => Request); 4613 4614 Subp_Id := Make_Temporary (Loc, 'P'); 4615 Subp_Index := Subp_Id; 4616 4617 -- Subp_Id may not be a constant, because in the case of the RPC 4618 -- receiver for an RCI package, when a call is received from a RAS 4619 -- dereference, it will be assigned during subsequent processing. 4620 4621 RPC_Receiver_Decls := New_List ( 4622 Make_Object_Declaration (Loc, 4623 Defining_Identifier => Subp_Id, 4624 Object_Definition => 4625 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), 4626 Expression => 4627 Make_Attribute_Reference (Loc, 4628 Prefix => 4629 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), 4630 Attribute_Name => Name_Input, 4631 Expressions => New_List ( 4632 Make_Selected_Component (Loc, 4633 Prefix => Request, 4634 Selector_Name => Name_Params))))); 4635 4636 Stmts := New_List; 4637 4638 Decl := 4639 Make_Subprogram_Body (Loc, 4640 Specification => RPC_Receiver_Spec, 4641 Declarations => RPC_Receiver_Decls, 4642 Handled_Statement_Sequence => 4643 Make_Handled_Sequence_Of_Statements (Loc, 4644 Statements => Stmts)); 4645 end Build_RPC_Receiver_Body; 4646 4647 ----------------------- 4648 -- Build_Stub_Target -- 4649 ----------------------- 4650 4651 function Build_Stub_Target 4652 (Loc : Source_Ptr; 4653 Decls : List_Id; 4654 RCI_Locator : Entity_Id; 4655 Controlling_Parameter : Entity_Id) return RPC_Target 4656 is 4657 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA); 4658 4659 begin 4660 Target_Info.Partition := Make_Temporary (Loc, 'P'); 4661 4662 if Present (Controlling_Parameter) then 4663 Append_To (Decls, 4664 Make_Object_Declaration (Loc, 4665 Defining_Identifier => Target_Info.Partition, 4666 Constant_Present => True, 4667 Object_Definition => 4668 New_Occurrence_Of (RTE (RE_Partition_ID), Loc), 4669 4670 Expression => 4671 Make_Selected_Component (Loc, 4672 Prefix => Controlling_Parameter, 4673 Selector_Name => Name_Origin))); 4674 4675 Target_Info.RPC_Receiver := 4676 Make_Selected_Component (Loc, 4677 Prefix => Controlling_Parameter, 4678 Selector_Name => Name_Receiver); 4679 4680 else 4681 Append_To (Decls, 4682 Make_Object_Declaration (Loc, 4683 Defining_Identifier => Target_Info.Partition, 4684 Constant_Present => True, 4685 Object_Definition => 4686 New_Occurrence_Of (RTE (RE_Partition_ID), Loc), 4687 4688 Expression => 4689 Make_Function_Call (Loc, 4690 Name => Make_Selected_Component (Loc, 4691 Prefix => 4692 Make_Identifier (Loc, Chars (RCI_Locator)), 4693 Selector_Name => 4694 Make_Identifier (Loc, 4695 Name_Get_Active_Partition_ID))))); 4696 4697 Target_Info.RPC_Receiver := 4698 Make_Selected_Component (Loc, 4699 Prefix => 4700 Make_Identifier (Loc, Chars (RCI_Locator)), 4701 Selector_Name => 4702 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver)); 4703 end if; 4704 return Target_Info; 4705 end Build_Stub_Target; 4706 4707 -------------------------------------- 4708 -- Build_Subprogram_Receiving_Stubs -- 4709 -------------------------------------- 4710 4711 function Build_Subprogram_Receiving_Stubs 4712 (Vis_Decl : Node_Id; 4713 Asynchronous : Boolean; 4714 Dynamically_Asynchronous : Boolean := False; 4715 Stub_Type : Entity_Id := Empty; 4716 RACW_Type : Entity_Id := Empty; 4717 Parent_Primitive : Entity_Id := Empty) return Node_Id 4718 is 4719 Loc : constant Source_Ptr := Sloc (Vis_Decl); 4720 4721 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); 4722 -- Formal parameter for receiving stubs: a descriptor for an incoming 4723 -- request. 4724 4725 Decls : constant List_Id := New_List; 4726 -- All the parameters will get declared before calling the real 4727 -- subprograms. Also the out parameters will be declared. 4728 4729 Statements : constant List_Id := New_List; 4730 4731 Extra_Formal_Statements : constant List_Id := New_List; 4732 -- Statements concerning extra formal parameters 4733 4734 After_Statements : constant List_Id := New_List; 4735 -- Statements to be executed after the subprogram call 4736 4737 Inner_Decls : List_Id := No_List; 4738 -- In case of a function, the inner declarations are needed since 4739 -- the result may be unconstrained. 4740 4741 Excep_Handlers : List_Id := No_List; 4742 Excep_Choice : Entity_Id; 4743 Excep_Code : List_Id; 4744 4745 Parameter_List : constant List_Id := New_List; 4746 -- List of parameters to be passed to the subprogram 4747 4748 Current_Parameter : Node_Id; 4749 4750 Ordered_Parameters_List : constant List_Id := 4751 Build_Ordered_Parameters_List 4752 (Specification (Vis_Decl)); 4753 4754 Subp_Spec : Node_Id; 4755 -- Subprogram specification 4756 4757 Called_Subprogram : Node_Id; 4758 -- The subprogram to call 4759 4760 Null_Raise_Statement : Node_Id; 4761 4762 Dynamic_Async : Entity_Id; 4763 4764 begin 4765 if Present (RACW_Type) then 4766 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc); 4767 else 4768 Called_Subprogram := 4769 New_Occurrence_Of 4770 (Defining_Unit_Name (Specification (Vis_Decl)), Loc); 4771 end if; 4772 4773 if Dynamically_Asynchronous then 4774 Dynamic_Async := Make_Temporary (Loc, 'S'); 4775 else 4776 Dynamic_Async := Empty; 4777 end if; 4778 4779 if not Asynchronous or Dynamically_Asynchronous then 4780 4781 -- The first statement after the subprogram call is a statement to 4782 -- write a Null_Occurrence into the result stream. 4783 4784 Null_Raise_Statement := 4785 Make_Attribute_Reference (Loc, 4786 Prefix => 4787 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), 4788 Attribute_Name => Name_Write, 4789 Expressions => New_List ( 4790 Make_Selected_Component (Loc, 4791 Prefix => Request_Parameter, 4792 Selector_Name => Name_Result), 4793 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); 4794 4795 if Dynamically_Asynchronous then 4796 Null_Raise_Statement := 4797 Make_Implicit_If_Statement (Vis_Decl, 4798 Condition => 4799 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), 4800 Then_Statements => New_List (Null_Raise_Statement)); 4801 end if; 4802 4803 Append_To (After_Statements, Null_Raise_Statement); 4804 end if; 4805 4806 -- Loop through every parameter and get its value from the stream. If 4807 -- the parameter is unconstrained, then the parameter is read using 4808 -- 'Input at the point of declaration. 4809 4810 Current_Parameter := First (Ordered_Parameters_List); 4811 while Present (Current_Parameter) loop 4812 declare 4813 Etyp : Entity_Id; 4814 Constrained : Boolean; 4815 4816 Need_Extra_Constrained : Boolean; 4817 -- True when an Extra_Constrained actual is required 4818 4819 Object : constant Entity_Id := Make_Temporary (Loc, 'P'); 4820 4821 Expr : Node_Id := Empty; 4822 4823 Is_Controlling_Formal : constant Boolean := 4824 Is_RACW_Controlling_Formal 4825 (Current_Parameter, Stub_Type); 4826 4827 begin 4828 if Is_Controlling_Formal then 4829 4830 -- We have a controlling formal parameter. Read its address 4831 -- rather than a real object. The address is in Unsigned_64 4832 -- form. 4833 4834 Etyp := RTE (RE_Unsigned_64); 4835 else 4836 Etyp := Etype (Parameter_Type (Current_Parameter)); 4837 end if; 4838 4839 Constrained := not Transmit_As_Unconstrained (Etyp); 4840 4841 if In_Present (Current_Parameter) 4842 or else not Out_Present (Current_Parameter) 4843 or else not Constrained 4844 or else Is_Controlling_Formal 4845 then 4846 -- If an input parameter is constrained, then the read of 4847 -- the parameter is deferred until the beginning of the 4848 -- subprogram body. If it is unconstrained, then an 4849 -- expression is built for the object declaration and the 4850 -- variable is set using 'Input instead of 'Read. Note that 4851 -- this deferral does not change the order in which the 4852 -- actuals are read because Build_Ordered_Parameter_List 4853 -- puts them unconstrained first. 4854 4855 if Constrained then 4856 Append_To (Statements, 4857 Make_Attribute_Reference (Loc, 4858 Prefix => New_Occurrence_Of (Etyp, Loc), 4859 Attribute_Name => Name_Read, 4860 Expressions => New_List ( 4861 Make_Selected_Component (Loc, 4862 Prefix => Request_Parameter, 4863 Selector_Name => Name_Params), 4864 New_Occurrence_Of (Object, Loc)))); 4865 4866 else 4867 4868 -- Build and append Input_With_Tag_Check function 4869 4870 Append_To (Decls, 4871 Input_With_Tag_Check (Loc, 4872 Var_Type => Etyp, 4873 Stream => 4874 Make_Selected_Component (Loc, 4875 Prefix => Request_Parameter, 4876 Selector_Name => Name_Params))); 4877 4878 -- Prepare function call expression 4879 4880 Expr := 4881 Make_Function_Call (Loc, 4882 Name => 4883 New_Occurrence_Of 4884 (Defining_Unit_Name 4885 (Specification (Last (Decls))), Loc)); 4886 end if; 4887 end if; 4888 4889 Need_Extra_Constrained := 4890 Nkind (Parameter_Type (Current_Parameter)) /= 4891 N_Access_Definition 4892 and then 4893 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void 4894 and then 4895 Present (Extra_Constrained 4896 (Defining_Identifier (Current_Parameter))); 4897 4898 -- We may not associate an extra constrained actual to a 4899 -- constant object, so if one is needed, declare the actual 4900 -- as a variable even if it won't be modified. 4901 4902 Build_Actual_Object_Declaration 4903 (Object => Object, 4904 Etyp => Etyp, 4905 Variable => Need_Extra_Constrained 4906 or else Out_Present (Current_Parameter), 4907 Expr => Expr, 4908 Decls => Decls); 4909 4910 -- An out parameter may be written back using a 'Write 4911 -- attribute instead of a 'Output because it has been 4912 -- constrained by the parameter given to the caller. Note that 4913 -- out controlling arguments in the case of a RACW are not put 4914 -- back in the stream because the pointer on them has not 4915 -- changed. 4916 4917 if Out_Present (Current_Parameter) 4918 and then 4919 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type 4920 then 4921 Append_To (After_Statements, 4922 Make_Attribute_Reference (Loc, 4923 Prefix => New_Occurrence_Of (Etyp, Loc), 4924 Attribute_Name => Name_Write, 4925 Expressions => New_List ( 4926 Make_Selected_Component (Loc, 4927 Prefix => Request_Parameter, 4928 Selector_Name => Name_Result), 4929 New_Occurrence_Of (Object, Loc)))); 4930 end if; 4931 4932 -- For RACW controlling formals, the Etyp of Object is always 4933 -- an RACW, even if the parameter is not of an anonymous access 4934 -- type. In such case, we need to dereference it at call time. 4935 4936 if Is_Controlling_Formal then 4937 if Nkind (Parameter_Type (Current_Parameter)) /= 4938 N_Access_Definition 4939 then 4940 Append_To (Parameter_List, 4941 Make_Parameter_Association (Loc, 4942 Selector_Name => 4943 New_Occurrence_Of ( 4944 Defining_Identifier (Current_Parameter), Loc), 4945 Explicit_Actual_Parameter => 4946 Make_Explicit_Dereference (Loc, 4947 Unchecked_Convert_To (RACW_Type, 4948 OK_Convert_To (RTE (RE_Address), 4949 New_Occurrence_Of (Object, Loc)))))); 4950 4951 else 4952 Append_To (Parameter_List, 4953 Make_Parameter_Association (Loc, 4954 Selector_Name => 4955 New_Occurrence_Of ( 4956 Defining_Identifier (Current_Parameter), Loc), 4957 Explicit_Actual_Parameter => 4958 Unchecked_Convert_To (RACW_Type, 4959 OK_Convert_To (RTE (RE_Address), 4960 New_Occurrence_Of (Object, Loc))))); 4961 end if; 4962 4963 else 4964 Append_To (Parameter_List, 4965 Make_Parameter_Association (Loc, 4966 Selector_Name => 4967 New_Occurrence_Of ( 4968 Defining_Identifier (Current_Parameter), Loc), 4969 Explicit_Actual_Parameter => 4970 New_Occurrence_Of (Object, Loc))); 4971 end if; 4972 4973 -- If the current parameter needs an extra formal, then read it 4974 -- from the stream and set the corresponding semantic field in 4975 -- the variable. If the kind of the parameter identifier is 4976 -- E_Void, then this is a compiler generated parameter that 4977 -- doesn't need an extra constrained status. 4978 4979 -- The case of Extra_Accessibility should also be handled ??? 4980 4981 if Need_Extra_Constrained then 4982 declare 4983 Extra_Parameter : constant Entity_Id := 4984 Extra_Constrained 4985 (Defining_Identifier 4986 (Current_Parameter)); 4987 4988 Formal_Entity : constant Entity_Id := 4989 Make_Defining_Identifier 4990 (Loc, Chars (Extra_Parameter)); 4991 4992 Formal_Type : constant Entity_Id := 4993 Etype (Extra_Parameter); 4994 4995 begin 4996 Append_To (Decls, 4997 Make_Object_Declaration (Loc, 4998 Defining_Identifier => Formal_Entity, 4999 Object_Definition => 5000 New_Occurrence_Of (Formal_Type, Loc))); 5001 5002 Append_To (Extra_Formal_Statements, 5003 Make_Attribute_Reference (Loc, 5004 Prefix => New_Occurrence_Of ( 5005 Formal_Type, Loc), 5006 Attribute_Name => Name_Read, 5007 Expressions => New_List ( 5008 Make_Selected_Component (Loc, 5009 Prefix => Request_Parameter, 5010 Selector_Name => Name_Params), 5011 New_Occurrence_Of (Formal_Entity, Loc)))); 5012 5013 -- Note: the call to Set_Extra_Constrained below relies 5014 -- on the fact that Object's Ekind has been set by 5015 -- Build_Actual_Object_Declaration. 5016 5017 Set_Extra_Constrained (Object, Formal_Entity); 5018 end; 5019 end if; 5020 end; 5021 5022 Next (Current_Parameter); 5023 end loop; 5024 5025 -- Append the formal statements list at the end of regular statements 5026 5027 Append_List_To (Statements, Extra_Formal_Statements); 5028 5029 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then 5030 5031 -- The remote subprogram is a function. We build an inner block to 5032 -- be able to hold a potentially unconstrained result in a 5033 -- variable. 5034 5035 declare 5036 Etyp : constant Entity_Id := 5037 Etype (Result_Definition (Specification (Vis_Decl))); 5038 Result : constant Node_Id := Make_Temporary (Loc, 'R'); 5039 5040 begin 5041 Inner_Decls := New_List ( 5042 Make_Object_Declaration (Loc, 5043 Defining_Identifier => Result, 5044 Constant_Present => True, 5045 Object_Definition => New_Occurrence_Of (Etyp, Loc), 5046 Expression => 5047 Make_Function_Call (Loc, 5048 Name => Called_Subprogram, 5049 Parameter_Associations => Parameter_List))); 5050 5051 if Is_Class_Wide_Type (Etyp) then 5052 5053 -- For a remote call to a function with a class-wide type, 5054 -- check that the returned value satisfies the requirements 5055 -- of E.4(18). 5056 5057 Append_To (Inner_Decls, 5058 Make_Transportable_Check (Loc, 5059 New_Occurrence_Of (Result, Loc))); 5060 5061 end if; 5062 5063 Append_To (After_Statements, 5064 Make_Attribute_Reference (Loc, 5065 Prefix => New_Occurrence_Of (Etyp, Loc), 5066 Attribute_Name => Name_Output, 5067 Expressions => New_List ( 5068 Make_Selected_Component (Loc, 5069 Prefix => Request_Parameter, 5070 Selector_Name => Name_Result), 5071 New_Occurrence_Of (Result, Loc)))); 5072 end; 5073 5074 Append_To (Statements, 5075 Make_Block_Statement (Loc, 5076 Declarations => Inner_Decls, 5077 Handled_Statement_Sequence => 5078 Make_Handled_Sequence_Of_Statements (Loc, 5079 Statements => After_Statements))); 5080 5081 else 5082 -- The remote subprogram is a procedure. We do not need any inner 5083 -- block in this case. 5084 5085 if Dynamically_Asynchronous then 5086 Append_To (Decls, 5087 Make_Object_Declaration (Loc, 5088 Defining_Identifier => Dynamic_Async, 5089 Object_Definition => 5090 New_Occurrence_Of (Standard_Boolean, Loc))); 5091 5092 Append_To (Statements, 5093 Make_Attribute_Reference (Loc, 5094 Prefix => New_Occurrence_Of (Standard_Boolean, Loc), 5095 Attribute_Name => Name_Read, 5096 Expressions => New_List ( 5097 Make_Selected_Component (Loc, 5098 Prefix => Request_Parameter, 5099 Selector_Name => Name_Params), 5100 New_Occurrence_Of (Dynamic_Async, Loc)))); 5101 end if; 5102 5103 Append_To (Statements, 5104 Make_Procedure_Call_Statement (Loc, 5105 Name => Called_Subprogram, 5106 Parameter_Associations => Parameter_List)); 5107 5108 Append_List_To (Statements, After_Statements); 5109 end if; 5110 5111 if Asynchronous and then not Dynamically_Asynchronous then 5112 5113 -- For an asynchronous procedure, add a null exception handler 5114 5115 Excep_Handlers := New_List ( 5116 Make_Implicit_Exception_Handler (Loc, 5117 Exception_Choices => New_List (Make_Others_Choice (Loc)), 5118 Statements => New_List (Make_Null_Statement (Loc)))); 5119 5120 else 5121 -- In the other cases, if an exception is raised, then the 5122 -- exception occurrence is copied into the output stream and 5123 -- no other output parameter is written. 5124 5125 Excep_Choice := Make_Temporary (Loc, 'E'); 5126 5127 Excep_Code := New_List ( 5128 Make_Attribute_Reference (Loc, 5129 Prefix => 5130 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), 5131 Attribute_Name => Name_Write, 5132 Expressions => New_List ( 5133 Make_Selected_Component (Loc, 5134 Prefix => Request_Parameter, 5135 Selector_Name => Name_Result), 5136 New_Occurrence_Of (Excep_Choice, Loc)))); 5137 5138 if Dynamically_Asynchronous then 5139 Excep_Code := New_List ( 5140 Make_Implicit_If_Statement (Vis_Decl, 5141 Condition => Make_Op_Not (Loc, 5142 New_Occurrence_Of (Dynamic_Async, Loc)), 5143 Then_Statements => Excep_Code)); 5144 end if; 5145 5146 Excep_Handlers := New_List ( 5147 Make_Implicit_Exception_Handler (Loc, 5148 Choice_Parameter => Excep_Choice, 5149 Exception_Choices => New_List (Make_Others_Choice (Loc)), 5150 Statements => Excep_Code)); 5151 5152 end if; 5153 5154 Subp_Spec := 5155 Make_Procedure_Specification (Loc, 5156 Defining_Unit_Name => Make_Temporary (Loc, 'F'), 5157 5158 Parameter_Specifications => New_List ( 5159 Make_Parameter_Specification (Loc, 5160 Defining_Identifier => Request_Parameter, 5161 Parameter_Type => 5162 New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); 5163 5164 return 5165 Make_Subprogram_Body (Loc, 5166 Specification => Subp_Spec, 5167 Declarations => Decls, 5168 Handled_Statement_Sequence => 5169 Make_Handled_Sequence_Of_Statements (Loc, 5170 Statements => Statements, 5171 Exception_Handlers => Excep_Handlers)); 5172 end Build_Subprogram_Receiving_Stubs; 5173 5174 ------------ 5175 -- Result -- 5176 ------------ 5177 5178 function Result return Node_Id is 5179 begin 5180 return Make_Identifier (Loc, Name_V); 5181 end Result; 5182 5183 ----------------------- 5184 -- RPC_Receiver_Decl -- 5185 ----------------------- 5186 5187 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is 5188 Loc : constant Source_Ptr := Sloc (RACW_Type); 5189 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); 5190 5191 begin 5192 -- No RPC receiver for remote access-to-subprogram 5193 5194 if Is_RAS then 5195 return Empty; 5196 end if; 5197 5198 return 5199 Make_Subprogram_Declaration (Loc, 5200 Build_RPC_Receiver_Specification 5201 (RPC_Receiver => Make_Temporary (Loc, 'R'), 5202 Request_Parameter => Make_Defining_Identifier (Loc, Name_R))); 5203 end RPC_Receiver_Decl; 5204 5205 ---------------------- 5206 -- Stream_Parameter -- 5207 ---------------------- 5208 5209 function Stream_Parameter return Node_Id is 5210 begin 5211 return Make_Identifier (Loc, Name_S); 5212 end Stream_Parameter; 5213 5214 end GARLIC_Support; 5215 5216 ------------------------------- 5217 -- Get_And_Reset_RACW_Bodies -- 5218 ------------------------------- 5219 5220 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is 5221 Desig : constant Entity_Id := 5222 Etype (Designated_Type (RACW_Type)); 5223 5224 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig); 5225 5226 Body_Decls : List_Id; 5227 -- Returned list of declarations 5228 5229 begin 5230 if Stub_Elements = Empty_Stub_Structure then 5231 5232 -- Stub elements may be missing as a consequence of a previously 5233 -- detected error. 5234 5235 return No_List; 5236 end if; 5237 5238 Body_Decls := Stub_Elements.Body_Decls; 5239 Stub_Elements.Body_Decls := No_List; 5240 Stubs_Table.Set (Desig, Stub_Elements); 5241 return Body_Decls; 5242 end Get_And_Reset_RACW_Bodies; 5243 5244 ----------------------- 5245 -- Get_Stub_Elements -- 5246 ----------------------- 5247 5248 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is 5249 Desig : constant Entity_Id := 5250 Etype (Designated_Type (RACW_Type)); 5251 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); 5252 begin 5253 pragma Assert (Stub_Elements /= Empty_Stub_Structure); 5254 return Stub_Elements; 5255 end Get_Stub_Elements; 5256 5257 ----------------------- 5258 -- Get_Subprogram_Id -- 5259 ----------------------- 5260 5261 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is 5262 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier; 5263 begin 5264 pragma Assert (Result /= No_String); 5265 return Result; 5266 end Get_Subprogram_Id; 5267 5268 ----------------------- 5269 -- Get_Subprogram_Id -- 5270 ----------------------- 5271 5272 function Get_Subprogram_Id (Def : Entity_Id) return Int is 5273 begin 5274 return Get_Subprogram_Ids (Def).Int_Identifier; 5275 end Get_Subprogram_Id; 5276 5277 ------------------------ 5278 -- Get_Subprogram_Ids -- 5279 ------------------------ 5280 5281 function Get_Subprogram_Ids 5282 (Def : Entity_Id) return Subprogram_Identifiers 5283 is 5284 begin 5285 return Subprogram_Identifier_Table.Get (Def); 5286 end Get_Subprogram_Ids; 5287 5288 ---------- 5289 -- Hash -- 5290 ---------- 5291 5292 function Hash (F : Entity_Id) return Hash_Index is 5293 begin 5294 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); 5295 end Hash; 5296 5297 function Hash (F : Name_Id) return Hash_Index is 5298 begin 5299 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); 5300 end Hash; 5301 5302 -------------------------- 5303 -- Input_With_Tag_Check -- 5304 -------------------------- 5305 5306 function Input_With_Tag_Check 5307 (Loc : Source_Ptr; 5308 Var_Type : Entity_Id; 5309 Stream : Node_Id) return Node_Id 5310 is 5311 begin 5312 return 5313 Make_Subprogram_Body (Loc, 5314 Specification => 5315 Make_Function_Specification (Loc, 5316 Defining_Unit_Name => Make_Temporary (Loc, 'S'), 5317 Result_Definition => New_Occurrence_Of (Var_Type, Loc)), 5318 Declarations => No_List, 5319 Handled_Statement_Sequence => 5320 Make_Handled_Sequence_Of_Statements (Loc, New_List ( 5321 Make_Tag_Check (Loc, 5322 Make_Simple_Return_Statement (Loc, 5323 Make_Attribute_Reference (Loc, 5324 Prefix => New_Occurrence_Of (Var_Type, Loc), 5325 Attribute_Name => Name_Input, 5326 Expressions => 5327 New_List (Stream))))))); 5328 end Input_With_Tag_Check; 5329 5330 -------------------------------- 5331 -- Is_RACW_Controlling_Formal -- 5332 -------------------------------- 5333 5334 function Is_RACW_Controlling_Formal 5335 (Parameter : Node_Id; 5336 Stub_Type : Entity_Id) return Boolean 5337 is 5338 Typ : Entity_Id; 5339 5340 begin 5341 -- If the kind of the parameter is E_Void, then it is not a controlling 5342 -- formal (this can happen in the context of RAS). 5343 5344 if Ekind (Defining_Identifier (Parameter)) = E_Void then 5345 return False; 5346 end if; 5347 5348 -- If the parameter is not a controlling formal, then it cannot be 5349 -- possibly a RACW_Controlling_Formal. 5350 5351 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then 5352 return False; 5353 end if; 5354 5355 Typ := Parameter_Type (Parameter); 5356 return (Nkind (Typ) = N_Access_Definition 5357 and then Etype (Subtype_Mark (Typ)) = Stub_Type) 5358 or else Etype (Typ) = Stub_Type; 5359 end Is_RACW_Controlling_Formal; 5360 5361 ------------------------------ 5362 -- Make_Transportable_Check -- 5363 ------------------------------ 5364 5365 function Make_Transportable_Check 5366 (Loc : Source_Ptr; 5367 Expr : Node_Id) return Node_Id is 5368 begin 5369 return 5370 Make_Raise_Program_Error (Loc, 5371 Condition => 5372 Make_Op_Not (Loc, 5373 Build_Get_Transportable (Loc, 5374 Make_Selected_Component (Loc, 5375 Prefix => Expr, 5376 Selector_Name => Make_Identifier (Loc, Name_uTag)))), 5377 Reason => PE_Non_Transportable_Actual); 5378 end Make_Transportable_Check; 5379 5380 ----------------------------- 5381 -- Make_Selected_Component -- 5382 ----------------------------- 5383 5384 function Make_Selected_Component 5385 (Loc : Source_Ptr; 5386 Prefix : Entity_Id; 5387 Selector_Name : Name_Id) return Node_Id 5388 is 5389 begin 5390 return Make_Selected_Component (Loc, 5391 Prefix => New_Occurrence_Of (Prefix, Loc), 5392 Selector_Name => Make_Identifier (Loc, Selector_Name)); 5393 end Make_Selected_Component; 5394 5395 -------------------- 5396 -- Make_Tag_Check -- 5397 -------------------- 5398 5399 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is 5400 Occ : constant Entity_Id := Make_Temporary (Loc, 'E'); 5401 5402 begin 5403 return Make_Block_Statement (Loc, 5404 Handled_Statement_Sequence => 5405 Make_Handled_Sequence_Of_Statements (Loc, 5406 Statements => New_List (N), 5407 5408 Exception_Handlers => New_List ( 5409 Make_Implicit_Exception_Handler (Loc, 5410 Choice_Parameter => Occ, 5411 5412 Exception_Choices => 5413 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)), 5414 5415 Statements => 5416 New_List (Make_Procedure_Call_Statement (Loc, 5417 New_Occurrence_Of 5418 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc), 5419 New_List (New_Occurrence_Of (Occ, Loc)))))))); 5420 end Make_Tag_Check; 5421 5422 ---------------------------- 5423 -- Need_Extra_Constrained -- 5424 ---------------------------- 5425 5426 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is 5427 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter)); 5428 begin 5429 return Out_Present (Parameter) 5430 and then Has_Discriminants (Etyp) 5431 and then not Is_Constrained (Etyp) 5432 and then not Is_Indefinite_Subtype (Etyp); 5433 end Need_Extra_Constrained; 5434 5435 ------------------------------------ 5436 -- Pack_Entity_Into_Stream_Access -- 5437 ------------------------------------ 5438 5439 function Pack_Entity_Into_Stream_Access 5440 (Loc : Source_Ptr; 5441 Stream : Node_Id; 5442 Object : Entity_Id; 5443 Etyp : Entity_Id := Empty) return Node_Id 5444 is 5445 Typ : Entity_Id; 5446 5447 begin 5448 if Present (Etyp) then 5449 Typ := Etyp; 5450 else 5451 Typ := Etype (Object); 5452 end if; 5453 5454 return 5455 Pack_Node_Into_Stream_Access (Loc, 5456 Stream => Stream, 5457 Object => New_Occurrence_Of (Object, Loc), 5458 Etyp => Typ); 5459 end Pack_Entity_Into_Stream_Access; 5460 5461 --------------------------- 5462 -- Pack_Node_Into_Stream -- 5463 --------------------------- 5464 5465 function Pack_Node_Into_Stream 5466 (Loc : Source_Ptr; 5467 Stream : Entity_Id; 5468 Object : Node_Id; 5469 Etyp : Entity_Id) return Node_Id 5470 is 5471 Write_Attribute : Name_Id := Name_Write; 5472 5473 begin 5474 if not Is_Constrained (Etyp) then 5475 Write_Attribute := Name_Output; 5476 end if; 5477 5478 return 5479 Make_Attribute_Reference (Loc, 5480 Prefix => New_Occurrence_Of (Etyp, Loc), 5481 Attribute_Name => Write_Attribute, 5482 Expressions => New_List ( 5483 Make_Attribute_Reference (Loc, 5484 Prefix => New_Occurrence_Of (Stream, Loc), 5485 Attribute_Name => Name_Access), 5486 Object)); 5487 end Pack_Node_Into_Stream; 5488 5489 ---------------------------------- 5490 -- Pack_Node_Into_Stream_Access -- 5491 ---------------------------------- 5492 5493 function Pack_Node_Into_Stream_Access 5494 (Loc : Source_Ptr; 5495 Stream : Node_Id; 5496 Object : Node_Id; 5497 Etyp : Entity_Id) return Node_Id 5498 is 5499 Write_Attribute : Name_Id := Name_Write; 5500 5501 begin 5502 if not Is_Constrained (Etyp) then 5503 Write_Attribute := Name_Output; 5504 end if; 5505 5506 return 5507 Make_Attribute_Reference (Loc, 5508 Prefix => New_Occurrence_Of (Etyp, Loc), 5509 Attribute_Name => Write_Attribute, 5510 Expressions => New_List ( 5511 Stream, 5512 Object)); 5513 end Pack_Node_Into_Stream_Access; 5514 5515 --------------------- 5516 -- PolyORB_Support -- 5517 --------------------- 5518 5519 package body PolyORB_Support is 5520 5521 -- Local subprograms 5522 5523 procedure Add_RACW_Read_Attribute 5524 (RACW_Type : Entity_Id; 5525 Stub_Type : Entity_Id; 5526 Stub_Type_Access : Entity_Id; 5527 Body_Decls : List_Id); 5528 -- Add Read attribute for the RACW type. The declaration and attribute 5529 -- definition clauses are inserted right after the declaration of 5530 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is 5531 -- appended to it (case where the RACW declaration is in the main unit). 5532 5533 procedure Add_RACW_Write_Attribute 5534 (RACW_Type : Entity_Id; 5535 Stub_Type : Entity_Id; 5536 Stub_Type_Access : Entity_Id; 5537 Body_Decls : List_Id); 5538 -- Same as above for the Write attribute 5539 5540 procedure Add_RACW_From_Any 5541 (RACW_Type : Entity_Id; 5542 Body_Decls : List_Id); 5543 -- Add the From_Any TSS for this RACW type 5544 5545 procedure Add_RACW_To_Any 5546 (RACW_Type : Entity_Id; 5547 Body_Decls : List_Id); 5548 -- Add the To_Any TSS for this RACW type 5549 5550 procedure Add_RACW_TypeCode 5551 (Designated_Type : Entity_Id; 5552 RACW_Type : Entity_Id; 5553 Body_Decls : List_Id); 5554 -- Add the TypeCode TSS for this RACW type 5555 5556 procedure Add_RAS_From_Any (RAS_Type : Entity_Id); 5557 -- Add the From_Any TSS for this RAS type 5558 5559 procedure Add_RAS_To_Any (RAS_Type : Entity_Id); 5560 -- Add the To_Any TSS for this RAS type 5561 5562 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id); 5563 -- Add the TypeCode TSS for this RAS type 5564 5565 procedure Add_RAS_Access_TSS (N : Node_Id); 5566 -- Add a subprogram body for RAS Access TSS 5567 5568 ------------------------------------- 5569 -- Add_Obj_RPC_Receiver_Completion -- 5570 ------------------------------------- 5571 5572 procedure Add_Obj_RPC_Receiver_Completion 5573 (Loc : Source_Ptr; 5574 Decls : List_Id; 5575 RPC_Receiver : Entity_Id; 5576 Stub_Elements : Stub_Structure) 5577 is 5578 Desig : constant Entity_Id := 5579 Etype (Designated_Type (Stub_Elements.RACW_Type)); 5580 begin 5581 Append_To (Decls, 5582 Make_Procedure_Call_Statement (Loc, 5583 Name => 5584 New_Occurrence_Of ( 5585 RTE (RE_Register_Obj_Receiving_Stub), Loc), 5586 5587 Parameter_Associations => New_List ( 5588 5589 -- Name 5590 5591 Make_String_Literal (Loc, 5592 Fully_Qualified_Name_String (Desig, Append_NUL => False)), 5593 5594 -- Handler 5595 5596 Make_Attribute_Reference (Loc, 5597 Prefix => 5598 New_Occurrence_Of ( 5599 Defining_Unit_Name (Parent (RPC_Receiver)), Loc), 5600 Attribute_Name => 5601 Name_Access), 5602 5603 -- Receiver 5604 5605 Make_Attribute_Reference (Loc, 5606 Prefix => 5607 New_Occurrence_Of ( 5608 Defining_Identifier ( 5609 Stub_Elements.RPC_Receiver_Decl), Loc), 5610 Attribute_Name => 5611 Name_Access)))); 5612 end Add_Obj_RPC_Receiver_Completion; 5613 5614 ----------------------- 5615 -- Add_RACW_Features -- 5616 ----------------------- 5617 5618 procedure Add_RACW_Features 5619 (RACW_Type : Entity_Id; 5620 Desig : Entity_Id; 5621 Stub_Type : Entity_Id; 5622 Stub_Type_Access : Entity_Id; 5623 RPC_Receiver_Decl : Node_Id; 5624 Body_Decls : List_Id) 5625 is 5626 pragma Unreferenced (RPC_Receiver_Decl); 5627 5628 begin 5629 Add_RACW_From_Any 5630 (RACW_Type => RACW_Type, 5631 Body_Decls => Body_Decls); 5632 5633 Add_RACW_To_Any 5634 (RACW_Type => RACW_Type, 5635 Body_Decls => Body_Decls); 5636 5637 Add_RACW_Write_Attribute 5638 (RACW_Type => RACW_Type, 5639 Stub_Type => Stub_Type, 5640 Stub_Type_Access => Stub_Type_Access, 5641 Body_Decls => Body_Decls); 5642 5643 Add_RACW_Read_Attribute 5644 (RACW_Type => RACW_Type, 5645 Stub_Type => Stub_Type, 5646 Stub_Type_Access => Stub_Type_Access, 5647 Body_Decls => Body_Decls); 5648 5649 Add_RACW_TypeCode 5650 (Designated_Type => Desig, 5651 RACW_Type => RACW_Type, 5652 Body_Decls => Body_Decls); 5653 end Add_RACW_Features; 5654 5655 ----------------------- 5656 -- Add_RACW_From_Any -- 5657 ----------------------- 5658 5659 procedure Add_RACW_From_Any 5660 (RACW_Type : Entity_Id; 5661 Body_Decls : List_Id) 5662 is 5663 Loc : constant Source_Ptr := Sloc (RACW_Type); 5664 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); 5665 Fnam : constant Entity_Id := 5666 Make_Defining_Identifier (Loc, 5667 Chars => New_External_Name (Chars (RACW_Type), 'F')); 5668 5669 Func_Spec : Node_Id; 5670 Func_Decl : Node_Id; 5671 Func_Body : Node_Id; 5672 5673 Statements : List_Id; 5674 -- Various parts of the subprogram 5675 5676 Any_Parameter : constant Entity_Id := 5677 Make_Defining_Identifier (Loc, Name_A); 5678 5679 Asynchronous_Flag : constant Entity_Id := 5680 Asynchronous_Flags_Table.Get (RACW_Type); 5681 -- The flag object declared in Add_RACW_Asynchronous_Flag 5682 5683 begin 5684 Func_Spec := 5685 Make_Function_Specification (Loc, 5686 Defining_Unit_Name => 5687 Fnam, 5688 Parameter_Specifications => New_List ( 5689 Make_Parameter_Specification (Loc, 5690 Defining_Identifier => 5691 Any_Parameter, 5692 Parameter_Type => 5693 New_Occurrence_Of (RTE (RE_Any), Loc))), 5694 Result_Definition => New_Occurrence_Of (RACW_Type, Loc)); 5695 5696 -- NOTE: The usage occurrences of RACW_Parameter must refer to the 5697 -- entity in the declaration spec, not those of the body spec. 5698 5699 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); 5700 Insert_After (Declaration_Node (RACW_Type), Func_Decl); 5701 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any); 5702 5703 if No (Body_Decls) then 5704 return; 5705 end if; 5706 5707 -- ??? Issue with asynchronous calls here: the Asynchronous flag is 5708 -- set on the stub type if, and only if, the RACW type has a pragma 5709 -- Asynchronous. This is incorrect for RACWs that implement RAS 5710 -- types, because in that case the /designated subprogram/ (not the 5711 -- type) might be asynchronous, and that causes the stub to need to 5712 -- be asynchronous too. A solution is to transport a RAS as a struct 5713 -- containing a RACW and an asynchronous flag, and to properly alter 5714 -- the Asynchronous component in the stub type in the RAS's _From_Any 5715 -- TSS. 5716 5717 Statements := New_List ( 5718 Make_Simple_Return_Statement (Loc, 5719 Expression => Unchecked_Convert_To (RACW_Type, 5720 Make_Function_Call (Loc, 5721 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc), 5722 Parameter_Associations => New_List ( 5723 Make_Function_Call (Loc, 5724 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), 5725 Parameter_Associations => New_List ( 5726 New_Occurrence_Of (Any_Parameter, Loc))), 5727 Build_Stub_Tag (Loc, RACW_Type), 5728 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), 5729 New_Occurrence_Of (Asynchronous_Flag, Loc)))))); 5730 5731 Func_Body := 5732 Make_Subprogram_Body (Loc, 5733 Specification => Copy_Specification (Loc, Func_Spec), 5734 Declarations => No_List, 5735 Handled_Statement_Sequence => 5736 Make_Handled_Sequence_Of_Statements (Loc, 5737 Statements => Statements)); 5738 5739 Append_To (Body_Decls, Func_Body); 5740 end Add_RACW_From_Any; 5741 5742 ----------------------------- 5743 -- Add_RACW_Read_Attribute -- 5744 ----------------------------- 5745 5746 procedure Add_RACW_Read_Attribute 5747 (RACW_Type : Entity_Id; 5748 Stub_Type : Entity_Id; 5749 Stub_Type_Access : Entity_Id; 5750 Body_Decls : List_Id) 5751 is 5752 pragma Unreferenced (Stub_Type, Stub_Type_Access); 5753 5754 Loc : constant Source_Ptr := Sloc (RACW_Type); 5755 5756 Proc_Decl : Node_Id; 5757 Attr_Decl : Node_Id; 5758 5759 Body_Node : Node_Id; 5760 5761 Decls : constant List_Id := New_List; 5762 Statements : constant List_Id := New_List; 5763 Reference : constant Entity_Id := 5764 Make_Defining_Identifier (Loc, Name_R); 5765 -- Various parts of the procedure 5766 5767 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); 5768 5769 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); 5770 5771 Asynchronous_Flag : constant Entity_Id := 5772 Asynchronous_Flags_Table.Get (RACW_Type); 5773 pragma Assert (Present (Asynchronous_Flag)); 5774 5775 function Stream_Parameter return Node_Id; 5776 function Result return Node_Id; 5777 5778 -- Functions to create occurrences of the formal parameter names 5779 5780 ------------ 5781 -- Result -- 5782 ------------ 5783 5784 function Result return Node_Id is 5785 begin 5786 return Make_Identifier (Loc, Name_V); 5787 end Result; 5788 5789 ---------------------- 5790 -- Stream_Parameter -- 5791 ---------------------- 5792 5793 function Stream_Parameter return Node_Id is 5794 begin 5795 return Make_Identifier (Loc, Name_S); 5796 end Stream_Parameter; 5797 5798 -- Start of processing for Add_RACW_Read_Attribute 5799 5800 begin 5801 Build_Stream_Procedure 5802 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True); 5803 5804 Proc_Decl := Make_Subprogram_Declaration (Loc, 5805 Copy_Specification (Loc, Specification (Body_Node))); 5806 5807 Attr_Decl := 5808 Make_Attribute_Definition_Clause (Loc, 5809 Name => New_Occurrence_Of (RACW_Type, Loc), 5810 Chars => Name_Read, 5811 Expression => 5812 New_Occurrence_Of ( 5813 Defining_Unit_Name (Specification (Proc_Decl)), Loc)); 5814 5815 Insert_After (Declaration_Node (RACW_Type), Proc_Decl); 5816 Insert_After (Proc_Decl, Attr_Decl); 5817 5818 if No (Body_Decls) then 5819 return; 5820 end if; 5821 5822 Append_To (Decls, 5823 Make_Object_Declaration (Loc, 5824 Defining_Identifier => 5825 Reference, 5826 Object_Definition => 5827 New_Occurrence_Of (RTE (RE_Object_Ref), Loc))); 5828 5829 Append_List_To (Statements, New_List ( 5830 Make_Attribute_Reference (Loc, 5831 Prefix => 5832 New_Occurrence_Of (RTE (RE_Object_Ref), Loc), 5833 Attribute_Name => Name_Read, 5834 Expressions => New_List ( 5835 Stream_Parameter, 5836 New_Occurrence_Of (Reference, Loc))), 5837 5838 Make_Assignment_Statement (Loc, 5839 Name => 5840 Result, 5841 Expression => 5842 Unchecked_Convert_To (RACW_Type, 5843 Make_Function_Call (Loc, 5844 Name => 5845 New_Occurrence_Of (RTE (RE_Get_RACW), Loc), 5846 Parameter_Associations => New_List ( 5847 New_Occurrence_Of (Reference, Loc), 5848 Build_Stub_Tag (Loc, RACW_Type), 5849 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), 5850 New_Occurrence_Of (Asynchronous_Flag, Loc))))))); 5851 5852 Set_Declarations (Body_Node, Decls); 5853 Append_To (Body_Decls, Body_Node); 5854 end Add_RACW_Read_Attribute; 5855 5856 --------------------- 5857 -- Add_RACW_To_Any -- 5858 --------------------- 5859 5860 procedure Add_RACW_To_Any 5861 (RACW_Type : Entity_Id; 5862 Body_Decls : List_Id) 5863 is 5864 Loc : constant Source_Ptr := Sloc (RACW_Type); 5865 5866 Fnam : constant Entity_Id := 5867 Make_Defining_Identifier (Loc, 5868 Chars => New_External_Name (Chars (RACW_Type), 'T')); 5869 5870 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); 5871 5872 Stub_Elements : constant Stub_Structure := 5873 Get_Stub_Elements (RACW_Type); 5874 5875 Func_Spec : Node_Id; 5876 Func_Decl : Node_Id; 5877 Func_Body : Node_Id; 5878 5879 Decls : List_Id; 5880 Statements : List_Id; 5881 -- Various parts of the subprogram 5882 5883 RACW_Parameter : constant Entity_Id := 5884 Make_Defining_Identifier (Loc, Name_R); 5885 5886 Reference : constant Entity_Id := Make_Temporary (Loc, 'R'); 5887 Any : constant Entity_Id := Make_Temporary (Loc, 'A'); 5888 5889 begin 5890 Func_Spec := 5891 Make_Function_Specification (Loc, 5892 Defining_Unit_Name => 5893 Fnam, 5894 Parameter_Specifications => New_List ( 5895 Make_Parameter_Specification (Loc, 5896 Defining_Identifier => 5897 RACW_Parameter, 5898 Parameter_Type => 5899 New_Occurrence_Of (RACW_Type, Loc))), 5900 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); 5901 5902 -- NOTE: The usage occurrences of RACW_Parameter must refer to the 5903 -- entity in the declaration spec, not in the body spec. 5904 5905 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); 5906 5907 Insert_After (Declaration_Node (RACW_Type), Func_Decl); 5908 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any); 5909 5910 if No (Body_Decls) then 5911 return; 5912 end if; 5913 5914 -- Generate: 5915 5916 -- R : constant Object_Ref := 5917 -- Get_Reference 5918 -- (Address!(RACW), 5919 -- "typ", 5920 -- Stub_Type'Tag, 5921 -- Is_RAS, 5922 -- RPC_Receiver'Access); 5923 -- A : Any; 5924 5925 Decls := New_List ( 5926 Make_Object_Declaration (Loc, 5927 Defining_Identifier => Reference, 5928 Constant_Present => True, 5929 Object_Definition => 5930 New_Occurrence_Of (RTE (RE_Object_Ref), Loc), 5931 Expression => 5932 Make_Function_Call (Loc, 5933 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), 5934 Parameter_Associations => New_List ( 5935 Unchecked_Convert_To (RTE (RE_Address), 5936 New_Occurrence_Of (RACW_Parameter, Loc)), 5937 Make_String_Literal (Loc, 5938 Strval => Fully_Qualified_Name_String 5939 (Etype (Designated_Type (RACW_Type)), 5940 Append_NUL => False)), 5941 Build_Stub_Tag (Loc, RACW_Type), 5942 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc), 5943 Make_Attribute_Reference (Loc, 5944 Prefix => 5945 New_Occurrence_Of 5946 (Defining_Identifier 5947 (Stub_Elements.RPC_Receiver_Decl), Loc), 5948 Attribute_Name => Name_Access)))), 5949 5950 Make_Object_Declaration (Loc, 5951 Defining_Identifier => Any, 5952 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc))); 5953 5954 -- Generate: 5955 5956 -- Any := TA_ObjRef (Reference); 5957 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode); 5958 -- return Any; 5959 5960 Statements := New_List ( 5961 Make_Assignment_Statement (Loc, 5962 Name => New_Occurrence_Of (Any, Loc), 5963 Expression => 5964 Make_Function_Call (Loc, 5965 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), 5966 Parameter_Associations => New_List ( 5967 New_Occurrence_Of (Reference, Loc)))), 5968 5969 Make_Procedure_Call_Statement (Loc, 5970 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), 5971 Parameter_Associations => New_List ( 5972 New_Occurrence_Of (Any, Loc), 5973 Make_Selected_Component (Loc, 5974 Prefix => 5975 Defining_Identifier ( 5976 Stub_Elements.RPC_Receiver_Decl), 5977 Selector_Name => Name_Obj_TypeCode))), 5978 5979 Make_Simple_Return_Statement (Loc, 5980 Expression => New_Occurrence_Of (Any, Loc))); 5981 5982 Func_Body := 5983 Make_Subprogram_Body (Loc, 5984 Specification => Copy_Specification (Loc, Func_Spec), 5985 Declarations => Decls, 5986 Handled_Statement_Sequence => 5987 Make_Handled_Sequence_Of_Statements (Loc, 5988 Statements => Statements)); 5989 Append_To (Body_Decls, Func_Body); 5990 end Add_RACW_To_Any; 5991 5992 ----------------------- 5993 -- Add_RACW_TypeCode -- 5994 ----------------------- 5995 5996 procedure Add_RACW_TypeCode 5997 (Designated_Type : Entity_Id; 5998 RACW_Type : Entity_Id; 5999 Body_Decls : List_Id) 6000 is 6001 Loc : constant Source_Ptr := Sloc (RACW_Type); 6002 6003 Fnam : constant Entity_Id := 6004 Make_Defining_Identifier (Loc, 6005 Chars => New_External_Name (Chars (RACW_Type), 'Y')); 6006 6007 Stub_Elements : constant Stub_Structure := 6008 Stubs_Table.Get (Designated_Type); 6009 pragma Assert (Stub_Elements /= Empty_Stub_Structure); 6010 6011 Func_Spec : Node_Id; 6012 Func_Decl : Node_Id; 6013 Func_Body : Node_Id; 6014 6015 begin 6016 -- The spec for this subprogram has a dummy 'access RACW' argument, 6017 -- which serves only for overloading purposes. 6018 6019 Func_Spec := 6020 Make_Function_Specification (Loc, 6021 Defining_Unit_Name => Fnam, 6022 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); 6023 6024 -- NOTE: The usage occurrences of RACW_Parameter must refer to the 6025 -- entity in the declaration spec, not those of the body spec. 6026 6027 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); 6028 Insert_After (Declaration_Node (RACW_Type), Func_Decl); 6029 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode); 6030 6031 if No (Body_Decls) then 6032 return; 6033 end if; 6034 6035 Func_Body := 6036 Make_Subprogram_Body (Loc, 6037 Specification => Copy_Specification (Loc, Func_Spec), 6038 Declarations => Empty_List, 6039 Handled_Statement_Sequence => 6040 Make_Handled_Sequence_Of_Statements (Loc, 6041 Statements => New_List ( 6042 Make_Simple_Return_Statement (Loc, 6043 Expression => 6044 Make_Selected_Component (Loc, 6045 Prefix => 6046 Defining_Identifier 6047 (Stub_Elements.RPC_Receiver_Decl), 6048 Selector_Name => Name_Obj_TypeCode))))); 6049 6050 Append_To (Body_Decls, Func_Body); 6051 end Add_RACW_TypeCode; 6052 6053 ------------------------------ 6054 -- Add_RACW_Write_Attribute -- 6055 ------------------------------ 6056 6057 procedure Add_RACW_Write_Attribute 6058 (RACW_Type : Entity_Id; 6059 Stub_Type : Entity_Id; 6060 Stub_Type_Access : Entity_Id; 6061 Body_Decls : List_Id) 6062 is 6063 pragma Unreferenced (Stub_Type, Stub_Type_Access); 6064 6065 Loc : constant Source_Ptr := Sloc (RACW_Type); 6066 6067 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); 6068 6069 Stub_Elements : constant Stub_Structure := 6070 Get_Stub_Elements (RACW_Type); 6071 6072 Body_Node : Node_Id; 6073 Proc_Decl : Node_Id; 6074 Attr_Decl : Node_Id; 6075 6076 Statements : constant List_Id := New_List; 6077 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R'); 6078 6079 function Stream_Parameter return Node_Id; 6080 function Object return Node_Id; 6081 -- Functions to create occurrences of the formal parameter names 6082 6083 ------------ 6084 -- Object -- 6085 ------------ 6086 6087 function Object return Node_Id is 6088 begin 6089 return Make_Identifier (Loc, Name_V); 6090 end Object; 6091 6092 ---------------------- 6093 -- Stream_Parameter -- 6094 ---------------------- 6095 6096 function Stream_Parameter return Node_Id is 6097 begin 6098 return Make_Identifier (Loc, Name_S); 6099 end Stream_Parameter; 6100 6101 -- Start of processing for Add_RACW_Write_Attribute 6102 6103 begin 6104 Build_Stream_Procedure 6105 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False); 6106 6107 Proc_Decl := 6108 Make_Subprogram_Declaration (Loc, 6109 Copy_Specification (Loc, Specification (Body_Node))); 6110 6111 Attr_Decl := 6112 Make_Attribute_Definition_Clause (Loc, 6113 Name => New_Occurrence_Of (RACW_Type, Loc), 6114 Chars => Name_Write, 6115 Expression => 6116 New_Occurrence_Of ( 6117 Defining_Unit_Name (Specification (Proc_Decl)), Loc)); 6118 6119 Insert_After (Declaration_Node (RACW_Type), Proc_Decl); 6120 Insert_After (Proc_Decl, Attr_Decl); 6121 6122 if No (Body_Decls) then 6123 return; 6124 end if; 6125 6126 Append_To (Statements, 6127 Pack_Node_Into_Stream_Access (Loc, 6128 Stream => Stream_Parameter, 6129 Object => 6130 Make_Function_Call (Loc, 6131 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc), 6132 Parameter_Associations => New_List ( 6133 Unchecked_Convert_To (RTE (RE_Address), Object), 6134 Make_String_Literal (Loc, 6135 Strval => Fully_Qualified_Name_String 6136 (Etype (Designated_Type (RACW_Type)), 6137 Append_NUL => False)), 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 => 6634 New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc), 6635 Parameter_Associations => New_List ( 6636 New_Occurrence_Of (RTE (RE_Tk_Objref), Loc), 6637 Make_Aggregate (Loc, 6638 Expressions => 6639 New_List ( 6640 Make_Function_Call (Loc, 6641 Name => 6642 New_Occurrence_Of 6643 (RTE (RE_TA_Std_String), Loc), 6644 Parameter_Associations => New_List ( 6645 Make_String_Literal (Loc, Name_String))), 6646 Make_Function_Call (Loc, 6647 Name => 6648 New_Occurrence_Of 6649 (RTE (RE_TA_Std_String), Loc), 6650 Parameter_Associations => New_List ( 6651 Make_String_Literal (Loc, 6652 Strval => Repo_Id_String)))))))))))); 6653 Set_TSS (RAS_Type, Fnam); 6654 end Add_RAS_TypeCode; 6655 6656 ----------------------------------------- 6657 -- Add_Receiving_Stubs_To_Declarations -- 6658 ----------------------------------------- 6659 6660 procedure Add_Receiving_Stubs_To_Declarations 6661 (Pkg_Spec : Node_Id; 6662 Decls : List_Id; 6663 Stmts : List_Id) 6664 is 6665 Loc : constant Source_Ptr := Sloc (Pkg_Spec); 6666 6667 Pkg_RPC_Receiver : constant Entity_Id := 6668 Make_Temporary (Loc, 'H'); 6669 Pkg_RPC_Receiver_Object : Node_Id; 6670 Pkg_RPC_Receiver_Body : Node_Id; 6671 Pkg_RPC_Receiver_Decls : List_Id; 6672 Pkg_RPC_Receiver_Statements : List_Id; 6673 6674 Pkg_RPC_Receiver_Cases : constant List_Id := New_List; 6675 -- A Pkg_RPC_Receiver is built to decode the request 6676 6677 Request : Node_Id; 6678 -- Request object received from neutral layer 6679 6680 Subp_Id : Entity_Id; 6681 -- Subprogram identifier as received from the neutral distribution 6682 -- core. 6683 6684 Subp_Index : Entity_Id; 6685 -- Internal index as determined by matching either the method name 6686 -- from the request structure, or the local subprogram address (in 6687 -- case of a RAS). 6688 6689 Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L'); 6690 6691 Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A'); 6692 -- Address of a local subprogram designated by a reference 6693 -- corresponding to a RAS. 6694 6695 Dispatch_On_Address : constant List_Id := New_List; 6696 Dispatch_On_Name : constant List_Id := New_List; 6697 6698 Current_Subp_Number : Int := First_RCI_Subprogram_Id; 6699 6700 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I'); 6701 Subp_Info_List : constant List_Id := New_List; 6702 6703 Register_Pkg_Actuals : constant List_Id := New_List; 6704 6705 All_Calls_Remote_E : Entity_Id; 6706 6707 procedure Append_Stubs_To 6708 (RPC_Receiver_Cases : List_Id; 6709 Declaration : Node_Id; 6710 Stubs : Node_Id; 6711 Subp_Number : Int; 6712 Subp_Dist_Name : Entity_Id; 6713 Subp_Proxy_Addr : Entity_Id); 6714 -- Add one case to the specified RPC receiver case list associating 6715 -- Subprogram_Number with the subprogram declared by Declaration, for 6716 -- which we have receiving stubs in Stubs. Subp_Number is an internal 6717 -- subprogram index. Subp_Dist_Name is the string used to call the 6718 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy 6719 -- object, used in the context of calls through remote 6720 -- access-to-subprogram types. 6721 6722 procedure Visit_Subprogram (Decl : Node_Id); 6723 -- Generate receiving stub for one remote subprogram 6724 6725 --------------------- 6726 -- Append_Stubs_To -- 6727 --------------------- 6728 6729 procedure Append_Stubs_To 6730 (RPC_Receiver_Cases : List_Id; 6731 Declaration : Node_Id; 6732 Stubs : Node_Id; 6733 Subp_Number : Int; 6734 Subp_Dist_Name : Entity_Id; 6735 Subp_Proxy_Addr : Entity_Id) 6736 is 6737 Case_Stmts : List_Id; 6738 begin 6739 Case_Stmts := New_List ( 6740 Make_Procedure_Call_Statement (Loc, 6741 Name => 6742 New_Occurrence_Of ( 6743 Defining_Entity (Stubs), Loc), 6744 Parameter_Associations => 6745 New_List (New_Occurrence_Of (Request, Loc)))); 6746 6747 if Nkind (Specification (Declaration)) = N_Function_Specification 6748 or else not 6749 Is_Asynchronous (Defining_Entity (Specification (Declaration))) 6750 then 6751 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc)); 6752 end if; 6753 6754 Append_To (RPC_Receiver_Cases, 6755 Make_Case_Statement_Alternative (Loc, 6756 Discrete_Choices => 6757 New_List (Make_Integer_Literal (Loc, Subp_Number)), 6758 Statements => Case_Stmts)); 6759 6760 Append_To (Dispatch_On_Name, 6761 Make_Elsif_Part (Loc, 6762 Condition => 6763 Make_Function_Call (Loc, 6764 Name => 6765 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc), 6766 Parameter_Associations => New_List ( 6767 New_Occurrence_Of (Subp_Id, Loc), 6768 New_Occurrence_Of (Subp_Dist_Name, Loc))), 6769 6770 Then_Statements => New_List ( 6771 Make_Assignment_Statement (Loc, 6772 New_Occurrence_Of (Subp_Index, Loc), 6773 Make_Integer_Literal (Loc, Subp_Number))))); 6774 6775 Append_To (Dispatch_On_Address, 6776 Make_Elsif_Part (Loc, 6777 Condition => 6778 Make_Op_Eq (Loc, 6779 Left_Opnd => New_Occurrence_Of (Local_Address, Loc), 6780 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)), 6781 6782 Then_Statements => New_List ( 6783 Make_Assignment_Statement (Loc, 6784 New_Occurrence_Of (Subp_Index, Loc), 6785 Make_Integer_Literal (Loc, Subp_Number))))); 6786 end Append_Stubs_To; 6787 6788 ---------------------- 6789 -- Visit_Subprogram -- 6790 ---------------------- 6791 6792 procedure Visit_Subprogram (Decl : Node_Id) is 6793 Loc : constant Source_Ptr := Sloc (Decl); 6794 Spec : constant Node_Id := Specification (Decl); 6795 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec); 6796 6797 Subp_Val : String_Id; 6798 6799 Subp_Dist_Name : constant Entity_Id := 6800 Make_Defining_Identifier (Loc, 6801 Chars => 6802 New_External_Name 6803 (Related_Id => Chars (Subp_Def), 6804 Suffix => 'D', 6805 Suffix_Index => -1)); 6806 6807 Current_Stubs : Node_Id; 6808 Proxy_Obj_Addr : Entity_Id; 6809 6810 begin 6811 -- Disable expansion of stubs if serious errors have been 6812 -- diagnosed, because otherwise some illegal remote subprogram 6813 -- declarations could cause cascaded errors in stubs. 6814 6815 if Serious_Errors_Detected /= 0 then 6816 return; 6817 end if; 6818 6819 -- Build receiving stub 6820 6821 Current_Stubs := 6822 Build_Subprogram_Receiving_Stubs 6823 (Vis_Decl => Decl, 6824 Asynchronous => Nkind (Spec) = N_Procedure_Specification 6825 and then Is_Asynchronous (Subp_Def)); 6826 6827 Append_To (Decls, Current_Stubs); 6828 Analyze (Current_Stubs); 6829 6830 -- Build RAS proxy 6831 6832 Add_RAS_Proxy_And_Analyze (Decls, 6833 Vis_Decl => Decl, 6834 All_Calls_Remote_E => All_Calls_Remote_E, 6835 Proxy_Object_Addr => Proxy_Obj_Addr); 6836 6837 -- Compute distribution identifier 6838 6839 Assign_Subprogram_Identifier 6840 (Subp_Def, Current_Subp_Number, Subp_Val); 6841 6842 pragma Assert 6843 (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); 6844 6845 Append_To (Decls, 6846 Make_Object_Declaration (Loc, 6847 Defining_Identifier => Subp_Dist_Name, 6848 Constant_Present => True, 6849 Object_Definition => 6850 New_Occurrence_Of (Standard_String, Loc), 6851 Expression => 6852 Make_String_Literal (Loc, Subp_Val))); 6853 Analyze (Last (Decls)); 6854 6855 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms 6856 -- table for this receiver. The aggregate below must be kept 6857 -- consistent with the declaration of RCI_Subp_Info in 6858 -- System.Partition_Interface. 6859 6860 Append_To (Subp_Info_List, 6861 Make_Component_Association (Loc, 6862 Choices => 6863 New_List (Make_Integer_Literal (Loc, Current_Subp_Number)), 6864 6865 Expression => 6866 Make_Aggregate (Loc, 6867 Expressions => New_List ( 6868 6869 -- Name => 6870 6871 Make_Attribute_Reference (Loc, 6872 Prefix => 6873 New_Occurrence_Of (Subp_Dist_Name, Loc), 6874 Attribute_Name => Name_Address), 6875 6876 -- Name_Length => 6877 6878 Make_Attribute_Reference (Loc, 6879 Prefix => 6880 New_Occurrence_Of (Subp_Dist_Name, Loc), 6881 Attribute_Name => Name_Length), 6882 6883 -- Addr => 6884 6885 New_Occurrence_Of (Proxy_Obj_Addr, Loc))))); 6886 6887 Append_Stubs_To (Pkg_RPC_Receiver_Cases, 6888 Declaration => Decl, 6889 Stubs => Current_Stubs, 6890 Subp_Number => Current_Subp_Number, 6891 Subp_Dist_Name => Subp_Dist_Name, 6892 Subp_Proxy_Addr => Proxy_Obj_Addr); 6893 6894 Current_Subp_Number := Current_Subp_Number + 1; 6895 end Visit_Subprogram; 6896 6897 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram); 6898 6899 -- Start of processing for Add_Receiving_Stubs_To_Declarations 6900 6901 begin 6902 -- Building receiving stubs consist in several operations: 6903 6904 -- - a package RPC receiver must be built. This subprogram will get 6905 -- a Subprogram_Id from the incoming stream and will dispatch the 6906 -- call to the right subprogram; 6907 6908 -- - a receiving stub for each subprogram visible in the package 6909 -- spec. This stub will read all the parameters from the stream, 6910 -- and put the result as well as the exception occurrence in the 6911 -- output stream; 6912 6913 Build_RPC_Receiver_Body ( 6914 RPC_Receiver => Pkg_RPC_Receiver, 6915 Request => Request, 6916 Subp_Id => Subp_Id, 6917 Subp_Index => Subp_Index, 6918 Stmts => Pkg_RPC_Receiver_Statements, 6919 Decl => Pkg_RPC_Receiver_Body); 6920 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body); 6921 6922 -- Extract local address information from the target reference: 6923 -- if non-null, that means that this is a reference that denotes 6924 -- one particular operation, and hence that the operation name 6925 -- must not be taken into account for dispatching. 6926 6927 Append_To (Pkg_RPC_Receiver_Decls, 6928 Make_Object_Declaration (Loc, 6929 Defining_Identifier => Is_Local, 6930 Object_Definition => 6931 New_Occurrence_Of (Standard_Boolean, Loc))); 6932 6933 Append_To (Pkg_RPC_Receiver_Decls, 6934 Make_Object_Declaration (Loc, 6935 Defining_Identifier => Local_Address, 6936 Object_Definition => 6937 New_Occurrence_Of (RTE (RE_Address), Loc))); 6938 6939 Append_To (Pkg_RPC_Receiver_Statements, 6940 Make_Procedure_Call_Statement (Loc, 6941 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), 6942 Parameter_Associations => New_List ( 6943 Make_Selected_Component (Loc, 6944 Prefix => Request, 6945 Selector_Name => Name_Target), 6946 New_Occurrence_Of (Is_Local, Loc), 6947 New_Occurrence_Of (Local_Address, Loc)))); 6948 6949 -- For each subprogram, the receiving stub will be built and a case 6950 -- statement will be made on the Subprogram_Id to dispatch to the 6951 -- right subprogram. 6952 6953 All_Calls_Remote_E := Boolean_Literals ( 6954 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); 6955 6956 Overload_Counter_Table.Reset; 6957 Reserve_NamingContext_Methods; 6958 6959 Visit_Spec (Pkg_Spec); 6960 6961 Append_To (Decls, 6962 Make_Object_Declaration (Loc, 6963 Defining_Identifier => Subp_Info_Array, 6964 Constant_Present => True, 6965 Aliased_Present => True, 6966 Object_Definition => 6967 Make_Subtype_Indication (Loc, 6968 Subtype_Mark => 6969 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), 6970 Constraint => 6971 Make_Index_Or_Discriminant_Constraint (Loc, 6972 New_List ( 6973 Make_Range (Loc, 6974 Low_Bound => 6975 Make_Integer_Literal (Loc, 6976 Intval => First_RCI_Subprogram_Id), 6977 High_Bound => 6978 Make_Integer_Literal (Loc, 6979 Intval => 6980 First_RCI_Subprogram_Id 6981 + List_Length (Subp_Info_List) - 1))))))); 6982 6983 if Present (First (Subp_Info_List)) then 6984 Set_Expression (Last (Decls), 6985 Make_Aggregate (Loc, 6986 Component_Associations => Subp_Info_List)); 6987 6988 -- Generate the dispatch statement to determine the subprogram id 6989 -- of the called subprogram. 6990 6991 -- We first test whether the reference that was used to make the 6992 -- call was the base RCI reference (in which case Local_Address is 6993 -- zero, and the method identifier from the request must be used 6994 -- to determine which subprogram is called) or a reference 6995 -- identifying one particular subprogram (in which case 6996 -- Local_Address is the address of that subprogram, and the 6997 -- method name from the request is ignored). The latter occurs 6998 -- for the case of a call through a remote access-to-subprogram. 6999 7000 -- In each case, cascaded elsifs are used to determine the proper 7001 -- subprogram index. Using hash tables might be more efficient. 7002 7003 Append_To (Pkg_RPC_Receiver_Statements, 7004 Make_Implicit_If_Statement (Pkg_Spec, 7005 Condition => 7006 Make_Op_Ne (Loc, 7007 Left_Opnd => New_Occurrence_Of (Local_Address, Loc), 7008 Right_Opnd => New_Occurrence_Of 7009 (RTE (RE_Null_Address), Loc)), 7010 7011 Then_Statements => New_List ( 7012 Make_Implicit_If_Statement (Pkg_Spec, 7013 Condition => New_Occurrence_Of (Standard_False, Loc), 7014 Then_Statements => New_List ( 7015 Make_Null_Statement (Loc)), 7016 Elsif_Parts => Dispatch_On_Address)), 7017 7018 Else_Statements => New_List ( 7019 Make_Implicit_If_Statement (Pkg_Spec, 7020 Condition => New_Occurrence_Of (Standard_False, Loc), 7021 Then_Statements => New_List (Make_Null_Statement (Loc)), 7022 Elsif_Parts => Dispatch_On_Name)))); 7023 7024 else 7025 -- For a degenerate RCI with no visible subprograms, 7026 -- Subp_Info_List has zero length, and the declaration is for an 7027 -- empty array, in which case no initialization aggregate must be 7028 -- generated. We do not generate a Dispatch_Statement either. 7029 7030 -- No initialization provided: remove CONSTANT so that the 7031 -- declaration is not an incomplete deferred constant. 7032 7033 Set_Constant_Present (Last (Decls), False); 7034 end if; 7035 7036 -- Analyze Subp_Info_Array declaration 7037 7038 Analyze (Last (Decls)); 7039 7040 -- If we receive an invalid Subprogram_Id, it is best to do nothing 7041 -- rather than raising an exception since we do not want someone 7042 -- to crash a remote partition by sending invalid subprogram ids. 7043 -- This is consistent with the other parts of the case statement 7044 -- since even in presence of incorrect parameters in the stream, 7045 -- every exception will be caught and (if the subprogram is not an 7046 -- APC) put into the result stream and sent away. 7047 7048 Append_To (Pkg_RPC_Receiver_Cases, 7049 Make_Case_Statement_Alternative (Loc, 7050 Discrete_Choices => New_List (Make_Others_Choice (Loc)), 7051 Statements => New_List (Make_Null_Statement (Loc)))); 7052 7053 Append_To (Pkg_RPC_Receiver_Statements, 7054 Make_Case_Statement (Loc, 7055 Expression => New_Occurrence_Of (Subp_Index, Loc), 7056 Alternatives => Pkg_RPC_Receiver_Cases)); 7057 7058 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and 7059 -- analyze it. 7060 7061 Append_To (Decls, Pkg_RPC_Receiver_Body); 7062 Analyze (Last (Decls)); 7063 7064 Pkg_RPC_Receiver_Object := 7065 Make_Object_Declaration (Loc, 7066 Defining_Identifier => Make_Temporary (Loc, 'R'), 7067 Aliased_Present => True, 7068 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); 7069 Append_To (Decls, Pkg_RPC_Receiver_Object); 7070 Analyze (Last (Decls)); 7071 7072 -- Name 7073 7074 Append_To (Register_Pkg_Actuals, 7075 Make_String_Literal (Loc, 7076 Strval => 7077 Fully_Qualified_Name_String 7078 (Defining_Entity (Pkg_Spec), Append_NUL => False))); 7079 7080 -- Version 7081 7082 Append_To (Register_Pkg_Actuals, 7083 Make_Attribute_Reference (Loc, 7084 Prefix => 7085 New_Occurrence_Of 7086 (Defining_Entity (Pkg_Spec), Loc), 7087 Attribute_Name => Name_Version)); 7088 7089 -- Handler 7090 7091 Append_To (Register_Pkg_Actuals, 7092 Make_Attribute_Reference (Loc, 7093 Prefix => 7094 New_Occurrence_Of (Pkg_RPC_Receiver, Loc), 7095 Attribute_Name => Name_Access)); 7096 7097 -- Receiver 7098 7099 Append_To (Register_Pkg_Actuals, 7100 Make_Attribute_Reference (Loc, 7101 Prefix => 7102 New_Occurrence_Of ( 7103 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc), 7104 Attribute_Name => Name_Access)); 7105 7106 -- Subp_Info 7107 7108 Append_To (Register_Pkg_Actuals, 7109 Make_Attribute_Reference (Loc, 7110 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), 7111 Attribute_Name => Name_Address)); 7112 7113 -- Subp_Info_Len 7114 7115 Append_To (Register_Pkg_Actuals, 7116 Make_Attribute_Reference (Loc, 7117 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), 7118 Attribute_Name => Name_Length)); 7119 7120 -- Is_All_Calls_Remote 7121 7122 Append_To (Register_Pkg_Actuals, 7123 New_Occurrence_Of (All_Calls_Remote_E, Loc)); 7124 7125 -- Finally call Register_Pkg_Receiving_Stub with the above parameters 7126 7127 Append_To (Stmts, 7128 Make_Procedure_Call_Statement (Loc, 7129 Name => 7130 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc), 7131 Parameter_Associations => Register_Pkg_Actuals)); 7132 Analyze (Last (Stmts)); 7133 end Add_Receiving_Stubs_To_Declarations; 7134 7135 --------------------------------- 7136 -- Build_General_Calling_Stubs -- 7137 --------------------------------- 7138 7139 procedure Build_General_Calling_Stubs 7140 (Decls : List_Id; 7141 Statements : List_Id; 7142 Target_Object : Node_Id; 7143 Subprogram_Id : Node_Id; 7144 Asynchronous : Node_Id := Empty; 7145 Is_Known_Asynchronous : Boolean := False; 7146 Is_Known_Non_Asynchronous : Boolean := False; 7147 Is_Function : Boolean; 7148 Spec : Node_Id; 7149 Stub_Type : Entity_Id := Empty; 7150 RACW_Type : Entity_Id := Empty; 7151 Nod : Node_Id) 7152 is 7153 Loc : constant Source_Ptr := Sloc (Nod); 7154 7155 Request : constant Entity_Id := Make_Temporary (Loc, 'R'); 7156 -- The request object constructed by these stubs 7157 -- Could we use Name_R instead??? (see GLADE client stubs) 7158 7159 function Make_Request_RTE_Call 7160 (RE : RE_Id; 7161 Actuals : List_Id := New_List) return Node_Id; 7162 -- Generate a procedure call statement calling RE with the given 7163 -- actuals. Request'Access is appended to the list. 7164 7165 --------------------------- 7166 -- Make_Request_RTE_Call -- 7167 --------------------------- 7168 7169 function Make_Request_RTE_Call 7170 (RE : RE_Id; 7171 Actuals : List_Id := New_List) return Node_Id 7172 is 7173 begin 7174 Append_To (Actuals, 7175 Make_Attribute_Reference (Loc, 7176 Prefix => New_Occurrence_Of (Request, Loc), 7177 Attribute_Name => Name_Access)); 7178 return Make_Procedure_Call_Statement (Loc, 7179 Name => 7180 New_Occurrence_Of (RTE (RE), Loc), 7181 Parameter_Associations => Actuals); 7182 end Make_Request_RTE_Call; 7183 7184 Arguments : Node_Id; 7185 -- Name of the named values list used to transmit parameters 7186 -- to the remote package 7187 7188 Result : Node_Id; 7189 -- Name of the result named value (in non-APC cases) which get the 7190 -- result of the remote subprogram. 7191 7192 Result_TC : Node_Id; 7193 -- Typecode expression for the result of the request (void 7194 -- typecode for procedures). 7195 7196 Exception_Return_Parameter : Node_Id; 7197 -- Name of the parameter which will hold the exception sent by the 7198 -- remote subprogram. 7199 7200 Current_Parameter : Node_Id; 7201 -- Current parameter being handled 7202 7203 Ordered_Parameters_List : constant List_Id := 7204 Build_Ordered_Parameters_List (Spec); 7205 7206 Asynchronous_P : Node_Id; 7207 -- A Boolean expression indicating whether this call is asynchronous 7208 7209 Asynchronous_Statements : List_Id := No_List; 7210 Non_Asynchronous_Statements : List_Id := No_List; 7211 -- Statements specifics to the Asynchronous/Non-Asynchronous cases 7212 7213 Extra_Formal_Statements : constant List_Id := New_List; 7214 -- List of statements for extra formal parameters. It will appear 7215 -- after the regular statements for writing out parameters. 7216 7217 After_Statements : constant List_Id := New_List; 7218 -- Statements to be executed after call returns (to assign IN OUT or 7219 -- OUT parameter values). 7220 7221 Etyp : Entity_Id; 7222 -- The type of the formal parameter being processed 7223 7224 Is_Controlling_Formal : Boolean; 7225 Is_First_Controlling_Formal : Boolean; 7226 First_Controlling_Formal_Seen : Boolean := False; 7227 -- Controlling formal parameters of distributed object primitives 7228 -- require special handling, and the first such parameter needs even 7229 -- more special handling. 7230 7231 begin 7232 -- ??? document general form of stub subprograms for the PolyORB case 7233 7234 Append_To (Decls, 7235 Make_Object_Declaration (Loc, 7236 Defining_Identifier => Request, 7237 Aliased_Present => True, 7238 Object_Definition => 7239 New_Occurrence_Of (RTE (RE_Request), Loc))); 7240 7241 Result := Make_Temporary (Loc, 'R'); 7242 7243 if Is_Function then 7244 Result_TC := 7245 PolyORB_Support.Helpers.Build_TypeCode_Call 7246 (Loc, Etype (Result_Definition (Spec)), Decls); 7247 else 7248 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc); 7249 end if; 7250 7251 Append_To (Decls, 7252 Make_Object_Declaration (Loc, 7253 Defining_Identifier => Result, 7254 Aliased_Present => False, 7255 Object_Definition => 7256 New_Occurrence_Of (RTE (RE_NamedValue), Loc), 7257 Expression => 7258 Make_Aggregate (Loc, 7259 Component_Associations => New_List ( 7260 Make_Component_Association (Loc, 7261 Choices => New_List (Make_Identifier (Loc, Name_Name)), 7262 Expression => 7263 New_Occurrence_Of (RTE (RE_Result_Name), Loc)), 7264 Make_Component_Association (Loc, 7265 Choices => New_List ( 7266 Make_Identifier (Loc, Name_Argument)), 7267 Expression => 7268 Make_Function_Call (Loc, 7269 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), 7270 Parameter_Associations => New_List (Result_TC))), 7271 Make_Component_Association (Loc, 7272 Choices => New_List ( 7273 Make_Identifier (Loc, Name_Arg_Modes)), 7274 Expression => Make_Integer_Literal (Loc, 0)))))); 7275 7276 if not Is_Known_Asynchronous then 7277 Exception_Return_Parameter := Make_Temporary (Loc, 'E'); 7278 7279 Append_To (Decls, 7280 Make_Object_Declaration (Loc, 7281 Defining_Identifier => Exception_Return_Parameter, 7282 Object_Definition => 7283 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); 7284 7285 else 7286 Exception_Return_Parameter := Empty; 7287 end if; 7288 7289 -- Initialize and fill in arguments list 7290 7291 Arguments := Make_Temporary (Loc, 'A'); 7292 Declare_Create_NVList (Loc, Arguments, Decls, Statements); 7293 7294 Current_Parameter := First (Ordered_Parameters_List); 7295 while Present (Current_Parameter) loop 7296 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then 7297 Is_Controlling_Formal := True; 7298 Is_First_Controlling_Formal := 7299 not First_Controlling_Formal_Seen; 7300 First_Controlling_Formal_Seen := True; 7301 7302 else 7303 Is_Controlling_Formal := False; 7304 Is_First_Controlling_Formal := False; 7305 end if; 7306 7307 if Is_Controlling_Formal then 7308 7309 -- For a controlling formal argument, we send its reference 7310 7311 Etyp := RACW_Type; 7312 7313 else 7314 Etyp := Etype (Parameter_Type (Current_Parameter)); 7315 end if; 7316 7317 -- The first controlling formal parameter is treated specially: 7318 -- it is used to set the target object of the call. 7319 7320 if not Is_First_Controlling_Formal then 7321 declare 7322 Constrained : constant Boolean := 7323 Is_Constrained (Etyp) 7324 or else Is_Elementary_Type (Etyp); 7325 7326 Any : constant Entity_Id := Make_Temporary (Loc, 'A'); 7327 7328 Actual_Parameter : Node_Id := 7329 New_Occurrence_Of ( 7330 Defining_Identifier ( 7331 Current_Parameter), Loc); 7332 7333 Expr : Node_Id; 7334 7335 begin 7336 if Is_Controlling_Formal then 7337 7338 -- For a controlling formal parameter (other than the 7339 -- first one), use the corresponding RACW. If the 7340 -- parameter is not an anonymous access parameter, that 7341 -- involves taking its 'Unrestricted_Access. 7342 7343 if Nkind (Parameter_Type (Current_Parameter)) 7344 = N_Access_Definition 7345 then 7346 Actual_Parameter := OK_Convert_To 7347 (Etyp, Actual_Parameter); 7348 else 7349 Actual_Parameter := OK_Convert_To (Etyp, 7350 Make_Attribute_Reference (Loc, 7351 Prefix => Actual_Parameter, 7352 Attribute_Name => Name_Unrestricted_Access)); 7353 end if; 7354 7355 end if; 7356 7357 if In_Present (Current_Parameter) 7358 or else not Out_Present (Current_Parameter) 7359 or else not Constrained 7360 or else Is_Controlling_Formal 7361 then 7362 -- The parameter has an input value, is constrained at 7363 -- runtime by an input value, or is a controlling formal 7364 -- parameter (always passed as a reference) other than 7365 -- the first one. 7366 7367 Expr := PolyORB_Support.Helpers.Build_To_Any_Call 7368 (Loc, Actual_Parameter, Decls); 7369 7370 else 7371 Expr := Make_Function_Call (Loc, 7372 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), 7373 Parameter_Associations => New_List ( 7374 PolyORB_Support.Helpers.Build_TypeCode_Call 7375 (Loc, Etyp, Decls))); 7376 end if; 7377 7378 Append_To (Decls, 7379 Make_Object_Declaration (Loc, 7380 Defining_Identifier => Any, 7381 Aliased_Present => False, 7382 Object_Definition => 7383 New_Occurrence_Of (RTE (RE_Any), Loc), 7384 Expression => Expr)); 7385 7386 Append_To (Statements, 7387 Add_Parameter_To_NVList (Loc, 7388 Parameter => Current_Parameter, 7389 NVList => Arguments, 7390 Constrained => Constrained, 7391 Any => Any)); 7392 7393 if Out_Present (Current_Parameter) 7394 and then not Is_Controlling_Formal 7395 then 7396 if Is_Limited_Type (Etyp) then 7397 Helpers.Assign_Opaque_From_Any (Loc, 7398 Stms => After_Statements, 7399 Typ => Etyp, 7400 N => New_Occurrence_Of (Any, Loc), 7401 Target => 7402 Defining_Identifier (Current_Parameter)); 7403 else 7404 Append_To (After_Statements, 7405 Make_Assignment_Statement (Loc, 7406 Name => 7407 New_Occurrence_Of ( 7408 Defining_Identifier (Current_Parameter), Loc), 7409 Expression => 7410 PolyORB_Support.Helpers.Build_From_Any_Call 7411 (Etyp, 7412 New_Occurrence_Of (Any, Loc), 7413 Decls))); 7414 end if; 7415 end if; 7416 end; 7417 end if; 7418 7419 -- If the current parameter has a dynamic constrained status, then 7420 -- this status is transmitted as well. 7421 7422 -- This should be done for accessibility as well ??? 7423 7424 if Nkind (Parameter_Type (Current_Parameter)) /= 7425 N_Access_Definition 7426 and then Need_Extra_Constrained (Current_Parameter) 7427 then 7428 -- In this block, we do not use the extra formal that has been 7429 -- created because it does not exist at the time of expansion 7430 -- when building calling stubs for remote access to subprogram 7431 -- types. We create an extra variable of this type and push it 7432 -- in the stream after the regular parameters. 7433 7434 declare 7435 Extra_Any_Parameter : constant Entity_Id := 7436 Make_Temporary (Loc, 'P'); 7437 7438 Parameter_Exp : constant Node_Id := 7439 Make_Attribute_Reference (Loc, 7440 Prefix => New_Occurrence_Of ( 7441 Defining_Identifier (Current_Parameter), Loc), 7442 Attribute_Name => Name_Constrained); 7443 7444 begin 7445 Set_Etype (Parameter_Exp, Etype (Standard_Boolean)); 7446 7447 Append_To (Decls, 7448 Make_Object_Declaration (Loc, 7449 Defining_Identifier => Extra_Any_Parameter, 7450 Aliased_Present => False, 7451 Object_Definition => 7452 New_Occurrence_Of (RTE (RE_Any), Loc), 7453 Expression => 7454 PolyORB_Support.Helpers.Build_To_Any_Call 7455 (Loc, Parameter_Exp, Decls))); 7456 7457 Append_To (Extra_Formal_Statements, 7458 Add_Parameter_To_NVList (Loc, 7459 Parameter => Extra_Any_Parameter, 7460 NVList => Arguments, 7461 Constrained => True, 7462 Any => Extra_Any_Parameter)); 7463 end; 7464 end if; 7465 7466 Next (Current_Parameter); 7467 end loop; 7468 7469 -- Append the formal statements list to the statements 7470 7471 Append_List_To (Statements, Extra_Formal_Statements); 7472 7473 Append_To (Statements, 7474 Make_Procedure_Call_Statement (Loc, 7475 Name => 7476 New_Occurrence_Of (RTE (RE_Request_Setup), Loc), 7477 Parameter_Associations => New_List ( 7478 New_Occurrence_Of (Request, Loc), 7479 Target_Object, 7480 Subprogram_Id, 7481 New_Occurrence_Of (Arguments, Loc), 7482 New_Occurrence_Of (Result, Loc), 7483 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc)))); 7484 7485 pragma Assert 7486 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); 7487 7488 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then 7489 Asynchronous_P := 7490 New_Occurrence_Of 7491 (Boolean_Literals (Is_Known_Asynchronous), Loc); 7492 7493 else 7494 pragma Assert (Present (Asynchronous)); 7495 Asynchronous_P := New_Copy_Tree (Asynchronous); 7496 7497 -- The expression node Asynchronous will be used to build an 'if' 7498 -- statement at the end of Build_General_Calling_Stubs: we need to 7499 -- make a copy here. 7500 end if; 7501 7502 Append_To (Parameter_Associations (Last (Statements)), 7503 Make_Indexed_Component (Loc, 7504 Prefix => 7505 New_Occurrence_Of ( 7506 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc), 7507 Expressions => New_List (Asynchronous_P))); 7508 7509 Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke)); 7510 7511 -- Asynchronous case 7512 7513 if not Is_Known_Non_Asynchronous then 7514 Asynchronous_Statements := New_List (Make_Null_Statement (Loc)); 7515 end if; 7516 7517 -- Non-asynchronous case 7518 7519 if not Is_Known_Asynchronous then 7520 -- Reraise an exception occurrence from the completed request. 7521 -- If the exception occurrence is empty, this is a no-op. 7522 7523 Non_Asynchronous_Statements := New_List ( 7524 Make_Procedure_Call_Statement (Loc, 7525 Name => 7526 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc), 7527 Parameter_Associations => New_List ( 7528 New_Occurrence_Of (Request, Loc)))); 7529 7530 if Is_Function then 7531 -- If this is a function call, read the value and return it 7532 7533 Append_To (Non_Asynchronous_Statements, 7534 Make_Tag_Check (Loc, 7535 Make_Simple_Return_Statement (Loc, 7536 PolyORB_Support.Helpers.Build_From_Any_Call 7537 (Etype (Result_Definition (Spec)), 7538 Make_Selected_Component (Loc, 7539 Prefix => Result, 7540 Selector_Name => Name_Argument), 7541 Decls)))); 7542 7543 else 7544 7545 -- Case of a procedure: deal with IN OUT and OUT formals 7546 7547 Append_List_To (Non_Asynchronous_Statements, After_Statements); 7548 end if; 7549 end if; 7550 7551 if Is_Known_Asynchronous then 7552 Append_List_To (Statements, Asynchronous_Statements); 7553 7554 elsif Is_Known_Non_Asynchronous then 7555 Append_List_To (Statements, Non_Asynchronous_Statements); 7556 7557 else 7558 pragma Assert (Present (Asynchronous)); 7559 Append_To (Statements, 7560 Make_Implicit_If_Statement (Nod, 7561 Condition => Asynchronous, 7562 Then_Statements => Asynchronous_Statements, 7563 Else_Statements => Non_Asynchronous_Statements)); 7564 end if; 7565 end Build_General_Calling_Stubs; 7566 7567 ----------------------- 7568 -- Build_Stub_Target -- 7569 ----------------------- 7570 7571 function Build_Stub_Target 7572 (Loc : Source_Ptr; 7573 Decls : List_Id; 7574 RCI_Locator : Entity_Id; 7575 Controlling_Parameter : Entity_Id) return RPC_Target 7576 is 7577 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA); 7578 Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T'); 7579 7580 begin 7581 if Present (Controlling_Parameter) then 7582 Append_To (Decls, 7583 Make_Object_Declaration (Loc, 7584 Defining_Identifier => Target_Reference, 7585 7586 Object_Definition => 7587 New_Occurrence_Of (RTE (RE_Object_Ref), Loc), 7588 7589 Expression => 7590 Make_Function_Call (Loc, 7591 Name => 7592 New_Occurrence_Of (RTE (RE_Make_Ref), Loc), 7593 Parameter_Associations => New_List ( 7594 Make_Selected_Component (Loc, 7595 Prefix => Controlling_Parameter, 7596 Selector_Name => Name_Target))))); 7597 7598 -- Note: Controlling_Parameter has the same components as 7599 -- System.Partition_Interface.RACW_Stub_Type. 7600 7601 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc); 7602 7603 else 7604 Target_Info.Object := 7605 Make_Selected_Component (Loc, 7606 Prefix => 7607 Make_Identifier (Loc, Chars (RCI_Locator)), 7608 Selector_Name => 7609 Make_Identifier (Loc, Name_Get_RCI_Package_Ref)); 7610 end if; 7611 7612 return Target_Info; 7613 end Build_Stub_Target; 7614 7615 ----------------------------- 7616 -- Build_RPC_Receiver_Body -- 7617 ----------------------------- 7618 7619 procedure Build_RPC_Receiver_Body 7620 (RPC_Receiver : Entity_Id; 7621 Request : out Entity_Id; 7622 Subp_Id : out Entity_Id; 7623 Subp_Index : out Entity_Id; 7624 Stmts : out List_Id; 7625 Decl : out Node_Id) 7626 is 7627 Loc : constant Source_Ptr := Sloc (RPC_Receiver); 7628 7629 RPC_Receiver_Spec : Node_Id; 7630 RPC_Receiver_Decls : List_Id; 7631 7632 begin 7633 Request := Make_Defining_Identifier (Loc, Name_R); 7634 7635 RPC_Receiver_Spec := 7636 Build_RPC_Receiver_Specification 7637 (RPC_Receiver => RPC_Receiver, 7638 Request_Parameter => Request); 7639 7640 Subp_Id := Make_Defining_Identifier (Loc, Name_P); 7641 Subp_Index := Make_Defining_Identifier (Loc, Name_I); 7642 7643 RPC_Receiver_Decls := New_List ( 7644 Make_Object_Renaming_Declaration (Loc, 7645 Defining_Identifier => Subp_Id, 7646 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), 7647 Name => 7648 Make_Explicit_Dereference (Loc, 7649 Prefix => 7650 Make_Selected_Component (Loc, 7651 Prefix => Request, 7652 Selector_Name => Name_Operation))), 7653 7654 Make_Object_Declaration (Loc, 7655 Defining_Identifier => Subp_Index, 7656 Object_Definition => 7657 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), 7658 Expression => 7659 Make_Attribute_Reference (Loc, 7660 Prefix => 7661 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), 7662 Attribute_Name => Name_Last))); 7663 7664 Stmts := New_List; 7665 7666 Decl := 7667 Make_Subprogram_Body (Loc, 7668 Specification => RPC_Receiver_Spec, 7669 Declarations => RPC_Receiver_Decls, 7670 Handled_Statement_Sequence => 7671 Make_Handled_Sequence_Of_Statements (Loc, 7672 Statements => Stmts)); 7673 end Build_RPC_Receiver_Body; 7674 7675 -------------------------------------- 7676 -- Build_Subprogram_Receiving_Stubs -- 7677 -------------------------------------- 7678 7679 function Build_Subprogram_Receiving_Stubs 7680 (Vis_Decl : Node_Id; 7681 Asynchronous : Boolean; 7682 Dynamically_Asynchronous : Boolean := False; 7683 Stub_Type : Entity_Id := Empty; 7684 RACW_Type : Entity_Id := Empty; 7685 Parent_Primitive : Entity_Id := Empty) return Node_Id 7686 is 7687 Loc : constant Source_Ptr := Sloc (Vis_Decl); 7688 7689 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R'); 7690 -- Formal parameter for receiving stubs: a descriptor for an incoming 7691 -- request. 7692 7693 Outer_Decls : constant List_Id := New_List; 7694 -- At the outermost level, an NVList and Any's are declared for all 7695 -- parameters. The Dynamic_Async flag also needs to be declared there 7696 -- to be visible from the exception handling code. 7697 7698 Outer_Statements : constant List_Id := New_List; 7699 -- Statements that occur prior to the declaration of the actual 7700 -- parameter variables. 7701 7702 Outer_Extra_Formal_Statements : constant List_Id := New_List; 7703 -- Statements concerning extra formal parameters, prior to the 7704 -- declaration of the actual parameter variables. 7705 7706 Decls : constant List_Id := New_List; 7707 -- All the parameters will get declared before calling the real 7708 -- subprograms. Also the out parameters will be declared. At this 7709 -- level, parameters may be unconstrained. 7710 7711 Statements : constant List_Id := New_List; 7712 7713 After_Statements : constant List_Id := New_List; 7714 -- Statements to be executed after the subprogram call 7715 7716 Inner_Decls : List_Id := No_List; 7717 -- In case of a function, the inner declarations are needed since 7718 -- the result may be unconstrained. 7719 7720 Excep_Handlers : List_Id := No_List; 7721 7722 Parameter_List : constant List_Id := New_List; 7723 -- List of parameters to be passed to the subprogram 7724 7725 First_Controlling_Formal_Seen : Boolean := False; 7726 7727 Current_Parameter : Node_Id; 7728 7729 Ordered_Parameters_List : constant List_Id := 7730 Build_Ordered_Parameters_List 7731 (Specification (Vis_Decl)); 7732 7733 Arguments : constant Entity_Id := Make_Temporary (Loc, 'A'); 7734 -- Name of the named values list used to retrieve parameters 7735 7736 Subp_Spec : Node_Id; 7737 -- Subprogram specification 7738 7739 Called_Subprogram : Node_Id; 7740 -- The subprogram to call 7741 7742 begin 7743 if Present (RACW_Type) then 7744 Called_Subprogram := 7745 New_Occurrence_Of (Parent_Primitive, Loc); 7746 else 7747 Called_Subprogram := 7748 New_Occurrence_Of 7749 (Defining_Unit_Name (Specification (Vis_Decl)), Loc); 7750 end if; 7751 7752 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements); 7753 7754 -- Loop through every parameter and get its value from the stream. If 7755 -- the parameter is unconstrained, then the parameter is read using 7756 -- 'Input at the point of declaration. 7757 7758 Current_Parameter := First (Ordered_Parameters_List); 7759 while Present (Current_Parameter) loop 7760 declare 7761 Etyp : Entity_Id; 7762 Constrained : Boolean; 7763 Any : Entity_Id := Empty; 7764 Object : constant Entity_Id := Make_Temporary (Loc, 'P'); 7765 Expr : Node_Id := Empty; 7766 7767 Is_Controlling_Formal : constant Boolean := 7768 Is_RACW_Controlling_Formal 7769 (Current_Parameter, Stub_Type); 7770 7771 Is_First_Controlling_Formal : Boolean := False; 7772 7773 Need_Extra_Constrained : Boolean; 7774 -- True when an extra constrained actual is required 7775 7776 begin 7777 if Is_Controlling_Formal then 7778 7779 -- Controlling formals in distributed object primitive 7780 -- operations are handled specially: 7781 7782 -- - the first controlling formal is used as the 7783 -- target of the call; 7784 7785 -- - the remaining controlling formals are transmitted 7786 -- as RACWs. 7787 7788 Etyp := RACW_Type; 7789 Is_First_Controlling_Formal := 7790 not First_Controlling_Formal_Seen; 7791 First_Controlling_Formal_Seen := True; 7792 7793 else 7794 Etyp := Etype (Parameter_Type (Current_Parameter)); 7795 end if; 7796 7797 Constrained := 7798 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); 7799 7800 if not Is_First_Controlling_Formal then 7801 Any := Make_Temporary (Loc, 'A'); 7802 7803 Append_To (Outer_Decls, 7804 Make_Object_Declaration (Loc, 7805 Defining_Identifier => Any, 7806 Object_Definition => 7807 New_Occurrence_Of (RTE (RE_Any), Loc), 7808 Expression => 7809 Make_Function_Call (Loc, 7810 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc), 7811 Parameter_Associations => New_List ( 7812 PolyORB_Support.Helpers.Build_TypeCode_Call 7813 (Loc, Etyp, Outer_Decls))))); 7814 7815 Append_To (Outer_Statements, 7816 Add_Parameter_To_NVList (Loc, 7817 Parameter => Current_Parameter, 7818 NVList => Arguments, 7819 Constrained => Constrained, 7820 Any => Any)); 7821 end if; 7822 7823 if Is_First_Controlling_Formal then 7824 declare 7825 Addr : constant Entity_Id := Make_Temporary (Loc, 'A'); 7826 7827 Is_Local : constant Entity_Id := 7828 Make_Temporary (Loc, 'L'); 7829 7830 begin 7831 -- Special case: obtain the first controlling formal 7832 -- from the target of the remote call, instead of the 7833 -- argument list. 7834 7835 Append_To (Outer_Decls, 7836 Make_Object_Declaration (Loc, 7837 Defining_Identifier => Addr, 7838 Object_Definition => 7839 New_Occurrence_Of (RTE (RE_Address), Loc))); 7840 7841 Append_To (Outer_Decls, 7842 Make_Object_Declaration (Loc, 7843 Defining_Identifier => Is_Local, 7844 Object_Definition => 7845 New_Occurrence_Of (Standard_Boolean, Loc))); 7846 7847 Append_To (Outer_Statements, 7848 Make_Procedure_Call_Statement (Loc, 7849 Name => 7850 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), 7851 Parameter_Associations => New_List ( 7852 Make_Selected_Component (Loc, 7853 Prefix => 7854 New_Occurrence_Of ( 7855 Request_Parameter, Loc), 7856 Selector_Name => 7857 Make_Identifier (Loc, Name_Target)), 7858 New_Occurrence_Of (Is_Local, Loc), 7859 New_Occurrence_Of (Addr, Loc)))); 7860 7861 Expr := Unchecked_Convert_To (RACW_Type, 7862 New_Occurrence_Of (Addr, Loc)); 7863 end; 7864 7865 elsif In_Present (Current_Parameter) 7866 or else not Out_Present (Current_Parameter) 7867 or else not Constrained 7868 then 7869 -- If an input parameter is constrained, then its reading is 7870 -- deferred until the beginning of the subprogram body. If 7871 -- it is unconstrained, then an expression is built for 7872 -- the object declaration and the variable is set using 7873 -- 'Input instead of 'Read. 7874 7875 if Constrained and then Is_Limited_Type (Etyp) then 7876 Helpers.Assign_Opaque_From_Any (Loc, 7877 Stms => Statements, 7878 Typ => Etyp, 7879 N => New_Occurrence_Of (Any, Loc), 7880 Target => Object); 7881 7882 else 7883 Expr := Helpers.Build_From_Any_Call 7884 (Etyp, New_Occurrence_Of (Any, Loc), Decls); 7885 7886 if Constrained then 7887 Append_To (Statements, 7888 Make_Assignment_Statement (Loc, 7889 Name => New_Occurrence_Of (Object, Loc), 7890 Expression => Expr)); 7891 Expr := Empty; 7892 7893 else 7894 -- Expr will be used to initialize (and constrain) the 7895 -- parameter when it is declared. 7896 null; 7897 end if; 7898 7899 null; 7900 end if; 7901 end if; 7902 7903 Need_Extra_Constrained := 7904 Nkind (Parameter_Type (Current_Parameter)) /= 7905 N_Access_Definition 7906 and then 7907 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void 7908 and then 7909 Present (Extra_Constrained 7910 (Defining_Identifier (Current_Parameter))); 7911 7912 -- We may not associate an extra constrained actual to a 7913 -- constant object, so if one is needed, declare the actual 7914 -- as a variable even if it won't be modified. 7915 7916 Build_Actual_Object_Declaration 7917 (Object => Object, 7918 Etyp => Etyp, 7919 Variable => Need_Extra_Constrained 7920 or else Out_Present (Current_Parameter), 7921 Expr => Expr, 7922 Decls => Decls); 7923 Set_Etype (Object, Etyp); 7924 7925 -- An out parameter may be written back using a 'Write 7926 -- attribute instead of a 'Output because it has been 7927 -- constrained by the parameter given to the caller. Note that 7928 -- out controlling arguments in the case of a RACW are not put 7929 -- back in the stream because the pointer on them has not 7930 -- changed. 7931 7932 if Out_Present (Current_Parameter) 7933 and then not Is_Controlling_Formal 7934 then 7935 Append_To (After_Statements, 7936 Make_Procedure_Call_Statement (Loc, 7937 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc), 7938 Parameter_Associations => New_List ( 7939 New_Occurrence_Of (Any, Loc), 7940 PolyORB_Support.Helpers.Build_To_Any_Call 7941 (Loc, New_Occurrence_Of (Object, Loc), Decls)))); 7942 end if; 7943 7944 -- For RACW controlling formals, the Etyp of Object is always 7945 -- an RACW, even if the parameter is not of an anonymous access 7946 -- type. In such case, we need to dereference it at call time. 7947 7948 if Is_Controlling_Formal then 7949 if Nkind (Parameter_Type (Current_Parameter)) /= 7950 N_Access_Definition 7951 then 7952 Append_To (Parameter_List, 7953 Make_Parameter_Association (Loc, 7954 Selector_Name => 7955 New_Occurrence_Of 7956 (Defining_Identifier (Current_Parameter), Loc), 7957 Explicit_Actual_Parameter => 7958 Make_Explicit_Dereference (Loc, 7959 Prefix => New_Occurrence_Of (Object, Loc)))); 7960 7961 else 7962 Append_To (Parameter_List, 7963 Make_Parameter_Association (Loc, 7964 Selector_Name => 7965 New_Occurrence_Of 7966 (Defining_Identifier (Current_Parameter), Loc), 7967 7968 Explicit_Actual_Parameter => 7969 New_Occurrence_Of (Object, Loc))); 7970 end if; 7971 7972 else 7973 Append_To (Parameter_List, 7974 Make_Parameter_Association (Loc, 7975 Selector_Name => 7976 New_Occurrence_Of ( 7977 Defining_Identifier (Current_Parameter), Loc), 7978 Explicit_Actual_Parameter => 7979 New_Occurrence_Of (Object, Loc))); 7980 end if; 7981 7982 -- If the current parameter needs an extra formal, then read it 7983 -- from the stream and set the corresponding semantic field in 7984 -- the variable. If the kind of the parameter identifier is 7985 -- E_Void, then this is a compiler generated parameter that 7986 -- doesn't need an extra constrained status. 7987 7988 -- The case of Extra_Accessibility should also be handled ??? 7989 7990 if Need_Extra_Constrained then 7991 declare 7992 Extra_Parameter : constant Entity_Id := 7993 Extra_Constrained 7994 (Defining_Identifier 7995 (Current_Parameter)); 7996 7997 Extra_Any : constant Entity_Id := 7998 Make_Temporary (Loc, 'A'); 7999 8000 Formal_Entity : constant Entity_Id := 8001 Make_Defining_Identifier (Loc, 8002 Chars => Chars (Extra_Parameter)); 8003 8004 Formal_Type : constant Entity_Id := 8005 Etype (Extra_Parameter); 8006 8007 begin 8008 Append_To (Outer_Decls, 8009 Make_Object_Declaration (Loc, 8010 Defining_Identifier => Extra_Any, 8011 Object_Definition => 8012 New_Occurrence_Of (RTE (RE_Any), Loc), 8013 Expression => 8014 Make_Function_Call (Loc, 8015 Name => 8016 New_Occurrence_Of (RTE (RE_Create_Any), Loc), 8017 Parameter_Associations => New_List ( 8018 PolyORB_Support.Helpers.Build_TypeCode_Call 8019 (Loc, Formal_Type, Outer_Decls))))); 8020 8021 Append_To (Outer_Extra_Formal_Statements, 8022 Add_Parameter_To_NVList (Loc, 8023 Parameter => Extra_Parameter, 8024 NVList => Arguments, 8025 Constrained => True, 8026 Any => Extra_Any)); 8027 8028 Append_To (Decls, 8029 Make_Object_Declaration (Loc, 8030 Defining_Identifier => Formal_Entity, 8031 Object_Definition => 8032 New_Occurrence_Of (Formal_Type, Loc))); 8033 8034 Append_To (Statements, 8035 Make_Assignment_Statement (Loc, 8036 Name => New_Occurrence_Of (Formal_Entity, Loc), 8037 Expression => 8038 PolyORB_Support.Helpers.Build_From_Any_Call 8039 (Formal_Type, 8040 New_Occurrence_Of (Extra_Any, Loc), 8041 Decls))); 8042 Set_Extra_Constrained (Object, Formal_Entity); 8043 end; 8044 end if; 8045 end; 8046 8047 Next (Current_Parameter); 8048 end loop; 8049 8050 -- Extra Formals should go after all the other parameters 8051 8052 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements); 8053 8054 Append_To (Outer_Statements, 8055 Make_Procedure_Call_Statement (Loc, 8056 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc), 8057 Parameter_Associations => New_List ( 8058 New_Occurrence_Of (Request_Parameter, Loc), 8059 New_Occurrence_Of (Arguments, Loc)))); 8060 8061 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then 8062 8063 -- The remote subprogram is a function: Build an inner block to be 8064 -- able to hold a potentially unconstrained result in a variable. 8065 8066 declare 8067 Etyp : constant Entity_Id := 8068 Etype (Result_Definition (Specification (Vis_Decl))); 8069 Result : constant Node_Id := Make_Temporary (Loc, 'R'); 8070 8071 begin 8072 Inner_Decls := New_List ( 8073 Make_Object_Declaration (Loc, 8074 Defining_Identifier => Result, 8075 Constant_Present => True, 8076 Object_Definition => New_Occurrence_Of (Etyp, Loc), 8077 Expression => 8078 Make_Function_Call (Loc, 8079 Name => Called_Subprogram, 8080 Parameter_Associations => Parameter_List))); 8081 8082 if Is_Class_Wide_Type (Etyp) then 8083 8084 -- For a remote call to a function with a class-wide type, 8085 -- check that the returned value satisfies the requirements 8086 -- of (RM E.4(18)). 8087 8088 Append_To (Inner_Decls, 8089 Make_Transportable_Check (Loc, 8090 New_Occurrence_Of (Result, Loc))); 8091 8092 end if; 8093 8094 Set_Etype (Result, Etyp); 8095 Append_To (After_Statements, 8096 Make_Procedure_Call_Statement (Loc, 8097 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc), 8098 Parameter_Associations => New_List ( 8099 New_Occurrence_Of (Request_Parameter, Loc), 8100 PolyORB_Support.Helpers.Build_To_Any_Call 8101 (Loc, New_Occurrence_Of (Result, Loc), Decls)))); 8102 8103 -- A DSA function does not have out or inout arguments 8104 end; 8105 8106 Append_To (Statements, 8107 Make_Block_Statement (Loc, 8108 Declarations => Inner_Decls, 8109 Handled_Statement_Sequence => 8110 Make_Handled_Sequence_Of_Statements (Loc, 8111 Statements => After_Statements))); 8112 8113 else 8114 -- The remote subprogram is a procedure. We do not need any inner 8115 -- block in this case. No specific processing is required here for 8116 -- the dynamically asynchronous case: the indication of whether 8117 -- call is asynchronous or not is managed by the Sync_Scope 8118 -- attibute of the request, and is handled entirely in the 8119 -- protocol layer. 8120 8121 Append_To (After_Statements, 8122 Make_Procedure_Call_Statement (Loc, 8123 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc), 8124 Parameter_Associations => New_List ( 8125 New_Occurrence_Of (Request_Parameter, Loc)))); 8126 8127 Append_To (Statements, 8128 Make_Procedure_Call_Statement (Loc, 8129 Name => Called_Subprogram, 8130 Parameter_Associations => Parameter_List)); 8131 8132 Append_List_To (Statements, After_Statements); 8133 end if; 8134 8135 Subp_Spec := 8136 Make_Procedure_Specification (Loc, 8137 Defining_Unit_Name => Make_Temporary (Loc, 'F'), 8138 8139 Parameter_Specifications => New_List ( 8140 Make_Parameter_Specification (Loc, 8141 Defining_Identifier => Request_Parameter, 8142 Parameter_Type => 8143 New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); 8144 8145 -- An exception raised during the execution of an incoming remote 8146 -- subprogram call and that needs to be sent back to the caller is 8147 -- propagated by the receiving stubs, and will be handled by the 8148 -- caller (the distribution runtime). 8149 8150 if Asynchronous and then not Dynamically_Asynchronous then 8151 8152 -- For an asynchronous procedure, add a null exception handler 8153 8154 Excep_Handlers := New_List ( 8155 Make_Implicit_Exception_Handler (Loc, 8156 Exception_Choices => New_List (Make_Others_Choice (Loc)), 8157 Statements => New_List (Make_Null_Statement (Loc)))); 8158 8159 else 8160 -- In the other cases, if an exception is raised, then the 8161 -- exception occurrence is propagated. 8162 8163 null; 8164 end if; 8165 8166 Append_To (Outer_Statements, 8167 Make_Block_Statement (Loc, 8168 Declarations => Decls, 8169 Handled_Statement_Sequence => 8170 Make_Handled_Sequence_Of_Statements (Loc, 8171 Statements => Statements))); 8172 8173 return 8174 Make_Subprogram_Body (Loc, 8175 Specification => Subp_Spec, 8176 Declarations => Outer_Decls, 8177 Handled_Statement_Sequence => 8178 Make_Handled_Sequence_Of_Statements (Loc, 8179 Statements => Outer_Statements, 8180 Exception_Handlers => Excep_Handlers)); 8181 end Build_Subprogram_Receiving_Stubs; 8182 8183 ------------- 8184 -- Helpers -- 8185 ------------- 8186 8187 package body Helpers is 8188 8189 ----------------------- 8190 -- Local Subprograms -- 8191 ----------------------- 8192 8193 function Find_Numeric_Representation 8194 (Typ : Entity_Id) return Entity_Id; 8195 -- Given a numeric type Typ, return the smallest integer or modular 8196 -- type from Interfaces, or the smallest floating point type from 8197 -- Standard whose range encompasses that of Typ. 8198 8199 function Make_Helper_Function_Name 8200 (Loc : Source_Ptr; 8201 Typ : Entity_Id; 8202 Nam : Name_Id) return Entity_Id; 8203 -- Return the name to be assigned for helper subprogram Nam of Typ 8204 8205 ------------------------------------------------------------ 8206 -- Common subprograms for building various tree fragments -- 8207 ------------------------------------------------------------ 8208 8209 function Build_Get_Aggregate_Element 8210 (Loc : Source_Ptr; 8211 Any : Entity_Id; 8212 TC : Node_Id; 8213 Idx : Node_Id) return Node_Id; 8214 -- Build a call to Get_Aggregate_Element on Any for typecode TC, 8215 -- returning the Idx'th element. 8216 8217 generic 8218 Subprogram : Entity_Id; 8219 -- Reference location for constructed nodes 8220 8221 Arry : Entity_Id; 8222 -- For 'Range and Etype 8223 8224 Indexes : List_Id; 8225 -- For the construction of the innermost element expression 8226 8227 with procedure Add_Process_Element 8228 (Stmts : List_Id; 8229 Any : Entity_Id; 8230 Counter : Entity_Id; 8231 Datum : Node_Id); 8232 8233 procedure Append_Array_Traversal 8234 (Stmts : List_Id; 8235 Any : Entity_Id; 8236 Counter : Entity_Id := Empty; 8237 Depth : Pos := 1); 8238 -- Build nested loop statements that iterate over the elements of an 8239 -- array Arry. The statement(s) built by Add_Process_Element are 8240 -- executed for each element; Indexes is the list of indexes to be 8241 -- used in the construction of the indexed component that denotes the 8242 -- current element. Subprogram is the entity for the subprogram for 8243 -- which this iterator is generated. The generated statements are 8244 -- appended to Stmts. 8245 8246 generic 8247 Rec : Entity_Id; 8248 -- The record entity being dealt with 8249 8250 with procedure Add_Process_Element 8251 (Stmts : List_Id; 8252 Container : Node_Or_Entity_Id; 8253 Counter : in out Int; 8254 Rec : Entity_Id; 8255 Field : Node_Id); 8256 -- Rec is the instance of the record type, or Empty. 8257 -- Field is either the N_Defining_Identifier for a component, 8258 -- or an N_Variant_Part. 8259 8260 procedure Append_Record_Traversal 8261 (Stmts : List_Id; 8262 Clist : Node_Id; 8263 Container : Node_Or_Entity_Id; 8264 Counter : in out Int); 8265 -- Process component list Clist. Individual fields are passed 8266 -- to Field_Processing. Each variant part is also processed. 8267 -- Container is the outer Any (for From_Any/To_Any), 8268 -- the outer typecode (for TC) to which the operation applies. 8269 8270 ----------------------------- 8271 -- Append_Record_Traversal -- 8272 ----------------------------- 8273 8274 procedure Append_Record_Traversal 8275 (Stmts : List_Id; 8276 Clist : Node_Id; 8277 Container : Node_Or_Entity_Id; 8278 Counter : in out Int) 8279 is 8280 CI : List_Id; 8281 VP : Node_Id; 8282 -- Clist's Component_Items and Variant_Part 8283 8284 Item : Node_Id; 8285 Def : Entity_Id; 8286 8287 begin 8288 if No (Clist) then 8289 return; 8290 end if; 8291 8292 CI := Component_Items (Clist); 8293 VP := Variant_Part (Clist); 8294 8295 Item := First (CI); 8296 while Present (Item) loop 8297 Def := Defining_Identifier (Item); 8298 8299 if not Is_Internal_Name (Chars (Def)) then 8300 Add_Process_Element 8301 (Stmts, Container, Counter, Rec, Def); 8302 end if; 8303 8304 Next (Item); 8305 end loop; 8306 8307 if Present (VP) then 8308 Add_Process_Element (Stmts, Container, Counter, Rec, VP); 8309 end if; 8310 end Append_Record_Traversal; 8311 8312 ----------------------------- 8313 -- Assign_Opaque_From_Any -- 8314 ----------------------------- 8315 8316 procedure Assign_Opaque_From_Any 8317 (Loc : Source_Ptr; 8318 Stms : List_Id; 8319 Typ : Entity_Id; 8320 N : Node_Id; 8321 Target : Entity_Id) 8322 is 8323 Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); 8324 Expr : Node_Id; 8325 8326 Read_Call_List : List_Id; 8327 -- List on which to place the 'Read attribute reference 8328 8329 begin 8330 -- Strm : Buffer_Stream_Type; 8331 8332 Append_To (Stms, 8333 Make_Object_Declaration (Loc, 8334 Defining_Identifier => Strm, 8335 Aliased_Present => True, 8336 Object_Definition => 8337 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); 8338 8339 -- Any_To_BS (Strm, A); 8340 8341 Append_To (Stms, 8342 Make_Procedure_Call_Statement (Loc, 8343 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), 8344 Parameter_Associations => New_List ( 8345 N, 8346 New_Occurrence_Of (Strm, Loc)))); 8347 8348 if Transmit_As_Unconstrained (Typ) then 8349 Expr := 8350 Make_Attribute_Reference (Loc, 8351 Prefix => New_Occurrence_Of (Typ, Loc), 8352 Attribute_Name => Name_Input, 8353 Expressions => New_List ( 8354 Make_Attribute_Reference (Loc, 8355 Prefix => New_Occurrence_Of (Strm, Loc), 8356 Attribute_Name => Name_Access))); 8357 8358 -- Target := Typ'Input (Strm'Access) 8359 8360 if Present (Target) then 8361 Append_To (Stms, 8362 Make_Assignment_Statement (Loc, 8363 Name => New_Occurrence_Of (Target, Loc), 8364 Expression => Expr)); 8365 8366 -- return Typ'Input (Strm'Access); 8367 8368 else 8369 Append_To (Stms, 8370 Make_Simple_Return_Statement (Loc, 8371 Expression => Expr)); 8372 end if; 8373 8374 else 8375 if Present (Target) then 8376 Read_Call_List := Stms; 8377 Expr := New_Occurrence_Of (Target, Loc); 8378 8379 else 8380 declare 8381 Temp : constant Entity_Id := Make_Temporary (Loc, 'R'); 8382 8383 begin 8384 Read_Call_List := New_List; 8385 Expr := New_Occurrence_Of (Temp, Loc); 8386 8387 Append_To (Stms, Make_Block_Statement (Loc, 8388 Declarations => New_List ( 8389 Make_Object_Declaration (Loc, 8390 Defining_Identifier => 8391 Temp, 8392 Object_Definition => 8393 New_Occurrence_Of (Typ, Loc))), 8394 8395 Handled_Statement_Sequence => 8396 Make_Handled_Sequence_Of_Statements (Loc, 8397 Statements => Read_Call_List))); 8398 end; 8399 end if; 8400 8401 -- Typ'Read (Strm'Access, [Target|Temp]) 8402 8403 Append_To (Read_Call_List, 8404 Make_Attribute_Reference (Loc, 8405 Prefix => New_Occurrence_Of (Typ, Loc), 8406 Attribute_Name => Name_Read, 8407 Expressions => New_List ( 8408 Make_Attribute_Reference (Loc, 8409 Prefix => New_Occurrence_Of (Strm, Loc), 8410 Attribute_Name => Name_Access), 8411 Expr))); 8412 8413 if No (Target) then 8414 8415 -- return Temp 8416 8417 Append_To (Read_Call_List, 8418 Make_Simple_Return_Statement (Loc, 8419 Expression => New_Copy (Expr))); 8420 end if; 8421 end if; 8422 end Assign_Opaque_From_Any; 8423 8424 ------------------------- 8425 -- Build_From_Any_Call -- 8426 ------------------------- 8427 8428 function Build_From_Any_Call 8429 (Typ : Entity_Id; 8430 N : Node_Id; 8431 Decls : List_Id) return Node_Id 8432 is 8433 Loc : constant Source_Ptr := Sloc (N); 8434 8435 U_Type : Entity_Id := Underlying_Type (Typ); 8436 8437 Fnam : Entity_Id := Empty; 8438 Lib_RE : RE_Id := RE_Null; 8439 Result : Node_Id; 8440 8441 begin 8442 -- First simple case where the From_Any function is present 8443 -- in the type's TSS. 8444 8445 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any); 8446 8447 -- For the subtype representing a generic actual type, go to the 8448 -- actual type. 8449 8450 if Is_Generic_Actual_Type (U_Type) then 8451 U_Type := Underlying_Type (Base_Type (U_Type)); 8452 end if; 8453 8454 -- For a standard subtype, go to the base type 8455 8456 if Sloc (U_Type) <= Standard_Location then 8457 U_Type := Base_Type (U_Type); 8458 8459 -- For a user subtype, go to first subtype 8460 8461 elsif Comes_From_Source (U_Type) 8462 and then Nkind (Declaration_Node (U_Type)) 8463 = N_Subtype_Declaration 8464 then 8465 U_Type := First_Subtype (U_Type); 8466 end if; 8467 8468 -- Check first for Boolean and Character. These are enumeration 8469 -- types, but we treat them specially, since they may require 8470 -- special handling in the transfer protocol. However, this 8471 -- special handling only applies if they have standard 8472 -- representation, otherwise they are treated like any other 8473 -- enumeration type. 8474 8475 if Present (Fnam) then 8476 null; 8477 8478 elsif U_Type = Standard_Boolean then 8479 Lib_RE := RE_FA_B; 8480 8481 elsif U_Type = Standard_Character then 8482 Lib_RE := RE_FA_C; 8483 8484 elsif U_Type = Standard_Wide_Character then 8485 Lib_RE := RE_FA_WC; 8486 8487 elsif U_Type = Standard_Wide_Wide_Character then 8488 Lib_RE := RE_FA_WWC; 8489 8490 -- Floating point types 8491 8492 elsif U_Type = Standard_Short_Float then 8493 Lib_RE := RE_FA_SF; 8494 8495 elsif U_Type = Standard_Float then 8496 Lib_RE := RE_FA_F; 8497 8498 elsif U_Type = Standard_Long_Float then 8499 Lib_RE := RE_FA_LF; 8500 8501 elsif U_Type = Standard_Long_Long_Float then 8502 Lib_RE := RE_FA_LLF; 8503 8504 -- Integer types 8505 8506 elsif U_Type = RTE (RE_Integer_8) then 8507 Lib_RE := RE_FA_I8; 8508 8509 elsif U_Type = RTE (RE_Integer_16) then 8510 Lib_RE := RE_FA_I16; 8511 8512 elsif U_Type = RTE (RE_Integer_32) then 8513 Lib_RE := RE_FA_I32; 8514 8515 elsif U_Type = RTE (RE_Integer_64) then 8516 Lib_RE := RE_FA_I64; 8517 8518 -- Unsigned integer types 8519 8520 elsif U_Type = RTE (RE_Unsigned_8) then 8521 Lib_RE := RE_FA_U8; 8522 8523 elsif U_Type = RTE (RE_Unsigned_16) then 8524 Lib_RE := RE_FA_U16; 8525 8526 elsif U_Type = RTE (RE_Unsigned_32) then 8527 Lib_RE := RE_FA_U32; 8528 8529 elsif U_Type = RTE (RE_Unsigned_64) then 8530 Lib_RE := RE_FA_U64; 8531 8532 elsif Is_RTE (U_Type, RE_Unbounded_String) then 8533 Lib_RE := RE_FA_String; 8534 8535 -- Special DSA types 8536 8537 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then 8538 Lib_RE := RE_FA_A; 8539 8540 -- Other (non-primitive) types 8541 8542 else 8543 declare 8544 Decl : Entity_Id; 8545 8546 begin 8547 Build_From_Any_Function (Loc, U_Type, Decl, Fnam); 8548 Append_To (Decls, Decl); 8549 end; 8550 end if; 8551 8552 -- Call the function 8553 8554 if Lib_RE /= RE_Null then 8555 pragma Assert (No (Fnam)); 8556 Fnam := RTE (Lib_RE); 8557 end if; 8558 8559 Result := 8560 Make_Function_Call (Loc, 8561 Name => New_Occurrence_Of (Fnam, Loc), 8562 Parameter_Associations => New_List (N)); 8563 8564 -- We must set the type of Result, so the unchecked conversion 8565 -- from the underlying type to the base type is properly done. 8566 8567 Set_Etype (Result, U_Type); 8568 8569 return Unchecked_Convert_To (Typ, Result); 8570 end Build_From_Any_Call; 8571 8572 ----------------------------- 8573 -- Build_From_Any_Function -- 8574 ----------------------------- 8575 8576 procedure Build_From_Any_Function 8577 (Loc : Source_Ptr; 8578 Typ : Entity_Id; 8579 Decl : out Node_Id; 8580 Fnam : out Entity_Id) 8581 is 8582 Spec : Node_Id; 8583 Decls : constant List_Id := New_List; 8584 Stms : constant List_Id := New_List; 8585 8586 Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A'); 8587 8588 Use_Opaque_Representation : Boolean; 8589 8590 begin 8591 -- For a derived type, we can't go past the base type (to the 8592 -- parent type) here, because that would cause the attribute's 8593 -- formal parameter to have the wrong type; hence the Base_Type 8594 -- check here. 8595 8596 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then 8597 Build_From_Any_Function 8598 (Loc => Loc, 8599 Typ => Etype (Typ), 8600 Decl => Decl, 8601 Fnam => Fnam); 8602 return; 8603 end if; 8604 8605 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any); 8606 8607 Spec := 8608 Make_Function_Specification (Loc, 8609 Defining_Unit_Name => Fnam, 8610 Parameter_Specifications => New_List ( 8611 Make_Parameter_Specification (Loc, 8612 Defining_Identifier => Any_Parameter, 8613 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))), 8614 Result_Definition => New_Occurrence_Of (Typ, Loc)); 8615 8616 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any 8617 8618 pragma Assert 8619 (not (Is_Remote_Access_To_Class_Wide_Type (Typ))); 8620 8621 Use_Opaque_Representation := False; 8622 8623 if Has_Stream_Attribute_Definition 8624 (Typ, TSS_Stream_Output, At_Any_Place => True) 8625 or else 8626 Has_Stream_Attribute_Definition 8627 (Typ, TSS_Stream_Write, At_Any_Place => True) 8628 then 8629 -- If user-defined stream attributes are specified for this 8630 -- type, use them and transmit data as an opaque sequence of 8631 -- stream elements. 8632 8633 Use_Opaque_Representation := True; 8634 8635 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then 8636 Append_To (Stms, 8637 Make_Simple_Return_Statement (Loc, 8638 Expression => 8639 OK_Convert_To (Typ, 8640 Build_From_Any_Call 8641 (Root_Type (Typ), 8642 New_Occurrence_Of (Any_Parameter, Loc), 8643 Decls)))); 8644 8645 elsif Is_Record_Type (Typ) 8646 and then not Is_Derived_Type (Typ) 8647 and then not Is_Tagged_Type (Typ) 8648 then 8649 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then 8650 Append_To (Stms, 8651 Make_Simple_Return_Statement (Loc, 8652 Expression => 8653 Build_From_Any_Call 8654 (Etype (Typ), 8655 New_Occurrence_Of (Any_Parameter, Loc), 8656 Decls))); 8657 8658 else 8659 declare 8660 Disc : Entity_Id := Empty; 8661 Discriminant_Associations : List_Id; 8662 Rdef : constant Node_Id := 8663 Type_Definition 8664 (Declaration_Node (Typ)); 8665 Component_Counter : Int := 0; 8666 8667 -- The returned object 8668 8669 Res : constant Entity_Id := Make_Temporary (Loc, 'R'); 8670 8671 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc); 8672 8673 procedure FA_Rec_Add_Process_Element 8674 (Stmts : List_Id; 8675 Any : Entity_Id; 8676 Counter : in out Int; 8677 Rec : Entity_Id; 8678 Field : Node_Id); 8679 8680 procedure FA_Append_Record_Traversal is 8681 new Append_Record_Traversal 8682 (Rec => Res, 8683 Add_Process_Element => FA_Rec_Add_Process_Element); 8684 8685 -------------------------------- 8686 -- FA_Rec_Add_Process_Element -- 8687 -------------------------------- 8688 8689 procedure FA_Rec_Add_Process_Element 8690 (Stmts : List_Id; 8691 Any : Entity_Id; 8692 Counter : in out Int; 8693 Rec : Entity_Id; 8694 Field : Node_Id) 8695 is 8696 Ctyp : Entity_Id; 8697 begin 8698 if Nkind (Field) = N_Defining_Identifier then 8699 -- A regular component 8700 8701 Ctyp := Etype (Field); 8702 8703 Append_To (Stmts, 8704 Make_Assignment_Statement (Loc, 8705 Name => Make_Selected_Component (Loc, 8706 Prefix => 8707 New_Occurrence_Of (Rec, Loc), 8708 Selector_Name => 8709 New_Occurrence_Of (Field, Loc)), 8710 8711 Expression => 8712 Build_From_Any_Call (Ctyp, 8713 Build_Get_Aggregate_Element (Loc, 8714 Any => Any, 8715 TC => 8716 Build_TypeCode_Call (Loc, Ctyp, Decls), 8717 Idx => 8718 Make_Integer_Literal (Loc, Counter)), 8719 Decls))); 8720 8721 else 8722 -- A variant part 8723 8724 declare 8725 Variant : Node_Id; 8726 Struct_Counter : Int := 0; 8727 8728 Block_Decls : constant List_Id := New_List; 8729 Block_Stmts : constant List_Id := New_List; 8730 VP_Stmts : List_Id; 8731 8732 Alt_List : constant List_Id := New_List; 8733 Choice_List : List_Id; 8734 8735 Struct_Any : constant Entity_Id := 8736 Make_Temporary (Loc, 'S'); 8737 8738 begin 8739 Append_To (Decls, 8740 Make_Object_Declaration (Loc, 8741 Defining_Identifier => Struct_Any, 8742 Constant_Present => True, 8743 Object_Definition => 8744 New_Occurrence_Of (RTE (RE_Any), Loc), 8745 Expression => 8746 Make_Function_Call (Loc, 8747 Name => 8748 New_Occurrence_Of 8749 (RTE (RE_Extract_Union_Value), Loc), 8750 8751 Parameter_Associations => New_List ( 8752 Build_Get_Aggregate_Element (Loc, 8753 Any => Any, 8754 TC => 8755 Make_Function_Call (Loc, 8756 Name => New_Occurrence_Of ( 8757 RTE (RE_Any_Member_Type), Loc), 8758 Parameter_Associations => 8759 New_List ( 8760 New_Occurrence_Of (Any, Loc), 8761 Make_Integer_Literal (Loc, 8762 Intval => Counter))), 8763 Idx => 8764 Make_Integer_Literal (Loc, 8765 Intval => Counter)))))); 8766 8767 Append_To (Stmts, 8768 Make_Block_Statement (Loc, 8769 Declarations => Block_Decls, 8770 Handled_Statement_Sequence => 8771 Make_Handled_Sequence_Of_Statements (Loc, 8772 Statements => Block_Stmts))); 8773 8774 Append_To (Block_Stmts, 8775 Make_Case_Statement (Loc, 8776 Expression => 8777 Make_Selected_Component (Loc, 8778 Prefix => Rec, 8779 Selector_Name => Chars (Name (Field))), 8780 Alternatives => Alt_List)); 8781 8782 Variant := First_Non_Pragma (Variants (Field)); 8783 while Present (Variant) loop 8784 Choice_List := 8785 New_Copy_List_Tree 8786 (Discrete_Choices (Variant)); 8787 8788 VP_Stmts := New_List; 8789 8790 -- Struct_Counter should be reset before 8791 -- handling a variant part. Indeed only one 8792 -- of the case statement alternatives will be 8793 -- executed at run time, so the counter must 8794 -- start at 0 for every case statement. 8795 8796 Struct_Counter := 0; 8797 8798 FA_Append_Record_Traversal ( 8799 Stmts => VP_Stmts, 8800 Clist => Component_List (Variant), 8801 Container => Struct_Any, 8802 Counter => Struct_Counter); 8803 8804 Append_To (Alt_List, 8805 Make_Case_Statement_Alternative (Loc, 8806 Discrete_Choices => Choice_List, 8807 Statements => VP_Stmts)); 8808 Next_Non_Pragma (Variant); 8809 end loop; 8810 end; 8811 end if; 8812 8813 Counter := Counter + 1; 8814 end FA_Rec_Add_Process_Element; 8815 8816 begin 8817 -- First all discriminants 8818 8819 if Has_Discriminants (Typ) then 8820 Discriminant_Associations := New_List; 8821 8822 Disc := First_Discriminant (Typ); 8823 while Present (Disc) loop 8824 declare 8825 Disc_Var_Name : constant Entity_Id := 8826 Make_Defining_Identifier (Loc, 8827 Chars => Chars (Disc)); 8828 Disc_Type : constant Entity_Id := 8829 Etype (Disc); 8830 8831 begin 8832 Append_To (Decls, 8833 Make_Object_Declaration (Loc, 8834 Defining_Identifier => Disc_Var_Name, 8835 Constant_Present => True, 8836 Object_Definition => 8837 New_Occurrence_Of (Disc_Type, Loc), 8838 8839 Expression => 8840 Build_From_Any_Call (Disc_Type, 8841 Build_Get_Aggregate_Element (Loc, 8842 Any => Any_Parameter, 8843 TC => Build_TypeCode_Call 8844 (Loc, Disc_Type, Decls), 8845 Idx => Make_Integer_Literal (Loc, 8846 Intval => Component_Counter)), 8847 Decls))); 8848 8849 Component_Counter := Component_Counter + 1; 8850 8851 Append_To (Discriminant_Associations, 8852 Make_Discriminant_Association (Loc, 8853 Selector_Names => New_List ( 8854 New_Occurrence_Of (Disc, Loc)), 8855 Expression => 8856 New_Occurrence_Of (Disc_Var_Name, Loc))); 8857 end; 8858 Next_Discriminant (Disc); 8859 end loop; 8860 8861 Res_Definition := 8862 Make_Subtype_Indication (Loc, 8863 Subtype_Mark => Res_Definition, 8864 Constraint => 8865 Make_Index_Or_Discriminant_Constraint (Loc, 8866 Discriminant_Associations)); 8867 end if; 8868 8869 -- Now we have all the discriminants in variables, we can 8870 -- declared a constrained object. Note that we are not 8871 -- initializing (non-discriminant) components directly in 8872 -- the object declarations, because which fields to 8873 -- initialize depends (at run time) on the discriminant 8874 -- values. 8875 8876 Append_To (Decls, 8877 Make_Object_Declaration (Loc, 8878 Defining_Identifier => Res, 8879 Object_Definition => Res_Definition)); 8880 8881 -- ... then all components 8882 8883 FA_Append_Record_Traversal (Stms, 8884 Clist => Component_List (Rdef), 8885 Container => Any_Parameter, 8886 Counter => Component_Counter); 8887 8888 Append_To (Stms, 8889 Make_Simple_Return_Statement (Loc, 8890 Expression => New_Occurrence_Of (Res, Loc))); 8891 end; 8892 end if; 8893 8894 elsif Is_Array_Type (Typ) then 8895 declare 8896 Constrained : constant Boolean := Is_Constrained (Typ); 8897 8898 procedure FA_Ary_Add_Process_Element 8899 (Stmts : List_Id; 8900 Any : Entity_Id; 8901 Counter : Entity_Id; 8902 Datum : Node_Id); 8903 -- Assign the current element (as identified by Counter) of 8904 -- Any to the variable denoted by name Datum, and advance 8905 -- Counter by 1. If Datum is not an Any, a call to From_Any 8906 -- for its type is inserted. 8907 8908 -------------------------------- 8909 -- FA_Ary_Add_Process_Element -- 8910 -------------------------------- 8911 8912 procedure FA_Ary_Add_Process_Element 8913 (Stmts : List_Id; 8914 Any : Entity_Id; 8915 Counter : Entity_Id; 8916 Datum : Node_Id) 8917 is 8918 Assignment : constant Node_Id := 8919 Make_Assignment_Statement (Loc, 8920 Name => Datum, 8921 Expression => Empty); 8922 8923 Element_Any : Node_Id; 8924 8925 begin 8926 declare 8927 Element_TC : Node_Id; 8928 8929 begin 8930 if Etype (Datum) = RTE (RE_Any) then 8931 8932 -- When Datum is an Any the Etype field is not 8933 -- sufficient to determine the typecode of Datum 8934 -- (which can be a TC_SEQUENCE or TC_ARRAY 8935 -- depending on the value of Constrained). 8936 8937 -- Therefore we retrieve the typecode which has 8938 -- been constructed in Append_Array_Traversal with 8939 -- a call to Get_Any_Type. 8940 8941 Element_TC := 8942 Make_Function_Call (Loc, 8943 Name => New_Occurrence_Of ( 8944 RTE (RE_Get_Any_Type), Loc), 8945 Parameter_Associations => New_List ( 8946 New_Occurrence_Of (Entity (Datum), Loc))); 8947 else 8948 -- For non Any Datum we simply construct a typecode 8949 -- matching the Etype of the Datum. 8950 8951 Element_TC := Build_TypeCode_Call 8952 (Loc, Etype (Datum), Decls); 8953 end if; 8954 8955 Element_Any := 8956 Build_Get_Aggregate_Element (Loc, 8957 Any => Any, 8958 TC => Element_TC, 8959 Idx => New_Occurrence_Of (Counter, Loc)); 8960 end; 8961 8962 -- Note: here we *prepend* statements to Stmts, so 8963 -- we must do it in reverse order. 8964 8965 Prepend_To (Stmts, 8966 Make_Assignment_Statement (Loc, 8967 Name => 8968 New_Occurrence_Of (Counter, Loc), 8969 Expression => 8970 Make_Op_Add (Loc, 8971 Left_Opnd => New_Occurrence_Of (Counter, Loc), 8972 Right_Opnd => Make_Integer_Literal (Loc, 1)))); 8973 8974 if Nkind (Datum) /= N_Attribute_Reference then 8975 8976 -- We ignore the value of the length of each 8977 -- dimension, since the target array has already been 8978 -- constrained anyway. 8979 8980 if Etype (Datum) /= RTE (RE_Any) then 8981 Set_Expression (Assignment, 8982 Build_From_Any_Call 8983 (Component_Type (Typ), Element_Any, Decls)); 8984 else 8985 Set_Expression (Assignment, Element_Any); 8986 end if; 8987 8988 Prepend_To (Stmts, Assignment); 8989 end if; 8990 end FA_Ary_Add_Process_Element; 8991 8992 ------------------------ 8993 -- Local Declarations -- 8994 ------------------------ 8995 8996 Counter : constant Entity_Id := 8997 Make_Defining_Identifier (Loc, Name_J); 8998 8999 Initial_Counter_Value : Int := 0; 9000 9001 Component_TC : constant Entity_Id := 9002 Make_Defining_Identifier (Loc, Name_T); 9003 9004 Res : constant Entity_Id := 9005 Make_Defining_Identifier (Loc, Name_R); 9006 9007 procedure Append_From_Any_Array_Iterator is 9008 new Append_Array_Traversal ( 9009 Subprogram => Fnam, 9010 Arry => Res, 9011 Indexes => New_List, 9012 Add_Process_Element => FA_Ary_Add_Process_Element); 9013 9014 Res_Subtype_Indication : Node_Id := 9015 New_Occurrence_Of (Typ, Loc); 9016 9017 begin 9018 if not Constrained then 9019 declare 9020 Ndim : constant Int := Number_Dimensions (Typ); 9021 Lnam : Name_Id; 9022 Hnam : Name_Id; 9023 Indx : Node_Id := First_Index (Typ); 9024 Indt : Entity_Id; 9025 9026 Ranges : constant List_Id := New_List; 9027 9028 begin 9029 for J in 1 .. Ndim loop 9030 Lnam := New_External_Name ('L', J); 9031 Hnam := New_External_Name ('H', J); 9032 9033 -- Note, for empty arrays bounds may be out of 9034 -- the range of Etype (Indx). 9035 9036 Indt := Base_Type (Etype (Indx)); 9037 9038 Append_To (Decls, 9039 Make_Object_Declaration (Loc, 9040 Defining_Identifier => 9041 Make_Defining_Identifier (Loc, Lnam), 9042 Constant_Present => True, 9043 Object_Definition => 9044 New_Occurrence_Of (Indt, Loc), 9045 Expression => 9046 Build_From_Any_Call 9047 (Indt, 9048 Build_Get_Aggregate_Element (Loc, 9049 Any => Any_Parameter, 9050 TC => Build_TypeCode_Call 9051 (Loc, Indt, Decls), 9052 Idx => 9053 Make_Integer_Literal (Loc, J - 1)), 9054 Decls))); 9055 9056 Append_To (Decls, 9057 Make_Object_Declaration (Loc, 9058 Defining_Identifier => 9059 Make_Defining_Identifier (Loc, Hnam), 9060 9061 Constant_Present => True, 9062 9063 Object_Definition => 9064 New_Occurrence_Of (Indt, Loc), 9065 9066 Expression => Make_Attribute_Reference (Loc, 9067 Prefix => 9068 New_Occurrence_Of (Indt, Loc), 9069 9070 Attribute_Name => Name_Val, 9071 9072 Expressions => New_List ( 9073 Make_Op_Subtract (Loc, 9074 Left_Opnd => 9075 Make_Op_Add (Loc, 9076 Left_Opnd => 9077 OK_Convert_To 9078 (Standard_Long_Integer, 9079 Make_Identifier (Loc, Lnam)), 9080 9081 Right_Opnd => 9082 OK_Convert_To 9083 (Standard_Long_Integer, 9084 Make_Function_Call (Loc, 9085 Name => 9086 New_Occurrence_Of (RTE ( 9087 RE_Get_Nested_Sequence_Length 9088 ), Loc), 9089 Parameter_Associations => 9090 New_List ( 9091 New_Occurrence_Of ( 9092 Any_Parameter, Loc), 9093 Make_Integer_Literal (Loc, 9094 Intval => J))))), 9095 9096 Right_Opnd => 9097 Make_Integer_Literal (Loc, 1)))))); 9098 9099 Append_To (Ranges, 9100 Make_Range (Loc, 9101 Low_Bound => Make_Identifier (Loc, Lnam), 9102 High_Bound => Make_Identifier (Loc, Hnam))); 9103 9104 Next_Index (Indx); 9105 end loop; 9106 9107 -- Now we have all the necessary bound information: 9108 -- apply the set of range constraints to the 9109 -- (unconstrained) nominal subtype of Res. 9110 9111 Initial_Counter_Value := Ndim; 9112 Res_Subtype_Indication := Make_Subtype_Indication (Loc, 9113 Subtype_Mark => Res_Subtype_Indication, 9114 Constraint => 9115 Make_Index_Or_Discriminant_Constraint (Loc, 9116 Constraints => Ranges)); 9117 end; 9118 end if; 9119 9120 Append_To (Decls, 9121 Make_Object_Declaration (Loc, 9122 Defining_Identifier => Res, 9123 Object_Definition => Res_Subtype_Indication)); 9124 Set_Etype (Res, Typ); 9125 9126 Append_To (Decls, 9127 Make_Object_Declaration (Loc, 9128 Defining_Identifier => Counter, 9129 Object_Definition => 9130 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc), 9131 Expression => 9132 Make_Integer_Literal (Loc, Initial_Counter_Value))); 9133 9134 Append_To (Decls, 9135 Make_Object_Declaration (Loc, 9136 Defining_Identifier => Component_TC, 9137 Constant_Present => True, 9138 Object_Definition => 9139 New_Occurrence_Of (RTE (RE_TypeCode), Loc), 9140 Expression => 9141 Build_TypeCode_Call (Loc, 9142 Component_Type (Typ), Decls))); 9143 9144 Append_From_Any_Array_Iterator 9145 (Stms, Any_Parameter, Counter); 9146 9147 Append_To (Stms, 9148 Make_Simple_Return_Statement (Loc, 9149 Expression => New_Occurrence_Of (Res, Loc))); 9150 end; 9151 9152 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then 9153 Append_To (Stms, 9154 Make_Simple_Return_Statement (Loc, 9155 Expression => 9156 Unchecked_Convert_To (Typ, 9157 Build_From_Any_Call 9158 (Find_Numeric_Representation (Typ), 9159 New_Occurrence_Of (Any_Parameter, Loc), 9160 Decls)))); 9161 9162 else 9163 Use_Opaque_Representation := True; 9164 end if; 9165 9166 if Use_Opaque_Representation then 9167 Assign_Opaque_From_Any (Loc, 9168 Stms => Stms, 9169 Typ => Typ, 9170 N => New_Occurrence_Of (Any_Parameter, Loc), 9171 Target => Empty); 9172 end if; 9173 9174 Decl := 9175 Make_Subprogram_Body (Loc, 9176 Specification => Spec, 9177 Declarations => Decls, 9178 Handled_Statement_Sequence => 9179 Make_Handled_Sequence_Of_Statements (Loc, 9180 Statements => Stms)); 9181 end Build_From_Any_Function; 9182 9183 --------------------------------- 9184 -- Build_Get_Aggregate_Element -- 9185 --------------------------------- 9186 9187 function Build_Get_Aggregate_Element 9188 (Loc : Source_Ptr; 9189 Any : Entity_Id; 9190 TC : Node_Id; 9191 Idx : Node_Id) return Node_Id 9192 is 9193 begin 9194 return Make_Function_Call (Loc, 9195 Name => 9196 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc), 9197 Parameter_Associations => New_List ( 9198 New_Occurrence_Of (Any, Loc), 9199 TC, 9200 Idx)); 9201 end Build_Get_Aggregate_Element; 9202 9203 ------------------------- 9204 -- Build_Reposiroty_Id -- 9205 ------------------------- 9206 9207 procedure Build_Name_And_Repository_Id 9208 (E : Entity_Id; 9209 Name_Str : out String_Id; 9210 Repo_Id_Str : out String_Id) 9211 is 9212 begin 9213 Name_Str := Fully_Qualified_Name_String (E, Append_NUL => False); 9214 Start_String; 9215 Store_String_Chars ("DSA:"); 9216 Store_String_Chars (Name_Str); 9217 Store_String_Chars (":1.0"); 9218 Repo_Id_Str := End_String; 9219 end Build_Name_And_Repository_Id; 9220 9221 ----------------------- 9222 -- Build_To_Any_Call -- 9223 ----------------------- 9224 9225 function Build_To_Any_Call 9226 (Loc : Source_Ptr; 9227 N : Node_Id; 9228 Decls : List_Id) return Node_Id 9229 is 9230 Typ : Entity_Id := Etype (N); 9231 U_Type : Entity_Id; 9232 C_Type : Entity_Id; 9233 Fnam : Entity_Id := Empty; 9234 Lib_RE : RE_Id := RE_Null; 9235 9236 begin 9237 -- If N is a selected component, then maybe its Etype has not been 9238 -- set yet: try to use Etype of the selector_name in that case. 9239 9240 if No (Typ) and then Nkind (N) = N_Selected_Component then 9241 Typ := Etype (Selector_Name (N)); 9242 end if; 9243 9244 pragma Assert (Present (Typ)); 9245 9246 -- Get full view for private type, completion for incomplete type 9247 9248 U_Type := Underlying_Type (Typ); 9249 9250 -- First simple case where the To_Any function is present in the 9251 -- type's TSS. 9252 9253 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any); 9254 9255 -- For the subtype representing a generic actual type, go to the 9256 -- actual type. 9257 9258 if Is_Generic_Actual_Type (U_Type) then 9259 U_Type := Underlying_Type (Base_Type (U_Type)); 9260 end if; 9261 9262 -- For a standard subtype, go to the base type 9263 9264 if Sloc (U_Type) <= Standard_Location then 9265 U_Type := Base_Type (U_Type); 9266 9267 -- For a user subtype, go to first subtype 9268 9269 elsif Comes_From_Source (U_Type) 9270 and then Nkind (Declaration_Node (U_Type)) 9271 = N_Subtype_Declaration 9272 then 9273 U_Type := First_Subtype (U_Type); 9274 end if; 9275 9276 if Present (Fnam) then 9277 null; 9278 9279 -- Check first for Boolean and Character. These are enumeration 9280 -- types, but we treat them specially, since they may require 9281 -- special handling in the transfer protocol. However, this 9282 -- special handling only applies if they have standard 9283 -- representation, otherwise they are treated like any other 9284 -- enumeration type. 9285 9286 elsif U_Type = Standard_Boolean then 9287 Lib_RE := RE_TA_B; 9288 9289 elsif U_Type = Standard_Character then 9290 Lib_RE := RE_TA_C; 9291 9292 elsif U_Type = Standard_Wide_Character then 9293 Lib_RE := RE_TA_WC; 9294 9295 elsif U_Type = Standard_Wide_Wide_Character then 9296 Lib_RE := RE_TA_WWC; 9297 9298 -- Floating point types 9299 9300 elsif U_Type = Standard_Short_Float then 9301 Lib_RE := RE_TA_SF; 9302 9303 elsif U_Type = Standard_Float then 9304 Lib_RE := RE_TA_F; 9305 9306 elsif U_Type = Standard_Long_Float then 9307 Lib_RE := RE_TA_LF; 9308 9309 elsif U_Type = Standard_Long_Long_Float then 9310 Lib_RE := RE_TA_LLF; 9311 9312 -- Integer types 9313 9314 elsif U_Type = RTE (RE_Integer_8) then 9315 Lib_RE := RE_TA_I8; 9316 9317 elsif U_Type = RTE (RE_Integer_16) then 9318 Lib_RE := RE_TA_I16; 9319 9320 elsif U_Type = RTE (RE_Integer_32) then 9321 Lib_RE := RE_TA_I32; 9322 9323 elsif U_Type = RTE (RE_Integer_64) then 9324 Lib_RE := RE_TA_I64; 9325 9326 -- Unsigned integer types 9327 9328 elsif U_Type = RTE (RE_Unsigned_8) then 9329 Lib_RE := RE_TA_U8; 9330 9331 elsif U_Type = RTE (RE_Unsigned_16) then 9332 Lib_RE := RE_TA_U16; 9333 9334 elsif U_Type = RTE (RE_Unsigned_32) then 9335 Lib_RE := RE_TA_U32; 9336 9337 elsif U_Type = RTE (RE_Unsigned_64) then 9338 Lib_RE := RE_TA_U64; 9339 9340 elsif Is_RTE (U_Type, RE_Unbounded_String) then 9341 Lib_RE := RE_TA_String; 9342 9343 -- Special DSA types 9344 9345 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then 9346 Lib_RE := RE_TA_A; 9347 U_Type := Typ; 9348 9349 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then 9350 9351 -- No corresponding FA_TC ??? 9352 9353 Lib_RE := RE_TA_TC; 9354 9355 -- Other (non-primitive) types 9356 9357 else 9358 declare 9359 Decl : Entity_Id; 9360 begin 9361 Build_To_Any_Function (Loc, U_Type, Decl, Fnam); 9362 Append_To (Decls, Decl); 9363 end; 9364 end if; 9365 9366 -- Call the function 9367 9368 if Lib_RE /= RE_Null then 9369 pragma Assert (No (Fnam)); 9370 Fnam := RTE (Lib_RE); 9371 end if; 9372 9373 -- If Fnam is already analyzed, find the proper expected type, 9374 -- else we have a newly constructed To_Any function and we know 9375 -- that the expected type of its parameter is U_Type. 9376 9377 if Ekind (Fnam) = E_Function 9378 and then Present (First_Formal (Fnam)) 9379 then 9380 C_Type := Etype (First_Formal (Fnam)); 9381 else 9382 C_Type := U_Type; 9383 end if; 9384 9385 return 9386 Make_Function_Call (Loc, 9387 Name => New_Occurrence_Of (Fnam, Loc), 9388 Parameter_Associations => 9389 New_List (OK_Convert_To (C_Type, N))); 9390 end Build_To_Any_Call; 9391 9392 --------------------------- 9393 -- Build_To_Any_Function -- 9394 --------------------------- 9395 9396 procedure Build_To_Any_Function 9397 (Loc : Source_Ptr; 9398 Typ : Entity_Id; 9399 Decl : out Node_Id; 9400 Fnam : out Entity_Id) 9401 is 9402 Spec : Node_Id; 9403 Decls : constant List_Id := New_List; 9404 Stms : constant List_Id := New_List; 9405 9406 Expr_Parameter : Entity_Id; 9407 Any : Entity_Id; 9408 Result_TC : Node_Id; 9409 9410 Any_Decl : Node_Id; 9411 9412 Use_Opaque_Representation : Boolean; 9413 -- When True, use stream attributes and represent type as an 9414 -- opaque sequence of bytes. 9415 9416 begin 9417 -- For a derived type, we can't go past the base type (to the 9418 -- parent type) here, because that would cause the attribute's 9419 -- formal parameter to have the wrong type; hence the Base_Type 9420 -- check here. 9421 9422 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then 9423 Build_To_Any_Function 9424 (Loc => Loc, 9425 Typ => Etype (Typ), 9426 Decl => Decl, 9427 Fnam => Fnam); 9428 return; 9429 end if; 9430 9431 Expr_Parameter := Make_Defining_Identifier (Loc, Name_E); 9432 Any := Make_Defining_Identifier (Loc, Name_A); 9433 Result_TC := Build_TypeCode_Call (Loc, Typ, Decls); 9434 9435 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any); 9436 9437 Spec := 9438 Make_Function_Specification (Loc, 9439 Defining_Unit_Name => Fnam, 9440 Parameter_Specifications => New_List ( 9441 Make_Parameter_Specification (Loc, 9442 Defining_Identifier => Expr_Parameter, 9443 Parameter_Type => New_Occurrence_Of (Typ, Loc))), 9444 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); 9445 Set_Etype (Expr_Parameter, Typ); 9446 9447 Any_Decl := 9448 Make_Object_Declaration (Loc, 9449 Defining_Identifier => Any, 9450 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); 9451 9452 Use_Opaque_Representation := False; 9453 9454 if Has_Stream_Attribute_Definition 9455 (Typ, TSS_Stream_Output, At_Any_Place => True) 9456 or else 9457 Has_Stream_Attribute_Definition 9458 (Typ, TSS_Stream_Write, At_Any_Place => True) 9459 then 9460 -- If user-defined stream attributes are specified for this 9461 -- type, use them and transmit data as an opaque sequence of 9462 -- stream elements. 9463 9464 Use_Opaque_Representation := True; 9465 9466 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then 9467 9468 -- Non-tagged derived type: convert to root type 9469 9470 declare 9471 Rt_Type : constant Entity_Id := Root_Type (Typ); 9472 Expr : constant Node_Id := 9473 OK_Convert_To 9474 (Rt_Type, 9475 New_Occurrence_Of (Expr_Parameter, Loc)); 9476 begin 9477 Set_Expression (Any_Decl, 9478 Build_To_Any_Call (Loc, Expr, Decls)); 9479 end; 9480 9481 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then 9482 9483 -- Non-tagged record type 9484 9485 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then 9486 declare 9487 Rt_Type : constant Entity_Id := Etype (Typ); 9488 Expr : constant Node_Id := 9489 OK_Convert_To (Rt_Type, 9490 New_Occurrence_Of (Expr_Parameter, Loc)); 9491 9492 begin 9493 Set_Expression 9494 (Any_Decl, Build_To_Any_Call (Loc, Expr, Decls)); 9495 end; 9496 9497 -- Comment needed here (and label on declare block ???) 9498 9499 else 9500 declare 9501 Disc : Entity_Id := Empty; 9502 Rdef : constant Node_Id := 9503 Type_Definition (Declaration_Node (Typ)); 9504 Counter : Int := 0; 9505 Elements : constant List_Id := New_List; 9506 9507 procedure TA_Rec_Add_Process_Element 9508 (Stmts : List_Id; 9509 Container : Node_Or_Entity_Id; 9510 Counter : in out Int; 9511 Rec : Entity_Id; 9512 Field : Node_Id); 9513 -- Processing routine for traversal below 9514 9515 procedure TA_Append_Record_Traversal is 9516 new Append_Record_Traversal 9517 (Rec => Expr_Parameter, 9518 Add_Process_Element => TA_Rec_Add_Process_Element); 9519 9520 -------------------------------- 9521 -- TA_Rec_Add_Process_Element -- 9522 -------------------------------- 9523 9524 procedure TA_Rec_Add_Process_Element 9525 (Stmts : List_Id; 9526 Container : Node_Or_Entity_Id; 9527 Counter : in out Int; 9528 Rec : Entity_Id; 9529 Field : Node_Id) 9530 is 9531 Field_Ref : Node_Id; 9532 9533 begin 9534 if Nkind (Field) = N_Defining_Identifier then 9535 9536 -- A regular component 9537 9538 Field_Ref := Make_Selected_Component (Loc, 9539 Prefix => New_Occurrence_Of (Rec, Loc), 9540 Selector_Name => New_Occurrence_Of (Field, Loc)); 9541 Set_Etype (Field_Ref, Etype (Field)); 9542 9543 Append_To (Stmts, 9544 Make_Procedure_Call_Statement (Loc, 9545 Name => 9546 New_Occurrence_Of ( 9547 RTE (RE_Add_Aggregate_Element), Loc), 9548 Parameter_Associations => New_List ( 9549 New_Occurrence_Of (Container, Loc), 9550 Build_To_Any_Call (Loc, Field_Ref, Decls)))); 9551 9552 else 9553 -- A variant part 9554 9555 Variant_Part : declare 9556 Variant : Node_Id; 9557 Struct_Counter : Int := 0; 9558 9559 Block_Decls : constant List_Id := New_List; 9560 Block_Stmts : constant List_Id := New_List; 9561 VP_Stmts : List_Id; 9562 9563 Alt_List : constant List_Id := New_List; 9564 Choice_List : List_Id; 9565 9566 Union_Any : constant Entity_Id := 9567 Make_Temporary (Loc, 'V'); 9568 9569 Struct_Any : constant Entity_Id := 9570 Make_Temporary (Loc, 'S'); 9571 9572 function Make_Discriminant_Reference 9573 return Node_Id; 9574 -- Build reference to the discriminant for this 9575 -- variant part. 9576 9577 --------------------------------- 9578 -- Make_Discriminant_Reference -- 9579 --------------------------------- 9580 9581 function Make_Discriminant_Reference 9582 return Node_Id 9583 is 9584 Nod : constant Node_Id := 9585 Make_Selected_Component (Loc, 9586 Prefix => Rec, 9587 Selector_Name => 9588 Chars (Name (Field))); 9589 begin 9590 Set_Etype (Nod, Etype (Name (Field))); 9591 return Nod; 9592 end Make_Discriminant_Reference; 9593 9594 -- Start of processing for Variant_Part 9595 9596 begin 9597 Append_To (Stmts, 9598 Make_Block_Statement (Loc, 9599 Declarations => 9600 Block_Decls, 9601 Handled_Statement_Sequence => 9602 Make_Handled_Sequence_Of_Statements (Loc, 9603 Statements => Block_Stmts))); 9604 9605 -- Declare variant part aggregate (Union_Any). 9606 -- Knowing the position of this VP in the 9607 -- variant record, we can fetch the VP typecode 9608 -- from Container. 9609 9610 Append_To (Block_Decls, 9611 Make_Object_Declaration (Loc, 9612 Defining_Identifier => Union_Any, 9613 Object_Definition => 9614 New_Occurrence_Of (RTE (RE_Any), Loc), 9615 Expression => 9616 Make_Function_Call (Loc, 9617 Name => New_Occurrence_Of ( 9618 RTE (RE_Create_Any), Loc), 9619 Parameter_Associations => New_List ( 9620 Make_Function_Call (Loc, 9621 Name => 9622 New_Occurrence_Of ( 9623 RTE (RE_Any_Member_Type), Loc), 9624 Parameter_Associations => New_List ( 9625 New_Occurrence_Of (Container, Loc), 9626 Make_Integer_Literal (Loc, 9627 Counter))))))); 9628 9629 -- Declare inner struct aggregate (which 9630 -- contains the components of this VP). 9631 9632 Append_To (Block_Decls, 9633 Make_Object_Declaration (Loc, 9634 Defining_Identifier => Struct_Any, 9635 Object_Definition => 9636 New_Occurrence_Of (RTE (RE_Any), Loc), 9637 Expression => 9638 Make_Function_Call (Loc, 9639 Name => New_Occurrence_Of ( 9640 RTE (RE_Create_Any), Loc), 9641 Parameter_Associations => New_List ( 9642 Make_Function_Call (Loc, 9643 Name => 9644 New_Occurrence_Of ( 9645 RTE (RE_Any_Member_Type), Loc), 9646 Parameter_Associations => New_List ( 9647 New_Occurrence_Of (Union_Any, Loc), 9648 Make_Integer_Literal (Loc, 9649 Uint_1))))))); 9650 9651 -- Build case statement 9652 9653 Append_To (Block_Stmts, 9654 Make_Case_Statement (Loc, 9655 Expression => Make_Discriminant_Reference, 9656 Alternatives => Alt_List)); 9657 9658 Variant := First_Non_Pragma (Variants (Field)); 9659 while Present (Variant) loop 9660 Choice_List := New_Copy_List_Tree 9661 (Discrete_Choices (Variant)); 9662 9663 VP_Stmts := New_List; 9664 9665 -- Append discriminant val to union aggregate 9666 9667 Append_To (VP_Stmts, 9668 Make_Procedure_Call_Statement (Loc, 9669 Name => 9670 New_Occurrence_Of ( 9671 RTE (RE_Add_Aggregate_Element), Loc), 9672 Parameter_Associations => New_List ( 9673 New_Occurrence_Of (Union_Any, Loc), 9674 Build_To_Any_Call 9675 (Loc, 9676 Make_Discriminant_Reference, 9677 Block_Decls)))); 9678 9679 -- Populate inner struct aggregate 9680 9681 -- Struct_Counter should be reset before 9682 -- handling a variant part. Indeed only one 9683 -- of the case statement alternatives will be 9684 -- executed at run time, so the counter must 9685 -- start at 0 for every case statement. 9686 9687 Struct_Counter := 0; 9688 9689 TA_Append_Record_Traversal 9690 (Stmts => VP_Stmts, 9691 Clist => Component_List (Variant), 9692 Container => Struct_Any, 9693 Counter => Struct_Counter); 9694 9695 -- Append inner struct to union aggregate 9696 9697 Append_To (VP_Stmts, 9698 Make_Procedure_Call_Statement (Loc, 9699 Name => 9700 New_Occurrence_Of 9701 (RTE (RE_Add_Aggregate_Element), Loc), 9702 Parameter_Associations => New_List ( 9703 New_Occurrence_Of (Union_Any, Loc), 9704 New_Occurrence_Of (Struct_Any, Loc)))); 9705 9706 -- Append union to outer aggregate 9707 9708 Append_To (VP_Stmts, 9709 Make_Procedure_Call_Statement (Loc, 9710 Name => 9711 New_Occurrence_Of 9712 (RTE (RE_Add_Aggregate_Element), Loc), 9713 Parameter_Associations => New_List ( 9714 New_Occurrence_Of (Container, Loc), 9715 New_Occurrence_Of 9716 (Union_Any, Loc)))); 9717 9718 Append_To (Alt_List, 9719 Make_Case_Statement_Alternative (Loc, 9720 Discrete_Choices => Choice_List, 9721 Statements => VP_Stmts)); 9722 9723 Next_Non_Pragma (Variant); 9724 end loop; 9725 end Variant_Part; 9726 end if; 9727 9728 Counter := Counter + 1; 9729 end TA_Rec_Add_Process_Element; 9730 9731 begin 9732 -- Records are encoded in a TC_STRUCT aggregate: 9733 9734 -- -- Outer aggregate (TC_STRUCT) 9735 -- | [discriminant1] 9736 -- | [discriminant2] 9737 -- | ... 9738 -- | 9739 -- | [component1] 9740 -- | [component2] 9741 -- | ... 9742 9743 -- A component can be a common component or variant part 9744 9745 -- A variant part is encoded as a TC_UNION aggregate: 9746 9747 -- -- Variant Part Aggregate (TC_UNION) 9748 -- | [discriminant choice for this Variant Part] 9749 -- | 9750 -- | -- Inner struct (TC_STRUCT) 9751 -- | | [component1] 9752 -- | | [component2] 9753 -- | | ... 9754 9755 -- Let's start by building the outer aggregate. First we 9756 -- construct Elements array containing all discriminants. 9757 9758 if Has_Discriminants (Typ) then 9759 Disc := First_Discriminant (Typ); 9760 while Present (Disc) loop 9761 declare 9762 Discriminant : constant Entity_Id := 9763 Make_Selected_Component (Loc, 9764 Prefix => 9765 Expr_Parameter, 9766 Selector_Name => 9767 Chars (Disc)); 9768 9769 begin 9770 Set_Etype (Discriminant, Etype (Disc)); 9771 9772 Append_To (Elements, 9773 Make_Component_Association (Loc, 9774 Choices => New_List ( 9775 Make_Integer_Literal (Loc, Counter)), 9776 Expression => 9777 Build_To_Any_Call (Loc, 9778 Discriminant, Decls))); 9779 end; 9780 9781 Counter := Counter + 1; 9782 Next_Discriminant (Disc); 9783 end loop; 9784 9785 else 9786 -- If there are no discriminants, we declare an empty 9787 -- Elements array. 9788 9789 declare 9790 Dummy_Any : constant Entity_Id := 9791 Make_Temporary (Loc, 'A'); 9792 9793 begin 9794 Append_To (Decls, 9795 Make_Object_Declaration (Loc, 9796 Defining_Identifier => Dummy_Any, 9797 Object_Definition => 9798 New_Occurrence_Of (RTE (RE_Any), Loc))); 9799 9800 Append_To (Elements, 9801 Make_Component_Association (Loc, 9802 Choices => New_List ( 9803 Make_Range (Loc, 9804 Low_Bound => 9805 Make_Integer_Literal (Loc, 1), 9806 High_Bound => 9807 Make_Integer_Literal (Loc, 0))), 9808 Expression => 9809 New_Occurrence_Of (Dummy_Any, Loc))); 9810 end; 9811 end if; 9812 9813 -- We build the result aggregate with discriminants 9814 -- as the first elements. 9815 9816 Set_Expression (Any_Decl, 9817 Make_Function_Call (Loc, 9818 Name => New_Occurrence_Of 9819 (RTE (RE_Any_Aggregate_Build), Loc), 9820 Parameter_Associations => New_List ( 9821 Result_TC, 9822 Make_Aggregate (Loc, 9823 Component_Associations => Elements)))); 9824 Result_TC := Empty; 9825 9826 -- Then we append all the components to the result 9827 -- aggregate. 9828 9829 TA_Append_Record_Traversal (Stms, 9830 Clist => Component_List (Rdef), 9831 Container => Any, 9832 Counter => Counter); 9833 end; 9834 end if; 9835 9836 elsif Is_Array_Type (Typ) then 9837 9838 -- Constrained and unconstrained array types 9839 9840 declare 9841 Constrained : constant Boolean := 9842 not Transmit_As_Unconstrained (Typ); 9843 9844 procedure TA_Ary_Add_Process_Element 9845 (Stmts : List_Id; 9846 Any : Entity_Id; 9847 Counter : Entity_Id; 9848 Datum : Node_Id); 9849 9850 -------------------------------- 9851 -- TA_Ary_Add_Process_Element -- 9852 -------------------------------- 9853 9854 procedure TA_Ary_Add_Process_Element 9855 (Stmts : List_Id; 9856 Any : Entity_Id; 9857 Counter : Entity_Id; 9858 Datum : Node_Id) 9859 is 9860 pragma Unreferenced (Counter); 9861 9862 Element_Any : Node_Id; 9863 9864 begin 9865 if Etype (Datum) = RTE (RE_Any) then 9866 Element_Any := Datum; 9867 else 9868 Element_Any := Build_To_Any_Call (Loc, Datum, Decls); 9869 end if; 9870 9871 Append_To (Stmts, 9872 Make_Procedure_Call_Statement (Loc, 9873 Name => New_Occurrence_Of ( 9874 RTE (RE_Add_Aggregate_Element), Loc), 9875 Parameter_Associations => New_List ( 9876 New_Occurrence_Of (Any, Loc), 9877 Element_Any))); 9878 end TA_Ary_Add_Process_Element; 9879 9880 procedure Append_To_Any_Array_Iterator is 9881 new Append_Array_Traversal ( 9882 Subprogram => Fnam, 9883 Arry => Expr_Parameter, 9884 Indexes => New_List, 9885 Add_Process_Element => TA_Ary_Add_Process_Element); 9886 9887 Index : Node_Id; 9888 9889 begin 9890 Set_Expression (Any_Decl, 9891 Make_Function_Call (Loc, 9892 Name => 9893 New_Occurrence_Of (RTE (RE_Create_Any), Loc), 9894 Parameter_Associations => New_List (Result_TC))); 9895 Result_TC := Empty; 9896 9897 if not Constrained then 9898 Index := First_Index (Typ); 9899 for J in 1 .. Number_Dimensions (Typ) loop 9900 Append_To (Stms, 9901 Make_Procedure_Call_Statement (Loc, 9902 Name => 9903 New_Occurrence_Of 9904 (RTE (RE_Add_Aggregate_Element), Loc), 9905 Parameter_Associations => New_List ( 9906 New_Occurrence_Of (Any, Loc), 9907 Build_To_Any_Call (Loc, 9908 OK_Convert_To (Etype (Index), 9909 Make_Attribute_Reference (Loc, 9910 Prefix => 9911 New_Occurrence_Of (Expr_Parameter, Loc), 9912 Attribute_Name => Name_First, 9913 Expressions => New_List ( 9914 Make_Integer_Literal (Loc, J)))), 9915 Decls)))); 9916 Next_Index (Index); 9917 end loop; 9918 end if; 9919 9920 Append_To_Any_Array_Iterator (Stms, Any); 9921 end; 9922 9923 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then 9924 9925 -- Integer types 9926 9927 Set_Expression (Any_Decl, 9928 Build_To_Any_Call (Loc, 9929 OK_Convert_To ( 9930 Find_Numeric_Representation (Typ), 9931 New_Occurrence_Of (Expr_Parameter, Loc)), 9932 Decls)); 9933 9934 else 9935 -- Default case, including tagged types: opaque representation 9936 9937 Use_Opaque_Representation := True; 9938 end if; 9939 9940 if Use_Opaque_Representation then 9941 declare 9942 Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); 9943 -- Stream used to store data representation produced by 9944 -- stream attribute. 9945 9946 begin 9947 -- Generate: 9948 -- Strm : aliased Buffer_Stream_Type; 9949 9950 Append_To (Decls, 9951 Make_Object_Declaration (Loc, 9952 Defining_Identifier => Strm, 9953 Aliased_Present => True, 9954 Object_Definition => 9955 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); 9956 9957 -- Generate: 9958 -- T'Output (Strm'Access, E); 9959 -- or 9960 -- T'Write (Strm'Access, E); 9961 -- depending on whether to transmit as unconstrained 9962 9963 declare 9964 Attr_Name : Name_Id; 9965 9966 begin 9967 if Transmit_As_Unconstrained (Typ) then 9968 Attr_Name := Name_Output; 9969 else 9970 Attr_Name := Name_Write; 9971 end if; 9972 9973 Append_To (Stms, 9974 Make_Attribute_Reference (Loc, 9975 Prefix => New_Occurrence_Of (Typ, Loc), 9976 Attribute_Name => Attr_Name, 9977 Expressions => New_List ( 9978 Make_Attribute_Reference (Loc, 9979 Prefix => New_Occurrence_Of (Strm, Loc), 9980 Attribute_Name => Name_Access), 9981 New_Occurrence_Of (Expr_Parameter, Loc)))); 9982 end; 9983 9984 -- Generate: 9985 -- BS_To_Any (Strm, A); 9986 9987 Append_To (Stms, 9988 Make_Procedure_Call_Statement (Loc, 9989 Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc), 9990 Parameter_Associations => New_List ( 9991 New_Occurrence_Of (Strm, Loc), 9992 New_Occurrence_Of (Any, Loc)))); 9993 9994 -- Generate: 9995 -- Release_Buffer (Strm); 9996 9997 Append_To (Stms, 9998 Make_Procedure_Call_Statement (Loc, 9999 Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), 10000 Parameter_Associations => New_List ( 10001 New_Occurrence_Of (Strm, Loc)))); 10002 end; 10003 end if; 10004 10005 Append_To (Decls, Any_Decl); 10006 10007 if Present (Result_TC) then 10008 Append_To (Stms, 10009 Make_Procedure_Call_Statement (Loc, 10010 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), 10011 Parameter_Associations => New_List ( 10012 New_Occurrence_Of (Any, Loc), 10013 Result_TC))); 10014 end if; 10015 10016 Append_To (Stms, 10017 Make_Simple_Return_Statement (Loc, 10018 Expression => New_Occurrence_Of (Any, Loc))); 10019 10020 Decl := 10021 Make_Subprogram_Body (Loc, 10022 Specification => Spec, 10023 Declarations => Decls, 10024 Handled_Statement_Sequence => 10025 Make_Handled_Sequence_Of_Statements (Loc, 10026 Statements => Stms)); 10027 end Build_To_Any_Function; 10028 10029 ------------------------- 10030 -- Build_TypeCode_Call -- 10031 ------------------------- 10032 10033 function Build_TypeCode_Call 10034 (Loc : Source_Ptr; 10035 Typ : Entity_Id; 10036 Decls : List_Id) return Node_Id 10037 is 10038 U_Type : Entity_Id := Underlying_Type (Typ); 10039 -- The full view, if Typ is private; the completion, 10040 -- if Typ is incomplete. 10041 10042 Fnam : Entity_Id := Empty; 10043 Lib_RE : RE_Id := RE_Null; 10044 Expr : Node_Id; 10045 10046 begin 10047 -- Special case System.PolyORB.Interface.Any: its primitives have 10048 -- not been set yet, so can't call Find_Inherited_TSS. 10049 10050 if Typ = RTE (RE_Any) then 10051 Fnam := RTE (RE_TC_A); 10052 10053 else 10054 -- First simple case where the TypeCode is present 10055 -- in the type's TSS. 10056 10057 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode); 10058 end if; 10059 10060 -- For the subtype representing a generic actual type, go to the 10061 -- actual type. 10062 10063 if Is_Generic_Actual_Type (U_Type) then 10064 U_Type := Underlying_Type (Base_Type (U_Type)); 10065 end if; 10066 10067 -- For a standard subtype, go to the base type 10068 10069 if Sloc (U_Type) <= Standard_Location then 10070 U_Type := Base_Type (U_Type); 10071 10072 -- For a user subtype, go to first subtype 10073 10074 elsif Comes_From_Source (U_Type) 10075 and then Nkind (Declaration_Node (U_Type)) 10076 = N_Subtype_Declaration 10077 then 10078 U_Type := First_Subtype (U_Type); 10079 end if; 10080 10081 if No (Fnam) then 10082 if U_Type = Standard_Boolean then 10083 Lib_RE := RE_TC_B; 10084 10085 elsif U_Type = Standard_Character then 10086 Lib_RE := RE_TC_C; 10087 10088 elsif U_Type = Standard_Wide_Character then 10089 Lib_RE := RE_TC_WC; 10090 10091 elsif U_Type = Standard_Wide_Wide_Character then 10092 Lib_RE := RE_TC_WWC; 10093 10094 -- Floating point types 10095 10096 elsif U_Type = Standard_Short_Float then 10097 Lib_RE := RE_TC_SF; 10098 10099 elsif U_Type = Standard_Float then 10100 Lib_RE := RE_TC_F; 10101 10102 elsif U_Type = Standard_Long_Float then 10103 Lib_RE := RE_TC_LF; 10104 10105 elsif U_Type = Standard_Long_Long_Float then 10106 Lib_RE := RE_TC_LLF; 10107 10108 -- Integer types (walk back to the base type) 10109 10110 elsif U_Type = RTE (RE_Integer_8) then 10111 Lib_RE := RE_TC_I8; 10112 10113 elsif U_Type = RTE (RE_Integer_16) then 10114 Lib_RE := RE_TC_I16; 10115 10116 elsif U_Type = RTE (RE_Integer_32) then 10117 Lib_RE := RE_TC_I32; 10118 10119 elsif U_Type = RTE (RE_Integer_64) then 10120 Lib_RE := RE_TC_I64; 10121 10122 -- Unsigned integer types 10123 10124 elsif U_Type = RTE (RE_Unsigned_8) then 10125 Lib_RE := RE_TC_U8; 10126 10127 elsif U_Type = RTE (RE_Unsigned_16) then 10128 Lib_RE := RE_TC_U16; 10129 10130 elsif U_Type = RTE (RE_Unsigned_32) then 10131 Lib_RE := RE_TC_U32; 10132 10133 elsif U_Type = RTE (RE_Unsigned_64) then 10134 Lib_RE := RE_TC_U64; 10135 10136 elsif Is_RTE (U_Type, RE_Unbounded_String) then 10137 Lib_RE := RE_TC_String; 10138 10139 -- Special DSA types 10140 10141 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then 10142 Lib_RE := RE_TC_A; 10143 10144 -- Other (non-primitive) types 10145 10146 else 10147 declare 10148 Decl : Entity_Id; 10149 begin 10150 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam); 10151 Append_To (Decls, Decl); 10152 end; 10153 end if; 10154 10155 if Lib_RE /= RE_Null then 10156 Fnam := RTE (Lib_RE); 10157 end if; 10158 end if; 10159 10160 -- Call the function 10161 10162 Expr := 10163 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc)); 10164 10165 -- Allow Expr to be used as arg to Build_To_Any_Call immediately 10166 10167 Set_Etype (Expr, RTE (RE_TypeCode)); 10168 10169 return Expr; 10170 end Build_TypeCode_Call; 10171 10172 ----------------------------- 10173 -- Build_TypeCode_Function -- 10174 ----------------------------- 10175 10176 procedure Build_TypeCode_Function 10177 (Loc : Source_Ptr; 10178 Typ : Entity_Id; 10179 Decl : out Node_Id; 10180 Fnam : out Entity_Id) 10181 is 10182 Spec : Node_Id; 10183 Decls : constant List_Id := New_List; 10184 Stms : constant List_Id := New_List; 10185 10186 TCNam : constant Entity_Id := 10187 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode); 10188 10189 Parameters : List_Id; 10190 10191 procedure Add_String_Parameter 10192 (S : String_Id; 10193 Parameter_List : List_Id); 10194 -- Add a literal for S to Parameters 10195 10196 procedure Add_TypeCode_Parameter 10197 (TC_Node : Node_Id; 10198 Parameter_List : List_Id); 10199 -- Add the typecode for Typ to Parameters 10200 10201 procedure Add_Long_Parameter 10202 (Expr_Node : Node_Id; 10203 Parameter_List : List_Id); 10204 -- Add a signed long integer expression to Parameters 10205 10206 procedure Initialize_Parameter_List 10207 (Name_String : String_Id; 10208 Repo_Id_String : String_Id; 10209 Parameter_List : out List_Id); 10210 -- Return a list that contains the first two parameters 10211 -- for a parameterized typecode: name and repository id. 10212 10213 function Make_Constructed_TypeCode 10214 (Kind : Entity_Id; 10215 Parameters : List_Id) return Node_Id; 10216 -- Call Build_Complex_TC with the given kind and parameters 10217 10218 procedure Return_Constructed_TypeCode (Kind : Entity_Id); 10219 -- Make a return statement that calls Build_Complex_TC with the 10220 -- given typecode kind, and the constructed parameters list. 10221 10222 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id); 10223 -- Return a typecode that is a TC_Alias for the given typecode 10224 10225 -------------------------- 10226 -- Add_String_Parameter -- 10227 -------------------------- 10228 10229 procedure Add_String_Parameter 10230 (S : String_Id; 10231 Parameter_List : List_Id) 10232 is 10233 begin 10234 Append_To (Parameter_List, 10235 Make_Function_Call (Loc, 10236 Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc), 10237 Parameter_Associations => New_List ( 10238 Make_String_Literal (Loc, S)))); 10239 end Add_String_Parameter; 10240 10241 ---------------------------- 10242 -- Add_TypeCode_Parameter -- 10243 ---------------------------- 10244 10245 procedure Add_TypeCode_Parameter 10246 (TC_Node : Node_Id; 10247 Parameter_List : List_Id) 10248 is 10249 begin 10250 Append_To (Parameter_List, 10251 Make_Function_Call (Loc, 10252 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc), 10253 Parameter_Associations => New_List (TC_Node))); 10254 end Add_TypeCode_Parameter; 10255 10256 ------------------------ 10257 -- Add_Long_Parameter -- 10258 ------------------------ 10259 10260 procedure Add_Long_Parameter 10261 (Expr_Node : Node_Id; 10262 Parameter_List : List_Id) 10263 is 10264 begin 10265 Append_To (Parameter_List, 10266 Make_Function_Call (Loc, 10267 Name => 10268 New_Occurrence_Of (RTE (RE_TA_I32), Loc), 10269 Parameter_Associations => New_List (Expr_Node))); 10270 end Add_Long_Parameter; 10271 10272 ------------------------------- 10273 -- Initialize_Parameter_List -- 10274 ------------------------------- 10275 10276 procedure Initialize_Parameter_List 10277 (Name_String : String_Id; 10278 Repo_Id_String : String_Id; 10279 Parameter_List : out List_Id) 10280 is 10281 begin 10282 Parameter_List := New_List; 10283 Add_String_Parameter (Name_String, Parameter_List); 10284 Add_String_Parameter (Repo_Id_String, Parameter_List); 10285 end Initialize_Parameter_List; 10286 10287 --------------------------- 10288 -- Return_Alias_TypeCode -- 10289 --------------------------- 10290 10291 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id) is 10292 begin 10293 Add_TypeCode_Parameter (Base_TypeCode, Parameters); 10294 Return_Constructed_TypeCode (RTE (RE_Tk_Alias)); 10295 end Return_Alias_TypeCode; 10296 10297 ------------------------------- 10298 -- Make_Constructed_TypeCode -- 10299 ------------------------------- 10300 10301 function Make_Constructed_TypeCode 10302 (Kind : Entity_Id; 10303 Parameters : List_Id) return Node_Id 10304 is 10305 Constructed_TC : constant Node_Id := 10306 Make_Function_Call (Loc, 10307 Name => 10308 New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc), 10309 Parameter_Associations => New_List ( 10310 New_Occurrence_Of (Kind, Loc), 10311 Make_Aggregate (Loc, 10312 Expressions => Parameters))); 10313 begin 10314 Set_Etype (Constructed_TC, RTE (RE_TypeCode)); 10315 return Constructed_TC; 10316 end Make_Constructed_TypeCode; 10317 10318 --------------------------------- 10319 -- Return_Constructed_TypeCode -- 10320 --------------------------------- 10321 10322 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is 10323 begin 10324 Append_To (Stms, 10325 Make_Simple_Return_Statement (Loc, 10326 Expression => 10327 Make_Constructed_TypeCode (Kind, Parameters))); 10328 end Return_Constructed_TypeCode; 10329 10330 ------------------ 10331 -- Record types -- 10332 ------------------ 10333 10334 procedure TC_Rec_Add_Process_Element 10335 (Params : List_Id; 10336 Any : Entity_Id; 10337 Counter : in out Int; 10338 Rec : Entity_Id; 10339 Field : Node_Id); 10340 10341 procedure TC_Append_Record_Traversal is 10342 new Append_Record_Traversal ( 10343 Rec => Empty, 10344 Add_Process_Element => TC_Rec_Add_Process_Element); 10345 10346 -------------------------------- 10347 -- TC_Rec_Add_Process_Element -- 10348 -------------------------------- 10349 10350 procedure TC_Rec_Add_Process_Element 10351 (Params : List_Id; 10352 Any : Entity_Id; 10353 Counter : in out Int; 10354 Rec : Entity_Id; 10355 Field : Node_Id) 10356 is 10357 pragma Unreferenced (Any, Counter, Rec); 10358 10359 begin 10360 if Nkind (Field) = N_Defining_Identifier then 10361 10362 -- A regular component 10363 10364 Add_TypeCode_Parameter 10365 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params); 10366 Get_Name_String (Chars (Field)); 10367 Add_String_Parameter (String_From_Name_Buffer, Params); 10368 10369 else 10370 10371 -- A variant part 10372 10373 Variant_Part : declare 10374 Disc_Type : constant Entity_Id := Etype (Name (Field)); 10375 10376 Is_Enum : constant Boolean := 10377 Is_Enumeration_Type (Disc_Type); 10378 10379 Union_TC_Params : List_Id; 10380 10381 U_Name : constant Name_Id := 10382 New_External_Name (Chars (Typ), 'V', -1); 10383 10384 Name_Str : String_Id; 10385 Struct_TC_Params : List_Id; 10386 10387 Variant : Node_Id; 10388 Choice : Node_Id; 10389 Default : constant Node_Id := 10390 Make_Integer_Literal (Loc, -1); 10391 10392 Dummy_Counter : Int := 0; 10393 10394 Choice_Index : Int := 0; 10395 -- Index of current choice in TypeCode, used to identify 10396 -- it as the default choice if it is a "when others". 10397 10398 procedure Add_Params_For_Variant_Components; 10399 -- Add a struct TypeCode and a corresponding member name 10400 -- to the union parameter list. 10401 10402 -- Ordering of declarations is a complete mess in this 10403 -- area, it is supposed to be types/variables, then 10404 -- subprogram specs, then subprogram bodies ??? 10405 10406 --------------------------------------- 10407 -- Add_Params_For_Variant_Components -- 10408 --------------------------------------- 10409 10410 procedure Add_Params_For_Variant_Components is 10411 S_Name : constant Name_Id := 10412 New_External_Name (U_Name, 'S', -1); 10413 10414 begin 10415 Get_Name_String (S_Name); 10416 Name_Str := String_From_Name_Buffer; 10417 Initialize_Parameter_List 10418 (Name_Str, Name_Str, Struct_TC_Params); 10419 10420 -- Build struct parameters 10421 10422 TC_Append_Record_Traversal (Struct_TC_Params, 10423 Component_List (Variant), 10424 Empty, 10425 Dummy_Counter); 10426 10427 Add_TypeCode_Parameter 10428 (Make_Constructed_TypeCode 10429 (RTE (RE_Tk_Struct), Struct_TC_Params), 10430 Union_TC_Params); 10431 10432 Add_String_Parameter (Name_Str, Union_TC_Params); 10433 end Add_Params_For_Variant_Components; 10434 10435 -- Start of processing for Variant_Part 10436 10437 begin 10438 Get_Name_String (U_Name); 10439 Name_Str := String_From_Name_Buffer; 10440 10441 Initialize_Parameter_List 10442 (Name_Str, Name_Str, Union_TC_Params); 10443 10444 -- Add union in enclosing parameter list 10445 10446 Add_TypeCode_Parameter 10447 (Make_Constructed_TypeCode 10448 (RTE (RE_Tk_Union), Union_TC_Params), 10449 Params); 10450 10451 Add_String_Parameter (Name_Str, Params); 10452 10453 -- Build union parameters 10454 10455 Add_TypeCode_Parameter 10456 (Build_TypeCode_Call (Loc, Disc_Type, Decls), 10457 Union_TC_Params); 10458 10459 Add_Long_Parameter (Default, Union_TC_Params); 10460 10461 Variant := First_Non_Pragma (Variants (Field)); 10462 while Present (Variant) loop 10463 Choice := First (Discrete_Choices (Variant)); 10464 while Present (Choice) loop 10465 case Nkind (Choice) is 10466 when N_Range => 10467 declare 10468 L : constant Uint := 10469 Expr_Value (Low_Bound (Choice)); 10470 H : constant Uint := 10471 Expr_Value (High_Bound (Choice)); 10472 J : Uint := L; 10473 -- 3.8.1(8) guarantees that the bounds of 10474 -- this range are static. 10475 10476 Expr : Node_Id; 10477 10478 begin 10479 while J <= H loop 10480 if Is_Enum then 10481 Expr := Get_Enum_Lit_From_Pos 10482 (Disc_Type, J, Loc); 10483 else 10484 Expr := 10485 Make_Integer_Literal (Loc, J); 10486 end if; 10487 10488 Set_Etype (Expr, Disc_Type); 10489 Append_To (Union_TC_Params, 10490 Build_To_Any_Call (Loc, Expr, Decls)); 10491 10492 Add_Params_For_Variant_Components; 10493 J := J + Uint_1; 10494 end loop; 10495 10496 Choice_Index := 10497 Choice_Index + UI_To_Int (H - L) + 1; 10498 end; 10499 10500 when N_Others_Choice => 10501 10502 -- This variant has a default choice. We must 10503 -- therefore set the default parameter to the 10504 -- current choice index. This parameter is by 10505 -- construction the 4th in Union_TC_Params. 10506 10507 Replace 10508 (Pick (Union_TC_Params, 4), 10509 Make_Function_Call (Loc, 10510 Name => 10511 New_Occurrence_Of 10512 (RTE (RE_TA_I32), Loc), 10513 Parameter_Associations => 10514 New_List ( 10515 Make_Integer_Literal (Loc, 10516 Intval => Choice_Index)))); 10517 10518 -- Add a placeholder member label for the 10519 -- default case, which must have the 10520 -- discriminant type. 10521 10522 declare 10523 Exp : constant Node_Id := 10524 Make_Attribute_Reference (Loc, 10525 Prefix => New_Occurrence_Of 10526 (Disc_Type, Loc), 10527 Attribute_Name => Name_First); 10528 begin 10529 Set_Etype (Exp, Disc_Type); 10530 Append_To (Union_TC_Params, 10531 Build_To_Any_Call (Loc, Exp, Decls)); 10532 end; 10533 10534 Add_Params_For_Variant_Components; 10535 Choice_Index := Choice_Index + 1; 10536 10537 -- Case of an explicit choice 10538 10539 when others => 10540 declare 10541 Exp : constant Node_Id := 10542 New_Copy_Tree (Choice); 10543 begin 10544 Append_To (Union_TC_Params, 10545 Build_To_Any_Call (Loc, Exp, Decls)); 10546 end; 10547 10548 Add_Params_For_Variant_Components; 10549 Choice_Index := Choice_Index + 1; 10550 end case; 10551 10552 Next (Choice); 10553 end loop; 10554 10555 Next_Non_Pragma (Variant); 10556 end loop; 10557 end Variant_Part; 10558 end if; 10559 end TC_Rec_Add_Process_Element; 10560 10561 Type_Name_Str : String_Id; 10562 Type_Repo_Id_Str : String_Id; 10563 10564 -- Start of processing for Build_TypeCode_Function 10565 10566 begin 10567 -- For a derived type, we can't go past the base type (to the 10568 -- parent type) here, because that would cause the attribute's 10569 -- formal parameter to have the wrong type; hence the Base_Type 10570 -- check here. 10571 10572 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then 10573 Build_TypeCode_Function 10574 (Loc => Loc, 10575 Typ => Etype (Typ), 10576 Decl => Decl, 10577 Fnam => Fnam); 10578 return; 10579 end if; 10580 10581 Fnam := TCNam; 10582 10583 Spec := 10584 Make_Function_Specification (Loc, 10585 Defining_Unit_Name => Fnam, 10586 Parameter_Specifications => Empty_List, 10587 Result_Definition => 10588 New_Occurrence_Of (RTE (RE_TypeCode), Loc)); 10589 10590 Build_Name_And_Repository_Id (Typ, 10591 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str); 10592 10593 Initialize_Parameter_List 10594 (Type_Name_Str, Type_Repo_Id_Str, Parameters); 10595 10596 if Has_Stream_Attribute_Definition 10597 (Typ, TSS_Stream_Output, At_Any_Place => True) 10598 or else 10599 Has_Stream_Attribute_Definition 10600 (Typ, TSS_Stream_Write, At_Any_Place => True) 10601 then 10602 -- If user-defined stream attributes are specified for this 10603 -- type, use them and transmit data as an opaque sequence of 10604 -- stream elements. 10605 10606 Return_Alias_TypeCode 10607 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); 10608 10609 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then 10610 Return_Alias_TypeCode ( 10611 Build_TypeCode_Call (Loc, Etype (Typ), Decls)); 10612 10613 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then 10614 Return_Alias_TypeCode ( 10615 Build_TypeCode_Call (Loc, 10616 Find_Numeric_Representation (Typ), Decls)); 10617 10618 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then 10619 10620 -- Record typecodes are encoded as follows: 10621 -- -- TC_STRUCT 10622 -- | 10623 -- | [Name] 10624 -- | [Repository Id] 10625 -- 10626 -- Then for each discriminant: 10627 -- 10628 -- | [Discriminant Type Code] 10629 -- | [Discriminant Name] 10630 -- | ... 10631 -- 10632 -- Then for each component: 10633 -- 10634 -- | [Component Type Code] 10635 -- | [Component Name] 10636 -- | ... 10637 -- 10638 -- Variants components type codes are encoded as follows: 10639 -- -- TC_UNION 10640 -- | 10641 -- | [Name] 10642 -- | [Repository Id] 10643 -- | [Discriminant Type Code] 10644 -- | [Index of Default Variant Part or -1 for no default] 10645 -- 10646 -- Then for each Variant Part : 10647 -- 10648 -- | [VP Label] 10649 -- | 10650 -- | -- TC_STRUCT 10651 -- | | [Variant Part Name] 10652 -- | | [Variant Part Repository Id] 10653 -- | | 10654 -- | Then for each VP component: 10655 -- | | [VP component Typecode] 10656 -- | | [VP component Name] 10657 -- | | ... 10658 -- | -- 10659 -- | 10660 -- | [VP Name] 10661 10662 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then 10663 Return_Alias_TypeCode 10664 (Build_TypeCode_Call (Loc, Etype (Typ), Decls)); 10665 10666 else 10667 declare 10668 Disc : Entity_Id := Empty; 10669 Rdef : constant Node_Id := 10670 Type_Definition (Declaration_Node (Typ)); 10671 Dummy_Counter : Int := 0; 10672 10673 begin 10674 -- Construct the discriminants typecodes 10675 10676 if Has_Discriminants (Typ) then 10677 Disc := First_Discriminant (Typ); 10678 end if; 10679 10680 while Present (Disc) loop 10681 Add_TypeCode_Parameter ( 10682 Build_TypeCode_Call (Loc, Etype (Disc), Decls), 10683 Parameters); 10684 Get_Name_String (Chars (Disc)); 10685 Add_String_Parameter ( 10686 String_From_Name_Buffer, 10687 Parameters); 10688 Next_Discriminant (Disc); 10689 end loop; 10690 10691 -- then the components typecodes 10692 10693 TC_Append_Record_Traversal 10694 (Parameters, Component_List (Rdef), 10695 Empty, Dummy_Counter); 10696 Return_Constructed_TypeCode (RTE (RE_Tk_Struct)); 10697 end; 10698 end if; 10699 10700 elsif Is_Array_Type (Typ) then 10701 declare 10702 Ndim : constant Pos := Number_Dimensions (Typ); 10703 Inner_TypeCode : Node_Id; 10704 Constrained : constant Boolean := Is_Constrained (Typ); 10705 Indx : Node_Id := First_Index (Typ); 10706 10707 begin 10708 Inner_TypeCode := 10709 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls); 10710 10711 for J in 1 .. Ndim loop 10712 if Constrained then 10713 Inner_TypeCode := Make_Constructed_TypeCode 10714 (RTE (RE_Tk_Array), New_List ( 10715 Build_To_Any_Call (Loc, 10716 OK_Convert_To (RTE (RE_Unsigned_32), 10717 Make_Attribute_Reference (Loc, 10718 Prefix => New_Occurrence_Of (Typ, Loc), 10719 Attribute_Name => Name_Length, 10720 Expressions => New_List ( 10721 Make_Integer_Literal (Loc, 10722 Intval => Ndim - J + 1)))), 10723 Decls), 10724 Build_To_Any_Call (Loc, Inner_TypeCode, Decls))); 10725 10726 else 10727 -- Unconstrained case: add low bound for each 10728 -- dimension. 10729 10730 Add_TypeCode_Parameter 10731 (Build_TypeCode_Call (Loc, Etype (Indx), Decls), 10732 Parameters); 10733 Get_Name_String (New_External_Name ('L', J)); 10734 Add_String_Parameter ( 10735 String_From_Name_Buffer, 10736 Parameters); 10737 Next_Index (Indx); 10738 10739 Inner_TypeCode := Make_Constructed_TypeCode 10740 (RTE (RE_Tk_Sequence), New_List ( 10741 Build_To_Any_Call (Loc, 10742 OK_Convert_To (RTE (RE_Unsigned_32), 10743 Make_Integer_Literal (Loc, 0)), 10744 Decls), 10745 Build_To_Any_Call (Loc, Inner_TypeCode, Decls))); 10746 end if; 10747 end loop; 10748 10749 if Constrained then 10750 Return_Alias_TypeCode (Inner_TypeCode); 10751 else 10752 Add_TypeCode_Parameter (Inner_TypeCode, Parameters); 10753 Start_String; 10754 Store_String_Char ('V'); 10755 Add_String_Parameter (End_String, Parameters); 10756 Return_Constructed_TypeCode (RTE (RE_Tk_Struct)); 10757 end if; 10758 end; 10759 10760 else 10761 -- Default: type is represented as an opaque sequence of bytes 10762 10763 Return_Alias_TypeCode 10764 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); 10765 end if; 10766 10767 Decl := 10768 Make_Subprogram_Body (Loc, 10769 Specification => Spec, 10770 Declarations => Decls, 10771 Handled_Statement_Sequence => 10772 Make_Handled_Sequence_Of_Statements (Loc, 10773 Statements => Stms)); 10774 end Build_TypeCode_Function; 10775 10776 --------------------------------- 10777 -- Find_Numeric_Representation -- 10778 --------------------------------- 10779 10780 function Find_Numeric_Representation 10781 (Typ : Entity_Id) return Entity_Id 10782 is 10783 FST : constant Entity_Id := First_Subtype (Typ); 10784 P_Size : constant Uint := Esize (FST); 10785 10786 begin 10787 -- Special case: for Stream_Element_Offset and Storage_Offset, 10788 -- always force transmission as a 64-bit value. 10789 10790 if Is_RTE (FST, RE_Stream_Element_Offset) 10791 or else 10792 Is_RTE (FST, RE_Storage_Offset) 10793 then 10794 return RTE (RE_Unsigned_64); 10795 end if; 10796 10797 if Is_Unsigned_Type (Typ) then 10798 if P_Size <= 8 then 10799 return RTE (RE_Unsigned_8); 10800 10801 elsif P_Size <= 16 then 10802 return RTE (RE_Unsigned_16); 10803 10804 elsif P_Size <= 32 then 10805 return RTE (RE_Unsigned_32); 10806 10807 else 10808 return RTE (RE_Unsigned_64); 10809 end if; 10810 10811 elsif Is_Integer_Type (Typ) then 10812 if P_Size <= 8 then 10813 return RTE (RE_Integer_8); 10814 10815 elsif P_Size <= Standard_Short_Integer_Size then 10816 return RTE (RE_Integer_16); 10817 10818 elsif P_Size <= Standard_Integer_Size then 10819 return RTE (RE_Integer_32); 10820 10821 else 10822 return RTE (RE_Integer_64); 10823 end if; 10824 10825 elsif Is_Floating_Point_Type (Typ) then 10826 if P_Size <= Standard_Short_Float_Size then 10827 return Standard_Short_Float; 10828 10829 elsif P_Size <= Standard_Float_Size then 10830 return Standard_Float; 10831 10832 elsif P_Size <= Standard_Long_Float_Size then 10833 return Standard_Long_Float; 10834 10835 else 10836 return Standard_Long_Long_Float; 10837 end if; 10838 10839 else 10840 raise Program_Error; 10841 end if; 10842 10843 -- TBD: fixed point types??? 10844 -- TBverified numeric types with a biased representation??? 10845 10846 end Find_Numeric_Representation; 10847 10848 --------------------------- 10849 -- Append_Array_Traversal -- 10850 --------------------------- 10851 10852 procedure Append_Array_Traversal 10853 (Stmts : List_Id; 10854 Any : Entity_Id; 10855 Counter : Entity_Id := Empty; 10856 Depth : Pos := 1) 10857 is 10858 Loc : constant Source_Ptr := Sloc (Subprogram); 10859 Typ : constant Entity_Id := Etype (Arry); 10860 Constrained : constant Boolean := Is_Constrained (Typ); 10861 Ndim : constant Pos := Number_Dimensions (Typ); 10862 10863 Inner_Any, Inner_Counter : Entity_Id; 10864 10865 Loop_Stm : Node_Id; 10866 Inner_Stmts : constant List_Id := New_List; 10867 10868 begin 10869 if Depth > Ndim then 10870 10871 -- Processing for one element of an array 10872 10873 declare 10874 Element_Expr : constant Node_Id := 10875 Make_Indexed_Component (Loc, 10876 New_Occurrence_Of (Arry, Loc), 10877 Indexes); 10878 begin 10879 Set_Etype (Element_Expr, Component_Type (Typ)); 10880 Add_Process_Element (Stmts, 10881 Any => Any, 10882 Counter => Counter, 10883 Datum => Element_Expr); 10884 end; 10885 10886 return; 10887 end if; 10888 10889 Append_To (Indexes, 10890 Make_Identifier (Loc, New_External_Name ('L', Depth))); 10891 10892 if not Constrained or else Depth > 1 then 10893 Inner_Any := Make_Defining_Identifier (Loc, 10894 New_External_Name ('A', Depth)); 10895 Set_Etype (Inner_Any, RTE (RE_Any)); 10896 else 10897 Inner_Any := Empty; 10898 end if; 10899 10900 if Present (Counter) then 10901 Inner_Counter := Make_Defining_Identifier (Loc, 10902 New_External_Name ('J', Depth)); 10903 else 10904 Inner_Counter := Empty; 10905 end if; 10906 10907 declare 10908 Loop_Any : Node_Id := Inner_Any; 10909 10910 begin 10911 -- For the first dimension of a constrained array, we add 10912 -- elements directly in the corresponding Any; there is no 10913 -- intervening inner Any. 10914 10915 if No (Loop_Any) then 10916 Loop_Any := Any; 10917 end if; 10918 10919 Append_Array_Traversal (Inner_Stmts, 10920 Any => Loop_Any, 10921 Counter => Inner_Counter, 10922 Depth => Depth + 1); 10923 end; 10924 10925 Loop_Stm := 10926 Make_Implicit_Loop_Statement (Subprogram, 10927 Iteration_Scheme => 10928 Make_Iteration_Scheme (Loc, 10929 Loop_Parameter_Specification => 10930 Make_Loop_Parameter_Specification (Loc, 10931 Defining_Identifier => 10932 Make_Defining_Identifier (Loc, 10933 Chars => New_External_Name ('L', Depth)), 10934 10935 Discrete_Subtype_Definition => 10936 Make_Attribute_Reference (Loc, 10937 Prefix => New_Occurrence_Of (Arry, Loc), 10938 Attribute_Name => Name_Range, 10939 10940 Expressions => New_List ( 10941 Make_Integer_Literal (Loc, Depth))))), 10942 Statements => Inner_Stmts); 10943 10944 declare 10945 Decls : constant List_Id := New_List; 10946 Dimen_Stmts : constant List_Id := New_List; 10947 Length_Node : Node_Id; 10948 10949 Inner_Any_TypeCode : constant Entity_Id := 10950 Make_Defining_Identifier (Loc, 10951 New_External_Name ('T', Depth)); 10952 10953 Inner_Any_TypeCode_Expr : Node_Id; 10954 10955 begin 10956 if Depth = 1 then 10957 if Constrained then 10958 Inner_Any_TypeCode_Expr := 10959 Make_Function_Call (Loc, 10960 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc), 10961 Parameter_Associations => New_List ( 10962 New_Occurrence_Of (Any, Loc))); 10963 10964 else 10965 Inner_Any_TypeCode_Expr := 10966 Make_Function_Call (Loc, 10967 Name => 10968 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc), 10969 Parameter_Associations => New_List ( 10970 New_Occurrence_Of (Any, Loc), 10971 Make_Integer_Literal (Loc, Ndim))); 10972 end if; 10973 10974 else 10975 Inner_Any_TypeCode_Expr := 10976 Make_Function_Call (Loc, 10977 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc), 10978 Parameter_Associations => New_List ( 10979 Make_Identifier (Loc, 10980 Chars => New_External_Name ('T', Depth - 1)))); 10981 end if; 10982 10983 Append_To (Decls, 10984 Make_Object_Declaration (Loc, 10985 Defining_Identifier => Inner_Any_TypeCode, 10986 Constant_Present => True, 10987 Object_Definition => New_Occurrence_Of ( 10988 RTE (RE_TypeCode), Loc), 10989 Expression => Inner_Any_TypeCode_Expr)); 10990 10991 if Present (Inner_Any) then 10992 Append_To (Decls, 10993 Make_Object_Declaration (Loc, 10994 Defining_Identifier => Inner_Any, 10995 Object_Definition => 10996 New_Occurrence_Of (RTE (RE_Any), Loc), 10997 Expression => 10998 Make_Function_Call (Loc, 10999 Name => 11000 New_Occurrence_Of ( 11001 RTE (RE_Create_Any), Loc), 11002 Parameter_Associations => New_List ( 11003 New_Occurrence_Of (Inner_Any_TypeCode, Loc))))); 11004 end if; 11005 11006 if Present (Inner_Counter) then 11007 Append_To (Decls, 11008 Make_Object_Declaration (Loc, 11009 Defining_Identifier => Inner_Counter, 11010 Object_Definition => 11011 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc), 11012 Expression => 11013 Make_Integer_Literal (Loc, 0))); 11014 end if; 11015 11016 if not Constrained then 11017 Length_Node := Make_Attribute_Reference (Loc, 11018 Prefix => New_Occurrence_Of (Arry, Loc), 11019 Attribute_Name => Name_Length, 11020 Expressions => 11021 New_List (Make_Integer_Literal (Loc, Depth))); 11022 Set_Etype (Length_Node, RTE (RE_Unsigned_32)); 11023 11024 Add_Process_Element (Dimen_Stmts, 11025 Datum => Length_Node, 11026 Any => Inner_Any, 11027 Counter => Inner_Counter); 11028 end if; 11029 11030 -- Loop_Stm does appropriate processing for each element 11031 -- of Inner_Any. 11032 11033 Append_To (Dimen_Stmts, Loop_Stm); 11034 11035 -- Link outer and inner any 11036 11037 if Present (Inner_Any) then 11038 Add_Process_Element (Dimen_Stmts, 11039 Any => Any, 11040 Counter => Counter, 11041 Datum => New_Occurrence_Of (Inner_Any, Loc)); 11042 end if; 11043 11044 Append_To (Stmts, 11045 Make_Block_Statement (Loc, 11046 Declarations => 11047 Decls, 11048 Handled_Statement_Sequence => 11049 Make_Handled_Sequence_Of_Statements (Loc, 11050 Statements => Dimen_Stmts))); 11051 end; 11052 end Append_Array_Traversal; 11053 11054 ------------------------------- 11055 -- Make_Helper_Function_Name -- 11056 ------------------------------- 11057 11058 function Make_Helper_Function_Name 11059 (Loc : Source_Ptr; 11060 Typ : Entity_Id; 11061 Nam : Name_Id) return Entity_Id 11062 is 11063 begin 11064 declare 11065 Serial : Nat := 0; 11066 -- For tagged types that aren't frozen yet, generate the helper 11067 -- under its canonical name so that it matches the primitive 11068 -- spec. For all other cases, we use a serialized name so that 11069 -- multiple generations of the same procedure do not clash. 11070 11071 begin 11072 if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then 11073 null; 11074 else 11075 Serial := Increment_Serial_Number; 11076 end if; 11077 11078 -- Use prefixed underscore to avoid potential clash with user 11079 -- identifier (we use attribute names for Nam). 11080 11081 return 11082 Make_Defining_Identifier (Loc, 11083 Chars => 11084 New_External_Name 11085 (Related_Id => Nam, 11086 Suffix => ' ', 11087 Suffix_Index => Serial, 11088 Prefix => '_')); 11089 end; 11090 end Make_Helper_Function_Name; 11091 end Helpers; 11092 11093 ----------------------------------- 11094 -- Reserve_NamingContext_Methods -- 11095 ----------------------------------- 11096 11097 procedure Reserve_NamingContext_Methods is 11098 Str_Resolve : constant String := "resolve"; 11099 begin 11100 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve; 11101 Name_Len := Str_Resolve'Length; 11102 Overload_Counter_Table.Set (Name_Find, 1); 11103 end Reserve_NamingContext_Methods; 11104 11105 ----------------------- 11106 -- RPC_Receiver_Decl -- 11107 ----------------------- 11108 11109 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is 11110 Loc : constant Source_Ptr := Sloc (RACW_Type); 11111 begin 11112 return 11113 Make_Object_Declaration (Loc, 11114 Defining_Identifier => Make_Temporary (Loc, 'R'), 11115 Aliased_Present => True, 11116 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); 11117 end RPC_Receiver_Decl; 11118 11119 end PolyORB_Support; 11120 11121 ------------------------------- 11122 -- RACW_Type_Is_Asynchronous -- 11123 ------------------------------- 11124 11125 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is 11126 Asynchronous_Flag : constant Entity_Id := 11127 Asynchronous_Flags_Table.Get (RACW_Type); 11128 begin 11129 Replace (Expression (Parent (Asynchronous_Flag)), 11130 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag))); 11131 end RACW_Type_Is_Asynchronous; 11132 11133 ------------------------- 11134 -- RCI_Package_Locator -- 11135 ------------------------- 11136 11137 function RCI_Package_Locator 11138 (Loc : Source_Ptr; 11139 Package_Spec : Node_Id) return Node_Id 11140 is 11141 Inst : Node_Id; 11142 Pkg_Name : constant String_Id := 11143 Fully_Qualified_Name_String 11144 (Defining_Entity (Package_Spec), Append_NUL => False); 11145 11146 begin 11147 Inst := 11148 Make_Package_Instantiation (Loc, 11149 Defining_Unit_Name => Make_Temporary (Loc, 'R'), 11150 11151 Name => 11152 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc), 11153 11154 Generic_Associations => New_List ( 11155 Make_Generic_Association (Loc, 11156 Selector_Name => 11157 Make_Identifier (Loc, Name_RCI_Name), 11158 Explicit_Generic_Actual_Parameter => 11159 Make_String_Literal (Loc, 11160 Strval => Pkg_Name)), 11161 11162 Make_Generic_Association (Loc, 11163 Selector_Name => 11164 Make_Identifier (Loc, Name_Version), 11165 Explicit_Generic_Actual_Parameter => 11166 Make_Attribute_Reference (Loc, 11167 Prefix => 11168 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc), 11169 Attribute_Name => 11170 Name_Version)))); 11171 11172 RCI_Locator_Table.Set 11173 (Defining_Unit_Name (Package_Spec), 11174 Defining_Unit_Name (Inst)); 11175 return Inst; 11176 end RCI_Package_Locator; 11177 11178 ----------------------------------------------- 11179 -- Remote_Types_Tagged_Full_View_Encountered -- 11180 ----------------------------------------------- 11181 11182 procedure Remote_Types_Tagged_Full_View_Encountered 11183 (Full_View : Entity_Id) 11184 is 11185 Stub_Elements : constant Stub_Structure := 11186 Stubs_Table.Get (Full_View); 11187 11188 begin 11189 -- For an RACW encountered before the freeze point of its designated 11190 -- type, the stub type is generated at the point of the RACW declaration 11191 -- but the primitives are generated only once the designated type is 11192 -- frozen. That freeze can occur in another scope, for example when the 11193 -- RACW is declared in a nested package. In that case we need to 11194 -- reestablish the stub type's scope prior to generating its primitive 11195 -- operations. 11196 11197 if Stub_Elements /= Empty_Stub_Structure then 11198 declare 11199 Saved_Scope : constant Entity_Id := Current_Scope; 11200 Stubs_Scope : constant Entity_Id := 11201 Scope (Stub_Elements.Stub_Type); 11202 11203 begin 11204 if Current_Scope /= Stubs_Scope then 11205 Push_Scope (Stubs_Scope); 11206 end if; 11207 11208 Add_RACW_Primitive_Declarations_And_Bodies 11209 (Full_View, 11210 Stub_Elements.RPC_Receiver_Decl, 11211 Stub_Elements.Body_Decls); 11212 11213 if Current_Scope /= Saved_Scope then 11214 Pop_Scope; 11215 end if; 11216 end; 11217 end if; 11218 end Remote_Types_Tagged_Full_View_Encountered; 11219 11220 ------------------- 11221 -- Scope_Of_Spec -- 11222 ------------------- 11223 11224 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is 11225 Unit_Name : Node_Id; 11226 11227 begin 11228 Unit_Name := Defining_Unit_Name (Spec); 11229 while Nkind (Unit_Name) /= N_Defining_Identifier loop 11230 Unit_Name := Defining_Identifier (Unit_Name); 11231 end loop; 11232 11233 return Unit_Name; 11234 end Scope_Of_Spec; 11235 11236 ---------------------- 11237 -- Set_Renaming_TSS -- 11238 ---------------------- 11239 11240 procedure Set_Renaming_TSS 11241 (Typ : Entity_Id; 11242 Nam : Entity_Id; 11243 TSS_Nam : TSS_Name_Type) 11244 is 11245 Loc : constant Source_Ptr := Sloc (Nam); 11246 Spec : constant Node_Id := Parent (Nam); 11247 11248 TSS_Node : constant Node_Id := 11249 Make_Subprogram_Renaming_Declaration (Loc, 11250 Specification => 11251 Copy_Specification (Loc, 11252 Spec => Spec, 11253 New_Name => Make_TSS_Name (Typ, TSS_Nam)), 11254 Name => New_Occurrence_Of (Nam, Loc)); 11255 11256 Snam : constant Entity_Id := 11257 Defining_Unit_Name (Specification (TSS_Node)); 11258 11259 begin 11260 if Nkind (Spec) = N_Function_Specification then 11261 Set_Ekind (Snam, E_Function); 11262 Set_Etype (Snam, Entity (Result_Definition (Spec))); 11263 else 11264 Set_Ekind (Snam, E_Procedure); 11265 Set_Etype (Snam, Standard_Void_Type); 11266 end if; 11267 11268 Set_TSS (Typ, Snam); 11269 end Set_Renaming_TSS; 11270 11271 ---------------------------------------------- 11272 -- Specific_Add_Obj_RPC_Receiver_Completion -- 11273 ---------------------------------------------- 11274 11275 procedure Specific_Add_Obj_RPC_Receiver_Completion 11276 (Loc : Source_Ptr; 11277 Decls : List_Id; 11278 RPC_Receiver : Entity_Id; 11279 Stub_Elements : Stub_Structure) 11280 is 11281 begin 11282 case Get_PCS_Name is 11283 when Name_PolyORB_DSA => 11284 PolyORB_Support.Add_Obj_RPC_Receiver_Completion 11285 (Loc, Decls, RPC_Receiver, Stub_Elements); 11286 when others => 11287 GARLIC_Support.Add_Obj_RPC_Receiver_Completion 11288 (Loc, Decls, RPC_Receiver, Stub_Elements); 11289 end case; 11290 end Specific_Add_Obj_RPC_Receiver_Completion; 11291 11292 -------------------------------- 11293 -- Specific_Add_RACW_Features -- 11294 -------------------------------- 11295 11296 procedure Specific_Add_RACW_Features 11297 (RACW_Type : Entity_Id; 11298 Desig : Entity_Id; 11299 Stub_Type : Entity_Id; 11300 Stub_Type_Access : Entity_Id; 11301 RPC_Receiver_Decl : Node_Id; 11302 Body_Decls : List_Id) 11303 is 11304 begin 11305 case Get_PCS_Name is 11306 when Name_PolyORB_DSA => 11307 PolyORB_Support.Add_RACW_Features 11308 (RACW_Type, 11309 Desig, 11310 Stub_Type, 11311 Stub_Type_Access, 11312 RPC_Receiver_Decl, 11313 Body_Decls); 11314 11315 when others => 11316 GARLIC_Support.Add_RACW_Features 11317 (RACW_Type, 11318 Stub_Type, 11319 Stub_Type_Access, 11320 RPC_Receiver_Decl, 11321 Body_Decls); 11322 end case; 11323 end Specific_Add_RACW_Features; 11324 11325 -------------------------------- 11326 -- Specific_Add_RAST_Features -- 11327 -------------------------------- 11328 11329 procedure Specific_Add_RAST_Features 11330 (Vis_Decl : Node_Id; 11331 RAS_Type : Entity_Id) 11332 is 11333 begin 11334 case Get_PCS_Name is 11335 when Name_PolyORB_DSA => 11336 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type); 11337 when others => 11338 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type); 11339 end case; 11340 end Specific_Add_RAST_Features; 11341 11342 -------------------------------------------------- 11343 -- Specific_Add_Receiving_Stubs_To_Declarations -- 11344 -------------------------------------------------- 11345 11346 procedure Specific_Add_Receiving_Stubs_To_Declarations 11347 (Pkg_Spec : Node_Id; 11348 Decls : List_Id; 11349 Stmts : List_Id) 11350 is 11351 begin 11352 case Get_PCS_Name is 11353 when Name_PolyORB_DSA => 11354 PolyORB_Support.Add_Receiving_Stubs_To_Declarations 11355 (Pkg_Spec, Decls, Stmts); 11356 when others => 11357 GARLIC_Support.Add_Receiving_Stubs_To_Declarations 11358 (Pkg_Spec, Decls, Stmts); 11359 end case; 11360 end Specific_Add_Receiving_Stubs_To_Declarations; 11361 11362 ------------------------------------------ 11363 -- Specific_Build_General_Calling_Stubs -- 11364 ------------------------------------------ 11365 11366 procedure Specific_Build_General_Calling_Stubs 11367 (Decls : List_Id; 11368 Statements : List_Id; 11369 Target : RPC_Target; 11370 Subprogram_Id : Node_Id; 11371 Asynchronous : Node_Id := Empty; 11372 Is_Known_Asynchronous : Boolean := False; 11373 Is_Known_Non_Asynchronous : Boolean := False; 11374 Is_Function : Boolean; 11375 Spec : Node_Id; 11376 Stub_Type : Entity_Id := Empty; 11377 RACW_Type : Entity_Id := Empty; 11378 Nod : Node_Id) 11379 is 11380 begin 11381 case Get_PCS_Name is 11382 when Name_PolyORB_DSA => 11383 PolyORB_Support.Build_General_Calling_Stubs 11384 (Decls, 11385 Statements, 11386 Target.Object, 11387 Subprogram_Id, 11388 Asynchronous, 11389 Is_Known_Asynchronous, 11390 Is_Known_Non_Asynchronous, 11391 Is_Function, 11392 Spec, 11393 Stub_Type, 11394 RACW_Type, 11395 Nod); 11396 11397 when others => 11398 GARLIC_Support.Build_General_Calling_Stubs 11399 (Decls, 11400 Statements, 11401 Target.Partition, 11402 Target.RPC_Receiver, 11403 Subprogram_Id, 11404 Asynchronous, 11405 Is_Known_Asynchronous, 11406 Is_Known_Non_Asynchronous, 11407 Is_Function, 11408 Spec, 11409 Stub_Type, 11410 RACW_Type, 11411 Nod); 11412 end case; 11413 end Specific_Build_General_Calling_Stubs; 11414 11415 -------------------------------------- 11416 -- Specific_Build_RPC_Receiver_Body -- 11417 -------------------------------------- 11418 11419 procedure Specific_Build_RPC_Receiver_Body 11420 (RPC_Receiver : Entity_Id; 11421 Request : out Entity_Id; 11422 Subp_Id : out Entity_Id; 11423 Subp_Index : out Entity_Id; 11424 Stmts : out List_Id; 11425 Decl : out Node_Id) 11426 is 11427 begin 11428 case Get_PCS_Name is 11429 when Name_PolyORB_DSA => 11430 PolyORB_Support.Build_RPC_Receiver_Body 11431 (RPC_Receiver, 11432 Request, 11433 Subp_Id, 11434 Subp_Index, 11435 Stmts, 11436 Decl); 11437 11438 when others => 11439 GARLIC_Support.Build_RPC_Receiver_Body 11440 (RPC_Receiver, 11441 Request, 11442 Subp_Id, 11443 Subp_Index, 11444 Stmts, 11445 Decl); 11446 end case; 11447 end Specific_Build_RPC_Receiver_Body; 11448 11449 -------------------------------- 11450 -- Specific_Build_Stub_Target -- 11451 -------------------------------- 11452 11453 function Specific_Build_Stub_Target 11454 (Loc : Source_Ptr; 11455 Decls : List_Id; 11456 RCI_Locator : Entity_Id; 11457 Controlling_Parameter : Entity_Id) return RPC_Target 11458 is 11459 begin 11460 case Get_PCS_Name is 11461 when Name_PolyORB_DSA => 11462 return 11463 PolyORB_Support.Build_Stub_Target 11464 (Loc, Decls, RCI_Locator, Controlling_Parameter); 11465 11466 when others => 11467 return 11468 GARLIC_Support.Build_Stub_Target 11469 (Loc, Decls, RCI_Locator, Controlling_Parameter); 11470 end case; 11471 end Specific_Build_Stub_Target; 11472 11473 -------------------------------- 11474 -- Specific_RPC_Receiver_Decl -- 11475 -------------------------------- 11476 11477 function Specific_RPC_Receiver_Decl 11478 (RACW_Type : Entity_Id) return Node_Id 11479 is 11480 begin 11481 case Get_PCS_Name is 11482 when Name_PolyORB_DSA => 11483 return PolyORB_Support.RPC_Receiver_Decl (RACW_Type); 11484 11485 when others => 11486 return GARLIC_Support.RPC_Receiver_Decl (RACW_Type); 11487 end case; 11488 end Specific_RPC_Receiver_Decl; 11489 11490 ----------------------------------------------- 11491 -- Specific_Build_Subprogram_Receiving_Stubs -- 11492 ----------------------------------------------- 11493 11494 function Specific_Build_Subprogram_Receiving_Stubs 11495 (Vis_Decl : Node_Id; 11496 Asynchronous : Boolean; 11497 Dynamically_Asynchronous : Boolean := False; 11498 Stub_Type : Entity_Id := Empty; 11499 RACW_Type : Entity_Id := Empty; 11500 Parent_Primitive : Entity_Id := Empty) return Node_Id 11501 is 11502 begin 11503 case Get_PCS_Name is 11504 when Name_PolyORB_DSA => 11505 return 11506 PolyORB_Support.Build_Subprogram_Receiving_Stubs 11507 (Vis_Decl, 11508 Asynchronous, 11509 Dynamically_Asynchronous, 11510 Stub_Type, 11511 RACW_Type, 11512 Parent_Primitive); 11513 11514 when others => 11515 return 11516 GARLIC_Support.Build_Subprogram_Receiving_Stubs 11517 (Vis_Decl, 11518 Asynchronous, 11519 Dynamically_Asynchronous, 11520 Stub_Type, 11521 RACW_Type, 11522 Parent_Primitive); 11523 end case; 11524 end Specific_Build_Subprogram_Receiving_Stubs; 11525 11526 ------------------------------- 11527 -- Transmit_As_Unconstrained -- 11528 ------------------------------- 11529 11530 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is 11531 begin 11532 return 11533 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ)) 11534 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ)); 11535 end Transmit_As_Unconstrained; 11536 11537 -------------------------- 11538 -- Underlying_RACW_Type -- 11539 -------------------------- 11540 11541 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is 11542 Record_Type : Entity_Id; 11543 11544 begin 11545 if Ekind (RAS_Typ) = E_Record_Type then 11546 Record_Type := RAS_Typ; 11547 else 11548 pragma Assert (Present (Equivalent_Type (RAS_Typ))); 11549 Record_Type := Equivalent_Type (RAS_Typ); 11550 end if; 11551 11552 return 11553 Etype (Subtype_Indication 11554 (Component_Definition 11555 (First (Component_Items 11556 (Component_List 11557 (Type_Definition 11558 (Declaration_Node (Record_Type)))))))); 11559 end Underlying_RACW_Type; 11560 11561end Exp_Dist; 11562