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