1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, 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_Strm; use Exp_Strm;
31 with Exp_Tss; use Exp_Tss;
32 with Exp_Util; use Exp_Util;
34 with Nlists; use Nlists;
35 with Nmake; use Nmake;
37 with Rtsfind; use Rtsfind;
39 with Sem_Aux; use Sem_Aux;
40 with Sem_Cat; use Sem_Cat;
41 with Sem_Ch3; use Sem_Ch3;
42 with Sem_Ch8; use Sem_Ch8;
43 with Sem_Ch12; use Sem_Ch12;
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 (Pkg_Spec : Node_Id);
229 -- Add calling stubs to the declarative part
231 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
232 -- Return True if nothing prevents the program whose specification is
233 -- given to be asynchronous (i.e. no [IN] OUT parameters).
235 function Pack_Entity_Into_Stream_Access
239 Etyp : Entity_Id := Empty) return Node_Id;
240 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
241 -- then Etype (Object) will be used if present. If the type is
242 -- constrained, then 'Write will be used to output the object,
243 -- If the type is unconstrained, 'Output will be used.
245 function Pack_Node_Into_Stream
249 Etyp : Entity_Id) return Node_Id;
250 -- Similar to above, with an arbitrary node instead of an entity
252 function Pack_Node_Into_Stream_Access
256 Etyp : Entity_Id) return Node_Id;
257 -- Similar to above, with Stream instead of Stream'Access
259 function Make_Selected_Component
262 Selector_Name : Name_Id) return Node_Id;
263 -- Return a selected_component whose prefix denotes the given entity, and
264 -- with the given Selector_Name.
266 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
267 -- Return the scope represented by a given spec
269 procedure Set_Renaming_TSS
272 TSS_Nam : TSS_Name_Type);
273 -- Create a renaming declaration of subprogram Nam, and register it as a
274 -- TSS for Typ with name TSS_Nam.
276 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
277 -- Return True if the current parameter needs an extra formal to reflect
278 -- its constrained status.
280 function Is_RACW_Controlling_Formal
281 (Parameter : Node_Id;
282 Stub_Type : Entity_Id) return Boolean;
283 -- Return True if the current parameter is a controlling formal argument
284 -- of type Stub_Type or access to Stub_Type.
286 procedure Declare_Create_NVList
291 -- Append the declaration of NVList to Decls, and its
292 -- initialization to Stmts.
294 function Add_Parameter_To_NVList
297 Parameter : Entity_Id;
298 Constrained : Boolean;
299 RACW_Ctrl : Boolean := False;
300 Any : Entity_Id) return Node_Id;
301 -- Return a call to Add_Item to add the Any corresponding to the designated
302 -- formal Parameter (with the indicated Constrained status) to NVList.
303 -- RACW_Ctrl must be set to True for controlling formals of distributed
304 -- object primitive operations.
310 -- This record describes various tree fragments associated with the
311 -- generation of RACW calling stubs. One such record exists for every
312 -- distributed object type, i.e. each tagged type that is the designated
313 -- type of one or more RACW type.
315 type Stub_Structure is record
316 Stub_Type : Entity_Id;
317 -- Stub type: this type has the same primitive operations as the
318 -- designated types, but the provided bodies for these operations
319 -- a remote call to an actual target object potentially located on
320 -- another partition; each value of the stub type encapsulates a
321 -- reference to a remote object.
323 Stub_Type_Access : Entity_Id;
324 -- A local access type designating the stub type (this is not an RACW
327 RPC_Receiver_Decl : Node_Id;
328 -- Declaration for the RPC receiver entity associated with the
329 -- designated type. As an exception, in the case of GARLIC, for an RACW
330 -- that implements a RAS, no object RPC receiver is generated. Instead,
331 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
332 -- would have been inserted.
334 Body_Decls : List_Id;
335 -- List of subprogram bodies to be included in generated code: bodies
336 -- for the RACW's stream attributes, and for the primitive operations
339 RACW_Type : Entity_Id;
340 -- One of the RACW types designating this distributed object type
341 -- (they are all interchangeable; we use any one of them in order to
342 -- avoid having to create various anonymous access types).
346 Empty_Stub_Structure : constant Stub_Structure :=
347 (Empty, Empty, Empty, No_List, Empty);
349 package Stubs_Table is
350 new Simple_HTable (Header_Num => Hash_Index,
351 Element => Stub_Structure,
352 No_Element => Empty_Stub_Structure,
356 -- Mapping between a RACW designated type and its stub type
358 package Asynchronous_Flags_Table is
359 new Simple_HTable (Header_Num => Hash_Index,
360 Element => Entity_Id,
365 -- Mapping between a RACW type and a constant having the value True
366 -- if the RACW is asynchronous and False otherwise.
368 package RCI_Locator_Table is
369 new Simple_HTable (Header_Num => Hash_Index,
370 Element => Entity_Id,
375 -- Mapping between a RCI package on which All_Calls_Remote applies and
376 -- the generic instantiation of RCI_Locator for this package.
378 package RCI_Calling_Stubs_Table is
379 new Simple_HTable (Header_Num => Hash_Index,
380 Element => Entity_Id,
385 -- Mapping between a RCI subprogram and the corresponding calling stubs
387 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure;
388 -- Return the stub information associated with the given RACW type
390 procedure Add_Stub_Type
391 (Designated_Type : Entity_Id;
392 RACW_Type : Entity_Id;
394 Stub_Type : out Entity_Id;
395 Stub_Type_Access : out Entity_Id;
396 RPC_Receiver_Decl : out Node_Id;
397 Body_Decls : out List_Id;
398 Existing : out Boolean);
399 -- Add the declaration of the stub type, the access to stub type and the
400 -- object RPC receiver at the end of Decls. If these already exist,
401 -- then nothing is added in the tree but the right values are returned
402 -- anyhow and Existing is set to True.
404 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
405 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
406 -- structure table, reset it to No_List, and return the previous value.
408 procedure Add_RACW_Asynchronous_Flag
409 (Declarations : List_Id;
410 RACW_Type : Entity_Id);
411 -- Declare a boolean constant associated with RACW_Type whose value
412 -- indicates at run time whether a pragma Asynchronous applies to it.
414 procedure Assign_Subprogram_Identifier
418 -- Determine the distribution subprogram identifier to
419 -- be used for remote subprogram Def, return it in Id and
420 -- store it in a hash table for later retrieval by
421 -- Get_Subprogram_Id. Spn is the subprogram number.
423 function RCI_Package_Locator
425 Package_Spec : Node_Id) return Node_Id;
426 -- Instantiate the generic package RCI_Locator in order to locate the
427 -- RCI package whose spec is given as argument.
429 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
430 -- Surround a node N by a tag check, as in:
434 -- when E : Ada.Tags.Tag_Error =>
435 -- Raise_Exception (Program_Error'Identity,
436 -- Exception_Message (E));
439 function Input_With_Tag_Check
441 Var_Type : Entity_Id;
442 Stream : Node_Id) return Node_Id;
443 -- Return a function with the following form:
444 -- function R return Var_Type is
446 -- return Var_Type'Input (S);
448 -- when E : Ada.Tags.Tag_Error =>
449 -- Raise_Exception (Program_Error'Identity,
450 -- Exception_Message (E));
453 procedure Build_Actual_Object_Declaration
459 -- Build the declaration of an object with the given defining identifier,
460 -- initialized with Expr if provided, to serve as actual parameter in a
461 -- server stub. If Variable is true, the declared object will be a variable
462 -- (case of an out or in out formal), else it will be a constant. Object's
463 -- Ekind is set accordingly. The declaration, as well as any other
464 -- declarations it requires, are appended to Decls.
466 --------------------------------------------
467 -- Hooks for PCS-specific code generation --
468 --------------------------------------------
470 -- Part of the code generation circuitry for distribution needs to be
471 -- tailored for each implementation of the PCS. For each routine that
472 -- needs to be specialized, a Specific_<routine> wrapper is created,
473 -- which calls the corresponding <routine> in package
474 -- <pcs_implementation>_Support.
476 procedure Specific_Add_RACW_Features
477 (RACW_Type : Entity_Id;
479 Stub_Type : Entity_Id;
480 Stub_Type_Access : Entity_Id;
481 RPC_Receiver_Decl : Node_Id;
482 Body_Decls : List_Id);
483 -- Add declaration for TSSs for a given RACW type. The declarations are
484 -- added just after the declaration of the RACW type itself. If the RACW
485 -- appears in the main unit, Body_Decls is a list of declarations to which
486 -- the bodies are appended. Else Body_Decls is No_List.
487 -- PCS-specific ancillary subprogram for Add_RACW_Features.
489 procedure Specific_Add_RAST_Features
491 RAS_Type : Entity_Id);
492 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
493 -- subprogram for Add_RAST_Features.
495 -- An RPC_Target record is used during construction of calling stubs
496 -- to pass PCS-specific tree fragments corresponding to the information
497 -- necessary to locate the target of a remote subprogram call.
499 type RPC_Target (PCS_Kind : PCS_Names) is record
501 when Name_PolyORB_DSA =>
503 -- An expression whose value is a PolyORB reference to the target
507 Partition : Entity_Id;
508 -- A variable containing the Partition_ID of the target partition
510 RPC_Receiver : Node_Id;
511 -- An expression whose value is the address of the target RPC
516 procedure Specific_Build_General_Calling_Stubs
518 Statements : List_Id;
520 Subprogram_Id : Node_Id;
521 Asynchronous : Node_Id := Empty;
522 Is_Known_Asynchronous : Boolean := False;
523 Is_Known_Non_Asynchronous : Boolean := False;
524 Is_Function : Boolean;
526 Stub_Type : Entity_Id := Empty;
527 RACW_Type : Entity_Id := Empty;
529 -- Build calling stubs for general purpose. The parameters are:
530 -- Decls : A place to put declarations
531 -- Statements : A place to put statements
532 -- Target : PCS-specific target information (see details in
533 -- RPC_Target declaration).
534 -- Subprogram_Id : A node containing the subprogram ID
535 -- Asynchronous : True if an APC must be made instead of an RPC.
536 -- The value needs not be supplied if one of the
537 -- Is_Known_... is True.
538 -- Is_Known_Async... : True if we know that this is asynchronous
539 -- Is_Known_Non_A... : True if we know that this is not asynchronous
540 -- Spec : Node with a Parameter_Specifications and a
541 -- Result_Definition if applicable
542 -- Stub_Type : For case of RACW stubs, parameters of type access
543 -- to Stub_Type will be marshalled using the address
544 -- address of the object (the addr field) rather
545 -- than using the 'Write on the stub itself
546 -- Nod : Used to provide sloc for generated code
548 function Specific_Build_Stub_Target
551 RCI_Locator : Entity_Id;
552 Controlling_Parameter : Entity_Id) return RPC_Target;
553 -- Build call target information nodes for use within calling stubs. In the
554 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
555 -- for an RACW, Controlling_Parameter is the entity for the controlling
556 -- formal parameter used to determine the location of the target of the
557 -- call. Decls provides a location where variable declarations can be
558 -- appended to construct the necessary values.
560 function Specific_RPC_Receiver_Decl
561 (RACW_Type : Entity_Id) return Node_Id;
562 -- Build the RPC receiver, for RACW, if applicable, else return Empty
564 procedure Specific_Build_RPC_Receiver_Body
565 (RPC_Receiver : Entity_Id;
566 Request : out Entity_Id;
567 Subp_Id : out Entity_Id;
568 Subp_Index : out Entity_Id;
571 -- Make a subprogram body for an RPC receiver, with the given
572 -- defining unit name. On return:
573 -- - Subp_Id is the subprogram identifier from the PCS.
574 -- - Subp_Index is the index in the list of subprograms
575 -- used for dispatching (a variable of type Subprogram_Id).
576 -- - Stmts is the place where the request dispatching
577 -- statements can occur,
578 -- - Decl is the subprogram body declaration.
580 function Specific_Build_Subprogram_Receiving_Stubs
582 Asynchronous : Boolean;
583 Dynamically_Asynchronous : Boolean := False;
584 Stub_Type : Entity_Id := Empty;
585 RACW_Type : Entity_Id := Empty;
586 Parent_Primitive : Entity_Id := Empty) return Node_Id;
587 -- Build the receiving stub for a given subprogram. The subprogram
588 -- declaration is also built by this procedure, and the value returned
589 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
590 -- found in the specification, then its address is read from the stream
591 -- instead of the object itself and converted into an access to
592 -- class-wide type before doing the real call using any of the RACW type
593 -- pointing on the designated type.
595 procedure Specific_Add_Obj_RPC_Receiver_Completion
598 RPC_Receiver : Entity_Id;
599 Stub_Elements : Stub_Structure);
600 -- Add the necessary code to Decls after the completion of generation
601 -- of the RACW RPC receiver described by Stub_Elements.
603 procedure Specific_Add_Receiving_Stubs_To_Declarations
607 -- Add receiving stubs to the declarative part of an RCI unit
613 package GARLIC_Support is
615 -- Support for generating DSA code that uses the GARLIC PCS
617 -- The subprograms below provide the GARLIC versions of the
618 -- corresponding Specific_<subprogram> routine declared above.
620 procedure Add_RACW_Features
621 (RACW_Type : Entity_Id;
622 Stub_Type : Entity_Id;
623 Stub_Type_Access : Entity_Id;
624 RPC_Receiver_Decl : Node_Id;
625 Body_Decls : List_Id);
627 procedure Add_RAST_Features
629 RAS_Type : Entity_Id);
631 procedure Build_General_Calling_Stubs
633 Statements : List_Id;
634 Target_Partition : Entity_Id; -- From RPC_Target
635 Target_RPC_Receiver : Node_Id; -- From RPC_Target
636 Subprogram_Id : Node_Id;
637 Asynchronous : Node_Id := Empty;
638 Is_Known_Asynchronous : Boolean := False;
639 Is_Known_Non_Asynchronous : Boolean := False;
640 Is_Function : Boolean;
642 Stub_Type : Entity_Id := Empty;
643 RACW_Type : Entity_Id := Empty;
646 function Build_Stub_Target
649 RCI_Locator : Entity_Id;
650 Controlling_Parameter : Entity_Id) return RPC_Target;
652 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id;
654 function Build_Subprogram_Receiving_Stubs
656 Asynchronous : Boolean;
657 Dynamically_Asynchronous : Boolean := False;
658 Stub_Type : Entity_Id := Empty;
659 RACW_Type : Entity_Id := Empty;
660 Parent_Primitive : Entity_Id := Empty) return Node_Id;
662 procedure Add_Obj_RPC_Receiver_Completion
665 RPC_Receiver : Entity_Id;
666 Stub_Elements : Stub_Structure);
668 procedure Add_Receiving_Stubs_To_Declarations
673 procedure Build_RPC_Receiver_Body
674 (RPC_Receiver : Entity_Id;
675 Request : out Entity_Id;
676 Subp_Id : out Entity_Id;
677 Subp_Index : out Entity_Id;
683 ---------------------
684 -- PolyORB_Support --
685 ---------------------
687 package PolyORB_Support is
689 -- Support for generating DSA code that uses the PolyORB PCS
691 -- The subprograms below provide the PolyORB versions of the
692 -- corresponding Specific_<subprogram> routine declared above.
694 procedure Add_RACW_Features
695 (RACW_Type : Entity_Id;
697 Stub_Type : Entity_Id;
698 Stub_Type_Access : Entity_Id;
699 RPC_Receiver_Decl : Node_Id;
700 Body_Decls : List_Id);
702 procedure Add_RAST_Features
704 RAS_Type : Entity_Id);
706 procedure Build_General_Calling_Stubs
708 Statements : List_Id;
709 Target_Object : Node_Id; -- From RPC_Target
710 Subprogram_Id : Node_Id;
711 Asynchronous : Node_Id := Empty;
712 Is_Known_Asynchronous : Boolean := False;
713 Is_Known_Non_Asynchronous : Boolean := False;
714 Is_Function : Boolean;
716 Stub_Type : Entity_Id := Empty;
717 RACW_Type : Entity_Id := Empty;
720 function Build_Stub_Target
723 RCI_Locator : Entity_Id;
724 Controlling_Parameter : Entity_Id) return RPC_Target;
726 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id;
728 function Build_Subprogram_Receiving_Stubs
730 Asynchronous : Boolean;
731 Dynamically_Asynchronous : Boolean := False;
732 Stub_Type : Entity_Id := Empty;
733 RACW_Type : Entity_Id := Empty;
734 Parent_Primitive : Entity_Id := Empty) return Node_Id;
736 procedure Add_Obj_RPC_Receiver_Completion
739 RPC_Receiver : Entity_Id;
740 Stub_Elements : Stub_Structure);
742 procedure Add_Receiving_Stubs_To_Declarations
747 procedure Build_RPC_Receiver_Body
748 (RPC_Receiver : Entity_Id;
749 Request : out Entity_Id;
750 Subp_Id : out Entity_Id;
751 Subp_Index : out Entity_Id;
755 procedure Reserve_NamingContext_Methods;
756 -- Mark the method names for interface NamingContext as already used in
757 -- the overload table, so no clashes occur with user code (with the
758 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
759 -- their methods to be accessed as objects, for the implementation of
760 -- remote access-to-subprogram types).
768 -- Routines to build distribution helper subprograms for user-defined
769 -- types. For implementation of the Distributed systems annex (DSA)
770 -- over the PolyORB generic middleware components, it is necessary to
771 -- generate several supporting subprograms for each application data
772 -- type used in inter-partition communication. These subprograms are:
774 -- A Typecode function returning a high-level description of the
777 -- Two conversion functions allowing conversion of values of the
778 -- type from and to the generic data containers used by PolyORB.
779 -- These generic containers are called 'Any' type values after the
780 -- CORBA terminology, and hence the conversion subprograms are
781 -- named To_Any and From_Any.
783 function Build_From_Any_Call
786 Decls : List_Id) return Node_Id;
787 -- Build call to From_Any attribute function of type Typ with
788 -- expression N as actual parameter. Decls is the declarations list
789 -- for an appropriate enclosing scope of the point where the call
790 -- will be inserted; if the From_Any attribute for Typ needs to be
791 -- generated at this point, its declaration is appended to Decls.
793 procedure Build_From_Any_Function
797 Fnam : out Entity_Id);
798 -- Build From_Any attribute function for Typ. Loc is the reference
799 -- location for generated nodes, Typ is the type for which the
800 -- conversion function is generated. On return, Decl and Fnam contain
801 -- the declaration and entity for the newly-created function.
803 function Build_To_Any_Call
807 Constrained : Boolean := False) return Node_Id;
808 -- Build call to To_Any attribute function with expression as actual
809 -- parameter. Loc is the reference location of generated nodes,
810 -- Decls is the declarations list for an appropriate enclosing scope
811 -- of the point where the call will be inserted; if the To_Any
812 -- attribute for the type of N needs to be generated at this point,
813 -- its declaration is appended to Decls. For the case of a limited
814 -- type, there is an additional parameter Constrained indicating
815 -- whether 'Write (when True) or 'Output (when False) is used.
817 procedure Build_To_Any_Function
821 Fnam : out Entity_Id);
822 -- Build To_Any attribute function for Typ. Loc is the reference
823 -- location for generated nodes, Typ is the type for which the
824 -- conversion function is generated. On return, Decl and Fnam contain
825 -- the declaration and entity for the newly-created function.
827 function Build_TypeCode_Call
830 Decls : List_Id) return Node_Id;
831 -- Build call to TypeCode attribute function for Typ. Decls is the
832 -- declarations list for an appropriate enclosing scope of the point
833 -- where the call will be inserted; if the To_Any attribute for Typ
834 -- needs to be generated at this point, its declaration is appended
837 procedure Build_TypeCode_Function
841 Fnam : out Entity_Id);
842 -- Build TypeCode attribute function for Typ. Loc is the reference
843 -- location for generated nodes, Typ is the type for which the
844 -- typecode function is generated. On return, Decl and Fnam contain
845 -- the declaration and entity for the newly-created function.
847 procedure Build_Name_And_Repository_Id
849 Name_Str : out String_Id;
850 Repo_Id_Str : out String_Id);
851 -- In the PolyORB distribution model, each distributed object type
852 -- and each distributed operation has a globally unique identifier,
853 -- its Repository Id. This subprogram builds and returns two strings
854 -- for entity E (a distributed object type or operation): one
855 -- containing the name of E, the second containing its repository id.
857 procedure Assign_Opaque_From_Any
863 Constrained : Boolean := False);
864 -- For a Target object of type Typ, which has opaque representation
865 -- as a sequence of octets determined by stream attributes (which
866 -- includes all limited types), append code to Stmts performing the
868 -- Target := Typ'From_Any (N)
870 -- or, if Target is Empty:
871 -- return Typ'From_Any (N)
873 -- Constrained determines whether 'Input (when False) or 'Read
874 -- (when True) is used.
880 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
882 function Build_From_Any_Call
885 Decls : List_Id) return Node_Id
886 renames PolyORB_Support.Helpers.Build_From_Any_Call;
888 function Build_To_Any_Call
892 Constrained : Boolean := False) return Node_Id
893 renames PolyORB_Support.Helpers.Build_To_Any_Call;
895 function Build_TypeCode_Call
898 Decls : List_Id) return Node_Id
899 renames PolyORB_Support.Helpers.Build_TypeCode_Call;
901 ------------------------------------
902 -- Local variables and structures --
903 ------------------------------------
905 RCI_Cache : Node_Id := Empty;
906 -- Needs comments ???
908 Output_From_Constrained : constant array (Boolean) of Name_Id :=
909 (False => Name_Output,
911 -- The attribute to choose depending on the fact that the parameter
912 -- is constrained or not. There is no such thing as Input_From_Constrained
913 -- since this require separate mechanisms ('Input is a function while
914 -- 'Read is a procedure).
917 with procedure Process_Subprogram_Declaration (Decl : Node_Id);
918 -- Generate calling or receiving stub for this subprogram declaration
920 procedure Build_Package_Stubs (Pkg_Spec : Node_Id);
921 -- Recursively visit the given RCI Package_Specification, calling
922 -- Process_Subprogram_Declaration for each remote subprogram.
924 -------------------------
925 -- Build_Package_Stubs --
926 -------------------------
928 procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is
929 Decls : constant List_Id := Visible_Declarations (Pkg_Spec);
932 procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id);
933 -- Recurse for the given nested package declaration
935 ----------------------
936 -- Visit_Nested_Pkg --
937 ----------------------
939 procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is
940 Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl);
942 Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec));
943 Build_Package_Stubs (Nested_Pkg_Spec);
945 end Visit_Nested_Pkg;
947 -- Start of processing for Build_Package_Stubs
950 Decl := First (Decls);
951 while Present (Decl) loop
953 when N_Subprogram_Declaration =>
955 -- Note: we test Comes_From_Source on Spec, not Decl, because
956 -- in the case of a subprogram instance, only the specification
957 -- (not the declaration) is marked as coming from source.
959 if Comes_From_Source (Specification (Decl)) then
960 Process_Subprogram_Declaration (Decl);
963 when N_Package_Declaration =>
965 -- Case of a nested package or package instantiation coming
966 -- from source, including the wrapper package for an instance
967 -- of a generic subprogram.
970 Pkg_Ent : constant Entity_Id :=
971 Defining_Unit_Name (Specification (Decl));
973 if Comes_From_Source (Decl)
975 (Is_Generic_Instance (Pkg_Ent)
976 and then Comes_From_Source
977 (Get_Unit_Instantiation_Node (Pkg_Ent)))
979 Visit_Nested_Pkg (Decl);
989 end Build_Package_Stubs;
991 ---------------------------------------
992 -- Add_Calling_Stubs_To_Declarations --
993 ---------------------------------------
995 procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is
996 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
998 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
999 -- Subprogram id 0 is reserved for calls received from
1000 -- remote access-to-subprogram dereferences.
1002 RCI_Instantiation : Node_Id;
1004 procedure Visit_Subprogram (Decl : Node_Id);
1005 -- Generate calling stub for one remote subprogram
1007 ----------------------
1008 -- Visit_Subprogram --
1009 ----------------------
1011 procedure Visit_Subprogram (Decl : Node_Id) is
1012 Loc : constant Source_Ptr := Sloc (Decl);
1013 Spec : constant Node_Id := Specification (Decl);
1014 Subp_Stubs : Node_Id;
1016 Subp_Str : String_Id;
1017 pragma Warnings (Off, Subp_Str);
1020 -- Disable expansion of stubs if serious errors have been diagnosed,
1021 -- because otherwise some illegal remote subprogram declarations
1022 -- could cause cascaded errors in stubs.
1024 if Serious_Errors_Detected /= 0 then
1028 Assign_Subprogram_Identifier
1029 (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str);
1032 Build_Subprogram_Calling_Stubs
1035 Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)),
1037 Nkind (Spec) = N_Procedure_Specification
1038 and then Is_Asynchronous (Defining_Unit_Name (Spec)));
1040 Append_To (List_Containing (Decl), Subp_Stubs);
1041 Analyze (Subp_Stubs);
1043 Current_Subprogram_Number := Current_Subprogram_Number + 1;
1044 end Visit_Subprogram;
1046 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
1048 -- Start of processing for Add_Calling_Stubs_To_Declarations
1051 Push_Scope (Scope_Of_Spec (Pkg_Spec));
1053 -- The first thing added is an instantiation of the generic package
1054 -- System.Partition_Interface.RCI_Locator with the name of this remote
1055 -- package. This will act as an interface with the name server to
1056 -- determine the Partition_ID and the RPC_Receiver for the receiver
1059 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
1060 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
1062 Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation);
1063 Analyze (RCI_Instantiation);
1065 -- For each subprogram declaration visible in the spec, we do build a
1066 -- body. We also increment a counter to assign a different Subprogram_Id
1067 -- to each subprogram. The receiving stubs processing uses the same
1068 -- mechanism and will thus assign the same Id and do the correct
1071 Overload_Counter_Table.Reset;
1072 PolyORB_Support.Reserve_NamingContext_Methods;
1074 Visit_Spec (Pkg_Spec);
1077 end Add_Calling_Stubs_To_Declarations;
1079 -----------------------------
1080 -- Add_Parameter_To_NVList --
1081 -----------------------------
1083 function Add_Parameter_To_NVList
1086 Parameter : Entity_Id;
1087 Constrained : Boolean;
1088 RACW_Ctrl : Boolean := False;
1089 Any : Entity_Id) return Node_Id
1091 Parameter_Name_String : String_Id;
1092 Parameter_Mode : Node_Id;
1094 function Parameter_Passing_Mode
1096 Parameter : Entity_Id;
1097 Constrained : Boolean) return Node_Id;
1098 -- Return an expression that denotes the parameter passing mode to be
1099 -- used for Parameter in distribution stubs, where Constrained is
1100 -- Parameter's constrained status.
1102 ----------------------------
1103 -- Parameter_Passing_Mode --
1104 ----------------------------
1106 function Parameter_Passing_Mode
1108 Parameter : Entity_Id;
1109 Constrained : Boolean) return Node_Id
1114 if Out_Present (Parameter) then
1115 if In_Present (Parameter)
1116 or else not Constrained
1118 -- Unconstrained formals must be translated
1119 -- to 'in' or 'inout', not 'out', because
1120 -- they need to be constrained by the actual.
1122 Lib_RE := RE_Mode_Inout;
1124 Lib_RE := RE_Mode_Out;
1128 Lib_RE := RE_Mode_In;
1131 return New_Occurrence_Of (RTE (Lib_RE), Loc);
1132 end Parameter_Passing_Mode;
1134 -- Start of processing for Add_Parameter_To_NVList
1137 if Nkind (Parameter) = N_Defining_Identifier then
1138 Get_Name_String (Chars (Parameter));
1140 Get_Name_String (Chars (Defining_Identifier (Parameter)));
1143 Parameter_Name_String := String_From_Name_Buffer;
1145 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1147 -- When the parameter passed to Add_Parameter_To_NVList is an
1148 -- Extra_Constrained parameter, Parameter is an N_Defining_
1149 -- Identifier, instead of a complete N_Parameter_Specification.
1150 -- Thus, we explicitly set 'in' mode in this case.
1152 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1156 Parameter_Passing_Mode (Loc, Parameter, Constrained);
1160 Make_Procedure_Call_Statement (Loc,
1162 New_Occurrence_Of (RTE (RE_NVList_Add_Item), Loc),
1163 Parameter_Associations => New_List (
1164 New_Occurrence_Of (NVList, Loc),
1165 Make_Function_Call (Loc,
1167 New_Occurrence_Of (RTE (RE_To_PolyORB_String), Loc),
1168 Parameter_Associations => New_List (
1169 Make_String_Literal (Loc, Strval => Parameter_Name_String))),
1170 New_Occurrence_Of (Any, Loc),
1172 end Add_Parameter_To_NVList;
1174 --------------------------------
1175 -- Add_RACW_Asynchronous_Flag --
1176 --------------------------------
1178 procedure Add_RACW_Asynchronous_Flag
1179 (Declarations : List_Id;
1180 RACW_Type : Entity_Id)
1182 Loc : constant Source_Ptr := Sloc (RACW_Type);
1184 Asynchronous_Flag : constant Entity_Id :=
1185 Make_Defining_Identifier (Loc,
1186 New_External_Name (Chars (RACW_Type), 'A'));
1189 -- Declare the asynchronous flag. This flag will be changed to True
1190 -- whenever it is known that the RACW type is asynchronous.
1192 Append_To (Declarations,
1193 Make_Object_Declaration (Loc,
1194 Defining_Identifier => Asynchronous_Flag,
1195 Constant_Present => True,
1196 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1197 Expression => New_Occurrence_Of (Standard_False, Loc)));
1199 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1200 end Add_RACW_Asynchronous_Flag;
1202 -----------------------
1203 -- Add_RACW_Features --
1204 -----------------------
1206 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1207 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1208 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1212 Body_Decls : List_Id;
1214 Stub_Type : Entity_Id;
1215 Stub_Type_Access : Entity_Id;
1216 RPC_Receiver_Decl : Node_Id;
1219 -- True when appropriate stubs have already been generated (this is the
1220 -- case when another RACW with the same designated type has already been
1221 -- encountered), in which case we reuse the previous stubs rather than
1222 -- generating new ones.
1225 if not Expander_Active then
1229 -- Mark the current package declaration as containing an RACW, so that
1230 -- the bodies for the calling stubs and the RACW stream subprograms
1231 -- are attached to the tree when the corresponding body is encountered.
1233 Set_Has_RACW (Current_Scope);
1235 -- Look for place to declare the RACW stub type and RACW operations
1241 -- Case of declaring the RACW in the same package as its designated
1242 -- type: we know that the designated type is a private type, so we
1243 -- use the private declarations list.
1245 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1247 if Present (Private_Declarations (Pkg_Spec)) then
1248 Decls := Private_Declarations (Pkg_Spec);
1250 Decls := Visible_Declarations (Pkg_Spec);
1254 -- Case of declaring the RACW in another package than its designated
1255 -- type: use the private declarations list if present; otherwise
1256 -- use the visible declarations.
1258 Decls := List_Containing (Declaration_Node (RACW_Type));
1262 -- If we were unable to find the declarations, that means that the
1263 -- completion of the type was missing. We can safely return and let the
1264 -- error be caught by the semantic analysis.
1271 (Designated_Type => Desig,
1272 RACW_Type => RACW_Type,
1274 Stub_Type => Stub_Type,
1275 Stub_Type_Access => Stub_Type_Access,
1276 RPC_Receiver_Decl => RPC_Receiver_Decl,
1277 Body_Decls => Body_Decls,
1278 Existing => Existing);
1280 -- If this RACW is not in the main unit, do not generate primitive or
1283 if not Entity_Is_In_Main_Unit (RACW_Type) then
1284 Body_Decls := No_List;
1287 Add_RACW_Asynchronous_Flag
1288 (Declarations => Decls,
1289 RACW_Type => RACW_Type);
1291 Specific_Add_RACW_Features
1292 (RACW_Type => RACW_Type,
1294 Stub_Type => Stub_Type,
1295 Stub_Type_Access => Stub_Type_Access,
1296 RPC_Receiver_Decl => RPC_Receiver_Decl,
1297 Body_Decls => Body_Decls);
1299 -- If we already have stubs for this designated type, nothing to do
1305 if Is_Frozen (Desig) then
1306 Validate_RACW_Primitives (RACW_Type);
1307 Add_RACW_Primitive_Declarations_And_Bodies
1308 (Designated_Type => Desig,
1309 Insertion_Node => RPC_Receiver_Decl,
1310 Body_Decls => Body_Decls);
1313 -- Validate_RACW_Primitives requires the list of all primitives of
1314 -- the designated type, so defer processing until Desig is frozen.
1315 -- See Exp_Ch3.Freeze_Type.
1317 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1319 end Add_RACW_Features;
1321 ------------------------------------------------
1322 -- Add_RACW_Primitive_Declarations_And_Bodies --
1323 ------------------------------------------------
1325 procedure Add_RACW_Primitive_Declarations_And_Bodies
1326 (Designated_Type : Entity_Id;
1327 Insertion_Node : Node_Id;
1328 Body_Decls : List_Id)
1330 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1331 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1332 -- the declarations are recognized as belonging to the current package.
1334 Stub_Elements : constant Stub_Structure :=
1335 Stubs_Table.Get (Designated_Type);
1337 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1339 Is_RAS : constant Boolean :=
1340 not Comes_From_Source (Stub_Elements.RACW_Type);
1341 -- Case of the RACW generated to implement a remote access-to-
1344 Build_Bodies : constant Boolean :=
1345 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1346 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1347 -- only when the main unit is the unit that contains the stub type.
1349 Current_Insertion_Node : Node_Id := Insertion_Node;
1351 RPC_Receiver : Entity_Id;
1352 RPC_Receiver_Statements : List_Id;
1353 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1354 RPC_Receiver_Elsif_Parts : List_Id := No_List;
1355 RPC_Receiver_Request : Entity_Id := Empty;
1356 RPC_Receiver_Subp_Id : Entity_Id := Empty;
1357 RPC_Receiver_Subp_Index : Entity_Id := Empty;
1359 Subp_Str : String_Id;
1361 Current_Primitive_Elmt : Elmt_Id;
1362 Current_Primitive : Entity_Id;
1363 Current_Primitive_Body : Node_Id;
1364 Current_Primitive_Spec : Node_Id;
1365 Current_Primitive_Decl : Node_Id;
1366 Current_Primitive_Number : Int := 0;
1367 Current_Primitive_Alias : Node_Id;
1368 Current_Receiver : Entity_Id;
1369 Current_Receiver_Body : Node_Id;
1370 RPC_Receiver_Decl : Node_Id;
1371 Possibly_Asynchronous : Boolean;
1374 if not Expander_Active then
1379 RPC_Receiver := Make_Temporary (Loc, 'P');
1381 Specific_Build_RPC_Receiver_Body
1382 (RPC_Receiver => RPC_Receiver,
1383 Request => RPC_Receiver_Request,
1384 Subp_Id => RPC_Receiver_Subp_Id,
1385 Subp_Index => RPC_Receiver_Subp_Index,
1386 Stmts => RPC_Receiver_Statements,
1387 Decl => RPC_Receiver_Decl);
1389 if Get_PCS_Name = Name_PolyORB_DSA then
1391 -- For the case of PolyORB, we need to map a textual operation
1392 -- name into a primitive index. Currently we do so using a simple
1393 -- sequence of string comparisons.
1395 RPC_Receiver_Elsif_Parts := New_List;
1399 -- Build callers, receivers for every primitive operations and a RPC
1400 -- receiver for this type. Note that we use Direct_Primitive_Operations,
1401 -- not Primitive_Operations, because we really want just the primitives
1402 -- of the tagged type itself, and in the case of a tagged synchronized
1403 -- type we do not want to get the primitives of the corresponding
1406 if Present (Direct_Primitive_Operations (Designated_Type)) then
1407 Overload_Counter_Table.Reset;
1409 Current_Primitive_Elmt :=
1410 First_Elmt (Direct_Primitive_Operations (Designated_Type));
1411 while Current_Primitive_Elmt /= No_Elmt loop
1412 Current_Primitive := Node (Current_Primitive_Elmt);
1414 -- Copy the primitive of all the parents, except predefined ones
1415 -- that are not remotely dispatching. Also omit hidden primitives
1416 -- (occurs in the case of primitives of interface progenitors
1417 -- other than immediate ancestors of the Designated_Type).
1419 if Chars (Current_Primitive) /= Name_uSize
1420 and then Chars (Current_Primitive) /= Name_uAlignment
1422 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1423 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1424 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1425 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1426 Is_TSS (Current_Primitive, TSS_Stream_Write)
1428 Is_Predefined_Interface_Primitive (Current_Primitive))
1429 and then not Is_Hidden (Current_Primitive)
1431 -- The first thing to do is build an up-to-date copy of the
1432 -- spec with all the formals referencing Controlling_Type
1433 -- transformed into formals referencing Stub_Type. Since this
1434 -- primitive may have been inherited, go back the alias chain
1435 -- until the real primitive has been found.
1437 Current_Primitive_Alias := Ultimate_Alias (Current_Primitive);
1439 -- Copy the spec from the original declaration for the purpose
1440 -- of declaring an overriding subprogram: we need to replace
1441 -- the type of each controlling formal with Stub_Type. The
1442 -- primitive may have been declared for Controlling_Type or
1443 -- inherited from some ancestor type for which we do not have
1444 -- an easily determined Entity_Id. We have no systematic way
1445 -- of knowing which type to substitute Stub_Type for. Instead,
1446 -- Copy_Specification relies on the flag Is_Controlling_Formal
1447 -- to determine which formals to change.
1449 Current_Primitive_Spec :=
1450 Copy_Specification (Loc,
1451 Spec => Parent (Current_Primitive_Alias),
1452 Ctrl_Type => Stub_Elements.Stub_Type);
1454 Current_Primitive_Decl :=
1455 Make_Subprogram_Declaration (Loc,
1456 Specification => Current_Primitive_Spec);
1458 Insert_After_And_Analyze (Current_Insertion_Node,
1459 Current_Primitive_Decl);
1460 Current_Insertion_Node := Current_Primitive_Decl;
1462 Possibly_Asynchronous :=
1463 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1464 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1466 Assign_Subprogram_Identifier (
1467 Defining_Unit_Name (Current_Primitive_Spec),
1468 Current_Primitive_Number,
1471 if Build_Bodies then
1472 Current_Primitive_Body :=
1473 Build_Subprogram_Calling_Stubs
1474 (Vis_Decl => Current_Primitive_Decl,
1476 Build_Subprogram_Id (Loc,
1477 Defining_Unit_Name (Current_Primitive_Spec)),
1478 Asynchronous => Possibly_Asynchronous,
1479 Dynamically_Asynchronous => Possibly_Asynchronous,
1480 Stub_Type => Stub_Elements.Stub_Type,
1481 RACW_Type => Stub_Elements.RACW_Type);
1482 Append_To (Body_Decls, Current_Primitive_Body);
1484 -- Analyzing the body here would cause the Stub type to
1485 -- be frozen, thus preventing subsequent primitive
1486 -- declarations. For this reason, it will be analyzed
1487 -- later in the regular flow (and in the context of the
1488 -- appropriate unit body, see Append_RACW_Bodies).
1492 -- Build the receiver stubs
1494 if Build_Bodies and then not Is_RAS then
1495 Current_Receiver_Body :=
1496 Specific_Build_Subprogram_Receiving_Stubs
1497 (Vis_Decl => Current_Primitive_Decl,
1498 Asynchronous => Possibly_Asynchronous,
1499 Dynamically_Asynchronous => Possibly_Asynchronous,
1500 Stub_Type => Stub_Elements.Stub_Type,
1501 RACW_Type => Stub_Elements.RACW_Type,
1502 Parent_Primitive => Current_Primitive);
1505 Defining_Unit_Name (Specification (Current_Receiver_Body));
1507 Append_To (Body_Decls, Current_Receiver_Body);
1509 -- Add a case alternative to the receiver
1511 if Get_PCS_Name = Name_PolyORB_DSA then
1512 Append_To (RPC_Receiver_Elsif_Parts,
1513 Make_Elsif_Part (Loc,
1515 Make_Function_Call (Loc,
1518 RTE (RE_Caseless_String_Eq), Loc),
1519 Parameter_Associations => New_List (
1520 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1521 Make_String_Literal (Loc, Subp_Str))),
1523 Then_Statements => New_List (
1524 Make_Assignment_Statement (Loc,
1525 Name => New_Occurrence_Of (
1526 RPC_Receiver_Subp_Index, Loc),
1528 Make_Integer_Literal (Loc,
1529 Intval => Current_Primitive_Number)))));
1532 Append_To (RPC_Receiver_Case_Alternatives,
1533 Make_Case_Statement_Alternative (Loc,
1534 Discrete_Choices => New_List (
1535 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1537 Statements => New_List (
1538 Make_Procedure_Call_Statement (Loc,
1540 New_Occurrence_Of (Current_Receiver, Loc),
1541 Parameter_Associations => New_List (
1542 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1545 -- Increment the index of current primitive
1547 Current_Primitive_Number := Current_Primitive_Number + 1;
1550 Next_Elmt (Current_Primitive_Elmt);
1554 -- Build the case statement and the heart of the subprogram
1556 if Build_Bodies and then not Is_RAS then
1557 if Get_PCS_Name = Name_PolyORB_DSA
1558 and then Present (First (RPC_Receiver_Elsif_Parts))
1560 Append_To (RPC_Receiver_Statements,
1561 Make_Implicit_If_Statement (Designated_Type,
1562 Condition => New_Occurrence_Of (Standard_False, Loc),
1563 Then_Statements => New_List,
1564 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1567 Append_To (RPC_Receiver_Case_Alternatives,
1568 Make_Case_Statement_Alternative (Loc,
1569 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1570 Statements => New_List (Make_Null_Statement (Loc))));
1572 Append_To (RPC_Receiver_Statements,
1573 Make_Case_Statement (Loc,
1575 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1576 Alternatives => RPC_Receiver_Case_Alternatives));
1578 Append_To (Body_Decls, RPC_Receiver_Decl);
1579 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1580 Body_Decls, RPC_Receiver, Stub_Elements);
1582 -- Do not analyze RPC receiver body at this stage since it references
1583 -- subprograms that have not been analyzed yet. It will be analyzed in
1584 -- the regular flow (see Append_RACW_Bodies).
1587 end Add_RACW_Primitive_Declarations_And_Bodies;
1589 -----------------------------
1590 -- Add_RAS_Dereference_TSS --
1591 -----------------------------
1593 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1594 Loc : constant Source_Ptr := Sloc (N);
1596 Type_Def : constant Node_Id := Type_Definition (N);
1597 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1598 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1599 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1601 RACW_Primitive_Name : Node_Id;
1603 Proc : constant Entity_Id :=
1604 Make_Defining_Identifier (Loc,
1605 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1607 Proc_Spec : Node_Id;
1608 Param_Specs : List_Id;
1609 Param_Assoc : constant List_Id := New_List;
1610 Stmts : constant List_Id := New_List;
1612 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P');
1614 Is_Function : constant Boolean :=
1615 Nkind (Type_Def) = N_Access_Function_Definition;
1617 Is_Degenerate : Boolean;
1618 -- Set to True if the subprogram_specification for this RAS has an
1619 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1621 Spec : constant Node_Id := Type_Def;
1623 Current_Parameter : Node_Id;
1625 -- Start of processing for Add_RAS_Dereference_TSS
1628 -- The Dereference TSS for a remote access-to-subprogram type has the
1631 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1634 -- This is called whenever a value of a RAS type is dereferenced
1636 -- First construct a list of parameter specifications:
1638 -- The first formal is the RAS values
1640 Param_Specs := New_List (
1641 Make_Parameter_Specification (Loc,
1642 Defining_Identifier => RAS_Parameter,
1645 New_Occurrence_Of (Fat_Type, Loc)));
1647 -- The following formals are copied from the type declaration
1649 Is_Degenerate := False;
1650 Current_Parameter := First (Parameter_Specifications (Type_Def));
1651 Parameters : while Present (Current_Parameter) loop
1652 if Nkind (Parameter_Type (Current_Parameter)) =
1655 Is_Degenerate := True;
1658 Append_To (Param_Specs,
1659 Make_Parameter_Specification (Loc,
1660 Defining_Identifier =>
1661 Make_Defining_Identifier (Loc,
1662 Chars => Chars (Defining_Identifier (Current_Parameter))),
1663 In_Present => In_Present (Current_Parameter),
1664 Out_Present => Out_Present (Current_Parameter),
1666 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1668 New_Copy_Tree (Expression (Current_Parameter))));
1670 Append_To (Param_Assoc,
1671 Make_Identifier (Loc,
1672 Chars => Chars (Defining_Identifier (Current_Parameter))));
1674 Next (Current_Parameter);
1675 end loop Parameters;
1677 if Is_Degenerate then
1678 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1680 -- Generate a dummy body. This code will never actually be executed,
1681 -- because null is the only legal value for a degenerate RAS type.
1682 -- For legality's sake (in order to avoid generating a function that
1683 -- does not contain a return statement), we include a dummy recursive
1684 -- call on the TSS itself.
1687 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1688 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1691 -- For a normal RAS type, we cast the RAS formal to the corresponding
1692 -- tagged type, and perform a dispatching call to its Call primitive
1695 Prepend_To (Param_Assoc,
1696 Unchecked_Convert_To (RACW_Type,
1697 New_Occurrence_Of (RAS_Parameter, Loc)));
1699 RACW_Primitive_Name :=
1700 Make_Selected_Component (Loc,
1701 Prefix => Scope (RACW_Type),
1702 Selector_Name => Name_uCall);
1707 Make_Simple_Return_Statement (Loc,
1709 Make_Function_Call (Loc,
1710 Name => RACW_Primitive_Name,
1711 Parameter_Associations => Param_Assoc)));
1715 Make_Procedure_Call_Statement (Loc,
1716 Name => RACW_Primitive_Name,
1717 Parameter_Associations => Param_Assoc));
1720 -- Build the complete subprogram
1724 Make_Function_Specification (Loc,
1725 Defining_Unit_Name => Proc,
1726 Parameter_Specifications => Param_Specs,
1727 Result_Definition =>
1729 Entity (Result_Definition (Spec)), Loc));
1731 Set_Ekind (Proc, E_Function);
1733 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1737 Make_Procedure_Specification (Loc,
1738 Defining_Unit_Name => Proc,
1739 Parameter_Specifications => Param_Specs);
1741 Set_Ekind (Proc, E_Procedure);
1742 Set_Etype (Proc, Standard_Void_Type);
1746 Make_Subprogram_Body (Loc,
1747 Specification => Proc_Spec,
1748 Declarations => New_List,
1749 Handled_Statement_Sequence =>
1750 Make_Handled_Sequence_Of_Statements (Loc,
1751 Statements => Stmts)));
1753 Set_TSS (Fat_Type, Proc);
1754 end Add_RAS_Dereference_TSS;
1756 -------------------------------
1757 -- Add_RAS_Proxy_And_Analyze --
1758 -------------------------------
1760 procedure Add_RAS_Proxy_And_Analyze
1763 All_Calls_Remote_E : Entity_Id;
1764 Proxy_Object_Addr : out Entity_Id)
1766 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1768 Subp_Name : constant Entity_Id :=
1769 Defining_Unit_Name (Specification (Vis_Decl));
1771 Pkg_Name : constant Entity_Id :=
1772 Make_Defining_Identifier (Loc,
1773 Chars => New_External_Name (Chars (Subp_Name), 'P', -1));
1775 Proxy_Type : constant Entity_Id :=
1776 Make_Defining_Identifier (Loc,
1779 (Related_Id => Chars (Subp_Name),
1782 Proxy_Type_Full_View : constant Entity_Id :=
1783 Make_Defining_Identifier (Loc,
1784 Chars (Proxy_Type));
1786 Subp_Decl_Spec : constant Node_Id :=
1787 Build_RAS_Primitive_Specification
1788 (Subp_Spec => Specification (Vis_Decl),
1789 Remote_Object_Type => Proxy_Type);
1791 Subp_Body_Spec : constant Node_Id :=
1792 Build_RAS_Primitive_Specification
1793 (Subp_Spec => Specification (Vis_Decl),
1794 Remote_Object_Type => Proxy_Type);
1796 Vis_Decls : constant List_Id := New_List;
1797 Pvt_Decls : constant List_Id := New_List;
1798 Actuals : constant List_Id := New_List;
1800 Perform_Call : Node_Id;
1803 -- type subpP is tagged limited private;
1805 Append_To (Vis_Decls,
1806 Make_Private_Type_Declaration (Loc,
1807 Defining_Identifier => Proxy_Type,
1808 Tagged_Present => True,
1809 Limited_Present => True));
1811 -- [subprogram] Call
1812 -- (Self : access subpP;
1813 -- ...other-formals...)
1816 Append_To (Vis_Decls,
1817 Make_Subprogram_Declaration (Loc,
1818 Specification => Subp_Decl_Spec));
1820 -- A : constant System.Address;
1822 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1824 Append_To (Vis_Decls,
1825 Make_Object_Declaration (Loc,
1826 Defining_Identifier => Proxy_Object_Addr,
1827 Constant_Present => True,
1828 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)));
1832 -- type subpP is tagged limited record
1833 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1837 Append_To (Pvt_Decls,
1838 Make_Full_Type_Declaration (Loc,
1839 Defining_Identifier => Proxy_Type_Full_View,
1841 Build_Remote_Subprogram_Proxy_Type (Loc,
1842 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1844 -- Trick semantic analysis into swapping the public and full view when
1845 -- freezing the public view.
1847 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1850 -- (Self : access O;
1851 -- ...other-formals...) is
1853 -- P (...other-formals...);
1857 -- (Self : access O;
1858 -- ...other-formals...)
1861 -- return F (...other-formals...);
1864 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1866 Make_Procedure_Call_Statement (Loc,
1867 Name => New_Occurrence_Of (Subp_Name, Loc),
1868 Parameter_Associations => Actuals);
1871 Make_Simple_Return_Statement (Loc,
1873 Make_Function_Call (Loc,
1874 Name => New_Occurrence_Of (Subp_Name, Loc),
1875 Parameter_Associations => Actuals));
1878 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1879 pragma Assert (Present (Formal));
1882 exit when No (Formal);
1884 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1887 -- O : aliased subpP;
1889 Append_To (Pvt_Decls,
1890 Make_Object_Declaration (Loc,
1891 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
1892 Aliased_Present => True,
1893 Object_Definition => New_Occurrence_Of (Proxy_Type, Loc)));
1895 -- A : constant System.Address := O'Address;
1897 Append_To (Pvt_Decls,
1898 Make_Object_Declaration (Loc,
1899 Defining_Identifier =>
1900 Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)),
1901 Constant_Present => True,
1902 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc),
1904 Make_Attribute_Reference (Loc,
1905 Prefix => New_Occurrence_Of (
1906 Defining_Identifier (Last (Pvt_Decls)), Loc),
1907 Attribute_Name => Name_Address)));
1910 Make_Package_Declaration (Loc,
1911 Specification => Make_Package_Specification (Loc,
1912 Defining_Unit_Name => Pkg_Name,
1913 Visible_Declarations => Vis_Decls,
1914 Private_Declarations => Pvt_Decls,
1915 End_Label => Empty)));
1916 Analyze (Last (Decls));
1919 Make_Package_Body (Loc,
1920 Defining_Unit_Name =>
1921 Make_Defining_Identifier (Loc, Chars (Pkg_Name)),
1922 Declarations => New_List (
1923 Make_Subprogram_Body (Loc,
1924 Specification => Subp_Body_Spec,
1925 Declarations => New_List,
1926 Handled_Statement_Sequence =>
1927 Make_Handled_Sequence_Of_Statements (Loc,
1928 Statements => New_List (Perform_Call))))));
1929 Analyze (Last (Decls));
1930 end Add_RAS_Proxy_And_Analyze;
1932 -----------------------
1933 -- Add_RAST_Features --
1934 -----------------------
1936 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1937 RAS_Type : constant Entity_Id :=
1938 Equivalent_Type (Defining_Identifier (Vis_Decl));
1940 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1941 Add_RAS_Dereference_TSS (Vis_Decl);
1942 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1943 end Add_RAST_Features;
1949 procedure Add_Stub_Type
1950 (Designated_Type : Entity_Id;
1951 RACW_Type : Entity_Id;
1953 Stub_Type : out Entity_Id;
1954 Stub_Type_Access : out Entity_Id;
1955 RPC_Receiver_Decl : out Node_Id;
1956 Body_Decls : out List_Id;
1957 Existing : out Boolean)
1959 Loc : constant Source_Ptr := Sloc (RACW_Type);
1961 Stub_Elements : constant Stub_Structure :=
1962 Stubs_Table.Get (Designated_Type);
1963 Stub_Type_Decl : Node_Id;
1964 Stub_Type_Access_Decl : Node_Id;
1967 if Stub_Elements /= Empty_Stub_Structure then
1968 Stub_Type := Stub_Elements.Stub_Type;
1969 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1970 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1971 Body_Decls := Stub_Elements.Body_Decls;
1977 Stub_Type := Make_Temporary (Loc, 'S');
1978 Set_Ekind (Stub_Type, E_Record_Type);
1979 Set_Is_RACW_Stub_Type (Stub_Type);
1981 Make_Defining_Identifier (Loc,
1982 Chars => New_External_Name
1983 (Related_Id => Chars (Stub_Type), Suffix => 'A'));
1985 RPC_Receiver_Decl := Specific_RPC_Receiver_Decl (RACW_Type);
1987 -- Create new stub type, copying components from generic RACW_Stub_Type
1990 Make_Full_Type_Declaration (Loc,
1991 Defining_Identifier => Stub_Type,
1993 Make_Record_Definition (Loc,
1994 Tagged_Present => True,
1995 Limited_Present => True,
1997 Make_Component_List (Loc,
1999 Copy_Component_List (RTE (RE_RACW_Stub_Type), Loc))));
2001 -- Does the stub type need to explicitly implement interfaces from the
2002 -- designated type???
2004 -- In particular are there issues in the case where the designated type
2005 -- is a synchronized interface???
2007 Stub_Type_Access_Decl :=
2008 Make_Full_Type_Declaration (Loc,
2009 Defining_Identifier => Stub_Type_Access,
2011 Make_Access_To_Object_Definition (Loc,
2012 All_Present => True,
2013 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
2015 Append_To (Decls, Stub_Type_Decl);
2016 Analyze (Last (Decls));
2017 Append_To (Decls, Stub_Type_Access_Decl);
2018 Analyze (Last (Decls));
2020 -- We can't directly derive the stub type from the designated type,
2021 -- because we don't want any components or discriminants from the real
2022 -- type, so instead we manually fake a derivation to get an appropriate
2025 Derive_Subprograms (Parent_Type => Designated_Type,
2026 Derived_Type => Stub_Type);
2028 if Present (RPC_Receiver_Decl) then
2029 Append_To (Decls, RPC_Receiver_Decl);
2032 -- Case of RACW implementing a RAS with the GARLIC PCS: there is
2033 -- no RPC receiver in that case, this is just an indication of
2034 -- where to insert code in the tree (see comment in declaration of
2035 -- type Stub_Structure).
2037 RPC_Receiver_Decl := Last (Decls);
2040 Body_Decls := New_List;
2042 Stubs_Table.Set (Designated_Type,
2043 (Stub_Type => Stub_Type,
2044 Stub_Type_Access => Stub_Type_Access,
2045 RPC_Receiver_Decl => RPC_Receiver_Decl,
2046 Body_Decls => Body_Decls,
2047 RACW_Type => RACW_Type));
2050 ------------------------
2051 -- Append_RACW_Bodies --
2052 ------------------------
2054 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
2058 E := First_Entity (Spec_Id);
2059 while Present (E) loop
2060 if Is_Remote_Access_To_Class_Wide_Type (E) then
2061 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
2066 end Append_RACW_Bodies;
2068 ----------------------------------
2069 -- Assign_Subprogram_Identifier --
2070 ----------------------------------
2072 procedure Assign_Subprogram_Identifier
2077 N : constant Name_Id := Chars (Def);
2079 Overload_Order : constant Int := Overload_Counter_Table.Get (N) + 1;
2082 Overload_Counter_Table.Set (N, Overload_Order);
2084 Get_Name_String (N);
2086 -- Homonym handling: as in Exp_Dbug, but much simpler, because the only
2087 -- entities for which we have to generate names here need only to be
2088 -- disambiguated within their own scope.
2090 if Overload_Order > 1 then
2091 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
2092 Name_Len := Name_Len + 2;
2093 Add_Nat_To_Name_Buffer (Overload_Order);
2096 Id := String_From_Name_Buffer;
2097 Subprogram_Identifier_Table.Set
2099 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
2100 end Assign_Subprogram_Identifier;
2102 -------------------------------------
2103 -- Build_Actual_Object_Declaration --
2104 -------------------------------------
2106 procedure Build_Actual_Object_Declaration
2107 (Object : Entity_Id;
2113 Loc : constant Source_Ptr := Sloc (Object);
2116 -- Declare a temporary object for the actual, possibly initialized with
2117 -- a 'Input/From_Any call.
2119 -- Complication arises in the case of limited types, for which such a
2120 -- declaration is illegal in Ada 95. In that case, we first generate a
2121 -- renaming declaration of the 'Input call, and then if needed we
2122 -- generate an overlaid non-constant view.
2124 if Ada_Version <= Ada_95
2125 and then Is_Limited_Type (Etyp)
2126 and then Present (Expr)
2129 -- Object : Etyp renames <func-call>
2132 Make_Object_Renaming_Declaration (Loc,
2133 Defining_Identifier => Object,
2134 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
2139 -- The name defined by the renaming declaration denotes a
2140 -- constant view; create a non-constant object at the same address
2141 -- to be used as the actual.
2144 Constant_Object : constant Entity_Id :=
2145 Make_Temporary (Loc, 'P');
2148 Set_Defining_Identifier
2149 (Last (Decls), Constant_Object);
2151 -- We have an unconstrained Etyp: build the actual constrained
2152 -- subtype for the value we just read from the stream.
2154 -- subtype S is <actual subtype of Constant_Object>;
2157 Build_Actual_Subtype (Etyp,
2158 New_Occurrence_Of (Constant_Object, Loc)));
2163 Make_Object_Declaration (Loc,
2164 Defining_Identifier => Object,
2165 Object_Definition =>
2167 (Defining_Identifier (Last (Decls)), Loc)));
2168 Set_Ekind (Object, E_Variable);
2170 -- Suppress default initialization:
2171 -- pragma Import (Ada, Object);
2175 Chars => Name_Import,
2176 Pragma_Argument_Associations => New_List (
2177 Make_Pragma_Argument_Association (Loc,
2178 Chars => Name_Convention,
2179 Expression => Make_Identifier (Loc, Name_Ada)),
2180 Make_Pragma_Argument_Association (Loc,
2181 Chars => Name_Entity,
2182 Expression => New_Occurrence_Of (Object, Loc)))));
2184 -- for Object'Address use Constant_Object'Address;
2187 Make_Attribute_Definition_Clause (Loc,
2188 Name => New_Occurrence_Of (Object, Loc),
2189 Chars => Name_Address,
2191 Make_Attribute_Reference (Loc,
2192 Prefix => New_Occurrence_Of (Constant_Object, Loc),
2193 Attribute_Name => Name_Address)));
2198 -- General case of a regular object declaration. Object is flagged
2199 -- constant unless it has mode out or in out, to allow the backend
2200 -- to optimize where possible.
2202 -- Object : [constant] Etyp [:= <expr>];
2205 Make_Object_Declaration (Loc,
2206 Defining_Identifier => Object,
2207 Constant_Present => Present (Expr) and then not Variable,
2208 Object_Definition => New_Occurrence_Of (Etyp, Loc),
2209 Expression => Expr));
2211 if Constant_Present (Last (Decls)) then
2212 Set_Ekind (Object, E_Constant);
2214 Set_Ekind (Object, E_Variable);
2217 end Build_Actual_Object_Declaration;
2219 ------------------------------
2220 -- Build_Get_Unique_RP_Call --
2221 ------------------------------
2223 function Build_Get_Unique_RP_Call
2225 Pointer : Entity_Id;
2226 Stub_Type : Entity_Id) return List_Id
2230 Make_Procedure_Call_Statement (Loc,
2232 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2233 Parameter_Associations => New_List (
2234 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2235 New_Occurrence_Of (Pointer, Loc)))),
2237 Make_Assignment_Statement (Loc,
2239 Make_Selected_Component (Loc,
2240 Prefix => New_Occurrence_Of (Pointer, Loc),
2242 New_Occurrence_Of (First_Tag_Component
2243 (Designated_Type (Etype (Pointer))), Loc)),
2245 Make_Attribute_Reference (Loc,
2246 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2247 Attribute_Name => Name_Tag)));
2249 -- Note: The assignment to Pointer._Tag is safe here because
2250 -- we carefully ensured that Stub_Type has exactly the same layout
2251 -- as System.Partition_Interface.RACW_Stub_Type.
2253 end Build_Get_Unique_RP_Call;
2255 -----------------------------------
2256 -- Build_Ordered_Parameters_List --
2257 -----------------------------------
2259 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2260 Constrained_List : List_Id;
2261 Unconstrained_List : List_Id;
2262 Current_Parameter : Node_Id;
2265 First_Parameter : Node_Id;
2266 For_RAS : Boolean := False;
2269 if No (Parameter_Specifications (Spec)) then
2273 Constrained_List := New_List;
2274 Unconstrained_List := New_List;
2275 First_Parameter := First (Parameter_Specifications (Spec));
2277 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2278 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2283 -- Loop through the parameters and add them to the right list. Note that
2284 -- we treat a parameter of a null-excluding access type as unconstrained
2285 -- because we can't declare an object of such a type with default
2288 Current_Parameter := First_Parameter;
2289 while Present (Current_Parameter) loop
2290 Ptyp := Parameter_Type (Current_Parameter);
2292 if (Nkind (Ptyp) = N_Access_Definition
2293 or else not Transmit_As_Unconstrained (Etype (Ptyp)))
2294 and then not (For_RAS and then Current_Parameter = First_Parameter)
2296 Append_To (Constrained_List, New_Copy (Current_Parameter));
2298 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2301 Next (Current_Parameter);
2304 -- Unconstrained parameters are returned first
2306 Append_List_To (Unconstrained_List, Constrained_List);
2308 return Unconstrained_List;
2309 end Build_Ordered_Parameters_List;
2311 ----------------------------------
2312 -- Build_Passive_Partition_Stub --
2313 ----------------------------------
2315 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2317 Pkg_Ent : Entity_Id;
2320 Loc : constant Source_Ptr := Sloc (U);
2323 -- Verify that the implementation supports distribution, by accessing
2324 -- a type defined in the proper version of system.rpc
2327 Dist_OK : Entity_Id;
2328 pragma Warnings (Off, Dist_OK);
2330 Dist_OK := RTE (RE_Params_Stream_Type);
2333 -- Use body if present, spec otherwise
2335 if Nkind (U) = N_Package_Declaration then
2336 Pkg_Spec := Specification (U);
2337 L := Visible_Declarations (Pkg_Spec);
2339 Pkg_Spec := Parent (Corresponding_Spec (U));
2340 L := Declarations (U);
2342 Pkg_Ent := Defining_Entity (Pkg_Spec);
2345 Make_Procedure_Call_Statement (Loc,
2347 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2348 Parameter_Associations => New_List (
2349 Make_String_Literal (Loc,
2350 Fully_Qualified_Name_String (Pkg_Ent, Append_NUL => False)),
2351 Make_Attribute_Reference (Loc,
2352 Prefix => New_Occurrence_Of (Pkg_Ent, Loc),
2353 Attribute_Name => Name_Version)));
2356 end Build_Passive_Partition_Stub;
2358 --------------------------------------
2359 -- Build_RPC_Receiver_Specification --
2360 --------------------------------------
2362 function Build_RPC_Receiver_Specification
2363 (RPC_Receiver : Entity_Id;
2364 Request_Parameter : Entity_Id) return Node_Id
2366 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2369 Make_Procedure_Specification (Loc,
2370 Defining_Unit_Name => RPC_Receiver,
2371 Parameter_Specifications => New_List (
2372 Make_Parameter_Specification (Loc,
2373 Defining_Identifier => Request_Parameter,
2375 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2376 end Build_RPC_Receiver_Specification;
2378 ----------------------------------------
2379 -- Build_Remote_Subprogram_Proxy_Type --
2380 ----------------------------------------
2382 function Build_Remote_Subprogram_Proxy_Type
2384 ACR_Expression : Node_Id) return Node_Id
2388 Make_Record_Definition (Loc,
2389 Tagged_Present => True,
2390 Limited_Present => True,
2392 Make_Component_List (Loc,
2393 Component_Items => New_List (
2394 Make_Component_Declaration (Loc,
2395 Defining_Identifier =>
2396 Make_Defining_Identifier (Loc,
2397 Name_All_Calls_Remote),
2398 Component_Definition =>
2399 Make_Component_Definition (Loc,
2400 Subtype_Indication =>
2401 New_Occurrence_Of (Standard_Boolean, Loc)),
2405 Make_Component_Declaration (Loc,
2406 Defining_Identifier =>
2407 Make_Defining_Identifier (Loc,
2409 Component_Definition =>
2410 Make_Component_Definition (Loc,
2411 Subtype_Indication =>
2412 New_Occurrence_Of (RTE (RE_Address), Loc)),
2414 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2416 Make_Component_Declaration (Loc,
2417 Defining_Identifier =>
2418 Make_Defining_Identifier (Loc,
2420 Component_Definition =>
2421 Make_Component_Definition (Loc,
2422 Subtype_Indication =>
2423 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2424 end Build_Remote_Subprogram_Proxy_Type;
2426 --------------------
2427 -- Build_Stub_Tag --
2428 --------------------
2430 function Build_Stub_Tag
2432 RACW_Type : Entity_Id) return Node_Id
2434 Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type);
2437 Make_Attribute_Reference (Loc,
2438 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2439 Attribute_Name => Name_Tag);
2442 ------------------------------------
2443 -- Build_Subprogram_Calling_Stubs --
2444 ------------------------------------
2446 function Build_Subprogram_Calling_Stubs
2447 (Vis_Decl : Node_Id;
2449 Asynchronous : Boolean;
2450 Dynamically_Asynchronous : Boolean := False;
2451 Stub_Type : Entity_Id := Empty;
2452 RACW_Type : Entity_Id := Empty;
2453 Locator : Entity_Id := Empty;
2454 New_Name : Name_Id := No_Name) return Node_Id
2456 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2458 Decls : constant List_Id := New_List;
2459 Statements : constant List_Id := New_List;
2461 Subp_Spec : Node_Id;
2462 -- The specification of the body
2464 Controlling_Parameter : Entity_Id := Empty;
2466 Asynchronous_Expr : Node_Id := Empty;
2468 RCI_Locator : Entity_Id;
2470 Spec_To_Use : Node_Id;
2472 procedure Insert_Partition_Check (Parameter : Node_Id);
2473 -- Check that the parameter has been elaborated on the same partition
2474 -- than the controlling parameter (E.4(19)).
2476 ----------------------------
2477 -- Insert_Partition_Check --
2478 ----------------------------
2480 procedure Insert_Partition_Check (Parameter : Node_Id) is
2481 Parameter_Entity : constant Entity_Id :=
2482 Defining_Identifier (Parameter);
2484 -- The expression that will be built is of the form:
2486 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2487 -- raise Constraint_Error;
2490 -- We do not check that Parameter is in Stub_Type since such a check
2491 -- has been inserted at the point of call already (a tag check since
2492 -- we have multiple controlling operands).
2495 Make_Raise_Constraint_Error (Loc,
2499 Make_Function_Call (Loc,
2501 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2502 Parameter_Associations =>
2504 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2505 New_Occurrence_Of (Parameter_Entity, Loc)),
2506 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2507 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2508 Reason => CE_Partition_Check_Failed));
2509 end Insert_Partition_Check;
2511 -- Start of processing for Build_Subprogram_Calling_Stubs
2515 Copy_Specification (Loc,
2516 Spec => Specification (Vis_Decl),
2517 New_Name => New_Name);
2519 if Locator = Empty then
2520 RCI_Locator := RCI_Cache;
2521 Spec_To_Use := Specification (Vis_Decl);
2523 RCI_Locator := Locator;
2524 Spec_To_Use := Subp_Spec;
2527 -- Find a controlling argument if we have a stub type. Also check
2528 -- if this subprogram can be made asynchronous.
2530 if Present (Stub_Type)
2531 and then Present (Parameter_Specifications (Spec_To_Use))
2534 Current_Parameter : Node_Id :=
2535 First (Parameter_Specifications
2538 while Present (Current_Parameter) loop
2540 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2542 if Controlling_Parameter = Empty then
2543 Controlling_Parameter :=
2544 Defining_Identifier (Current_Parameter);
2546 Insert_Partition_Check (Current_Parameter);
2550 Next (Current_Parameter);
2555 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2557 if Dynamically_Asynchronous then
2558 Asynchronous_Expr := Make_Selected_Component (Loc,
2559 Prefix => Controlling_Parameter,
2560 Selector_Name => Name_Asynchronous);
2563 Specific_Build_General_Calling_Stubs
2565 Statements => Statements,
2566 Target => Specific_Build_Stub_Target (Loc,
2567 Decls, RCI_Locator, Controlling_Parameter),
2568 Subprogram_Id => Subp_Id,
2569 Asynchronous => Asynchronous_Expr,
2570 Is_Known_Asynchronous => Asynchronous
2571 and then not Dynamically_Asynchronous,
2572 Is_Known_Non_Asynchronous
2574 and then not Dynamically_Asynchronous,
2575 Is_Function => Nkind (Spec_To_Use) =
2576 N_Function_Specification,
2577 Spec => Spec_To_Use,
2578 Stub_Type => Stub_Type,
2579 RACW_Type => RACW_Type,
2582 RCI_Calling_Stubs_Table.Set
2583 (Defining_Unit_Name (Specification (Vis_Decl)),
2584 Defining_Unit_Name (Spec_To_Use));
2587 Make_Subprogram_Body (Loc,
2588 Specification => Subp_Spec,
2589 Declarations => Decls,
2590 Handled_Statement_Sequence =>
2591 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2592 end Build_Subprogram_Calling_Stubs;
2594 -------------------------
2595 -- Build_Subprogram_Id --
2596 -------------------------
2598 function Build_Subprogram_Id
2600 E : Entity_Id) return Node_Id
2603 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2605 Current_Declaration : Node_Id;
2606 Current_Subp : Entity_Id;
2607 Current_Subp_Str : String_Id;
2608 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2610 pragma Warnings (Off, Current_Subp_Str);
2613 -- Build_Subprogram_Id is called outside of the context of
2614 -- generating calling or receiving stubs. Hence we are processing
2615 -- an 'Access attribute_reference for an RCI subprogram, for the
2616 -- purpose of obtaining a RAS value.
2619 (Is_Remote_Call_Interface (Scope (E))
2621 (Nkind (Parent (E)) = N_Procedure_Specification
2623 Nkind (Parent (E)) = N_Function_Specification));
2625 Current_Declaration :=
2626 First (Visible_Declarations
2627 (Package_Specification_Of_Scope (Scope (E))));
2628 while Present (Current_Declaration) loop
2629 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2630 and then Comes_From_Source (Current_Declaration)
2632 Current_Subp := Defining_Unit_Name (Specification (
2633 Current_Declaration));
2635 Assign_Subprogram_Identifier
2636 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2638 Current_Subp_Number := Current_Subp_Number + 1;
2641 Next (Current_Declaration);
2646 case Get_PCS_Name is
2647 when Name_PolyORB_DSA =>
2648 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2651 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2653 end Build_Subprogram_Id;
2655 ------------------------
2656 -- Copy_Specification --
2657 ------------------------
2659 function Copy_Specification
2662 Ctrl_Type : Entity_Id := Empty;
2663 New_Name : Name_Id := No_Name) return Node_Id
2665 Parameters : List_Id := No_List;
2667 Current_Parameter : Node_Id;
2668 Current_Identifier : Entity_Id;
2669 Current_Type : Node_Id;
2671 Name_For_New_Spec : Name_Id;
2673 New_Identifier : Entity_Id;
2675 -- Comments needed in body below ???
2678 if New_Name = No_Name then
2679 pragma Assert (Nkind (Spec) = N_Function_Specification
2680 or else Nkind (Spec) = N_Procedure_Specification);
2682 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2684 Name_For_New_Spec := New_Name;
2687 if Present (Parameter_Specifications (Spec)) then
2688 Parameters := New_List;
2689 Current_Parameter := First (Parameter_Specifications (Spec));
2690 while Present (Current_Parameter) loop
2691 Current_Identifier := Defining_Identifier (Current_Parameter);
2692 Current_Type := Parameter_Type (Current_Parameter);
2694 if Nkind (Current_Type) = N_Access_Definition then
2695 if Present (Ctrl_Type) then
2696 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2698 Make_Access_Definition (Loc,
2699 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2700 Null_Exclusion_Present =>
2701 Null_Exclusion_Present (Current_Type));
2705 Make_Access_Definition (Loc,
2707 New_Copy_Tree (Subtype_Mark (Current_Type)),
2708 Null_Exclusion_Present =>
2709 Null_Exclusion_Present (Current_Type));
2713 if Present (Ctrl_Type)
2714 and then Is_Controlling_Formal (Current_Identifier)
2716 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2718 Current_Type := New_Copy_Tree (Current_Type);
2722 New_Identifier := Make_Defining_Identifier (Loc,
2723 Chars (Current_Identifier));
2725 Append_To (Parameters,
2726 Make_Parameter_Specification (Loc,
2727 Defining_Identifier => New_Identifier,
2728 Parameter_Type => Current_Type,
2729 In_Present => In_Present (Current_Parameter),
2730 Out_Present => Out_Present (Current_Parameter),
2732 New_Copy_Tree (Expression (Current_Parameter))));
2734 -- For a regular formal parameter (that needs to be marshalled
2735 -- in the context of remote calls), set the Etype now, because
2736 -- marshalling processing might need it.
2738 if Is_Entity_Name (Current_Type) then
2739 Set_Etype (New_Identifier, Entity (Current_Type));
2741 -- Current_Type is an access definition, special processing
2742 -- (not requiring etype) will occur for marshalling.
2748 Next (Current_Parameter);
2752 case Nkind (Spec) is
2753 when N_Access_Function_Definition
2754 | N_Function_Specification
2757 Make_Function_Specification (Loc,
2758 Defining_Unit_Name =>
2759 Make_Defining_Identifier (Loc,
2760 Chars => Name_For_New_Spec),
2761 Parameter_Specifications => Parameters,
2762 Result_Definition =>
2763 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2765 when N_Access_Procedure_Definition
2766 | N_Procedure_Specification
2769 Make_Procedure_Specification (Loc,
2770 Defining_Unit_Name =>
2771 Make_Defining_Identifier (Loc,
2772 Chars => Name_For_New_Spec),
2773 Parameter_Specifications => Parameters);
2776 raise Program_Error;
2778 end Copy_Specification;
2780 -----------------------------
2781 -- Corresponding_Stub_Type --
2782 -----------------------------
2784 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2785 Desig : constant Entity_Id :=
2786 Etype (Designated_Type (RACW_Type));
2787 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2789 return Stub_Elements.Stub_Type;
2790 end Corresponding_Stub_Type;
2792 ---------------------------
2793 -- Could_Be_Asynchronous --
2794 ---------------------------
2796 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2797 Current_Parameter : Node_Id;
2800 if Present (Parameter_Specifications (Spec)) then
2801 Current_Parameter := First (Parameter_Specifications (Spec));
2802 while Present (Current_Parameter) loop
2803 if Out_Present (Current_Parameter) then
2807 Next (Current_Parameter);
2812 end Could_Be_Asynchronous;
2814 ---------------------------
2815 -- Declare_Create_NVList --
2816 ---------------------------
2818 procedure Declare_Create_NVList
2826 Make_Object_Declaration (Loc,
2827 Defining_Identifier => NVList,
2828 Aliased_Present => False,
2829 Object_Definition =>
2830 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2833 Make_Procedure_Call_Statement (Loc,
2834 Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2835 Parameter_Associations => New_List (
2836 New_Occurrence_Of (NVList, Loc))));
2837 end Declare_Create_NVList;
2839 ---------------------------------------------
2840 -- Expand_All_Calls_Remote_Subprogram_Call --
2841 ---------------------------------------------
2843 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2844 Loc : constant Source_Ptr := Sloc (N);
2845 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2846 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2847 RCI_Locator_Decl : Node_Id;
2848 RCI_Locator : Entity_Id;
2849 Calling_Stubs : Node_Id;
2850 E_Calling_Stubs : Entity_Id;
2853 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2855 if E_Calling_Stubs = Empty then
2856 RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
2858 -- The RCI_Locator package and calling stub are is inserted at the
2859 -- top level in the current unit, and must appear in the proper scope
2860 -- so that it is not prematurely removed by the GCC back end.
2863 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2865 if Ekind (Scop) = E_Package_Body then
2866 Push_Scope (Spec_Entity (Scop));
2867 elsif Ekind (Scop) = E_Subprogram_Body then
2869 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2875 if RCI_Locator = Empty then
2877 RCI_Package_Locator (Loc, Package_Specification (RCI_Package));
2878 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
2879 Analyze (RCI_Locator_Decl);
2880 RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
2883 RCI_Locator_Decl := Parent (RCI_Locator);
2886 Calling_Stubs := Build_Subprogram_Calling_Stubs
2887 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2889 Build_Subprogram_Id (Loc, Called_Subprogram),
2890 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2892 Is_Asynchronous (Called_Subprogram),
2893 Locator => RCI_Locator,
2894 New_Name => New_Internal_Name ('S'));
2895 Insert_After (RCI_Locator_Decl, Calling_Stubs);
2896 Analyze (Calling_Stubs);
2899 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2902 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2903 end Expand_All_Calls_Remote_Subprogram_Call;
2905 ---------------------------------
2906 -- Expand_Calling_Stubs_Bodies --
2907 ---------------------------------
2909 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2910 Spec : constant Node_Id := Specification (Unit_Node);
2912 Add_Calling_Stubs_To_Declarations (Spec);
2913 end Expand_Calling_Stubs_Bodies;
2915 -----------------------------------
2916 -- Expand_Receiving_Stubs_Bodies --
2917 -----------------------------------
2919 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2922 Stubs_Decls : List_Id;
2923 Stubs_Stmts : List_Id;
2926 if Nkind (Unit_Node) = N_Package_Declaration then
2927 Spec := Specification (Unit_Node);
2928 Decls := Private_Declarations (Spec);
2931 Decls := Visible_Declarations (Spec);
2934 Push_Scope (Scope_Of_Spec (Spec));
2935 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2939 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2940 Decls := Declarations (Unit_Node);
2942 Push_Scope (Scope_Of_Spec (Unit_Node));
2943 Stubs_Decls := New_List;
2944 Stubs_Stmts := New_List;
2945 Specific_Add_Receiving_Stubs_To_Declarations
2946 (Spec, Stubs_Decls, Stubs_Stmts);
2948 Insert_List_Before (First (Decls), Stubs_Decls);
2951 HSS_Stmts : constant List_Id :=
2952 Statements (Handled_Statement_Sequence (Unit_Node));
2954 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2957 if No (First_HSS_Stmt) then
2958 Append_List_To (HSS_Stmts, Stubs_Stmts);
2960 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2966 end Expand_Receiving_Stubs_Bodies;
2968 --------------------
2969 -- GARLIC_Support --
2970 --------------------
2972 package body GARLIC_Support is
2974 -- Local subprograms
2976 procedure Add_RACW_Read_Attribute
2977 (RACW_Type : Entity_Id;
2978 Stub_Type : Entity_Id;
2979 Stub_Type_Access : Entity_Id;
2980 Body_Decls : List_Id);
2981 -- Add Read attribute for the RACW type. The declaration and attribute
2982 -- definition clauses are inserted right after the declaration of
2983 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2984 -- appended to it (case where the RACW declaration is in the main unit).
2986 procedure Add_RACW_Write_Attribute
2987 (RACW_Type : Entity_Id;
2988 Stub_Type : Entity_Id;
2989 Stub_Type_Access : Entity_Id;
2990 RPC_Receiver : Node_Id;
2991 Body_Decls : List_Id);
2992 -- Same as above for the Write attribute
2994 function Stream_Parameter return Node_Id;
2995 function Result return Node_Id;
2996 function Object return Node_Id renames Result;
2997 -- Functions to create occurrences of the formal parameter names of the
2998 -- 'Read and 'Write attributes.
3001 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
3002 -- their ancillary subroutines (set on entry by Add_RACW_Features).
3004 procedure Add_RAS_Access_TSS (N : Node_Id);
3005 -- Add a subprogram body for RAS Access TSS
3007 -------------------------------------
3008 -- Add_Obj_RPC_Receiver_Completion --
3009 -------------------------------------
3011 procedure Add_Obj_RPC_Receiver_Completion
3014 RPC_Receiver : Entity_Id;
3015 Stub_Elements : Stub_Structure)
3018 -- The RPC receiver body should not be the completion of the
3019 -- declaration recorded in the stub structure, because then the
3020 -- occurrences of the formal parameters within the body should refer
3021 -- to the entities from the declaration, not from the completion, to
3022 -- which we do not have easy access. Instead, the RPC receiver body
3023 -- acts as its own declaration, and the RPC receiver declaration is
3024 -- completed by a renaming-as-body.
3027 Make_Subprogram_Renaming_Declaration (Loc,
3029 Copy_Specification (Loc,
3030 Specification (Stub_Elements.RPC_Receiver_Decl)),
3031 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
3032 end Add_Obj_RPC_Receiver_Completion;
3034 -----------------------
3035 -- Add_RACW_Features --
3036 -----------------------
3038 procedure Add_RACW_Features
3039 (RACW_Type : Entity_Id;
3040 Stub_Type : Entity_Id;
3041 Stub_Type_Access : Entity_Id;
3042 RPC_Receiver_Decl : Node_Id;
3043 Body_Decls : List_Id)
3045 RPC_Receiver : Node_Id;
3046 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
3049 Loc := Sloc (RACW_Type);
3053 -- For a RAS, the RPC receiver is that of the RCI unit, not that
3054 -- of the corresponding distributed object type. We retrieve its
3055 -- address from the local proxy object.
3057 RPC_Receiver := Make_Selected_Component (Loc,
3059 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
3060 Selector_Name => Make_Identifier (Loc, Name_Receiver));
3063 RPC_Receiver := Make_Attribute_Reference (Loc,
3064 Prefix => New_Occurrence_Of (
3065 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
3066 Attribute_Name => Name_Address);
3069 Add_RACW_Write_Attribute
3076 Add_RACW_Read_Attribute
3081 end Add_RACW_Features;
3083 -----------------------------
3084 -- Add_RACW_Read_Attribute --
3085 -----------------------------
3087 procedure Add_RACW_Read_Attribute
3088 (RACW_Type : Entity_Id;
3089 Stub_Type : Entity_Id;
3090 Stub_Type_Access : Entity_Id;
3091 Body_Decls : List_Id)
3093 Proc_Decl : Node_Id;
3094 Attr_Decl : Node_Id;
3096 Body_Node : Node_Id;
3098 Statements : constant List_Id := New_List;
3100 Local_Statements : List_Id;
3101 Remote_Statements : List_Id;
3102 -- Various parts of the procedure
3104 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
3105 Asynchronous_Flag : constant Entity_Id :=
3106 Asynchronous_Flags_Table.Get (RACW_Type);
3107 pragma Assert (Present (Asynchronous_Flag));
3109 -- Prepare local identifiers
3111 Source_Partition : Entity_Id;
3112 Source_Receiver : Entity_Id;
3113 Source_Address : Entity_Id;
3114 Local_Stub : Entity_Id;
3115 Stubbed_Result : Entity_Id;
3117 -- Start of processing for Add_RACW_Read_Attribute
3120 Build_Stream_Procedure (Loc,
3121 RACW_Type, Body_Node, Pnam, Statements, Outp => True);
3122 Proc_Decl := Make_Subprogram_Declaration (Loc,
3123 Copy_Specification (Loc, Specification (Body_Node)));
3126 Make_Attribute_Definition_Clause (Loc,
3127 Name => New_Occurrence_Of (RACW_Type, Loc),
3131 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3133 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3134 Insert_After (Proc_Decl, Attr_Decl);
3136 if No (Body_Decls) then
3138 -- Case of processing an RACW type from another unit than the
3139 -- main one: do not generate a body.
3144 -- Prepare local identifiers
3146 Source_Partition := Make_Temporary (Loc, 'P');
3147 Source_Receiver := Make_Temporary (Loc, 'S');
3148 Source_Address := Make_Temporary (Loc, 'P');
3149 Local_Stub := Make_Temporary (Loc, 'L');
3150 Stubbed_Result := Make_Temporary (Loc, 'S');
3152 -- Generate object declarations
3155 Make_Object_Declaration (Loc,
3156 Defining_Identifier => Source_Partition,
3157 Object_Definition =>
3158 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
3160 Make_Object_Declaration (Loc,
3161 Defining_Identifier => Source_Receiver,
3162 Object_Definition =>
3163 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3165 Make_Object_Declaration (Loc,
3166 Defining_Identifier => Source_Address,
3167 Object_Definition =>
3168 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3170 Make_Object_Declaration (Loc,
3171 Defining_Identifier => Local_Stub,
3172 Aliased_Present => True,
3173 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
3175 Make_Object_Declaration (Loc,
3176 Defining_Identifier => Stubbed_Result,
3177 Object_Definition =>
3178 New_Occurrence_Of (Stub_Type_Access, Loc),
3180 Make_Attribute_Reference (Loc,
3182 New_Occurrence_Of (Local_Stub, Loc),
3184 Name_Unchecked_Access)));
3186 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3188 Append_List_To (Statements, New_List (
3189 Make_Attribute_Reference (Loc,
3191 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3192 Attribute_Name => Name_Read,
3193 Expressions => New_List (
3195 New_Occurrence_Of (Source_Partition, Loc))),
3197 Make_Attribute_Reference (Loc,
3199 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3202 Expressions => New_List (
3204 New_Occurrence_Of (Source_Receiver, Loc))),
3206 Make_Attribute_Reference (Loc,
3208 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3211 Expressions => New_List (
3213 New_Occurrence_Of (Source_Address, Loc)))));
3215 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3217 Set_Etype (Stubbed_Result, Stub_Type_Access);
3219 -- If the Address is Null_Address, then return a null object, unless
3220 -- RACW_Type is null-excluding, in which case unconditionally raise
3221 -- CONSTRAINT_ERROR instead.
3224 Zero_Statements : List_Id;
3225 -- Statements executed when a zero value is received
3228 if Can_Never_Be_Null (RACW_Type) then
3229 Zero_Statements := New_List (
3230 Make_Raise_Constraint_Error (Loc,
3231 Reason => CE_Null_Not_Allowed));
3233 Zero_Statements := New_List (
3234 Make_Assignment_Statement (Loc,
3236 Expression => Make_Null (Loc)),
3237 Make_Simple_Return_Statement (Loc));
3240 Append_To (Statements,
3241 Make_Implicit_If_Statement (RACW_Type,
3244 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3245 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3246 Then_Statements => Zero_Statements));
3249 -- If the RACW denotes an object created on the current partition,
3250 -- Local_Statements will be executed. The real object will be used.
3252 Local_Statements := New_List (
3253 Make_Assignment_Statement (Loc,
3256 Unchecked_Convert_To (RACW_Type,
3257 OK_Convert_To (RTE (RE_Address),
3258 New_Occurrence_Of (Source_Address, Loc)))));
3260 -- If the object is located on another partition, then a stub object
3261 -- will be created with all the information needed to rebuild the
3262 -- real object at the other end.
3264 Remote_Statements := New_List (
3266 Make_Assignment_Statement (Loc,
3267 Name => Make_Selected_Component (Loc,
3268 Prefix => Stubbed_Result,
3269 Selector_Name => Name_Origin),
3271 New_Occurrence_Of (Source_Partition, Loc)),
3273 Make_Assignment_Statement (Loc,
3274 Name => Make_Selected_Component (Loc,
3275 Prefix => Stubbed_Result,
3276 Selector_Name => Name_Receiver),
3278 New_Occurrence_Of (Source_Receiver, Loc)),
3280 Make_Assignment_Statement (Loc,
3281 Name => Make_Selected_Component (Loc,
3282 Prefix => Stubbed_Result,
3283 Selector_Name => Name_Addr),
3285 New_Occurrence_Of (Source_Address, Loc)));
3287 Append_To (Remote_Statements,
3288 Make_Assignment_Statement (Loc,
3289 Name => Make_Selected_Component (Loc,
3290 Prefix => Stubbed_Result,
3291 Selector_Name => Name_Asynchronous),
3293 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3295 Append_List_To (Remote_Statements,
3296 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3297 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3298 -- set on the stub type if, and only if, the RACW type has a pragma
3299 -- Asynchronous. This is incorrect for RACWs that implement RAS
3300 -- types, because in that case the /designated subprogram/ (not the
3301 -- type) might be asynchronous, and that causes the stub to need to
3302 -- be asynchronous too. A solution is to transport a RAS as a struct
3303 -- containing a RACW and an asynchronous flag, and to properly alter
3304 -- the Asynchronous component in the stub type in the RAS's Input
3307 Append_To (Remote_Statements,
3308 Make_Assignment_Statement (Loc,
3310 Expression => Unchecked_Convert_To (RACW_Type,
3311 New_Occurrence_Of (Stubbed_Result, Loc))));
3313 -- Distinguish between the local and remote cases, and execute the
3314 -- appropriate piece of code.
3316 Append_To (Statements,
3317 Make_Implicit_If_Statement (RACW_Type,
3321 Make_Function_Call (Loc,
3322 Name => New_Occurrence_Of (
3323 RTE (RE_Get_Local_Partition_Id), Loc)),
3324 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3325 Then_Statements => Local_Statements,
3326 Else_Statements => Remote_Statements));
3328 Set_Declarations (Body_Node, Decls);
3329 Append_To (Body_Decls, Body_Node);
3330 end Add_RACW_Read_Attribute;
3332 ------------------------------
3333 -- Add_RACW_Write_Attribute --
3334 ------------------------------
3336 procedure Add_RACW_Write_Attribute
3337 (RACW_Type : Entity_Id;
3338 Stub_Type : Entity_Id;
3339 Stub_Type_Access : Entity_Id;
3340 RPC_Receiver : Node_Id;
3341 Body_Decls : List_Id)
3343 Body_Node : Node_Id;
3344 Proc_Decl : Node_Id;
3345 Attr_Decl : Node_Id;
3347 Statements : constant List_Id := New_List;
3348 Local_Statements : List_Id;
3349 Remote_Statements : List_Id;
3350 Null_Statements : List_Id;
3352 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
3355 Build_Stream_Procedure
3356 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
3358 Proc_Decl := Make_Subprogram_Declaration (Loc,
3359 Copy_Specification (Loc, Specification (Body_Node)));
3362 Make_Attribute_Definition_Clause (Loc,
3363 Name => New_Occurrence_Of (RACW_Type, Loc),
3364 Chars => Name_Write,
3367 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3369 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3370 Insert_After (Proc_Decl, Attr_Decl);
3372 if No (Body_Decls) then
3376 -- Build the code fragment corresponding to the marshalling of a
3379 Local_Statements := New_List (
3381 Pack_Entity_Into_Stream_Access (Loc,
3382 Stream => Stream_Parameter,
3383 Object => RTE (RE_Get_Local_Partition_Id)),
3385 Pack_Node_Into_Stream_Access (Loc,
3386 Stream => Stream_Parameter,
3387 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3388 Etyp => RTE (RE_Unsigned_64)),
3390 Pack_Node_Into_Stream_Access (Loc,
3391 Stream => Stream_Parameter,
3392 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3393 Make_Attribute_Reference (Loc,
3395 Make_Explicit_Dereference (Loc,
3397 Attribute_Name => Name_Address)),
3398 Etyp => RTE (RE_Unsigned_64)));
3400 -- Build the code fragment corresponding to the marshalling of
3403 Remote_Statements := New_List (
3404 Pack_Node_Into_Stream_Access (Loc,
3405 Stream => Stream_Parameter,
3407 Make_Selected_Component (Loc,
3409 Unchecked_Convert_To (Stub_Type_Access, Object),
3410 Selector_Name => Make_Identifier (Loc, Name_Origin)),
3411 Etyp => RTE (RE_Partition_ID)),
3413 Pack_Node_Into_Stream_Access (Loc,
3414 Stream => Stream_Parameter,
3416 Make_Selected_Component (Loc,
3418 Unchecked_Convert_To (Stub_Type_Access, Object),
3419 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
3420 Etyp => RTE (RE_Unsigned_64)),
3422 Pack_Node_Into_Stream_Access (Loc,
3423 Stream => Stream_Parameter,
3425 Make_Selected_Component (Loc,
3427 Unchecked_Convert_To (Stub_Type_Access, Object),
3428 Selector_Name => Make_Identifier (Loc, Name_Addr)),
3429 Etyp => RTE (RE_Unsigned_64)));
3431 -- Build code fragment corresponding to marshalling of a null object
3433 Null_Statements := New_List (
3435 Pack_Entity_Into_Stream_Access (Loc,
3436 Stream => Stream_Parameter,
3437 Object => RTE (RE_Get_Local_Partition_Id)),
3439 Pack_Node_Into_Stream_Access (Loc,
3440 Stream => Stream_Parameter,
3441 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3442 Etyp => RTE (RE_Unsigned_64)),
3444 Pack_Node_Into_Stream_Access (Loc,
3445 Stream => Stream_Parameter,
3446 Object => Make_Integer_Literal (Loc, Uint_0),
3447 Etyp => RTE (RE_Unsigned_64)));
3449 Append_To (Statements,
3450 Make_Implicit_If_Statement (RACW_Type,
3453 Left_Opnd => Object,
3454 Right_Opnd => Make_Null (Loc)),
3456 Then_Statements => Null_Statements,
3458 Elsif_Parts => New_List (
3459 Make_Elsif_Part (Loc,
3463 Make_Attribute_Reference (Loc,
3465 Attribute_Name => Name_Tag),
3468 Make_Attribute_Reference (Loc,
3469 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3470 Attribute_Name => Name_Tag)),
3471 Then_Statements => Remote_Statements)),
3472 Else_Statements => Local_Statements));
3474 Append_To (Body_Decls, Body_Node);
3475 end Add_RACW_Write_Attribute;
3477 ------------------------
3478 -- Add_RAS_Access_TSS --
3479 ------------------------
3481 procedure Add_RAS_Access_TSS (N : Node_Id) is
3482 Loc : constant Source_Ptr := Sloc (N);
3484 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3485 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3486 -- Ras_Type is the access to subprogram type while Fat_Type is the
3487 -- corresponding record type.
3489 RACW_Type : constant Entity_Id :=
3490 Underlying_RACW_Type (Ras_Type);
3491 Desig : constant Entity_Id :=
3492 Etype (Designated_Type (RACW_Type));
3494 Stub_Elements : constant Stub_Structure :=
3495 Stubs_Table.Get (Desig);
3496 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3498 Proc : constant Entity_Id :=
3499 Make_Defining_Identifier (Loc,
3500 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3502 Proc_Spec : Node_Id;
3504 -- Formal parameters
3506 Package_Name : constant Entity_Id :=
3507 Make_Defining_Identifier (Loc,
3511 Subp_Id : constant Entity_Id :=
3512 Make_Defining_Identifier (Loc,
3514 -- Target subprogram
3516 Asynch_P : constant Entity_Id :=
3517 Make_Defining_Identifier (Loc,
3518 Chars => Name_Asynchronous);
3519 -- Is the procedure to which the 'Access applies asynchronous?
3521 All_Calls_Remote : constant Entity_Id :=
3522 Make_Defining_Identifier (Loc,
3523 Chars => Name_All_Calls_Remote);
3524 -- True if an All_Calls_Remote pragma applies to the RCI unit
3525 -- that contains the subprogram.
3527 -- Common local variables
3529 Proc_Decls : List_Id;
3530 Proc_Statements : List_Id;
3532 Origin : constant Entity_Id := Make_Temporary (Loc, 'P');
3534 -- Additional local variables for the local case
3536 Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P');
3538 -- Additional local variables for the remote case
3540 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
3541 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
3544 (Field_Name : Name_Id;
3545 Value : Node_Id) return Node_Id;
3546 -- Construct an assignment that sets the named component in the
3554 (Field_Name : Name_Id;
3555 Value : Node_Id) return Node_Id
3559 Make_Assignment_Statement (Loc,
3561 Make_Selected_Component (Loc,
3563 Selector_Name => Field_Name),
3564 Expression => Value);
3567 -- Start of processing for Add_RAS_Access_TSS
3570 Proc_Decls := New_List (
3572 -- Common declarations
3574 Make_Object_Declaration (Loc,
3575 Defining_Identifier => Origin,
3576 Constant_Present => True,
3577 Object_Definition =>
3578 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3580 Make_Function_Call (Loc,
3582 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3583 Parameter_Associations => New_List (
3584 New_Occurrence_Of (Package_Name, Loc)))),
3586 -- Declaration use only in the local case: proxy address
3588 Make_Object_Declaration (Loc,
3589 Defining_Identifier => Proxy_Addr,
3590 Object_Definition =>
3591 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3593 -- Declarations used only in the remote case: stub object and
3596 Make_Object_Declaration (Loc,
3597 Defining_Identifier => Local_Stub,
3598 Aliased_Present => True,
3599 Object_Definition =>
3600 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3602 Make_Object_Declaration (Loc,
3603 Defining_Identifier =>
3605 Object_Definition =>
3606 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3608 Make_Attribute_Reference (Loc,
3609 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3610 Attribute_Name => Name_Unchecked_Access)));
3612 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3614 -- Build_Get_Unique_RP_Call needs above information
3616 -- Note: Here we assume that the Fat_Type is a record
3617 -- containing just a pointer to a proxy or stub object.
3619 Proc_Statements := New_List (
3623 -- Get_RAS_Info (Pkg, Subp, PA);
3624 -- if Origin = Local_Partition_Id
3625 -- and then not All_Calls_Remote
3627 -- return Fat_Type!(PA);
3630 Make_Procedure_Call_Statement (Loc,
3631 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3632 Parameter_Associations => New_List (
3633 New_Occurrence_Of (Package_Name, Loc),
3634 New_Occurrence_Of (Subp_Id, Loc),
3635 New_Occurrence_Of (Proxy_Addr, Loc))),
3637 Make_Implicit_If_Statement (N,
3643 New_Occurrence_Of (Origin, Loc),
3645 Make_Function_Call (Loc,
3647 RTE (RE_Get_Local_Partition_Id), Loc))),
3651 New_Occurrence_Of (All_Calls_Remote, Loc))),
3653 Then_Statements => New_List (
3654 Make_Simple_Return_Statement (Loc,
3655 Unchecked_Convert_To (Fat_Type,
3656 OK_Convert_To (RTE (RE_Address),
3657 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3659 Set_Field (Name_Origin,
3660 New_Occurrence_Of (Origin, Loc)),
3662 Set_Field (Name_Receiver,
3663 Make_Function_Call (Loc,
3665 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3666 Parameter_Associations => New_List (
3667 New_Occurrence_Of (Package_Name, Loc)))),
3669 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3671 -- E.4.1(9) A remote call is asynchronous if it is a call to
3672 -- a procedure or a call through a value of an access-to-procedure
3673 -- type to which a pragma Asynchronous applies.
3675 -- Asynch_P is true when the procedure is asynchronous;
3676 -- Asynch_T is true when the type is asynchronous.
3678 Set_Field (Name_Asynchronous,
3680 New_Occurrence_Of (Asynch_P, Loc),
3681 New_Occurrence_Of (Boolean_Literals (
3682 Is_Asynchronous (Ras_Type)), Loc))));
3684 Append_List_To (Proc_Statements,
3685 Build_Get_Unique_RP_Call
3686 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3688 -- Return the newly created value
3690 Append_To (Proc_Statements,
3691 Make_Simple_Return_Statement (Loc,
3693 Unchecked_Convert_To (Fat_Type,
3694 New_Occurrence_Of (Stub_Ptr, Loc))));
3697 Make_Function_Specification (Loc,
3698 Defining_Unit_Name => Proc,
3699 Parameter_Specifications => New_List (
3700 Make_Parameter_Specification (Loc,
3701 Defining_Identifier => Package_Name,
3703 New_Occurrence_Of (Standard_String, Loc)),
3705 Make_Parameter_Specification (Loc,
3706 Defining_Identifier => Subp_Id,
3708 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3710 Make_Parameter_Specification (Loc,
3711 Defining_Identifier => Asynch_P,
3713 New_Occurrence_Of (Standard_Boolean, Loc)),
3715 Make_Parameter_Specification (Loc,
3716 Defining_Identifier => All_Calls_Remote,
3718 New_Occurrence_Of (Standard_Boolean, Loc))),
3720 Result_Definition =>
3721 New_Occurrence_Of (Fat_Type, Loc));
3723 -- Set the kind and return type of the function to prevent
3724 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3726 Set_Ekind (Proc, E_Function);
3727 Set_Etype (Proc, Fat_Type);
3730 Make_Subprogram_Body (Loc,
3731 Specification => Proc_Spec,
3732 Declarations => Proc_Decls,
3733 Handled_Statement_Sequence =>
3734 Make_Handled_Sequence_Of_Statements (Loc,
3735 Statements => Proc_Statements)));
3737 Set_TSS (Fat_Type, Proc);
3738 end Add_RAS_Access_TSS;
3740 -----------------------
3741 -- Add_RAST_Features --
3742 -----------------------
3744 procedure Add_RAST_Features
3745 (Vis_Decl : Node_Id;
3746 RAS_Type : Entity_Id)
3748 pragma Unreferenced (RAS_Type);
3750 Add_RAS_Access_TSS (Vis_Decl);
3751 end Add_RAST_Features;
3753 -----------------------------------------
3754 -- Add_Receiving_Stubs_To_Declarations --
3755 -----------------------------------------
3757 procedure Add_Receiving_Stubs_To_Declarations
3758 (Pkg_Spec : Node_Id;
3762 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3764 Request_Parameter : Node_Id;
3766 Pkg_RPC_Receiver : constant Entity_Id :=
3767 Make_Temporary (Loc, 'H');
3768 Pkg_RPC_Receiver_Statements : List_Id;
3769 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3770 Pkg_RPC_Receiver_Body : Node_Id;
3771 -- A Pkg_RPC_Receiver is built to decode the request
3773 Lookup_RAS : Node_Id;
3774 Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R');
3775 -- A remote subprogram is created to allow peers to look up RAS
3776 -- information using subprogram ids.
3778 Subp_Id : Entity_Id;
3779 Subp_Index : Entity_Id;
3780 -- Subprogram_Id as read from the incoming stream
3782 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
3783 Current_Stubs : Node_Id;
3785 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
3786 Subp_Info_List : constant List_Id := New_List;
3788 Register_Pkg_Actuals : constant List_Id := New_List;
3790 All_Calls_Remote_E : Entity_Id;
3791 Proxy_Object_Addr : Entity_Id;
3793 procedure Append_Stubs_To
3794 (RPC_Receiver_Cases : List_Id;
3796 Subprogram_Number : Int);
3797 -- Add one case to the specified RPC receiver case list
3798 -- associating Subprogram_Number with the subprogram declared
3799 -- by Declaration, for which we have receiving stubs in Stubs.
3801 procedure Visit_Subprogram (Decl : Node_Id);
3802 -- Generate receiving stub for one remote subprogram
3804 ---------------------
3805 -- Append_Stubs_To --
3806 ---------------------
3808 procedure Append_Stubs_To
3809 (RPC_Receiver_Cases : List_Id;
3811 Subprogram_Number : Int)
3814 Append_To (RPC_Receiver_Cases,
3815 Make_Case_Statement_Alternative (Loc,
3817 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3820 Make_Procedure_Call_Statement (Loc,
3822 New_Occurrence_Of (Defining_Entity (Stubs), Loc),
3823 Parameter_Associations => New_List (
3824 New_Occurrence_Of (Request_Parameter, Loc))))));
3825 end Append_Stubs_To;
3827 ----------------------
3828 -- Visit_Subprogram --
3829 ----------------------
3831 procedure Visit_Subprogram (Decl : Node_Id) is
3832 Loc : constant Source_Ptr := Sloc (Decl);
3833 Spec : constant Node_Id := Specification (Decl);
3834 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
3836 Subp_Val : String_Id;
3837 pragma Warnings (Off, Subp_Val);
3840 -- Disable expansion of stubs if serious errors have been
3841 -- diagnosed, because otherwise some illegal remote subprogram
3842 -- declarations could cause cascaded errors in stubs.
3844 if Serious_Errors_Detected /= 0 then
3848 -- Build receiving stub
3851 Build_Subprogram_Receiving_Stubs
3854 Nkind (Spec) = N_Procedure_Specification
3855 and then Is_Asynchronous (Subp_Def));
3857 Append_To (Decls, Current_Stubs);
3858 Analyze (Current_Stubs);
3862 Add_RAS_Proxy_And_Analyze (Decls,
3864 All_Calls_Remote_E => All_Calls_Remote_E,
3865 Proxy_Object_Addr => Proxy_Object_Addr);
3867 -- Compute distribution identifier
3869 Assign_Subprogram_Identifier
3870 (Subp_Def, Current_Subp_Number, Subp_Val);
3872 pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
3874 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
3875 -- table for this receiver. This aggregate must be kept consistent
3876 -- with the declaration of RCI_Subp_Info in
3877 -- System.Partition_Interface.
3879 Append_To (Subp_Info_List,
3880 Make_Component_Association (Loc,
3881 Choices => New_List (
3882 Make_Integer_Literal (Loc, Current_Subp_Number)),
3885 Make_Aggregate (Loc,
3886 Component_Associations => New_List (
3890 Make_Component_Association (Loc,
3892 New_List (Make_Identifier (Loc, Name_Addr)),
3894 New_Occurrence_Of (Proxy_Object_Addr, Loc))))));
3896 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3897 Stubs => Current_Stubs,
3898 Subprogram_Number => Current_Subp_Number);
3900 Current_Subp_Number := Current_Subp_Number + 1;
3901 end Visit_Subprogram;
3903 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
3905 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3908 -- Building receiving stubs consist in several operations:
3910 -- - a package RPC receiver must be built. This subprogram
3911 -- will get a Subprogram_Id from the incoming stream
3912 -- and will dispatch the call to the right subprogram;
3914 -- - a receiving stub for each subprogram visible in the package
3915 -- spec. This stub will read all the parameters from the stream,
3916 -- and put the result as well as the exception occurrence in the
3919 -- - a dummy package with an empty spec and a body made of an
3920 -- elaboration part, whose job is to register the receiving
3921 -- part of this RCI package on the name server. This is done
3922 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3924 Build_RPC_Receiver_Body (
3925 RPC_Receiver => Pkg_RPC_Receiver,
3926 Request => Request_Parameter,
3928 Subp_Index => Subp_Index,
3929 Stmts => Pkg_RPC_Receiver_Statements,
3930 Decl => Pkg_RPC_Receiver_Body);
3931 pragma Assert (Subp_Id = Subp_Index);
3933 -- A null subp_id denotes a call through a RAS, in which case the
3934 -- next Uint_64 element in the stream is the address of the local
3935 -- proxy object, from which we can retrieve the actual subprogram id.
3937 Append_To (Pkg_RPC_Receiver_Statements,
3938 Make_Implicit_If_Statement (Pkg_Spec,
3941 New_Occurrence_Of (Subp_Id, Loc),
3942 Make_Integer_Literal (Loc, 0)),
3944 Then_Statements => New_List (
3945 Make_Assignment_Statement (Loc,
3947 New_Occurrence_Of (Subp_Id, Loc),
3950 Make_Selected_Component (Loc,
3952 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3953 OK_Convert_To (RTE (RE_Address),
3954 Make_Attribute_Reference (Loc,
3956 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3959 Expressions => New_List (
3960 Make_Selected_Component (Loc,
3961 Prefix => Request_Parameter,
3962 Selector_Name => Name_Params))))),
3964 Selector_Name => Make_Identifier (Loc, Name_Subp_Id))))));
3966 -- Build a subprogram for RAS information lookups
3969 Make_Subprogram_Declaration (Loc,
3971 Make_Function_Specification (Loc,
3972 Defining_Unit_Name =>
3974 Parameter_Specifications => New_List (
3975 Make_Parameter_Specification (Loc,
3976 Defining_Identifier =>
3977 Make_Defining_Identifier (Loc, Name_Subp_Id),
3981 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3982 Result_Definition =>
3983 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3984 Append_To (Decls, Lookup_RAS);
3985 Analyze (Lookup_RAS);
3987 Current_Stubs := Build_Subprogram_Receiving_Stubs
3988 (Vis_Decl => Lookup_RAS,
3989 Asynchronous => False);
3990 Append_To (Decls, Current_Stubs);
3991 Analyze (Current_Stubs);
3993 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3994 Stubs => Current_Stubs,
3995 Subprogram_Number => 1);
3997 -- For each subprogram, the receiving stub will be built and a
3998 -- case statement will be made on the Subprogram_Id to dispatch
3999 -- to the right subprogram.
4001 All_Calls_Remote_E :=
4003 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
4005 Overload_Counter_Table.Reset;
4007 Visit_Spec (Pkg_Spec);
4009 -- If we receive an invalid Subprogram_Id, it is best to do nothing
4010 -- rather than raising an exception since we do not want someone
4011 -- to crash a remote partition by sending invalid subprogram ids.
4012 -- This is consistent with the other parts of the case statement
4013 -- since even in presence of incorrect parameters in the stream,
4014 -- every exception will be caught and (if the subprogram is not an
4015 -- APC) put into the result stream and sent away.
4017 Append_To (Pkg_RPC_Receiver_Cases,
4018 Make_Case_Statement_Alternative (Loc,
4019 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4020 Statements => New_List (Make_Null_Statement (Loc))));
4022 Append_To (Pkg_RPC_Receiver_Statements,
4023 Make_Case_Statement (Loc,
4024 Expression => New_Occurrence_Of (Subp_Id, Loc),
4025 Alternatives => Pkg_RPC_Receiver_Cases));
4028 Make_Object_Declaration (Loc,
4029 Defining_Identifier => Subp_Info_Array,
4030 Constant_Present => True,
4031 Aliased_Present => True,
4032 Object_Definition =>
4033 Make_Subtype_Indication (Loc,
4035 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
4037 Make_Index_Or_Discriminant_Constraint (Loc,
4040 Low_Bound => Make_Integer_Literal (Loc,
4041 First_RCI_Subprogram_Id),
4043 Make_Integer_Literal (Loc,
4045 First_RCI_Subprogram_Id
4046 + List_Length (Subp_Info_List) - 1)))))));
4048 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
4049 -- has zero length, and the declaration is for an empty array, in
4050 -- which case no initialization aggregate must be generated.
4052 if Present (First (Subp_Info_List)) then
4053 Set_Expression (Last (Decls),
4054 Make_Aggregate (Loc,
4055 Component_Associations => Subp_Info_List));
4057 -- No initialization provided: remove CONSTANT so that the
4058 -- declaration is not an incomplete deferred constant.
4061 Set_Constant_Present (Last (Decls), False);
4064 Analyze (Last (Decls));
4067 Subp_Info_Addr : Node_Id;
4068 -- Return statement for Lookup_RAS_Info: address of the subprogram
4069 -- information record for the requested subprogram id.
4072 if Present (First (Subp_Info_List)) then
4074 Make_Selected_Component (Loc,
4076 Make_Indexed_Component (Loc,
4077 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4078 Expressions => New_List (
4079 Convert_To (Standard_Integer,
4080 Make_Identifier (Loc, Name_Subp_Id)))),
4081 Selector_Name => Make_Identifier (Loc, Name_Addr));
4083 -- Case of no visible subprogram: just raise Constraint_Error, we
4084 -- know for sure we got junk from a remote partition.
4088 Make_Raise_Constraint_Error (Loc,
4089 Reason => CE_Range_Check_Failed);
4090 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
4094 Make_Subprogram_Body (Loc,
4096 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
4097 Declarations => No_List,
4098 Handled_Statement_Sequence =>
4099 Make_Handled_Sequence_Of_Statements (Loc,
4100 Statements => New_List (
4101 Make_Simple_Return_Statement (Loc,
4104 (RTE (RE_Unsigned_64), Subp_Info_Addr))))));
4107 Analyze (Last (Decls));
4109 Append_To (Decls, Pkg_RPC_Receiver_Body);
4110 Analyze (Last (Decls));
4114 Append_To (Register_Pkg_Actuals,
4115 Make_String_Literal (Loc,
4117 Fully_Qualified_Name_String
4118 (Defining_Entity (Pkg_Spec), Append_NUL => False)));
4122 Append_To (Register_Pkg_Actuals,
4123 Make_Attribute_Reference (Loc,
4124 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
4125 Attribute_Name => Name_Unrestricted_Access));
4129 Append_To (Register_Pkg_Actuals,
4130 Make_Attribute_Reference (Loc,
4132 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
4133 Attribute_Name => Name_Version));
4137 Append_To (Register_Pkg_Actuals,
4138 Make_Attribute_Reference (Loc,
4139 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4140 Attribute_Name => Name_Address));
4144 Append_To (Register_Pkg_Actuals,
4145 Make_Attribute_Reference (Loc,
4146 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4147 Attribute_Name => Name_Length));
4149 -- Generate the call
4152 Make_Procedure_Call_Statement (Loc,
4154 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
4155 Parameter_Associations => Register_Pkg_Actuals));
4156 Analyze (Last (Stmts));
4157 end Add_Receiving_Stubs_To_Declarations;
4159 ---------------------------------
4160 -- Build_General_Calling_Stubs --
4161 ---------------------------------
4163 procedure Build_General_Calling_Stubs
4165 Statements : List_Id;
4166 Target_Partition : Entity_Id;
4167 Target_RPC_Receiver : Node_Id;
4168 Subprogram_Id : Node_Id;
4169 Asynchronous : Node_Id := Empty;
4170 Is_Known_Asynchronous : Boolean := False;
4171 Is_Known_Non_Asynchronous : Boolean := False;
4172 Is_Function : Boolean;
4174 Stub_Type : Entity_Id := Empty;
4175 RACW_Type : Entity_Id := Empty;
4178 Loc : constant Source_Ptr := Sloc (Nod);
4180 Stream_Parameter : Node_Id;
4181 -- Name of the stream used to transmit parameters to the remote
4184 Result_Parameter : Node_Id;
4185 -- Name of the result parameter (in non-APC cases) which get the
4186 -- result of the remote subprogram.
4188 Exception_Return_Parameter : Node_Id;
4189 -- Name of the parameter which will hold the exception sent by the
4190 -- remote subprogram.
4192 Current_Parameter : Node_Id;
4193 -- Current parameter being handled
4195 Ordered_Parameters_List : constant List_Id :=
4196 Build_Ordered_Parameters_List (Spec);
4198 Asynchronous_Statements : List_Id := No_List;
4199 Non_Asynchronous_Statements : List_Id := No_List;
4200 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4202 Extra_Formal_Statements : constant List_Id := New_List;
4203 -- List of statements for extra formal parameters. It will appear
4204 -- after the regular statements for writing out parameters.
4206 pragma Unreferenced (RACW_Type);
4207 -- Used only for the PolyORB case
4210 -- The general form of a calling stub for a given subprogram is:
4212 -- procedure X (...) is P : constant Partition_ID :=
4213 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4214 -- System.RPC.Params_Stream_Type (0); begin
4215 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4216 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4217 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4218 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4220 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4222 -- There are some variations: Do_APC is called for an asynchronous
4223 -- procedure and the part after the call is completely ommitted as
4224 -- well as the declaration of Result. For a function call, 'Input is
4225 -- always used to read the result even if it is constrained.
4227 Stream_Parameter := Make_Temporary (Loc, 'S');
4230 Make_Object_Declaration (Loc,
4231 Defining_Identifier => Stream_Parameter,
4232 Aliased_Present => True,
4233 Object_Definition =>
4234 Make_Subtype_Indication (Loc,
4236 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4238 Make_Index_Or_Discriminant_Constraint (Loc,
4240 New_List (Make_Integer_Literal (Loc, 0))))));
4242 if not Is_Known_Asynchronous then
4243 Result_Parameter := Make_Temporary (Loc, 'R');
4246 Make_Object_Declaration (Loc,
4247 Defining_Identifier => Result_Parameter,
4248 Aliased_Present => True,
4249 Object_Definition =>
4250 Make_Subtype_Indication (Loc,
4252 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4254 Make_Index_Or_Discriminant_Constraint (Loc,
4256 New_List (Make_Integer_Literal (Loc, 0))))));
4258 Exception_Return_Parameter := Make_Temporary (Loc, 'E');
4261 Make_Object_Declaration (Loc,
4262 Defining_Identifier => Exception_Return_Parameter,
4263 Object_Definition =>
4264 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4267 Result_Parameter := Empty;
4268 Exception_Return_Parameter := Empty;
4271 -- Put first the RPC receiver corresponding to the remote package
4273 Append_To (Statements,
4274 Make_Attribute_Reference (Loc,
4276 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4277 Attribute_Name => Name_Write,
4278 Expressions => New_List (
4279 Make_Attribute_Reference (Loc,
4280 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4281 Attribute_Name => Name_Access),
4282 Target_RPC_Receiver)));
4284 -- Then put the Subprogram_Id of the subprogram we want to call in
4287 Append_To (Statements,
4288 Make_Attribute_Reference (Loc,
4289 Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4290 Attribute_Name => Name_Write,
4291 Expressions => New_List (
4292 Make_Attribute_Reference (Loc,
4293 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4294 Attribute_Name => Name_Access),
4297 Current_Parameter := First (Ordered_Parameters_List);
4298 while Present (Current_Parameter) loop
4300 Typ : constant Node_Id :=
4301 Parameter_Type (Current_Parameter);
4303 Constrained : Boolean;
4305 Extra_Parameter : Entity_Id;
4308 if Is_RACW_Controlling_Formal
4309 (Current_Parameter, Stub_Type)
4311 -- In the case of a controlling formal argument, we marshall
4312 -- its addr field rather than the local stub.
4314 Append_To (Statements,
4315 Pack_Node_Into_Stream (Loc,
4316 Stream => Stream_Parameter,
4318 Make_Selected_Component (Loc,
4320 Defining_Identifier (Current_Parameter),
4321 Selector_Name => Name_Addr),
4322 Etyp => RTE (RE_Unsigned_64)));
4327 (Defining_Identifier (Current_Parameter), Loc);
4329 -- Access type parameters are transmitted as in out
4330 -- parameters. However, a dereference is needed so that
4331 -- we marshall the designated object.
4333 if Nkind (Typ) = N_Access_Definition then
4334 Value := Make_Explicit_Dereference (Loc, Value);
4335 Etyp := Etype (Subtype_Mark (Typ));
4337 Etyp := Etype (Typ);
4340 Constrained := not Transmit_As_Unconstrained (Etyp);
4342 -- Any parameter but unconstrained out parameters are
4343 -- transmitted to the peer.
4345 if In_Present (Current_Parameter)
4346 or else not Out_Present (Current_Parameter)
4347 or else not Constrained
4349 Append_To (Statements,
4350 Make_Attribute_Reference (Loc,
4351 Prefix => New_Occurrence_Of (Etyp, Loc),
4353 Output_From_Constrained (Constrained),
4354 Expressions => New_List (
4355 Make_Attribute_Reference (Loc,
4357 New_Occurrence_Of (Stream_Parameter, Loc),
4358 Attribute_Name => Name_Access),
4363 -- If the current parameter has a dynamic constrained status,
4364 -- then this status is transmitted as well.
4365 -- This should be done for accessibility as well ???
4367 if Nkind (Typ) /= N_Access_Definition
4368 and then Need_Extra_Constrained (Current_Parameter)
4370 -- In this block, we do not use the extra formal that has
4371 -- been created because it does not exist at the time of
4372 -- expansion when building calling stubs for remote access
4373 -- to subprogram types. We create an extra variable of this
4374 -- type and push it in the stream after the regular
4377 Extra_Parameter := Make_Temporary (Loc, 'P');
4380 Make_Object_Declaration (Loc,
4381 Defining_Identifier => Extra_Parameter,
4382 Constant_Present => True,
4383 Object_Definition =>
4384 New_Occurrence_Of (Standard_Boolean, Loc),
4386 Make_Attribute_Reference (Loc,
4389 Defining_Identifier (Current_Parameter), Loc),
4390 Attribute_Name => Name_Constrained)));
4392 Append_To (Extra_Formal_Statements,
4393 Make_Attribute_Reference (Loc,
4395 New_Occurrence_Of (Standard_Boolean, Loc),
4396 Attribute_Name => Name_Write,
4397 Expressions => New_List (
4398 Make_Attribute_Reference (Loc,
4401 (Stream_Parameter, Loc), Attribute_Name =>
4403 New_Occurrence_Of (Extra_Parameter, Loc))));
4406 Next (Current_Parameter);
4410 -- Append the formal statements list to the statements
4412 Append_List_To (Statements, Extra_Formal_Statements);
4414 if not Is_Known_Non_Asynchronous then
4416 -- Build the call to System.RPC.Do_APC
4418 Asynchronous_Statements := New_List (
4419 Make_Procedure_Call_Statement (Loc,
4421 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4422 Parameter_Associations => New_List (
4423 New_Occurrence_Of (Target_Partition, Loc),
4424 Make_Attribute_Reference (Loc,
4426 New_Occurrence_Of (Stream_Parameter, Loc),
4427 Attribute_Name => Name_Access))));
4429 Asynchronous_Statements := No_List;
4432 if not Is_Known_Asynchronous then
4434 -- Build the call to System.RPC.Do_RPC
4436 Non_Asynchronous_Statements := New_List (
4437 Make_Procedure_Call_Statement (Loc,
4439 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4440 Parameter_Associations => New_List (
4441 New_Occurrence_Of (Target_Partition, Loc),
4443 Make_Attribute_Reference (Loc,
4445 New_Occurrence_Of (Stream_Parameter, Loc),
4446 Attribute_Name => Name_Access),
4448 Make_Attribute_Reference (Loc,
4450 New_Occurrence_Of (Result_Parameter, Loc),
4451 Attribute_Name => Name_Access))));
4453 -- Read the exception occurrence from the result stream and
4454 -- reraise it. It does no harm if this is a Null_Occurrence since
4455 -- this does nothing.
4457 Append_To (Non_Asynchronous_Statements,
4458 Make_Attribute_Reference (Loc,
4460 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4462 Attribute_Name => Name_Read,
4464 Expressions => New_List (
4465 Make_Attribute_Reference (Loc,
4467 New_Occurrence_Of (Result_Parameter, Loc),
4468 Attribute_Name => Name_Access),
4469 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4471 Append_To (Non_Asynchronous_Statements,
4472 Make_Procedure_Call_Statement (Loc,
4474 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4475 Parameter_Associations => New_List (
4476 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4480 -- If this is a function call, then read the value and return
4481 -- it. The return value is written/read using 'Output/'Input.
4483 Append_To (Non_Asynchronous_Statements,
4484 Make_Tag_Check (Loc,
4485 Make_Simple_Return_Statement (Loc,
4487 Make_Attribute_Reference (Loc,
4490 Etype (Result_Definition (Spec)), Loc),
4492 Attribute_Name => Name_Input,
4494 Expressions => New_List (
4495 Make_Attribute_Reference (Loc,
4497 New_Occurrence_Of (Result_Parameter, Loc),
4498 Attribute_Name => Name_Access))))));
4501 -- Loop around parameters and assign out (or in out)
4502 -- parameters. In the case of RACW, controlling arguments
4503 -- cannot possibly have changed since they are remote, so
4504 -- we do not read them from the stream.
4506 Current_Parameter := First (Ordered_Parameters_List);
4507 while Present (Current_Parameter) loop
4509 Typ : constant Node_Id :=
4510 Parameter_Type (Current_Parameter);
4517 (Defining_Identifier (Current_Parameter), Loc);
4519 if Nkind (Typ) = N_Access_Definition then
4520 Value := Make_Explicit_Dereference (Loc, Value);
4521 Etyp := Etype (Subtype_Mark (Typ));
4523 Etyp := Etype (Typ);
4526 if (Out_Present (Current_Parameter)
4527 or else Nkind (Typ) = N_Access_Definition)
4528 and then Etyp /= Stub_Type
4530 Append_To (Non_Asynchronous_Statements,
4531 Make_Attribute_Reference (Loc,
4533 New_Occurrence_Of (Etyp, Loc),
4535 Attribute_Name => Name_Read,
4537 Expressions => New_List (
4538 Make_Attribute_Reference (Loc,
4540 New_Occurrence_Of (Result_Parameter, Loc),
4541 Attribute_Name => Name_Access),
4546 Next (Current_Parameter);
4551 if Is_Known_Asynchronous then
4552 Append_List_To (Statements, Asynchronous_Statements);
4554 elsif Is_Known_Non_Asynchronous then
4555 Append_List_To (Statements, Non_Asynchronous_Statements);
4558 pragma Assert (Present (Asynchronous));
4559 Prepend_To (Asynchronous_Statements,
4560 Make_Attribute_Reference (Loc,
4561 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4562 Attribute_Name => Name_Write,
4563 Expressions => New_List (
4564 Make_Attribute_Reference (Loc,
4566 New_Occurrence_Of (Stream_Parameter, Loc),
4567 Attribute_Name => Name_Access),
4568 New_Occurrence_Of (Standard_True, Loc))));
4570 Prepend_To (Non_Asynchronous_Statements,
4571 Make_Attribute_Reference (Loc,
4572 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4573 Attribute_Name => Name_Write,
4574 Expressions => New_List (
4575 Make_Attribute_Reference (Loc,
4577 New_Occurrence_Of (Stream_Parameter, Loc),
4578 Attribute_Name => Name_Access),
4579 New_Occurrence_Of (Standard_False, Loc))));
4581 Append_To (Statements,
4582 Make_Implicit_If_Statement (Nod,
4583 Condition => Asynchronous,
4584 Then_Statements => Asynchronous_Statements,
4585 Else_Statements => Non_Asynchronous_Statements));
4587 end Build_General_Calling_Stubs;
4589 -----------------------------
4590 -- Build_RPC_Receiver_Body --
4591 -----------------------------
4593 procedure Build_RPC_Receiver_Body
4594 (RPC_Receiver : Entity_Id;
4595 Request : out Entity_Id;
4596 Subp_Id : out Entity_Id;
4597 Subp_Index : out Entity_Id;
4598 Stmts : out List_Id;
4601 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4603 RPC_Receiver_Spec : Node_Id;
4604 RPC_Receiver_Decls : List_Id;
4607 Request := Make_Defining_Identifier (Loc, Name_R);
4609 RPC_Receiver_Spec :=
4610 Build_RPC_Receiver_Specification
4611 (RPC_Receiver => RPC_Receiver,
4612 Request_Parameter => Request);
4614 Subp_Id := Make_Temporary (Loc, 'P');
4615 Subp_Index := Subp_Id;
4617 -- Subp_Id may not be a constant, because in the case of the RPC
4618 -- receiver for an RCI package, when a call is received from a RAS
4619 -- dereference, it will be assigned during subsequent processing.
4621 RPC_Receiver_Decls := New_List (
4622 Make_Object_Declaration (Loc,
4623 Defining_Identifier => Subp_Id,
4624 Object_Definition =>
4625 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4627 Make_Attribute_Reference (Loc,
4629 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4630 Attribute_Name => Name_Input,
4631 Expressions => New_List (
4632 Make_Selected_Component (Loc,
4634 Selector_Name => Name_Params)))));
4639 Make_Subprogram_Body (Loc,
4640 Specification => RPC_Receiver_Spec,
4641 Declarations => RPC_Receiver_Decls,
4642 Handled_Statement_Sequence =>
4643 Make_Handled_Sequence_Of_Statements (Loc,
4644 Statements => Stmts));
4645 end Build_RPC_Receiver_Body;
4647 -----------------------
4648 -- Build_Stub_Target --
4649 -----------------------
4651 function Build_Stub_Target
4654 RCI_Locator : Entity_Id;
4655 Controlling_Parameter : Entity_Id) return RPC_Target
4657 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4660 Target_Info.Partition := Make_Temporary (Loc, 'P');
4662 if Present (Controlling_Parameter) then
4664 Make_Object_Declaration (Loc,
4665 Defining_Identifier => Target_Info.Partition,
4666 Constant_Present => True,
4667 Object_Definition =>
4668 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4671 Make_Selected_Component (Loc,
4672 Prefix => Controlling_Parameter,
4673 Selector_Name => Name_Origin)));
4675 Target_Info.RPC_Receiver :=
4676 Make_Selected_Component (Loc,
4677 Prefix => Controlling_Parameter,
4678 Selector_Name => Name_Receiver);
4682 Make_Object_Declaration (Loc,
4683 Defining_Identifier => Target_Info.Partition,
4684 Constant_Present => True,
4685 Object_Definition =>
4686 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4689 Make_Function_Call (Loc,
4690 Name => Make_Selected_Component (Loc,
4692 Make_Identifier (Loc, Chars (RCI_Locator)),
4694 Make_Identifier (Loc,
4695 Name_Get_Active_Partition_ID)))));
4697 Target_Info.RPC_Receiver :=
4698 Make_Selected_Component (Loc,
4700 Make_Identifier (Loc, Chars (RCI_Locator)),
4702 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4705 end Build_Stub_Target;
4707 --------------------------------------
4708 -- Build_Subprogram_Receiving_Stubs --
4709 --------------------------------------
4711 function Build_Subprogram_Receiving_Stubs
4712 (Vis_Decl : Node_Id;
4713 Asynchronous : Boolean;
4714 Dynamically_Asynchronous : Boolean := False;
4715 Stub_Type : Entity_Id := Empty;
4716 RACW_Type : Entity_Id := Empty;
4717 Parent_Primitive : Entity_Id := Empty) return Node_Id
4719 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4721 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
4722 -- Formal parameter for receiving stubs: a descriptor for an incoming
4725 Decls : constant List_Id := New_List;
4726 -- All the parameters will get declared before calling the real
4727 -- subprograms. Also the out parameters will be declared.
4729 Statements : constant List_Id := New_List;
4731 Extra_Formal_Statements : constant List_Id := New_List;
4732 -- Statements concerning extra formal parameters
4734 After_Statements : constant List_Id := New_List;
4735 -- Statements to be executed after the subprogram call
4737 Inner_Decls : List_Id := No_List;
4738 -- In case of a function, the inner declarations are needed since
4739 -- the result may be unconstrained.
4741 Excep_Handlers : List_Id := No_List;
4742 Excep_Choice : Entity_Id;
4743 Excep_Code : List_Id;
4745 Parameter_List : constant List_Id := New_List;
4746 -- List of parameters to be passed to the subprogram
4748 Current_Parameter : Node_Id;
4750 Ordered_Parameters_List : constant List_Id :=
4751 Build_Ordered_Parameters_List
4752 (Specification (Vis_Decl));
4754 Subp_Spec : Node_Id;
4755 -- Subprogram specification
4757 Called_Subprogram : Node_Id;
4758 -- The subprogram to call
4760 Null_Raise_Statement : Node_Id;
4762 Dynamic_Async : Entity_Id;
4765 if Present (RACW_Type) then
4766 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4768 Called_Subprogram :=
4770 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4773 if Dynamically_Asynchronous then
4774 Dynamic_Async := Make_Temporary (Loc, 'S');
4776 Dynamic_Async := Empty;
4779 if not Asynchronous or Dynamically_Asynchronous then
4781 -- The first statement after the subprogram call is a statement to
4782 -- write a Null_Occurrence into the result stream.
4784 Null_Raise_Statement :=
4785 Make_Attribute_Reference (Loc,
4787 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4788 Attribute_Name => Name_Write,
4789 Expressions => New_List (
4790 Make_Selected_Component (Loc,
4791 Prefix => Request_Parameter,
4792 Selector_Name => Name_Result),
4793 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4795 if Dynamically_Asynchronous then
4796 Null_Raise_Statement :=
4797 Make_Implicit_If_Statement (Vis_Decl,
4799 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4800 Then_Statements => New_List (Null_Raise_Statement));
4803 Append_To (After_Statements, Null_Raise_Statement);
4806 -- Loop through every parameter and get its value from the stream. If
4807 -- the parameter is unconstrained, then the parameter is read using
4808 -- 'Input at the point of declaration.
4810 Current_Parameter := First (Ordered_Parameters_List);
4811 while Present (Current_Parameter) loop
4814 Constrained : Boolean;
4816 Need_Extra_Constrained : Boolean;
4817 -- True when an Extra_Constrained actual is required
4819 Object : constant Entity_Id := Make_Temporary (Loc, 'P');
4821 Expr : Node_Id := Empty;
4823 Is_Controlling_Formal : constant Boolean :=
4824 Is_RACW_Controlling_Formal
4825 (Current_Parameter, Stub_Type);
4828 if Is_Controlling_Formal then
4830 -- We have a controlling formal parameter. Read its address
4831 -- rather than a real object. The address is in Unsigned_64
4834 Etyp := RTE (RE_Unsigned_64);
4836 Etyp := Etype (Parameter_Type (Current_Parameter));
4839 Constrained := not Transmit_As_Unconstrained (Etyp);
4841 if In_Present (Current_Parameter)
4842 or else not Out_Present (Current_Parameter)
4843 or else not Constrained
4844 or else Is_Controlling_Formal
4846 -- If an input parameter is constrained, then the read of
4847 -- the parameter is deferred until the beginning of the
4848 -- subprogram body. If it is unconstrained, then an
4849 -- expression is built for the object declaration and the
4850 -- variable is set using 'Input instead of 'Read. Note that
4851 -- this deferral does not change the order in which the
4852 -- actuals are read because Build_Ordered_Parameter_List
4853 -- puts them unconstrained first.
4856 Append_To (Statements,
4857 Make_Attribute_Reference (Loc,
4858 Prefix => New_Occurrence_Of (Etyp, Loc),
4859 Attribute_Name => Name_Read,
4860 Expressions => New_List (
4861 Make_Selected_Component (Loc,
4862 Prefix => Request_Parameter,
4863 Selector_Name => Name_Params),
4864 New_Occurrence_Of (Object, Loc))));
4868 -- Build and append Input_With_Tag_Check function
4871 Input_With_Tag_Check (Loc,
4874 Make_Selected_Component (Loc,
4875 Prefix => Request_Parameter,
4876 Selector_Name => Name_Params)));
4878 -- Prepare function call expression
4881 Make_Function_Call (Loc,
4885 (Specification (Last (Decls))), Loc));
4889 Need_Extra_Constrained :=
4890 Nkind (Parameter_Type (Current_Parameter)) /=
4893 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4895 Present (Extra_Constrained
4896 (Defining_Identifier (Current_Parameter)));
4898 -- We may not associate an extra constrained actual to a
4899 -- constant object, so if one is needed, declare the actual
4900 -- as a variable even if it won't be modified.
4902 Build_Actual_Object_Declaration
4905 Variable => Need_Extra_Constrained
4906 or else Out_Present (Current_Parameter),
4910 -- An out parameter may be written back using a 'Write
4911 -- attribute instead of a 'Output because it has been
4912 -- constrained by the parameter given to the caller. Note that
4913 -- out controlling arguments in the case of a RACW are not put
4914 -- back in the stream because the pointer on them has not
4917 if Out_Present (Current_Parameter)
4919 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4921 Append_To (After_Statements,
4922 Make_Attribute_Reference (Loc,
4923 Prefix => New_Occurrence_Of (Etyp, Loc),
4924 Attribute_Name => Name_Write,
4925 Expressions => New_List (
4926 Make_Selected_Component (Loc,
4927 Prefix => Request_Parameter,
4928 Selector_Name => Name_Result),
4929 New_Occurrence_Of (Object, Loc))));
4932 -- For RACW controlling formals, the Etyp of Object is always
4933 -- an RACW, even if the parameter is not of an anonymous access
4934 -- type. In such case, we need to dereference it at call time.
4936 if Is_Controlling_Formal then
4937 if Nkind (Parameter_Type (Current_Parameter)) /=
4940 Append_To (Parameter_List,
4941 Make_Parameter_Association (Loc,
4944 Defining_Identifier (Current_Parameter), Loc),
4945 Explicit_Actual_Parameter =>
4946 Make_Explicit_Dereference (Loc,
4947 Unchecked_Convert_To (RACW_Type,
4948 OK_Convert_To (RTE (RE_Address),
4949 New_Occurrence_Of (Object, Loc))))));
4952 Append_To (Parameter_List,
4953 Make_Parameter_Association (Loc,
4956 Defining_Identifier (Current_Parameter), Loc),
4957 Explicit_Actual_Parameter =>
4958 Unchecked_Convert_To (RACW_Type,
4959 OK_Convert_To (RTE (RE_Address),
4960 New_Occurrence_Of (Object, Loc)))));
4964 Append_To (Parameter_List,
4965 Make_Parameter_Association (Loc,
4968 Defining_Identifier (Current_Parameter), Loc),
4969 Explicit_Actual_Parameter =>
4970 New_Occurrence_Of (Object, Loc)));
4973 -- If the current parameter needs an extra formal, then read it
4974 -- from the stream and set the corresponding semantic field in
4975 -- the variable. If the kind of the parameter identifier is
4976 -- E_Void, then this is a compiler generated parameter that
4977 -- doesn't need an extra constrained status.
4979 -- The case of Extra_Accessibility should also be handled ???
4981 if Need_Extra_Constrained then
4983 Extra_Parameter : constant Entity_Id :=
4985 (Defining_Identifier
4986 (Current_Parameter));
4988 Formal_Entity : constant Entity_Id :=
4989 Make_Defining_Identifier
4990 (Loc, Chars (Extra_Parameter));
4992 Formal_Type : constant Entity_Id :=
4993 Etype (Extra_Parameter);
4997 Make_Object_Declaration (Loc,
4998 Defining_Identifier => Formal_Entity,
4999 Object_Definition =>
5000 New_Occurrence_Of (Formal_Type, Loc)));
5002 Append_To (Extra_Formal_Statements,
5003 Make_Attribute_Reference (Loc,
5004 Prefix => New_Occurrence_Of (
5006 Attribute_Name => Name_Read,
5007 Expressions => New_List (
5008 Make_Selected_Component (Loc,
5009 Prefix => Request_Parameter,
5010 Selector_Name => Name_Params),
5011 New_Occurrence_Of (Formal_Entity, Loc))));
5013 -- Note: the call to Set_Extra_Constrained below relies
5014 -- on the fact that Object's Ekind has been set by
5015 -- Build_Actual_Object_Declaration.
5017 Set_Extra_Constrained (Object, Formal_Entity);
5022 Next (Current_Parameter);
5025 -- Append the formal statements list at the end of regular statements
5027 Append_List_To (Statements, Extra_Formal_Statements);
5029 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
5031 -- The remote subprogram is a function. We build an inner block to
5032 -- be able to hold a potentially unconstrained result in a
5036 Etyp : constant Entity_Id :=
5037 Etype (Result_Definition (Specification (Vis_Decl)));
5038 Result : constant Node_Id := Make_Temporary (Loc, 'R');
5041 Inner_Decls := New_List (
5042 Make_Object_Declaration (Loc,
5043 Defining_Identifier => Result,
5044 Constant_Present => True,
5045 Object_Definition => New_Occurrence_Of (Etyp, Loc),
5047 Make_Function_Call (Loc,
5048 Name => Called_Subprogram,
5049 Parameter_Associations => Parameter_List)));
5051 if Is_Class_Wide_Type (Etyp) then
5053 -- For a remote call to a function with a class-wide type,
5054 -- check that the returned value satisfies the requirements
5057 Append_To (Inner_Decls,
5058 Make_Transportable_Check (Loc,
5059 New_Occurrence_Of (Result, Loc)));
5063 Append_To (After_Statements,
5064 Make_Attribute_Reference (Loc,
5065 Prefix => New_Occurrence_Of (Etyp, Loc),
5066 Attribute_Name => Name_Output,
5067 Expressions => New_List (
5068 Make_Selected_Component (Loc,
5069 Prefix => Request_Parameter,
5070 Selector_Name => Name_Result),
5071 New_Occurrence_Of (Result, Loc))));
5074 Append_To (Statements,
5075 Make_Block_Statement (Loc,
5076 Declarations => Inner_Decls,
5077 Handled_Statement_Sequence =>
5078 Make_Handled_Sequence_Of_Statements (Loc,
5079 Statements => After_Statements)));
5082 -- The remote subprogram is a procedure. We do not need any inner
5083 -- block in this case.
5085 if Dynamically_Asynchronous then
5087 Make_Object_Declaration (Loc,
5088 Defining_Identifier => Dynamic_Async,
5089 Object_Definition =>
5090 New_Occurrence_Of (Standard_Boolean, Loc)));
5092 Append_To (Statements,
5093 Make_Attribute_Reference (Loc,
5094 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5095 Attribute_Name => Name_Read,
5096 Expressions => New_List (
5097 Make_Selected_Component (Loc,
5098 Prefix => Request_Parameter,
5099 Selector_Name => Name_Params),
5100 New_Occurrence_Of (Dynamic_Async, Loc))));
5103 Append_To (Statements,
5104 Make_Procedure_Call_Statement (Loc,
5105 Name => Called_Subprogram,
5106 Parameter_Associations => Parameter_List));
5108 Append_List_To (Statements, After_Statements);
5111 if Asynchronous and then not Dynamically_Asynchronous then
5113 -- For an asynchronous procedure, add a null exception handler
5115 Excep_Handlers := New_List (
5116 Make_Implicit_Exception_Handler (Loc,
5117 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5118 Statements => New_List (Make_Null_Statement (Loc))));
5121 -- In the other cases, if an exception is raised, then the
5122 -- exception occurrence is copied into the output stream and
5123 -- no other output parameter is written.
5125 Excep_Choice := Make_Temporary (Loc, 'E');
5127 Excep_Code := New_List (
5128 Make_Attribute_Reference (Loc,
5130 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5131 Attribute_Name => Name_Write,
5132 Expressions => New_List (
5133 Make_Selected_Component (Loc,
5134 Prefix => Request_Parameter,
5135 Selector_Name => Name_Result),
5136 New_Occurrence_Of (Excep_Choice, Loc))));
5138 if Dynamically_Asynchronous then
5139 Excep_Code := New_List (
5140 Make_Implicit_If_Statement (Vis_Decl,
5141 Condition => Make_Op_Not (Loc,
5142 New_Occurrence_Of (Dynamic_Async, Loc)),
5143 Then_Statements => Excep_Code));
5146 Excep_Handlers := New_List (
5147 Make_Implicit_Exception_Handler (Loc,
5148 Choice_Parameter => Excep_Choice,
5149 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5150 Statements => Excep_Code));
5155 Make_Procedure_Specification (Loc,
5156 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
5158 Parameter_Specifications => New_List (
5159 Make_Parameter_Specification (Loc,
5160 Defining_Identifier => Request_Parameter,
5162 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5165 Make_Subprogram_Body (Loc,
5166 Specification => Subp_Spec,
5167 Declarations => Decls,
5168 Handled_Statement_Sequence =>
5169 Make_Handled_Sequence_Of_Statements (Loc,
5170 Statements => Statements,
5171 Exception_Handlers => Excep_Handlers));
5172 end Build_Subprogram_Receiving_Stubs;
5178 function Result return Node_Id is
5180 return Make_Identifier (Loc, Name_V);
5183 -----------------------
5184 -- RPC_Receiver_Decl --
5185 -----------------------
5187 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is
5188 Loc : constant Source_Ptr := Sloc (RACW_Type);
5189 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5192 -- No RPC receiver for remote access-to-subprogram
5199 Make_Subprogram_Declaration (Loc,
5200 Build_RPC_Receiver_Specification
5201 (RPC_Receiver => Make_Temporary (Loc, 'R'),
5202 Request_Parameter => Make_Defining_Identifier (Loc, Name_R)));
5203 end RPC_Receiver_Decl;
5205 ----------------------
5206 -- Stream_Parameter --
5207 ----------------------
5209 function Stream_Parameter return Node_Id is
5211 return Make_Identifier (Loc, Name_S);
5212 end Stream_Parameter;
5216 -------------------------------
5217 -- Get_And_Reset_RACW_Bodies --
5218 -------------------------------
5220 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5221 Desig : constant Entity_Id :=
5222 Etype (Designated_Type (RACW_Type));
5224 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5226 Body_Decls : List_Id;
5227 -- Returned list of declarations
5230 if Stub_Elements = Empty_Stub_Structure then
5232 -- Stub elements may be missing as a consequence of a previously
5238 Body_Decls := Stub_Elements.Body_Decls;
5239 Stub_Elements.Body_Decls := No_List;
5240 Stubs_Table.Set (Desig, Stub_Elements);
5242 end Get_And_Reset_RACW_Bodies;
5244 -----------------------
5245 -- Get_Stub_Elements --
5246 -----------------------
5248 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is
5249 Desig : constant Entity_Id :=
5250 Etype (Designated_Type (RACW_Type));
5251 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
5253 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5254 return Stub_Elements;
5255 end Get_Stub_Elements;
5257 -----------------------
5258 -- Get_Subprogram_Id --
5259 -----------------------
5261 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5262 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5264 pragma Assert (Result /= No_String);
5266 end Get_Subprogram_Id;
5268 -----------------------
5269 -- Get_Subprogram_Id --
5270 -----------------------
5272 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5274 return Get_Subprogram_Ids (Def).Int_Identifier;
5275 end Get_Subprogram_Id;
5277 ------------------------
5278 -- Get_Subprogram_Ids --
5279 ------------------------
5281 function Get_Subprogram_Ids
5282 (Def : Entity_Id) return Subprogram_Identifiers
5285 return Subprogram_Identifier_Table.Get (Def);
5286 end Get_Subprogram_Ids;
5292 function Hash (F : Entity_Id) return Hash_Index is
5294 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5297 function Hash (F : Name_Id) return Hash_Index is
5299 return Hash_Index (Integer (F) mod Positive (Hash_Index'Last + 1));
5302 --------------------------
5303 -- Input_With_Tag_Check --
5304 --------------------------
5306 function Input_With_Tag_Check
5308 Var_Type : Entity_Id;
5309 Stream : Node_Id) return Node_Id
5313 Make_Subprogram_Body (Loc,
5315 Make_Function_Specification (Loc,
5316 Defining_Unit_Name => Make_Temporary (Loc, 'S'),
5317 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5318 Declarations => No_List,
5319 Handled_Statement_Sequence =>
5320 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5321 Make_Tag_Check (Loc,
5322 Make_Simple_Return_Statement (Loc,
5323 Make_Attribute_Reference (Loc,
5324 Prefix => New_Occurrence_Of (Var_Type, Loc),
5325 Attribute_Name => Name_Input,
5327 New_List (Stream)))))));
5328 end Input_With_Tag_Check;
5330 --------------------------------
5331 -- Is_RACW_Controlling_Formal --
5332 --------------------------------
5334 function Is_RACW_Controlling_Formal
5335 (Parameter : Node_Id;
5336 Stub_Type : Entity_Id) return Boolean
5341 -- If the kind of the parameter is E_Void, then it is not a controlling
5342 -- formal (this can happen in the context of RAS).
5344 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5348 -- If the parameter is not a controlling formal, then it cannot be
5349 -- possibly a RACW_Controlling_Formal.
5351 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5355 Typ := Parameter_Type (Parameter);
5356 return (Nkind (Typ) = N_Access_Definition
5357 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5358 or else Etype (Typ) = Stub_Type;
5359 end Is_RACW_Controlling_Formal;
5361 ------------------------------
5362 -- Make_Transportable_Check --
5363 ------------------------------
5365 function Make_Transportable_Check
5367 Expr : Node_Id) return Node_Id is
5370 Make_Raise_Program_Error (Loc,
5373 Build_Get_Transportable (Loc,
5374 Make_Selected_Component (Loc,
5376 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5377 Reason => PE_Non_Transportable_Actual);
5378 end Make_Transportable_Check;
5380 -----------------------------
5381 -- Make_Selected_Component --
5382 -----------------------------
5384 function Make_Selected_Component
5387 Selector_Name : Name_Id) return Node_Id
5390 return Make_Selected_Component (Loc,
5391 Prefix => New_Occurrence_Of (Prefix, Loc),
5392 Selector_Name => Make_Identifier (Loc, Selector_Name));
5393 end Make_Selected_Component;
5395 --------------------
5396 -- Make_Tag_Check --
5397 --------------------
5399 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5400 Occ : constant Entity_Id := Make_Temporary (Loc, 'E');
5403 return Make_Block_Statement (Loc,
5404 Handled_Statement_Sequence =>
5405 Make_Handled_Sequence_Of_Statements (Loc,
5406 Statements => New_List (N),
5408 Exception_Handlers => New_List (
5409 Make_Implicit_Exception_Handler (Loc,
5410 Choice_Parameter => Occ,
5412 Exception_Choices =>
5413 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5416 New_List (Make_Procedure_Call_Statement (Loc,
5418 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5419 New_List (New_Occurrence_Of (Occ, Loc))))))));
5422 ----------------------------
5423 -- Need_Extra_Constrained --
5424 ----------------------------
5426 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5427 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5429 return Out_Present (Parameter)
5430 and then Has_Discriminants (Etyp)
5431 and then not Is_Constrained (Etyp)
5432 and then Is_Definite_Subtype (Etyp);
5433 end Need_Extra_Constrained;
5435 ------------------------------------
5436 -- Pack_Entity_Into_Stream_Access --
5437 ------------------------------------
5439 function Pack_Entity_Into_Stream_Access
5443 Etyp : Entity_Id := Empty) return Node_Id
5448 if Present (Etyp) then
5451 Typ := Etype (Object);
5455 Pack_Node_Into_Stream_Access (Loc,
5457 Object => New_Occurrence_Of (Object, Loc),
5459 end Pack_Entity_Into_Stream_Access;
5461 ---------------------------
5462 -- Pack_Node_Into_Stream --
5463 ---------------------------
5465 function Pack_Node_Into_Stream
5469 Etyp : Entity_Id) return Node_Id
5471 Write_Attribute : Name_Id := Name_Write;
5474 if not Is_Constrained (Etyp) then
5475 Write_Attribute := Name_Output;
5479 Make_Attribute_Reference (Loc,
5480 Prefix => New_Occurrence_Of (Etyp, Loc),
5481 Attribute_Name => Write_Attribute,
5482 Expressions => New_List (
5483 Make_Attribute_Reference (Loc,
5484 Prefix => New_Occurrence_Of (Stream, Loc),
5485 Attribute_Name => Name_Access),
5487 end Pack_Node_Into_Stream;
5489 ----------------------------------
5490 -- Pack_Node_Into_Stream_Access --
5491 ----------------------------------
5493 function Pack_Node_Into_Stream_Access
5497 Etyp : Entity_Id) return Node_Id
5499 Write_Attribute : Name_Id := Name_Write;
5502 if not Is_Constrained (Etyp) then
5503 Write_Attribute := Name_Output;
5507 Make_Attribute_Reference (Loc,
5508 Prefix => New_Occurrence_Of (Etyp, Loc),
5509 Attribute_Name => Write_Attribute,
5510 Expressions => New_List (
5513 end Pack_Node_Into_Stream_Access;
5515 ---------------------
5516 -- PolyORB_Support --
5517 ---------------------
5519 package body PolyORB_Support is
5521 -- Local subprograms
5523 procedure Add_RACW_Read_Attribute
5524 (RACW_Type : Entity_Id;
5525 Stub_Type : Entity_Id;
5526 Stub_Type_Access : Entity_Id;
5527 Body_Decls : List_Id);
5528 -- Add Read attribute for the RACW type. The declaration and attribute
5529 -- definition clauses are inserted right after the declaration of
5530 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5531 -- appended to it (case where the RACW declaration is in the main unit).
5533 procedure Add_RACW_Write_Attribute
5534 (RACW_Type : Entity_Id;
5535 Stub_Type : Entity_Id;
5536 Stub_Type_Access : Entity_Id;
5537 Body_Decls : List_Id);
5538 -- Same as above for the Write attribute
5540 procedure Add_RACW_From_Any
5541 (RACW_Type : Entity_Id;
5542 Body_Decls : List_Id);
5543 -- Add the From_Any TSS for this RACW type
5545 procedure Add_RACW_To_Any
5546 (RACW_Type : Entity_Id;
5547 Body_Decls : List_Id);
5548 -- Add the To_Any TSS for this RACW type
5550 procedure Add_RACW_TypeCode
5551 (Designated_Type : Entity_Id;
5552 RACW_Type : Entity_Id;
5553 Body_Decls : List_Id);
5554 -- Add the TypeCode TSS for this RACW type
5556 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5557 -- Add the From_Any TSS for this RAS type
5559 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5560 -- Add the To_Any TSS for this RAS type
5562 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5563 -- Add the TypeCode TSS for this RAS type
5565 procedure Add_RAS_Access_TSS (N : Node_Id);
5566 -- Add a subprogram body for RAS Access TSS
5568 -------------------------------------
5569 -- Add_Obj_RPC_Receiver_Completion --
5570 -------------------------------------
5572 procedure Add_Obj_RPC_Receiver_Completion
5575 RPC_Receiver : Entity_Id;
5576 Stub_Elements : Stub_Structure)
5578 Desig : constant Entity_Id :=
5579 Etype (Designated_Type (Stub_Elements.RACW_Type));
5582 Make_Procedure_Call_Statement (Loc,
5585 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5587 Parameter_Associations => New_List (
5591 Make_String_Literal (Loc,
5592 Fully_Qualified_Name_String (Desig, Append_NUL => False)),
5596 Make_Attribute_Reference (Loc,
5599 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5605 Make_Attribute_Reference (Loc,
5608 Defining_Identifier (
5609 Stub_Elements.RPC_Receiver_Decl), Loc),
5612 end Add_Obj_RPC_Receiver_Completion;
5614 -----------------------
5615 -- Add_RACW_Features --
5616 -----------------------
5618 procedure Add_RACW_Features
5619 (RACW_Type : Entity_Id;
5621 Stub_Type : Entity_Id;
5622 Stub_Type_Access : Entity_Id;
5623 RPC_Receiver_Decl : Node_Id;
5624 Body_Decls : List_Id)
5626 pragma Unreferenced (RPC_Receiver_Decl);
5630 (RACW_Type => RACW_Type,
5631 Body_Decls => Body_Decls);
5634 (RACW_Type => RACW_Type,
5635 Body_Decls => Body_Decls);
5637 Add_RACW_Write_Attribute
5638 (RACW_Type => RACW_Type,
5639 Stub_Type => Stub_Type,
5640 Stub_Type_Access => Stub_Type_Access,
5641 Body_Decls => Body_Decls);
5643 Add_RACW_Read_Attribute
5644 (RACW_Type => RACW_Type,
5645 Stub_Type => Stub_Type,
5646 Stub_Type_Access => Stub_Type_Access,
5647 Body_Decls => Body_Decls);
5650 (Designated_Type => Desig,
5651 RACW_Type => RACW_Type,
5652 Body_Decls => Body_Decls);
5653 end Add_RACW_Features;
5655 -----------------------
5656 -- Add_RACW_From_Any --
5657 -----------------------
5659 procedure Add_RACW_From_Any
5660 (RACW_Type : Entity_Id;
5661 Body_Decls : List_Id)
5663 Loc : constant Source_Ptr := Sloc (RACW_Type);
5664 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5665 Fnam : constant Entity_Id :=
5666 Make_Defining_Identifier (Loc,
5667 Chars => New_External_Name (Chars (RACW_Type), 'F'));
5669 Func_Spec : Node_Id;
5670 Func_Decl : Node_Id;
5671 Func_Body : Node_Id;
5673 Statements : List_Id;
5674 -- Various parts of the subprogram
5676 Any_Parameter : constant Entity_Id :=
5677 Make_Defining_Identifier (Loc, Name_A);
5679 Asynchronous_Flag : constant Entity_Id :=
5680 Asynchronous_Flags_Table.Get (RACW_Type);
5681 -- The flag object declared in Add_RACW_Asynchronous_Flag
5685 Make_Function_Specification (Loc,
5686 Defining_Unit_Name =>
5688 Parameter_Specifications => New_List (
5689 Make_Parameter_Specification (Loc,
5690 Defining_Identifier =>
5693 New_Occurrence_Of (RTE (RE_Any), Loc))),
5694 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5696 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5697 -- entity in the declaration spec, not those of the body spec.
5699 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5700 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5701 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5703 if No (Body_Decls) then
5707 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5708 -- set on the stub type if, and only if, the RACW type has a pragma
5709 -- Asynchronous. This is incorrect for RACWs that implement RAS
5710 -- types, because in that case the /designated subprogram/ (not the
5711 -- type) might be asynchronous, and that causes the stub to need to
5712 -- be asynchronous too. A solution is to transport a RAS as a struct
5713 -- containing a RACW and an asynchronous flag, and to properly alter
5714 -- the Asynchronous component in the stub type in the RAS's _From_Any
5717 Statements := New_List (
5718 Make_Simple_Return_Statement (Loc,
5719 Expression => Unchecked_Convert_To (RACW_Type,
5720 Make_Function_Call (Loc,
5721 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5722 Parameter_Associations => New_List (
5723 Make_Function_Call (Loc,
5724 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5725 Parameter_Associations => New_List (
5726 New_Occurrence_Of (Any_Parameter, Loc))),
5727 Build_Stub_Tag (Loc, RACW_Type),
5728 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5729 New_Occurrence_Of (Asynchronous_Flag, Loc))))));
5732 Make_Subprogram_Body (Loc,
5733 Specification => Copy_Specification (Loc, Func_Spec),
5734 Declarations => No_List,
5735 Handled_Statement_Sequence =>
5736 Make_Handled_Sequence_Of_Statements (Loc,
5737 Statements => Statements));
5739 Append_To (Body_Decls, Func_Body);
5740 end Add_RACW_From_Any;
5742 -----------------------------
5743 -- Add_RACW_Read_Attribute --
5744 -----------------------------
5746 procedure Add_RACW_Read_Attribute
5747 (RACW_Type : Entity_Id;
5748 Stub_Type : Entity_Id;
5749 Stub_Type_Access : Entity_Id;
5750 Body_Decls : List_Id)
5752 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5754 Loc : constant Source_Ptr := Sloc (RACW_Type);
5756 Proc_Decl : Node_Id;
5757 Attr_Decl : Node_Id;
5759 Body_Node : Node_Id;
5761 Decls : constant List_Id := New_List;
5762 Statements : constant List_Id := New_List;
5763 Reference : constant Entity_Id :=
5764 Make_Defining_Identifier (Loc, Name_R);
5765 -- Various parts of the procedure
5767 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
5769 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5771 Asynchronous_Flag : constant Entity_Id :=
5772 Asynchronous_Flags_Table.Get (RACW_Type);
5773 pragma Assert (Present (Asynchronous_Flag));
5775 function Stream_Parameter return Node_Id;
5776 function Result return Node_Id;
5778 -- Functions to create occurrences of the formal parameter names
5784 function Result return Node_Id is
5786 return Make_Identifier (Loc, Name_V);
5789 ----------------------
5790 -- Stream_Parameter --
5791 ----------------------
5793 function Stream_Parameter return Node_Id is
5795 return Make_Identifier (Loc, Name_S);
5796 end Stream_Parameter;
5798 -- Start of processing for Add_RACW_Read_Attribute
5801 Build_Stream_Procedure
5802 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
5804 Proc_Decl := Make_Subprogram_Declaration (Loc,
5805 Copy_Specification (Loc, Specification (Body_Node)));
5808 Make_Attribute_Definition_Clause (Loc,
5809 Name => New_Occurrence_Of (RACW_Type, Loc),
5813 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5815 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5816 Insert_After (Proc_Decl, Attr_Decl);
5818 if No (Body_Decls) then
5823 Make_Object_Declaration (Loc,
5824 Defining_Identifier =>
5826 Object_Definition =>
5827 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5829 Append_List_To (Statements, New_List (
5830 Make_Attribute_Reference (Loc,
5832 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5833 Attribute_Name => Name_Read,
5834 Expressions => New_List (
5836 New_Occurrence_Of (Reference, Loc))),
5838 Make_Assignment_Statement (Loc,
5842 Unchecked_Convert_To (RACW_Type,
5843 Make_Function_Call (Loc,
5845 New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5846 Parameter_Associations => New_List (
5847 New_Occurrence_Of (Reference, Loc),
5848 Build_Stub_Tag (Loc, RACW_Type),
5849 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5850 New_Occurrence_Of (Asynchronous_Flag, Loc)))))));
5852 Set_Declarations (Body_Node, Decls);
5853 Append_To (Body_Decls, Body_Node);
5854 end Add_RACW_Read_Attribute;
5856 ---------------------
5857 -- Add_RACW_To_Any --
5858 ---------------------
5860 procedure Add_RACW_To_Any
5861 (RACW_Type : Entity_Id;
5862 Body_Decls : List_Id)
5864 Loc : constant Source_Ptr := Sloc (RACW_Type);
5866 Fnam : constant Entity_Id :=
5867 Make_Defining_Identifier (Loc,
5868 Chars => New_External_Name (Chars (RACW_Type), 'T'));
5870 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5872 Stub_Elements : constant Stub_Structure :=
5873 Get_Stub_Elements (RACW_Type);
5875 Func_Spec : Node_Id;
5876 Func_Decl : Node_Id;
5877 Func_Body : Node_Id;
5880 Statements : List_Id;
5881 -- Various parts of the subprogram
5883 RACW_Parameter : constant Entity_Id :=
5884 Make_Defining_Identifier (Loc, Name_R);
5886 Reference : constant Entity_Id := Make_Temporary (Loc, 'R');
5887 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
5891 Make_Function_Specification (Loc,
5892 Defining_Unit_Name =>
5894 Parameter_Specifications => New_List (
5895 Make_Parameter_Specification (Loc,
5896 Defining_Identifier =>
5899 New_Occurrence_Of (RACW_Type, Loc))),
5900 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5902 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5903 -- entity in the declaration spec, not in the body spec.
5905 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5907 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5908 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5910 if No (Body_Decls) then
5916 -- R : constant Object_Ref :=
5922 -- RPC_Receiver'Access);
5926 Make_Object_Declaration (Loc,
5927 Defining_Identifier => Reference,
5928 Constant_Present => True,
5929 Object_Definition =>
5930 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5932 Make_Function_Call (Loc,
5933 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5934 Parameter_Associations => New_List (
5935 Unchecked_Convert_To (RTE (RE_Address),
5936 New_Occurrence_Of (RACW_Parameter, Loc)),
5937 Make_String_Literal (Loc,
5938 Strval => Fully_Qualified_Name_String
5939 (Etype (Designated_Type (RACW_Type)),
5940 Append_NUL => False)),
5941 Build_Stub_Tag (Loc, RACW_Type),
5942 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5943 Make_Attribute_Reference (Loc,
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 := Make_Temporary (Loc, 'R');
6079 function Stream_Parameter return Node_Id;
6080 function Object return Node_Id;
6081 -- Functions to create occurrences of the formal parameter names
6087 function Object return Node_Id is
6089 return Make_Identifier (Loc, Name_V);
6092 ----------------------
6093 -- Stream_Parameter --
6094 ----------------------
6096 function Stream_Parameter return Node_Id is
6098 return Make_Identifier (Loc, Name_S);
6099 end Stream_Parameter;
6101 -- Start of processing for Add_RACW_Write_Attribute
6104 Build_Stream_Procedure
6105 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
6108 Make_Subprogram_Declaration (Loc,
6109 Copy_Specification (Loc, Specification (Body_Node)));
6112 Make_Attribute_Definition_Clause (Loc,
6113 Name => New_Occurrence_Of (RACW_Type, Loc),
6114 Chars => Name_Write,
6117 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6119 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6120 Insert_After (Proc_Decl, Attr_Decl);
6122 if No (Body_Decls) then
6126 Append_To (Statements,
6127 Pack_Node_Into_Stream_Access (Loc,
6128 Stream => Stream_Parameter,
6130 Make_Function_Call (Loc,
6131 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6132 Parameter_Associations => New_List (
6133 Unchecked_Convert_To (RTE (RE_Address), Object),
6134 Make_String_Literal (Loc,
6135 Strval => Fully_Qualified_Name_String
6136 (Etype (Designated_Type (RACW_Type)),
6137 Append_NUL => False)),
6138 Build_Stub_Tag (Loc, RACW_Type),
6139 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
6140 Make_Attribute_Reference (Loc,
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 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
6237 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
6238 -- Additional local variables for the remote case
6241 (Field_Name : Name_Id;
6242 Value : Node_Id) return Node_Id;
6243 -- Construct an assignment that sets the named component in the
6251 (Field_Name : Name_Id;
6252 Value : Node_Id) return Node_Id
6256 Make_Assignment_Statement (Loc,
6258 Make_Selected_Component (Loc,
6260 Selector_Name => Field_Name),
6261 Expression => Value);
6264 -- Start of processing for Add_RAS_Access_TSS
6267 Proc_Decls := New_List (
6269 -- Common declarations
6271 Make_Object_Declaration (Loc,
6272 Defining_Identifier => Subp_Ref,
6273 Object_Definition =>
6274 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6276 Make_Object_Declaration (Loc,
6277 Defining_Identifier => Is_Local,
6278 Object_Definition =>
6279 New_Occurrence_Of (Standard_Boolean, Loc)),
6281 Make_Object_Declaration (Loc,
6282 Defining_Identifier => Local_Addr,
6283 Object_Definition =>
6284 New_Occurrence_Of (RTE (RE_Address), Loc)),
6286 Make_Object_Declaration (Loc,
6287 Defining_Identifier => Local_Stub,
6288 Aliased_Present => True,
6289 Object_Definition =>
6290 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6292 Make_Object_Declaration (Loc,
6293 Defining_Identifier => Stub_Ptr,
6294 Object_Definition =>
6295 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6297 Make_Attribute_Reference (Loc,
6298 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6299 Attribute_Name => Name_Unchecked_Access)));
6301 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6302 -- Build_Get_Unique_RP_Call needs this information
6304 -- Get_RAS_Info (Pkg, Subp, R);
6305 -- Obtain a reference to the target subprogram
6307 Proc_Statements := New_List (
6308 Make_Procedure_Call_Statement (Loc,
6309 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6310 Parameter_Associations => New_List (
6311 New_Occurrence_Of (Package_Name, Loc),
6312 New_Occurrence_Of (Subp_Id, Loc),
6313 New_Occurrence_Of (Subp_Ref, Loc))),
6315 -- Get_Local_Address (R, L, A);
6316 -- Determine whether the subprogram is local (L), and if so
6317 -- obtain the local address of its proxy (A).
6319 Make_Procedure_Call_Statement (Loc,
6320 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6321 Parameter_Associations => New_List (
6322 New_Occurrence_Of (Subp_Ref, Loc),
6323 New_Occurrence_Of (Is_Local, Loc),
6324 New_Occurrence_Of (Local_Addr, Loc))));
6326 -- Note: Here we assume that the Fat_Type is a record containing just
6327 -- an access to a proxy or stub object.
6329 Append_To (Proc_Statements,
6333 Make_Implicit_If_Statement (N,
6334 Condition => New_Occurrence_Of (Is_Local, Loc),
6336 Then_Statements => New_List (
6338 -- if A.Target = null then
6340 Make_Implicit_If_Statement (N,
6343 Make_Selected_Component (Loc,
6345 Unchecked_Convert_To
6346 (RTE (RE_RAS_Proxy_Type_Access),
6347 New_Occurrence_Of (Local_Addr, Loc)),
6348 Selector_Name => Make_Identifier (Loc, Name_Target)),
6351 Then_Statements => New_List (
6353 -- A.Target := Entity_Of (Ref);
6355 Make_Assignment_Statement (Loc,
6357 Make_Selected_Component (Loc,
6359 Unchecked_Convert_To
6360 (RTE (RE_RAS_Proxy_Type_Access),
6361 New_Occurrence_Of (Local_Addr, Loc)),
6362 Selector_Name => Make_Identifier (Loc, Name_Target)),
6364 Make_Function_Call (Loc,
6365 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6366 Parameter_Associations => New_List (
6367 New_Occurrence_Of (Subp_Ref, Loc)))),
6369 -- Inc_Usage (A.Target);
6372 Make_Procedure_Call_Statement (Loc,
6373 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6374 Parameter_Associations => New_List (
6375 Make_Selected_Component (Loc,
6377 Unchecked_Convert_To
6378 (RTE (RE_RAS_Proxy_Type_Access),
6379 New_Occurrence_Of (Local_Addr, Loc)),
6381 Make_Identifier (Loc, Name_Target)))))),
6383 -- if not All_Calls_Remote then
6384 -- return Fat_Type!(A);
6387 Make_Implicit_If_Statement (N,
6391 New_Occurrence_Of (All_Calls_Remote, Loc)),
6393 Then_Statements => New_List (
6394 Make_Simple_Return_Statement (Loc,
6396 Unchecked_Convert_To
6397 (Fat_Type, New_Occurrence_Of (Local_Addr, Loc))))))));
6399 Append_List_To (Proc_Statements, New_List (
6401 -- Stub.Target := Entity_Of (Ref);
6403 Set_Field (Name_Target,
6404 Make_Function_Call (Loc,
6405 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6406 Parameter_Associations => New_List (
6407 New_Occurrence_Of (Subp_Ref, Loc)))),
6409 -- Inc_Usage (Stub.Target);
6411 Make_Procedure_Call_Statement (Loc,
6412 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6413 Parameter_Associations => New_List (
6414 Make_Selected_Component (Loc,
6416 Selector_Name => Name_Target))),
6418 -- E.4.1(9) A remote call is asynchronous if it is a call to
6419 -- a procedure, or a call through a value of an access-to-procedure
6420 -- type, to which a pragma Asynchronous applies.
6422 -- Parameter Asynch_P is true when the procedure is asynchronous;
6423 -- Expression Asynch_T is true when the type is asynchronous.
6425 Set_Field (Name_Asynchronous,
6427 Left_Opnd => New_Occurrence_Of (Asynch_P, Loc),
6430 (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc)))));
6432 Append_List_To (Proc_Statements,
6433 Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
6435 Append_To (Proc_Statements,
6436 Make_Simple_Return_Statement (Loc,
6438 Unchecked_Convert_To (Fat_Type,
6439 New_Occurrence_Of (Stub_Ptr, Loc))));
6442 Make_Function_Specification (Loc,
6443 Defining_Unit_Name => Proc,
6444 Parameter_Specifications => New_List (
6445 Make_Parameter_Specification (Loc,
6446 Defining_Identifier => Package_Name,
6448 New_Occurrence_Of (Standard_String, Loc)),
6450 Make_Parameter_Specification (Loc,
6451 Defining_Identifier => Subp_Id,
6453 New_Occurrence_Of (Standard_String, Loc)),
6455 Make_Parameter_Specification (Loc,
6456 Defining_Identifier => Asynch_P,
6458 New_Occurrence_Of (Standard_Boolean, Loc)),
6460 Make_Parameter_Specification (Loc,
6461 Defining_Identifier => All_Calls_Remote,
6463 New_Occurrence_Of (Standard_Boolean, Loc))),
6465 Result_Definition =>
6466 New_Occurrence_Of (Fat_Type, Loc));
6468 -- Set the kind and return type of the function to prevent
6469 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6471 Set_Ekind (Proc, E_Function);
6472 Set_Etype (Proc, Fat_Type);
6475 Make_Subprogram_Body (Loc,
6476 Specification => Proc_Spec,
6477 Declarations => Proc_Decls,
6478 Handled_Statement_Sequence =>
6479 Make_Handled_Sequence_Of_Statements (Loc,
6480 Statements => Proc_Statements)));
6482 Set_TSS (Fat_Type, Proc);
6483 end Add_RAS_Access_TSS;
6485 ----------------------
6486 -- Add_RAS_From_Any --
6487 ----------------------
6489 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6490 Loc : constant Source_Ptr := Sloc (RAS_Type);
6492 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6493 Make_TSS_Name (RAS_Type, TSS_From_Any));
6495 Func_Spec : Node_Id;
6497 Statements : List_Id;
6499 Any_Parameter : constant Entity_Id :=
6500 Make_Defining_Identifier (Loc, Name_A);
6503 Statements := New_List (
6504 Make_Simple_Return_Statement (Loc,
6506 Make_Aggregate (Loc,
6507 Component_Associations => New_List (
6508 Make_Component_Association (Loc,
6509 Choices => New_List (Make_Identifier (Loc, Name_Ras)),
6511 PolyORB_Support.Helpers.Build_From_Any_Call
6512 (Underlying_RACW_Type (RAS_Type),
6513 New_Occurrence_Of (Any_Parameter, Loc),
6517 Make_Function_Specification (Loc,
6518 Defining_Unit_Name => Fnam,
6519 Parameter_Specifications => New_List (
6520 Make_Parameter_Specification (Loc,
6521 Defining_Identifier => Any_Parameter,
6522 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
6523 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6526 Make_Subprogram_Body (Loc,
6527 Specification => Func_Spec,
6528 Declarations => No_List,
6529 Handled_Statement_Sequence =>
6530 Make_Handled_Sequence_Of_Statements (Loc,
6531 Statements => Statements)));
6532 Set_TSS (RAS_Type, Fnam);
6533 end Add_RAS_From_Any;
6535 --------------------
6536 -- Add_RAS_To_Any --
6537 --------------------
6539 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6540 Loc : constant Source_Ptr := Sloc (RAS_Type);
6542 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6543 Make_TSS_Name (RAS_Type, TSS_To_Any));
6546 Statements : List_Id;
6548 Func_Spec : Node_Id;
6550 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
6551 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
6552 RACW_Parameter : constant Node_Id :=
6553 Make_Selected_Component (Loc,
6554 Prefix => RAS_Parameter,
6555 Selector_Name => Name_Ras);
6558 -- Object declarations
6560 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6562 Make_Object_Declaration (Loc,
6563 Defining_Identifier => Any,
6564 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc),
6566 PolyORB_Support.Helpers.Build_To_Any_Call
6567 (Loc, RACW_Parameter, No_List)));
6569 Statements := New_List (
6570 Make_Procedure_Call_Statement (Loc,
6571 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6572 Parameter_Associations => New_List (
6573 New_Occurrence_Of (Any, Loc),
6574 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6577 Make_Simple_Return_Statement (Loc,
6578 Expression => New_Occurrence_Of (Any, Loc)));
6581 Make_Function_Specification (Loc,
6582 Defining_Unit_Name => Fnam,
6583 Parameter_Specifications => New_List (
6584 Make_Parameter_Specification (Loc,
6585 Defining_Identifier => RAS_Parameter,
6586 Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))),
6587 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6590 Make_Subprogram_Body (Loc,
6591 Specification => Func_Spec,
6592 Declarations => Decls,
6593 Handled_Statement_Sequence =>
6594 Make_Handled_Sequence_Of_Statements (Loc,
6595 Statements => Statements)));
6596 Set_TSS (RAS_Type, Fnam);
6599 ----------------------
6600 -- Add_RAS_TypeCode --
6601 ----------------------
6603 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6604 Loc : constant Source_Ptr := Sloc (RAS_Type);
6606 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6607 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6609 Func_Spec : Node_Id;
6610 Decls : constant List_Id := New_List;
6611 Name_String : String_Id;
6612 Repo_Id_String : String_Id;
6616 Make_Function_Specification (Loc,
6617 Defining_Unit_Name => Fnam,
6618 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6620 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6621 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6624 Make_Subprogram_Body (Loc,
6625 Specification => Func_Spec,
6626 Declarations => Decls,
6627 Handled_Statement_Sequence =>
6628 Make_Handled_Sequence_Of_Statements (Loc,
6629 Statements => New_List (
6630 Make_Simple_Return_Statement (Loc,
6632 Make_Function_Call (Loc,
6634 New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc),
6635 Parameter_Associations => New_List (
6636 New_Occurrence_Of (RTE (RE_Tk_Objref), Loc),
6637 Make_Aggregate (Loc,
6640 Make_Function_Call (Loc,
6643 (RTE (RE_TA_Std_String), Loc),
6644 Parameter_Associations => New_List (
6645 Make_String_Literal (Loc, Name_String))),
6646 Make_Function_Call (Loc,
6649 (RTE (RE_TA_Std_String), Loc),
6650 Parameter_Associations => New_List (
6651 Make_String_Literal (Loc,
6652 Strval => Repo_Id_String))))))))))));
6653 Set_TSS (RAS_Type, Fnam);
6654 end Add_RAS_TypeCode;
6656 -----------------------------------------
6657 -- Add_Receiving_Stubs_To_Declarations --
6658 -----------------------------------------
6660 procedure Add_Receiving_Stubs_To_Declarations
6661 (Pkg_Spec : Node_Id;
6665 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6667 Pkg_RPC_Receiver : constant Entity_Id :=
6668 Make_Temporary (Loc, 'H');
6669 Pkg_RPC_Receiver_Object : Node_Id;
6670 Pkg_RPC_Receiver_Body : Node_Id;
6671 Pkg_RPC_Receiver_Decls : List_Id;
6672 Pkg_RPC_Receiver_Statements : List_Id;
6674 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6675 -- A Pkg_RPC_Receiver is built to decode the request
6678 -- Request object received from neutral layer
6680 Subp_Id : Entity_Id;
6681 -- Subprogram identifier as received from the neutral distribution
6684 Subp_Index : Entity_Id;
6685 -- Internal index as determined by matching either the method name
6686 -- from the request structure, or the local subprogram address (in
6689 Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L');
6691 Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A');
6692 -- Address of a local subprogram designated by a reference
6693 -- corresponding to a RAS.
6695 Dispatch_On_Address : constant List_Id := New_List;
6696 Dispatch_On_Name : constant List_Id := New_List;
6698 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
6700 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
6701 Subp_Info_List : constant List_Id := New_List;
6703 Register_Pkg_Actuals : constant List_Id := New_List;
6705 All_Calls_Remote_E : Entity_Id;
6707 procedure Append_Stubs_To
6708 (RPC_Receiver_Cases : List_Id;
6709 Declaration : Node_Id;
6712 Subp_Dist_Name : Entity_Id;
6713 Subp_Proxy_Addr : Entity_Id);
6714 -- Add one case to the specified RPC receiver case list associating
6715 -- Subprogram_Number with the subprogram declared by Declaration, for
6716 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6717 -- subprogram index. Subp_Dist_Name is the string used to call the
6718 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6719 -- object, used in the context of calls through remote
6720 -- access-to-subprogram types.
6722 procedure Visit_Subprogram (Decl : Node_Id);
6723 -- Generate receiving stub for one remote subprogram
6725 ---------------------
6726 -- Append_Stubs_To --
6727 ---------------------
6729 procedure Append_Stubs_To
6730 (RPC_Receiver_Cases : List_Id;
6731 Declaration : Node_Id;
6734 Subp_Dist_Name : Entity_Id;
6735 Subp_Proxy_Addr : Entity_Id)
6737 Case_Stmts : List_Id;
6739 Case_Stmts := New_List (
6740 Make_Procedure_Call_Statement (Loc,
6743 Defining_Entity (Stubs), Loc),
6744 Parameter_Associations =>
6745 New_List (New_Occurrence_Of (Request, Loc))));
6747 if Nkind (Specification (Declaration)) = N_Function_Specification
6749 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6751 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6754 Append_To (RPC_Receiver_Cases,
6755 Make_Case_Statement_Alternative (Loc,
6757 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6758 Statements => Case_Stmts));
6760 Append_To (Dispatch_On_Name,
6761 Make_Elsif_Part (Loc,
6763 Make_Function_Call (Loc,
6765 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6766 Parameter_Associations => New_List (
6767 New_Occurrence_Of (Subp_Id, Loc),
6768 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6770 Then_Statements => New_List (
6771 Make_Assignment_Statement (Loc,
6772 New_Occurrence_Of (Subp_Index, Loc),
6773 Make_Integer_Literal (Loc, Subp_Number)))));
6775 Append_To (Dispatch_On_Address,
6776 Make_Elsif_Part (Loc,
6779 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6780 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6782 Then_Statements => New_List (
6783 Make_Assignment_Statement (Loc,
6784 New_Occurrence_Of (Subp_Index, Loc),
6785 Make_Integer_Literal (Loc, Subp_Number)))));
6786 end Append_Stubs_To;
6788 ----------------------
6789 -- Visit_Subprogram --
6790 ----------------------
6792 procedure Visit_Subprogram (Decl : Node_Id) is
6793 Loc : constant Source_Ptr := Sloc (Decl);
6794 Spec : constant Node_Id := Specification (Decl);
6795 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
6797 Subp_Val : String_Id;
6799 Subp_Dist_Name : constant Entity_Id :=
6800 Make_Defining_Identifier (Loc,
6803 (Related_Id => Chars (Subp_Def),
6805 Suffix_Index => -1));
6807 Current_Stubs : Node_Id;
6808 Proxy_Obj_Addr : Entity_Id;
6811 -- Disable expansion of stubs if serious errors have been
6812 -- diagnosed, because otherwise some illegal remote subprogram
6813 -- declarations could cause cascaded errors in stubs.
6815 if Serious_Errors_Detected /= 0 then
6819 -- Build receiving stub
6822 Build_Subprogram_Receiving_Stubs
6824 Asynchronous => Nkind (Spec) = N_Procedure_Specification
6825 and then Is_Asynchronous (Subp_Def));
6827 Append_To (Decls, Current_Stubs);
6828 Analyze (Current_Stubs);
6832 Add_RAS_Proxy_And_Analyze (Decls,
6834 All_Calls_Remote_E => All_Calls_Remote_E,
6835 Proxy_Object_Addr => Proxy_Obj_Addr);
6837 -- Compute distribution identifier
6839 Assign_Subprogram_Identifier
6840 (Subp_Def, Current_Subp_Number, Subp_Val);
6843 (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
6846 Make_Object_Declaration (Loc,
6847 Defining_Identifier => Subp_Dist_Name,
6848 Constant_Present => True,
6849 Object_Definition =>
6850 New_Occurrence_Of (Standard_String, Loc),
6852 Make_String_Literal (Loc, Subp_Val)));
6853 Analyze (Last (Decls));
6855 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
6856 -- table for this receiver. The aggregate below must be kept
6857 -- consistent with the declaration of RCI_Subp_Info in
6858 -- System.Partition_Interface.
6860 Append_To (Subp_Info_List,
6861 Make_Component_Association (Loc,
6863 New_List (Make_Integer_Literal (Loc, Current_Subp_Number)),
6866 Make_Aggregate (Loc,
6867 Expressions => New_List (
6871 Make_Attribute_Reference (Loc,
6873 New_Occurrence_Of (Subp_Dist_Name, Loc),
6874 Attribute_Name => Name_Address),
6878 Make_Attribute_Reference (Loc,
6880 New_Occurrence_Of (Subp_Dist_Name, Loc),
6881 Attribute_Name => Name_Length),
6885 New_Occurrence_Of (Proxy_Obj_Addr, Loc)))));
6887 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6888 Declaration => Decl,
6889 Stubs => Current_Stubs,
6890 Subp_Number => Current_Subp_Number,
6891 Subp_Dist_Name => Subp_Dist_Name,
6892 Subp_Proxy_Addr => Proxy_Obj_Addr);
6894 Current_Subp_Number := Current_Subp_Number + 1;
6895 end Visit_Subprogram;
6897 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
6899 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6902 -- Building receiving stubs consist in several operations:
6904 -- - a package RPC receiver must be built. This subprogram will get
6905 -- a Subprogram_Id from the incoming stream and will dispatch the
6906 -- call to the right subprogram;
6908 -- - a receiving stub for each subprogram visible in the package
6909 -- spec. This stub will read all the parameters from the stream,
6910 -- and put the result as well as the exception occurrence in the
6913 Build_RPC_Receiver_Body (
6914 RPC_Receiver => Pkg_RPC_Receiver,
6917 Subp_Index => Subp_Index,
6918 Stmts => Pkg_RPC_Receiver_Statements,
6919 Decl => Pkg_RPC_Receiver_Body);
6920 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6922 -- Extract local address information from the target reference:
6923 -- if non-null, that means that this is a reference that denotes
6924 -- one particular operation, and hence that the operation name
6925 -- must not be taken into account for dispatching.
6927 Append_To (Pkg_RPC_Receiver_Decls,
6928 Make_Object_Declaration (Loc,
6929 Defining_Identifier => Is_Local,
6930 Object_Definition =>
6931 New_Occurrence_Of (Standard_Boolean, Loc)));
6933 Append_To (Pkg_RPC_Receiver_Decls,
6934 Make_Object_Declaration (Loc,
6935 Defining_Identifier => Local_Address,
6936 Object_Definition =>
6937 New_Occurrence_Of (RTE (RE_Address), Loc)));
6939 Append_To (Pkg_RPC_Receiver_Statements,
6940 Make_Procedure_Call_Statement (Loc,
6941 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6942 Parameter_Associations => New_List (
6943 Make_Selected_Component (Loc,
6945 Selector_Name => Name_Target),
6946 New_Occurrence_Of (Is_Local, Loc),
6947 New_Occurrence_Of (Local_Address, Loc))));
6949 -- For each subprogram, the receiving stub will be built and a case
6950 -- statement will be made on the Subprogram_Id to dispatch to the
6951 -- right subprogram.
6953 All_Calls_Remote_E := Boolean_Literals (
6954 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6956 Overload_Counter_Table.Reset;
6957 Reserve_NamingContext_Methods;
6959 Visit_Spec (Pkg_Spec);
6962 Make_Object_Declaration (Loc,
6963 Defining_Identifier => Subp_Info_Array,
6964 Constant_Present => True,
6965 Aliased_Present => True,
6966 Object_Definition =>
6967 Make_Subtype_Indication (Loc,
6969 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6971 Make_Index_Or_Discriminant_Constraint (Loc,
6975 Make_Integer_Literal (Loc,
6976 Intval => First_RCI_Subprogram_Id),
6978 Make_Integer_Literal (Loc,
6980 First_RCI_Subprogram_Id
6981 + List_Length (Subp_Info_List) - 1)))))));
6983 if Present (First (Subp_Info_List)) then
6984 Set_Expression (Last (Decls),
6985 Make_Aggregate (Loc,
6986 Component_Associations => Subp_Info_List));
6988 -- Generate the dispatch statement to determine the subprogram id
6989 -- of the called subprogram.
6991 -- We first test whether the reference that was used to make the
6992 -- call was the base RCI reference (in which case Local_Address is
6993 -- zero, and the method identifier from the request must be used
6994 -- to determine which subprogram is called) or a reference
6995 -- identifying one particular subprogram (in which case
6996 -- Local_Address is the address of that subprogram, and the
6997 -- method name from the request is ignored). The latter occurs
6998 -- for the case of a call through a remote access-to-subprogram.
7000 -- In each case, cascaded elsifs are used to determine the proper
7001 -- subprogram index. Using hash tables might be more efficient.
7003 Append_To (Pkg_RPC_Receiver_Statements,
7004 Make_Implicit_If_Statement (Pkg_Spec,
7007 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
7008 Right_Opnd => New_Occurrence_Of
7009 (RTE (RE_Null_Address), Loc)),
7011 Then_Statements => New_List (
7012 Make_Implicit_If_Statement (Pkg_Spec,
7013 Condition => New_Occurrence_Of (Standard_False, Loc),
7014 Then_Statements => New_List (
7015 Make_Null_Statement (Loc)),
7016 Elsif_Parts => Dispatch_On_Address)),
7018 Else_Statements => New_List (
7019 Make_Implicit_If_Statement (Pkg_Spec,
7020 Condition => New_Occurrence_Of (Standard_False, Loc),
7021 Then_Statements => New_List (Make_Null_Statement (Loc)),
7022 Elsif_Parts => Dispatch_On_Name))));
7025 -- For a degenerate RCI with no visible subprograms,
7026 -- Subp_Info_List has zero length, and the declaration is for an
7027 -- empty array, in which case no initialization aggregate must be
7028 -- generated. We do not generate a Dispatch_Statement either.
7030 -- No initialization provided: remove CONSTANT so that the
7031 -- declaration is not an incomplete deferred constant.
7033 Set_Constant_Present (Last (Decls), False);
7036 -- Analyze Subp_Info_Array declaration
7038 Analyze (Last (Decls));
7040 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7041 -- rather than raising an exception since we do not want someone
7042 -- to crash a remote partition by sending invalid subprogram ids.
7043 -- This is consistent with the other parts of the case statement
7044 -- since even in presence of incorrect parameters in the stream,
7045 -- every exception will be caught and (if the subprogram is not an
7046 -- APC) put into the result stream and sent away.
7048 Append_To (Pkg_RPC_Receiver_Cases,
7049 Make_Case_Statement_Alternative (Loc,
7050 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
7051 Statements => New_List (Make_Null_Statement (Loc))));
7053 Append_To (Pkg_RPC_Receiver_Statements,
7054 Make_Case_Statement (Loc,
7055 Expression => New_Occurrence_Of (Subp_Index, Loc),
7056 Alternatives => Pkg_RPC_Receiver_Cases));
7058 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7061 Append_To (Decls, Pkg_RPC_Receiver_Body);
7062 Analyze (Last (Decls));
7064 Pkg_RPC_Receiver_Object :=
7065 Make_Object_Declaration (Loc,
7066 Defining_Identifier => Make_Temporary (Loc, 'R'),
7067 Aliased_Present => True,
7068 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
7069 Append_To (Decls, Pkg_RPC_Receiver_Object);
7070 Analyze (Last (Decls));
7074 Append_To (Register_Pkg_Actuals,
7075 Make_String_Literal (Loc,
7077 Fully_Qualified_Name_String
7078 (Defining_Entity (Pkg_Spec), Append_NUL => False)));
7082 Append_To (Register_Pkg_Actuals,
7083 Make_Attribute_Reference (Loc,
7086 (Defining_Entity (Pkg_Spec), Loc),
7087 Attribute_Name => Name_Version));
7091 Append_To (Register_Pkg_Actuals,
7092 Make_Attribute_Reference (Loc,
7094 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7095 Attribute_Name => Name_Access));
7099 Append_To (Register_Pkg_Actuals,
7100 Make_Attribute_Reference (Loc,
7103 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc),
7104 Attribute_Name => Name_Access));
7108 Append_To (Register_Pkg_Actuals,
7109 Make_Attribute_Reference (Loc,
7110 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7111 Attribute_Name => Name_Address));
7115 Append_To (Register_Pkg_Actuals,
7116 Make_Attribute_Reference (Loc,
7117 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7118 Attribute_Name => Name_Length));
7120 -- Is_All_Calls_Remote
7122 Append_To (Register_Pkg_Actuals,
7123 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7125 -- Finally call Register_Pkg_Receiving_Stub with the above parameters
7128 Make_Procedure_Call_Statement (Loc,
7130 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7131 Parameter_Associations => Register_Pkg_Actuals));
7132 Analyze (Last (Stmts));
7133 end Add_Receiving_Stubs_To_Declarations;
7135 ---------------------------------
7136 -- Build_General_Calling_Stubs --
7137 ---------------------------------
7139 procedure Build_General_Calling_Stubs
7141 Statements : List_Id;
7142 Target_Object : Node_Id;
7143 Subprogram_Id : Node_Id;
7144 Asynchronous : Node_Id := Empty;
7145 Is_Known_Asynchronous : Boolean := False;
7146 Is_Known_Non_Asynchronous : Boolean := False;
7147 Is_Function : Boolean;
7149 Stub_Type : Entity_Id := Empty;
7150 RACW_Type : Entity_Id := Empty;
7153 Loc : constant Source_Ptr := Sloc (Nod);
7155 Request : constant Entity_Id := Make_Temporary (Loc, 'R');
7156 -- The request object constructed by these stubs
7157 -- Could we use Name_R instead??? (see GLADE client stubs)
7159 function Make_Request_RTE_Call
7161 Actuals : List_Id := New_List) return Node_Id;
7162 -- Generate a procedure call statement calling RE with the given
7163 -- actuals. Request'Access is appended to the list.
7165 ---------------------------
7166 -- Make_Request_RTE_Call --
7167 ---------------------------
7169 function Make_Request_RTE_Call
7171 Actuals : List_Id := New_List) return Node_Id
7175 Make_Attribute_Reference (Loc,
7176 Prefix => New_Occurrence_Of (Request, Loc),
7177 Attribute_Name => Name_Access));
7178 return Make_Procedure_Call_Statement (Loc,
7180 New_Occurrence_Of (RTE (RE), Loc),
7181 Parameter_Associations => Actuals);
7182 end Make_Request_RTE_Call;
7184 Arguments : Node_Id;
7185 -- Name of the named values list used to transmit parameters
7186 -- to the remote package
7189 -- Name of the result named value (in non-APC cases) which get the
7190 -- result of the remote subprogram.
7192 Result_TC : Node_Id;
7193 -- Typecode expression for the result of the request (void
7194 -- typecode for procedures).
7196 Exception_Return_Parameter : Node_Id;
7197 -- Name of the parameter which will hold the exception sent by the
7198 -- remote subprogram.
7200 Current_Parameter : Node_Id;
7201 -- Current parameter being handled
7203 Ordered_Parameters_List : constant List_Id :=
7204 Build_Ordered_Parameters_List (Spec);
7206 Asynchronous_P : Node_Id;
7207 -- A Boolean expression indicating whether this call is asynchronous
7209 Asynchronous_Statements : List_Id := No_List;
7210 Non_Asynchronous_Statements : List_Id := No_List;
7211 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7213 Extra_Formal_Statements : constant List_Id := New_List;
7214 -- List of statements for extra formal parameters. It will appear
7215 -- after the regular statements for writing out parameters.
7217 After_Statements : constant List_Id := New_List;
7218 -- Statements to be executed after call returns (to assign IN OUT or
7219 -- OUT parameter values).
7222 -- The type of the formal parameter being processed
7224 Is_Controlling_Formal : Boolean;
7225 Is_First_Controlling_Formal : Boolean;
7226 First_Controlling_Formal_Seen : Boolean := False;
7227 -- Controlling formal parameters of distributed object primitives
7228 -- require special handling, and the first such parameter needs even
7229 -- more special handling.
7232 -- ??? document general form of stub subprograms for the PolyORB case
7235 Make_Object_Declaration (Loc,
7236 Defining_Identifier => Request,
7237 Aliased_Present => True,
7238 Object_Definition =>
7239 New_Occurrence_Of (RTE (RE_Request), Loc)));
7241 Result := Make_Temporary (Loc, 'R');
7245 PolyORB_Support.Helpers.Build_TypeCode_Call
7246 (Loc, Etype (Result_Definition (Spec)), Decls);
7248 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7252 Make_Object_Declaration (Loc,
7253 Defining_Identifier => Result,
7254 Aliased_Present => False,
7255 Object_Definition =>
7256 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7258 Make_Aggregate (Loc,
7259 Component_Associations => New_List (
7260 Make_Component_Association (Loc,
7261 Choices => New_List (Make_Identifier (Loc, Name_Name)),
7263 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7264 Make_Component_Association (Loc,
7265 Choices => New_List (
7266 Make_Identifier (Loc, Name_Argument)),
7268 Make_Function_Call (Loc,
7269 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7270 Parameter_Associations => New_List (Result_TC))),
7271 Make_Component_Association (Loc,
7272 Choices => New_List (
7273 Make_Identifier (Loc, Name_Arg_Modes)),
7274 Expression => Make_Integer_Literal (Loc, 0))))));
7276 if not Is_Known_Asynchronous then
7277 Exception_Return_Parameter := Make_Temporary (Loc, 'E');
7280 Make_Object_Declaration (Loc,
7281 Defining_Identifier => Exception_Return_Parameter,
7282 Object_Definition =>
7283 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7286 Exception_Return_Parameter := Empty;
7289 -- Initialize and fill in arguments list
7291 Arguments := Make_Temporary (Loc, 'A');
7292 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7294 Current_Parameter := First (Ordered_Parameters_List);
7295 while Present (Current_Parameter) loop
7296 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7297 Is_Controlling_Formal := True;
7298 Is_First_Controlling_Formal :=
7299 not First_Controlling_Formal_Seen;
7300 First_Controlling_Formal_Seen := True;
7303 Is_Controlling_Formal := False;
7304 Is_First_Controlling_Formal := False;
7307 if Is_Controlling_Formal then
7309 -- For a controlling formal argument, we send its reference
7314 Etyp := Etype (Parameter_Type (Current_Parameter));
7317 -- The first controlling formal parameter is treated specially:
7318 -- it is used to set the target object of the call.
7320 if not Is_First_Controlling_Formal then
7322 Constrained : constant Boolean :=
7323 Is_Constrained (Etyp)
7324 or else Is_Elementary_Type (Etyp);
7326 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
7328 Actual_Parameter : Node_Id :=
7330 Defining_Identifier (
7331 Current_Parameter), Loc);
7336 if Is_Controlling_Formal then
7338 -- For a controlling formal parameter (other than the
7339 -- first one), use the corresponding RACW. If the
7340 -- parameter is not an anonymous access parameter, that
7341 -- involves taking its 'Unrestricted_Access.
7343 if Nkind (Parameter_Type (Current_Parameter))
7344 = N_Access_Definition
7346 Actual_Parameter := OK_Convert_To
7347 (Etyp, Actual_Parameter);
7349 Actual_Parameter := OK_Convert_To (Etyp,
7350 Make_Attribute_Reference (Loc,
7351 Prefix => Actual_Parameter,
7352 Attribute_Name => Name_Unrestricted_Access));
7357 if In_Present (Current_Parameter)
7358 or else not Out_Present (Current_Parameter)
7359 or else not Constrained
7360 or else Is_Controlling_Formal
7362 -- The parameter has an input value, is constrained at
7363 -- runtime by an input value, or is a controlling formal
7364 -- parameter (always passed as a reference) other than
7367 Expr := PolyORB_Support.Helpers.Build_To_Any_Call
7368 (Loc, Actual_Parameter, Decls);
7371 Expr := Make_Function_Call (Loc,
7372 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7373 Parameter_Associations => New_List (
7374 PolyORB_Support.Helpers.Build_TypeCode_Call
7375 (Loc, Etyp, Decls)));
7379 Make_Object_Declaration (Loc,
7380 Defining_Identifier => Any,
7381 Aliased_Present => False,
7382 Object_Definition =>
7383 New_Occurrence_Of (RTE (RE_Any), Loc),
7384 Expression => Expr));
7386 Append_To (Statements,
7387 Add_Parameter_To_NVList (Loc,
7388 Parameter => Current_Parameter,
7389 NVList => Arguments,
7390 Constrained => Constrained,
7393 if Out_Present (Current_Parameter)
7394 and then not Is_Controlling_Formal
7396 if Is_Limited_Type (Etyp) then
7397 Helpers.Assign_Opaque_From_Any (Loc,
7398 Stms => After_Statements,
7400 N => New_Occurrence_Of (Any, Loc),
7402 Defining_Identifier (Current_Parameter),
7403 Constrained => True);
7406 Append_To (After_Statements,
7407 Make_Assignment_Statement (Loc,
7410 Defining_Identifier (Current_Parameter), Loc),
7412 PolyORB_Support.Helpers.Build_From_Any_Call
7414 New_Occurrence_Of (Any, Loc),
7421 -- If the current parameter has a dynamic constrained status, then
7422 -- this status is transmitted as well.
7424 -- This should be done for accessibility as well ???
7426 if Nkind (Parameter_Type (Current_Parameter)) /=
7428 and then Need_Extra_Constrained (Current_Parameter)
7430 -- In this block, we do not use the extra formal that has been
7431 -- created because it does not exist at the time of expansion
7432 -- when building calling stubs for remote access to subprogram
7433 -- types. We create an extra variable of this type and push it
7434 -- in the stream after the regular parameters.
7437 Extra_Any_Parameter : constant Entity_Id :=
7438 Make_Temporary (Loc, 'P');
7440 Parameter_Exp : constant Node_Id :=
7441 Make_Attribute_Reference (Loc,
7442 Prefix => New_Occurrence_Of (
7443 Defining_Identifier (Current_Parameter), Loc),
7444 Attribute_Name => Name_Constrained);
7447 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7450 Make_Object_Declaration (Loc,
7451 Defining_Identifier => Extra_Any_Parameter,
7452 Aliased_Present => False,
7453 Object_Definition =>
7454 New_Occurrence_Of (RTE (RE_Any), Loc),
7456 PolyORB_Support.Helpers.Build_To_Any_Call
7457 (Loc, Parameter_Exp, Decls)));
7459 Append_To (Extra_Formal_Statements,
7460 Add_Parameter_To_NVList (Loc,
7461 Parameter => Extra_Any_Parameter,
7462 NVList => Arguments,
7463 Constrained => True,
7464 Any => Extra_Any_Parameter));
7468 Next (Current_Parameter);
7471 -- Append the formal statements list to the statements
7473 Append_List_To (Statements, Extra_Formal_Statements);
7475 Append_To (Statements,
7476 Make_Procedure_Call_Statement (Loc,
7478 New_Occurrence_Of (RTE (RE_Request_Setup), Loc),
7479 Parameter_Associations => New_List (
7480 New_Occurrence_Of (Request, Loc),
7483 New_Occurrence_Of (Arguments, Loc),
7484 New_Occurrence_Of (Result, Loc),
7485 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7488 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7490 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7493 (Boolean_Literals (Is_Known_Asynchronous), Loc);
7496 pragma Assert (Present (Asynchronous));
7497 Asynchronous_P := New_Copy_Tree (Asynchronous);
7499 -- The expression node Asynchronous will be used to build an 'if'
7500 -- statement at the end of Build_General_Calling_Stubs: we need to
7501 -- make a copy here.
7504 Append_To (Parameter_Associations (Last (Statements)),
7505 Make_Indexed_Component (Loc,
7508 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7509 Expressions => New_List (Asynchronous_P)));
7511 Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke));
7513 -- Asynchronous case
7515 if not Is_Known_Non_Asynchronous then
7516 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7519 -- Non-asynchronous case
7521 if not Is_Known_Asynchronous then
7522 -- Reraise an exception occurrence from the completed request.
7523 -- If the exception occurrence is empty, this is a no-op.
7525 Non_Asynchronous_Statements := New_List (
7526 Make_Procedure_Call_Statement (Loc,
7528 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7529 Parameter_Associations => New_List (
7530 New_Occurrence_Of (Request, Loc))));
7533 -- If this is a function call, read the value and return it
7535 Append_To (Non_Asynchronous_Statements,
7536 Make_Tag_Check (Loc,
7537 Make_Simple_Return_Statement (Loc,
7538 PolyORB_Support.Helpers.Build_From_Any_Call
7539 (Etype (Result_Definition (Spec)),
7540 Make_Selected_Component (Loc,
7542 Selector_Name => Name_Argument),
7547 -- Case of a procedure: deal with IN OUT and OUT formals
7549 Append_List_To (Non_Asynchronous_Statements, After_Statements);
7553 if Is_Known_Asynchronous then
7554 Append_List_To (Statements, Asynchronous_Statements);
7556 elsif Is_Known_Non_Asynchronous then
7557 Append_List_To (Statements, Non_Asynchronous_Statements);
7560 pragma Assert (Present (Asynchronous));
7561 Append_To (Statements,
7562 Make_Implicit_If_Statement (Nod,
7563 Condition => Asynchronous,
7564 Then_Statements => Asynchronous_Statements,
7565 Else_Statements => Non_Asynchronous_Statements));
7567 end Build_General_Calling_Stubs;
7569 -----------------------
7570 -- Build_Stub_Target --
7571 -----------------------
7573 function Build_Stub_Target
7576 RCI_Locator : Entity_Id;
7577 Controlling_Parameter : Entity_Id) return RPC_Target
7579 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7580 Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T');
7583 if Present (Controlling_Parameter) then
7585 Make_Object_Declaration (Loc,
7586 Defining_Identifier => Target_Reference,
7588 Object_Definition =>
7589 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7592 Make_Function_Call (Loc,
7594 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7595 Parameter_Associations => New_List (
7596 Make_Selected_Component (Loc,
7597 Prefix => Controlling_Parameter,
7598 Selector_Name => Name_Target)))));
7600 -- Note: Controlling_Parameter has the same components as
7601 -- System.Partition_Interface.RACW_Stub_Type.
7603 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7606 Target_Info.Object :=
7607 Make_Selected_Component (Loc,
7609 Make_Identifier (Loc, Chars (RCI_Locator)),
7611 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7615 end Build_Stub_Target;
7617 -----------------------------
7618 -- Build_RPC_Receiver_Body --
7619 -----------------------------
7621 procedure Build_RPC_Receiver_Body
7622 (RPC_Receiver : Entity_Id;
7623 Request : out Entity_Id;
7624 Subp_Id : out Entity_Id;
7625 Subp_Index : out Entity_Id;
7626 Stmts : out List_Id;
7629 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7631 RPC_Receiver_Spec : Node_Id;
7632 RPC_Receiver_Decls : List_Id;
7635 Request := Make_Defining_Identifier (Loc, Name_R);
7637 RPC_Receiver_Spec :=
7638 Build_RPC_Receiver_Specification
7639 (RPC_Receiver => RPC_Receiver,
7640 Request_Parameter => Request);
7642 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7643 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7645 RPC_Receiver_Decls := New_List (
7646 Make_Object_Renaming_Declaration (Loc,
7647 Defining_Identifier => Subp_Id,
7648 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7650 Make_Explicit_Dereference (Loc,
7652 Make_Selected_Component (Loc,
7654 Selector_Name => Name_Operation))),
7656 Make_Object_Declaration (Loc,
7657 Defining_Identifier => Subp_Index,
7658 Object_Definition =>
7659 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7661 Make_Attribute_Reference (Loc,
7663 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7664 Attribute_Name => Name_Last)));
7669 Make_Subprogram_Body (Loc,
7670 Specification => RPC_Receiver_Spec,
7671 Declarations => RPC_Receiver_Decls,
7672 Handled_Statement_Sequence =>
7673 Make_Handled_Sequence_Of_Statements (Loc,
7674 Statements => Stmts));
7675 end Build_RPC_Receiver_Body;
7677 --------------------------------------
7678 -- Build_Subprogram_Receiving_Stubs --
7679 --------------------------------------
7681 function Build_Subprogram_Receiving_Stubs
7682 (Vis_Decl : Node_Id;
7683 Asynchronous : Boolean;
7684 Dynamically_Asynchronous : Boolean := False;
7685 Stub_Type : Entity_Id := Empty;
7686 RACW_Type : Entity_Id := Empty;
7687 Parent_Primitive : Entity_Id := Empty) return Node_Id
7689 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7691 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
7692 -- Formal parameter for receiving stubs: a descriptor for an incoming
7695 Outer_Decls : constant List_Id := New_List;
7696 -- At the outermost level, an NVList and Any's are declared for all
7697 -- parameters. The Dynamic_Async flag also needs to be declared there
7698 -- to be visible from the exception handling code.
7700 Outer_Statements : constant List_Id := New_List;
7701 -- Statements that occur prior to the declaration of the actual
7702 -- parameter variables.
7704 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7705 -- Statements concerning extra formal parameters, prior to the
7706 -- declaration of the actual parameter variables.
7708 Decls : constant List_Id := New_List;
7709 -- All the parameters will get declared before calling the real
7710 -- subprograms. Also the out parameters will be declared. At this
7711 -- level, parameters may be unconstrained.
7713 Statements : constant List_Id := New_List;
7715 After_Statements : constant List_Id := New_List;
7716 -- Statements to be executed after the subprogram call
7718 Inner_Decls : List_Id := No_List;
7719 -- In case of a function, the inner declarations are needed since
7720 -- the result may be unconstrained.
7722 Excep_Handlers : List_Id := No_List;
7724 Parameter_List : constant List_Id := New_List;
7725 -- List of parameters to be passed to the subprogram
7727 First_Controlling_Formal_Seen : Boolean := False;
7729 Current_Parameter : Node_Id;
7731 Ordered_Parameters_List : constant List_Id :=
7732 Build_Ordered_Parameters_List
7733 (Specification (Vis_Decl));
7735 Arguments : constant Entity_Id := Make_Temporary (Loc, 'A');
7736 -- Name of the named values list used to retrieve parameters
7738 Subp_Spec : Node_Id;
7739 -- Subprogram specification
7741 Called_Subprogram : Node_Id;
7742 -- The subprogram to call
7745 if Present (RACW_Type) then
7746 Called_Subprogram :=
7747 New_Occurrence_Of (Parent_Primitive, Loc);
7749 Called_Subprogram :=
7751 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7754 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7756 -- Loop through every parameter and get its value from the stream. If
7757 -- the parameter is unconstrained, then the parameter is read using
7758 -- 'Input at the point of declaration.
7760 Current_Parameter := First (Ordered_Parameters_List);
7761 while Present (Current_Parameter) loop
7764 Constrained : Boolean;
7765 Any : Entity_Id := Empty;
7766 Object : constant Entity_Id := Make_Temporary (Loc, 'P');
7767 Expr : Node_Id := Empty;
7769 Is_Controlling_Formal : constant Boolean :=
7770 Is_RACW_Controlling_Formal
7771 (Current_Parameter, Stub_Type);
7773 Is_First_Controlling_Formal : Boolean := False;
7775 Need_Extra_Constrained : Boolean;
7776 -- True when an extra constrained actual is required
7779 if Is_Controlling_Formal then
7781 -- Controlling formals in distributed object primitive
7782 -- operations are handled specially:
7784 -- - the first controlling formal is used as the
7785 -- target of the call;
7787 -- - the remaining controlling formals are transmitted
7791 Is_First_Controlling_Formal :=
7792 not First_Controlling_Formal_Seen;
7793 First_Controlling_Formal_Seen := True;
7796 Etyp := Etype (Parameter_Type (Current_Parameter));
7800 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
7802 if not Is_First_Controlling_Formal then
7803 Any := Make_Temporary (Loc, 'A');
7805 Append_To (Outer_Decls,
7806 Make_Object_Declaration (Loc,
7807 Defining_Identifier => Any,
7808 Object_Definition =>
7809 New_Occurrence_Of (RTE (RE_Any), Loc),
7811 Make_Function_Call (Loc,
7812 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7813 Parameter_Associations => New_List (
7814 PolyORB_Support.Helpers.Build_TypeCode_Call
7815 (Loc, Etyp, Outer_Decls)))));
7817 Append_To (Outer_Statements,
7818 Add_Parameter_To_NVList (Loc,
7819 Parameter => Current_Parameter,
7820 NVList => Arguments,
7821 Constrained => Constrained,
7825 if Is_First_Controlling_Formal then
7827 Addr : constant Entity_Id := Make_Temporary (Loc, 'A');
7829 Is_Local : constant Entity_Id :=
7830 Make_Temporary (Loc, 'L');
7833 -- Special case: obtain the first controlling formal
7834 -- from the target of the remote call, instead of the
7837 Append_To (Outer_Decls,
7838 Make_Object_Declaration (Loc,
7839 Defining_Identifier => Addr,
7840 Object_Definition =>
7841 New_Occurrence_Of (RTE (RE_Address), Loc)));
7843 Append_To (Outer_Decls,
7844 Make_Object_Declaration (Loc,
7845 Defining_Identifier => Is_Local,
7846 Object_Definition =>
7847 New_Occurrence_Of (Standard_Boolean, Loc)));
7849 Append_To (Outer_Statements,
7850 Make_Procedure_Call_Statement (Loc,
7852 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7853 Parameter_Associations => New_List (
7854 Make_Selected_Component (Loc,
7857 Request_Parameter, Loc),
7859 Make_Identifier (Loc, Name_Target)),
7860 New_Occurrence_Of (Is_Local, Loc),
7861 New_Occurrence_Of (Addr, Loc))));
7863 Expr := Unchecked_Convert_To (RACW_Type,
7864 New_Occurrence_Of (Addr, Loc));
7867 elsif In_Present (Current_Parameter)
7868 or else not Out_Present (Current_Parameter)
7869 or else not Constrained
7871 -- If an input parameter is constrained, then its reading is
7872 -- deferred until the beginning of the subprogram body. If
7873 -- it is unconstrained, then an expression is built for
7874 -- the object declaration and the variable is set using
7875 -- 'Input instead of 'Read.
7877 if Constrained and then Is_Limited_Type (Etyp) then
7878 Helpers.Assign_Opaque_From_Any (Loc,
7881 N => New_Occurrence_Of (Any, Loc),
7885 Expr := Helpers.Build_From_Any_Call
7886 (Etyp, New_Occurrence_Of (Any, Loc), Decls);
7889 Append_To (Statements,
7890 Make_Assignment_Statement (Loc,
7891 Name => New_Occurrence_Of (Object, Loc),
7892 Expression => Expr));
7896 -- Expr will be used to initialize (and constrain) the
7897 -- parameter when it is declared.
7905 Need_Extra_Constrained :=
7906 Nkind (Parameter_Type (Current_Parameter)) /=
7909 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7911 Present (Extra_Constrained
7912 (Defining_Identifier (Current_Parameter)));
7914 -- We may not associate an extra constrained actual to a
7915 -- constant object, so if one is needed, declare the actual
7916 -- as a variable even if it won't be modified.
7918 Build_Actual_Object_Declaration
7921 Variable => Need_Extra_Constrained
7922 or else Out_Present (Current_Parameter),
7925 Set_Etype (Object, Etyp);
7927 -- An out parameter may be written back using a 'Write
7928 -- attribute instead of a 'Output because it has been
7929 -- constrained by the parameter given to the caller. Note that
7930 -- OUT controlling arguments in the case of a RACW are not put
7931 -- back in the stream because the pointer on them has not
7934 if Out_Present (Current_Parameter)
7935 and then not Is_Controlling_Formal
7937 Append_To (After_Statements,
7938 Make_Procedure_Call_Statement (Loc,
7939 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
7940 Parameter_Associations => New_List (
7941 New_Occurrence_Of (Any, Loc),
7942 PolyORB_Support.Helpers.Build_To_Any_Call
7944 New_Occurrence_Of (Object, Loc),
7946 Constrained => True))));
7949 -- For RACW controlling formals, the Etyp of Object is always
7950 -- an RACW, even if the parameter is not of an anonymous access
7951 -- type. In such case, we need to dereference it at call time.
7953 if Is_Controlling_Formal then
7954 if Nkind (Parameter_Type (Current_Parameter)) /=
7957 Append_To (Parameter_List,
7958 Make_Parameter_Association (Loc,
7961 (Defining_Identifier (Current_Parameter), Loc),
7962 Explicit_Actual_Parameter =>
7963 Make_Explicit_Dereference (Loc,
7964 Prefix => New_Occurrence_Of (Object, Loc))));
7967 Append_To (Parameter_List,
7968 Make_Parameter_Association (Loc,
7971 (Defining_Identifier (Current_Parameter), Loc),
7973 Explicit_Actual_Parameter =>
7974 New_Occurrence_Of (Object, Loc)));
7978 Append_To (Parameter_List,
7979 Make_Parameter_Association (Loc,
7982 Defining_Identifier (Current_Parameter), Loc),
7983 Explicit_Actual_Parameter =>
7984 New_Occurrence_Of (Object, Loc)));
7987 -- If the current parameter needs an extra formal, then read it
7988 -- from the stream and set the corresponding semantic field in
7989 -- the variable. If the kind of the parameter identifier is
7990 -- E_Void, then this is a compiler generated parameter that
7991 -- doesn't need an extra constrained status.
7993 -- The case of Extra_Accessibility should also be handled ???
7995 if Need_Extra_Constrained then
7997 Extra_Parameter : constant Entity_Id :=
7999 (Defining_Identifier
8000 (Current_Parameter));
8002 Extra_Any : constant Entity_Id :=
8003 Make_Temporary (Loc, 'A');
8005 Formal_Entity : constant Entity_Id :=
8006 Make_Defining_Identifier (Loc,
8007 Chars => Chars (Extra_Parameter));
8009 Formal_Type : constant Entity_Id :=
8010 Etype (Extra_Parameter);
8013 Append_To (Outer_Decls,
8014 Make_Object_Declaration (Loc,
8015 Defining_Identifier => Extra_Any,
8016 Object_Definition =>
8017 New_Occurrence_Of (RTE (RE_Any), Loc),
8019 Make_Function_Call (Loc,
8021 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8022 Parameter_Associations => New_List (
8023 PolyORB_Support.Helpers.Build_TypeCode_Call
8024 (Loc, Formal_Type, Outer_Decls)))));
8026 Append_To (Outer_Extra_Formal_Statements,
8027 Add_Parameter_To_NVList (Loc,
8028 Parameter => Extra_Parameter,
8029 NVList => Arguments,
8030 Constrained => True,
8034 Make_Object_Declaration (Loc,
8035 Defining_Identifier => Formal_Entity,
8036 Object_Definition =>
8037 New_Occurrence_Of (Formal_Type, Loc)));
8039 Append_To (Statements,
8040 Make_Assignment_Statement (Loc,
8041 Name => New_Occurrence_Of (Formal_Entity, Loc),
8043 PolyORB_Support.Helpers.Build_From_Any_Call
8045 New_Occurrence_Of (Extra_Any, Loc),
8047 Set_Extra_Constrained (Object, Formal_Entity);
8052 Next (Current_Parameter);
8055 -- Extra Formals should go after all the other parameters
8057 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8059 Append_To (Outer_Statements,
8060 Make_Procedure_Call_Statement (Loc,
8061 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8062 Parameter_Associations => New_List (
8063 New_Occurrence_Of (Request_Parameter, Loc),
8064 New_Occurrence_Of (Arguments, Loc))));
8066 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8068 -- The remote subprogram is a function: Build an inner block to be
8069 -- able to hold a potentially unconstrained result in a variable.
8072 Etyp : constant Entity_Id :=
8073 Etype (Result_Definition (Specification (Vis_Decl)));
8074 Result : constant Node_Id := Make_Temporary (Loc, 'R');
8077 Inner_Decls := New_List (
8078 Make_Object_Declaration (Loc,
8079 Defining_Identifier => Result,
8080 Constant_Present => True,
8081 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8083 Make_Function_Call (Loc,
8084 Name => Called_Subprogram,
8085 Parameter_Associations => Parameter_List)));
8087 if Is_Class_Wide_Type (Etyp) then
8089 -- For a remote call to a function with a class-wide type,
8090 -- check that the returned value satisfies the requirements
8093 Append_To (Inner_Decls,
8094 Make_Transportable_Check (Loc,
8095 New_Occurrence_Of (Result, Loc)));
8099 Set_Etype (Result, Etyp);
8100 Append_To (After_Statements,
8101 Make_Procedure_Call_Statement (Loc,
8102 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8103 Parameter_Associations => New_List (
8104 New_Occurrence_Of (Request_Parameter, Loc),
8105 PolyORB_Support.Helpers.Build_To_Any_Call
8106 (Loc, New_Occurrence_Of (Result, Loc), Decls))));
8108 -- A DSA function does not have out or inout arguments
8111 Append_To (Statements,
8112 Make_Block_Statement (Loc,
8113 Declarations => Inner_Decls,
8114 Handled_Statement_Sequence =>
8115 Make_Handled_Sequence_Of_Statements (Loc,
8116 Statements => After_Statements)));
8119 -- The remote subprogram is a procedure. We do not need any inner
8120 -- block in this case. No specific processing is required here for
8121 -- the dynamically asynchronous case: the indication of whether
8122 -- call is asynchronous or not is managed by the Sync_Scope
8123 -- attibute of the request, and is handled entirely in the
8126 Append_To (After_Statements,
8127 Make_Procedure_Call_Statement (Loc,
8128 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8129 Parameter_Associations => New_List (
8130 New_Occurrence_Of (Request_Parameter, Loc))));
8132 Append_To (Statements,
8133 Make_Procedure_Call_Statement (Loc,
8134 Name => Called_Subprogram,
8135 Parameter_Associations => Parameter_List));
8137 Append_List_To (Statements, After_Statements);
8141 Make_Procedure_Specification (Loc,
8142 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
8144 Parameter_Specifications => New_List (
8145 Make_Parameter_Specification (Loc,
8146 Defining_Identifier => Request_Parameter,
8148 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8150 -- An exception raised during the execution of an incoming remote
8151 -- subprogram call and that needs to be sent back to the caller is
8152 -- propagated by the receiving stubs, and will be handled by the
8153 -- caller (the distribution runtime).
8155 if Asynchronous and then not Dynamically_Asynchronous then
8157 -- For an asynchronous procedure, add a null exception handler
8159 Excep_Handlers := New_List (
8160 Make_Implicit_Exception_Handler (Loc,
8161 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8162 Statements => New_List (Make_Null_Statement (Loc))));
8165 -- In the other cases, if an exception is raised, then the
8166 -- exception occurrence is propagated.
8171 Append_To (Outer_Statements,
8172 Make_Block_Statement (Loc,
8173 Declarations => Decls,
8174 Handled_Statement_Sequence =>
8175 Make_Handled_Sequence_Of_Statements (Loc,
8176 Statements => Statements)));
8179 Make_Subprogram_Body (Loc,
8180 Specification => Subp_Spec,
8181 Declarations => Outer_Decls,
8182 Handled_Statement_Sequence =>
8183 Make_Handled_Sequence_Of_Statements (Loc,
8184 Statements => Outer_Statements,
8185 Exception_Handlers => Excep_Handlers));
8186 end Build_Subprogram_Receiving_Stubs;
8192 package body Helpers is
8194 -----------------------
8195 -- Local Subprograms --
8196 -----------------------
8198 function Find_Numeric_Representation
8199 (Typ : Entity_Id) return Entity_Id;
8200 -- Given a numeric type Typ, return the smallest integer or modular
8201 -- type from Interfaces, or the smallest floating point type from
8202 -- Standard whose range encompasses that of Typ.
8204 function Is_Generic_Actual_Subtype (Typ : Entity_Id) return Boolean;
8205 -- Return true if Typ is a subtype representing a generic formal type
8206 -- as a subtype of the actual type in an instance. This is needed to
8207 -- recognize these subtypes because the Is_Generic_Actual_Type flag
8208 -- can only be relied upon within the instance.
8210 function Make_Helper_Function_Name
8213 Nam : Name_Id) return Entity_Id;
8214 -- Return the name to be assigned for helper subprogram Nam of Typ
8216 ------------------------------------------------------------
8217 -- Common subprograms for building various tree fragments --
8218 ------------------------------------------------------------
8220 function Build_Get_Aggregate_Element
8224 Idx : Node_Id) return Node_Id;
8225 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8226 -- returning the Idx'th element.
8229 Subprogram : Entity_Id;
8230 -- Reference location for constructed nodes
8233 -- For 'Range and Etype
8236 -- For the construction of the innermost element expression
8238 with procedure Add_Process_Element
8241 Counter : Entity_Id;
8244 procedure Append_Array_Traversal
8247 Counter : Entity_Id := Empty;
8249 -- Build nested loop statements that iterate over the elements of an
8250 -- array Arry. The statement(s) built by Add_Process_Element are
8251 -- executed for each element; Indexes is the list of indexes to be
8252 -- used in the construction of the indexed component that denotes the
8253 -- current element. Subprogram is the entity for the subprogram for
8254 -- which this iterator is generated. The generated statements are
8255 -- appended to Stmts.
8259 -- The record entity being dealt with
8261 with procedure Add_Process_Element
8263 Container : Node_Or_Entity_Id;
8264 Counter : in out Nat;
8267 -- Rec is the instance of the record type, or Empty.
8268 -- Field is either the N_Defining_Identifier for a component,
8269 -- or an N_Variant_Part.
8271 procedure Append_Record_Traversal
8274 Container : Node_Or_Entity_Id;
8275 Counter : in out Nat);
8276 -- Process component list Clist. Individual fields are passed
8277 -- to Field_Processing. Each variant part is also processed.
8278 -- Container is the outer Any (for From_Any/To_Any),
8279 -- the outer typecode (for TC) to which the operation applies.
8281 -----------------------------
8282 -- Append_Record_Traversal --
8283 -----------------------------
8285 procedure Append_Record_Traversal
8288 Container : Node_Or_Entity_Id;
8289 Counter : in out Nat)
8293 -- Clist's Component_Items and Variant_Part
8303 CI := Component_Items (Clist);
8304 VP := Variant_Part (Clist);
8307 while Present (Item) loop
8308 Def := Defining_Identifier (Item);
8310 if not Is_Internal_Name (Chars (Def)) then
8312 (Stmts, Container, Counter, Rec, Def);
8318 if Present (VP) then
8319 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8321 end Append_Record_Traversal;
8323 -----------------------------
8324 -- Assign_Opaque_From_Any --
8325 -----------------------------
8327 procedure Assign_Opaque_From_Any
8333 Constrained : Boolean := False)
8335 Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
8338 Read_Call_List : List_Id;
8339 -- List on which to place the 'Read attribute reference
8342 -- Strm : Buffer_Stream_Type;
8345 Make_Object_Declaration (Loc,
8346 Defining_Identifier => Strm,
8347 Aliased_Present => True,
8348 Object_Definition =>
8349 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
8351 -- Any_To_BS (Strm, A);
8354 Make_Procedure_Call_Statement (Loc,
8355 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
8356 Parameter_Associations => New_List (
8358 New_Occurrence_Of (Strm, Loc))));
8360 if Transmit_As_Unconstrained (Typ) and then not Constrained then
8362 Make_Attribute_Reference (Loc,
8363 Prefix => New_Occurrence_Of (Typ, Loc),
8364 Attribute_Name => Name_Input,
8365 Expressions => New_List (
8366 Make_Attribute_Reference (Loc,
8367 Prefix => New_Occurrence_Of (Strm, Loc),
8368 Attribute_Name => Name_Access)));
8370 -- Target := Typ'Input (Strm'Access)
8372 if Present (Target) then
8374 Make_Assignment_Statement (Loc,
8375 Name => New_Occurrence_Of (Target, Loc),
8376 Expression => Expr));
8378 -- return Typ'Input (Strm'Access);
8382 Make_Simple_Return_Statement (Loc,
8383 Expression => Expr));
8387 if Present (Target) then
8388 Read_Call_List := Stms;
8389 Expr := New_Occurrence_Of (Target, Loc);
8393 Temp : constant Entity_Id := Make_Temporary (Loc, 'R');
8396 Read_Call_List := New_List;
8397 Expr := New_Occurrence_Of (Temp, Loc);
8399 Append_To (Stms, Make_Block_Statement (Loc,
8400 Declarations => New_List (
8401 Make_Object_Declaration (Loc,
8402 Defining_Identifier =>
8404 Object_Definition =>
8405 New_Occurrence_Of (Typ, Loc))),
8407 Handled_Statement_Sequence =>
8408 Make_Handled_Sequence_Of_Statements (Loc,
8409 Statements => Read_Call_List)));
8413 -- Typ'Read (Strm'Access, [Target|Temp])
8415 Append_To (Read_Call_List,
8416 Make_Attribute_Reference (Loc,
8417 Prefix => New_Occurrence_Of (Typ, Loc),
8418 Attribute_Name => Name_Read,
8419 Expressions => New_List (
8420 Make_Attribute_Reference (Loc,
8421 Prefix => New_Occurrence_Of (Strm, Loc),
8422 Attribute_Name => Name_Access),
8429 Append_To (Read_Call_List,
8430 Make_Simple_Return_Statement (Loc,
8431 Expression => New_Copy (Expr)));
8434 end Assign_Opaque_From_Any;
8436 -------------------------
8437 -- Build_From_Any_Call --
8438 -------------------------
8440 function Build_From_Any_Call
8443 Decls : List_Id) return Node_Id
8445 Loc : constant Source_Ptr := Sloc (N);
8447 U_Type : Entity_Id := Underlying_Type (Typ);
8450 Lib_RE : RE_Id := RE_Null;
8454 -- First simple case where the From_Any function is present
8455 -- in the type's TSS.
8457 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8459 -- For the subtype representing a generic actual type, go to the
8462 if Is_Generic_Actual_Subtype (U_Type) then
8463 U_Type := Underlying_Type (Base_Type (U_Type));
8466 -- For a standard subtype, go to the base type
8468 if Sloc (U_Type) <= Standard_Location then
8469 U_Type := Base_Type (U_Type);
8471 -- For a user subtype, go to first subtype
8473 elsif Comes_From_Source (U_Type)
8474 and then Nkind (Declaration_Node (U_Type))
8475 = N_Subtype_Declaration
8477 U_Type := First_Subtype (U_Type);
8480 -- Check first for Boolean and Character. These are enumeration
8481 -- types, but we treat them specially, since they may require
8482 -- special handling in the transfer protocol. However, this
8483 -- special handling only applies if they have standard
8484 -- representation, otherwise they are treated like any other
8485 -- enumeration type.
8487 if Present (Fnam) then
8490 elsif U_Type = Standard_Boolean then
8493 elsif U_Type = Standard_Character then
8496 elsif U_Type = Standard_Wide_Character then
8499 elsif U_Type = Standard_Wide_Wide_Character then
8500 Lib_RE := RE_FA_WWC;
8502 -- Floating point types
8504 elsif U_Type = Standard_Short_Float then
8507 elsif U_Type = Standard_Float then
8510 elsif U_Type = Standard_Long_Float then
8513 elsif U_Type = Standard_Long_Long_Float then
8514 Lib_RE := RE_FA_LLF;
8518 elsif U_Type = RTE (RE_Integer_8) then
8521 elsif U_Type = RTE (RE_Integer_16) then
8522 Lib_RE := RE_FA_I16;
8524 elsif U_Type = RTE (RE_Integer_32) then
8525 Lib_RE := RE_FA_I32;
8527 elsif U_Type = RTE (RE_Integer_64) then
8528 Lib_RE := RE_FA_I64;
8530 -- Unsigned integer types
8532 elsif U_Type = RTE (RE_Unsigned_8) then
8535 elsif U_Type = RTE (RE_Unsigned_16) then
8536 Lib_RE := RE_FA_U16;
8538 elsif U_Type = RTE (RE_Unsigned_32) then
8539 Lib_RE := RE_FA_U32;
8541 elsif U_Type = RTE (RE_Unsigned_64) then
8542 Lib_RE := RE_FA_U64;
8544 elsif Is_RTE (U_Type, RE_Unbounded_String) then
8545 Lib_RE := RE_FA_String;
8547 -- Special DSA types
8549 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
8552 -- Other (non-primitive) types
8559 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8560 Append_To (Decls, Decl);
8564 -- Call the function
8566 if Lib_RE /= RE_Null then
8567 pragma Assert (No (Fnam));
8568 Fnam := RTE (Lib_RE);
8572 Make_Function_Call (Loc,
8573 Name => New_Occurrence_Of (Fnam, Loc),
8574 Parameter_Associations => New_List (N));
8576 -- We must set the type of Result, so the unchecked conversion
8577 -- from the underlying type to the base type is properly done.
8579 Set_Etype (Result, U_Type);
8581 return Unchecked_Convert_To (Typ, Result);
8582 end Build_From_Any_Call;
8584 -----------------------------
8585 -- Build_From_Any_Function --
8586 -----------------------------
8588 procedure Build_From_Any_Function
8592 Fnam : out Entity_Id)
8595 Decls : constant List_Id := New_List;
8596 Stms : constant List_Id := New_List;
8598 Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A');
8600 Use_Opaque_Representation : Boolean;
8603 -- For a derived type, we can't go past the base type (to the
8604 -- parent type) here, because that would cause the attribute's
8605 -- formal parameter to have the wrong type; hence the Base_Type
8608 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
8609 Build_From_Any_Function
8617 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
8620 Make_Function_Specification (Loc,
8621 Defining_Unit_Name => Fnam,
8622 Parameter_Specifications => New_List (
8623 Make_Parameter_Specification (Loc,
8624 Defining_Identifier => Any_Parameter,
8625 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
8626 Result_Definition => New_Occurrence_Of (Typ, Loc));
8628 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8631 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8633 Use_Opaque_Representation := False;
8635 if Has_Stream_Attribute_Definition
8636 (Typ, TSS_Stream_Output, At_Any_Place => True)
8638 Has_Stream_Attribute_Definition
8639 (Typ, TSS_Stream_Write, At_Any_Place => True)
8641 -- If user-defined stream attributes are specified for this
8642 -- type, use them and transmit data as an opaque sequence of
8645 Use_Opaque_Representation := True;
8647 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
8649 Make_Simple_Return_Statement (Loc,
8654 New_Occurrence_Of (Any_Parameter, Loc),
8657 elsif Is_Record_Type (Typ)
8658 and then not Is_Derived_Type (Typ)
8659 and then not Is_Tagged_Type (Typ)
8661 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8663 Make_Simple_Return_Statement (Loc,
8667 New_Occurrence_Of (Any_Parameter, Loc),
8672 Disc : Entity_Id := Empty;
8673 Discriminant_Associations : List_Id;
8674 Rdef : constant Node_Id :=
8676 (Declaration_Node (Typ));
8677 Component_Counter : Nat := 0;
8679 -- The returned object
8681 Res : constant Entity_Id := Make_Temporary (Loc, 'R');
8683 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8685 procedure FA_Rec_Add_Process_Element
8688 Counter : in out Nat;
8692 procedure FA_Append_Record_Traversal is
8693 new Append_Record_Traversal
8695 Add_Process_Element => FA_Rec_Add_Process_Element);
8697 --------------------------------
8698 -- FA_Rec_Add_Process_Element --
8699 --------------------------------
8701 procedure FA_Rec_Add_Process_Element
8704 Counter : in out Nat;
8710 if Nkind (Field) = N_Defining_Identifier then
8711 -- A regular component
8713 Ctyp := Etype (Field);
8716 Make_Assignment_Statement (Loc,
8717 Name => Make_Selected_Component (Loc,
8719 New_Occurrence_Of (Rec, Loc),
8721 New_Occurrence_Of (Field, Loc)),
8724 Build_From_Any_Call (Ctyp,
8725 Build_Get_Aggregate_Element (Loc,
8728 Build_TypeCode_Call (Loc, Ctyp, Decls),
8730 Make_Integer_Literal (Loc, Counter)),
8738 Struct_Counter : Nat := 0;
8740 Block_Decls : constant List_Id := New_List;
8741 Block_Stmts : constant List_Id := New_List;
8744 Alt_List : constant List_Id := New_List;
8745 Choice_List : List_Id;
8747 Struct_Any : constant Entity_Id :=
8748 Make_Temporary (Loc, 'S');
8752 Make_Object_Declaration (Loc,
8753 Defining_Identifier => Struct_Any,
8754 Constant_Present => True,
8755 Object_Definition =>
8756 New_Occurrence_Of (RTE (RE_Any), Loc),
8758 Make_Function_Call (Loc,
8761 (RTE (RE_Extract_Union_Value), Loc),
8763 Parameter_Associations => New_List (
8764 Build_Get_Aggregate_Element (Loc,
8767 Make_Function_Call (Loc,
8768 Name => New_Occurrence_Of (
8769 RTE (RE_Any_Member_Type), Loc),
8770 Parameter_Associations =>
8772 New_Occurrence_Of (Any, Loc),
8773 Make_Integer_Literal (Loc,
8774 Intval => Counter))),
8776 Make_Integer_Literal (Loc,
8777 Intval => Counter))))));
8780 Make_Block_Statement (Loc,
8781 Declarations => Block_Decls,
8782 Handled_Statement_Sequence =>
8783 Make_Handled_Sequence_Of_Statements (Loc,
8784 Statements => Block_Stmts)));
8786 Append_To (Block_Stmts,
8787 Make_Case_Statement (Loc,
8789 Make_Selected_Component (Loc,
8791 Selector_Name => Chars (Name (Field))),
8792 Alternatives => Alt_List));
8794 Variant := First_Non_Pragma (Variants (Field));
8795 while Present (Variant) loop
8798 (Discrete_Choices (Variant));
8800 VP_Stmts := New_List;
8802 -- Struct_Counter should be reset before
8803 -- handling a variant part. Indeed only one
8804 -- of the case statement alternatives will be
8805 -- executed at run time, so the counter must
8806 -- start at 0 for every case statement.
8808 Struct_Counter := 0;
8810 FA_Append_Record_Traversal (
8812 Clist => Component_List (Variant),
8813 Container => Struct_Any,
8814 Counter => Struct_Counter);
8816 Append_To (Alt_List,
8817 Make_Case_Statement_Alternative (Loc,
8818 Discrete_Choices => Choice_List,
8819 Statements => VP_Stmts));
8820 Next_Non_Pragma (Variant);
8825 Counter := Counter + 1;
8826 end FA_Rec_Add_Process_Element;
8829 -- First all discriminants
8831 if Has_Discriminants (Typ) then
8832 Discriminant_Associations := New_List;
8834 Disc := First_Discriminant (Typ);
8835 while Present (Disc) loop
8837 Disc_Var_Name : constant Entity_Id :=
8838 Make_Defining_Identifier (Loc,
8839 Chars => Chars (Disc));
8840 Disc_Type : constant Entity_Id :=
8845 Make_Object_Declaration (Loc,
8846 Defining_Identifier => Disc_Var_Name,
8847 Constant_Present => True,
8848 Object_Definition =>
8849 New_Occurrence_Of (Disc_Type, Loc),
8852 Build_From_Any_Call (Disc_Type,
8853 Build_Get_Aggregate_Element (Loc,
8854 Any => Any_Parameter,
8855 TC => Build_TypeCode_Call
8856 (Loc, Disc_Type, Decls),
8857 Idx => Make_Integer_Literal (Loc,
8858 Intval => Component_Counter)),
8861 Component_Counter := Component_Counter + 1;
8863 Append_To (Discriminant_Associations,
8864 Make_Discriminant_Association (Loc,
8865 Selector_Names => New_List (
8866 New_Occurrence_Of (Disc, Loc)),
8868 New_Occurrence_Of (Disc_Var_Name, Loc)));
8870 Next_Discriminant (Disc);
8874 Make_Subtype_Indication (Loc,
8875 Subtype_Mark => Res_Definition,
8877 Make_Index_Or_Discriminant_Constraint (Loc,
8878 Discriminant_Associations));
8881 -- Now we have all the discriminants in variables, we can
8882 -- declared a constrained object. Note that we are not
8883 -- initializing (non-discriminant) components directly in
8884 -- the object declarations, because which fields to
8885 -- initialize depends (at run time) on the discriminant
8889 Make_Object_Declaration (Loc,
8890 Defining_Identifier => Res,
8891 Object_Definition => Res_Definition));
8893 -- ... then all components
8895 FA_Append_Record_Traversal (Stms,
8896 Clist => Component_List (Rdef),
8897 Container => Any_Parameter,
8898 Counter => Component_Counter);
8901 Make_Simple_Return_Statement (Loc,
8902 Expression => New_Occurrence_Of (Res, Loc)));
8906 elsif Is_Array_Type (Typ) then
8908 Constrained : constant Boolean := Is_Constrained (Typ);
8910 procedure FA_Ary_Add_Process_Element
8913 Counter : Entity_Id;
8915 -- Assign the current element (as identified by Counter) of
8916 -- Any to the variable denoted by name Datum, and advance
8917 -- Counter by 1. If Datum is not an Any, a call to From_Any
8918 -- for its type is inserted.
8920 --------------------------------
8921 -- FA_Ary_Add_Process_Element --
8922 --------------------------------
8924 procedure FA_Ary_Add_Process_Element
8927 Counter : Entity_Id;
8930 Assignment : constant Node_Id :=
8931 Make_Assignment_Statement (Loc,
8933 Expression => Empty);
8935 Element_Any : Node_Id;
8939 Element_TC : Node_Id;
8942 if Etype (Datum) = RTE (RE_Any) then
8944 -- When Datum is an Any the Etype field is not
8945 -- sufficient to determine the typecode of Datum
8946 -- (which can be a TC_SEQUENCE or TC_ARRAY
8947 -- depending on the value of Constrained).
8949 -- Therefore we retrieve the typecode which has
8950 -- been constructed in Append_Array_Traversal with
8951 -- a call to Get_Any_Type.
8954 Make_Function_Call (Loc,
8955 Name => New_Occurrence_Of (
8956 RTE (RE_Get_Any_Type), Loc),
8957 Parameter_Associations => New_List (
8958 New_Occurrence_Of (Entity (Datum), Loc)));
8960 -- For non Any Datum we simply construct a typecode
8961 -- matching the Etype of the Datum.
8963 Element_TC := Build_TypeCode_Call
8964 (Loc, Etype (Datum), Decls);
8968 Build_Get_Aggregate_Element (Loc,
8971 Idx => New_Occurrence_Of (Counter, Loc));
8974 -- Note: here we *prepend* statements to Stmts, so
8975 -- we must do it in reverse order.
8978 Make_Assignment_Statement (Loc,
8980 New_Occurrence_Of (Counter, Loc),
8983 Left_Opnd => New_Occurrence_Of (Counter, Loc),
8984 Right_Opnd => Make_Integer_Literal (Loc, 1))));
8986 if Nkind (Datum) /= N_Attribute_Reference then
8988 -- We ignore the value of the length of each
8989 -- dimension, since the target array has already been
8990 -- constrained anyway.
8992 if Etype (Datum) /= RTE (RE_Any) then
8993 Set_Expression (Assignment,
8995 (Component_Type (Typ), Element_Any, Decls));
8997 Set_Expression (Assignment, Element_Any);
9000 Prepend_To (Stmts, Assignment);
9002 end FA_Ary_Add_Process_Element;
9004 ------------------------
9005 -- Local Declarations --
9006 ------------------------
9008 Counter : constant Entity_Id :=
9009 Make_Defining_Identifier (Loc, Name_J);
9011 Initial_Counter_Value : Int := 0;
9013 Component_TC : constant Entity_Id :=
9014 Make_Defining_Identifier (Loc, Name_T);
9016 Res : constant Entity_Id :=
9017 Make_Defining_Identifier (Loc, Name_R);
9019 procedure Append_From_Any_Array_Iterator is
9020 new Append_Array_Traversal (
9023 Indexes => New_List,
9024 Add_Process_Element => FA_Ary_Add_Process_Element);
9026 Res_Subtype_Indication : Node_Id :=
9027 New_Occurrence_Of (Typ, Loc);
9030 if not Constrained then
9032 Ndim : constant Int := Number_Dimensions (Typ);
9035 Indx : Node_Id := First_Index (Typ);
9038 Ranges : constant List_Id := New_List;
9041 for J in 1 .. Ndim loop
9042 Lnam := New_External_Name ('L', J);
9043 Hnam := New_External_Name ('H', J);
9045 -- Note, for empty arrays bounds may be out of
9046 -- the range of Etype (Indx).
9048 Indt := Base_Type (Etype (Indx));
9051 Make_Object_Declaration (Loc,
9052 Defining_Identifier =>
9053 Make_Defining_Identifier (Loc, Lnam),
9054 Constant_Present => True,
9055 Object_Definition =>
9056 New_Occurrence_Of (Indt, Loc),
9060 Build_Get_Aggregate_Element (Loc,
9061 Any => Any_Parameter,
9062 TC => Build_TypeCode_Call
9065 Make_Integer_Literal (Loc, J - 1)),
9069 Make_Object_Declaration (Loc,
9070 Defining_Identifier =>
9071 Make_Defining_Identifier (Loc, Hnam),
9073 Constant_Present => True,
9075 Object_Definition =>
9076 New_Occurrence_Of (Indt, Loc),
9078 Expression => Make_Attribute_Reference (Loc,
9080 New_Occurrence_Of (Indt, Loc),
9082 Attribute_Name => Name_Val,
9084 Expressions => New_List (
9085 Make_Op_Subtract (Loc,
9090 (Standard_Long_Integer,
9091 Make_Identifier (Loc, Lnam)),
9095 (Standard_Long_Integer,
9096 Make_Function_Call (Loc,
9098 New_Occurrence_Of (RTE (
9099 RE_Get_Nested_Sequence_Length
9101 Parameter_Associations =>
9104 Any_Parameter, Loc),
9105 Make_Integer_Literal (Loc,
9109 Make_Integer_Literal (Loc, 1))))));
9113 Low_Bound => Make_Identifier (Loc, Lnam),
9114 High_Bound => Make_Identifier (Loc, Hnam)));
9119 -- Now we have all the necessary bound information:
9120 -- apply the set of range constraints to the
9121 -- (unconstrained) nominal subtype of Res.
9123 Initial_Counter_Value := Ndim;
9124 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9125 Subtype_Mark => Res_Subtype_Indication,
9127 Make_Index_Or_Discriminant_Constraint (Loc,
9128 Constraints => Ranges));
9133 Make_Object_Declaration (Loc,
9134 Defining_Identifier => Res,
9135 Object_Definition => Res_Subtype_Indication));
9136 Set_Etype (Res, Typ);
9139 Make_Object_Declaration (Loc,
9140 Defining_Identifier => Counter,
9141 Object_Definition =>
9142 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc),
9144 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9147 Make_Object_Declaration (Loc,
9148 Defining_Identifier => Component_TC,
9149 Constant_Present => True,
9150 Object_Definition =>
9151 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9153 Build_TypeCode_Call (Loc,
9154 Component_Type (Typ), Decls)));
9156 Append_From_Any_Array_Iterator
9157 (Stms, Any_Parameter, Counter);
9160 Make_Simple_Return_Statement (Loc,
9161 Expression => New_Occurrence_Of (Res, Loc)));
9164 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9166 Make_Simple_Return_Statement (Loc,
9168 Unchecked_Convert_To (Typ,
9170 (Find_Numeric_Representation (Typ),
9171 New_Occurrence_Of (Any_Parameter, Loc),
9175 Use_Opaque_Representation := True;
9178 if Use_Opaque_Representation then
9179 Assign_Opaque_From_Any (Loc,
9182 N => New_Occurrence_Of (Any_Parameter, Loc),
9187 Make_Subprogram_Body (Loc,
9188 Specification => Spec,
9189 Declarations => Decls,
9190 Handled_Statement_Sequence =>
9191 Make_Handled_Sequence_Of_Statements (Loc,
9192 Statements => Stms));
9193 end Build_From_Any_Function;
9195 ---------------------------------
9196 -- Build_Get_Aggregate_Element --
9197 ---------------------------------
9199 function Build_Get_Aggregate_Element
9203 Idx : Node_Id) return Node_Id
9206 return Make_Function_Call (Loc,
9208 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc),
9209 Parameter_Associations => New_List (
9210 New_Occurrence_Of (Any, Loc),
9213 end Build_Get_Aggregate_Element;
9215 ----------------------------------
9216 -- Build_Name_And_Repository_Id --
9217 ----------------------------------
9219 procedure Build_Name_And_Repository_Id
9221 Name_Str : out String_Id;
9222 Repo_Id_Str : out String_Id)
9225 Name_Str := Fully_Qualified_Name_String (E, Append_NUL => False);
9227 Store_String_Chars ("DSA:");
9228 Store_String_Chars (Name_Str);
9229 Store_String_Chars (":1.0");
9230 Repo_Id_Str := End_String;
9231 end Build_Name_And_Repository_Id;
9233 -----------------------
9234 -- Build_To_Any_Call --
9235 -----------------------
9237 function Build_To_Any_Call
9241 Constrained : Boolean := False) return Node_Id
9243 Typ : Entity_Id := Etype (N);
9247 Lib_RE : RE_Id := RE_Null;
9250 -- If N is a selected component, then maybe its Etype has not been
9251 -- set yet: try to use Etype of the selector_name in that case.
9253 if No (Typ) and then Nkind (N) = N_Selected_Component then
9254 Typ := Etype (Selector_Name (N));
9257 pragma Assert (Present (Typ));
9259 -- Get full view for private type, completion for incomplete type
9261 U_Type := Underlying_Type (Typ);
9263 -- First simple case where the To_Any function is present in the
9266 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9268 -- For the subtype representing a generic actual type, go to the
9271 if Is_Generic_Actual_Subtype (U_Type) then
9272 U_Type := Underlying_Type (Base_Type (U_Type));
9275 -- For a standard subtype, go to the base type
9277 if Sloc (U_Type) <= Standard_Location then
9278 U_Type := Base_Type (U_Type);
9280 -- For a user subtype, go to first subtype
9282 elsif Comes_From_Source (U_Type)
9283 and then Nkind (Declaration_Node (U_Type))
9284 = N_Subtype_Declaration
9286 U_Type := First_Subtype (U_Type);
9289 if Present (Fnam) then
9292 -- Check first for Boolean and Character. These are enumeration
9293 -- types, but we treat them specially, since they may require
9294 -- special handling in the transfer protocol. However, this
9295 -- special handling only applies if they have standard
9296 -- representation, otherwise they are treated like any other
9297 -- enumeration type.
9299 elsif U_Type = Standard_Boolean then
9302 elsif U_Type = Standard_Character then
9305 elsif U_Type = Standard_Wide_Character then
9308 elsif U_Type = Standard_Wide_Wide_Character then
9309 Lib_RE := RE_TA_WWC;
9311 -- Floating point types
9313 elsif U_Type = Standard_Short_Float then
9316 elsif U_Type = Standard_Float then
9319 elsif U_Type = Standard_Long_Float then
9322 elsif U_Type = Standard_Long_Long_Float then
9323 Lib_RE := RE_TA_LLF;
9327 elsif U_Type = RTE (RE_Integer_8) then
9330 elsif U_Type = RTE (RE_Integer_16) then
9331 Lib_RE := RE_TA_I16;
9333 elsif U_Type = RTE (RE_Integer_32) then
9334 Lib_RE := RE_TA_I32;
9336 elsif U_Type = RTE (RE_Integer_64) then
9337 Lib_RE := RE_TA_I64;
9339 -- Unsigned integer types
9341 elsif U_Type = RTE (RE_Unsigned_8) then
9344 elsif U_Type = RTE (RE_Unsigned_16) then
9345 Lib_RE := RE_TA_U16;
9347 elsif U_Type = RTE (RE_Unsigned_32) then
9348 Lib_RE := RE_TA_U32;
9350 elsif U_Type = RTE (RE_Unsigned_64) then
9351 Lib_RE := RE_TA_U64;
9353 elsif Is_RTE (U_Type, RE_Unbounded_String) then
9354 Lib_RE := RE_TA_String;
9356 -- Special DSA types
9358 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
9362 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9364 -- No corresponding FA_TC ???
9368 -- Other (non-primitive) types
9374 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9375 Append_To (Decls, Decl);
9379 -- Call the function
9381 if Lib_RE /= RE_Null then
9382 pragma Assert (No (Fnam));
9383 Fnam := RTE (Lib_RE);
9386 -- If Fnam is already analyzed, find the proper expected type,
9387 -- else we have a newly constructed To_Any function and we know
9388 -- that the expected type of its parameter is U_Type.
9390 if Ekind (Fnam) = E_Function
9391 and then Present (First_Formal (Fnam))
9393 C_Type := Etype (First_Formal (Fnam));
9399 Params : constant List_Id :=
9400 New_List (OK_Convert_To (C_Type, N));
9402 if Is_Limited_Type (C_Type) then
9404 New_Occurrence_Of (Boolean_Literals (Constrained), Loc));
9408 Make_Function_Call (Loc,
9409 Name => New_Occurrence_Of (Fnam, Loc),
9410 Parameter_Associations => Params);
9412 end Build_To_Any_Call;
9414 ---------------------------
9415 -- Build_To_Any_Function --
9416 ---------------------------
9418 procedure Build_To_Any_Function
9422 Fnam : out Entity_Id)
9429 Expr_Formal : Entity_Id;
9430 Cstr_Formal : Entity_Id := Empty; -- initialize to prevent warning
9432 Result_TC : Node_Id;
9436 Use_Opaque_Representation : Boolean;
9437 -- When True, use stream attributes and represent type as an
9438 -- opaque sequence of bytes.
9441 -- For a derived type, we can't go past the base type (to the
9442 -- parent type) here, because that would cause the attribute's
9443 -- formal parameter to have the wrong type; hence the Base_Type
9446 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
9447 Build_To_Any_Function
9458 Any := Make_Defining_Identifier (Loc, Name_A);
9459 Result_TC := Build_TypeCode_Call (Loc, Typ, Decls);
9461 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
9463 Expr_Formal := Make_Defining_Identifier (Loc, Name_E);
9464 Params := New_List (
9465 Make_Parameter_Specification (Loc,
9466 Defining_Identifier => Expr_Formal,
9467 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
9468 Set_Etype (Expr_Formal, Typ);
9470 if Is_Limited_Type (Typ) then
9471 Cstr_Formal := Make_Defining_Identifier (Loc, Name_C);
9473 Make_Parameter_Specification (Loc,
9474 Defining_Identifier => Cstr_Formal,
9476 New_Occurrence_Of (Standard_Boolean, Loc)));
9480 Make_Function_Specification (Loc,
9481 Defining_Unit_Name => Fnam,
9482 Parameter_Specifications => Params,
9483 Result_Definition =>
9484 New_Occurrence_Of (RTE (RE_Any), Loc));
9487 Make_Object_Declaration (Loc,
9488 Defining_Identifier => Any,
9489 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9491 Use_Opaque_Representation := False;
9493 if Has_Stream_Attribute_Definition
9494 (Typ, TSS_Stream_Output, At_Any_Place => True)
9496 Has_Stream_Attribute_Definition
9497 (Typ, TSS_Stream_Write, At_Any_Place => True)
9499 -- If user-defined stream attributes are specified for this
9500 -- type, use them and transmit data as an opaque sequence of
9503 Use_Opaque_Representation := True;
9505 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9507 -- Untagged derived type: convert to root type
9510 Rt_Type : constant Entity_Id := Root_Type (Typ);
9511 Expr : constant Node_Id :=
9514 New_Occurrence_Of (Expr_Formal, Loc));
9516 Set_Expression (Any_Decl,
9517 Build_To_Any_Call (Loc, Expr, Decls));
9520 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9522 -- Untagged record type
9524 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9526 Rt_Type : constant Entity_Id := Etype (Typ);
9527 Expr : constant Node_Id :=
9528 OK_Convert_To (Rt_Type,
9529 New_Occurrence_Of (Expr_Formal, Loc));
9533 (Any_Decl, Build_To_Any_Call (Loc, Expr, Decls));
9536 -- Comment needed here (and label on declare block ???)
9540 Disc : Entity_Id := Empty;
9541 Rdef : constant Node_Id :=
9542 Type_Definition (Declaration_Node (Typ));
9544 Elements : constant List_Id := New_List;
9546 procedure TA_Rec_Add_Process_Element
9548 Container : Node_Or_Entity_Id;
9549 Counter : in out Nat;
9552 -- Processing routine for traversal below
9554 procedure TA_Append_Record_Traversal is
9555 new Append_Record_Traversal
9556 (Rec => Expr_Formal,
9557 Add_Process_Element => TA_Rec_Add_Process_Element);
9559 --------------------------------
9560 -- TA_Rec_Add_Process_Element --
9561 --------------------------------
9563 procedure TA_Rec_Add_Process_Element
9565 Container : Node_Or_Entity_Id;
9566 Counter : in out Nat;
9570 Field_Ref : Node_Id;
9573 if Nkind (Field) = N_Defining_Identifier then
9575 -- A regular component
9577 Field_Ref := Make_Selected_Component (Loc,
9578 Prefix => New_Occurrence_Of (Rec, Loc),
9579 Selector_Name => New_Occurrence_Of (Field, Loc));
9580 Set_Etype (Field_Ref, Etype (Field));
9583 Make_Procedure_Call_Statement (Loc,
9586 RTE (RE_Add_Aggregate_Element), Loc),
9587 Parameter_Associations => New_List (
9588 New_Occurrence_Of (Container, Loc),
9589 Build_To_Any_Call (Loc, Field_Ref, Decls))));
9594 Variant_Part : declare
9596 Struct_Counter : Nat := 0;
9598 Block_Decls : constant List_Id := New_List;
9599 Block_Stmts : constant List_Id := New_List;
9602 Alt_List : constant List_Id := New_List;
9603 Choice_List : List_Id;
9605 Union_Any : constant Entity_Id :=
9606 Make_Temporary (Loc, 'V');
9608 Struct_Any : constant Entity_Id :=
9609 Make_Temporary (Loc, 'S');
9611 function Make_Discriminant_Reference
9613 -- Build reference to the discriminant for this
9616 ---------------------------------
9617 -- Make_Discriminant_Reference --
9618 ---------------------------------
9620 function Make_Discriminant_Reference
9623 Nod : constant Node_Id :=
9624 Make_Selected_Component (Loc,
9627 Chars (Name (Field)));
9629 Set_Etype (Nod, Etype (Name (Field)));
9631 end Make_Discriminant_Reference;
9633 -- Start of processing for Variant_Part
9637 Make_Block_Statement (Loc,
9640 Handled_Statement_Sequence =>
9641 Make_Handled_Sequence_Of_Statements (Loc,
9642 Statements => Block_Stmts)));
9644 -- Declare variant part aggregate (Union_Any).
9645 -- Knowing the position of this VP in the
9646 -- variant record, we can fetch the VP typecode
9649 Append_To (Block_Decls,
9650 Make_Object_Declaration (Loc,
9651 Defining_Identifier => Union_Any,
9652 Object_Definition =>
9653 New_Occurrence_Of (RTE (RE_Any), Loc),
9655 Make_Function_Call (Loc,
9656 Name => New_Occurrence_Of (
9657 RTE (RE_Create_Any), Loc),
9658 Parameter_Associations => New_List (
9659 Make_Function_Call (Loc,
9662 RTE (RE_Any_Member_Type), Loc),
9663 Parameter_Associations => New_List (
9664 New_Occurrence_Of (Container, Loc),
9665 Make_Integer_Literal (Loc,
9668 -- Declare inner struct aggregate (which
9669 -- contains the components of this VP).
9671 Append_To (Block_Decls,
9672 Make_Object_Declaration (Loc,
9673 Defining_Identifier => Struct_Any,
9674 Object_Definition =>
9675 New_Occurrence_Of (RTE (RE_Any), Loc),
9677 Make_Function_Call (Loc,
9678 Name => New_Occurrence_Of (
9679 RTE (RE_Create_Any), Loc),
9680 Parameter_Associations => New_List (
9681 Make_Function_Call (Loc,
9684 RTE (RE_Any_Member_Type), Loc),
9685 Parameter_Associations => New_List (
9686 New_Occurrence_Of (Union_Any, Loc),
9687 Make_Integer_Literal (Loc,
9690 -- Build case statement
9692 Append_To (Block_Stmts,
9693 Make_Case_Statement (Loc,
9694 Expression => Make_Discriminant_Reference,
9695 Alternatives => Alt_List));
9697 Variant := First_Non_Pragma (Variants (Field));
9698 while Present (Variant) loop
9699 Choice_List := New_Copy_List_Tree
9700 (Discrete_Choices (Variant));
9702 VP_Stmts := New_List;
9704 -- Append discriminant val to union aggregate
9706 Append_To (VP_Stmts,
9707 Make_Procedure_Call_Statement (Loc,
9710 RTE (RE_Add_Aggregate_Element), Loc),
9711 Parameter_Associations => New_List (
9712 New_Occurrence_Of (Union_Any, Loc),
9715 Make_Discriminant_Reference,
9718 -- Populate inner struct aggregate
9720 -- Struct_Counter should be reset before
9721 -- handling a variant part. Indeed only one
9722 -- of the case statement alternatives will be
9723 -- executed at run time, so the counter must
9724 -- start at 0 for every case statement.
9726 Struct_Counter := 0;
9728 TA_Append_Record_Traversal
9730 Clist => Component_List (Variant),
9731 Container => Struct_Any,
9732 Counter => Struct_Counter);
9734 -- Append inner struct to union aggregate
9736 Append_To (VP_Stmts,
9737 Make_Procedure_Call_Statement (Loc,
9740 (RTE (RE_Add_Aggregate_Element), Loc),
9741 Parameter_Associations => New_List (
9742 New_Occurrence_Of (Union_Any, Loc),
9743 New_Occurrence_Of (Struct_Any, Loc))));
9745 -- Append union to outer aggregate
9747 Append_To (VP_Stmts,
9748 Make_Procedure_Call_Statement (Loc,
9751 (RTE (RE_Add_Aggregate_Element), Loc),
9752 Parameter_Associations => New_List (
9753 New_Occurrence_Of (Container, Loc),
9755 (Union_Any, Loc))));
9757 Append_To (Alt_List,
9758 Make_Case_Statement_Alternative (Loc,
9759 Discrete_Choices => Choice_List,
9760 Statements => VP_Stmts));
9762 Next_Non_Pragma (Variant);
9767 Counter := Counter + 1;
9768 end TA_Rec_Add_Process_Element;
9771 -- Records are encoded in a TC_STRUCT aggregate:
9773 -- -- Outer aggregate (TC_STRUCT)
9774 -- | [discriminant1]
9775 -- | [discriminant2]
9782 -- A component can be a common component or variant part
9784 -- A variant part is encoded as a TC_UNION aggregate:
9786 -- -- Variant Part Aggregate (TC_UNION)
9787 -- | [discriminant choice for this Variant Part]
9789 -- | -- Inner struct (TC_STRUCT)
9794 -- Let's start by building the outer aggregate. First we
9795 -- construct Elements array containing all discriminants.
9797 if Has_Discriminants (Typ) then
9798 Disc := First_Discriminant (Typ);
9799 while Present (Disc) loop
9801 Discriminant : constant Entity_Id :=
9802 Make_Selected_Component (Loc,
9803 Prefix => Expr_Formal,
9804 Selector_Name => Chars (Disc));
9806 Set_Etype (Discriminant, Etype (Disc));
9807 Append_To (Elements,
9808 Make_Component_Association (Loc,
9809 Choices => New_List (
9810 Make_Integer_Literal (Loc, Counter)),
9812 Build_To_Any_Call (Loc,
9813 Discriminant, Decls)));
9816 Counter := Counter + 1;
9817 Next_Discriminant (Disc);
9821 -- If there are no discriminants, we declare an empty
9825 Dummy_Any : constant Entity_Id :=
9826 Make_Temporary (Loc, 'A');
9830 Make_Object_Declaration (Loc,
9831 Defining_Identifier => Dummy_Any,
9832 Object_Definition =>
9833 New_Occurrence_Of (RTE (RE_Any), Loc)));
9835 Append_To (Elements,
9836 Make_Component_Association (Loc,
9837 Choices => New_List (
9840 Make_Integer_Literal (Loc, 1),
9842 Make_Integer_Literal (Loc, 0))),
9844 New_Occurrence_Of (Dummy_Any, Loc)));
9848 -- We build the result aggregate with discriminants
9849 -- as the first elements.
9851 Set_Expression (Any_Decl,
9852 Make_Function_Call (Loc,
9853 Name => New_Occurrence_Of
9854 (RTE (RE_Any_Aggregate_Build), Loc),
9855 Parameter_Associations => New_List (
9857 Make_Aggregate (Loc,
9858 Component_Associations => Elements))));
9861 -- Then we append all the components to the result
9864 TA_Append_Record_Traversal (Stms,
9865 Clist => Component_List (Rdef),
9867 Counter => Counter);
9871 elsif Is_Array_Type (Typ) then
9873 -- Constrained and unconstrained array types
9876 Constrained : constant Boolean :=
9877 not Transmit_As_Unconstrained (Typ);
9879 procedure TA_Ary_Add_Process_Element
9882 Counter : Entity_Id;
9885 --------------------------------
9886 -- TA_Ary_Add_Process_Element --
9887 --------------------------------
9889 procedure TA_Ary_Add_Process_Element
9892 Counter : Entity_Id;
9895 pragma Unreferenced (Counter);
9897 Element_Any : Node_Id;
9900 if Etype (Datum) = RTE (RE_Any) then
9901 Element_Any := Datum;
9903 Element_Any := Build_To_Any_Call (Loc, Datum, Decls);
9907 Make_Procedure_Call_Statement (Loc,
9908 Name => New_Occurrence_Of (
9909 RTE (RE_Add_Aggregate_Element), Loc),
9910 Parameter_Associations => New_List (
9911 New_Occurrence_Of (Any, Loc),
9913 end TA_Ary_Add_Process_Element;
9915 procedure Append_To_Any_Array_Iterator is
9916 new Append_Array_Traversal (
9918 Arry => Expr_Formal,
9919 Indexes => New_List,
9920 Add_Process_Element => TA_Ary_Add_Process_Element);
9925 Set_Expression (Any_Decl,
9926 Make_Function_Call (Loc,
9928 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9929 Parameter_Associations => New_List (Result_TC)));
9932 if not Constrained then
9933 Index := First_Index (Typ);
9934 for J in 1 .. Number_Dimensions (Typ) loop
9936 Make_Procedure_Call_Statement (Loc,
9939 (RTE (RE_Add_Aggregate_Element), Loc),
9940 Parameter_Associations => New_List (
9941 New_Occurrence_Of (Any, Loc),
9942 Build_To_Any_Call (Loc,
9943 OK_Convert_To (Etype (Index),
9944 Make_Attribute_Reference (Loc,
9946 New_Occurrence_Of (Expr_Formal, Loc),
9947 Attribute_Name => Name_First,
9948 Expressions => New_List (
9949 Make_Integer_Literal (Loc, J)))),
9955 Append_To_Any_Array_Iterator (Stms, Any);
9958 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9962 Set_Expression (Any_Decl,
9963 Build_To_Any_Call (Loc,
9965 Find_Numeric_Representation (Typ),
9966 New_Occurrence_Of (Expr_Formal, Loc)),
9970 -- Default case, including tagged types: opaque representation
9972 Use_Opaque_Representation := True;
9975 if Use_Opaque_Representation then
9977 Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
9978 -- Stream used to store data representation produced by
9979 -- stream attribute.
9983 -- Strm : aliased Buffer_Stream_Type;
9986 Make_Object_Declaration (Loc,
9987 Defining_Identifier => Strm,
9988 Aliased_Present => True,
9989 Object_Definition =>
9990 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9993 -- T'Output (Strm'Access, E);
9995 -- T'Write (Strm'Access, E);
9996 -- depending on whether to transmit as unconstrained.
9998 -- For limited types, select at run time depending on
9999 -- Constrained parameter.
10002 function Stream_Call (Attr : Name_Id) return Node_Id;
10003 -- Return a call to the named attribute
10009 function Stream_Call (Attr : Name_Id) return Node_Id is
10011 return Make_Attribute_Reference (Loc,
10013 New_Occurrence_Of (Typ, Loc),
10014 Attribute_Name => Attr,
10015 Expressions => New_List (
10016 Make_Attribute_Reference (Loc,
10018 New_Occurrence_Of (Strm, Loc),
10019 Attribute_Name => Name_Access),
10020 New_Occurrence_Of (Expr_Formal, Loc)));
10025 if Is_Limited_Type (Typ) then
10027 Make_Implicit_If_Statement (Typ,
10029 New_Occurrence_Of (Cstr_Formal, Loc),
10030 Then_Statements => New_List (
10031 Stream_Call (Name_Write)),
10032 Else_Statements => New_List (
10033 Stream_Call (Name_Output))));
10035 elsif Transmit_As_Unconstrained (Typ) then
10036 Append_To (Stms, Stream_Call (Name_Output));
10039 Append_To (Stms, Stream_Call (Name_Write));
10044 -- BS_To_Any (Strm, A);
10047 Make_Procedure_Call_Statement (Loc,
10049 New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
10050 Parameter_Associations => New_List (
10051 New_Occurrence_Of (Strm, Loc),
10052 New_Occurrence_Of (Any, Loc))));
10055 -- Release_Buffer (Strm);
10058 Make_Procedure_Call_Statement (Loc,
10060 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
10061 Parameter_Associations => New_List (
10062 New_Occurrence_Of (Strm, Loc))));
10066 Append_To (Decls, Any_Decl);
10068 if Present (Result_TC) then
10070 Make_Procedure_Call_Statement (Loc,
10072 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
10073 Parameter_Associations => New_List (
10074 New_Occurrence_Of (Any, Loc),
10079 Make_Simple_Return_Statement (Loc,
10080 Expression => New_Occurrence_Of (Any, Loc)));
10083 Make_Subprogram_Body (Loc,
10084 Specification => Spec,
10085 Declarations => Decls,
10086 Handled_Statement_Sequence =>
10087 Make_Handled_Sequence_Of_Statements (Loc,
10088 Statements => Stms));
10089 end Build_To_Any_Function;
10091 -------------------------
10092 -- Build_TypeCode_Call --
10093 -------------------------
10095 function Build_TypeCode_Call
10098 Decls : List_Id) return Node_Id
10100 U_Type : Entity_Id := Underlying_Type (Typ);
10101 -- The full view, if Typ is private; the completion,
10102 -- if Typ is incomplete.
10105 Lib_RE : RE_Id := RE_Null;
10109 -- Special case System.PolyORB.Interface.Any: its primitives have
10110 -- not been set yet, so can't call Find_Inherited_TSS.
10112 if Typ = RTE (RE_Any) then
10113 Fnam := RTE (RE_TC_A);
10116 -- First simple case where the TypeCode is present
10117 -- in the type's TSS.
10119 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10122 -- For the subtype representing a generic actual type, go to the
10125 if Is_Generic_Actual_Subtype (U_Type) then
10126 U_Type := Underlying_Type (Base_Type (U_Type));
10129 -- For a standard subtype, go to the base type
10131 if Sloc (U_Type) <= Standard_Location then
10132 U_Type := Base_Type (U_Type);
10134 -- For a user subtype, go to first subtype
10136 elsif Comes_From_Source (U_Type)
10137 and then Nkind (Declaration_Node (U_Type))
10138 = N_Subtype_Declaration
10140 U_Type := First_Subtype (U_Type);
10144 if U_Type = Standard_Boolean then
10147 elsif U_Type = Standard_Character then
10150 elsif U_Type = Standard_Wide_Character then
10151 Lib_RE := RE_TC_WC;
10153 elsif U_Type = Standard_Wide_Wide_Character then
10154 Lib_RE := RE_TC_WWC;
10156 -- Floating point types
10158 elsif U_Type = Standard_Short_Float then
10159 Lib_RE := RE_TC_SF;
10161 elsif U_Type = Standard_Float then
10164 elsif U_Type = Standard_Long_Float then
10165 Lib_RE := RE_TC_LF;
10167 elsif U_Type = Standard_Long_Long_Float then
10168 Lib_RE := RE_TC_LLF;
10170 -- Integer types (walk back to the base type)
10172 elsif U_Type = RTE (RE_Integer_8) then
10173 Lib_RE := RE_TC_I8;
10175 elsif U_Type = RTE (RE_Integer_16) then
10176 Lib_RE := RE_TC_I16;
10178 elsif U_Type = RTE (RE_Integer_32) then
10179 Lib_RE := RE_TC_I32;
10181 elsif U_Type = RTE (RE_Integer_64) then
10182 Lib_RE := RE_TC_I64;
10184 -- Unsigned integer types
10186 elsif U_Type = RTE (RE_Unsigned_8) then
10187 Lib_RE := RE_TC_U8;
10189 elsif U_Type = RTE (RE_Unsigned_16) then
10190 Lib_RE := RE_TC_U16;
10192 elsif U_Type = RTE (RE_Unsigned_32) then
10193 Lib_RE := RE_TC_U32;
10195 elsif U_Type = RTE (RE_Unsigned_64) then
10196 Lib_RE := RE_TC_U64;
10198 elsif Is_RTE (U_Type, RE_Unbounded_String) then
10199 Lib_RE := RE_TC_String;
10201 -- Special DSA types
10203 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
10206 -- Other (non-primitive) types
10212 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10213 Append_To (Decls, Decl);
10217 if Lib_RE /= RE_Null then
10218 Fnam := RTE (Lib_RE);
10222 -- Call the function
10225 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10227 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10229 Set_Etype (Expr, RTE (RE_TypeCode));
10232 end Build_TypeCode_Call;
10234 -----------------------------
10235 -- Build_TypeCode_Function --
10236 -----------------------------
10238 procedure Build_TypeCode_Function
10241 Decl : out Node_Id;
10242 Fnam : out Entity_Id)
10245 Decls : constant List_Id := New_List;
10246 Stms : constant List_Id := New_List;
10248 TCNam : constant Entity_Id :=
10249 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
10251 Parameters : List_Id;
10253 procedure Add_String_Parameter
10255 Parameter_List : List_Id);
10256 -- Add a literal for S to Parameters
10258 procedure Add_TypeCode_Parameter
10259 (TC_Node : Node_Id;
10260 Parameter_List : List_Id);
10261 -- Add the typecode for Typ to Parameters
10263 procedure Add_Long_Parameter
10264 (Expr_Node : Node_Id;
10265 Parameter_List : List_Id);
10266 -- Add a signed long integer expression to Parameters
10268 procedure Initialize_Parameter_List
10269 (Name_String : String_Id;
10270 Repo_Id_String : String_Id;
10271 Parameter_List : out List_Id);
10272 -- Return a list that contains the first two parameters
10273 -- for a parameterized typecode: name and repository id.
10275 function Make_Constructed_TypeCode
10277 Parameters : List_Id) return Node_Id;
10278 -- Call Build_Complex_TC with the given kind and parameters
10280 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10281 -- Make a return statement that calls Build_Complex_TC with the
10282 -- given typecode kind, and the constructed parameters list.
10284 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10285 -- Return a typecode that is a TC_Alias for the given typecode
10287 --------------------------
10288 -- Add_String_Parameter --
10289 --------------------------
10291 procedure Add_String_Parameter
10293 Parameter_List : List_Id)
10296 Append_To (Parameter_List,
10297 Make_Function_Call (Loc,
10298 Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc),
10299 Parameter_Associations => New_List (
10300 Make_String_Literal (Loc, S))));
10301 end Add_String_Parameter;
10303 ----------------------------
10304 -- Add_TypeCode_Parameter --
10305 ----------------------------
10307 procedure Add_TypeCode_Parameter
10308 (TC_Node : Node_Id;
10309 Parameter_List : List_Id)
10312 Append_To (Parameter_List,
10313 Make_Function_Call (Loc,
10314 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10315 Parameter_Associations => New_List (TC_Node)));
10316 end Add_TypeCode_Parameter;
10318 ------------------------
10319 -- Add_Long_Parameter --
10320 ------------------------
10322 procedure Add_Long_Parameter
10323 (Expr_Node : Node_Id;
10324 Parameter_List : List_Id)
10327 Append_To (Parameter_List,
10328 Make_Function_Call (Loc,
10330 New_Occurrence_Of (RTE (RE_TA_I32), Loc),
10331 Parameter_Associations => New_List (Expr_Node)));
10332 end Add_Long_Parameter;
10334 -------------------------------
10335 -- Initialize_Parameter_List --
10336 -------------------------------
10338 procedure Initialize_Parameter_List
10339 (Name_String : String_Id;
10340 Repo_Id_String : String_Id;
10341 Parameter_List : out List_Id)
10344 Parameter_List := New_List;
10345 Add_String_Parameter (Name_String, Parameter_List);
10346 Add_String_Parameter (Repo_Id_String, Parameter_List);
10347 end Initialize_Parameter_List;
10349 ---------------------------
10350 -- Return_Alias_TypeCode --
10351 ---------------------------
10353 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id) is
10355 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10356 Return_Constructed_TypeCode (RTE (RE_Tk_Alias));
10357 end Return_Alias_TypeCode;
10359 -------------------------------
10360 -- Make_Constructed_TypeCode --
10361 -------------------------------
10363 function Make_Constructed_TypeCode
10365 Parameters : List_Id) return Node_Id
10367 Constructed_TC : constant Node_Id :=
10368 Make_Function_Call (Loc,
10370 New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc),
10371 Parameter_Associations => New_List (
10372 New_Occurrence_Of (Kind, Loc),
10373 Make_Aggregate (Loc,
10374 Expressions => Parameters)));
10376 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10377 return Constructed_TC;
10378 end Make_Constructed_TypeCode;
10380 ---------------------------------
10381 -- Return_Constructed_TypeCode --
10382 ---------------------------------
10384 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10387 Make_Simple_Return_Statement (Loc,
10389 Make_Constructed_TypeCode (Kind, Parameters)));
10390 end Return_Constructed_TypeCode;
10396 procedure TC_Rec_Add_Process_Element
10399 Counter : in out Nat;
10403 procedure TC_Append_Record_Traversal is
10404 new Append_Record_Traversal (
10406 Add_Process_Element => TC_Rec_Add_Process_Element);
10408 --------------------------------
10409 -- TC_Rec_Add_Process_Element --
10410 --------------------------------
10412 procedure TC_Rec_Add_Process_Element
10415 Counter : in out Nat;
10419 pragma Unreferenced (Any, Counter, Rec);
10422 if Nkind (Field) = N_Defining_Identifier then
10424 -- A regular component
10426 Add_TypeCode_Parameter
10427 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10428 Get_Name_String (Chars (Field));
10429 Add_String_Parameter (String_From_Name_Buffer, Params);
10435 Variant_Part : declare
10436 Disc_Type : constant Entity_Id := Etype (Name (Field));
10438 Is_Enum : constant Boolean :=
10439 Is_Enumeration_Type (Disc_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 : Nat := 0;
10456 Choice_Index : Int := 0;
10457 -- Index of current choice in TypeCode, used to identify
10458 -- it as the default choice if it is a "when others".
10460 procedure Add_Params_For_Variant_Components;
10461 -- Add a struct TypeCode and a corresponding member name
10462 -- to the union parameter list.
10464 -- Ordering of declarations is a complete mess in this
10465 -- area, it is supposed to be types/variables, then
10466 -- subprogram specs, then subprogram bodies ???
10468 ---------------------------------------
10469 -- Add_Params_For_Variant_Components --
10470 ---------------------------------------
10472 procedure Add_Params_For_Variant_Components is
10473 S_Name : constant Name_Id :=
10474 New_External_Name (U_Name, 'S', -1);
10477 Get_Name_String (S_Name);
10478 Name_Str := String_From_Name_Buffer;
10479 Initialize_Parameter_List
10480 (Name_Str, Name_Str, Struct_TC_Params);
10482 -- Build struct parameters
10484 TC_Append_Record_Traversal (Struct_TC_Params,
10485 Component_List (Variant),
10489 Add_TypeCode_Parameter
10490 (Make_Constructed_TypeCode
10491 (RTE (RE_Tk_Struct), Struct_TC_Params),
10494 Add_String_Parameter (Name_Str, Union_TC_Params);
10495 end Add_Params_For_Variant_Components;
10497 -- Start of processing for Variant_Part
10500 Get_Name_String (U_Name);
10501 Name_Str := String_From_Name_Buffer;
10503 Initialize_Parameter_List
10504 (Name_Str, Name_Str, Union_TC_Params);
10506 -- Add union in enclosing parameter list
10508 Add_TypeCode_Parameter
10509 (Make_Constructed_TypeCode
10510 (RTE (RE_Tk_Union), Union_TC_Params),
10513 Add_String_Parameter (Name_Str, Params);
10515 -- Build union parameters
10517 Add_TypeCode_Parameter
10518 (Build_TypeCode_Call (Loc, Disc_Type, Decls),
10521 Add_Long_Parameter (Default, Union_TC_Params);
10523 Variant := First_Non_Pragma (Variants (Field));
10524 while Present (Variant) loop
10525 Choice := First (Discrete_Choices (Variant));
10526 while Present (Choice) loop
10527 case Nkind (Choice) is
10530 L : constant Uint :=
10531 Expr_Value (Low_Bound (Choice));
10532 H : constant Uint :=
10533 Expr_Value (High_Bound (Choice));
10535 -- 3.8.1(8) guarantees that the bounds of
10536 -- this range are static.
10543 Expr := Get_Enum_Lit_From_Pos
10544 (Disc_Type, J, Loc);
10547 Make_Integer_Literal (Loc, J);
10550 Set_Etype (Expr, Disc_Type);
10551 Append_To (Union_TC_Params,
10552 Build_To_Any_Call (Loc, Expr, Decls));
10554 Add_Params_For_Variant_Components;
10559 Choice_Index + UI_To_Int (H - L) + 1;
10562 when N_Others_Choice =>
10564 -- This variant has a default choice. We must
10565 -- therefore set the default parameter to the
10566 -- current choice index. This parameter is by
10567 -- construction the 4th in Union_TC_Params.
10570 (Pick (Union_TC_Params, 4),
10571 Make_Function_Call (Loc,
10574 (RTE (RE_TA_I32), Loc),
10575 Parameter_Associations =>
10577 Make_Integer_Literal (Loc,
10578 Intval => Choice_Index))));
10580 -- Add a placeholder member label for the
10581 -- default case, which must have the
10582 -- discriminant type.
10585 Exp : constant Node_Id :=
10586 Make_Attribute_Reference (Loc,
10587 Prefix => New_Occurrence_Of
10589 Attribute_Name => Name_First);
10591 Set_Etype (Exp, Disc_Type);
10592 Append_To (Union_TC_Params,
10593 Build_To_Any_Call (Loc, Exp, Decls));
10596 Add_Params_For_Variant_Components;
10597 Choice_Index := Choice_Index + 1;
10599 -- Case of an explicit choice
10603 Exp : constant Node_Id :=
10604 New_Copy_Tree (Choice);
10606 Append_To (Union_TC_Params,
10607 Build_To_Any_Call (Loc, Exp, Decls));
10610 Add_Params_For_Variant_Components;
10611 Choice_Index := Choice_Index + 1;
10617 Next_Non_Pragma (Variant);
10621 end TC_Rec_Add_Process_Element;
10623 Type_Name_Str : String_Id;
10624 Type_Repo_Id_Str : String_Id;
10626 -- Start of processing for Build_TypeCode_Function
10629 -- For a derived type, we can't go past the base type (to the
10630 -- parent type) here, because that would cause the attribute's
10631 -- formal parameter to have the wrong type; hence the Base_Type
10634 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
10635 Build_TypeCode_Function
10637 Typ => Etype (Typ),
10646 Make_Function_Specification (Loc,
10647 Defining_Unit_Name => Fnam,
10648 Parameter_Specifications => Empty_List,
10649 Result_Definition =>
10650 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10652 Build_Name_And_Repository_Id (Typ,
10653 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10655 Initialize_Parameter_List
10656 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10658 if Has_Stream_Attribute_Definition
10659 (Typ, TSS_Stream_Output, At_Any_Place => True)
10661 Has_Stream_Attribute_Definition
10662 (Typ, TSS_Stream_Write, At_Any_Place => True)
10664 -- If user-defined stream attributes are specified for this
10665 -- type, use them and transmit data as an opaque sequence of
10666 -- stream elements.
10668 Return_Alias_TypeCode
10669 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10671 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
10672 Return_Alias_TypeCode (
10673 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10675 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10676 Return_Alias_TypeCode (
10677 Build_TypeCode_Call (Loc,
10678 Find_Numeric_Representation (Typ), Decls));
10680 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
10682 -- Record typecodes are encoded as follows:
10686 -- | [Repository Id]
10688 -- Then for each discriminant:
10690 -- | [Discriminant Type Code]
10691 -- | [Discriminant Name]
10694 -- Then for each component:
10696 -- | [Component Type Code]
10697 -- | [Component Name]
10700 -- Variants components type codes are encoded as follows:
10704 -- | [Repository Id]
10705 -- | [Discriminant Type Code]
10706 -- | [Index of Default Variant Part or -1 for no default]
10708 -- Then for each Variant Part :
10713 -- | | [Variant Part Name]
10714 -- | | [Variant Part Repository Id]
10716 -- | Then for each VP component:
10717 -- | | [VP component Typecode]
10718 -- | | [VP component Name]
10724 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10725 Return_Alias_TypeCode
10726 (Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10730 Disc : Entity_Id := Empty;
10731 Rdef : constant Node_Id :=
10732 Type_Definition (Declaration_Node (Typ));
10733 Dummy_Counter : Int := 0;
10736 -- Construct the discriminants typecodes
10738 if Has_Discriminants (Typ) then
10739 Disc := First_Discriminant (Typ);
10742 while Present (Disc) loop
10743 Add_TypeCode_Parameter (
10744 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10746 Get_Name_String (Chars (Disc));
10747 Add_String_Parameter (
10748 String_From_Name_Buffer,
10750 Next_Discriminant (Disc);
10753 -- then the components typecodes
10755 TC_Append_Record_Traversal
10756 (Parameters, Component_List (Rdef),
10757 Empty, Dummy_Counter);
10758 Return_Constructed_TypeCode (RTE (RE_Tk_Struct));
10762 elsif Is_Array_Type (Typ) then
10764 Ndim : constant Pos := Number_Dimensions (Typ);
10765 Inner_TypeCode : Node_Id;
10766 Constrained : constant Boolean := Is_Constrained (Typ);
10767 Indx : Node_Id := First_Index (Typ);
10771 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls);
10773 for J in 1 .. Ndim loop
10774 if Constrained then
10775 Inner_TypeCode := Make_Constructed_TypeCode
10776 (RTE (RE_Tk_Array), New_List (
10777 Build_To_Any_Call (Loc,
10778 OK_Convert_To (RTE (RE_Unsigned_32),
10779 Make_Attribute_Reference (Loc,
10780 Prefix => New_Occurrence_Of (Typ, Loc),
10781 Attribute_Name => Name_Length,
10782 Expressions => New_List (
10783 Make_Integer_Literal (Loc,
10784 Intval => Ndim - J + 1)))),
10786 Build_To_Any_Call (Loc, Inner_TypeCode, Decls)));
10789 -- Unconstrained case: add low bound for each
10792 Add_TypeCode_Parameter
10793 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10795 Get_Name_String (New_External_Name ('L', J));
10796 Add_String_Parameter (
10797 String_From_Name_Buffer,
10801 Inner_TypeCode := Make_Constructed_TypeCode
10802 (RTE (RE_Tk_Sequence), New_List (
10803 Build_To_Any_Call (Loc,
10804 OK_Convert_To (RTE (RE_Unsigned_32),
10805 Make_Integer_Literal (Loc, 0)),
10807 Build_To_Any_Call (Loc, Inner_TypeCode, Decls)));
10811 if Constrained then
10812 Return_Alias_TypeCode (Inner_TypeCode);
10814 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10816 Store_String_Char ('V');
10817 Add_String_Parameter (End_String, Parameters);
10818 Return_Constructed_TypeCode (RTE (RE_Tk_Struct));
10823 -- Default: type is represented as an opaque sequence of bytes
10825 Return_Alias_TypeCode
10826 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10830 Make_Subprogram_Body (Loc,
10831 Specification => Spec,
10832 Declarations => Decls,
10833 Handled_Statement_Sequence =>
10834 Make_Handled_Sequence_Of_Statements (Loc,
10835 Statements => Stms));
10836 end Build_TypeCode_Function;
10838 ---------------------------------
10839 -- Find_Numeric_Representation --
10840 ---------------------------------
10842 function Find_Numeric_Representation
10843 (Typ : Entity_Id) return Entity_Id
10845 FST : constant Entity_Id := First_Subtype (Typ);
10846 P_Size : constant Uint := Esize (FST);
10849 -- Special case: for Stream_Element_Offset and Storage_Offset,
10850 -- always force transmission as a 64-bit value.
10852 if Is_RTE (FST, RE_Stream_Element_Offset)
10854 Is_RTE (FST, RE_Storage_Offset)
10856 return RTE (RE_Unsigned_64);
10859 if Is_Unsigned_Type (Typ) then
10860 if P_Size <= 8 then
10861 return RTE (RE_Unsigned_8);
10863 elsif P_Size <= 16 then
10864 return RTE (RE_Unsigned_16);
10866 elsif P_Size <= 32 then
10867 return RTE (RE_Unsigned_32);
10870 return RTE (RE_Unsigned_64);
10873 elsif Is_Integer_Type (Typ) then
10874 if P_Size <= 8 then
10875 return RTE (RE_Integer_8);
10877 elsif P_Size <= Standard_Short_Integer_Size then
10878 return RTE (RE_Integer_16);
10880 elsif P_Size <= Standard_Integer_Size then
10881 return RTE (RE_Integer_32);
10884 return RTE (RE_Integer_64);
10887 elsif Is_Floating_Point_Type (Typ) then
10888 if P_Size <= Standard_Short_Float_Size then
10889 return Standard_Short_Float;
10891 elsif P_Size <= Standard_Float_Size then
10892 return Standard_Float;
10894 elsif P_Size <= Standard_Long_Float_Size then
10895 return Standard_Long_Float;
10898 return Standard_Long_Long_Float;
10902 raise Program_Error;
10905 -- TBD: fixed point types???
10906 -- TBverified numeric types with a biased representation???
10908 end Find_Numeric_Representation;
10910 ---------------------------------
10911 -- Is_Generic_Actual_Subtype --
10912 ---------------------------------
10914 function Is_Generic_Actual_Subtype (Typ : Entity_Id) return Boolean is
10917 and then Present (Associated_Node_For_Itype (Typ))
10920 N : constant Node_Id := Associated_Node_For_Itype (Typ);
10922 if Nkind (N) = N_Subtype_Declaration
10923 and then Nkind (Parent (N)) = N_Package_Specification
10924 and then Is_Generic_Instance (Scope_Of_Spec (Parent (N)))
10932 end Is_Generic_Actual_Subtype;
10934 ---------------------------
10935 -- Append_Array_Traversal --
10936 ---------------------------
10938 procedure Append_Array_Traversal
10941 Counter : Entity_Id := Empty;
10944 Loc : constant Source_Ptr := Sloc (Subprogram);
10945 Typ : constant Entity_Id := Etype (Arry);
10946 Constrained : constant Boolean := Is_Constrained (Typ);
10947 Ndim : constant Pos := Number_Dimensions (Typ);
10949 Inner_Any, Inner_Counter : Entity_Id;
10951 Loop_Stm : Node_Id;
10952 Inner_Stmts : constant List_Id := New_List;
10955 if Depth > Ndim then
10957 -- Processing for one element of an array
10960 Element_Expr : constant Node_Id :=
10961 Make_Indexed_Component (Loc,
10962 New_Occurrence_Of (Arry, Loc),
10965 Set_Etype (Element_Expr, Component_Type (Typ));
10966 Add_Process_Element (Stmts,
10968 Counter => Counter,
10969 Datum => Element_Expr);
10975 Append_To (Indexes,
10976 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10978 if not Constrained or else Depth > 1 then
10979 Inner_Any := Make_Defining_Identifier (Loc,
10980 New_External_Name ('A', Depth));
10981 Set_Etype (Inner_Any, RTE (RE_Any));
10983 Inner_Any := Empty;
10986 if Present (Counter) then
10987 Inner_Counter := Make_Defining_Identifier (Loc,
10988 New_External_Name ('J', Depth));
10990 Inner_Counter := Empty;
10994 Loop_Any : Node_Id := Inner_Any;
10997 -- For the first dimension of a constrained array, we add
10998 -- elements directly in the corresponding Any; there is no
10999 -- intervening inner Any.
11001 if No (Loop_Any) then
11005 Append_Array_Traversal (Inner_Stmts,
11007 Counter => Inner_Counter,
11008 Depth => Depth + 1);
11012 Make_Implicit_Loop_Statement (Subprogram,
11013 Iteration_Scheme =>
11014 Make_Iteration_Scheme (Loc,
11015 Loop_Parameter_Specification =>
11016 Make_Loop_Parameter_Specification (Loc,
11017 Defining_Identifier =>
11018 Make_Defining_Identifier (Loc,
11019 Chars => New_External_Name ('L', Depth)),
11021 Discrete_Subtype_Definition =>
11022 Make_Attribute_Reference (Loc,
11023 Prefix => New_Occurrence_Of (Arry, Loc),
11024 Attribute_Name => Name_Range,
11026 Expressions => New_List (
11027 Make_Integer_Literal (Loc, Depth))))),
11028 Statements => Inner_Stmts);
11031 Decls : constant List_Id := New_List;
11032 Dimen_Stmts : constant List_Id := New_List;
11033 Length_Node : Node_Id;
11035 Inner_Any_TypeCode : constant Entity_Id :=
11036 Make_Defining_Identifier (Loc,
11037 New_External_Name ('T', Depth));
11039 Inner_Any_TypeCode_Expr : Node_Id;
11043 if Constrained then
11044 Inner_Any_TypeCode_Expr :=
11045 Make_Function_Call (Loc,
11046 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
11047 Parameter_Associations => New_List (
11048 New_Occurrence_Of (Any, Loc)));
11051 Inner_Any_TypeCode_Expr :=
11052 Make_Function_Call (Loc,
11054 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
11055 Parameter_Associations => New_List (
11056 New_Occurrence_Of (Any, Loc),
11057 Make_Integer_Literal (Loc, Ndim)));
11061 Inner_Any_TypeCode_Expr :=
11062 Make_Function_Call (Loc,
11063 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc),
11064 Parameter_Associations => New_List (
11065 Make_Identifier (Loc,
11066 Chars => New_External_Name ('T', Depth - 1))));
11070 Make_Object_Declaration (Loc,
11071 Defining_Identifier => Inner_Any_TypeCode,
11072 Constant_Present => True,
11073 Object_Definition => New_Occurrence_Of (
11074 RTE (RE_TypeCode), Loc),
11075 Expression => Inner_Any_TypeCode_Expr));
11077 if Present (Inner_Any) then
11079 Make_Object_Declaration (Loc,
11080 Defining_Identifier => Inner_Any,
11081 Object_Definition =>
11082 New_Occurrence_Of (RTE (RE_Any), Loc),
11084 Make_Function_Call (Loc,
11086 New_Occurrence_Of (
11087 RTE (RE_Create_Any), Loc),
11088 Parameter_Associations => New_List (
11089 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
11092 if Present (Inner_Counter) then
11094 Make_Object_Declaration (Loc,
11095 Defining_Identifier => Inner_Counter,
11096 Object_Definition =>
11097 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc),
11099 Make_Integer_Literal (Loc, 0)));
11102 if not Constrained then
11103 Length_Node := Make_Attribute_Reference (Loc,
11104 Prefix => New_Occurrence_Of (Arry, Loc),
11105 Attribute_Name => Name_Length,
11107 New_List (Make_Integer_Literal (Loc, Depth)));
11108 Set_Etype (Length_Node, RTE (RE_Unsigned_32));
11110 Add_Process_Element (Dimen_Stmts,
11111 Datum => Length_Node,
11113 Counter => Inner_Counter);
11116 -- Loop_Stm does appropriate processing for each element
11119 Append_To (Dimen_Stmts, Loop_Stm);
11121 -- Link outer and inner any
11123 if Present (Inner_Any) then
11124 Add_Process_Element (Dimen_Stmts,
11126 Counter => Counter,
11127 Datum => New_Occurrence_Of (Inner_Any, Loc));
11131 Make_Block_Statement (Loc,
11134 Handled_Statement_Sequence =>
11135 Make_Handled_Sequence_Of_Statements (Loc,
11136 Statements => Dimen_Stmts)));
11138 end Append_Array_Traversal;
11140 -------------------------------
11141 -- Make_Helper_Function_Name --
11142 -------------------------------
11144 function Make_Helper_Function_Name
11147 Nam : Name_Id) return Entity_Id
11152 -- For tagged types that aren't frozen yet, generate the helper
11153 -- under its canonical name so that it matches the primitive
11154 -- spec. For all other cases, we use a serialized name so that
11155 -- multiple generations of the same procedure do not clash.
11158 if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then
11161 Serial := Increment_Serial_Number;
11164 -- Use prefixed underscore to avoid potential clash with user
11165 -- identifier (we use attribute names for Nam).
11168 Make_Defining_Identifier (Loc,
11171 (Related_Id => Nam,
11173 Suffix_Index => Serial,
11176 end Make_Helper_Function_Name;
11179 -----------------------------------
11180 -- Reserve_NamingContext_Methods --
11181 -----------------------------------
11183 procedure Reserve_NamingContext_Methods is
11184 Str_Resolve : constant String := "resolve";
11186 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11187 Name_Len := Str_Resolve'Length;
11188 Overload_Counter_Table.Set (Name_Find, 1);
11189 end Reserve_NamingContext_Methods;
11191 -----------------------
11192 -- RPC_Receiver_Decl --
11193 -----------------------
11195 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is
11196 Loc : constant Source_Ptr := Sloc (RACW_Type);
11199 Make_Object_Declaration (Loc,
11200 Defining_Identifier => Make_Temporary (Loc, 'R'),
11201 Aliased_Present => True,
11202 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
11203 end RPC_Receiver_Decl;
11205 end PolyORB_Support;
11207 -------------------------------
11208 -- RACW_Type_Is_Asynchronous --
11209 -------------------------------
11211 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11212 Asynchronous_Flag : constant Entity_Id :=
11213 Asynchronous_Flags_Table.Get (RACW_Type);
11215 Replace (Expression (Parent (Asynchronous_Flag)),
11216 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11217 end RACW_Type_Is_Asynchronous;
11219 -------------------------
11220 -- RCI_Package_Locator --
11221 -------------------------
11223 function RCI_Package_Locator
11225 Package_Spec : Node_Id) return Node_Id
11228 Pkg_Name : constant String_Id :=
11229 Fully_Qualified_Name_String
11230 (Defining_Entity (Package_Spec), Append_NUL => False);
11234 Make_Package_Instantiation (Loc,
11235 Defining_Unit_Name => Make_Temporary (Loc, 'R'),
11238 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11240 Generic_Associations => New_List (
11241 Make_Generic_Association (Loc,
11243 Make_Identifier (Loc, Name_RCI_Name),
11244 Explicit_Generic_Actual_Parameter =>
11245 Make_String_Literal (Loc,
11246 Strval => Pkg_Name)),
11248 Make_Generic_Association (Loc,
11250 Make_Identifier (Loc, Name_Version),
11251 Explicit_Generic_Actual_Parameter =>
11252 Make_Attribute_Reference (Loc,
11254 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11258 RCI_Locator_Table.Set
11259 (Defining_Unit_Name (Package_Spec),
11260 Defining_Unit_Name (Inst));
11262 end RCI_Package_Locator;
11264 -----------------------------------------------
11265 -- Remote_Types_Tagged_Full_View_Encountered --
11266 -----------------------------------------------
11268 procedure Remote_Types_Tagged_Full_View_Encountered
11269 (Full_View : Entity_Id)
11271 Stub_Elements : constant Stub_Structure :=
11272 Stubs_Table.Get (Full_View);
11275 -- For an RACW encountered before the freeze point of its designated
11276 -- type, the stub type is generated at the point of the RACW declaration
11277 -- but the primitives are generated only once the designated type is
11278 -- frozen. That freeze can occur in another scope, for example when the
11279 -- RACW is declared in a nested package. In that case we need to
11280 -- reestablish the stub type's scope prior to generating its primitive
11283 if Stub_Elements /= Empty_Stub_Structure then
11285 Saved_Scope : constant Entity_Id := Current_Scope;
11286 Stubs_Scope : constant Entity_Id :=
11287 Scope (Stub_Elements.Stub_Type);
11290 if Current_Scope /= Stubs_Scope then
11291 Push_Scope (Stubs_Scope);
11294 Add_RACW_Primitive_Declarations_And_Bodies
11296 Stub_Elements.RPC_Receiver_Decl,
11297 Stub_Elements.Body_Decls);
11299 if Current_Scope /= Saved_Scope then
11304 end Remote_Types_Tagged_Full_View_Encountered;
11306 -------------------
11307 -- Scope_Of_Spec --
11308 -------------------
11310 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11311 Unit_Name : Node_Id;
11314 Unit_Name := Defining_Unit_Name (Spec);
11315 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11316 Unit_Name := Defining_Identifier (Unit_Name);
11322 ----------------------
11323 -- Set_Renaming_TSS --
11324 ----------------------
11326 procedure Set_Renaming_TSS
11329 TSS_Nam : TSS_Name_Type)
11331 Loc : constant Source_Ptr := Sloc (Nam);
11332 Spec : constant Node_Id := Parent (Nam);
11334 TSS_Node : constant Node_Id :=
11335 Make_Subprogram_Renaming_Declaration (Loc,
11337 Copy_Specification (Loc,
11339 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11340 Name => New_Occurrence_Of (Nam, Loc));
11342 Snam : constant Entity_Id :=
11343 Defining_Unit_Name (Specification (TSS_Node));
11346 if Nkind (Spec) = N_Function_Specification then
11347 Set_Ekind (Snam, E_Function);
11348 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11350 Set_Ekind (Snam, E_Procedure);
11351 Set_Etype (Snam, Standard_Void_Type);
11354 Set_TSS (Typ, Snam);
11355 end Set_Renaming_TSS;
11357 ----------------------------------------------
11358 -- Specific_Add_Obj_RPC_Receiver_Completion --
11359 ----------------------------------------------
11361 procedure Specific_Add_Obj_RPC_Receiver_Completion
11364 RPC_Receiver : Entity_Id;
11365 Stub_Elements : Stub_Structure)
11368 case Get_PCS_Name is
11369 when Name_PolyORB_DSA =>
11370 PolyORB_Support.Add_Obj_RPC_Receiver_Completion
11371 (Loc, Decls, RPC_Receiver, Stub_Elements);
11374 GARLIC_Support.Add_Obj_RPC_Receiver_Completion
11375 (Loc, Decls, RPC_Receiver, Stub_Elements);
11377 end Specific_Add_Obj_RPC_Receiver_Completion;
11379 --------------------------------
11380 -- Specific_Add_RACW_Features --
11381 --------------------------------
11383 procedure Specific_Add_RACW_Features
11384 (RACW_Type : Entity_Id;
11386 Stub_Type : Entity_Id;
11387 Stub_Type_Access : Entity_Id;
11388 RPC_Receiver_Decl : Node_Id;
11389 Body_Decls : List_Id)
11392 case Get_PCS_Name is
11393 when Name_PolyORB_DSA =>
11394 PolyORB_Support.Add_RACW_Features
11403 GARLIC_Support.Add_RACW_Features
11410 end Specific_Add_RACW_Features;
11412 --------------------------------
11413 -- Specific_Add_RAST_Features --
11414 --------------------------------
11416 procedure Specific_Add_RAST_Features
11417 (Vis_Decl : Node_Id;
11418 RAS_Type : Entity_Id)
11421 case Get_PCS_Name is
11422 when Name_PolyORB_DSA =>
11423 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11426 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11428 end Specific_Add_RAST_Features;
11430 --------------------------------------------------
11431 -- Specific_Add_Receiving_Stubs_To_Declarations --
11432 --------------------------------------------------
11434 procedure Specific_Add_Receiving_Stubs_To_Declarations
11435 (Pkg_Spec : Node_Id;
11440 case Get_PCS_Name is
11441 when Name_PolyORB_DSA =>
11442 PolyORB_Support.Add_Receiving_Stubs_To_Declarations
11443 (Pkg_Spec, Decls, Stmts);
11446 GARLIC_Support.Add_Receiving_Stubs_To_Declarations
11447 (Pkg_Spec, Decls, Stmts);
11449 end Specific_Add_Receiving_Stubs_To_Declarations;
11451 ------------------------------------------
11452 -- Specific_Build_General_Calling_Stubs --
11453 ------------------------------------------
11455 procedure Specific_Build_General_Calling_Stubs
11457 Statements : List_Id;
11458 Target : RPC_Target;
11459 Subprogram_Id : Node_Id;
11460 Asynchronous : Node_Id := Empty;
11461 Is_Known_Asynchronous : Boolean := False;
11462 Is_Known_Non_Asynchronous : Boolean := False;
11463 Is_Function : Boolean;
11465 Stub_Type : Entity_Id := Empty;
11466 RACW_Type : Entity_Id := Empty;
11470 case Get_PCS_Name is
11471 when Name_PolyORB_DSA =>
11472 PolyORB_Support.Build_General_Calling_Stubs
11478 Is_Known_Asynchronous,
11479 Is_Known_Non_Asynchronous,
11487 GARLIC_Support.Build_General_Calling_Stubs
11491 Target.RPC_Receiver,
11494 Is_Known_Asynchronous,
11495 Is_Known_Non_Asynchronous,
11502 end Specific_Build_General_Calling_Stubs;
11504 --------------------------------------
11505 -- Specific_Build_RPC_Receiver_Body --
11506 --------------------------------------
11508 procedure Specific_Build_RPC_Receiver_Body
11509 (RPC_Receiver : Entity_Id;
11510 Request : out Entity_Id;
11511 Subp_Id : out Entity_Id;
11512 Subp_Index : out Entity_Id;
11513 Stmts : out List_Id;
11514 Decl : out Node_Id)
11517 case Get_PCS_Name is
11518 when Name_PolyORB_DSA =>
11519 PolyORB_Support.Build_RPC_Receiver_Body
11528 GARLIC_Support.Build_RPC_Receiver_Body
11536 end Specific_Build_RPC_Receiver_Body;
11538 --------------------------------
11539 -- Specific_Build_Stub_Target --
11540 --------------------------------
11542 function Specific_Build_Stub_Target
11545 RCI_Locator : Entity_Id;
11546 Controlling_Parameter : Entity_Id) return RPC_Target
11549 case Get_PCS_Name is
11550 when Name_PolyORB_DSA =>
11552 PolyORB_Support.Build_Stub_Target
11553 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11557 GARLIC_Support.Build_Stub_Target
11558 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11560 end Specific_Build_Stub_Target;
11562 --------------------------------
11563 -- Specific_RPC_Receiver_Decl --
11564 --------------------------------
11566 function Specific_RPC_Receiver_Decl
11567 (RACW_Type : Entity_Id) return Node_Id
11570 case Get_PCS_Name is
11571 when Name_PolyORB_DSA =>
11572 return PolyORB_Support.RPC_Receiver_Decl (RACW_Type);
11575 return GARLIC_Support.RPC_Receiver_Decl (RACW_Type);
11577 end Specific_RPC_Receiver_Decl;
11579 -----------------------------------------------
11580 -- Specific_Build_Subprogram_Receiving_Stubs --
11581 -----------------------------------------------
11583 function Specific_Build_Subprogram_Receiving_Stubs
11584 (Vis_Decl : Node_Id;
11585 Asynchronous : Boolean;
11586 Dynamically_Asynchronous : Boolean := False;
11587 Stub_Type : Entity_Id := Empty;
11588 RACW_Type : Entity_Id := Empty;
11589 Parent_Primitive : Entity_Id := Empty) return Node_Id
11592 case Get_PCS_Name is
11593 when Name_PolyORB_DSA =>
11595 PolyORB_Support.Build_Subprogram_Receiving_Stubs
11598 Dynamically_Asynchronous,
11605 GARLIC_Support.Build_Subprogram_Receiving_Stubs
11608 Dynamically_Asynchronous,
11613 end Specific_Build_Subprogram_Receiving_Stubs;
11615 -------------------------------
11616 -- Transmit_As_Unconstrained --
11617 -------------------------------
11619 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
11622 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
11623 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
11624 end Transmit_As_Unconstrained;
11626 --------------------------
11627 -- Underlying_RACW_Type --
11628 --------------------------
11630 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11631 Record_Type : Entity_Id;
11634 if Ekind (RAS_Typ) = E_Record_Type then
11635 Record_Type := RAS_Typ;
11637 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11638 Record_Type := Equivalent_Type (RAS_Typ);
11642 Etype (Subtype_Indication
11643 (Component_Definition
11644 (First (Component_Items
11647 (Declaration_Node (Record_Type))))))));
11648 end Underlying_RACW_Type;