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 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2759 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2760 Loc : constant Source_Ptr := Sloc (N);
2761 RCI_Locator : Node_Id;
2762 RCI_Cache : 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_Cache := RCI_Locator_Table.Get (RCI_Package);
2772 if RCI_Cache = Empty then
2775 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2776 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2778 -- The RCI_Locator package is inserted at the top level in the
2779 -- current unit, and must appear in the proper scope, so that it
2780 -- is not prematurely removed by the GCC back-end.
2783 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2786 if Ekind (Scop) = E_Package_Body then
2787 Push_Scope (Spec_Entity (Scop));
2789 elsif Ekind (Scop) = E_Subprogram_Body then
2791 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2797 Analyze (RCI_Locator);
2801 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2804 RCI_Locator := Parent (RCI_Cache);
2807 Calling_Stubs := Build_Subprogram_Calling_Stubs
2808 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2810 Build_Subprogram_Id (Loc, Called_Subprogram),
2811 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2813 Is_Asynchronous (Called_Subprogram),
2814 Locator => RCI_Cache,
2815 New_Name => New_Internal_Name ('S'));
2816 Insert_After (RCI_Locator, Calling_Stubs);
2817 Analyze (Calling_Stubs);
2818 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2821 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2822 end Expand_All_Calls_Remote_Subprogram_Call;
2824 ---------------------------------
2825 -- Expand_Calling_Stubs_Bodies --
2826 ---------------------------------
2828 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2829 Spec : constant Node_Id := Specification (Unit_Node);
2830 Decls : constant List_Id := Visible_Declarations (Spec);
2832 Push_Scope (Scope_Of_Spec (Spec));
2833 Add_Calling_Stubs_To_Declarations
2834 (Specification (Unit_Node), Decls);
2836 end Expand_Calling_Stubs_Bodies;
2838 -----------------------------------
2839 -- Expand_Receiving_Stubs_Bodies --
2840 -----------------------------------
2842 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2845 Stubs_Decls : List_Id;
2846 Stubs_Stmts : List_Id;
2849 if Nkind (Unit_Node) = N_Package_Declaration then
2850 Spec := Specification (Unit_Node);
2851 Decls := Private_Declarations (Spec);
2854 Decls := Visible_Declarations (Spec);
2857 Push_Scope (Scope_Of_Spec (Spec));
2858 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2862 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2863 Decls := Declarations (Unit_Node);
2865 Push_Scope (Scope_Of_Spec (Unit_Node));
2866 Stubs_Decls := New_List;
2867 Stubs_Stmts := New_List;
2868 Specific_Add_Receiving_Stubs_To_Declarations
2869 (Spec, Stubs_Decls, Stubs_Stmts);
2871 Insert_List_Before (First (Decls), Stubs_Decls);
2874 HSS_Stmts : constant List_Id :=
2875 Statements (Handled_Statement_Sequence (Unit_Node));
2877 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2880 if No (First_HSS_Stmt) then
2881 Append_List_To (HSS_Stmts, Stubs_Stmts);
2883 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2889 end Expand_Receiving_Stubs_Bodies;
2891 --------------------
2892 -- GARLIC_Support --
2893 --------------------
2895 package body GARLIC_Support is
2897 -- Local subprograms
2899 procedure Add_RACW_Read_Attribute
2900 (RACW_Type : Entity_Id;
2901 Stub_Type : Entity_Id;
2902 Stub_Type_Access : Entity_Id;
2903 Body_Decls : List_Id);
2904 -- Add Read attribute for the RACW type. The declaration and attribute
2905 -- definition clauses are inserted right after the declaration of
2906 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2907 -- appended to it (case where the RACW declaration is in the main unit).
2909 procedure Add_RACW_Write_Attribute
2910 (RACW_Type : Entity_Id;
2911 Stub_Type : Entity_Id;
2912 Stub_Type_Access : Entity_Id;
2913 RPC_Receiver : Node_Id;
2914 Body_Decls : List_Id);
2915 -- Same as above for the Write attribute
2917 function Stream_Parameter return Node_Id;
2918 function Result return Node_Id;
2919 function Object return Node_Id renames Result;
2920 -- Functions to create occurrences of the formal parameter names of the
2921 -- 'Read and 'Write attributes.
2924 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2925 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2927 procedure Add_RAS_Access_TSS (N : Node_Id);
2928 -- Add a subprogram body for RAS Access TSS
2930 -------------------------------------
2931 -- Add_Obj_RPC_Receiver_Completion --
2932 -------------------------------------
2934 procedure Add_Obj_RPC_Receiver_Completion
2937 RPC_Receiver : Entity_Id;
2938 Stub_Elements : Stub_Structure)
2941 -- The RPC receiver body should not be the completion of the
2942 -- declaration recorded in the stub structure, because then the
2943 -- occurrences of the formal parameters within the body should refer
2944 -- to the entities from the declaration, not from the completion, to
2945 -- which we do not have easy access. Instead, the RPC receiver body
2946 -- acts as its own declaration, and the RPC receiver declaration is
2947 -- completed by a renaming-as-body.
2950 Make_Subprogram_Renaming_Declaration (Loc,
2952 Copy_Specification (Loc,
2953 Specification (Stub_Elements.RPC_Receiver_Decl)),
2954 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2955 end Add_Obj_RPC_Receiver_Completion;
2957 -----------------------
2958 -- Add_RACW_Features --
2959 -----------------------
2961 procedure Add_RACW_Features
2962 (RACW_Type : Entity_Id;
2963 Stub_Type : Entity_Id;
2964 Stub_Type_Access : Entity_Id;
2965 RPC_Receiver_Decl : Node_Id;
2966 Body_Decls : List_Id)
2968 RPC_Receiver : Node_Id;
2969 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2972 Loc := Sloc (RACW_Type);
2976 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2977 -- of the corresponding distributed object type. We retrieve its
2978 -- address from the local proxy object.
2980 RPC_Receiver := Make_Selected_Component (Loc,
2982 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2983 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2986 RPC_Receiver := Make_Attribute_Reference (Loc,
2987 Prefix => New_Occurrence_Of (
2988 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2989 Attribute_Name => Name_Address);
2992 Add_RACW_Write_Attribute
2999 Add_RACW_Read_Attribute
3004 end Add_RACW_Features;
3006 -----------------------------
3007 -- Add_RACW_Read_Attribute --
3008 -----------------------------
3010 procedure Add_RACW_Read_Attribute
3011 (RACW_Type : Entity_Id;
3012 Stub_Type : Entity_Id;
3013 Stub_Type_Access : Entity_Id;
3014 Body_Decls : List_Id)
3016 Proc_Decl : Node_Id;
3017 Attr_Decl : Node_Id;
3019 Body_Node : Node_Id;
3021 Statements : constant List_Id := New_List;
3023 Local_Statements : List_Id;
3024 Remote_Statements : List_Id;
3025 -- Various parts of the procedure
3027 Pnam : constant Entity_Id :=
3028 Make_Defining_Identifier
3029 (Loc, New_Internal_Name ('R'));
3030 Asynchronous_Flag : constant Entity_Id :=
3031 Asynchronous_Flags_Table.Get (RACW_Type);
3032 pragma Assert (Present (Asynchronous_Flag));
3034 -- Prepare local identifiers
3036 Source_Partition : Entity_Id;
3037 Source_Receiver : Entity_Id;
3038 Source_Address : Entity_Id;
3039 Local_Stub : Entity_Id;
3040 Stubbed_Result : Entity_Id;
3042 -- Start of processing for Add_RACW_Read_Attribute
3045 Build_Stream_Procedure (Loc,
3046 RACW_Type, Body_Node, Pnam, Statements, Outp => True);
3047 Proc_Decl := Make_Subprogram_Declaration (Loc,
3048 Copy_Specification (Loc, Specification (Body_Node)));
3051 Make_Attribute_Definition_Clause (Loc,
3052 Name => New_Occurrence_Of (RACW_Type, Loc),
3056 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3058 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3059 Insert_After (Proc_Decl, Attr_Decl);
3061 if No (Body_Decls) then
3063 -- Case of processing an RACW type from another unit than the
3064 -- main one: do not generate a body.
3069 -- Prepare local identifiers
3072 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3074 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3076 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3078 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
3080 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3082 -- Generate object declarations
3085 Make_Object_Declaration (Loc,
3086 Defining_Identifier => Source_Partition,
3087 Object_Definition =>
3088 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
3090 Make_Object_Declaration (Loc,
3091 Defining_Identifier => Source_Receiver,
3092 Object_Definition =>
3093 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3095 Make_Object_Declaration (Loc,
3096 Defining_Identifier => Source_Address,
3097 Object_Definition =>
3098 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3100 Make_Object_Declaration (Loc,
3101 Defining_Identifier => Local_Stub,
3102 Aliased_Present => True,
3103 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
3105 Make_Object_Declaration (Loc,
3106 Defining_Identifier => Stubbed_Result,
3107 Object_Definition =>
3108 New_Occurrence_Of (Stub_Type_Access, Loc),
3110 Make_Attribute_Reference (Loc,
3112 New_Occurrence_Of (Local_Stub, Loc),
3114 Name_Unchecked_Access)));
3116 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3118 Append_List_To (Statements, New_List (
3119 Make_Attribute_Reference (Loc,
3121 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3122 Attribute_Name => Name_Read,
3123 Expressions => New_List (
3125 New_Occurrence_Of (Source_Partition, Loc))),
3127 Make_Attribute_Reference (Loc,
3129 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3132 Expressions => New_List (
3134 New_Occurrence_Of (Source_Receiver, Loc))),
3136 Make_Attribute_Reference (Loc,
3138 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3141 Expressions => New_List (
3143 New_Occurrence_Of (Source_Address, Loc)))));
3145 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3147 Set_Etype (Stubbed_Result, Stub_Type_Access);
3149 -- If the Address is Null_Address, then return a null object, unless
3150 -- RACW_Type is null-excluding, in which case unconditionally raise
3151 -- CONSTRAINT_ERROR instead.
3154 Zero_Statements : List_Id;
3155 -- Statements executed when a zero value is received
3158 if Can_Never_Be_Null (RACW_Type) then
3159 Zero_Statements := New_List (
3160 Make_Raise_Constraint_Error (Loc,
3161 Reason => CE_Null_Not_Allowed));
3163 Zero_Statements := New_List (
3164 Make_Assignment_Statement (Loc,
3166 Expression => Make_Null (Loc)),
3167 Make_Simple_Return_Statement (Loc));
3170 Append_To (Statements,
3171 Make_Implicit_If_Statement (RACW_Type,
3174 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3175 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3176 Then_Statements => Zero_Statements));
3179 -- If the RACW denotes an object created on the current partition,
3180 -- Local_Statements will be executed. The real object will be used.
3182 Local_Statements := New_List (
3183 Make_Assignment_Statement (Loc,
3186 Unchecked_Convert_To (RACW_Type,
3187 OK_Convert_To (RTE (RE_Address),
3188 New_Occurrence_Of (Source_Address, Loc)))));
3190 -- If the object is located on another partition, then a stub object
3191 -- will be created with all the information needed to rebuild the
3192 -- real object at the other end.
3194 Remote_Statements := New_List (
3196 Make_Assignment_Statement (Loc,
3197 Name => Make_Selected_Component (Loc,
3198 Prefix => Stubbed_Result,
3199 Selector_Name => Name_Origin),
3201 New_Occurrence_Of (Source_Partition, Loc)),
3203 Make_Assignment_Statement (Loc,
3204 Name => Make_Selected_Component (Loc,
3205 Prefix => Stubbed_Result,
3206 Selector_Name => Name_Receiver),
3208 New_Occurrence_Of (Source_Receiver, Loc)),
3210 Make_Assignment_Statement (Loc,
3211 Name => Make_Selected_Component (Loc,
3212 Prefix => Stubbed_Result,
3213 Selector_Name => Name_Addr),
3215 New_Occurrence_Of (Source_Address, Loc)));
3217 Append_To (Remote_Statements,
3218 Make_Assignment_Statement (Loc,
3219 Name => Make_Selected_Component (Loc,
3220 Prefix => Stubbed_Result,
3221 Selector_Name => Name_Asynchronous),
3223 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3225 Append_List_To (Remote_Statements,
3226 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3227 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3228 -- set on the stub type if, and only if, the RACW type has a pragma
3229 -- Asynchronous. This is incorrect for RACWs that implement RAS
3230 -- types, because in that case the /designated subprogram/ (not the
3231 -- type) might be asynchronous, and that causes the stub to need to
3232 -- be asynchronous too. A solution is to transport a RAS as a struct
3233 -- containing a RACW and an asynchronous flag, and to properly alter
3234 -- the Asynchronous component in the stub type in the RAS's Input
3237 Append_To (Remote_Statements,
3238 Make_Assignment_Statement (Loc,
3240 Expression => Unchecked_Convert_To (RACW_Type,
3241 New_Occurrence_Of (Stubbed_Result, Loc))));
3243 -- Distinguish between the local and remote cases, and execute the
3244 -- appropriate piece of code.
3246 Append_To (Statements,
3247 Make_Implicit_If_Statement (RACW_Type,
3251 Make_Function_Call (Loc,
3252 Name => New_Occurrence_Of (
3253 RTE (RE_Get_Local_Partition_Id), Loc)),
3254 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3255 Then_Statements => Local_Statements,
3256 Else_Statements => Remote_Statements));
3258 Set_Declarations (Body_Node, Decls);
3259 Append_To (Body_Decls, Body_Node);
3260 end Add_RACW_Read_Attribute;
3262 ------------------------------
3263 -- Add_RACW_Write_Attribute --
3264 ------------------------------
3266 procedure Add_RACW_Write_Attribute
3267 (RACW_Type : Entity_Id;
3268 Stub_Type : Entity_Id;
3269 Stub_Type_Access : Entity_Id;
3270 RPC_Receiver : Node_Id;
3271 Body_Decls : List_Id)
3273 Body_Node : Node_Id;
3274 Proc_Decl : Node_Id;
3275 Attr_Decl : Node_Id;
3277 Statements : constant List_Id := New_List;
3278 Local_Statements : List_Id;
3279 Remote_Statements : List_Id;
3280 Null_Statements : List_Id;
3282 Pnam : constant Entity_Id :=
3283 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3286 Build_Stream_Procedure
3287 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
3289 Proc_Decl := Make_Subprogram_Declaration (Loc,
3290 Copy_Specification (Loc, Specification (Body_Node)));
3293 Make_Attribute_Definition_Clause (Loc,
3294 Name => New_Occurrence_Of (RACW_Type, Loc),
3295 Chars => Name_Write,
3298 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3300 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3301 Insert_After (Proc_Decl, Attr_Decl);
3303 if No (Body_Decls) then
3307 -- Build the code fragment corresponding to the marshalling of a
3310 Local_Statements := New_List (
3312 Pack_Entity_Into_Stream_Access (Loc,
3313 Stream => Stream_Parameter,
3314 Object => RTE (RE_Get_Local_Partition_Id)),
3316 Pack_Node_Into_Stream_Access (Loc,
3317 Stream => Stream_Parameter,
3318 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3319 Etyp => RTE (RE_Unsigned_64)),
3321 Pack_Node_Into_Stream_Access (Loc,
3322 Stream => Stream_Parameter,
3323 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3324 Make_Attribute_Reference (Loc,
3326 Make_Explicit_Dereference (Loc,
3328 Attribute_Name => Name_Address)),
3329 Etyp => RTE (RE_Unsigned_64)));
3331 -- Build the code fragment corresponding to the marshalling of
3334 Remote_Statements := New_List (
3335 Pack_Node_Into_Stream_Access (Loc,
3336 Stream => Stream_Parameter,
3338 Make_Selected_Component (Loc,
3340 Unchecked_Convert_To (Stub_Type_Access, Object),
3341 Selector_Name => Make_Identifier (Loc, Name_Origin)),
3342 Etyp => RTE (RE_Partition_ID)),
3344 Pack_Node_Into_Stream_Access (Loc,
3345 Stream => Stream_Parameter,
3347 Make_Selected_Component (Loc,
3349 Unchecked_Convert_To (Stub_Type_Access, Object),
3350 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
3351 Etyp => RTE (RE_Unsigned_64)),
3353 Pack_Node_Into_Stream_Access (Loc,
3354 Stream => Stream_Parameter,
3356 Make_Selected_Component (Loc,
3358 Unchecked_Convert_To (Stub_Type_Access, Object),
3359 Selector_Name => Make_Identifier (Loc, Name_Addr)),
3360 Etyp => RTE (RE_Unsigned_64)));
3362 -- Build code fragment corresponding to marshalling of a null object
3364 Null_Statements := New_List (
3366 Pack_Entity_Into_Stream_Access (Loc,
3367 Stream => Stream_Parameter,
3368 Object => RTE (RE_Get_Local_Partition_Id)),
3370 Pack_Node_Into_Stream_Access (Loc,
3371 Stream => Stream_Parameter,
3372 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3373 Etyp => RTE (RE_Unsigned_64)),
3375 Pack_Node_Into_Stream_Access (Loc,
3376 Stream => Stream_Parameter,
3377 Object => Make_Integer_Literal (Loc, Uint_0),
3378 Etyp => RTE (RE_Unsigned_64)));
3380 Append_To (Statements,
3381 Make_Implicit_If_Statement (RACW_Type,
3384 Left_Opnd => Object,
3385 Right_Opnd => Make_Null (Loc)),
3387 Then_Statements => Null_Statements,
3389 Elsif_Parts => New_List (
3390 Make_Elsif_Part (Loc,
3394 Make_Attribute_Reference (Loc,
3396 Attribute_Name => Name_Tag),
3399 Make_Attribute_Reference (Loc,
3400 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3401 Attribute_Name => Name_Tag)),
3402 Then_Statements => Remote_Statements)),
3403 Else_Statements => Local_Statements));
3405 Append_To (Body_Decls, Body_Node);
3406 end Add_RACW_Write_Attribute;
3408 ------------------------
3409 -- Add_RAS_Access_TSS --
3410 ------------------------
3412 procedure Add_RAS_Access_TSS (N : Node_Id) is
3413 Loc : constant Source_Ptr := Sloc (N);
3415 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3416 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3417 -- Ras_Type is the access to subprogram type while Fat_Type is the
3418 -- corresponding record type.
3420 RACW_Type : constant Entity_Id :=
3421 Underlying_RACW_Type (Ras_Type);
3422 Desig : constant Entity_Id :=
3423 Etype (Designated_Type (RACW_Type));
3425 Stub_Elements : constant Stub_Structure :=
3426 Stubs_Table.Get (Desig);
3427 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3429 Proc : constant Entity_Id :=
3430 Make_Defining_Identifier (Loc,
3431 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3433 Proc_Spec : Node_Id;
3435 -- Formal parameters
3437 Package_Name : constant Entity_Id :=
3438 Make_Defining_Identifier (Loc,
3442 Subp_Id : constant Entity_Id :=
3443 Make_Defining_Identifier (Loc,
3445 -- Target subprogram
3447 Asynch_P : constant Entity_Id :=
3448 Make_Defining_Identifier (Loc,
3449 Chars => Name_Asynchronous);
3450 -- Is the procedure to which the 'Access applies asynchronous?
3452 All_Calls_Remote : constant Entity_Id :=
3453 Make_Defining_Identifier (Loc,
3454 Chars => Name_All_Calls_Remote);
3455 -- True if an All_Calls_Remote pragma applies to the RCI unit
3456 -- that contains the subprogram.
3458 -- Common local variables
3460 Proc_Decls : List_Id;
3461 Proc_Statements : List_Id;
3463 Origin : constant Entity_Id :=
3464 Make_Defining_Identifier (Loc,
3465 Chars => New_Internal_Name ('P'));
3467 -- Additional local variables for the local case
3469 Proxy_Addr : constant Entity_Id :=
3470 Make_Defining_Identifier (Loc,
3471 Chars => New_Internal_Name ('P'));
3473 -- Additional local variables for the remote case
3475 Local_Stub : constant Entity_Id :=
3476 Make_Defining_Identifier (Loc,
3477 Chars => New_Internal_Name ('L'));
3479 Stub_Ptr : constant Entity_Id :=
3480 Make_Defining_Identifier (Loc,
3481 Chars => New_Internal_Name ('S'));
3484 (Field_Name : Name_Id;
3485 Value : Node_Id) return Node_Id;
3486 -- Construct an assignment that sets the named component in the
3494 (Field_Name : Name_Id;
3495 Value : Node_Id) return Node_Id
3499 Make_Assignment_Statement (Loc,
3501 Make_Selected_Component (Loc,
3503 Selector_Name => Field_Name),
3504 Expression => Value);
3507 -- Start of processing for Add_RAS_Access_TSS
3510 Proc_Decls := New_List (
3512 -- Common declarations
3514 Make_Object_Declaration (Loc,
3515 Defining_Identifier => Origin,
3516 Constant_Present => True,
3517 Object_Definition =>
3518 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3520 Make_Function_Call (Loc,
3522 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3523 Parameter_Associations => New_List (
3524 New_Occurrence_Of (Package_Name, Loc)))),
3526 -- Declaration use only in the local case: proxy address
3528 Make_Object_Declaration (Loc,
3529 Defining_Identifier => Proxy_Addr,
3530 Object_Definition =>
3531 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3533 -- Declarations used only in the remote case: stub object and
3536 Make_Object_Declaration (Loc,
3537 Defining_Identifier => Local_Stub,
3538 Aliased_Present => True,
3539 Object_Definition =>
3540 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3542 Make_Object_Declaration (Loc,
3543 Defining_Identifier =>
3545 Object_Definition =>
3546 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3548 Make_Attribute_Reference (Loc,
3549 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3550 Attribute_Name => Name_Unchecked_Access)));
3552 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3554 -- Build_Get_Unique_RP_Call needs above information
3556 -- Note: Here we assume that the Fat_Type is a record
3557 -- containing just a pointer to a proxy or stub object.
3559 Proc_Statements := New_List (
3563 -- Get_RAS_Info (Pkg, Subp, PA);
3564 -- if Origin = Local_Partition_Id
3565 -- and then not All_Calls_Remote
3567 -- return Fat_Type!(PA);
3570 Make_Procedure_Call_Statement (Loc,
3571 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3572 Parameter_Associations => New_List (
3573 New_Occurrence_Of (Package_Name, Loc),
3574 New_Occurrence_Of (Subp_Id, Loc),
3575 New_Occurrence_Of (Proxy_Addr, Loc))),
3577 Make_Implicit_If_Statement (N,
3583 New_Occurrence_Of (Origin, Loc),
3585 Make_Function_Call (Loc,
3587 RTE (RE_Get_Local_Partition_Id), Loc))),
3591 New_Occurrence_Of (All_Calls_Remote, Loc))),
3593 Then_Statements => New_List (
3594 Make_Simple_Return_Statement (Loc,
3595 Unchecked_Convert_To (Fat_Type,
3596 OK_Convert_To (RTE (RE_Address),
3597 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3599 Set_Field (Name_Origin,
3600 New_Occurrence_Of (Origin, Loc)),
3602 Set_Field (Name_Receiver,
3603 Make_Function_Call (Loc,
3605 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3606 Parameter_Associations => New_List (
3607 New_Occurrence_Of (Package_Name, Loc)))),
3609 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3611 -- E.4.1(9) A remote call is asynchronous if it is a call to
3612 -- a procedure or a call through a value of an access-to-procedure
3613 -- type to which a pragma Asynchronous applies.
3615 -- Asynch_P is true when the procedure is asynchronous;
3616 -- Asynch_T is true when the type is asynchronous.
3618 Set_Field (Name_Asynchronous,
3620 New_Occurrence_Of (Asynch_P, Loc),
3621 New_Occurrence_Of (Boolean_Literals (
3622 Is_Asynchronous (Ras_Type)), Loc))));
3624 Append_List_To (Proc_Statements,
3625 Build_Get_Unique_RP_Call
3626 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3628 -- Return the newly created value
3630 Append_To (Proc_Statements,
3631 Make_Simple_Return_Statement (Loc,
3633 Unchecked_Convert_To (Fat_Type,
3634 New_Occurrence_Of (Stub_Ptr, Loc))));
3637 Make_Function_Specification (Loc,
3638 Defining_Unit_Name => Proc,
3639 Parameter_Specifications => New_List (
3640 Make_Parameter_Specification (Loc,
3641 Defining_Identifier => Package_Name,
3643 New_Occurrence_Of (Standard_String, Loc)),
3645 Make_Parameter_Specification (Loc,
3646 Defining_Identifier => Subp_Id,
3648 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3650 Make_Parameter_Specification (Loc,
3651 Defining_Identifier => Asynch_P,
3653 New_Occurrence_Of (Standard_Boolean, Loc)),
3655 Make_Parameter_Specification (Loc,
3656 Defining_Identifier => All_Calls_Remote,
3658 New_Occurrence_Of (Standard_Boolean, Loc))),
3660 Result_Definition =>
3661 New_Occurrence_Of (Fat_Type, Loc));
3663 -- Set the kind and return type of the function to prevent
3664 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3666 Set_Ekind (Proc, E_Function);
3667 Set_Etype (Proc, Fat_Type);
3670 Make_Subprogram_Body (Loc,
3671 Specification => Proc_Spec,
3672 Declarations => Proc_Decls,
3673 Handled_Statement_Sequence =>
3674 Make_Handled_Sequence_Of_Statements (Loc,
3675 Statements => Proc_Statements)));
3677 Set_TSS (Fat_Type, Proc);
3678 end Add_RAS_Access_TSS;
3680 -----------------------
3681 -- Add_RAST_Features --
3682 -----------------------
3684 procedure Add_RAST_Features
3685 (Vis_Decl : Node_Id;
3686 RAS_Type : Entity_Id)
3688 pragma Unreferenced (RAS_Type);
3690 Add_RAS_Access_TSS (Vis_Decl);
3691 end Add_RAST_Features;
3693 -----------------------------------------
3694 -- Add_Receiving_Stubs_To_Declarations --
3695 -----------------------------------------
3697 procedure Add_Receiving_Stubs_To_Declarations
3698 (Pkg_Spec : Node_Id;
3702 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3704 Request_Parameter : Node_Id;
3706 Pkg_RPC_Receiver : constant Entity_Id :=
3707 Make_Defining_Identifier (Loc,
3708 New_Internal_Name ('H'));
3709 Pkg_RPC_Receiver_Statements : List_Id;
3710 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3711 Pkg_RPC_Receiver_Body : Node_Id;
3712 -- A Pkg_RPC_Receiver is built to decode the request
3714 Lookup_RAS_Info : constant Entity_Id :=
3715 Make_Defining_Identifier (Loc,
3716 Chars => New_Internal_Name ('R'));
3717 -- A remote subprogram is created to allow peers to look up
3718 -- RAS information using subprogram ids.
3720 Subp_Id : Entity_Id;
3721 Subp_Index : Entity_Id;
3722 -- Subprogram_Id as read from the incoming stream
3724 Current_Declaration : Node_Id;
3725 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3726 Current_Stubs : Node_Id;
3728 Subp_Info_Array : constant Entity_Id :=
3729 Make_Defining_Identifier (Loc,
3730 Chars => New_Internal_Name ('I'));
3732 Subp_Info_List : constant List_Id := New_List;
3734 Register_Pkg_Actuals : constant List_Id := New_List;
3736 All_Calls_Remote_E : Entity_Id;
3737 Proxy_Object_Addr : Entity_Id;
3739 procedure Append_Stubs_To
3740 (RPC_Receiver_Cases : List_Id;
3742 Subprogram_Number : Int);
3743 -- Add one case to the specified RPC receiver case list
3744 -- associating Subprogram_Number with the subprogram declared
3745 -- by Declaration, for which we have receiving stubs in Stubs.
3747 ---------------------
3748 -- Append_Stubs_To --
3749 ---------------------
3751 procedure Append_Stubs_To
3752 (RPC_Receiver_Cases : List_Id;
3754 Subprogram_Number : Int)
3757 Append_To (RPC_Receiver_Cases,
3758 Make_Case_Statement_Alternative (Loc,
3760 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3763 Make_Procedure_Call_Statement (Loc,
3765 New_Occurrence_Of (Defining_Entity (Stubs), Loc),
3766 Parameter_Associations => New_List (
3767 New_Occurrence_Of (Request_Parameter, Loc))))));
3768 end Append_Stubs_To;
3770 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3773 -- Building receiving stubs consist in several operations:
3775 -- - a package RPC receiver must be built. This subprogram
3776 -- will get a Subprogram_Id from the incoming stream
3777 -- and will dispatch the call to the right subprogram;
3779 -- - a receiving stub for each subprogram visible in the package
3780 -- spec. This stub will read all the parameters from the stream,
3781 -- and put the result as well as the exception occurrence in the
3784 -- - a dummy package with an empty spec and a body made of an
3785 -- elaboration part, whose job is to register the receiving
3786 -- part of this RCI package on the name server. This is done
3787 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3789 Build_RPC_Receiver_Body (
3790 RPC_Receiver => Pkg_RPC_Receiver,
3791 Request => Request_Parameter,
3793 Subp_Index => Subp_Index,
3794 Stmts => Pkg_RPC_Receiver_Statements,
3795 Decl => Pkg_RPC_Receiver_Body);
3796 pragma Assert (Subp_Id = Subp_Index);
3798 -- A null subp_id denotes a call through a RAS, in which case the
3799 -- next Uint_64 element in the stream is the address of the local
3800 -- proxy object, from which we can retrieve the actual subprogram id.
3802 Append_To (Pkg_RPC_Receiver_Statements,
3803 Make_Implicit_If_Statement (Pkg_Spec,
3806 New_Occurrence_Of (Subp_Id, Loc),
3807 Make_Integer_Literal (Loc, 0)),
3809 Then_Statements => New_List (
3810 Make_Assignment_Statement (Loc,
3812 New_Occurrence_Of (Subp_Id, Loc),
3815 Make_Selected_Component (Loc,
3817 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3818 OK_Convert_To (RTE (RE_Address),
3819 Make_Attribute_Reference (Loc,
3821 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3824 Expressions => New_List (
3825 Make_Selected_Component (Loc,
3826 Prefix => Request_Parameter,
3827 Selector_Name => Name_Params))))),
3830 Make_Identifier (Loc, Name_Subp_Id))))));
3832 -- Build a subprogram for RAS information lookups
3834 Current_Declaration :=
3835 Make_Subprogram_Declaration (Loc,
3837 Make_Function_Specification (Loc,
3838 Defining_Unit_Name =>
3840 Parameter_Specifications => New_List (
3841 Make_Parameter_Specification (Loc,
3842 Defining_Identifier =>
3843 Make_Defining_Identifier (Loc, Name_Subp_Id),
3847 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3848 Result_Definition =>
3849 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3851 Append_To (Decls, Current_Declaration);
3852 Analyze (Current_Declaration);
3854 Current_Stubs := Build_Subprogram_Receiving_Stubs
3855 (Vis_Decl => Current_Declaration,
3856 Asynchronous => False);
3857 Append_To (Decls, Current_Stubs);
3858 Analyze (Current_Stubs);
3860 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3863 Subprogram_Number => 1);
3865 -- For each subprogram, the receiving stub will be built and a
3866 -- case statement will be made on the Subprogram_Id to dispatch
3867 -- to the right subprogram.
3869 All_Calls_Remote_E :=
3871 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3873 Overload_Counter_Table.Reset;
3875 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3876 while Present (Current_Declaration) loop
3877 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3878 and then Comes_From_Source (Current_Declaration)
3881 Loc : constant Source_Ptr := Sloc (Current_Declaration);
3882 -- While specifically processing Current_Declaration, use
3883 -- its Sloc as the location of all generated nodes.
3885 Subp_Def : constant Entity_Id :=
3887 (Specification (Current_Declaration));
3889 Subp_Val : String_Id;
3890 pragma Warnings (Off, Subp_Val);
3893 -- Build receiving stub
3896 Build_Subprogram_Receiving_Stubs
3897 (Vis_Decl => Current_Declaration,
3899 Nkind (Specification (Current_Declaration)) =
3900 N_Procedure_Specification
3901 and then Is_Asynchronous (Subp_Def));
3903 Append_To (Decls, Current_Stubs);
3904 Analyze (Current_Stubs);
3908 Add_RAS_Proxy_And_Analyze (Decls,
3909 Vis_Decl => Current_Declaration,
3910 All_Calls_Remote_E => All_Calls_Remote_E,
3911 Proxy_Object_Addr => Proxy_Object_Addr);
3913 -- Compute distribution identifier
3915 Assign_Subprogram_Identifier
3917 Current_Subprogram_Number,
3921 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
3923 -- Add subprogram descriptor (RCI_Subp_Info) to the
3924 -- subprograms table for this receiver. The aggregate
3925 -- below must be kept consistent with the declaration
3926 -- of type RCI_Subp_Info in System.Partition_Interface.
3928 Append_To (Subp_Info_List,
3929 Make_Component_Association (Loc,
3930 Choices => New_List (
3931 Make_Integer_Literal (Loc,
3932 Current_Subprogram_Number)),
3935 Make_Aggregate (Loc,
3936 Component_Associations => New_List (
3937 Make_Component_Association (Loc,
3938 Choices => New_List (
3939 Make_Identifier (Loc, Name_Addr)),
3942 Proxy_Object_Addr, Loc))))));
3944 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3945 Stubs => Current_Stubs,
3946 Subprogram_Number => Current_Subprogram_Number);
3949 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3952 Next (Current_Declaration);
3955 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3956 -- rather than raising an exception since we do not want someone
3957 -- to crash a remote partition by sending invalid subprogram ids.
3958 -- This is consistent with the other parts of the case statement
3959 -- since even in presence of incorrect parameters in the stream,
3960 -- every exception will be caught and (if the subprogram is not an
3961 -- APC) put into the result stream and sent away.
3963 Append_To (Pkg_RPC_Receiver_Cases,
3964 Make_Case_Statement_Alternative (Loc,
3965 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
3966 Statements => New_List (Make_Null_Statement (Loc))));
3968 Append_To (Pkg_RPC_Receiver_Statements,
3969 Make_Case_Statement (Loc,
3970 Expression => New_Occurrence_Of (Subp_Id, Loc),
3971 Alternatives => Pkg_RPC_Receiver_Cases));
3974 Make_Object_Declaration (Loc,
3975 Defining_Identifier => Subp_Info_Array,
3976 Constant_Present => True,
3977 Aliased_Present => True,
3978 Object_Definition =>
3979 Make_Subtype_Indication (Loc,
3981 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3983 Make_Index_Or_Discriminant_Constraint (Loc,
3986 Low_Bound => Make_Integer_Literal (Loc,
3987 First_RCI_Subprogram_Id),
3989 Make_Integer_Literal (Loc,
3991 First_RCI_Subprogram_Id
3992 + List_Length (Subp_Info_List) - 1)))))));
3994 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3995 -- has zero length, and the declaration is for an empty array, in
3996 -- which case no initialization aggregate must be generated.
3998 if Present (First (Subp_Info_List)) then
3999 Set_Expression (Last (Decls),
4000 Make_Aggregate (Loc,
4001 Component_Associations => Subp_Info_List));
4003 -- No initialization provided: remove CONSTANT so that the
4004 -- declaration is not an incomplete deferred constant.
4007 Set_Constant_Present (Last (Decls), False);
4010 Analyze (Last (Decls));
4013 Subp_Info_Addr : Node_Id;
4014 -- Return statement for Lookup_RAS_Info: address of the subprogram
4015 -- information record for the requested subprogram id.
4018 if Present (First (Subp_Info_List)) then
4020 Make_Selected_Component (Loc,
4022 Make_Indexed_Component (Loc,
4023 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4024 Expressions => New_List (
4025 Convert_To (Standard_Integer,
4026 Make_Identifier (Loc, Name_Subp_Id)))),
4027 Selector_Name => Make_Identifier (Loc, Name_Addr));
4029 -- Case of no visible subprogram: just raise Constraint_Error, we
4030 -- know for sure we got junk from a remote partition.
4034 Make_Raise_Constraint_Error (Loc,
4035 Reason => CE_Range_Check_Failed);
4036 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
4040 Make_Subprogram_Body (Loc,
4042 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
4043 Declarations => No_List,
4044 Handled_Statement_Sequence =>
4045 Make_Handled_Sequence_Of_Statements (Loc,
4046 Statements => New_List (
4047 Make_Simple_Return_Statement (Loc,
4050 (RTE (RE_Unsigned_64), Subp_Info_Addr))))));
4053 Analyze (Last (Decls));
4055 Append_To (Decls, Pkg_RPC_Receiver_Body);
4056 Analyze (Last (Decls));
4058 Get_Library_Unit_Name_String (Pkg_Spec);
4062 Append_To (Register_Pkg_Actuals,
4063 Make_String_Literal (Loc,
4064 Strval => String_From_Name_Buffer));
4068 Append_To (Register_Pkg_Actuals,
4069 Make_Attribute_Reference (Loc,
4070 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
4071 Attribute_Name => Name_Unrestricted_Access));
4075 Append_To (Register_Pkg_Actuals,
4076 Make_Attribute_Reference (Loc,
4078 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
4079 Attribute_Name => Name_Version));
4083 Append_To (Register_Pkg_Actuals,
4084 Make_Attribute_Reference (Loc,
4085 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4086 Attribute_Name => Name_Address));
4090 Append_To (Register_Pkg_Actuals,
4091 Make_Attribute_Reference (Loc,
4092 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4093 Attribute_Name => Name_Length));
4095 -- Generate the call
4098 Make_Procedure_Call_Statement (Loc,
4100 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
4101 Parameter_Associations => Register_Pkg_Actuals));
4102 Analyze (Last (Stmts));
4103 end Add_Receiving_Stubs_To_Declarations;
4105 ---------------------------------
4106 -- Build_General_Calling_Stubs --
4107 ---------------------------------
4109 procedure Build_General_Calling_Stubs
4111 Statements : List_Id;
4112 Target_Partition : Entity_Id;
4113 Target_RPC_Receiver : Node_Id;
4114 Subprogram_Id : Node_Id;
4115 Asynchronous : Node_Id := Empty;
4116 Is_Known_Asynchronous : Boolean := False;
4117 Is_Known_Non_Asynchronous : Boolean := False;
4118 Is_Function : Boolean;
4120 Stub_Type : Entity_Id := Empty;
4121 RACW_Type : Entity_Id := Empty;
4124 Loc : constant Source_Ptr := Sloc (Nod);
4126 Stream_Parameter : Node_Id;
4127 -- Name of the stream used to transmit parameters to the remote
4130 Result_Parameter : Node_Id;
4131 -- Name of the result parameter (in non-APC cases) which get the
4132 -- result of the remote subprogram.
4134 Exception_Return_Parameter : Node_Id;
4135 -- Name of the parameter which will hold the exception sent by the
4136 -- remote subprogram.
4138 Current_Parameter : Node_Id;
4139 -- Current parameter being handled
4141 Ordered_Parameters_List : constant List_Id :=
4142 Build_Ordered_Parameters_List (Spec);
4144 Asynchronous_Statements : List_Id := No_List;
4145 Non_Asynchronous_Statements : List_Id := No_List;
4146 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4148 Extra_Formal_Statements : constant List_Id := New_List;
4149 -- List of statements for extra formal parameters. It will appear
4150 -- after the regular statements for writing out parameters.
4152 pragma Unreferenced (RACW_Type);
4153 -- Used only for the PolyORB case
4156 -- The general form of a calling stub for a given subprogram is:
4158 -- procedure X (...) is P : constant Partition_ID :=
4159 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4160 -- System.RPC.Params_Stream_Type (0); begin
4161 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4162 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4163 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4164 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4166 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4168 -- There are some variations: Do_APC is called for an asynchronous
4169 -- procedure and the part after the call is completely ommitted as
4170 -- well as the declaration of Result. For a function call, 'Input is
4171 -- always used to read the result even if it is constrained.
4174 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4177 Make_Object_Declaration (Loc,
4178 Defining_Identifier => Stream_Parameter,
4179 Aliased_Present => True,
4180 Object_Definition =>
4181 Make_Subtype_Indication (Loc,
4183 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4185 Make_Index_Or_Discriminant_Constraint (Loc,
4187 New_List (Make_Integer_Literal (Loc, 0))))));
4189 if not Is_Known_Asynchronous then
4191 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4194 Make_Object_Declaration (Loc,
4195 Defining_Identifier => Result_Parameter,
4196 Aliased_Present => True,
4197 Object_Definition =>
4198 Make_Subtype_Indication (Loc,
4200 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4202 Make_Index_Or_Discriminant_Constraint (Loc,
4204 New_List (Make_Integer_Literal (Loc, 0))))));
4206 Exception_Return_Parameter :=
4207 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4210 Make_Object_Declaration (Loc,
4211 Defining_Identifier => Exception_Return_Parameter,
4212 Object_Definition =>
4213 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4216 Result_Parameter := Empty;
4217 Exception_Return_Parameter := Empty;
4220 -- Put first the RPC receiver corresponding to the remote package
4222 Append_To (Statements,
4223 Make_Attribute_Reference (Loc,
4225 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4226 Attribute_Name => Name_Write,
4227 Expressions => New_List (
4228 Make_Attribute_Reference (Loc,
4229 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4230 Attribute_Name => Name_Access),
4231 Target_RPC_Receiver)));
4233 -- Then put the Subprogram_Id of the subprogram we want to call in
4236 Append_To (Statements,
4237 Make_Attribute_Reference (Loc,
4238 Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4239 Attribute_Name => Name_Write,
4240 Expressions => New_List (
4241 Make_Attribute_Reference (Loc,
4242 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4243 Attribute_Name => Name_Access),
4246 Current_Parameter := First (Ordered_Parameters_List);
4247 while Present (Current_Parameter) loop
4249 Typ : constant Node_Id :=
4250 Parameter_Type (Current_Parameter);
4252 Constrained : Boolean;
4254 Extra_Parameter : Entity_Id;
4257 if Is_RACW_Controlling_Formal
4258 (Current_Parameter, Stub_Type)
4260 -- In the case of a controlling formal argument, we marshall
4261 -- its addr field rather than the local stub.
4263 Append_To (Statements,
4264 Pack_Node_Into_Stream (Loc,
4265 Stream => Stream_Parameter,
4267 Make_Selected_Component (Loc,
4269 Defining_Identifier (Current_Parameter),
4270 Selector_Name => Name_Addr),
4271 Etyp => RTE (RE_Unsigned_64)));
4276 (Defining_Identifier (Current_Parameter), Loc);
4278 -- Access type parameters are transmitted as in out
4279 -- parameters. However, a dereference is needed so that
4280 -- we marshall the designated object.
4282 if Nkind (Typ) = N_Access_Definition then
4283 Value := Make_Explicit_Dereference (Loc, Value);
4284 Etyp := Etype (Subtype_Mark (Typ));
4286 Etyp := Etype (Typ);
4289 Constrained := not Transmit_As_Unconstrained (Etyp);
4291 -- Any parameter but unconstrained out parameters are
4292 -- transmitted to the peer.
4294 if In_Present (Current_Parameter)
4295 or else not Out_Present (Current_Parameter)
4296 or else not Constrained
4298 Append_To (Statements,
4299 Make_Attribute_Reference (Loc,
4300 Prefix => New_Occurrence_Of (Etyp, Loc),
4302 Output_From_Constrained (Constrained),
4303 Expressions => New_List (
4304 Make_Attribute_Reference (Loc,
4306 New_Occurrence_Of (Stream_Parameter, Loc),
4307 Attribute_Name => Name_Access),
4312 -- If the current parameter has a dynamic constrained status,
4313 -- then this status is transmitted as well.
4314 -- This should be done for accessibility as well ???
4316 if Nkind (Typ) /= N_Access_Definition
4317 and then Need_Extra_Constrained (Current_Parameter)
4319 -- In this block, we do not use the extra formal that has
4320 -- been created because it does not exist at the time of
4321 -- expansion when building calling stubs for remote access
4322 -- to subprogram types. We create an extra variable of this
4323 -- type and push it in the stream after the regular
4326 Extra_Parameter := Make_Defining_Identifier
4327 (Loc, New_Internal_Name ('P'));
4330 Make_Object_Declaration (Loc,
4331 Defining_Identifier => Extra_Parameter,
4332 Constant_Present => True,
4333 Object_Definition =>
4334 New_Occurrence_Of (Standard_Boolean, Loc),
4336 Make_Attribute_Reference (Loc,
4339 Defining_Identifier (Current_Parameter), Loc),
4340 Attribute_Name => Name_Constrained)));
4342 Append_To (Extra_Formal_Statements,
4343 Make_Attribute_Reference (Loc,
4345 New_Occurrence_Of (Standard_Boolean, Loc),
4346 Attribute_Name => Name_Write,
4347 Expressions => New_List (
4348 Make_Attribute_Reference (Loc,
4351 (Stream_Parameter, Loc), Attribute_Name =>
4353 New_Occurrence_Of (Extra_Parameter, Loc))));
4356 Next (Current_Parameter);
4360 -- Append the formal statements list to the statements
4362 Append_List_To (Statements, Extra_Formal_Statements);
4364 if not Is_Known_Non_Asynchronous then
4366 -- Build the call to System.RPC.Do_APC
4368 Asynchronous_Statements := New_List (
4369 Make_Procedure_Call_Statement (Loc,
4371 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4372 Parameter_Associations => New_List (
4373 New_Occurrence_Of (Target_Partition, Loc),
4374 Make_Attribute_Reference (Loc,
4376 New_Occurrence_Of (Stream_Parameter, Loc),
4377 Attribute_Name => Name_Access))));
4379 Asynchronous_Statements := No_List;
4382 if not Is_Known_Asynchronous then
4384 -- Build the call to System.RPC.Do_RPC
4386 Non_Asynchronous_Statements := New_List (
4387 Make_Procedure_Call_Statement (Loc,
4389 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4390 Parameter_Associations => New_List (
4391 New_Occurrence_Of (Target_Partition, Loc),
4393 Make_Attribute_Reference (Loc,
4395 New_Occurrence_Of (Stream_Parameter, Loc),
4396 Attribute_Name => Name_Access),
4398 Make_Attribute_Reference (Loc,
4400 New_Occurrence_Of (Result_Parameter, Loc),
4401 Attribute_Name => Name_Access))));
4403 -- Read the exception occurrence from the result stream and
4404 -- reraise it. It does no harm if this is a Null_Occurrence since
4405 -- this does nothing.
4407 Append_To (Non_Asynchronous_Statements,
4408 Make_Attribute_Reference (Loc,
4410 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4412 Attribute_Name => Name_Read,
4414 Expressions => New_List (
4415 Make_Attribute_Reference (Loc,
4417 New_Occurrence_Of (Result_Parameter, Loc),
4418 Attribute_Name => Name_Access),
4419 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4421 Append_To (Non_Asynchronous_Statements,
4422 Make_Procedure_Call_Statement (Loc,
4424 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4425 Parameter_Associations => New_List (
4426 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4430 -- If this is a function call, then read the value and return
4431 -- it. The return value is written/read using 'Output/'Input.
4433 Append_To (Non_Asynchronous_Statements,
4434 Make_Tag_Check (Loc,
4435 Make_Simple_Return_Statement (Loc,
4437 Make_Attribute_Reference (Loc,
4440 Etype (Result_Definition (Spec)), Loc),
4442 Attribute_Name => Name_Input,
4444 Expressions => New_List (
4445 Make_Attribute_Reference (Loc,
4447 New_Occurrence_Of (Result_Parameter, Loc),
4448 Attribute_Name => Name_Access))))));
4451 -- Loop around parameters and assign out (or in out)
4452 -- parameters. In the case of RACW, controlling arguments
4453 -- cannot possibly have changed since they are remote, so
4454 -- we do not read them from the stream.
4456 Current_Parameter := First (Ordered_Parameters_List);
4457 while Present (Current_Parameter) loop
4459 Typ : constant Node_Id :=
4460 Parameter_Type (Current_Parameter);
4467 (Defining_Identifier (Current_Parameter), Loc);
4469 if Nkind (Typ) = N_Access_Definition then
4470 Value := Make_Explicit_Dereference (Loc, Value);
4471 Etyp := Etype (Subtype_Mark (Typ));
4473 Etyp := Etype (Typ);
4476 if (Out_Present (Current_Parameter)
4477 or else Nkind (Typ) = N_Access_Definition)
4478 and then Etyp /= Stub_Type
4480 Append_To (Non_Asynchronous_Statements,
4481 Make_Attribute_Reference (Loc,
4483 New_Occurrence_Of (Etyp, Loc),
4485 Attribute_Name => Name_Read,
4487 Expressions => New_List (
4488 Make_Attribute_Reference (Loc,
4490 New_Occurrence_Of (Result_Parameter, Loc),
4491 Attribute_Name => Name_Access),
4496 Next (Current_Parameter);
4501 if Is_Known_Asynchronous then
4502 Append_List_To (Statements, Asynchronous_Statements);
4504 elsif Is_Known_Non_Asynchronous then
4505 Append_List_To (Statements, Non_Asynchronous_Statements);
4508 pragma Assert (Present (Asynchronous));
4509 Prepend_To (Asynchronous_Statements,
4510 Make_Attribute_Reference (Loc,
4511 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4512 Attribute_Name => Name_Write,
4513 Expressions => New_List (
4514 Make_Attribute_Reference (Loc,
4516 New_Occurrence_Of (Stream_Parameter, Loc),
4517 Attribute_Name => Name_Access),
4518 New_Occurrence_Of (Standard_True, Loc))));
4520 Prepend_To (Non_Asynchronous_Statements,
4521 Make_Attribute_Reference (Loc,
4522 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4523 Attribute_Name => Name_Write,
4524 Expressions => New_List (
4525 Make_Attribute_Reference (Loc,
4527 New_Occurrence_Of (Stream_Parameter, Loc),
4528 Attribute_Name => Name_Access),
4529 New_Occurrence_Of (Standard_False, Loc))));
4531 Append_To (Statements,
4532 Make_Implicit_If_Statement (Nod,
4533 Condition => Asynchronous,
4534 Then_Statements => Asynchronous_Statements,
4535 Else_Statements => Non_Asynchronous_Statements));
4537 end Build_General_Calling_Stubs;
4539 -----------------------------
4540 -- Build_RPC_Receiver_Body --
4541 -----------------------------
4543 procedure Build_RPC_Receiver_Body
4544 (RPC_Receiver : Entity_Id;
4545 Request : out Entity_Id;
4546 Subp_Id : out Entity_Id;
4547 Subp_Index : out Entity_Id;
4548 Stmts : out List_Id;
4551 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4553 RPC_Receiver_Spec : Node_Id;
4554 RPC_Receiver_Decls : List_Id;
4557 Request := Make_Defining_Identifier (Loc, Name_R);
4559 RPC_Receiver_Spec :=
4560 Build_RPC_Receiver_Specification
4561 (RPC_Receiver => RPC_Receiver,
4562 Request_Parameter => Request);
4564 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4565 Subp_Index := Subp_Id;
4567 -- Subp_Id may not be a constant, because in the case of the RPC
4568 -- receiver for an RCI package, when a call is received from a RAS
4569 -- dereference, it will be assigned during subsequent processing.
4571 RPC_Receiver_Decls := New_List (
4572 Make_Object_Declaration (Loc,
4573 Defining_Identifier => Subp_Id,
4574 Object_Definition =>
4575 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4577 Make_Attribute_Reference (Loc,
4579 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4580 Attribute_Name => Name_Input,
4581 Expressions => New_List (
4582 Make_Selected_Component (Loc,
4584 Selector_Name => Name_Params)))));
4589 Make_Subprogram_Body (Loc,
4590 Specification => RPC_Receiver_Spec,
4591 Declarations => RPC_Receiver_Decls,
4592 Handled_Statement_Sequence =>
4593 Make_Handled_Sequence_Of_Statements (Loc,
4594 Statements => Stmts));
4595 end Build_RPC_Receiver_Body;
4597 -----------------------
4598 -- Build_Stub_Target --
4599 -----------------------
4601 function Build_Stub_Target
4604 RCI_Locator : Entity_Id;
4605 Controlling_Parameter : Entity_Id) return RPC_Target
4607 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4609 Target_Info.Partition :=
4610 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4611 if Present (Controlling_Parameter) then
4613 Make_Object_Declaration (Loc,
4614 Defining_Identifier => Target_Info.Partition,
4615 Constant_Present => True,
4616 Object_Definition =>
4617 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4620 Make_Selected_Component (Loc,
4621 Prefix => Controlling_Parameter,
4622 Selector_Name => Name_Origin)));
4624 Target_Info.RPC_Receiver :=
4625 Make_Selected_Component (Loc,
4626 Prefix => Controlling_Parameter,
4627 Selector_Name => Name_Receiver);
4631 Make_Object_Declaration (Loc,
4632 Defining_Identifier => Target_Info.Partition,
4633 Constant_Present => True,
4634 Object_Definition =>
4635 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4638 Make_Function_Call (Loc,
4639 Name => Make_Selected_Component (Loc,
4641 Make_Identifier (Loc, Chars (RCI_Locator)),
4643 Make_Identifier (Loc,
4644 Name_Get_Active_Partition_ID)))));
4646 Target_Info.RPC_Receiver :=
4647 Make_Selected_Component (Loc,
4649 Make_Identifier (Loc, Chars (RCI_Locator)),
4651 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4654 end Build_Stub_Target;
4656 ---------------------
4657 -- Build_Stub_Type --
4658 ---------------------
4660 procedure Build_Stub_Type
4661 (RACW_Type : Entity_Id;
4662 Stub_Type_Comps : out List_Id;
4663 RPC_Receiver_Decl : out Node_Id)
4665 Loc : constant Source_Ptr := Sloc (RACW_Type);
4666 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4669 Stub_Type_Comps := New_List (
4670 Make_Component_Declaration (Loc,
4671 Defining_Identifier =>
4672 Make_Defining_Identifier (Loc, Name_Origin),
4673 Component_Definition =>
4674 Make_Component_Definition (Loc,
4675 Aliased_Present => False,
4676 Subtype_Indication =>
4677 New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
4679 Make_Component_Declaration (Loc,
4680 Defining_Identifier =>
4681 Make_Defining_Identifier (Loc, Name_Receiver),
4682 Component_Definition =>
4683 Make_Component_Definition (Loc,
4684 Aliased_Present => False,
4685 Subtype_Indication =>
4686 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4688 Make_Component_Declaration (Loc,
4689 Defining_Identifier =>
4690 Make_Defining_Identifier (Loc, Name_Addr),
4691 Component_Definition =>
4692 Make_Component_Definition (Loc,
4693 Aliased_Present => False,
4694 Subtype_Indication =>
4695 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4697 Make_Component_Declaration (Loc,
4698 Defining_Identifier =>
4699 Make_Defining_Identifier (Loc, Name_Asynchronous),
4700 Component_Definition =>
4701 Make_Component_Definition (Loc,
4702 Aliased_Present => False,
4703 Subtype_Indication =>
4704 New_Occurrence_Of (Standard_Boolean, Loc))));
4707 RPC_Receiver_Decl := Empty;
4710 RPC_Receiver_Request : constant Entity_Id :=
4711 Make_Defining_Identifier (Loc, Name_R);
4713 RPC_Receiver_Decl :=
4714 Make_Subprogram_Declaration (Loc,
4715 Build_RPC_Receiver_Specification (
4716 RPC_Receiver => Make_Defining_Identifier (Loc,
4717 New_Internal_Name ('R')),
4718 Request_Parameter => RPC_Receiver_Request));
4721 end Build_Stub_Type;
4723 --------------------------------------
4724 -- Build_Subprogram_Receiving_Stubs --
4725 --------------------------------------
4727 function Build_Subprogram_Receiving_Stubs
4728 (Vis_Decl : Node_Id;
4729 Asynchronous : Boolean;
4730 Dynamically_Asynchronous : Boolean := False;
4731 Stub_Type : Entity_Id := Empty;
4732 RACW_Type : Entity_Id := Empty;
4733 Parent_Primitive : Entity_Id := Empty) return Node_Id
4735 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4737 Request_Parameter : constant Entity_Id :=
4738 Make_Defining_Identifier (Loc,
4739 New_Internal_Name ('R'));
4740 -- Formal parameter for receiving stubs: a descriptor for an incoming
4743 Decls : constant List_Id := New_List;
4744 -- All the parameters will get declared before calling the real
4745 -- subprograms. Also the out parameters will be declared.
4747 Statements : constant List_Id := New_List;
4749 Extra_Formal_Statements : constant List_Id := New_List;
4750 -- Statements concerning extra formal parameters
4752 After_Statements : constant List_Id := New_List;
4753 -- Statements to be executed after the subprogram call
4755 Inner_Decls : List_Id := No_List;
4756 -- In case of a function, the inner declarations are needed since
4757 -- the result may be unconstrained.
4759 Excep_Handlers : List_Id := No_List;
4760 Excep_Choice : Entity_Id;
4761 Excep_Code : List_Id;
4763 Parameter_List : constant List_Id := New_List;
4764 -- List of parameters to be passed to the subprogram
4766 Current_Parameter : Node_Id;
4768 Ordered_Parameters_List : constant List_Id :=
4769 Build_Ordered_Parameters_List
4770 (Specification (Vis_Decl));
4772 Subp_Spec : Node_Id;
4773 -- Subprogram specification
4775 Called_Subprogram : Node_Id;
4776 -- The subprogram to call
4778 Null_Raise_Statement : Node_Id;
4780 Dynamic_Async : Entity_Id;
4783 if Present (RACW_Type) then
4784 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4786 Called_Subprogram :=
4788 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4791 if Dynamically_Asynchronous then
4793 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4795 Dynamic_Async := Empty;
4798 if not Asynchronous or Dynamically_Asynchronous then
4800 -- The first statement after the subprogram call is a statement to
4801 -- write a Null_Occurrence into the result stream.
4803 Null_Raise_Statement :=
4804 Make_Attribute_Reference (Loc,
4806 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4807 Attribute_Name => Name_Write,
4808 Expressions => New_List (
4809 Make_Selected_Component (Loc,
4810 Prefix => Request_Parameter,
4811 Selector_Name => Name_Result),
4812 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4814 if Dynamically_Asynchronous then
4815 Null_Raise_Statement :=
4816 Make_Implicit_If_Statement (Vis_Decl,
4818 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4819 Then_Statements => New_List (Null_Raise_Statement));
4822 Append_To (After_Statements, Null_Raise_Statement);
4825 -- Loop through every parameter and get its value from the stream. If
4826 -- the parameter is unconstrained, then the parameter is read using
4827 -- 'Input at the point of declaration.
4829 Current_Parameter := First (Ordered_Parameters_List);
4830 while Present (Current_Parameter) loop
4833 Constrained : Boolean;
4835 Need_Extra_Constrained : Boolean;
4836 -- True when an Extra_Constrained actual is required
4838 Object : constant Entity_Id :=
4839 Make_Defining_Identifier (Loc,
4840 New_Internal_Name ('P'));
4842 Expr : Node_Id := Empty;
4844 Is_Controlling_Formal : constant Boolean :=
4845 Is_RACW_Controlling_Formal
4846 (Current_Parameter, Stub_Type);
4849 if Is_Controlling_Formal then
4851 -- We have a controlling formal parameter. Read its address
4852 -- rather than a real object. The address is in Unsigned_64
4855 Etyp := RTE (RE_Unsigned_64);
4857 Etyp := Etype (Parameter_Type (Current_Parameter));
4860 Constrained := not Transmit_As_Unconstrained (Etyp);
4862 if In_Present (Current_Parameter)
4863 or else not Out_Present (Current_Parameter)
4864 or else not Constrained
4865 or else Is_Controlling_Formal
4867 -- If an input parameter is constrained, then the read of
4868 -- the parameter is deferred until the beginning of the
4869 -- subprogram body. If it is unconstrained, then an
4870 -- expression is built for the object declaration and the
4871 -- variable is set using 'Input instead of 'Read. Note that
4872 -- this deferral does not change the order in which the
4873 -- actuals are read because Build_Ordered_Parameter_List
4874 -- puts them unconstrained first.
4877 Append_To (Statements,
4878 Make_Attribute_Reference (Loc,
4879 Prefix => New_Occurrence_Of (Etyp, Loc),
4880 Attribute_Name => Name_Read,
4881 Expressions => New_List (
4882 Make_Selected_Component (Loc,
4883 Prefix => Request_Parameter,
4884 Selector_Name => Name_Params),
4885 New_Occurrence_Of (Object, Loc))));
4889 -- Build and append Input_With_Tag_Check function
4892 Input_With_Tag_Check (Loc,
4895 Make_Selected_Component (Loc,
4896 Prefix => Request_Parameter,
4897 Selector_Name => Name_Params)));
4899 -- Prepare function call expression
4902 Make_Function_Call (Loc,
4906 (Specification (Last (Decls))), Loc));
4910 Need_Extra_Constrained :=
4911 Nkind (Parameter_Type (Current_Parameter)) /=
4914 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4916 Present (Extra_Constrained
4917 (Defining_Identifier (Current_Parameter)));
4919 -- We may not associate an extra constrained actual to a
4920 -- constant object, so if one is needed, declare the actual
4921 -- as a variable even if it won't be modified.
4923 Build_Actual_Object_Declaration
4926 Variable => Need_Extra_Constrained
4927 or else Out_Present (Current_Parameter),
4931 -- An out parameter may be written back using a 'Write
4932 -- attribute instead of a 'Output because it has been
4933 -- constrained by the parameter given to the caller. Note that
4934 -- out controlling arguments in the case of a RACW are not put
4935 -- back in the stream because the pointer on them has not
4938 if Out_Present (Current_Parameter)
4940 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4942 Append_To (After_Statements,
4943 Make_Attribute_Reference (Loc,
4944 Prefix => New_Occurrence_Of (Etyp, Loc),
4945 Attribute_Name => Name_Write,
4946 Expressions => New_List (
4947 Make_Selected_Component (Loc,
4948 Prefix => Request_Parameter,
4949 Selector_Name => Name_Result),
4950 New_Occurrence_Of (Object, Loc))));
4953 -- For RACW controlling formals, the Etyp of Object is always
4954 -- an RACW, even if the parameter is not of an anonymous access
4955 -- type. In such case, we need to dereference it at call time.
4957 if Is_Controlling_Formal then
4958 if Nkind (Parameter_Type (Current_Parameter)) /=
4961 Append_To (Parameter_List,
4962 Make_Parameter_Association (Loc,
4965 Defining_Identifier (Current_Parameter), Loc),
4966 Explicit_Actual_Parameter =>
4967 Make_Explicit_Dereference (Loc,
4968 Unchecked_Convert_To (RACW_Type,
4969 OK_Convert_To (RTE (RE_Address),
4970 New_Occurrence_Of (Object, Loc))))));
4973 Append_To (Parameter_List,
4974 Make_Parameter_Association (Loc,
4977 Defining_Identifier (Current_Parameter), Loc),
4978 Explicit_Actual_Parameter =>
4979 Unchecked_Convert_To (RACW_Type,
4980 OK_Convert_To (RTE (RE_Address),
4981 New_Occurrence_Of (Object, Loc)))));
4985 Append_To (Parameter_List,
4986 Make_Parameter_Association (Loc,
4989 Defining_Identifier (Current_Parameter), Loc),
4990 Explicit_Actual_Parameter =>
4991 New_Occurrence_Of (Object, Loc)));
4994 -- If the current parameter needs an extra formal, then read it
4995 -- from the stream and set the corresponding semantic field in
4996 -- the variable. If the kind of the parameter identifier is
4997 -- E_Void, then this is a compiler generated parameter that
4998 -- doesn't need an extra constrained status.
5000 -- The case of Extra_Accessibility should also be handled ???
5002 if Need_Extra_Constrained then
5004 Extra_Parameter : constant Entity_Id :=
5006 (Defining_Identifier
5007 (Current_Parameter));
5009 Formal_Entity : constant Entity_Id :=
5010 Make_Defining_Identifier
5011 (Loc, Chars (Extra_Parameter));
5013 Formal_Type : constant Entity_Id :=
5014 Etype (Extra_Parameter);
5018 Make_Object_Declaration (Loc,
5019 Defining_Identifier => Formal_Entity,
5020 Object_Definition =>
5021 New_Occurrence_Of (Formal_Type, Loc)));
5023 Append_To (Extra_Formal_Statements,
5024 Make_Attribute_Reference (Loc,
5025 Prefix => New_Occurrence_Of (
5027 Attribute_Name => Name_Read,
5028 Expressions => New_List (
5029 Make_Selected_Component (Loc,
5030 Prefix => Request_Parameter,
5031 Selector_Name => Name_Params),
5032 New_Occurrence_Of (Formal_Entity, Loc))));
5034 -- Note: the call to Set_Extra_Constrained below relies
5035 -- on the fact that Object's Ekind has been set by
5036 -- Build_Actual_Object_Declaration.
5038 Set_Extra_Constrained (Object, Formal_Entity);
5043 Next (Current_Parameter);
5046 -- Append the formal statements list at the end of regular statements
5048 Append_List_To (Statements, Extra_Formal_Statements);
5050 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
5052 -- The remote subprogram is a function. We build an inner block to
5053 -- be able to hold a potentially unconstrained result in a
5057 Etyp : constant Entity_Id :=
5058 Etype (Result_Definition (Specification (Vis_Decl)));
5059 Result : constant Node_Id :=
5060 Make_Defining_Identifier (Loc,
5061 New_Internal_Name ('R'));
5063 Inner_Decls := New_List (
5064 Make_Object_Declaration (Loc,
5065 Defining_Identifier => Result,
5066 Constant_Present => True,
5067 Object_Definition => New_Occurrence_Of (Etyp, Loc),
5069 Make_Function_Call (Loc,
5070 Name => Called_Subprogram,
5071 Parameter_Associations => Parameter_List)));
5073 if Is_Class_Wide_Type (Etyp) then
5075 -- For a remote call to a function with a class-wide type,
5076 -- check that the returned value satisfies the requirements
5079 Append_To (Inner_Decls,
5080 Make_Transportable_Check (Loc,
5081 New_Occurrence_Of (Result, Loc)));
5085 Append_To (After_Statements,
5086 Make_Attribute_Reference (Loc,
5087 Prefix => New_Occurrence_Of (Etyp, Loc),
5088 Attribute_Name => Name_Output,
5089 Expressions => New_List (
5090 Make_Selected_Component (Loc,
5091 Prefix => Request_Parameter,
5092 Selector_Name => Name_Result),
5093 New_Occurrence_Of (Result, Loc))));
5096 Append_To (Statements,
5097 Make_Block_Statement (Loc,
5098 Declarations => Inner_Decls,
5099 Handled_Statement_Sequence =>
5100 Make_Handled_Sequence_Of_Statements (Loc,
5101 Statements => After_Statements)));
5104 -- The remote subprogram is a procedure. We do not need any inner
5105 -- block in this case.
5107 if Dynamically_Asynchronous then
5109 Make_Object_Declaration (Loc,
5110 Defining_Identifier => Dynamic_Async,
5111 Object_Definition =>
5112 New_Occurrence_Of (Standard_Boolean, Loc)));
5114 Append_To (Statements,
5115 Make_Attribute_Reference (Loc,
5116 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5117 Attribute_Name => Name_Read,
5118 Expressions => New_List (
5119 Make_Selected_Component (Loc,
5120 Prefix => Request_Parameter,
5121 Selector_Name => Name_Params),
5122 New_Occurrence_Of (Dynamic_Async, Loc))));
5125 Append_To (Statements,
5126 Make_Procedure_Call_Statement (Loc,
5127 Name => Called_Subprogram,
5128 Parameter_Associations => Parameter_List));
5130 Append_List_To (Statements, After_Statements);
5133 if Asynchronous and then not Dynamically_Asynchronous then
5135 -- For an asynchronous procedure, add a null exception handler
5137 Excep_Handlers := New_List (
5138 Make_Implicit_Exception_Handler (Loc,
5139 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5140 Statements => New_List (Make_Null_Statement (Loc))));
5143 -- In the other cases, if an exception is raised, then the
5144 -- exception occurrence is copied into the output stream and
5145 -- no other output parameter is written.
5148 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5150 Excep_Code := New_List (
5151 Make_Attribute_Reference (Loc,
5153 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5154 Attribute_Name => Name_Write,
5155 Expressions => New_List (
5156 Make_Selected_Component (Loc,
5157 Prefix => Request_Parameter,
5158 Selector_Name => Name_Result),
5159 New_Occurrence_Of (Excep_Choice, Loc))));
5161 if Dynamically_Asynchronous then
5162 Excep_Code := New_List (
5163 Make_Implicit_If_Statement (Vis_Decl,
5164 Condition => Make_Op_Not (Loc,
5165 New_Occurrence_Of (Dynamic_Async, Loc)),
5166 Then_Statements => Excep_Code));
5169 Excep_Handlers := New_List (
5170 Make_Implicit_Exception_Handler (Loc,
5171 Choice_Parameter => Excep_Choice,
5172 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5173 Statements => Excep_Code));
5178 Make_Procedure_Specification (Loc,
5179 Defining_Unit_Name =>
5180 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
5182 Parameter_Specifications => New_List (
5183 Make_Parameter_Specification (Loc,
5184 Defining_Identifier => Request_Parameter,
5186 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5189 Make_Subprogram_Body (Loc,
5190 Specification => Subp_Spec,
5191 Declarations => Decls,
5192 Handled_Statement_Sequence =>
5193 Make_Handled_Sequence_Of_Statements (Loc,
5194 Statements => Statements,
5195 Exception_Handlers => Excep_Handlers));
5196 end Build_Subprogram_Receiving_Stubs;
5202 function Result return Node_Id is
5204 return Make_Identifier (Loc, Name_V);
5207 ----------------------
5208 -- Stream_Parameter --
5209 ----------------------
5211 function Stream_Parameter return Node_Id is
5213 return Make_Identifier (Loc, Name_S);
5214 end Stream_Parameter;
5218 -------------------------------
5219 -- Get_And_Reset_RACW_Bodies --
5220 -------------------------------
5222 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5223 Desig : constant Entity_Id :=
5224 Etype (Designated_Type (RACW_Type));
5226 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5228 Body_Decls : List_Id;
5229 -- Returned list of declarations
5232 if Stub_Elements = Empty_Stub_Structure then
5234 -- Stub elements may be missing as a consequence of a previously
5240 Body_Decls := Stub_Elements.Body_Decls;
5241 Stub_Elements.Body_Decls := No_List;
5242 Stubs_Table.Set (Desig, Stub_Elements);
5244 end Get_And_Reset_RACW_Bodies;
5246 -----------------------
5247 -- Get_Stub_Elements --
5248 -----------------------
5250 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is
5251 Desig : constant Entity_Id :=
5252 Etype (Designated_Type (RACW_Type));
5253 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
5255 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5256 return Stub_Elements;
5257 end Get_Stub_Elements;
5259 -----------------------
5260 -- Get_Subprogram_Id --
5261 -----------------------
5263 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5264 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5266 pragma Assert (Result /= No_String);
5268 end Get_Subprogram_Id;
5270 -----------------------
5271 -- Get_Subprogram_Id --
5272 -----------------------
5274 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5276 return Get_Subprogram_Ids (Def).Int_Identifier;
5277 end Get_Subprogram_Id;
5279 ------------------------
5280 -- Get_Subprogram_Ids --
5281 ------------------------
5283 function Get_Subprogram_Ids
5284 (Def : Entity_Id) return Subprogram_Identifiers
5287 return Subprogram_Identifier_Table.Get (Def);
5288 end Get_Subprogram_Ids;
5294 function Hash (F : Entity_Id) return Hash_Index is
5296 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5299 function Hash (F : Name_Id) return Hash_Index is
5301 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5304 --------------------------
5305 -- Input_With_Tag_Check --
5306 --------------------------
5308 function Input_With_Tag_Check
5310 Var_Type : Entity_Id;
5311 Stream : Node_Id) return Node_Id
5315 Make_Subprogram_Body (Loc,
5316 Specification => Make_Function_Specification (Loc,
5317 Defining_Unit_Name =>
5318 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
5319 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5320 Declarations => No_List,
5321 Handled_Statement_Sequence =>
5322 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5323 Make_Tag_Check (Loc,
5324 Make_Simple_Return_Statement (Loc,
5325 Make_Attribute_Reference (Loc,
5326 Prefix => New_Occurrence_Of (Var_Type, Loc),
5327 Attribute_Name => Name_Input,
5329 New_List (Stream)))))));
5330 end Input_With_Tag_Check;
5332 --------------------------------
5333 -- Is_RACW_Controlling_Formal --
5334 --------------------------------
5336 function Is_RACW_Controlling_Formal
5337 (Parameter : Node_Id;
5338 Stub_Type : Entity_Id) return Boolean
5343 -- If the kind of the parameter is E_Void, then it is not a controlling
5344 -- formal (this can happen in the context of RAS).
5346 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5350 -- If the parameter is not a controlling formal, then it cannot be
5351 -- possibly a RACW_Controlling_Formal.
5353 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5357 Typ := Parameter_Type (Parameter);
5358 return (Nkind (Typ) = N_Access_Definition
5359 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5360 or else Etype (Typ) = Stub_Type;
5361 end Is_RACW_Controlling_Formal;
5363 ------------------------------
5364 -- Make_Transportable_Check --
5365 ------------------------------
5367 function Make_Transportable_Check
5369 Expr : Node_Id) return Node_Id is
5372 Make_Raise_Program_Error (Loc,
5375 Build_Get_Transportable (Loc,
5376 Make_Selected_Component (Loc,
5378 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5379 Reason => PE_Non_Transportable_Actual);
5380 end Make_Transportable_Check;
5382 -----------------------------
5383 -- Make_Selected_Component --
5384 -----------------------------
5386 function Make_Selected_Component
5389 Selector_Name : Name_Id) return Node_Id
5392 return Make_Selected_Component (Loc,
5393 Prefix => New_Occurrence_Of (Prefix, Loc),
5394 Selector_Name => Make_Identifier (Loc, Selector_Name));
5395 end Make_Selected_Component;
5397 --------------------
5398 -- Make_Tag_Check --
5399 --------------------
5401 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5402 Occ : constant Entity_Id :=
5403 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5406 return Make_Block_Statement (Loc,
5407 Handled_Statement_Sequence =>
5408 Make_Handled_Sequence_Of_Statements (Loc,
5409 Statements => New_List (N),
5411 Exception_Handlers => New_List (
5412 Make_Implicit_Exception_Handler (Loc,
5413 Choice_Parameter => Occ,
5415 Exception_Choices =>
5416 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5419 New_List (Make_Procedure_Call_Statement (Loc,
5421 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5422 New_List (New_Occurrence_Of (Occ, Loc))))))));
5425 ----------------------------
5426 -- Need_Extra_Constrained --
5427 ----------------------------
5429 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5430 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5432 return Out_Present (Parameter)
5433 and then Has_Discriminants (Etyp)
5434 and then not Is_Constrained (Etyp)
5435 and then not Is_Indefinite_Subtype (Etyp);
5436 end Need_Extra_Constrained;
5438 ------------------------------------
5439 -- Pack_Entity_Into_Stream_Access --
5440 ------------------------------------
5442 function Pack_Entity_Into_Stream_Access
5446 Etyp : Entity_Id := Empty) return Node_Id
5451 if Present (Etyp) then
5454 Typ := Etype (Object);
5458 Pack_Node_Into_Stream_Access (Loc,
5460 Object => New_Occurrence_Of (Object, Loc),
5462 end Pack_Entity_Into_Stream_Access;
5464 ---------------------------
5465 -- Pack_Node_Into_Stream --
5466 ---------------------------
5468 function Pack_Node_Into_Stream
5472 Etyp : Entity_Id) return Node_Id
5474 Write_Attribute : Name_Id := Name_Write;
5477 if not Is_Constrained (Etyp) then
5478 Write_Attribute := Name_Output;
5482 Make_Attribute_Reference (Loc,
5483 Prefix => New_Occurrence_Of (Etyp, Loc),
5484 Attribute_Name => Write_Attribute,
5485 Expressions => New_List (
5486 Make_Attribute_Reference (Loc,
5487 Prefix => New_Occurrence_Of (Stream, Loc),
5488 Attribute_Name => Name_Access),
5490 end Pack_Node_Into_Stream;
5492 ----------------------------------
5493 -- Pack_Node_Into_Stream_Access --
5494 ----------------------------------
5496 function Pack_Node_Into_Stream_Access
5500 Etyp : Entity_Id) return Node_Id
5502 Write_Attribute : Name_Id := Name_Write;
5505 if not Is_Constrained (Etyp) then
5506 Write_Attribute := Name_Output;
5510 Make_Attribute_Reference (Loc,
5511 Prefix => New_Occurrence_Of (Etyp, Loc),
5512 Attribute_Name => Write_Attribute,
5513 Expressions => New_List (
5516 end Pack_Node_Into_Stream_Access;
5518 ---------------------
5519 -- PolyORB_Support --
5520 ---------------------
5522 package body PolyORB_Support is
5524 -- Local subprograms
5526 procedure Add_RACW_Read_Attribute
5527 (RACW_Type : Entity_Id;
5528 Stub_Type : Entity_Id;
5529 Stub_Type_Access : Entity_Id;
5530 Body_Decls : List_Id);
5531 -- Add Read attribute for the RACW type. The declaration and attribute
5532 -- definition clauses are inserted right after the declaration of
5533 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5534 -- appended to it (case where the RACW declaration is in the main unit).
5536 procedure Add_RACW_Write_Attribute
5537 (RACW_Type : Entity_Id;
5538 Stub_Type : Entity_Id;
5539 Stub_Type_Access : Entity_Id;
5540 Body_Decls : List_Id);
5541 -- Same as above for the Write attribute
5543 procedure Add_RACW_From_Any
5544 (RACW_Type : Entity_Id;
5545 Body_Decls : List_Id);
5546 -- Add the From_Any TSS for this RACW type
5548 procedure Add_RACW_To_Any
5549 (RACW_Type : Entity_Id;
5550 Body_Decls : List_Id);
5551 -- Add the To_Any TSS for this RACW type
5553 procedure Add_RACW_TypeCode
5554 (Designated_Type : Entity_Id;
5555 RACW_Type : Entity_Id;
5556 Body_Decls : List_Id);
5557 -- Add the TypeCode TSS for this RACW type
5559 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5560 -- Add the From_Any TSS for this RAS type
5562 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5563 -- Add the To_Any TSS for this RAS type
5565 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5566 -- Add the TypeCode TSS for this RAS type
5568 procedure Add_RAS_Access_TSS (N : Node_Id);
5569 -- Add a subprogram body for RAS Access TSS
5571 -------------------------------------
5572 -- Add_Obj_RPC_Receiver_Completion --
5573 -------------------------------------
5575 procedure Add_Obj_RPC_Receiver_Completion
5578 RPC_Receiver : Entity_Id;
5579 Stub_Elements : Stub_Structure)
5581 Desig : constant Entity_Id :=
5582 Etype (Designated_Type (Stub_Elements.RACW_Type));
5585 Make_Procedure_Call_Statement (Loc,
5588 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5590 Parameter_Associations => New_List (
5594 Make_String_Literal (Loc,
5595 Full_Qualified_Name (Desig)),
5599 Make_Attribute_Reference (Loc,
5602 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5608 Make_Attribute_Reference (Loc,
5611 Defining_Identifier (
5612 Stub_Elements.RPC_Receiver_Decl), Loc),
5615 end Add_Obj_RPC_Receiver_Completion;
5617 -----------------------
5618 -- Add_RACW_Features --
5619 -----------------------
5621 procedure Add_RACW_Features
5622 (RACW_Type : Entity_Id;
5624 Stub_Type : Entity_Id;
5625 Stub_Type_Access : Entity_Id;
5626 RPC_Receiver_Decl : Node_Id;
5627 Body_Decls : List_Id)
5629 pragma Unreferenced (RPC_Receiver_Decl);
5633 (RACW_Type => RACW_Type,
5634 Body_Decls => Body_Decls);
5637 (RACW_Type => RACW_Type,
5638 Body_Decls => Body_Decls);
5640 Add_RACW_Write_Attribute
5641 (RACW_Type => RACW_Type,
5642 Stub_Type => Stub_Type,
5643 Stub_Type_Access => Stub_Type_Access,
5644 Body_Decls => Body_Decls);
5646 Add_RACW_Read_Attribute
5647 (RACW_Type => RACW_Type,
5648 Stub_Type => Stub_Type,
5649 Stub_Type_Access => Stub_Type_Access,
5650 Body_Decls => Body_Decls);
5653 (Designated_Type => Desig,
5654 RACW_Type => RACW_Type,
5655 Body_Decls => Body_Decls);
5656 end Add_RACW_Features;
5658 -----------------------
5659 -- Add_RACW_From_Any --
5660 -----------------------
5662 procedure Add_RACW_From_Any
5663 (RACW_Type : Entity_Id;
5664 Body_Decls : List_Id)
5666 Loc : constant Source_Ptr := Sloc (RACW_Type);
5667 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5668 Fnam : constant Entity_Id :=
5669 Make_Defining_Identifier (Loc,
5670 Chars => New_External_Name (Chars (RACW_Type), 'F'));
5672 Func_Spec : Node_Id;
5673 Func_Decl : Node_Id;
5674 Func_Body : Node_Id;
5676 Statements : List_Id;
5677 -- Various parts of the subprogram
5679 Any_Parameter : constant Entity_Id :=
5680 Make_Defining_Identifier (Loc, Name_A);
5682 Asynchronous_Flag : constant Entity_Id :=
5683 Asynchronous_Flags_Table.Get (RACW_Type);
5684 -- The flag object declared in Add_RACW_Asynchronous_Flag
5688 Make_Function_Specification (Loc,
5689 Defining_Unit_Name =>
5691 Parameter_Specifications => New_List (
5692 Make_Parameter_Specification (Loc,
5693 Defining_Identifier =>
5696 New_Occurrence_Of (RTE (RE_Any), Loc))),
5697 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5699 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5700 -- entity in the declaration spec, not those of the body spec.
5702 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5703 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5704 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5706 if No (Body_Decls) then
5710 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5711 -- set on the stub type if, and only if, the RACW type has a pragma
5712 -- Asynchronous. This is incorrect for RACWs that implement RAS
5713 -- types, because in that case the /designated subprogram/ (not the
5714 -- type) might be asynchronous, and that causes the stub to need to
5715 -- be asynchronous too. A solution is to transport a RAS as a struct
5716 -- containing a RACW and an asynchronous flag, and to properly alter
5717 -- the Asynchronous component in the stub type in the RAS's _From_Any
5720 Statements := New_List (
5721 Make_Simple_Return_Statement (Loc,
5722 Expression => Unchecked_Convert_To (RACW_Type,
5723 Make_Function_Call (Loc,
5724 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5725 Parameter_Associations => New_List (
5726 Make_Function_Call (Loc,
5727 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5728 Parameter_Associations => New_List (
5729 New_Occurrence_Of (Any_Parameter, Loc))),
5730 Build_Stub_Tag (Loc, RACW_Type),
5731 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5732 New_Occurrence_Of (Asynchronous_Flag, Loc))))));
5735 Make_Subprogram_Body (Loc,
5736 Specification => Copy_Specification (Loc, Func_Spec),
5737 Declarations => No_List,
5738 Handled_Statement_Sequence =>
5739 Make_Handled_Sequence_Of_Statements (Loc,
5740 Statements => Statements));
5742 Append_To (Body_Decls, Func_Body);
5743 end Add_RACW_From_Any;
5745 -----------------------------
5746 -- Add_RACW_Read_Attribute --
5747 -----------------------------
5749 procedure Add_RACW_Read_Attribute
5750 (RACW_Type : Entity_Id;
5751 Stub_Type : Entity_Id;
5752 Stub_Type_Access : Entity_Id;
5753 Body_Decls : List_Id)
5755 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5757 Loc : constant Source_Ptr := Sloc (RACW_Type);
5759 Proc_Decl : Node_Id;
5760 Attr_Decl : Node_Id;
5762 Body_Node : Node_Id;
5764 Decls : constant List_Id := New_List;
5765 Statements : constant List_Id := New_List;
5766 Reference : constant Entity_Id :=
5767 Make_Defining_Identifier (Loc, Name_R);
5768 -- Various parts of the procedure
5770 Pnam : constant Entity_Id := Make_Defining_Identifier (Loc,
5771 New_Internal_Name ('R'));
5773 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5775 Asynchronous_Flag : constant Entity_Id :=
5776 Asynchronous_Flags_Table.Get (RACW_Type);
5777 pragma Assert (Present (Asynchronous_Flag));
5779 function Stream_Parameter return Node_Id;
5780 function Result return Node_Id;
5782 -- Functions to create occurrences of the formal parameter names
5788 function Result return Node_Id is
5790 return Make_Identifier (Loc, Name_V);
5793 ----------------------
5794 -- Stream_Parameter --
5795 ----------------------
5797 function Stream_Parameter return Node_Id is
5799 return Make_Identifier (Loc, Name_S);
5800 end Stream_Parameter;
5802 -- Start of processing for Add_RACW_Read_Attribute
5805 Build_Stream_Procedure
5806 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
5808 Proc_Decl := Make_Subprogram_Declaration (Loc,
5809 Copy_Specification (Loc, Specification (Body_Node)));
5812 Make_Attribute_Definition_Clause (Loc,
5813 Name => New_Occurrence_Of (RACW_Type, Loc),
5817 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5819 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5820 Insert_After (Proc_Decl, Attr_Decl);
5822 if No (Body_Decls) then
5827 Make_Object_Declaration (Loc,
5828 Defining_Identifier =>
5830 Object_Definition =>
5831 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5833 Append_List_To (Statements, New_List (
5834 Make_Attribute_Reference (Loc,
5836 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5837 Attribute_Name => Name_Read,
5838 Expressions => New_List (
5840 New_Occurrence_Of (Reference, Loc))),
5842 Make_Assignment_Statement (Loc,
5846 Unchecked_Convert_To (RACW_Type,
5847 Make_Function_Call (Loc,
5849 New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5850 Parameter_Associations => New_List (
5851 New_Occurrence_Of (Reference, Loc),
5852 Build_Stub_Tag (Loc, RACW_Type),
5853 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5854 New_Occurrence_Of (Asynchronous_Flag, Loc)))))));
5856 Set_Declarations (Body_Node, Decls);
5857 Append_To (Body_Decls, Body_Node);
5858 end Add_RACW_Read_Attribute;
5860 ---------------------
5861 -- Add_RACW_To_Any --
5862 ---------------------
5864 procedure Add_RACW_To_Any
5865 (RACW_Type : Entity_Id;
5866 Body_Decls : List_Id)
5868 Loc : constant Source_Ptr := Sloc (RACW_Type);
5870 Fnam : constant Entity_Id :=
5871 Make_Defining_Identifier (Loc,
5872 Chars => New_External_Name (Chars (RACW_Type), 'T'));
5874 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5876 Stub_Elements : constant Stub_Structure :=
5877 Get_Stub_Elements (RACW_Type);
5879 Func_Spec : Node_Id;
5880 Func_Decl : Node_Id;
5881 Func_Body : Node_Id;
5884 Statements : List_Id;
5885 -- Various parts of the subprogram
5887 RACW_Parameter : constant Entity_Id :=
5888 Make_Defining_Identifier (Loc, Name_R);
5890 Reference : constant Entity_Id :=
5891 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
5892 Any : constant Entity_Id :=
5893 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
5897 Make_Function_Specification (Loc,
5898 Defining_Unit_Name =>
5900 Parameter_Specifications => New_List (
5901 Make_Parameter_Specification (Loc,
5902 Defining_Identifier =>
5905 New_Occurrence_Of (RACW_Type, Loc))),
5906 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5908 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5909 -- entity in the declaration spec, not in the body spec.
5911 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5913 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5914 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5916 if No (Body_Decls) then
5922 -- R : constant Object_Ref :=
5928 -- RPC_Receiver'Access);
5932 Make_Object_Declaration (Loc,
5933 Defining_Identifier => Reference,
5934 Constant_Present => True,
5935 Object_Definition =>
5936 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5938 Make_Function_Call (Loc,
5939 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5940 Parameter_Associations => New_List (
5941 Unchecked_Convert_To (RTE (RE_Address),
5942 New_Occurrence_Of (RACW_Parameter, Loc)),
5943 Make_String_Literal (Loc,
5944 Strval => Full_Qualified_Name
5945 (Etype (Designated_Type (RACW_Type)))),
5946 Build_Stub_Tag (Loc, RACW_Type),
5947 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5948 Make_Attribute_Reference (Loc,
5951 (Defining_Identifier
5952 (Stub_Elements.RPC_Receiver_Decl), Loc),
5953 Attribute_Name => Name_Access)))),
5955 Make_Object_Declaration (Loc,
5956 Defining_Identifier => Any,
5957 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)));
5961 -- Any := TA_ObjRef (Reference);
5962 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5965 Statements := New_List (
5966 Make_Assignment_Statement (Loc,
5967 Name => New_Occurrence_Of (Any, Loc),
5969 Make_Function_Call (Loc,
5970 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5971 Parameter_Associations => New_List (
5972 New_Occurrence_Of (Reference, Loc)))),
5974 Make_Procedure_Call_Statement (Loc,
5975 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5976 Parameter_Associations => New_List (
5977 New_Occurrence_Of (Any, Loc),
5978 Make_Selected_Component (Loc,
5980 Defining_Identifier (
5981 Stub_Elements.RPC_Receiver_Decl),
5982 Selector_Name => Name_Obj_TypeCode))),
5984 Make_Simple_Return_Statement (Loc,
5985 Expression => New_Occurrence_Of (Any, Loc)));
5988 Make_Subprogram_Body (Loc,
5989 Specification => Copy_Specification (Loc, Func_Spec),
5990 Declarations => Decls,
5991 Handled_Statement_Sequence =>
5992 Make_Handled_Sequence_Of_Statements (Loc,
5993 Statements => Statements));
5994 Append_To (Body_Decls, Func_Body);
5995 end Add_RACW_To_Any;
5997 -----------------------
5998 -- Add_RACW_TypeCode --
5999 -----------------------
6001 procedure Add_RACW_TypeCode
6002 (Designated_Type : Entity_Id;
6003 RACW_Type : Entity_Id;
6004 Body_Decls : List_Id)
6006 Loc : constant Source_Ptr := Sloc (RACW_Type);
6008 Fnam : constant Entity_Id :=
6009 Make_Defining_Identifier (Loc,
6010 Chars => New_External_Name (Chars (RACW_Type), 'Y'));
6012 Stub_Elements : constant Stub_Structure :=
6013 Stubs_Table.Get (Designated_Type);
6014 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6016 Func_Spec : Node_Id;
6017 Func_Decl : Node_Id;
6018 Func_Body : Node_Id;
6021 -- The spec for this subprogram has a dummy 'access RACW' argument,
6022 -- which serves only for overloading purposes.
6025 Make_Function_Specification (Loc,
6026 Defining_Unit_Name => Fnam,
6027 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6029 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6030 -- entity in the declaration spec, not those of the body spec.
6032 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6033 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6034 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6036 if No (Body_Decls) then
6041 Make_Subprogram_Body (Loc,
6042 Specification => Copy_Specification (Loc, Func_Spec),
6043 Declarations => Empty_List,
6044 Handled_Statement_Sequence =>
6045 Make_Handled_Sequence_Of_Statements (Loc,
6046 Statements => New_List (
6047 Make_Simple_Return_Statement (Loc,
6049 Make_Selected_Component (Loc,
6052 (Stub_Elements.RPC_Receiver_Decl),
6053 Selector_Name => Name_Obj_TypeCode)))));
6055 Append_To (Body_Decls, Func_Body);
6056 end Add_RACW_TypeCode;
6058 ------------------------------
6059 -- Add_RACW_Write_Attribute --
6060 ------------------------------
6062 procedure Add_RACW_Write_Attribute
6063 (RACW_Type : Entity_Id;
6064 Stub_Type : Entity_Id;
6065 Stub_Type_Access : Entity_Id;
6066 Body_Decls : List_Id)
6068 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6070 Loc : constant Source_Ptr := Sloc (RACW_Type);
6072 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
6074 Stub_Elements : constant Stub_Structure :=
6075 Get_Stub_Elements (RACW_Type);
6077 Body_Node : Node_Id;
6078 Proc_Decl : Node_Id;
6079 Attr_Decl : Node_Id;
6081 Statements : constant List_Id := New_List;
6082 Pnam : constant Entity_Id :=
6083 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
6085 function Stream_Parameter return Node_Id;
6086 function Object return Node_Id;
6087 -- Functions to create occurrences of the formal parameter names
6093 function Object return Node_Id is
6095 return Make_Identifier (Loc, Name_V);
6098 ----------------------
6099 -- Stream_Parameter --
6100 ----------------------
6102 function Stream_Parameter return Node_Id is
6104 return Make_Identifier (Loc, Name_S);
6105 end Stream_Parameter;
6107 -- Start of processing for Add_RACW_Write_Attribute
6110 Build_Stream_Procedure
6111 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
6114 Make_Subprogram_Declaration (Loc,
6115 Copy_Specification (Loc, Specification (Body_Node)));
6118 Make_Attribute_Definition_Clause (Loc,
6119 Name => New_Occurrence_Of (RACW_Type, Loc),
6120 Chars => Name_Write,
6123 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6125 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6126 Insert_After (Proc_Decl, Attr_Decl);
6128 if No (Body_Decls) then
6132 Append_To (Statements,
6133 Pack_Node_Into_Stream_Access (Loc,
6134 Stream => Stream_Parameter,
6136 Make_Function_Call (Loc,
6137 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6138 Parameter_Associations => New_List (
6139 Unchecked_Convert_To (RTE (RE_Address), Object),
6140 Make_String_Literal (Loc,
6141 Strval => Full_Qualified_Name
6142 (Etype (Designated_Type (RACW_Type)))),
6143 Build_Stub_Tag (Loc, RACW_Type),
6144 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
6145 Make_Attribute_Reference (Loc,
6148 (Defining_Identifier
6149 (Stub_Elements.RPC_Receiver_Decl), Loc),
6150 Attribute_Name => Name_Access))),
6152 Etyp => RTE (RE_Object_Ref)));
6154 Append_To (Body_Decls, Body_Node);
6155 end Add_RACW_Write_Attribute;
6157 -----------------------
6158 -- Add_RAST_Features --
6159 -----------------------
6161 procedure Add_RAST_Features
6162 (Vis_Decl : Node_Id;
6163 RAS_Type : Entity_Id)
6166 Add_RAS_Access_TSS (Vis_Decl);
6168 Add_RAS_From_Any (RAS_Type);
6169 Add_RAS_TypeCode (RAS_Type);
6171 -- To_Any uses TypeCode, and therefore needs to be generated last
6173 Add_RAS_To_Any (RAS_Type);
6174 end Add_RAST_Features;
6176 ------------------------
6177 -- Add_RAS_Access_TSS --
6178 ------------------------
6180 procedure Add_RAS_Access_TSS (N : Node_Id) is
6181 Loc : constant Source_Ptr := Sloc (N);
6183 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6184 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6185 -- Ras_Type is the access to subprogram type; Fat_Type is the
6186 -- corresponding record type.
6188 RACW_Type : constant Entity_Id :=
6189 Underlying_RACW_Type (Ras_Type);
6191 Stub_Elements : constant Stub_Structure :=
6192 Get_Stub_Elements (RACW_Type);
6194 Proc : constant Entity_Id :=
6195 Make_Defining_Identifier (Loc,
6196 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6198 Proc_Spec : Node_Id;
6200 -- Formal parameters
6202 Package_Name : constant Entity_Id :=
6203 Make_Defining_Identifier (Loc,
6208 Subp_Id : constant Entity_Id :=
6209 Make_Defining_Identifier (Loc,
6212 -- Target subprogram
6214 Asynch_P : constant Entity_Id :=
6215 Make_Defining_Identifier (Loc,
6216 Chars => Name_Asynchronous);
6217 -- Is the procedure to which the 'Access applies asynchronous?
6219 All_Calls_Remote : constant Entity_Id :=
6220 Make_Defining_Identifier (Loc,
6221 Chars => Name_All_Calls_Remote);
6222 -- True if an All_Calls_Remote pragma applies to the RCI unit
6223 -- that contains the subprogram.
6225 -- Common local variables
6227 Proc_Decls : List_Id;
6228 Proc_Statements : List_Id;
6230 Subp_Ref : constant Entity_Id :=
6231 Make_Defining_Identifier (Loc, Name_R);
6232 -- Reference that designates the target subprogram (returned
6233 -- by Get_RAS_Info).
6235 Is_Local : constant Entity_Id :=
6236 Make_Defining_Identifier (Loc, Name_L);
6237 Local_Addr : constant Entity_Id :=
6238 Make_Defining_Identifier (Loc, Name_A);
6239 -- For the call to Get_Local_Address
6241 -- Additional local variables for the remote case
6243 Local_Stub : constant Entity_Id :=
6244 Make_Defining_Identifier (Loc,
6245 Chars => New_Internal_Name ('L'));
6247 Stub_Ptr : constant Entity_Id :=
6248 Make_Defining_Identifier (Loc,
6249 Chars => New_Internal_Name ('S'));
6252 (Field_Name : Name_Id;
6253 Value : Node_Id) return Node_Id;
6254 -- Construct an assignment that sets the named component in the
6262 (Field_Name : Name_Id;
6263 Value : Node_Id) return Node_Id
6267 Make_Assignment_Statement (Loc,
6269 Make_Selected_Component (Loc,
6271 Selector_Name => Field_Name),
6272 Expression => Value);
6275 -- Start of processing for Add_RAS_Access_TSS
6278 Proc_Decls := New_List (
6280 -- Common declarations
6282 Make_Object_Declaration (Loc,
6283 Defining_Identifier => Subp_Ref,
6284 Object_Definition =>
6285 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6287 Make_Object_Declaration (Loc,
6288 Defining_Identifier => Is_Local,
6289 Object_Definition =>
6290 New_Occurrence_Of (Standard_Boolean, Loc)),
6292 Make_Object_Declaration (Loc,
6293 Defining_Identifier => Local_Addr,
6294 Object_Definition =>
6295 New_Occurrence_Of (RTE (RE_Address), Loc)),
6297 Make_Object_Declaration (Loc,
6298 Defining_Identifier => Local_Stub,
6299 Aliased_Present => True,
6300 Object_Definition =>
6301 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6303 Make_Object_Declaration (Loc,
6304 Defining_Identifier => Stub_Ptr,
6305 Object_Definition =>
6306 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6308 Make_Attribute_Reference (Loc,
6309 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6310 Attribute_Name => Name_Unchecked_Access)));
6312 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6313 -- Build_Get_Unique_RP_Call needs this information
6315 -- Get_RAS_Info (Pkg, Subp, R);
6316 -- Obtain a reference to the target subprogram
6318 Proc_Statements := New_List (
6319 Make_Procedure_Call_Statement (Loc,
6320 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6321 Parameter_Associations => New_List (
6322 New_Occurrence_Of (Package_Name, Loc),
6323 New_Occurrence_Of (Subp_Id, Loc),
6324 New_Occurrence_Of (Subp_Ref, Loc))),
6326 -- Get_Local_Address (R, L, A);
6327 -- Determine whether the subprogram is local (L), and if so
6328 -- obtain the local address of its proxy (A).
6330 Make_Procedure_Call_Statement (Loc,
6331 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6332 Parameter_Associations => New_List (
6333 New_Occurrence_Of (Subp_Ref, Loc),
6334 New_Occurrence_Of (Is_Local, Loc),
6335 New_Occurrence_Of (Local_Addr, Loc))));
6337 -- Note: Here we assume that the Fat_Type is a record containing just
6338 -- an access to a proxy or stub object.
6340 Append_To (Proc_Statements,
6344 Make_Implicit_If_Statement (N,
6345 Condition => New_Occurrence_Of (Is_Local, Loc),
6347 Then_Statements => New_List (
6349 -- if A.Target = null then
6351 Make_Implicit_If_Statement (N,
6354 Make_Selected_Component (Loc,
6356 Unchecked_Convert_To
6357 (RTE (RE_RAS_Proxy_Type_Access),
6358 New_Occurrence_Of (Local_Addr, Loc)),
6359 Selector_Name => Make_Identifier (Loc, Name_Target)),
6362 Then_Statements => New_List (
6364 -- A.Target := Entity_Of (Ref);
6366 Make_Assignment_Statement (Loc,
6368 Make_Selected_Component (Loc,
6370 Unchecked_Convert_To
6371 (RTE (RE_RAS_Proxy_Type_Access),
6372 New_Occurrence_Of (Local_Addr, Loc)),
6373 Selector_Name => Make_Identifier (Loc, Name_Target)),
6375 Make_Function_Call (Loc,
6376 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6377 Parameter_Associations => New_List (
6378 New_Occurrence_Of (Subp_Ref, Loc)))),
6380 -- Inc_Usage (A.Target);
6383 Make_Procedure_Call_Statement (Loc,
6384 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6385 Parameter_Associations => New_List (
6386 Make_Selected_Component (Loc,
6388 Unchecked_Convert_To
6389 (RTE (RE_RAS_Proxy_Type_Access),
6390 New_Occurrence_Of (Local_Addr, Loc)),
6392 Make_Identifier (Loc, Name_Target)))))),
6394 -- if not All_Calls_Remote then
6395 -- return Fat_Type!(A);
6398 Make_Implicit_If_Statement (N,
6402 New_Occurrence_Of (All_Calls_Remote, Loc)),
6404 Then_Statements => New_List (
6405 Make_Simple_Return_Statement (Loc,
6407 Unchecked_Convert_To
6408 (Fat_Type, New_Occurrence_Of (Local_Addr, Loc))))))));
6410 Append_List_To (Proc_Statements, New_List (
6412 -- Stub.Target := Entity_Of (Ref);
6414 Set_Field (Name_Target,
6415 Make_Function_Call (Loc,
6416 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6417 Parameter_Associations => New_List (
6418 New_Occurrence_Of (Subp_Ref, Loc)))),
6420 -- Inc_Usage (Stub.Target);
6422 Make_Procedure_Call_Statement (Loc,
6423 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6424 Parameter_Associations => New_List (
6425 Make_Selected_Component (Loc,
6427 Selector_Name => Name_Target))),
6429 -- E.4.1(9) A remote call is asynchronous if it is a call to
6430 -- a procedure, or a call through a value of an access-to-procedure
6431 -- type, to which a pragma Asynchronous applies.
6433 -- Parameter Asynch_P is true when the procedure is asynchronous;
6434 -- Expression Asynch_T is true when the type is asynchronous.
6436 Set_Field (Name_Asynchronous,
6438 Left_Opnd => New_Occurrence_Of (Asynch_P, Loc),
6441 (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc)))));
6443 Append_List_To (Proc_Statements,
6444 Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
6446 Append_To (Proc_Statements,
6447 Make_Simple_Return_Statement (Loc,
6449 Unchecked_Convert_To (Fat_Type,
6450 New_Occurrence_Of (Stub_Ptr, Loc))));
6453 Make_Function_Specification (Loc,
6454 Defining_Unit_Name => Proc,
6455 Parameter_Specifications => New_List (
6456 Make_Parameter_Specification (Loc,
6457 Defining_Identifier => Package_Name,
6459 New_Occurrence_Of (Standard_String, Loc)),
6461 Make_Parameter_Specification (Loc,
6462 Defining_Identifier => Subp_Id,
6464 New_Occurrence_Of (Standard_String, Loc)),
6466 Make_Parameter_Specification (Loc,
6467 Defining_Identifier => Asynch_P,
6469 New_Occurrence_Of (Standard_Boolean, Loc)),
6471 Make_Parameter_Specification (Loc,
6472 Defining_Identifier => All_Calls_Remote,
6474 New_Occurrence_Of (Standard_Boolean, Loc))),
6476 Result_Definition =>
6477 New_Occurrence_Of (Fat_Type, Loc));
6479 -- Set the kind and return type of the function to prevent
6480 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6482 Set_Ekind (Proc, E_Function);
6483 Set_Etype (Proc, Fat_Type);
6486 Make_Subprogram_Body (Loc,
6487 Specification => Proc_Spec,
6488 Declarations => Proc_Decls,
6489 Handled_Statement_Sequence =>
6490 Make_Handled_Sequence_Of_Statements (Loc,
6491 Statements => Proc_Statements)));
6493 Set_TSS (Fat_Type, Proc);
6494 end Add_RAS_Access_TSS;
6496 ----------------------
6497 -- Add_RAS_From_Any --
6498 ----------------------
6500 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6501 Loc : constant Source_Ptr := Sloc (RAS_Type);
6503 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6504 Make_TSS_Name (RAS_Type, TSS_From_Any));
6506 Func_Spec : Node_Id;
6508 Statements : List_Id;
6510 Any_Parameter : constant Entity_Id :=
6511 Make_Defining_Identifier (Loc, Name_A);
6514 Statements := New_List (
6515 Make_Simple_Return_Statement (Loc,
6517 Make_Aggregate (Loc,
6518 Component_Associations => New_List (
6519 Make_Component_Association (Loc,
6520 Choices => New_List (
6521 Make_Identifier (Loc, Name_Ras)),
6523 PolyORB_Support.Helpers.Build_From_Any_Call (
6524 Underlying_RACW_Type (RAS_Type),
6525 New_Occurrence_Of (Any_Parameter, Loc),
6529 Make_Function_Specification (Loc,
6530 Defining_Unit_Name => Fnam,
6531 Parameter_Specifications => New_List (
6532 Make_Parameter_Specification (Loc,
6533 Defining_Identifier => Any_Parameter,
6534 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
6535 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6538 Make_Subprogram_Body (Loc,
6539 Specification => Func_Spec,
6540 Declarations => No_List,
6541 Handled_Statement_Sequence =>
6542 Make_Handled_Sequence_Of_Statements (Loc,
6543 Statements => Statements)));
6544 Set_TSS (RAS_Type, Fnam);
6545 end Add_RAS_From_Any;
6547 --------------------
6548 -- Add_RAS_To_Any --
6549 --------------------
6551 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6552 Loc : constant Source_Ptr := Sloc (RAS_Type);
6554 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6555 Make_TSS_Name (RAS_Type, TSS_To_Any));
6558 Statements : List_Id;
6560 Func_Spec : Node_Id;
6562 Any : constant Entity_Id :=
6563 Make_Defining_Identifier (Loc,
6564 Chars => New_Internal_Name ('A'));
6565 RAS_Parameter : constant Entity_Id :=
6566 Make_Defining_Identifier (Loc,
6567 Chars => New_Internal_Name ('R'));
6568 RACW_Parameter : constant Node_Id :=
6569 Make_Selected_Component (Loc,
6570 Prefix => RAS_Parameter,
6571 Selector_Name => Name_Ras);
6574 -- Object declarations
6576 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6578 Make_Object_Declaration (Loc,
6579 Defining_Identifier => Any,
6580 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc),
6582 PolyORB_Support.Helpers.Build_To_Any_Call
6583 (RACW_Parameter, No_List)));
6585 Statements := New_List (
6586 Make_Procedure_Call_Statement (Loc,
6587 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6588 Parameter_Associations => New_List (
6589 New_Occurrence_Of (Any, Loc),
6590 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6593 Make_Simple_Return_Statement (Loc,
6594 Expression => New_Occurrence_Of (Any, Loc)));
6597 Make_Function_Specification (Loc,
6598 Defining_Unit_Name => Fnam,
6599 Parameter_Specifications => New_List (
6600 Make_Parameter_Specification (Loc,
6601 Defining_Identifier => RAS_Parameter,
6602 Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))),
6603 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6606 Make_Subprogram_Body (Loc,
6607 Specification => Func_Spec,
6608 Declarations => Decls,
6609 Handled_Statement_Sequence =>
6610 Make_Handled_Sequence_Of_Statements (Loc,
6611 Statements => Statements)));
6612 Set_TSS (RAS_Type, Fnam);
6615 ----------------------
6616 -- Add_RAS_TypeCode --
6617 ----------------------
6619 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6620 Loc : constant Source_Ptr := Sloc (RAS_Type);
6622 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6623 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6625 Func_Spec : Node_Id;
6626 Decls : constant List_Id := New_List;
6627 Name_String : String_Id;
6628 Repo_Id_String : String_Id;
6632 Make_Function_Specification (Loc,
6633 Defining_Unit_Name => Fnam,
6634 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6636 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6637 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6640 Make_Subprogram_Body (Loc,
6641 Specification => Func_Spec,
6642 Declarations => Decls,
6643 Handled_Statement_Sequence =>
6644 Make_Handled_Sequence_Of_Statements (Loc,
6645 Statements => New_List (
6646 Make_Simple_Return_Statement (Loc,
6648 Make_Function_Call (Loc,
6649 Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6650 Parameter_Associations => New_List (
6651 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6652 Make_Aggregate (Loc,
6655 Make_Function_Call (Loc,
6658 (RTE (RE_TA_Std_String), Loc),
6659 Parameter_Associations => New_List (
6660 Make_String_Literal (Loc, Name_String))),
6661 Make_Function_Call (Loc,
6664 (RTE (RE_TA_Std_String), Loc),
6665 Parameter_Associations => New_List (
6666 Make_String_Literal (Loc,
6667 Strval => Repo_Id_String))))))))))));
6668 Set_TSS (RAS_Type, Fnam);
6669 end Add_RAS_TypeCode;
6671 -----------------------------------------
6672 -- Add_Receiving_Stubs_To_Declarations --
6673 -----------------------------------------
6675 procedure Add_Receiving_Stubs_To_Declarations
6676 (Pkg_Spec : Node_Id;
6680 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6682 Pkg_RPC_Receiver : constant Entity_Id :=
6683 Make_Defining_Identifier (Loc,
6684 New_Internal_Name ('H'));
6685 Pkg_RPC_Receiver_Object : Node_Id;
6686 Pkg_RPC_Receiver_Body : Node_Id;
6687 Pkg_RPC_Receiver_Decls : List_Id;
6688 Pkg_RPC_Receiver_Statements : List_Id;
6690 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6691 -- A Pkg_RPC_Receiver is built to decode the request
6694 -- Request object received from neutral layer
6696 Subp_Id : Entity_Id;
6697 -- Subprogram identifier as received from the neutral distribution
6700 Subp_Index : Entity_Id;
6701 -- Internal index as determined by matching either the method name
6702 -- from the request structure, or the local subprogram address (in
6705 Is_Local : constant Entity_Id :=
6706 Make_Defining_Identifier (Loc,
6707 Chars => New_Internal_Name ('L'));
6709 Local_Address : constant Entity_Id :=
6710 Make_Defining_Identifier (Loc,
6711 Chars => New_Internal_Name ('A'));
6712 -- Address of a local subprogram designated by a reference
6713 -- corresponding to a RAS.
6715 Dispatch_On_Address : constant List_Id := New_List;
6716 Dispatch_On_Name : constant List_Id := New_List;
6718 Current_Declaration : Node_Id;
6719 Current_Stubs : Node_Id;
6720 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6722 Subp_Info_Array : constant Entity_Id :=
6723 Make_Defining_Identifier (Loc,
6724 Chars => New_Internal_Name ('I'));
6726 Subp_Info_List : constant List_Id := New_List;
6728 Register_Pkg_Actuals : constant List_Id := New_List;
6730 All_Calls_Remote_E : Entity_Id;
6732 procedure Append_Stubs_To
6733 (RPC_Receiver_Cases : List_Id;
6734 Declaration : Node_Id;
6737 Subp_Dist_Name : Entity_Id;
6738 Subp_Proxy_Addr : Entity_Id);
6739 -- Add one case to the specified RPC receiver case list associating
6740 -- Subprogram_Number with the subprogram declared by Declaration, for
6741 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6742 -- subprogram index. Subp_Dist_Name is the string used to call the
6743 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6744 -- object, used in the context of calls through remote
6745 -- access-to-subprogram types.
6747 ---------------------
6748 -- Append_Stubs_To --
6749 ---------------------
6751 procedure Append_Stubs_To
6752 (RPC_Receiver_Cases : List_Id;
6753 Declaration : Node_Id;
6756 Subp_Dist_Name : Entity_Id;
6757 Subp_Proxy_Addr : Entity_Id)
6759 Case_Stmts : List_Id;
6761 Case_Stmts := New_List (
6762 Make_Procedure_Call_Statement (Loc,
6765 Defining_Entity (Stubs), Loc),
6766 Parameter_Associations =>
6767 New_List (New_Occurrence_Of (Request, Loc))));
6769 if Nkind (Specification (Declaration)) = N_Function_Specification
6771 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6773 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6776 Append_To (RPC_Receiver_Cases,
6777 Make_Case_Statement_Alternative (Loc,
6779 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6780 Statements => Case_Stmts));
6782 Append_To (Dispatch_On_Name,
6783 Make_Elsif_Part (Loc,
6785 Make_Function_Call (Loc,
6787 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6788 Parameter_Associations => New_List (
6789 New_Occurrence_Of (Subp_Id, Loc),
6790 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6792 Then_Statements => New_List (
6793 Make_Assignment_Statement (Loc,
6794 New_Occurrence_Of (Subp_Index, Loc),
6795 Make_Integer_Literal (Loc, Subp_Number)))));
6797 Append_To (Dispatch_On_Address,
6798 Make_Elsif_Part (Loc,
6801 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6802 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6804 Then_Statements => New_List (
6805 Make_Assignment_Statement (Loc,
6806 New_Occurrence_Of (Subp_Index, Loc),
6807 Make_Integer_Literal (Loc, Subp_Number)))));
6808 end Append_Stubs_To;
6810 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6813 -- Building receiving stubs consist in several operations:
6815 -- - a package RPC receiver must be built. This subprogram will get
6816 -- a Subprogram_Id from the incoming stream and will dispatch the
6817 -- call to the right subprogram;
6819 -- - a receiving stub for each subprogram visible in the package
6820 -- spec. This stub will read all the parameters from the stream,
6821 -- and put the result as well as the exception occurrence in the
6824 -- - a dummy package with an empty spec and a body made of an
6825 -- elaboration part, whose job is to register the receiving
6826 -- part of this RCI package on the name server. This is done
6827 -- by calling System.Partition_Interface.Register_Receiving_Stub.
6829 Build_RPC_Receiver_Body (
6830 RPC_Receiver => Pkg_RPC_Receiver,
6833 Subp_Index => Subp_Index,
6834 Stmts => Pkg_RPC_Receiver_Statements,
6835 Decl => Pkg_RPC_Receiver_Body);
6836 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6838 -- Extract local address information from the target reference:
6839 -- if non-null, that means that this is a reference that denotes
6840 -- one particular operation, and hence that the operation name
6841 -- must not be taken into account for dispatching.
6843 Append_To (Pkg_RPC_Receiver_Decls,
6844 Make_Object_Declaration (Loc,
6845 Defining_Identifier => Is_Local,
6846 Object_Definition =>
6847 New_Occurrence_Of (Standard_Boolean, Loc)));
6849 Append_To (Pkg_RPC_Receiver_Decls,
6850 Make_Object_Declaration (Loc,
6851 Defining_Identifier => Local_Address,
6852 Object_Definition =>
6853 New_Occurrence_Of (RTE (RE_Address), Loc)));
6855 Append_To (Pkg_RPC_Receiver_Statements,
6856 Make_Procedure_Call_Statement (Loc,
6857 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6858 Parameter_Associations => New_List (
6859 Make_Selected_Component (Loc,
6861 Selector_Name => Name_Target),
6862 New_Occurrence_Of (Is_Local, Loc),
6863 New_Occurrence_Of (Local_Address, Loc))));
6865 -- For each subprogram, the receiving stub will be built and a case
6866 -- statement will be made on the Subprogram_Id to dispatch to the
6867 -- right subprogram.
6869 All_Calls_Remote_E := Boolean_Literals (
6870 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6872 Overload_Counter_Table.Reset;
6873 Reserve_NamingContext_Methods;
6875 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
6876 while Present (Current_Declaration) loop
6877 if Nkind (Current_Declaration) = N_Subprogram_Declaration
6878 and then Comes_From_Source (Current_Declaration)
6881 Loc : constant Source_Ptr := Sloc (Current_Declaration);
6882 -- While specifically processing Current_Declaration, use
6883 -- its Sloc as the location of all generated nodes.
6885 Subp_Def : constant Entity_Id :=
6887 (Specification (Current_Declaration));
6889 Subp_Val : String_Id;
6891 Subp_Dist_Name : constant Entity_Id :=
6892 Make_Defining_Identifier (Loc,
6895 (Related_Id => Chars (Subp_Def),
6897 Suffix_Index => -1));
6899 Proxy_Object_Addr : Entity_Id;
6902 -- Build receiving stub
6905 Build_Subprogram_Receiving_Stubs
6906 (Vis_Decl => Current_Declaration,
6908 Nkind (Specification (Current_Declaration)) =
6909 N_Procedure_Specification
6910 and then Is_Asynchronous (Subp_Def));
6912 Append_To (Decls, Current_Stubs);
6913 Analyze (Current_Stubs);
6917 Add_RAS_Proxy_And_Analyze (Decls,
6918 Vis_Decl => Current_Declaration,
6919 All_Calls_Remote_E => All_Calls_Remote_E,
6920 Proxy_Object_Addr => Proxy_Object_Addr);
6922 -- Compute distribution identifier
6924 Assign_Subprogram_Identifier
6926 Current_Subprogram_Number,
6930 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
6933 Make_Object_Declaration (Loc,
6934 Defining_Identifier => Subp_Dist_Name,
6935 Constant_Present => True,
6936 Object_Definition =>
6937 New_Occurrence_Of (Standard_String, Loc),
6939 Make_String_Literal (Loc, Subp_Val)));
6940 Analyze (Last (Decls));
6942 -- Add subprogram descriptor (RCI_Subp_Info) to the
6943 -- subprograms table for this receiver. The aggregate
6944 -- below must be kept consistent with the declaration
6945 -- of type RCI_Subp_Info in System.Partition_Interface.
6947 Append_To (Subp_Info_List,
6948 Make_Component_Association (Loc,
6949 Choices => New_List (
6950 Make_Integer_Literal (Loc, Current_Subprogram_Number)),
6953 Make_Aggregate (Loc,
6954 Expressions => New_List (
6955 Make_Attribute_Reference (Loc,
6957 New_Occurrence_Of (Subp_Dist_Name, Loc),
6958 Attribute_Name => Name_Address),
6960 Make_Attribute_Reference (Loc,
6962 New_Occurrence_Of (Subp_Dist_Name, Loc),
6963 Attribute_Name => Name_Length),
6965 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
6967 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6968 Declaration => Current_Declaration,
6969 Stubs => Current_Stubs,
6970 Subp_Number => Current_Subprogram_Number,
6971 Subp_Dist_Name => Subp_Dist_Name,
6972 Subp_Proxy_Addr => Proxy_Object_Addr);
6975 Current_Subprogram_Number := Current_Subprogram_Number + 1;
6978 Next (Current_Declaration);
6982 Make_Object_Declaration (Loc,
6983 Defining_Identifier => Subp_Info_Array,
6984 Constant_Present => True,
6985 Aliased_Present => True,
6986 Object_Definition =>
6987 Make_Subtype_Indication (Loc,
6989 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6991 Make_Index_Or_Discriminant_Constraint (Loc,
6995 Make_Integer_Literal (Loc,
6996 Intval => First_RCI_Subprogram_Id),
6998 Make_Integer_Literal (Loc,
7000 First_RCI_Subprogram_Id
7001 + List_Length (Subp_Info_List) - 1)))))));
7003 if Present (First (Subp_Info_List)) then
7004 Set_Expression (Last (Decls),
7005 Make_Aggregate (Loc,
7006 Component_Associations => Subp_Info_List));
7008 -- Generate the dispatch statement to determine the subprogram id
7009 -- of the called subprogram.
7011 -- We first test whether the reference that was used to make the
7012 -- call was the base RCI reference (in which case Local_Address is
7013 -- zero, and the method identifier from the request must be used
7014 -- to determine which subprogram is called) or a reference
7015 -- identifying one particular subprogram (in which case
7016 -- Local_Address is the address of that subprogram, and the
7017 -- method name from the request is ignored). The latter occurs
7018 -- for the case of a call through a remote access-to-subprogram.
7020 -- In each case, cascaded elsifs are used to determine the proper
7021 -- subprogram index. Using hash tables might be more efficient.
7023 Append_To (Pkg_RPC_Receiver_Statements,
7024 Make_Implicit_If_Statement (Pkg_Spec,
7027 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
7028 Right_Opnd => New_Occurrence_Of
7029 (RTE (RE_Null_Address), Loc)),
7031 Then_Statements => New_List (
7032 Make_Implicit_If_Statement (Pkg_Spec,
7033 Condition => New_Occurrence_Of (Standard_False, Loc),
7034 Then_Statements => New_List (
7035 Make_Null_Statement (Loc)),
7036 Elsif_Parts => Dispatch_On_Address)),
7038 Else_Statements => New_List (
7039 Make_Implicit_If_Statement (Pkg_Spec,
7040 Condition => New_Occurrence_Of (Standard_False, Loc),
7041 Then_Statements => New_List (Make_Null_Statement (Loc)),
7042 Elsif_Parts => Dispatch_On_Name))));
7045 -- For a degenerate RCI with no visible subprograms,
7046 -- Subp_Info_List has zero length, and the declaration is for an
7047 -- empty array, in which case no initialization aggregate must be
7048 -- generated. We do not generate a Dispatch_Statement either.
7050 -- No initialization provided: remove CONSTANT so that the
7051 -- declaration is not an incomplete deferred constant.
7053 Set_Constant_Present (Last (Decls), False);
7056 -- Analyze Subp_Info_Array declaration
7058 Analyze (Last (Decls));
7060 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7061 -- rather than raising an exception since we do not want someone
7062 -- to crash a remote partition by sending invalid subprogram ids.
7063 -- This is consistent with the other parts of the case statement
7064 -- since even in presence of incorrect parameters in the stream,
7065 -- every exception will be caught and (if the subprogram is not an
7066 -- APC) put into the result stream and sent away.
7068 Append_To (Pkg_RPC_Receiver_Cases,
7069 Make_Case_Statement_Alternative (Loc,
7070 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
7071 Statements => New_List (Make_Null_Statement (Loc))));
7073 Append_To (Pkg_RPC_Receiver_Statements,
7074 Make_Case_Statement (Loc,
7075 Expression => New_Occurrence_Of (Subp_Index, Loc),
7076 Alternatives => Pkg_RPC_Receiver_Cases));
7078 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7081 Append_To (Decls, Pkg_RPC_Receiver_Body);
7082 Analyze (Last (Decls));
7084 Pkg_RPC_Receiver_Object :=
7085 Make_Object_Declaration (Loc,
7086 Defining_Identifier =>
7087 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
7088 Aliased_Present => True,
7089 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
7090 Append_To (Decls, Pkg_RPC_Receiver_Object);
7091 Analyze (Last (Decls));
7093 Get_Library_Unit_Name_String (Pkg_Spec);
7097 Append_To (Register_Pkg_Actuals,
7098 Make_String_Literal (Loc,
7099 Strval => String_From_Name_Buffer));
7103 Append_To (Register_Pkg_Actuals,
7104 Make_Attribute_Reference (Loc,
7107 (Defining_Entity (Pkg_Spec), Loc),
7108 Attribute_Name => Name_Version));
7112 Append_To (Register_Pkg_Actuals,
7113 Make_Attribute_Reference (Loc,
7115 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7116 Attribute_Name => Name_Access));
7120 Append_To (Register_Pkg_Actuals,
7121 Make_Attribute_Reference (Loc,
7124 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc),
7125 Attribute_Name => Name_Access));
7129 Append_To (Register_Pkg_Actuals,
7130 Make_Attribute_Reference (Loc,
7131 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7132 Attribute_Name => Name_Address));
7136 Append_To (Register_Pkg_Actuals,
7137 Make_Attribute_Reference (Loc,
7138 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7139 Attribute_Name => Name_Length));
7141 -- Is_All_Calls_Remote
7143 Append_To (Register_Pkg_Actuals,
7144 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7149 Make_Procedure_Call_Statement (Loc,
7151 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7152 Parameter_Associations => Register_Pkg_Actuals));
7153 Analyze (Last (Stmts));
7154 end Add_Receiving_Stubs_To_Declarations;
7156 ---------------------------------
7157 -- Build_General_Calling_Stubs --
7158 ---------------------------------
7160 procedure Build_General_Calling_Stubs
7162 Statements : List_Id;
7163 Target_Object : Node_Id;
7164 Subprogram_Id : Node_Id;
7165 Asynchronous : Node_Id := Empty;
7166 Is_Known_Asynchronous : Boolean := False;
7167 Is_Known_Non_Asynchronous : Boolean := False;
7168 Is_Function : Boolean;
7170 Stub_Type : Entity_Id := Empty;
7171 RACW_Type : Entity_Id := Empty;
7174 Loc : constant Source_Ptr := Sloc (Nod);
7176 Request : constant Entity_Id :=
7177 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7178 -- The request object constructed by these stubs
7179 -- Could we use Name_R instead??? (see GLADE client stubs)
7181 function Make_Request_RTE_Call
7183 Actuals : List_Id := New_List) return Node_Id;
7184 -- Generate a procedure call statement calling RE with the given
7185 -- actuals. Request is appended to the list.
7187 ---------------------------
7188 -- Make_Request_RTE_Call --
7189 ---------------------------
7191 function Make_Request_RTE_Call
7193 Actuals : List_Id := New_List) return Node_Id
7196 Append_To (Actuals, New_Occurrence_Of (Request, Loc));
7197 return Make_Procedure_Call_Statement (Loc,
7199 New_Occurrence_Of (RTE (RE), Loc),
7200 Parameter_Associations => Actuals);
7201 end Make_Request_RTE_Call;
7203 Arguments : Node_Id;
7204 -- Name of the named values list used to transmit parameters
7205 -- to the remote package
7208 -- Name of the result named value (in non-APC cases) which get the
7209 -- result of the remote subprogram.
7211 Result_TC : Node_Id;
7212 -- Typecode expression for the result of the request (void
7213 -- typecode for procedures).
7215 Exception_Return_Parameter : Node_Id;
7216 -- Name of the parameter which will hold the exception sent by the
7217 -- remote subprogram.
7219 Current_Parameter : Node_Id;
7220 -- Current parameter being handled
7222 Ordered_Parameters_List : constant List_Id :=
7223 Build_Ordered_Parameters_List (Spec);
7225 Asynchronous_P : Node_Id;
7226 -- A Boolean expression indicating whether this call is asynchronous
7228 Asynchronous_Statements : List_Id := No_List;
7229 Non_Asynchronous_Statements : List_Id := No_List;
7230 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7232 Extra_Formal_Statements : constant List_Id := New_List;
7233 -- List of statements for extra formal parameters. It will appear
7234 -- after the regular statements for writing out parameters.
7236 After_Statements : constant List_Id := New_List;
7237 -- Statements to be executed after call returns (to assign IN OUT or
7238 -- OUT parameter values).
7241 -- The type of the formal parameter being processed
7243 Is_Controlling_Formal : Boolean;
7244 Is_First_Controlling_Formal : Boolean;
7245 First_Controlling_Formal_Seen : Boolean := False;
7246 -- Controlling formal parameters of distributed object primitives
7247 -- require special handling, and the first such parameter needs even
7248 -- more special handling.
7251 -- ??? document general form of stub subprograms for the PolyORB case
7254 Make_Object_Declaration (Loc,
7255 Defining_Identifier => Request,
7256 Aliased_Present => False,
7257 Object_Definition =>
7258 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
7261 Make_Defining_Identifier (Loc,
7262 Chars => New_Internal_Name ('R'));
7266 PolyORB_Support.Helpers.Build_TypeCode_Call
7267 (Loc, Etype (Result_Definition (Spec)), Decls);
7269 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7273 Make_Object_Declaration (Loc,
7274 Defining_Identifier => Result,
7275 Aliased_Present => False,
7276 Object_Definition =>
7277 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7279 Make_Aggregate (Loc,
7280 Component_Associations => New_List (
7281 Make_Component_Association (Loc,
7282 Choices => New_List (Make_Identifier (Loc, Name_Name)),
7284 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7285 Make_Component_Association (Loc,
7286 Choices => New_List (
7287 Make_Identifier (Loc, Name_Argument)),
7289 Make_Function_Call (Loc,
7290 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7291 Parameter_Associations => New_List (Result_TC))),
7292 Make_Component_Association (Loc,
7293 Choices => New_List (
7294 Make_Identifier (Loc, Name_Arg_Modes)),
7295 Expression => Make_Integer_Literal (Loc, 0))))));
7297 if not Is_Known_Asynchronous then
7298 Exception_Return_Parameter :=
7299 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7302 Make_Object_Declaration (Loc,
7303 Defining_Identifier => Exception_Return_Parameter,
7304 Object_Definition =>
7305 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7308 Exception_Return_Parameter := Empty;
7311 -- Initialize and fill in arguments list
7314 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7315 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7317 Current_Parameter := First (Ordered_Parameters_List);
7318 while Present (Current_Parameter) loop
7319 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7320 Is_Controlling_Formal := True;
7321 Is_First_Controlling_Formal :=
7322 not First_Controlling_Formal_Seen;
7323 First_Controlling_Formal_Seen := True;
7326 Is_Controlling_Formal := False;
7327 Is_First_Controlling_Formal := False;
7330 if Is_Controlling_Formal then
7332 -- For a controlling formal argument, we send its reference
7337 Etyp := Etype (Parameter_Type (Current_Parameter));
7340 -- The first controlling formal parameter is treated specially:
7341 -- it is used to set the target object of the call.
7343 if not Is_First_Controlling_Formal then
7345 Constrained : constant Boolean :=
7346 Is_Constrained (Etyp)
7347 or else Is_Elementary_Type (Etyp);
7349 Any : constant Entity_Id :=
7350 Make_Defining_Identifier (Loc,
7351 New_Internal_Name ('A'));
7353 Actual_Parameter : Node_Id :=
7355 Defining_Identifier (
7356 Current_Parameter), Loc);
7361 if Is_Controlling_Formal then
7363 -- For a controlling formal parameter (other than the
7364 -- first one), use the corresponding RACW. If the
7365 -- parameter is not an anonymous access parameter, that
7366 -- involves taking its 'Unrestricted_Access.
7368 if Nkind (Parameter_Type (Current_Parameter))
7369 = N_Access_Definition
7371 Actual_Parameter := OK_Convert_To
7372 (Etyp, Actual_Parameter);
7374 Actual_Parameter := OK_Convert_To (Etyp,
7375 Make_Attribute_Reference (Loc,
7376 Prefix => Actual_Parameter,
7377 Attribute_Name => Name_Unrestricted_Access));
7382 if In_Present (Current_Parameter)
7383 or else not Out_Present (Current_Parameter)
7384 or else not Constrained
7385 or else Is_Controlling_Formal
7387 -- The parameter has an input value, is constrained at
7388 -- runtime by an input value, or is a controlling formal
7389 -- parameter (always passed as a reference) other than
7392 Expr := PolyORB_Support.Helpers.Build_To_Any_Call
7393 (Actual_Parameter, Decls);
7396 Expr := Make_Function_Call (Loc,
7397 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7398 Parameter_Associations => New_List (
7399 PolyORB_Support.Helpers.Build_TypeCode_Call
7400 (Loc, Etyp, Decls)));
7404 Make_Object_Declaration (Loc,
7405 Defining_Identifier => Any,
7406 Aliased_Present => False,
7407 Object_Definition =>
7408 New_Occurrence_Of (RTE (RE_Any), Loc),
7409 Expression => Expr));
7411 Append_To (Statements,
7412 Add_Parameter_To_NVList (Loc,
7413 Parameter => Current_Parameter,
7414 NVList => Arguments,
7415 Constrained => Constrained,
7418 if Out_Present (Current_Parameter)
7419 and then not Is_Controlling_Formal
7421 if Is_Limited_Type (Etyp) then
7422 Helpers.Assign_Opaque_From_Any (Loc,
7423 Stms => After_Statements,
7425 N => New_Occurrence_Of (Any, Loc),
7427 Defining_Identifier (Current_Parameter));
7429 Append_To (After_Statements,
7430 Make_Assignment_Statement (Loc,
7433 Defining_Identifier (Current_Parameter), Loc),
7435 PolyORB_Support.Helpers.Build_From_Any_Call
7437 New_Occurrence_Of (Any, Loc),
7444 -- If the current parameter has a dynamic constrained status, then
7445 -- this status is transmitted as well.
7446 -- This should be done for accessibility as well ???
7448 if Nkind (Parameter_Type (Current_Parameter)) /=
7450 and then Need_Extra_Constrained (Current_Parameter)
7452 -- In this block, we do not use the extra formal that has been
7453 -- created because it does not exist at the time of expansion
7454 -- when building calling stubs for remote access to subprogram
7455 -- types. We create an extra variable of this type and push it
7456 -- in the stream after the regular parameters.
7459 Extra_Any_Parameter : constant Entity_Id :=
7460 Make_Defining_Identifier
7461 (Loc, New_Internal_Name ('P'));
7463 Parameter_Exp : constant Node_Id :=
7464 Make_Attribute_Reference (Loc,
7465 Prefix => New_Occurrence_Of (
7466 Defining_Identifier (Current_Parameter), Loc),
7467 Attribute_Name => Name_Constrained);
7470 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7473 Make_Object_Declaration (Loc,
7474 Defining_Identifier => Extra_Any_Parameter,
7475 Aliased_Present => False,
7476 Object_Definition =>
7477 New_Occurrence_Of (RTE (RE_Any), Loc),
7479 PolyORB_Support.Helpers.Build_To_Any_Call
7480 (Parameter_Exp, Decls)));
7482 Append_To (Extra_Formal_Statements,
7483 Add_Parameter_To_NVList (Loc,
7484 Parameter => Extra_Any_Parameter,
7485 NVList => Arguments,
7486 Constrained => True,
7487 Any => Extra_Any_Parameter));
7491 Next (Current_Parameter);
7494 -- Append the formal statements list to the statements
7496 Append_List_To (Statements, Extra_Formal_Statements);
7498 Append_To (Statements,
7499 Make_Request_RTE_Call (RE_Request_Create, New_List (
7502 New_Occurrence_Of (Arguments, Loc),
7503 New_Occurrence_Of (Result, Loc),
7505 (RTE (RE_Nil_Exc_List), Loc))));
7508 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7510 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7513 (Boolean_Literals (Is_Known_Asynchronous), Loc);
7516 pragma Assert (Present (Asynchronous));
7517 Asynchronous_P := New_Copy_Tree (Asynchronous);
7519 -- The expression node Asynchronous will be used to build an 'if'
7520 -- statement at the end of Build_General_Calling_Stubs: we need to
7521 -- make a copy here.
7524 Append_To (Parameter_Associations (Last (Statements)),
7525 Make_Indexed_Component (Loc,
7528 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7529 Expressions => New_List (Asynchronous_P)));
7531 Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke));
7533 -- Asynchronous case
7535 if not Is_Known_Non_Asynchronous then
7536 Asynchronous_Statements :=
7537 New_List (Make_Request_RTE_Call (RE_Request_Destroy));
7540 -- Non-asynchronous case
7542 if not Is_Known_Asynchronous then
7543 -- Reraise an exception occurrence from the completed request.
7544 -- If the exception occurrence is empty, this is a no-op.
7546 Non_Asynchronous_Statements := New_List (
7547 Make_Procedure_Call_Statement (Loc,
7549 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7550 Parameter_Associations => New_List (
7551 New_Occurrence_Of (Request, Loc))));
7555 Append_To (Non_Asynchronous_Statements,
7556 Make_Request_RTE_Call (RE_Request_Destroy));
7558 -- If this is a function call, read the value and return it
7560 Append_To (Non_Asynchronous_Statements,
7561 Make_Tag_Check (Loc,
7562 Make_Simple_Return_Statement (Loc,
7563 PolyORB_Support.Helpers.Build_From_Any_Call
7564 (Etype (Result_Definition (Spec)),
7565 Make_Selected_Component (Loc,
7567 Selector_Name => Name_Argument),
7572 -- Case of a procedure: deal with IN OUT and OUT formals
7574 Append_List_To (Non_Asynchronous_Statements, After_Statements);
7576 Append_To (Non_Asynchronous_Statements,
7577 Make_Request_RTE_Call (RE_Request_Destroy));
7581 if Is_Known_Asynchronous then
7582 Append_List_To (Statements, Asynchronous_Statements);
7584 elsif Is_Known_Non_Asynchronous then
7585 Append_List_To (Statements, Non_Asynchronous_Statements);
7588 pragma Assert (Present (Asynchronous));
7589 Append_To (Statements,
7590 Make_Implicit_If_Statement (Nod,
7591 Condition => Asynchronous,
7592 Then_Statements => Asynchronous_Statements,
7593 Else_Statements => Non_Asynchronous_Statements));
7595 end Build_General_Calling_Stubs;
7597 -----------------------
7598 -- Build_Stub_Target --
7599 -----------------------
7601 function Build_Stub_Target
7604 RCI_Locator : Entity_Id;
7605 Controlling_Parameter : Entity_Id) return RPC_Target
7607 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7608 Target_Reference : constant Entity_Id :=
7609 Make_Defining_Identifier (Loc,
7610 New_Internal_Name ('T'));
7612 if Present (Controlling_Parameter) then
7614 Make_Object_Declaration (Loc,
7615 Defining_Identifier => Target_Reference,
7617 Object_Definition =>
7618 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7621 Make_Function_Call (Loc,
7623 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7624 Parameter_Associations => New_List (
7625 Make_Selected_Component (Loc,
7626 Prefix => Controlling_Parameter,
7627 Selector_Name => Name_Target)))));
7629 -- Note: Controlling_Parameter has the same components as
7630 -- System.Partition_Interface.RACW_Stub_Type.
7632 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7635 Target_Info.Object :=
7636 Make_Selected_Component (Loc,
7637 Prefix => Make_Identifier (Loc, Chars (RCI_Locator)),
7639 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7643 end Build_Stub_Target;
7645 ---------------------
7646 -- Build_Stub_Type --
7647 ---------------------
7649 procedure Build_Stub_Type
7650 (RACW_Type : Entity_Id;
7651 Stub_Type_Comps : out List_Id;
7652 RPC_Receiver_Decl : out Node_Id)
7654 Loc : constant Source_Ptr := Sloc (RACW_Type);
7657 Stub_Type_Comps := New_List (
7658 Make_Component_Declaration (Loc,
7659 Defining_Identifier =>
7660 Make_Defining_Identifier (Loc, Name_Target),
7661 Component_Definition =>
7662 Make_Component_Definition (Loc,
7663 Aliased_Present => False,
7664 Subtype_Indication =>
7665 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7667 Make_Component_Declaration (Loc,
7668 Defining_Identifier =>
7669 Make_Defining_Identifier (Loc, Name_Asynchronous),
7671 Component_Definition =>
7672 Make_Component_Definition (Loc,
7673 Aliased_Present => False,
7674 Subtype_Indication =>
7675 New_Occurrence_Of (Standard_Boolean, Loc))));
7677 RPC_Receiver_Decl :=
7678 Make_Object_Declaration (Loc,
7679 Defining_Identifier => Make_Defining_Identifier (Loc,
7680 New_Internal_Name ('R')),
7681 Aliased_Present => True,
7682 Object_Definition =>
7683 New_Occurrence_Of (RTE (RE_Servant), Loc));
7684 end Build_Stub_Type;
7686 -----------------------------
7687 -- Build_RPC_Receiver_Body --
7688 -----------------------------
7690 procedure Build_RPC_Receiver_Body
7691 (RPC_Receiver : Entity_Id;
7692 Request : out Entity_Id;
7693 Subp_Id : out Entity_Id;
7694 Subp_Index : out Entity_Id;
7695 Stmts : out List_Id;
7698 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7700 RPC_Receiver_Spec : Node_Id;
7701 RPC_Receiver_Decls : List_Id;
7704 Request := Make_Defining_Identifier (Loc, Name_R);
7706 RPC_Receiver_Spec :=
7707 Build_RPC_Receiver_Specification
7708 (RPC_Receiver => RPC_Receiver,
7709 Request_Parameter => Request);
7711 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7712 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7714 RPC_Receiver_Decls := New_List (
7715 Make_Object_Renaming_Declaration (Loc,
7716 Defining_Identifier => Subp_Id,
7717 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7719 Make_Explicit_Dereference (Loc,
7721 Make_Selected_Component (Loc,
7723 Selector_Name => Name_Operation))),
7725 Make_Object_Declaration (Loc,
7726 Defining_Identifier => Subp_Index,
7727 Object_Definition =>
7728 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7730 Make_Attribute_Reference (Loc,
7732 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7733 Attribute_Name => Name_Last)));
7738 Make_Subprogram_Body (Loc,
7739 Specification => RPC_Receiver_Spec,
7740 Declarations => RPC_Receiver_Decls,
7741 Handled_Statement_Sequence =>
7742 Make_Handled_Sequence_Of_Statements (Loc,
7743 Statements => Stmts));
7744 end Build_RPC_Receiver_Body;
7746 --------------------------------------
7747 -- Build_Subprogram_Receiving_Stubs --
7748 --------------------------------------
7750 function Build_Subprogram_Receiving_Stubs
7751 (Vis_Decl : Node_Id;
7752 Asynchronous : Boolean;
7753 Dynamically_Asynchronous : Boolean := False;
7754 Stub_Type : Entity_Id := Empty;
7755 RACW_Type : Entity_Id := Empty;
7756 Parent_Primitive : Entity_Id := Empty) return Node_Id
7758 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7760 Request_Parameter : constant Entity_Id :=
7761 Make_Defining_Identifier (Loc,
7762 New_Internal_Name ('R'));
7763 -- Formal parameter for receiving stubs: a descriptor for an incoming
7766 Outer_Decls : constant List_Id := New_List;
7767 -- At the outermost level, an NVList and Any's are declared for all
7768 -- parameters. The Dynamic_Async flag also needs to be declared there
7769 -- to be visible from the exception handling code.
7771 Outer_Statements : constant List_Id := New_List;
7772 -- Statements that occur prior to the declaration of the actual
7773 -- parameter variables.
7775 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7776 -- Statements concerning extra formal parameters, prior to the
7777 -- declaration of the actual parameter variables.
7779 Decls : constant List_Id := New_List;
7780 -- All the parameters will get declared before calling the real
7781 -- subprograms. Also the out parameters will be declared. At this
7782 -- level, parameters may be unconstrained.
7784 Statements : constant List_Id := New_List;
7786 After_Statements : constant List_Id := New_List;
7787 -- Statements to be executed after the subprogram call
7789 Inner_Decls : List_Id := No_List;
7790 -- In case of a function, the inner declarations are needed since
7791 -- the result may be unconstrained.
7793 Excep_Handlers : List_Id := No_List;
7795 Parameter_List : constant List_Id := New_List;
7796 -- List of parameters to be passed to the subprogram
7798 First_Controlling_Formal_Seen : Boolean := False;
7800 Current_Parameter : Node_Id;
7802 Ordered_Parameters_List : constant List_Id :=
7803 Build_Ordered_Parameters_List
7804 (Specification (Vis_Decl));
7806 Arguments : constant Entity_Id :=
7807 Make_Defining_Identifier (Loc,
7808 New_Internal_Name ('A'));
7809 -- Name of the named values list used to retrieve parameters
7811 Subp_Spec : Node_Id;
7812 -- Subprogram specification
7814 Called_Subprogram : Node_Id;
7815 -- The subprogram to call
7818 if Present (RACW_Type) then
7819 Called_Subprogram :=
7820 New_Occurrence_Of (Parent_Primitive, Loc);
7822 Called_Subprogram :=
7824 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7827 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7829 -- Loop through every parameter and get its value from the stream. If
7830 -- the parameter is unconstrained, then the parameter is read using
7831 -- 'Input at the point of declaration.
7833 Current_Parameter := First (Ordered_Parameters_List);
7834 while Present (Current_Parameter) loop
7837 Constrained : Boolean;
7838 Any : Entity_Id := Empty;
7839 Object : constant Entity_Id :=
7840 Make_Defining_Identifier (Loc,
7841 Chars => New_Internal_Name ('P'));
7842 Expr : Node_Id := Empty;
7844 Is_Controlling_Formal : constant Boolean :=
7845 Is_RACW_Controlling_Formal
7846 (Current_Parameter, Stub_Type);
7848 Is_First_Controlling_Formal : Boolean := False;
7850 Need_Extra_Constrained : Boolean;
7851 -- True when an extra constrained actual is required
7854 if Is_Controlling_Formal then
7856 -- Controlling formals in distributed object primitive
7857 -- operations are handled specially:
7859 -- - the first controlling formal is used as the
7860 -- target of the call;
7862 -- - the remaining controlling formals are transmitted
7866 Is_First_Controlling_Formal :=
7867 not First_Controlling_Formal_Seen;
7868 First_Controlling_Formal_Seen := True;
7871 Etyp := Etype (Parameter_Type (Current_Parameter));
7875 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
7877 if not Is_First_Controlling_Formal then
7879 Make_Defining_Identifier (Loc,
7880 Chars => New_Internal_Name ('A'));
7882 Append_To (Outer_Decls,
7883 Make_Object_Declaration (Loc,
7884 Defining_Identifier => Any,
7885 Object_Definition =>
7886 New_Occurrence_Of (RTE (RE_Any), Loc),
7888 Make_Function_Call (Loc,
7889 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7890 Parameter_Associations => New_List (
7891 PolyORB_Support.Helpers.Build_TypeCode_Call
7892 (Loc, Etyp, Outer_Decls)))));
7894 Append_To (Outer_Statements,
7895 Add_Parameter_To_NVList (Loc,
7896 Parameter => Current_Parameter,
7897 NVList => Arguments,
7898 Constrained => Constrained,
7902 if Is_First_Controlling_Formal then
7904 Addr : constant Entity_Id :=
7905 Make_Defining_Identifier (Loc,
7906 Chars => New_Internal_Name ('A'));
7908 Is_Local : constant Entity_Id :=
7909 Make_Defining_Identifier (Loc,
7910 Chars => New_Internal_Name ('L'));
7913 -- Special case: obtain the first controlling formal
7914 -- from the target of the remote call, instead of the
7917 Append_To (Outer_Decls,
7918 Make_Object_Declaration (Loc,
7919 Defining_Identifier => Addr,
7920 Object_Definition =>
7921 New_Occurrence_Of (RTE (RE_Address), Loc)));
7923 Append_To (Outer_Decls,
7924 Make_Object_Declaration (Loc,
7925 Defining_Identifier => Is_Local,
7926 Object_Definition =>
7927 New_Occurrence_Of (Standard_Boolean, Loc)));
7929 Append_To (Outer_Statements,
7930 Make_Procedure_Call_Statement (Loc,
7932 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7933 Parameter_Associations => New_List (
7934 Make_Selected_Component (Loc,
7937 Request_Parameter, Loc),
7939 Make_Identifier (Loc, Name_Target)),
7940 New_Occurrence_Of (Is_Local, Loc),
7941 New_Occurrence_Of (Addr, Loc))));
7943 Expr := Unchecked_Convert_To (RACW_Type,
7944 New_Occurrence_Of (Addr, Loc));
7947 elsif In_Present (Current_Parameter)
7948 or else not Out_Present (Current_Parameter)
7949 or else not Constrained
7951 -- If an input parameter is constrained, then its reading is
7952 -- deferred until the beginning of the subprogram body. If
7953 -- it is unconstrained, then an expression is built for
7954 -- the object declaration and the variable is set using
7955 -- 'Input instead of 'Read.
7957 if Constrained and then Is_Limited_Type (Etyp) then
7958 Helpers.Assign_Opaque_From_Any (Loc,
7961 N => New_Occurrence_Of (Any, Loc),
7965 Expr := Helpers.Build_From_Any_Call
7966 (Etyp, New_Occurrence_Of (Any, Loc), Decls);
7969 Append_To (Statements,
7970 Make_Assignment_Statement (Loc,
7971 Name => New_Occurrence_Of (Object, Loc),
7972 Expression => Expr));
7976 -- Expr will be used to initialize (and constrain) the
7977 -- parameter when it is declared.
7985 Need_Extra_Constrained :=
7986 Nkind (Parameter_Type (Current_Parameter)) /=
7989 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7991 Present (Extra_Constrained
7992 (Defining_Identifier (Current_Parameter)));
7994 -- We may not associate an extra constrained actual to a
7995 -- constant object, so if one is needed, declare the actual
7996 -- as a variable even if it won't be modified.
7998 Build_Actual_Object_Declaration
8001 Variable => Need_Extra_Constrained
8002 or else Out_Present (Current_Parameter),
8005 Set_Etype (Object, Etyp);
8007 -- An out parameter may be written back using a 'Write
8008 -- attribute instead of a 'Output because it has been
8009 -- constrained by the parameter given to the caller. Note that
8010 -- out controlling arguments in the case of a RACW are not put
8011 -- back in the stream because the pointer on them has not
8014 if Out_Present (Current_Parameter)
8015 and then not Is_Controlling_Formal
8017 Append_To (After_Statements,
8018 Make_Procedure_Call_Statement (Loc,
8019 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
8020 Parameter_Associations => New_List (
8021 New_Occurrence_Of (Any, Loc),
8022 PolyORB_Support.Helpers.Build_To_Any_Call
8023 (New_Occurrence_Of (Object, Loc), Decls))));
8026 -- For RACW controlling formals, the Etyp of Object is always
8027 -- an RACW, even if the parameter is not of an anonymous access
8028 -- type. In such case, we need to dereference it at call time.
8030 if Is_Controlling_Formal then
8031 if Nkind (Parameter_Type (Current_Parameter)) /=
8034 Append_To (Parameter_List,
8035 Make_Parameter_Association (Loc,
8038 (Defining_Identifier (Current_Parameter), Loc),
8039 Explicit_Actual_Parameter =>
8040 Make_Explicit_Dereference (Loc,
8041 Prefix => New_Occurrence_Of (Object, Loc))));
8044 Append_To (Parameter_List,
8045 Make_Parameter_Association (Loc,
8048 (Defining_Identifier (Current_Parameter), Loc),
8050 Explicit_Actual_Parameter =>
8051 New_Occurrence_Of (Object, Loc)));
8055 Append_To (Parameter_List,
8056 Make_Parameter_Association (Loc,
8059 Defining_Identifier (Current_Parameter), Loc),
8060 Explicit_Actual_Parameter =>
8061 New_Occurrence_Of (Object, Loc)));
8064 -- If the current parameter needs an extra formal, then read it
8065 -- from the stream and set the corresponding semantic field in
8066 -- the variable. If the kind of the parameter identifier is
8067 -- E_Void, then this is a compiler generated parameter that
8068 -- doesn't need an extra constrained status.
8070 -- The case of Extra_Accessibility should also be handled ???
8072 if Need_Extra_Constrained then
8074 Extra_Parameter : constant Entity_Id :=
8076 (Defining_Identifier
8077 (Current_Parameter));
8079 Extra_Any : constant Entity_Id :=
8080 Make_Defining_Identifier (Loc,
8081 Chars => New_Internal_Name ('A'));
8083 Formal_Entity : constant Entity_Id :=
8084 Make_Defining_Identifier (Loc,
8085 Chars => Chars (Extra_Parameter));
8087 Formal_Type : constant Entity_Id :=
8088 Etype (Extra_Parameter);
8091 Append_To (Outer_Decls,
8092 Make_Object_Declaration (Loc,
8093 Defining_Identifier => Extra_Any,
8094 Object_Definition =>
8095 New_Occurrence_Of (RTE (RE_Any), Loc),
8097 Make_Function_Call (Loc,
8099 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8100 Parameter_Associations => New_List (
8101 PolyORB_Support.Helpers.Build_TypeCode_Call
8102 (Loc, Formal_Type, Outer_Decls)))));
8104 Append_To (Outer_Extra_Formal_Statements,
8105 Add_Parameter_To_NVList (Loc,
8106 Parameter => Extra_Parameter,
8107 NVList => Arguments,
8108 Constrained => True,
8112 Make_Object_Declaration (Loc,
8113 Defining_Identifier => Formal_Entity,
8114 Object_Definition =>
8115 New_Occurrence_Of (Formal_Type, Loc)));
8117 Append_To (Statements,
8118 Make_Assignment_Statement (Loc,
8119 Name => New_Occurrence_Of (Formal_Entity, Loc),
8121 PolyORB_Support.Helpers.Build_From_Any_Call
8123 New_Occurrence_Of (Extra_Any, Loc),
8125 Set_Extra_Constrained (Object, Formal_Entity);
8130 Next (Current_Parameter);
8133 -- Extra Formals should go after all the other parameters
8135 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8137 Append_To (Outer_Statements,
8138 Make_Procedure_Call_Statement (Loc,
8139 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8140 Parameter_Associations => New_List (
8141 New_Occurrence_Of (Request_Parameter, Loc),
8142 New_Occurrence_Of (Arguments, Loc))));
8144 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8146 -- The remote subprogram is a function: Build an inner block to be
8147 -- able to hold a potentially unconstrained result in a variable.
8150 Etyp : constant Entity_Id :=
8151 Etype (Result_Definition (Specification (Vis_Decl)));
8152 Result : constant Node_Id :=
8153 Make_Defining_Identifier (Loc,
8154 Chars => New_Internal_Name ('R'));
8157 Inner_Decls := New_List (
8158 Make_Object_Declaration (Loc,
8159 Defining_Identifier => Result,
8160 Constant_Present => True,
8161 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8163 Make_Function_Call (Loc,
8164 Name => Called_Subprogram,
8165 Parameter_Associations => Parameter_List)));
8167 if Is_Class_Wide_Type (Etyp) then
8169 -- For a remote call to a function with a class-wide type,
8170 -- check that the returned value satisfies the requirements
8173 Append_To (Inner_Decls,
8174 Make_Transportable_Check (Loc,
8175 New_Occurrence_Of (Result, Loc)));
8179 Set_Etype (Result, Etyp);
8180 Append_To (After_Statements,
8181 Make_Procedure_Call_Statement (Loc,
8182 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8183 Parameter_Associations => New_List (
8184 New_Occurrence_Of (Request_Parameter, Loc),
8185 PolyORB_Support.Helpers.Build_To_Any_Call
8186 (New_Occurrence_Of (Result, Loc), Decls))));
8188 -- A DSA function does not have out or inout arguments
8191 Append_To (Statements,
8192 Make_Block_Statement (Loc,
8193 Declarations => Inner_Decls,
8194 Handled_Statement_Sequence =>
8195 Make_Handled_Sequence_Of_Statements (Loc,
8196 Statements => After_Statements)));
8199 -- The remote subprogram is a procedure. We do not need any inner
8200 -- block in this case. No specific processing is required here for
8201 -- the dynamically asynchronous case: the indication of whether
8202 -- call is asynchronous or not is managed by the Sync_Scope
8203 -- attibute of the request, and is handled entirely in the
8206 Append_To (After_Statements,
8207 Make_Procedure_Call_Statement (Loc,
8208 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8209 Parameter_Associations => New_List (
8210 New_Occurrence_Of (Request_Parameter, Loc))));
8212 Append_To (Statements,
8213 Make_Procedure_Call_Statement (Loc,
8214 Name => Called_Subprogram,
8215 Parameter_Associations => Parameter_List));
8217 Append_List_To (Statements, After_Statements);
8221 Make_Procedure_Specification (Loc,
8222 Defining_Unit_Name =>
8223 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
8225 Parameter_Specifications => New_List (
8226 Make_Parameter_Specification (Loc,
8227 Defining_Identifier => Request_Parameter,
8229 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8231 -- An exception raised during the execution of an incoming remote
8232 -- subprogram call and that needs to be sent back to the caller is
8233 -- propagated by the receiving stubs, and will be handled by the
8234 -- caller (the distribution runtime).
8236 if Asynchronous and then not Dynamically_Asynchronous then
8238 -- For an asynchronous procedure, add a null exception handler
8240 Excep_Handlers := New_List (
8241 Make_Implicit_Exception_Handler (Loc,
8242 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8243 Statements => New_List (Make_Null_Statement (Loc))));
8246 -- In the other cases, if an exception is raised, then the
8247 -- exception occurrence is propagated.
8252 Append_To (Outer_Statements,
8253 Make_Block_Statement (Loc,
8254 Declarations => Decls,
8255 Handled_Statement_Sequence =>
8256 Make_Handled_Sequence_Of_Statements (Loc,
8257 Statements => Statements)));
8260 Make_Subprogram_Body (Loc,
8261 Specification => Subp_Spec,
8262 Declarations => Outer_Decls,
8263 Handled_Statement_Sequence =>
8264 Make_Handled_Sequence_Of_Statements (Loc,
8265 Statements => Outer_Statements,
8266 Exception_Handlers => Excep_Handlers));
8267 end Build_Subprogram_Receiving_Stubs;
8273 package body Helpers is
8275 -----------------------
8276 -- Local Subprograms --
8277 -----------------------
8279 function Find_Numeric_Representation
8280 (Typ : Entity_Id) return Entity_Id;
8281 -- Given a numeric type Typ, return the smallest integer or floating
8282 -- point type from Standard, or the smallest unsigned (modular) type
8283 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8285 function Make_Helper_Function_Name
8288 Nam : Name_Id) return Entity_Id;
8289 -- Return the name to be assigned for helper subprogram Nam of Typ
8291 ------------------------------------------------------------
8292 -- Common subprograms for building various tree fragments --
8293 ------------------------------------------------------------
8295 function Build_Get_Aggregate_Element
8299 Idx : Node_Id) return Node_Id;
8300 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8301 -- returning the Idx'th element.
8304 Subprogram : Entity_Id;
8305 -- Reference location for constructed nodes
8308 -- For 'Range and Etype
8311 -- For the construction of the innermost element expression
8313 with procedure Add_Process_Element
8316 Counter : Entity_Id;
8319 procedure Append_Array_Traversal
8322 Counter : Entity_Id := Empty;
8324 -- Build nested loop statements that iterate over the elements of an
8325 -- array Arry. The statement(s) built by Add_Process_Element are
8326 -- executed for each element; Indices is the list of indices to be
8327 -- used in the construction of the indexed component that denotes the
8328 -- current element. Subprogram is the entity for the subprogram for
8329 -- which this iterator is generated. The generated statements are
8330 -- appended to Stmts.
8334 -- The record entity being dealt with
8336 with procedure Add_Process_Element
8338 Container : Node_Or_Entity_Id;
8339 Counter : in out Int;
8342 -- Rec is the instance of the record type, or Empty.
8343 -- Field is either the N_Defining_Identifier for a component,
8344 -- or an N_Variant_Part.
8346 procedure Append_Record_Traversal
8349 Container : Node_Or_Entity_Id;
8350 Counter : in out Int);
8351 -- Process component list Clist. Individual fields are passed
8352 -- to Field_Processing. Each variant part is also processed.
8353 -- Container is the outer Any (for From_Any/To_Any),
8354 -- the outer typecode (for TC) to which the operation applies.
8356 -----------------------------
8357 -- Append_Record_Traversal --
8358 -----------------------------
8360 procedure Append_Record_Traversal
8363 Container : Node_Or_Entity_Id;
8364 Counter : in out Int)
8368 -- Clist's Component_Items and Variant_Part
8378 CI := Component_Items (Clist);
8379 VP := Variant_Part (Clist);
8382 while Present (Item) loop
8383 Def := Defining_Identifier (Item);
8385 if not Is_Internal_Name (Chars (Def)) then
8387 (Stmts, Container, Counter, Rec, Def);
8393 if Present (VP) then
8394 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8396 end Append_Record_Traversal;
8398 -----------------------------
8399 -- Assign_Opaque_From_Any --
8400 -----------------------------
8402 procedure Assign_Opaque_From_Any
8409 Strm : constant Entity_Id :=
8410 Make_Defining_Identifier (Loc,
8411 Chars => New_Internal_Name ('S'));
8414 Read_Call_List : List_Id;
8415 -- List on which to place the 'Read attribute reference
8418 -- Strm : Buffer_Stream_Type;
8421 Make_Object_Declaration (Loc,
8422 Defining_Identifier => Strm,
8423 Aliased_Present => True,
8424 Object_Definition =>
8425 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
8427 -- Any_To_BS (Strm, A);
8430 Make_Procedure_Call_Statement (Loc,
8431 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
8432 Parameter_Associations => New_List (
8434 New_Occurrence_Of (Strm, Loc))));
8436 if Transmit_As_Unconstrained (Typ) then
8438 Make_Attribute_Reference (Loc,
8439 Prefix => New_Occurrence_Of (Typ, Loc),
8440 Attribute_Name => Name_Input,
8441 Expressions => New_List (
8442 Make_Attribute_Reference (Loc,
8443 Prefix => New_Occurrence_Of (Strm, Loc),
8444 Attribute_Name => Name_Access)));
8446 -- Target := Typ'Input (Strm'Access)
8448 if Present (Target) then
8450 Make_Assignment_Statement (Loc,
8451 Name => New_Occurrence_Of (Target, Loc),
8452 Expression => Expr));
8454 -- return Typ'Input (Strm'Access);
8458 Make_Simple_Return_Statement (Loc,
8459 Expression => Expr));
8463 if Present (Target) then
8464 Read_Call_List := Stms;
8465 Expr := New_Occurrence_Of (Target, Loc);
8469 Temp : constant Entity_Id :=
8470 Make_Defining_Identifier
8471 (Loc, New_Internal_Name ('R'));
8474 Read_Call_List := New_List;
8475 Expr := New_Occurrence_Of (Temp, Loc);
8477 Append_To (Stms, Make_Block_Statement (Loc,
8478 Declarations => New_List (
8479 Make_Object_Declaration (Loc,
8480 Defining_Identifier =>
8482 Object_Definition =>
8483 New_Occurrence_Of (Typ, Loc))),
8485 Handled_Statement_Sequence =>
8486 Make_Handled_Sequence_Of_Statements (Loc,
8487 Statements => Read_Call_List)));
8491 -- Typ'Read (Strm'Access, [Target|Temp])
8493 Append_To (Read_Call_List,
8494 Make_Attribute_Reference (Loc,
8495 Prefix => New_Occurrence_Of (Typ, Loc),
8496 Attribute_Name => Name_Read,
8497 Expressions => New_List (
8498 Make_Attribute_Reference (Loc,
8499 Prefix => New_Occurrence_Of (Strm, Loc),
8500 Attribute_Name => Name_Access),
8507 Append_To (Read_Call_List,
8508 Make_Simple_Return_Statement (Loc,
8509 Expression => New_Copy (Expr)));
8512 end Assign_Opaque_From_Any;
8514 -------------------------
8515 -- Build_From_Any_Call --
8516 -------------------------
8518 function Build_From_Any_Call
8521 Decls : List_Id) return Node_Id
8523 Loc : constant Source_Ptr := Sloc (N);
8525 U_Type : Entity_Id := Underlying_Type (Typ);
8527 Fnam : Entity_Id := Empty;
8528 Lib_RE : RE_Id := RE_Null;
8532 -- First simple case where the From_Any function is present
8533 -- in the type's TSS.
8535 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8537 if Sloc (U_Type) <= Standard_Location then
8538 U_Type := Base_Type (U_Type);
8541 -- Check first for Boolean and Character. These are enumeration
8542 -- types, but we treat them specially, since they may require
8543 -- special handling in the transfer protocol. However, this
8544 -- special handling only applies if they have standard
8545 -- representation, otherwise they are treated like any other
8546 -- enumeration type.
8548 if Present (Fnam) then
8551 elsif U_Type = Standard_Boolean then
8554 elsif U_Type = Standard_Character then
8557 elsif U_Type = Standard_Wide_Character then
8560 elsif U_Type = Standard_Wide_Wide_Character then
8561 Lib_RE := RE_FA_WWC;
8563 -- Floating point types
8565 elsif U_Type = Standard_Short_Float then
8568 elsif U_Type = Standard_Float then
8571 elsif U_Type = Standard_Long_Float then
8574 elsif U_Type = Standard_Long_Long_Float then
8575 Lib_RE := RE_FA_LLF;
8579 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8580 Lib_RE := RE_FA_SSI;
8582 elsif U_Type = Etype (Standard_Short_Integer) then
8585 elsif U_Type = Etype (Standard_Integer) then
8588 elsif U_Type = Etype (Standard_Long_Integer) then
8591 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8592 Lib_RE := RE_FA_LLI;
8594 -- Unsigned integer types
8596 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8597 Lib_RE := RE_FA_SSU;
8599 elsif U_Type = RTE (RE_Short_Unsigned) then
8602 elsif U_Type = RTE (RE_Unsigned) then
8605 elsif U_Type = RTE (RE_Long_Unsigned) then
8608 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8609 Lib_RE := RE_FA_LLU;
8611 elsif Is_RTE (U_Type, RE_Unbounded_String) then
8612 Lib_RE := RE_FA_String;
8614 -- Special DSA types
8616 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
8619 -- Other (non-primitive) types
8624 Typ : Entity_Id := U_Type;
8627 -- For the subtype representing a generic actual type, go
8628 -- to the base type.
8630 if Is_Generic_Actual_Type (Typ) then
8631 Typ := Base_Type (Typ);
8634 Build_From_Any_Function (Loc, Typ, Decl, Fnam);
8635 Append_To (Decls, Decl);
8639 -- Call the function
8641 if Lib_RE /= RE_Null then
8642 pragma Assert (No (Fnam));
8643 Fnam := RTE (Lib_RE);
8647 Make_Function_Call (Loc,
8648 Name => New_Occurrence_Of (Fnam, Loc),
8649 Parameter_Associations => New_List (N));
8651 -- We must set the type of Result, so the unchecked conversion
8652 -- from the underlying type to the base type is properly done.
8654 Set_Etype (Result, U_Type);
8656 return Unchecked_Convert_To (Typ, Result);
8657 end Build_From_Any_Call;
8659 -----------------------------
8660 -- Build_From_Any_Function --
8661 -----------------------------
8663 procedure Build_From_Any_Function
8667 Fnam : out Entity_Id)
8670 Decls : constant List_Id := New_List;
8671 Stms : constant List_Id := New_List;
8673 Any_Parameter : constant Entity_Id :=
8674 Make_Defining_Identifier (Loc,
8675 New_Internal_Name ('A'));
8677 Use_Opaque_Representation : Boolean;
8680 if Is_Itype (Typ) then
8681 Build_From_Any_Function
8689 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
8692 Make_Function_Specification (Loc,
8693 Defining_Unit_Name => Fnam,
8694 Parameter_Specifications => New_List (
8695 Make_Parameter_Specification (Loc,
8696 Defining_Identifier => Any_Parameter,
8697 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
8698 Result_Definition => New_Occurrence_Of (Typ, Loc));
8700 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8703 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8705 Use_Opaque_Representation := False;
8707 if Has_Stream_Attribute_Definition
8708 (Typ, TSS_Stream_Output, At_Any_Place => True)
8710 Has_Stream_Attribute_Definition
8711 (Typ, TSS_Stream_Write, At_Any_Place => True)
8713 -- If user-defined stream attributes are specified for this
8714 -- type, use them and transmit data as an opaque sequence of
8717 Use_Opaque_Representation := True;
8719 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
8721 Make_Simple_Return_Statement (Loc,
8726 New_Occurrence_Of (Any_Parameter, Loc),
8729 elsif Is_Record_Type (Typ)
8730 and then not Is_Derived_Type (Typ)
8731 and then not Is_Tagged_Type (Typ)
8733 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8735 Make_Simple_Return_Statement (Loc,
8739 New_Occurrence_Of (Any_Parameter, Loc),
8744 Disc : Entity_Id := Empty;
8745 Discriminant_Associations : List_Id;
8746 Rdef : constant Node_Id :=
8748 (Declaration_Node (Typ));
8749 Component_Counter : Int := 0;
8751 -- The returned object
8753 Res : constant Entity_Id :=
8754 Make_Defining_Identifier (Loc,
8755 New_Internal_Name ('R'));
8757 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8759 procedure FA_Rec_Add_Process_Element
8762 Counter : in out Int;
8766 procedure FA_Append_Record_Traversal is
8767 new Append_Record_Traversal
8769 Add_Process_Element => FA_Rec_Add_Process_Element);
8771 --------------------------------
8772 -- FA_Rec_Add_Process_Element --
8773 --------------------------------
8775 procedure FA_Rec_Add_Process_Element
8778 Counter : in out Int;
8784 if Nkind (Field) = N_Defining_Identifier then
8785 -- A regular component
8787 Ctyp := Etype (Field);
8790 Make_Assignment_Statement (Loc,
8791 Name => Make_Selected_Component (Loc,
8793 New_Occurrence_Of (Rec, Loc),
8795 New_Occurrence_Of (Field, Loc)),
8798 Build_From_Any_Call (Ctyp,
8799 Build_Get_Aggregate_Element (Loc,
8802 Build_TypeCode_Call (Loc, Ctyp, Decls),
8804 Make_Integer_Literal (Loc, Counter)),
8812 Struct_Counter : Int := 0;
8814 Block_Decls : constant List_Id := New_List;
8815 Block_Stmts : constant List_Id := New_List;
8818 Alt_List : constant List_Id := New_List;
8819 Choice_List : List_Id;
8821 Struct_Any : constant Entity_Id :=
8822 Make_Defining_Identifier (Loc,
8823 New_Internal_Name ('S'));
8827 Make_Object_Declaration (Loc,
8828 Defining_Identifier => Struct_Any,
8829 Constant_Present => True,
8830 Object_Definition =>
8831 New_Occurrence_Of (RTE (RE_Any), Loc),
8833 Make_Function_Call (Loc,
8836 (RTE (RE_Extract_Union_Value), Loc),
8838 Parameter_Associations => New_List (
8839 Build_Get_Aggregate_Element (Loc,
8842 Make_Function_Call (Loc,
8843 Name => New_Occurrence_Of (
8844 RTE (RE_Any_Member_Type), Loc),
8845 Parameter_Associations =>
8847 New_Occurrence_Of (Any, Loc),
8848 Make_Integer_Literal (Loc,
8849 Intval => Counter))),
8851 Make_Integer_Literal (Loc,
8852 Intval => Counter))))));
8855 Make_Block_Statement (Loc,
8856 Declarations => Block_Decls,
8857 Handled_Statement_Sequence =>
8858 Make_Handled_Sequence_Of_Statements (Loc,
8859 Statements => Block_Stmts)));
8861 Append_To (Block_Stmts,
8862 Make_Case_Statement (Loc,
8864 Make_Selected_Component (Loc,
8866 Selector_Name => Chars (Name (Field))),
8867 Alternatives => Alt_List));
8869 Variant := First_Non_Pragma (Variants (Field));
8870 while Present (Variant) loop
8873 (Discrete_Choices (Variant));
8875 VP_Stmts := New_List;
8877 -- Struct_Counter should be reset before
8878 -- handling a variant part. Indeed only one
8879 -- of the case statement alternatives will be
8880 -- executed at run-time, so the counter must
8881 -- start at 0 for every case statement.
8883 Struct_Counter := 0;
8885 FA_Append_Record_Traversal (
8887 Clist => Component_List (Variant),
8888 Container => Struct_Any,
8889 Counter => Struct_Counter);
8891 Append_To (Alt_List,
8892 Make_Case_Statement_Alternative (Loc,
8893 Discrete_Choices => Choice_List,
8894 Statements => VP_Stmts));
8895 Next_Non_Pragma (Variant);
8900 Counter := Counter + 1;
8901 end FA_Rec_Add_Process_Element;
8904 -- First all discriminants
8906 if Has_Discriminants (Typ) then
8907 Discriminant_Associations := New_List;
8909 Disc := First_Discriminant (Typ);
8910 while Present (Disc) loop
8912 Disc_Var_Name : constant Entity_Id :=
8913 Make_Defining_Identifier (Loc,
8914 Chars => Chars (Disc));
8915 Disc_Type : constant Entity_Id :=
8920 Make_Object_Declaration (Loc,
8921 Defining_Identifier => Disc_Var_Name,
8922 Constant_Present => True,
8923 Object_Definition =>
8924 New_Occurrence_Of (Disc_Type, Loc),
8927 Build_From_Any_Call (Disc_Type,
8928 Build_Get_Aggregate_Element (Loc,
8929 Any => Any_Parameter,
8930 TC => Build_TypeCode_Call
8931 (Loc, Disc_Type, Decls),
8932 Idx => Make_Integer_Literal (Loc,
8933 Intval => Component_Counter)),
8936 Component_Counter := Component_Counter + 1;
8938 Append_To (Discriminant_Associations,
8939 Make_Discriminant_Association (Loc,
8940 Selector_Names => New_List (
8941 New_Occurrence_Of (Disc, Loc)),
8943 New_Occurrence_Of (Disc_Var_Name, Loc)));
8945 Next_Discriminant (Disc);
8949 Make_Subtype_Indication (Loc,
8950 Subtype_Mark => Res_Definition,
8952 Make_Index_Or_Discriminant_Constraint (Loc,
8953 Discriminant_Associations));
8956 -- Now we have all the discriminants in variables, we can
8957 -- declared a constrained object. Note that we are not
8958 -- initializing (non-discriminant) components directly in
8959 -- the object declarations, because which fields to
8960 -- initialize depends (at run time) on the discriminant
8964 Make_Object_Declaration (Loc,
8965 Defining_Identifier => Res,
8966 Object_Definition => Res_Definition));
8968 -- ... then all components
8970 FA_Append_Record_Traversal (Stms,
8971 Clist => Component_List (Rdef),
8972 Container => Any_Parameter,
8973 Counter => Component_Counter);
8976 Make_Simple_Return_Statement (Loc,
8977 Expression => New_Occurrence_Of (Res, Loc)));
8981 elsif Is_Array_Type (Typ) then
8983 Constrained : constant Boolean := Is_Constrained (Typ);
8985 procedure FA_Ary_Add_Process_Element
8988 Counter : Entity_Id;
8990 -- Assign the current element (as identified by Counter) of
8991 -- Any to the variable denoted by name Datum, and advance
8992 -- Counter by 1. If Datum is not an Any, a call to From_Any
8993 -- for its type is inserted.
8995 --------------------------------
8996 -- FA_Ary_Add_Process_Element --
8997 --------------------------------
8999 procedure FA_Ary_Add_Process_Element
9002 Counter : Entity_Id;
9005 Assignment : constant Node_Id :=
9006 Make_Assignment_Statement (Loc,
9008 Expression => Empty);
9010 Element_Any : Node_Id;
9014 Element_TC : Node_Id;
9017 if Etype (Datum) = RTE (RE_Any) then
9019 -- When Datum is an Any the Etype field is not
9020 -- sufficient to determine the typecode of Datum
9021 -- (which can be a TC_SEQUENCE or TC_ARRAY
9022 -- depending on the value of Constrained).
9024 -- Therefore we retrieve the typecode which has
9025 -- been constructed in Append_Array_Traversal with
9026 -- a call to Get_Any_Type.
9029 Make_Function_Call (Loc,
9030 Name => New_Occurrence_Of (
9031 RTE (RE_Get_Any_Type), Loc),
9032 Parameter_Associations => New_List (
9033 New_Occurrence_Of (Entity (Datum), Loc)));
9035 -- For non Any Datum we simply construct a typecode
9036 -- matching the Etype of the Datum.
9038 Element_TC := Build_TypeCode_Call
9039 (Loc, Etype (Datum), Decls);
9043 Build_Get_Aggregate_Element (Loc,
9046 Idx => New_Occurrence_Of (Counter, Loc));
9049 -- Note: here we *prepend* statements to Stmts, so
9050 -- we must do it in reverse order.
9053 Make_Assignment_Statement (Loc,
9055 New_Occurrence_Of (Counter, Loc),
9058 Left_Opnd => New_Occurrence_Of (Counter, Loc),
9059 Right_Opnd => Make_Integer_Literal (Loc, 1))));
9061 if Nkind (Datum) /= N_Attribute_Reference then
9063 -- We ignore the value of the length of each
9064 -- dimension, since the target array has already
9065 -- been constrained anyway.
9067 if Etype (Datum) /= RTE (RE_Any) then
9068 Set_Expression (Assignment,
9070 (Component_Type (Typ), Element_Any, Decls));
9072 Set_Expression (Assignment, Element_Any);
9075 Prepend_To (Stmts, Assignment);
9077 end FA_Ary_Add_Process_Element;
9079 ------------------------
9080 -- Local Declarations --
9081 ------------------------
9083 Counter : constant Entity_Id :=
9084 Make_Defining_Identifier (Loc, Name_J);
9086 Initial_Counter_Value : Int := 0;
9088 Component_TC : constant Entity_Id :=
9089 Make_Defining_Identifier (Loc, Name_T);
9091 Res : constant Entity_Id :=
9092 Make_Defining_Identifier (Loc, Name_R);
9094 procedure Append_From_Any_Array_Iterator is
9095 new Append_Array_Traversal (
9098 Indices => New_List,
9099 Add_Process_Element => FA_Ary_Add_Process_Element);
9101 Res_Subtype_Indication : Node_Id :=
9102 New_Occurrence_Of (Typ, Loc);
9105 if not Constrained then
9107 Ndim : constant Int := Number_Dimensions (Typ);
9110 Indx : Node_Id := First_Index (Typ);
9113 Ranges : constant List_Id := New_List;
9116 for J in 1 .. Ndim loop
9117 Lnam := New_External_Name ('L', J);
9118 Hnam := New_External_Name ('H', J);
9120 -- Note, for empty arrays bounds may be out of
9121 -- the range of Etype (Indx).
9123 Indt := Base_Type (Etype (Indx));
9126 Make_Object_Declaration (Loc,
9127 Defining_Identifier =>
9128 Make_Defining_Identifier (Loc, Lnam),
9129 Constant_Present => True,
9130 Object_Definition =>
9131 New_Occurrence_Of (Indt, Loc),
9135 Build_Get_Aggregate_Element (Loc,
9136 Any => Any_Parameter,
9137 TC => Build_TypeCode_Call
9140 Make_Integer_Literal (Loc, J - 1)),
9144 Make_Object_Declaration (Loc,
9145 Defining_Identifier =>
9146 Make_Defining_Identifier (Loc, Hnam),
9148 Constant_Present => True,
9150 Object_Definition =>
9151 New_Occurrence_Of (Indt, Loc),
9153 Expression => Make_Attribute_Reference (Loc,
9155 New_Occurrence_Of (Indt, Loc),
9157 Attribute_Name => Name_Val,
9159 Expressions => New_List (
9160 Make_Op_Subtract (Loc,
9165 Standard_Long_Integer,
9166 Make_Identifier (Loc, Lnam)),
9170 Standard_Long_Integer,
9171 Make_Function_Call (Loc,
9173 New_Occurrence_Of (RTE (
9174 RE_Get_Nested_Sequence_Length
9176 Parameter_Associations =>
9179 Any_Parameter, Loc),
9180 Make_Integer_Literal (Loc,
9184 Make_Integer_Literal (Loc, 1))))));
9188 Low_Bound => Make_Identifier (Loc, Lnam),
9189 High_Bound => Make_Identifier (Loc, Hnam)));
9194 -- Now we have all the necessary bound information:
9195 -- apply the set of range constraints to the
9196 -- (unconstrained) nominal subtype of Res.
9198 Initial_Counter_Value := Ndim;
9199 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9200 Subtype_Mark => Res_Subtype_Indication,
9202 Make_Index_Or_Discriminant_Constraint (Loc,
9203 Constraints => Ranges));
9208 Make_Object_Declaration (Loc,
9209 Defining_Identifier => Res,
9210 Object_Definition => Res_Subtype_Indication));
9211 Set_Etype (Res, Typ);
9214 Make_Object_Declaration (Loc,
9215 Defining_Identifier => Counter,
9216 Object_Definition =>
9217 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
9219 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9222 Make_Object_Declaration (Loc,
9223 Defining_Identifier => Component_TC,
9224 Constant_Present => True,
9225 Object_Definition =>
9226 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9228 Build_TypeCode_Call (Loc,
9229 Component_Type (Typ), Decls)));
9231 Append_From_Any_Array_Iterator
9232 (Stms, Any_Parameter, Counter);
9235 Make_Simple_Return_Statement (Loc,
9236 Expression => New_Occurrence_Of (Res, Loc)));
9239 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9241 Make_Simple_Return_Statement (Loc,
9243 Unchecked_Convert_To (Typ,
9245 (Find_Numeric_Representation (Typ),
9246 New_Occurrence_Of (Any_Parameter, Loc),
9250 Use_Opaque_Representation := True;
9253 if Use_Opaque_Representation then
9254 Assign_Opaque_From_Any (Loc,
9257 N => New_Occurrence_Of (Any_Parameter, Loc),
9262 Make_Subprogram_Body (Loc,
9263 Specification => Spec,
9264 Declarations => Decls,
9265 Handled_Statement_Sequence =>
9266 Make_Handled_Sequence_Of_Statements (Loc,
9267 Statements => Stms));
9268 end Build_From_Any_Function;
9270 ---------------------------------
9271 -- Build_Get_Aggregate_Element --
9272 ---------------------------------
9274 function Build_Get_Aggregate_Element
9278 Idx : Node_Id) return Node_Id
9281 return Make_Function_Call (Loc,
9283 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc),
9284 Parameter_Associations => New_List (
9285 New_Occurrence_Of (Any, Loc),
9288 end Build_Get_Aggregate_Element;
9290 -------------------------
9291 -- Build_Reposiroty_Id --
9292 -------------------------
9294 procedure Build_Name_And_Repository_Id
9296 Name_Str : out String_Id;
9297 Repo_Id_Str : out String_Id)
9301 Store_String_Chars ("DSA:");
9302 Get_Library_Unit_Name_String (Scope (E));
9304 (Name_Buffer (Name_Buffer'First ..
9305 Name_Buffer'First + Name_Len - 1));
9306 Store_String_Char ('.');
9307 Get_Name_String (Chars (E));
9309 (Name_Buffer (Name_Buffer'First ..
9310 Name_Buffer'First + Name_Len - 1));
9311 Store_String_Chars (":1.0");
9312 Repo_Id_Str := End_String;
9313 Name_Str := String_From_Name_Buffer;
9314 end Build_Name_And_Repository_Id;
9316 -----------------------
9317 -- Build_To_Any_Call --
9318 -----------------------
9320 function Build_To_Any_Call
9322 Decls : List_Id) return Node_Id
9324 Loc : constant Source_Ptr := Sloc (N);
9326 Typ : Entity_Id := Etype (N);
9329 Fnam : Entity_Id := Empty;
9330 Lib_RE : RE_Id := RE_Null;
9333 -- If N is a selected component, then maybe its Etype has not been
9334 -- set yet: try to use Etype of the selector_name in that case.
9336 if No (Typ) and then Nkind (N) = N_Selected_Component then
9337 Typ := Etype (Selector_Name (N));
9340 pragma Assert (Present (Typ));
9342 -- Get full view for private type, completion for incomplete type
9344 U_Type := Underlying_Type (Typ);
9346 -- First simple case where the To_Any function is present in the
9349 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9351 -- Check first for Boolean and Character. These are enumeration
9352 -- types, but we treat them specially, since they may require
9353 -- special handling in the transfer protocol. However, this
9354 -- special handling only applies if they have standard
9355 -- representation, otherwise they are treated like any other
9356 -- enumeration type.
9358 if Sloc (U_Type) <= Standard_Location then
9359 U_Type := Base_Type (U_Type);
9362 if Present (Fnam) then
9365 elsif U_Type = Standard_Boolean then
9368 elsif U_Type = Standard_Character then
9371 elsif U_Type = Standard_Wide_Character then
9374 elsif U_Type = Standard_Wide_Wide_Character then
9375 Lib_RE := RE_TA_WWC;
9377 -- Floating point types
9379 elsif U_Type = Standard_Short_Float then
9382 elsif U_Type = Standard_Float then
9385 elsif U_Type = Standard_Long_Float then
9388 elsif U_Type = Standard_Long_Long_Float then
9389 Lib_RE := RE_TA_LLF;
9393 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9394 Lib_RE := RE_TA_SSI;
9396 elsif U_Type = Etype (Standard_Short_Integer) then
9399 elsif U_Type = Etype (Standard_Integer) then
9402 elsif U_Type = Etype (Standard_Long_Integer) then
9405 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9406 Lib_RE := RE_TA_LLI;
9408 -- Unsigned integer types
9410 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9411 Lib_RE := RE_TA_SSU;
9413 elsif U_Type = RTE (RE_Short_Unsigned) then
9416 elsif U_Type = RTE (RE_Unsigned) then
9419 elsif U_Type = RTE (RE_Long_Unsigned) then
9422 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9423 Lib_RE := RE_TA_LLU;
9425 elsif Is_RTE (U_Type, RE_Unbounded_String) then
9426 Lib_RE := RE_TA_String;
9428 -- Special DSA types
9430 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
9434 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9436 -- No corresponding FA_TC ???
9440 -- Other (non-primitive) types
9446 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9447 Append_To (Decls, Decl);
9451 -- Call the function
9453 if Lib_RE /= RE_Null then
9454 pragma Assert (No (Fnam));
9455 Fnam := RTE (Lib_RE);
9458 -- If Fnam is already analyzed, find the proper expected type,
9459 -- else we have a newly constructed To_Any function and we know
9460 -- that the expected type of its parameter is U_Type.
9462 if Ekind (Fnam) = E_Function
9463 and then Present (First_Formal (Fnam))
9465 C_Type := Etype (First_Formal (Fnam));
9471 Make_Function_Call (Loc,
9472 Name => New_Occurrence_Of (Fnam, Loc),
9473 Parameter_Associations =>
9474 New_List (OK_Convert_To (C_Type, N)));
9475 end Build_To_Any_Call;
9477 ---------------------------
9478 -- Build_To_Any_Function --
9479 ---------------------------
9481 procedure Build_To_Any_Function
9485 Fnam : out Entity_Id)
9488 Decls : constant List_Id := New_List;
9489 Stms : constant List_Id := New_List;
9491 Expr_Parameter : constant Entity_Id :=
9492 Make_Defining_Identifier (Loc, Name_E);
9494 Any : constant Entity_Id :=
9495 Make_Defining_Identifier (Loc, Name_A);
9498 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9500 Use_Opaque_Representation : Boolean;
9501 -- When True, use stream attributes and represent type as an
9502 -- opaque sequence of bytes.
9505 if Is_Itype (Typ) then
9506 Build_To_Any_Function
9514 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
9517 Make_Function_Specification (Loc,
9518 Defining_Unit_Name => Fnam,
9519 Parameter_Specifications => New_List (
9520 Make_Parameter_Specification (Loc,
9521 Defining_Identifier => Expr_Parameter,
9522 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9523 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9524 Set_Etype (Expr_Parameter, Typ);
9527 Make_Object_Declaration (Loc,
9528 Defining_Identifier => Any,
9529 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9531 Use_Opaque_Representation := False;
9533 if Has_Stream_Attribute_Definition
9534 (Typ, TSS_Stream_Output, At_Any_Place => True)
9536 Has_Stream_Attribute_Definition
9537 (Typ, TSS_Stream_Write, At_Any_Place => True)
9539 -- If user-defined stream attributes are specified for this
9540 -- type, use them and transmit data as an opaque sequence of
9543 Use_Opaque_Representation := True;
9545 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9547 -- Non-tagged derived type: convert to root type
9550 Rt_Type : constant Entity_Id := Root_Type (Typ);
9551 Expr : constant Node_Id :=
9554 New_Occurrence_Of (Expr_Parameter, Loc));
9556 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9559 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9561 -- Non-tagged record type
9563 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9565 Rt_Type : constant Entity_Id := Etype (Typ);
9566 Expr : constant Node_Id :=
9567 OK_Convert_To (Rt_Type,
9568 New_Occurrence_Of (Expr_Parameter, Loc));
9572 (Any_Decl, Build_To_Any_Call (Expr, Decls));
9575 -- Comment needed here (and label on declare block ???)
9579 Disc : Entity_Id := Empty;
9580 Rdef : constant Node_Id :=
9581 Type_Definition (Declaration_Node (Typ));
9583 Elements : constant List_Id := New_List;
9585 procedure TA_Rec_Add_Process_Element
9587 Container : Node_Or_Entity_Id;
9588 Counter : in out Int;
9591 -- Processing routine for traversal below
9593 procedure TA_Append_Record_Traversal is
9594 new Append_Record_Traversal
9595 (Rec => Expr_Parameter,
9596 Add_Process_Element => TA_Rec_Add_Process_Element);
9598 --------------------------------
9599 -- TA_Rec_Add_Process_Element --
9600 --------------------------------
9602 procedure TA_Rec_Add_Process_Element
9604 Container : Node_Or_Entity_Id;
9605 Counter : in out Int;
9609 Field_Ref : Node_Id;
9612 if Nkind (Field) = N_Defining_Identifier then
9614 -- A regular component
9616 Field_Ref := Make_Selected_Component (Loc,
9617 Prefix => New_Occurrence_Of (Rec, Loc),
9618 Selector_Name => New_Occurrence_Of (Field, Loc));
9619 Set_Etype (Field_Ref, Etype (Field));
9622 Make_Procedure_Call_Statement (Loc,
9625 RTE (RE_Add_Aggregate_Element), Loc),
9626 Parameter_Associations => New_List (
9627 New_Occurrence_Of (Container, Loc),
9628 Build_To_Any_Call (Field_Ref, Decls))));
9633 Variant_Part : declare
9635 Struct_Counter : Int := 0;
9637 Block_Decls : constant List_Id := New_List;
9638 Block_Stmts : constant List_Id := New_List;
9641 Alt_List : constant List_Id := New_List;
9642 Choice_List : List_Id;
9644 Union_Any : constant Entity_Id :=
9645 Make_Defining_Identifier (Loc,
9646 New_Internal_Name ('V'));
9648 Struct_Any : constant Entity_Id :=
9649 Make_Defining_Identifier (Loc,
9650 New_Internal_Name ('S'));
9652 function Make_Discriminant_Reference
9654 -- Build reference to the discriminant for this
9657 ---------------------------------
9658 -- Make_Discriminant_Reference --
9659 ---------------------------------
9661 function Make_Discriminant_Reference
9664 Nod : constant Node_Id :=
9665 Make_Selected_Component (Loc,
9668 Chars (Name (Field)));
9670 Set_Etype (Nod, Etype (Name (Field)));
9672 end Make_Discriminant_Reference;
9674 -- Start of processing for Variant_Part
9678 Make_Block_Statement (Loc,
9681 Handled_Statement_Sequence =>
9682 Make_Handled_Sequence_Of_Statements (Loc,
9683 Statements => Block_Stmts)));
9685 -- Declare variant part aggregate (Union_Any).
9686 -- Knowing the position of this VP in the
9687 -- variant record, we can fetch the VP typecode
9690 Append_To (Block_Decls,
9691 Make_Object_Declaration (Loc,
9692 Defining_Identifier => Union_Any,
9693 Object_Definition =>
9694 New_Occurrence_Of (RTE (RE_Any), Loc),
9696 Make_Function_Call (Loc,
9697 Name => New_Occurrence_Of (
9698 RTE (RE_Create_Any), Loc),
9699 Parameter_Associations => New_List (
9700 Make_Function_Call (Loc,
9703 RTE (RE_Any_Member_Type), Loc),
9704 Parameter_Associations => New_List (
9705 New_Occurrence_Of (Container, Loc),
9706 Make_Integer_Literal (Loc,
9709 -- Declare inner struct aggregate (which
9710 -- contains the components of this VP).
9712 Append_To (Block_Decls,
9713 Make_Object_Declaration (Loc,
9714 Defining_Identifier => Struct_Any,
9715 Object_Definition =>
9716 New_Occurrence_Of (RTE (RE_Any), Loc),
9718 Make_Function_Call (Loc,
9719 Name => New_Occurrence_Of (
9720 RTE (RE_Create_Any), Loc),
9721 Parameter_Associations => New_List (
9722 Make_Function_Call (Loc,
9725 RTE (RE_Any_Member_Type), Loc),
9726 Parameter_Associations => New_List (
9727 New_Occurrence_Of (Union_Any, Loc),
9728 Make_Integer_Literal (Loc,
9731 -- Build case statement
9733 Append_To (Block_Stmts,
9734 Make_Case_Statement (Loc,
9735 Expression => Make_Discriminant_Reference,
9736 Alternatives => Alt_List));
9738 Variant := First_Non_Pragma (Variants (Field));
9739 while Present (Variant) loop
9740 Choice_List := New_Copy_List_Tree
9741 (Discrete_Choices (Variant));
9743 VP_Stmts := New_List;
9745 -- Append discriminant val to union aggregate
9747 Append_To (VP_Stmts,
9748 Make_Procedure_Call_Statement (Loc,
9751 RTE (RE_Add_Aggregate_Element), Loc),
9752 Parameter_Associations => New_List (
9753 New_Occurrence_Of (Union_Any, Loc),
9755 (Make_Discriminant_Reference,
9758 -- Populate inner struct aggregate
9760 -- Struct_Counter should be reset before
9761 -- handling a variant part. Indeed only one
9762 -- of the case statement alternatives will be
9763 -- executed at run-time, so the counter must
9764 -- start at 0 for every case statement.
9766 Struct_Counter := 0;
9768 TA_Append_Record_Traversal
9770 Clist => Component_List (Variant),
9771 Container => Struct_Any,
9772 Counter => Struct_Counter);
9774 -- Append inner struct to union aggregate
9776 Append_To (VP_Stmts,
9777 Make_Procedure_Call_Statement (Loc,
9780 (RTE (RE_Add_Aggregate_Element), Loc),
9781 Parameter_Associations => New_List (
9782 New_Occurrence_Of (Union_Any, Loc),
9783 New_Occurrence_Of (Struct_Any, Loc))));
9785 -- Append union to outer aggregate
9787 Append_To (VP_Stmts,
9788 Make_Procedure_Call_Statement (Loc,
9791 (RTE (RE_Add_Aggregate_Element), Loc),
9792 Parameter_Associations => New_List (
9793 New_Occurrence_Of (Container, Loc),
9795 (Union_Any, Loc))));
9797 Append_To (Alt_List,
9798 Make_Case_Statement_Alternative (Loc,
9799 Discrete_Choices => Choice_List,
9800 Statements => VP_Stmts));
9802 Next_Non_Pragma (Variant);
9807 Counter := Counter + 1;
9808 end TA_Rec_Add_Process_Element;
9811 -- Records are encoded in a TC_STRUCT aggregate:
9813 -- -- Outer aggregate (TC_STRUCT)
9814 -- | [discriminant1]
9815 -- | [discriminant2]
9822 -- A component can be a common component or variant part
9824 -- A variant part is encoded as a TC_UNION aggregate:
9826 -- -- Variant Part Aggregate (TC_UNION)
9827 -- | [discriminant choice for this Variant Part]
9829 -- | -- Inner struct (TC_STRUCT)
9834 -- Let's start by building the outer aggregate. First we
9835 -- construct Elements array containing all discriminants.
9837 if Has_Discriminants (Typ) then
9838 Disc := First_Discriminant (Typ);
9839 while Present (Disc) loop
9841 Discriminant : constant Entity_Id :=
9842 Make_Selected_Component (Loc,
9849 Set_Etype (Discriminant, Etype (Disc));
9851 Append_To (Elements,
9852 Make_Component_Association (Loc,
9853 Choices => New_List (
9854 Make_Integer_Literal (Loc, Counter)),
9856 Build_To_Any_Call (Discriminant, Decls)));
9859 Counter := Counter + 1;
9860 Next_Discriminant (Disc);
9864 -- If there are no discriminants, we declare an empty
9868 Dummy_Any : constant Entity_Id :=
9869 Make_Defining_Identifier (Loc,
9870 Chars => New_Internal_Name ('A'));
9874 Make_Object_Declaration (Loc,
9875 Defining_Identifier => Dummy_Any,
9876 Object_Definition =>
9877 New_Occurrence_Of (RTE (RE_Any), Loc)));
9879 Append_To (Elements,
9880 Make_Component_Association (Loc,
9881 Choices => New_List (
9884 Make_Integer_Literal (Loc, 1),
9886 Make_Integer_Literal (Loc, 0))),
9888 New_Occurrence_Of (Dummy_Any, Loc)));
9892 -- We build the result aggregate with discriminants
9893 -- as the first elements.
9895 Set_Expression (Any_Decl,
9896 Make_Function_Call (Loc,
9897 Name => New_Occurrence_Of
9898 (RTE (RE_Any_Aggregate_Build), Loc),
9899 Parameter_Associations => New_List (
9901 Make_Aggregate (Loc,
9902 Component_Associations => Elements))));
9905 -- Then we append all the components to the result
9908 TA_Append_Record_Traversal (Stms,
9909 Clist => Component_List (Rdef),
9911 Counter => Counter);
9915 elsif Is_Array_Type (Typ) then
9917 -- Constrained and unconstrained array types
9920 Constrained : constant Boolean := Is_Constrained (Typ);
9922 procedure TA_Ary_Add_Process_Element
9925 Counter : Entity_Id;
9928 --------------------------------
9929 -- TA_Ary_Add_Process_Element --
9930 --------------------------------
9932 procedure TA_Ary_Add_Process_Element
9935 Counter : Entity_Id;
9938 pragma Unreferenced (Counter);
9940 Element_Any : Node_Id;
9943 if Etype (Datum) = RTE (RE_Any) then
9944 Element_Any := Datum;
9946 Element_Any := Build_To_Any_Call (Datum, Decls);
9950 Make_Procedure_Call_Statement (Loc,
9951 Name => New_Occurrence_Of (
9952 RTE (RE_Add_Aggregate_Element), Loc),
9953 Parameter_Associations => New_List (
9954 New_Occurrence_Of (Any, Loc),
9956 end TA_Ary_Add_Process_Element;
9958 procedure Append_To_Any_Array_Iterator is
9959 new Append_Array_Traversal (
9961 Arry => Expr_Parameter,
9962 Indices => New_List,
9963 Add_Process_Element => TA_Ary_Add_Process_Element);
9968 Set_Expression (Any_Decl,
9969 Make_Function_Call (Loc,
9971 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9972 Parameter_Associations => New_List (Result_TC)));
9975 if not Constrained then
9976 Index := First_Index (Typ);
9977 for J in 1 .. Number_Dimensions (Typ) loop
9979 Make_Procedure_Call_Statement (Loc,
9982 RTE (RE_Add_Aggregate_Element), Loc),
9983 Parameter_Associations => New_List (
9984 New_Occurrence_Of (Any, Loc),
9986 OK_Convert_To (Etype (Index),
9987 Make_Attribute_Reference (Loc,
9989 New_Occurrence_Of (Expr_Parameter, Loc),
9990 Attribute_Name => Name_First,
9991 Expressions => New_List (
9992 Make_Integer_Literal (Loc, J)))),
9998 Append_To_Any_Array_Iterator (Stms, Any);
10001 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10005 Set_Expression (Any_Decl,
10006 Build_To_Any_Call (
10008 Find_Numeric_Representation (Typ),
10009 New_Occurrence_Of (Expr_Parameter, Loc)),
10013 -- Default case, including tagged types: opaque representation
10015 Use_Opaque_Representation := True;
10018 if Use_Opaque_Representation then
10020 Strm : constant Entity_Id :=
10021 Make_Defining_Identifier (Loc,
10022 Chars => New_Internal_Name ('S'));
10023 -- Stream used to store data representation produced by
10024 -- stream attribute.
10028 -- Strm : aliased Buffer_Stream_Type;
10031 Make_Object_Declaration (Loc,
10032 Defining_Identifier =>
10036 Object_Definition =>
10037 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
10040 -- T'Output (Strm'Access, E);
10043 Make_Attribute_Reference (Loc,
10044 Prefix => New_Occurrence_Of (Typ, Loc),
10045 Attribute_Name => Name_Output,
10046 Expressions => New_List (
10047 Make_Attribute_Reference (Loc,
10048 Prefix => New_Occurrence_Of (Strm, Loc),
10049 Attribute_Name => Name_Access),
10050 New_Occurrence_Of (Expr_Parameter, Loc))));
10053 -- BS_To_Any (Strm, A);
10056 Make_Procedure_Call_Statement (Loc,
10057 Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
10058 Parameter_Associations => New_List (
10059 New_Occurrence_Of (Strm, Loc),
10060 New_Occurrence_Of (Any, Loc))));
10063 -- Release_Buffer (Strm);
10066 Make_Procedure_Call_Statement (Loc,
10067 Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
10068 Parameter_Associations => New_List (
10069 New_Occurrence_Of (Strm, Loc))));
10073 Append_To (Decls, Any_Decl);
10075 if Present (Result_TC) then
10077 Make_Procedure_Call_Statement (Loc,
10078 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
10079 Parameter_Associations => New_List (
10080 New_Occurrence_Of (Any, Loc),
10085 Make_Simple_Return_Statement (Loc,
10086 Expression => New_Occurrence_Of (Any, Loc)));
10089 Make_Subprogram_Body (Loc,
10090 Specification => Spec,
10091 Declarations => Decls,
10092 Handled_Statement_Sequence =>
10093 Make_Handled_Sequence_Of_Statements (Loc,
10094 Statements => Stms));
10095 end Build_To_Any_Function;
10097 -------------------------
10098 -- Build_TypeCode_Call --
10099 -------------------------
10101 function Build_TypeCode_Call
10104 Decls : List_Id) return Node_Id
10106 U_Type : Entity_Id := Underlying_Type (Typ);
10107 -- The full view, if Typ is private; the completion,
10108 -- if Typ is incomplete.
10110 Fnam : Entity_Id := Empty;
10111 Lib_RE : RE_Id := RE_Null;
10115 -- Special case System.PolyORB.Interface.Any: its primitives have
10116 -- not been set yet, so can't call Find_Inherited_TSS.
10118 if Typ = RTE (RE_Any) then
10119 Fnam := RTE (RE_TC_A);
10122 -- First simple case where the TypeCode is present
10123 -- in the type's TSS.
10125 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10129 if Sloc (U_Type) <= Standard_Location then
10131 -- Do not try to build alias typecodes for subtypes from
10134 U_Type := Base_Type (U_Type);
10137 if U_Type = Standard_Boolean then
10140 elsif U_Type = Standard_Character then
10143 elsif U_Type = Standard_Wide_Character then
10144 Lib_RE := RE_TC_WC;
10146 elsif U_Type = Standard_Wide_Wide_Character then
10147 Lib_RE := RE_TC_WWC;
10149 -- Floating point types
10151 elsif U_Type = Standard_Short_Float then
10152 Lib_RE := RE_TC_SF;
10154 elsif U_Type = Standard_Float then
10157 elsif U_Type = Standard_Long_Float then
10158 Lib_RE := RE_TC_LF;
10160 elsif U_Type = Standard_Long_Long_Float then
10161 Lib_RE := RE_TC_LLF;
10163 -- Integer types (walk back to the base type)
10165 elsif U_Type = Etype (Standard_Short_Short_Integer) then
10166 Lib_RE := RE_TC_SSI;
10168 elsif U_Type = Etype (Standard_Short_Integer) then
10169 Lib_RE := RE_TC_SI;
10171 elsif U_Type = Etype (Standard_Integer) then
10174 elsif U_Type = Etype (Standard_Long_Integer) then
10175 Lib_RE := RE_TC_LI;
10177 elsif U_Type = Etype (Standard_Long_Long_Integer) then
10178 Lib_RE := RE_TC_LLI;
10180 -- Unsigned integer types
10182 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
10183 Lib_RE := RE_TC_SSU;
10185 elsif U_Type = RTE (RE_Short_Unsigned) then
10186 Lib_RE := RE_TC_SU;
10188 elsif U_Type = RTE (RE_Unsigned) then
10191 elsif U_Type = RTE (RE_Long_Unsigned) then
10192 Lib_RE := RE_TC_LU;
10194 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
10195 Lib_RE := RE_TC_LLU;
10197 elsif Is_RTE (U_Type, RE_Unbounded_String) then
10198 Lib_RE := RE_TC_String;
10200 -- Special DSA types
10202 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
10205 -- Other (non-primitive) types
10211 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10212 Append_To (Decls, Decl);
10216 if Lib_RE /= RE_Null then
10217 Fnam := RTE (Lib_RE);
10221 -- Call the function
10224 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10226 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10228 Set_Etype (Expr, RTE (RE_TypeCode));
10231 end Build_TypeCode_Call;
10233 -----------------------------
10234 -- Build_TypeCode_Function --
10235 -----------------------------
10237 procedure Build_TypeCode_Function
10240 Decl : out Node_Id;
10241 Fnam : out Entity_Id)
10244 Decls : constant List_Id := New_List;
10245 Stms : constant List_Id := New_List;
10247 TCNam : constant Entity_Id :=
10248 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
10250 Parameters : List_Id;
10252 procedure Add_String_Parameter
10254 Parameter_List : List_Id);
10255 -- Add a literal for S to Parameters
10257 procedure Add_TypeCode_Parameter
10258 (TC_Node : Node_Id;
10259 Parameter_List : List_Id);
10260 -- Add the typecode for Typ to Parameters
10262 procedure Add_Long_Parameter
10263 (Expr_Node : Node_Id;
10264 Parameter_List : List_Id);
10265 -- Add a signed long integer expression to Parameters
10267 procedure Initialize_Parameter_List
10268 (Name_String : String_Id;
10269 Repo_Id_String : String_Id;
10270 Parameter_List : out List_Id);
10271 -- Return a list that contains the first two parameters
10272 -- for a parameterized typecode: name and repository id.
10274 function Make_Constructed_TypeCode
10276 Parameters : List_Id) return Node_Id;
10277 -- Call TC_Build with the given kind and parameters
10279 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10280 -- Make a return statement that calls TC_Build with the given
10281 -- typecode kind, and the constructed parameters list.
10283 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10284 -- Return a typecode that is a TC_Alias for the given typecode
10286 --------------------------
10287 -- Add_String_Parameter --
10288 --------------------------
10290 procedure Add_String_Parameter
10292 Parameter_List : List_Id)
10295 Append_To (Parameter_List,
10296 Make_Function_Call (Loc,
10297 Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc),
10298 Parameter_Associations => New_List (
10299 Make_String_Literal (Loc, S))));
10300 end Add_String_Parameter;
10302 ----------------------------
10303 -- Add_TypeCode_Parameter --
10304 ----------------------------
10306 procedure Add_TypeCode_Parameter
10307 (TC_Node : Node_Id;
10308 Parameter_List : List_Id)
10311 Append_To (Parameter_List,
10312 Make_Function_Call (Loc,
10313 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10314 Parameter_Associations => New_List (TC_Node)));
10315 end Add_TypeCode_Parameter;
10317 ------------------------
10318 -- Add_Long_Parameter --
10319 ------------------------
10321 procedure Add_Long_Parameter
10322 (Expr_Node : Node_Id;
10323 Parameter_List : List_Id)
10326 Append_To (Parameter_List,
10327 Make_Function_Call (Loc,
10328 Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc),
10329 Parameter_Associations => New_List (Expr_Node)));
10330 end Add_Long_Parameter;
10332 -------------------------------
10333 -- Initialize_Parameter_List --
10334 -------------------------------
10336 procedure Initialize_Parameter_List
10337 (Name_String : String_Id;
10338 Repo_Id_String : String_Id;
10339 Parameter_List : out List_Id)
10342 Parameter_List := New_List;
10343 Add_String_Parameter (Name_String, Parameter_List);
10344 Add_String_Parameter (Repo_Id_String, Parameter_List);
10345 end Initialize_Parameter_List;
10347 ---------------------------
10348 -- Return_Alias_TypeCode --
10349 ---------------------------
10351 procedure Return_Alias_TypeCode
10352 (Base_TypeCode : Node_Id)
10355 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10356 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
10357 end Return_Alias_TypeCode;
10359 -------------------------------
10360 -- Make_Constructed_TypeCode --
10361 -------------------------------
10363 function Make_Constructed_TypeCode
10365 Parameters : List_Id) return Node_Id
10367 Constructed_TC : constant Node_Id :=
10368 Make_Function_Call (Loc,
10370 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
10371 Parameter_Associations => New_List (
10372 New_Occurrence_Of (Kind, Loc),
10373 Make_Aggregate (Loc,
10374 Expressions => Parameters)));
10376 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10377 return Constructed_TC;
10378 end Make_Constructed_TypeCode;
10380 ---------------------------------
10381 -- Return_Constructed_TypeCode --
10382 ---------------------------------
10384 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10387 Make_Simple_Return_Statement (Loc,
10389 Make_Constructed_TypeCode (Kind, Parameters)));
10390 end Return_Constructed_TypeCode;
10396 procedure TC_Rec_Add_Process_Element
10399 Counter : in out Int;
10403 procedure TC_Append_Record_Traversal is
10404 new Append_Record_Traversal (
10406 Add_Process_Element => TC_Rec_Add_Process_Element);
10408 --------------------------------
10409 -- TC_Rec_Add_Process_Element --
10410 --------------------------------
10412 procedure TC_Rec_Add_Process_Element
10415 Counter : in out Int;
10419 pragma Unreferenced (Any, Counter, Rec);
10422 if Nkind (Field) = N_Defining_Identifier then
10424 -- A regular component
10426 Add_TypeCode_Parameter
10427 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10428 Get_Name_String (Chars (Field));
10429 Add_String_Parameter (String_From_Name_Buffer, Params);
10436 Discriminant_Type : constant Entity_Id :=
10437 Etype (Name (Field));
10439 Is_Enum : constant Boolean :=
10440 Is_Enumeration_Type (Discriminant_Type);
10442 Union_TC_Params : List_Id;
10444 U_Name : constant Name_Id :=
10445 New_External_Name (Chars (Typ), 'V', -1);
10447 Name_Str : String_Id;
10448 Struct_TC_Params : List_Id;
10452 Default : constant Node_Id :=
10453 Make_Integer_Literal (Loc, -1);
10455 Dummy_Counter : Int := 0;
10457 Choice_Index : Int := 0;
10459 procedure Add_Params_For_Variant_Components;
10460 -- Add a struct TypeCode and a corresponding member name
10461 -- to the union parameter list.
10463 -- Ordering of declarations is a complete mess in this
10464 -- area, it is supposed to be types/variables, then
10465 -- subprogram specs, then subprogram bodies ???
10467 ---------------------------------------
10468 -- Add_Params_For_Variant_Components --
10469 ---------------------------------------
10471 procedure Add_Params_For_Variant_Components
10473 S_Name : constant Name_Id :=
10474 New_External_Name (U_Name, 'S', -1);
10477 Get_Name_String (S_Name);
10478 Name_Str := String_From_Name_Buffer;
10479 Initialize_Parameter_List
10480 (Name_Str, Name_Str, Struct_TC_Params);
10482 -- Build struct parameters
10484 TC_Append_Record_Traversal (Struct_TC_Params,
10485 Component_List (Variant),
10489 Add_TypeCode_Parameter
10490 (Make_Constructed_TypeCode
10491 (RTE (RE_TC_Struct), Struct_TC_Params),
10494 Add_String_Parameter (Name_Str, Union_TC_Params);
10495 end Add_Params_For_Variant_Components;
10498 Get_Name_String (U_Name);
10499 Name_Str := String_From_Name_Buffer;
10501 Initialize_Parameter_List
10502 (Name_Str, Name_Str, Union_TC_Params);
10504 -- Add union in enclosing parameter list
10506 Add_TypeCode_Parameter
10507 (Make_Constructed_TypeCode
10508 (RTE (RE_TC_Union), Union_TC_Params),
10511 Add_String_Parameter (Name_Str, Params);
10513 -- Build union parameters
10515 Add_TypeCode_Parameter
10516 (Build_TypeCode_Call
10517 (Loc, Discriminant_Type, Decls),
10520 Add_Long_Parameter (Default, Union_TC_Params);
10522 Variant := First_Non_Pragma (Variants (Field));
10523 while Present (Variant) loop
10524 Choice := First (Discrete_Choices (Variant));
10525 while Present (Choice) loop
10526 case Nkind (Choice) is
10529 L : constant Uint :=
10530 Expr_Value (Low_Bound (Choice));
10531 H : constant Uint :=
10532 Expr_Value (High_Bound (Choice));
10534 -- 3.8.1(8) guarantees that the bounds of
10535 -- this range are static.
10542 Expr := New_Occurrence_Of (
10543 Get_Enum_Lit_From_Pos (
10544 Discriminant_Type, J, Loc), Loc);
10547 Make_Integer_Literal (Loc, J);
10549 Append_To (Union_TC_Params,
10550 Build_To_Any_Call (Expr, Decls));
10552 Add_Params_For_Variant_Components;
10557 when N_Others_Choice =>
10559 -- This variant possess a default choice.
10560 -- We must therefore set the default
10561 -- parameter to the current choice index. The
10562 -- default parameter is by construction the
10563 -- fourth in the Union_TC_Params list.
10566 Default_Node : constant Node_Id :=
10567 Pick (Union_TC_Params, 4);
10569 New_Default_Node : constant Node_Id :=
10570 Make_Function_Call (Loc,
10573 (RTE (RE_TA_LI), Loc),
10574 Parameter_Associations =>
10576 Make_Integer_Literal
10577 (Loc, Choice_Index)));
10583 Remove (Default_Node);
10586 -- Add a placeholder member label
10587 -- for the default case.
10588 -- It must be of the discriminant type.
10591 Exp : constant Node_Id :=
10592 Make_Attribute_Reference (Loc,
10593 Prefix => New_Occurrence_Of
10594 (Discriminant_Type, Loc),
10595 Attribute_Name => Name_First);
10597 Set_Etype (Exp, Discriminant_Type);
10598 Append_To (Union_TC_Params,
10599 Build_To_Any_Call (Exp, Decls));
10602 Add_Params_For_Variant_Components;
10606 -- Case of an explicit choice
10609 Exp : constant Node_Id :=
10610 New_Copy_Tree (Choice);
10612 Append_To (Union_TC_Params,
10613 Build_To_Any_Call (Exp, Decls));
10616 Add_Params_For_Variant_Components;
10620 Choice_Index := Choice_Index + 1;
10623 Next_Non_Pragma (Variant);
10627 end TC_Rec_Add_Process_Element;
10629 Type_Name_Str : String_Id;
10630 Type_Repo_Id_Str : String_Id;
10633 if Is_Itype (Typ) then
10634 Build_TypeCode_Function
10636 Typ => Etype (Typ),
10645 Make_Function_Specification (Loc,
10646 Defining_Unit_Name => Fnam,
10647 Parameter_Specifications => Empty_List,
10648 Result_Definition =>
10649 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10651 Build_Name_And_Repository_Id (Typ,
10652 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10654 Initialize_Parameter_List
10655 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10657 if Has_Stream_Attribute_Definition
10658 (Typ, TSS_Stream_Output, At_Any_Place => True)
10660 Has_Stream_Attribute_Definition
10661 (Typ, TSS_Stream_Write, At_Any_Place => True)
10663 -- If user-defined stream attributes are specified for this
10664 -- type, use them and transmit data as an opaque sequence of
10665 -- stream elements.
10667 Return_Alias_TypeCode
10668 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10670 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
10671 Return_Alias_TypeCode (
10672 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10674 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10675 Return_Alias_TypeCode (
10676 Build_TypeCode_Call (Loc,
10677 Find_Numeric_Representation (Typ), Decls));
10679 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
10681 -- Record typecodes are encoded as follows:
10685 -- | [Repository Id]
10687 -- Then for each discriminant:
10689 -- | [Discriminant Type Code]
10690 -- | [Discriminant Name]
10693 -- Then for each component:
10695 -- | [Component Type Code]
10696 -- | [Component Name]
10699 -- Variants components type codes are encoded as follows:
10703 -- | [Repository Id]
10704 -- | [Discriminant Type Code]
10705 -- | [Index of Default Variant Part or -1 for no default]
10707 -- Then for each Variant Part :
10712 -- | | [Variant Part Name]
10713 -- | | [Variant Part Repository Id]
10715 -- | Then for each VP component:
10716 -- | | [VP component Typecode]
10717 -- | | [VP component Name]
10723 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10724 Return_Alias_TypeCode
10725 (Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10729 Disc : Entity_Id := Empty;
10730 Rdef : constant Node_Id :=
10731 Type_Definition (Declaration_Node (Typ));
10732 Dummy_Counter : Int := 0;
10735 -- Construct the discriminants typecodes
10737 if Has_Discriminants (Typ) then
10738 Disc := First_Discriminant (Typ);
10741 while Present (Disc) loop
10742 Add_TypeCode_Parameter (
10743 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10745 Get_Name_String (Chars (Disc));
10746 Add_String_Parameter (
10747 String_From_Name_Buffer,
10749 Next_Discriminant (Disc);
10752 -- then the components typecodes
10754 TC_Append_Record_Traversal
10755 (Parameters, Component_List (Rdef),
10756 Empty, Dummy_Counter);
10757 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10761 elsif Is_Array_Type (Typ) then
10763 Ndim : constant Pos := Number_Dimensions (Typ);
10764 Inner_TypeCode : Node_Id;
10765 Constrained : constant Boolean := Is_Constrained (Typ);
10766 Indx : Node_Id := First_Index (Typ);
10770 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls);
10772 for J in 1 .. Ndim loop
10773 if Constrained then
10774 Inner_TypeCode := Make_Constructed_TypeCode
10775 (RTE (RE_TC_Array), New_List (
10776 Build_To_Any_Call (
10777 OK_Convert_To (RTE (RE_Long_Unsigned),
10778 Make_Attribute_Reference (Loc,
10779 Prefix => New_Occurrence_Of (Typ, Loc),
10780 Attribute_Name => Name_Length,
10781 Expressions => New_List (
10782 Make_Integer_Literal (Loc,
10783 Intval => Ndim - J + 1)))),
10785 Build_To_Any_Call (Inner_TypeCode, Decls)));
10788 -- Unconstrained case: add low bound for each
10791 Add_TypeCode_Parameter
10792 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10794 Get_Name_String (New_External_Name ('L', J));
10795 Add_String_Parameter (
10796 String_From_Name_Buffer,
10800 Inner_TypeCode := Make_Constructed_TypeCode
10801 (RTE (RE_TC_Sequence), New_List (
10802 Build_To_Any_Call (
10803 OK_Convert_To (RTE (RE_Long_Unsigned),
10804 Make_Integer_Literal (Loc, 0)),
10806 Build_To_Any_Call (Inner_TypeCode, Decls)));
10810 if Constrained then
10811 Return_Alias_TypeCode (Inner_TypeCode);
10813 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10815 Store_String_Char ('V');
10816 Add_String_Parameter (End_String, Parameters);
10817 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10822 -- Default: type is represented as an opaque sequence of bytes
10824 Return_Alias_TypeCode
10825 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10829 Make_Subprogram_Body (Loc,
10830 Specification => Spec,
10831 Declarations => Decls,
10832 Handled_Statement_Sequence =>
10833 Make_Handled_Sequence_Of_Statements (Loc,
10834 Statements => Stms));
10835 end Build_TypeCode_Function;
10837 ---------------------------------
10838 -- Find_Numeric_Representation --
10839 ---------------------------------
10841 function Find_Numeric_Representation
10842 (Typ : Entity_Id) return Entity_Id
10844 FST : constant Entity_Id := First_Subtype (Typ);
10845 P_Size : constant Uint := Esize (FST);
10848 if Is_Unsigned_Type (Typ) then
10849 if P_Size <= Standard_Short_Short_Integer_Size then
10850 return RTE (RE_Short_Short_Unsigned);
10852 elsif P_Size <= Standard_Short_Integer_Size then
10853 return RTE (RE_Short_Unsigned);
10855 elsif P_Size <= Standard_Integer_Size then
10856 return RTE (RE_Unsigned);
10858 elsif P_Size <= Standard_Long_Integer_Size then
10859 return RTE (RE_Long_Unsigned);
10862 return RTE (RE_Long_Long_Unsigned);
10865 elsif Is_Integer_Type (Typ) then
10866 if P_Size <= Standard_Short_Short_Integer_Size then
10867 return Standard_Short_Short_Integer;
10869 elsif P_Size <= Standard_Short_Integer_Size then
10870 return Standard_Short_Integer;
10872 elsif P_Size <= Standard_Integer_Size then
10873 return Standard_Integer;
10875 elsif P_Size <= Standard_Long_Integer_Size then
10876 return Standard_Long_Integer;
10879 return Standard_Long_Long_Integer;
10882 elsif Is_Floating_Point_Type (Typ) then
10883 if P_Size <= Standard_Short_Float_Size then
10884 return Standard_Short_Float;
10886 elsif P_Size <= Standard_Float_Size then
10887 return Standard_Float;
10889 elsif P_Size <= Standard_Long_Float_Size then
10890 return Standard_Long_Float;
10893 return Standard_Long_Long_Float;
10897 raise Program_Error;
10900 -- TBD: fixed point types???
10901 -- TBverified numeric types with a biased representation???
10903 end Find_Numeric_Representation;
10905 ---------------------------
10906 -- Append_Array_Traversal --
10907 ---------------------------
10909 procedure Append_Array_Traversal
10912 Counter : Entity_Id := Empty;
10915 Loc : constant Source_Ptr := Sloc (Subprogram);
10916 Typ : constant Entity_Id := Etype (Arry);
10917 Constrained : constant Boolean := Is_Constrained (Typ);
10918 Ndim : constant Pos := Number_Dimensions (Typ);
10920 Inner_Any, Inner_Counter : Entity_Id;
10922 Loop_Stm : Node_Id;
10923 Inner_Stmts : constant List_Id := New_List;
10926 if Depth > Ndim then
10928 -- Processing for one element of an array
10931 Element_Expr : constant Node_Id :=
10932 Make_Indexed_Component (Loc,
10933 New_Occurrence_Of (Arry, Loc),
10936 Set_Etype (Element_Expr, Component_Type (Typ));
10937 Add_Process_Element (Stmts,
10939 Counter => Counter,
10940 Datum => Element_Expr);
10946 Append_To (Indices,
10947 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10949 if not Constrained or else Depth > 1 then
10950 Inner_Any := Make_Defining_Identifier (Loc,
10951 New_External_Name ('A', Depth));
10952 Set_Etype (Inner_Any, RTE (RE_Any));
10954 Inner_Any := Empty;
10957 if Present (Counter) then
10958 Inner_Counter := Make_Defining_Identifier (Loc,
10959 New_External_Name ('J', Depth));
10961 Inner_Counter := Empty;
10965 Loop_Any : Node_Id := Inner_Any;
10968 -- For the first dimension of a constrained array, we add
10969 -- elements directly in the corresponding Any; there is no
10970 -- intervening inner Any.
10972 if No (Loop_Any) then
10976 Append_Array_Traversal (Inner_Stmts,
10978 Counter => Inner_Counter,
10979 Depth => Depth + 1);
10983 Make_Implicit_Loop_Statement (Subprogram,
10984 Iteration_Scheme =>
10985 Make_Iteration_Scheme (Loc,
10986 Loop_Parameter_Specification =>
10987 Make_Loop_Parameter_Specification (Loc,
10988 Defining_Identifier =>
10989 Make_Defining_Identifier (Loc,
10990 Chars => New_External_Name ('L', Depth)),
10992 Discrete_Subtype_Definition =>
10993 Make_Attribute_Reference (Loc,
10994 Prefix => New_Occurrence_Of (Arry, Loc),
10995 Attribute_Name => Name_Range,
10997 Expressions => New_List (
10998 Make_Integer_Literal (Loc, Depth))))),
10999 Statements => Inner_Stmts);
11002 Decls : constant List_Id := New_List;
11003 Dimen_Stmts : constant List_Id := New_List;
11004 Length_Node : Node_Id;
11006 Inner_Any_TypeCode : constant Entity_Id :=
11007 Make_Defining_Identifier (Loc,
11008 New_External_Name ('T', Depth));
11010 Inner_Any_TypeCode_Expr : Node_Id;
11014 if Constrained then
11015 Inner_Any_TypeCode_Expr :=
11016 Make_Function_Call (Loc,
11017 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
11018 Parameter_Associations => New_List (
11019 New_Occurrence_Of (Any, Loc)));
11022 Inner_Any_TypeCode_Expr :=
11023 Make_Function_Call (Loc,
11025 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
11026 Parameter_Associations => New_List (
11027 New_Occurrence_Of (Any, Loc),
11028 Make_Integer_Literal (Loc, Ndim)));
11032 Inner_Any_TypeCode_Expr :=
11033 Make_Function_Call (Loc,
11034 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc),
11035 Parameter_Associations => New_List (
11036 Make_Identifier (Loc,
11037 Chars => New_External_Name ('T', Depth - 1))));
11041 Make_Object_Declaration (Loc,
11042 Defining_Identifier => Inner_Any_TypeCode,
11043 Constant_Present => True,
11044 Object_Definition => New_Occurrence_Of (
11045 RTE (RE_TypeCode), Loc),
11046 Expression => Inner_Any_TypeCode_Expr));
11048 if Present (Inner_Any) then
11050 Make_Object_Declaration (Loc,
11051 Defining_Identifier => Inner_Any,
11052 Object_Definition =>
11053 New_Occurrence_Of (RTE (RE_Any), Loc),
11055 Make_Function_Call (Loc,
11057 New_Occurrence_Of (
11058 RTE (RE_Create_Any), Loc),
11059 Parameter_Associations => New_List (
11060 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
11063 if Present (Inner_Counter) then
11065 Make_Object_Declaration (Loc,
11066 Defining_Identifier => Inner_Counter,
11067 Object_Definition =>
11068 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
11070 Make_Integer_Literal (Loc, 0)));
11073 if not Constrained then
11074 Length_Node := Make_Attribute_Reference (Loc,
11075 Prefix => New_Occurrence_Of (Arry, Loc),
11076 Attribute_Name => Name_Length,
11078 New_List (Make_Integer_Literal (Loc, Depth)));
11079 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
11081 Add_Process_Element (Dimen_Stmts,
11082 Datum => Length_Node,
11084 Counter => Inner_Counter);
11087 -- Loop_Stm does appropriate processing for each element
11090 Append_To (Dimen_Stmts, Loop_Stm);
11092 -- Link outer and inner any
11094 if Present (Inner_Any) then
11095 Add_Process_Element (Dimen_Stmts,
11097 Counter => Counter,
11098 Datum => New_Occurrence_Of (Inner_Any, Loc));
11102 Make_Block_Statement (Loc,
11105 Handled_Statement_Sequence =>
11106 Make_Handled_Sequence_Of_Statements (Loc,
11107 Statements => Dimen_Stmts)));
11109 end Append_Array_Traversal;
11111 -------------------------------
11112 -- Make_Helper_Function_Name --
11113 -------------------------------
11115 function Make_Helper_Function_Name
11118 Nam : Name_Id) return Entity_Id
11123 -- For tagged types, we use a canonical name so that it matches
11124 -- the primitive spec. For all other cases, we use a serialized
11125 -- name so that multiple generations of the same procedure do
11129 if not Is_Tagged_Type (Typ) then
11130 Serial := Increment_Serial_Number;
11133 -- Use prefixed underscore to avoid potential clash with used
11134 -- identifier (we use attribute names for Nam).
11137 Make_Defining_Identifier (Loc,
11140 (Related_Id => Nam,
11141 Suffix => ' ', Suffix_Index => Serial,
11144 end Make_Helper_Function_Name;
11147 -----------------------------------
11148 -- Reserve_NamingContext_Methods --
11149 -----------------------------------
11151 procedure Reserve_NamingContext_Methods is
11152 Str_Resolve : constant String := "resolve";
11154 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11155 Name_Len := Str_Resolve'Length;
11156 Overload_Counter_Table.Set (Name_Find, 1);
11157 end Reserve_NamingContext_Methods;
11159 end PolyORB_Support;
11161 -------------------------------
11162 -- RACW_Type_Is_Asynchronous --
11163 -------------------------------
11165 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11166 Asynchronous_Flag : constant Entity_Id :=
11167 Asynchronous_Flags_Table.Get (RACW_Type);
11169 Replace (Expression (Parent (Asynchronous_Flag)),
11170 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11171 end RACW_Type_Is_Asynchronous;
11173 -------------------------
11174 -- RCI_Package_Locator --
11175 -------------------------
11177 function RCI_Package_Locator
11179 Package_Spec : Node_Id) return Node_Id
11182 Pkg_Name : String_Id;
11185 Get_Library_Unit_Name_String (Package_Spec);
11186 Pkg_Name := String_From_Name_Buffer;
11188 Make_Package_Instantiation (Loc,
11189 Defining_Unit_Name =>
11190 Make_Defining_Identifier (Loc,
11191 Chars => New_Internal_Name ('R')),
11194 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11196 Generic_Associations => New_List (
11197 Make_Generic_Association (Loc,
11199 Make_Identifier (Loc, Name_RCI_Name),
11200 Explicit_Generic_Actual_Parameter =>
11201 Make_String_Literal (Loc,
11202 Strval => Pkg_Name)),
11204 Make_Generic_Association (Loc,
11206 Make_Identifier (Loc, Name_Version),
11207 Explicit_Generic_Actual_Parameter =>
11208 Make_Attribute_Reference (Loc,
11210 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11214 RCI_Locator_Table.Set
11215 (Defining_Unit_Name (Package_Spec),
11216 Defining_Unit_Name (Inst));
11218 end RCI_Package_Locator;
11220 -----------------------------------------------
11221 -- Remote_Types_Tagged_Full_View_Encountered --
11222 -----------------------------------------------
11224 procedure Remote_Types_Tagged_Full_View_Encountered
11225 (Full_View : Entity_Id)
11227 Stub_Elements : constant Stub_Structure :=
11228 Stubs_Table.Get (Full_View);
11231 -- For an RACW encountered before the freeze point of its designated
11232 -- type, the stub type is generated at the point of the RACW declaration
11233 -- but the primitives are generated only once the designated type is
11234 -- frozen. That freeze can occur in another scope, for example when the
11235 -- RACW is declared in a nested package. In that case we need to
11236 -- reestablish the stub type's scope prior to generating its primitive
11239 if Stub_Elements /= Empty_Stub_Structure then
11241 Saved_Scope : constant Entity_Id := Current_Scope;
11242 Stubs_Scope : constant Entity_Id :=
11243 Scope (Stub_Elements.Stub_Type);
11246 if Current_Scope /= Stubs_Scope then
11247 Push_Scope (Stubs_Scope);
11250 Add_RACW_Primitive_Declarations_And_Bodies
11252 Stub_Elements.RPC_Receiver_Decl,
11253 Stub_Elements.Body_Decls);
11255 if Current_Scope /= Saved_Scope then
11260 end Remote_Types_Tagged_Full_View_Encountered;
11262 -------------------
11263 -- Scope_Of_Spec --
11264 -------------------
11266 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11267 Unit_Name : Node_Id;
11270 Unit_Name := Defining_Unit_Name (Spec);
11271 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11272 Unit_Name := Defining_Identifier (Unit_Name);
11278 ----------------------
11279 -- Set_Renaming_TSS --
11280 ----------------------
11282 procedure Set_Renaming_TSS
11285 TSS_Nam : TSS_Name_Type)
11287 Loc : constant Source_Ptr := Sloc (Nam);
11288 Spec : constant Node_Id := Parent (Nam);
11290 TSS_Node : constant Node_Id :=
11291 Make_Subprogram_Renaming_Declaration (Loc,
11293 Copy_Specification (Loc,
11295 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11296 Name => New_Occurrence_Of (Nam, Loc));
11298 Snam : constant Entity_Id :=
11299 Defining_Unit_Name (Specification (TSS_Node));
11302 if Nkind (Spec) = N_Function_Specification then
11303 Set_Ekind (Snam, E_Function);
11304 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11306 Set_Ekind (Snam, E_Procedure);
11307 Set_Etype (Snam, Standard_Void_Type);
11310 Set_TSS (Typ, Snam);
11311 end Set_Renaming_TSS;
11313 ----------------------------------------------
11314 -- Specific_Add_Obj_RPC_Receiver_Completion --
11315 ----------------------------------------------
11317 procedure Specific_Add_Obj_RPC_Receiver_Completion
11320 RPC_Receiver : Entity_Id;
11321 Stub_Elements : Stub_Structure)
11324 case Get_PCS_Name is
11325 when Name_PolyORB_DSA =>
11326 PolyORB_Support.Add_Obj_RPC_Receiver_Completion
11327 (Loc, Decls, RPC_Receiver, Stub_Elements);
11329 GARLIC_Support.Add_Obj_RPC_Receiver_Completion
11330 (Loc, Decls, RPC_Receiver, Stub_Elements);
11332 end Specific_Add_Obj_RPC_Receiver_Completion;
11334 --------------------------------
11335 -- Specific_Add_RACW_Features --
11336 --------------------------------
11338 procedure Specific_Add_RACW_Features
11339 (RACW_Type : Entity_Id;
11341 Stub_Type : Entity_Id;
11342 Stub_Type_Access : Entity_Id;
11343 RPC_Receiver_Decl : Node_Id;
11344 Body_Decls : List_Id)
11347 case Get_PCS_Name is
11348 when Name_PolyORB_DSA =>
11349 PolyORB_Support.Add_RACW_Features
11358 GARLIC_Support.Add_RACW_Features
11365 end Specific_Add_RACW_Features;
11367 --------------------------------
11368 -- Specific_Add_RAST_Features --
11369 --------------------------------
11371 procedure Specific_Add_RAST_Features
11372 (Vis_Decl : Node_Id;
11373 RAS_Type : Entity_Id)
11376 case Get_PCS_Name is
11377 when Name_PolyORB_DSA =>
11378 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11380 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11382 end Specific_Add_RAST_Features;
11384 --------------------------------------------------
11385 -- Specific_Add_Receiving_Stubs_To_Declarations --
11386 --------------------------------------------------
11388 procedure Specific_Add_Receiving_Stubs_To_Declarations
11389 (Pkg_Spec : Node_Id;
11394 case Get_PCS_Name is
11395 when Name_PolyORB_DSA =>
11396 PolyORB_Support.Add_Receiving_Stubs_To_Declarations
11397 (Pkg_Spec, Decls, Stmts);
11399 GARLIC_Support.Add_Receiving_Stubs_To_Declarations
11400 (Pkg_Spec, Decls, Stmts);
11402 end Specific_Add_Receiving_Stubs_To_Declarations;
11404 ------------------------------------------
11405 -- Specific_Build_General_Calling_Stubs --
11406 ------------------------------------------
11408 procedure Specific_Build_General_Calling_Stubs
11410 Statements : List_Id;
11411 Target : RPC_Target;
11412 Subprogram_Id : Node_Id;
11413 Asynchronous : Node_Id := Empty;
11414 Is_Known_Asynchronous : Boolean := False;
11415 Is_Known_Non_Asynchronous : Boolean := False;
11416 Is_Function : Boolean;
11418 Stub_Type : Entity_Id := Empty;
11419 RACW_Type : Entity_Id := Empty;
11423 case Get_PCS_Name is
11424 when Name_PolyORB_DSA =>
11425 PolyORB_Support.Build_General_Calling_Stubs
11431 Is_Known_Asynchronous,
11432 Is_Known_Non_Asynchronous,
11440 GARLIC_Support.Build_General_Calling_Stubs
11444 Target.RPC_Receiver,
11447 Is_Known_Asynchronous,
11448 Is_Known_Non_Asynchronous,
11455 end Specific_Build_General_Calling_Stubs;
11457 --------------------------------------
11458 -- Specific_Build_RPC_Receiver_Body --
11459 --------------------------------------
11461 procedure Specific_Build_RPC_Receiver_Body
11462 (RPC_Receiver : Entity_Id;
11463 Request : out Entity_Id;
11464 Subp_Id : out Entity_Id;
11465 Subp_Index : out Entity_Id;
11466 Stmts : out List_Id;
11467 Decl : out Node_Id)
11470 case Get_PCS_Name is
11471 when Name_PolyORB_DSA =>
11472 PolyORB_Support.Build_RPC_Receiver_Body
11481 GARLIC_Support.Build_RPC_Receiver_Body
11489 end Specific_Build_RPC_Receiver_Body;
11491 --------------------------------
11492 -- Specific_Build_Stub_Target --
11493 --------------------------------
11495 function Specific_Build_Stub_Target
11498 RCI_Locator : Entity_Id;
11499 Controlling_Parameter : Entity_Id) return RPC_Target
11502 case Get_PCS_Name is
11503 when Name_PolyORB_DSA =>
11505 PolyORB_Support.Build_Stub_Target
11506 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11510 GARLIC_Support.Build_Stub_Target
11511 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11513 end Specific_Build_Stub_Target;
11515 ------------------------------
11516 -- Specific_Build_Stub_Type --
11517 ------------------------------
11519 procedure Specific_Build_Stub_Type
11520 (RACW_Type : Entity_Id;
11521 Stub_Type_Comps : out List_Id;
11522 RPC_Receiver_Decl : out Node_Id)
11525 case Get_PCS_Name is
11526 when Name_PolyORB_DSA =>
11527 PolyORB_Support.Build_Stub_Type
11528 (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
11531 GARLIC_Support.Build_Stub_Type
11532 (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
11534 end Specific_Build_Stub_Type;
11536 -----------------------------------------------
11537 -- Specific_Build_Subprogram_Receiving_Stubs --
11538 -----------------------------------------------
11540 function Specific_Build_Subprogram_Receiving_Stubs
11541 (Vis_Decl : Node_Id;
11542 Asynchronous : Boolean;
11543 Dynamically_Asynchronous : Boolean := False;
11544 Stub_Type : Entity_Id := Empty;
11545 RACW_Type : Entity_Id := Empty;
11546 Parent_Primitive : Entity_Id := Empty) return Node_Id
11549 case Get_PCS_Name is
11550 when Name_PolyORB_DSA =>
11552 PolyORB_Support.Build_Subprogram_Receiving_Stubs
11555 Dynamically_Asynchronous,
11562 GARLIC_Support.Build_Subprogram_Receiving_Stubs
11565 Dynamically_Asynchronous,
11570 end Specific_Build_Subprogram_Receiving_Stubs;
11572 -------------------------------
11573 -- Transmit_As_Unconstrained --
11574 -------------------------------
11576 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
11579 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
11580 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
11581 end Transmit_As_Unconstrained;
11583 --------------------------
11584 -- Underlying_RACW_Type --
11585 --------------------------
11587 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11588 Record_Type : Entity_Id;
11591 if Ekind (RAS_Typ) = E_Record_Type then
11592 Record_Type := RAS_Typ;
11594 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11595 Record_Type := Equivalent_Type (RAS_Typ);
11599 Etype (Subtype_Indication
11600 (Component_Definition
11601 (First (Component_Items
11604 (Declaration_Node (Record_Type))))))));
11605 end Underlying_RACW_Type;