1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Elists; use Elists;
29 with Exp_Atag; use Exp_Atag;
30 with Exp_Disp; use Exp_Disp;
31 with Exp_Strm; use Exp_Strm;
32 with Exp_Tss; use Exp_Tss;
33 with Exp_Util; use Exp_Util;
35 with Nlists; use Nlists;
36 with Nmake; use Nmake;
38 with Rtsfind; use Rtsfind;
40 with Sem_Aux; use Sem_Aux;
41 with Sem_Cat; use Sem_Cat;
42 with Sem_Ch3; use Sem_Ch3;
43 with Sem_Ch8; use Sem_Ch8;
44 with Sem_Dist; use Sem_Dist;
45 with Sem_Eval; use Sem_Eval;
46 with Sem_Util; use Sem_Util;
47 with Sinfo; use Sinfo;
48 with Stand; use Stand;
49 with Stringt; use Stringt;
50 with Tbuild; use Tbuild;
51 with Ttypes; use Ttypes;
52 with Uintp; use Uintp;
54 with GNAT.HTable; use GNAT.HTable;
56 package body Exp_Dist is
58 -- The following model has been used to implement distributed objects:
59 -- given a designated type D and a RACW type R, then a record of the form:
61 -- type Stub is tagged record
62 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
65 -- is built. This type has two properties:
67 -- 1) Since it has the same structure than 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 arrive 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 names. 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
174 -- subprogram proxy type.
175 -- ACR_Expression is use as the initialization value for
176 -- the All_Calls_Remote component.
178 function Build_Get_Unique_RP_Call
181 Stub_Type : Entity_Id) return List_Id;
182 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
183 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
184 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
186 function Build_Stub_Tag
188 RACW_Type : Entity_Id) return Node_Id;
189 -- Return an expression denoting the tag of the stub type associated with
192 function Build_Subprogram_Calling_Stubs
195 Asynchronous : Boolean;
196 Dynamically_Asynchronous : Boolean := False;
197 Stub_Type : Entity_Id := Empty;
198 RACW_Type : Entity_Id := Empty;
199 Locator : Entity_Id := Empty;
200 New_Name : Name_Id := No_Name) return Node_Id;
201 -- Build the calling stub for a given subprogram with the subprogram ID
202 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
203 -- parameters of this type will be marshalled instead of the object
204 -- itself. It will then be converted into Stub_Type before performing
205 -- the real call. If Dynamically_Asynchronous is True, then it will be
206 -- computed at run time whether the call is asynchronous or not.
207 -- Otherwise, the value of the formal Asynchronous will be used.
208 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
209 -- New_Name is given, then it will be used instead of the original name.
211 function Build_RPC_Receiver_Specification
212 (RPC_Receiver : Entity_Id;
213 Request_Parameter : Entity_Id) return Node_Id;
214 -- Make a subprogram specification for an RPC receiver, with the given
215 -- defining unit name and formal parameter.
217 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
218 -- Return an ordered parameter list: unconstrained parameters are put
219 -- at the beginning of the list and constrained ones are put after. If
220 -- there are no parameters, an empty list is returned. Special case:
221 -- the controlling formal of the equivalent RACW operation for a RAS
222 -- type is always left in first position.
224 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean;
225 -- True when Typ is an unconstrained type, or a null-excluding access type.
226 -- In either case, this means stubs cannot contain a default-initialized
227 -- object declaration of such type.
229 procedure Add_Calling_Stubs_To_Declarations
232 -- Add calling stubs to the declarative part
234 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
235 -- Return True if nothing prevents the program whose specification is
236 -- given to be asynchronous (i.e. no out parameter).
238 function Pack_Entity_Into_Stream_Access
242 Etyp : Entity_Id := Empty) return Node_Id;
243 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
244 -- then Etype (Object) will be used if present. If the type is
245 -- constrained, then 'Write will be used to output the object,
246 -- If the type is unconstrained, 'Output will be used.
248 function Pack_Node_Into_Stream
252 Etyp : Entity_Id) return Node_Id;
253 -- Similar to above, with an arbitrary node instead of an entity
255 function Pack_Node_Into_Stream_Access
259 Etyp : Entity_Id) return Node_Id;
260 -- Similar to above, with Stream instead of Stream'Access
262 function Make_Selected_Component
265 Selector_Name : Name_Id) return Node_Id;
266 -- Return a selected_component whose prefix denotes the given entity, and
267 -- with the given Selector_Name.
269 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
270 -- Return the scope represented by a given spec
272 procedure Set_Renaming_TSS
275 TSS_Nam : TSS_Name_Type);
276 -- Create a renaming declaration of subprogram Nam, and register it as a
277 -- TSS for Typ with name TSS_Nam.
279 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
280 -- Return True if the current parameter needs an extra formal to reflect
281 -- its constrained status.
283 function Is_RACW_Controlling_Formal
284 (Parameter : Node_Id;
285 Stub_Type : Entity_Id) return Boolean;
286 -- Return True if the current parameter is a controlling formal argument
287 -- of type Stub_Type or access to Stub_Type.
289 procedure Declare_Create_NVList
294 -- Append the declaration of NVList to Decls, and its
295 -- initialization to Stmts.
297 function Add_Parameter_To_NVList
300 Parameter : Entity_Id;
301 Constrained : Boolean;
302 RACW_Ctrl : Boolean := False;
303 Any : Entity_Id) return Node_Id;
304 -- Return a call to Add_Item to add the Any corresponding to the designated
305 -- formal Parameter (with the indicated Constrained status) to NVList.
306 -- RACW_Ctrl must be set to True for controlling formals of distributed
307 -- object primitive operations.
313 -- This record describes various tree fragments associated with the
314 -- generation of RACW calling stubs. One such record exists for every
315 -- distributed object type, i.e. each tagged type that is the designated
316 -- type of one or more RACW type.
318 type Stub_Structure is record
319 Stub_Type : Entity_Id;
320 -- Stub type: this type has the same primitive operations as the
321 -- designated types, but the provided bodies for these operations
322 -- a remote call to an actual target object potentially located on
323 -- another partition; each value of the stub type encapsulates a
324 -- reference to a remote object.
326 Stub_Type_Access : Entity_Id;
327 -- A local access type designating the stub type (this is not an RACW
330 RPC_Receiver_Decl : Node_Id;
331 -- Declaration for the RPC receiver entity associated with the
332 -- designated type. As an exception, for the case of an RACW that
333 -- implements a RAS, no object RPC receiver is generated. Instead,
334 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
335 -- would have been inserted.
337 Body_Decls : List_Id;
338 -- List of subprogram bodies to be included in generated code: bodies
339 -- for the RACW's stream attributes, and for the primitive operations
342 RACW_Type : Entity_Id;
343 -- One of the RACW types designating this distributed object type
344 -- (they are all interchangeable; we use any one of them in order to
345 -- avoid having to create various anonymous access types).
349 Empty_Stub_Structure : constant Stub_Structure :=
350 (Empty, Empty, Empty, No_List, Empty);
352 package Stubs_Table is
353 new Simple_HTable (Header_Num => Hash_Index,
354 Element => Stub_Structure,
355 No_Element => Empty_Stub_Structure,
359 -- Mapping between a RACW designated type and its stub type
361 package Asynchronous_Flags_Table is
362 new Simple_HTable (Header_Num => Hash_Index,
363 Element => Entity_Id,
368 -- Mapping between a RACW type and a constant having the value True
369 -- if the RACW is asynchronous and False otherwise.
371 package RCI_Locator_Table is
372 new Simple_HTable (Header_Num => Hash_Index,
373 Element => Entity_Id,
378 -- Mapping between a RCI package on which All_Calls_Remote applies and
379 -- the generic instantiation of RCI_Locator for this package.
381 package RCI_Calling_Stubs_Table is
382 new Simple_HTable (Header_Num => Hash_Index,
383 Element => Entity_Id,
388 -- Mapping between a RCI subprogram and the corresponding calling stubs
390 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure;
391 -- Return the stub information associated with the given RACW type
393 procedure Add_Stub_Type
394 (Designated_Type : Entity_Id;
395 RACW_Type : Entity_Id;
397 Stub_Type : out Entity_Id;
398 Stub_Type_Access : out Entity_Id;
399 RPC_Receiver_Decl : out Node_Id;
400 Body_Decls : out List_Id;
401 Existing : out Boolean);
402 -- Add the declaration of the stub type, the access to stub type and the
403 -- object RPC receiver at the end of Decls. If these already exist,
404 -- then nothing is added in the tree but the right values are returned
405 -- anyhow and Existing is set to True.
407 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
408 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
409 -- structure table, reset it to No_List, and return the previous value.
411 procedure Add_RACW_Asynchronous_Flag
412 (Declarations : List_Id;
413 RACW_Type : Entity_Id);
414 -- Declare a boolean constant associated with RACW_Type whose value
415 -- indicates at run time whether a pragma Asynchronous applies to it.
417 procedure Assign_Subprogram_Identifier
421 -- Determine the distribution subprogram identifier to
422 -- be used for remote subprogram Def, return it in Id and
423 -- store it in a hash table for later retrieval by
424 -- Get_Subprogram_Id. Spn is the subprogram number.
426 function RCI_Package_Locator
428 Package_Spec : Node_Id) return Node_Id;
429 -- Instantiate the generic package RCI_Locator in order to locate the
430 -- RCI package whose spec is given as argument.
432 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
433 -- Surround a node N by a tag check, as in:
437 -- when E : Ada.Tags.Tag_Error =>
438 -- Raise_Exception (Program_Error'Identity,
439 -- Exception_Message (E));
442 function Input_With_Tag_Check
444 Var_Type : Entity_Id;
445 Stream : Node_Id) return Node_Id;
446 -- Return a function with the following form:
447 -- function R return Var_Type is
449 -- return Var_Type'Input (S);
451 -- when E : Ada.Tags.Tag_Error =>
452 -- Raise_Exception (Program_Error'Identity,
453 -- Exception_Message (E));
456 procedure Build_Actual_Object_Declaration
462 -- Build the declaration of an object with the given defining identifier,
463 -- initialized with Expr if provided, to serve as actual parameter in a
464 -- server stub. If Variable is true, the declared object will be a variable
465 -- (case of an out or in out formal), else it will be a constant. Object's
466 -- Ekind is set accordingly. The declaration, as well as any other
467 -- declarations it requires, are appended to Decls.
469 --------------------------------------------
470 -- Hooks for PCS-specific code generation --
471 --------------------------------------------
473 -- Part of the code generation circuitry for distribution needs to be
474 -- tailored for each implementation of the PCS. For each routine that
475 -- needs to be specialized, a Specific_<routine> wrapper is created,
476 -- which calls the corresponding <routine> in package
477 -- <pcs_implementation>_Support.
479 procedure Specific_Add_RACW_Features
480 (RACW_Type : Entity_Id;
482 Stub_Type : Entity_Id;
483 Stub_Type_Access : Entity_Id;
484 RPC_Receiver_Decl : Node_Id;
485 Body_Decls : List_Id);
486 -- Add declaration for TSSs for a given RACW type. The declarations are
487 -- added just after the declaration of the RACW type itself. If the RACW
488 -- appears in the main unit, Body_Decls is a list of declarations to which
489 -- the bodies are appended. Else Body_Decls is No_List.
490 -- PCS-specific ancillary subprogram for Add_RACW_Features.
492 procedure Specific_Add_RAST_Features
494 RAS_Type : Entity_Id);
495 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
496 -- subprogram for Add_RAST_Features.
498 -- An RPC_Target record is used during construction of calling stubs
499 -- to pass PCS-specific tree fragments corresponding to the information
500 -- necessary to locate the target of a remote subprogram call.
502 type RPC_Target (PCS_Kind : PCS_Names) is record
504 when Name_PolyORB_DSA =>
506 -- An expression whose value is a PolyORB reference to the target
510 Partition : Entity_Id;
511 -- A variable containing the Partition_ID of the target partition
513 RPC_Receiver : Node_Id;
514 -- An expression whose value is the address of the target RPC
519 procedure Specific_Build_General_Calling_Stubs
521 Statements : List_Id;
523 Subprogram_Id : Node_Id;
524 Asynchronous : Node_Id := Empty;
525 Is_Known_Asynchronous : Boolean := False;
526 Is_Known_Non_Asynchronous : Boolean := False;
527 Is_Function : Boolean;
529 Stub_Type : Entity_Id := Empty;
530 RACW_Type : Entity_Id := Empty;
532 -- Build calling stubs for general purpose. The parameters are:
533 -- Decls : a place to put declarations
534 -- Statements : a place to put statements
535 -- Target : PCS-specific target information (see details
536 -- in RPC_Target declaration).
537 -- Subprogram_Id : a node containing the subprogram ID
538 -- Asynchronous : True if an APC must be made instead of an RPC.
539 -- The value needs not be supplied if one of the
540 -- Is_Known_... is True.
541 -- Is_Known_Async... : True if we know that this is asynchronous
542 -- Is_Known_Non_A... : True if we know that this is not asynchronous
543 -- Spec : a node with a Parameter_Specifications and
544 -- a Result_Definition if applicable
545 -- Stub_Type : in case of RACW stubs, parameters of type access
546 -- to Stub_Type will be marshalled using the
547 -- address of the object (the addr field) rather
548 -- than using the 'Write on the stub itself
549 -- Nod : used to provide sloc for generated code
551 function Specific_Build_Stub_Target
554 RCI_Locator : Entity_Id;
555 Controlling_Parameter : Entity_Id) return RPC_Target;
556 -- Build call target information nodes for use within calling stubs. In the
557 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
558 -- for an RACW, Controlling_Parameter is the entity for the controlling
559 -- formal parameter used to determine the location of the target of the
560 -- call. Decls provides a location where variable declarations can be
561 -- appended to construct the necessary values.
563 procedure Specific_Build_Stub_Type
564 (RACW_Type : Entity_Id;
565 Stub_Type_Comps : out List_Id;
566 RPC_Receiver_Decl : out Node_Id);
567 -- Build a components list for the stub type associated with an RACW type,
568 -- and build the necessary RPC receiver, if applicable. PCS-specific
569 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
570 -- is generated, then RPC_Receiver_Decl is set to Empty.
572 procedure Specific_Build_RPC_Receiver_Body
573 (RPC_Receiver : Entity_Id;
574 Request : out Entity_Id;
575 Subp_Id : out Entity_Id;
576 Subp_Index : out Entity_Id;
579 -- Make a subprogram body for an RPC receiver, with the given
580 -- defining unit name. On return:
581 -- - Subp_Id is the subprogram identifier from the PCS.
582 -- - Subp_Index is the index in the list of subprograms
583 -- used for dispatching (a variable of type Subprogram_Id).
584 -- - Stmts is the place where the request dispatching
585 -- statements can occur,
586 -- - Decl is the subprogram body declaration.
588 function Specific_Build_Subprogram_Receiving_Stubs
590 Asynchronous : Boolean;
591 Dynamically_Asynchronous : Boolean := False;
592 Stub_Type : Entity_Id := Empty;
593 RACW_Type : Entity_Id := Empty;
594 Parent_Primitive : Entity_Id := Empty) return Node_Id;
595 -- Build the receiving stub for a given subprogram. The subprogram
596 -- declaration is also built by this procedure, and the value returned
597 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
598 -- found in the specification, then its address is read from the stream
599 -- instead of the object itself and converted into an access to
600 -- class-wide type before doing the real call using any of the RACW type
601 -- pointing on the designated type.
603 procedure Specific_Add_Obj_RPC_Receiver_Completion
606 RPC_Receiver : Entity_Id;
607 Stub_Elements : Stub_Structure);
608 -- Add the necessary code to Decls after the completion of generation
609 -- of the RACW RPC receiver described by Stub_Elements.
611 procedure Specific_Add_Receiving_Stubs_To_Declarations
615 -- Add receiving stubs to the declarative part of an RCI unit
621 package GARLIC_Support is
623 -- Support for generating DSA code that uses the GARLIC PCS
625 -- The subprograms below provide the GARLIC versions of the
626 -- corresponding Specific_<subprogram> routine declared above.
628 procedure Add_RACW_Features
629 (RACW_Type : Entity_Id;
630 Stub_Type : Entity_Id;
631 Stub_Type_Access : Entity_Id;
632 RPC_Receiver_Decl : Node_Id;
633 Body_Decls : List_Id);
635 procedure Add_RAST_Features
637 RAS_Type : Entity_Id);
639 procedure Build_General_Calling_Stubs
641 Statements : List_Id;
642 Target_Partition : Entity_Id; -- From RPC_Target
643 Target_RPC_Receiver : Node_Id; -- From RPC_Target
644 Subprogram_Id : Node_Id;
645 Asynchronous : Node_Id := Empty;
646 Is_Known_Asynchronous : Boolean := False;
647 Is_Known_Non_Asynchronous : Boolean := False;
648 Is_Function : Boolean;
650 Stub_Type : Entity_Id := Empty;
651 RACW_Type : Entity_Id := Empty;
654 function Build_Stub_Target
657 RCI_Locator : Entity_Id;
658 Controlling_Parameter : Entity_Id) return RPC_Target;
660 procedure Build_Stub_Type
661 (RACW_Type : Entity_Id;
662 Stub_Type_Comps : out List_Id;
663 RPC_Receiver_Decl : out Node_Id);
665 function Build_Subprogram_Receiving_Stubs
667 Asynchronous : Boolean;
668 Dynamically_Asynchronous : Boolean := False;
669 Stub_Type : Entity_Id := Empty;
670 RACW_Type : Entity_Id := Empty;
671 Parent_Primitive : Entity_Id := Empty) return Node_Id;
673 procedure Add_Obj_RPC_Receiver_Completion
676 RPC_Receiver : Entity_Id;
677 Stub_Elements : Stub_Structure);
679 procedure Add_Receiving_Stubs_To_Declarations
684 procedure Build_RPC_Receiver_Body
685 (RPC_Receiver : Entity_Id;
686 Request : out Entity_Id;
687 Subp_Id : out Entity_Id;
688 Subp_Index : out Entity_Id;
694 ---------------------
695 -- PolyORB_Support --
696 ---------------------
698 package PolyORB_Support is
700 -- Support for generating DSA code that uses the PolyORB PCS
702 -- The subprograms below provide the PolyORB versions of the
703 -- corresponding Specific_<subprogram> routine declared above.
705 procedure Add_RACW_Features
706 (RACW_Type : Entity_Id;
708 Stub_Type : Entity_Id;
709 Stub_Type_Access : Entity_Id;
710 RPC_Receiver_Decl : Node_Id;
711 Body_Decls : List_Id);
713 procedure Add_RAST_Features
715 RAS_Type : Entity_Id);
717 procedure Build_General_Calling_Stubs
719 Statements : List_Id;
720 Target_Object : Node_Id; -- From RPC_Target
721 Subprogram_Id : Node_Id;
722 Asynchronous : Node_Id := Empty;
723 Is_Known_Asynchronous : Boolean := False;
724 Is_Known_Non_Asynchronous : Boolean := False;
725 Is_Function : Boolean;
727 Stub_Type : Entity_Id := Empty;
728 RACW_Type : Entity_Id := Empty;
731 function Build_Stub_Target
734 RCI_Locator : Entity_Id;
735 Controlling_Parameter : Entity_Id) return RPC_Target;
737 procedure Build_Stub_Type
738 (RACW_Type : Entity_Id;
739 Stub_Type_Comps : out List_Id;
740 RPC_Receiver_Decl : out Node_Id);
742 function Build_Subprogram_Receiving_Stubs
744 Asynchronous : Boolean;
745 Dynamically_Asynchronous : Boolean := False;
746 Stub_Type : Entity_Id := Empty;
747 RACW_Type : Entity_Id := Empty;
748 Parent_Primitive : Entity_Id := Empty) return Node_Id;
750 procedure Add_Obj_RPC_Receiver_Completion
753 RPC_Receiver : Entity_Id;
754 Stub_Elements : Stub_Structure);
756 procedure Add_Receiving_Stubs_To_Declarations
761 procedure Build_RPC_Receiver_Body
762 (RPC_Receiver : Entity_Id;
763 Request : out Entity_Id;
764 Subp_Id : out Entity_Id;
765 Subp_Index : out Entity_Id;
769 procedure Reserve_NamingContext_Methods;
770 -- Mark the method names for interface NamingContext as already used in
771 -- the overload table, so no clashes occur with user code (with the
772 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
773 -- their methods to be accessed as objects, for the implementation of
774 -- remote access-to-subprogram types).
782 -- Routines to build distribution helper subprograms for user-defined
783 -- types. For implementation of the Distributed systems annex (DSA)
784 -- over the PolyORB generic middleware components, it is necessary to
785 -- generate several supporting subprograms for each application data
786 -- type used in inter-partition communication. These subprograms are:
788 -- A Typecode function returning a high-level description of the
791 -- Two conversion functions allowing conversion of values of the
792 -- type from and to the generic data containers used by PolyORB.
793 -- These generic containers are called 'Any' type values after the
794 -- CORBA terminology, and hence the conversion subprograms are
795 -- named To_Any and From_Any.
797 function Build_From_Any_Call
800 Decls : List_Id) return Node_Id;
801 -- Build call to From_Any attribute function of type Typ with
802 -- expression N as actual parameter. Decls is the declarations list
803 -- for an appropriate enclosing scope of the point where the call
804 -- will be inserted; if the From_Any attribute for Typ needs to be
805 -- generated at this point, its declaration is appended to Decls.
807 procedure Build_From_Any_Function
811 Fnam : out Entity_Id);
812 -- Build From_Any attribute function for Typ. Loc is the reference
813 -- location for generated nodes, Typ is the type for which the
814 -- conversion function is generated. On return, Decl and Fnam contain
815 -- the declaration and entity for the newly-created function.
817 function Build_To_Any_Call
819 Decls : List_Id) return Node_Id;
820 -- Build call to To_Any attribute function with expression as actual
821 -- parameter. Decls is the declarations list for an appropriate
822 -- enclosing scope of the point where the call will be inserted; if
823 -- the To_Any attribute for Typ needs to be generated at this point,
824 -- its declaration is appended to Decls.
826 procedure Build_To_Any_Function
830 Fnam : out Entity_Id);
831 -- Build To_Any attribute function for Typ. Loc is the reference
832 -- location for generated nodes, Typ is the type for which the
833 -- conversion function is generated. On return, Decl and Fnam contain
834 -- the declaration and entity for the newly-created function.
836 function Build_TypeCode_Call
839 Decls : List_Id) return Node_Id;
840 -- Build call to TypeCode attribute function for Typ. Decls is the
841 -- declarations list for an appropriate enclosing scope of the point
842 -- where the call will be inserted; if the To_Any attribute for Typ
843 -- needs to be generated at this point, its declaration is appended
846 procedure Build_TypeCode_Function
850 Fnam : out Entity_Id);
851 -- Build TypeCode attribute function for Typ. Loc is the reference
852 -- location for generated nodes, Typ is the type for which the
853 -- conversion function is generated. On return, Decl and Fnam contain
854 -- the declaration and entity for the newly-created function.
856 procedure Build_Name_And_Repository_Id
858 Name_Str : out String_Id;
859 Repo_Id_Str : out String_Id);
860 -- In the PolyORB distribution model, each distributed object type
861 -- and each distributed operation has a globally unique identifier,
862 -- its Repository Id. This subprogram builds and returns two strings
863 -- for entity E (a distributed object type or operation): one
864 -- containing the name of E, the second containing its repository id.
866 procedure Assign_Opaque_From_Any
872 -- For a Target object of type Typ, which has opaque representation
873 -- as a sequence of octets determined by stream attributes (which
874 -- includes all limited types), append code to Stmts performing the
876 -- Target := Typ'From_Any (N)
878 -- or, if Target is Empty:
879 -- return Typ'From_Any (N)
885 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
887 function Build_From_Any_Call
890 Decls : List_Id) return Node_Id
891 renames PolyORB_Support.Helpers.Build_From_Any_Call;
893 function Build_To_Any_Call
895 Decls : List_Id) return Node_Id
896 renames PolyORB_Support.Helpers.Build_To_Any_Call;
898 function Build_TypeCode_Call
901 Decls : List_Id) return Node_Id
902 renames PolyORB_Support.Helpers.Build_TypeCode_Call;
904 ------------------------------------
905 -- Local variables and structures --
906 ------------------------------------
909 -- Needs comments ???
911 Output_From_Constrained : constant array (Boolean) of Name_Id :=
912 (False => Name_Output,
914 -- The attribute to choose depending on the fact that the parameter
915 -- is constrained or not. There is no such thing as Input_From_Constrained
916 -- since this require separate mechanisms ('Input is a function while
917 -- 'Read is a procedure).
919 ---------------------------------------
920 -- Add_Calling_Stubs_To_Declarations --
921 ---------------------------------------
923 procedure Add_Calling_Stubs_To_Declarations
927 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
928 -- Subprogram id 0 is reserved for calls received from
929 -- remote access-to-subprogram dereferences.
931 Current_Declaration : Node_Id;
932 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
933 RCI_Instantiation : Node_Id;
934 Subp_Stubs : Node_Id;
935 Subp_Str : String_Id;
937 pragma Warnings (Off, Subp_Str);
940 -- The first thing added is an instantiation of the generic package
941 -- System.Partition_Interface.RCI_Locator with the name of this remote
942 -- package. This will act as an interface with the name server to
943 -- determine the Partition_ID and the RPC_Receiver for the receiver
946 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
947 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
949 Append_To (Decls, RCI_Instantiation);
950 Analyze (RCI_Instantiation);
952 -- For each subprogram declaration visible in the spec, we do build a
953 -- body. We also increment a counter to assign a different Subprogram_Id
954 -- to each subprograms. The receiving stubs processing do use the same
955 -- mechanism and will thus assign the same Id and do the correct
958 Overload_Counter_Table.Reset;
959 PolyORB_Support.Reserve_NamingContext_Methods;
961 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
962 while Present (Current_Declaration) loop
963 if Nkind (Current_Declaration) = N_Subprogram_Declaration
964 and then Comes_From_Source (Current_Declaration)
966 Assign_Subprogram_Identifier
967 (Defining_Unit_Name (Specification (Current_Declaration)),
968 Current_Subprogram_Number,
972 Build_Subprogram_Calling_Stubs (
973 Vis_Decl => Current_Declaration,
975 Build_Subprogram_Id (Loc,
976 Defining_Unit_Name (Specification (Current_Declaration))),
978 Nkind (Specification (Current_Declaration)) =
979 N_Procedure_Specification
981 Is_Asynchronous (Defining_Unit_Name (Specification
982 (Current_Declaration))));
984 Append_To (Decls, Subp_Stubs);
985 Analyze (Subp_Stubs);
987 Current_Subprogram_Number := Current_Subprogram_Number + 1;
990 Next (Current_Declaration);
992 end Add_Calling_Stubs_To_Declarations;
994 -----------------------------
995 -- Add_Parameter_To_NVList --
996 -----------------------------
998 function Add_Parameter_To_NVList
1001 Parameter : Entity_Id;
1002 Constrained : Boolean;
1003 RACW_Ctrl : Boolean := False;
1004 Any : Entity_Id) return Node_Id
1006 Parameter_Name_String : String_Id;
1007 Parameter_Mode : Node_Id;
1009 function Parameter_Passing_Mode
1011 Parameter : Entity_Id;
1012 Constrained : Boolean) return Node_Id;
1013 -- Return an expression that denotes the parameter passing mode to be
1014 -- used for Parameter in distribution stubs, where Constrained is
1015 -- Parameter's constrained status.
1017 ----------------------------
1018 -- Parameter_Passing_Mode --
1019 ----------------------------
1021 function Parameter_Passing_Mode
1023 Parameter : Entity_Id;
1024 Constrained : Boolean) return Node_Id
1029 if Out_Present (Parameter) then
1030 if In_Present (Parameter)
1031 or else not Constrained
1033 -- Unconstrained formals must be translated
1034 -- to 'in' or 'inout', not 'out', because
1035 -- they need to be constrained by the actual.
1037 Lib_RE := RE_Mode_Inout;
1039 Lib_RE := RE_Mode_Out;
1043 Lib_RE := RE_Mode_In;
1046 return New_Occurrence_Of (RTE (Lib_RE), Loc);
1047 end Parameter_Passing_Mode;
1049 -- Start of processing for Add_Parameter_To_NVList
1052 if Nkind (Parameter) = N_Defining_Identifier then
1053 Get_Name_String (Chars (Parameter));
1055 Get_Name_String (Chars (Defining_Identifier (Parameter)));
1058 Parameter_Name_String := String_From_Name_Buffer;
1060 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1062 -- When the parameter passed to Add_Parameter_To_NVList is an
1063 -- Extra_Constrained parameter, Parameter is an N_Defining_
1064 -- Identifier, instead of a complete N_Parameter_Specification.
1065 -- Thus, we explicitly set 'in' mode in this case.
1067 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1071 Parameter_Passing_Mode (Loc, Parameter, Constrained);
1075 Make_Procedure_Call_Statement (Loc,
1078 (RTE (RE_NVList_Add_Item), Loc),
1079 Parameter_Associations => New_List (
1080 New_Occurrence_Of (NVList, Loc),
1081 Make_Function_Call (Loc,
1084 (RTE (RE_To_PolyORB_String), Loc),
1085 Parameter_Associations => New_List (
1086 Make_String_Literal (Loc,
1087 Strval => Parameter_Name_String))),
1088 New_Occurrence_Of (Any, Loc),
1090 end Add_Parameter_To_NVList;
1092 --------------------------------
1093 -- Add_RACW_Asynchronous_Flag --
1094 --------------------------------
1096 procedure Add_RACW_Asynchronous_Flag
1097 (Declarations : List_Id;
1098 RACW_Type : Entity_Id)
1100 Loc : constant Source_Ptr := Sloc (RACW_Type);
1102 Asynchronous_Flag : constant Entity_Id :=
1103 Make_Defining_Identifier (Loc,
1104 New_External_Name (Chars (RACW_Type), 'A'));
1107 -- Declare the asynchronous flag. This flag will be changed to True
1108 -- whenever it is known that the RACW type is asynchronous.
1110 Append_To (Declarations,
1111 Make_Object_Declaration (Loc,
1112 Defining_Identifier => Asynchronous_Flag,
1113 Constant_Present => True,
1114 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1115 Expression => New_Occurrence_Of (Standard_False, Loc)));
1117 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1118 end Add_RACW_Asynchronous_Flag;
1120 -----------------------
1121 -- Add_RACW_Features --
1122 -----------------------
1124 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1125 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1126 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1130 Body_Decls : List_Id;
1132 Stub_Type : Entity_Id;
1133 Stub_Type_Access : Entity_Id;
1134 RPC_Receiver_Decl : Node_Id;
1137 -- True when appropriate stubs have already been generated (this is the
1138 -- case when another RACW with the same designated type has already been
1139 -- encountered), in which case we reuse the previous stubs rather than
1140 -- generating new ones.
1143 if not Expander_Active then
1147 -- Mark the current package declaration as containing an RACW, so that
1148 -- the bodies for the calling stubs and the RACW stream subprograms
1149 -- are attached to the tree when the corresponding body is encountered.
1151 Set_Has_RACW (Current_Scope);
1153 -- Look for place to declare the RACW stub type and RACW operations
1159 -- Case of declaring the RACW in the same package as its designated
1160 -- type: we know that the designated type is a private type, so we
1161 -- use the private declarations list.
1163 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1165 if Present (Private_Declarations (Pkg_Spec)) then
1166 Decls := Private_Declarations (Pkg_Spec);
1168 Decls := Visible_Declarations (Pkg_Spec);
1172 -- Case of declaring the RACW in another package than its designated
1173 -- type: use the private declarations list if present; otherwise
1174 -- use the visible declarations.
1176 Decls := List_Containing (Declaration_Node (RACW_Type));
1180 -- If we were unable to find the declarations, that means that the
1181 -- completion of the type was missing. We can safely return and let the
1182 -- error be caught by the semantic analysis.
1189 (Designated_Type => Desig,
1190 RACW_Type => RACW_Type,
1192 Stub_Type => Stub_Type,
1193 Stub_Type_Access => Stub_Type_Access,
1194 RPC_Receiver_Decl => RPC_Receiver_Decl,
1195 Body_Decls => Body_Decls,
1196 Existing => Existing);
1198 -- If this RACW is not in the main unit, do not generate primitive or
1201 if not Entity_Is_In_Main_Unit (RACW_Type) then
1202 Body_Decls := No_List;
1205 Add_RACW_Asynchronous_Flag
1206 (Declarations => Decls,
1207 RACW_Type => RACW_Type);
1209 Specific_Add_RACW_Features
1210 (RACW_Type => RACW_Type,
1212 Stub_Type => Stub_Type,
1213 Stub_Type_Access => Stub_Type_Access,
1214 RPC_Receiver_Decl => RPC_Receiver_Decl,
1215 Body_Decls => Body_Decls);
1217 -- If we already have stubs for this designated type, nothing to do
1223 if Is_Frozen (Desig) then
1224 Validate_RACW_Primitives (RACW_Type);
1225 Add_RACW_Primitive_Declarations_And_Bodies
1226 (Designated_Type => Desig,
1227 Insertion_Node => RPC_Receiver_Decl,
1228 Body_Decls => Body_Decls);
1231 -- Validate_RACW_Primitives requires the list of all primitives of
1232 -- the designated type, so defer processing until Desig is frozen.
1233 -- See Exp_Ch3.Freeze_Type.
1235 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1237 end Add_RACW_Features;
1239 ------------------------------------------------
1240 -- Add_RACW_Primitive_Declarations_And_Bodies --
1241 ------------------------------------------------
1243 procedure Add_RACW_Primitive_Declarations_And_Bodies
1244 (Designated_Type : Entity_Id;
1245 Insertion_Node : Node_Id;
1246 Body_Decls : List_Id)
1248 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1249 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1250 -- the declarations are recognized as belonging to the current package.
1252 Stub_Elements : constant Stub_Structure :=
1253 Stubs_Table.Get (Designated_Type);
1255 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1257 Is_RAS : constant Boolean :=
1258 not Comes_From_Source (Stub_Elements.RACW_Type);
1259 -- Case of the RACW generated to implement a remote access-to-
1262 Build_Bodies : constant Boolean :=
1263 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1264 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1265 -- only when the main unit is the unit that contains the stub type.
1267 Current_Insertion_Node : Node_Id := Insertion_Node;
1269 RPC_Receiver : Entity_Id;
1270 RPC_Receiver_Statements : List_Id;
1271 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1272 RPC_Receiver_Elsif_Parts : List_Id;
1273 RPC_Receiver_Request : Entity_Id;
1274 RPC_Receiver_Subp_Id : Entity_Id;
1275 RPC_Receiver_Subp_Index : Entity_Id;
1277 Subp_Str : String_Id;
1279 Current_Primitive_Elmt : Elmt_Id;
1280 Current_Primitive : Entity_Id;
1281 Current_Primitive_Body : Node_Id;
1282 Current_Primitive_Spec : Node_Id;
1283 Current_Primitive_Decl : Node_Id;
1284 Current_Primitive_Number : Int := 0;
1285 Current_Primitive_Alias : Node_Id;
1286 Current_Receiver : Entity_Id;
1287 Current_Receiver_Body : Node_Id;
1288 RPC_Receiver_Decl : Node_Id;
1289 Possibly_Asynchronous : Boolean;
1292 if not Expander_Active then
1298 Make_Defining_Identifier (Loc,
1299 Chars => New_Internal_Name ('P'));
1301 Specific_Build_RPC_Receiver_Body
1302 (RPC_Receiver => RPC_Receiver,
1303 Request => RPC_Receiver_Request,
1304 Subp_Id => RPC_Receiver_Subp_Id,
1305 Subp_Index => RPC_Receiver_Subp_Index,
1306 Stmts => RPC_Receiver_Statements,
1307 Decl => RPC_Receiver_Decl);
1309 if Get_PCS_Name = Name_PolyORB_DSA then
1311 -- For the case of PolyORB, we need to map a textual operation
1312 -- name into a primitive index. Currently we do so using a simple
1313 -- sequence of string comparisons.
1315 RPC_Receiver_Elsif_Parts := New_List;
1319 -- Build callers, receivers for every primitive operations and a RPC
1320 -- receiver for this type.
1322 if Present (Primitive_Operations (Designated_Type)) then
1323 Overload_Counter_Table.Reset;
1325 Current_Primitive_Elmt :=
1326 First_Elmt (Primitive_Operations (Designated_Type));
1327 while Current_Primitive_Elmt /= No_Elmt loop
1328 Current_Primitive := Node (Current_Primitive_Elmt);
1330 -- Copy the primitive of all the parents, except predefined ones
1331 -- that are not remotely dispatching. Also omit hidden primitives
1332 -- (occurs in the case of primitives of interface progenitors
1333 -- other than immediate ancestors of the Designated_Type).
1335 if Chars (Current_Primitive) /= Name_uSize
1336 and then Chars (Current_Primitive) /= Name_uAlignment
1338 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1339 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1340 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1341 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1342 Is_TSS (Current_Primitive, TSS_Stream_Write) or else
1343 Is_Predefined_Interface_Primitive (Current_Primitive))
1344 and then not Is_Hidden (Current_Primitive)
1346 -- The first thing to do is build an up-to-date copy of the
1347 -- spec with all the formals referencing Controlling_Type
1348 -- transformed into formals referencing Stub_Type. Since this
1349 -- primitive may have been inherited, go back the alias chain
1350 -- until the real primitive has been found.
1352 Current_Primitive_Alias := Current_Primitive;
1353 while Present (Alias (Current_Primitive_Alias)) loop
1355 (Current_Primitive_Alias
1356 /= Alias (Current_Primitive_Alias));
1357 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
1360 -- Copy the spec from the original declaration for the purpose
1361 -- of declaring an overriding subprogram: we need to replace
1362 -- the type of each controlling formal with Stub_Type. The
1363 -- primitive may have been declared for Controlling_Type or
1364 -- inherited from some ancestor type for which we do not have
1365 -- an easily determined Entity_Id. We have no systematic way
1366 -- of knowing which type to substitute Stub_Type for. Instead,
1367 -- Copy_Specification relies on the flag Is_Controlling_Formal
1368 -- to determine which formals to change.
1370 Current_Primitive_Spec :=
1371 Copy_Specification (Loc,
1372 Spec => Parent (Current_Primitive_Alias),
1373 Ctrl_Type => Stub_Elements.Stub_Type);
1375 Current_Primitive_Decl :=
1376 Make_Subprogram_Declaration (Loc,
1377 Specification => Current_Primitive_Spec);
1379 Insert_After_And_Analyze (Current_Insertion_Node,
1380 Current_Primitive_Decl);
1381 Current_Insertion_Node := Current_Primitive_Decl;
1383 Possibly_Asynchronous :=
1384 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1385 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1387 Assign_Subprogram_Identifier (
1388 Defining_Unit_Name (Current_Primitive_Spec),
1389 Current_Primitive_Number,
1392 if Build_Bodies then
1393 Current_Primitive_Body :=
1394 Build_Subprogram_Calling_Stubs
1395 (Vis_Decl => Current_Primitive_Decl,
1397 Build_Subprogram_Id (Loc,
1398 Defining_Unit_Name (Current_Primitive_Spec)),
1399 Asynchronous => Possibly_Asynchronous,
1400 Dynamically_Asynchronous => Possibly_Asynchronous,
1401 Stub_Type => Stub_Elements.Stub_Type,
1402 RACW_Type => Stub_Elements.RACW_Type);
1403 Append_To (Body_Decls, Current_Primitive_Body);
1405 -- Analyzing the body here would cause the Stub type to
1406 -- be frozen, thus preventing subsequent primitive
1407 -- declarations. For this reason, it will be analyzed
1408 -- later in the regular flow (and in the context of the
1409 -- appropriate unit body, see Append_RACW_Bodies).
1413 -- Build the receiver stubs
1415 if Build_Bodies and then not Is_RAS then
1416 Current_Receiver_Body :=
1417 Specific_Build_Subprogram_Receiving_Stubs
1418 (Vis_Decl => Current_Primitive_Decl,
1419 Asynchronous => Possibly_Asynchronous,
1420 Dynamically_Asynchronous => Possibly_Asynchronous,
1421 Stub_Type => Stub_Elements.Stub_Type,
1422 RACW_Type => Stub_Elements.RACW_Type,
1423 Parent_Primitive => Current_Primitive);
1425 Current_Receiver := Defining_Unit_Name (
1426 Specification (Current_Receiver_Body));
1428 Append_To (Body_Decls, Current_Receiver_Body);
1430 -- Add a case alternative to the receiver
1432 if Get_PCS_Name = Name_PolyORB_DSA then
1433 Append_To (RPC_Receiver_Elsif_Parts,
1434 Make_Elsif_Part (Loc,
1436 Make_Function_Call (Loc,
1439 RTE (RE_Caseless_String_Eq), Loc),
1440 Parameter_Associations => New_List (
1441 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1442 Make_String_Literal (Loc, Subp_Str))),
1444 Then_Statements => New_List (
1445 Make_Assignment_Statement (Loc,
1446 Name => New_Occurrence_Of (
1447 RPC_Receiver_Subp_Index, Loc),
1449 Make_Integer_Literal (Loc,
1450 Intval => Current_Primitive_Number)))));
1453 Append_To (RPC_Receiver_Case_Alternatives,
1454 Make_Case_Statement_Alternative (Loc,
1455 Discrete_Choices => New_List (
1456 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1458 Statements => New_List (
1459 Make_Procedure_Call_Statement (Loc,
1461 New_Occurrence_Of (Current_Receiver, Loc),
1462 Parameter_Associations => New_List (
1463 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1466 -- Increment the index of current primitive
1468 Current_Primitive_Number := Current_Primitive_Number + 1;
1471 Next_Elmt (Current_Primitive_Elmt);
1475 -- Build the case statement and the heart of the subprogram
1477 if Build_Bodies and then not Is_RAS then
1478 if Get_PCS_Name = Name_PolyORB_DSA
1479 and then Present (First (RPC_Receiver_Elsif_Parts))
1481 Append_To (RPC_Receiver_Statements,
1482 Make_Implicit_If_Statement (Designated_Type,
1483 Condition => New_Occurrence_Of (Standard_False, Loc),
1484 Then_Statements => New_List,
1485 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1488 Append_To (RPC_Receiver_Case_Alternatives,
1489 Make_Case_Statement_Alternative (Loc,
1490 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1491 Statements => New_List (Make_Null_Statement (Loc))));
1493 Append_To (RPC_Receiver_Statements,
1494 Make_Case_Statement (Loc,
1496 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1497 Alternatives => RPC_Receiver_Case_Alternatives));
1499 Append_To (Body_Decls, RPC_Receiver_Decl);
1500 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1501 Body_Decls, RPC_Receiver, Stub_Elements);
1503 -- Do not analyze RPC receiver body at this stage since it references
1504 -- subprograms that have not been analyzed yet. It will be analyzed in
1505 -- the regular flow (see Append_RACW_Bodies).
1508 end Add_RACW_Primitive_Declarations_And_Bodies;
1510 -----------------------------
1511 -- Add_RAS_Dereference_TSS --
1512 -----------------------------
1514 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1515 Loc : constant Source_Ptr := Sloc (N);
1517 Type_Def : constant Node_Id := Type_Definition (N);
1518 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1519 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1520 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1522 RACW_Primitive_Name : Node_Id;
1524 Proc : constant Entity_Id :=
1525 Make_Defining_Identifier (Loc,
1526 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1528 Proc_Spec : Node_Id;
1529 Param_Specs : List_Id;
1530 Param_Assoc : constant List_Id := New_List;
1531 Stmts : constant List_Id := New_List;
1533 RAS_Parameter : constant Entity_Id :=
1534 Make_Defining_Identifier (Loc,
1535 Chars => New_Internal_Name ('P'));
1537 Is_Function : constant Boolean :=
1538 Nkind (Type_Def) = N_Access_Function_Definition;
1540 Is_Degenerate : Boolean;
1541 -- Set to True if the subprogram_specification for this RAS has an
1542 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1544 Spec : constant Node_Id := Type_Def;
1546 Current_Parameter : Node_Id;
1548 -- Start of processing for Add_RAS_Dereference_TSS
1551 -- The Dereference TSS for a remote access-to-subprogram type has the
1554 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1557 -- This is called whenever a value of a RAS type is dereferenced
1559 -- First construct a list of parameter specifications:
1561 -- The first formal is the RAS values
1563 Param_Specs := New_List (
1564 Make_Parameter_Specification (Loc,
1565 Defining_Identifier => RAS_Parameter,
1568 New_Occurrence_Of (Fat_Type, Loc)));
1570 -- The following formals are copied from the type declaration
1572 Is_Degenerate := False;
1573 Current_Parameter := First (Parameter_Specifications (Type_Def));
1574 Parameters : while Present (Current_Parameter) loop
1575 if Nkind (Parameter_Type (Current_Parameter)) =
1578 Is_Degenerate := True;
1581 Append_To (Param_Specs,
1582 Make_Parameter_Specification (Loc,
1583 Defining_Identifier =>
1584 Make_Defining_Identifier (Loc,
1585 Chars => Chars (Defining_Identifier (Current_Parameter))),
1586 In_Present => In_Present (Current_Parameter),
1587 Out_Present => Out_Present (Current_Parameter),
1589 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1591 New_Copy_Tree (Expression (Current_Parameter))));
1593 Append_To (Param_Assoc,
1594 Make_Identifier (Loc,
1595 Chars => Chars (Defining_Identifier (Current_Parameter))));
1597 Next (Current_Parameter);
1598 end loop Parameters;
1600 if Is_Degenerate then
1601 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1603 -- Generate a dummy body. This code will never actually be executed,
1604 -- because null is the only legal value for a degenerate RAS type.
1605 -- For legality's sake (in order to avoid generating a function that
1606 -- does not contain a return statement), we include a dummy recursive
1607 -- call on the TSS itself.
1610 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1611 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1614 -- For a normal RAS type, we cast the RAS formal to the corresponding
1615 -- tagged type, and perform a dispatching call to its Call primitive
1618 Prepend_To (Param_Assoc,
1619 Unchecked_Convert_To (RACW_Type,
1620 New_Occurrence_Of (RAS_Parameter, Loc)));
1622 RACW_Primitive_Name :=
1623 Make_Selected_Component (Loc,
1624 Prefix => Scope (RACW_Type),
1625 Selector_Name => Name_uCall);
1630 Make_Simple_Return_Statement (Loc,
1632 Make_Function_Call (Loc,
1633 Name => RACW_Primitive_Name,
1634 Parameter_Associations => Param_Assoc)));
1638 Make_Procedure_Call_Statement (Loc,
1639 Name => RACW_Primitive_Name,
1640 Parameter_Associations => Param_Assoc));
1643 -- Build the complete subprogram
1647 Make_Function_Specification (Loc,
1648 Defining_Unit_Name => Proc,
1649 Parameter_Specifications => Param_Specs,
1650 Result_Definition =>
1652 Entity (Result_Definition (Spec)), Loc));
1654 Set_Ekind (Proc, E_Function);
1656 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1660 Make_Procedure_Specification (Loc,
1661 Defining_Unit_Name => Proc,
1662 Parameter_Specifications => Param_Specs);
1664 Set_Ekind (Proc, E_Procedure);
1665 Set_Etype (Proc, Standard_Void_Type);
1669 Make_Subprogram_Body (Loc,
1670 Specification => Proc_Spec,
1671 Declarations => New_List,
1672 Handled_Statement_Sequence =>
1673 Make_Handled_Sequence_Of_Statements (Loc,
1674 Statements => Stmts)));
1676 Set_TSS (Fat_Type, Proc);
1677 end Add_RAS_Dereference_TSS;
1679 -------------------------------
1680 -- Add_RAS_Proxy_And_Analyze --
1681 -------------------------------
1683 procedure Add_RAS_Proxy_And_Analyze
1686 All_Calls_Remote_E : Entity_Id;
1687 Proxy_Object_Addr : out Entity_Id)
1689 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1691 Subp_Name : constant Entity_Id :=
1692 Defining_Unit_Name (Specification (Vis_Decl));
1694 Pkg_Name : constant Entity_Id :=
1695 Make_Defining_Identifier (Loc,
1696 Chars => New_External_Name (Chars (Subp_Name), 'P', -1));
1698 Proxy_Type : constant Entity_Id :=
1699 Make_Defining_Identifier (Loc,
1702 (Related_Id => Chars (Subp_Name),
1705 Proxy_Type_Full_View : constant Entity_Id :=
1706 Make_Defining_Identifier (Loc,
1707 Chars (Proxy_Type));
1709 Subp_Decl_Spec : constant Node_Id :=
1710 Build_RAS_Primitive_Specification
1711 (Subp_Spec => Specification (Vis_Decl),
1712 Remote_Object_Type => Proxy_Type);
1714 Subp_Body_Spec : constant Node_Id :=
1715 Build_RAS_Primitive_Specification
1716 (Subp_Spec => Specification (Vis_Decl),
1717 Remote_Object_Type => Proxy_Type);
1719 Vis_Decls : constant List_Id := New_List;
1720 Pvt_Decls : constant List_Id := New_List;
1721 Actuals : constant List_Id := New_List;
1723 Perform_Call : Node_Id;
1726 -- type subpP is tagged limited private;
1728 Append_To (Vis_Decls,
1729 Make_Private_Type_Declaration (Loc,
1730 Defining_Identifier => Proxy_Type,
1731 Tagged_Present => True,
1732 Limited_Present => True));
1734 -- [subprogram] Call
1735 -- (Self : access subpP;
1736 -- ...other-formals...)
1739 Append_To (Vis_Decls,
1740 Make_Subprogram_Declaration (Loc,
1741 Specification => Subp_Decl_Spec));
1743 -- A : constant System.Address;
1745 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1747 Append_To (Vis_Decls,
1748 Make_Object_Declaration (Loc,
1749 Defining_Identifier => Proxy_Object_Addr,
1750 Constant_Present => True,
1751 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)));
1755 -- type subpP is tagged limited record
1756 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1760 Append_To (Pvt_Decls,
1761 Make_Full_Type_Declaration (Loc,
1762 Defining_Identifier => Proxy_Type_Full_View,
1764 Build_Remote_Subprogram_Proxy_Type (Loc,
1765 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1767 -- Trick semantic analysis into swapping the public and full view when
1768 -- freezing the public view.
1770 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1773 -- (Self : access O;
1774 -- ...other-formals...) is
1776 -- P (...other-formals...);
1780 -- (Self : access O;
1781 -- ...other-formals...)
1784 -- return F (...other-formals...);
1787 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1789 Make_Procedure_Call_Statement (Loc,
1790 Name => New_Occurrence_Of (Subp_Name, Loc),
1791 Parameter_Associations => Actuals);
1794 Make_Simple_Return_Statement (Loc,
1796 Make_Function_Call (Loc,
1797 Name => New_Occurrence_Of (Subp_Name, Loc),
1798 Parameter_Associations => Actuals));
1801 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1802 pragma Assert (Present (Formal));
1805 exit when No (Formal);
1807 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1810 -- O : aliased subpP;
1812 Append_To (Pvt_Decls,
1813 Make_Object_Declaration (Loc,
1814 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
1815 Aliased_Present => True,
1816 Object_Definition => New_Occurrence_Of (Proxy_Type, Loc)));
1818 -- A : constant System.Address := O'Address;
1820 Append_To (Pvt_Decls,
1821 Make_Object_Declaration (Loc,
1822 Defining_Identifier =>
1823 Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)),
1824 Constant_Present => True,
1825 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc),
1827 Make_Attribute_Reference (Loc,
1828 Prefix => New_Occurrence_Of (
1829 Defining_Identifier (Last (Pvt_Decls)), Loc),
1830 Attribute_Name => Name_Address)));
1833 Make_Package_Declaration (Loc,
1834 Specification => Make_Package_Specification (Loc,
1835 Defining_Unit_Name => Pkg_Name,
1836 Visible_Declarations => Vis_Decls,
1837 Private_Declarations => Pvt_Decls,
1838 End_Label => Empty)));
1839 Analyze (Last (Decls));
1842 Make_Package_Body (Loc,
1843 Defining_Unit_Name =>
1844 Make_Defining_Identifier (Loc, Chars (Pkg_Name)),
1845 Declarations => New_List (
1846 Make_Subprogram_Body (Loc,
1847 Specification => Subp_Body_Spec,
1848 Declarations => New_List,
1849 Handled_Statement_Sequence =>
1850 Make_Handled_Sequence_Of_Statements (Loc,
1851 Statements => New_List (Perform_Call))))));
1852 Analyze (Last (Decls));
1853 end Add_RAS_Proxy_And_Analyze;
1855 -----------------------
1856 -- Add_RAST_Features --
1857 -----------------------
1859 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1860 RAS_Type : constant Entity_Id :=
1861 Equivalent_Type (Defining_Identifier (Vis_Decl));
1863 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1864 Add_RAS_Dereference_TSS (Vis_Decl);
1865 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1866 end Add_RAST_Features;
1872 procedure Add_Stub_Type
1873 (Designated_Type : Entity_Id;
1874 RACW_Type : Entity_Id;
1876 Stub_Type : out Entity_Id;
1877 Stub_Type_Access : out Entity_Id;
1878 RPC_Receiver_Decl : out Node_Id;
1879 Body_Decls : out List_Id;
1880 Existing : out Boolean)
1882 Loc : constant Source_Ptr := Sloc (RACW_Type);
1884 Stub_Elements : constant Stub_Structure :=
1885 Stubs_Table.Get (Designated_Type);
1886 Stub_Type_Comps : List_Id;
1887 Stub_Type_Decl : Node_Id;
1888 Stub_Type_Access_Decl : Node_Id;
1891 if Stub_Elements /= Empty_Stub_Structure then
1892 Stub_Type := Stub_Elements.Stub_Type;
1893 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1894 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1895 Body_Decls := Stub_Elements.Body_Decls;
1902 Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S'));
1903 Set_Ekind (Stub_Type, E_Record_Type);
1904 Set_Is_RACW_Stub_Type (Stub_Type);
1906 Make_Defining_Identifier (Loc,
1907 Chars => New_External_Name
1908 (Related_Id => Chars (Stub_Type), Suffix => 'A'));
1910 Specific_Build_Stub_Type (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
1913 Make_Full_Type_Declaration (Loc,
1914 Defining_Identifier => Stub_Type,
1916 Make_Record_Definition (Loc,
1917 Tagged_Present => True,
1918 Limited_Present => True,
1920 Make_Component_List (Loc,
1921 Component_Items => Stub_Type_Comps)));
1923 -- Does the stub type need to explicitly implement interfaces from the
1924 -- designated type???
1926 -- In particular are there issues in the case where the designated type
1927 -- is a synchronized interface???
1929 Stub_Type_Access_Decl :=
1930 Make_Full_Type_Declaration (Loc,
1931 Defining_Identifier => Stub_Type_Access,
1933 Make_Access_To_Object_Definition (Loc,
1934 All_Present => True,
1935 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1937 Append_To (Decls, Stub_Type_Decl);
1938 Analyze (Last (Decls));
1939 Append_To (Decls, Stub_Type_Access_Decl);
1940 Analyze (Last (Decls));
1942 -- We can't directly derive the stub type from the designated type,
1943 -- because we don't want any components or discriminants from the real
1944 -- type, so instead we manually fake a derivation to get an appropriate
1947 Derive_Subprograms (Parent_Type => Designated_Type,
1948 Derived_Type => Stub_Type);
1950 if Present (RPC_Receiver_Decl) then
1951 Append_To (Decls, RPC_Receiver_Decl);
1953 RPC_Receiver_Decl := Last (Decls);
1956 Body_Decls := New_List;
1958 Stubs_Table.Set (Designated_Type,
1959 (Stub_Type => Stub_Type,
1960 Stub_Type_Access => Stub_Type_Access,
1961 RPC_Receiver_Decl => RPC_Receiver_Decl,
1962 Body_Decls => Body_Decls,
1963 RACW_Type => RACW_Type));
1966 ------------------------
1967 -- Append_RACW_Bodies --
1968 ------------------------
1970 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
1974 E := First_Entity (Spec_Id);
1975 while Present (E) loop
1976 if Is_Remote_Access_To_Class_Wide_Type (E) then
1977 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
1982 end Append_RACW_Bodies;
1984 ----------------------------------
1985 -- Assign_Subprogram_Identifier --
1986 ----------------------------------
1988 procedure Assign_Subprogram_Identifier
1993 N : constant Name_Id := Chars (Def);
1995 Overload_Order : constant Int :=
1996 Overload_Counter_Table.Get (N) + 1;
1999 Overload_Counter_Table.Set (N, Overload_Order);
2001 Get_Name_String (N);
2003 -- Homonym handling: as in Exp_Dbug, but much simpler, because the only
2004 -- entities for which we have to generate names here need only to be
2005 -- disambiguated within their own scope.
2007 if Overload_Order > 1 then
2008 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
2009 Name_Len := Name_Len + 2;
2010 Add_Nat_To_Name_Buffer (Overload_Order);
2013 Id := String_From_Name_Buffer;
2014 Subprogram_Identifier_Table.Set
2016 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
2017 end Assign_Subprogram_Identifier;
2019 -------------------------------------
2020 -- Build_Actual_Object_Declaration --
2021 -------------------------------------
2023 procedure Build_Actual_Object_Declaration
2024 (Object : Entity_Id;
2030 Loc : constant Source_Ptr := Sloc (Object);
2033 -- Declare a temporary object for the actual, possibly initialized with
2034 -- a 'Input/From_Any call.
2036 -- Complication arises in the case of limited types, for which such a
2037 -- declaration is illegal in Ada 95. In that case, we first generate a
2038 -- renaming declaration of the 'Input call, and then if needed we
2039 -- generate an overlaid non-constant view.
2041 if Ada_Version <= Ada_95
2042 and then Is_Limited_Type (Etyp)
2043 and then Present (Expr)
2046 -- Object : Etyp renames <func-call>
2049 Make_Object_Renaming_Declaration (Loc,
2050 Defining_Identifier => Object,
2051 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
2056 -- The name defined by the renaming declaration denotes a
2057 -- constant view; create a non-constant object at the same address
2058 -- to be used as the actual.
2061 Constant_Object : constant Entity_Id :=
2062 Make_Defining_Identifier (Loc,
2063 New_Internal_Name ('P'));
2065 Set_Defining_Identifier
2066 (Last (Decls), Constant_Object);
2068 -- We have an unconstrained Etyp: build the actual constrained
2069 -- subtype for the value we just read from the stream.
2071 -- subtype S is <actual subtype of Constant_Object>;
2074 Build_Actual_Subtype (Etyp,
2075 New_Occurrence_Of (Constant_Object, Loc)));
2080 Make_Object_Declaration (Loc,
2081 Defining_Identifier => Object,
2082 Object_Definition =>
2084 (Defining_Identifier (Last (Decls)), Loc)));
2085 Set_Ekind (Object, E_Variable);
2087 -- Suppress default initialization:
2088 -- pragma Import (Ada, Object);
2092 Chars => Name_Import,
2093 Pragma_Argument_Associations => New_List (
2094 Make_Pragma_Argument_Association (Loc,
2095 Chars => Name_Convention,
2096 Expression => Make_Identifier (Loc, Name_Ada)),
2097 Make_Pragma_Argument_Association (Loc,
2098 Chars => Name_Entity,
2099 Expression => New_Occurrence_Of (Object, Loc)))));
2101 -- for Object'Address use Constant_Object'Address;
2104 Make_Attribute_Definition_Clause (Loc,
2105 Name => New_Occurrence_Of (Object, Loc),
2106 Chars => Name_Address,
2108 Make_Attribute_Reference (Loc,
2109 Prefix => New_Occurrence_Of (Constant_Object, Loc),
2110 Attribute_Name => Name_Address)));
2115 -- General case of a regular object declaration. Object is flagged
2116 -- constant unless it has mode out or in out, to allow the backend
2117 -- to optimize where possible.
2119 -- Object : [constant] Etyp [:= <expr>];
2122 Make_Object_Declaration (Loc,
2123 Defining_Identifier => Object,
2124 Constant_Present => Present (Expr) and then not Variable,
2125 Object_Definition => New_Occurrence_Of (Etyp, Loc),
2126 Expression => Expr));
2128 if Constant_Present (Last (Decls)) then
2129 Set_Ekind (Object, E_Constant);
2131 Set_Ekind (Object, E_Variable);
2134 end Build_Actual_Object_Declaration;
2136 ------------------------------
2137 -- Build_Get_Unique_RP_Call --
2138 ------------------------------
2140 function Build_Get_Unique_RP_Call
2142 Pointer : Entity_Id;
2143 Stub_Type : Entity_Id) return List_Id
2147 Make_Procedure_Call_Statement (Loc,
2149 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2150 Parameter_Associations => New_List (
2151 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2152 New_Occurrence_Of (Pointer, Loc)))),
2154 Make_Assignment_Statement (Loc,
2156 Make_Selected_Component (Loc,
2157 Prefix => New_Occurrence_Of (Pointer, Loc),
2159 New_Occurrence_Of (First_Tag_Component
2160 (Designated_Type (Etype (Pointer))), Loc)),
2162 Make_Attribute_Reference (Loc,
2163 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2164 Attribute_Name => Name_Tag)));
2166 -- Note: The assignment to Pointer._Tag is safe here because
2167 -- we carefully ensured that Stub_Type has exactly the same layout
2168 -- as System.Partition_Interface.RACW_Stub_Type.
2170 end Build_Get_Unique_RP_Call;
2172 -----------------------------------
2173 -- Build_Ordered_Parameters_List --
2174 -----------------------------------
2176 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2177 Constrained_List : List_Id;
2178 Unconstrained_List : List_Id;
2179 Current_Parameter : Node_Id;
2182 First_Parameter : Node_Id;
2183 For_RAS : Boolean := False;
2186 if No (Parameter_Specifications (Spec)) then
2190 Constrained_List := New_List;
2191 Unconstrained_List := New_List;
2192 First_Parameter := First (Parameter_Specifications (Spec));
2194 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2195 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2200 -- Loop through the parameters and add them to the right list. Note that
2201 -- we treat a parameter of a null-excluding access type as unconstrained
2202 -- because we can't declare an object of such a type with default
2205 Current_Parameter := First_Parameter;
2206 while Present (Current_Parameter) loop
2207 Ptyp := Parameter_Type (Current_Parameter);
2209 if (Nkind (Ptyp) = N_Access_Definition
2210 or else not Transmit_As_Unconstrained (Etype (Ptyp)))
2211 and then not (For_RAS and then Current_Parameter = First_Parameter)
2213 Append_To (Constrained_List, New_Copy (Current_Parameter));
2215 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2218 Next (Current_Parameter);
2221 -- Unconstrained parameters are returned first
2223 Append_List_To (Unconstrained_List, Constrained_List);
2225 return Unconstrained_List;
2226 end Build_Ordered_Parameters_List;
2228 ----------------------------------
2229 -- Build_Passive_Partition_Stub --
2230 ----------------------------------
2232 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2234 Pkg_Name : String_Id;
2237 Loc : constant Source_Ptr := Sloc (U);
2240 -- Verify that the implementation supports distribution, by accessing
2241 -- a type defined in the proper version of system.rpc
2244 Dist_OK : Entity_Id;
2245 pragma Warnings (Off, Dist_OK);
2247 Dist_OK := RTE (RE_Params_Stream_Type);
2250 -- Use body if present, spec otherwise
2252 if Nkind (U) = N_Package_Declaration then
2253 Pkg_Spec := Specification (U);
2254 L := Visible_Declarations (Pkg_Spec);
2256 Pkg_Spec := Parent (Corresponding_Spec (U));
2257 L := Declarations (U);
2260 Get_Library_Unit_Name_String (Pkg_Spec);
2261 Pkg_Name := String_From_Name_Buffer;
2263 Make_Procedure_Call_Statement (Loc,
2265 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2266 Parameter_Associations => New_List (
2267 Make_String_Literal (Loc, Pkg_Name),
2268 Make_Attribute_Reference (Loc,
2270 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2271 Attribute_Name => Name_Version)));
2274 end Build_Passive_Partition_Stub;
2276 --------------------------------------
2277 -- Build_RPC_Receiver_Specification --
2278 --------------------------------------
2280 function Build_RPC_Receiver_Specification
2281 (RPC_Receiver : Entity_Id;
2282 Request_Parameter : Entity_Id) return Node_Id
2284 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2287 Make_Procedure_Specification (Loc,
2288 Defining_Unit_Name => RPC_Receiver,
2289 Parameter_Specifications => New_List (
2290 Make_Parameter_Specification (Loc,
2291 Defining_Identifier => Request_Parameter,
2293 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2294 end Build_RPC_Receiver_Specification;
2296 ----------------------------------------
2297 -- Build_Remote_Subprogram_Proxy_Type --
2298 ----------------------------------------
2300 function Build_Remote_Subprogram_Proxy_Type
2302 ACR_Expression : Node_Id) return Node_Id
2306 Make_Record_Definition (Loc,
2307 Tagged_Present => True,
2308 Limited_Present => True,
2310 Make_Component_List (Loc,
2312 Component_Items => New_List (
2313 Make_Component_Declaration (Loc,
2314 Defining_Identifier =>
2315 Make_Defining_Identifier (Loc,
2316 Name_All_Calls_Remote),
2317 Component_Definition =>
2318 Make_Component_Definition (Loc,
2319 Subtype_Indication =>
2320 New_Occurrence_Of (Standard_Boolean, Loc)),
2324 Make_Component_Declaration (Loc,
2325 Defining_Identifier =>
2326 Make_Defining_Identifier (Loc,
2328 Component_Definition =>
2329 Make_Component_Definition (Loc,
2330 Subtype_Indication =>
2331 New_Occurrence_Of (RTE (RE_Address), Loc)),
2333 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2335 Make_Component_Declaration (Loc,
2336 Defining_Identifier =>
2337 Make_Defining_Identifier (Loc,
2339 Component_Definition =>
2340 Make_Component_Definition (Loc,
2341 Subtype_Indication =>
2342 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2343 end Build_Remote_Subprogram_Proxy_Type;
2345 --------------------
2346 -- Build_Stub_Tag --
2347 --------------------
2349 function Build_Stub_Tag
2351 RACW_Type : Entity_Id) return Node_Id
2353 Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type);
2356 Make_Attribute_Reference (Loc,
2357 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2358 Attribute_Name => Name_Tag);
2361 ------------------------------------
2362 -- Build_Subprogram_Calling_Stubs --
2363 ------------------------------------
2365 function Build_Subprogram_Calling_Stubs
2366 (Vis_Decl : Node_Id;
2368 Asynchronous : Boolean;
2369 Dynamically_Asynchronous : Boolean := False;
2370 Stub_Type : Entity_Id := Empty;
2371 RACW_Type : Entity_Id := Empty;
2372 Locator : Entity_Id := Empty;
2373 New_Name : Name_Id := No_Name) return Node_Id
2375 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2377 Decls : constant List_Id := New_List;
2378 Statements : constant List_Id := New_List;
2380 Subp_Spec : Node_Id;
2381 -- The specification of the body
2383 Controlling_Parameter : Entity_Id := Empty;
2385 Asynchronous_Expr : Node_Id := Empty;
2387 RCI_Locator : Entity_Id;
2389 Spec_To_Use : Node_Id;
2391 procedure Insert_Partition_Check (Parameter : Node_Id);
2392 -- Check that the parameter has been elaborated on the same partition
2393 -- than the controlling parameter (E.4(19)).
2395 ----------------------------
2396 -- Insert_Partition_Check --
2397 ----------------------------
2399 procedure Insert_Partition_Check (Parameter : Node_Id) is
2400 Parameter_Entity : constant Entity_Id :=
2401 Defining_Identifier (Parameter);
2403 -- The expression that will be built is of the form:
2405 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2406 -- raise Constraint_Error;
2409 -- We do not check that Parameter is in Stub_Type since such a check
2410 -- has been inserted at the point of call already (a tag check since
2411 -- we have multiple controlling operands).
2414 Make_Raise_Constraint_Error (Loc,
2418 Make_Function_Call (Loc,
2420 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2421 Parameter_Associations =>
2423 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2424 New_Occurrence_Of (Parameter_Entity, Loc)),
2425 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2426 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2427 Reason => CE_Partition_Check_Failed));
2428 end Insert_Partition_Check;
2430 -- Start of processing for Build_Subprogram_Calling_Stubs
2433 Subp_Spec := Copy_Specification (Loc,
2434 Spec => Specification (Vis_Decl),
2435 New_Name => New_Name);
2437 if Locator = Empty then
2438 RCI_Locator := RCI_Cache;
2439 Spec_To_Use := Specification (Vis_Decl);
2441 RCI_Locator := Locator;
2442 Spec_To_Use := Subp_Spec;
2445 -- Find a controlling argument if we have a stub type. Also check
2446 -- if this subprogram can be made asynchronous.
2448 if Present (Stub_Type)
2449 and then Present (Parameter_Specifications (Spec_To_Use))
2452 Current_Parameter : Node_Id :=
2453 First (Parameter_Specifications
2456 while Present (Current_Parameter) loop
2458 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2460 if Controlling_Parameter = Empty then
2461 Controlling_Parameter :=
2462 Defining_Identifier (Current_Parameter);
2464 Insert_Partition_Check (Current_Parameter);
2468 Next (Current_Parameter);
2473 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2475 if Dynamically_Asynchronous then
2476 Asynchronous_Expr := Make_Selected_Component (Loc,
2477 Prefix => Controlling_Parameter,
2478 Selector_Name => Name_Asynchronous);
2481 Specific_Build_General_Calling_Stubs
2483 Statements => Statements,
2484 Target => Specific_Build_Stub_Target (Loc,
2485 Decls, RCI_Locator, Controlling_Parameter),
2486 Subprogram_Id => Subp_Id,
2487 Asynchronous => Asynchronous_Expr,
2488 Is_Known_Asynchronous => Asynchronous
2489 and then not Dynamically_Asynchronous,
2490 Is_Known_Non_Asynchronous
2492 and then not Dynamically_Asynchronous,
2493 Is_Function => Nkind (Spec_To_Use) =
2494 N_Function_Specification,
2495 Spec => Spec_To_Use,
2496 Stub_Type => Stub_Type,
2497 RACW_Type => RACW_Type,
2500 RCI_Calling_Stubs_Table.Set
2501 (Defining_Unit_Name (Specification (Vis_Decl)),
2502 Defining_Unit_Name (Spec_To_Use));
2505 Make_Subprogram_Body (Loc,
2506 Specification => Subp_Spec,
2507 Declarations => Decls,
2508 Handled_Statement_Sequence =>
2509 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2510 end Build_Subprogram_Calling_Stubs;
2512 -------------------------
2513 -- Build_Subprogram_Id --
2514 -------------------------
2516 function Build_Subprogram_Id
2518 E : Entity_Id) return Node_Id
2521 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2523 Current_Declaration : Node_Id;
2524 Current_Subp : Entity_Id;
2525 Current_Subp_Str : String_Id;
2526 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2528 pragma Warnings (Off, Current_Subp_Str);
2531 -- Build_Subprogram_Id is called outside of the context of
2532 -- generating calling or receiving stubs. Hence we are processing
2533 -- an 'Access attribute_reference for an RCI subprogram, for the
2534 -- purpose of obtaining a RAS value.
2537 (Is_Remote_Call_Interface (Scope (E))
2539 (Nkind (Parent (E)) = N_Procedure_Specification
2541 Nkind (Parent (E)) = N_Function_Specification));
2543 Current_Declaration :=
2544 First (Visible_Declarations
2545 (Package_Specification_Of_Scope (Scope (E))));
2546 while Present (Current_Declaration) loop
2547 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2548 and then Comes_From_Source (Current_Declaration)
2550 Current_Subp := Defining_Unit_Name (Specification (
2551 Current_Declaration));
2553 Assign_Subprogram_Identifier
2554 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2556 Current_Subp_Number := Current_Subp_Number + 1;
2559 Next (Current_Declaration);
2564 case Get_PCS_Name is
2565 when Name_PolyORB_DSA =>
2566 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2568 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2570 end Build_Subprogram_Id;
2572 ------------------------
2573 -- Copy_Specification --
2574 ------------------------
2576 function Copy_Specification
2579 Ctrl_Type : Entity_Id := Empty;
2580 New_Name : Name_Id := No_Name) return Node_Id
2582 Parameters : List_Id := No_List;
2584 Current_Parameter : Node_Id;
2585 Current_Identifier : Entity_Id;
2586 Current_Type : Node_Id;
2588 Name_For_New_Spec : Name_Id;
2590 New_Identifier : Entity_Id;
2592 -- Comments needed in body below ???
2595 if New_Name = No_Name then
2596 pragma Assert (Nkind (Spec) = N_Function_Specification
2597 or else Nkind (Spec) = N_Procedure_Specification);
2599 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2601 Name_For_New_Spec := New_Name;
2604 if Present (Parameter_Specifications (Spec)) then
2605 Parameters := New_List;
2606 Current_Parameter := First (Parameter_Specifications (Spec));
2607 while Present (Current_Parameter) loop
2608 Current_Identifier := Defining_Identifier (Current_Parameter);
2609 Current_Type := Parameter_Type (Current_Parameter);
2611 if Nkind (Current_Type) = N_Access_Definition then
2612 if Present (Ctrl_Type) then
2613 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2615 Make_Access_Definition (Loc,
2616 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2617 Null_Exclusion_Present =>
2618 Null_Exclusion_Present (Current_Type));
2622 Make_Access_Definition (Loc,
2624 New_Copy_Tree (Subtype_Mark (Current_Type)),
2625 Null_Exclusion_Present =>
2626 Null_Exclusion_Present (Current_Type));
2630 if Present (Ctrl_Type)
2631 and then Is_Controlling_Formal (Current_Identifier)
2633 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2635 Current_Type := New_Copy_Tree (Current_Type);
2639 New_Identifier := Make_Defining_Identifier (Loc,
2640 Chars (Current_Identifier));
2642 Append_To (Parameters,
2643 Make_Parameter_Specification (Loc,
2644 Defining_Identifier => New_Identifier,
2645 Parameter_Type => Current_Type,
2646 In_Present => In_Present (Current_Parameter),
2647 Out_Present => Out_Present (Current_Parameter),
2649 New_Copy_Tree (Expression (Current_Parameter))));
2651 -- For a regular formal parameter (that needs to be marshalled
2652 -- in the context of remote calls), set the Etype now, because
2653 -- marshalling processing might need it.
2655 if Is_Entity_Name (Current_Type) then
2656 Set_Etype (New_Identifier, Entity (Current_Type));
2658 -- Current_Type is an access definition, special processing
2659 -- (not requiring etype) will occur for marshalling.
2665 Next (Current_Parameter);
2669 case Nkind (Spec) is
2671 when N_Function_Specification | N_Access_Function_Definition =>
2673 Make_Function_Specification (Loc,
2674 Defining_Unit_Name =>
2675 Make_Defining_Identifier (Loc,
2676 Chars => Name_For_New_Spec),
2677 Parameter_Specifications => Parameters,
2678 Result_Definition =>
2679 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2681 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2683 Make_Procedure_Specification (Loc,
2684 Defining_Unit_Name =>
2685 Make_Defining_Identifier (Loc,
2686 Chars => Name_For_New_Spec),
2687 Parameter_Specifications => Parameters);
2690 raise Program_Error;
2692 end Copy_Specification;
2694 -----------------------------
2695 -- Corresponding_Stub_Type --
2696 -----------------------------
2698 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2699 Desig : constant Entity_Id :=
2700 Etype (Designated_Type (RACW_Type));
2701 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2703 return Stub_Elements.Stub_Type;
2704 end Corresponding_Stub_Type;
2706 ---------------------------
2707 -- Could_Be_Asynchronous --
2708 ---------------------------
2710 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2711 Current_Parameter : Node_Id;
2714 if Present (Parameter_Specifications (Spec)) then
2715 Current_Parameter := First (Parameter_Specifications (Spec));
2716 while Present (Current_Parameter) loop
2717 if Out_Present (Current_Parameter) then
2721 Next (Current_Parameter);
2726 end Could_Be_Asynchronous;
2728 ---------------------------
2729 -- Declare_Create_NVList --
2730 ---------------------------
2732 procedure Declare_Create_NVList
2740 Make_Object_Declaration (Loc,
2741 Defining_Identifier => NVList,
2742 Aliased_Present => False,
2743 Object_Definition =>
2744 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2747 Make_Procedure_Call_Statement (Loc,
2748 Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2749 Parameter_Associations => New_List (
2750 New_Occurrence_Of (NVList, Loc))));
2751 end Declare_Create_NVList;
2753 ---------------------------------------------
2754 -- Expand_All_Calls_Remote_Subprogram_Call --
2755 ---------------------------------------------
2757 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2758 Loc : constant Source_Ptr := Sloc (N);
2759 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2760 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2761 RCI_Locator_Decl : Node_Id;
2762 RCI_Locator : Entity_Id;
2763 Calling_Stubs : Node_Id;
2764 E_Calling_Stubs : Entity_Id;
2767 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2769 if E_Calling_Stubs = Empty then
2770 RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
2772 -- The RCI_Locator package and calling stub are is inserted at the
2773 -- top level in the current unit, and must appear in the proper scope
2774 -- so that it is not prematurely removed by the GCC back end.
2777 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2779 if Ekind (Scop) = E_Package_Body then
2780 Push_Scope (Spec_Entity (Scop));
2781 elsif Ekind (Scop) = E_Subprogram_Body then
2783 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2789 if RCI_Locator = Empty then
2792 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2793 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
2794 Analyze (RCI_Locator_Decl);
2795 RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
2798 RCI_Locator_Decl := Parent (RCI_Locator);
2801 Calling_Stubs := Build_Subprogram_Calling_Stubs
2802 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2804 Build_Subprogram_Id (Loc, Called_Subprogram),
2805 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2807 Is_Asynchronous (Called_Subprogram),
2808 Locator => RCI_Locator,
2809 New_Name => New_Internal_Name ('S'));
2810 Insert_After (RCI_Locator_Decl, Calling_Stubs);
2811 Analyze (Calling_Stubs);
2814 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2817 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2818 end Expand_All_Calls_Remote_Subprogram_Call;
2820 ---------------------------------
2821 -- Expand_Calling_Stubs_Bodies --
2822 ---------------------------------
2824 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2825 Spec : constant Node_Id := Specification (Unit_Node);
2826 Decls : constant List_Id := Visible_Declarations (Spec);
2828 Push_Scope (Scope_Of_Spec (Spec));
2829 Add_Calling_Stubs_To_Declarations
2830 (Specification (Unit_Node), Decls);
2832 end Expand_Calling_Stubs_Bodies;
2834 -----------------------------------
2835 -- Expand_Receiving_Stubs_Bodies --
2836 -----------------------------------
2838 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2841 Stubs_Decls : List_Id;
2842 Stubs_Stmts : List_Id;
2845 if Nkind (Unit_Node) = N_Package_Declaration then
2846 Spec := Specification (Unit_Node);
2847 Decls := Private_Declarations (Spec);
2850 Decls := Visible_Declarations (Spec);
2853 Push_Scope (Scope_Of_Spec (Spec));
2854 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2858 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2859 Decls := Declarations (Unit_Node);
2861 Push_Scope (Scope_Of_Spec (Unit_Node));
2862 Stubs_Decls := New_List;
2863 Stubs_Stmts := New_List;
2864 Specific_Add_Receiving_Stubs_To_Declarations
2865 (Spec, Stubs_Decls, Stubs_Stmts);
2867 Insert_List_Before (First (Decls), Stubs_Decls);
2870 HSS_Stmts : constant List_Id :=
2871 Statements (Handled_Statement_Sequence (Unit_Node));
2873 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2876 if No (First_HSS_Stmt) then
2877 Append_List_To (HSS_Stmts, Stubs_Stmts);
2879 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2885 end Expand_Receiving_Stubs_Bodies;
2887 --------------------
2888 -- GARLIC_Support --
2889 --------------------
2891 package body GARLIC_Support is
2893 -- Local subprograms
2895 procedure Add_RACW_Read_Attribute
2896 (RACW_Type : Entity_Id;
2897 Stub_Type : Entity_Id;
2898 Stub_Type_Access : Entity_Id;
2899 Body_Decls : List_Id);
2900 -- Add Read attribute for the RACW type. The declaration and attribute
2901 -- definition clauses are inserted right after the declaration of
2902 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2903 -- appended to it (case where the RACW declaration is in the main unit).
2905 procedure Add_RACW_Write_Attribute
2906 (RACW_Type : Entity_Id;
2907 Stub_Type : Entity_Id;
2908 Stub_Type_Access : Entity_Id;
2909 RPC_Receiver : Node_Id;
2910 Body_Decls : List_Id);
2911 -- Same as above for the Write attribute
2913 function Stream_Parameter return Node_Id;
2914 function Result return Node_Id;
2915 function Object return Node_Id renames Result;
2916 -- Functions to create occurrences of the formal parameter names of the
2917 -- 'Read and 'Write attributes.
2920 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2921 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2923 procedure Add_RAS_Access_TSS (N : Node_Id);
2924 -- Add a subprogram body for RAS Access TSS
2926 -------------------------------------
2927 -- Add_Obj_RPC_Receiver_Completion --
2928 -------------------------------------
2930 procedure Add_Obj_RPC_Receiver_Completion
2933 RPC_Receiver : Entity_Id;
2934 Stub_Elements : Stub_Structure)
2937 -- The RPC receiver body should not be the completion of the
2938 -- declaration recorded in the stub structure, because then the
2939 -- occurrences of the formal parameters within the body should refer
2940 -- to the entities from the declaration, not from the completion, to
2941 -- which we do not have easy access. Instead, the RPC receiver body
2942 -- acts as its own declaration, and the RPC receiver declaration is
2943 -- completed by a renaming-as-body.
2946 Make_Subprogram_Renaming_Declaration (Loc,
2948 Copy_Specification (Loc,
2949 Specification (Stub_Elements.RPC_Receiver_Decl)),
2950 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2951 end Add_Obj_RPC_Receiver_Completion;
2953 -----------------------
2954 -- Add_RACW_Features --
2955 -----------------------
2957 procedure Add_RACW_Features
2958 (RACW_Type : Entity_Id;
2959 Stub_Type : Entity_Id;
2960 Stub_Type_Access : Entity_Id;
2961 RPC_Receiver_Decl : Node_Id;
2962 Body_Decls : List_Id)
2964 RPC_Receiver : Node_Id;
2965 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2968 Loc := Sloc (RACW_Type);
2972 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2973 -- of the corresponding distributed object type. We retrieve its
2974 -- address from the local proxy object.
2976 RPC_Receiver := Make_Selected_Component (Loc,
2978 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2979 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2982 RPC_Receiver := Make_Attribute_Reference (Loc,
2983 Prefix => New_Occurrence_Of (
2984 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2985 Attribute_Name => Name_Address);
2988 Add_RACW_Write_Attribute
2995 Add_RACW_Read_Attribute
3000 end Add_RACW_Features;
3002 -----------------------------
3003 -- Add_RACW_Read_Attribute --
3004 -----------------------------
3006 procedure Add_RACW_Read_Attribute
3007 (RACW_Type : Entity_Id;
3008 Stub_Type : Entity_Id;
3009 Stub_Type_Access : Entity_Id;
3010 Body_Decls : List_Id)
3012 Proc_Decl : Node_Id;
3013 Attr_Decl : Node_Id;
3015 Body_Node : Node_Id;
3017 Statements : constant List_Id := New_List;
3019 Local_Statements : List_Id;
3020 Remote_Statements : List_Id;
3021 -- Various parts of the procedure
3023 Pnam : constant Entity_Id :=
3024 Make_Defining_Identifier
3025 (Loc, New_Internal_Name ('R'));
3026 Asynchronous_Flag : constant Entity_Id :=
3027 Asynchronous_Flags_Table.Get (RACW_Type);
3028 pragma Assert (Present (Asynchronous_Flag));
3030 -- Prepare local identifiers
3032 Source_Partition : Entity_Id;
3033 Source_Receiver : Entity_Id;
3034 Source_Address : Entity_Id;
3035 Local_Stub : Entity_Id;
3036 Stubbed_Result : Entity_Id;
3038 -- Start of processing for Add_RACW_Read_Attribute
3041 Build_Stream_Procedure (Loc,
3042 RACW_Type, Body_Node, Pnam, Statements, Outp => True);
3043 Proc_Decl := Make_Subprogram_Declaration (Loc,
3044 Copy_Specification (Loc, Specification (Body_Node)));
3047 Make_Attribute_Definition_Clause (Loc,
3048 Name => New_Occurrence_Of (RACW_Type, Loc),
3052 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3054 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3055 Insert_After (Proc_Decl, Attr_Decl);
3057 if No (Body_Decls) then
3059 -- Case of processing an RACW type from another unit than the
3060 -- main one: do not generate a body.
3065 -- Prepare local identifiers
3068 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3070 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3072 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3074 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
3076 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3078 -- Generate object declarations
3081 Make_Object_Declaration (Loc,
3082 Defining_Identifier => Source_Partition,
3083 Object_Definition =>
3084 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
3086 Make_Object_Declaration (Loc,
3087 Defining_Identifier => Source_Receiver,
3088 Object_Definition =>
3089 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3091 Make_Object_Declaration (Loc,
3092 Defining_Identifier => Source_Address,
3093 Object_Definition =>
3094 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3096 Make_Object_Declaration (Loc,
3097 Defining_Identifier => Local_Stub,
3098 Aliased_Present => True,
3099 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
3101 Make_Object_Declaration (Loc,
3102 Defining_Identifier => Stubbed_Result,
3103 Object_Definition =>
3104 New_Occurrence_Of (Stub_Type_Access, Loc),
3106 Make_Attribute_Reference (Loc,
3108 New_Occurrence_Of (Local_Stub, Loc),
3110 Name_Unchecked_Access)));
3112 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3114 Append_List_To (Statements, New_List (
3115 Make_Attribute_Reference (Loc,
3117 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3118 Attribute_Name => Name_Read,
3119 Expressions => New_List (
3121 New_Occurrence_Of (Source_Partition, Loc))),
3123 Make_Attribute_Reference (Loc,
3125 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3128 Expressions => New_List (
3130 New_Occurrence_Of (Source_Receiver, Loc))),
3132 Make_Attribute_Reference (Loc,
3134 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3137 Expressions => New_List (
3139 New_Occurrence_Of (Source_Address, Loc)))));
3141 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3143 Set_Etype (Stubbed_Result, Stub_Type_Access);
3145 -- If the Address is Null_Address, then return a null object, unless
3146 -- RACW_Type is null-excluding, in which case unconditionally raise
3147 -- CONSTRAINT_ERROR instead.
3150 Zero_Statements : List_Id;
3151 -- Statements executed when a zero value is received
3154 if Can_Never_Be_Null (RACW_Type) then
3155 Zero_Statements := New_List (
3156 Make_Raise_Constraint_Error (Loc,
3157 Reason => CE_Null_Not_Allowed));
3159 Zero_Statements := New_List (
3160 Make_Assignment_Statement (Loc,
3162 Expression => Make_Null (Loc)),
3163 Make_Simple_Return_Statement (Loc));
3166 Append_To (Statements,
3167 Make_Implicit_If_Statement (RACW_Type,
3170 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3171 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3172 Then_Statements => Zero_Statements));
3175 -- If the RACW denotes an object created on the current partition,
3176 -- Local_Statements will be executed. The real object will be used.
3178 Local_Statements := New_List (
3179 Make_Assignment_Statement (Loc,
3182 Unchecked_Convert_To (RACW_Type,
3183 OK_Convert_To (RTE (RE_Address),
3184 New_Occurrence_Of (Source_Address, Loc)))));
3186 -- If the object is located on another partition, then a stub object
3187 -- will be created with all the information needed to rebuild the
3188 -- real object at the other end.
3190 Remote_Statements := New_List (
3192 Make_Assignment_Statement (Loc,
3193 Name => Make_Selected_Component (Loc,
3194 Prefix => Stubbed_Result,
3195 Selector_Name => Name_Origin),
3197 New_Occurrence_Of (Source_Partition, Loc)),
3199 Make_Assignment_Statement (Loc,
3200 Name => Make_Selected_Component (Loc,
3201 Prefix => Stubbed_Result,
3202 Selector_Name => Name_Receiver),
3204 New_Occurrence_Of (Source_Receiver, Loc)),
3206 Make_Assignment_Statement (Loc,
3207 Name => Make_Selected_Component (Loc,
3208 Prefix => Stubbed_Result,
3209 Selector_Name => Name_Addr),
3211 New_Occurrence_Of (Source_Address, Loc)));
3213 Append_To (Remote_Statements,
3214 Make_Assignment_Statement (Loc,
3215 Name => Make_Selected_Component (Loc,
3216 Prefix => Stubbed_Result,
3217 Selector_Name => Name_Asynchronous),
3219 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3221 Append_List_To (Remote_Statements,
3222 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3223 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3224 -- set on the stub type if, and only if, the RACW type has a pragma
3225 -- Asynchronous. This is incorrect for RACWs that implement RAS
3226 -- types, because in that case the /designated subprogram/ (not the
3227 -- type) might be asynchronous, and that causes the stub to need to
3228 -- be asynchronous too. A solution is to transport a RAS as a struct
3229 -- containing a RACW and an asynchronous flag, and to properly alter
3230 -- the Asynchronous component in the stub type in the RAS's Input
3233 Append_To (Remote_Statements,
3234 Make_Assignment_Statement (Loc,
3236 Expression => Unchecked_Convert_To (RACW_Type,
3237 New_Occurrence_Of (Stubbed_Result, Loc))));
3239 -- Distinguish between the local and remote cases, and execute the
3240 -- appropriate piece of code.
3242 Append_To (Statements,
3243 Make_Implicit_If_Statement (RACW_Type,
3247 Make_Function_Call (Loc,
3248 Name => New_Occurrence_Of (
3249 RTE (RE_Get_Local_Partition_Id), Loc)),
3250 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3251 Then_Statements => Local_Statements,
3252 Else_Statements => Remote_Statements));
3254 Set_Declarations (Body_Node, Decls);
3255 Append_To (Body_Decls, Body_Node);
3256 end Add_RACW_Read_Attribute;
3258 ------------------------------
3259 -- Add_RACW_Write_Attribute --
3260 ------------------------------
3262 procedure Add_RACW_Write_Attribute
3263 (RACW_Type : Entity_Id;
3264 Stub_Type : Entity_Id;
3265 Stub_Type_Access : Entity_Id;
3266 RPC_Receiver : Node_Id;
3267 Body_Decls : List_Id)
3269 Body_Node : Node_Id;
3270 Proc_Decl : Node_Id;
3271 Attr_Decl : Node_Id;
3273 Statements : constant List_Id := New_List;
3274 Local_Statements : List_Id;
3275 Remote_Statements : List_Id;
3276 Null_Statements : List_Id;
3278 Pnam : constant Entity_Id :=
3279 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3282 Build_Stream_Procedure
3283 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
3285 Proc_Decl := Make_Subprogram_Declaration (Loc,
3286 Copy_Specification (Loc, Specification (Body_Node)));
3289 Make_Attribute_Definition_Clause (Loc,
3290 Name => New_Occurrence_Of (RACW_Type, Loc),
3291 Chars => Name_Write,
3294 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3296 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3297 Insert_After (Proc_Decl, Attr_Decl);
3299 if No (Body_Decls) then
3303 -- Build the code fragment corresponding to the marshalling of a
3306 Local_Statements := New_List (
3308 Pack_Entity_Into_Stream_Access (Loc,
3309 Stream => Stream_Parameter,
3310 Object => RTE (RE_Get_Local_Partition_Id)),
3312 Pack_Node_Into_Stream_Access (Loc,
3313 Stream => Stream_Parameter,
3314 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3315 Etyp => RTE (RE_Unsigned_64)),
3317 Pack_Node_Into_Stream_Access (Loc,
3318 Stream => Stream_Parameter,
3319 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3320 Make_Attribute_Reference (Loc,
3322 Make_Explicit_Dereference (Loc,
3324 Attribute_Name => Name_Address)),
3325 Etyp => RTE (RE_Unsigned_64)));
3327 -- Build the code fragment corresponding to the marshalling of
3330 Remote_Statements := New_List (
3331 Pack_Node_Into_Stream_Access (Loc,
3332 Stream => Stream_Parameter,
3334 Make_Selected_Component (Loc,
3336 Unchecked_Convert_To (Stub_Type_Access, Object),
3337 Selector_Name => Make_Identifier (Loc, Name_Origin)),
3338 Etyp => RTE (RE_Partition_ID)),
3340 Pack_Node_Into_Stream_Access (Loc,
3341 Stream => Stream_Parameter,
3343 Make_Selected_Component (Loc,
3345 Unchecked_Convert_To (Stub_Type_Access, Object),
3346 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
3347 Etyp => RTE (RE_Unsigned_64)),
3349 Pack_Node_Into_Stream_Access (Loc,
3350 Stream => Stream_Parameter,
3352 Make_Selected_Component (Loc,
3354 Unchecked_Convert_To (Stub_Type_Access, Object),
3355 Selector_Name => Make_Identifier (Loc, Name_Addr)),
3356 Etyp => RTE (RE_Unsigned_64)));
3358 -- Build code fragment corresponding to marshalling of a null object
3360 Null_Statements := New_List (
3362 Pack_Entity_Into_Stream_Access (Loc,
3363 Stream => Stream_Parameter,
3364 Object => RTE (RE_Get_Local_Partition_Id)),
3366 Pack_Node_Into_Stream_Access (Loc,
3367 Stream => Stream_Parameter,
3368 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3369 Etyp => RTE (RE_Unsigned_64)),
3371 Pack_Node_Into_Stream_Access (Loc,
3372 Stream => Stream_Parameter,
3373 Object => Make_Integer_Literal (Loc, Uint_0),
3374 Etyp => RTE (RE_Unsigned_64)));
3376 Append_To (Statements,
3377 Make_Implicit_If_Statement (RACW_Type,
3380 Left_Opnd => Object,
3381 Right_Opnd => Make_Null (Loc)),
3383 Then_Statements => Null_Statements,
3385 Elsif_Parts => New_List (
3386 Make_Elsif_Part (Loc,
3390 Make_Attribute_Reference (Loc,
3392 Attribute_Name => Name_Tag),
3395 Make_Attribute_Reference (Loc,
3396 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3397 Attribute_Name => Name_Tag)),
3398 Then_Statements => Remote_Statements)),
3399 Else_Statements => Local_Statements));
3401 Append_To (Body_Decls, Body_Node);
3402 end Add_RACW_Write_Attribute;
3404 ------------------------
3405 -- Add_RAS_Access_TSS --
3406 ------------------------
3408 procedure Add_RAS_Access_TSS (N : Node_Id) is
3409 Loc : constant Source_Ptr := Sloc (N);
3411 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3412 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3413 -- Ras_Type is the access to subprogram type while Fat_Type is the
3414 -- corresponding record type.
3416 RACW_Type : constant Entity_Id :=
3417 Underlying_RACW_Type (Ras_Type);
3418 Desig : constant Entity_Id :=
3419 Etype (Designated_Type (RACW_Type));
3421 Stub_Elements : constant Stub_Structure :=
3422 Stubs_Table.Get (Desig);
3423 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3425 Proc : constant Entity_Id :=
3426 Make_Defining_Identifier (Loc,
3427 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3429 Proc_Spec : Node_Id;
3431 -- Formal parameters
3433 Package_Name : constant Entity_Id :=
3434 Make_Defining_Identifier (Loc,
3438 Subp_Id : constant Entity_Id :=
3439 Make_Defining_Identifier (Loc,
3441 -- Target subprogram
3443 Asynch_P : constant Entity_Id :=
3444 Make_Defining_Identifier (Loc,
3445 Chars => Name_Asynchronous);
3446 -- Is the procedure to which the 'Access applies asynchronous?
3448 All_Calls_Remote : constant Entity_Id :=
3449 Make_Defining_Identifier (Loc,
3450 Chars => Name_All_Calls_Remote);
3451 -- True if an All_Calls_Remote pragma applies to the RCI unit
3452 -- that contains the subprogram.
3454 -- Common local variables
3456 Proc_Decls : List_Id;
3457 Proc_Statements : List_Id;
3459 Origin : constant Entity_Id :=
3460 Make_Defining_Identifier (Loc,
3461 Chars => New_Internal_Name ('P'));
3463 -- Additional local variables for the local case
3465 Proxy_Addr : constant Entity_Id :=
3466 Make_Defining_Identifier (Loc,
3467 Chars => New_Internal_Name ('P'));
3469 -- Additional local variables for the remote case
3471 Local_Stub : constant Entity_Id :=
3472 Make_Defining_Identifier (Loc,
3473 Chars => New_Internal_Name ('L'));
3475 Stub_Ptr : constant Entity_Id :=
3476 Make_Defining_Identifier (Loc,
3477 Chars => New_Internal_Name ('S'));
3480 (Field_Name : Name_Id;
3481 Value : Node_Id) return Node_Id;
3482 -- Construct an assignment that sets the named component in the
3490 (Field_Name : Name_Id;
3491 Value : Node_Id) return Node_Id
3495 Make_Assignment_Statement (Loc,
3497 Make_Selected_Component (Loc,
3499 Selector_Name => Field_Name),
3500 Expression => Value);
3503 -- Start of processing for Add_RAS_Access_TSS
3506 Proc_Decls := New_List (
3508 -- Common declarations
3510 Make_Object_Declaration (Loc,
3511 Defining_Identifier => Origin,
3512 Constant_Present => True,
3513 Object_Definition =>
3514 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3516 Make_Function_Call (Loc,
3518 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3519 Parameter_Associations => New_List (
3520 New_Occurrence_Of (Package_Name, Loc)))),
3522 -- Declaration use only in the local case: proxy address
3524 Make_Object_Declaration (Loc,
3525 Defining_Identifier => Proxy_Addr,
3526 Object_Definition =>
3527 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3529 -- Declarations used only in the remote case: stub object and
3532 Make_Object_Declaration (Loc,
3533 Defining_Identifier => Local_Stub,
3534 Aliased_Present => True,
3535 Object_Definition =>
3536 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3538 Make_Object_Declaration (Loc,
3539 Defining_Identifier =>
3541 Object_Definition =>
3542 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3544 Make_Attribute_Reference (Loc,
3545 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3546 Attribute_Name => Name_Unchecked_Access)));
3548 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3550 -- Build_Get_Unique_RP_Call needs above information
3552 -- Note: Here we assume that the Fat_Type is a record
3553 -- containing just a pointer to a proxy or stub object.
3555 Proc_Statements := New_List (
3559 -- Get_RAS_Info (Pkg, Subp, PA);
3560 -- if Origin = Local_Partition_Id
3561 -- and then not All_Calls_Remote
3563 -- return Fat_Type!(PA);
3566 Make_Procedure_Call_Statement (Loc,
3567 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3568 Parameter_Associations => New_List (
3569 New_Occurrence_Of (Package_Name, Loc),
3570 New_Occurrence_Of (Subp_Id, Loc),
3571 New_Occurrence_Of (Proxy_Addr, Loc))),
3573 Make_Implicit_If_Statement (N,
3579 New_Occurrence_Of (Origin, Loc),
3581 Make_Function_Call (Loc,
3583 RTE (RE_Get_Local_Partition_Id), Loc))),
3587 New_Occurrence_Of (All_Calls_Remote, Loc))),
3589 Then_Statements => New_List (
3590 Make_Simple_Return_Statement (Loc,
3591 Unchecked_Convert_To (Fat_Type,
3592 OK_Convert_To (RTE (RE_Address),
3593 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3595 Set_Field (Name_Origin,
3596 New_Occurrence_Of (Origin, Loc)),
3598 Set_Field (Name_Receiver,
3599 Make_Function_Call (Loc,
3601 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3602 Parameter_Associations => New_List (
3603 New_Occurrence_Of (Package_Name, Loc)))),
3605 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3607 -- E.4.1(9) A remote call is asynchronous if it is a call to
3608 -- a procedure or a call through a value of an access-to-procedure
3609 -- type to which a pragma Asynchronous applies.
3611 -- Asynch_P is true when the procedure is asynchronous;
3612 -- Asynch_T is true when the type is asynchronous.
3614 Set_Field (Name_Asynchronous,
3616 New_Occurrence_Of (Asynch_P, Loc),
3617 New_Occurrence_Of (Boolean_Literals (
3618 Is_Asynchronous (Ras_Type)), Loc))));
3620 Append_List_To (Proc_Statements,
3621 Build_Get_Unique_RP_Call
3622 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3624 -- Return the newly created value
3626 Append_To (Proc_Statements,
3627 Make_Simple_Return_Statement (Loc,
3629 Unchecked_Convert_To (Fat_Type,
3630 New_Occurrence_Of (Stub_Ptr, Loc))));
3633 Make_Function_Specification (Loc,
3634 Defining_Unit_Name => Proc,
3635 Parameter_Specifications => New_List (
3636 Make_Parameter_Specification (Loc,
3637 Defining_Identifier => Package_Name,
3639 New_Occurrence_Of (Standard_String, Loc)),
3641 Make_Parameter_Specification (Loc,
3642 Defining_Identifier => Subp_Id,
3644 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3646 Make_Parameter_Specification (Loc,
3647 Defining_Identifier => Asynch_P,
3649 New_Occurrence_Of (Standard_Boolean, Loc)),
3651 Make_Parameter_Specification (Loc,
3652 Defining_Identifier => All_Calls_Remote,
3654 New_Occurrence_Of (Standard_Boolean, Loc))),
3656 Result_Definition =>
3657 New_Occurrence_Of (Fat_Type, Loc));
3659 -- Set the kind and return type of the function to prevent
3660 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3662 Set_Ekind (Proc, E_Function);
3663 Set_Etype (Proc, Fat_Type);
3666 Make_Subprogram_Body (Loc,
3667 Specification => Proc_Spec,
3668 Declarations => Proc_Decls,
3669 Handled_Statement_Sequence =>
3670 Make_Handled_Sequence_Of_Statements (Loc,
3671 Statements => Proc_Statements)));
3673 Set_TSS (Fat_Type, Proc);
3674 end Add_RAS_Access_TSS;
3676 -----------------------
3677 -- Add_RAST_Features --
3678 -----------------------
3680 procedure Add_RAST_Features
3681 (Vis_Decl : Node_Id;
3682 RAS_Type : Entity_Id)
3684 pragma Unreferenced (RAS_Type);
3686 Add_RAS_Access_TSS (Vis_Decl);
3687 end Add_RAST_Features;
3689 -----------------------------------------
3690 -- Add_Receiving_Stubs_To_Declarations --
3691 -----------------------------------------
3693 procedure Add_Receiving_Stubs_To_Declarations
3694 (Pkg_Spec : Node_Id;
3698 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3700 Request_Parameter : Node_Id;
3702 Pkg_RPC_Receiver : constant Entity_Id :=
3703 Make_Defining_Identifier (Loc,
3704 New_Internal_Name ('H'));
3705 Pkg_RPC_Receiver_Statements : List_Id;
3706 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3707 Pkg_RPC_Receiver_Body : Node_Id;
3708 -- A Pkg_RPC_Receiver is built to decode the request
3710 Lookup_RAS_Info : constant Entity_Id :=
3711 Make_Defining_Identifier (Loc,
3712 Chars => New_Internal_Name ('R'));
3713 -- A remote subprogram is created to allow peers to look up
3714 -- RAS information using subprogram ids.
3716 Subp_Id : Entity_Id;
3717 Subp_Index : Entity_Id;
3718 -- Subprogram_Id as read from the incoming stream
3720 Current_Declaration : Node_Id;
3721 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3722 Current_Stubs : Node_Id;
3724 Subp_Info_Array : constant Entity_Id :=
3725 Make_Defining_Identifier (Loc,
3726 Chars => New_Internal_Name ('I'));
3728 Subp_Info_List : constant List_Id := New_List;
3730 Register_Pkg_Actuals : constant List_Id := New_List;
3732 All_Calls_Remote_E : Entity_Id;
3733 Proxy_Object_Addr : Entity_Id;
3735 procedure Append_Stubs_To
3736 (RPC_Receiver_Cases : List_Id;
3738 Subprogram_Number : Int);
3739 -- Add one case to the specified RPC receiver case list
3740 -- associating Subprogram_Number with the subprogram declared
3741 -- by Declaration, for which we have receiving stubs in Stubs.
3743 ---------------------
3744 -- Append_Stubs_To --
3745 ---------------------
3747 procedure Append_Stubs_To
3748 (RPC_Receiver_Cases : List_Id;
3750 Subprogram_Number : Int)
3753 Append_To (RPC_Receiver_Cases,
3754 Make_Case_Statement_Alternative (Loc,
3756 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3759 Make_Procedure_Call_Statement (Loc,
3761 New_Occurrence_Of (Defining_Entity (Stubs), Loc),
3762 Parameter_Associations => New_List (
3763 New_Occurrence_Of (Request_Parameter, Loc))))));
3764 end Append_Stubs_To;
3766 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3769 -- Building receiving stubs consist in several operations:
3771 -- - a package RPC receiver must be built. This subprogram
3772 -- will get a Subprogram_Id from the incoming stream
3773 -- and will dispatch the call to the right subprogram;
3775 -- - a receiving stub for each subprogram visible in the package
3776 -- spec. This stub will read all the parameters from the stream,
3777 -- and put the result as well as the exception occurrence in the
3780 -- - a dummy package with an empty spec and a body made of an
3781 -- elaboration part, whose job is to register the receiving
3782 -- part of this RCI package on the name server. This is done
3783 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3785 Build_RPC_Receiver_Body (
3786 RPC_Receiver => Pkg_RPC_Receiver,
3787 Request => Request_Parameter,
3789 Subp_Index => Subp_Index,
3790 Stmts => Pkg_RPC_Receiver_Statements,
3791 Decl => Pkg_RPC_Receiver_Body);
3792 pragma Assert (Subp_Id = Subp_Index);
3794 -- A null subp_id denotes a call through a RAS, in which case the
3795 -- next Uint_64 element in the stream is the address of the local
3796 -- proxy object, from which we can retrieve the actual subprogram id.
3798 Append_To (Pkg_RPC_Receiver_Statements,
3799 Make_Implicit_If_Statement (Pkg_Spec,
3802 New_Occurrence_Of (Subp_Id, Loc),
3803 Make_Integer_Literal (Loc, 0)),
3805 Then_Statements => New_List (
3806 Make_Assignment_Statement (Loc,
3808 New_Occurrence_Of (Subp_Id, Loc),
3811 Make_Selected_Component (Loc,
3813 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3814 OK_Convert_To (RTE (RE_Address),
3815 Make_Attribute_Reference (Loc,
3817 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3820 Expressions => New_List (
3821 Make_Selected_Component (Loc,
3822 Prefix => Request_Parameter,
3823 Selector_Name => Name_Params))))),
3826 Make_Identifier (Loc, Name_Subp_Id))))));
3828 -- Build a subprogram for RAS information lookups
3830 Current_Declaration :=
3831 Make_Subprogram_Declaration (Loc,
3833 Make_Function_Specification (Loc,
3834 Defining_Unit_Name =>
3836 Parameter_Specifications => New_List (
3837 Make_Parameter_Specification (Loc,
3838 Defining_Identifier =>
3839 Make_Defining_Identifier (Loc, Name_Subp_Id),
3843 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3844 Result_Definition =>
3845 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3847 Append_To (Decls, Current_Declaration);
3848 Analyze (Current_Declaration);
3850 Current_Stubs := Build_Subprogram_Receiving_Stubs
3851 (Vis_Decl => Current_Declaration,
3852 Asynchronous => False);
3853 Append_To (Decls, Current_Stubs);
3854 Analyze (Current_Stubs);
3856 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3859 Subprogram_Number => 1);
3861 -- For each subprogram, the receiving stub will be built and a
3862 -- case statement will be made on the Subprogram_Id to dispatch
3863 -- to the right subprogram.
3865 All_Calls_Remote_E :=
3867 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3869 Overload_Counter_Table.Reset;
3871 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3872 while Present (Current_Declaration) loop
3873 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3874 and then Comes_From_Source (Current_Declaration)
3877 Loc : constant Source_Ptr := Sloc (Current_Declaration);
3878 -- While specifically processing Current_Declaration, use
3879 -- its Sloc as the location of all generated nodes.
3881 Subp_Def : constant Entity_Id :=
3883 (Specification (Current_Declaration));
3885 Subp_Val : String_Id;
3886 pragma Warnings (Off, Subp_Val);
3889 -- Build receiving stub
3892 Build_Subprogram_Receiving_Stubs
3893 (Vis_Decl => Current_Declaration,
3895 Nkind (Specification (Current_Declaration)) =
3896 N_Procedure_Specification
3897 and then Is_Asynchronous (Subp_Def));
3899 Append_To (Decls, Current_Stubs);
3900 Analyze (Current_Stubs);
3904 Add_RAS_Proxy_And_Analyze (Decls,
3905 Vis_Decl => Current_Declaration,
3906 All_Calls_Remote_E => All_Calls_Remote_E,
3907 Proxy_Object_Addr => Proxy_Object_Addr);
3909 -- Compute distribution identifier
3911 Assign_Subprogram_Identifier
3913 Current_Subprogram_Number,
3917 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
3919 -- Add subprogram descriptor (RCI_Subp_Info) to the
3920 -- subprograms table for this receiver. The aggregate
3921 -- below must be kept consistent with the declaration
3922 -- of type RCI_Subp_Info in System.Partition_Interface.
3924 Append_To (Subp_Info_List,
3925 Make_Component_Association (Loc,
3926 Choices => New_List (
3927 Make_Integer_Literal (Loc,
3928 Current_Subprogram_Number)),
3931 Make_Aggregate (Loc,
3932 Component_Associations => New_List (
3933 Make_Component_Association (Loc,
3934 Choices => New_List (
3935 Make_Identifier (Loc, Name_Addr)),
3938 Proxy_Object_Addr, Loc))))));
3940 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3941 Stubs => Current_Stubs,
3942 Subprogram_Number => Current_Subprogram_Number);
3945 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3948 Next (Current_Declaration);
3951 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3952 -- rather than raising an exception since we do not want someone
3953 -- to crash a remote partition by sending invalid subprogram ids.
3954 -- This is consistent with the other parts of the case statement
3955 -- since even in presence of incorrect parameters in the stream,
3956 -- every exception will be caught and (if the subprogram is not an
3957 -- APC) put into the result stream and sent away.
3959 Append_To (Pkg_RPC_Receiver_Cases,
3960 Make_Case_Statement_Alternative (Loc,
3961 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
3962 Statements => New_List (Make_Null_Statement (Loc))));
3964 Append_To (Pkg_RPC_Receiver_Statements,
3965 Make_Case_Statement (Loc,
3966 Expression => New_Occurrence_Of (Subp_Id, Loc),
3967 Alternatives => Pkg_RPC_Receiver_Cases));
3970 Make_Object_Declaration (Loc,
3971 Defining_Identifier => Subp_Info_Array,
3972 Constant_Present => True,
3973 Aliased_Present => True,
3974 Object_Definition =>
3975 Make_Subtype_Indication (Loc,
3977 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3979 Make_Index_Or_Discriminant_Constraint (Loc,
3982 Low_Bound => Make_Integer_Literal (Loc,
3983 First_RCI_Subprogram_Id),
3985 Make_Integer_Literal (Loc,
3987 First_RCI_Subprogram_Id
3988 + List_Length (Subp_Info_List) - 1)))))));
3990 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3991 -- has zero length, and the declaration is for an empty array, in
3992 -- which case no initialization aggregate must be generated.
3994 if Present (First (Subp_Info_List)) then
3995 Set_Expression (Last (Decls),
3996 Make_Aggregate (Loc,
3997 Component_Associations => Subp_Info_List));
3999 -- No initialization provided: remove CONSTANT so that the
4000 -- declaration is not an incomplete deferred constant.
4003 Set_Constant_Present (Last (Decls), False);
4006 Analyze (Last (Decls));
4009 Subp_Info_Addr : Node_Id;
4010 -- Return statement for Lookup_RAS_Info: address of the subprogram
4011 -- information record for the requested subprogram id.
4014 if Present (First (Subp_Info_List)) then
4016 Make_Selected_Component (Loc,
4018 Make_Indexed_Component (Loc,
4019 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4020 Expressions => New_List (
4021 Convert_To (Standard_Integer,
4022 Make_Identifier (Loc, Name_Subp_Id)))),
4023 Selector_Name => Make_Identifier (Loc, Name_Addr));
4025 -- Case of no visible subprogram: just raise Constraint_Error, we
4026 -- know for sure we got junk from a remote partition.
4030 Make_Raise_Constraint_Error (Loc,
4031 Reason => CE_Range_Check_Failed);
4032 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
4036 Make_Subprogram_Body (Loc,
4038 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
4039 Declarations => No_List,
4040 Handled_Statement_Sequence =>
4041 Make_Handled_Sequence_Of_Statements (Loc,
4042 Statements => New_List (
4043 Make_Simple_Return_Statement (Loc,
4046 (RTE (RE_Unsigned_64), Subp_Info_Addr))))));
4049 Analyze (Last (Decls));
4051 Append_To (Decls, Pkg_RPC_Receiver_Body);
4052 Analyze (Last (Decls));
4054 Get_Library_Unit_Name_String (Pkg_Spec);
4058 Append_To (Register_Pkg_Actuals,
4059 Make_String_Literal (Loc,
4060 Strval => String_From_Name_Buffer));
4064 Append_To (Register_Pkg_Actuals,
4065 Make_Attribute_Reference (Loc,
4066 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
4067 Attribute_Name => Name_Unrestricted_Access));
4071 Append_To (Register_Pkg_Actuals,
4072 Make_Attribute_Reference (Loc,
4074 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
4075 Attribute_Name => Name_Version));
4079 Append_To (Register_Pkg_Actuals,
4080 Make_Attribute_Reference (Loc,
4081 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4082 Attribute_Name => Name_Address));
4086 Append_To (Register_Pkg_Actuals,
4087 Make_Attribute_Reference (Loc,
4088 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4089 Attribute_Name => Name_Length));
4091 -- Generate the call
4094 Make_Procedure_Call_Statement (Loc,
4096 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
4097 Parameter_Associations => Register_Pkg_Actuals));
4098 Analyze (Last (Stmts));
4099 end Add_Receiving_Stubs_To_Declarations;
4101 ---------------------------------
4102 -- Build_General_Calling_Stubs --
4103 ---------------------------------
4105 procedure Build_General_Calling_Stubs
4107 Statements : List_Id;
4108 Target_Partition : Entity_Id;
4109 Target_RPC_Receiver : Node_Id;
4110 Subprogram_Id : Node_Id;
4111 Asynchronous : Node_Id := Empty;
4112 Is_Known_Asynchronous : Boolean := False;
4113 Is_Known_Non_Asynchronous : Boolean := False;
4114 Is_Function : Boolean;
4116 Stub_Type : Entity_Id := Empty;
4117 RACW_Type : Entity_Id := Empty;
4120 Loc : constant Source_Ptr := Sloc (Nod);
4122 Stream_Parameter : Node_Id;
4123 -- Name of the stream used to transmit parameters to the remote
4126 Result_Parameter : Node_Id;
4127 -- Name of the result parameter (in non-APC cases) which get the
4128 -- result of the remote subprogram.
4130 Exception_Return_Parameter : Node_Id;
4131 -- Name of the parameter which will hold the exception sent by the
4132 -- remote subprogram.
4134 Current_Parameter : Node_Id;
4135 -- Current parameter being handled
4137 Ordered_Parameters_List : constant List_Id :=
4138 Build_Ordered_Parameters_List (Spec);
4140 Asynchronous_Statements : List_Id := No_List;
4141 Non_Asynchronous_Statements : List_Id := No_List;
4142 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4144 Extra_Formal_Statements : constant List_Id := New_List;
4145 -- List of statements for extra formal parameters. It will appear
4146 -- after the regular statements for writing out parameters.
4148 pragma Unreferenced (RACW_Type);
4149 -- Used only for the PolyORB case
4152 -- The general form of a calling stub for a given subprogram is:
4154 -- procedure X (...) is P : constant Partition_ID :=
4155 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4156 -- System.RPC.Params_Stream_Type (0); begin
4157 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4158 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4159 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4160 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4162 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4164 -- There are some variations: Do_APC is called for an asynchronous
4165 -- procedure and the part after the call is completely ommitted as
4166 -- well as the declaration of Result. For a function call, 'Input is
4167 -- always used to read the result even if it is constrained.
4170 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4173 Make_Object_Declaration (Loc,
4174 Defining_Identifier => Stream_Parameter,
4175 Aliased_Present => True,
4176 Object_Definition =>
4177 Make_Subtype_Indication (Loc,
4179 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4181 Make_Index_Or_Discriminant_Constraint (Loc,
4183 New_List (Make_Integer_Literal (Loc, 0))))));
4185 if not Is_Known_Asynchronous then
4187 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4190 Make_Object_Declaration (Loc,
4191 Defining_Identifier => Result_Parameter,
4192 Aliased_Present => True,
4193 Object_Definition =>
4194 Make_Subtype_Indication (Loc,
4196 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4198 Make_Index_Or_Discriminant_Constraint (Loc,
4200 New_List (Make_Integer_Literal (Loc, 0))))));
4202 Exception_Return_Parameter :=
4203 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4206 Make_Object_Declaration (Loc,
4207 Defining_Identifier => Exception_Return_Parameter,
4208 Object_Definition =>
4209 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4212 Result_Parameter := Empty;
4213 Exception_Return_Parameter := Empty;
4216 -- Put first the RPC receiver corresponding to the remote package
4218 Append_To (Statements,
4219 Make_Attribute_Reference (Loc,
4221 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4222 Attribute_Name => Name_Write,
4223 Expressions => New_List (
4224 Make_Attribute_Reference (Loc,
4225 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4226 Attribute_Name => Name_Access),
4227 Target_RPC_Receiver)));
4229 -- Then put the Subprogram_Id of the subprogram we want to call in
4232 Append_To (Statements,
4233 Make_Attribute_Reference (Loc,
4234 Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4235 Attribute_Name => Name_Write,
4236 Expressions => New_List (
4237 Make_Attribute_Reference (Loc,
4238 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4239 Attribute_Name => Name_Access),
4242 Current_Parameter := First (Ordered_Parameters_List);
4243 while Present (Current_Parameter) loop
4245 Typ : constant Node_Id :=
4246 Parameter_Type (Current_Parameter);
4248 Constrained : Boolean;
4250 Extra_Parameter : Entity_Id;
4253 if Is_RACW_Controlling_Formal
4254 (Current_Parameter, Stub_Type)
4256 -- In the case of a controlling formal argument, we marshall
4257 -- its addr field rather than the local stub.
4259 Append_To (Statements,
4260 Pack_Node_Into_Stream (Loc,
4261 Stream => Stream_Parameter,
4263 Make_Selected_Component (Loc,
4265 Defining_Identifier (Current_Parameter),
4266 Selector_Name => Name_Addr),
4267 Etyp => RTE (RE_Unsigned_64)));
4272 (Defining_Identifier (Current_Parameter), Loc);
4274 -- Access type parameters are transmitted as in out
4275 -- parameters. However, a dereference is needed so that
4276 -- we marshall the designated object.
4278 if Nkind (Typ) = N_Access_Definition then
4279 Value := Make_Explicit_Dereference (Loc, Value);
4280 Etyp := Etype (Subtype_Mark (Typ));
4282 Etyp := Etype (Typ);
4285 Constrained := not Transmit_As_Unconstrained (Etyp);
4287 -- Any parameter but unconstrained out parameters are
4288 -- transmitted to the peer.
4290 if In_Present (Current_Parameter)
4291 or else not Out_Present (Current_Parameter)
4292 or else not Constrained
4294 Append_To (Statements,
4295 Make_Attribute_Reference (Loc,
4296 Prefix => New_Occurrence_Of (Etyp, Loc),
4298 Output_From_Constrained (Constrained),
4299 Expressions => New_List (
4300 Make_Attribute_Reference (Loc,
4302 New_Occurrence_Of (Stream_Parameter, Loc),
4303 Attribute_Name => Name_Access),
4308 -- If the current parameter has a dynamic constrained status,
4309 -- then this status is transmitted as well.
4310 -- This should be done for accessibility as well ???
4312 if Nkind (Typ) /= N_Access_Definition
4313 and then Need_Extra_Constrained (Current_Parameter)
4315 -- In this block, we do not use the extra formal that has
4316 -- been created because it does not exist at the time of
4317 -- expansion when building calling stubs for remote access
4318 -- to subprogram types. We create an extra variable of this
4319 -- type and push it in the stream after the regular
4322 Extra_Parameter := Make_Defining_Identifier
4323 (Loc, New_Internal_Name ('P'));
4326 Make_Object_Declaration (Loc,
4327 Defining_Identifier => Extra_Parameter,
4328 Constant_Present => True,
4329 Object_Definition =>
4330 New_Occurrence_Of (Standard_Boolean, Loc),
4332 Make_Attribute_Reference (Loc,
4335 Defining_Identifier (Current_Parameter), Loc),
4336 Attribute_Name => Name_Constrained)));
4338 Append_To (Extra_Formal_Statements,
4339 Make_Attribute_Reference (Loc,
4341 New_Occurrence_Of (Standard_Boolean, Loc),
4342 Attribute_Name => Name_Write,
4343 Expressions => New_List (
4344 Make_Attribute_Reference (Loc,
4347 (Stream_Parameter, Loc), Attribute_Name =>
4349 New_Occurrence_Of (Extra_Parameter, Loc))));
4352 Next (Current_Parameter);
4356 -- Append the formal statements list to the statements
4358 Append_List_To (Statements, Extra_Formal_Statements);
4360 if not Is_Known_Non_Asynchronous then
4362 -- Build the call to System.RPC.Do_APC
4364 Asynchronous_Statements := New_List (
4365 Make_Procedure_Call_Statement (Loc,
4367 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4368 Parameter_Associations => New_List (
4369 New_Occurrence_Of (Target_Partition, Loc),
4370 Make_Attribute_Reference (Loc,
4372 New_Occurrence_Of (Stream_Parameter, Loc),
4373 Attribute_Name => Name_Access))));
4375 Asynchronous_Statements := No_List;
4378 if not Is_Known_Asynchronous then
4380 -- Build the call to System.RPC.Do_RPC
4382 Non_Asynchronous_Statements := New_List (
4383 Make_Procedure_Call_Statement (Loc,
4385 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4386 Parameter_Associations => New_List (
4387 New_Occurrence_Of (Target_Partition, Loc),
4389 Make_Attribute_Reference (Loc,
4391 New_Occurrence_Of (Stream_Parameter, Loc),
4392 Attribute_Name => Name_Access),
4394 Make_Attribute_Reference (Loc,
4396 New_Occurrence_Of (Result_Parameter, Loc),
4397 Attribute_Name => Name_Access))));
4399 -- Read the exception occurrence from the result stream and
4400 -- reraise it. It does no harm if this is a Null_Occurrence since
4401 -- this does nothing.
4403 Append_To (Non_Asynchronous_Statements,
4404 Make_Attribute_Reference (Loc,
4406 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4408 Attribute_Name => Name_Read,
4410 Expressions => New_List (
4411 Make_Attribute_Reference (Loc,
4413 New_Occurrence_Of (Result_Parameter, Loc),
4414 Attribute_Name => Name_Access),
4415 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4417 Append_To (Non_Asynchronous_Statements,
4418 Make_Procedure_Call_Statement (Loc,
4420 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4421 Parameter_Associations => New_List (
4422 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4426 -- If this is a function call, then read the value and return
4427 -- it. The return value is written/read using 'Output/'Input.
4429 Append_To (Non_Asynchronous_Statements,
4430 Make_Tag_Check (Loc,
4431 Make_Simple_Return_Statement (Loc,
4433 Make_Attribute_Reference (Loc,
4436 Etype (Result_Definition (Spec)), Loc),
4438 Attribute_Name => Name_Input,
4440 Expressions => New_List (
4441 Make_Attribute_Reference (Loc,
4443 New_Occurrence_Of (Result_Parameter, Loc),
4444 Attribute_Name => Name_Access))))));
4447 -- Loop around parameters and assign out (or in out)
4448 -- parameters. In the case of RACW, controlling arguments
4449 -- cannot possibly have changed since they are remote, so
4450 -- we do not read them from the stream.
4452 Current_Parameter := First (Ordered_Parameters_List);
4453 while Present (Current_Parameter) loop
4455 Typ : constant Node_Id :=
4456 Parameter_Type (Current_Parameter);
4463 (Defining_Identifier (Current_Parameter), Loc);
4465 if Nkind (Typ) = N_Access_Definition then
4466 Value := Make_Explicit_Dereference (Loc, Value);
4467 Etyp := Etype (Subtype_Mark (Typ));
4469 Etyp := Etype (Typ);
4472 if (Out_Present (Current_Parameter)
4473 or else Nkind (Typ) = N_Access_Definition)
4474 and then Etyp /= Stub_Type
4476 Append_To (Non_Asynchronous_Statements,
4477 Make_Attribute_Reference (Loc,
4479 New_Occurrence_Of (Etyp, Loc),
4481 Attribute_Name => Name_Read,
4483 Expressions => New_List (
4484 Make_Attribute_Reference (Loc,
4486 New_Occurrence_Of (Result_Parameter, Loc),
4487 Attribute_Name => Name_Access),
4492 Next (Current_Parameter);
4497 if Is_Known_Asynchronous then
4498 Append_List_To (Statements, Asynchronous_Statements);
4500 elsif Is_Known_Non_Asynchronous then
4501 Append_List_To (Statements, Non_Asynchronous_Statements);
4504 pragma Assert (Present (Asynchronous));
4505 Prepend_To (Asynchronous_Statements,
4506 Make_Attribute_Reference (Loc,
4507 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4508 Attribute_Name => Name_Write,
4509 Expressions => New_List (
4510 Make_Attribute_Reference (Loc,
4512 New_Occurrence_Of (Stream_Parameter, Loc),
4513 Attribute_Name => Name_Access),
4514 New_Occurrence_Of (Standard_True, Loc))));
4516 Prepend_To (Non_Asynchronous_Statements,
4517 Make_Attribute_Reference (Loc,
4518 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4519 Attribute_Name => Name_Write,
4520 Expressions => New_List (
4521 Make_Attribute_Reference (Loc,
4523 New_Occurrence_Of (Stream_Parameter, Loc),
4524 Attribute_Name => Name_Access),
4525 New_Occurrence_Of (Standard_False, Loc))));
4527 Append_To (Statements,
4528 Make_Implicit_If_Statement (Nod,
4529 Condition => Asynchronous,
4530 Then_Statements => Asynchronous_Statements,
4531 Else_Statements => Non_Asynchronous_Statements));
4533 end Build_General_Calling_Stubs;
4535 -----------------------------
4536 -- Build_RPC_Receiver_Body --
4537 -----------------------------
4539 procedure Build_RPC_Receiver_Body
4540 (RPC_Receiver : Entity_Id;
4541 Request : out Entity_Id;
4542 Subp_Id : out Entity_Id;
4543 Subp_Index : out Entity_Id;
4544 Stmts : out List_Id;
4547 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4549 RPC_Receiver_Spec : Node_Id;
4550 RPC_Receiver_Decls : List_Id;
4553 Request := Make_Defining_Identifier (Loc, Name_R);
4555 RPC_Receiver_Spec :=
4556 Build_RPC_Receiver_Specification
4557 (RPC_Receiver => RPC_Receiver,
4558 Request_Parameter => Request);
4560 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4561 Subp_Index := Subp_Id;
4563 -- Subp_Id may not be a constant, because in the case of the RPC
4564 -- receiver for an RCI package, when a call is received from a RAS
4565 -- dereference, it will be assigned during subsequent processing.
4567 RPC_Receiver_Decls := New_List (
4568 Make_Object_Declaration (Loc,
4569 Defining_Identifier => Subp_Id,
4570 Object_Definition =>
4571 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4573 Make_Attribute_Reference (Loc,
4575 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4576 Attribute_Name => Name_Input,
4577 Expressions => New_List (
4578 Make_Selected_Component (Loc,
4580 Selector_Name => Name_Params)))));
4585 Make_Subprogram_Body (Loc,
4586 Specification => RPC_Receiver_Spec,
4587 Declarations => RPC_Receiver_Decls,
4588 Handled_Statement_Sequence =>
4589 Make_Handled_Sequence_Of_Statements (Loc,
4590 Statements => Stmts));
4591 end Build_RPC_Receiver_Body;
4593 -----------------------
4594 -- Build_Stub_Target --
4595 -----------------------
4597 function Build_Stub_Target
4600 RCI_Locator : Entity_Id;
4601 Controlling_Parameter : Entity_Id) return RPC_Target
4603 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4605 Target_Info.Partition :=
4606 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4607 if Present (Controlling_Parameter) then
4609 Make_Object_Declaration (Loc,
4610 Defining_Identifier => Target_Info.Partition,
4611 Constant_Present => True,
4612 Object_Definition =>
4613 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4616 Make_Selected_Component (Loc,
4617 Prefix => Controlling_Parameter,
4618 Selector_Name => Name_Origin)));
4620 Target_Info.RPC_Receiver :=
4621 Make_Selected_Component (Loc,
4622 Prefix => Controlling_Parameter,
4623 Selector_Name => Name_Receiver);
4627 Make_Object_Declaration (Loc,
4628 Defining_Identifier => Target_Info.Partition,
4629 Constant_Present => True,
4630 Object_Definition =>
4631 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4634 Make_Function_Call (Loc,
4635 Name => Make_Selected_Component (Loc,
4637 Make_Identifier (Loc, Chars (RCI_Locator)),
4639 Make_Identifier (Loc,
4640 Name_Get_Active_Partition_ID)))));
4642 Target_Info.RPC_Receiver :=
4643 Make_Selected_Component (Loc,
4645 Make_Identifier (Loc, Chars (RCI_Locator)),
4647 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4650 end Build_Stub_Target;
4652 ---------------------
4653 -- Build_Stub_Type --
4654 ---------------------
4656 procedure Build_Stub_Type
4657 (RACW_Type : Entity_Id;
4658 Stub_Type_Comps : out List_Id;
4659 RPC_Receiver_Decl : out Node_Id)
4661 Loc : constant Source_Ptr := Sloc (RACW_Type);
4662 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4665 Stub_Type_Comps := New_List (
4666 Make_Component_Declaration (Loc,
4667 Defining_Identifier =>
4668 Make_Defining_Identifier (Loc, Name_Origin),
4669 Component_Definition =>
4670 Make_Component_Definition (Loc,
4671 Aliased_Present => False,
4672 Subtype_Indication =>
4673 New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
4675 Make_Component_Declaration (Loc,
4676 Defining_Identifier =>
4677 Make_Defining_Identifier (Loc, Name_Receiver),
4678 Component_Definition =>
4679 Make_Component_Definition (Loc,
4680 Aliased_Present => False,
4681 Subtype_Indication =>
4682 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4684 Make_Component_Declaration (Loc,
4685 Defining_Identifier =>
4686 Make_Defining_Identifier (Loc, Name_Addr),
4687 Component_Definition =>
4688 Make_Component_Definition (Loc,
4689 Aliased_Present => False,
4690 Subtype_Indication =>
4691 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4693 Make_Component_Declaration (Loc,
4694 Defining_Identifier =>
4695 Make_Defining_Identifier (Loc, Name_Asynchronous),
4696 Component_Definition =>
4697 Make_Component_Definition (Loc,
4698 Aliased_Present => False,
4699 Subtype_Indication =>
4700 New_Occurrence_Of (Standard_Boolean, Loc))));
4703 RPC_Receiver_Decl := Empty;
4706 RPC_Receiver_Request : constant Entity_Id :=
4707 Make_Defining_Identifier (Loc, Name_R);
4709 RPC_Receiver_Decl :=
4710 Make_Subprogram_Declaration (Loc,
4711 Build_RPC_Receiver_Specification (
4712 RPC_Receiver => Make_Defining_Identifier (Loc,
4713 New_Internal_Name ('R')),
4714 Request_Parameter => RPC_Receiver_Request));
4717 end Build_Stub_Type;
4719 --------------------------------------
4720 -- Build_Subprogram_Receiving_Stubs --
4721 --------------------------------------
4723 function Build_Subprogram_Receiving_Stubs
4724 (Vis_Decl : Node_Id;
4725 Asynchronous : Boolean;
4726 Dynamically_Asynchronous : Boolean := False;
4727 Stub_Type : Entity_Id := Empty;
4728 RACW_Type : Entity_Id := Empty;
4729 Parent_Primitive : Entity_Id := Empty) return Node_Id
4731 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4733 Request_Parameter : constant Entity_Id :=
4734 Make_Defining_Identifier (Loc,
4735 New_Internal_Name ('R'));
4736 -- Formal parameter for receiving stubs: a descriptor for an incoming
4739 Decls : constant List_Id := New_List;
4740 -- All the parameters will get declared before calling the real
4741 -- subprograms. Also the out parameters will be declared.
4743 Statements : constant List_Id := New_List;
4745 Extra_Formal_Statements : constant List_Id := New_List;
4746 -- Statements concerning extra formal parameters
4748 After_Statements : constant List_Id := New_List;
4749 -- Statements to be executed after the subprogram call
4751 Inner_Decls : List_Id := No_List;
4752 -- In case of a function, the inner declarations are needed since
4753 -- the result may be unconstrained.
4755 Excep_Handlers : List_Id := No_List;
4756 Excep_Choice : Entity_Id;
4757 Excep_Code : List_Id;
4759 Parameter_List : constant List_Id := New_List;
4760 -- List of parameters to be passed to the subprogram
4762 Current_Parameter : Node_Id;
4764 Ordered_Parameters_List : constant List_Id :=
4765 Build_Ordered_Parameters_List
4766 (Specification (Vis_Decl));
4768 Subp_Spec : Node_Id;
4769 -- Subprogram specification
4771 Called_Subprogram : Node_Id;
4772 -- The subprogram to call
4774 Null_Raise_Statement : Node_Id;
4776 Dynamic_Async : Entity_Id;
4779 if Present (RACW_Type) then
4780 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4782 Called_Subprogram :=
4784 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4787 if Dynamically_Asynchronous then
4789 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4791 Dynamic_Async := Empty;
4794 if not Asynchronous or Dynamically_Asynchronous then
4796 -- The first statement after the subprogram call is a statement to
4797 -- write a Null_Occurrence into the result stream.
4799 Null_Raise_Statement :=
4800 Make_Attribute_Reference (Loc,
4802 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4803 Attribute_Name => Name_Write,
4804 Expressions => New_List (
4805 Make_Selected_Component (Loc,
4806 Prefix => Request_Parameter,
4807 Selector_Name => Name_Result),
4808 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4810 if Dynamically_Asynchronous then
4811 Null_Raise_Statement :=
4812 Make_Implicit_If_Statement (Vis_Decl,
4814 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4815 Then_Statements => New_List (Null_Raise_Statement));
4818 Append_To (After_Statements, Null_Raise_Statement);
4821 -- Loop through every parameter and get its value from the stream. If
4822 -- the parameter is unconstrained, then the parameter is read using
4823 -- 'Input at the point of declaration.
4825 Current_Parameter := First (Ordered_Parameters_List);
4826 while Present (Current_Parameter) loop
4829 Constrained : Boolean;
4831 Need_Extra_Constrained : Boolean;
4832 -- True when an Extra_Constrained actual is required
4834 Object : constant Entity_Id :=
4835 Make_Defining_Identifier (Loc,
4836 New_Internal_Name ('P'));
4838 Expr : Node_Id := Empty;
4840 Is_Controlling_Formal : constant Boolean :=
4841 Is_RACW_Controlling_Formal
4842 (Current_Parameter, Stub_Type);
4845 if Is_Controlling_Formal then
4847 -- We have a controlling formal parameter. Read its address
4848 -- rather than a real object. The address is in Unsigned_64
4851 Etyp := RTE (RE_Unsigned_64);
4853 Etyp := Etype (Parameter_Type (Current_Parameter));
4856 Constrained := not Transmit_As_Unconstrained (Etyp);
4858 if In_Present (Current_Parameter)
4859 or else not Out_Present (Current_Parameter)
4860 or else not Constrained
4861 or else Is_Controlling_Formal
4863 -- If an input parameter is constrained, then the read of
4864 -- the parameter is deferred until the beginning of the
4865 -- subprogram body. If it is unconstrained, then an
4866 -- expression is built for the object declaration and the
4867 -- variable is set using 'Input instead of 'Read. Note that
4868 -- this deferral does not change the order in which the
4869 -- actuals are read because Build_Ordered_Parameter_List
4870 -- puts them unconstrained first.
4873 Append_To (Statements,
4874 Make_Attribute_Reference (Loc,
4875 Prefix => New_Occurrence_Of (Etyp, Loc),
4876 Attribute_Name => Name_Read,
4877 Expressions => New_List (
4878 Make_Selected_Component (Loc,
4879 Prefix => Request_Parameter,
4880 Selector_Name => Name_Params),
4881 New_Occurrence_Of (Object, Loc))));
4885 -- Build and append Input_With_Tag_Check function
4888 Input_With_Tag_Check (Loc,
4891 Make_Selected_Component (Loc,
4892 Prefix => Request_Parameter,
4893 Selector_Name => Name_Params)));
4895 -- Prepare function call expression
4898 Make_Function_Call (Loc,
4902 (Specification (Last (Decls))), Loc));
4906 Need_Extra_Constrained :=
4907 Nkind (Parameter_Type (Current_Parameter)) /=
4910 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4912 Present (Extra_Constrained
4913 (Defining_Identifier (Current_Parameter)));
4915 -- We may not associate an extra constrained actual to a
4916 -- constant object, so if one is needed, declare the actual
4917 -- as a variable even if it won't be modified.
4919 Build_Actual_Object_Declaration
4922 Variable => Need_Extra_Constrained
4923 or else Out_Present (Current_Parameter),
4927 -- An out parameter may be written back using a 'Write
4928 -- attribute instead of a 'Output because it has been
4929 -- constrained by the parameter given to the caller. Note that
4930 -- out controlling arguments in the case of a RACW are not put
4931 -- back in the stream because the pointer on them has not
4934 if Out_Present (Current_Parameter)
4936 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4938 Append_To (After_Statements,
4939 Make_Attribute_Reference (Loc,
4940 Prefix => New_Occurrence_Of (Etyp, Loc),
4941 Attribute_Name => Name_Write,
4942 Expressions => New_List (
4943 Make_Selected_Component (Loc,
4944 Prefix => Request_Parameter,
4945 Selector_Name => Name_Result),
4946 New_Occurrence_Of (Object, Loc))));
4949 -- For RACW controlling formals, the Etyp of Object is always
4950 -- an RACW, even if the parameter is not of an anonymous access
4951 -- type. In such case, we need to dereference it at call time.
4953 if Is_Controlling_Formal then
4954 if Nkind (Parameter_Type (Current_Parameter)) /=
4957 Append_To (Parameter_List,
4958 Make_Parameter_Association (Loc,
4961 Defining_Identifier (Current_Parameter), Loc),
4962 Explicit_Actual_Parameter =>
4963 Make_Explicit_Dereference (Loc,
4964 Unchecked_Convert_To (RACW_Type,
4965 OK_Convert_To (RTE (RE_Address),
4966 New_Occurrence_Of (Object, Loc))))));
4969 Append_To (Parameter_List,
4970 Make_Parameter_Association (Loc,
4973 Defining_Identifier (Current_Parameter), Loc),
4974 Explicit_Actual_Parameter =>
4975 Unchecked_Convert_To (RACW_Type,
4976 OK_Convert_To (RTE (RE_Address),
4977 New_Occurrence_Of (Object, Loc)))));
4981 Append_To (Parameter_List,
4982 Make_Parameter_Association (Loc,
4985 Defining_Identifier (Current_Parameter), Loc),
4986 Explicit_Actual_Parameter =>
4987 New_Occurrence_Of (Object, Loc)));
4990 -- If the current parameter needs an extra formal, then read it
4991 -- from the stream and set the corresponding semantic field in
4992 -- the variable. If the kind of the parameter identifier is
4993 -- E_Void, then this is a compiler generated parameter that
4994 -- doesn't need an extra constrained status.
4996 -- The case of Extra_Accessibility should also be handled ???
4998 if Need_Extra_Constrained then
5000 Extra_Parameter : constant Entity_Id :=
5002 (Defining_Identifier
5003 (Current_Parameter));
5005 Formal_Entity : constant Entity_Id :=
5006 Make_Defining_Identifier
5007 (Loc, Chars (Extra_Parameter));
5009 Formal_Type : constant Entity_Id :=
5010 Etype (Extra_Parameter);
5014 Make_Object_Declaration (Loc,
5015 Defining_Identifier => Formal_Entity,
5016 Object_Definition =>
5017 New_Occurrence_Of (Formal_Type, Loc)));
5019 Append_To (Extra_Formal_Statements,
5020 Make_Attribute_Reference (Loc,
5021 Prefix => New_Occurrence_Of (
5023 Attribute_Name => Name_Read,
5024 Expressions => New_List (
5025 Make_Selected_Component (Loc,
5026 Prefix => Request_Parameter,
5027 Selector_Name => Name_Params),
5028 New_Occurrence_Of (Formal_Entity, Loc))));
5030 -- Note: the call to Set_Extra_Constrained below relies
5031 -- on the fact that Object's Ekind has been set by
5032 -- Build_Actual_Object_Declaration.
5034 Set_Extra_Constrained (Object, Formal_Entity);
5039 Next (Current_Parameter);
5042 -- Append the formal statements list at the end of regular statements
5044 Append_List_To (Statements, Extra_Formal_Statements);
5046 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
5048 -- The remote subprogram is a function. We build an inner block to
5049 -- be able to hold a potentially unconstrained result in a
5053 Etyp : constant Entity_Id :=
5054 Etype (Result_Definition (Specification (Vis_Decl)));
5055 Result : constant Node_Id :=
5056 Make_Defining_Identifier (Loc,
5057 New_Internal_Name ('R'));
5059 Inner_Decls := New_List (
5060 Make_Object_Declaration (Loc,
5061 Defining_Identifier => Result,
5062 Constant_Present => True,
5063 Object_Definition => New_Occurrence_Of (Etyp, Loc),
5065 Make_Function_Call (Loc,
5066 Name => Called_Subprogram,
5067 Parameter_Associations => Parameter_List)));
5069 if Is_Class_Wide_Type (Etyp) then
5071 -- For a remote call to a function with a class-wide type,
5072 -- check that the returned value satisfies the requirements
5075 Append_To (Inner_Decls,
5076 Make_Transportable_Check (Loc,
5077 New_Occurrence_Of (Result, Loc)));
5081 Append_To (After_Statements,
5082 Make_Attribute_Reference (Loc,
5083 Prefix => New_Occurrence_Of (Etyp, Loc),
5084 Attribute_Name => Name_Output,
5085 Expressions => New_List (
5086 Make_Selected_Component (Loc,
5087 Prefix => Request_Parameter,
5088 Selector_Name => Name_Result),
5089 New_Occurrence_Of (Result, Loc))));
5092 Append_To (Statements,
5093 Make_Block_Statement (Loc,
5094 Declarations => Inner_Decls,
5095 Handled_Statement_Sequence =>
5096 Make_Handled_Sequence_Of_Statements (Loc,
5097 Statements => After_Statements)));
5100 -- The remote subprogram is a procedure. We do not need any inner
5101 -- block in this case.
5103 if Dynamically_Asynchronous then
5105 Make_Object_Declaration (Loc,
5106 Defining_Identifier => Dynamic_Async,
5107 Object_Definition =>
5108 New_Occurrence_Of (Standard_Boolean, Loc)));
5110 Append_To (Statements,
5111 Make_Attribute_Reference (Loc,
5112 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5113 Attribute_Name => Name_Read,
5114 Expressions => New_List (
5115 Make_Selected_Component (Loc,
5116 Prefix => Request_Parameter,
5117 Selector_Name => Name_Params),
5118 New_Occurrence_Of (Dynamic_Async, Loc))));
5121 Append_To (Statements,
5122 Make_Procedure_Call_Statement (Loc,
5123 Name => Called_Subprogram,
5124 Parameter_Associations => Parameter_List));
5126 Append_List_To (Statements, After_Statements);
5129 if Asynchronous and then not Dynamically_Asynchronous then
5131 -- For an asynchronous procedure, add a null exception handler
5133 Excep_Handlers := New_List (
5134 Make_Implicit_Exception_Handler (Loc,
5135 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5136 Statements => New_List (Make_Null_Statement (Loc))));
5139 -- In the other cases, if an exception is raised, then the
5140 -- exception occurrence is copied into the output stream and
5141 -- no other output parameter is written.
5144 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5146 Excep_Code := New_List (
5147 Make_Attribute_Reference (Loc,
5149 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5150 Attribute_Name => Name_Write,
5151 Expressions => New_List (
5152 Make_Selected_Component (Loc,
5153 Prefix => Request_Parameter,
5154 Selector_Name => Name_Result),
5155 New_Occurrence_Of (Excep_Choice, Loc))));
5157 if Dynamically_Asynchronous then
5158 Excep_Code := New_List (
5159 Make_Implicit_If_Statement (Vis_Decl,
5160 Condition => Make_Op_Not (Loc,
5161 New_Occurrence_Of (Dynamic_Async, Loc)),
5162 Then_Statements => Excep_Code));
5165 Excep_Handlers := New_List (
5166 Make_Implicit_Exception_Handler (Loc,
5167 Choice_Parameter => Excep_Choice,
5168 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5169 Statements => Excep_Code));
5174 Make_Procedure_Specification (Loc,
5175 Defining_Unit_Name =>
5176 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
5178 Parameter_Specifications => New_List (
5179 Make_Parameter_Specification (Loc,
5180 Defining_Identifier => Request_Parameter,
5182 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5185 Make_Subprogram_Body (Loc,
5186 Specification => Subp_Spec,
5187 Declarations => Decls,
5188 Handled_Statement_Sequence =>
5189 Make_Handled_Sequence_Of_Statements (Loc,
5190 Statements => Statements,
5191 Exception_Handlers => Excep_Handlers));
5192 end Build_Subprogram_Receiving_Stubs;
5198 function Result return Node_Id is
5200 return Make_Identifier (Loc, Name_V);
5203 ----------------------
5204 -- Stream_Parameter --
5205 ----------------------
5207 function Stream_Parameter return Node_Id is
5209 return Make_Identifier (Loc, Name_S);
5210 end Stream_Parameter;
5214 -------------------------------
5215 -- Get_And_Reset_RACW_Bodies --
5216 -------------------------------
5218 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5219 Desig : constant Entity_Id :=
5220 Etype (Designated_Type (RACW_Type));
5222 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5224 Body_Decls : List_Id;
5225 -- Returned list of declarations
5228 if Stub_Elements = Empty_Stub_Structure then
5230 -- Stub elements may be missing as a consequence of a previously
5236 Body_Decls := Stub_Elements.Body_Decls;
5237 Stub_Elements.Body_Decls := No_List;
5238 Stubs_Table.Set (Desig, Stub_Elements);
5240 end Get_And_Reset_RACW_Bodies;
5242 -----------------------
5243 -- Get_Stub_Elements --
5244 -----------------------
5246 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is
5247 Desig : constant Entity_Id :=
5248 Etype (Designated_Type (RACW_Type));
5249 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
5251 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5252 return Stub_Elements;
5253 end Get_Stub_Elements;
5255 -----------------------
5256 -- Get_Subprogram_Id --
5257 -----------------------
5259 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5260 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5262 pragma Assert (Result /= No_String);
5264 end Get_Subprogram_Id;
5266 -----------------------
5267 -- Get_Subprogram_Id --
5268 -----------------------
5270 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5272 return Get_Subprogram_Ids (Def).Int_Identifier;
5273 end Get_Subprogram_Id;
5275 ------------------------
5276 -- Get_Subprogram_Ids --
5277 ------------------------
5279 function Get_Subprogram_Ids
5280 (Def : Entity_Id) return Subprogram_Identifiers
5283 return Subprogram_Identifier_Table.Get (Def);
5284 end Get_Subprogram_Ids;
5290 function Hash (F : Entity_Id) return Hash_Index is
5292 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5295 function Hash (F : Name_Id) return Hash_Index is
5297 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5300 --------------------------
5301 -- Input_With_Tag_Check --
5302 --------------------------
5304 function Input_With_Tag_Check
5306 Var_Type : Entity_Id;
5307 Stream : Node_Id) return Node_Id
5311 Make_Subprogram_Body (Loc,
5312 Specification => Make_Function_Specification (Loc,
5313 Defining_Unit_Name =>
5314 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
5315 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5316 Declarations => No_List,
5317 Handled_Statement_Sequence =>
5318 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5319 Make_Tag_Check (Loc,
5320 Make_Simple_Return_Statement (Loc,
5321 Make_Attribute_Reference (Loc,
5322 Prefix => New_Occurrence_Of (Var_Type, Loc),
5323 Attribute_Name => Name_Input,
5325 New_List (Stream)))))));
5326 end Input_With_Tag_Check;
5328 --------------------------------
5329 -- Is_RACW_Controlling_Formal --
5330 --------------------------------
5332 function Is_RACW_Controlling_Formal
5333 (Parameter : Node_Id;
5334 Stub_Type : Entity_Id) return Boolean
5339 -- If the kind of the parameter is E_Void, then it is not a controlling
5340 -- formal (this can happen in the context of RAS).
5342 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5346 -- If the parameter is not a controlling formal, then it cannot be
5347 -- possibly a RACW_Controlling_Formal.
5349 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5353 Typ := Parameter_Type (Parameter);
5354 return (Nkind (Typ) = N_Access_Definition
5355 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5356 or else Etype (Typ) = Stub_Type;
5357 end Is_RACW_Controlling_Formal;
5359 ------------------------------
5360 -- Make_Transportable_Check --
5361 ------------------------------
5363 function Make_Transportable_Check
5365 Expr : Node_Id) return Node_Id is
5368 Make_Raise_Program_Error (Loc,
5371 Build_Get_Transportable (Loc,
5372 Make_Selected_Component (Loc,
5374 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5375 Reason => PE_Non_Transportable_Actual);
5376 end Make_Transportable_Check;
5378 -----------------------------
5379 -- Make_Selected_Component --
5380 -----------------------------
5382 function Make_Selected_Component
5385 Selector_Name : Name_Id) return Node_Id
5388 return Make_Selected_Component (Loc,
5389 Prefix => New_Occurrence_Of (Prefix, Loc),
5390 Selector_Name => Make_Identifier (Loc, Selector_Name));
5391 end Make_Selected_Component;
5393 --------------------
5394 -- Make_Tag_Check --
5395 --------------------
5397 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5398 Occ : constant Entity_Id :=
5399 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5402 return Make_Block_Statement (Loc,
5403 Handled_Statement_Sequence =>
5404 Make_Handled_Sequence_Of_Statements (Loc,
5405 Statements => New_List (N),
5407 Exception_Handlers => New_List (
5408 Make_Implicit_Exception_Handler (Loc,
5409 Choice_Parameter => Occ,
5411 Exception_Choices =>
5412 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5415 New_List (Make_Procedure_Call_Statement (Loc,
5417 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5418 New_List (New_Occurrence_Of (Occ, Loc))))))));
5421 ----------------------------
5422 -- Need_Extra_Constrained --
5423 ----------------------------
5425 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5426 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5428 return Out_Present (Parameter)
5429 and then Has_Discriminants (Etyp)
5430 and then not Is_Constrained (Etyp)
5431 and then not Is_Indefinite_Subtype (Etyp);
5432 end Need_Extra_Constrained;
5434 ------------------------------------
5435 -- Pack_Entity_Into_Stream_Access --
5436 ------------------------------------
5438 function Pack_Entity_Into_Stream_Access
5442 Etyp : Entity_Id := Empty) return Node_Id
5447 if Present (Etyp) then
5450 Typ := Etype (Object);
5454 Pack_Node_Into_Stream_Access (Loc,
5456 Object => New_Occurrence_Of (Object, Loc),
5458 end Pack_Entity_Into_Stream_Access;
5460 ---------------------------
5461 -- Pack_Node_Into_Stream --
5462 ---------------------------
5464 function Pack_Node_Into_Stream
5468 Etyp : Entity_Id) return Node_Id
5470 Write_Attribute : Name_Id := Name_Write;
5473 if not Is_Constrained (Etyp) then
5474 Write_Attribute := Name_Output;
5478 Make_Attribute_Reference (Loc,
5479 Prefix => New_Occurrence_Of (Etyp, Loc),
5480 Attribute_Name => Write_Attribute,
5481 Expressions => New_List (
5482 Make_Attribute_Reference (Loc,
5483 Prefix => New_Occurrence_Of (Stream, Loc),
5484 Attribute_Name => Name_Access),
5486 end Pack_Node_Into_Stream;
5488 ----------------------------------
5489 -- Pack_Node_Into_Stream_Access --
5490 ----------------------------------
5492 function Pack_Node_Into_Stream_Access
5496 Etyp : Entity_Id) return Node_Id
5498 Write_Attribute : Name_Id := Name_Write;
5501 if not Is_Constrained (Etyp) then
5502 Write_Attribute := Name_Output;
5506 Make_Attribute_Reference (Loc,
5507 Prefix => New_Occurrence_Of (Etyp, Loc),
5508 Attribute_Name => Write_Attribute,
5509 Expressions => New_List (
5512 end Pack_Node_Into_Stream_Access;
5514 ---------------------
5515 -- PolyORB_Support --
5516 ---------------------
5518 package body PolyORB_Support is
5520 -- Local subprograms
5522 procedure Add_RACW_Read_Attribute
5523 (RACW_Type : Entity_Id;
5524 Stub_Type : Entity_Id;
5525 Stub_Type_Access : Entity_Id;
5526 Body_Decls : List_Id);
5527 -- Add Read attribute for the RACW type. The declaration and attribute
5528 -- definition clauses are inserted right after the declaration of
5529 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5530 -- appended to it (case where the RACW declaration is in the main unit).
5532 procedure Add_RACW_Write_Attribute
5533 (RACW_Type : Entity_Id;
5534 Stub_Type : Entity_Id;
5535 Stub_Type_Access : Entity_Id;
5536 Body_Decls : List_Id);
5537 -- Same as above for the Write attribute
5539 procedure Add_RACW_From_Any
5540 (RACW_Type : Entity_Id;
5541 Body_Decls : List_Id);
5542 -- Add the From_Any TSS for this RACW type
5544 procedure Add_RACW_To_Any
5545 (RACW_Type : Entity_Id;
5546 Body_Decls : List_Id);
5547 -- Add the To_Any TSS for this RACW type
5549 procedure Add_RACW_TypeCode
5550 (Designated_Type : Entity_Id;
5551 RACW_Type : Entity_Id;
5552 Body_Decls : List_Id);
5553 -- Add the TypeCode TSS for this RACW type
5555 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5556 -- Add the From_Any TSS for this RAS type
5558 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5559 -- Add the To_Any TSS for this RAS type
5561 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5562 -- Add the TypeCode TSS for this RAS type
5564 procedure Add_RAS_Access_TSS (N : Node_Id);
5565 -- Add a subprogram body for RAS Access TSS
5567 -------------------------------------
5568 -- Add_Obj_RPC_Receiver_Completion --
5569 -------------------------------------
5571 procedure Add_Obj_RPC_Receiver_Completion
5574 RPC_Receiver : Entity_Id;
5575 Stub_Elements : Stub_Structure)
5577 Desig : constant Entity_Id :=
5578 Etype (Designated_Type (Stub_Elements.RACW_Type));
5581 Make_Procedure_Call_Statement (Loc,
5584 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5586 Parameter_Associations => New_List (
5590 Make_String_Literal (Loc,
5591 Full_Qualified_Name (Desig)),
5595 Make_Attribute_Reference (Loc,
5598 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5604 Make_Attribute_Reference (Loc,
5607 Defining_Identifier (
5608 Stub_Elements.RPC_Receiver_Decl), Loc),
5611 end Add_Obj_RPC_Receiver_Completion;
5613 -----------------------
5614 -- Add_RACW_Features --
5615 -----------------------
5617 procedure Add_RACW_Features
5618 (RACW_Type : Entity_Id;
5620 Stub_Type : Entity_Id;
5621 Stub_Type_Access : Entity_Id;
5622 RPC_Receiver_Decl : Node_Id;
5623 Body_Decls : List_Id)
5625 pragma Unreferenced (RPC_Receiver_Decl);
5629 (RACW_Type => RACW_Type,
5630 Body_Decls => Body_Decls);
5633 (RACW_Type => RACW_Type,
5634 Body_Decls => Body_Decls);
5636 Add_RACW_Write_Attribute
5637 (RACW_Type => RACW_Type,
5638 Stub_Type => Stub_Type,
5639 Stub_Type_Access => Stub_Type_Access,
5640 Body_Decls => Body_Decls);
5642 Add_RACW_Read_Attribute
5643 (RACW_Type => RACW_Type,
5644 Stub_Type => Stub_Type,
5645 Stub_Type_Access => Stub_Type_Access,
5646 Body_Decls => Body_Decls);
5649 (Designated_Type => Desig,
5650 RACW_Type => RACW_Type,
5651 Body_Decls => Body_Decls);
5652 end Add_RACW_Features;
5654 -----------------------
5655 -- Add_RACW_From_Any --
5656 -----------------------
5658 procedure Add_RACW_From_Any
5659 (RACW_Type : Entity_Id;
5660 Body_Decls : List_Id)
5662 Loc : constant Source_Ptr := Sloc (RACW_Type);
5663 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5664 Fnam : constant Entity_Id :=
5665 Make_Defining_Identifier (Loc,
5666 Chars => New_External_Name (Chars (RACW_Type), 'F'));
5668 Func_Spec : Node_Id;
5669 Func_Decl : Node_Id;
5670 Func_Body : Node_Id;
5672 Statements : List_Id;
5673 -- Various parts of the subprogram
5675 Any_Parameter : constant Entity_Id :=
5676 Make_Defining_Identifier (Loc, Name_A);
5678 Asynchronous_Flag : constant Entity_Id :=
5679 Asynchronous_Flags_Table.Get (RACW_Type);
5680 -- The flag object declared in Add_RACW_Asynchronous_Flag
5684 Make_Function_Specification (Loc,
5685 Defining_Unit_Name =>
5687 Parameter_Specifications => New_List (
5688 Make_Parameter_Specification (Loc,
5689 Defining_Identifier =>
5692 New_Occurrence_Of (RTE (RE_Any), Loc))),
5693 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5695 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5696 -- entity in the declaration spec, not those of the body spec.
5698 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5699 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5700 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5702 if No (Body_Decls) then
5706 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5707 -- set on the stub type if, and only if, the RACW type has a pragma
5708 -- Asynchronous. This is incorrect for RACWs that implement RAS
5709 -- types, because in that case the /designated subprogram/ (not the
5710 -- type) might be asynchronous, and that causes the stub to need to
5711 -- be asynchronous too. A solution is to transport a RAS as a struct
5712 -- containing a RACW and an asynchronous flag, and to properly alter
5713 -- the Asynchronous component in the stub type in the RAS's _From_Any
5716 Statements := New_List (
5717 Make_Simple_Return_Statement (Loc,
5718 Expression => Unchecked_Convert_To (RACW_Type,
5719 Make_Function_Call (Loc,
5720 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5721 Parameter_Associations => New_List (
5722 Make_Function_Call (Loc,
5723 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5724 Parameter_Associations => New_List (
5725 New_Occurrence_Of (Any_Parameter, Loc))),
5726 Build_Stub_Tag (Loc, RACW_Type),
5727 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5728 New_Occurrence_Of (Asynchronous_Flag, Loc))))));
5731 Make_Subprogram_Body (Loc,
5732 Specification => Copy_Specification (Loc, Func_Spec),
5733 Declarations => No_List,
5734 Handled_Statement_Sequence =>
5735 Make_Handled_Sequence_Of_Statements (Loc,
5736 Statements => Statements));
5738 Append_To (Body_Decls, Func_Body);
5739 end Add_RACW_From_Any;
5741 -----------------------------
5742 -- Add_RACW_Read_Attribute --
5743 -----------------------------
5745 procedure Add_RACW_Read_Attribute
5746 (RACW_Type : Entity_Id;
5747 Stub_Type : Entity_Id;
5748 Stub_Type_Access : Entity_Id;
5749 Body_Decls : List_Id)
5751 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5753 Loc : constant Source_Ptr := Sloc (RACW_Type);
5755 Proc_Decl : Node_Id;
5756 Attr_Decl : Node_Id;
5758 Body_Node : Node_Id;
5760 Decls : constant List_Id := New_List;
5761 Statements : constant List_Id := New_List;
5762 Reference : constant Entity_Id :=
5763 Make_Defining_Identifier (Loc, Name_R);
5764 -- Various parts of the procedure
5766 Pnam : constant Entity_Id := Make_Defining_Identifier (Loc,
5767 New_Internal_Name ('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 :=
5887 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
5888 Any : constant Entity_Id :=
5889 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
5893 Make_Function_Specification (Loc,
5894 Defining_Unit_Name =>
5896 Parameter_Specifications => New_List (
5897 Make_Parameter_Specification (Loc,
5898 Defining_Identifier =>
5901 New_Occurrence_Of (RACW_Type, Loc))),
5902 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5904 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5905 -- entity in the declaration spec, not in the body spec.
5907 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5909 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5910 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5912 if No (Body_Decls) then
5918 -- R : constant Object_Ref :=
5924 -- RPC_Receiver'Access);
5928 Make_Object_Declaration (Loc,
5929 Defining_Identifier => Reference,
5930 Constant_Present => True,
5931 Object_Definition =>
5932 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5934 Make_Function_Call (Loc,
5935 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5936 Parameter_Associations => New_List (
5937 Unchecked_Convert_To (RTE (RE_Address),
5938 New_Occurrence_Of (RACW_Parameter, Loc)),
5939 Make_String_Literal (Loc,
5940 Strval => Full_Qualified_Name
5941 (Etype (Designated_Type (RACW_Type)))),
5942 Build_Stub_Tag (Loc, RACW_Type),
5943 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5944 Make_Attribute_Reference (Loc,
5947 (Defining_Identifier
5948 (Stub_Elements.RPC_Receiver_Decl), Loc),
5949 Attribute_Name => Name_Access)))),
5951 Make_Object_Declaration (Loc,
5952 Defining_Identifier => Any,
5953 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)));
5957 -- Any := TA_ObjRef (Reference);
5958 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5961 Statements := New_List (
5962 Make_Assignment_Statement (Loc,
5963 Name => New_Occurrence_Of (Any, Loc),
5965 Make_Function_Call (Loc,
5966 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5967 Parameter_Associations => New_List (
5968 New_Occurrence_Of (Reference, Loc)))),
5970 Make_Procedure_Call_Statement (Loc,
5971 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5972 Parameter_Associations => New_List (
5973 New_Occurrence_Of (Any, Loc),
5974 Make_Selected_Component (Loc,
5976 Defining_Identifier (
5977 Stub_Elements.RPC_Receiver_Decl),
5978 Selector_Name => Name_Obj_TypeCode))),
5980 Make_Simple_Return_Statement (Loc,
5981 Expression => New_Occurrence_Of (Any, Loc)));
5984 Make_Subprogram_Body (Loc,
5985 Specification => Copy_Specification (Loc, Func_Spec),
5986 Declarations => Decls,
5987 Handled_Statement_Sequence =>
5988 Make_Handled_Sequence_Of_Statements (Loc,
5989 Statements => Statements));
5990 Append_To (Body_Decls, Func_Body);
5991 end Add_RACW_To_Any;
5993 -----------------------
5994 -- Add_RACW_TypeCode --
5995 -----------------------
5997 procedure Add_RACW_TypeCode
5998 (Designated_Type : Entity_Id;
5999 RACW_Type : Entity_Id;
6000 Body_Decls : List_Id)
6002 Loc : constant Source_Ptr := Sloc (RACW_Type);
6004 Fnam : constant Entity_Id :=
6005 Make_Defining_Identifier (Loc,
6006 Chars => New_External_Name (Chars (RACW_Type), 'Y'));
6008 Stub_Elements : constant Stub_Structure :=
6009 Stubs_Table.Get (Designated_Type);
6010 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6012 Func_Spec : Node_Id;
6013 Func_Decl : Node_Id;
6014 Func_Body : Node_Id;
6017 -- The spec for this subprogram has a dummy 'access RACW' argument,
6018 -- which serves only for overloading purposes.
6021 Make_Function_Specification (Loc,
6022 Defining_Unit_Name => Fnam,
6023 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6025 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6026 -- entity in the declaration spec, not those of the body spec.
6028 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6029 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6030 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6032 if No (Body_Decls) then
6037 Make_Subprogram_Body (Loc,
6038 Specification => Copy_Specification (Loc, Func_Spec),
6039 Declarations => Empty_List,
6040 Handled_Statement_Sequence =>
6041 Make_Handled_Sequence_Of_Statements (Loc,
6042 Statements => New_List (
6043 Make_Simple_Return_Statement (Loc,
6045 Make_Selected_Component (Loc,
6048 (Stub_Elements.RPC_Receiver_Decl),
6049 Selector_Name => Name_Obj_TypeCode)))));
6051 Append_To (Body_Decls, Func_Body);
6052 end Add_RACW_TypeCode;
6054 ------------------------------
6055 -- Add_RACW_Write_Attribute --
6056 ------------------------------
6058 procedure Add_RACW_Write_Attribute
6059 (RACW_Type : Entity_Id;
6060 Stub_Type : Entity_Id;
6061 Stub_Type_Access : Entity_Id;
6062 Body_Decls : List_Id)
6064 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6066 Loc : constant Source_Ptr := Sloc (RACW_Type);
6068 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
6070 Stub_Elements : constant Stub_Structure :=
6071 Get_Stub_Elements (RACW_Type);
6073 Body_Node : Node_Id;
6074 Proc_Decl : Node_Id;
6075 Attr_Decl : Node_Id;
6077 Statements : constant List_Id := New_List;
6078 Pnam : constant Entity_Id :=
6079 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
6081 function Stream_Parameter return Node_Id;
6082 function Object return Node_Id;
6083 -- Functions to create occurrences of the formal parameter names
6089 function Object return Node_Id is
6091 return Make_Identifier (Loc, Name_V);
6094 ----------------------
6095 -- Stream_Parameter --
6096 ----------------------
6098 function Stream_Parameter return Node_Id is
6100 return Make_Identifier (Loc, Name_S);
6101 end Stream_Parameter;
6103 -- Start of processing for Add_RACW_Write_Attribute
6106 Build_Stream_Procedure
6107 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
6110 Make_Subprogram_Declaration (Loc,
6111 Copy_Specification (Loc, Specification (Body_Node)));
6114 Make_Attribute_Definition_Clause (Loc,
6115 Name => New_Occurrence_Of (RACW_Type, Loc),
6116 Chars => Name_Write,
6119 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6121 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6122 Insert_After (Proc_Decl, Attr_Decl);
6124 if No (Body_Decls) then
6128 Append_To (Statements,
6129 Pack_Node_Into_Stream_Access (Loc,
6130 Stream => Stream_Parameter,
6132 Make_Function_Call (Loc,
6133 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6134 Parameter_Associations => New_List (
6135 Unchecked_Convert_To (RTE (RE_Address), Object),
6136 Make_String_Literal (Loc,
6137 Strval => Full_Qualified_Name
6138 (Etype (Designated_Type (RACW_Type)))),
6139 Build_Stub_Tag (Loc, RACW_Type),
6140 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
6141 Make_Attribute_Reference (Loc,
6144 (Defining_Identifier
6145 (Stub_Elements.RPC_Receiver_Decl), Loc),
6146 Attribute_Name => Name_Access))),
6148 Etyp => RTE (RE_Object_Ref)));
6150 Append_To (Body_Decls, Body_Node);
6151 end Add_RACW_Write_Attribute;
6153 -----------------------
6154 -- Add_RAST_Features --
6155 -----------------------
6157 procedure Add_RAST_Features
6158 (Vis_Decl : Node_Id;
6159 RAS_Type : Entity_Id)
6162 Add_RAS_Access_TSS (Vis_Decl);
6164 Add_RAS_From_Any (RAS_Type);
6165 Add_RAS_TypeCode (RAS_Type);
6167 -- To_Any uses TypeCode, and therefore needs to be generated last
6169 Add_RAS_To_Any (RAS_Type);
6170 end Add_RAST_Features;
6172 ------------------------
6173 -- Add_RAS_Access_TSS --
6174 ------------------------
6176 procedure Add_RAS_Access_TSS (N : Node_Id) is
6177 Loc : constant Source_Ptr := Sloc (N);
6179 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6180 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6181 -- Ras_Type is the access to subprogram type; Fat_Type is the
6182 -- corresponding record type.
6184 RACW_Type : constant Entity_Id :=
6185 Underlying_RACW_Type (Ras_Type);
6187 Stub_Elements : constant Stub_Structure :=
6188 Get_Stub_Elements (RACW_Type);
6190 Proc : constant Entity_Id :=
6191 Make_Defining_Identifier (Loc,
6192 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6194 Proc_Spec : Node_Id;
6196 -- Formal parameters
6198 Package_Name : constant Entity_Id :=
6199 Make_Defining_Identifier (Loc,
6204 Subp_Id : constant Entity_Id :=
6205 Make_Defining_Identifier (Loc,
6208 -- Target subprogram
6210 Asynch_P : constant Entity_Id :=
6211 Make_Defining_Identifier (Loc,
6212 Chars => Name_Asynchronous);
6213 -- Is the procedure to which the 'Access applies asynchronous?
6215 All_Calls_Remote : constant Entity_Id :=
6216 Make_Defining_Identifier (Loc,
6217 Chars => Name_All_Calls_Remote);
6218 -- True if an All_Calls_Remote pragma applies to the RCI unit
6219 -- that contains the subprogram.
6221 -- Common local variables
6223 Proc_Decls : List_Id;
6224 Proc_Statements : List_Id;
6226 Subp_Ref : constant Entity_Id :=
6227 Make_Defining_Identifier (Loc, Name_R);
6228 -- Reference that designates the target subprogram (returned
6229 -- by Get_RAS_Info).
6231 Is_Local : constant Entity_Id :=
6232 Make_Defining_Identifier (Loc, Name_L);
6233 Local_Addr : constant Entity_Id :=
6234 Make_Defining_Identifier (Loc, Name_A);
6235 -- For the call to Get_Local_Address
6237 -- Additional local variables for the remote case
6239 Local_Stub : constant Entity_Id :=
6240 Make_Defining_Identifier (Loc,
6241 Chars => New_Internal_Name ('L'));
6243 Stub_Ptr : constant Entity_Id :=
6244 Make_Defining_Identifier (Loc,
6245 Chars => New_Internal_Name ('S'));
6248 (Field_Name : Name_Id;
6249 Value : Node_Id) return Node_Id;
6250 -- Construct an assignment that sets the named component in the
6258 (Field_Name : Name_Id;
6259 Value : Node_Id) return Node_Id
6263 Make_Assignment_Statement (Loc,
6265 Make_Selected_Component (Loc,
6267 Selector_Name => Field_Name),
6268 Expression => Value);
6271 -- Start of processing for Add_RAS_Access_TSS
6274 Proc_Decls := New_List (
6276 -- Common declarations
6278 Make_Object_Declaration (Loc,
6279 Defining_Identifier => Subp_Ref,
6280 Object_Definition =>
6281 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6283 Make_Object_Declaration (Loc,
6284 Defining_Identifier => Is_Local,
6285 Object_Definition =>
6286 New_Occurrence_Of (Standard_Boolean, Loc)),
6288 Make_Object_Declaration (Loc,
6289 Defining_Identifier => Local_Addr,
6290 Object_Definition =>
6291 New_Occurrence_Of (RTE (RE_Address), Loc)),
6293 Make_Object_Declaration (Loc,
6294 Defining_Identifier => Local_Stub,
6295 Aliased_Present => True,
6296 Object_Definition =>
6297 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6299 Make_Object_Declaration (Loc,
6300 Defining_Identifier => Stub_Ptr,
6301 Object_Definition =>
6302 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6304 Make_Attribute_Reference (Loc,
6305 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6306 Attribute_Name => Name_Unchecked_Access)));
6308 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6309 -- Build_Get_Unique_RP_Call needs this information
6311 -- Get_RAS_Info (Pkg, Subp, R);
6312 -- Obtain a reference to the target subprogram
6314 Proc_Statements := New_List (
6315 Make_Procedure_Call_Statement (Loc,
6316 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6317 Parameter_Associations => New_List (
6318 New_Occurrence_Of (Package_Name, Loc),
6319 New_Occurrence_Of (Subp_Id, Loc),
6320 New_Occurrence_Of (Subp_Ref, Loc))),
6322 -- Get_Local_Address (R, L, A);
6323 -- Determine whether the subprogram is local (L), and if so
6324 -- obtain the local address of its proxy (A).
6326 Make_Procedure_Call_Statement (Loc,
6327 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6328 Parameter_Associations => New_List (
6329 New_Occurrence_Of (Subp_Ref, Loc),
6330 New_Occurrence_Of (Is_Local, Loc),
6331 New_Occurrence_Of (Local_Addr, Loc))));
6333 -- Note: Here we assume that the Fat_Type is a record containing just
6334 -- an access to a proxy or stub object.
6336 Append_To (Proc_Statements,
6340 Make_Implicit_If_Statement (N,
6341 Condition => New_Occurrence_Of (Is_Local, Loc),
6343 Then_Statements => New_List (
6345 -- if A.Target = null then
6347 Make_Implicit_If_Statement (N,
6350 Make_Selected_Component (Loc,
6352 Unchecked_Convert_To
6353 (RTE (RE_RAS_Proxy_Type_Access),
6354 New_Occurrence_Of (Local_Addr, Loc)),
6355 Selector_Name => Make_Identifier (Loc, Name_Target)),
6358 Then_Statements => New_List (
6360 -- A.Target := Entity_Of (Ref);
6362 Make_Assignment_Statement (Loc,
6364 Make_Selected_Component (Loc,
6366 Unchecked_Convert_To
6367 (RTE (RE_RAS_Proxy_Type_Access),
6368 New_Occurrence_Of (Local_Addr, Loc)),
6369 Selector_Name => Make_Identifier (Loc, Name_Target)),
6371 Make_Function_Call (Loc,
6372 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6373 Parameter_Associations => New_List (
6374 New_Occurrence_Of (Subp_Ref, Loc)))),
6376 -- Inc_Usage (A.Target);
6379 Make_Procedure_Call_Statement (Loc,
6380 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6381 Parameter_Associations => New_List (
6382 Make_Selected_Component (Loc,
6384 Unchecked_Convert_To
6385 (RTE (RE_RAS_Proxy_Type_Access),
6386 New_Occurrence_Of (Local_Addr, Loc)),
6388 Make_Identifier (Loc, Name_Target)))))),
6390 -- if not All_Calls_Remote then
6391 -- return Fat_Type!(A);
6394 Make_Implicit_If_Statement (N,
6398 New_Occurrence_Of (All_Calls_Remote, Loc)),
6400 Then_Statements => New_List (
6401 Make_Simple_Return_Statement (Loc,
6403 Unchecked_Convert_To
6404 (Fat_Type, New_Occurrence_Of (Local_Addr, Loc))))))));
6406 Append_List_To (Proc_Statements, New_List (
6408 -- Stub.Target := Entity_Of (Ref);
6410 Set_Field (Name_Target,
6411 Make_Function_Call (Loc,
6412 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6413 Parameter_Associations => New_List (
6414 New_Occurrence_Of (Subp_Ref, Loc)))),
6416 -- Inc_Usage (Stub.Target);
6418 Make_Procedure_Call_Statement (Loc,
6419 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6420 Parameter_Associations => New_List (
6421 Make_Selected_Component (Loc,
6423 Selector_Name => Name_Target))),
6425 -- E.4.1(9) A remote call is asynchronous if it is a call to
6426 -- a procedure, or a call through a value of an access-to-procedure
6427 -- type, to which a pragma Asynchronous applies.
6429 -- Parameter Asynch_P is true when the procedure is asynchronous;
6430 -- Expression Asynch_T is true when the type is asynchronous.
6432 Set_Field (Name_Asynchronous,
6434 Left_Opnd => New_Occurrence_Of (Asynch_P, Loc),
6437 (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc)))));
6439 Append_List_To (Proc_Statements,
6440 Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
6442 Append_To (Proc_Statements,
6443 Make_Simple_Return_Statement (Loc,
6445 Unchecked_Convert_To (Fat_Type,
6446 New_Occurrence_Of (Stub_Ptr, Loc))));
6449 Make_Function_Specification (Loc,
6450 Defining_Unit_Name => Proc,
6451 Parameter_Specifications => New_List (
6452 Make_Parameter_Specification (Loc,
6453 Defining_Identifier => Package_Name,
6455 New_Occurrence_Of (Standard_String, Loc)),
6457 Make_Parameter_Specification (Loc,
6458 Defining_Identifier => Subp_Id,
6460 New_Occurrence_Of (Standard_String, Loc)),
6462 Make_Parameter_Specification (Loc,
6463 Defining_Identifier => Asynch_P,
6465 New_Occurrence_Of (Standard_Boolean, Loc)),
6467 Make_Parameter_Specification (Loc,
6468 Defining_Identifier => All_Calls_Remote,
6470 New_Occurrence_Of (Standard_Boolean, Loc))),
6472 Result_Definition =>
6473 New_Occurrence_Of (Fat_Type, Loc));
6475 -- Set the kind and return type of the function to prevent
6476 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6478 Set_Ekind (Proc, E_Function);
6479 Set_Etype (Proc, Fat_Type);
6482 Make_Subprogram_Body (Loc,
6483 Specification => Proc_Spec,
6484 Declarations => Proc_Decls,
6485 Handled_Statement_Sequence =>
6486 Make_Handled_Sequence_Of_Statements (Loc,
6487 Statements => Proc_Statements)));
6489 Set_TSS (Fat_Type, Proc);
6490 end Add_RAS_Access_TSS;
6492 ----------------------
6493 -- Add_RAS_From_Any --
6494 ----------------------
6496 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6497 Loc : constant Source_Ptr := Sloc (RAS_Type);
6499 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6500 Make_TSS_Name (RAS_Type, TSS_From_Any));
6502 Func_Spec : Node_Id;
6504 Statements : List_Id;
6506 Any_Parameter : constant Entity_Id :=
6507 Make_Defining_Identifier (Loc, Name_A);
6510 Statements := New_List (
6511 Make_Simple_Return_Statement (Loc,
6513 Make_Aggregate (Loc,
6514 Component_Associations => New_List (
6515 Make_Component_Association (Loc,
6516 Choices => New_List (
6517 Make_Identifier (Loc, Name_Ras)),
6519 PolyORB_Support.Helpers.Build_From_Any_Call (
6520 Underlying_RACW_Type (RAS_Type),
6521 New_Occurrence_Of (Any_Parameter, Loc),
6525 Make_Function_Specification (Loc,
6526 Defining_Unit_Name => Fnam,
6527 Parameter_Specifications => New_List (
6528 Make_Parameter_Specification (Loc,
6529 Defining_Identifier => Any_Parameter,
6530 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
6531 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6534 Make_Subprogram_Body (Loc,
6535 Specification => Func_Spec,
6536 Declarations => No_List,
6537 Handled_Statement_Sequence =>
6538 Make_Handled_Sequence_Of_Statements (Loc,
6539 Statements => Statements)));
6540 Set_TSS (RAS_Type, Fnam);
6541 end Add_RAS_From_Any;
6543 --------------------
6544 -- Add_RAS_To_Any --
6545 --------------------
6547 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6548 Loc : constant Source_Ptr := Sloc (RAS_Type);
6550 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6551 Make_TSS_Name (RAS_Type, TSS_To_Any));
6554 Statements : List_Id;
6556 Func_Spec : Node_Id;
6558 Any : constant Entity_Id :=
6559 Make_Defining_Identifier (Loc,
6560 Chars => New_Internal_Name ('A'));
6561 RAS_Parameter : constant Entity_Id :=
6562 Make_Defining_Identifier (Loc,
6563 Chars => New_Internal_Name ('R'));
6564 RACW_Parameter : constant Node_Id :=
6565 Make_Selected_Component (Loc,
6566 Prefix => RAS_Parameter,
6567 Selector_Name => Name_Ras);
6570 -- Object declarations
6572 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6574 Make_Object_Declaration (Loc,
6575 Defining_Identifier => Any,
6576 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc),
6578 PolyORB_Support.Helpers.Build_To_Any_Call
6579 (RACW_Parameter, No_List)));
6581 Statements := New_List (
6582 Make_Procedure_Call_Statement (Loc,
6583 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6584 Parameter_Associations => New_List (
6585 New_Occurrence_Of (Any, Loc),
6586 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6589 Make_Simple_Return_Statement (Loc,
6590 Expression => New_Occurrence_Of (Any, Loc)));
6593 Make_Function_Specification (Loc,
6594 Defining_Unit_Name => Fnam,
6595 Parameter_Specifications => New_List (
6596 Make_Parameter_Specification (Loc,
6597 Defining_Identifier => RAS_Parameter,
6598 Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))),
6599 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6602 Make_Subprogram_Body (Loc,
6603 Specification => Func_Spec,
6604 Declarations => Decls,
6605 Handled_Statement_Sequence =>
6606 Make_Handled_Sequence_Of_Statements (Loc,
6607 Statements => Statements)));
6608 Set_TSS (RAS_Type, Fnam);
6611 ----------------------
6612 -- Add_RAS_TypeCode --
6613 ----------------------
6615 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6616 Loc : constant Source_Ptr := Sloc (RAS_Type);
6618 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6619 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6621 Func_Spec : Node_Id;
6622 Decls : constant List_Id := New_List;
6623 Name_String : String_Id;
6624 Repo_Id_String : String_Id;
6628 Make_Function_Specification (Loc,
6629 Defining_Unit_Name => Fnam,
6630 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6632 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6633 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6636 Make_Subprogram_Body (Loc,
6637 Specification => Func_Spec,
6638 Declarations => Decls,
6639 Handled_Statement_Sequence =>
6640 Make_Handled_Sequence_Of_Statements (Loc,
6641 Statements => New_List (
6642 Make_Simple_Return_Statement (Loc,
6644 Make_Function_Call (Loc,
6645 Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6646 Parameter_Associations => New_List (
6647 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6648 Make_Aggregate (Loc,
6651 Make_Function_Call (Loc,
6654 (RTE (RE_TA_Std_String), Loc),
6655 Parameter_Associations => New_List (
6656 Make_String_Literal (Loc, Name_String))),
6657 Make_Function_Call (Loc,
6660 (RTE (RE_TA_Std_String), Loc),
6661 Parameter_Associations => New_List (
6662 Make_String_Literal (Loc,
6663 Strval => Repo_Id_String))))))))))));
6664 Set_TSS (RAS_Type, Fnam);
6665 end Add_RAS_TypeCode;
6667 -----------------------------------------
6668 -- Add_Receiving_Stubs_To_Declarations --
6669 -----------------------------------------
6671 procedure Add_Receiving_Stubs_To_Declarations
6672 (Pkg_Spec : Node_Id;
6676 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6678 Pkg_RPC_Receiver : constant Entity_Id :=
6679 Make_Defining_Identifier (Loc,
6680 New_Internal_Name ('H'));
6681 Pkg_RPC_Receiver_Object : Node_Id;
6682 Pkg_RPC_Receiver_Body : Node_Id;
6683 Pkg_RPC_Receiver_Decls : List_Id;
6684 Pkg_RPC_Receiver_Statements : List_Id;
6686 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6687 -- A Pkg_RPC_Receiver is built to decode the request
6690 -- Request object received from neutral layer
6692 Subp_Id : Entity_Id;
6693 -- Subprogram identifier as received from the neutral distribution
6696 Subp_Index : Entity_Id;
6697 -- Internal index as determined by matching either the method name
6698 -- from the request structure, or the local subprogram address (in
6701 Is_Local : constant Entity_Id :=
6702 Make_Defining_Identifier (Loc,
6703 Chars => New_Internal_Name ('L'));
6705 Local_Address : constant Entity_Id :=
6706 Make_Defining_Identifier (Loc,
6707 Chars => New_Internal_Name ('A'));
6708 -- Address of a local subprogram designated by a reference
6709 -- corresponding to a RAS.
6711 Dispatch_On_Address : constant List_Id := New_List;
6712 Dispatch_On_Name : constant List_Id := New_List;
6714 Current_Declaration : Node_Id;
6715 Current_Stubs : Node_Id;
6716 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6718 Subp_Info_Array : constant Entity_Id :=
6719 Make_Defining_Identifier (Loc,
6720 Chars => New_Internal_Name ('I'));
6722 Subp_Info_List : constant List_Id := New_List;
6724 Register_Pkg_Actuals : constant List_Id := New_List;
6726 All_Calls_Remote_E : Entity_Id;
6728 procedure Append_Stubs_To
6729 (RPC_Receiver_Cases : List_Id;
6730 Declaration : Node_Id;
6733 Subp_Dist_Name : Entity_Id;
6734 Subp_Proxy_Addr : Entity_Id);
6735 -- Add one case to the specified RPC receiver case list associating
6736 -- Subprogram_Number with the subprogram declared by Declaration, for
6737 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6738 -- subprogram index. Subp_Dist_Name is the string used to call the
6739 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6740 -- object, used in the context of calls through remote
6741 -- access-to-subprogram types.
6743 ---------------------
6744 -- Append_Stubs_To --
6745 ---------------------
6747 procedure Append_Stubs_To
6748 (RPC_Receiver_Cases : List_Id;
6749 Declaration : Node_Id;
6752 Subp_Dist_Name : Entity_Id;
6753 Subp_Proxy_Addr : Entity_Id)
6755 Case_Stmts : List_Id;
6757 Case_Stmts := New_List (
6758 Make_Procedure_Call_Statement (Loc,
6761 Defining_Entity (Stubs), Loc),
6762 Parameter_Associations =>
6763 New_List (New_Occurrence_Of (Request, Loc))));
6765 if Nkind (Specification (Declaration)) = N_Function_Specification
6767 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6769 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6772 Append_To (RPC_Receiver_Cases,
6773 Make_Case_Statement_Alternative (Loc,
6775 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6776 Statements => Case_Stmts));
6778 Append_To (Dispatch_On_Name,
6779 Make_Elsif_Part (Loc,
6781 Make_Function_Call (Loc,
6783 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6784 Parameter_Associations => New_List (
6785 New_Occurrence_Of (Subp_Id, Loc),
6786 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6788 Then_Statements => New_List (
6789 Make_Assignment_Statement (Loc,
6790 New_Occurrence_Of (Subp_Index, Loc),
6791 Make_Integer_Literal (Loc, Subp_Number)))));
6793 Append_To (Dispatch_On_Address,
6794 Make_Elsif_Part (Loc,
6797 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6798 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6800 Then_Statements => New_List (
6801 Make_Assignment_Statement (Loc,
6802 New_Occurrence_Of (Subp_Index, Loc),
6803 Make_Integer_Literal (Loc, Subp_Number)))));
6804 end Append_Stubs_To;
6806 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6809 -- Building receiving stubs consist in several operations:
6811 -- - a package RPC receiver must be built. This subprogram will get
6812 -- a Subprogram_Id from the incoming stream and will dispatch the
6813 -- call to the right subprogram;
6815 -- - a receiving stub for each subprogram visible in the package
6816 -- spec. This stub will read all the parameters from the stream,
6817 -- and put the result as well as the exception occurrence in the
6820 -- - a dummy package with an empty spec and a body made of an
6821 -- elaboration part, whose job is to register the receiving
6822 -- part of this RCI package on the name server. This is done
6823 -- by calling System.Partition_Interface.Register_Receiving_Stub.
6825 Build_RPC_Receiver_Body (
6826 RPC_Receiver => Pkg_RPC_Receiver,
6829 Subp_Index => Subp_Index,
6830 Stmts => Pkg_RPC_Receiver_Statements,
6831 Decl => Pkg_RPC_Receiver_Body);
6832 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6834 -- Extract local address information from the target reference:
6835 -- if non-null, that means that this is a reference that denotes
6836 -- one particular operation, and hence that the operation name
6837 -- must not be taken into account for dispatching.
6839 Append_To (Pkg_RPC_Receiver_Decls,
6840 Make_Object_Declaration (Loc,
6841 Defining_Identifier => Is_Local,
6842 Object_Definition =>
6843 New_Occurrence_Of (Standard_Boolean, Loc)));
6845 Append_To (Pkg_RPC_Receiver_Decls,
6846 Make_Object_Declaration (Loc,
6847 Defining_Identifier => Local_Address,
6848 Object_Definition =>
6849 New_Occurrence_Of (RTE (RE_Address), Loc)));
6851 Append_To (Pkg_RPC_Receiver_Statements,
6852 Make_Procedure_Call_Statement (Loc,
6853 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6854 Parameter_Associations => New_List (
6855 Make_Selected_Component (Loc,
6857 Selector_Name => Name_Target),
6858 New_Occurrence_Of (Is_Local, Loc),
6859 New_Occurrence_Of (Local_Address, Loc))));
6861 -- For each subprogram, the receiving stub will be built and a case
6862 -- statement will be made on the Subprogram_Id to dispatch to the
6863 -- right subprogram.
6865 All_Calls_Remote_E := Boolean_Literals (
6866 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6868 Overload_Counter_Table.Reset;
6869 Reserve_NamingContext_Methods;
6871 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
6872 while Present (Current_Declaration) loop
6873 if Nkind (Current_Declaration) = N_Subprogram_Declaration
6874 and then Comes_From_Source (Current_Declaration)
6877 Loc : constant Source_Ptr := Sloc (Current_Declaration);
6878 -- While specifically processing Current_Declaration, use
6879 -- its Sloc as the location of all generated nodes.
6881 Subp_Def : constant Entity_Id :=
6883 (Specification (Current_Declaration));
6885 Subp_Val : String_Id;
6887 Subp_Dist_Name : constant Entity_Id :=
6888 Make_Defining_Identifier (Loc,
6891 (Related_Id => Chars (Subp_Def),
6893 Suffix_Index => -1));
6895 Proxy_Object_Addr : Entity_Id;
6898 -- Build receiving stub
6901 Build_Subprogram_Receiving_Stubs
6902 (Vis_Decl => Current_Declaration,
6904 Nkind (Specification (Current_Declaration)) =
6905 N_Procedure_Specification
6906 and then Is_Asynchronous (Subp_Def));
6908 Append_To (Decls, Current_Stubs);
6909 Analyze (Current_Stubs);
6913 Add_RAS_Proxy_And_Analyze (Decls,
6914 Vis_Decl => Current_Declaration,
6915 All_Calls_Remote_E => All_Calls_Remote_E,
6916 Proxy_Object_Addr => Proxy_Object_Addr);
6918 -- Compute distribution identifier
6920 Assign_Subprogram_Identifier
6922 Current_Subprogram_Number,
6926 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
6929 Make_Object_Declaration (Loc,
6930 Defining_Identifier => Subp_Dist_Name,
6931 Constant_Present => True,
6932 Object_Definition =>
6933 New_Occurrence_Of (Standard_String, Loc),
6935 Make_String_Literal (Loc, Subp_Val)));
6936 Analyze (Last (Decls));
6938 -- Add subprogram descriptor (RCI_Subp_Info) to the
6939 -- subprograms table for this receiver. The aggregate
6940 -- below must be kept consistent with the declaration
6941 -- of type RCI_Subp_Info in System.Partition_Interface.
6943 Append_To (Subp_Info_List,
6944 Make_Component_Association (Loc,
6945 Choices => New_List (
6946 Make_Integer_Literal (Loc, Current_Subprogram_Number)),
6949 Make_Aggregate (Loc,
6950 Expressions => New_List (
6951 Make_Attribute_Reference (Loc,
6953 New_Occurrence_Of (Subp_Dist_Name, Loc),
6954 Attribute_Name => Name_Address),
6956 Make_Attribute_Reference (Loc,
6958 New_Occurrence_Of (Subp_Dist_Name, Loc),
6959 Attribute_Name => Name_Length),
6961 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
6963 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6964 Declaration => Current_Declaration,
6965 Stubs => Current_Stubs,
6966 Subp_Number => Current_Subprogram_Number,
6967 Subp_Dist_Name => Subp_Dist_Name,
6968 Subp_Proxy_Addr => Proxy_Object_Addr);
6971 Current_Subprogram_Number := Current_Subprogram_Number + 1;
6974 Next (Current_Declaration);
6978 Make_Object_Declaration (Loc,
6979 Defining_Identifier => Subp_Info_Array,
6980 Constant_Present => True,
6981 Aliased_Present => True,
6982 Object_Definition =>
6983 Make_Subtype_Indication (Loc,
6985 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6987 Make_Index_Or_Discriminant_Constraint (Loc,
6991 Make_Integer_Literal (Loc,
6992 Intval => First_RCI_Subprogram_Id),
6994 Make_Integer_Literal (Loc,
6996 First_RCI_Subprogram_Id
6997 + List_Length (Subp_Info_List) - 1)))))));
6999 if Present (First (Subp_Info_List)) then
7000 Set_Expression (Last (Decls),
7001 Make_Aggregate (Loc,
7002 Component_Associations => Subp_Info_List));
7004 -- Generate the dispatch statement to determine the subprogram id
7005 -- of the called subprogram.
7007 -- We first test whether the reference that was used to make the
7008 -- call was the base RCI reference (in which case Local_Address is
7009 -- zero, and the method identifier from the request must be used
7010 -- to determine which subprogram is called) or a reference
7011 -- identifying one particular subprogram (in which case
7012 -- Local_Address is the address of that subprogram, and the
7013 -- method name from the request is ignored). The latter occurs
7014 -- for the case of a call through a remote access-to-subprogram.
7016 -- In each case, cascaded elsifs are used to determine the proper
7017 -- subprogram index. Using hash tables might be more efficient.
7019 Append_To (Pkg_RPC_Receiver_Statements,
7020 Make_Implicit_If_Statement (Pkg_Spec,
7023 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
7024 Right_Opnd => New_Occurrence_Of
7025 (RTE (RE_Null_Address), Loc)),
7027 Then_Statements => New_List (
7028 Make_Implicit_If_Statement (Pkg_Spec,
7029 Condition => New_Occurrence_Of (Standard_False, Loc),
7030 Then_Statements => New_List (
7031 Make_Null_Statement (Loc)),
7032 Elsif_Parts => Dispatch_On_Address)),
7034 Else_Statements => New_List (
7035 Make_Implicit_If_Statement (Pkg_Spec,
7036 Condition => New_Occurrence_Of (Standard_False, Loc),
7037 Then_Statements => New_List (Make_Null_Statement (Loc)),
7038 Elsif_Parts => Dispatch_On_Name))));
7041 -- For a degenerate RCI with no visible subprograms,
7042 -- Subp_Info_List has zero length, and the declaration is for an
7043 -- empty array, in which case no initialization aggregate must be
7044 -- generated. We do not generate a Dispatch_Statement either.
7046 -- No initialization provided: remove CONSTANT so that the
7047 -- declaration is not an incomplete deferred constant.
7049 Set_Constant_Present (Last (Decls), False);
7052 -- Analyze Subp_Info_Array declaration
7054 Analyze (Last (Decls));
7056 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7057 -- rather than raising an exception since we do not want someone
7058 -- to crash a remote partition by sending invalid subprogram ids.
7059 -- This is consistent with the other parts of the case statement
7060 -- since even in presence of incorrect parameters in the stream,
7061 -- every exception will be caught and (if the subprogram is not an
7062 -- APC) put into the result stream and sent away.
7064 Append_To (Pkg_RPC_Receiver_Cases,
7065 Make_Case_Statement_Alternative (Loc,
7066 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
7067 Statements => New_List (Make_Null_Statement (Loc))));
7069 Append_To (Pkg_RPC_Receiver_Statements,
7070 Make_Case_Statement (Loc,
7071 Expression => New_Occurrence_Of (Subp_Index, Loc),
7072 Alternatives => Pkg_RPC_Receiver_Cases));
7074 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7077 Append_To (Decls, Pkg_RPC_Receiver_Body);
7078 Analyze (Last (Decls));
7080 Pkg_RPC_Receiver_Object :=
7081 Make_Object_Declaration (Loc,
7082 Defining_Identifier =>
7083 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
7084 Aliased_Present => True,
7085 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
7086 Append_To (Decls, Pkg_RPC_Receiver_Object);
7087 Analyze (Last (Decls));
7089 Get_Library_Unit_Name_String (Pkg_Spec);
7093 Append_To (Register_Pkg_Actuals,
7094 Make_String_Literal (Loc,
7095 Strval => String_From_Name_Buffer));
7099 Append_To (Register_Pkg_Actuals,
7100 Make_Attribute_Reference (Loc,
7103 (Defining_Entity (Pkg_Spec), Loc),
7104 Attribute_Name => Name_Version));
7108 Append_To (Register_Pkg_Actuals,
7109 Make_Attribute_Reference (Loc,
7111 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7112 Attribute_Name => Name_Access));
7116 Append_To (Register_Pkg_Actuals,
7117 Make_Attribute_Reference (Loc,
7120 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc),
7121 Attribute_Name => Name_Access));
7125 Append_To (Register_Pkg_Actuals,
7126 Make_Attribute_Reference (Loc,
7127 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7128 Attribute_Name => Name_Address));
7132 Append_To (Register_Pkg_Actuals,
7133 Make_Attribute_Reference (Loc,
7134 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7135 Attribute_Name => Name_Length));
7137 -- Is_All_Calls_Remote
7139 Append_To (Register_Pkg_Actuals,
7140 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7145 Make_Procedure_Call_Statement (Loc,
7147 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7148 Parameter_Associations => Register_Pkg_Actuals));
7149 Analyze (Last (Stmts));
7150 end Add_Receiving_Stubs_To_Declarations;
7152 ---------------------------------
7153 -- Build_General_Calling_Stubs --
7154 ---------------------------------
7156 procedure Build_General_Calling_Stubs
7158 Statements : List_Id;
7159 Target_Object : Node_Id;
7160 Subprogram_Id : Node_Id;
7161 Asynchronous : Node_Id := Empty;
7162 Is_Known_Asynchronous : Boolean := False;
7163 Is_Known_Non_Asynchronous : Boolean := False;
7164 Is_Function : Boolean;
7166 Stub_Type : Entity_Id := Empty;
7167 RACW_Type : Entity_Id := Empty;
7170 Loc : constant Source_Ptr := Sloc (Nod);
7172 Request : constant Entity_Id :=
7173 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7174 -- The request object constructed by these stubs
7175 -- Could we use Name_R instead??? (see GLADE client stubs)
7177 function Make_Request_RTE_Call
7179 Actuals : List_Id := New_List) return Node_Id;
7180 -- Generate a procedure call statement calling RE with the given
7181 -- actuals. Request is appended to the list.
7183 ---------------------------
7184 -- Make_Request_RTE_Call --
7185 ---------------------------
7187 function Make_Request_RTE_Call
7189 Actuals : List_Id := New_List) return Node_Id
7192 Append_To (Actuals, New_Occurrence_Of (Request, Loc));
7193 return Make_Procedure_Call_Statement (Loc,
7195 New_Occurrence_Of (RTE (RE), Loc),
7196 Parameter_Associations => Actuals);
7197 end Make_Request_RTE_Call;
7199 Arguments : Node_Id;
7200 -- Name of the named values list used to transmit parameters
7201 -- to the remote package
7204 -- Name of the result named value (in non-APC cases) which get the
7205 -- result of the remote subprogram.
7207 Result_TC : Node_Id;
7208 -- Typecode expression for the result of the request (void
7209 -- typecode for procedures).
7211 Exception_Return_Parameter : Node_Id;
7212 -- Name of the parameter which will hold the exception sent by the
7213 -- remote subprogram.
7215 Current_Parameter : Node_Id;
7216 -- Current parameter being handled
7218 Ordered_Parameters_List : constant List_Id :=
7219 Build_Ordered_Parameters_List (Spec);
7221 Asynchronous_P : Node_Id;
7222 -- A Boolean expression indicating whether this call is asynchronous
7224 Asynchronous_Statements : List_Id := No_List;
7225 Non_Asynchronous_Statements : List_Id := No_List;
7226 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7228 Extra_Formal_Statements : constant List_Id := New_List;
7229 -- List of statements for extra formal parameters. It will appear
7230 -- after the regular statements for writing out parameters.
7232 After_Statements : constant List_Id := New_List;
7233 -- Statements to be executed after call returns (to assign IN OUT or
7234 -- OUT parameter values).
7237 -- The type of the formal parameter being processed
7239 Is_Controlling_Formal : Boolean;
7240 Is_First_Controlling_Formal : Boolean;
7241 First_Controlling_Formal_Seen : Boolean := False;
7242 -- Controlling formal parameters of distributed object primitives
7243 -- require special handling, and the first such parameter needs even
7244 -- more special handling.
7247 -- ??? document general form of stub subprograms for the PolyORB case
7250 Make_Object_Declaration (Loc,
7251 Defining_Identifier => Request,
7252 Aliased_Present => False,
7253 Object_Definition =>
7254 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
7257 Make_Defining_Identifier (Loc,
7258 Chars => New_Internal_Name ('R'));
7262 PolyORB_Support.Helpers.Build_TypeCode_Call
7263 (Loc, Etype (Result_Definition (Spec)), Decls);
7265 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7269 Make_Object_Declaration (Loc,
7270 Defining_Identifier => Result,
7271 Aliased_Present => False,
7272 Object_Definition =>
7273 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7275 Make_Aggregate (Loc,
7276 Component_Associations => New_List (
7277 Make_Component_Association (Loc,
7278 Choices => New_List (Make_Identifier (Loc, Name_Name)),
7280 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7281 Make_Component_Association (Loc,
7282 Choices => New_List (
7283 Make_Identifier (Loc, Name_Argument)),
7285 Make_Function_Call (Loc,
7286 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7287 Parameter_Associations => New_List (Result_TC))),
7288 Make_Component_Association (Loc,
7289 Choices => New_List (
7290 Make_Identifier (Loc, Name_Arg_Modes)),
7291 Expression => Make_Integer_Literal (Loc, 0))))));
7293 if not Is_Known_Asynchronous then
7294 Exception_Return_Parameter :=
7295 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7298 Make_Object_Declaration (Loc,
7299 Defining_Identifier => Exception_Return_Parameter,
7300 Object_Definition =>
7301 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7304 Exception_Return_Parameter := Empty;
7307 -- Initialize and fill in arguments list
7310 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7311 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7313 Current_Parameter := First (Ordered_Parameters_List);
7314 while Present (Current_Parameter) loop
7315 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7316 Is_Controlling_Formal := True;
7317 Is_First_Controlling_Formal :=
7318 not First_Controlling_Formal_Seen;
7319 First_Controlling_Formal_Seen := True;
7322 Is_Controlling_Formal := False;
7323 Is_First_Controlling_Formal := False;
7326 if Is_Controlling_Formal then
7328 -- For a controlling formal argument, we send its reference
7333 Etyp := Etype (Parameter_Type (Current_Parameter));
7336 -- The first controlling formal parameter is treated specially:
7337 -- it is used to set the target object of the call.
7339 if not Is_First_Controlling_Formal then
7341 Constrained : constant Boolean :=
7342 Is_Constrained (Etyp)
7343 or else Is_Elementary_Type (Etyp);
7345 Any : constant Entity_Id :=
7346 Make_Defining_Identifier (Loc,
7347 New_Internal_Name ('A'));
7349 Actual_Parameter : Node_Id :=
7351 Defining_Identifier (
7352 Current_Parameter), Loc);
7357 if Is_Controlling_Formal then
7359 -- For a controlling formal parameter (other than the
7360 -- first one), use the corresponding RACW. If the
7361 -- parameter is not an anonymous access parameter, that
7362 -- involves taking its 'Unrestricted_Access.
7364 if Nkind (Parameter_Type (Current_Parameter))
7365 = N_Access_Definition
7367 Actual_Parameter := OK_Convert_To
7368 (Etyp, Actual_Parameter);
7370 Actual_Parameter := OK_Convert_To (Etyp,
7371 Make_Attribute_Reference (Loc,
7372 Prefix => Actual_Parameter,
7373 Attribute_Name => Name_Unrestricted_Access));
7378 if In_Present (Current_Parameter)
7379 or else not Out_Present (Current_Parameter)
7380 or else not Constrained
7381 or else Is_Controlling_Formal
7383 -- The parameter has an input value, is constrained at
7384 -- runtime by an input value, or is a controlling formal
7385 -- parameter (always passed as a reference) other than
7388 Expr := PolyORB_Support.Helpers.Build_To_Any_Call
7389 (Actual_Parameter, Decls);
7392 Expr := Make_Function_Call (Loc,
7393 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7394 Parameter_Associations => New_List (
7395 PolyORB_Support.Helpers.Build_TypeCode_Call
7396 (Loc, Etyp, Decls)));
7400 Make_Object_Declaration (Loc,
7401 Defining_Identifier => Any,
7402 Aliased_Present => False,
7403 Object_Definition =>
7404 New_Occurrence_Of (RTE (RE_Any), Loc),
7405 Expression => Expr));
7407 Append_To (Statements,
7408 Add_Parameter_To_NVList (Loc,
7409 Parameter => Current_Parameter,
7410 NVList => Arguments,
7411 Constrained => Constrained,
7414 if Out_Present (Current_Parameter)
7415 and then not Is_Controlling_Formal
7417 if Is_Limited_Type (Etyp) then
7418 Helpers.Assign_Opaque_From_Any (Loc,
7419 Stms => After_Statements,
7421 N => New_Occurrence_Of (Any, Loc),
7423 Defining_Identifier (Current_Parameter));
7425 Append_To (After_Statements,
7426 Make_Assignment_Statement (Loc,
7429 Defining_Identifier (Current_Parameter), Loc),
7431 PolyORB_Support.Helpers.Build_From_Any_Call
7433 New_Occurrence_Of (Any, Loc),
7440 -- If the current parameter has a dynamic constrained status, then
7441 -- this status is transmitted as well.
7442 -- This should be done for accessibility as well ???
7444 if Nkind (Parameter_Type (Current_Parameter)) /=
7446 and then Need_Extra_Constrained (Current_Parameter)
7448 -- In this block, we do not use the extra formal that has been
7449 -- created because it does not exist at the time of expansion
7450 -- when building calling stubs for remote access to subprogram
7451 -- types. We create an extra variable of this type and push it
7452 -- in the stream after the regular parameters.
7455 Extra_Any_Parameter : constant Entity_Id :=
7456 Make_Defining_Identifier
7457 (Loc, New_Internal_Name ('P'));
7459 Parameter_Exp : constant Node_Id :=
7460 Make_Attribute_Reference (Loc,
7461 Prefix => New_Occurrence_Of (
7462 Defining_Identifier (Current_Parameter), Loc),
7463 Attribute_Name => Name_Constrained);
7466 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7469 Make_Object_Declaration (Loc,
7470 Defining_Identifier => Extra_Any_Parameter,
7471 Aliased_Present => False,
7472 Object_Definition =>
7473 New_Occurrence_Of (RTE (RE_Any), Loc),
7475 PolyORB_Support.Helpers.Build_To_Any_Call
7476 (Parameter_Exp, Decls)));
7478 Append_To (Extra_Formal_Statements,
7479 Add_Parameter_To_NVList (Loc,
7480 Parameter => Extra_Any_Parameter,
7481 NVList => Arguments,
7482 Constrained => True,
7483 Any => Extra_Any_Parameter));
7487 Next (Current_Parameter);
7490 -- Append the formal statements list to the statements
7492 Append_List_To (Statements, Extra_Formal_Statements);
7494 Append_To (Statements,
7495 Make_Request_RTE_Call (RE_Request_Create, New_List (
7498 New_Occurrence_Of (Arguments, Loc),
7499 New_Occurrence_Of (Result, Loc),
7501 (RTE (RE_Nil_Exc_List), Loc))));
7504 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7506 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7509 (Boolean_Literals (Is_Known_Asynchronous), Loc);
7512 pragma Assert (Present (Asynchronous));
7513 Asynchronous_P := New_Copy_Tree (Asynchronous);
7515 -- The expression node Asynchronous will be used to build an 'if'
7516 -- statement at the end of Build_General_Calling_Stubs: we need to
7517 -- make a copy here.
7520 Append_To (Parameter_Associations (Last (Statements)),
7521 Make_Indexed_Component (Loc,
7524 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7525 Expressions => New_List (Asynchronous_P)));
7527 Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke));
7529 -- Asynchronous case
7531 if not Is_Known_Non_Asynchronous then
7532 Asynchronous_Statements :=
7533 New_List (Make_Request_RTE_Call (RE_Request_Destroy));
7536 -- Non-asynchronous case
7538 if not Is_Known_Asynchronous then
7539 -- Reraise an exception occurrence from the completed request.
7540 -- If the exception occurrence is empty, this is a no-op.
7542 Non_Asynchronous_Statements := New_List (
7543 Make_Procedure_Call_Statement (Loc,
7545 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7546 Parameter_Associations => New_List (
7547 New_Occurrence_Of (Request, Loc))));
7551 Append_To (Non_Asynchronous_Statements,
7552 Make_Request_RTE_Call (RE_Request_Destroy));
7554 -- If this is a function call, read the value and return it
7556 Append_To (Non_Asynchronous_Statements,
7557 Make_Tag_Check (Loc,
7558 Make_Simple_Return_Statement (Loc,
7559 PolyORB_Support.Helpers.Build_From_Any_Call
7560 (Etype (Result_Definition (Spec)),
7561 Make_Selected_Component (Loc,
7563 Selector_Name => Name_Argument),
7568 -- Case of a procedure: deal with IN OUT and OUT formals
7570 Append_List_To (Non_Asynchronous_Statements, After_Statements);
7572 Append_To (Non_Asynchronous_Statements,
7573 Make_Request_RTE_Call (RE_Request_Destroy));
7577 if Is_Known_Asynchronous then
7578 Append_List_To (Statements, Asynchronous_Statements);
7580 elsif Is_Known_Non_Asynchronous then
7581 Append_List_To (Statements, Non_Asynchronous_Statements);
7584 pragma Assert (Present (Asynchronous));
7585 Append_To (Statements,
7586 Make_Implicit_If_Statement (Nod,
7587 Condition => Asynchronous,
7588 Then_Statements => Asynchronous_Statements,
7589 Else_Statements => Non_Asynchronous_Statements));
7591 end Build_General_Calling_Stubs;
7593 -----------------------
7594 -- Build_Stub_Target --
7595 -----------------------
7597 function Build_Stub_Target
7600 RCI_Locator : Entity_Id;
7601 Controlling_Parameter : Entity_Id) return RPC_Target
7603 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7604 Target_Reference : constant Entity_Id :=
7605 Make_Defining_Identifier (Loc,
7606 New_Internal_Name ('T'));
7608 if Present (Controlling_Parameter) then
7610 Make_Object_Declaration (Loc,
7611 Defining_Identifier => Target_Reference,
7613 Object_Definition =>
7614 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7617 Make_Function_Call (Loc,
7619 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7620 Parameter_Associations => New_List (
7621 Make_Selected_Component (Loc,
7622 Prefix => Controlling_Parameter,
7623 Selector_Name => Name_Target)))));
7625 -- Note: Controlling_Parameter has the same components as
7626 -- System.Partition_Interface.RACW_Stub_Type.
7628 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7631 Target_Info.Object :=
7632 Make_Selected_Component (Loc,
7633 Prefix => Make_Identifier (Loc, Chars (RCI_Locator)),
7635 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7639 end Build_Stub_Target;
7641 ---------------------
7642 -- Build_Stub_Type --
7643 ---------------------
7645 procedure Build_Stub_Type
7646 (RACW_Type : Entity_Id;
7647 Stub_Type_Comps : out List_Id;
7648 RPC_Receiver_Decl : out Node_Id)
7650 Loc : constant Source_Ptr := Sloc (RACW_Type);
7653 Stub_Type_Comps := New_List (
7654 Make_Component_Declaration (Loc,
7655 Defining_Identifier =>
7656 Make_Defining_Identifier (Loc, Name_Target),
7657 Component_Definition =>
7658 Make_Component_Definition (Loc,
7659 Aliased_Present => False,
7660 Subtype_Indication =>
7661 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7663 Make_Component_Declaration (Loc,
7664 Defining_Identifier =>
7665 Make_Defining_Identifier (Loc, Name_Asynchronous),
7667 Component_Definition =>
7668 Make_Component_Definition (Loc,
7669 Aliased_Present => False,
7670 Subtype_Indication =>
7671 New_Occurrence_Of (Standard_Boolean, Loc))));
7673 RPC_Receiver_Decl :=
7674 Make_Object_Declaration (Loc,
7675 Defining_Identifier => Make_Defining_Identifier (Loc,
7676 New_Internal_Name ('R')),
7677 Aliased_Present => True,
7678 Object_Definition =>
7679 New_Occurrence_Of (RTE (RE_Servant), Loc));
7680 end Build_Stub_Type;
7682 -----------------------------
7683 -- Build_RPC_Receiver_Body --
7684 -----------------------------
7686 procedure Build_RPC_Receiver_Body
7687 (RPC_Receiver : Entity_Id;
7688 Request : out Entity_Id;
7689 Subp_Id : out Entity_Id;
7690 Subp_Index : out Entity_Id;
7691 Stmts : out List_Id;
7694 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7696 RPC_Receiver_Spec : Node_Id;
7697 RPC_Receiver_Decls : List_Id;
7700 Request := Make_Defining_Identifier (Loc, Name_R);
7702 RPC_Receiver_Spec :=
7703 Build_RPC_Receiver_Specification
7704 (RPC_Receiver => RPC_Receiver,
7705 Request_Parameter => Request);
7707 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7708 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7710 RPC_Receiver_Decls := New_List (
7711 Make_Object_Renaming_Declaration (Loc,
7712 Defining_Identifier => Subp_Id,
7713 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7715 Make_Explicit_Dereference (Loc,
7717 Make_Selected_Component (Loc,
7719 Selector_Name => Name_Operation))),
7721 Make_Object_Declaration (Loc,
7722 Defining_Identifier => Subp_Index,
7723 Object_Definition =>
7724 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7726 Make_Attribute_Reference (Loc,
7728 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7729 Attribute_Name => Name_Last)));
7734 Make_Subprogram_Body (Loc,
7735 Specification => RPC_Receiver_Spec,
7736 Declarations => RPC_Receiver_Decls,
7737 Handled_Statement_Sequence =>
7738 Make_Handled_Sequence_Of_Statements (Loc,
7739 Statements => Stmts));
7740 end Build_RPC_Receiver_Body;
7742 --------------------------------------
7743 -- Build_Subprogram_Receiving_Stubs --
7744 --------------------------------------
7746 function Build_Subprogram_Receiving_Stubs
7747 (Vis_Decl : Node_Id;
7748 Asynchronous : Boolean;
7749 Dynamically_Asynchronous : Boolean := False;
7750 Stub_Type : Entity_Id := Empty;
7751 RACW_Type : Entity_Id := Empty;
7752 Parent_Primitive : Entity_Id := Empty) return Node_Id
7754 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7756 Request_Parameter : constant Entity_Id :=
7757 Make_Defining_Identifier (Loc,
7758 New_Internal_Name ('R'));
7759 -- Formal parameter for receiving stubs: a descriptor for an incoming
7762 Outer_Decls : constant List_Id := New_List;
7763 -- At the outermost level, an NVList and Any's are declared for all
7764 -- parameters. The Dynamic_Async flag also needs to be declared there
7765 -- to be visible from the exception handling code.
7767 Outer_Statements : constant List_Id := New_List;
7768 -- Statements that occur prior to the declaration of the actual
7769 -- parameter variables.
7771 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7772 -- Statements concerning extra formal parameters, prior to the
7773 -- declaration of the actual parameter variables.
7775 Decls : constant List_Id := New_List;
7776 -- All the parameters will get declared before calling the real
7777 -- subprograms. Also the out parameters will be declared. At this
7778 -- level, parameters may be unconstrained.
7780 Statements : constant List_Id := New_List;
7782 After_Statements : constant List_Id := New_List;
7783 -- Statements to be executed after the subprogram call
7785 Inner_Decls : List_Id := No_List;
7786 -- In case of a function, the inner declarations are needed since
7787 -- the result may be unconstrained.
7789 Excep_Handlers : List_Id := No_List;
7791 Parameter_List : constant List_Id := New_List;
7792 -- List of parameters to be passed to the subprogram
7794 First_Controlling_Formal_Seen : Boolean := False;
7796 Current_Parameter : Node_Id;
7798 Ordered_Parameters_List : constant List_Id :=
7799 Build_Ordered_Parameters_List
7800 (Specification (Vis_Decl));
7802 Arguments : constant Entity_Id :=
7803 Make_Defining_Identifier (Loc,
7804 New_Internal_Name ('A'));
7805 -- Name of the named values list used to retrieve parameters
7807 Subp_Spec : Node_Id;
7808 -- Subprogram specification
7810 Called_Subprogram : Node_Id;
7811 -- The subprogram to call
7814 if Present (RACW_Type) then
7815 Called_Subprogram :=
7816 New_Occurrence_Of (Parent_Primitive, Loc);
7818 Called_Subprogram :=
7820 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7823 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7825 -- Loop through every parameter and get its value from the stream. If
7826 -- the parameter is unconstrained, then the parameter is read using
7827 -- 'Input at the point of declaration.
7829 Current_Parameter := First (Ordered_Parameters_List);
7830 while Present (Current_Parameter) loop
7833 Constrained : Boolean;
7834 Any : Entity_Id := Empty;
7835 Object : constant Entity_Id :=
7836 Make_Defining_Identifier (Loc,
7837 Chars => New_Internal_Name ('P'));
7838 Expr : Node_Id := Empty;
7840 Is_Controlling_Formal : constant Boolean :=
7841 Is_RACW_Controlling_Formal
7842 (Current_Parameter, Stub_Type);
7844 Is_First_Controlling_Formal : Boolean := False;
7846 Need_Extra_Constrained : Boolean;
7847 -- True when an extra constrained actual is required
7850 if Is_Controlling_Formal then
7852 -- Controlling formals in distributed object primitive
7853 -- operations are handled specially:
7855 -- - the first controlling formal is used as the
7856 -- target of the call;
7858 -- - the remaining controlling formals are transmitted
7862 Is_First_Controlling_Formal :=
7863 not First_Controlling_Formal_Seen;
7864 First_Controlling_Formal_Seen := True;
7867 Etyp := Etype (Parameter_Type (Current_Parameter));
7871 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
7873 if not Is_First_Controlling_Formal then
7875 Make_Defining_Identifier (Loc,
7876 Chars => New_Internal_Name ('A'));
7878 Append_To (Outer_Decls,
7879 Make_Object_Declaration (Loc,
7880 Defining_Identifier => Any,
7881 Object_Definition =>
7882 New_Occurrence_Of (RTE (RE_Any), Loc),
7884 Make_Function_Call (Loc,
7885 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7886 Parameter_Associations => New_List (
7887 PolyORB_Support.Helpers.Build_TypeCode_Call
7888 (Loc, Etyp, Outer_Decls)))));
7890 Append_To (Outer_Statements,
7891 Add_Parameter_To_NVList (Loc,
7892 Parameter => Current_Parameter,
7893 NVList => Arguments,
7894 Constrained => Constrained,
7898 if Is_First_Controlling_Formal then
7900 Addr : constant Entity_Id :=
7901 Make_Defining_Identifier (Loc,
7902 Chars => New_Internal_Name ('A'));
7904 Is_Local : constant Entity_Id :=
7905 Make_Defining_Identifier (Loc,
7906 Chars => New_Internal_Name ('L'));
7909 -- Special case: obtain the first controlling formal
7910 -- from the target of the remote call, instead of the
7913 Append_To (Outer_Decls,
7914 Make_Object_Declaration (Loc,
7915 Defining_Identifier => Addr,
7916 Object_Definition =>
7917 New_Occurrence_Of (RTE (RE_Address), Loc)));
7919 Append_To (Outer_Decls,
7920 Make_Object_Declaration (Loc,
7921 Defining_Identifier => Is_Local,
7922 Object_Definition =>
7923 New_Occurrence_Of (Standard_Boolean, Loc)));
7925 Append_To (Outer_Statements,
7926 Make_Procedure_Call_Statement (Loc,
7928 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7929 Parameter_Associations => New_List (
7930 Make_Selected_Component (Loc,
7933 Request_Parameter, Loc),
7935 Make_Identifier (Loc, Name_Target)),
7936 New_Occurrence_Of (Is_Local, Loc),
7937 New_Occurrence_Of (Addr, Loc))));
7939 Expr := Unchecked_Convert_To (RACW_Type,
7940 New_Occurrence_Of (Addr, Loc));
7943 elsif In_Present (Current_Parameter)
7944 or else not Out_Present (Current_Parameter)
7945 or else not Constrained
7947 -- If an input parameter is constrained, then its reading is
7948 -- deferred until the beginning of the subprogram body. If
7949 -- it is unconstrained, then an expression is built for
7950 -- the object declaration and the variable is set using
7951 -- 'Input instead of 'Read.
7953 if Constrained and then Is_Limited_Type (Etyp) then
7954 Helpers.Assign_Opaque_From_Any (Loc,
7957 N => New_Occurrence_Of (Any, Loc),
7961 Expr := Helpers.Build_From_Any_Call
7962 (Etyp, New_Occurrence_Of (Any, Loc), Decls);
7965 Append_To (Statements,
7966 Make_Assignment_Statement (Loc,
7967 Name => New_Occurrence_Of (Object, Loc),
7968 Expression => Expr));
7972 -- Expr will be used to initialize (and constrain) the
7973 -- parameter when it is declared.
7981 Need_Extra_Constrained :=
7982 Nkind (Parameter_Type (Current_Parameter)) /=
7985 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7987 Present (Extra_Constrained
7988 (Defining_Identifier (Current_Parameter)));
7990 -- We may not associate an extra constrained actual to a
7991 -- constant object, so if one is needed, declare the actual
7992 -- as a variable even if it won't be modified.
7994 Build_Actual_Object_Declaration
7997 Variable => Need_Extra_Constrained
7998 or else Out_Present (Current_Parameter),
8001 Set_Etype (Object, Etyp);
8003 -- An out parameter may be written back using a 'Write
8004 -- attribute instead of a 'Output because it has been
8005 -- constrained by the parameter given to the caller. Note that
8006 -- out controlling arguments in the case of a RACW are not put
8007 -- back in the stream because the pointer on them has not
8010 if Out_Present (Current_Parameter)
8011 and then not Is_Controlling_Formal
8013 Append_To (After_Statements,
8014 Make_Procedure_Call_Statement (Loc,
8015 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
8016 Parameter_Associations => New_List (
8017 New_Occurrence_Of (Any, Loc),
8018 PolyORB_Support.Helpers.Build_To_Any_Call
8019 (New_Occurrence_Of (Object, Loc), Decls))));
8022 -- For RACW controlling formals, the Etyp of Object is always
8023 -- an RACW, even if the parameter is not of an anonymous access
8024 -- type. In such case, we need to dereference it at call time.
8026 if Is_Controlling_Formal then
8027 if Nkind (Parameter_Type (Current_Parameter)) /=
8030 Append_To (Parameter_List,
8031 Make_Parameter_Association (Loc,
8034 (Defining_Identifier (Current_Parameter), Loc),
8035 Explicit_Actual_Parameter =>
8036 Make_Explicit_Dereference (Loc,
8037 Prefix => New_Occurrence_Of (Object, Loc))));
8040 Append_To (Parameter_List,
8041 Make_Parameter_Association (Loc,
8044 (Defining_Identifier (Current_Parameter), Loc),
8046 Explicit_Actual_Parameter =>
8047 New_Occurrence_Of (Object, Loc)));
8051 Append_To (Parameter_List,
8052 Make_Parameter_Association (Loc,
8055 Defining_Identifier (Current_Parameter), Loc),
8056 Explicit_Actual_Parameter =>
8057 New_Occurrence_Of (Object, Loc)));
8060 -- If the current parameter needs an extra formal, then read it
8061 -- from the stream and set the corresponding semantic field in
8062 -- the variable. If the kind of the parameter identifier is
8063 -- E_Void, then this is a compiler generated parameter that
8064 -- doesn't need an extra constrained status.
8066 -- The case of Extra_Accessibility should also be handled ???
8068 if Need_Extra_Constrained then
8070 Extra_Parameter : constant Entity_Id :=
8072 (Defining_Identifier
8073 (Current_Parameter));
8075 Extra_Any : constant Entity_Id :=
8076 Make_Defining_Identifier (Loc,
8077 Chars => New_Internal_Name ('A'));
8079 Formal_Entity : constant Entity_Id :=
8080 Make_Defining_Identifier (Loc,
8081 Chars => Chars (Extra_Parameter));
8083 Formal_Type : constant Entity_Id :=
8084 Etype (Extra_Parameter);
8087 Append_To (Outer_Decls,
8088 Make_Object_Declaration (Loc,
8089 Defining_Identifier => Extra_Any,
8090 Object_Definition =>
8091 New_Occurrence_Of (RTE (RE_Any), Loc),
8093 Make_Function_Call (Loc,
8095 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8096 Parameter_Associations => New_List (
8097 PolyORB_Support.Helpers.Build_TypeCode_Call
8098 (Loc, Formal_Type, Outer_Decls)))));
8100 Append_To (Outer_Extra_Formal_Statements,
8101 Add_Parameter_To_NVList (Loc,
8102 Parameter => Extra_Parameter,
8103 NVList => Arguments,
8104 Constrained => True,
8108 Make_Object_Declaration (Loc,
8109 Defining_Identifier => Formal_Entity,
8110 Object_Definition =>
8111 New_Occurrence_Of (Formal_Type, Loc)));
8113 Append_To (Statements,
8114 Make_Assignment_Statement (Loc,
8115 Name => New_Occurrence_Of (Formal_Entity, Loc),
8117 PolyORB_Support.Helpers.Build_From_Any_Call
8119 New_Occurrence_Of (Extra_Any, Loc),
8121 Set_Extra_Constrained (Object, Formal_Entity);
8126 Next (Current_Parameter);
8129 -- Extra Formals should go after all the other parameters
8131 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8133 Append_To (Outer_Statements,
8134 Make_Procedure_Call_Statement (Loc,
8135 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8136 Parameter_Associations => New_List (
8137 New_Occurrence_Of (Request_Parameter, Loc),
8138 New_Occurrence_Of (Arguments, Loc))));
8140 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8142 -- The remote subprogram is a function: Build an inner block to be
8143 -- able to hold a potentially unconstrained result in a variable.
8146 Etyp : constant Entity_Id :=
8147 Etype (Result_Definition (Specification (Vis_Decl)));
8148 Result : constant Node_Id :=
8149 Make_Defining_Identifier (Loc,
8150 Chars => New_Internal_Name ('R'));
8153 Inner_Decls := New_List (
8154 Make_Object_Declaration (Loc,
8155 Defining_Identifier => Result,
8156 Constant_Present => True,
8157 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8159 Make_Function_Call (Loc,
8160 Name => Called_Subprogram,
8161 Parameter_Associations => Parameter_List)));
8163 if Is_Class_Wide_Type (Etyp) then
8165 -- For a remote call to a function with a class-wide type,
8166 -- check that the returned value satisfies the requirements
8169 Append_To (Inner_Decls,
8170 Make_Transportable_Check (Loc,
8171 New_Occurrence_Of (Result, Loc)));
8175 Set_Etype (Result, Etyp);
8176 Append_To (After_Statements,
8177 Make_Procedure_Call_Statement (Loc,
8178 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8179 Parameter_Associations => New_List (
8180 New_Occurrence_Of (Request_Parameter, Loc),
8181 PolyORB_Support.Helpers.Build_To_Any_Call
8182 (New_Occurrence_Of (Result, Loc), Decls))));
8184 -- A DSA function does not have out or inout arguments
8187 Append_To (Statements,
8188 Make_Block_Statement (Loc,
8189 Declarations => Inner_Decls,
8190 Handled_Statement_Sequence =>
8191 Make_Handled_Sequence_Of_Statements (Loc,
8192 Statements => After_Statements)));
8195 -- The remote subprogram is a procedure. We do not need any inner
8196 -- block in this case. No specific processing is required here for
8197 -- the dynamically asynchronous case: the indication of whether
8198 -- call is asynchronous or not is managed by the Sync_Scope
8199 -- attibute of the request, and is handled entirely in the
8202 Append_To (After_Statements,
8203 Make_Procedure_Call_Statement (Loc,
8204 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8205 Parameter_Associations => New_List (
8206 New_Occurrence_Of (Request_Parameter, Loc))));
8208 Append_To (Statements,
8209 Make_Procedure_Call_Statement (Loc,
8210 Name => Called_Subprogram,
8211 Parameter_Associations => Parameter_List));
8213 Append_List_To (Statements, After_Statements);
8217 Make_Procedure_Specification (Loc,
8218 Defining_Unit_Name =>
8219 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
8221 Parameter_Specifications => New_List (
8222 Make_Parameter_Specification (Loc,
8223 Defining_Identifier => Request_Parameter,
8225 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8227 -- An exception raised during the execution of an incoming remote
8228 -- subprogram call and that needs to be sent back to the caller is
8229 -- propagated by the receiving stubs, and will be handled by the
8230 -- caller (the distribution runtime).
8232 if Asynchronous and then not Dynamically_Asynchronous then
8234 -- For an asynchronous procedure, add a null exception handler
8236 Excep_Handlers := New_List (
8237 Make_Implicit_Exception_Handler (Loc,
8238 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8239 Statements => New_List (Make_Null_Statement (Loc))));
8242 -- In the other cases, if an exception is raised, then the
8243 -- exception occurrence is propagated.
8248 Append_To (Outer_Statements,
8249 Make_Block_Statement (Loc,
8250 Declarations => Decls,
8251 Handled_Statement_Sequence =>
8252 Make_Handled_Sequence_Of_Statements (Loc,
8253 Statements => Statements)));
8256 Make_Subprogram_Body (Loc,
8257 Specification => Subp_Spec,
8258 Declarations => Outer_Decls,
8259 Handled_Statement_Sequence =>
8260 Make_Handled_Sequence_Of_Statements (Loc,
8261 Statements => Outer_Statements,
8262 Exception_Handlers => Excep_Handlers));
8263 end Build_Subprogram_Receiving_Stubs;
8269 package body Helpers is
8271 -----------------------
8272 -- Local Subprograms --
8273 -----------------------
8275 function Find_Numeric_Representation
8276 (Typ : Entity_Id) return Entity_Id;
8277 -- Given a numeric type Typ, return the smallest integer or floating
8278 -- point type from Standard, or the smallest unsigned (modular) type
8279 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8281 function Make_Helper_Function_Name
8284 Nam : Name_Id) return Entity_Id;
8285 -- Return the name to be assigned for helper subprogram Nam of Typ
8287 ------------------------------------------------------------
8288 -- Common subprograms for building various tree fragments --
8289 ------------------------------------------------------------
8291 function Build_Get_Aggregate_Element
8295 Idx : Node_Id) return Node_Id;
8296 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8297 -- returning the Idx'th element.
8300 Subprogram : Entity_Id;
8301 -- Reference location for constructed nodes
8304 -- For 'Range and Etype
8307 -- For the construction of the innermost element expression
8309 with procedure Add_Process_Element
8312 Counter : Entity_Id;
8315 procedure Append_Array_Traversal
8318 Counter : Entity_Id := Empty;
8320 -- Build nested loop statements that iterate over the elements of an
8321 -- array Arry. The statement(s) built by Add_Process_Element are
8322 -- executed for each element; Indices is the list of indices to be
8323 -- used in the construction of the indexed component that denotes the
8324 -- current element. Subprogram is the entity for the subprogram for
8325 -- which this iterator is generated. The generated statements are
8326 -- appended to Stmts.
8330 -- The record entity being dealt with
8332 with procedure Add_Process_Element
8334 Container : Node_Or_Entity_Id;
8335 Counter : in out Int;
8338 -- Rec is the instance of the record type, or Empty.
8339 -- Field is either the N_Defining_Identifier for a component,
8340 -- or an N_Variant_Part.
8342 procedure Append_Record_Traversal
8345 Container : Node_Or_Entity_Id;
8346 Counter : in out Int);
8347 -- Process component list Clist. Individual fields are passed
8348 -- to Field_Processing. Each variant part is also processed.
8349 -- Container is the outer Any (for From_Any/To_Any),
8350 -- the outer typecode (for TC) to which the operation applies.
8352 -----------------------------
8353 -- Append_Record_Traversal --
8354 -----------------------------
8356 procedure Append_Record_Traversal
8359 Container : Node_Or_Entity_Id;
8360 Counter : in out Int)
8364 -- Clist's Component_Items and Variant_Part
8374 CI := Component_Items (Clist);
8375 VP := Variant_Part (Clist);
8378 while Present (Item) loop
8379 Def := Defining_Identifier (Item);
8381 if not Is_Internal_Name (Chars (Def)) then
8383 (Stmts, Container, Counter, Rec, Def);
8389 if Present (VP) then
8390 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8392 end Append_Record_Traversal;
8394 -----------------------------
8395 -- Assign_Opaque_From_Any --
8396 -----------------------------
8398 procedure Assign_Opaque_From_Any
8405 Strm : constant Entity_Id :=
8406 Make_Defining_Identifier (Loc,
8407 Chars => New_Internal_Name ('S'));
8410 Read_Call_List : List_Id;
8411 -- List on which to place the 'Read attribute reference
8414 -- Strm : Buffer_Stream_Type;
8417 Make_Object_Declaration (Loc,
8418 Defining_Identifier => Strm,
8419 Aliased_Present => True,
8420 Object_Definition =>
8421 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
8423 -- Any_To_BS (Strm, A);
8426 Make_Procedure_Call_Statement (Loc,
8427 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
8428 Parameter_Associations => New_List (
8430 New_Occurrence_Of (Strm, Loc))));
8432 if Transmit_As_Unconstrained (Typ) then
8434 Make_Attribute_Reference (Loc,
8435 Prefix => New_Occurrence_Of (Typ, Loc),
8436 Attribute_Name => Name_Input,
8437 Expressions => New_List (
8438 Make_Attribute_Reference (Loc,
8439 Prefix => New_Occurrence_Of (Strm, Loc),
8440 Attribute_Name => Name_Access)));
8442 -- Target := Typ'Input (Strm'Access)
8444 if Present (Target) then
8446 Make_Assignment_Statement (Loc,
8447 Name => New_Occurrence_Of (Target, Loc),
8448 Expression => Expr));
8450 -- return Typ'Input (Strm'Access);
8454 Make_Simple_Return_Statement (Loc,
8455 Expression => Expr));
8459 if Present (Target) then
8460 Read_Call_List := Stms;
8461 Expr := New_Occurrence_Of (Target, Loc);
8465 Temp : constant Entity_Id :=
8466 Make_Defining_Identifier
8467 (Loc, New_Internal_Name ('R'));
8470 Read_Call_List := New_List;
8471 Expr := New_Occurrence_Of (Temp, Loc);
8473 Append_To (Stms, Make_Block_Statement (Loc,
8474 Declarations => New_List (
8475 Make_Object_Declaration (Loc,
8476 Defining_Identifier =>
8478 Object_Definition =>
8479 New_Occurrence_Of (Typ, Loc))),
8481 Handled_Statement_Sequence =>
8482 Make_Handled_Sequence_Of_Statements (Loc,
8483 Statements => Read_Call_List)));
8487 -- Typ'Read (Strm'Access, [Target|Temp])
8489 Append_To (Read_Call_List,
8490 Make_Attribute_Reference (Loc,
8491 Prefix => New_Occurrence_Of (Typ, Loc),
8492 Attribute_Name => Name_Read,
8493 Expressions => New_List (
8494 Make_Attribute_Reference (Loc,
8495 Prefix => New_Occurrence_Of (Strm, Loc),
8496 Attribute_Name => Name_Access),
8503 Append_To (Read_Call_List,
8504 Make_Simple_Return_Statement (Loc,
8505 Expression => New_Copy (Expr)));
8508 end Assign_Opaque_From_Any;
8510 -------------------------
8511 -- Build_From_Any_Call --
8512 -------------------------
8514 function Build_From_Any_Call
8517 Decls : List_Id) return Node_Id
8519 Loc : constant Source_Ptr := Sloc (N);
8521 U_Type : Entity_Id := Underlying_Type (Typ);
8523 Fnam : Entity_Id := Empty;
8524 Lib_RE : RE_Id := RE_Null;
8528 -- First simple case where the From_Any function is present
8529 -- in the type's TSS.
8531 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8533 if Sloc (U_Type) <= Standard_Location then
8534 U_Type := Base_Type (U_Type);
8537 -- Check first for Boolean and Character. These are enumeration
8538 -- types, but we treat them specially, since they may require
8539 -- special handling in the transfer protocol. However, this
8540 -- special handling only applies if they have standard
8541 -- representation, otherwise they are treated like any other
8542 -- enumeration type.
8544 if Present (Fnam) then
8547 elsif U_Type = Standard_Boolean then
8550 elsif U_Type = Standard_Character then
8553 elsif U_Type = Standard_Wide_Character then
8556 elsif U_Type = Standard_Wide_Wide_Character then
8557 Lib_RE := RE_FA_WWC;
8559 -- Floating point types
8561 elsif U_Type = Standard_Short_Float then
8564 elsif U_Type = Standard_Float then
8567 elsif U_Type = Standard_Long_Float then
8570 elsif U_Type = Standard_Long_Long_Float then
8571 Lib_RE := RE_FA_LLF;
8575 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8576 Lib_RE := RE_FA_SSI;
8578 elsif U_Type = Etype (Standard_Short_Integer) then
8581 elsif U_Type = Etype (Standard_Integer) then
8584 elsif U_Type = Etype (Standard_Long_Integer) then
8587 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8588 Lib_RE := RE_FA_LLI;
8590 -- Unsigned integer types
8592 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8593 Lib_RE := RE_FA_SSU;
8595 elsif U_Type = RTE (RE_Short_Unsigned) then
8598 elsif U_Type = RTE (RE_Unsigned) then
8601 elsif U_Type = RTE (RE_Long_Unsigned) then
8604 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8605 Lib_RE := RE_FA_LLU;
8607 elsif Is_RTE (U_Type, RE_Unbounded_String) then
8608 Lib_RE := RE_FA_String;
8610 -- Special DSA types
8612 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
8615 -- Other (non-primitive) types
8622 -- For the subtype representing a generic actual type, go
8623 -- to the base type.
8625 if Is_Generic_Actual_Type (U_Type) then
8626 U_Type := Base_Type (U_Type);
8629 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8630 Append_To (Decls, Decl);
8634 -- Call the function
8636 if Lib_RE /= RE_Null then
8637 pragma Assert (No (Fnam));
8638 Fnam := RTE (Lib_RE);
8642 Make_Function_Call (Loc,
8643 Name => New_Occurrence_Of (Fnam, Loc),
8644 Parameter_Associations => New_List (N));
8646 -- We must set the type of Result, so the unchecked conversion
8647 -- from the underlying type to the base type is properly done.
8649 Set_Etype (Result, U_Type);
8651 return Unchecked_Convert_To (Typ, Result);
8652 end Build_From_Any_Call;
8654 -----------------------------
8655 -- Build_From_Any_Function --
8656 -----------------------------
8658 procedure Build_From_Any_Function
8662 Fnam : out Entity_Id)
8665 Decls : constant List_Id := New_List;
8666 Stms : constant List_Id := New_List;
8668 Any_Parameter : constant Entity_Id :=
8669 Make_Defining_Identifier (Loc,
8670 New_Internal_Name ('A'));
8672 Use_Opaque_Representation : Boolean;
8675 -- The following test needs a comment ???
8677 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
8678 Build_From_Any_Function
8686 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
8689 Make_Function_Specification (Loc,
8690 Defining_Unit_Name => Fnam,
8691 Parameter_Specifications => New_List (
8692 Make_Parameter_Specification (Loc,
8693 Defining_Identifier => Any_Parameter,
8694 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
8695 Result_Definition => New_Occurrence_Of (Typ, Loc));
8697 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8700 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8702 Use_Opaque_Representation := False;
8704 if Has_Stream_Attribute_Definition
8705 (Typ, TSS_Stream_Output, At_Any_Place => True)
8707 Has_Stream_Attribute_Definition
8708 (Typ, TSS_Stream_Write, At_Any_Place => True)
8710 -- If user-defined stream attributes are specified for this
8711 -- type, use them and transmit data as an opaque sequence of
8714 Use_Opaque_Representation := True;
8716 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
8718 Make_Simple_Return_Statement (Loc,
8723 New_Occurrence_Of (Any_Parameter, Loc),
8726 elsif Is_Record_Type (Typ)
8727 and then not Is_Derived_Type (Typ)
8728 and then not Is_Tagged_Type (Typ)
8730 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8732 Make_Simple_Return_Statement (Loc,
8736 New_Occurrence_Of (Any_Parameter, Loc),
8741 Disc : Entity_Id := Empty;
8742 Discriminant_Associations : List_Id;
8743 Rdef : constant Node_Id :=
8745 (Declaration_Node (Typ));
8746 Component_Counter : Int := 0;
8748 -- The returned object
8750 Res : constant Entity_Id :=
8751 Make_Defining_Identifier (Loc,
8752 New_Internal_Name ('R'));
8754 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8756 procedure FA_Rec_Add_Process_Element
8759 Counter : in out Int;
8763 procedure FA_Append_Record_Traversal is
8764 new Append_Record_Traversal
8766 Add_Process_Element => FA_Rec_Add_Process_Element);
8768 --------------------------------
8769 -- FA_Rec_Add_Process_Element --
8770 --------------------------------
8772 procedure FA_Rec_Add_Process_Element
8775 Counter : in out Int;
8781 if Nkind (Field) = N_Defining_Identifier then
8782 -- A regular component
8784 Ctyp := Etype (Field);
8787 Make_Assignment_Statement (Loc,
8788 Name => Make_Selected_Component (Loc,
8790 New_Occurrence_Of (Rec, Loc),
8792 New_Occurrence_Of (Field, Loc)),
8795 Build_From_Any_Call (Ctyp,
8796 Build_Get_Aggregate_Element (Loc,
8799 Build_TypeCode_Call (Loc, Ctyp, Decls),
8801 Make_Integer_Literal (Loc, Counter)),
8809 Struct_Counter : Int := 0;
8811 Block_Decls : constant List_Id := New_List;
8812 Block_Stmts : constant List_Id := New_List;
8815 Alt_List : constant List_Id := New_List;
8816 Choice_List : List_Id;
8818 Struct_Any : constant Entity_Id :=
8819 Make_Defining_Identifier (Loc,
8820 New_Internal_Name ('S'));
8824 Make_Object_Declaration (Loc,
8825 Defining_Identifier => Struct_Any,
8826 Constant_Present => True,
8827 Object_Definition =>
8828 New_Occurrence_Of (RTE (RE_Any), Loc),
8830 Make_Function_Call (Loc,
8833 (RTE (RE_Extract_Union_Value), Loc),
8835 Parameter_Associations => New_List (
8836 Build_Get_Aggregate_Element (Loc,
8839 Make_Function_Call (Loc,
8840 Name => New_Occurrence_Of (
8841 RTE (RE_Any_Member_Type), Loc),
8842 Parameter_Associations =>
8844 New_Occurrence_Of (Any, Loc),
8845 Make_Integer_Literal (Loc,
8846 Intval => Counter))),
8848 Make_Integer_Literal (Loc,
8849 Intval => Counter))))));
8852 Make_Block_Statement (Loc,
8853 Declarations => Block_Decls,
8854 Handled_Statement_Sequence =>
8855 Make_Handled_Sequence_Of_Statements (Loc,
8856 Statements => Block_Stmts)));
8858 Append_To (Block_Stmts,
8859 Make_Case_Statement (Loc,
8861 Make_Selected_Component (Loc,
8863 Selector_Name => Chars (Name (Field))),
8864 Alternatives => Alt_List));
8866 Variant := First_Non_Pragma (Variants (Field));
8867 while Present (Variant) loop
8870 (Discrete_Choices (Variant));
8872 VP_Stmts := New_List;
8874 -- Struct_Counter should be reset before
8875 -- handling a variant part. Indeed only one
8876 -- of the case statement alternatives will be
8877 -- executed at run-time, so the counter must
8878 -- start at 0 for every case statement.
8880 Struct_Counter := 0;
8882 FA_Append_Record_Traversal (
8884 Clist => Component_List (Variant),
8885 Container => Struct_Any,
8886 Counter => Struct_Counter);
8888 Append_To (Alt_List,
8889 Make_Case_Statement_Alternative (Loc,
8890 Discrete_Choices => Choice_List,
8891 Statements => VP_Stmts));
8892 Next_Non_Pragma (Variant);
8897 Counter := Counter + 1;
8898 end FA_Rec_Add_Process_Element;
8901 -- First all discriminants
8903 if Has_Discriminants (Typ) then
8904 Discriminant_Associations := New_List;
8906 Disc := First_Discriminant (Typ);
8907 while Present (Disc) loop
8909 Disc_Var_Name : constant Entity_Id :=
8910 Make_Defining_Identifier (Loc,
8911 Chars => Chars (Disc));
8912 Disc_Type : constant Entity_Id :=
8917 Make_Object_Declaration (Loc,
8918 Defining_Identifier => Disc_Var_Name,
8919 Constant_Present => True,
8920 Object_Definition =>
8921 New_Occurrence_Of (Disc_Type, Loc),
8924 Build_From_Any_Call (Disc_Type,
8925 Build_Get_Aggregate_Element (Loc,
8926 Any => Any_Parameter,
8927 TC => Build_TypeCode_Call
8928 (Loc, Disc_Type, Decls),
8929 Idx => Make_Integer_Literal (Loc,
8930 Intval => Component_Counter)),
8933 Component_Counter := Component_Counter + 1;
8935 Append_To (Discriminant_Associations,
8936 Make_Discriminant_Association (Loc,
8937 Selector_Names => New_List (
8938 New_Occurrence_Of (Disc, Loc)),
8940 New_Occurrence_Of (Disc_Var_Name, Loc)));
8942 Next_Discriminant (Disc);
8946 Make_Subtype_Indication (Loc,
8947 Subtype_Mark => Res_Definition,
8949 Make_Index_Or_Discriminant_Constraint (Loc,
8950 Discriminant_Associations));
8953 -- Now we have all the discriminants in variables, we can
8954 -- declared a constrained object. Note that we are not
8955 -- initializing (non-discriminant) components directly in
8956 -- the object declarations, because which fields to
8957 -- initialize depends (at run time) on the discriminant
8961 Make_Object_Declaration (Loc,
8962 Defining_Identifier => Res,
8963 Object_Definition => Res_Definition));
8965 -- ... then all components
8967 FA_Append_Record_Traversal (Stms,
8968 Clist => Component_List (Rdef),
8969 Container => Any_Parameter,
8970 Counter => Component_Counter);
8973 Make_Simple_Return_Statement (Loc,
8974 Expression => New_Occurrence_Of (Res, Loc)));
8978 elsif Is_Array_Type (Typ) then
8980 Constrained : constant Boolean := Is_Constrained (Typ);
8982 procedure FA_Ary_Add_Process_Element
8985 Counter : Entity_Id;
8987 -- Assign the current element (as identified by Counter) of
8988 -- Any to the variable denoted by name Datum, and advance
8989 -- Counter by 1. If Datum is not an Any, a call to From_Any
8990 -- for its type is inserted.
8992 --------------------------------
8993 -- FA_Ary_Add_Process_Element --
8994 --------------------------------
8996 procedure FA_Ary_Add_Process_Element
8999 Counter : Entity_Id;
9002 Assignment : constant Node_Id :=
9003 Make_Assignment_Statement (Loc,
9005 Expression => Empty);
9007 Element_Any : Node_Id;
9011 Element_TC : Node_Id;
9014 if Etype (Datum) = RTE (RE_Any) then
9016 -- When Datum is an Any the Etype field is not
9017 -- sufficient to determine the typecode of Datum
9018 -- (which can be a TC_SEQUENCE or TC_ARRAY
9019 -- depending on the value of Constrained).
9021 -- Therefore we retrieve the typecode which has
9022 -- been constructed in Append_Array_Traversal with
9023 -- a call to Get_Any_Type.
9026 Make_Function_Call (Loc,
9027 Name => New_Occurrence_Of (
9028 RTE (RE_Get_Any_Type), Loc),
9029 Parameter_Associations => New_List (
9030 New_Occurrence_Of (Entity (Datum), Loc)));
9032 -- For non Any Datum we simply construct a typecode
9033 -- matching the Etype of the Datum.
9035 Element_TC := Build_TypeCode_Call
9036 (Loc, Etype (Datum), Decls);
9040 Build_Get_Aggregate_Element (Loc,
9043 Idx => New_Occurrence_Of (Counter, Loc));
9046 -- Note: here we *prepend* statements to Stmts, so
9047 -- we must do it in reverse order.
9050 Make_Assignment_Statement (Loc,
9052 New_Occurrence_Of (Counter, Loc),
9055 Left_Opnd => New_Occurrence_Of (Counter, Loc),
9056 Right_Opnd => Make_Integer_Literal (Loc, 1))));
9058 if Nkind (Datum) /= N_Attribute_Reference then
9060 -- We ignore the value of the length of each
9061 -- dimension, since the target array has already
9062 -- been constrained anyway.
9064 if Etype (Datum) /= RTE (RE_Any) then
9065 Set_Expression (Assignment,
9067 (Component_Type (Typ), Element_Any, Decls));
9069 Set_Expression (Assignment, Element_Any);
9072 Prepend_To (Stmts, Assignment);
9074 end FA_Ary_Add_Process_Element;
9076 ------------------------
9077 -- Local Declarations --
9078 ------------------------
9080 Counter : constant Entity_Id :=
9081 Make_Defining_Identifier (Loc, Name_J);
9083 Initial_Counter_Value : Int := 0;
9085 Component_TC : constant Entity_Id :=
9086 Make_Defining_Identifier (Loc, Name_T);
9088 Res : constant Entity_Id :=
9089 Make_Defining_Identifier (Loc, Name_R);
9091 procedure Append_From_Any_Array_Iterator is
9092 new Append_Array_Traversal (
9095 Indices => New_List,
9096 Add_Process_Element => FA_Ary_Add_Process_Element);
9098 Res_Subtype_Indication : Node_Id :=
9099 New_Occurrence_Of (Typ, Loc);
9102 if not Constrained then
9104 Ndim : constant Int := Number_Dimensions (Typ);
9107 Indx : Node_Id := First_Index (Typ);
9110 Ranges : constant List_Id := New_List;
9113 for J in 1 .. Ndim loop
9114 Lnam := New_External_Name ('L', J);
9115 Hnam := New_External_Name ('H', J);
9117 -- Note, for empty arrays bounds may be out of
9118 -- the range of Etype (Indx).
9120 Indt := Base_Type (Etype (Indx));
9123 Make_Object_Declaration (Loc,
9124 Defining_Identifier =>
9125 Make_Defining_Identifier (Loc, Lnam),
9126 Constant_Present => True,
9127 Object_Definition =>
9128 New_Occurrence_Of (Indt, Loc),
9132 Build_Get_Aggregate_Element (Loc,
9133 Any => Any_Parameter,
9134 TC => Build_TypeCode_Call
9137 Make_Integer_Literal (Loc, J - 1)),
9141 Make_Object_Declaration (Loc,
9142 Defining_Identifier =>
9143 Make_Defining_Identifier (Loc, Hnam),
9145 Constant_Present => True,
9147 Object_Definition =>
9148 New_Occurrence_Of (Indt, Loc),
9150 Expression => Make_Attribute_Reference (Loc,
9152 New_Occurrence_Of (Indt, Loc),
9154 Attribute_Name => Name_Val,
9156 Expressions => New_List (
9157 Make_Op_Subtract (Loc,
9162 Standard_Long_Integer,
9163 Make_Identifier (Loc, Lnam)),
9167 Standard_Long_Integer,
9168 Make_Function_Call (Loc,
9170 New_Occurrence_Of (RTE (
9171 RE_Get_Nested_Sequence_Length
9173 Parameter_Associations =>
9176 Any_Parameter, Loc),
9177 Make_Integer_Literal (Loc,
9181 Make_Integer_Literal (Loc, 1))))));
9185 Low_Bound => Make_Identifier (Loc, Lnam),
9186 High_Bound => Make_Identifier (Loc, Hnam)));
9191 -- Now we have all the necessary bound information:
9192 -- apply the set of range constraints to the
9193 -- (unconstrained) nominal subtype of Res.
9195 Initial_Counter_Value := Ndim;
9196 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9197 Subtype_Mark => Res_Subtype_Indication,
9199 Make_Index_Or_Discriminant_Constraint (Loc,
9200 Constraints => Ranges));
9205 Make_Object_Declaration (Loc,
9206 Defining_Identifier => Res,
9207 Object_Definition => Res_Subtype_Indication));
9208 Set_Etype (Res, Typ);
9211 Make_Object_Declaration (Loc,
9212 Defining_Identifier => Counter,
9213 Object_Definition =>
9214 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
9216 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9219 Make_Object_Declaration (Loc,
9220 Defining_Identifier => Component_TC,
9221 Constant_Present => True,
9222 Object_Definition =>
9223 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9225 Build_TypeCode_Call (Loc,
9226 Component_Type (Typ), Decls)));
9228 Append_From_Any_Array_Iterator
9229 (Stms, Any_Parameter, Counter);
9232 Make_Simple_Return_Statement (Loc,
9233 Expression => New_Occurrence_Of (Res, Loc)));
9236 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9238 Make_Simple_Return_Statement (Loc,
9240 Unchecked_Convert_To (Typ,
9242 (Find_Numeric_Representation (Typ),
9243 New_Occurrence_Of (Any_Parameter, Loc),
9247 Use_Opaque_Representation := True;
9250 if Use_Opaque_Representation then
9251 Assign_Opaque_From_Any (Loc,
9254 N => New_Occurrence_Of (Any_Parameter, Loc),
9259 Make_Subprogram_Body (Loc,
9260 Specification => Spec,
9261 Declarations => Decls,
9262 Handled_Statement_Sequence =>
9263 Make_Handled_Sequence_Of_Statements (Loc,
9264 Statements => Stms));
9265 end Build_From_Any_Function;
9267 ---------------------------------
9268 -- Build_Get_Aggregate_Element --
9269 ---------------------------------
9271 function Build_Get_Aggregate_Element
9275 Idx : Node_Id) return Node_Id
9278 return Make_Function_Call (Loc,
9280 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc),
9281 Parameter_Associations => New_List (
9282 New_Occurrence_Of (Any, Loc),
9285 end Build_Get_Aggregate_Element;
9287 -------------------------
9288 -- Build_Reposiroty_Id --
9289 -------------------------
9291 procedure Build_Name_And_Repository_Id
9293 Name_Str : out String_Id;
9294 Repo_Id_Str : out String_Id)
9298 Store_String_Chars ("DSA:");
9299 Get_Library_Unit_Name_String (Scope (E));
9301 (Name_Buffer (Name_Buffer'First ..
9302 Name_Buffer'First + Name_Len - 1));
9303 Store_String_Char ('.');
9304 Get_Name_String (Chars (E));
9306 (Name_Buffer (Name_Buffer'First ..
9307 Name_Buffer'First + Name_Len - 1));
9308 Store_String_Chars (":1.0");
9309 Repo_Id_Str := End_String;
9310 Name_Str := String_From_Name_Buffer;
9311 end Build_Name_And_Repository_Id;
9313 -----------------------
9314 -- Build_To_Any_Call --
9315 -----------------------
9317 function Build_To_Any_Call
9319 Decls : List_Id) return Node_Id
9321 Loc : constant Source_Ptr := Sloc (N);
9323 Typ : Entity_Id := Etype (N);
9326 Fnam : Entity_Id := Empty;
9327 Lib_RE : RE_Id := RE_Null;
9330 -- If N is a selected component, then maybe its Etype has not been
9331 -- set yet: try to use Etype of the selector_name in that case.
9333 if No (Typ) and then Nkind (N) = N_Selected_Component then
9334 Typ := Etype (Selector_Name (N));
9337 pragma Assert (Present (Typ));
9339 -- Get full view for private type, completion for incomplete type
9341 U_Type := Underlying_Type (Typ);
9343 -- First simple case where the To_Any function is present in the
9346 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9348 -- Check first for Boolean and Character. These are enumeration
9349 -- types, but we treat them specially, since they may require
9350 -- special handling in the transfer protocol. However, this
9351 -- special handling only applies if they have standard
9352 -- representation, otherwise they are treated like any other
9353 -- enumeration type.
9355 if Sloc (U_Type) <= Standard_Location then
9356 U_Type := Base_Type (U_Type);
9359 if Present (Fnam) then
9362 elsif U_Type = Standard_Boolean then
9365 elsif U_Type = Standard_Character then
9368 elsif U_Type = Standard_Wide_Character then
9371 elsif U_Type = Standard_Wide_Wide_Character then
9372 Lib_RE := RE_TA_WWC;
9374 -- Floating point types
9376 elsif U_Type = Standard_Short_Float then
9379 elsif U_Type = Standard_Float then
9382 elsif U_Type = Standard_Long_Float then
9385 elsif U_Type = Standard_Long_Long_Float then
9386 Lib_RE := RE_TA_LLF;
9390 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9391 Lib_RE := RE_TA_SSI;
9393 elsif U_Type = Etype (Standard_Short_Integer) then
9396 elsif U_Type = Etype (Standard_Integer) then
9399 elsif U_Type = Etype (Standard_Long_Integer) then
9402 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9403 Lib_RE := RE_TA_LLI;
9405 -- Unsigned integer types
9407 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9408 Lib_RE := RE_TA_SSU;
9410 elsif U_Type = RTE (RE_Short_Unsigned) then
9413 elsif U_Type = RTE (RE_Unsigned) then
9416 elsif U_Type = RTE (RE_Long_Unsigned) then
9419 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9420 Lib_RE := RE_TA_LLU;
9422 elsif Is_RTE (U_Type, RE_Unbounded_String) then
9423 Lib_RE := RE_TA_String;
9425 -- Special DSA types
9427 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
9431 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9433 -- No corresponding FA_TC ???
9437 -- Other (non-primitive) types
9443 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9444 Append_To (Decls, Decl);
9448 -- Call the function
9450 if Lib_RE /= RE_Null then
9451 pragma Assert (No (Fnam));
9452 Fnam := RTE (Lib_RE);
9455 -- If Fnam is already analyzed, find the proper expected type,
9456 -- else we have a newly constructed To_Any function and we know
9457 -- that the expected type of its parameter is U_Type.
9459 if Ekind (Fnam) = E_Function
9460 and then Present (First_Formal (Fnam))
9462 C_Type := Etype (First_Formal (Fnam));
9468 Make_Function_Call (Loc,
9469 Name => New_Occurrence_Of (Fnam, Loc),
9470 Parameter_Associations =>
9471 New_List (OK_Convert_To (C_Type, N)));
9472 end Build_To_Any_Call;
9474 ---------------------------
9475 -- Build_To_Any_Function --
9476 ---------------------------
9478 procedure Build_To_Any_Function
9482 Fnam : out Entity_Id)
9485 Decls : constant List_Id := New_List;
9486 Stms : constant List_Id := New_List;
9488 Expr_Parameter : constant Entity_Id :=
9489 Make_Defining_Identifier (Loc, Name_E);
9491 Any : constant Entity_Id :=
9492 Make_Defining_Identifier (Loc, Name_A);
9495 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9497 Use_Opaque_Representation : Boolean;
9498 -- When True, use stream attributes and represent type as an
9499 -- opaque sequence of bytes.
9502 -- The following test needs a comment ???
9504 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
9505 Build_To_Any_Function
9513 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
9516 Make_Function_Specification (Loc,
9517 Defining_Unit_Name => Fnam,
9518 Parameter_Specifications => New_List (
9519 Make_Parameter_Specification (Loc,
9520 Defining_Identifier => Expr_Parameter,
9521 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9522 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9523 Set_Etype (Expr_Parameter, Typ);
9526 Make_Object_Declaration (Loc,
9527 Defining_Identifier => Any,
9528 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9530 Use_Opaque_Representation := False;
9532 if Has_Stream_Attribute_Definition
9533 (Typ, TSS_Stream_Output, At_Any_Place => True)
9535 Has_Stream_Attribute_Definition
9536 (Typ, TSS_Stream_Write, At_Any_Place => True)
9538 -- If user-defined stream attributes are specified for this
9539 -- type, use them and transmit data as an opaque sequence of
9542 Use_Opaque_Representation := True;
9544 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9546 -- Non-tagged derived type: convert to root type
9549 Rt_Type : constant Entity_Id := Root_Type (Typ);
9550 Expr : constant Node_Id :=
9553 New_Occurrence_Of (Expr_Parameter, Loc));
9555 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9558 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9560 -- Non-tagged record type
9562 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9564 Rt_Type : constant Entity_Id := Etype (Typ);
9565 Expr : constant Node_Id :=
9566 OK_Convert_To (Rt_Type,
9567 New_Occurrence_Of (Expr_Parameter, Loc));
9571 (Any_Decl, Build_To_Any_Call (Expr, Decls));
9574 -- Comment needed here (and label on declare block ???)
9578 Disc : Entity_Id := Empty;
9579 Rdef : constant Node_Id :=
9580 Type_Definition (Declaration_Node (Typ));
9582 Elements : constant List_Id := New_List;
9584 procedure TA_Rec_Add_Process_Element
9586 Container : Node_Or_Entity_Id;
9587 Counter : in out Int;
9590 -- Processing routine for traversal below
9592 procedure TA_Append_Record_Traversal is
9593 new Append_Record_Traversal
9594 (Rec => Expr_Parameter,
9595 Add_Process_Element => TA_Rec_Add_Process_Element);
9597 --------------------------------
9598 -- TA_Rec_Add_Process_Element --
9599 --------------------------------
9601 procedure TA_Rec_Add_Process_Element
9603 Container : Node_Or_Entity_Id;
9604 Counter : in out Int;
9608 Field_Ref : Node_Id;
9611 if Nkind (Field) = N_Defining_Identifier then
9613 -- A regular component
9615 Field_Ref := Make_Selected_Component (Loc,
9616 Prefix => New_Occurrence_Of (Rec, Loc),
9617 Selector_Name => New_Occurrence_Of (Field, Loc));
9618 Set_Etype (Field_Ref, Etype (Field));
9621 Make_Procedure_Call_Statement (Loc,
9624 RTE (RE_Add_Aggregate_Element), Loc),
9625 Parameter_Associations => New_List (
9626 New_Occurrence_Of (Container, Loc),
9627 Build_To_Any_Call (Field_Ref, Decls))));
9632 Variant_Part : declare
9634 Struct_Counter : Int := 0;
9636 Block_Decls : constant List_Id := New_List;
9637 Block_Stmts : constant List_Id := New_List;
9640 Alt_List : constant List_Id := New_List;
9641 Choice_List : List_Id;
9643 Union_Any : constant Entity_Id :=
9644 Make_Defining_Identifier (Loc,
9645 New_Internal_Name ('V'));
9647 Struct_Any : constant Entity_Id :=
9648 Make_Defining_Identifier (Loc,
9649 New_Internal_Name ('S'));
9651 function Make_Discriminant_Reference
9653 -- Build reference to the discriminant for this
9656 ---------------------------------
9657 -- Make_Discriminant_Reference --
9658 ---------------------------------
9660 function Make_Discriminant_Reference
9663 Nod : constant Node_Id :=
9664 Make_Selected_Component (Loc,
9667 Chars (Name (Field)));
9669 Set_Etype (Nod, Etype (Name (Field)));
9671 end Make_Discriminant_Reference;
9673 -- Start of processing for Variant_Part
9677 Make_Block_Statement (Loc,
9680 Handled_Statement_Sequence =>
9681 Make_Handled_Sequence_Of_Statements (Loc,
9682 Statements => Block_Stmts)));
9684 -- Declare variant part aggregate (Union_Any).
9685 -- Knowing the position of this VP in the
9686 -- variant record, we can fetch the VP typecode
9689 Append_To (Block_Decls,
9690 Make_Object_Declaration (Loc,
9691 Defining_Identifier => Union_Any,
9692 Object_Definition =>
9693 New_Occurrence_Of (RTE (RE_Any), Loc),
9695 Make_Function_Call (Loc,
9696 Name => New_Occurrence_Of (
9697 RTE (RE_Create_Any), Loc),
9698 Parameter_Associations => New_List (
9699 Make_Function_Call (Loc,
9702 RTE (RE_Any_Member_Type), Loc),
9703 Parameter_Associations => New_List (
9704 New_Occurrence_Of (Container, Loc),
9705 Make_Integer_Literal (Loc,
9708 -- Declare inner struct aggregate (which
9709 -- contains the components of this VP).
9711 Append_To (Block_Decls,
9712 Make_Object_Declaration (Loc,
9713 Defining_Identifier => Struct_Any,
9714 Object_Definition =>
9715 New_Occurrence_Of (RTE (RE_Any), Loc),
9717 Make_Function_Call (Loc,
9718 Name => New_Occurrence_Of (
9719 RTE (RE_Create_Any), Loc),
9720 Parameter_Associations => New_List (
9721 Make_Function_Call (Loc,
9724 RTE (RE_Any_Member_Type), Loc),
9725 Parameter_Associations => New_List (
9726 New_Occurrence_Of (Union_Any, Loc),
9727 Make_Integer_Literal (Loc,
9730 -- Build case statement
9732 Append_To (Block_Stmts,
9733 Make_Case_Statement (Loc,
9734 Expression => Make_Discriminant_Reference,
9735 Alternatives => Alt_List));
9737 Variant := First_Non_Pragma (Variants (Field));
9738 while Present (Variant) loop
9739 Choice_List := New_Copy_List_Tree
9740 (Discrete_Choices (Variant));
9742 VP_Stmts := New_List;
9744 -- Append discriminant val to union aggregate
9746 Append_To (VP_Stmts,
9747 Make_Procedure_Call_Statement (Loc,
9750 RTE (RE_Add_Aggregate_Element), Loc),
9751 Parameter_Associations => New_List (
9752 New_Occurrence_Of (Union_Any, Loc),
9754 (Make_Discriminant_Reference,
9757 -- Populate inner struct aggregate
9759 -- Struct_Counter should be reset before
9760 -- handling a variant part. Indeed only one
9761 -- of the case statement alternatives will be
9762 -- executed at run-time, so the counter must
9763 -- start at 0 for every case statement.
9765 Struct_Counter := 0;
9767 TA_Append_Record_Traversal
9769 Clist => Component_List (Variant),
9770 Container => Struct_Any,
9771 Counter => Struct_Counter);
9773 -- Append inner struct to union aggregate
9775 Append_To (VP_Stmts,
9776 Make_Procedure_Call_Statement (Loc,
9779 (RTE (RE_Add_Aggregate_Element), Loc),
9780 Parameter_Associations => New_List (
9781 New_Occurrence_Of (Union_Any, Loc),
9782 New_Occurrence_Of (Struct_Any, Loc))));
9784 -- Append union to outer aggregate
9786 Append_To (VP_Stmts,
9787 Make_Procedure_Call_Statement (Loc,
9790 (RTE (RE_Add_Aggregate_Element), Loc),
9791 Parameter_Associations => New_List (
9792 New_Occurrence_Of (Container, Loc),
9794 (Union_Any, Loc))));
9796 Append_To (Alt_List,
9797 Make_Case_Statement_Alternative (Loc,
9798 Discrete_Choices => Choice_List,
9799 Statements => VP_Stmts));
9801 Next_Non_Pragma (Variant);
9806 Counter := Counter + 1;
9807 end TA_Rec_Add_Process_Element;
9810 -- Records are encoded in a TC_STRUCT aggregate:
9812 -- -- Outer aggregate (TC_STRUCT)
9813 -- | [discriminant1]
9814 -- | [discriminant2]
9821 -- A component can be a common component or variant part
9823 -- A variant part is encoded as a TC_UNION aggregate:
9825 -- -- Variant Part Aggregate (TC_UNION)
9826 -- | [discriminant choice for this Variant Part]
9828 -- | -- Inner struct (TC_STRUCT)
9833 -- Let's start by building the outer aggregate. First we
9834 -- construct Elements array containing all discriminants.
9836 if Has_Discriminants (Typ) then
9837 Disc := First_Discriminant (Typ);
9838 while Present (Disc) loop
9840 Discriminant : constant Entity_Id :=
9841 Make_Selected_Component (Loc,
9848 Set_Etype (Discriminant, Etype (Disc));
9850 Append_To (Elements,
9851 Make_Component_Association (Loc,
9852 Choices => New_List (
9853 Make_Integer_Literal (Loc, Counter)),
9855 Build_To_Any_Call (Discriminant, Decls)));
9858 Counter := Counter + 1;
9859 Next_Discriminant (Disc);
9863 -- If there are no discriminants, we declare an empty
9867 Dummy_Any : constant Entity_Id :=
9868 Make_Defining_Identifier (Loc,
9869 Chars => New_Internal_Name ('A'));
9873 Make_Object_Declaration (Loc,
9874 Defining_Identifier => Dummy_Any,
9875 Object_Definition =>
9876 New_Occurrence_Of (RTE (RE_Any), Loc)));
9878 Append_To (Elements,
9879 Make_Component_Association (Loc,
9880 Choices => New_List (
9883 Make_Integer_Literal (Loc, 1),
9885 Make_Integer_Literal (Loc, 0))),
9887 New_Occurrence_Of (Dummy_Any, Loc)));
9891 -- We build the result aggregate with discriminants
9892 -- as the first elements.
9894 Set_Expression (Any_Decl,
9895 Make_Function_Call (Loc,
9896 Name => New_Occurrence_Of
9897 (RTE (RE_Any_Aggregate_Build), Loc),
9898 Parameter_Associations => New_List (
9900 Make_Aggregate (Loc,
9901 Component_Associations => Elements))));
9904 -- Then we append all the components to the result
9907 TA_Append_Record_Traversal (Stms,
9908 Clist => Component_List (Rdef),
9910 Counter => Counter);
9914 elsif Is_Array_Type (Typ) then
9916 -- Constrained and unconstrained array types
9919 Constrained : constant Boolean := Is_Constrained (Typ);
9921 procedure TA_Ary_Add_Process_Element
9924 Counter : Entity_Id;
9927 --------------------------------
9928 -- TA_Ary_Add_Process_Element --
9929 --------------------------------
9931 procedure TA_Ary_Add_Process_Element
9934 Counter : Entity_Id;
9937 pragma Unreferenced (Counter);
9939 Element_Any : Node_Id;
9942 if Etype (Datum) = RTE (RE_Any) then
9943 Element_Any := Datum;
9945 Element_Any := Build_To_Any_Call (Datum, Decls);
9949 Make_Procedure_Call_Statement (Loc,
9950 Name => New_Occurrence_Of (
9951 RTE (RE_Add_Aggregate_Element), Loc),
9952 Parameter_Associations => New_List (
9953 New_Occurrence_Of (Any, Loc),
9955 end TA_Ary_Add_Process_Element;
9957 procedure Append_To_Any_Array_Iterator is
9958 new Append_Array_Traversal (
9960 Arry => Expr_Parameter,
9961 Indices => New_List,
9962 Add_Process_Element => TA_Ary_Add_Process_Element);
9967 Set_Expression (Any_Decl,
9968 Make_Function_Call (Loc,
9970 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9971 Parameter_Associations => New_List (Result_TC)));
9974 if not Constrained then
9975 Index := First_Index (Typ);
9976 for J in 1 .. Number_Dimensions (Typ) loop
9978 Make_Procedure_Call_Statement (Loc,
9981 RTE (RE_Add_Aggregate_Element), Loc),
9982 Parameter_Associations => New_List (
9983 New_Occurrence_Of (Any, Loc),
9985 OK_Convert_To (Etype (Index),
9986 Make_Attribute_Reference (Loc,
9988 New_Occurrence_Of (Expr_Parameter, Loc),
9989 Attribute_Name => Name_First,
9990 Expressions => New_List (
9991 Make_Integer_Literal (Loc, J)))),
9997 Append_To_Any_Array_Iterator (Stms, Any);
10000 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10004 Set_Expression (Any_Decl,
10005 Build_To_Any_Call (
10007 Find_Numeric_Representation (Typ),
10008 New_Occurrence_Of (Expr_Parameter, Loc)),
10012 -- Default case, including tagged types: opaque representation
10014 Use_Opaque_Representation := True;
10017 if Use_Opaque_Representation then
10019 Strm : constant Entity_Id :=
10020 Make_Defining_Identifier (Loc,
10021 Chars => New_Internal_Name ('S'));
10022 -- Stream used to store data representation produced by
10023 -- stream attribute.
10027 -- Strm : aliased Buffer_Stream_Type;
10030 Make_Object_Declaration (Loc,
10031 Defining_Identifier =>
10035 Object_Definition =>
10036 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
10039 -- T'Output (Strm'Access, E);
10042 Make_Attribute_Reference (Loc,
10043 Prefix => New_Occurrence_Of (Typ, Loc),
10044 Attribute_Name => Name_Output,
10045 Expressions => New_List (
10046 Make_Attribute_Reference (Loc,
10047 Prefix => New_Occurrence_Of (Strm, Loc),
10048 Attribute_Name => Name_Access),
10049 New_Occurrence_Of (Expr_Parameter, Loc))));
10052 -- BS_To_Any (Strm, A);
10055 Make_Procedure_Call_Statement (Loc,
10056 Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
10057 Parameter_Associations => New_List (
10058 New_Occurrence_Of (Strm, Loc),
10059 New_Occurrence_Of (Any, Loc))));
10062 -- Release_Buffer (Strm);
10065 Make_Procedure_Call_Statement (Loc,
10066 Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
10067 Parameter_Associations => New_List (
10068 New_Occurrence_Of (Strm, Loc))));
10072 Append_To (Decls, Any_Decl);
10074 if Present (Result_TC) then
10076 Make_Procedure_Call_Statement (Loc,
10077 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
10078 Parameter_Associations => New_List (
10079 New_Occurrence_Of (Any, Loc),
10084 Make_Simple_Return_Statement (Loc,
10085 Expression => New_Occurrence_Of (Any, Loc)));
10088 Make_Subprogram_Body (Loc,
10089 Specification => Spec,
10090 Declarations => Decls,
10091 Handled_Statement_Sequence =>
10092 Make_Handled_Sequence_Of_Statements (Loc,
10093 Statements => Stms));
10094 end Build_To_Any_Function;
10096 -------------------------
10097 -- Build_TypeCode_Call --
10098 -------------------------
10100 function Build_TypeCode_Call
10103 Decls : List_Id) return Node_Id
10105 U_Type : Entity_Id := Underlying_Type (Typ);
10106 -- The full view, if Typ is private; the completion,
10107 -- if Typ is incomplete.
10109 Fnam : Entity_Id := Empty;
10110 Lib_RE : RE_Id := RE_Null;
10114 -- Special case System.PolyORB.Interface.Any: its primitives have
10115 -- not been set yet, so can't call Find_Inherited_TSS.
10117 if Typ = RTE (RE_Any) then
10118 Fnam := RTE (RE_TC_A);
10121 -- First simple case where the TypeCode is present
10122 -- in the type's TSS.
10124 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10128 if Sloc (U_Type) <= Standard_Location then
10130 -- Do not try to build alias typecodes for subtypes from
10133 U_Type := Base_Type (U_Type);
10136 if U_Type = Standard_Boolean then
10139 elsif U_Type = Standard_Character then
10142 elsif U_Type = Standard_Wide_Character then
10143 Lib_RE := RE_TC_WC;
10145 elsif U_Type = Standard_Wide_Wide_Character then
10146 Lib_RE := RE_TC_WWC;
10148 -- Floating point types
10150 elsif U_Type = Standard_Short_Float then
10151 Lib_RE := RE_TC_SF;
10153 elsif U_Type = Standard_Float then
10156 elsif U_Type = Standard_Long_Float then
10157 Lib_RE := RE_TC_LF;
10159 elsif U_Type = Standard_Long_Long_Float then
10160 Lib_RE := RE_TC_LLF;
10162 -- Integer types (walk back to the base type)
10164 elsif U_Type = Etype (Standard_Short_Short_Integer) then
10165 Lib_RE := RE_TC_SSI;
10167 elsif U_Type = Etype (Standard_Short_Integer) then
10168 Lib_RE := RE_TC_SI;
10170 elsif U_Type = Etype (Standard_Integer) then
10173 elsif U_Type = Etype (Standard_Long_Integer) then
10174 Lib_RE := RE_TC_LI;
10176 elsif U_Type = Etype (Standard_Long_Long_Integer) then
10177 Lib_RE := RE_TC_LLI;
10179 -- Unsigned integer types
10181 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
10182 Lib_RE := RE_TC_SSU;
10184 elsif U_Type = RTE (RE_Short_Unsigned) then
10185 Lib_RE := RE_TC_SU;
10187 elsif U_Type = RTE (RE_Unsigned) then
10190 elsif U_Type = RTE (RE_Long_Unsigned) then
10191 Lib_RE := RE_TC_LU;
10193 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
10194 Lib_RE := RE_TC_LLU;
10196 elsif Is_RTE (U_Type, RE_Unbounded_String) then
10197 Lib_RE := RE_TC_String;
10199 -- Special DSA types
10201 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
10204 -- Other (non-primitive) types
10210 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10211 Append_To (Decls, Decl);
10215 if Lib_RE /= RE_Null then
10216 Fnam := RTE (Lib_RE);
10220 -- Call the function
10223 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10225 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10227 Set_Etype (Expr, RTE (RE_TypeCode));
10230 end Build_TypeCode_Call;
10232 -----------------------------
10233 -- Build_TypeCode_Function --
10234 -----------------------------
10236 procedure Build_TypeCode_Function
10239 Decl : out Node_Id;
10240 Fnam : out Entity_Id)
10243 Decls : constant List_Id := New_List;
10244 Stms : constant List_Id := New_List;
10246 TCNam : constant Entity_Id :=
10247 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
10249 Parameters : List_Id;
10251 procedure Add_String_Parameter
10253 Parameter_List : List_Id);
10254 -- Add a literal for S to Parameters
10256 procedure Add_TypeCode_Parameter
10257 (TC_Node : Node_Id;
10258 Parameter_List : List_Id);
10259 -- Add the typecode for Typ to Parameters
10261 procedure Add_Long_Parameter
10262 (Expr_Node : Node_Id;
10263 Parameter_List : List_Id);
10264 -- Add a signed long integer expression to Parameters
10266 procedure Initialize_Parameter_List
10267 (Name_String : String_Id;
10268 Repo_Id_String : String_Id;
10269 Parameter_List : out List_Id);
10270 -- Return a list that contains the first two parameters
10271 -- for a parameterized typecode: name and repository id.
10273 function Make_Constructed_TypeCode
10275 Parameters : List_Id) return Node_Id;
10276 -- Call TC_Build with the given kind and parameters
10278 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10279 -- Make a return statement that calls TC_Build with the given
10280 -- typecode kind, and the constructed parameters list.
10282 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10283 -- Return a typecode that is a TC_Alias for the given typecode
10285 --------------------------
10286 -- Add_String_Parameter --
10287 --------------------------
10289 procedure Add_String_Parameter
10291 Parameter_List : List_Id)
10294 Append_To (Parameter_List,
10295 Make_Function_Call (Loc,
10296 Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc),
10297 Parameter_Associations => New_List (
10298 Make_String_Literal (Loc, S))));
10299 end Add_String_Parameter;
10301 ----------------------------
10302 -- Add_TypeCode_Parameter --
10303 ----------------------------
10305 procedure Add_TypeCode_Parameter
10306 (TC_Node : Node_Id;
10307 Parameter_List : List_Id)
10310 Append_To (Parameter_List,
10311 Make_Function_Call (Loc,
10312 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10313 Parameter_Associations => New_List (TC_Node)));
10314 end Add_TypeCode_Parameter;
10316 ------------------------
10317 -- Add_Long_Parameter --
10318 ------------------------
10320 procedure Add_Long_Parameter
10321 (Expr_Node : Node_Id;
10322 Parameter_List : List_Id)
10325 Append_To (Parameter_List,
10326 Make_Function_Call (Loc,
10327 Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc),
10328 Parameter_Associations => New_List (Expr_Node)));
10329 end Add_Long_Parameter;
10331 -------------------------------
10332 -- Initialize_Parameter_List --
10333 -------------------------------
10335 procedure Initialize_Parameter_List
10336 (Name_String : String_Id;
10337 Repo_Id_String : String_Id;
10338 Parameter_List : out List_Id)
10341 Parameter_List := New_List;
10342 Add_String_Parameter (Name_String, Parameter_List);
10343 Add_String_Parameter (Repo_Id_String, Parameter_List);
10344 end Initialize_Parameter_List;
10346 ---------------------------
10347 -- Return_Alias_TypeCode --
10348 ---------------------------
10350 procedure Return_Alias_TypeCode
10351 (Base_TypeCode : Node_Id)
10354 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10355 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
10356 end Return_Alias_TypeCode;
10358 -------------------------------
10359 -- Make_Constructed_TypeCode --
10360 -------------------------------
10362 function Make_Constructed_TypeCode
10364 Parameters : List_Id) return Node_Id
10366 Constructed_TC : constant Node_Id :=
10367 Make_Function_Call (Loc,
10369 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
10370 Parameter_Associations => New_List (
10371 New_Occurrence_Of (Kind, Loc),
10372 Make_Aggregate (Loc,
10373 Expressions => Parameters)));
10375 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10376 return Constructed_TC;
10377 end Make_Constructed_TypeCode;
10379 ---------------------------------
10380 -- Return_Constructed_TypeCode --
10381 ---------------------------------
10383 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10386 Make_Simple_Return_Statement (Loc,
10388 Make_Constructed_TypeCode (Kind, Parameters)));
10389 end Return_Constructed_TypeCode;
10395 procedure TC_Rec_Add_Process_Element
10398 Counter : in out Int;
10402 procedure TC_Append_Record_Traversal is
10403 new Append_Record_Traversal (
10405 Add_Process_Element => TC_Rec_Add_Process_Element);
10407 --------------------------------
10408 -- TC_Rec_Add_Process_Element --
10409 --------------------------------
10411 procedure TC_Rec_Add_Process_Element
10414 Counter : in out Int;
10418 pragma Unreferenced (Any, Counter, Rec);
10421 if Nkind (Field) = N_Defining_Identifier then
10423 -- A regular component
10425 Add_TypeCode_Parameter
10426 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10427 Get_Name_String (Chars (Field));
10428 Add_String_Parameter (String_From_Name_Buffer, Params);
10435 Discriminant_Type : constant Entity_Id :=
10436 Etype (Name (Field));
10438 Is_Enum : constant Boolean :=
10439 Is_Enumeration_Type (Discriminant_Type);
10441 Union_TC_Params : List_Id;
10443 U_Name : constant Name_Id :=
10444 New_External_Name (Chars (Typ), 'V', -1);
10446 Name_Str : String_Id;
10447 Struct_TC_Params : List_Id;
10451 Default : constant Node_Id :=
10452 Make_Integer_Literal (Loc, -1);
10454 Dummy_Counter : Int := 0;
10456 Choice_Index : Int := 0;
10458 procedure Add_Params_For_Variant_Components;
10459 -- Add a struct TypeCode and a corresponding member name
10460 -- to the union parameter list.
10462 -- Ordering of declarations is a complete mess in this
10463 -- area, it is supposed to be types/variables, then
10464 -- subprogram specs, then subprogram bodies ???
10466 ---------------------------------------
10467 -- Add_Params_For_Variant_Components --
10468 ---------------------------------------
10470 procedure Add_Params_For_Variant_Components
10472 S_Name : constant Name_Id :=
10473 New_External_Name (U_Name, 'S', -1);
10476 Get_Name_String (S_Name);
10477 Name_Str := String_From_Name_Buffer;
10478 Initialize_Parameter_List
10479 (Name_Str, Name_Str, Struct_TC_Params);
10481 -- Build struct parameters
10483 TC_Append_Record_Traversal (Struct_TC_Params,
10484 Component_List (Variant),
10488 Add_TypeCode_Parameter
10489 (Make_Constructed_TypeCode
10490 (RTE (RE_TC_Struct), Struct_TC_Params),
10493 Add_String_Parameter (Name_Str, Union_TC_Params);
10494 end Add_Params_For_Variant_Components;
10497 Get_Name_String (U_Name);
10498 Name_Str := String_From_Name_Buffer;
10500 Initialize_Parameter_List
10501 (Name_Str, Name_Str, Union_TC_Params);
10503 -- Add union in enclosing parameter list
10505 Add_TypeCode_Parameter
10506 (Make_Constructed_TypeCode
10507 (RTE (RE_TC_Union), Union_TC_Params),
10510 Add_String_Parameter (Name_Str, Params);
10512 -- Build union parameters
10514 Add_TypeCode_Parameter
10515 (Build_TypeCode_Call
10516 (Loc, Discriminant_Type, Decls),
10519 Add_Long_Parameter (Default, Union_TC_Params);
10521 Variant := First_Non_Pragma (Variants (Field));
10522 while Present (Variant) loop
10523 Choice := First (Discrete_Choices (Variant));
10524 while Present (Choice) loop
10525 case Nkind (Choice) is
10528 L : constant Uint :=
10529 Expr_Value (Low_Bound (Choice));
10530 H : constant Uint :=
10531 Expr_Value (High_Bound (Choice));
10533 -- 3.8.1(8) guarantees that the bounds of
10534 -- this range are static.
10541 Expr := New_Occurrence_Of (
10542 Get_Enum_Lit_From_Pos (
10543 Discriminant_Type, J, Loc), Loc);
10546 Make_Integer_Literal (Loc, J);
10548 Append_To (Union_TC_Params,
10549 Build_To_Any_Call (Expr, Decls));
10551 Add_Params_For_Variant_Components;
10556 when N_Others_Choice =>
10558 -- This variant possess a default choice.
10559 -- We must therefore set the default
10560 -- parameter to the current choice index. The
10561 -- default parameter is by construction the
10562 -- fourth in the Union_TC_Params list.
10565 Default_Node : constant Node_Id :=
10566 Pick (Union_TC_Params, 4);
10568 New_Default_Node : constant Node_Id :=
10569 Make_Function_Call (Loc,
10572 (RTE (RE_TA_LI), Loc),
10573 Parameter_Associations =>
10575 Make_Integer_Literal
10576 (Loc, Choice_Index)));
10582 Remove (Default_Node);
10585 -- Add a placeholder member label
10586 -- for the default case.
10587 -- It must be of the discriminant type.
10590 Exp : constant Node_Id :=
10591 Make_Attribute_Reference (Loc,
10592 Prefix => New_Occurrence_Of
10593 (Discriminant_Type, Loc),
10594 Attribute_Name => Name_First);
10596 Set_Etype (Exp, Discriminant_Type);
10597 Append_To (Union_TC_Params,
10598 Build_To_Any_Call (Exp, Decls));
10601 Add_Params_For_Variant_Components;
10605 -- Case of an explicit choice
10608 Exp : constant Node_Id :=
10609 New_Copy_Tree (Choice);
10611 Append_To (Union_TC_Params,
10612 Build_To_Any_Call (Exp, Decls));
10615 Add_Params_For_Variant_Components;
10619 Choice_Index := Choice_Index + 1;
10622 Next_Non_Pragma (Variant);
10626 end TC_Rec_Add_Process_Element;
10628 Type_Name_Str : String_Id;
10629 Type_Repo_Id_Str : String_Id;
10631 -- Start of processing for Build_TypeCode_Function
10634 -- The following test needs a comment ???
10636 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
10637 Build_TypeCode_Function
10639 Typ => Etype (Typ),
10648 Make_Function_Specification (Loc,
10649 Defining_Unit_Name => Fnam,
10650 Parameter_Specifications => Empty_List,
10651 Result_Definition =>
10652 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10654 Build_Name_And_Repository_Id (Typ,
10655 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10657 Initialize_Parameter_List
10658 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10660 if Has_Stream_Attribute_Definition
10661 (Typ, TSS_Stream_Output, At_Any_Place => True)
10663 Has_Stream_Attribute_Definition
10664 (Typ, TSS_Stream_Write, At_Any_Place => True)
10666 -- If user-defined stream attributes are specified for this
10667 -- type, use them and transmit data as an opaque sequence of
10668 -- stream elements.
10670 Return_Alias_TypeCode
10671 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10673 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
10674 Return_Alias_TypeCode (
10675 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10677 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10678 Return_Alias_TypeCode (
10679 Build_TypeCode_Call (Loc,
10680 Find_Numeric_Representation (Typ), Decls));
10682 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
10684 -- Record typecodes are encoded as follows:
10688 -- | [Repository Id]
10690 -- Then for each discriminant:
10692 -- | [Discriminant Type Code]
10693 -- | [Discriminant Name]
10696 -- Then for each component:
10698 -- | [Component Type Code]
10699 -- | [Component Name]
10702 -- Variants components type codes are encoded as follows:
10706 -- | [Repository Id]
10707 -- | [Discriminant Type Code]
10708 -- | [Index of Default Variant Part or -1 for no default]
10710 -- Then for each Variant Part :
10715 -- | | [Variant Part Name]
10716 -- | | [Variant Part Repository Id]
10718 -- | Then for each VP component:
10719 -- | | [VP component Typecode]
10720 -- | | [VP component Name]
10726 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10727 Return_Alias_TypeCode
10728 (Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10732 Disc : Entity_Id := Empty;
10733 Rdef : constant Node_Id :=
10734 Type_Definition (Declaration_Node (Typ));
10735 Dummy_Counter : Int := 0;
10738 -- Construct the discriminants typecodes
10740 if Has_Discriminants (Typ) then
10741 Disc := First_Discriminant (Typ);
10744 while Present (Disc) loop
10745 Add_TypeCode_Parameter (
10746 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10748 Get_Name_String (Chars (Disc));
10749 Add_String_Parameter (
10750 String_From_Name_Buffer,
10752 Next_Discriminant (Disc);
10755 -- then the components typecodes
10757 TC_Append_Record_Traversal
10758 (Parameters, Component_List (Rdef),
10759 Empty, Dummy_Counter);
10760 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10764 elsif Is_Array_Type (Typ) then
10766 Ndim : constant Pos := Number_Dimensions (Typ);
10767 Inner_TypeCode : Node_Id;
10768 Constrained : constant Boolean := Is_Constrained (Typ);
10769 Indx : Node_Id := First_Index (Typ);
10773 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls);
10775 for J in 1 .. Ndim loop
10776 if Constrained then
10777 Inner_TypeCode := Make_Constructed_TypeCode
10778 (RTE (RE_TC_Array), New_List (
10779 Build_To_Any_Call (
10780 OK_Convert_To (RTE (RE_Long_Unsigned),
10781 Make_Attribute_Reference (Loc,
10782 Prefix => New_Occurrence_Of (Typ, Loc),
10783 Attribute_Name => Name_Length,
10784 Expressions => New_List (
10785 Make_Integer_Literal (Loc,
10786 Intval => Ndim - J + 1)))),
10788 Build_To_Any_Call (Inner_TypeCode, Decls)));
10791 -- Unconstrained case: add low bound for each
10794 Add_TypeCode_Parameter
10795 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10797 Get_Name_String (New_External_Name ('L', J));
10798 Add_String_Parameter (
10799 String_From_Name_Buffer,
10803 Inner_TypeCode := Make_Constructed_TypeCode
10804 (RTE (RE_TC_Sequence), New_List (
10805 Build_To_Any_Call (
10806 OK_Convert_To (RTE (RE_Long_Unsigned),
10807 Make_Integer_Literal (Loc, 0)),
10809 Build_To_Any_Call (Inner_TypeCode, Decls)));
10813 if Constrained then
10814 Return_Alias_TypeCode (Inner_TypeCode);
10816 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10818 Store_String_Char ('V');
10819 Add_String_Parameter (End_String, Parameters);
10820 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10825 -- Default: type is represented as an opaque sequence of bytes
10827 Return_Alias_TypeCode
10828 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10832 Make_Subprogram_Body (Loc,
10833 Specification => Spec,
10834 Declarations => Decls,
10835 Handled_Statement_Sequence =>
10836 Make_Handled_Sequence_Of_Statements (Loc,
10837 Statements => Stms));
10838 end Build_TypeCode_Function;
10840 ---------------------------------
10841 -- Find_Numeric_Representation --
10842 ---------------------------------
10844 function Find_Numeric_Representation
10845 (Typ : Entity_Id) return Entity_Id
10847 FST : constant Entity_Id := First_Subtype (Typ);
10848 P_Size : constant Uint := Esize (FST);
10851 if Is_Unsigned_Type (Typ) then
10852 if P_Size <= Standard_Short_Short_Integer_Size then
10853 return RTE (RE_Short_Short_Unsigned);
10855 elsif P_Size <= Standard_Short_Integer_Size then
10856 return RTE (RE_Short_Unsigned);
10858 elsif P_Size <= Standard_Integer_Size then
10859 return RTE (RE_Unsigned);
10861 elsif P_Size <= Standard_Long_Integer_Size then
10862 return RTE (RE_Long_Unsigned);
10865 return RTE (RE_Long_Long_Unsigned);
10868 elsif Is_Integer_Type (Typ) then
10869 if P_Size <= Standard_Short_Short_Integer_Size then
10870 return Standard_Short_Short_Integer;
10872 elsif P_Size <= Standard_Short_Integer_Size then
10873 return Standard_Short_Integer;
10875 elsif P_Size <= Standard_Integer_Size then
10876 return Standard_Integer;
10878 elsif P_Size <= Standard_Long_Integer_Size then
10879 return Standard_Long_Integer;
10882 return Standard_Long_Long_Integer;
10885 elsif Is_Floating_Point_Type (Typ) then
10886 if P_Size <= Standard_Short_Float_Size then
10887 return Standard_Short_Float;
10889 elsif P_Size <= Standard_Float_Size then
10890 return Standard_Float;
10892 elsif P_Size <= Standard_Long_Float_Size then
10893 return Standard_Long_Float;
10896 return Standard_Long_Long_Float;
10900 raise Program_Error;
10903 -- TBD: fixed point types???
10904 -- TBverified numeric types with a biased representation???
10906 end Find_Numeric_Representation;
10908 ---------------------------
10909 -- Append_Array_Traversal --
10910 ---------------------------
10912 procedure Append_Array_Traversal
10915 Counter : Entity_Id := Empty;
10918 Loc : constant Source_Ptr := Sloc (Subprogram);
10919 Typ : constant Entity_Id := Etype (Arry);
10920 Constrained : constant Boolean := Is_Constrained (Typ);
10921 Ndim : constant Pos := Number_Dimensions (Typ);
10923 Inner_Any, Inner_Counter : Entity_Id;
10925 Loop_Stm : Node_Id;
10926 Inner_Stmts : constant List_Id := New_List;
10929 if Depth > Ndim then
10931 -- Processing for one element of an array
10934 Element_Expr : constant Node_Id :=
10935 Make_Indexed_Component (Loc,
10936 New_Occurrence_Of (Arry, Loc),
10939 Set_Etype (Element_Expr, Component_Type (Typ));
10940 Add_Process_Element (Stmts,
10942 Counter => Counter,
10943 Datum => Element_Expr);
10949 Append_To (Indices,
10950 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10952 if not Constrained or else Depth > 1 then
10953 Inner_Any := Make_Defining_Identifier (Loc,
10954 New_External_Name ('A', Depth));
10955 Set_Etype (Inner_Any, RTE (RE_Any));
10957 Inner_Any := Empty;
10960 if Present (Counter) then
10961 Inner_Counter := Make_Defining_Identifier (Loc,
10962 New_External_Name ('J', Depth));
10964 Inner_Counter := Empty;
10968 Loop_Any : Node_Id := Inner_Any;
10971 -- For the first dimension of a constrained array, we add
10972 -- elements directly in the corresponding Any; there is no
10973 -- intervening inner Any.
10975 if No (Loop_Any) then
10979 Append_Array_Traversal (Inner_Stmts,
10981 Counter => Inner_Counter,
10982 Depth => Depth + 1);
10986 Make_Implicit_Loop_Statement (Subprogram,
10987 Iteration_Scheme =>
10988 Make_Iteration_Scheme (Loc,
10989 Loop_Parameter_Specification =>
10990 Make_Loop_Parameter_Specification (Loc,
10991 Defining_Identifier =>
10992 Make_Defining_Identifier (Loc,
10993 Chars => New_External_Name ('L', Depth)),
10995 Discrete_Subtype_Definition =>
10996 Make_Attribute_Reference (Loc,
10997 Prefix => New_Occurrence_Of (Arry, Loc),
10998 Attribute_Name => Name_Range,
11000 Expressions => New_List (
11001 Make_Integer_Literal (Loc, Depth))))),
11002 Statements => Inner_Stmts);
11005 Decls : constant List_Id := New_List;
11006 Dimen_Stmts : constant List_Id := New_List;
11007 Length_Node : Node_Id;
11009 Inner_Any_TypeCode : constant Entity_Id :=
11010 Make_Defining_Identifier (Loc,
11011 New_External_Name ('T', Depth));
11013 Inner_Any_TypeCode_Expr : Node_Id;
11017 if Constrained then
11018 Inner_Any_TypeCode_Expr :=
11019 Make_Function_Call (Loc,
11020 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
11021 Parameter_Associations => New_List (
11022 New_Occurrence_Of (Any, Loc)));
11025 Inner_Any_TypeCode_Expr :=
11026 Make_Function_Call (Loc,
11028 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
11029 Parameter_Associations => New_List (
11030 New_Occurrence_Of (Any, Loc),
11031 Make_Integer_Literal (Loc, Ndim)));
11035 Inner_Any_TypeCode_Expr :=
11036 Make_Function_Call (Loc,
11037 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc),
11038 Parameter_Associations => New_List (
11039 Make_Identifier (Loc,
11040 Chars => New_External_Name ('T', Depth - 1))));
11044 Make_Object_Declaration (Loc,
11045 Defining_Identifier => Inner_Any_TypeCode,
11046 Constant_Present => True,
11047 Object_Definition => New_Occurrence_Of (
11048 RTE (RE_TypeCode), Loc),
11049 Expression => Inner_Any_TypeCode_Expr));
11051 if Present (Inner_Any) then
11053 Make_Object_Declaration (Loc,
11054 Defining_Identifier => Inner_Any,
11055 Object_Definition =>
11056 New_Occurrence_Of (RTE (RE_Any), Loc),
11058 Make_Function_Call (Loc,
11060 New_Occurrence_Of (
11061 RTE (RE_Create_Any), Loc),
11062 Parameter_Associations => New_List (
11063 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
11066 if Present (Inner_Counter) then
11068 Make_Object_Declaration (Loc,
11069 Defining_Identifier => Inner_Counter,
11070 Object_Definition =>
11071 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
11073 Make_Integer_Literal (Loc, 0)));
11076 if not Constrained then
11077 Length_Node := Make_Attribute_Reference (Loc,
11078 Prefix => New_Occurrence_Of (Arry, Loc),
11079 Attribute_Name => Name_Length,
11081 New_List (Make_Integer_Literal (Loc, Depth)));
11082 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
11084 Add_Process_Element (Dimen_Stmts,
11085 Datum => Length_Node,
11087 Counter => Inner_Counter);
11090 -- Loop_Stm does appropriate processing for each element
11093 Append_To (Dimen_Stmts, Loop_Stm);
11095 -- Link outer and inner any
11097 if Present (Inner_Any) then
11098 Add_Process_Element (Dimen_Stmts,
11100 Counter => Counter,
11101 Datum => New_Occurrence_Of (Inner_Any, Loc));
11105 Make_Block_Statement (Loc,
11108 Handled_Statement_Sequence =>
11109 Make_Handled_Sequence_Of_Statements (Loc,
11110 Statements => Dimen_Stmts)));
11112 end Append_Array_Traversal;
11114 -------------------------------
11115 -- Make_Helper_Function_Name --
11116 -------------------------------
11118 function Make_Helper_Function_Name
11121 Nam : Name_Id) return Entity_Id
11126 -- For tagged types, we use a canonical name so that it matches
11127 -- the primitive spec. For all other cases, we use a serialized
11128 -- name so that multiple generations of the same procedure do
11132 if not Is_Tagged_Type (Typ) then
11133 Serial := Increment_Serial_Number;
11136 -- Use prefixed underscore to avoid potential clash with used
11137 -- identifier (we use attribute names for Nam).
11140 Make_Defining_Identifier (Loc,
11143 (Related_Id => Nam,
11144 Suffix => ' ', Suffix_Index => Serial,
11147 end Make_Helper_Function_Name;
11150 -----------------------------------
11151 -- Reserve_NamingContext_Methods --
11152 -----------------------------------
11154 procedure Reserve_NamingContext_Methods is
11155 Str_Resolve : constant String := "resolve";
11157 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11158 Name_Len := Str_Resolve'Length;
11159 Overload_Counter_Table.Set (Name_Find, 1);
11160 end Reserve_NamingContext_Methods;
11162 end PolyORB_Support;
11164 -------------------------------
11165 -- RACW_Type_Is_Asynchronous --
11166 -------------------------------
11168 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11169 Asynchronous_Flag : constant Entity_Id :=
11170 Asynchronous_Flags_Table.Get (RACW_Type);
11172 Replace (Expression (Parent (Asynchronous_Flag)),
11173 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11174 end RACW_Type_Is_Asynchronous;
11176 -------------------------
11177 -- RCI_Package_Locator --
11178 -------------------------
11180 function RCI_Package_Locator
11182 Package_Spec : Node_Id) return Node_Id
11185 Pkg_Name : String_Id;
11188 Get_Library_Unit_Name_String (Package_Spec);
11189 Pkg_Name := String_From_Name_Buffer;
11191 Make_Package_Instantiation (Loc,
11192 Defining_Unit_Name =>
11193 Make_Defining_Identifier (Loc,
11194 Chars => New_Internal_Name ('R')),
11197 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11199 Generic_Associations => New_List (
11200 Make_Generic_Association (Loc,
11202 Make_Identifier (Loc, Name_RCI_Name),
11203 Explicit_Generic_Actual_Parameter =>
11204 Make_String_Literal (Loc,
11205 Strval => Pkg_Name)),
11207 Make_Generic_Association (Loc,
11209 Make_Identifier (Loc, Name_Version),
11210 Explicit_Generic_Actual_Parameter =>
11211 Make_Attribute_Reference (Loc,
11213 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11217 RCI_Locator_Table.Set
11218 (Defining_Unit_Name (Package_Spec),
11219 Defining_Unit_Name (Inst));
11221 end RCI_Package_Locator;
11223 -----------------------------------------------
11224 -- Remote_Types_Tagged_Full_View_Encountered --
11225 -----------------------------------------------
11227 procedure Remote_Types_Tagged_Full_View_Encountered
11228 (Full_View : Entity_Id)
11230 Stub_Elements : constant Stub_Structure :=
11231 Stubs_Table.Get (Full_View);
11234 -- For an RACW encountered before the freeze point of its designated
11235 -- type, the stub type is generated at the point of the RACW declaration
11236 -- but the primitives are generated only once the designated type is
11237 -- frozen. That freeze can occur in another scope, for example when the
11238 -- RACW is declared in a nested package. In that case we need to
11239 -- reestablish the stub type's scope prior to generating its primitive
11242 if Stub_Elements /= Empty_Stub_Structure then
11244 Saved_Scope : constant Entity_Id := Current_Scope;
11245 Stubs_Scope : constant Entity_Id :=
11246 Scope (Stub_Elements.Stub_Type);
11249 if Current_Scope /= Stubs_Scope then
11250 Push_Scope (Stubs_Scope);
11253 Add_RACW_Primitive_Declarations_And_Bodies
11255 Stub_Elements.RPC_Receiver_Decl,
11256 Stub_Elements.Body_Decls);
11258 if Current_Scope /= Saved_Scope then
11263 end Remote_Types_Tagged_Full_View_Encountered;
11265 -------------------
11266 -- Scope_Of_Spec --
11267 -------------------
11269 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11270 Unit_Name : Node_Id;
11273 Unit_Name := Defining_Unit_Name (Spec);
11274 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11275 Unit_Name := Defining_Identifier (Unit_Name);
11281 ----------------------
11282 -- Set_Renaming_TSS --
11283 ----------------------
11285 procedure Set_Renaming_TSS
11288 TSS_Nam : TSS_Name_Type)
11290 Loc : constant Source_Ptr := Sloc (Nam);
11291 Spec : constant Node_Id := Parent (Nam);
11293 TSS_Node : constant Node_Id :=
11294 Make_Subprogram_Renaming_Declaration (Loc,
11296 Copy_Specification (Loc,
11298 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11299 Name => New_Occurrence_Of (Nam, Loc));
11301 Snam : constant Entity_Id :=
11302 Defining_Unit_Name (Specification (TSS_Node));
11305 if Nkind (Spec) = N_Function_Specification then
11306 Set_Ekind (Snam, E_Function);
11307 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11309 Set_Ekind (Snam, E_Procedure);
11310 Set_Etype (Snam, Standard_Void_Type);
11313 Set_TSS (Typ, Snam);
11314 end Set_Renaming_TSS;
11316 ----------------------------------------------
11317 -- Specific_Add_Obj_RPC_Receiver_Completion --
11318 ----------------------------------------------
11320 procedure Specific_Add_Obj_RPC_Receiver_Completion
11323 RPC_Receiver : Entity_Id;
11324 Stub_Elements : Stub_Structure)
11327 case Get_PCS_Name is
11328 when Name_PolyORB_DSA =>
11329 PolyORB_Support.Add_Obj_RPC_Receiver_Completion
11330 (Loc, Decls, RPC_Receiver, Stub_Elements);
11332 GARLIC_Support.Add_Obj_RPC_Receiver_Completion
11333 (Loc, Decls, RPC_Receiver, Stub_Elements);
11335 end Specific_Add_Obj_RPC_Receiver_Completion;
11337 --------------------------------
11338 -- Specific_Add_RACW_Features --
11339 --------------------------------
11341 procedure Specific_Add_RACW_Features
11342 (RACW_Type : Entity_Id;
11344 Stub_Type : Entity_Id;
11345 Stub_Type_Access : Entity_Id;
11346 RPC_Receiver_Decl : Node_Id;
11347 Body_Decls : List_Id)
11350 case Get_PCS_Name is
11351 when Name_PolyORB_DSA =>
11352 PolyORB_Support.Add_RACW_Features
11361 GARLIC_Support.Add_RACW_Features
11368 end Specific_Add_RACW_Features;
11370 --------------------------------
11371 -- Specific_Add_RAST_Features --
11372 --------------------------------
11374 procedure Specific_Add_RAST_Features
11375 (Vis_Decl : Node_Id;
11376 RAS_Type : Entity_Id)
11379 case Get_PCS_Name is
11380 when Name_PolyORB_DSA =>
11381 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11383 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11385 end Specific_Add_RAST_Features;
11387 --------------------------------------------------
11388 -- Specific_Add_Receiving_Stubs_To_Declarations --
11389 --------------------------------------------------
11391 procedure Specific_Add_Receiving_Stubs_To_Declarations
11392 (Pkg_Spec : Node_Id;
11397 case Get_PCS_Name is
11398 when Name_PolyORB_DSA =>
11399 PolyORB_Support.Add_Receiving_Stubs_To_Declarations
11400 (Pkg_Spec, Decls, Stmts);
11402 GARLIC_Support.Add_Receiving_Stubs_To_Declarations
11403 (Pkg_Spec, Decls, Stmts);
11405 end Specific_Add_Receiving_Stubs_To_Declarations;
11407 ------------------------------------------
11408 -- Specific_Build_General_Calling_Stubs --
11409 ------------------------------------------
11411 procedure Specific_Build_General_Calling_Stubs
11413 Statements : List_Id;
11414 Target : RPC_Target;
11415 Subprogram_Id : Node_Id;
11416 Asynchronous : Node_Id := Empty;
11417 Is_Known_Asynchronous : Boolean := False;
11418 Is_Known_Non_Asynchronous : Boolean := False;
11419 Is_Function : Boolean;
11421 Stub_Type : Entity_Id := Empty;
11422 RACW_Type : Entity_Id := Empty;
11426 case Get_PCS_Name is
11427 when Name_PolyORB_DSA =>
11428 PolyORB_Support.Build_General_Calling_Stubs
11434 Is_Known_Asynchronous,
11435 Is_Known_Non_Asynchronous,
11443 GARLIC_Support.Build_General_Calling_Stubs
11447 Target.RPC_Receiver,
11450 Is_Known_Asynchronous,
11451 Is_Known_Non_Asynchronous,
11458 end Specific_Build_General_Calling_Stubs;
11460 --------------------------------------
11461 -- Specific_Build_RPC_Receiver_Body --
11462 --------------------------------------
11464 procedure Specific_Build_RPC_Receiver_Body
11465 (RPC_Receiver : Entity_Id;
11466 Request : out Entity_Id;
11467 Subp_Id : out Entity_Id;
11468 Subp_Index : out Entity_Id;
11469 Stmts : out List_Id;
11470 Decl : out Node_Id)
11473 case Get_PCS_Name is
11474 when Name_PolyORB_DSA =>
11475 PolyORB_Support.Build_RPC_Receiver_Body
11484 GARLIC_Support.Build_RPC_Receiver_Body
11492 end Specific_Build_RPC_Receiver_Body;
11494 --------------------------------
11495 -- Specific_Build_Stub_Target --
11496 --------------------------------
11498 function Specific_Build_Stub_Target
11501 RCI_Locator : Entity_Id;
11502 Controlling_Parameter : Entity_Id) return RPC_Target
11505 case Get_PCS_Name is
11506 when Name_PolyORB_DSA =>
11508 PolyORB_Support.Build_Stub_Target
11509 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11513 GARLIC_Support.Build_Stub_Target
11514 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11516 end Specific_Build_Stub_Target;
11518 ------------------------------
11519 -- Specific_Build_Stub_Type --
11520 ------------------------------
11522 procedure Specific_Build_Stub_Type
11523 (RACW_Type : Entity_Id;
11524 Stub_Type_Comps : out List_Id;
11525 RPC_Receiver_Decl : out Node_Id)
11528 case Get_PCS_Name is
11529 when Name_PolyORB_DSA =>
11530 PolyORB_Support.Build_Stub_Type
11531 (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
11534 GARLIC_Support.Build_Stub_Type
11535 (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
11537 end Specific_Build_Stub_Type;
11539 -----------------------------------------------
11540 -- Specific_Build_Subprogram_Receiving_Stubs --
11541 -----------------------------------------------
11543 function Specific_Build_Subprogram_Receiving_Stubs
11544 (Vis_Decl : Node_Id;
11545 Asynchronous : Boolean;
11546 Dynamically_Asynchronous : Boolean := False;
11547 Stub_Type : Entity_Id := Empty;
11548 RACW_Type : Entity_Id := Empty;
11549 Parent_Primitive : Entity_Id := Empty) return Node_Id
11552 case Get_PCS_Name is
11553 when Name_PolyORB_DSA =>
11555 PolyORB_Support.Build_Subprogram_Receiving_Stubs
11558 Dynamically_Asynchronous,
11565 GARLIC_Support.Build_Subprogram_Receiving_Stubs
11568 Dynamically_Asynchronous,
11573 end Specific_Build_Subprogram_Receiving_Stubs;
11575 -------------------------------
11576 -- Transmit_As_Unconstrained --
11577 -------------------------------
11579 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
11582 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
11583 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
11584 end Transmit_As_Unconstrained;
11586 --------------------------
11587 -- Underlying_RACW_Type --
11588 --------------------------
11590 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11591 Record_Type : Entity_Id;
11594 if Ekind (RAS_Typ) = E_Record_Type then
11595 Record_Type := RAS_Typ;
11597 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11598 Record_Type := Equivalent_Type (RAS_Typ);
11602 Etype (Subtype_Indication
11603 (Component_Definition
11604 (First (Component_Items
11607 (Declaration_Node (Record_Type))))))));
11608 end Underlying_RACW_Type;