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