1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Elists; use Elists;
29 with Exp_Atag; use Exp_Atag;
30 with Exp_Disp; use Exp_Disp;
31 with Exp_Strm; use Exp_Strm;
32 with Exp_Tss; use Exp_Tss;
33 with Exp_Util; use Exp_Util;
35 with Nlists; use Nlists;
36 with Nmake; use Nmake;
38 with Rtsfind; use Rtsfind;
40 with Sem_Aux; use Sem_Aux;
41 with Sem_Cat; use Sem_Cat;
42 with Sem_Ch3; use Sem_Ch3;
43 with Sem_Ch8; use Sem_Ch8;
44 with Sem_Dist; use Sem_Dist;
45 with Sem_Eval; use Sem_Eval;
46 with Sem_Util; use Sem_Util;
47 with Sinfo; use Sinfo;
48 with Stand; use Stand;
49 with Stringt; use Stringt;
50 with Tbuild; use Tbuild;
51 with Ttypes; use Ttypes;
52 with Uintp; use Uintp;
54 with GNAT.HTable; use GNAT.HTable;
56 package body Exp_Dist is
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:
61 -- type Stub is tagged record
62 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
65 -- is built. This type has two properties:
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;
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.
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.)
90 type Hash_Index is range 0 .. 50;
92 -----------------------
93 -- Local subprograms --
94 -----------------------
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.
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.
105 type Subprogram_Identifiers is record
106 Str_Identifier : String_Id;
107 Int_Identifier : Int;
110 package Subprogram_Identifier_Table is
111 new Simple_HTable (Header_Num => Hash_Index,
112 Element => Subprogram_Identifiers,
113 No_Element => (No_String, 0),
117 -- Mapping between a remote subprogram and the corresponding subprogram
120 package Overload_Counter_Table is
121 new Simple_HTable (Header_Num => Hash_Index,
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).
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.
140 -- The integer identifier is used to perform remote calls with GARLIC;
141 -- the string identifier is used in the case of PolyORB.
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
149 -- NOTE: Another design would be to allow a representation clause on
150 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
152 pragma Warnings (Off, Get_Subprogram_Id);
153 -- One homonym only is unreferenced (specific to the GARLIC version)
155 procedure Add_RAS_Dereference_TSS (N : Node_Id);
156 -- Add a subprogram body for RAS Dereference TSS
158 procedure Add_RAS_Proxy_And_Analyze
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.
170 function Build_Remote_Subprogram_Proxy_Type
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.
177 function Build_Get_Unique_RP_Call
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).
185 function Build_Stub_Tag
187 RACW_Type : Entity_Id) return Node_Id;
188 -- Return an expression denoting the tag of the stub type associated with
191 function Build_Subprogram_Calling_Stubs
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.
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.
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.
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.
228 procedure Add_Calling_Stubs_To_Declarations
231 -- Add calling stubs to the declarative part
233 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
234 -- Return True if nothing prevents the program whose specification is
235 -- given to be asynchronous (i.e. no [IN] OUT parameters).
237 function Pack_Entity_Into_Stream_Access
241 Etyp : Entity_Id := Empty) return Node_Id;
242 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
243 -- then Etype (Object) will be used if present. If the type is
244 -- constrained, then 'Write will be used to output the object,
245 -- If the type is unconstrained, 'Output will be used.
247 function Pack_Node_Into_Stream
251 Etyp : Entity_Id) return Node_Id;
252 -- Similar to above, with an arbitrary node instead of an entity
254 function Pack_Node_Into_Stream_Access
258 Etyp : Entity_Id) return Node_Id;
259 -- Similar to above, with Stream instead of Stream'Access
261 function Make_Selected_Component
264 Selector_Name : Name_Id) return Node_Id;
265 -- Return a selected_component whose prefix denotes the given entity, and
266 -- with the given Selector_Name.
268 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
269 -- Return the scope represented by a given spec
271 procedure Set_Renaming_TSS
274 TSS_Nam : TSS_Name_Type);
275 -- Create a renaming declaration of subprogram Nam, and register it as a
276 -- TSS for Typ with name TSS_Nam.
278 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
279 -- Return True if the current parameter needs an extra formal to reflect
280 -- its constrained status.
282 function Is_RACW_Controlling_Formal
283 (Parameter : Node_Id;
284 Stub_Type : Entity_Id) return Boolean;
285 -- Return True if the current parameter is a controlling formal argument
286 -- of type Stub_Type or access to Stub_Type.
288 procedure Declare_Create_NVList
293 -- Append the declaration of NVList to Decls, and its
294 -- initialization to Stmts.
296 function Add_Parameter_To_NVList
299 Parameter : Entity_Id;
300 Constrained : Boolean;
301 RACW_Ctrl : Boolean := False;
302 Any : Entity_Id) return Node_Id;
303 -- Return a call to Add_Item to add the Any corresponding to the designated
304 -- formal Parameter (with the indicated Constrained status) to NVList.
305 -- RACW_Ctrl must be set to True for controlling formals of distributed
306 -- object primitive operations.
312 -- This record describes various tree fragments associated with the
313 -- generation of RACW calling stubs. One such record exists for every
314 -- distributed object type, i.e. each tagged type that is the designated
315 -- type of one or more RACW type.
317 type Stub_Structure is record
318 Stub_Type : Entity_Id;
319 -- Stub type: this type has the same primitive operations as the
320 -- designated types, but the provided bodies for these operations
321 -- a remote call to an actual target object potentially located on
322 -- another partition; each value of the stub type encapsulates a
323 -- reference to a remote object.
325 Stub_Type_Access : Entity_Id;
326 -- A local access type designating the stub type (this is not an RACW
329 RPC_Receiver_Decl : Node_Id;
330 -- Declaration for the RPC receiver entity associated with the
331 -- designated type. As an exception, for the case of an RACW that
332 -- implements a RAS, no object RPC receiver is generated. Instead,
333 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
334 -- would have been inserted.
336 Body_Decls : List_Id;
337 -- List of subprogram bodies to be included in generated code: bodies
338 -- for the RACW's stream attributes, and for the primitive operations
341 RACW_Type : Entity_Id;
342 -- One of the RACW types designating this distributed object type
343 -- (they are all interchangeable; we use any one of them in order to
344 -- avoid having to create various anonymous access types).
348 Empty_Stub_Structure : constant Stub_Structure :=
349 (Empty, Empty, Empty, No_List, Empty);
351 package Stubs_Table is
352 new Simple_HTable (Header_Num => Hash_Index,
353 Element => Stub_Structure,
354 No_Element => Empty_Stub_Structure,
358 -- Mapping between a RACW designated type and its stub type
360 package Asynchronous_Flags_Table is
361 new Simple_HTable (Header_Num => Hash_Index,
362 Element => Entity_Id,
367 -- Mapping between a RACW type and a constant having the value True
368 -- if the RACW is asynchronous and False otherwise.
370 package RCI_Locator_Table is
371 new Simple_HTable (Header_Num => Hash_Index,
372 Element => Entity_Id,
377 -- Mapping between a RCI package on which All_Calls_Remote applies and
378 -- the generic instantiation of RCI_Locator for this package.
380 package RCI_Calling_Stubs_Table is
381 new Simple_HTable (Header_Num => Hash_Index,
382 Element => Entity_Id,
387 -- Mapping between a RCI subprogram and the corresponding calling stubs
389 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure;
390 -- Return the stub information associated with the given RACW type
392 procedure Add_Stub_Type
393 (Designated_Type : Entity_Id;
394 RACW_Type : Entity_Id;
396 Stub_Type : out Entity_Id;
397 Stub_Type_Access : out Entity_Id;
398 RPC_Receiver_Decl : out Node_Id;
399 Body_Decls : out List_Id;
400 Existing : out Boolean);
401 -- Add the declaration of the stub type, the access to stub type and the
402 -- object RPC receiver at the end of Decls. If these already exist,
403 -- then nothing is added in the tree but the right values are returned
404 -- anyhow and Existing is set to True.
406 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
407 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
408 -- structure table, reset it to No_List, and return the previous value.
410 procedure Add_RACW_Asynchronous_Flag
411 (Declarations : List_Id;
412 RACW_Type : Entity_Id);
413 -- Declare a boolean constant associated with RACW_Type whose value
414 -- indicates at run time whether a pragma Asynchronous applies to it.
416 procedure Assign_Subprogram_Identifier
420 -- Determine the distribution subprogram identifier to
421 -- be used for remote subprogram Def, return it in Id and
422 -- store it in a hash table for later retrieval by
423 -- Get_Subprogram_Id. Spn is the subprogram number.
425 function RCI_Package_Locator
427 Package_Spec : Node_Id) return Node_Id;
428 -- Instantiate the generic package RCI_Locator in order to locate the
429 -- RCI package whose spec is given as argument.
431 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
432 -- Surround a node N by a tag check, as in:
436 -- when E : Ada.Tags.Tag_Error =>
437 -- Raise_Exception (Program_Error'Identity,
438 -- Exception_Message (E));
441 function Input_With_Tag_Check
443 Var_Type : Entity_Id;
444 Stream : Node_Id) return Node_Id;
445 -- Return a function with the following form:
446 -- function R return Var_Type is
448 -- return Var_Type'Input (S);
450 -- when E : Ada.Tags.Tag_Error =>
451 -- Raise_Exception (Program_Error'Identity,
452 -- Exception_Message (E));
455 procedure Build_Actual_Object_Declaration
461 -- Build the declaration of an object with the given defining identifier,
462 -- initialized with Expr if provided, to serve as actual parameter in a
463 -- server stub. If Variable is true, the declared object will be a variable
464 -- (case of an out or in out formal), else it will be a constant. Object's
465 -- Ekind is set accordingly. The declaration, as well as any other
466 -- declarations it requires, are appended to Decls.
468 --------------------------------------------
469 -- Hooks for PCS-specific code generation --
470 --------------------------------------------
472 -- Part of the code generation circuitry for distribution needs to be
473 -- tailored for each implementation of the PCS. For each routine that
474 -- needs to be specialized, a Specific_<routine> wrapper is created,
475 -- which calls the corresponding <routine> in package
476 -- <pcs_implementation>_Support.
478 procedure Specific_Add_RACW_Features
479 (RACW_Type : Entity_Id;
481 Stub_Type : Entity_Id;
482 Stub_Type_Access : Entity_Id;
483 RPC_Receiver_Decl : Node_Id;
484 Body_Decls : List_Id);
485 -- Add declaration for TSSs for a given RACW type. The declarations are
486 -- added just after the declaration of the RACW type itself. If the RACW
487 -- appears in the main unit, Body_Decls is a list of declarations to which
488 -- the bodies are appended. Else Body_Decls is No_List.
489 -- PCS-specific ancillary subprogram for Add_RACW_Features.
491 procedure Specific_Add_RAST_Features
493 RAS_Type : Entity_Id);
494 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
495 -- subprogram for Add_RAST_Features.
497 -- An RPC_Target record is used during construction of calling stubs
498 -- to pass PCS-specific tree fragments corresponding to the information
499 -- necessary to locate the target of a remote subprogram call.
501 type RPC_Target (PCS_Kind : PCS_Names) is record
503 when Name_PolyORB_DSA =>
505 -- An expression whose value is a PolyORB reference to the target
509 Partition : Entity_Id;
510 -- A variable containing the Partition_ID of the target partition
512 RPC_Receiver : Node_Id;
513 -- An expression whose value is the address of the target RPC
518 procedure Specific_Build_General_Calling_Stubs
520 Statements : List_Id;
522 Subprogram_Id : Node_Id;
523 Asynchronous : Node_Id := Empty;
524 Is_Known_Asynchronous : Boolean := False;
525 Is_Known_Non_Asynchronous : Boolean := False;
526 Is_Function : Boolean;
528 Stub_Type : Entity_Id := Empty;
529 RACW_Type : Entity_Id := Empty;
531 -- Build calling stubs for general purpose. The parameters are:
532 -- Decls : a place to put declarations
533 -- Statements : a place to put statements
534 -- Target : PCS-specific target information (see details
535 -- in RPC_Target declaration).
536 -- Subprogram_Id : a node containing the subprogram ID
537 -- Asynchronous : True if an APC must be made instead of an RPC.
538 -- The value needs not be supplied if one of the
539 -- Is_Known_... is True.
540 -- Is_Known_Async... : True if we know that this is asynchronous
541 -- Is_Known_Non_A... : True if we know that this is not asynchronous
542 -- Spec : a node with a Parameter_Specifications and
543 -- a Result_Definition if applicable
544 -- Stub_Type : in case of RACW stubs, parameters of type access
545 -- to Stub_Type will be marshalled using the
546 -- address of the object (the addr field) rather
547 -- than using the 'Write on the stub itself
548 -- Nod : used to provide sloc for generated code
550 function Specific_Build_Stub_Target
553 RCI_Locator : Entity_Id;
554 Controlling_Parameter : Entity_Id) return RPC_Target;
555 -- Build call target information nodes for use within calling stubs. In the
556 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
557 -- for an RACW, Controlling_Parameter is the entity for the controlling
558 -- formal parameter used to determine the location of the target of the
559 -- call. Decls provides a location where variable declarations can be
560 -- appended to construct the necessary values.
562 procedure Specific_Build_Stub_Type
563 (RACW_Type : Entity_Id;
564 Stub_Type_Comps : out List_Id;
565 RPC_Receiver_Decl : out Node_Id);
566 -- Build a components list for the stub type associated with an RACW type,
567 -- and build the necessary RPC receiver, if applicable. PCS-specific
568 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
569 -- is generated, then RPC_Receiver_Decl is set to Empty.
571 procedure Specific_Build_RPC_Receiver_Body
572 (RPC_Receiver : Entity_Id;
573 Request : out Entity_Id;
574 Subp_Id : out Entity_Id;
575 Subp_Index : out Entity_Id;
578 -- Make a subprogram body for an RPC receiver, with the given
579 -- defining unit name. On return:
580 -- - Subp_Id is the subprogram identifier from the PCS.
581 -- - Subp_Index is the index in the list of subprograms
582 -- used for dispatching (a variable of type Subprogram_Id).
583 -- - Stmts is the place where the request dispatching
584 -- statements can occur,
585 -- - Decl is the subprogram body declaration.
587 function Specific_Build_Subprogram_Receiving_Stubs
589 Asynchronous : Boolean;
590 Dynamically_Asynchronous : Boolean := False;
591 Stub_Type : Entity_Id := Empty;
592 RACW_Type : Entity_Id := Empty;
593 Parent_Primitive : Entity_Id := Empty) return Node_Id;
594 -- Build the receiving stub for a given subprogram. The subprogram
595 -- declaration is also built by this procedure, and the value returned
596 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
597 -- found in the specification, then its address is read from the stream
598 -- instead of the object itself and converted into an access to
599 -- class-wide type before doing the real call using any of the RACW type
600 -- pointing on the designated type.
602 procedure Specific_Add_Obj_RPC_Receiver_Completion
605 RPC_Receiver : Entity_Id;
606 Stub_Elements : Stub_Structure);
607 -- Add the necessary code to Decls after the completion of generation
608 -- of the RACW RPC receiver described by Stub_Elements.
610 procedure Specific_Add_Receiving_Stubs_To_Declarations
614 -- Add receiving stubs to the declarative part of an RCI unit
620 package GARLIC_Support is
622 -- Support for generating DSA code that uses the GARLIC PCS
624 -- The subprograms below provide the GARLIC versions of the
625 -- corresponding Specific_<subprogram> routine declared above.
627 procedure Add_RACW_Features
628 (RACW_Type : Entity_Id;
629 Stub_Type : Entity_Id;
630 Stub_Type_Access : Entity_Id;
631 RPC_Receiver_Decl : Node_Id;
632 Body_Decls : List_Id);
634 procedure Add_RAST_Features
636 RAS_Type : Entity_Id);
638 procedure Build_General_Calling_Stubs
640 Statements : List_Id;
641 Target_Partition : Entity_Id; -- From RPC_Target
642 Target_RPC_Receiver : Node_Id; -- From RPC_Target
643 Subprogram_Id : Node_Id;
644 Asynchronous : Node_Id := Empty;
645 Is_Known_Asynchronous : Boolean := False;
646 Is_Known_Non_Asynchronous : Boolean := False;
647 Is_Function : Boolean;
649 Stub_Type : Entity_Id := Empty;
650 RACW_Type : Entity_Id := Empty;
653 function Build_Stub_Target
656 RCI_Locator : Entity_Id;
657 Controlling_Parameter : Entity_Id) return RPC_Target;
659 procedure Build_Stub_Type
660 (RACW_Type : Entity_Id;
661 Stub_Type_Comps : out List_Id;
662 RPC_Receiver_Decl : out Node_Id);
664 function Build_Subprogram_Receiving_Stubs
666 Asynchronous : Boolean;
667 Dynamically_Asynchronous : Boolean := False;
668 Stub_Type : Entity_Id := Empty;
669 RACW_Type : Entity_Id := Empty;
670 Parent_Primitive : Entity_Id := Empty) return Node_Id;
672 procedure Add_Obj_RPC_Receiver_Completion
675 RPC_Receiver : Entity_Id;
676 Stub_Elements : Stub_Structure);
678 procedure Add_Receiving_Stubs_To_Declarations
683 procedure Build_RPC_Receiver_Body
684 (RPC_Receiver : Entity_Id;
685 Request : out Entity_Id;
686 Subp_Id : out Entity_Id;
687 Subp_Index : out Entity_Id;
693 ---------------------
694 -- PolyORB_Support --
695 ---------------------
697 package PolyORB_Support is
699 -- Support for generating DSA code that uses the PolyORB PCS
701 -- The subprograms below provide the PolyORB versions of the
702 -- corresponding Specific_<subprogram> routine declared above.
704 procedure Add_RACW_Features
705 (RACW_Type : Entity_Id;
707 Stub_Type : Entity_Id;
708 Stub_Type_Access : Entity_Id;
709 RPC_Receiver_Decl : Node_Id;
710 Body_Decls : List_Id);
712 procedure Add_RAST_Features
714 RAS_Type : Entity_Id);
716 procedure Build_General_Calling_Stubs
718 Statements : List_Id;
719 Target_Object : Node_Id; -- From RPC_Target
720 Subprogram_Id : Node_Id;
721 Asynchronous : Node_Id := Empty;
722 Is_Known_Asynchronous : Boolean := False;
723 Is_Known_Non_Asynchronous : Boolean := False;
724 Is_Function : Boolean;
726 Stub_Type : Entity_Id := Empty;
727 RACW_Type : Entity_Id := Empty;
730 function Build_Stub_Target
733 RCI_Locator : Entity_Id;
734 Controlling_Parameter : Entity_Id) return RPC_Target;
736 procedure Build_Stub_Type
737 (RACW_Type : Entity_Id;
738 Stub_Type_Comps : out List_Id;
739 RPC_Receiver_Decl : out Node_Id);
741 function Build_Subprogram_Receiving_Stubs
743 Asynchronous : Boolean;
744 Dynamically_Asynchronous : Boolean := False;
745 Stub_Type : Entity_Id := Empty;
746 RACW_Type : Entity_Id := Empty;
747 Parent_Primitive : Entity_Id := Empty) return Node_Id;
749 procedure Add_Obj_RPC_Receiver_Completion
752 RPC_Receiver : Entity_Id;
753 Stub_Elements : Stub_Structure);
755 procedure Add_Receiving_Stubs_To_Declarations
760 procedure Build_RPC_Receiver_Body
761 (RPC_Receiver : Entity_Id;
762 Request : out Entity_Id;
763 Subp_Id : out Entity_Id;
764 Subp_Index : out Entity_Id;
768 procedure Reserve_NamingContext_Methods;
769 -- Mark the method names for interface NamingContext as already used in
770 -- the overload table, so no clashes occur with user code (with the
771 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
772 -- their methods to be accessed as objects, for the implementation of
773 -- remote access-to-subprogram types).
781 -- Routines to build distribution helper subprograms for user-defined
782 -- types. For implementation of the Distributed systems annex (DSA)
783 -- over the PolyORB generic middleware components, it is necessary to
784 -- generate several supporting subprograms for each application data
785 -- type used in inter-partition communication. These subprograms are:
787 -- A Typecode function returning a high-level description of the
790 -- Two conversion functions allowing conversion of values of the
791 -- type from and to the generic data containers used by PolyORB.
792 -- These generic containers are called 'Any' type values after the
793 -- CORBA terminology, and hence the conversion subprograms are
794 -- named To_Any and From_Any.
796 function Build_From_Any_Call
799 Decls : List_Id) return Node_Id;
800 -- Build call to From_Any attribute function of type Typ with
801 -- expression N as actual parameter. Decls is the declarations list
802 -- for an appropriate enclosing scope of the point where the call
803 -- will be inserted; if the From_Any attribute for Typ needs to be
804 -- generated at this point, its declaration is appended to Decls.
806 procedure Build_From_Any_Function
810 Fnam : out Entity_Id);
811 -- Build From_Any attribute function for Typ. Loc is the reference
812 -- location for generated nodes, Typ is the type for which the
813 -- conversion function is generated. On return, Decl and Fnam contain
814 -- the declaration and entity for the newly-created function.
816 function Build_To_Any_Call
818 Decls : List_Id) return Node_Id;
819 -- Build call to To_Any attribute function with expression as actual
820 -- parameter. Decls is the declarations list for an appropriate
821 -- enclosing scope of the point where the call will be inserted; if
822 -- the To_Any attribute for Typ needs to be generated at this point,
823 -- its declaration is appended to Decls.
825 procedure Build_To_Any_Function
829 Fnam : out Entity_Id);
830 -- Build To_Any attribute function for Typ. Loc is the reference
831 -- location for generated nodes, Typ is the type for which the
832 -- conversion function is generated. On return, Decl and Fnam contain
833 -- the declaration and entity for the newly-created function.
835 function Build_TypeCode_Call
838 Decls : List_Id) return Node_Id;
839 -- Build call to TypeCode attribute function for Typ. Decls is the
840 -- declarations list for an appropriate enclosing scope of the point
841 -- where the call will be inserted; if the To_Any attribute for Typ
842 -- needs to be generated at this point, its declaration is appended
845 procedure Build_TypeCode_Function
849 Fnam : out Entity_Id);
850 -- Build TypeCode attribute function for Typ. Loc is the reference
851 -- location for generated nodes, Typ is the type for which the
852 -- conversion function is generated. On return, Decl and Fnam contain
853 -- the declaration and entity for the newly-created function.
855 procedure Build_Name_And_Repository_Id
857 Name_Str : out String_Id;
858 Repo_Id_Str : out String_Id);
859 -- In the PolyORB distribution model, each distributed object type
860 -- and each distributed operation has a globally unique identifier,
861 -- its Repository Id. This subprogram builds and returns two strings
862 -- for entity E (a distributed object type or operation): one
863 -- containing the name of E, the second containing its repository id.
865 procedure Assign_Opaque_From_Any
871 -- For a Target object of type Typ, which has opaque representation
872 -- as a sequence of octets determined by stream attributes (which
873 -- includes all limited types), append code to Stmts performing the
875 -- Target := Typ'From_Any (N)
877 -- or, if Target is Empty:
878 -- return Typ'From_Any (N)
884 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
886 function Build_From_Any_Call
889 Decls : List_Id) return Node_Id
890 renames PolyORB_Support.Helpers.Build_From_Any_Call;
892 function Build_To_Any_Call
894 Decls : List_Id) return Node_Id
895 renames PolyORB_Support.Helpers.Build_To_Any_Call;
897 function Build_TypeCode_Call
900 Decls : List_Id) return Node_Id
901 renames PolyORB_Support.Helpers.Build_TypeCode_Call;
903 ------------------------------------
904 -- Local variables and structures --
905 ------------------------------------
908 -- Needs comments ???
910 Output_From_Constrained : constant array (Boolean) of Name_Id :=
911 (False => Name_Output,
913 -- The attribute to choose depending on the fact that the parameter
914 -- is constrained or not. There is no such thing as Input_From_Constrained
915 -- since this require separate mechanisms ('Input is a function while
916 -- 'Read is a procedure).
918 ---------------------------------------
919 -- Add_Calling_Stubs_To_Declarations --
920 ---------------------------------------
922 procedure Add_Calling_Stubs_To_Declarations
926 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
927 -- Subprogram id 0 is reserved for calls received from
928 -- remote access-to-subprogram dereferences.
930 Current_Declaration : Node_Id;
931 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
932 RCI_Instantiation : Node_Id;
933 Subp_Stubs : Node_Id;
934 Subp_Str : String_Id;
936 pragma Warnings (Off, Subp_Str);
939 -- The first thing added is an instantiation of the generic package
940 -- System.Partition_Interface.RCI_Locator with the name of this remote
941 -- package. This will act as an interface with the name server to
942 -- determine the Partition_ID and the RPC_Receiver for the receiver
945 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
946 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
948 Append_To (Decls, RCI_Instantiation);
949 Analyze (RCI_Instantiation);
951 -- For each subprogram declaration visible in the spec, we do build a
952 -- body. We also increment a counter to assign a different Subprogram_Id
953 -- to each subprograms. The receiving stubs processing do use the same
954 -- mechanism and will thus assign the same Id and do the correct
957 Overload_Counter_Table.Reset;
958 PolyORB_Support.Reserve_NamingContext_Methods;
960 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
961 while Present (Current_Declaration) loop
962 if Nkind (Current_Declaration) = N_Subprogram_Declaration
963 and then Comes_From_Source (Current_Declaration)
965 Assign_Subprogram_Identifier
966 (Defining_Unit_Name (Specification (Current_Declaration)),
967 Current_Subprogram_Number,
971 Build_Subprogram_Calling_Stubs (
972 Vis_Decl => Current_Declaration,
974 Build_Subprogram_Id (Loc,
975 Defining_Unit_Name (Specification (Current_Declaration))),
977 Nkind (Specification (Current_Declaration)) =
978 N_Procedure_Specification
980 Is_Asynchronous (Defining_Unit_Name (Specification
981 (Current_Declaration))));
983 Append_To (Decls, Subp_Stubs);
984 Analyze (Subp_Stubs);
986 Current_Subprogram_Number := Current_Subprogram_Number + 1;
989 Next (Current_Declaration);
991 end Add_Calling_Stubs_To_Declarations;
993 -----------------------------
994 -- Add_Parameter_To_NVList --
995 -----------------------------
997 function Add_Parameter_To_NVList
1000 Parameter : Entity_Id;
1001 Constrained : Boolean;
1002 RACW_Ctrl : Boolean := False;
1003 Any : Entity_Id) return Node_Id
1005 Parameter_Name_String : String_Id;
1006 Parameter_Mode : Node_Id;
1008 function Parameter_Passing_Mode
1010 Parameter : Entity_Id;
1011 Constrained : Boolean) return Node_Id;
1012 -- Return an expression that denotes the parameter passing mode to be
1013 -- used for Parameter in distribution stubs, where Constrained is
1014 -- Parameter's constrained status.
1016 ----------------------------
1017 -- Parameter_Passing_Mode --
1018 ----------------------------
1020 function Parameter_Passing_Mode
1022 Parameter : Entity_Id;
1023 Constrained : Boolean) return Node_Id
1028 if Out_Present (Parameter) then
1029 if In_Present (Parameter)
1030 or else not Constrained
1032 -- Unconstrained formals must be translated
1033 -- to 'in' or 'inout', not 'out', because
1034 -- they need to be constrained by the actual.
1036 Lib_RE := RE_Mode_Inout;
1038 Lib_RE := RE_Mode_Out;
1042 Lib_RE := RE_Mode_In;
1045 return New_Occurrence_Of (RTE (Lib_RE), Loc);
1046 end Parameter_Passing_Mode;
1048 -- Start of processing for Add_Parameter_To_NVList
1051 if Nkind (Parameter) = N_Defining_Identifier then
1052 Get_Name_String (Chars (Parameter));
1054 Get_Name_String (Chars (Defining_Identifier (Parameter)));
1057 Parameter_Name_String := String_From_Name_Buffer;
1059 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1061 -- When the parameter passed to Add_Parameter_To_NVList is an
1062 -- Extra_Constrained parameter, Parameter is an N_Defining_
1063 -- Identifier, instead of a complete N_Parameter_Specification.
1064 -- Thus, we explicitly set 'in' mode in this case.
1066 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1070 Parameter_Passing_Mode (Loc, Parameter, Constrained);
1074 Make_Procedure_Call_Statement (Loc,
1077 (RTE (RE_NVList_Add_Item), Loc),
1078 Parameter_Associations => New_List (
1079 New_Occurrence_Of (NVList, Loc),
1080 Make_Function_Call (Loc,
1083 (RTE (RE_To_PolyORB_String), Loc),
1084 Parameter_Associations => New_List (
1085 Make_String_Literal (Loc,
1086 Strval => Parameter_Name_String))),
1087 New_Occurrence_Of (Any, Loc),
1089 end Add_Parameter_To_NVList;
1091 --------------------------------
1092 -- Add_RACW_Asynchronous_Flag --
1093 --------------------------------
1095 procedure Add_RACW_Asynchronous_Flag
1096 (Declarations : List_Id;
1097 RACW_Type : Entity_Id)
1099 Loc : constant Source_Ptr := Sloc (RACW_Type);
1101 Asynchronous_Flag : constant Entity_Id :=
1102 Make_Defining_Identifier (Loc,
1103 New_External_Name (Chars (RACW_Type), 'A'));
1106 -- Declare the asynchronous flag. This flag will be changed to True
1107 -- whenever it is known that the RACW type is asynchronous.
1109 Append_To (Declarations,
1110 Make_Object_Declaration (Loc,
1111 Defining_Identifier => Asynchronous_Flag,
1112 Constant_Present => True,
1113 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1114 Expression => New_Occurrence_Of (Standard_False, Loc)));
1116 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1117 end Add_RACW_Asynchronous_Flag;
1119 -----------------------
1120 -- Add_RACW_Features --
1121 -----------------------
1123 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1124 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1125 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1129 Body_Decls : List_Id;
1131 Stub_Type : Entity_Id;
1132 Stub_Type_Access : Entity_Id;
1133 RPC_Receiver_Decl : Node_Id;
1136 -- True when appropriate stubs have already been generated (this is the
1137 -- case when another RACW with the same designated type has already been
1138 -- encountered), in which case we reuse the previous stubs rather than
1139 -- generating new ones.
1142 if not Expander_Active then
1146 -- Mark the current package declaration as containing an RACW, so that
1147 -- the bodies for the calling stubs and the RACW stream subprograms
1148 -- are attached to the tree when the corresponding body is encountered.
1150 Set_Has_RACW (Current_Scope);
1152 -- Look for place to declare the RACW stub type and RACW operations
1158 -- Case of declaring the RACW in the same package as its designated
1159 -- type: we know that the designated type is a private type, so we
1160 -- use the private declarations list.
1162 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1164 if Present (Private_Declarations (Pkg_Spec)) then
1165 Decls := Private_Declarations (Pkg_Spec);
1167 Decls := Visible_Declarations (Pkg_Spec);
1171 -- Case of declaring the RACW in another package than its designated
1172 -- type: use the private declarations list if present; otherwise
1173 -- use the visible declarations.
1175 Decls := List_Containing (Declaration_Node (RACW_Type));
1179 -- If we were unable to find the declarations, that means that the
1180 -- completion of the type was missing. We can safely return and let the
1181 -- error be caught by the semantic analysis.
1188 (Designated_Type => Desig,
1189 RACW_Type => RACW_Type,
1191 Stub_Type => Stub_Type,
1192 Stub_Type_Access => Stub_Type_Access,
1193 RPC_Receiver_Decl => RPC_Receiver_Decl,
1194 Body_Decls => Body_Decls,
1195 Existing => Existing);
1197 -- If this RACW is not in the main unit, do not generate primitive or
1200 if not Entity_Is_In_Main_Unit (RACW_Type) then
1201 Body_Decls := No_List;
1204 Add_RACW_Asynchronous_Flag
1205 (Declarations => Decls,
1206 RACW_Type => RACW_Type);
1208 Specific_Add_RACW_Features
1209 (RACW_Type => RACW_Type,
1211 Stub_Type => Stub_Type,
1212 Stub_Type_Access => Stub_Type_Access,
1213 RPC_Receiver_Decl => RPC_Receiver_Decl,
1214 Body_Decls => Body_Decls);
1216 -- If we already have stubs for this designated type, nothing to do
1222 if Is_Frozen (Desig) then
1223 Validate_RACW_Primitives (RACW_Type);
1224 Add_RACW_Primitive_Declarations_And_Bodies
1225 (Designated_Type => Desig,
1226 Insertion_Node => RPC_Receiver_Decl,
1227 Body_Decls => Body_Decls);
1230 -- Validate_RACW_Primitives requires the list of all primitives of
1231 -- the designated type, so defer processing until Desig is frozen.
1232 -- See Exp_Ch3.Freeze_Type.
1234 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1236 end Add_RACW_Features;
1238 ------------------------------------------------
1239 -- Add_RACW_Primitive_Declarations_And_Bodies --
1240 ------------------------------------------------
1242 procedure Add_RACW_Primitive_Declarations_And_Bodies
1243 (Designated_Type : Entity_Id;
1244 Insertion_Node : Node_Id;
1245 Body_Decls : List_Id)
1247 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1248 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1249 -- the declarations are recognized as belonging to the current package.
1251 Stub_Elements : constant Stub_Structure :=
1252 Stubs_Table.Get (Designated_Type);
1254 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1256 Is_RAS : constant Boolean :=
1257 not Comes_From_Source (Stub_Elements.RACW_Type);
1258 -- Case of the RACW generated to implement a remote access-to-
1261 Build_Bodies : constant Boolean :=
1262 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1263 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1264 -- only when the main unit is the unit that contains the stub type.
1266 Current_Insertion_Node : Node_Id := Insertion_Node;
1268 RPC_Receiver : Entity_Id;
1269 RPC_Receiver_Statements : List_Id;
1270 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1271 RPC_Receiver_Elsif_Parts : List_Id;
1272 RPC_Receiver_Request : Entity_Id;
1273 RPC_Receiver_Subp_Id : Entity_Id;
1274 RPC_Receiver_Subp_Index : Entity_Id;
1276 Subp_Str : String_Id;
1278 Current_Primitive_Elmt : Elmt_Id;
1279 Current_Primitive : Entity_Id;
1280 Current_Primitive_Body : Node_Id;
1281 Current_Primitive_Spec : Node_Id;
1282 Current_Primitive_Decl : Node_Id;
1283 Current_Primitive_Number : Int := 0;
1284 Current_Primitive_Alias : Node_Id;
1285 Current_Receiver : Entity_Id;
1286 Current_Receiver_Body : Node_Id;
1287 RPC_Receiver_Decl : Node_Id;
1288 Possibly_Asynchronous : Boolean;
1291 if not Expander_Active then
1297 Make_Defining_Identifier (Loc,
1298 Chars => New_Internal_Name ('P'));
1300 Specific_Build_RPC_Receiver_Body
1301 (RPC_Receiver => RPC_Receiver,
1302 Request => RPC_Receiver_Request,
1303 Subp_Id => RPC_Receiver_Subp_Id,
1304 Subp_Index => RPC_Receiver_Subp_Index,
1305 Stmts => RPC_Receiver_Statements,
1306 Decl => RPC_Receiver_Decl);
1308 if Get_PCS_Name = Name_PolyORB_DSA then
1310 -- For the case of PolyORB, we need to map a textual operation
1311 -- name into a primitive index. Currently we do so using a simple
1312 -- sequence of string comparisons.
1314 RPC_Receiver_Elsif_Parts := New_List;
1318 -- Build callers, receivers for every primitive operations and a RPC
1319 -- receiver for this type.
1321 if Present (Primitive_Operations (Designated_Type)) then
1322 Overload_Counter_Table.Reset;
1324 Current_Primitive_Elmt :=
1325 First_Elmt (Primitive_Operations (Designated_Type));
1326 while Current_Primitive_Elmt /= No_Elmt loop
1327 Current_Primitive := Node (Current_Primitive_Elmt);
1329 -- Copy the primitive of all the parents, except predefined ones
1330 -- that are not remotely dispatching. Also omit hidden primitives
1331 -- (occurs in the case of primitives of interface progenitors
1332 -- other than immediate ancestors of the Designated_Type).
1334 if Chars (Current_Primitive) /= Name_uSize
1335 and then Chars (Current_Primitive) /= Name_uAlignment
1337 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1338 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1339 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1340 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1341 Is_TSS (Current_Primitive, TSS_Stream_Write) or else
1342 Is_Predefined_Interface_Primitive (Current_Primitive))
1343 and then not Is_Hidden (Current_Primitive)
1345 -- The first thing to do is build an up-to-date copy of the
1346 -- spec with all the formals referencing Controlling_Type
1347 -- transformed into formals referencing Stub_Type. Since this
1348 -- primitive may have been inherited, go back the alias chain
1349 -- until the real primitive has been found.
1351 Current_Primitive_Alias := Current_Primitive;
1352 while Present (Alias (Current_Primitive_Alias)) loop
1354 (Current_Primitive_Alias
1355 /= Alias (Current_Primitive_Alias));
1356 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
1359 -- Copy the spec from the original declaration for the purpose
1360 -- of declaring an overriding subprogram: we need to replace
1361 -- the type of each controlling formal with Stub_Type. The
1362 -- primitive may have been declared for Controlling_Type or
1363 -- inherited from some ancestor type for which we do not have
1364 -- an easily determined Entity_Id. We have no systematic way
1365 -- of knowing which type to substitute Stub_Type for. Instead,
1366 -- Copy_Specification relies on the flag Is_Controlling_Formal
1367 -- to determine which formals to change.
1369 Current_Primitive_Spec :=
1370 Copy_Specification (Loc,
1371 Spec => Parent (Current_Primitive_Alias),
1372 Ctrl_Type => Stub_Elements.Stub_Type);
1374 Current_Primitive_Decl :=
1375 Make_Subprogram_Declaration (Loc,
1376 Specification => Current_Primitive_Spec);
1378 Insert_After_And_Analyze (Current_Insertion_Node,
1379 Current_Primitive_Decl);
1380 Current_Insertion_Node := Current_Primitive_Decl;
1382 Possibly_Asynchronous :=
1383 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1384 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1386 Assign_Subprogram_Identifier (
1387 Defining_Unit_Name (Current_Primitive_Spec),
1388 Current_Primitive_Number,
1391 if Build_Bodies then
1392 Current_Primitive_Body :=
1393 Build_Subprogram_Calling_Stubs
1394 (Vis_Decl => Current_Primitive_Decl,
1396 Build_Subprogram_Id (Loc,
1397 Defining_Unit_Name (Current_Primitive_Spec)),
1398 Asynchronous => Possibly_Asynchronous,
1399 Dynamically_Asynchronous => Possibly_Asynchronous,
1400 Stub_Type => Stub_Elements.Stub_Type,
1401 RACW_Type => Stub_Elements.RACW_Type);
1402 Append_To (Body_Decls, Current_Primitive_Body);
1404 -- Analyzing the body here would cause the Stub type to
1405 -- be frozen, thus preventing subsequent primitive
1406 -- declarations. For this reason, it will be analyzed
1407 -- later in the regular flow (and in the context of the
1408 -- appropriate unit body, see Append_RACW_Bodies).
1412 -- Build the receiver stubs
1414 if Build_Bodies and then not Is_RAS then
1415 Current_Receiver_Body :=
1416 Specific_Build_Subprogram_Receiving_Stubs
1417 (Vis_Decl => Current_Primitive_Decl,
1418 Asynchronous => Possibly_Asynchronous,
1419 Dynamically_Asynchronous => Possibly_Asynchronous,
1420 Stub_Type => Stub_Elements.Stub_Type,
1421 RACW_Type => Stub_Elements.RACW_Type,
1422 Parent_Primitive => Current_Primitive);
1424 Current_Receiver := Defining_Unit_Name (
1425 Specification (Current_Receiver_Body));
1427 Append_To (Body_Decls, Current_Receiver_Body);
1429 -- Add a case alternative to the receiver
1431 if Get_PCS_Name = Name_PolyORB_DSA then
1432 Append_To (RPC_Receiver_Elsif_Parts,
1433 Make_Elsif_Part (Loc,
1435 Make_Function_Call (Loc,
1438 RTE (RE_Caseless_String_Eq), Loc),
1439 Parameter_Associations => New_List (
1440 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1441 Make_String_Literal (Loc, Subp_Str))),
1443 Then_Statements => New_List (
1444 Make_Assignment_Statement (Loc,
1445 Name => New_Occurrence_Of (
1446 RPC_Receiver_Subp_Index, Loc),
1448 Make_Integer_Literal (Loc,
1449 Intval => Current_Primitive_Number)))));
1452 Append_To (RPC_Receiver_Case_Alternatives,
1453 Make_Case_Statement_Alternative (Loc,
1454 Discrete_Choices => New_List (
1455 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1457 Statements => New_List (
1458 Make_Procedure_Call_Statement (Loc,
1460 New_Occurrence_Of (Current_Receiver, Loc),
1461 Parameter_Associations => New_List (
1462 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1465 -- Increment the index of current primitive
1467 Current_Primitive_Number := Current_Primitive_Number + 1;
1470 Next_Elmt (Current_Primitive_Elmt);
1474 -- Build the case statement and the heart of the subprogram
1476 if Build_Bodies and then not Is_RAS then
1477 if Get_PCS_Name = Name_PolyORB_DSA
1478 and then Present (First (RPC_Receiver_Elsif_Parts))
1480 Append_To (RPC_Receiver_Statements,
1481 Make_Implicit_If_Statement (Designated_Type,
1482 Condition => New_Occurrence_Of (Standard_False, Loc),
1483 Then_Statements => New_List,
1484 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1487 Append_To (RPC_Receiver_Case_Alternatives,
1488 Make_Case_Statement_Alternative (Loc,
1489 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1490 Statements => New_List (Make_Null_Statement (Loc))));
1492 Append_To (RPC_Receiver_Statements,
1493 Make_Case_Statement (Loc,
1495 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1496 Alternatives => RPC_Receiver_Case_Alternatives));
1498 Append_To (Body_Decls, RPC_Receiver_Decl);
1499 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1500 Body_Decls, RPC_Receiver, Stub_Elements);
1502 -- Do not analyze RPC receiver body at this stage since it references
1503 -- subprograms that have not been analyzed yet. It will be analyzed in
1504 -- the regular flow (see Append_RACW_Bodies).
1507 end Add_RACW_Primitive_Declarations_And_Bodies;
1509 -----------------------------
1510 -- Add_RAS_Dereference_TSS --
1511 -----------------------------
1513 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1514 Loc : constant Source_Ptr := Sloc (N);
1516 Type_Def : constant Node_Id := Type_Definition (N);
1517 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1518 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1519 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1521 RACW_Primitive_Name : Node_Id;
1523 Proc : constant Entity_Id :=
1524 Make_Defining_Identifier (Loc,
1525 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1527 Proc_Spec : Node_Id;
1528 Param_Specs : List_Id;
1529 Param_Assoc : constant List_Id := New_List;
1530 Stmts : constant List_Id := New_List;
1532 RAS_Parameter : constant Entity_Id :=
1533 Make_Defining_Identifier (Loc,
1534 Chars => New_Internal_Name ('P'));
1536 Is_Function : constant Boolean :=
1537 Nkind (Type_Def) = N_Access_Function_Definition;
1539 Is_Degenerate : Boolean;
1540 -- Set to True if the subprogram_specification for this RAS has an
1541 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1543 Spec : constant Node_Id := Type_Def;
1545 Current_Parameter : Node_Id;
1547 -- Start of processing for Add_RAS_Dereference_TSS
1550 -- The Dereference TSS for a remote access-to-subprogram type has the
1553 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1556 -- This is called whenever a value of a RAS type is dereferenced
1558 -- First construct a list of parameter specifications:
1560 -- The first formal is the RAS values
1562 Param_Specs := New_List (
1563 Make_Parameter_Specification (Loc,
1564 Defining_Identifier => RAS_Parameter,
1567 New_Occurrence_Of (Fat_Type, Loc)));
1569 -- The following formals are copied from the type declaration
1571 Is_Degenerate := False;
1572 Current_Parameter := First (Parameter_Specifications (Type_Def));
1573 Parameters : while Present (Current_Parameter) loop
1574 if Nkind (Parameter_Type (Current_Parameter)) =
1577 Is_Degenerate := True;
1580 Append_To (Param_Specs,
1581 Make_Parameter_Specification (Loc,
1582 Defining_Identifier =>
1583 Make_Defining_Identifier (Loc,
1584 Chars => Chars (Defining_Identifier (Current_Parameter))),
1585 In_Present => In_Present (Current_Parameter),
1586 Out_Present => Out_Present (Current_Parameter),
1588 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1590 New_Copy_Tree (Expression (Current_Parameter))));
1592 Append_To (Param_Assoc,
1593 Make_Identifier (Loc,
1594 Chars => Chars (Defining_Identifier (Current_Parameter))));
1596 Next (Current_Parameter);
1597 end loop Parameters;
1599 if Is_Degenerate then
1600 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1602 -- Generate a dummy body. This code will never actually be executed,
1603 -- because null is the only legal value for a degenerate RAS type.
1604 -- For legality's sake (in order to avoid generating a function that
1605 -- does not contain a return statement), we include a dummy recursive
1606 -- call on the TSS itself.
1609 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1610 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1613 -- For a normal RAS type, we cast the RAS formal to the corresponding
1614 -- tagged type, and perform a dispatching call to its Call primitive
1617 Prepend_To (Param_Assoc,
1618 Unchecked_Convert_To (RACW_Type,
1619 New_Occurrence_Of (RAS_Parameter, Loc)));
1621 RACW_Primitive_Name :=
1622 Make_Selected_Component (Loc,
1623 Prefix => Scope (RACW_Type),
1624 Selector_Name => Name_uCall);
1629 Make_Simple_Return_Statement (Loc,
1631 Make_Function_Call (Loc,
1632 Name => RACW_Primitive_Name,
1633 Parameter_Associations => Param_Assoc)));
1637 Make_Procedure_Call_Statement (Loc,
1638 Name => RACW_Primitive_Name,
1639 Parameter_Associations => Param_Assoc));
1642 -- Build the complete subprogram
1646 Make_Function_Specification (Loc,
1647 Defining_Unit_Name => Proc,
1648 Parameter_Specifications => Param_Specs,
1649 Result_Definition =>
1651 Entity (Result_Definition (Spec)), Loc));
1653 Set_Ekind (Proc, E_Function);
1655 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1659 Make_Procedure_Specification (Loc,
1660 Defining_Unit_Name => Proc,
1661 Parameter_Specifications => Param_Specs);
1663 Set_Ekind (Proc, E_Procedure);
1664 Set_Etype (Proc, Standard_Void_Type);
1668 Make_Subprogram_Body (Loc,
1669 Specification => Proc_Spec,
1670 Declarations => New_List,
1671 Handled_Statement_Sequence =>
1672 Make_Handled_Sequence_Of_Statements (Loc,
1673 Statements => Stmts)));
1675 Set_TSS (Fat_Type, Proc);
1676 end Add_RAS_Dereference_TSS;
1678 -------------------------------
1679 -- Add_RAS_Proxy_And_Analyze --
1680 -------------------------------
1682 procedure Add_RAS_Proxy_And_Analyze
1685 All_Calls_Remote_E : Entity_Id;
1686 Proxy_Object_Addr : out Entity_Id)
1688 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1690 Subp_Name : constant Entity_Id :=
1691 Defining_Unit_Name (Specification (Vis_Decl));
1693 Pkg_Name : constant Entity_Id :=
1694 Make_Defining_Identifier (Loc,
1695 Chars => New_External_Name (Chars (Subp_Name), 'P', -1));
1697 Proxy_Type : constant Entity_Id :=
1698 Make_Defining_Identifier (Loc,
1701 (Related_Id => Chars (Subp_Name),
1704 Proxy_Type_Full_View : constant Entity_Id :=
1705 Make_Defining_Identifier (Loc,
1706 Chars (Proxy_Type));
1708 Subp_Decl_Spec : constant Node_Id :=
1709 Build_RAS_Primitive_Specification
1710 (Subp_Spec => Specification (Vis_Decl),
1711 Remote_Object_Type => Proxy_Type);
1713 Subp_Body_Spec : constant Node_Id :=
1714 Build_RAS_Primitive_Specification
1715 (Subp_Spec => Specification (Vis_Decl),
1716 Remote_Object_Type => Proxy_Type);
1718 Vis_Decls : constant List_Id := New_List;
1719 Pvt_Decls : constant List_Id := New_List;
1720 Actuals : constant List_Id := New_List;
1722 Perform_Call : Node_Id;
1725 -- type subpP is tagged limited private;
1727 Append_To (Vis_Decls,
1728 Make_Private_Type_Declaration (Loc,
1729 Defining_Identifier => Proxy_Type,
1730 Tagged_Present => True,
1731 Limited_Present => True));
1733 -- [subprogram] Call
1734 -- (Self : access subpP;
1735 -- ...other-formals...)
1738 Append_To (Vis_Decls,
1739 Make_Subprogram_Declaration (Loc,
1740 Specification => Subp_Decl_Spec));
1742 -- A : constant System.Address;
1744 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1746 Append_To (Vis_Decls,
1747 Make_Object_Declaration (Loc,
1748 Defining_Identifier => Proxy_Object_Addr,
1749 Constant_Present => True,
1750 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)));
1754 -- type subpP is tagged limited record
1755 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1759 Append_To (Pvt_Decls,
1760 Make_Full_Type_Declaration (Loc,
1761 Defining_Identifier => Proxy_Type_Full_View,
1763 Build_Remote_Subprogram_Proxy_Type (Loc,
1764 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1766 -- Trick semantic analysis into swapping the public and full view when
1767 -- freezing the public view.
1769 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1772 -- (Self : access O;
1773 -- ...other-formals...) is
1775 -- P (...other-formals...);
1779 -- (Self : access O;
1780 -- ...other-formals...)
1783 -- return F (...other-formals...);
1786 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1788 Make_Procedure_Call_Statement (Loc,
1789 Name => New_Occurrence_Of (Subp_Name, Loc),
1790 Parameter_Associations => Actuals);
1793 Make_Simple_Return_Statement (Loc,
1795 Make_Function_Call (Loc,
1796 Name => New_Occurrence_Of (Subp_Name, Loc),
1797 Parameter_Associations => Actuals));
1800 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1801 pragma Assert (Present (Formal));
1804 exit when No (Formal);
1806 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1809 -- O : aliased subpP;
1811 Append_To (Pvt_Decls,
1812 Make_Object_Declaration (Loc,
1813 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
1814 Aliased_Present => True,
1815 Object_Definition => New_Occurrence_Of (Proxy_Type, Loc)));
1817 -- A : constant System.Address := O'Address;
1819 Append_To (Pvt_Decls,
1820 Make_Object_Declaration (Loc,
1821 Defining_Identifier =>
1822 Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)),
1823 Constant_Present => True,
1824 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc),
1826 Make_Attribute_Reference (Loc,
1827 Prefix => New_Occurrence_Of (
1828 Defining_Identifier (Last (Pvt_Decls)), Loc),
1829 Attribute_Name => Name_Address)));
1832 Make_Package_Declaration (Loc,
1833 Specification => Make_Package_Specification (Loc,
1834 Defining_Unit_Name => Pkg_Name,
1835 Visible_Declarations => Vis_Decls,
1836 Private_Declarations => Pvt_Decls,
1837 End_Label => Empty)));
1838 Analyze (Last (Decls));
1841 Make_Package_Body (Loc,
1842 Defining_Unit_Name =>
1843 Make_Defining_Identifier (Loc, Chars (Pkg_Name)),
1844 Declarations => New_List (
1845 Make_Subprogram_Body (Loc,
1846 Specification => Subp_Body_Spec,
1847 Declarations => New_List,
1848 Handled_Statement_Sequence =>
1849 Make_Handled_Sequence_Of_Statements (Loc,
1850 Statements => New_List (Perform_Call))))));
1851 Analyze (Last (Decls));
1852 end Add_RAS_Proxy_And_Analyze;
1854 -----------------------
1855 -- Add_RAST_Features --
1856 -----------------------
1858 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1859 RAS_Type : constant Entity_Id :=
1860 Equivalent_Type (Defining_Identifier (Vis_Decl));
1862 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1863 Add_RAS_Dereference_TSS (Vis_Decl);
1864 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1865 end Add_RAST_Features;
1871 procedure Add_Stub_Type
1872 (Designated_Type : Entity_Id;
1873 RACW_Type : Entity_Id;
1875 Stub_Type : out Entity_Id;
1876 Stub_Type_Access : out Entity_Id;
1877 RPC_Receiver_Decl : out Node_Id;
1878 Body_Decls : out List_Id;
1879 Existing : out Boolean)
1881 Loc : constant Source_Ptr := Sloc (RACW_Type);
1883 Stub_Elements : constant Stub_Structure :=
1884 Stubs_Table.Get (Designated_Type);
1885 Stub_Type_Comps : List_Id;
1886 Stub_Type_Decl : Node_Id;
1887 Stub_Type_Access_Decl : Node_Id;
1890 if Stub_Elements /= Empty_Stub_Structure then
1891 Stub_Type := Stub_Elements.Stub_Type;
1892 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1893 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1894 Body_Decls := Stub_Elements.Body_Decls;
1901 Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S'));
1902 Set_Ekind (Stub_Type, E_Record_Type);
1903 Set_Is_RACW_Stub_Type (Stub_Type);
1905 Make_Defining_Identifier (Loc,
1906 Chars => New_External_Name
1907 (Related_Id => Chars (Stub_Type), Suffix => 'A'));
1909 Specific_Build_Stub_Type (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
1912 Make_Full_Type_Declaration (Loc,
1913 Defining_Identifier => Stub_Type,
1915 Make_Record_Definition (Loc,
1916 Tagged_Present => True,
1917 Limited_Present => True,
1919 Make_Component_List (Loc,
1920 Component_Items => Stub_Type_Comps)));
1922 -- Does the stub type need to explicitly implement interfaces from the
1923 -- designated type???
1925 -- In particular are there issues in the case where the designated type
1926 -- is a synchronized interface???
1928 Stub_Type_Access_Decl :=
1929 Make_Full_Type_Declaration (Loc,
1930 Defining_Identifier => Stub_Type_Access,
1932 Make_Access_To_Object_Definition (Loc,
1933 All_Present => True,
1934 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1936 Append_To (Decls, Stub_Type_Decl);
1937 Analyze (Last (Decls));
1938 Append_To (Decls, Stub_Type_Access_Decl);
1939 Analyze (Last (Decls));
1941 -- We can't directly derive the stub type from the designated type,
1942 -- because we don't want any components or discriminants from the real
1943 -- type, so instead we manually fake a derivation to get an appropriate
1946 Derive_Subprograms (Parent_Type => Designated_Type,
1947 Derived_Type => Stub_Type);
1949 if Present (RPC_Receiver_Decl) then
1950 Append_To (Decls, RPC_Receiver_Decl);
1952 RPC_Receiver_Decl := Last (Decls);
1955 Body_Decls := New_List;
1957 Stubs_Table.Set (Designated_Type,
1958 (Stub_Type => Stub_Type,
1959 Stub_Type_Access => Stub_Type_Access,
1960 RPC_Receiver_Decl => RPC_Receiver_Decl,
1961 Body_Decls => Body_Decls,
1962 RACW_Type => RACW_Type));
1965 ------------------------
1966 -- Append_RACW_Bodies --
1967 ------------------------
1969 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
1973 E := First_Entity (Spec_Id);
1974 while Present (E) loop
1975 if Is_Remote_Access_To_Class_Wide_Type (E) then
1976 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
1981 end Append_RACW_Bodies;
1983 ----------------------------------
1984 -- Assign_Subprogram_Identifier --
1985 ----------------------------------
1987 procedure Assign_Subprogram_Identifier
1992 N : constant Name_Id := Chars (Def);
1994 Overload_Order : constant Int :=
1995 Overload_Counter_Table.Get (N) + 1;
1998 Overload_Counter_Table.Set (N, Overload_Order);
2000 Get_Name_String (N);
2002 -- Homonym handling: as in Exp_Dbug, but much simpler, because the only
2003 -- entities for which we have to generate names here need only to be
2004 -- disambiguated within their own scope.
2006 if Overload_Order > 1 then
2007 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
2008 Name_Len := Name_Len + 2;
2009 Add_Nat_To_Name_Buffer (Overload_Order);
2012 Id := String_From_Name_Buffer;
2013 Subprogram_Identifier_Table.Set
2015 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
2016 end Assign_Subprogram_Identifier;
2018 -------------------------------------
2019 -- Build_Actual_Object_Declaration --
2020 -------------------------------------
2022 procedure Build_Actual_Object_Declaration
2023 (Object : Entity_Id;
2029 Loc : constant Source_Ptr := Sloc (Object);
2032 -- Declare a temporary object for the actual, possibly initialized with
2033 -- a 'Input/From_Any call.
2035 -- Complication arises in the case of limited types, for which such a
2036 -- declaration is illegal in Ada 95. In that case, we first generate a
2037 -- renaming declaration of the 'Input call, and then if needed we
2038 -- generate an overlaid non-constant view.
2040 if Ada_Version <= Ada_95
2041 and then Is_Limited_Type (Etyp)
2042 and then Present (Expr)
2045 -- Object : Etyp renames <func-call>
2048 Make_Object_Renaming_Declaration (Loc,
2049 Defining_Identifier => Object,
2050 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
2055 -- The name defined by the renaming declaration denotes a
2056 -- constant view; create a non-constant object at the same address
2057 -- to be used as the actual.
2060 Constant_Object : constant Entity_Id :=
2061 Make_Defining_Identifier (Loc,
2062 New_Internal_Name ('P'));
2064 Set_Defining_Identifier
2065 (Last (Decls), Constant_Object);
2067 -- We have an unconstrained Etyp: build the actual constrained
2068 -- subtype for the value we just read from the stream.
2070 -- subtype S is <actual subtype of Constant_Object>;
2073 Build_Actual_Subtype (Etyp,
2074 New_Occurrence_Of (Constant_Object, Loc)));
2079 Make_Object_Declaration (Loc,
2080 Defining_Identifier => Object,
2081 Object_Definition =>
2083 (Defining_Identifier (Last (Decls)), Loc)));
2084 Set_Ekind (Object, E_Variable);
2086 -- Suppress default initialization:
2087 -- pragma Import (Ada, Object);
2091 Chars => Name_Import,
2092 Pragma_Argument_Associations => New_List (
2093 Make_Pragma_Argument_Association (Loc,
2094 Chars => Name_Convention,
2095 Expression => Make_Identifier (Loc, Name_Ada)),
2096 Make_Pragma_Argument_Association (Loc,
2097 Chars => Name_Entity,
2098 Expression => New_Occurrence_Of (Object, Loc)))));
2100 -- for Object'Address use Constant_Object'Address;
2103 Make_Attribute_Definition_Clause (Loc,
2104 Name => New_Occurrence_Of (Object, Loc),
2105 Chars => Name_Address,
2107 Make_Attribute_Reference (Loc,
2108 Prefix => New_Occurrence_Of (Constant_Object, Loc),
2109 Attribute_Name => Name_Address)));
2114 -- General case of a regular object declaration. Object is flagged
2115 -- constant unless it has mode out or in out, to allow the backend
2116 -- to optimize where possible.
2118 -- Object : [constant] Etyp [:= <expr>];
2121 Make_Object_Declaration (Loc,
2122 Defining_Identifier => Object,
2123 Constant_Present => Present (Expr) and then not Variable,
2124 Object_Definition => New_Occurrence_Of (Etyp, Loc),
2125 Expression => Expr));
2127 if Constant_Present (Last (Decls)) then
2128 Set_Ekind (Object, E_Constant);
2130 Set_Ekind (Object, E_Variable);
2133 end Build_Actual_Object_Declaration;
2135 ------------------------------
2136 -- Build_Get_Unique_RP_Call --
2137 ------------------------------
2139 function Build_Get_Unique_RP_Call
2141 Pointer : Entity_Id;
2142 Stub_Type : Entity_Id) return List_Id
2146 Make_Procedure_Call_Statement (Loc,
2148 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2149 Parameter_Associations => New_List (
2150 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2151 New_Occurrence_Of (Pointer, Loc)))),
2153 Make_Assignment_Statement (Loc,
2155 Make_Selected_Component (Loc,
2156 Prefix => New_Occurrence_Of (Pointer, Loc),
2158 New_Occurrence_Of (First_Tag_Component
2159 (Designated_Type (Etype (Pointer))), Loc)),
2161 Make_Attribute_Reference (Loc,
2162 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2163 Attribute_Name => Name_Tag)));
2165 -- Note: The assignment to Pointer._Tag is safe here because
2166 -- we carefully ensured that Stub_Type has exactly the same layout
2167 -- as System.Partition_Interface.RACW_Stub_Type.
2169 end Build_Get_Unique_RP_Call;
2171 -----------------------------------
2172 -- Build_Ordered_Parameters_List --
2173 -----------------------------------
2175 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2176 Constrained_List : List_Id;
2177 Unconstrained_List : List_Id;
2178 Current_Parameter : Node_Id;
2181 First_Parameter : Node_Id;
2182 For_RAS : Boolean := False;
2185 if No (Parameter_Specifications (Spec)) then
2189 Constrained_List := New_List;
2190 Unconstrained_List := New_List;
2191 First_Parameter := First (Parameter_Specifications (Spec));
2193 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2194 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2199 -- Loop through the parameters and add them to the right list. Note that
2200 -- we treat a parameter of a null-excluding access type as unconstrained
2201 -- because we can't declare an object of such a type with default
2204 Current_Parameter := First_Parameter;
2205 while Present (Current_Parameter) loop
2206 Ptyp := Parameter_Type (Current_Parameter);
2208 if (Nkind (Ptyp) = N_Access_Definition
2209 or else not Transmit_As_Unconstrained (Etype (Ptyp)))
2210 and then not (For_RAS and then Current_Parameter = First_Parameter)
2212 Append_To (Constrained_List, New_Copy (Current_Parameter));
2214 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2217 Next (Current_Parameter);
2220 -- Unconstrained parameters are returned first
2222 Append_List_To (Unconstrained_List, Constrained_List);
2224 return Unconstrained_List;
2225 end Build_Ordered_Parameters_List;
2227 ----------------------------------
2228 -- Build_Passive_Partition_Stub --
2229 ----------------------------------
2231 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2233 Pkg_Name : String_Id;
2236 Loc : constant Source_Ptr := Sloc (U);
2239 -- Verify that the implementation supports distribution, by accessing
2240 -- a type defined in the proper version of system.rpc
2243 Dist_OK : Entity_Id;
2244 pragma Warnings (Off, Dist_OK);
2246 Dist_OK := RTE (RE_Params_Stream_Type);
2249 -- Use body if present, spec otherwise
2251 if Nkind (U) = N_Package_Declaration then
2252 Pkg_Spec := Specification (U);
2253 L := Visible_Declarations (Pkg_Spec);
2255 Pkg_Spec := Parent (Corresponding_Spec (U));
2256 L := Declarations (U);
2259 Get_Library_Unit_Name_String (Pkg_Spec);
2260 Pkg_Name := String_From_Name_Buffer;
2262 Make_Procedure_Call_Statement (Loc,
2264 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2265 Parameter_Associations => New_List (
2266 Make_String_Literal (Loc, Pkg_Name),
2267 Make_Attribute_Reference (Loc,
2269 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2270 Attribute_Name => Name_Version)));
2273 end Build_Passive_Partition_Stub;
2275 --------------------------------------
2276 -- Build_RPC_Receiver_Specification --
2277 --------------------------------------
2279 function Build_RPC_Receiver_Specification
2280 (RPC_Receiver : Entity_Id;
2281 Request_Parameter : Entity_Id) return Node_Id
2283 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2286 Make_Procedure_Specification (Loc,
2287 Defining_Unit_Name => RPC_Receiver,
2288 Parameter_Specifications => New_List (
2289 Make_Parameter_Specification (Loc,
2290 Defining_Identifier => Request_Parameter,
2292 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2293 end Build_RPC_Receiver_Specification;
2295 ----------------------------------------
2296 -- Build_Remote_Subprogram_Proxy_Type --
2297 ----------------------------------------
2299 function Build_Remote_Subprogram_Proxy_Type
2301 ACR_Expression : Node_Id) return Node_Id
2305 Make_Record_Definition (Loc,
2306 Tagged_Present => True,
2307 Limited_Present => True,
2309 Make_Component_List (Loc,
2311 Component_Items => New_List (
2312 Make_Component_Declaration (Loc,
2313 Defining_Identifier =>
2314 Make_Defining_Identifier (Loc,
2315 Name_All_Calls_Remote),
2316 Component_Definition =>
2317 Make_Component_Definition (Loc,
2318 Subtype_Indication =>
2319 New_Occurrence_Of (Standard_Boolean, Loc)),
2323 Make_Component_Declaration (Loc,
2324 Defining_Identifier =>
2325 Make_Defining_Identifier (Loc,
2327 Component_Definition =>
2328 Make_Component_Definition (Loc,
2329 Subtype_Indication =>
2330 New_Occurrence_Of (RTE (RE_Address), Loc)),
2332 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2334 Make_Component_Declaration (Loc,
2335 Defining_Identifier =>
2336 Make_Defining_Identifier (Loc,
2338 Component_Definition =>
2339 Make_Component_Definition (Loc,
2340 Subtype_Indication =>
2341 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2342 end Build_Remote_Subprogram_Proxy_Type;
2344 --------------------
2345 -- Build_Stub_Tag --
2346 --------------------
2348 function Build_Stub_Tag
2350 RACW_Type : Entity_Id) return Node_Id
2352 Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type);
2355 Make_Attribute_Reference (Loc,
2356 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2357 Attribute_Name => Name_Tag);
2360 ------------------------------------
2361 -- Build_Subprogram_Calling_Stubs --
2362 ------------------------------------
2364 function Build_Subprogram_Calling_Stubs
2365 (Vis_Decl : Node_Id;
2367 Asynchronous : Boolean;
2368 Dynamically_Asynchronous : Boolean := False;
2369 Stub_Type : Entity_Id := Empty;
2370 RACW_Type : Entity_Id := Empty;
2371 Locator : Entity_Id := Empty;
2372 New_Name : Name_Id := No_Name) return Node_Id
2374 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2376 Decls : constant List_Id := New_List;
2377 Statements : constant List_Id := New_List;
2379 Subp_Spec : Node_Id;
2380 -- The specification of the body
2382 Controlling_Parameter : Entity_Id := Empty;
2384 Asynchronous_Expr : Node_Id := Empty;
2386 RCI_Locator : Entity_Id;
2388 Spec_To_Use : Node_Id;
2390 procedure Insert_Partition_Check (Parameter : Node_Id);
2391 -- Check that the parameter has been elaborated on the same partition
2392 -- than the controlling parameter (E.4(19)).
2394 ----------------------------
2395 -- Insert_Partition_Check --
2396 ----------------------------
2398 procedure Insert_Partition_Check (Parameter : Node_Id) is
2399 Parameter_Entity : constant Entity_Id :=
2400 Defining_Identifier (Parameter);
2402 -- The expression that will be built is of the form:
2404 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2405 -- raise Constraint_Error;
2408 -- We do not check that Parameter is in Stub_Type since such a check
2409 -- has been inserted at the point of call already (a tag check since
2410 -- we have multiple controlling operands).
2413 Make_Raise_Constraint_Error (Loc,
2417 Make_Function_Call (Loc,
2419 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2420 Parameter_Associations =>
2422 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2423 New_Occurrence_Of (Parameter_Entity, Loc)),
2424 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2425 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2426 Reason => CE_Partition_Check_Failed));
2427 end Insert_Partition_Check;
2429 -- Start of processing for Build_Subprogram_Calling_Stubs
2432 Subp_Spec := Copy_Specification (Loc,
2433 Spec => Specification (Vis_Decl),
2434 New_Name => New_Name);
2436 if Locator = Empty then
2437 RCI_Locator := RCI_Cache;
2438 Spec_To_Use := Specification (Vis_Decl);
2440 RCI_Locator := Locator;
2441 Spec_To_Use := Subp_Spec;
2444 -- Find a controlling argument if we have a stub type. Also check
2445 -- if this subprogram can be made asynchronous.
2447 if Present (Stub_Type)
2448 and then Present (Parameter_Specifications (Spec_To_Use))
2451 Current_Parameter : Node_Id :=
2452 First (Parameter_Specifications
2455 while Present (Current_Parameter) loop
2457 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2459 if Controlling_Parameter = Empty then
2460 Controlling_Parameter :=
2461 Defining_Identifier (Current_Parameter);
2463 Insert_Partition_Check (Current_Parameter);
2467 Next (Current_Parameter);
2472 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2474 if Dynamically_Asynchronous then
2475 Asynchronous_Expr := Make_Selected_Component (Loc,
2476 Prefix => Controlling_Parameter,
2477 Selector_Name => Name_Asynchronous);
2480 Specific_Build_General_Calling_Stubs
2482 Statements => Statements,
2483 Target => Specific_Build_Stub_Target (Loc,
2484 Decls, RCI_Locator, Controlling_Parameter),
2485 Subprogram_Id => Subp_Id,
2486 Asynchronous => Asynchronous_Expr,
2487 Is_Known_Asynchronous => Asynchronous
2488 and then not Dynamically_Asynchronous,
2489 Is_Known_Non_Asynchronous
2491 and then not Dynamically_Asynchronous,
2492 Is_Function => Nkind (Spec_To_Use) =
2493 N_Function_Specification,
2494 Spec => Spec_To_Use,
2495 Stub_Type => Stub_Type,
2496 RACW_Type => RACW_Type,
2499 RCI_Calling_Stubs_Table.Set
2500 (Defining_Unit_Name (Specification (Vis_Decl)),
2501 Defining_Unit_Name (Spec_To_Use));
2504 Make_Subprogram_Body (Loc,
2505 Specification => Subp_Spec,
2506 Declarations => Decls,
2507 Handled_Statement_Sequence =>
2508 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2509 end Build_Subprogram_Calling_Stubs;
2511 -------------------------
2512 -- Build_Subprogram_Id --
2513 -------------------------
2515 function Build_Subprogram_Id
2517 E : Entity_Id) return Node_Id
2520 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2522 Current_Declaration : Node_Id;
2523 Current_Subp : Entity_Id;
2524 Current_Subp_Str : String_Id;
2525 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2527 pragma Warnings (Off, Current_Subp_Str);
2530 -- Build_Subprogram_Id is called outside of the context of
2531 -- generating calling or receiving stubs. Hence we are processing
2532 -- an 'Access attribute_reference for an RCI subprogram, for the
2533 -- purpose of obtaining a RAS value.
2536 (Is_Remote_Call_Interface (Scope (E))
2538 (Nkind (Parent (E)) = N_Procedure_Specification
2540 Nkind (Parent (E)) = N_Function_Specification));
2542 Current_Declaration :=
2543 First (Visible_Declarations
2544 (Package_Specification_Of_Scope (Scope (E))));
2545 while Present (Current_Declaration) loop
2546 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2547 and then Comes_From_Source (Current_Declaration)
2549 Current_Subp := Defining_Unit_Name (Specification (
2550 Current_Declaration));
2552 Assign_Subprogram_Identifier
2553 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2555 Current_Subp_Number := Current_Subp_Number + 1;
2558 Next (Current_Declaration);
2563 case Get_PCS_Name is
2564 when Name_PolyORB_DSA =>
2565 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2567 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2569 end Build_Subprogram_Id;
2571 ------------------------
2572 -- Copy_Specification --
2573 ------------------------
2575 function Copy_Specification
2578 Ctrl_Type : Entity_Id := Empty;
2579 New_Name : Name_Id := No_Name) return Node_Id
2581 Parameters : List_Id := No_List;
2583 Current_Parameter : Node_Id;
2584 Current_Identifier : Entity_Id;
2585 Current_Type : Node_Id;
2587 Name_For_New_Spec : Name_Id;
2589 New_Identifier : Entity_Id;
2591 -- Comments needed in body below ???
2594 if New_Name = No_Name then
2595 pragma Assert (Nkind (Spec) = N_Function_Specification
2596 or else Nkind (Spec) = N_Procedure_Specification);
2598 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2600 Name_For_New_Spec := New_Name;
2603 if Present (Parameter_Specifications (Spec)) then
2604 Parameters := New_List;
2605 Current_Parameter := First (Parameter_Specifications (Spec));
2606 while Present (Current_Parameter) loop
2607 Current_Identifier := Defining_Identifier (Current_Parameter);
2608 Current_Type := Parameter_Type (Current_Parameter);
2610 if Nkind (Current_Type) = N_Access_Definition then
2611 if Present (Ctrl_Type) then
2612 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2614 Make_Access_Definition (Loc,
2615 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2616 Null_Exclusion_Present =>
2617 Null_Exclusion_Present (Current_Type));
2621 Make_Access_Definition (Loc,
2623 New_Copy_Tree (Subtype_Mark (Current_Type)),
2624 Null_Exclusion_Present =>
2625 Null_Exclusion_Present (Current_Type));
2629 if Present (Ctrl_Type)
2630 and then Is_Controlling_Formal (Current_Identifier)
2632 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2634 Current_Type := New_Copy_Tree (Current_Type);
2638 New_Identifier := Make_Defining_Identifier (Loc,
2639 Chars (Current_Identifier));
2641 Append_To (Parameters,
2642 Make_Parameter_Specification (Loc,
2643 Defining_Identifier => New_Identifier,
2644 Parameter_Type => Current_Type,
2645 In_Present => In_Present (Current_Parameter),
2646 Out_Present => Out_Present (Current_Parameter),
2648 New_Copy_Tree (Expression (Current_Parameter))));
2650 -- For a regular formal parameter (that needs to be marshalled
2651 -- in the context of remote calls), set the Etype now, because
2652 -- marshalling processing might need it.
2654 if Is_Entity_Name (Current_Type) then
2655 Set_Etype (New_Identifier, Entity (Current_Type));
2657 -- Current_Type is an access definition, special processing
2658 -- (not requiring etype) will occur for marshalling.
2664 Next (Current_Parameter);
2668 case Nkind (Spec) is
2670 when N_Function_Specification | N_Access_Function_Definition =>
2672 Make_Function_Specification (Loc,
2673 Defining_Unit_Name =>
2674 Make_Defining_Identifier (Loc,
2675 Chars => Name_For_New_Spec),
2676 Parameter_Specifications => Parameters,
2677 Result_Definition =>
2678 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2680 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2682 Make_Procedure_Specification (Loc,
2683 Defining_Unit_Name =>
2684 Make_Defining_Identifier (Loc,
2685 Chars => Name_For_New_Spec),
2686 Parameter_Specifications => Parameters);
2689 raise Program_Error;
2691 end Copy_Specification;
2693 -----------------------------
2694 -- Corresponding_Stub_Type --
2695 -----------------------------
2697 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2698 Desig : constant Entity_Id :=
2699 Etype (Designated_Type (RACW_Type));
2700 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2702 return Stub_Elements.Stub_Type;
2703 end Corresponding_Stub_Type;
2705 ---------------------------
2706 -- Could_Be_Asynchronous --
2707 ---------------------------
2709 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2710 Current_Parameter : Node_Id;
2713 if Present (Parameter_Specifications (Spec)) then
2714 Current_Parameter := First (Parameter_Specifications (Spec));
2715 while Present (Current_Parameter) loop
2716 if Out_Present (Current_Parameter) then
2720 Next (Current_Parameter);
2725 end Could_Be_Asynchronous;
2727 ---------------------------
2728 -- Declare_Create_NVList --
2729 ---------------------------
2731 procedure Declare_Create_NVList
2739 Make_Object_Declaration (Loc,
2740 Defining_Identifier => NVList,
2741 Aliased_Present => False,
2742 Object_Definition =>
2743 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2746 Make_Procedure_Call_Statement (Loc,
2747 Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2748 Parameter_Associations => New_List (
2749 New_Occurrence_Of (NVList, Loc))));
2750 end Declare_Create_NVList;
2752 ---------------------------------------------
2753 -- Expand_All_Calls_Remote_Subprogram_Call --
2754 ---------------------------------------------
2756 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2757 Loc : constant Source_Ptr := Sloc (N);
2758 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2759 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2760 RCI_Locator_Decl : Node_Id;
2761 RCI_Locator : Entity_Id;
2762 Calling_Stubs : Node_Id;
2763 E_Calling_Stubs : Entity_Id;
2766 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2768 if E_Calling_Stubs = Empty then
2769 RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
2771 -- The RCI_Locator package and calling stub are is inserted at the
2772 -- top level in the current unit, and must appear in the proper scope
2773 -- so that it is not prematurely removed by the GCC back end.
2776 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2778 if Ekind (Scop) = E_Package_Body then
2779 Push_Scope (Spec_Entity (Scop));
2780 elsif Ekind (Scop) = E_Subprogram_Body then
2782 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2788 if RCI_Locator = Empty then
2791 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2792 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
2793 Analyze (RCI_Locator_Decl);
2794 RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
2797 RCI_Locator_Decl := Parent (RCI_Locator);
2800 Calling_Stubs := Build_Subprogram_Calling_Stubs
2801 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2803 Build_Subprogram_Id (Loc, Called_Subprogram),
2804 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2806 Is_Asynchronous (Called_Subprogram),
2807 Locator => RCI_Locator,
2808 New_Name => New_Internal_Name ('S'));
2809 Insert_After (RCI_Locator_Decl, Calling_Stubs);
2810 Analyze (Calling_Stubs);
2813 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2816 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2817 end Expand_All_Calls_Remote_Subprogram_Call;
2819 ---------------------------------
2820 -- Expand_Calling_Stubs_Bodies --
2821 ---------------------------------
2823 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2824 Spec : constant Node_Id := Specification (Unit_Node);
2825 Decls : constant List_Id := Visible_Declarations (Spec);
2827 Push_Scope (Scope_Of_Spec (Spec));
2828 Add_Calling_Stubs_To_Declarations
2829 (Specification (Unit_Node), Decls);
2831 end Expand_Calling_Stubs_Bodies;
2833 -----------------------------------
2834 -- Expand_Receiving_Stubs_Bodies --
2835 -----------------------------------
2837 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2840 Stubs_Decls : List_Id;
2841 Stubs_Stmts : List_Id;
2844 if Nkind (Unit_Node) = N_Package_Declaration then
2845 Spec := Specification (Unit_Node);
2846 Decls := Private_Declarations (Spec);
2849 Decls := Visible_Declarations (Spec);
2852 Push_Scope (Scope_Of_Spec (Spec));
2853 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2857 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2858 Decls := Declarations (Unit_Node);
2860 Push_Scope (Scope_Of_Spec (Unit_Node));
2861 Stubs_Decls := New_List;
2862 Stubs_Stmts := New_List;
2863 Specific_Add_Receiving_Stubs_To_Declarations
2864 (Spec, Stubs_Decls, Stubs_Stmts);
2866 Insert_List_Before (First (Decls), Stubs_Decls);
2869 HSS_Stmts : constant List_Id :=
2870 Statements (Handled_Statement_Sequence (Unit_Node));
2872 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2875 if No (First_HSS_Stmt) then
2876 Append_List_To (HSS_Stmts, Stubs_Stmts);
2878 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2884 end Expand_Receiving_Stubs_Bodies;
2886 --------------------
2887 -- GARLIC_Support --
2888 --------------------
2890 package body GARLIC_Support is
2892 -- Local subprograms
2894 procedure Add_RACW_Read_Attribute
2895 (RACW_Type : Entity_Id;
2896 Stub_Type : Entity_Id;
2897 Stub_Type_Access : Entity_Id;
2898 Body_Decls : List_Id);
2899 -- Add Read attribute for the RACW type. The declaration and attribute
2900 -- definition clauses are inserted right after the declaration of
2901 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2902 -- appended to it (case where the RACW declaration is in the main unit).
2904 procedure Add_RACW_Write_Attribute
2905 (RACW_Type : Entity_Id;
2906 Stub_Type : Entity_Id;
2907 Stub_Type_Access : Entity_Id;
2908 RPC_Receiver : Node_Id;
2909 Body_Decls : List_Id);
2910 -- Same as above for the Write attribute
2912 function Stream_Parameter return Node_Id;
2913 function Result return Node_Id;
2914 function Object return Node_Id renames Result;
2915 -- Functions to create occurrences of the formal parameter names of the
2916 -- 'Read and 'Write attributes.
2919 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2920 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2922 procedure Add_RAS_Access_TSS (N : Node_Id);
2923 -- Add a subprogram body for RAS Access TSS
2925 -------------------------------------
2926 -- Add_Obj_RPC_Receiver_Completion --
2927 -------------------------------------
2929 procedure Add_Obj_RPC_Receiver_Completion
2932 RPC_Receiver : Entity_Id;
2933 Stub_Elements : Stub_Structure)
2936 -- The RPC receiver body should not be the completion of the
2937 -- declaration recorded in the stub structure, because then the
2938 -- occurrences of the formal parameters within the body should refer
2939 -- to the entities from the declaration, not from the completion, to
2940 -- which we do not have easy access. Instead, the RPC receiver body
2941 -- acts as its own declaration, and the RPC receiver declaration is
2942 -- completed by a renaming-as-body.
2945 Make_Subprogram_Renaming_Declaration (Loc,
2947 Copy_Specification (Loc,
2948 Specification (Stub_Elements.RPC_Receiver_Decl)),
2949 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2950 end Add_Obj_RPC_Receiver_Completion;
2952 -----------------------
2953 -- Add_RACW_Features --
2954 -----------------------
2956 procedure Add_RACW_Features
2957 (RACW_Type : Entity_Id;
2958 Stub_Type : Entity_Id;
2959 Stub_Type_Access : Entity_Id;
2960 RPC_Receiver_Decl : Node_Id;
2961 Body_Decls : List_Id)
2963 RPC_Receiver : Node_Id;
2964 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2967 Loc := Sloc (RACW_Type);
2971 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2972 -- of the corresponding distributed object type. We retrieve its
2973 -- address from the local proxy object.
2975 RPC_Receiver := Make_Selected_Component (Loc,
2977 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2978 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2981 RPC_Receiver := Make_Attribute_Reference (Loc,
2982 Prefix => New_Occurrence_Of (
2983 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2984 Attribute_Name => Name_Address);
2987 Add_RACW_Write_Attribute
2994 Add_RACW_Read_Attribute
2999 end Add_RACW_Features;
3001 -----------------------------
3002 -- Add_RACW_Read_Attribute --
3003 -----------------------------
3005 procedure Add_RACW_Read_Attribute
3006 (RACW_Type : Entity_Id;
3007 Stub_Type : Entity_Id;
3008 Stub_Type_Access : Entity_Id;
3009 Body_Decls : List_Id)
3011 Proc_Decl : Node_Id;
3012 Attr_Decl : Node_Id;
3014 Body_Node : Node_Id;
3016 Statements : constant List_Id := New_List;
3018 Local_Statements : List_Id;
3019 Remote_Statements : List_Id;
3020 -- Various parts of the procedure
3022 Pnam : constant Entity_Id :=
3023 Make_Defining_Identifier
3024 (Loc, New_Internal_Name ('R'));
3025 Asynchronous_Flag : constant Entity_Id :=
3026 Asynchronous_Flags_Table.Get (RACW_Type);
3027 pragma Assert (Present (Asynchronous_Flag));
3029 -- Prepare local identifiers
3031 Source_Partition : Entity_Id;
3032 Source_Receiver : Entity_Id;
3033 Source_Address : Entity_Id;
3034 Local_Stub : Entity_Id;
3035 Stubbed_Result : Entity_Id;
3037 -- Start of processing for Add_RACW_Read_Attribute
3040 Build_Stream_Procedure (Loc,
3041 RACW_Type, Body_Node, Pnam, Statements, Outp => True);
3042 Proc_Decl := Make_Subprogram_Declaration (Loc,
3043 Copy_Specification (Loc, Specification (Body_Node)));
3046 Make_Attribute_Definition_Clause (Loc,
3047 Name => New_Occurrence_Of (RACW_Type, Loc),
3051 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3053 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3054 Insert_After (Proc_Decl, Attr_Decl);
3056 if No (Body_Decls) then
3058 -- Case of processing an RACW type from another unit than the
3059 -- main one: do not generate a body.
3064 -- Prepare local identifiers
3067 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3069 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3071 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3073 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
3075 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3077 -- Generate object declarations
3080 Make_Object_Declaration (Loc,
3081 Defining_Identifier => Source_Partition,
3082 Object_Definition =>
3083 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
3085 Make_Object_Declaration (Loc,
3086 Defining_Identifier => Source_Receiver,
3087 Object_Definition =>
3088 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3090 Make_Object_Declaration (Loc,
3091 Defining_Identifier => Source_Address,
3092 Object_Definition =>
3093 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3095 Make_Object_Declaration (Loc,
3096 Defining_Identifier => Local_Stub,
3097 Aliased_Present => True,
3098 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
3100 Make_Object_Declaration (Loc,
3101 Defining_Identifier => Stubbed_Result,
3102 Object_Definition =>
3103 New_Occurrence_Of (Stub_Type_Access, Loc),
3105 Make_Attribute_Reference (Loc,
3107 New_Occurrence_Of (Local_Stub, Loc),
3109 Name_Unchecked_Access)));
3111 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3113 Append_List_To (Statements, New_List (
3114 Make_Attribute_Reference (Loc,
3116 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3117 Attribute_Name => Name_Read,
3118 Expressions => New_List (
3120 New_Occurrence_Of (Source_Partition, Loc))),
3122 Make_Attribute_Reference (Loc,
3124 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3127 Expressions => New_List (
3129 New_Occurrence_Of (Source_Receiver, Loc))),
3131 Make_Attribute_Reference (Loc,
3133 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3136 Expressions => New_List (
3138 New_Occurrence_Of (Source_Address, Loc)))));
3140 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3142 Set_Etype (Stubbed_Result, Stub_Type_Access);
3144 -- If the Address is Null_Address, then return a null object, unless
3145 -- RACW_Type is null-excluding, in which case unconditionally raise
3146 -- CONSTRAINT_ERROR instead.
3149 Zero_Statements : List_Id;
3150 -- Statements executed when a zero value is received
3153 if Can_Never_Be_Null (RACW_Type) then
3154 Zero_Statements := New_List (
3155 Make_Raise_Constraint_Error (Loc,
3156 Reason => CE_Null_Not_Allowed));
3158 Zero_Statements := New_List (
3159 Make_Assignment_Statement (Loc,
3161 Expression => Make_Null (Loc)),
3162 Make_Simple_Return_Statement (Loc));
3165 Append_To (Statements,
3166 Make_Implicit_If_Statement (RACW_Type,
3169 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3170 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3171 Then_Statements => Zero_Statements));
3174 -- If the RACW denotes an object created on the current partition,
3175 -- Local_Statements will be executed. The real object will be used.
3177 Local_Statements := New_List (
3178 Make_Assignment_Statement (Loc,
3181 Unchecked_Convert_To (RACW_Type,
3182 OK_Convert_To (RTE (RE_Address),
3183 New_Occurrence_Of (Source_Address, Loc)))));
3185 -- If the object is located on another partition, then a stub object
3186 -- will be created with all the information needed to rebuild the
3187 -- real object at the other end.
3189 Remote_Statements := New_List (
3191 Make_Assignment_Statement (Loc,
3192 Name => Make_Selected_Component (Loc,
3193 Prefix => Stubbed_Result,
3194 Selector_Name => Name_Origin),
3196 New_Occurrence_Of (Source_Partition, Loc)),
3198 Make_Assignment_Statement (Loc,
3199 Name => Make_Selected_Component (Loc,
3200 Prefix => Stubbed_Result,
3201 Selector_Name => Name_Receiver),
3203 New_Occurrence_Of (Source_Receiver, Loc)),
3205 Make_Assignment_Statement (Loc,
3206 Name => Make_Selected_Component (Loc,
3207 Prefix => Stubbed_Result,
3208 Selector_Name => Name_Addr),
3210 New_Occurrence_Of (Source_Address, Loc)));
3212 Append_To (Remote_Statements,
3213 Make_Assignment_Statement (Loc,
3214 Name => Make_Selected_Component (Loc,
3215 Prefix => Stubbed_Result,
3216 Selector_Name => Name_Asynchronous),
3218 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3220 Append_List_To (Remote_Statements,
3221 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3222 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3223 -- set on the stub type if, and only if, the RACW type has a pragma
3224 -- Asynchronous. This is incorrect for RACWs that implement RAS
3225 -- types, because in that case the /designated subprogram/ (not the
3226 -- type) might be asynchronous, and that causes the stub to need to
3227 -- be asynchronous too. A solution is to transport a RAS as a struct
3228 -- containing a RACW and an asynchronous flag, and to properly alter
3229 -- the Asynchronous component in the stub type in the RAS's Input
3232 Append_To (Remote_Statements,
3233 Make_Assignment_Statement (Loc,
3235 Expression => Unchecked_Convert_To (RACW_Type,
3236 New_Occurrence_Of (Stubbed_Result, Loc))));
3238 -- Distinguish between the local and remote cases, and execute the
3239 -- appropriate piece of code.
3241 Append_To (Statements,
3242 Make_Implicit_If_Statement (RACW_Type,
3246 Make_Function_Call (Loc,
3247 Name => New_Occurrence_Of (
3248 RTE (RE_Get_Local_Partition_Id), Loc)),
3249 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3250 Then_Statements => Local_Statements,
3251 Else_Statements => Remote_Statements));
3253 Set_Declarations (Body_Node, Decls);
3254 Append_To (Body_Decls, Body_Node);
3255 end Add_RACW_Read_Attribute;
3257 ------------------------------
3258 -- Add_RACW_Write_Attribute --
3259 ------------------------------
3261 procedure Add_RACW_Write_Attribute
3262 (RACW_Type : Entity_Id;
3263 Stub_Type : Entity_Id;
3264 Stub_Type_Access : Entity_Id;
3265 RPC_Receiver : Node_Id;
3266 Body_Decls : List_Id)
3268 Body_Node : Node_Id;
3269 Proc_Decl : Node_Id;
3270 Attr_Decl : Node_Id;
3272 Statements : constant List_Id := New_List;
3273 Local_Statements : List_Id;
3274 Remote_Statements : List_Id;
3275 Null_Statements : List_Id;
3277 Pnam : constant Entity_Id :=
3278 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3281 Build_Stream_Procedure
3282 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
3284 Proc_Decl := Make_Subprogram_Declaration (Loc,
3285 Copy_Specification (Loc, Specification (Body_Node)));
3288 Make_Attribute_Definition_Clause (Loc,
3289 Name => New_Occurrence_Of (RACW_Type, Loc),
3290 Chars => Name_Write,
3293 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3295 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3296 Insert_After (Proc_Decl, Attr_Decl);
3298 if No (Body_Decls) then
3302 -- Build the code fragment corresponding to the marshalling of a
3305 Local_Statements := New_List (
3307 Pack_Entity_Into_Stream_Access (Loc,
3308 Stream => Stream_Parameter,
3309 Object => RTE (RE_Get_Local_Partition_Id)),
3311 Pack_Node_Into_Stream_Access (Loc,
3312 Stream => Stream_Parameter,
3313 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3314 Etyp => RTE (RE_Unsigned_64)),
3316 Pack_Node_Into_Stream_Access (Loc,
3317 Stream => Stream_Parameter,
3318 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3319 Make_Attribute_Reference (Loc,
3321 Make_Explicit_Dereference (Loc,
3323 Attribute_Name => Name_Address)),
3324 Etyp => RTE (RE_Unsigned_64)));
3326 -- Build the code fragment corresponding to the marshalling of
3329 Remote_Statements := New_List (
3330 Pack_Node_Into_Stream_Access (Loc,
3331 Stream => Stream_Parameter,
3333 Make_Selected_Component (Loc,
3335 Unchecked_Convert_To (Stub_Type_Access, Object),
3336 Selector_Name => Make_Identifier (Loc, Name_Origin)),
3337 Etyp => RTE (RE_Partition_ID)),
3339 Pack_Node_Into_Stream_Access (Loc,
3340 Stream => Stream_Parameter,
3342 Make_Selected_Component (Loc,
3344 Unchecked_Convert_To (Stub_Type_Access, Object),
3345 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
3346 Etyp => RTE (RE_Unsigned_64)),
3348 Pack_Node_Into_Stream_Access (Loc,
3349 Stream => Stream_Parameter,
3351 Make_Selected_Component (Loc,
3353 Unchecked_Convert_To (Stub_Type_Access, Object),
3354 Selector_Name => Make_Identifier (Loc, Name_Addr)),
3355 Etyp => RTE (RE_Unsigned_64)));
3357 -- Build code fragment corresponding to marshalling of a null object
3359 Null_Statements := New_List (
3361 Pack_Entity_Into_Stream_Access (Loc,
3362 Stream => Stream_Parameter,
3363 Object => RTE (RE_Get_Local_Partition_Id)),
3365 Pack_Node_Into_Stream_Access (Loc,
3366 Stream => Stream_Parameter,
3367 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3368 Etyp => RTE (RE_Unsigned_64)),
3370 Pack_Node_Into_Stream_Access (Loc,
3371 Stream => Stream_Parameter,
3372 Object => Make_Integer_Literal (Loc, Uint_0),
3373 Etyp => RTE (RE_Unsigned_64)));
3375 Append_To (Statements,
3376 Make_Implicit_If_Statement (RACW_Type,
3379 Left_Opnd => Object,
3380 Right_Opnd => Make_Null (Loc)),
3382 Then_Statements => Null_Statements,
3384 Elsif_Parts => New_List (
3385 Make_Elsif_Part (Loc,
3389 Make_Attribute_Reference (Loc,
3391 Attribute_Name => Name_Tag),
3394 Make_Attribute_Reference (Loc,
3395 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3396 Attribute_Name => Name_Tag)),
3397 Then_Statements => Remote_Statements)),
3398 Else_Statements => Local_Statements));
3400 Append_To (Body_Decls, Body_Node);
3401 end Add_RACW_Write_Attribute;
3403 ------------------------
3404 -- Add_RAS_Access_TSS --
3405 ------------------------
3407 procedure Add_RAS_Access_TSS (N : Node_Id) is
3408 Loc : constant Source_Ptr := Sloc (N);
3410 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3411 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3412 -- Ras_Type is the access to subprogram type while Fat_Type is the
3413 -- corresponding record type.
3415 RACW_Type : constant Entity_Id :=
3416 Underlying_RACW_Type (Ras_Type);
3417 Desig : constant Entity_Id :=
3418 Etype (Designated_Type (RACW_Type));
3420 Stub_Elements : constant Stub_Structure :=
3421 Stubs_Table.Get (Desig);
3422 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3424 Proc : constant Entity_Id :=
3425 Make_Defining_Identifier (Loc,
3426 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3428 Proc_Spec : Node_Id;
3430 -- Formal parameters
3432 Package_Name : constant Entity_Id :=
3433 Make_Defining_Identifier (Loc,
3437 Subp_Id : constant Entity_Id :=
3438 Make_Defining_Identifier (Loc,
3440 -- Target subprogram
3442 Asynch_P : constant Entity_Id :=
3443 Make_Defining_Identifier (Loc,
3444 Chars => Name_Asynchronous);
3445 -- Is the procedure to which the 'Access applies asynchronous?
3447 All_Calls_Remote : constant Entity_Id :=
3448 Make_Defining_Identifier (Loc,
3449 Chars => Name_All_Calls_Remote);
3450 -- True if an All_Calls_Remote pragma applies to the RCI unit
3451 -- that contains the subprogram.
3453 -- Common local variables
3455 Proc_Decls : List_Id;
3456 Proc_Statements : List_Id;
3458 Origin : constant Entity_Id :=
3459 Make_Defining_Identifier (Loc,
3460 Chars => New_Internal_Name ('P'));
3462 -- Additional local variables for the local case
3464 Proxy_Addr : constant Entity_Id :=
3465 Make_Defining_Identifier (Loc,
3466 Chars => New_Internal_Name ('P'));
3468 -- Additional local variables for the remote case
3470 Local_Stub : constant Entity_Id :=
3471 Make_Defining_Identifier (Loc,
3472 Chars => New_Internal_Name ('L'));
3474 Stub_Ptr : constant Entity_Id :=
3475 Make_Defining_Identifier (Loc,
3476 Chars => New_Internal_Name ('S'));
3479 (Field_Name : Name_Id;
3480 Value : Node_Id) return Node_Id;
3481 -- Construct an assignment that sets the named component in the
3489 (Field_Name : Name_Id;
3490 Value : Node_Id) return Node_Id
3494 Make_Assignment_Statement (Loc,
3496 Make_Selected_Component (Loc,
3498 Selector_Name => Field_Name),
3499 Expression => Value);
3502 -- Start of processing for Add_RAS_Access_TSS
3505 Proc_Decls := New_List (
3507 -- Common declarations
3509 Make_Object_Declaration (Loc,
3510 Defining_Identifier => Origin,
3511 Constant_Present => True,
3512 Object_Definition =>
3513 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3515 Make_Function_Call (Loc,
3517 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3518 Parameter_Associations => New_List (
3519 New_Occurrence_Of (Package_Name, Loc)))),
3521 -- Declaration use only in the local case: proxy address
3523 Make_Object_Declaration (Loc,
3524 Defining_Identifier => Proxy_Addr,
3525 Object_Definition =>
3526 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3528 -- Declarations used only in the remote case: stub object and
3531 Make_Object_Declaration (Loc,
3532 Defining_Identifier => Local_Stub,
3533 Aliased_Present => True,
3534 Object_Definition =>
3535 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3537 Make_Object_Declaration (Loc,
3538 Defining_Identifier =>
3540 Object_Definition =>
3541 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3543 Make_Attribute_Reference (Loc,
3544 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3545 Attribute_Name => Name_Unchecked_Access)));
3547 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3549 -- Build_Get_Unique_RP_Call needs above information
3551 -- Note: Here we assume that the Fat_Type is a record
3552 -- containing just a pointer to a proxy or stub object.
3554 Proc_Statements := New_List (
3558 -- Get_RAS_Info (Pkg, Subp, PA);
3559 -- if Origin = Local_Partition_Id
3560 -- and then not All_Calls_Remote
3562 -- return Fat_Type!(PA);
3565 Make_Procedure_Call_Statement (Loc,
3566 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3567 Parameter_Associations => New_List (
3568 New_Occurrence_Of (Package_Name, Loc),
3569 New_Occurrence_Of (Subp_Id, Loc),
3570 New_Occurrence_Of (Proxy_Addr, Loc))),
3572 Make_Implicit_If_Statement (N,
3578 New_Occurrence_Of (Origin, Loc),
3580 Make_Function_Call (Loc,
3582 RTE (RE_Get_Local_Partition_Id), Loc))),
3586 New_Occurrence_Of (All_Calls_Remote, Loc))),
3588 Then_Statements => New_List (
3589 Make_Simple_Return_Statement (Loc,
3590 Unchecked_Convert_To (Fat_Type,
3591 OK_Convert_To (RTE (RE_Address),
3592 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3594 Set_Field (Name_Origin,
3595 New_Occurrence_Of (Origin, Loc)),
3597 Set_Field (Name_Receiver,
3598 Make_Function_Call (Loc,
3600 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3601 Parameter_Associations => New_List (
3602 New_Occurrence_Of (Package_Name, Loc)))),
3604 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3606 -- E.4.1(9) A remote call is asynchronous if it is a call to
3607 -- a procedure or a call through a value of an access-to-procedure
3608 -- type to which a pragma Asynchronous applies.
3610 -- Asynch_P is true when the procedure is asynchronous;
3611 -- Asynch_T is true when the type is asynchronous.
3613 Set_Field (Name_Asynchronous,
3615 New_Occurrence_Of (Asynch_P, Loc),
3616 New_Occurrence_Of (Boolean_Literals (
3617 Is_Asynchronous (Ras_Type)), Loc))));
3619 Append_List_To (Proc_Statements,
3620 Build_Get_Unique_RP_Call
3621 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3623 -- Return the newly created value
3625 Append_To (Proc_Statements,
3626 Make_Simple_Return_Statement (Loc,
3628 Unchecked_Convert_To (Fat_Type,
3629 New_Occurrence_Of (Stub_Ptr, Loc))));
3632 Make_Function_Specification (Loc,
3633 Defining_Unit_Name => Proc,
3634 Parameter_Specifications => New_List (
3635 Make_Parameter_Specification (Loc,
3636 Defining_Identifier => Package_Name,
3638 New_Occurrence_Of (Standard_String, Loc)),
3640 Make_Parameter_Specification (Loc,
3641 Defining_Identifier => Subp_Id,
3643 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3645 Make_Parameter_Specification (Loc,
3646 Defining_Identifier => Asynch_P,
3648 New_Occurrence_Of (Standard_Boolean, Loc)),
3650 Make_Parameter_Specification (Loc,
3651 Defining_Identifier => All_Calls_Remote,
3653 New_Occurrence_Of (Standard_Boolean, Loc))),
3655 Result_Definition =>
3656 New_Occurrence_Of (Fat_Type, Loc));
3658 -- Set the kind and return type of the function to prevent
3659 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3661 Set_Ekind (Proc, E_Function);
3662 Set_Etype (Proc, Fat_Type);
3665 Make_Subprogram_Body (Loc,
3666 Specification => Proc_Spec,
3667 Declarations => Proc_Decls,
3668 Handled_Statement_Sequence =>
3669 Make_Handled_Sequence_Of_Statements (Loc,
3670 Statements => Proc_Statements)));
3672 Set_TSS (Fat_Type, Proc);
3673 end Add_RAS_Access_TSS;
3675 -----------------------
3676 -- Add_RAST_Features --
3677 -----------------------
3679 procedure Add_RAST_Features
3680 (Vis_Decl : Node_Id;
3681 RAS_Type : Entity_Id)
3683 pragma Unreferenced (RAS_Type);
3685 Add_RAS_Access_TSS (Vis_Decl);
3686 end Add_RAST_Features;
3688 -----------------------------------------
3689 -- Add_Receiving_Stubs_To_Declarations --
3690 -----------------------------------------
3692 procedure Add_Receiving_Stubs_To_Declarations
3693 (Pkg_Spec : Node_Id;
3697 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3699 Request_Parameter : Node_Id;
3701 Pkg_RPC_Receiver : constant Entity_Id :=
3702 Make_Defining_Identifier (Loc,
3703 New_Internal_Name ('H'));
3704 Pkg_RPC_Receiver_Statements : List_Id;
3705 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3706 Pkg_RPC_Receiver_Body : Node_Id;
3707 -- A Pkg_RPC_Receiver is built to decode the request
3709 Lookup_RAS_Info : constant Entity_Id :=
3710 Make_Defining_Identifier (Loc,
3711 Chars => New_Internal_Name ('R'));
3712 -- A remote subprogram is created to allow peers to look up
3713 -- RAS information using subprogram ids.
3715 Subp_Id : Entity_Id;
3716 Subp_Index : Entity_Id;
3717 -- Subprogram_Id as read from the incoming stream
3719 Current_Declaration : Node_Id;
3720 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3721 Current_Stubs : Node_Id;
3723 Subp_Info_Array : constant Entity_Id :=
3724 Make_Defining_Identifier (Loc,
3725 Chars => New_Internal_Name ('I'));
3727 Subp_Info_List : constant List_Id := New_List;
3729 Register_Pkg_Actuals : constant List_Id := New_List;
3731 All_Calls_Remote_E : Entity_Id;
3732 Proxy_Object_Addr : Entity_Id;
3734 procedure Append_Stubs_To
3735 (RPC_Receiver_Cases : List_Id;
3737 Subprogram_Number : Int);
3738 -- Add one case to the specified RPC receiver case list
3739 -- associating Subprogram_Number with the subprogram declared
3740 -- by Declaration, for which we have receiving stubs in Stubs.
3742 ---------------------
3743 -- Append_Stubs_To --
3744 ---------------------
3746 procedure Append_Stubs_To
3747 (RPC_Receiver_Cases : List_Id;
3749 Subprogram_Number : Int)
3752 Append_To (RPC_Receiver_Cases,
3753 Make_Case_Statement_Alternative (Loc,
3755 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3758 Make_Procedure_Call_Statement (Loc,
3760 New_Occurrence_Of (Defining_Entity (Stubs), Loc),
3761 Parameter_Associations => New_List (
3762 New_Occurrence_Of (Request_Parameter, Loc))))));
3763 end Append_Stubs_To;
3765 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3768 -- Building receiving stubs consist in several operations:
3770 -- - a package RPC receiver must be built. This subprogram
3771 -- will get a Subprogram_Id from the incoming stream
3772 -- and will dispatch the call to the right subprogram;
3774 -- - a receiving stub for each subprogram visible in the package
3775 -- spec. This stub will read all the parameters from the stream,
3776 -- and put the result as well as the exception occurrence in the
3779 -- - a dummy package with an empty spec and a body made of an
3780 -- elaboration part, whose job is to register the receiving
3781 -- part of this RCI package on the name server. This is done
3782 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3784 Build_RPC_Receiver_Body (
3785 RPC_Receiver => Pkg_RPC_Receiver,
3786 Request => Request_Parameter,
3788 Subp_Index => Subp_Index,
3789 Stmts => Pkg_RPC_Receiver_Statements,
3790 Decl => Pkg_RPC_Receiver_Body);
3791 pragma Assert (Subp_Id = Subp_Index);
3793 -- A null subp_id denotes a call through a RAS, in which case the
3794 -- next Uint_64 element in the stream is the address of the local
3795 -- proxy object, from which we can retrieve the actual subprogram id.
3797 Append_To (Pkg_RPC_Receiver_Statements,
3798 Make_Implicit_If_Statement (Pkg_Spec,
3801 New_Occurrence_Of (Subp_Id, Loc),
3802 Make_Integer_Literal (Loc, 0)),
3804 Then_Statements => New_List (
3805 Make_Assignment_Statement (Loc,
3807 New_Occurrence_Of (Subp_Id, Loc),
3810 Make_Selected_Component (Loc,
3812 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3813 OK_Convert_To (RTE (RE_Address),
3814 Make_Attribute_Reference (Loc,
3816 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3819 Expressions => New_List (
3820 Make_Selected_Component (Loc,
3821 Prefix => Request_Parameter,
3822 Selector_Name => Name_Params))))),
3825 Make_Identifier (Loc, Name_Subp_Id))))));
3827 -- Build a subprogram for RAS information lookups
3829 Current_Declaration :=
3830 Make_Subprogram_Declaration (Loc,
3832 Make_Function_Specification (Loc,
3833 Defining_Unit_Name =>
3835 Parameter_Specifications => New_List (
3836 Make_Parameter_Specification (Loc,
3837 Defining_Identifier =>
3838 Make_Defining_Identifier (Loc, Name_Subp_Id),
3842 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3843 Result_Definition =>
3844 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3846 Append_To (Decls, Current_Declaration);
3847 Analyze (Current_Declaration);
3849 Current_Stubs := Build_Subprogram_Receiving_Stubs
3850 (Vis_Decl => Current_Declaration,
3851 Asynchronous => False);
3852 Append_To (Decls, Current_Stubs);
3853 Analyze (Current_Stubs);
3855 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3858 Subprogram_Number => 1);
3860 -- For each subprogram, the receiving stub will be built and a
3861 -- case statement will be made on the Subprogram_Id to dispatch
3862 -- to the right subprogram.
3864 All_Calls_Remote_E :=
3866 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3868 Overload_Counter_Table.Reset;
3870 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3871 while Present (Current_Declaration) loop
3872 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3873 and then Comes_From_Source (Current_Declaration)
3876 Loc : constant Source_Ptr := Sloc (Current_Declaration);
3877 -- While specifically processing Current_Declaration, use
3878 -- its Sloc as the location of all generated nodes.
3880 Subp_Def : constant Entity_Id :=
3882 (Specification (Current_Declaration));
3884 Subp_Val : String_Id;
3885 pragma Warnings (Off, Subp_Val);
3888 -- Build receiving stub
3891 Build_Subprogram_Receiving_Stubs
3892 (Vis_Decl => Current_Declaration,
3894 Nkind (Specification (Current_Declaration)) =
3895 N_Procedure_Specification
3896 and then Is_Asynchronous (Subp_Def));
3898 Append_To (Decls, Current_Stubs);
3899 Analyze (Current_Stubs);
3903 Add_RAS_Proxy_And_Analyze (Decls,
3904 Vis_Decl => Current_Declaration,
3905 All_Calls_Remote_E => All_Calls_Remote_E,
3906 Proxy_Object_Addr => Proxy_Object_Addr);
3908 -- Compute distribution identifier
3910 Assign_Subprogram_Identifier
3912 Current_Subprogram_Number,
3916 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
3918 -- Add subprogram descriptor (RCI_Subp_Info) to the
3919 -- subprograms table for this receiver. The aggregate
3920 -- below must be kept consistent with the declaration
3921 -- of type RCI_Subp_Info in System.Partition_Interface.
3923 Append_To (Subp_Info_List,
3924 Make_Component_Association (Loc,
3925 Choices => New_List (
3926 Make_Integer_Literal (Loc,
3927 Current_Subprogram_Number)),
3930 Make_Aggregate (Loc,
3931 Component_Associations => New_List (
3932 Make_Component_Association (Loc,
3933 Choices => New_List (
3934 Make_Identifier (Loc, Name_Addr)),
3937 Proxy_Object_Addr, Loc))))));
3939 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3940 Stubs => Current_Stubs,
3941 Subprogram_Number => Current_Subprogram_Number);
3944 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3947 Next (Current_Declaration);
3950 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3951 -- rather than raising an exception since we do not want someone
3952 -- to crash a remote partition by sending invalid subprogram ids.
3953 -- This is consistent with the other parts of the case statement
3954 -- since even in presence of incorrect parameters in the stream,
3955 -- every exception will be caught and (if the subprogram is not an
3956 -- APC) put into the result stream and sent away.
3958 Append_To (Pkg_RPC_Receiver_Cases,
3959 Make_Case_Statement_Alternative (Loc,
3960 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
3961 Statements => New_List (Make_Null_Statement (Loc))));
3963 Append_To (Pkg_RPC_Receiver_Statements,
3964 Make_Case_Statement (Loc,
3965 Expression => New_Occurrence_Of (Subp_Id, Loc),
3966 Alternatives => Pkg_RPC_Receiver_Cases));
3969 Make_Object_Declaration (Loc,
3970 Defining_Identifier => Subp_Info_Array,
3971 Constant_Present => True,
3972 Aliased_Present => True,
3973 Object_Definition =>
3974 Make_Subtype_Indication (Loc,
3976 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3978 Make_Index_Or_Discriminant_Constraint (Loc,
3981 Low_Bound => Make_Integer_Literal (Loc,
3982 First_RCI_Subprogram_Id),
3984 Make_Integer_Literal (Loc,
3986 First_RCI_Subprogram_Id
3987 + List_Length (Subp_Info_List) - 1)))))));
3989 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3990 -- has zero length, and the declaration is for an empty array, in
3991 -- which case no initialization aggregate must be generated.
3993 if Present (First (Subp_Info_List)) then
3994 Set_Expression (Last (Decls),
3995 Make_Aggregate (Loc,
3996 Component_Associations => Subp_Info_List));
3998 -- No initialization provided: remove CONSTANT so that the
3999 -- declaration is not an incomplete deferred constant.
4002 Set_Constant_Present (Last (Decls), False);
4005 Analyze (Last (Decls));
4008 Subp_Info_Addr : Node_Id;
4009 -- Return statement for Lookup_RAS_Info: address of the subprogram
4010 -- information record for the requested subprogram id.
4013 if Present (First (Subp_Info_List)) then
4015 Make_Selected_Component (Loc,
4017 Make_Indexed_Component (Loc,
4018 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4019 Expressions => New_List (
4020 Convert_To (Standard_Integer,
4021 Make_Identifier (Loc, Name_Subp_Id)))),
4022 Selector_Name => Make_Identifier (Loc, Name_Addr));
4024 -- Case of no visible subprogram: just raise Constraint_Error, we
4025 -- know for sure we got junk from a remote partition.
4029 Make_Raise_Constraint_Error (Loc,
4030 Reason => CE_Range_Check_Failed);
4031 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
4035 Make_Subprogram_Body (Loc,
4037 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
4038 Declarations => No_List,
4039 Handled_Statement_Sequence =>
4040 Make_Handled_Sequence_Of_Statements (Loc,
4041 Statements => New_List (
4042 Make_Simple_Return_Statement (Loc,
4045 (RTE (RE_Unsigned_64), Subp_Info_Addr))))));
4048 Analyze (Last (Decls));
4050 Append_To (Decls, Pkg_RPC_Receiver_Body);
4051 Analyze (Last (Decls));
4053 Get_Library_Unit_Name_String (Pkg_Spec);
4057 Append_To (Register_Pkg_Actuals,
4058 Make_String_Literal (Loc,
4059 Strval => String_From_Name_Buffer));
4063 Append_To (Register_Pkg_Actuals,
4064 Make_Attribute_Reference (Loc,
4065 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
4066 Attribute_Name => Name_Unrestricted_Access));
4070 Append_To (Register_Pkg_Actuals,
4071 Make_Attribute_Reference (Loc,
4073 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
4074 Attribute_Name => Name_Version));
4078 Append_To (Register_Pkg_Actuals,
4079 Make_Attribute_Reference (Loc,
4080 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4081 Attribute_Name => Name_Address));
4085 Append_To (Register_Pkg_Actuals,
4086 Make_Attribute_Reference (Loc,
4087 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4088 Attribute_Name => Name_Length));
4090 -- Generate the call
4093 Make_Procedure_Call_Statement (Loc,
4095 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
4096 Parameter_Associations => Register_Pkg_Actuals));
4097 Analyze (Last (Stmts));
4098 end Add_Receiving_Stubs_To_Declarations;
4100 ---------------------------------
4101 -- Build_General_Calling_Stubs --
4102 ---------------------------------
4104 procedure Build_General_Calling_Stubs
4106 Statements : List_Id;
4107 Target_Partition : Entity_Id;
4108 Target_RPC_Receiver : Node_Id;
4109 Subprogram_Id : Node_Id;
4110 Asynchronous : Node_Id := Empty;
4111 Is_Known_Asynchronous : Boolean := False;
4112 Is_Known_Non_Asynchronous : Boolean := False;
4113 Is_Function : Boolean;
4115 Stub_Type : Entity_Id := Empty;
4116 RACW_Type : Entity_Id := Empty;
4119 Loc : constant Source_Ptr := Sloc (Nod);
4121 Stream_Parameter : Node_Id;
4122 -- Name of the stream used to transmit parameters to the remote
4125 Result_Parameter : Node_Id;
4126 -- Name of the result parameter (in non-APC cases) which get the
4127 -- result of the remote subprogram.
4129 Exception_Return_Parameter : Node_Id;
4130 -- Name of the parameter which will hold the exception sent by the
4131 -- remote subprogram.
4133 Current_Parameter : Node_Id;
4134 -- Current parameter being handled
4136 Ordered_Parameters_List : constant List_Id :=
4137 Build_Ordered_Parameters_List (Spec);
4139 Asynchronous_Statements : List_Id := No_List;
4140 Non_Asynchronous_Statements : List_Id := No_List;
4141 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4143 Extra_Formal_Statements : constant List_Id := New_List;
4144 -- List of statements for extra formal parameters. It will appear
4145 -- after the regular statements for writing out parameters.
4147 pragma Unreferenced (RACW_Type);
4148 -- Used only for the PolyORB case
4151 -- The general form of a calling stub for a given subprogram is:
4153 -- procedure X (...) is P : constant Partition_ID :=
4154 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4155 -- System.RPC.Params_Stream_Type (0); begin
4156 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4157 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4158 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4159 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4161 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4163 -- There are some variations: Do_APC is called for an asynchronous
4164 -- procedure and the part after the call is completely ommitted as
4165 -- well as the declaration of Result. For a function call, 'Input is
4166 -- always used to read the result even if it is constrained.
4169 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4172 Make_Object_Declaration (Loc,
4173 Defining_Identifier => Stream_Parameter,
4174 Aliased_Present => True,
4175 Object_Definition =>
4176 Make_Subtype_Indication (Loc,
4178 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4180 Make_Index_Or_Discriminant_Constraint (Loc,
4182 New_List (Make_Integer_Literal (Loc, 0))))));
4184 if not Is_Known_Asynchronous then
4186 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4189 Make_Object_Declaration (Loc,
4190 Defining_Identifier => Result_Parameter,
4191 Aliased_Present => True,
4192 Object_Definition =>
4193 Make_Subtype_Indication (Loc,
4195 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4197 Make_Index_Or_Discriminant_Constraint (Loc,
4199 New_List (Make_Integer_Literal (Loc, 0))))));
4201 Exception_Return_Parameter :=
4202 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4205 Make_Object_Declaration (Loc,
4206 Defining_Identifier => Exception_Return_Parameter,
4207 Object_Definition =>
4208 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4211 Result_Parameter := Empty;
4212 Exception_Return_Parameter := Empty;
4215 -- Put first the RPC receiver corresponding to the remote package
4217 Append_To (Statements,
4218 Make_Attribute_Reference (Loc,
4220 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4221 Attribute_Name => Name_Write,
4222 Expressions => New_List (
4223 Make_Attribute_Reference (Loc,
4224 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4225 Attribute_Name => Name_Access),
4226 Target_RPC_Receiver)));
4228 -- Then put the Subprogram_Id of the subprogram we want to call in
4231 Append_To (Statements,
4232 Make_Attribute_Reference (Loc,
4233 Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4234 Attribute_Name => Name_Write,
4235 Expressions => New_List (
4236 Make_Attribute_Reference (Loc,
4237 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4238 Attribute_Name => Name_Access),
4241 Current_Parameter := First (Ordered_Parameters_List);
4242 while Present (Current_Parameter) loop
4244 Typ : constant Node_Id :=
4245 Parameter_Type (Current_Parameter);
4247 Constrained : Boolean;
4249 Extra_Parameter : Entity_Id;
4252 if Is_RACW_Controlling_Formal
4253 (Current_Parameter, Stub_Type)
4255 -- In the case of a controlling formal argument, we marshall
4256 -- its addr field rather than the local stub.
4258 Append_To (Statements,
4259 Pack_Node_Into_Stream (Loc,
4260 Stream => Stream_Parameter,
4262 Make_Selected_Component (Loc,
4264 Defining_Identifier (Current_Parameter),
4265 Selector_Name => Name_Addr),
4266 Etyp => RTE (RE_Unsigned_64)));
4271 (Defining_Identifier (Current_Parameter), Loc);
4273 -- Access type parameters are transmitted as in out
4274 -- parameters. However, a dereference is needed so that
4275 -- we marshall the designated object.
4277 if Nkind (Typ) = N_Access_Definition then
4278 Value := Make_Explicit_Dereference (Loc, Value);
4279 Etyp := Etype (Subtype_Mark (Typ));
4281 Etyp := Etype (Typ);
4284 Constrained := not Transmit_As_Unconstrained (Etyp);
4286 -- Any parameter but unconstrained out parameters are
4287 -- transmitted to the peer.
4289 if In_Present (Current_Parameter)
4290 or else not Out_Present (Current_Parameter)
4291 or else not Constrained
4293 Append_To (Statements,
4294 Make_Attribute_Reference (Loc,
4295 Prefix => New_Occurrence_Of (Etyp, Loc),
4297 Output_From_Constrained (Constrained),
4298 Expressions => New_List (
4299 Make_Attribute_Reference (Loc,
4301 New_Occurrence_Of (Stream_Parameter, Loc),
4302 Attribute_Name => Name_Access),
4307 -- If the current parameter has a dynamic constrained status,
4308 -- then this status is transmitted as well.
4309 -- This should be done for accessibility as well ???
4311 if Nkind (Typ) /= N_Access_Definition
4312 and then Need_Extra_Constrained (Current_Parameter)
4314 -- In this block, we do not use the extra formal that has
4315 -- been created because it does not exist at the time of
4316 -- expansion when building calling stubs for remote access
4317 -- to subprogram types. We create an extra variable of this
4318 -- type and push it in the stream after the regular
4321 Extra_Parameter := Make_Defining_Identifier
4322 (Loc, New_Internal_Name ('P'));
4325 Make_Object_Declaration (Loc,
4326 Defining_Identifier => Extra_Parameter,
4327 Constant_Present => True,
4328 Object_Definition =>
4329 New_Occurrence_Of (Standard_Boolean, Loc),
4331 Make_Attribute_Reference (Loc,
4334 Defining_Identifier (Current_Parameter), Loc),
4335 Attribute_Name => Name_Constrained)));
4337 Append_To (Extra_Formal_Statements,
4338 Make_Attribute_Reference (Loc,
4340 New_Occurrence_Of (Standard_Boolean, Loc),
4341 Attribute_Name => Name_Write,
4342 Expressions => New_List (
4343 Make_Attribute_Reference (Loc,
4346 (Stream_Parameter, Loc), Attribute_Name =>
4348 New_Occurrence_Of (Extra_Parameter, Loc))));
4351 Next (Current_Parameter);
4355 -- Append the formal statements list to the statements
4357 Append_List_To (Statements, Extra_Formal_Statements);
4359 if not Is_Known_Non_Asynchronous then
4361 -- Build the call to System.RPC.Do_APC
4363 Asynchronous_Statements := New_List (
4364 Make_Procedure_Call_Statement (Loc,
4366 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4367 Parameter_Associations => New_List (
4368 New_Occurrence_Of (Target_Partition, Loc),
4369 Make_Attribute_Reference (Loc,
4371 New_Occurrence_Of (Stream_Parameter, Loc),
4372 Attribute_Name => Name_Access))));
4374 Asynchronous_Statements := No_List;
4377 if not Is_Known_Asynchronous then
4379 -- Build the call to System.RPC.Do_RPC
4381 Non_Asynchronous_Statements := New_List (
4382 Make_Procedure_Call_Statement (Loc,
4384 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4385 Parameter_Associations => New_List (
4386 New_Occurrence_Of (Target_Partition, Loc),
4388 Make_Attribute_Reference (Loc,
4390 New_Occurrence_Of (Stream_Parameter, Loc),
4391 Attribute_Name => Name_Access),
4393 Make_Attribute_Reference (Loc,
4395 New_Occurrence_Of (Result_Parameter, Loc),
4396 Attribute_Name => Name_Access))));
4398 -- Read the exception occurrence from the result stream and
4399 -- reraise it. It does no harm if this is a Null_Occurrence since
4400 -- this does nothing.
4402 Append_To (Non_Asynchronous_Statements,
4403 Make_Attribute_Reference (Loc,
4405 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4407 Attribute_Name => Name_Read,
4409 Expressions => New_List (
4410 Make_Attribute_Reference (Loc,
4412 New_Occurrence_Of (Result_Parameter, Loc),
4413 Attribute_Name => Name_Access),
4414 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4416 Append_To (Non_Asynchronous_Statements,
4417 Make_Procedure_Call_Statement (Loc,
4419 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4420 Parameter_Associations => New_List (
4421 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4425 -- If this is a function call, then read the value and return
4426 -- it. The return value is written/read using 'Output/'Input.
4428 Append_To (Non_Asynchronous_Statements,
4429 Make_Tag_Check (Loc,
4430 Make_Simple_Return_Statement (Loc,
4432 Make_Attribute_Reference (Loc,
4435 Etype (Result_Definition (Spec)), Loc),
4437 Attribute_Name => Name_Input,
4439 Expressions => New_List (
4440 Make_Attribute_Reference (Loc,
4442 New_Occurrence_Of (Result_Parameter, Loc),
4443 Attribute_Name => Name_Access))))));
4446 -- Loop around parameters and assign out (or in out)
4447 -- parameters. In the case of RACW, controlling arguments
4448 -- cannot possibly have changed since they are remote, so
4449 -- we do not read them from the stream.
4451 Current_Parameter := First (Ordered_Parameters_List);
4452 while Present (Current_Parameter) loop
4454 Typ : constant Node_Id :=
4455 Parameter_Type (Current_Parameter);
4462 (Defining_Identifier (Current_Parameter), Loc);
4464 if Nkind (Typ) = N_Access_Definition then
4465 Value := Make_Explicit_Dereference (Loc, Value);
4466 Etyp := Etype (Subtype_Mark (Typ));
4468 Etyp := Etype (Typ);
4471 if (Out_Present (Current_Parameter)
4472 or else Nkind (Typ) = N_Access_Definition)
4473 and then Etyp /= Stub_Type
4475 Append_To (Non_Asynchronous_Statements,
4476 Make_Attribute_Reference (Loc,
4478 New_Occurrence_Of (Etyp, Loc),
4480 Attribute_Name => Name_Read,
4482 Expressions => New_List (
4483 Make_Attribute_Reference (Loc,
4485 New_Occurrence_Of (Result_Parameter, Loc),
4486 Attribute_Name => Name_Access),
4491 Next (Current_Parameter);
4496 if Is_Known_Asynchronous then
4497 Append_List_To (Statements, Asynchronous_Statements);
4499 elsif Is_Known_Non_Asynchronous then
4500 Append_List_To (Statements, Non_Asynchronous_Statements);
4503 pragma Assert (Present (Asynchronous));
4504 Prepend_To (Asynchronous_Statements,
4505 Make_Attribute_Reference (Loc,
4506 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4507 Attribute_Name => Name_Write,
4508 Expressions => New_List (
4509 Make_Attribute_Reference (Loc,
4511 New_Occurrence_Of (Stream_Parameter, Loc),
4512 Attribute_Name => Name_Access),
4513 New_Occurrence_Of (Standard_True, Loc))));
4515 Prepend_To (Non_Asynchronous_Statements,
4516 Make_Attribute_Reference (Loc,
4517 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4518 Attribute_Name => Name_Write,
4519 Expressions => New_List (
4520 Make_Attribute_Reference (Loc,
4522 New_Occurrence_Of (Stream_Parameter, Loc),
4523 Attribute_Name => Name_Access),
4524 New_Occurrence_Of (Standard_False, Loc))));
4526 Append_To (Statements,
4527 Make_Implicit_If_Statement (Nod,
4528 Condition => Asynchronous,
4529 Then_Statements => Asynchronous_Statements,
4530 Else_Statements => Non_Asynchronous_Statements));
4532 end Build_General_Calling_Stubs;
4534 -----------------------------
4535 -- Build_RPC_Receiver_Body --
4536 -----------------------------
4538 procedure Build_RPC_Receiver_Body
4539 (RPC_Receiver : Entity_Id;
4540 Request : out Entity_Id;
4541 Subp_Id : out Entity_Id;
4542 Subp_Index : out Entity_Id;
4543 Stmts : out List_Id;
4546 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4548 RPC_Receiver_Spec : Node_Id;
4549 RPC_Receiver_Decls : List_Id;
4552 Request := Make_Defining_Identifier (Loc, Name_R);
4554 RPC_Receiver_Spec :=
4555 Build_RPC_Receiver_Specification
4556 (RPC_Receiver => RPC_Receiver,
4557 Request_Parameter => Request);
4559 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4560 Subp_Index := Subp_Id;
4562 -- Subp_Id may not be a constant, because in the case of the RPC
4563 -- receiver for an RCI package, when a call is received from a RAS
4564 -- dereference, it will be assigned during subsequent processing.
4566 RPC_Receiver_Decls := New_List (
4567 Make_Object_Declaration (Loc,
4568 Defining_Identifier => Subp_Id,
4569 Object_Definition =>
4570 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4572 Make_Attribute_Reference (Loc,
4574 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4575 Attribute_Name => Name_Input,
4576 Expressions => New_List (
4577 Make_Selected_Component (Loc,
4579 Selector_Name => Name_Params)))));
4584 Make_Subprogram_Body (Loc,
4585 Specification => RPC_Receiver_Spec,
4586 Declarations => RPC_Receiver_Decls,
4587 Handled_Statement_Sequence =>
4588 Make_Handled_Sequence_Of_Statements (Loc,
4589 Statements => Stmts));
4590 end Build_RPC_Receiver_Body;
4592 -----------------------
4593 -- Build_Stub_Target --
4594 -----------------------
4596 function Build_Stub_Target
4599 RCI_Locator : Entity_Id;
4600 Controlling_Parameter : Entity_Id) return RPC_Target
4602 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4604 Target_Info.Partition :=
4605 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4606 if Present (Controlling_Parameter) then
4608 Make_Object_Declaration (Loc,
4609 Defining_Identifier => Target_Info.Partition,
4610 Constant_Present => True,
4611 Object_Definition =>
4612 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4615 Make_Selected_Component (Loc,
4616 Prefix => Controlling_Parameter,
4617 Selector_Name => Name_Origin)));
4619 Target_Info.RPC_Receiver :=
4620 Make_Selected_Component (Loc,
4621 Prefix => Controlling_Parameter,
4622 Selector_Name => Name_Receiver);
4626 Make_Object_Declaration (Loc,
4627 Defining_Identifier => Target_Info.Partition,
4628 Constant_Present => True,
4629 Object_Definition =>
4630 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4633 Make_Function_Call (Loc,
4634 Name => Make_Selected_Component (Loc,
4636 Make_Identifier (Loc, Chars (RCI_Locator)),
4638 Make_Identifier (Loc,
4639 Name_Get_Active_Partition_ID)))));
4641 Target_Info.RPC_Receiver :=
4642 Make_Selected_Component (Loc,
4644 Make_Identifier (Loc, Chars (RCI_Locator)),
4646 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4649 end Build_Stub_Target;
4651 ---------------------
4652 -- Build_Stub_Type --
4653 ---------------------
4655 procedure Build_Stub_Type
4656 (RACW_Type : Entity_Id;
4657 Stub_Type_Comps : out List_Id;
4658 RPC_Receiver_Decl : out Node_Id)
4660 Loc : constant Source_Ptr := Sloc (RACW_Type);
4661 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4664 Stub_Type_Comps := New_List (
4665 Make_Component_Declaration (Loc,
4666 Defining_Identifier =>
4667 Make_Defining_Identifier (Loc, Name_Origin),
4668 Component_Definition =>
4669 Make_Component_Definition (Loc,
4670 Aliased_Present => False,
4671 Subtype_Indication =>
4672 New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
4674 Make_Component_Declaration (Loc,
4675 Defining_Identifier =>
4676 Make_Defining_Identifier (Loc, Name_Receiver),
4677 Component_Definition =>
4678 Make_Component_Definition (Loc,
4679 Aliased_Present => False,
4680 Subtype_Indication =>
4681 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4683 Make_Component_Declaration (Loc,
4684 Defining_Identifier =>
4685 Make_Defining_Identifier (Loc, Name_Addr),
4686 Component_Definition =>
4687 Make_Component_Definition (Loc,
4688 Aliased_Present => False,
4689 Subtype_Indication =>
4690 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4692 Make_Component_Declaration (Loc,
4693 Defining_Identifier =>
4694 Make_Defining_Identifier (Loc, Name_Asynchronous),
4695 Component_Definition =>
4696 Make_Component_Definition (Loc,
4697 Aliased_Present => False,
4698 Subtype_Indication =>
4699 New_Occurrence_Of (Standard_Boolean, Loc))));
4702 RPC_Receiver_Decl := Empty;
4705 RPC_Receiver_Request : constant Entity_Id :=
4706 Make_Defining_Identifier (Loc, Name_R);
4708 RPC_Receiver_Decl :=
4709 Make_Subprogram_Declaration (Loc,
4710 Build_RPC_Receiver_Specification (
4711 RPC_Receiver => Make_Defining_Identifier (Loc,
4712 New_Internal_Name ('R')),
4713 Request_Parameter => RPC_Receiver_Request));
4716 end Build_Stub_Type;
4718 --------------------------------------
4719 -- Build_Subprogram_Receiving_Stubs --
4720 --------------------------------------
4722 function Build_Subprogram_Receiving_Stubs
4723 (Vis_Decl : Node_Id;
4724 Asynchronous : Boolean;
4725 Dynamically_Asynchronous : Boolean := False;
4726 Stub_Type : Entity_Id := Empty;
4727 RACW_Type : Entity_Id := Empty;
4728 Parent_Primitive : Entity_Id := Empty) return Node_Id
4730 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4732 Request_Parameter : constant Entity_Id :=
4733 Make_Defining_Identifier (Loc,
4734 New_Internal_Name ('R'));
4735 -- Formal parameter for receiving stubs: a descriptor for an incoming
4738 Decls : constant List_Id := New_List;
4739 -- All the parameters will get declared before calling the real
4740 -- subprograms. Also the out parameters will be declared.
4742 Statements : constant List_Id := New_List;
4744 Extra_Formal_Statements : constant List_Id := New_List;
4745 -- Statements concerning extra formal parameters
4747 After_Statements : constant List_Id := New_List;
4748 -- Statements to be executed after the subprogram call
4750 Inner_Decls : List_Id := No_List;
4751 -- In case of a function, the inner declarations are needed since
4752 -- the result may be unconstrained.
4754 Excep_Handlers : List_Id := No_List;
4755 Excep_Choice : Entity_Id;
4756 Excep_Code : List_Id;
4758 Parameter_List : constant List_Id := New_List;
4759 -- List of parameters to be passed to the subprogram
4761 Current_Parameter : Node_Id;
4763 Ordered_Parameters_List : constant List_Id :=
4764 Build_Ordered_Parameters_List
4765 (Specification (Vis_Decl));
4767 Subp_Spec : Node_Id;
4768 -- Subprogram specification
4770 Called_Subprogram : Node_Id;
4771 -- The subprogram to call
4773 Null_Raise_Statement : Node_Id;
4775 Dynamic_Async : Entity_Id;
4778 if Present (RACW_Type) then
4779 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4781 Called_Subprogram :=
4783 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4786 if Dynamically_Asynchronous then
4788 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4790 Dynamic_Async := Empty;
4793 if not Asynchronous or Dynamically_Asynchronous then
4795 -- The first statement after the subprogram call is a statement to
4796 -- write a Null_Occurrence into the result stream.
4798 Null_Raise_Statement :=
4799 Make_Attribute_Reference (Loc,
4801 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4802 Attribute_Name => Name_Write,
4803 Expressions => New_List (
4804 Make_Selected_Component (Loc,
4805 Prefix => Request_Parameter,
4806 Selector_Name => Name_Result),
4807 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4809 if Dynamically_Asynchronous then
4810 Null_Raise_Statement :=
4811 Make_Implicit_If_Statement (Vis_Decl,
4813 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4814 Then_Statements => New_List (Null_Raise_Statement));
4817 Append_To (After_Statements, Null_Raise_Statement);
4820 -- Loop through every parameter and get its value from the stream. If
4821 -- the parameter is unconstrained, then the parameter is read using
4822 -- 'Input at the point of declaration.
4824 Current_Parameter := First (Ordered_Parameters_List);
4825 while Present (Current_Parameter) loop
4828 Constrained : Boolean;
4830 Need_Extra_Constrained : Boolean;
4831 -- True when an Extra_Constrained actual is required
4833 Object : constant Entity_Id :=
4834 Make_Defining_Identifier (Loc,
4835 New_Internal_Name ('P'));
4837 Expr : Node_Id := Empty;
4839 Is_Controlling_Formal : constant Boolean :=
4840 Is_RACW_Controlling_Formal
4841 (Current_Parameter, Stub_Type);
4844 if Is_Controlling_Formal then
4846 -- We have a controlling formal parameter. Read its address
4847 -- rather than a real object. The address is in Unsigned_64
4850 Etyp := RTE (RE_Unsigned_64);
4852 Etyp := Etype (Parameter_Type (Current_Parameter));
4855 Constrained := not Transmit_As_Unconstrained (Etyp);
4857 if In_Present (Current_Parameter)
4858 or else not Out_Present (Current_Parameter)
4859 or else not Constrained
4860 or else Is_Controlling_Formal
4862 -- If an input parameter is constrained, then the read of
4863 -- the parameter is deferred until the beginning of the
4864 -- subprogram body. If it is unconstrained, then an
4865 -- expression is built for the object declaration and the
4866 -- variable is set using 'Input instead of 'Read. Note that
4867 -- this deferral does not change the order in which the
4868 -- actuals are read because Build_Ordered_Parameter_List
4869 -- puts them unconstrained first.
4872 Append_To (Statements,
4873 Make_Attribute_Reference (Loc,
4874 Prefix => New_Occurrence_Of (Etyp, Loc),
4875 Attribute_Name => Name_Read,
4876 Expressions => New_List (
4877 Make_Selected_Component (Loc,
4878 Prefix => Request_Parameter,
4879 Selector_Name => Name_Params),
4880 New_Occurrence_Of (Object, Loc))));
4884 -- Build and append Input_With_Tag_Check function
4887 Input_With_Tag_Check (Loc,
4890 Make_Selected_Component (Loc,
4891 Prefix => Request_Parameter,
4892 Selector_Name => Name_Params)));
4894 -- Prepare function call expression
4897 Make_Function_Call (Loc,
4901 (Specification (Last (Decls))), Loc));
4905 Need_Extra_Constrained :=
4906 Nkind (Parameter_Type (Current_Parameter)) /=
4909 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4911 Present (Extra_Constrained
4912 (Defining_Identifier (Current_Parameter)));
4914 -- We may not associate an extra constrained actual to a
4915 -- constant object, so if one is needed, declare the actual
4916 -- as a variable even if it won't be modified.
4918 Build_Actual_Object_Declaration
4921 Variable => Need_Extra_Constrained
4922 or else Out_Present (Current_Parameter),
4926 -- An out parameter may be written back using a 'Write
4927 -- attribute instead of a 'Output because it has been
4928 -- constrained by the parameter given to the caller. Note that
4929 -- out controlling arguments in the case of a RACW are not put
4930 -- back in the stream because the pointer on them has not
4933 if Out_Present (Current_Parameter)
4935 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4937 Append_To (After_Statements,
4938 Make_Attribute_Reference (Loc,
4939 Prefix => New_Occurrence_Of (Etyp, Loc),
4940 Attribute_Name => Name_Write,
4941 Expressions => New_List (
4942 Make_Selected_Component (Loc,
4943 Prefix => Request_Parameter,
4944 Selector_Name => Name_Result),
4945 New_Occurrence_Of (Object, Loc))));
4948 -- For RACW controlling formals, the Etyp of Object is always
4949 -- an RACW, even if the parameter is not of an anonymous access
4950 -- type. In such case, we need to dereference it at call time.
4952 if Is_Controlling_Formal then
4953 if Nkind (Parameter_Type (Current_Parameter)) /=
4956 Append_To (Parameter_List,
4957 Make_Parameter_Association (Loc,
4960 Defining_Identifier (Current_Parameter), Loc),
4961 Explicit_Actual_Parameter =>
4962 Make_Explicit_Dereference (Loc,
4963 Unchecked_Convert_To (RACW_Type,
4964 OK_Convert_To (RTE (RE_Address),
4965 New_Occurrence_Of (Object, Loc))))));
4968 Append_To (Parameter_List,
4969 Make_Parameter_Association (Loc,
4972 Defining_Identifier (Current_Parameter), Loc),
4973 Explicit_Actual_Parameter =>
4974 Unchecked_Convert_To (RACW_Type,
4975 OK_Convert_To (RTE (RE_Address),
4976 New_Occurrence_Of (Object, Loc)))));
4980 Append_To (Parameter_List,
4981 Make_Parameter_Association (Loc,
4984 Defining_Identifier (Current_Parameter), Loc),
4985 Explicit_Actual_Parameter =>
4986 New_Occurrence_Of (Object, Loc)));
4989 -- If the current parameter needs an extra formal, then read it
4990 -- from the stream and set the corresponding semantic field in
4991 -- the variable. If the kind of the parameter identifier is
4992 -- E_Void, then this is a compiler generated parameter that
4993 -- doesn't need an extra constrained status.
4995 -- The case of Extra_Accessibility should also be handled ???
4997 if Need_Extra_Constrained then
4999 Extra_Parameter : constant Entity_Id :=
5001 (Defining_Identifier
5002 (Current_Parameter));
5004 Formal_Entity : constant Entity_Id :=
5005 Make_Defining_Identifier
5006 (Loc, Chars (Extra_Parameter));
5008 Formal_Type : constant Entity_Id :=
5009 Etype (Extra_Parameter);
5013 Make_Object_Declaration (Loc,
5014 Defining_Identifier => Formal_Entity,
5015 Object_Definition =>
5016 New_Occurrence_Of (Formal_Type, Loc)));
5018 Append_To (Extra_Formal_Statements,
5019 Make_Attribute_Reference (Loc,
5020 Prefix => New_Occurrence_Of (
5022 Attribute_Name => Name_Read,
5023 Expressions => New_List (
5024 Make_Selected_Component (Loc,
5025 Prefix => Request_Parameter,
5026 Selector_Name => Name_Params),
5027 New_Occurrence_Of (Formal_Entity, Loc))));
5029 -- Note: the call to Set_Extra_Constrained below relies
5030 -- on the fact that Object's Ekind has been set by
5031 -- Build_Actual_Object_Declaration.
5033 Set_Extra_Constrained (Object, Formal_Entity);
5038 Next (Current_Parameter);
5041 -- Append the formal statements list at the end of regular statements
5043 Append_List_To (Statements, Extra_Formal_Statements);
5045 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
5047 -- The remote subprogram is a function. We build an inner block to
5048 -- be able to hold a potentially unconstrained result in a
5052 Etyp : constant Entity_Id :=
5053 Etype (Result_Definition (Specification (Vis_Decl)));
5054 Result : constant Node_Id :=
5055 Make_Defining_Identifier (Loc,
5056 New_Internal_Name ('R'));
5058 Inner_Decls := New_List (
5059 Make_Object_Declaration (Loc,
5060 Defining_Identifier => Result,
5061 Constant_Present => True,
5062 Object_Definition => New_Occurrence_Of (Etyp, Loc),
5064 Make_Function_Call (Loc,
5065 Name => Called_Subprogram,
5066 Parameter_Associations => Parameter_List)));
5068 if Is_Class_Wide_Type (Etyp) then
5070 -- For a remote call to a function with a class-wide type,
5071 -- check that the returned value satisfies the requirements
5074 Append_To (Inner_Decls,
5075 Make_Transportable_Check (Loc,
5076 New_Occurrence_Of (Result, Loc)));
5080 Append_To (After_Statements,
5081 Make_Attribute_Reference (Loc,
5082 Prefix => New_Occurrence_Of (Etyp, Loc),
5083 Attribute_Name => Name_Output,
5084 Expressions => New_List (
5085 Make_Selected_Component (Loc,
5086 Prefix => Request_Parameter,
5087 Selector_Name => Name_Result),
5088 New_Occurrence_Of (Result, Loc))));
5091 Append_To (Statements,
5092 Make_Block_Statement (Loc,
5093 Declarations => Inner_Decls,
5094 Handled_Statement_Sequence =>
5095 Make_Handled_Sequence_Of_Statements (Loc,
5096 Statements => After_Statements)));
5099 -- The remote subprogram is a procedure. We do not need any inner
5100 -- block in this case.
5102 if Dynamically_Asynchronous then
5104 Make_Object_Declaration (Loc,
5105 Defining_Identifier => Dynamic_Async,
5106 Object_Definition =>
5107 New_Occurrence_Of (Standard_Boolean, Loc)));
5109 Append_To (Statements,
5110 Make_Attribute_Reference (Loc,
5111 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5112 Attribute_Name => Name_Read,
5113 Expressions => New_List (
5114 Make_Selected_Component (Loc,
5115 Prefix => Request_Parameter,
5116 Selector_Name => Name_Params),
5117 New_Occurrence_Of (Dynamic_Async, Loc))));
5120 Append_To (Statements,
5121 Make_Procedure_Call_Statement (Loc,
5122 Name => Called_Subprogram,
5123 Parameter_Associations => Parameter_List));
5125 Append_List_To (Statements, After_Statements);
5128 if Asynchronous and then not Dynamically_Asynchronous then
5130 -- For an asynchronous procedure, add a null exception handler
5132 Excep_Handlers := New_List (
5133 Make_Implicit_Exception_Handler (Loc,
5134 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5135 Statements => New_List (Make_Null_Statement (Loc))));
5138 -- In the other cases, if an exception is raised, then the
5139 -- exception occurrence is copied into the output stream and
5140 -- no other output parameter is written.
5143 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5145 Excep_Code := New_List (
5146 Make_Attribute_Reference (Loc,
5148 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5149 Attribute_Name => Name_Write,
5150 Expressions => New_List (
5151 Make_Selected_Component (Loc,
5152 Prefix => Request_Parameter,
5153 Selector_Name => Name_Result),
5154 New_Occurrence_Of (Excep_Choice, Loc))));
5156 if Dynamically_Asynchronous then
5157 Excep_Code := New_List (
5158 Make_Implicit_If_Statement (Vis_Decl,
5159 Condition => Make_Op_Not (Loc,
5160 New_Occurrence_Of (Dynamic_Async, Loc)),
5161 Then_Statements => Excep_Code));
5164 Excep_Handlers := New_List (
5165 Make_Implicit_Exception_Handler (Loc,
5166 Choice_Parameter => Excep_Choice,
5167 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5168 Statements => Excep_Code));
5173 Make_Procedure_Specification (Loc,
5174 Defining_Unit_Name =>
5175 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
5177 Parameter_Specifications => New_List (
5178 Make_Parameter_Specification (Loc,
5179 Defining_Identifier => Request_Parameter,
5181 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5184 Make_Subprogram_Body (Loc,
5185 Specification => Subp_Spec,
5186 Declarations => Decls,
5187 Handled_Statement_Sequence =>
5188 Make_Handled_Sequence_Of_Statements (Loc,
5189 Statements => Statements,
5190 Exception_Handlers => Excep_Handlers));
5191 end Build_Subprogram_Receiving_Stubs;
5197 function Result return Node_Id is
5199 return Make_Identifier (Loc, Name_V);
5202 ----------------------
5203 -- Stream_Parameter --
5204 ----------------------
5206 function Stream_Parameter return Node_Id is
5208 return Make_Identifier (Loc, Name_S);
5209 end Stream_Parameter;
5213 -------------------------------
5214 -- Get_And_Reset_RACW_Bodies --
5215 -------------------------------
5217 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5218 Desig : constant Entity_Id :=
5219 Etype (Designated_Type (RACW_Type));
5221 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5223 Body_Decls : List_Id;
5224 -- Returned list of declarations
5227 if Stub_Elements = Empty_Stub_Structure then
5229 -- Stub elements may be missing as a consequence of a previously
5235 Body_Decls := Stub_Elements.Body_Decls;
5236 Stub_Elements.Body_Decls := No_List;
5237 Stubs_Table.Set (Desig, Stub_Elements);
5239 end Get_And_Reset_RACW_Bodies;
5241 -----------------------
5242 -- Get_Stub_Elements --
5243 -----------------------
5245 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is
5246 Desig : constant Entity_Id :=
5247 Etype (Designated_Type (RACW_Type));
5248 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
5250 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5251 return Stub_Elements;
5252 end Get_Stub_Elements;
5254 -----------------------
5255 -- Get_Subprogram_Id --
5256 -----------------------
5258 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5259 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5261 pragma Assert (Result /= No_String);
5263 end Get_Subprogram_Id;
5265 -----------------------
5266 -- Get_Subprogram_Id --
5267 -----------------------
5269 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5271 return Get_Subprogram_Ids (Def).Int_Identifier;
5272 end Get_Subprogram_Id;
5274 ------------------------
5275 -- Get_Subprogram_Ids --
5276 ------------------------
5278 function Get_Subprogram_Ids
5279 (Def : Entity_Id) return Subprogram_Identifiers
5282 return Subprogram_Identifier_Table.Get (Def);
5283 end Get_Subprogram_Ids;
5289 function Hash (F : Entity_Id) return Hash_Index is
5291 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5294 function Hash (F : Name_Id) return Hash_Index is
5296 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5299 --------------------------
5300 -- Input_With_Tag_Check --
5301 --------------------------
5303 function Input_With_Tag_Check
5305 Var_Type : Entity_Id;
5306 Stream : Node_Id) return Node_Id
5310 Make_Subprogram_Body (Loc,
5311 Specification => Make_Function_Specification (Loc,
5312 Defining_Unit_Name =>
5313 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
5314 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5315 Declarations => No_List,
5316 Handled_Statement_Sequence =>
5317 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5318 Make_Tag_Check (Loc,
5319 Make_Simple_Return_Statement (Loc,
5320 Make_Attribute_Reference (Loc,
5321 Prefix => New_Occurrence_Of (Var_Type, Loc),
5322 Attribute_Name => Name_Input,
5324 New_List (Stream)))))));
5325 end Input_With_Tag_Check;
5327 --------------------------------
5328 -- Is_RACW_Controlling_Formal --
5329 --------------------------------
5331 function Is_RACW_Controlling_Formal
5332 (Parameter : Node_Id;
5333 Stub_Type : Entity_Id) return Boolean
5338 -- If the kind of the parameter is E_Void, then it is not a controlling
5339 -- formal (this can happen in the context of RAS).
5341 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5345 -- If the parameter is not a controlling formal, then it cannot be
5346 -- possibly a RACW_Controlling_Formal.
5348 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5352 Typ := Parameter_Type (Parameter);
5353 return (Nkind (Typ) = N_Access_Definition
5354 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5355 or else Etype (Typ) = Stub_Type;
5356 end Is_RACW_Controlling_Formal;
5358 ------------------------------
5359 -- Make_Transportable_Check --
5360 ------------------------------
5362 function Make_Transportable_Check
5364 Expr : Node_Id) return Node_Id is
5367 Make_Raise_Program_Error (Loc,
5370 Build_Get_Transportable (Loc,
5371 Make_Selected_Component (Loc,
5373 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5374 Reason => PE_Non_Transportable_Actual);
5375 end Make_Transportable_Check;
5377 -----------------------------
5378 -- Make_Selected_Component --
5379 -----------------------------
5381 function Make_Selected_Component
5384 Selector_Name : Name_Id) return Node_Id
5387 return Make_Selected_Component (Loc,
5388 Prefix => New_Occurrence_Of (Prefix, Loc),
5389 Selector_Name => Make_Identifier (Loc, Selector_Name));
5390 end Make_Selected_Component;
5392 --------------------
5393 -- Make_Tag_Check --
5394 --------------------
5396 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5397 Occ : constant Entity_Id :=
5398 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5401 return Make_Block_Statement (Loc,
5402 Handled_Statement_Sequence =>
5403 Make_Handled_Sequence_Of_Statements (Loc,
5404 Statements => New_List (N),
5406 Exception_Handlers => New_List (
5407 Make_Implicit_Exception_Handler (Loc,
5408 Choice_Parameter => Occ,
5410 Exception_Choices =>
5411 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5414 New_List (Make_Procedure_Call_Statement (Loc,
5416 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5417 New_List (New_Occurrence_Of (Occ, Loc))))))));
5420 ----------------------------
5421 -- Need_Extra_Constrained --
5422 ----------------------------
5424 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5425 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5427 return Out_Present (Parameter)
5428 and then Has_Discriminants (Etyp)
5429 and then not Is_Constrained (Etyp)
5430 and then not Is_Indefinite_Subtype (Etyp);
5431 end Need_Extra_Constrained;
5433 ------------------------------------
5434 -- Pack_Entity_Into_Stream_Access --
5435 ------------------------------------
5437 function Pack_Entity_Into_Stream_Access
5441 Etyp : Entity_Id := Empty) return Node_Id
5446 if Present (Etyp) then
5449 Typ := Etype (Object);
5453 Pack_Node_Into_Stream_Access (Loc,
5455 Object => New_Occurrence_Of (Object, Loc),
5457 end Pack_Entity_Into_Stream_Access;
5459 ---------------------------
5460 -- Pack_Node_Into_Stream --
5461 ---------------------------
5463 function Pack_Node_Into_Stream
5467 Etyp : Entity_Id) return Node_Id
5469 Write_Attribute : Name_Id := Name_Write;
5472 if not Is_Constrained (Etyp) then
5473 Write_Attribute := Name_Output;
5477 Make_Attribute_Reference (Loc,
5478 Prefix => New_Occurrence_Of (Etyp, Loc),
5479 Attribute_Name => Write_Attribute,
5480 Expressions => New_List (
5481 Make_Attribute_Reference (Loc,
5482 Prefix => New_Occurrence_Of (Stream, Loc),
5483 Attribute_Name => Name_Access),
5485 end Pack_Node_Into_Stream;
5487 ----------------------------------
5488 -- Pack_Node_Into_Stream_Access --
5489 ----------------------------------
5491 function Pack_Node_Into_Stream_Access
5495 Etyp : Entity_Id) return Node_Id
5497 Write_Attribute : Name_Id := Name_Write;
5500 if not Is_Constrained (Etyp) then
5501 Write_Attribute := Name_Output;
5505 Make_Attribute_Reference (Loc,
5506 Prefix => New_Occurrence_Of (Etyp, Loc),
5507 Attribute_Name => Write_Attribute,
5508 Expressions => New_List (
5511 end Pack_Node_Into_Stream_Access;
5513 ---------------------
5514 -- PolyORB_Support --
5515 ---------------------
5517 package body PolyORB_Support is
5519 -- Local subprograms
5521 procedure Add_RACW_Read_Attribute
5522 (RACW_Type : Entity_Id;
5523 Stub_Type : Entity_Id;
5524 Stub_Type_Access : Entity_Id;
5525 Body_Decls : List_Id);
5526 -- Add Read attribute for the RACW type. The declaration and attribute
5527 -- definition clauses are inserted right after the declaration of
5528 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5529 -- appended to it (case where the RACW declaration is in the main unit).
5531 procedure Add_RACW_Write_Attribute
5532 (RACW_Type : Entity_Id;
5533 Stub_Type : Entity_Id;
5534 Stub_Type_Access : Entity_Id;
5535 Body_Decls : List_Id);
5536 -- Same as above for the Write attribute
5538 procedure Add_RACW_From_Any
5539 (RACW_Type : Entity_Id;
5540 Body_Decls : List_Id);
5541 -- Add the From_Any TSS for this RACW type
5543 procedure Add_RACW_To_Any
5544 (RACW_Type : Entity_Id;
5545 Body_Decls : List_Id);
5546 -- Add the To_Any TSS for this RACW type
5548 procedure Add_RACW_TypeCode
5549 (Designated_Type : Entity_Id;
5550 RACW_Type : Entity_Id;
5551 Body_Decls : List_Id);
5552 -- Add the TypeCode TSS for this RACW type
5554 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5555 -- Add the From_Any TSS for this RAS type
5557 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5558 -- Add the To_Any TSS for this RAS type
5560 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5561 -- Add the TypeCode TSS for this RAS type
5563 procedure Add_RAS_Access_TSS (N : Node_Id);
5564 -- Add a subprogram body for RAS Access TSS
5566 -------------------------------------
5567 -- Add_Obj_RPC_Receiver_Completion --
5568 -------------------------------------
5570 procedure Add_Obj_RPC_Receiver_Completion
5573 RPC_Receiver : Entity_Id;
5574 Stub_Elements : Stub_Structure)
5576 Desig : constant Entity_Id :=
5577 Etype (Designated_Type (Stub_Elements.RACW_Type));
5580 Make_Procedure_Call_Statement (Loc,
5583 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5585 Parameter_Associations => New_List (
5589 Make_String_Literal (Loc,
5590 Full_Qualified_Name (Desig)),
5594 Make_Attribute_Reference (Loc,
5597 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5603 Make_Attribute_Reference (Loc,
5606 Defining_Identifier (
5607 Stub_Elements.RPC_Receiver_Decl), Loc),
5610 end Add_Obj_RPC_Receiver_Completion;
5612 -----------------------
5613 -- Add_RACW_Features --
5614 -----------------------
5616 procedure Add_RACW_Features
5617 (RACW_Type : Entity_Id;
5619 Stub_Type : Entity_Id;
5620 Stub_Type_Access : Entity_Id;
5621 RPC_Receiver_Decl : Node_Id;
5622 Body_Decls : List_Id)
5624 pragma Unreferenced (RPC_Receiver_Decl);
5628 (RACW_Type => RACW_Type,
5629 Body_Decls => Body_Decls);
5632 (RACW_Type => RACW_Type,
5633 Body_Decls => Body_Decls);
5635 Add_RACW_Write_Attribute
5636 (RACW_Type => RACW_Type,
5637 Stub_Type => Stub_Type,
5638 Stub_Type_Access => Stub_Type_Access,
5639 Body_Decls => Body_Decls);
5641 Add_RACW_Read_Attribute
5642 (RACW_Type => RACW_Type,
5643 Stub_Type => Stub_Type,
5644 Stub_Type_Access => Stub_Type_Access,
5645 Body_Decls => Body_Decls);
5648 (Designated_Type => Desig,
5649 RACW_Type => RACW_Type,
5650 Body_Decls => Body_Decls);
5651 end Add_RACW_Features;
5653 -----------------------
5654 -- Add_RACW_From_Any --
5655 -----------------------
5657 procedure Add_RACW_From_Any
5658 (RACW_Type : Entity_Id;
5659 Body_Decls : List_Id)
5661 Loc : constant Source_Ptr := Sloc (RACW_Type);
5662 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5663 Fnam : constant Entity_Id :=
5664 Make_Defining_Identifier (Loc,
5665 Chars => New_External_Name (Chars (RACW_Type), 'F'));
5667 Func_Spec : Node_Id;
5668 Func_Decl : Node_Id;
5669 Func_Body : Node_Id;
5671 Statements : List_Id;
5672 -- Various parts of the subprogram
5674 Any_Parameter : constant Entity_Id :=
5675 Make_Defining_Identifier (Loc, Name_A);
5677 Asynchronous_Flag : constant Entity_Id :=
5678 Asynchronous_Flags_Table.Get (RACW_Type);
5679 -- The flag object declared in Add_RACW_Asynchronous_Flag
5683 Make_Function_Specification (Loc,
5684 Defining_Unit_Name =>
5686 Parameter_Specifications => New_List (
5687 Make_Parameter_Specification (Loc,
5688 Defining_Identifier =>
5691 New_Occurrence_Of (RTE (RE_Any), Loc))),
5692 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5694 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5695 -- entity in the declaration spec, not those of the body spec.
5697 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5698 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5699 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5701 if No (Body_Decls) then
5705 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5706 -- set on the stub type if, and only if, the RACW type has a pragma
5707 -- Asynchronous. This is incorrect for RACWs that implement RAS
5708 -- types, because in that case the /designated subprogram/ (not the
5709 -- type) might be asynchronous, and that causes the stub to need to
5710 -- be asynchronous too. A solution is to transport a RAS as a struct
5711 -- containing a RACW and an asynchronous flag, and to properly alter
5712 -- the Asynchronous component in the stub type in the RAS's _From_Any
5715 Statements := New_List (
5716 Make_Simple_Return_Statement (Loc,
5717 Expression => Unchecked_Convert_To (RACW_Type,
5718 Make_Function_Call (Loc,
5719 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5720 Parameter_Associations => New_List (
5721 Make_Function_Call (Loc,
5722 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5723 Parameter_Associations => New_List (
5724 New_Occurrence_Of (Any_Parameter, Loc))),
5725 Build_Stub_Tag (Loc, RACW_Type),
5726 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5727 New_Occurrence_Of (Asynchronous_Flag, Loc))))));
5730 Make_Subprogram_Body (Loc,
5731 Specification => Copy_Specification (Loc, Func_Spec),
5732 Declarations => No_List,
5733 Handled_Statement_Sequence =>
5734 Make_Handled_Sequence_Of_Statements (Loc,
5735 Statements => Statements));
5737 Append_To (Body_Decls, Func_Body);
5738 end Add_RACW_From_Any;
5740 -----------------------------
5741 -- Add_RACW_Read_Attribute --
5742 -----------------------------
5744 procedure Add_RACW_Read_Attribute
5745 (RACW_Type : Entity_Id;
5746 Stub_Type : Entity_Id;
5747 Stub_Type_Access : Entity_Id;
5748 Body_Decls : List_Id)
5750 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5752 Loc : constant Source_Ptr := Sloc (RACW_Type);
5754 Proc_Decl : Node_Id;
5755 Attr_Decl : Node_Id;
5757 Body_Node : Node_Id;
5759 Decls : constant List_Id := New_List;
5760 Statements : constant List_Id := New_List;
5761 Reference : constant Entity_Id :=
5762 Make_Defining_Identifier (Loc, Name_R);
5763 -- Various parts of the procedure
5765 Pnam : constant Entity_Id := Make_Defining_Identifier (Loc,
5766 New_Internal_Name ('R'));
5768 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5770 Asynchronous_Flag : constant Entity_Id :=
5771 Asynchronous_Flags_Table.Get (RACW_Type);
5772 pragma Assert (Present (Asynchronous_Flag));
5774 function Stream_Parameter return Node_Id;
5775 function Result return Node_Id;
5777 -- Functions to create occurrences of the formal parameter names
5783 function Result return Node_Id is
5785 return Make_Identifier (Loc, Name_V);
5788 ----------------------
5789 -- Stream_Parameter --
5790 ----------------------
5792 function Stream_Parameter return Node_Id is
5794 return Make_Identifier (Loc, Name_S);
5795 end Stream_Parameter;
5797 -- Start of processing for Add_RACW_Read_Attribute
5800 Build_Stream_Procedure
5801 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
5803 Proc_Decl := Make_Subprogram_Declaration (Loc,
5804 Copy_Specification (Loc, Specification (Body_Node)));
5807 Make_Attribute_Definition_Clause (Loc,
5808 Name => New_Occurrence_Of (RACW_Type, Loc),
5812 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5814 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5815 Insert_After (Proc_Decl, Attr_Decl);
5817 if No (Body_Decls) then
5822 Make_Object_Declaration (Loc,
5823 Defining_Identifier =>
5825 Object_Definition =>
5826 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5828 Append_List_To (Statements, New_List (
5829 Make_Attribute_Reference (Loc,
5831 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5832 Attribute_Name => Name_Read,
5833 Expressions => New_List (
5835 New_Occurrence_Of (Reference, Loc))),
5837 Make_Assignment_Statement (Loc,
5841 Unchecked_Convert_To (RACW_Type,
5842 Make_Function_Call (Loc,
5844 New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5845 Parameter_Associations => New_List (
5846 New_Occurrence_Of (Reference, Loc),
5847 Build_Stub_Tag (Loc, RACW_Type),
5848 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5849 New_Occurrence_Of (Asynchronous_Flag, Loc)))))));
5851 Set_Declarations (Body_Node, Decls);
5852 Append_To (Body_Decls, Body_Node);
5853 end Add_RACW_Read_Attribute;
5855 ---------------------
5856 -- Add_RACW_To_Any --
5857 ---------------------
5859 procedure Add_RACW_To_Any
5860 (RACW_Type : Entity_Id;
5861 Body_Decls : List_Id)
5863 Loc : constant Source_Ptr := Sloc (RACW_Type);
5865 Fnam : constant Entity_Id :=
5866 Make_Defining_Identifier (Loc,
5867 Chars => New_External_Name (Chars (RACW_Type), 'T'));
5869 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5871 Stub_Elements : constant Stub_Structure :=
5872 Get_Stub_Elements (RACW_Type);
5874 Func_Spec : Node_Id;
5875 Func_Decl : Node_Id;
5876 Func_Body : Node_Id;
5879 Statements : List_Id;
5880 -- Various parts of the subprogram
5882 RACW_Parameter : constant Entity_Id :=
5883 Make_Defining_Identifier (Loc, Name_R);
5885 Reference : constant Entity_Id :=
5886 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
5887 Any : constant Entity_Id :=
5888 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
5892 Make_Function_Specification (Loc,
5893 Defining_Unit_Name =>
5895 Parameter_Specifications => New_List (
5896 Make_Parameter_Specification (Loc,
5897 Defining_Identifier =>
5900 New_Occurrence_Of (RACW_Type, Loc))),
5901 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5903 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5904 -- entity in the declaration spec, not in the body spec.
5906 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5908 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5909 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5911 if No (Body_Decls) then
5917 -- R : constant Object_Ref :=
5923 -- RPC_Receiver'Access);
5927 Make_Object_Declaration (Loc,
5928 Defining_Identifier => Reference,
5929 Constant_Present => True,
5930 Object_Definition =>
5931 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5933 Make_Function_Call (Loc,
5934 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5935 Parameter_Associations => New_List (
5936 Unchecked_Convert_To (RTE (RE_Address),
5937 New_Occurrence_Of (RACW_Parameter, Loc)),
5938 Make_String_Literal (Loc,
5939 Strval => Full_Qualified_Name
5940 (Etype (Designated_Type (RACW_Type)))),
5941 Build_Stub_Tag (Loc, RACW_Type),
5942 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5943 Make_Attribute_Reference (Loc,
5946 (Defining_Identifier
5947 (Stub_Elements.RPC_Receiver_Decl), Loc),
5948 Attribute_Name => Name_Access)))),
5950 Make_Object_Declaration (Loc,
5951 Defining_Identifier => Any,
5952 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)));
5956 -- Any := TA_ObjRef (Reference);
5957 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5960 Statements := New_List (
5961 Make_Assignment_Statement (Loc,
5962 Name => New_Occurrence_Of (Any, Loc),
5964 Make_Function_Call (Loc,
5965 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5966 Parameter_Associations => New_List (
5967 New_Occurrence_Of (Reference, Loc)))),
5969 Make_Procedure_Call_Statement (Loc,
5970 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5971 Parameter_Associations => New_List (
5972 New_Occurrence_Of (Any, Loc),
5973 Make_Selected_Component (Loc,
5975 Defining_Identifier (
5976 Stub_Elements.RPC_Receiver_Decl),
5977 Selector_Name => Name_Obj_TypeCode))),
5979 Make_Simple_Return_Statement (Loc,
5980 Expression => New_Occurrence_Of (Any, Loc)));
5983 Make_Subprogram_Body (Loc,
5984 Specification => Copy_Specification (Loc, Func_Spec),
5985 Declarations => Decls,
5986 Handled_Statement_Sequence =>
5987 Make_Handled_Sequence_Of_Statements (Loc,
5988 Statements => Statements));
5989 Append_To (Body_Decls, Func_Body);
5990 end Add_RACW_To_Any;
5992 -----------------------
5993 -- Add_RACW_TypeCode --
5994 -----------------------
5996 procedure Add_RACW_TypeCode
5997 (Designated_Type : Entity_Id;
5998 RACW_Type : Entity_Id;
5999 Body_Decls : List_Id)
6001 Loc : constant Source_Ptr := Sloc (RACW_Type);
6003 Fnam : constant Entity_Id :=
6004 Make_Defining_Identifier (Loc,
6005 Chars => New_External_Name (Chars (RACW_Type), 'Y'));
6007 Stub_Elements : constant Stub_Structure :=
6008 Stubs_Table.Get (Designated_Type);
6009 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6011 Func_Spec : Node_Id;
6012 Func_Decl : Node_Id;
6013 Func_Body : Node_Id;
6016 -- The spec for this subprogram has a dummy 'access RACW' argument,
6017 -- which serves only for overloading purposes.
6020 Make_Function_Specification (Loc,
6021 Defining_Unit_Name => Fnam,
6022 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6024 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6025 -- entity in the declaration spec, not those of the body spec.
6027 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6028 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6029 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6031 if No (Body_Decls) then
6036 Make_Subprogram_Body (Loc,
6037 Specification => Copy_Specification (Loc, Func_Spec),
6038 Declarations => Empty_List,
6039 Handled_Statement_Sequence =>
6040 Make_Handled_Sequence_Of_Statements (Loc,
6041 Statements => New_List (
6042 Make_Simple_Return_Statement (Loc,
6044 Make_Selected_Component (Loc,
6047 (Stub_Elements.RPC_Receiver_Decl),
6048 Selector_Name => Name_Obj_TypeCode)))));
6050 Append_To (Body_Decls, Func_Body);
6051 end Add_RACW_TypeCode;
6053 ------------------------------
6054 -- Add_RACW_Write_Attribute --
6055 ------------------------------
6057 procedure Add_RACW_Write_Attribute
6058 (RACW_Type : Entity_Id;
6059 Stub_Type : Entity_Id;
6060 Stub_Type_Access : Entity_Id;
6061 Body_Decls : List_Id)
6063 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6065 Loc : constant Source_Ptr := Sloc (RACW_Type);
6067 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
6069 Stub_Elements : constant Stub_Structure :=
6070 Get_Stub_Elements (RACW_Type);
6072 Body_Node : Node_Id;
6073 Proc_Decl : Node_Id;
6074 Attr_Decl : Node_Id;
6076 Statements : constant List_Id := New_List;
6077 Pnam : constant Entity_Id :=
6078 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
6080 function Stream_Parameter return Node_Id;
6081 function Object return Node_Id;
6082 -- Functions to create occurrences of the formal parameter names
6088 function Object return Node_Id is
6090 return Make_Identifier (Loc, Name_V);
6093 ----------------------
6094 -- Stream_Parameter --
6095 ----------------------
6097 function Stream_Parameter return Node_Id is
6099 return Make_Identifier (Loc, Name_S);
6100 end Stream_Parameter;
6102 -- Start of processing for Add_RACW_Write_Attribute
6105 Build_Stream_Procedure
6106 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
6109 Make_Subprogram_Declaration (Loc,
6110 Copy_Specification (Loc, Specification (Body_Node)));
6113 Make_Attribute_Definition_Clause (Loc,
6114 Name => New_Occurrence_Of (RACW_Type, Loc),
6115 Chars => Name_Write,
6118 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6120 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6121 Insert_After (Proc_Decl, Attr_Decl);
6123 if No (Body_Decls) then
6127 Append_To (Statements,
6128 Pack_Node_Into_Stream_Access (Loc,
6129 Stream => Stream_Parameter,
6131 Make_Function_Call (Loc,
6132 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6133 Parameter_Associations => New_List (
6134 Unchecked_Convert_To (RTE (RE_Address), Object),
6135 Make_String_Literal (Loc,
6136 Strval => Full_Qualified_Name
6137 (Etype (Designated_Type (RACW_Type)))),
6138 Build_Stub_Tag (Loc, RACW_Type),
6139 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
6140 Make_Attribute_Reference (Loc,
6143 (Defining_Identifier
6144 (Stub_Elements.RPC_Receiver_Decl), Loc),
6145 Attribute_Name => Name_Access))),
6147 Etyp => RTE (RE_Object_Ref)));
6149 Append_To (Body_Decls, Body_Node);
6150 end Add_RACW_Write_Attribute;
6152 -----------------------
6153 -- Add_RAST_Features --
6154 -----------------------
6156 procedure Add_RAST_Features
6157 (Vis_Decl : Node_Id;
6158 RAS_Type : Entity_Id)
6161 Add_RAS_Access_TSS (Vis_Decl);
6163 Add_RAS_From_Any (RAS_Type);
6164 Add_RAS_TypeCode (RAS_Type);
6166 -- To_Any uses TypeCode, and therefore needs to be generated last
6168 Add_RAS_To_Any (RAS_Type);
6169 end Add_RAST_Features;
6171 ------------------------
6172 -- Add_RAS_Access_TSS --
6173 ------------------------
6175 procedure Add_RAS_Access_TSS (N : Node_Id) is
6176 Loc : constant Source_Ptr := Sloc (N);
6178 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6179 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6180 -- Ras_Type is the access to subprogram type; Fat_Type is the
6181 -- corresponding record type.
6183 RACW_Type : constant Entity_Id :=
6184 Underlying_RACW_Type (Ras_Type);
6186 Stub_Elements : constant Stub_Structure :=
6187 Get_Stub_Elements (RACW_Type);
6189 Proc : constant Entity_Id :=
6190 Make_Defining_Identifier (Loc,
6191 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6193 Proc_Spec : Node_Id;
6195 -- Formal parameters
6197 Package_Name : constant Entity_Id :=
6198 Make_Defining_Identifier (Loc,
6203 Subp_Id : constant Entity_Id :=
6204 Make_Defining_Identifier (Loc,
6207 -- Target subprogram
6209 Asynch_P : constant Entity_Id :=
6210 Make_Defining_Identifier (Loc,
6211 Chars => Name_Asynchronous);
6212 -- Is the procedure to which the 'Access applies asynchronous?
6214 All_Calls_Remote : constant Entity_Id :=
6215 Make_Defining_Identifier (Loc,
6216 Chars => Name_All_Calls_Remote);
6217 -- True if an All_Calls_Remote pragma applies to the RCI unit
6218 -- that contains the subprogram.
6220 -- Common local variables
6222 Proc_Decls : List_Id;
6223 Proc_Statements : List_Id;
6225 Subp_Ref : constant Entity_Id :=
6226 Make_Defining_Identifier (Loc, Name_R);
6227 -- Reference that designates the target subprogram (returned
6228 -- by Get_RAS_Info).
6230 Is_Local : constant Entity_Id :=
6231 Make_Defining_Identifier (Loc, Name_L);
6232 Local_Addr : constant Entity_Id :=
6233 Make_Defining_Identifier (Loc, Name_A);
6234 -- For the call to Get_Local_Address
6236 -- Additional local variables for the remote case
6238 Local_Stub : constant Entity_Id :=
6239 Make_Defining_Identifier (Loc,
6240 Chars => New_Internal_Name ('L'));
6242 Stub_Ptr : constant Entity_Id :=
6243 Make_Defining_Identifier (Loc,
6244 Chars => New_Internal_Name ('S'));
6247 (Field_Name : Name_Id;
6248 Value : Node_Id) return Node_Id;
6249 -- Construct an assignment that sets the named component in the
6257 (Field_Name : Name_Id;
6258 Value : Node_Id) return Node_Id
6262 Make_Assignment_Statement (Loc,
6264 Make_Selected_Component (Loc,
6266 Selector_Name => Field_Name),
6267 Expression => Value);
6270 -- Start of processing for Add_RAS_Access_TSS
6273 Proc_Decls := New_List (
6275 -- Common declarations
6277 Make_Object_Declaration (Loc,
6278 Defining_Identifier => Subp_Ref,
6279 Object_Definition =>
6280 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6282 Make_Object_Declaration (Loc,
6283 Defining_Identifier => Is_Local,
6284 Object_Definition =>
6285 New_Occurrence_Of (Standard_Boolean, Loc)),
6287 Make_Object_Declaration (Loc,
6288 Defining_Identifier => Local_Addr,
6289 Object_Definition =>
6290 New_Occurrence_Of (RTE (RE_Address), Loc)),
6292 Make_Object_Declaration (Loc,
6293 Defining_Identifier => Local_Stub,
6294 Aliased_Present => True,
6295 Object_Definition =>
6296 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6298 Make_Object_Declaration (Loc,
6299 Defining_Identifier => Stub_Ptr,
6300 Object_Definition =>
6301 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6303 Make_Attribute_Reference (Loc,
6304 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6305 Attribute_Name => Name_Unchecked_Access)));
6307 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6308 -- Build_Get_Unique_RP_Call needs this information
6310 -- Get_RAS_Info (Pkg, Subp, R);
6311 -- Obtain a reference to the target subprogram
6313 Proc_Statements := New_List (
6314 Make_Procedure_Call_Statement (Loc,
6315 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6316 Parameter_Associations => New_List (
6317 New_Occurrence_Of (Package_Name, Loc),
6318 New_Occurrence_Of (Subp_Id, Loc),
6319 New_Occurrence_Of (Subp_Ref, Loc))),
6321 -- Get_Local_Address (R, L, A);
6322 -- Determine whether the subprogram is local (L), and if so
6323 -- obtain the local address of its proxy (A).
6325 Make_Procedure_Call_Statement (Loc,
6326 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6327 Parameter_Associations => New_List (
6328 New_Occurrence_Of (Subp_Ref, Loc),
6329 New_Occurrence_Of (Is_Local, Loc),
6330 New_Occurrence_Of (Local_Addr, Loc))));
6332 -- Note: Here we assume that the Fat_Type is a record containing just
6333 -- an access to a proxy or stub object.
6335 Append_To (Proc_Statements,
6339 Make_Implicit_If_Statement (N,
6340 Condition => New_Occurrence_Of (Is_Local, Loc),
6342 Then_Statements => New_List (
6344 -- if A.Target = null then
6346 Make_Implicit_If_Statement (N,
6349 Make_Selected_Component (Loc,
6351 Unchecked_Convert_To
6352 (RTE (RE_RAS_Proxy_Type_Access),
6353 New_Occurrence_Of (Local_Addr, Loc)),
6354 Selector_Name => Make_Identifier (Loc, Name_Target)),
6357 Then_Statements => New_List (
6359 -- A.Target := Entity_Of (Ref);
6361 Make_Assignment_Statement (Loc,
6363 Make_Selected_Component (Loc,
6365 Unchecked_Convert_To
6366 (RTE (RE_RAS_Proxy_Type_Access),
6367 New_Occurrence_Of (Local_Addr, Loc)),
6368 Selector_Name => Make_Identifier (Loc, Name_Target)),
6370 Make_Function_Call (Loc,
6371 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6372 Parameter_Associations => New_List (
6373 New_Occurrence_Of (Subp_Ref, Loc)))),
6375 -- Inc_Usage (A.Target);
6378 Make_Procedure_Call_Statement (Loc,
6379 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6380 Parameter_Associations => New_List (
6381 Make_Selected_Component (Loc,
6383 Unchecked_Convert_To
6384 (RTE (RE_RAS_Proxy_Type_Access),
6385 New_Occurrence_Of (Local_Addr, Loc)),
6387 Make_Identifier (Loc, Name_Target)))))),
6389 -- if not All_Calls_Remote then
6390 -- return Fat_Type!(A);
6393 Make_Implicit_If_Statement (N,
6397 New_Occurrence_Of (All_Calls_Remote, Loc)),
6399 Then_Statements => New_List (
6400 Make_Simple_Return_Statement (Loc,
6402 Unchecked_Convert_To
6403 (Fat_Type, New_Occurrence_Of (Local_Addr, Loc))))))));
6405 Append_List_To (Proc_Statements, New_List (
6407 -- Stub.Target := Entity_Of (Ref);
6409 Set_Field (Name_Target,
6410 Make_Function_Call (Loc,
6411 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6412 Parameter_Associations => New_List (
6413 New_Occurrence_Of (Subp_Ref, Loc)))),
6415 -- Inc_Usage (Stub.Target);
6417 Make_Procedure_Call_Statement (Loc,
6418 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6419 Parameter_Associations => New_List (
6420 Make_Selected_Component (Loc,
6422 Selector_Name => Name_Target))),
6424 -- E.4.1(9) A remote call is asynchronous if it is a call to
6425 -- a procedure, or a call through a value of an access-to-procedure
6426 -- type, to which a pragma Asynchronous applies.
6428 -- Parameter Asynch_P is true when the procedure is asynchronous;
6429 -- Expression Asynch_T is true when the type is asynchronous.
6431 Set_Field (Name_Asynchronous,
6433 Left_Opnd => New_Occurrence_Of (Asynch_P, Loc),
6436 (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc)))));
6438 Append_List_To (Proc_Statements,
6439 Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
6441 Append_To (Proc_Statements,
6442 Make_Simple_Return_Statement (Loc,
6444 Unchecked_Convert_To (Fat_Type,
6445 New_Occurrence_Of (Stub_Ptr, Loc))));
6448 Make_Function_Specification (Loc,
6449 Defining_Unit_Name => Proc,
6450 Parameter_Specifications => New_List (
6451 Make_Parameter_Specification (Loc,
6452 Defining_Identifier => Package_Name,
6454 New_Occurrence_Of (Standard_String, Loc)),
6456 Make_Parameter_Specification (Loc,
6457 Defining_Identifier => Subp_Id,
6459 New_Occurrence_Of (Standard_String, Loc)),
6461 Make_Parameter_Specification (Loc,
6462 Defining_Identifier => Asynch_P,
6464 New_Occurrence_Of (Standard_Boolean, Loc)),
6466 Make_Parameter_Specification (Loc,
6467 Defining_Identifier => All_Calls_Remote,
6469 New_Occurrence_Of (Standard_Boolean, Loc))),
6471 Result_Definition =>
6472 New_Occurrence_Of (Fat_Type, Loc));
6474 -- Set the kind and return type of the function to prevent
6475 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6477 Set_Ekind (Proc, E_Function);
6478 Set_Etype (Proc, Fat_Type);
6481 Make_Subprogram_Body (Loc,
6482 Specification => Proc_Spec,
6483 Declarations => Proc_Decls,
6484 Handled_Statement_Sequence =>
6485 Make_Handled_Sequence_Of_Statements (Loc,
6486 Statements => Proc_Statements)));
6488 Set_TSS (Fat_Type, Proc);
6489 end Add_RAS_Access_TSS;
6491 ----------------------
6492 -- Add_RAS_From_Any --
6493 ----------------------
6495 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6496 Loc : constant Source_Ptr := Sloc (RAS_Type);
6498 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6499 Make_TSS_Name (RAS_Type, TSS_From_Any));
6501 Func_Spec : Node_Id;
6503 Statements : List_Id;
6505 Any_Parameter : constant Entity_Id :=
6506 Make_Defining_Identifier (Loc, Name_A);
6509 Statements := New_List (
6510 Make_Simple_Return_Statement (Loc,
6512 Make_Aggregate (Loc,
6513 Component_Associations => New_List (
6514 Make_Component_Association (Loc,
6515 Choices => New_List (
6516 Make_Identifier (Loc, Name_Ras)),
6518 PolyORB_Support.Helpers.Build_From_Any_Call (
6519 Underlying_RACW_Type (RAS_Type),
6520 New_Occurrence_Of (Any_Parameter, Loc),
6524 Make_Function_Specification (Loc,
6525 Defining_Unit_Name => Fnam,
6526 Parameter_Specifications => New_List (
6527 Make_Parameter_Specification (Loc,
6528 Defining_Identifier => Any_Parameter,
6529 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
6530 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6533 Make_Subprogram_Body (Loc,
6534 Specification => Func_Spec,
6535 Declarations => No_List,
6536 Handled_Statement_Sequence =>
6537 Make_Handled_Sequence_Of_Statements (Loc,
6538 Statements => Statements)));
6539 Set_TSS (RAS_Type, Fnam);
6540 end Add_RAS_From_Any;
6542 --------------------
6543 -- Add_RAS_To_Any --
6544 --------------------
6546 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6547 Loc : constant Source_Ptr := Sloc (RAS_Type);
6549 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6550 Make_TSS_Name (RAS_Type, TSS_To_Any));
6553 Statements : List_Id;
6555 Func_Spec : Node_Id;
6557 Any : constant Entity_Id :=
6558 Make_Defining_Identifier (Loc,
6559 Chars => New_Internal_Name ('A'));
6560 RAS_Parameter : constant Entity_Id :=
6561 Make_Defining_Identifier (Loc,
6562 Chars => New_Internal_Name ('R'));
6563 RACW_Parameter : constant Node_Id :=
6564 Make_Selected_Component (Loc,
6565 Prefix => RAS_Parameter,
6566 Selector_Name => Name_Ras);
6569 -- Object declarations
6571 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6573 Make_Object_Declaration (Loc,
6574 Defining_Identifier => Any,
6575 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc),
6577 PolyORB_Support.Helpers.Build_To_Any_Call
6578 (RACW_Parameter, No_List)));
6580 Statements := New_List (
6581 Make_Procedure_Call_Statement (Loc,
6582 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6583 Parameter_Associations => New_List (
6584 New_Occurrence_Of (Any, Loc),
6585 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6588 Make_Simple_Return_Statement (Loc,
6589 Expression => New_Occurrence_Of (Any, Loc)));
6592 Make_Function_Specification (Loc,
6593 Defining_Unit_Name => Fnam,
6594 Parameter_Specifications => New_List (
6595 Make_Parameter_Specification (Loc,
6596 Defining_Identifier => RAS_Parameter,
6597 Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))),
6598 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6601 Make_Subprogram_Body (Loc,
6602 Specification => Func_Spec,
6603 Declarations => Decls,
6604 Handled_Statement_Sequence =>
6605 Make_Handled_Sequence_Of_Statements (Loc,
6606 Statements => Statements)));
6607 Set_TSS (RAS_Type, Fnam);
6610 ----------------------
6611 -- Add_RAS_TypeCode --
6612 ----------------------
6614 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6615 Loc : constant Source_Ptr := Sloc (RAS_Type);
6617 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6618 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6620 Func_Spec : Node_Id;
6621 Decls : constant List_Id := New_List;
6622 Name_String : String_Id;
6623 Repo_Id_String : String_Id;
6627 Make_Function_Specification (Loc,
6628 Defining_Unit_Name => Fnam,
6629 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6631 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6632 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6635 Make_Subprogram_Body (Loc,
6636 Specification => Func_Spec,
6637 Declarations => Decls,
6638 Handled_Statement_Sequence =>
6639 Make_Handled_Sequence_Of_Statements (Loc,
6640 Statements => New_List (
6641 Make_Simple_Return_Statement (Loc,
6643 Make_Function_Call (Loc,
6644 Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6645 Parameter_Associations => New_List (
6646 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6647 Make_Aggregate (Loc,
6650 Make_Function_Call (Loc,
6653 (RTE (RE_TA_Std_String), Loc),
6654 Parameter_Associations => New_List (
6655 Make_String_Literal (Loc, Name_String))),
6656 Make_Function_Call (Loc,
6659 (RTE (RE_TA_Std_String), Loc),
6660 Parameter_Associations => New_List (
6661 Make_String_Literal (Loc,
6662 Strval => Repo_Id_String))))))))))));
6663 Set_TSS (RAS_Type, Fnam);
6664 end Add_RAS_TypeCode;
6666 -----------------------------------------
6667 -- Add_Receiving_Stubs_To_Declarations --
6668 -----------------------------------------
6670 procedure Add_Receiving_Stubs_To_Declarations
6671 (Pkg_Spec : Node_Id;
6675 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6677 Pkg_RPC_Receiver : constant Entity_Id :=
6678 Make_Defining_Identifier (Loc,
6679 New_Internal_Name ('H'));
6680 Pkg_RPC_Receiver_Object : Node_Id;
6681 Pkg_RPC_Receiver_Body : Node_Id;
6682 Pkg_RPC_Receiver_Decls : List_Id;
6683 Pkg_RPC_Receiver_Statements : List_Id;
6685 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6686 -- A Pkg_RPC_Receiver is built to decode the request
6689 -- Request object received from neutral layer
6691 Subp_Id : Entity_Id;
6692 -- Subprogram identifier as received from the neutral distribution
6695 Subp_Index : Entity_Id;
6696 -- Internal index as determined by matching either the method name
6697 -- from the request structure, or the local subprogram address (in
6700 Is_Local : constant Entity_Id :=
6701 Make_Defining_Identifier (Loc,
6702 Chars => New_Internal_Name ('L'));
6704 Local_Address : constant Entity_Id :=
6705 Make_Defining_Identifier (Loc,
6706 Chars => New_Internal_Name ('A'));
6707 -- Address of a local subprogram designated by a reference
6708 -- corresponding to a RAS.
6710 Dispatch_On_Address : constant List_Id := New_List;
6711 Dispatch_On_Name : constant List_Id := New_List;
6713 Current_Declaration : Node_Id;
6714 Current_Stubs : Node_Id;
6715 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6717 Subp_Info_Array : constant Entity_Id :=
6718 Make_Defining_Identifier (Loc,
6719 Chars => New_Internal_Name ('I'));
6721 Subp_Info_List : constant List_Id := New_List;
6723 Register_Pkg_Actuals : constant List_Id := New_List;
6725 All_Calls_Remote_E : Entity_Id;
6727 procedure Append_Stubs_To
6728 (RPC_Receiver_Cases : List_Id;
6729 Declaration : Node_Id;
6732 Subp_Dist_Name : Entity_Id;
6733 Subp_Proxy_Addr : Entity_Id);
6734 -- Add one case to the specified RPC receiver case list associating
6735 -- Subprogram_Number with the subprogram declared by Declaration, for
6736 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6737 -- subprogram index. Subp_Dist_Name is the string used to call the
6738 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6739 -- object, used in the context of calls through remote
6740 -- access-to-subprogram types.
6742 ---------------------
6743 -- Append_Stubs_To --
6744 ---------------------
6746 procedure Append_Stubs_To
6747 (RPC_Receiver_Cases : List_Id;
6748 Declaration : Node_Id;
6751 Subp_Dist_Name : Entity_Id;
6752 Subp_Proxy_Addr : Entity_Id)
6754 Case_Stmts : List_Id;
6756 Case_Stmts := New_List (
6757 Make_Procedure_Call_Statement (Loc,
6760 Defining_Entity (Stubs), Loc),
6761 Parameter_Associations =>
6762 New_List (New_Occurrence_Of (Request, Loc))));
6764 if Nkind (Specification (Declaration)) = N_Function_Specification
6766 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6768 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6771 Append_To (RPC_Receiver_Cases,
6772 Make_Case_Statement_Alternative (Loc,
6774 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6775 Statements => Case_Stmts));
6777 Append_To (Dispatch_On_Name,
6778 Make_Elsif_Part (Loc,
6780 Make_Function_Call (Loc,
6782 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6783 Parameter_Associations => New_List (
6784 New_Occurrence_Of (Subp_Id, Loc),
6785 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6787 Then_Statements => New_List (
6788 Make_Assignment_Statement (Loc,
6789 New_Occurrence_Of (Subp_Index, Loc),
6790 Make_Integer_Literal (Loc, Subp_Number)))));
6792 Append_To (Dispatch_On_Address,
6793 Make_Elsif_Part (Loc,
6796 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6797 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6799 Then_Statements => New_List (
6800 Make_Assignment_Statement (Loc,
6801 New_Occurrence_Of (Subp_Index, Loc),
6802 Make_Integer_Literal (Loc, Subp_Number)))));
6803 end Append_Stubs_To;
6805 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6808 -- Building receiving stubs consist in several operations:
6810 -- - a package RPC receiver must be built. This subprogram will get
6811 -- a Subprogram_Id from the incoming stream and will dispatch the
6812 -- call to the right subprogram;
6814 -- - a receiving stub for each subprogram visible in the package
6815 -- spec. This stub will read all the parameters from the stream,
6816 -- and put the result as well as the exception occurrence in the
6819 Build_RPC_Receiver_Body (
6820 RPC_Receiver => Pkg_RPC_Receiver,
6823 Subp_Index => Subp_Index,
6824 Stmts => Pkg_RPC_Receiver_Statements,
6825 Decl => Pkg_RPC_Receiver_Body);
6826 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6828 -- Extract local address information from the target reference:
6829 -- if non-null, that means that this is a reference that denotes
6830 -- one particular operation, and hence that the operation name
6831 -- must not be taken into account for dispatching.
6833 Append_To (Pkg_RPC_Receiver_Decls,
6834 Make_Object_Declaration (Loc,
6835 Defining_Identifier => Is_Local,
6836 Object_Definition =>
6837 New_Occurrence_Of (Standard_Boolean, Loc)));
6839 Append_To (Pkg_RPC_Receiver_Decls,
6840 Make_Object_Declaration (Loc,
6841 Defining_Identifier => Local_Address,
6842 Object_Definition =>
6843 New_Occurrence_Of (RTE (RE_Address), Loc)));
6845 Append_To (Pkg_RPC_Receiver_Statements,
6846 Make_Procedure_Call_Statement (Loc,
6847 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6848 Parameter_Associations => New_List (
6849 Make_Selected_Component (Loc,
6851 Selector_Name => Name_Target),
6852 New_Occurrence_Of (Is_Local, Loc),
6853 New_Occurrence_Of (Local_Address, Loc))));
6855 -- For each subprogram, the receiving stub will be built and a case
6856 -- statement will be made on the Subprogram_Id to dispatch to the
6857 -- right subprogram.
6859 All_Calls_Remote_E := Boolean_Literals (
6860 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6862 Overload_Counter_Table.Reset;
6863 Reserve_NamingContext_Methods;
6865 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
6866 while Present (Current_Declaration) loop
6867 if Nkind (Current_Declaration) = N_Subprogram_Declaration
6868 and then Comes_From_Source (Current_Declaration)
6871 Loc : constant Source_Ptr := Sloc (Current_Declaration);
6872 -- While specifically processing Current_Declaration, use
6873 -- its Sloc as the location of all generated nodes.
6875 Subp_Def : constant Entity_Id :=
6877 (Specification (Current_Declaration));
6879 Subp_Val : String_Id;
6881 Subp_Dist_Name : constant Entity_Id :=
6882 Make_Defining_Identifier (Loc,
6885 (Related_Id => Chars (Subp_Def),
6887 Suffix_Index => -1));
6889 Proxy_Object_Addr : Entity_Id;
6892 -- Build receiving stub
6895 Build_Subprogram_Receiving_Stubs
6896 (Vis_Decl => Current_Declaration,
6898 Nkind (Specification (Current_Declaration)) =
6899 N_Procedure_Specification
6900 and then Is_Asynchronous (Subp_Def));
6902 Append_To (Decls, Current_Stubs);
6903 Analyze (Current_Stubs);
6907 Add_RAS_Proxy_And_Analyze (Decls,
6908 Vis_Decl => Current_Declaration,
6909 All_Calls_Remote_E => All_Calls_Remote_E,
6910 Proxy_Object_Addr => Proxy_Object_Addr);
6912 -- Compute distribution identifier
6914 Assign_Subprogram_Identifier
6916 Current_Subprogram_Number,
6920 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
6923 Make_Object_Declaration (Loc,
6924 Defining_Identifier => Subp_Dist_Name,
6925 Constant_Present => True,
6926 Object_Definition =>
6927 New_Occurrence_Of (Standard_String, Loc),
6929 Make_String_Literal (Loc, Subp_Val)));
6930 Analyze (Last (Decls));
6932 -- Add subprogram descriptor (RCI_Subp_Info) to the
6933 -- subprograms table for this receiver. The aggregate
6934 -- below must be kept consistent with the declaration
6935 -- of type RCI_Subp_Info in System.Partition_Interface.
6937 Append_To (Subp_Info_List,
6938 Make_Component_Association (Loc,
6939 Choices => New_List (
6940 Make_Integer_Literal (Loc, Current_Subprogram_Number)),
6943 Make_Aggregate (Loc,
6944 Expressions => New_List (
6945 Make_Attribute_Reference (Loc,
6947 New_Occurrence_Of (Subp_Dist_Name, Loc),
6948 Attribute_Name => Name_Address),
6950 Make_Attribute_Reference (Loc,
6952 New_Occurrence_Of (Subp_Dist_Name, Loc),
6953 Attribute_Name => Name_Length),
6955 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
6957 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6958 Declaration => Current_Declaration,
6959 Stubs => Current_Stubs,
6960 Subp_Number => Current_Subprogram_Number,
6961 Subp_Dist_Name => Subp_Dist_Name,
6962 Subp_Proxy_Addr => Proxy_Object_Addr);
6965 Current_Subprogram_Number := Current_Subprogram_Number + 1;
6968 Next (Current_Declaration);
6972 Make_Object_Declaration (Loc,
6973 Defining_Identifier => Subp_Info_Array,
6974 Constant_Present => True,
6975 Aliased_Present => True,
6976 Object_Definition =>
6977 Make_Subtype_Indication (Loc,
6979 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6981 Make_Index_Or_Discriminant_Constraint (Loc,
6985 Make_Integer_Literal (Loc,
6986 Intval => First_RCI_Subprogram_Id),
6988 Make_Integer_Literal (Loc,
6990 First_RCI_Subprogram_Id
6991 + List_Length (Subp_Info_List) - 1)))))));
6993 if Present (First (Subp_Info_List)) then
6994 Set_Expression (Last (Decls),
6995 Make_Aggregate (Loc,
6996 Component_Associations => Subp_Info_List));
6998 -- Generate the dispatch statement to determine the subprogram id
6999 -- of the called subprogram.
7001 -- We first test whether the reference that was used to make the
7002 -- call was the base RCI reference (in which case Local_Address is
7003 -- zero, and the method identifier from the request must be used
7004 -- to determine which subprogram is called) or a reference
7005 -- identifying one particular subprogram (in which case
7006 -- Local_Address is the address of that subprogram, and the
7007 -- method name from the request is ignored). The latter occurs
7008 -- for the case of a call through a remote access-to-subprogram.
7010 -- In each case, cascaded elsifs are used to determine the proper
7011 -- subprogram index. Using hash tables might be more efficient.
7013 Append_To (Pkg_RPC_Receiver_Statements,
7014 Make_Implicit_If_Statement (Pkg_Spec,
7017 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
7018 Right_Opnd => New_Occurrence_Of
7019 (RTE (RE_Null_Address), Loc)),
7021 Then_Statements => New_List (
7022 Make_Implicit_If_Statement (Pkg_Spec,
7023 Condition => New_Occurrence_Of (Standard_False, Loc),
7024 Then_Statements => New_List (
7025 Make_Null_Statement (Loc)),
7026 Elsif_Parts => Dispatch_On_Address)),
7028 Else_Statements => New_List (
7029 Make_Implicit_If_Statement (Pkg_Spec,
7030 Condition => New_Occurrence_Of (Standard_False, Loc),
7031 Then_Statements => New_List (Make_Null_Statement (Loc)),
7032 Elsif_Parts => Dispatch_On_Name))));
7035 -- For a degenerate RCI with no visible subprograms,
7036 -- Subp_Info_List has zero length, and the declaration is for an
7037 -- empty array, in which case no initialization aggregate must be
7038 -- generated. We do not generate a Dispatch_Statement either.
7040 -- No initialization provided: remove CONSTANT so that the
7041 -- declaration is not an incomplete deferred constant.
7043 Set_Constant_Present (Last (Decls), False);
7046 -- Analyze Subp_Info_Array declaration
7048 Analyze (Last (Decls));
7050 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7051 -- rather than raising an exception since we do not want someone
7052 -- to crash a remote partition by sending invalid subprogram ids.
7053 -- This is consistent with the other parts of the case statement
7054 -- since even in presence of incorrect parameters in the stream,
7055 -- every exception will be caught and (if the subprogram is not an
7056 -- APC) put into the result stream and sent away.
7058 Append_To (Pkg_RPC_Receiver_Cases,
7059 Make_Case_Statement_Alternative (Loc,
7060 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
7061 Statements => New_List (Make_Null_Statement (Loc))));
7063 Append_To (Pkg_RPC_Receiver_Statements,
7064 Make_Case_Statement (Loc,
7065 Expression => New_Occurrence_Of (Subp_Index, Loc),
7066 Alternatives => Pkg_RPC_Receiver_Cases));
7068 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7071 Append_To (Decls, Pkg_RPC_Receiver_Body);
7072 Analyze (Last (Decls));
7074 Pkg_RPC_Receiver_Object :=
7075 Make_Object_Declaration (Loc,
7076 Defining_Identifier =>
7077 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
7078 Aliased_Present => True,
7079 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
7080 Append_To (Decls, Pkg_RPC_Receiver_Object);
7081 Analyze (Last (Decls));
7083 Get_Library_Unit_Name_String (Pkg_Spec);
7087 Append_To (Register_Pkg_Actuals,
7088 Make_String_Literal (Loc,
7089 Strval => String_From_Name_Buffer));
7093 Append_To (Register_Pkg_Actuals,
7094 Make_Attribute_Reference (Loc,
7097 (Defining_Entity (Pkg_Spec), Loc),
7098 Attribute_Name => Name_Version));
7102 Append_To (Register_Pkg_Actuals,
7103 Make_Attribute_Reference (Loc,
7105 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7106 Attribute_Name => Name_Access));
7110 Append_To (Register_Pkg_Actuals,
7111 Make_Attribute_Reference (Loc,
7114 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc),
7115 Attribute_Name => Name_Access));
7119 Append_To (Register_Pkg_Actuals,
7120 Make_Attribute_Reference (Loc,
7121 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7122 Attribute_Name => Name_Address));
7126 Append_To (Register_Pkg_Actuals,
7127 Make_Attribute_Reference (Loc,
7128 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7129 Attribute_Name => Name_Length));
7131 -- Is_All_Calls_Remote
7133 Append_To (Register_Pkg_Actuals,
7134 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7136 -- Finally call Register_Pkg_Receiving_Stub with the above parameters
7139 Make_Procedure_Call_Statement (Loc,
7141 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7142 Parameter_Associations => Register_Pkg_Actuals));
7143 Analyze (Last (Stmts));
7144 end Add_Receiving_Stubs_To_Declarations;
7146 ---------------------------------
7147 -- Build_General_Calling_Stubs --
7148 ---------------------------------
7150 procedure Build_General_Calling_Stubs
7152 Statements : List_Id;
7153 Target_Object : Node_Id;
7154 Subprogram_Id : Node_Id;
7155 Asynchronous : Node_Id := Empty;
7156 Is_Known_Asynchronous : Boolean := False;
7157 Is_Known_Non_Asynchronous : Boolean := False;
7158 Is_Function : Boolean;
7160 Stub_Type : Entity_Id := Empty;
7161 RACW_Type : Entity_Id := Empty;
7164 Loc : constant Source_Ptr := Sloc (Nod);
7166 Request : constant Entity_Id :=
7167 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7168 -- The request object constructed by these stubs
7169 -- Could we use Name_R instead??? (see GLADE client stubs)
7171 function Make_Request_RTE_Call
7173 Actuals : List_Id := New_List) return Node_Id;
7174 -- Generate a procedure call statement calling RE with the given
7175 -- actuals. Request is appended to the list.
7177 ---------------------------
7178 -- Make_Request_RTE_Call --
7179 ---------------------------
7181 function Make_Request_RTE_Call
7183 Actuals : List_Id := New_List) return Node_Id
7186 Append_To (Actuals, New_Occurrence_Of (Request, Loc));
7187 return Make_Procedure_Call_Statement (Loc,
7189 New_Occurrence_Of (RTE (RE), Loc),
7190 Parameter_Associations => Actuals);
7191 end Make_Request_RTE_Call;
7193 Arguments : Node_Id;
7194 -- Name of the named values list used to transmit parameters
7195 -- to the remote package
7198 -- Name of the result named value (in non-APC cases) which get the
7199 -- result of the remote subprogram.
7201 Result_TC : Node_Id;
7202 -- Typecode expression for the result of the request (void
7203 -- typecode for procedures).
7205 Exception_Return_Parameter : Node_Id;
7206 -- Name of the parameter which will hold the exception sent by the
7207 -- remote subprogram.
7209 Current_Parameter : Node_Id;
7210 -- Current parameter being handled
7212 Ordered_Parameters_List : constant List_Id :=
7213 Build_Ordered_Parameters_List (Spec);
7215 Asynchronous_P : Node_Id;
7216 -- A Boolean expression indicating whether this call is asynchronous
7218 Asynchronous_Statements : List_Id := No_List;
7219 Non_Asynchronous_Statements : List_Id := No_List;
7220 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7222 Extra_Formal_Statements : constant List_Id := New_List;
7223 -- List of statements for extra formal parameters. It will appear
7224 -- after the regular statements for writing out parameters.
7226 After_Statements : constant List_Id := New_List;
7227 -- Statements to be executed after call returns (to assign IN OUT or
7228 -- OUT parameter values).
7231 -- The type of the formal parameter being processed
7233 Is_Controlling_Formal : Boolean;
7234 Is_First_Controlling_Formal : Boolean;
7235 First_Controlling_Formal_Seen : Boolean := False;
7236 -- Controlling formal parameters of distributed object primitives
7237 -- require special handling, and the first such parameter needs even
7238 -- more special handling.
7241 -- ??? document general form of stub subprograms for the PolyORB case
7244 Make_Object_Declaration (Loc,
7245 Defining_Identifier => Request,
7246 Aliased_Present => False,
7247 Object_Definition =>
7248 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
7251 Make_Defining_Identifier (Loc,
7252 Chars => New_Internal_Name ('R'));
7256 PolyORB_Support.Helpers.Build_TypeCode_Call
7257 (Loc, Etype (Result_Definition (Spec)), Decls);
7259 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7263 Make_Object_Declaration (Loc,
7264 Defining_Identifier => Result,
7265 Aliased_Present => False,
7266 Object_Definition =>
7267 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7269 Make_Aggregate (Loc,
7270 Component_Associations => New_List (
7271 Make_Component_Association (Loc,
7272 Choices => New_List (Make_Identifier (Loc, Name_Name)),
7274 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7275 Make_Component_Association (Loc,
7276 Choices => New_List (
7277 Make_Identifier (Loc, Name_Argument)),
7279 Make_Function_Call (Loc,
7280 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7281 Parameter_Associations => New_List (Result_TC))),
7282 Make_Component_Association (Loc,
7283 Choices => New_List (
7284 Make_Identifier (Loc, Name_Arg_Modes)),
7285 Expression => Make_Integer_Literal (Loc, 0))))));
7287 if not Is_Known_Asynchronous then
7288 Exception_Return_Parameter :=
7289 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7292 Make_Object_Declaration (Loc,
7293 Defining_Identifier => Exception_Return_Parameter,
7294 Object_Definition =>
7295 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7298 Exception_Return_Parameter := Empty;
7301 -- Initialize and fill in arguments list
7304 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7305 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7307 Current_Parameter := First (Ordered_Parameters_List);
7308 while Present (Current_Parameter) loop
7309 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7310 Is_Controlling_Formal := True;
7311 Is_First_Controlling_Formal :=
7312 not First_Controlling_Formal_Seen;
7313 First_Controlling_Formal_Seen := True;
7316 Is_Controlling_Formal := False;
7317 Is_First_Controlling_Formal := False;
7320 if Is_Controlling_Formal then
7322 -- For a controlling formal argument, we send its reference
7327 Etyp := Etype (Parameter_Type (Current_Parameter));
7330 -- The first controlling formal parameter is treated specially:
7331 -- it is used to set the target object of the call.
7333 if not Is_First_Controlling_Formal then
7335 Constrained : constant Boolean :=
7336 Is_Constrained (Etyp)
7337 or else Is_Elementary_Type (Etyp);
7339 Any : constant Entity_Id :=
7340 Make_Defining_Identifier (Loc,
7341 New_Internal_Name ('A'));
7343 Actual_Parameter : Node_Id :=
7345 Defining_Identifier (
7346 Current_Parameter), Loc);
7351 if Is_Controlling_Formal then
7353 -- For a controlling formal parameter (other than the
7354 -- first one), use the corresponding RACW. If the
7355 -- parameter is not an anonymous access parameter, that
7356 -- involves taking its 'Unrestricted_Access.
7358 if Nkind (Parameter_Type (Current_Parameter))
7359 = N_Access_Definition
7361 Actual_Parameter := OK_Convert_To
7362 (Etyp, Actual_Parameter);
7364 Actual_Parameter := OK_Convert_To (Etyp,
7365 Make_Attribute_Reference (Loc,
7366 Prefix => Actual_Parameter,
7367 Attribute_Name => Name_Unrestricted_Access));
7372 if In_Present (Current_Parameter)
7373 or else not Out_Present (Current_Parameter)
7374 or else not Constrained
7375 or else Is_Controlling_Formal
7377 -- The parameter has an input value, is constrained at
7378 -- runtime by an input value, or is a controlling formal
7379 -- parameter (always passed as a reference) other than
7382 Expr := PolyORB_Support.Helpers.Build_To_Any_Call
7383 (Actual_Parameter, Decls);
7386 Expr := Make_Function_Call (Loc,
7387 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7388 Parameter_Associations => New_List (
7389 PolyORB_Support.Helpers.Build_TypeCode_Call
7390 (Loc, Etyp, Decls)));
7394 Make_Object_Declaration (Loc,
7395 Defining_Identifier => Any,
7396 Aliased_Present => False,
7397 Object_Definition =>
7398 New_Occurrence_Of (RTE (RE_Any), Loc),
7399 Expression => Expr));
7401 Append_To (Statements,
7402 Add_Parameter_To_NVList (Loc,
7403 Parameter => Current_Parameter,
7404 NVList => Arguments,
7405 Constrained => Constrained,
7408 if Out_Present (Current_Parameter)
7409 and then not Is_Controlling_Formal
7411 if Is_Limited_Type (Etyp) then
7412 Helpers.Assign_Opaque_From_Any (Loc,
7413 Stms => After_Statements,
7415 N => New_Occurrence_Of (Any, Loc),
7417 Defining_Identifier (Current_Parameter));
7419 Append_To (After_Statements,
7420 Make_Assignment_Statement (Loc,
7423 Defining_Identifier (Current_Parameter), Loc),
7425 PolyORB_Support.Helpers.Build_From_Any_Call
7427 New_Occurrence_Of (Any, Loc),
7434 -- If the current parameter has a dynamic constrained status, then
7435 -- this status is transmitted as well.
7436 -- This should be done for accessibility as well ???
7438 if Nkind (Parameter_Type (Current_Parameter)) /=
7440 and then Need_Extra_Constrained (Current_Parameter)
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.
7449 Extra_Any_Parameter : constant Entity_Id :=
7450 Make_Defining_Identifier
7451 (Loc, New_Internal_Name ('P'));
7453 Parameter_Exp : constant Node_Id :=
7454 Make_Attribute_Reference (Loc,
7455 Prefix => New_Occurrence_Of (
7456 Defining_Identifier (Current_Parameter), Loc),
7457 Attribute_Name => Name_Constrained);
7460 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7463 Make_Object_Declaration (Loc,
7464 Defining_Identifier => Extra_Any_Parameter,
7465 Aliased_Present => False,
7466 Object_Definition =>
7467 New_Occurrence_Of (RTE (RE_Any), Loc),
7469 PolyORB_Support.Helpers.Build_To_Any_Call
7470 (Parameter_Exp, Decls)));
7472 Append_To (Extra_Formal_Statements,
7473 Add_Parameter_To_NVList (Loc,
7474 Parameter => Extra_Any_Parameter,
7475 NVList => Arguments,
7476 Constrained => True,
7477 Any => Extra_Any_Parameter));
7481 Next (Current_Parameter);
7484 -- Append the formal statements list to the statements
7486 Append_List_To (Statements, Extra_Formal_Statements);
7488 Append_To (Statements,
7489 Make_Request_RTE_Call (RE_Request_Create, New_List (
7492 New_Occurrence_Of (Arguments, Loc),
7493 New_Occurrence_Of (Result, Loc),
7495 (RTE (RE_Nil_Exc_List), Loc))));
7498 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7500 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7503 (Boolean_Literals (Is_Known_Asynchronous), Loc);
7506 pragma Assert (Present (Asynchronous));
7507 Asynchronous_P := New_Copy_Tree (Asynchronous);
7509 -- The expression node Asynchronous will be used to build an 'if'
7510 -- statement at the end of Build_General_Calling_Stubs: we need to
7511 -- make a copy here.
7514 Append_To (Parameter_Associations (Last (Statements)),
7515 Make_Indexed_Component (Loc,
7518 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7519 Expressions => New_List (Asynchronous_P)));
7521 Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke));
7523 -- Asynchronous case
7525 if not Is_Known_Non_Asynchronous then
7526 Asynchronous_Statements :=
7527 New_List (Make_Request_RTE_Call (RE_Request_Destroy));
7530 -- Non-asynchronous case
7532 if not Is_Known_Asynchronous then
7533 -- Reraise an exception occurrence from the completed request.
7534 -- If the exception occurrence is empty, this is a no-op.
7536 Non_Asynchronous_Statements := New_List (
7537 Make_Procedure_Call_Statement (Loc,
7539 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7540 Parameter_Associations => New_List (
7541 New_Occurrence_Of (Request, Loc))));
7545 Append_To (Non_Asynchronous_Statements,
7546 Make_Request_RTE_Call (RE_Request_Destroy));
7548 -- If this is a function call, read the value and return it
7550 Append_To (Non_Asynchronous_Statements,
7551 Make_Tag_Check (Loc,
7552 Make_Simple_Return_Statement (Loc,
7553 PolyORB_Support.Helpers.Build_From_Any_Call
7554 (Etype (Result_Definition (Spec)),
7555 Make_Selected_Component (Loc,
7557 Selector_Name => Name_Argument),
7562 -- Case of a procedure: deal with IN OUT and OUT formals
7564 Append_List_To (Non_Asynchronous_Statements, After_Statements);
7566 Append_To (Non_Asynchronous_Statements,
7567 Make_Request_RTE_Call (RE_Request_Destroy));
7571 if Is_Known_Asynchronous then
7572 Append_List_To (Statements, Asynchronous_Statements);
7574 elsif Is_Known_Non_Asynchronous then
7575 Append_List_To (Statements, Non_Asynchronous_Statements);
7578 pragma Assert (Present (Asynchronous));
7579 Append_To (Statements,
7580 Make_Implicit_If_Statement (Nod,
7581 Condition => Asynchronous,
7582 Then_Statements => Asynchronous_Statements,
7583 Else_Statements => Non_Asynchronous_Statements));
7585 end Build_General_Calling_Stubs;
7587 -----------------------
7588 -- Build_Stub_Target --
7589 -----------------------
7591 function Build_Stub_Target
7594 RCI_Locator : Entity_Id;
7595 Controlling_Parameter : Entity_Id) return RPC_Target
7597 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7598 Target_Reference : constant Entity_Id :=
7599 Make_Defining_Identifier (Loc,
7600 New_Internal_Name ('T'));
7602 if Present (Controlling_Parameter) then
7604 Make_Object_Declaration (Loc,
7605 Defining_Identifier => Target_Reference,
7607 Object_Definition =>
7608 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7611 Make_Function_Call (Loc,
7613 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7614 Parameter_Associations => New_List (
7615 Make_Selected_Component (Loc,
7616 Prefix => Controlling_Parameter,
7617 Selector_Name => Name_Target)))));
7619 -- Note: Controlling_Parameter has the same components as
7620 -- System.Partition_Interface.RACW_Stub_Type.
7622 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7625 Target_Info.Object :=
7626 Make_Selected_Component (Loc,
7627 Prefix => Make_Identifier (Loc, Chars (RCI_Locator)),
7629 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7633 end Build_Stub_Target;
7635 ---------------------
7636 -- Build_Stub_Type --
7637 ---------------------
7639 procedure Build_Stub_Type
7640 (RACW_Type : Entity_Id;
7641 Stub_Type_Comps : out List_Id;
7642 RPC_Receiver_Decl : out Node_Id)
7644 Loc : constant Source_Ptr := Sloc (RACW_Type);
7647 Stub_Type_Comps := New_List (
7648 Make_Component_Declaration (Loc,
7649 Defining_Identifier =>
7650 Make_Defining_Identifier (Loc, Name_Target),
7651 Component_Definition =>
7652 Make_Component_Definition (Loc,
7653 Aliased_Present => False,
7654 Subtype_Indication =>
7655 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7657 Make_Component_Declaration (Loc,
7658 Defining_Identifier =>
7659 Make_Defining_Identifier (Loc, Name_Asynchronous),
7661 Component_Definition =>
7662 Make_Component_Definition (Loc,
7663 Aliased_Present => False,
7664 Subtype_Indication =>
7665 New_Occurrence_Of (Standard_Boolean, Loc))));
7667 RPC_Receiver_Decl :=
7668 Make_Object_Declaration (Loc,
7669 Defining_Identifier => Make_Defining_Identifier (Loc,
7670 New_Internal_Name ('R')),
7671 Aliased_Present => True,
7672 Object_Definition =>
7673 New_Occurrence_Of (RTE (RE_Servant), Loc));
7674 end Build_Stub_Type;
7676 -----------------------------
7677 -- Build_RPC_Receiver_Body --
7678 -----------------------------
7680 procedure Build_RPC_Receiver_Body
7681 (RPC_Receiver : Entity_Id;
7682 Request : out Entity_Id;
7683 Subp_Id : out Entity_Id;
7684 Subp_Index : out Entity_Id;
7685 Stmts : out List_Id;
7688 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7690 RPC_Receiver_Spec : Node_Id;
7691 RPC_Receiver_Decls : List_Id;
7694 Request := Make_Defining_Identifier (Loc, Name_R);
7696 RPC_Receiver_Spec :=
7697 Build_RPC_Receiver_Specification
7698 (RPC_Receiver => RPC_Receiver,
7699 Request_Parameter => Request);
7701 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7702 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7704 RPC_Receiver_Decls := New_List (
7705 Make_Object_Renaming_Declaration (Loc,
7706 Defining_Identifier => Subp_Id,
7707 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7709 Make_Explicit_Dereference (Loc,
7711 Make_Selected_Component (Loc,
7713 Selector_Name => Name_Operation))),
7715 Make_Object_Declaration (Loc,
7716 Defining_Identifier => Subp_Index,
7717 Object_Definition =>
7718 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7720 Make_Attribute_Reference (Loc,
7722 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7723 Attribute_Name => Name_Last)));
7728 Make_Subprogram_Body (Loc,
7729 Specification => RPC_Receiver_Spec,
7730 Declarations => RPC_Receiver_Decls,
7731 Handled_Statement_Sequence =>
7732 Make_Handled_Sequence_Of_Statements (Loc,
7733 Statements => Stmts));
7734 end Build_RPC_Receiver_Body;
7736 --------------------------------------
7737 -- Build_Subprogram_Receiving_Stubs --
7738 --------------------------------------
7740 function Build_Subprogram_Receiving_Stubs
7741 (Vis_Decl : Node_Id;
7742 Asynchronous : Boolean;
7743 Dynamically_Asynchronous : Boolean := False;
7744 Stub_Type : Entity_Id := Empty;
7745 RACW_Type : Entity_Id := Empty;
7746 Parent_Primitive : Entity_Id := Empty) return Node_Id
7748 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7750 Request_Parameter : constant Entity_Id :=
7751 Make_Defining_Identifier (Loc,
7752 New_Internal_Name ('R'));
7753 -- Formal parameter for receiving stubs: a descriptor for an incoming
7756 Outer_Decls : constant List_Id := New_List;
7757 -- At the outermost level, an NVList and Any's are declared for all
7758 -- parameters. The Dynamic_Async flag also needs to be declared there
7759 -- to be visible from the exception handling code.
7761 Outer_Statements : constant List_Id := New_List;
7762 -- Statements that occur prior to the declaration of the actual
7763 -- parameter variables.
7765 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7766 -- Statements concerning extra formal parameters, prior to the
7767 -- declaration of the actual parameter variables.
7769 Decls : constant List_Id := New_List;
7770 -- All the parameters will get declared before calling the real
7771 -- subprograms. Also the out parameters will be declared. At this
7772 -- level, parameters may be unconstrained.
7774 Statements : constant List_Id := New_List;
7776 After_Statements : constant List_Id := New_List;
7777 -- Statements to be executed after the subprogram call
7779 Inner_Decls : List_Id := No_List;
7780 -- In case of a function, the inner declarations are needed since
7781 -- the result may be unconstrained.
7783 Excep_Handlers : List_Id := No_List;
7785 Parameter_List : constant List_Id := New_List;
7786 -- List of parameters to be passed to the subprogram
7788 First_Controlling_Formal_Seen : Boolean := False;
7790 Current_Parameter : Node_Id;
7792 Ordered_Parameters_List : constant List_Id :=
7793 Build_Ordered_Parameters_List
7794 (Specification (Vis_Decl));
7796 Arguments : constant Entity_Id :=
7797 Make_Defining_Identifier (Loc,
7798 New_Internal_Name ('A'));
7799 -- Name of the named values list used to retrieve parameters
7801 Subp_Spec : Node_Id;
7802 -- Subprogram specification
7804 Called_Subprogram : Node_Id;
7805 -- The subprogram to call
7808 if Present (RACW_Type) then
7809 Called_Subprogram :=
7810 New_Occurrence_Of (Parent_Primitive, Loc);
7812 Called_Subprogram :=
7814 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7817 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7819 -- Loop through every parameter and get its value from the stream. If
7820 -- the parameter is unconstrained, then the parameter is read using
7821 -- 'Input at the point of declaration.
7823 Current_Parameter := First (Ordered_Parameters_List);
7824 while Present (Current_Parameter) loop
7827 Constrained : Boolean;
7828 Any : Entity_Id := Empty;
7829 Object : constant Entity_Id :=
7830 Make_Defining_Identifier (Loc,
7831 Chars => New_Internal_Name ('P'));
7832 Expr : Node_Id := Empty;
7834 Is_Controlling_Formal : constant Boolean :=
7835 Is_RACW_Controlling_Formal
7836 (Current_Parameter, Stub_Type);
7838 Is_First_Controlling_Formal : Boolean := False;
7840 Need_Extra_Constrained : Boolean;
7841 -- True when an extra constrained actual is required
7844 if Is_Controlling_Formal then
7846 -- Controlling formals in distributed object primitive
7847 -- operations are handled specially:
7849 -- - the first controlling formal is used as the
7850 -- target of the call;
7852 -- - the remaining controlling formals are transmitted
7856 Is_First_Controlling_Formal :=
7857 not First_Controlling_Formal_Seen;
7858 First_Controlling_Formal_Seen := True;
7861 Etyp := Etype (Parameter_Type (Current_Parameter));
7865 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
7867 if not Is_First_Controlling_Formal then
7869 Make_Defining_Identifier (Loc,
7870 Chars => New_Internal_Name ('A'));
7872 Append_To (Outer_Decls,
7873 Make_Object_Declaration (Loc,
7874 Defining_Identifier => Any,
7875 Object_Definition =>
7876 New_Occurrence_Of (RTE (RE_Any), Loc),
7878 Make_Function_Call (Loc,
7879 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7880 Parameter_Associations => New_List (
7881 PolyORB_Support.Helpers.Build_TypeCode_Call
7882 (Loc, Etyp, Outer_Decls)))));
7884 Append_To (Outer_Statements,
7885 Add_Parameter_To_NVList (Loc,
7886 Parameter => Current_Parameter,
7887 NVList => Arguments,
7888 Constrained => Constrained,
7892 if Is_First_Controlling_Formal then
7894 Addr : constant Entity_Id :=
7895 Make_Defining_Identifier (Loc,
7896 Chars => New_Internal_Name ('A'));
7898 Is_Local : constant Entity_Id :=
7899 Make_Defining_Identifier (Loc,
7900 Chars => New_Internal_Name ('L'));
7903 -- Special case: obtain the first controlling formal
7904 -- from the target of the remote call, instead of the
7907 Append_To (Outer_Decls,
7908 Make_Object_Declaration (Loc,
7909 Defining_Identifier => Addr,
7910 Object_Definition =>
7911 New_Occurrence_Of (RTE (RE_Address), Loc)));
7913 Append_To (Outer_Decls,
7914 Make_Object_Declaration (Loc,
7915 Defining_Identifier => Is_Local,
7916 Object_Definition =>
7917 New_Occurrence_Of (Standard_Boolean, Loc)));
7919 Append_To (Outer_Statements,
7920 Make_Procedure_Call_Statement (Loc,
7922 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7923 Parameter_Associations => New_List (
7924 Make_Selected_Component (Loc,
7927 Request_Parameter, Loc),
7929 Make_Identifier (Loc, Name_Target)),
7930 New_Occurrence_Of (Is_Local, Loc),
7931 New_Occurrence_Of (Addr, Loc))));
7933 Expr := Unchecked_Convert_To (RACW_Type,
7934 New_Occurrence_Of (Addr, Loc));
7937 elsif In_Present (Current_Parameter)
7938 or else not Out_Present (Current_Parameter)
7939 or else not Constrained
7941 -- If an input parameter is constrained, then its reading is
7942 -- deferred until the beginning of the subprogram body. If
7943 -- it is unconstrained, then an expression is built for
7944 -- the object declaration and the variable is set using
7945 -- 'Input instead of 'Read.
7947 if Constrained and then Is_Limited_Type (Etyp) then
7948 Helpers.Assign_Opaque_From_Any (Loc,
7951 N => New_Occurrence_Of (Any, Loc),
7955 Expr := Helpers.Build_From_Any_Call
7956 (Etyp, New_Occurrence_Of (Any, Loc), Decls);
7959 Append_To (Statements,
7960 Make_Assignment_Statement (Loc,
7961 Name => New_Occurrence_Of (Object, Loc),
7962 Expression => Expr));
7966 -- Expr will be used to initialize (and constrain) the
7967 -- parameter when it is declared.
7975 Need_Extra_Constrained :=
7976 Nkind (Parameter_Type (Current_Parameter)) /=
7979 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7981 Present (Extra_Constrained
7982 (Defining_Identifier (Current_Parameter)));
7984 -- We may not associate an extra constrained actual to a
7985 -- constant object, so if one is needed, declare the actual
7986 -- as a variable even if it won't be modified.
7988 Build_Actual_Object_Declaration
7991 Variable => Need_Extra_Constrained
7992 or else Out_Present (Current_Parameter),
7995 Set_Etype (Object, Etyp);
7997 -- An out parameter may be written back using a 'Write
7998 -- attribute instead of a 'Output because it has been
7999 -- constrained by the parameter given to the caller. Note that
8000 -- out controlling arguments in the case of a RACW are not put
8001 -- back in the stream because the pointer on them has not
8004 if Out_Present (Current_Parameter)
8005 and then not Is_Controlling_Formal
8007 Append_To (After_Statements,
8008 Make_Procedure_Call_Statement (Loc,
8009 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
8010 Parameter_Associations => New_List (
8011 New_Occurrence_Of (Any, Loc),
8012 PolyORB_Support.Helpers.Build_To_Any_Call
8013 (New_Occurrence_Of (Object, Loc), Decls))));
8016 -- For RACW controlling formals, the Etyp of Object is always
8017 -- an RACW, even if the parameter is not of an anonymous access
8018 -- type. In such case, we need to dereference it at call time.
8020 if Is_Controlling_Formal then
8021 if Nkind (Parameter_Type (Current_Parameter)) /=
8024 Append_To (Parameter_List,
8025 Make_Parameter_Association (Loc,
8028 (Defining_Identifier (Current_Parameter), Loc),
8029 Explicit_Actual_Parameter =>
8030 Make_Explicit_Dereference (Loc,
8031 Prefix => New_Occurrence_Of (Object, Loc))));
8034 Append_To (Parameter_List,
8035 Make_Parameter_Association (Loc,
8038 (Defining_Identifier (Current_Parameter), Loc),
8040 Explicit_Actual_Parameter =>
8041 New_Occurrence_Of (Object, Loc)));
8045 Append_To (Parameter_List,
8046 Make_Parameter_Association (Loc,
8049 Defining_Identifier (Current_Parameter), Loc),
8050 Explicit_Actual_Parameter =>
8051 New_Occurrence_Of (Object, Loc)));
8054 -- If the current parameter needs an extra formal, then read it
8055 -- from the stream and set the corresponding semantic field in
8056 -- the variable. If the kind of the parameter identifier is
8057 -- E_Void, then this is a compiler generated parameter that
8058 -- doesn't need an extra constrained status.
8060 -- The case of Extra_Accessibility should also be handled ???
8062 if Need_Extra_Constrained then
8064 Extra_Parameter : constant Entity_Id :=
8066 (Defining_Identifier
8067 (Current_Parameter));
8069 Extra_Any : constant Entity_Id :=
8070 Make_Defining_Identifier (Loc,
8071 Chars => New_Internal_Name ('A'));
8073 Formal_Entity : constant Entity_Id :=
8074 Make_Defining_Identifier (Loc,
8075 Chars => Chars (Extra_Parameter));
8077 Formal_Type : constant Entity_Id :=
8078 Etype (Extra_Parameter);
8081 Append_To (Outer_Decls,
8082 Make_Object_Declaration (Loc,
8083 Defining_Identifier => Extra_Any,
8084 Object_Definition =>
8085 New_Occurrence_Of (RTE (RE_Any), Loc),
8087 Make_Function_Call (Loc,
8089 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8090 Parameter_Associations => New_List (
8091 PolyORB_Support.Helpers.Build_TypeCode_Call
8092 (Loc, Formal_Type, Outer_Decls)))));
8094 Append_To (Outer_Extra_Formal_Statements,
8095 Add_Parameter_To_NVList (Loc,
8096 Parameter => Extra_Parameter,
8097 NVList => Arguments,
8098 Constrained => True,
8102 Make_Object_Declaration (Loc,
8103 Defining_Identifier => Formal_Entity,
8104 Object_Definition =>
8105 New_Occurrence_Of (Formal_Type, Loc)));
8107 Append_To (Statements,
8108 Make_Assignment_Statement (Loc,
8109 Name => New_Occurrence_Of (Formal_Entity, Loc),
8111 PolyORB_Support.Helpers.Build_From_Any_Call
8113 New_Occurrence_Of (Extra_Any, Loc),
8115 Set_Extra_Constrained (Object, Formal_Entity);
8120 Next (Current_Parameter);
8123 -- Extra Formals should go after all the other parameters
8125 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8127 Append_To (Outer_Statements,
8128 Make_Procedure_Call_Statement (Loc,
8129 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8130 Parameter_Associations => New_List (
8131 New_Occurrence_Of (Request_Parameter, Loc),
8132 New_Occurrence_Of (Arguments, Loc))));
8134 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8136 -- The remote subprogram is a function: Build an inner block to be
8137 -- able to hold a potentially unconstrained result in a variable.
8140 Etyp : constant Entity_Id :=
8141 Etype (Result_Definition (Specification (Vis_Decl)));
8142 Result : constant Node_Id :=
8143 Make_Defining_Identifier (Loc,
8144 Chars => New_Internal_Name ('R'));
8147 Inner_Decls := New_List (
8148 Make_Object_Declaration (Loc,
8149 Defining_Identifier => Result,
8150 Constant_Present => True,
8151 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8153 Make_Function_Call (Loc,
8154 Name => Called_Subprogram,
8155 Parameter_Associations => Parameter_List)));
8157 if Is_Class_Wide_Type (Etyp) then
8159 -- For a remote call to a function with a class-wide type,
8160 -- check that the returned value satisfies the requirements
8163 Append_To (Inner_Decls,
8164 Make_Transportable_Check (Loc,
8165 New_Occurrence_Of (Result, Loc)));
8169 Set_Etype (Result, Etyp);
8170 Append_To (After_Statements,
8171 Make_Procedure_Call_Statement (Loc,
8172 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8173 Parameter_Associations => New_List (
8174 New_Occurrence_Of (Request_Parameter, Loc),
8175 PolyORB_Support.Helpers.Build_To_Any_Call
8176 (New_Occurrence_Of (Result, Loc), Decls))));
8178 -- A DSA function does not have out or inout arguments
8181 Append_To (Statements,
8182 Make_Block_Statement (Loc,
8183 Declarations => Inner_Decls,
8184 Handled_Statement_Sequence =>
8185 Make_Handled_Sequence_Of_Statements (Loc,
8186 Statements => After_Statements)));
8189 -- The remote subprogram is a procedure. We do not need any inner
8190 -- block in this case. No specific processing is required here for
8191 -- the dynamically asynchronous case: the indication of whether
8192 -- call is asynchronous or not is managed by the Sync_Scope
8193 -- attibute of the request, and is handled entirely in the
8196 Append_To (After_Statements,
8197 Make_Procedure_Call_Statement (Loc,
8198 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8199 Parameter_Associations => New_List (
8200 New_Occurrence_Of (Request_Parameter, Loc))));
8202 Append_To (Statements,
8203 Make_Procedure_Call_Statement (Loc,
8204 Name => Called_Subprogram,
8205 Parameter_Associations => Parameter_List));
8207 Append_List_To (Statements, After_Statements);
8211 Make_Procedure_Specification (Loc,
8212 Defining_Unit_Name =>
8213 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
8215 Parameter_Specifications => New_List (
8216 Make_Parameter_Specification (Loc,
8217 Defining_Identifier => Request_Parameter,
8219 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8221 -- An exception raised during the execution of an incoming remote
8222 -- subprogram call and that needs to be sent back to the caller is
8223 -- propagated by the receiving stubs, and will be handled by the
8224 -- caller (the distribution runtime).
8226 if Asynchronous and then not Dynamically_Asynchronous then
8228 -- For an asynchronous procedure, add a null exception handler
8230 Excep_Handlers := New_List (
8231 Make_Implicit_Exception_Handler (Loc,
8232 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8233 Statements => New_List (Make_Null_Statement (Loc))));
8236 -- In the other cases, if an exception is raised, then the
8237 -- exception occurrence is propagated.
8242 Append_To (Outer_Statements,
8243 Make_Block_Statement (Loc,
8244 Declarations => Decls,
8245 Handled_Statement_Sequence =>
8246 Make_Handled_Sequence_Of_Statements (Loc,
8247 Statements => Statements)));
8250 Make_Subprogram_Body (Loc,
8251 Specification => Subp_Spec,
8252 Declarations => Outer_Decls,
8253 Handled_Statement_Sequence =>
8254 Make_Handled_Sequence_Of_Statements (Loc,
8255 Statements => Outer_Statements,
8256 Exception_Handlers => Excep_Handlers));
8257 end Build_Subprogram_Receiving_Stubs;
8263 package body Helpers is
8265 -----------------------
8266 -- Local Subprograms --
8267 -----------------------
8269 function Find_Numeric_Representation
8270 (Typ : Entity_Id) return Entity_Id;
8271 -- Given a numeric type Typ, return the smallest integer or floating
8272 -- point type from Standard, or the smallest unsigned (modular) type
8273 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8275 function Make_Helper_Function_Name
8278 Nam : Name_Id) return Entity_Id;
8279 -- Return the name to be assigned for helper subprogram Nam of Typ
8281 ------------------------------------------------------------
8282 -- Common subprograms for building various tree fragments --
8283 ------------------------------------------------------------
8285 function Build_Get_Aggregate_Element
8289 Idx : Node_Id) return Node_Id;
8290 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8291 -- returning the Idx'th element.
8294 Subprogram : Entity_Id;
8295 -- Reference location for constructed nodes
8298 -- For 'Range and Etype
8301 -- For the construction of the innermost element expression
8303 with procedure Add_Process_Element
8306 Counter : Entity_Id;
8309 procedure Append_Array_Traversal
8312 Counter : Entity_Id := Empty;
8314 -- Build nested loop statements that iterate over the elements of an
8315 -- array Arry. The statement(s) built by Add_Process_Element are
8316 -- executed for each element; Indices is the list of indices to be
8317 -- used in the construction of the indexed component that denotes the
8318 -- current element. Subprogram is the entity for the subprogram for
8319 -- which this iterator is generated. The generated statements are
8320 -- appended to Stmts.
8324 -- The record entity being dealt with
8326 with procedure Add_Process_Element
8328 Container : Node_Or_Entity_Id;
8329 Counter : in out Int;
8332 -- Rec is the instance of the record type, or Empty.
8333 -- Field is either the N_Defining_Identifier for a component,
8334 -- or an N_Variant_Part.
8336 procedure Append_Record_Traversal
8339 Container : Node_Or_Entity_Id;
8340 Counter : in out Int);
8341 -- Process component list Clist. Individual fields are passed
8342 -- to Field_Processing. Each variant part is also processed.
8343 -- Container is the outer Any (for From_Any/To_Any),
8344 -- the outer typecode (for TC) to which the operation applies.
8346 -----------------------------
8347 -- Append_Record_Traversal --
8348 -----------------------------
8350 procedure Append_Record_Traversal
8353 Container : Node_Or_Entity_Id;
8354 Counter : in out Int)
8358 -- Clist's Component_Items and Variant_Part
8368 CI := Component_Items (Clist);
8369 VP := Variant_Part (Clist);
8372 while Present (Item) loop
8373 Def := Defining_Identifier (Item);
8375 if not Is_Internal_Name (Chars (Def)) then
8377 (Stmts, Container, Counter, Rec, Def);
8383 if Present (VP) then
8384 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8386 end Append_Record_Traversal;
8388 -----------------------------
8389 -- Assign_Opaque_From_Any --
8390 -----------------------------
8392 procedure Assign_Opaque_From_Any
8399 Strm : constant Entity_Id :=
8400 Make_Defining_Identifier (Loc,
8401 Chars => New_Internal_Name ('S'));
8404 Read_Call_List : List_Id;
8405 -- List on which to place the 'Read attribute reference
8408 -- Strm : Buffer_Stream_Type;
8411 Make_Object_Declaration (Loc,
8412 Defining_Identifier => Strm,
8413 Aliased_Present => True,
8414 Object_Definition =>
8415 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
8417 -- Any_To_BS (Strm, A);
8420 Make_Procedure_Call_Statement (Loc,
8421 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
8422 Parameter_Associations => New_List (
8424 New_Occurrence_Of (Strm, Loc))));
8426 if Transmit_As_Unconstrained (Typ) then
8428 Make_Attribute_Reference (Loc,
8429 Prefix => New_Occurrence_Of (Typ, Loc),
8430 Attribute_Name => Name_Input,
8431 Expressions => New_List (
8432 Make_Attribute_Reference (Loc,
8433 Prefix => New_Occurrence_Of (Strm, Loc),
8434 Attribute_Name => Name_Access)));
8436 -- Target := Typ'Input (Strm'Access)
8438 if Present (Target) then
8440 Make_Assignment_Statement (Loc,
8441 Name => New_Occurrence_Of (Target, Loc),
8442 Expression => Expr));
8444 -- return Typ'Input (Strm'Access);
8448 Make_Simple_Return_Statement (Loc,
8449 Expression => Expr));
8453 if Present (Target) then
8454 Read_Call_List := Stms;
8455 Expr := New_Occurrence_Of (Target, Loc);
8459 Temp : constant Entity_Id :=
8460 Make_Defining_Identifier
8461 (Loc, New_Internal_Name ('R'));
8464 Read_Call_List := New_List;
8465 Expr := New_Occurrence_Of (Temp, Loc);
8467 Append_To (Stms, Make_Block_Statement (Loc,
8468 Declarations => New_List (
8469 Make_Object_Declaration (Loc,
8470 Defining_Identifier =>
8472 Object_Definition =>
8473 New_Occurrence_Of (Typ, Loc))),
8475 Handled_Statement_Sequence =>
8476 Make_Handled_Sequence_Of_Statements (Loc,
8477 Statements => Read_Call_List)));
8481 -- Typ'Read (Strm'Access, [Target|Temp])
8483 Append_To (Read_Call_List,
8484 Make_Attribute_Reference (Loc,
8485 Prefix => New_Occurrence_Of (Typ, Loc),
8486 Attribute_Name => Name_Read,
8487 Expressions => New_List (
8488 Make_Attribute_Reference (Loc,
8489 Prefix => New_Occurrence_Of (Strm, Loc),
8490 Attribute_Name => Name_Access),
8497 Append_To (Read_Call_List,
8498 Make_Simple_Return_Statement (Loc,
8499 Expression => New_Copy (Expr)));
8502 end Assign_Opaque_From_Any;
8504 -------------------------
8505 -- Build_From_Any_Call --
8506 -------------------------
8508 function Build_From_Any_Call
8511 Decls : List_Id) return Node_Id
8513 Loc : constant Source_Ptr := Sloc (N);
8515 U_Type : Entity_Id := Underlying_Type (Typ);
8517 Fnam : Entity_Id := Empty;
8518 Lib_RE : RE_Id := RE_Null;
8522 -- First simple case where the From_Any function is present
8523 -- in the type's TSS.
8525 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8527 if Sloc (U_Type) <= Standard_Location then
8528 U_Type := Base_Type (U_Type);
8531 -- Check first for Boolean and Character. These are enumeration
8532 -- types, but we treat them specially, since they may require
8533 -- special handling in the transfer protocol. However, this
8534 -- special handling only applies if they have standard
8535 -- representation, otherwise they are treated like any other
8536 -- enumeration type.
8538 if Present (Fnam) then
8541 elsif U_Type = Standard_Boolean then
8544 elsif U_Type = Standard_Character then
8547 elsif U_Type = Standard_Wide_Character then
8550 elsif U_Type = Standard_Wide_Wide_Character then
8551 Lib_RE := RE_FA_WWC;
8553 -- Floating point types
8555 elsif U_Type = Standard_Short_Float then
8558 elsif U_Type = Standard_Float then
8561 elsif U_Type = Standard_Long_Float then
8564 elsif U_Type = Standard_Long_Long_Float then
8565 Lib_RE := RE_FA_LLF;
8569 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8570 Lib_RE := RE_FA_SSI;
8572 elsif U_Type = Etype (Standard_Short_Integer) then
8575 elsif U_Type = Etype (Standard_Integer) then
8578 elsif U_Type = Etype (Standard_Long_Integer) then
8581 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8582 Lib_RE := RE_FA_LLI;
8584 -- Unsigned integer types
8586 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8587 Lib_RE := RE_FA_SSU;
8589 elsif U_Type = RTE (RE_Short_Unsigned) then
8592 elsif U_Type = RTE (RE_Unsigned) then
8595 elsif U_Type = RTE (RE_Long_Unsigned) then
8598 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8599 Lib_RE := RE_FA_LLU;
8601 elsif Is_RTE (U_Type, RE_Unbounded_String) then
8602 Lib_RE := RE_FA_String;
8604 -- Special DSA types
8606 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
8609 -- Other (non-primitive) types
8616 -- For the subtype representing a generic actual type, go
8617 -- to the base type.
8619 if Is_Generic_Actual_Type (U_Type) then
8620 U_Type := Base_Type (U_Type);
8623 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8624 Append_To (Decls, Decl);
8628 -- Call the function
8630 if Lib_RE /= RE_Null then
8631 pragma Assert (No (Fnam));
8632 Fnam := RTE (Lib_RE);
8636 Make_Function_Call (Loc,
8637 Name => New_Occurrence_Of (Fnam, Loc),
8638 Parameter_Associations => New_List (N));
8640 -- We must set the type of Result, so the unchecked conversion
8641 -- from the underlying type to the base type is properly done.
8643 Set_Etype (Result, U_Type);
8645 return Unchecked_Convert_To (Typ, Result);
8646 end Build_From_Any_Call;
8648 -----------------------------
8649 -- Build_From_Any_Function --
8650 -----------------------------
8652 procedure Build_From_Any_Function
8656 Fnam : out Entity_Id)
8659 Decls : constant List_Id := New_List;
8660 Stms : constant List_Id := New_List;
8662 Any_Parameter : constant Entity_Id :=
8663 Make_Defining_Identifier (Loc,
8664 New_Internal_Name ('A'));
8666 Use_Opaque_Representation : Boolean;
8669 -- For a derived type, we can't go past the base type (to the
8670 -- parent type) here, because that would cause the attribute's
8671 -- formal parameter to have the wrong type; hence the Base_Type
8674 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
8675 Build_From_Any_Function
8683 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
8686 Make_Function_Specification (Loc,
8687 Defining_Unit_Name => Fnam,
8688 Parameter_Specifications => New_List (
8689 Make_Parameter_Specification (Loc,
8690 Defining_Identifier => Any_Parameter,
8691 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
8692 Result_Definition => New_Occurrence_Of (Typ, Loc));
8694 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8697 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8699 Use_Opaque_Representation := False;
8701 if Has_Stream_Attribute_Definition
8702 (Typ, TSS_Stream_Output, At_Any_Place => True)
8704 Has_Stream_Attribute_Definition
8705 (Typ, TSS_Stream_Write, At_Any_Place => True)
8707 -- If user-defined stream attributes are specified for this
8708 -- type, use them and transmit data as an opaque sequence of
8711 Use_Opaque_Representation := True;
8713 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
8715 Make_Simple_Return_Statement (Loc,
8720 New_Occurrence_Of (Any_Parameter, Loc),
8723 elsif Is_Record_Type (Typ)
8724 and then not Is_Derived_Type (Typ)
8725 and then not Is_Tagged_Type (Typ)
8727 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8729 Make_Simple_Return_Statement (Loc,
8733 New_Occurrence_Of (Any_Parameter, Loc),
8738 Disc : Entity_Id := Empty;
8739 Discriminant_Associations : List_Id;
8740 Rdef : constant Node_Id :=
8742 (Declaration_Node (Typ));
8743 Component_Counter : Int := 0;
8745 -- The returned object
8747 Res : constant Entity_Id :=
8748 Make_Defining_Identifier (Loc,
8749 New_Internal_Name ('R'));
8751 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8753 procedure FA_Rec_Add_Process_Element
8756 Counter : in out Int;
8760 procedure FA_Append_Record_Traversal is
8761 new Append_Record_Traversal
8763 Add_Process_Element => FA_Rec_Add_Process_Element);
8765 --------------------------------
8766 -- FA_Rec_Add_Process_Element --
8767 --------------------------------
8769 procedure FA_Rec_Add_Process_Element
8772 Counter : in out Int;
8778 if Nkind (Field) = N_Defining_Identifier then
8779 -- A regular component
8781 Ctyp := Etype (Field);
8784 Make_Assignment_Statement (Loc,
8785 Name => Make_Selected_Component (Loc,
8787 New_Occurrence_Of (Rec, Loc),
8789 New_Occurrence_Of (Field, Loc)),
8792 Build_From_Any_Call (Ctyp,
8793 Build_Get_Aggregate_Element (Loc,
8796 Build_TypeCode_Call (Loc, Ctyp, Decls),
8798 Make_Integer_Literal (Loc, Counter)),
8806 Struct_Counter : Int := 0;
8808 Block_Decls : constant List_Id := New_List;
8809 Block_Stmts : constant List_Id := New_List;
8812 Alt_List : constant List_Id := New_List;
8813 Choice_List : List_Id;
8815 Struct_Any : constant Entity_Id :=
8816 Make_Defining_Identifier (Loc,
8817 New_Internal_Name ('S'));
8821 Make_Object_Declaration (Loc,
8822 Defining_Identifier => Struct_Any,
8823 Constant_Present => True,
8824 Object_Definition =>
8825 New_Occurrence_Of (RTE (RE_Any), Loc),
8827 Make_Function_Call (Loc,
8830 (RTE (RE_Extract_Union_Value), Loc),
8832 Parameter_Associations => New_List (
8833 Build_Get_Aggregate_Element (Loc,
8836 Make_Function_Call (Loc,
8837 Name => New_Occurrence_Of (
8838 RTE (RE_Any_Member_Type), Loc),
8839 Parameter_Associations =>
8841 New_Occurrence_Of (Any, Loc),
8842 Make_Integer_Literal (Loc,
8843 Intval => Counter))),
8845 Make_Integer_Literal (Loc,
8846 Intval => Counter))))));
8849 Make_Block_Statement (Loc,
8850 Declarations => Block_Decls,
8851 Handled_Statement_Sequence =>
8852 Make_Handled_Sequence_Of_Statements (Loc,
8853 Statements => Block_Stmts)));
8855 Append_To (Block_Stmts,
8856 Make_Case_Statement (Loc,
8858 Make_Selected_Component (Loc,
8860 Selector_Name => Chars (Name (Field))),
8861 Alternatives => Alt_List));
8863 Variant := First_Non_Pragma (Variants (Field));
8864 while Present (Variant) loop
8867 (Discrete_Choices (Variant));
8869 VP_Stmts := New_List;
8871 -- Struct_Counter should be reset before
8872 -- handling a variant part. Indeed only one
8873 -- of the case statement alternatives will be
8874 -- executed at run-time, so the counter must
8875 -- start at 0 for every case statement.
8877 Struct_Counter := 0;
8879 FA_Append_Record_Traversal (
8881 Clist => Component_List (Variant),
8882 Container => Struct_Any,
8883 Counter => Struct_Counter);
8885 Append_To (Alt_List,
8886 Make_Case_Statement_Alternative (Loc,
8887 Discrete_Choices => Choice_List,
8888 Statements => VP_Stmts));
8889 Next_Non_Pragma (Variant);
8894 Counter := Counter + 1;
8895 end FA_Rec_Add_Process_Element;
8898 -- First all discriminants
8900 if Has_Discriminants (Typ) then
8901 Discriminant_Associations := New_List;
8903 Disc := First_Discriminant (Typ);
8904 while Present (Disc) loop
8906 Disc_Var_Name : constant Entity_Id :=
8907 Make_Defining_Identifier (Loc,
8908 Chars => Chars (Disc));
8909 Disc_Type : constant Entity_Id :=
8914 Make_Object_Declaration (Loc,
8915 Defining_Identifier => Disc_Var_Name,
8916 Constant_Present => True,
8917 Object_Definition =>
8918 New_Occurrence_Of (Disc_Type, Loc),
8921 Build_From_Any_Call (Disc_Type,
8922 Build_Get_Aggregate_Element (Loc,
8923 Any => Any_Parameter,
8924 TC => Build_TypeCode_Call
8925 (Loc, Disc_Type, Decls),
8926 Idx => Make_Integer_Literal (Loc,
8927 Intval => Component_Counter)),
8930 Component_Counter := Component_Counter + 1;
8932 Append_To (Discriminant_Associations,
8933 Make_Discriminant_Association (Loc,
8934 Selector_Names => New_List (
8935 New_Occurrence_Of (Disc, Loc)),
8937 New_Occurrence_Of (Disc_Var_Name, Loc)));
8939 Next_Discriminant (Disc);
8943 Make_Subtype_Indication (Loc,
8944 Subtype_Mark => Res_Definition,
8946 Make_Index_Or_Discriminant_Constraint (Loc,
8947 Discriminant_Associations));
8950 -- Now we have all the discriminants in variables, we can
8951 -- declared a constrained object. Note that we are not
8952 -- initializing (non-discriminant) components directly in
8953 -- the object declarations, because which fields to
8954 -- initialize depends (at run time) on the discriminant
8958 Make_Object_Declaration (Loc,
8959 Defining_Identifier => Res,
8960 Object_Definition => Res_Definition));
8962 -- ... then all components
8964 FA_Append_Record_Traversal (Stms,
8965 Clist => Component_List (Rdef),
8966 Container => Any_Parameter,
8967 Counter => Component_Counter);
8970 Make_Simple_Return_Statement (Loc,
8971 Expression => New_Occurrence_Of (Res, Loc)));
8975 elsif Is_Array_Type (Typ) then
8977 Constrained : constant Boolean := Is_Constrained (Typ);
8979 procedure FA_Ary_Add_Process_Element
8982 Counter : Entity_Id;
8984 -- Assign the current element (as identified by Counter) of
8985 -- Any to the variable denoted by name Datum, and advance
8986 -- Counter by 1. If Datum is not an Any, a call to From_Any
8987 -- for its type is inserted.
8989 --------------------------------
8990 -- FA_Ary_Add_Process_Element --
8991 --------------------------------
8993 procedure FA_Ary_Add_Process_Element
8996 Counter : Entity_Id;
8999 Assignment : constant Node_Id :=
9000 Make_Assignment_Statement (Loc,
9002 Expression => Empty);
9004 Element_Any : Node_Id;
9008 Element_TC : Node_Id;
9011 if Etype (Datum) = RTE (RE_Any) then
9013 -- When Datum is an Any the Etype field is not
9014 -- sufficient to determine the typecode of Datum
9015 -- (which can be a TC_SEQUENCE or TC_ARRAY
9016 -- depending on the value of Constrained).
9018 -- Therefore we retrieve the typecode which has
9019 -- been constructed in Append_Array_Traversal with
9020 -- a call to Get_Any_Type.
9023 Make_Function_Call (Loc,
9024 Name => New_Occurrence_Of (
9025 RTE (RE_Get_Any_Type), Loc),
9026 Parameter_Associations => New_List (
9027 New_Occurrence_Of (Entity (Datum), Loc)));
9029 -- For non Any Datum we simply construct a typecode
9030 -- matching the Etype of the Datum.
9032 Element_TC := Build_TypeCode_Call
9033 (Loc, Etype (Datum), Decls);
9037 Build_Get_Aggregate_Element (Loc,
9040 Idx => New_Occurrence_Of (Counter, Loc));
9043 -- Note: here we *prepend* statements to Stmts, so
9044 -- we must do it in reverse order.
9047 Make_Assignment_Statement (Loc,
9049 New_Occurrence_Of (Counter, Loc),
9052 Left_Opnd => New_Occurrence_Of (Counter, Loc),
9053 Right_Opnd => Make_Integer_Literal (Loc, 1))));
9055 if Nkind (Datum) /= N_Attribute_Reference then
9057 -- We ignore the value of the length of each
9058 -- dimension, since the target array has already
9059 -- been constrained anyway.
9061 if Etype (Datum) /= RTE (RE_Any) then
9062 Set_Expression (Assignment,
9064 (Component_Type (Typ), Element_Any, Decls));
9066 Set_Expression (Assignment, Element_Any);
9069 Prepend_To (Stmts, Assignment);
9071 end FA_Ary_Add_Process_Element;
9073 ------------------------
9074 -- Local Declarations --
9075 ------------------------
9077 Counter : constant Entity_Id :=
9078 Make_Defining_Identifier (Loc, Name_J);
9080 Initial_Counter_Value : Int := 0;
9082 Component_TC : constant Entity_Id :=
9083 Make_Defining_Identifier (Loc, Name_T);
9085 Res : constant Entity_Id :=
9086 Make_Defining_Identifier (Loc, Name_R);
9088 procedure Append_From_Any_Array_Iterator is
9089 new Append_Array_Traversal (
9092 Indices => New_List,
9093 Add_Process_Element => FA_Ary_Add_Process_Element);
9095 Res_Subtype_Indication : Node_Id :=
9096 New_Occurrence_Of (Typ, Loc);
9099 if not Constrained then
9101 Ndim : constant Int := Number_Dimensions (Typ);
9104 Indx : Node_Id := First_Index (Typ);
9107 Ranges : constant List_Id := New_List;
9110 for J in 1 .. Ndim loop
9111 Lnam := New_External_Name ('L', J);
9112 Hnam := New_External_Name ('H', J);
9114 -- Note, for empty arrays bounds may be out of
9115 -- the range of Etype (Indx).
9117 Indt := Base_Type (Etype (Indx));
9120 Make_Object_Declaration (Loc,
9121 Defining_Identifier =>
9122 Make_Defining_Identifier (Loc, Lnam),
9123 Constant_Present => True,
9124 Object_Definition =>
9125 New_Occurrence_Of (Indt, Loc),
9129 Build_Get_Aggregate_Element (Loc,
9130 Any => Any_Parameter,
9131 TC => Build_TypeCode_Call
9134 Make_Integer_Literal (Loc, J - 1)),
9138 Make_Object_Declaration (Loc,
9139 Defining_Identifier =>
9140 Make_Defining_Identifier (Loc, Hnam),
9142 Constant_Present => True,
9144 Object_Definition =>
9145 New_Occurrence_Of (Indt, Loc),
9147 Expression => Make_Attribute_Reference (Loc,
9149 New_Occurrence_Of (Indt, Loc),
9151 Attribute_Name => Name_Val,
9153 Expressions => New_List (
9154 Make_Op_Subtract (Loc,
9159 Standard_Long_Integer,
9160 Make_Identifier (Loc, Lnam)),
9164 Standard_Long_Integer,
9165 Make_Function_Call (Loc,
9167 New_Occurrence_Of (RTE (
9168 RE_Get_Nested_Sequence_Length
9170 Parameter_Associations =>
9173 Any_Parameter, Loc),
9174 Make_Integer_Literal (Loc,
9178 Make_Integer_Literal (Loc, 1))))));
9182 Low_Bound => Make_Identifier (Loc, Lnam),
9183 High_Bound => Make_Identifier (Loc, Hnam)));
9188 -- Now we have all the necessary bound information:
9189 -- apply the set of range constraints to the
9190 -- (unconstrained) nominal subtype of Res.
9192 Initial_Counter_Value := Ndim;
9193 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9194 Subtype_Mark => Res_Subtype_Indication,
9196 Make_Index_Or_Discriminant_Constraint (Loc,
9197 Constraints => Ranges));
9202 Make_Object_Declaration (Loc,
9203 Defining_Identifier => Res,
9204 Object_Definition => Res_Subtype_Indication));
9205 Set_Etype (Res, Typ);
9208 Make_Object_Declaration (Loc,
9209 Defining_Identifier => Counter,
9210 Object_Definition =>
9211 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
9213 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9216 Make_Object_Declaration (Loc,
9217 Defining_Identifier => Component_TC,
9218 Constant_Present => True,
9219 Object_Definition =>
9220 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9222 Build_TypeCode_Call (Loc,
9223 Component_Type (Typ), Decls)));
9225 Append_From_Any_Array_Iterator
9226 (Stms, Any_Parameter, Counter);
9229 Make_Simple_Return_Statement (Loc,
9230 Expression => New_Occurrence_Of (Res, Loc)));
9233 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9235 Make_Simple_Return_Statement (Loc,
9237 Unchecked_Convert_To (Typ,
9239 (Find_Numeric_Representation (Typ),
9240 New_Occurrence_Of (Any_Parameter, Loc),
9244 Use_Opaque_Representation := True;
9247 if Use_Opaque_Representation then
9248 Assign_Opaque_From_Any (Loc,
9251 N => New_Occurrence_Of (Any_Parameter, Loc),
9256 Make_Subprogram_Body (Loc,
9257 Specification => Spec,
9258 Declarations => Decls,
9259 Handled_Statement_Sequence =>
9260 Make_Handled_Sequence_Of_Statements (Loc,
9261 Statements => Stms));
9262 end Build_From_Any_Function;
9264 ---------------------------------
9265 -- Build_Get_Aggregate_Element --
9266 ---------------------------------
9268 function Build_Get_Aggregate_Element
9272 Idx : Node_Id) return Node_Id
9275 return Make_Function_Call (Loc,
9277 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc),
9278 Parameter_Associations => New_List (
9279 New_Occurrence_Of (Any, Loc),
9282 end Build_Get_Aggregate_Element;
9284 -------------------------
9285 -- Build_Reposiroty_Id --
9286 -------------------------
9288 procedure Build_Name_And_Repository_Id
9290 Name_Str : out String_Id;
9291 Repo_Id_Str : out String_Id)
9295 Store_String_Chars ("DSA:");
9296 Get_Library_Unit_Name_String (Scope (E));
9298 (Name_Buffer (Name_Buffer'First ..
9299 Name_Buffer'First + Name_Len - 1));
9300 Store_String_Char ('.');
9301 Get_Name_String (Chars (E));
9303 (Name_Buffer (Name_Buffer'First ..
9304 Name_Buffer'First + Name_Len - 1));
9305 Store_String_Chars (":1.0");
9306 Repo_Id_Str := End_String;
9307 Name_Str := String_From_Name_Buffer;
9308 end Build_Name_And_Repository_Id;
9310 -----------------------
9311 -- Build_To_Any_Call --
9312 -----------------------
9314 function Build_To_Any_Call
9316 Decls : List_Id) return Node_Id
9318 Loc : constant Source_Ptr := Sloc (N);
9320 Typ : Entity_Id := Etype (N);
9323 Fnam : Entity_Id := Empty;
9324 Lib_RE : RE_Id := RE_Null;
9327 -- If N is a selected component, then maybe its Etype has not been
9328 -- set yet: try to use Etype of the selector_name in that case.
9330 if No (Typ) and then Nkind (N) = N_Selected_Component then
9331 Typ := Etype (Selector_Name (N));
9334 pragma Assert (Present (Typ));
9336 -- Get full view for private type, completion for incomplete type
9338 U_Type := Underlying_Type (Typ);
9340 -- First simple case where the To_Any function is present in the
9343 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9345 -- Check first for Boolean and Character. These are enumeration
9346 -- types, but we treat them specially, since they may require
9347 -- special handling in the transfer protocol. However, this
9348 -- special handling only applies if they have standard
9349 -- representation, otherwise they are treated like any other
9350 -- enumeration type.
9352 if Sloc (U_Type) <= Standard_Location then
9353 U_Type := Base_Type (U_Type);
9356 if Present (Fnam) then
9359 elsif U_Type = Standard_Boolean then
9362 elsif U_Type = Standard_Character then
9365 elsif U_Type = Standard_Wide_Character then
9368 elsif U_Type = Standard_Wide_Wide_Character then
9369 Lib_RE := RE_TA_WWC;
9371 -- Floating point types
9373 elsif U_Type = Standard_Short_Float then
9376 elsif U_Type = Standard_Float then
9379 elsif U_Type = Standard_Long_Float then
9382 elsif U_Type = Standard_Long_Long_Float then
9383 Lib_RE := RE_TA_LLF;
9387 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9388 Lib_RE := RE_TA_SSI;
9390 elsif U_Type = Etype (Standard_Short_Integer) then
9393 elsif U_Type = Etype (Standard_Integer) then
9396 elsif U_Type = Etype (Standard_Long_Integer) then
9399 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9400 Lib_RE := RE_TA_LLI;
9402 -- Unsigned integer types
9404 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9405 Lib_RE := RE_TA_SSU;
9407 elsif U_Type = RTE (RE_Short_Unsigned) then
9410 elsif U_Type = RTE (RE_Unsigned) then
9413 elsif U_Type = RTE (RE_Long_Unsigned) then
9416 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9417 Lib_RE := RE_TA_LLU;
9419 elsif Is_RTE (U_Type, RE_Unbounded_String) then
9420 Lib_RE := RE_TA_String;
9422 -- Special DSA types
9424 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
9428 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9430 -- No corresponding FA_TC ???
9434 -- Other (non-primitive) types
9440 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9441 Append_To (Decls, Decl);
9445 -- Call the function
9447 if Lib_RE /= RE_Null then
9448 pragma Assert (No (Fnam));
9449 Fnam := RTE (Lib_RE);
9452 -- If Fnam is already analyzed, find the proper expected type,
9453 -- else we have a newly constructed To_Any function and we know
9454 -- that the expected type of its parameter is U_Type.
9456 if Ekind (Fnam) = E_Function
9457 and then Present (First_Formal (Fnam))
9459 C_Type := Etype (First_Formal (Fnam));
9465 Make_Function_Call (Loc,
9466 Name => New_Occurrence_Of (Fnam, Loc),
9467 Parameter_Associations =>
9468 New_List (OK_Convert_To (C_Type, N)));
9469 end Build_To_Any_Call;
9471 ---------------------------
9472 -- Build_To_Any_Function --
9473 ---------------------------
9475 procedure Build_To_Any_Function
9479 Fnam : out Entity_Id)
9482 Decls : constant List_Id := New_List;
9483 Stms : constant List_Id := New_List;
9485 Expr_Parameter : constant Entity_Id :=
9486 Make_Defining_Identifier (Loc, Name_E);
9488 Any : constant Entity_Id :=
9489 Make_Defining_Identifier (Loc, Name_A);
9492 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9494 Use_Opaque_Representation : Boolean;
9495 -- When True, use stream attributes and represent type as an
9496 -- opaque sequence of bytes.
9499 -- For a derived type, we can't go past the base type (to the
9500 -- parent type) here, because that would cause the attribute's
9501 -- formal parameter to have the wrong type; hence the Base_Type
9504 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
9505 Build_To_Any_Function
9513 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
9516 Make_Function_Specification (Loc,
9517 Defining_Unit_Name => Fnam,
9518 Parameter_Specifications => New_List (
9519 Make_Parameter_Specification (Loc,
9520 Defining_Identifier => Expr_Parameter,
9521 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9522 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9523 Set_Etype (Expr_Parameter, Typ);
9526 Make_Object_Declaration (Loc,
9527 Defining_Identifier => Any,
9528 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9530 Use_Opaque_Representation := False;
9532 if Has_Stream_Attribute_Definition
9533 (Typ, TSS_Stream_Output, At_Any_Place => True)
9535 Has_Stream_Attribute_Definition
9536 (Typ, TSS_Stream_Write, At_Any_Place => True)
9538 -- If user-defined stream attributes are specified for this
9539 -- type, use them and transmit data as an opaque sequence of
9542 Use_Opaque_Representation := True;
9544 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9546 -- Non-tagged derived type: convert to root type
9549 Rt_Type : constant Entity_Id := Root_Type (Typ);
9550 Expr : constant Node_Id :=
9553 New_Occurrence_Of (Expr_Parameter, Loc));
9555 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9558 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9560 -- Non-tagged record type
9562 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9564 Rt_Type : constant Entity_Id := Etype (Typ);
9565 Expr : constant Node_Id :=
9566 OK_Convert_To (Rt_Type,
9567 New_Occurrence_Of (Expr_Parameter, Loc));
9571 (Any_Decl, Build_To_Any_Call (Expr, Decls));
9574 -- Comment needed here (and label on declare block ???)
9578 Disc : Entity_Id := Empty;
9579 Rdef : constant Node_Id :=
9580 Type_Definition (Declaration_Node (Typ));
9582 Elements : constant List_Id := New_List;
9584 procedure TA_Rec_Add_Process_Element
9586 Container : Node_Or_Entity_Id;
9587 Counter : in out Int;
9590 -- Processing routine for traversal below
9592 procedure TA_Append_Record_Traversal is
9593 new Append_Record_Traversal
9594 (Rec => Expr_Parameter,
9595 Add_Process_Element => TA_Rec_Add_Process_Element);
9597 --------------------------------
9598 -- TA_Rec_Add_Process_Element --
9599 --------------------------------
9601 procedure TA_Rec_Add_Process_Element
9603 Container : Node_Or_Entity_Id;
9604 Counter : in out Int;
9608 Field_Ref : Node_Id;
9611 if Nkind (Field) = N_Defining_Identifier then
9613 -- A regular component
9615 Field_Ref := Make_Selected_Component (Loc,
9616 Prefix => New_Occurrence_Of (Rec, Loc),
9617 Selector_Name => New_Occurrence_Of (Field, Loc));
9618 Set_Etype (Field_Ref, Etype (Field));
9621 Make_Procedure_Call_Statement (Loc,
9624 RTE (RE_Add_Aggregate_Element), Loc),
9625 Parameter_Associations => New_List (
9626 New_Occurrence_Of (Container, Loc),
9627 Build_To_Any_Call (Field_Ref, Decls))));
9632 Variant_Part : declare
9634 Struct_Counter : Int := 0;
9636 Block_Decls : constant List_Id := New_List;
9637 Block_Stmts : constant List_Id := New_List;
9640 Alt_List : constant List_Id := New_List;
9641 Choice_List : List_Id;
9643 Union_Any : constant Entity_Id :=
9644 Make_Defining_Identifier (Loc,
9645 New_Internal_Name ('V'));
9647 Struct_Any : constant Entity_Id :=
9648 Make_Defining_Identifier (Loc,
9649 New_Internal_Name ('S'));
9651 function Make_Discriminant_Reference
9653 -- Build reference to the discriminant for this
9656 ---------------------------------
9657 -- Make_Discriminant_Reference --
9658 ---------------------------------
9660 function Make_Discriminant_Reference
9663 Nod : constant Node_Id :=
9664 Make_Selected_Component (Loc,
9667 Chars (Name (Field)));
9669 Set_Etype (Nod, Etype (Name (Field)));
9671 end Make_Discriminant_Reference;
9673 -- Start of processing for Variant_Part
9677 Make_Block_Statement (Loc,
9680 Handled_Statement_Sequence =>
9681 Make_Handled_Sequence_Of_Statements (Loc,
9682 Statements => Block_Stmts)));
9684 -- Declare variant part aggregate (Union_Any).
9685 -- Knowing the position of this VP in the
9686 -- variant record, we can fetch the VP typecode
9689 Append_To (Block_Decls,
9690 Make_Object_Declaration (Loc,
9691 Defining_Identifier => Union_Any,
9692 Object_Definition =>
9693 New_Occurrence_Of (RTE (RE_Any), Loc),
9695 Make_Function_Call (Loc,
9696 Name => New_Occurrence_Of (
9697 RTE (RE_Create_Any), Loc),
9698 Parameter_Associations => New_List (
9699 Make_Function_Call (Loc,
9702 RTE (RE_Any_Member_Type), Loc),
9703 Parameter_Associations => New_List (
9704 New_Occurrence_Of (Container, Loc),
9705 Make_Integer_Literal (Loc,
9708 -- Declare inner struct aggregate (which
9709 -- contains the components of this VP).
9711 Append_To (Block_Decls,
9712 Make_Object_Declaration (Loc,
9713 Defining_Identifier => Struct_Any,
9714 Object_Definition =>
9715 New_Occurrence_Of (RTE (RE_Any), Loc),
9717 Make_Function_Call (Loc,
9718 Name => New_Occurrence_Of (
9719 RTE (RE_Create_Any), Loc),
9720 Parameter_Associations => New_List (
9721 Make_Function_Call (Loc,
9724 RTE (RE_Any_Member_Type), Loc),
9725 Parameter_Associations => New_List (
9726 New_Occurrence_Of (Union_Any, Loc),
9727 Make_Integer_Literal (Loc,
9730 -- Build case statement
9732 Append_To (Block_Stmts,
9733 Make_Case_Statement (Loc,
9734 Expression => Make_Discriminant_Reference,
9735 Alternatives => Alt_List));
9737 Variant := First_Non_Pragma (Variants (Field));
9738 while Present (Variant) loop
9739 Choice_List := New_Copy_List_Tree
9740 (Discrete_Choices (Variant));
9742 VP_Stmts := New_List;
9744 -- Append discriminant val to union aggregate
9746 Append_To (VP_Stmts,
9747 Make_Procedure_Call_Statement (Loc,
9750 RTE (RE_Add_Aggregate_Element), Loc),
9751 Parameter_Associations => New_List (
9752 New_Occurrence_Of (Union_Any, Loc),
9754 (Make_Discriminant_Reference,
9757 -- Populate inner struct aggregate
9759 -- Struct_Counter should be reset before
9760 -- handling a variant part. Indeed only one
9761 -- of the case statement alternatives will be
9762 -- executed at run-time, so the counter must
9763 -- start at 0 for every case statement.
9765 Struct_Counter := 0;
9767 TA_Append_Record_Traversal
9769 Clist => Component_List (Variant),
9770 Container => Struct_Any,
9771 Counter => Struct_Counter);
9773 -- Append inner struct to union aggregate
9775 Append_To (VP_Stmts,
9776 Make_Procedure_Call_Statement (Loc,
9779 (RTE (RE_Add_Aggregate_Element), Loc),
9780 Parameter_Associations => New_List (
9781 New_Occurrence_Of (Union_Any, Loc),
9782 New_Occurrence_Of (Struct_Any, Loc))));
9784 -- Append union to outer aggregate
9786 Append_To (VP_Stmts,
9787 Make_Procedure_Call_Statement (Loc,
9790 (RTE (RE_Add_Aggregate_Element), Loc),
9791 Parameter_Associations => New_List (
9792 New_Occurrence_Of (Container, Loc),
9794 (Union_Any, Loc))));
9796 Append_To (Alt_List,
9797 Make_Case_Statement_Alternative (Loc,
9798 Discrete_Choices => Choice_List,
9799 Statements => VP_Stmts));
9801 Next_Non_Pragma (Variant);
9806 Counter := Counter + 1;
9807 end TA_Rec_Add_Process_Element;
9810 -- Records are encoded in a TC_STRUCT aggregate:
9812 -- -- Outer aggregate (TC_STRUCT)
9813 -- | [discriminant1]
9814 -- | [discriminant2]
9821 -- A component can be a common component or variant part
9823 -- A variant part is encoded as a TC_UNION aggregate:
9825 -- -- Variant Part Aggregate (TC_UNION)
9826 -- | [discriminant choice for this Variant Part]
9828 -- | -- Inner struct (TC_STRUCT)
9833 -- Let's start by building the outer aggregate. First we
9834 -- construct Elements array containing all discriminants.
9836 if Has_Discriminants (Typ) then
9837 Disc := First_Discriminant (Typ);
9838 while Present (Disc) loop
9840 Discriminant : constant Entity_Id :=
9841 Make_Selected_Component (Loc,
9848 Set_Etype (Discriminant, Etype (Disc));
9850 Append_To (Elements,
9851 Make_Component_Association (Loc,
9852 Choices => New_List (
9853 Make_Integer_Literal (Loc, Counter)),
9855 Build_To_Any_Call (Discriminant, Decls)));
9858 Counter := Counter + 1;
9859 Next_Discriminant (Disc);
9863 -- If there are no discriminants, we declare an empty
9867 Dummy_Any : constant Entity_Id :=
9868 Make_Defining_Identifier (Loc,
9869 Chars => New_Internal_Name ('A'));
9873 Make_Object_Declaration (Loc,
9874 Defining_Identifier => Dummy_Any,
9875 Object_Definition =>
9876 New_Occurrence_Of (RTE (RE_Any), Loc)));
9878 Append_To (Elements,
9879 Make_Component_Association (Loc,
9880 Choices => New_List (
9883 Make_Integer_Literal (Loc, 1),
9885 Make_Integer_Literal (Loc, 0))),
9887 New_Occurrence_Of (Dummy_Any, Loc)));
9891 -- We build the result aggregate with discriminants
9892 -- as the first elements.
9894 Set_Expression (Any_Decl,
9895 Make_Function_Call (Loc,
9896 Name => New_Occurrence_Of
9897 (RTE (RE_Any_Aggregate_Build), Loc),
9898 Parameter_Associations => New_List (
9900 Make_Aggregate (Loc,
9901 Component_Associations => Elements))));
9904 -- Then we append all the components to the result
9907 TA_Append_Record_Traversal (Stms,
9908 Clist => Component_List (Rdef),
9910 Counter => Counter);
9914 elsif Is_Array_Type (Typ) then
9916 -- Constrained and unconstrained array types
9919 Constrained : constant Boolean := Is_Constrained (Typ);
9921 procedure TA_Ary_Add_Process_Element
9924 Counter : Entity_Id;
9927 --------------------------------
9928 -- TA_Ary_Add_Process_Element --
9929 --------------------------------
9931 procedure TA_Ary_Add_Process_Element
9934 Counter : Entity_Id;
9937 pragma Unreferenced (Counter);
9939 Element_Any : Node_Id;
9942 if Etype (Datum) = RTE (RE_Any) then
9943 Element_Any := Datum;
9945 Element_Any := Build_To_Any_Call (Datum, Decls);
9949 Make_Procedure_Call_Statement (Loc,
9950 Name => New_Occurrence_Of (
9951 RTE (RE_Add_Aggregate_Element), Loc),
9952 Parameter_Associations => New_List (
9953 New_Occurrence_Of (Any, Loc),
9955 end TA_Ary_Add_Process_Element;
9957 procedure Append_To_Any_Array_Iterator is
9958 new Append_Array_Traversal (
9960 Arry => Expr_Parameter,
9961 Indices => New_List,
9962 Add_Process_Element => TA_Ary_Add_Process_Element);
9967 Set_Expression (Any_Decl,
9968 Make_Function_Call (Loc,
9970 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9971 Parameter_Associations => New_List (Result_TC)));
9974 if not Constrained then
9975 Index := First_Index (Typ);
9976 for J in 1 .. Number_Dimensions (Typ) loop
9978 Make_Procedure_Call_Statement (Loc,
9981 RTE (RE_Add_Aggregate_Element), Loc),
9982 Parameter_Associations => New_List (
9983 New_Occurrence_Of (Any, Loc),
9985 OK_Convert_To (Etype (Index),
9986 Make_Attribute_Reference (Loc,
9988 New_Occurrence_Of (Expr_Parameter, Loc),
9989 Attribute_Name => Name_First,
9990 Expressions => New_List (
9991 Make_Integer_Literal (Loc, J)))),
9997 Append_To_Any_Array_Iterator (Stms, Any);
10000 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10004 Set_Expression (Any_Decl,
10005 Build_To_Any_Call (
10007 Find_Numeric_Representation (Typ),
10008 New_Occurrence_Of (Expr_Parameter, Loc)),
10012 -- Default case, including tagged types: opaque representation
10014 Use_Opaque_Representation := True;
10017 if Use_Opaque_Representation then
10019 Strm : constant Entity_Id :=
10020 Make_Defining_Identifier (Loc,
10021 Chars => New_Internal_Name ('S'));
10022 -- Stream used to store data representation produced by
10023 -- stream attribute.
10027 -- Strm : aliased Buffer_Stream_Type;
10030 Make_Object_Declaration (Loc,
10031 Defining_Identifier =>
10035 Object_Definition =>
10036 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
10039 -- T'Output (Strm'Access, E);
10042 Make_Attribute_Reference (Loc,
10043 Prefix => New_Occurrence_Of (Typ, Loc),
10044 Attribute_Name => Name_Output,
10045 Expressions => New_List (
10046 Make_Attribute_Reference (Loc,
10047 Prefix => New_Occurrence_Of (Strm, Loc),
10048 Attribute_Name => Name_Access),
10049 New_Occurrence_Of (Expr_Parameter, Loc))));
10052 -- BS_To_Any (Strm, A);
10055 Make_Procedure_Call_Statement (Loc,
10056 Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
10057 Parameter_Associations => New_List (
10058 New_Occurrence_Of (Strm, Loc),
10059 New_Occurrence_Of (Any, Loc))));
10062 -- Release_Buffer (Strm);
10065 Make_Procedure_Call_Statement (Loc,
10066 Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
10067 Parameter_Associations => New_List (
10068 New_Occurrence_Of (Strm, Loc))));
10072 Append_To (Decls, Any_Decl);
10074 if Present (Result_TC) then
10076 Make_Procedure_Call_Statement (Loc,
10077 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
10078 Parameter_Associations => New_List (
10079 New_Occurrence_Of (Any, Loc),
10084 Make_Simple_Return_Statement (Loc,
10085 Expression => New_Occurrence_Of (Any, Loc)));
10088 Make_Subprogram_Body (Loc,
10089 Specification => Spec,
10090 Declarations => Decls,
10091 Handled_Statement_Sequence =>
10092 Make_Handled_Sequence_Of_Statements (Loc,
10093 Statements => Stms));
10094 end Build_To_Any_Function;
10096 -------------------------
10097 -- Build_TypeCode_Call --
10098 -------------------------
10100 function Build_TypeCode_Call
10103 Decls : List_Id) return Node_Id
10105 U_Type : Entity_Id := Underlying_Type (Typ);
10106 -- The full view, if Typ is private; the completion,
10107 -- if Typ is incomplete.
10109 Fnam : Entity_Id := Empty;
10110 Lib_RE : RE_Id := RE_Null;
10114 -- Special case System.PolyORB.Interface.Any: its primitives have
10115 -- not been set yet, so can't call Find_Inherited_TSS.
10117 if Typ = RTE (RE_Any) then
10118 Fnam := RTE (RE_TC_A);
10121 -- First simple case where the TypeCode is present
10122 -- in the type's TSS.
10124 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10128 if Sloc (U_Type) <= Standard_Location then
10130 -- Do not try to build alias typecodes for subtypes from
10133 U_Type := Base_Type (U_Type);
10136 if U_Type = Standard_Boolean then
10139 elsif U_Type = Standard_Character then
10142 elsif U_Type = Standard_Wide_Character then
10143 Lib_RE := RE_TC_WC;
10145 elsif U_Type = Standard_Wide_Wide_Character then
10146 Lib_RE := RE_TC_WWC;
10148 -- Floating point types
10150 elsif U_Type = Standard_Short_Float then
10151 Lib_RE := RE_TC_SF;
10153 elsif U_Type = Standard_Float then
10156 elsif U_Type = Standard_Long_Float then
10157 Lib_RE := RE_TC_LF;
10159 elsif U_Type = Standard_Long_Long_Float then
10160 Lib_RE := RE_TC_LLF;
10162 -- Integer types (walk back to the base type)
10164 elsif U_Type = Etype (Standard_Short_Short_Integer) then
10165 Lib_RE := RE_TC_SSI;
10167 elsif U_Type = Etype (Standard_Short_Integer) then
10168 Lib_RE := RE_TC_SI;
10170 elsif U_Type = Etype (Standard_Integer) then
10173 elsif U_Type = Etype (Standard_Long_Integer) then
10174 Lib_RE := RE_TC_LI;
10176 elsif U_Type = Etype (Standard_Long_Long_Integer) then
10177 Lib_RE := RE_TC_LLI;
10179 -- Unsigned integer types
10181 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
10182 Lib_RE := RE_TC_SSU;
10184 elsif U_Type = RTE (RE_Short_Unsigned) then
10185 Lib_RE := RE_TC_SU;
10187 elsif U_Type = RTE (RE_Unsigned) then
10190 elsif U_Type = RTE (RE_Long_Unsigned) then
10191 Lib_RE := RE_TC_LU;
10193 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
10194 Lib_RE := RE_TC_LLU;
10196 elsif Is_RTE (U_Type, RE_Unbounded_String) then
10197 Lib_RE := RE_TC_String;
10199 -- Special DSA types
10201 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
10204 -- Other (non-primitive) types
10210 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10211 Append_To (Decls, Decl);
10215 if Lib_RE /= RE_Null then
10216 Fnam := RTE (Lib_RE);
10220 -- Call the function
10223 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10225 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10227 Set_Etype (Expr, RTE (RE_TypeCode));
10230 end Build_TypeCode_Call;
10232 -----------------------------
10233 -- Build_TypeCode_Function --
10234 -----------------------------
10236 procedure Build_TypeCode_Function
10239 Decl : out Node_Id;
10240 Fnam : out Entity_Id)
10243 Decls : constant List_Id := New_List;
10244 Stms : constant List_Id := New_List;
10246 TCNam : constant Entity_Id :=
10247 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
10249 Parameters : List_Id;
10251 procedure Add_String_Parameter
10253 Parameter_List : List_Id);
10254 -- Add a literal for S to Parameters
10256 procedure Add_TypeCode_Parameter
10257 (TC_Node : Node_Id;
10258 Parameter_List : List_Id);
10259 -- Add the typecode for Typ to Parameters
10261 procedure Add_Long_Parameter
10262 (Expr_Node : Node_Id;
10263 Parameter_List : List_Id);
10264 -- Add a signed long integer expression to Parameters
10266 procedure Initialize_Parameter_List
10267 (Name_String : String_Id;
10268 Repo_Id_String : String_Id;
10269 Parameter_List : out List_Id);
10270 -- Return a list that contains the first two parameters
10271 -- for a parameterized typecode: name and repository id.
10273 function Make_Constructed_TypeCode
10275 Parameters : List_Id) return Node_Id;
10276 -- Call TC_Build with the given kind and parameters
10278 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10279 -- Make a return statement that calls TC_Build with the given
10280 -- typecode kind, and the constructed parameters list.
10282 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10283 -- Return a typecode that is a TC_Alias for the given typecode
10285 --------------------------
10286 -- Add_String_Parameter --
10287 --------------------------
10289 procedure Add_String_Parameter
10291 Parameter_List : List_Id)
10294 Append_To (Parameter_List,
10295 Make_Function_Call (Loc,
10296 Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc),
10297 Parameter_Associations => New_List (
10298 Make_String_Literal (Loc, S))));
10299 end Add_String_Parameter;
10301 ----------------------------
10302 -- Add_TypeCode_Parameter --
10303 ----------------------------
10305 procedure Add_TypeCode_Parameter
10306 (TC_Node : Node_Id;
10307 Parameter_List : List_Id)
10310 Append_To (Parameter_List,
10311 Make_Function_Call (Loc,
10312 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10313 Parameter_Associations => New_List (TC_Node)));
10314 end Add_TypeCode_Parameter;
10316 ------------------------
10317 -- Add_Long_Parameter --
10318 ------------------------
10320 procedure Add_Long_Parameter
10321 (Expr_Node : Node_Id;
10322 Parameter_List : List_Id)
10325 Append_To (Parameter_List,
10326 Make_Function_Call (Loc,
10327 Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc),
10328 Parameter_Associations => New_List (Expr_Node)));
10329 end Add_Long_Parameter;
10331 -------------------------------
10332 -- Initialize_Parameter_List --
10333 -------------------------------
10335 procedure Initialize_Parameter_List
10336 (Name_String : String_Id;
10337 Repo_Id_String : String_Id;
10338 Parameter_List : out List_Id)
10341 Parameter_List := New_List;
10342 Add_String_Parameter (Name_String, Parameter_List);
10343 Add_String_Parameter (Repo_Id_String, Parameter_List);
10344 end Initialize_Parameter_List;
10346 ---------------------------
10347 -- Return_Alias_TypeCode --
10348 ---------------------------
10350 procedure Return_Alias_TypeCode
10351 (Base_TypeCode : Node_Id)
10354 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10355 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
10356 end Return_Alias_TypeCode;
10358 -------------------------------
10359 -- Make_Constructed_TypeCode --
10360 -------------------------------
10362 function Make_Constructed_TypeCode
10364 Parameters : List_Id) return Node_Id
10366 Constructed_TC : constant Node_Id :=
10367 Make_Function_Call (Loc,
10369 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
10370 Parameter_Associations => New_List (
10371 New_Occurrence_Of (Kind, Loc),
10372 Make_Aggregate (Loc,
10373 Expressions => Parameters)));
10375 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10376 return Constructed_TC;
10377 end Make_Constructed_TypeCode;
10379 ---------------------------------
10380 -- Return_Constructed_TypeCode --
10381 ---------------------------------
10383 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10386 Make_Simple_Return_Statement (Loc,
10388 Make_Constructed_TypeCode (Kind, Parameters)));
10389 end Return_Constructed_TypeCode;
10395 procedure TC_Rec_Add_Process_Element
10398 Counter : in out Int;
10402 procedure TC_Append_Record_Traversal is
10403 new Append_Record_Traversal (
10405 Add_Process_Element => TC_Rec_Add_Process_Element);
10407 --------------------------------
10408 -- TC_Rec_Add_Process_Element --
10409 --------------------------------
10411 procedure TC_Rec_Add_Process_Element
10414 Counter : in out Int;
10418 pragma Unreferenced (Any, Counter, Rec);
10421 if Nkind (Field) = N_Defining_Identifier then
10423 -- A regular component
10425 Add_TypeCode_Parameter
10426 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10427 Get_Name_String (Chars (Field));
10428 Add_String_Parameter (String_From_Name_Buffer, Params);
10435 Discriminant_Type : constant Entity_Id :=
10436 Etype (Name (Field));
10438 Is_Enum : constant Boolean :=
10439 Is_Enumeration_Type (Discriminant_Type);
10441 Union_TC_Params : List_Id;
10443 U_Name : constant Name_Id :=
10444 New_External_Name (Chars (Typ), 'V', -1);
10446 Name_Str : String_Id;
10447 Struct_TC_Params : List_Id;
10451 Default : constant Node_Id :=
10452 Make_Integer_Literal (Loc, -1);
10454 Dummy_Counter : Int := 0;
10456 Choice_Index : Int := 0;
10458 procedure Add_Params_For_Variant_Components;
10459 -- Add a struct TypeCode and a corresponding member name
10460 -- to the union parameter list.
10462 -- Ordering of declarations is a complete mess in this
10463 -- area, it is supposed to be types/variables, then
10464 -- subprogram specs, then subprogram bodies ???
10466 ---------------------------------------
10467 -- Add_Params_For_Variant_Components --
10468 ---------------------------------------
10470 procedure Add_Params_For_Variant_Components
10472 S_Name : constant Name_Id :=
10473 New_External_Name (U_Name, 'S', -1);
10476 Get_Name_String (S_Name);
10477 Name_Str := String_From_Name_Buffer;
10478 Initialize_Parameter_List
10479 (Name_Str, Name_Str, Struct_TC_Params);
10481 -- Build struct parameters
10483 TC_Append_Record_Traversal (Struct_TC_Params,
10484 Component_List (Variant),
10488 Add_TypeCode_Parameter
10489 (Make_Constructed_TypeCode
10490 (RTE (RE_TC_Struct), Struct_TC_Params),
10493 Add_String_Parameter (Name_Str, Union_TC_Params);
10494 end Add_Params_For_Variant_Components;
10497 Get_Name_String (U_Name);
10498 Name_Str := String_From_Name_Buffer;
10500 Initialize_Parameter_List
10501 (Name_Str, Name_Str, Union_TC_Params);
10503 -- Add union in enclosing parameter list
10505 Add_TypeCode_Parameter
10506 (Make_Constructed_TypeCode
10507 (RTE (RE_TC_Union), Union_TC_Params),
10510 Add_String_Parameter (Name_Str, Params);
10512 -- Build union parameters
10514 Add_TypeCode_Parameter
10515 (Build_TypeCode_Call
10516 (Loc, Discriminant_Type, Decls),
10519 Add_Long_Parameter (Default, Union_TC_Params);
10521 Variant := First_Non_Pragma (Variants (Field));
10522 while Present (Variant) loop
10523 Choice := First (Discrete_Choices (Variant));
10524 while Present (Choice) loop
10525 case Nkind (Choice) is
10528 L : constant Uint :=
10529 Expr_Value (Low_Bound (Choice));
10530 H : constant Uint :=
10531 Expr_Value (High_Bound (Choice));
10533 -- 3.8.1(8) guarantees that the bounds of
10534 -- this range are static.
10541 Expr := New_Occurrence_Of (
10542 Get_Enum_Lit_From_Pos (
10543 Discriminant_Type, J, Loc), Loc);
10546 Make_Integer_Literal (Loc, J);
10548 Append_To (Union_TC_Params,
10549 Build_To_Any_Call (Expr, Decls));
10551 Add_Params_For_Variant_Components;
10556 when N_Others_Choice =>
10558 -- This variant possess a default choice.
10559 -- We must therefore set the default
10560 -- parameter to the current choice index. The
10561 -- default parameter is by construction the
10562 -- fourth in the Union_TC_Params list.
10565 Default_Node : constant Node_Id :=
10566 Pick (Union_TC_Params, 4);
10568 New_Default_Node : constant Node_Id :=
10569 Make_Function_Call (Loc,
10572 (RTE (RE_TA_LI), Loc),
10573 Parameter_Associations =>
10575 Make_Integer_Literal
10576 (Loc, Choice_Index)));
10582 Remove (Default_Node);
10585 -- Add a placeholder member label
10586 -- for the default case.
10587 -- It must be of the discriminant type.
10590 Exp : constant Node_Id :=
10591 Make_Attribute_Reference (Loc,
10592 Prefix => New_Occurrence_Of
10593 (Discriminant_Type, Loc),
10594 Attribute_Name => Name_First);
10596 Set_Etype (Exp, Discriminant_Type);
10597 Append_To (Union_TC_Params,
10598 Build_To_Any_Call (Exp, Decls));
10601 Add_Params_For_Variant_Components;
10605 -- Case of an explicit choice
10608 Exp : constant Node_Id :=
10609 New_Copy_Tree (Choice);
10611 Append_To (Union_TC_Params,
10612 Build_To_Any_Call (Exp, Decls));
10615 Add_Params_For_Variant_Components;
10619 Choice_Index := Choice_Index + 1;
10622 Next_Non_Pragma (Variant);
10626 end TC_Rec_Add_Process_Element;
10628 Type_Name_Str : String_Id;
10629 Type_Repo_Id_Str : String_Id;
10631 -- Start of processing for Build_TypeCode_Function
10634 -- For a derived type, we can't go past the base type (to the
10635 -- parent type) here, because that would cause the attribute's
10636 -- formal parameter to have the wrong type; hence the Base_Type
10639 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
10640 Build_TypeCode_Function
10642 Typ => Etype (Typ),
10651 Make_Function_Specification (Loc,
10652 Defining_Unit_Name => Fnam,
10653 Parameter_Specifications => Empty_List,
10654 Result_Definition =>
10655 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10657 Build_Name_And_Repository_Id (Typ,
10658 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10660 Initialize_Parameter_List
10661 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10663 if Has_Stream_Attribute_Definition
10664 (Typ, TSS_Stream_Output, At_Any_Place => True)
10666 Has_Stream_Attribute_Definition
10667 (Typ, TSS_Stream_Write, At_Any_Place => True)
10669 -- If user-defined stream attributes are specified for this
10670 -- type, use them and transmit data as an opaque sequence of
10671 -- stream elements.
10673 Return_Alias_TypeCode
10674 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10676 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
10677 Return_Alias_TypeCode (
10678 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10680 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10681 Return_Alias_TypeCode (
10682 Build_TypeCode_Call (Loc,
10683 Find_Numeric_Representation (Typ), Decls));
10685 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
10687 -- Record typecodes are encoded as follows:
10691 -- | [Repository Id]
10693 -- Then for each discriminant:
10695 -- | [Discriminant Type Code]
10696 -- | [Discriminant Name]
10699 -- Then for each component:
10701 -- | [Component Type Code]
10702 -- | [Component Name]
10705 -- Variants components type codes are encoded as follows:
10709 -- | [Repository Id]
10710 -- | [Discriminant Type Code]
10711 -- | [Index of Default Variant Part or -1 for no default]
10713 -- Then for each Variant Part :
10718 -- | | [Variant Part Name]
10719 -- | | [Variant Part Repository Id]
10721 -- | Then for each VP component:
10722 -- | | [VP component Typecode]
10723 -- | | [VP component Name]
10729 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10730 Return_Alias_TypeCode
10731 (Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10735 Disc : Entity_Id := Empty;
10736 Rdef : constant Node_Id :=
10737 Type_Definition (Declaration_Node (Typ));
10738 Dummy_Counter : Int := 0;
10741 -- Construct the discriminants typecodes
10743 if Has_Discriminants (Typ) then
10744 Disc := First_Discriminant (Typ);
10747 while Present (Disc) loop
10748 Add_TypeCode_Parameter (
10749 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10751 Get_Name_String (Chars (Disc));
10752 Add_String_Parameter (
10753 String_From_Name_Buffer,
10755 Next_Discriminant (Disc);
10758 -- then the components typecodes
10760 TC_Append_Record_Traversal
10761 (Parameters, Component_List (Rdef),
10762 Empty, Dummy_Counter);
10763 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10767 elsif Is_Array_Type (Typ) then
10769 Ndim : constant Pos := Number_Dimensions (Typ);
10770 Inner_TypeCode : Node_Id;
10771 Constrained : constant Boolean := Is_Constrained (Typ);
10772 Indx : Node_Id := First_Index (Typ);
10776 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls);
10778 for J in 1 .. Ndim loop
10779 if Constrained then
10780 Inner_TypeCode := Make_Constructed_TypeCode
10781 (RTE (RE_TC_Array), New_List (
10782 Build_To_Any_Call (
10783 OK_Convert_To (RTE (RE_Long_Unsigned),
10784 Make_Attribute_Reference (Loc,
10785 Prefix => New_Occurrence_Of (Typ, Loc),
10786 Attribute_Name => Name_Length,
10787 Expressions => New_List (
10788 Make_Integer_Literal (Loc,
10789 Intval => Ndim - J + 1)))),
10791 Build_To_Any_Call (Inner_TypeCode, Decls)));
10794 -- Unconstrained case: add low bound for each
10797 Add_TypeCode_Parameter
10798 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10800 Get_Name_String (New_External_Name ('L', J));
10801 Add_String_Parameter (
10802 String_From_Name_Buffer,
10806 Inner_TypeCode := Make_Constructed_TypeCode
10807 (RTE (RE_TC_Sequence), New_List (
10808 Build_To_Any_Call (
10809 OK_Convert_To (RTE (RE_Long_Unsigned),
10810 Make_Integer_Literal (Loc, 0)),
10812 Build_To_Any_Call (Inner_TypeCode, Decls)));
10816 if Constrained then
10817 Return_Alias_TypeCode (Inner_TypeCode);
10819 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10821 Store_String_Char ('V');
10822 Add_String_Parameter (End_String, Parameters);
10823 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10828 -- Default: type is represented as an opaque sequence of bytes
10830 Return_Alias_TypeCode
10831 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10835 Make_Subprogram_Body (Loc,
10836 Specification => Spec,
10837 Declarations => Decls,
10838 Handled_Statement_Sequence =>
10839 Make_Handled_Sequence_Of_Statements (Loc,
10840 Statements => Stms));
10841 end Build_TypeCode_Function;
10843 ---------------------------------
10844 -- Find_Numeric_Representation --
10845 ---------------------------------
10847 function Find_Numeric_Representation
10848 (Typ : Entity_Id) return Entity_Id
10850 FST : constant Entity_Id := First_Subtype (Typ);
10851 P_Size : constant Uint := Esize (FST);
10854 if Is_Unsigned_Type (Typ) then
10855 if P_Size <= Standard_Short_Short_Integer_Size then
10856 return RTE (RE_Short_Short_Unsigned);
10858 elsif P_Size <= Standard_Short_Integer_Size then
10859 return RTE (RE_Short_Unsigned);
10861 elsif P_Size <= Standard_Integer_Size then
10862 return RTE (RE_Unsigned);
10864 elsif P_Size <= Standard_Long_Integer_Size then
10865 return RTE (RE_Long_Unsigned);
10868 return RTE (RE_Long_Long_Unsigned);
10871 elsif Is_Integer_Type (Typ) then
10872 if P_Size <= Standard_Short_Short_Integer_Size then
10873 return Standard_Short_Short_Integer;
10875 elsif P_Size <= Standard_Short_Integer_Size then
10876 return Standard_Short_Integer;
10878 elsif P_Size <= Standard_Integer_Size then
10879 return Standard_Integer;
10881 elsif P_Size <= Standard_Long_Integer_Size then
10882 return Standard_Long_Integer;
10885 return Standard_Long_Long_Integer;
10888 elsif Is_Floating_Point_Type (Typ) then
10889 if P_Size <= Standard_Short_Float_Size then
10890 return Standard_Short_Float;
10892 elsif P_Size <= Standard_Float_Size then
10893 return Standard_Float;
10895 elsif P_Size <= Standard_Long_Float_Size then
10896 return Standard_Long_Float;
10899 return Standard_Long_Long_Float;
10903 raise Program_Error;
10906 -- TBD: fixed point types???
10907 -- TBverified numeric types with a biased representation???
10909 end Find_Numeric_Representation;
10911 ---------------------------
10912 -- Append_Array_Traversal --
10913 ---------------------------
10915 procedure Append_Array_Traversal
10918 Counter : Entity_Id := Empty;
10921 Loc : constant Source_Ptr := Sloc (Subprogram);
10922 Typ : constant Entity_Id := Etype (Arry);
10923 Constrained : constant Boolean := Is_Constrained (Typ);
10924 Ndim : constant Pos := Number_Dimensions (Typ);
10926 Inner_Any, Inner_Counter : Entity_Id;
10928 Loop_Stm : Node_Id;
10929 Inner_Stmts : constant List_Id := New_List;
10932 if Depth > Ndim then
10934 -- Processing for one element of an array
10937 Element_Expr : constant Node_Id :=
10938 Make_Indexed_Component (Loc,
10939 New_Occurrence_Of (Arry, Loc),
10942 Set_Etype (Element_Expr, Component_Type (Typ));
10943 Add_Process_Element (Stmts,
10945 Counter => Counter,
10946 Datum => Element_Expr);
10952 Append_To (Indices,
10953 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10955 if not Constrained or else Depth > 1 then
10956 Inner_Any := Make_Defining_Identifier (Loc,
10957 New_External_Name ('A', Depth));
10958 Set_Etype (Inner_Any, RTE (RE_Any));
10960 Inner_Any := Empty;
10963 if Present (Counter) then
10964 Inner_Counter := Make_Defining_Identifier (Loc,
10965 New_External_Name ('J', Depth));
10967 Inner_Counter := Empty;
10971 Loop_Any : Node_Id := Inner_Any;
10974 -- For the first dimension of a constrained array, we add
10975 -- elements directly in the corresponding Any; there is no
10976 -- intervening inner Any.
10978 if No (Loop_Any) then
10982 Append_Array_Traversal (Inner_Stmts,
10984 Counter => Inner_Counter,
10985 Depth => Depth + 1);
10989 Make_Implicit_Loop_Statement (Subprogram,
10990 Iteration_Scheme =>
10991 Make_Iteration_Scheme (Loc,
10992 Loop_Parameter_Specification =>
10993 Make_Loop_Parameter_Specification (Loc,
10994 Defining_Identifier =>
10995 Make_Defining_Identifier (Loc,
10996 Chars => New_External_Name ('L', Depth)),
10998 Discrete_Subtype_Definition =>
10999 Make_Attribute_Reference (Loc,
11000 Prefix => New_Occurrence_Of (Arry, Loc),
11001 Attribute_Name => Name_Range,
11003 Expressions => New_List (
11004 Make_Integer_Literal (Loc, Depth))))),
11005 Statements => Inner_Stmts);
11008 Decls : constant List_Id := New_List;
11009 Dimen_Stmts : constant List_Id := New_List;
11010 Length_Node : Node_Id;
11012 Inner_Any_TypeCode : constant Entity_Id :=
11013 Make_Defining_Identifier (Loc,
11014 New_External_Name ('T', Depth));
11016 Inner_Any_TypeCode_Expr : Node_Id;
11020 if Constrained then
11021 Inner_Any_TypeCode_Expr :=
11022 Make_Function_Call (Loc,
11023 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
11024 Parameter_Associations => New_List (
11025 New_Occurrence_Of (Any, Loc)));
11028 Inner_Any_TypeCode_Expr :=
11029 Make_Function_Call (Loc,
11031 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
11032 Parameter_Associations => New_List (
11033 New_Occurrence_Of (Any, Loc),
11034 Make_Integer_Literal (Loc, Ndim)));
11038 Inner_Any_TypeCode_Expr :=
11039 Make_Function_Call (Loc,
11040 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc),
11041 Parameter_Associations => New_List (
11042 Make_Identifier (Loc,
11043 Chars => New_External_Name ('T', Depth - 1))));
11047 Make_Object_Declaration (Loc,
11048 Defining_Identifier => Inner_Any_TypeCode,
11049 Constant_Present => True,
11050 Object_Definition => New_Occurrence_Of (
11051 RTE (RE_TypeCode), Loc),
11052 Expression => Inner_Any_TypeCode_Expr));
11054 if Present (Inner_Any) then
11056 Make_Object_Declaration (Loc,
11057 Defining_Identifier => Inner_Any,
11058 Object_Definition =>
11059 New_Occurrence_Of (RTE (RE_Any), Loc),
11061 Make_Function_Call (Loc,
11063 New_Occurrence_Of (
11064 RTE (RE_Create_Any), Loc),
11065 Parameter_Associations => New_List (
11066 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
11069 if Present (Inner_Counter) then
11071 Make_Object_Declaration (Loc,
11072 Defining_Identifier => Inner_Counter,
11073 Object_Definition =>
11074 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
11076 Make_Integer_Literal (Loc, 0)));
11079 if not Constrained then
11080 Length_Node := Make_Attribute_Reference (Loc,
11081 Prefix => New_Occurrence_Of (Arry, Loc),
11082 Attribute_Name => Name_Length,
11084 New_List (Make_Integer_Literal (Loc, Depth)));
11085 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
11087 Add_Process_Element (Dimen_Stmts,
11088 Datum => Length_Node,
11090 Counter => Inner_Counter);
11093 -- Loop_Stm does appropriate processing for each element
11096 Append_To (Dimen_Stmts, Loop_Stm);
11098 -- Link outer and inner any
11100 if Present (Inner_Any) then
11101 Add_Process_Element (Dimen_Stmts,
11103 Counter => Counter,
11104 Datum => New_Occurrence_Of (Inner_Any, Loc));
11108 Make_Block_Statement (Loc,
11111 Handled_Statement_Sequence =>
11112 Make_Handled_Sequence_Of_Statements (Loc,
11113 Statements => Dimen_Stmts)));
11115 end Append_Array_Traversal;
11117 -------------------------------
11118 -- Make_Helper_Function_Name --
11119 -------------------------------
11121 function Make_Helper_Function_Name
11124 Nam : Name_Id) return Entity_Id
11129 -- For tagged types, we use a canonical name so that it matches
11130 -- the primitive spec. For all other cases, we use a serialized
11131 -- name so that multiple generations of the same procedure do
11135 if not Is_Tagged_Type (Typ) then
11136 Serial := Increment_Serial_Number;
11139 -- Use prefixed underscore to avoid potential clash with used
11140 -- identifier (we use attribute names for Nam).
11143 Make_Defining_Identifier (Loc,
11146 (Related_Id => Nam,
11147 Suffix => ' ', Suffix_Index => Serial,
11150 end Make_Helper_Function_Name;
11153 -----------------------------------
11154 -- Reserve_NamingContext_Methods --
11155 -----------------------------------
11157 procedure Reserve_NamingContext_Methods is
11158 Str_Resolve : constant String := "resolve";
11160 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11161 Name_Len := Str_Resolve'Length;
11162 Overload_Counter_Table.Set (Name_Find, 1);
11163 end Reserve_NamingContext_Methods;
11165 end PolyORB_Support;
11167 -------------------------------
11168 -- RACW_Type_Is_Asynchronous --
11169 -------------------------------
11171 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11172 Asynchronous_Flag : constant Entity_Id :=
11173 Asynchronous_Flags_Table.Get (RACW_Type);
11175 Replace (Expression (Parent (Asynchronous_Flag)),
11176 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11177 end RACW_Type_Is_Asynchronous;
11179 -------------------------
11180 -- RCI_Package_Locator --
11181 -------------------------
11183 function RCI_Package_Locator
11185 Package_Spec : Node_Id) return Node_Id
11188 Pkg_Name : String_Id;
11191 Get_Library_Unit_Name_String (Package_Spec);
11192 Pkg_Name := String_From_Name_Buffer;
11194 Make_Package_Instantiation (Loc,
11195 Defining_Unit_Name =>
11196 Make_Defining_Identifier (Loc,
11197 Chars => New_Internal_Name ('R')),
11200 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11202 Generic_Associations => New_List (
11203 Make_Generic_Association (Loc,
11205 Make_Identifier (Loc, Name_RCI_Name),
11206 Explicit_Generic_Actual_Parameter =>
11207 Make_String_Literal (Loc,
11208 Strval => Pkg_Name)),
11210 Make_Generic_Association (Loc,
11212 Make_Identifier (Loc, Name_Version),
11213 Explicit_Generic_Actual_Parameter =>
11214 Make_Attribute_Reference (Loc,
11216 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11220 RCI_Locator_Table.Set
11221 (Defining_Unit_Name (Package_Spec),
11222 Defining_Unit_Name (Inst));
11224 end RCI_Package_Locator;
11226 -----------------------------------------------
11227 -- Remote_Types_Tagged_Full_View_Encountered --
11228 -----------------------------------------------
11230 procedure Remote_Types_Tagged_Full_View_Encountered
11231 (Full_View : Entity_Id)
11233 Stub_Elements : constant Stub_Structure :=
11234 Stubs_Table.Get (Full_View);
11237 -- For an RACW encountered before the freeze point of its designated
11238 -- type, the stub type is generated at the point of the RACW declaration
11239 -- but the primitives are generated only once the designated type is
11240 -- frozen. That freeze can occur in another scope, for example when the
11241 -- RACW is declared in a nested package. In that case we need to
11242 -- reestablish the stub type's scope prior to generating its primitive
11245 if Stub_Elements /= Empty_Stub_Structure then
11247 Saved_Scope : constant Entity_Id := Current_Scope;
11248 Stubs_Scope : constant Entity_Id :=
11249 Scope (Stub_Elements.Stub_Type);
11252 if Current_Scope /= Stubs_Scope then
11253 Push_Scope (Stubs_Scope);
11256 Add_RACW_Primitive_Declarations_And_Bodies
11258 Stub_Elements.RPC_Receiver_Decl,
11259 Stub_Elements.Body_Decls);
11261 if Current_Scope /= Saved_Scope then
11266 end Remote_Types_Tagged_Full_View_Encountered;
11268 -------------------
11269 -- Scope_Of_Spec --
11270 -------------------
11272 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11273 Unit_Name : Node_Id;
11276 Unit_Name := Defining_Unit_Name (Spec);
11277 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11278 Unit_Name := Defining_Identifier (Unit_Name);
11284 ----------------------
11285 -- Set_Renaming_TSS --
11286 ----------------------
11288 procedure Set_Renaming_TSS
11291 TSS_Nam : TSS_Name_Type)
11293 Loc : constant Source_Ptr := Sloc (Nam);
11294 Spec : constant Node_Id := Parent (Nam);
11296 TSS_Node : constant Node_Id :=
11297 Make_Subprogram_Renaming_Declaration (Loc,
11299 Copy_Specification (Loc,
11301 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11302 Name => New_Occurrence_Of (Nam, Loc));
11304 Snam : constant Entity_Id :=
11305 Defining_Unit_Name (Specification (TSS_Node));
11308 if Nkind (Spec) = N_Function_Specification then
11309 Set_Ekind (Snam, E_Function);
11310 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11312 Set_Ekind (Snam, E_Procedure);
11313 Set_Etype (Snam, Standard_Void_Type);
11316 Set_TSS (Typ, Snam);
11317 end Set_Renaming_TSS;
11319 ----------------------------------------------
11320 -- Specific_Add_Obj_RPC_Receiver_Completion --
11321 ----------------------------------------------
11323 procedure Specific_Add_Obj_RPC_Receiver_Completion
11326 RPC_Receiver : Entity_Id;
11327 Stub_Elements : Stub_Structure)
11330 case Get_PCS_Name is
11331 when Name_PolyORB_DSA =>
11332 PolyORB_Support.Add_Obj_RPC_Receiver_Completion
11333 (Loc, Decls, RPC_Receiver, Stub_Elements);
11335 GARLIC_Support.Add_Obj_RPC_Receiver_Completion
11336 (Loc, Decls, RPC_Receiver, Stub_Elements);
11338 end Specific_Add_Obj_RPC_Receiver_Completion;
11340 --------------------------------
11341 -- Specific_Add_RACW_Features --
11342 --------------------------------
11344 procedure Specific_Add_RACW_Features
11345 (RACW_Type : Entity_Id;
11347 Stub_Type : Entity_Id;
11348 Stub_Type_Access : Entity_Id;
11349 RPC_Receiver_Decl : Node_Id;
11350 Body_Decls : List_Id)
11353 case Get_PCS_Name is
11354 when Name_PolyORB_DSA =>
11355 PolyORB_Support.Add_RACW_Features
11364 GARLIC_Support.Add_RACW_Features
11371 end Specific_Add_RACW_Features;
11373 --------------------------------
11374 -- Specific_Add_RAST_Features --
11375 --------------------------------
11377 procedure Specific_Add_RAST_Features
11378 (Vis_Decl : Node_Id;
11379 RAS_Type : Entity_Id)
11382 case Get_PCS_Name is
11383 when Name_PolyORB_DSA =>
11384 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11386 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11388 end Specific_Add_RAST_Features;
11390 --------------------------------------------------
11391 -- Specific_Add_Receiving_Stubs_To_Declarations --
11392 --------------------------------------------------
11394 procedure Specific_Add_Receiving_Stubs_To_Declarations
11395 (Pkg_Spec : Node_Id;
11400 case Get_PCS_Name is
11401 when Name_PolyORB_DSA =>
11402 PolyORB_Support.Add_Receiving_Stubs_To_Declarations
11403 (Pkg_Spec, Decls, Stmts);
11405 GARLIC_Support.Add_Receiving_Stubs_To_Declarations
11406 (Pkg_Spec, Decls, Stmts);
11408 end Specific_Add_Receiving_Stubs_To_Declarations;
11410 ------------------------------------------
11411 -- Specific_Build_General_Calling_Stubs --
11412 ------------------------------------------
11414 procedure Specific_Build_General_Calling_Stubs
11416 Statements : List_Id;
11417 Target : RPC_Target;
11418 Subprogram_Id : Node_Id;
11419 Asynchronous : Node_Id := Empty;
11420 Is_Known_Asynchronous : Boolean := False;
11421 Is_Known_Non_Asynchronous : Boolean := False;
11422 Is_Function : Boolean;
11424 Stub_Type : Entity_Id := Empty;
11425 RACW_Type : Entity_Id := Empty;
11429 case Get_PCS_Name is
11430 when Name_PolyORB_DSA =>
11431 PolyORB_Support.Build_General_Calling_Stubs
11437 Is_Known_Asynchronous,
11438 Is_Known_Non_Asynchronous,
11446 GARLIC_Support.Build_General_Calling_Stubs
11450 Target.RPC_Receiver,
11453 Is_Known_Asynchronous,
11454 Is_Known_Non_Asynchronous,
11461 end Specific_Build_General_Calling_Stubs;
11463 --------------------------------------
11464 -- Specific_Build_RPC_Receiver_Body --
11465 --------------------------------------
11467 procedure Specific_Build_RPC_Receiver_Body
11468 (RPC_Receiver : Entity_Id;
11469 Request : out Entity_Id;
11470 Subp_Id : out Entity_Id;
11471 Subp_Index : out Entity_Id;
11472 Stmts : out List_Id;
11473 Decl : out Node_Id)
11476 case Get_PCS_Name is
11477 when Name_PolyORB_DSA =>
11478 PolyORB_Support.Build_RPC_Receiver_Body
11487 GARLIC_Support.Build_RPC_Receiver_Body
11495 end Specific_Build_RPC_Receiver_Body;
11497 --------------------------------
11498 -- Specific_Build_Stub_Target --
11499 --------------------------------
11501 function Specific_Build_Stub_Target
11504 RCI_Locator : Entity_Id;
11505 Controlling_Parameter : Entity_Id) return RPC_Target
11508 case Get_PCS_Name is
11509 when Name_PolyORB_DSA =>
11511 PolyORB_Support.Build_Stub_Target
11512 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11516 GARLIC_Support.Build_Stub_Target
11517 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11519 end Specific_Build_Stub_Target;
11521 ------------------------------
11522 -- Specific_Build_Stub_Type --
11523 ------------------------------
11525 procedure Specific_Build_Stub_Type
11526 (RACW_Type : Entity_Id;
11527 Stub_Type_Comps : out List_Id;
11528 RPC_Receiver_Decl : out Node_Id)
11531 case Get_PCS_Name is
11532 when Name_PolyORB_DSA =>
11533 PolyORB_Support.Build_Stub_Type
11534 (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
11537 GARLIC_Support.Build_Stub_Type
11538 (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
11540 end Specific_Build_Stub_Type;
11542 -----------------------------------------------
11543 -- Specific_Build_Subprogram_Receiving_Stubs --
11544 -----------------------------------------------
11546 function Specific_Build_Subprogram_Receiving_Stubs
11547 (Vis_Decl : Node_Id;
11548 Asynchronous : Boolean;
11549 Dynamically_Asynchronous : Boolean := False;
11550 Stub_Type : Entity_Id := Empty;
11551 RACW_Type : Entity_Id := Empty;
11552 Parent_Primitive : Entity_Id := Empty) return Node_Id
11555 case Get_PCS_Name is
11556 when Name_PolyORB_DSA =>
11558 PolyORB_Support.Build_Subprogram_Receiving_Stubs
11561 Dynamically_Asynchronous,
11568 GARLIC_Support.Build_Subprogram_Receiving_Stubs
11571 Dynamically_Asynchronous,
11576 end Specific_Build_Subprogram_Receiving_Stubs;
11578 -------------------------------
11579 -- Transmit_As_Unconstrained --
11580 -------------------------------
11582 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
11585 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
11586 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
11587 end Transmit_As_Unconstrained;
11589 --------------------------
11590 -- Underlying_RACW_Type --
11591 --------------------------
11593 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11594 Record_Type : Entity_Id;
11597 if Ekind (RAS_Typ) = E_Record_Type then
11598 Record_Type := RAS_Typ;
11600 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11601 Record_Type := Equivalent_Type (RAS_Typ);
11605 Etype (Subtype_Indication
11606 (Component_Definition
11607 (First (Component_Items
11610 (Declaration_Node (Record_Type))))))));
11611 end Underlying_RACW_Type;