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