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_Strm; use Exp_Strm;
31 with Exp_Tss; use Exp_Tss;
32 with Exp_Util; use Exp_Util;
34 with Nlists; use Nlists;
35 with Nmake; use Nmake;
37 with Rtsfind; use Rtsfind;
39 with Sem_Aux; use Sem_Aux;
40 with Sem_Cat; use Sem_Cat;
41 with Sem_Ch3; use Sem_Ch3;
42 with Sem_Ch8; use Sem_Ch8;
43 with Sem_Dist; use Sem_Dist;
44 with Sem_Eval; use Sem_Eval;
45 with Sem_Util; use Sem_Util;
46 with Sinfo; use Sinfo;
47 with Stand; use Stand;
48 with Stringt; use Stringt;
49 with Tbuild; use Tbuild;
50 with Ttypes; use Ttypes;
51 with Uintp; use Uintp;
53 with GNAT.HTable; use GNAT.HTable;
55 package body Exp_Dist is
57 -- The following model has been used to implement distributed objects:
58 -- given a designated type D and a RACW type R, then a record of the
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 be
68 -- 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
86 -- RAS information lookup operation. (This is for the Garlic code
87 -- generation, where subprograms are identified by numbers; in the
88 -- PolyORB version, they are identified by name, with a numeric suffix
91 type Hash_Index is range 0 .. 50;
93 -----------------------
94 -- Local subprograms --
95 -----------------------
97 function Hash (F : Entity_Id) return Hash_Index;
98 -- DSA expansion associates stubs to distributed object types using
99 -- a hash table on entity ids.
101 function Hash (F : Name_Id) return Hash_Index;
102 -- The generation of subprogram identifiers requires an overload counter
103 -- to be associated with each remote subprogram names. These counters
104 -- are maintained in a hash table on name ids.
106 type Subprogram_Identifiers is record
107 Str_Identifier : String_Id;
108 Int_Identifier : Int;
111 package Subprogram_Identifier_Table is
112 new Simple_HTable (Header_Num => Hash_Index,
113 Element => Subprogram_Identifiers,
114 No_Element => (No_String, 0),
118 -- Mapping between a remote subprogram and the corresponding
119 -- subprogram identifiers.
121 package Overload_Counter_Table is
122 new Simple_HTable (Header_Num => Hash_Index,
128 -- Mapping between a subprogram name and an integer that
129 -- counts the number of defining subprogram names with that
130 -- Name_Id encountered so far in a given context (an interface).
132 function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
133 function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
134 function Get_Subprogram_Id (Def : Entity_Id) return Int;
135 -- Given a subprogram defined in a RCI package, get its distribution
136 -- subprogram identifiers (the distribution identifiers are a unique
137 -- subprogram number, and the non-qualified subprogram name, in the
138 -- casing used for the subprogram declaration; if the name is overloaded,
139 -- a double underscore and a serial number are appended.
141 -- The integer identifier is used to perform remote calls with GARLIC;
142 -- the string identifier is used in the case of PolyORB.
144 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
145 -- when receiving a call, the calling stubs will create requests with the
146 -- exact casing of the defining unit name of the called subprogram, so as
147 -- to allow calls to subprograms on distributed nodes that do distinguish
150 -- NOTE: Another design would be to allow a representation clause on
151 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
153 pragma Warnings (Off, Get_Subprogram_Id);
154 -- One homonym only is unreferenced (specific to the GARLIC version)
156 procedure Add_RAS_Dereference_TSS (N : Node_Id);
157 -- Add a subprogram body for RAS Dereference TSS
159 procedure Add_RAS_Proxy_And_Analyze
162 All_Calls_Remote_E : Entity_Id;
163 Proxy_Object_Addr : out Entity_Id);
164 -- Add the proxy type required, on the receiving (server) side, to handle
165 -- calls to the subprogram declared by Vis_Decl through a remote access
166 -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
167 -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
168 -- is appended to Decls. Proxy_Object_Addr is a constant of type
169 -- System.Address that designates an instance of the proxy object.
171 function Build_Remote_Subprogram_Proxy_Type
173 ACR_Expression : Node_Id) return Node_Id;
174 -- Build and return a tagged record type definition for an RCI
175 -- subprogram proxy type.
176 -- ACR_Expression is use as the initialization value for
177 -- the All_Calls_Remote component.
179 function Build_Get_Unique_RP_Call
182 Stub_Type : Entity_Id) return List_Id;
183 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
184 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
185 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
187 function Build_Stub_Tag
189 RACW_Type : Entity_Id) return Node_Id;
190 -- Return an expression denoting the tag of the stub type associated with
193 function Build_Subprogram_Calling_Stubs
196 Asynchronous : Boolean;
197 Dynamically_Asynchronous : Boolean := False;
198 Stub_Type : Entity_Id := Empty;
199 RACW_Type : Entity_Id := Empty;
200 Locator : Entity_Id := Empty;
201 New_Name : Name_Id := No_Name) return Node_Id;
202 -- Build the calling stub for a given subprogram with the subprogram ID
203 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
204 -- parameters of this type will be marshalled instead of the object
205 -- itself. It will then be converted into Stub_Type before performing
206 -- the real call. If Dynamically_Asynchronous is True, then it will be
207 -- computed at run time whether the call is asynchronous or not.
208 -- Otherwise, the value of the formal Asynchronous will be used.
209 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
210 -- New_Name is given, then it will be used instead of the original name.
212 function Build_RPC_Receiver_Specification
213 (RPC_Receiver : Entity_Id;
214 Request_Parameter : Entity_Id) return Node_Id;
215 -- Make a subprogram specification for an RPC receiver, with the given
216 -- defining unit name and formal parameter.
218 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
219 -- Return an ordered parameter list: unconstrained parameters are put
220 -- at the beginning of the list and constrained ones are put after. If
221 -- there are no parameters, an empty list is returned. Special case:
222 -- the controlling formal of the equivalent RACW operation for a RAS
223 -- type is always left in first position.
225 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean;
226 -- True when Typ is an unconstrained type, or a null-excluding access type.
227 -- In either case, this means stubs cannot contain a default-initialized
228 -- object declaration of such type.
230 procedure Add_Calling_Stubs_To_Declarations
233 -- Add calling stubs to the declarative part
235 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
236 -- Return True if nothing prevents the program whose specification is
237 -- given to be asynchronous (i.e. no out parameter).
239 function Pack_Entity_Into_Stream_Access
243 Etyp : Entity_Id := Empty) return Node_Id;
244 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
245 -- then Etype (Object) will be used if present. If the type is
246 -- constrained, then 'Write will be used to output the object,
247 -- If the type is unconstrained, 'Output will be used.
249 function Pack_Node_Into_Stream
253 Etyp : Entity_Id) return Node_Id;
254 -- Similar to above, with an arbitrary node instead of an entity
256 function Pack_Node_Into_Stream_Access
260 Etyp : Entity_Id) return Node_Id;
261 -- Similar to above, with Stream instead of Stream'Access
263 function Make_Selected_Component
266 Selector_Name : Name_Id) return Node_Id;
267 -- Return a selected_component whose prefix denotes the given entity,
268 -- and with the given Selector_Name.
270 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
271 -- Return the scope represented by a given spec
273 procedure Set_Renaming_TSS
276 TSS_Nam : TSS_Name_Type);
277 -- Create a renaming declaration of subprogram Nam,
278 -- and register it as a TSS for Typ with name TSS_Nam.
280 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
281 -- Return True if the current parameter needs an extra formal to reflect
282 -- its constrained status.
284 function Is_RACW_Controlling_Formal
285 (Parameter : Node_Id;
286 Stub_Type : Entity_Id) return Boolean;
287 -- Return True if the current parameter is a controlling formal argument
288 -- of type Stub_Type or access to Stub_Type.
290 procedure Declare_Create_NVList
295 -- Append the declaration of NVList to Decls, and its
296 -- initialization to Stmts.
298 function Add_Parameter_To_NVList
301 Parameter : Entity_Id;
302 Constrained : Boolean;
303 RACW_Ctrl : Boolean := False;
304 Any : Entity_Id) return Node_Id;
305 -- Return a call to Add_Item to add the Any corresponding to the designated
306 -- formal Parameter (with the indicated Constrained status) to NVList.
307 -- RACW_Ctrl must be set to True for controlling formals of distributed
308 -- object primitive operations.
314 -- This record describes various tree fragments associated with the
315 -- generation of RACW calling stubs. One such record exists for every
316 -- distributed object type, i.e. each tagged type that is the designated
317 -- type of one or more RACW type.
319 type Stub_Structure is record
320 Stub_Type : Entity_Id;
321 -- Stub type: this type has the same primitive operations as the
322 -- designated types, but the provided bodies for these operations
323 -- a remote call to an actual target object potentially located on
324 -- another partition; each value of the stub type encapsulates a
325 -- reference to a remote object.
327 Stub_Type_Access : Entity_Id;
328 -- A local access type designating the stub type (this is not an RACW
331 RPC_Receiver_Decl : Node_Id;
332 -- Declaration for the RPC receiver entity associated with the
333 -- designated type. As an exception, for the case of an RACW that
334 -- implements a RAS, no object RPC receiver is generated. Instead,
335 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
336 -- would have been inserted.
338 Body_Decls : List_Id;
339 -- List of subprogram bodies to be included in generated code: bodies
340 -- for the RACW's stream attributes, and for the primitive operations
343 RACW_Type : Entity_Id;
344 -- One of the RACW types designating this distributed object type
345 -- (they are all interchangeable; we use any one of them in order to
346 -- avoid having to create various anonymous access types).
350 Empty_Stub_Structure : constant Stub_Structure :=
351 (Empty, Empty, Empty, No_List, Empty);
353 package Stubs_Table is
354 new Simple_HTable (Header_Num => Hash_Index,
355 Element => Stub_Structure,
356 No_Element => Empty_Stub_Structure,
360 -- Mapping between a RACW designated type and its stub type
362 package Asynchronous_Flags_Table is
363 new Simple_HTable (Header_Num => Hash_Index,
364 Element => Entity_Id,
369 -- Mapping between a RACW type and a constant having the value True
370 -- if the RACW is asynchronous and False otherwise.
372 package RCI_Locator_Table is
373 new Simple_HTable (Header_Num => Hash_Index,
374 Element => Entity_Id,
379 -- Mapping between a RCI package on which All_Calls_Remote applies and
380 -- the generic instantiation of RCI_Locator for this package.
382 package RCI_Calling_Stubs_Table is
383 new Simple_HTable (Header_Num => Hash_Index,
384 Element => Entity_Id,
389 -- Mapping between a RCI subprogram and the corresponding calling stubs
391 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure;
392 -- Return the stub information associated with the given RACW type
394 procedure Add_Stub_Type
395 (Designated_Type : Entity_Id;
396 RACW_Type : Entity_Id;
398 Stub_Type : out Entity_Id;
399 Stub_Type_Access : out Entity_Id;
400 RPC_Receiver_Decl : out Node_Id;
401 Body_Decls : out List_Id;
402 Existing : out Boolean);
403 -- Add the declaration of the stub type, the access to stub type and the
404 -- object RPC receiver at the end of Decls. If these already exist,
405 -- then nothing is added in the tree but the right values are returned
406 -- anyhow and Existing is set to True.
408 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
409 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
410 -- structure table, reset it to No_List, and return the previous value.
412 procedure Add_RACW_Asynchronous_Flag
413 (Declarations : List_Id;
414 RACW_Type : Entity_Id);
415 -- Declare a boolean constant associated with RACW_Type whose value
416 -- indicates at run time whether a pragma Asynchronous applies to it.
418 procedure Assign_Subprogram_Identifier
422 -- Determine the distribution subprogram identifier to
423 -- be used for remote subprogram Def, return it in Id and
424 -- store it in a hash table for later retrieval by
425 -- Get_Subprogram_Id. Spn is the subprogram number.
427 function RCI_Package_Locator
429 Package_Spec : Node_Id) return Node_Id;
430 -- Instantiate the generic package RCI_Locator in order to locate the
431 -- RCI package whose spec is given as argument.
433 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
434 -- Surround a node N by a tag check, as in:
438 -- when E : Ada.Tags.Tag_Error =>
439 -- Raise_Exception (Program_Error'Identity,
440 -- Exception_Message (E));
443 function Input_With_Tag_Check
445 Var_Type : Entity_Id;
446 Stream : Node_Id) return Node_Id;
447 -- Return a function with the following form:
448 -- function R return Var_Type is
450 -- return Var_Type'Input (S);
452 -- when E : Ada.Tags.Tag_Error =>
453 -- Raise_Exception (Program_Error'Identity,
454 -- Exception_Message (E));
457 procedure Build_Actual_Object_Declaration
463 -- Build the declaration of an object with the given defining identifier,
464 -- initialized with Expr if provided, to serve as actual parameter in a
465 -- server stub. If Variable is true, the declared object will be a variable
466 -- (case of an out or in out formal), else it will be a constant. Object's
467 -- Ekind is set accordingly. The declaration, as well as any other
468 -- declarations it requires, are appended to Decls.
470 --------------------------------------------
471 -- Hooks for PCS-specific code generation --
472 --------------------------------------------
474 -- Part of the code generation circuitry for distribution needs to be
475 -- tailored for each implementation of the PCS. For each routine that
476 -- needs to be specialized, a Specific_<routine> wrapper is created,
477 -- which calls the corresponding <routine> in package
478 -- <pcs_implementation>_Support.
480 procedure Specific_Add_RACW_Features
481 (RACW_Type : Entity_Id;
483 Stub_Type : Entity_Id;
484 Stub_Type_Access : Entity_Id;
485 RPC_Receiver_Decl : Node_Id;
486 Body_Decls : List_Id);
487 -- Add declaration for TSSs for a given RACW type. The declarations are
488 -- added just after the declaration of the RACW type itself. If the RACW
489 -- appears in the main unit, Body_Decls is a list of declarations to which
490 -- the bodies are appended. Else Body_Decls is No_List.
491 -- PCS-specific ancillary subprogram for Add_RACW_Features.
493 procedure Specific_Add_RAST_Features
495 RAS_Type : Entity_Id);
496 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
497 -- subprogram for Add_RAST_Features.
499 -- An RPC_Target record is used during construction of calling stubs
500 -- to pass PCS-specific tree fragments corresponding to the information
501 -- necessary to locate the target of a remote subprogram call.
503 type RPC_Target (PCS_Kind : PCS_Names) is record
505 when Name_PolyORB_DSA =>
507 -- An expression whose value is a PolyORB reference to the target
511 Partition : Entity_Id;
512 -- A variable containing the Partition_ID of the target partition
514 RPC_Receiver : Node_Id;
515 -- An expression whose value is the address of the target RPC
520 procedure Specific_Build_General_Calling_Stubs
522 Statements : List_Id;
524 Subprogram_Id : Node_Id;
525 Asynchronous : Node_Id := Empty;
526 Is_Known_Asynchronous : Boolean := False;
527 Is_Known_Non_Asynchronous : Boolean := False;
528 Is_Function : Boolean;
530 Stub_Type : Entity_Id := Empty;
531 RACW_Type : Entity_Id := Empty;
533 -- Build calling stubs for general purpose. The parameters are:
534 -- Decls : a place to put declarations
535 -- Statements : a place to put statements
536 -- Target : PCS-specific target information (see details
537 -- in RPC_Target declaration).
538 -- Subprogram_Id : a node containing the subprogram ID
539 -- Asynchronous : True if an APC must be made instead of an RPC.
540 -- The value needs not be supplied if one of the
541 -- Is_Known_... is True.
542 -- Is_Known_Async... : True if we know that this is asynchronous
543 -- Is_Known_Non_A... : True if we know that this is not asynchronous
544 -- Spec : a node with a Parameter_Specifications and
545 -- a Result_Definition if applicable
546 -- Stub_Type : in case of RACW stubs, parameters of type access
547 -- to Stub_Type will be marshalled using the
548 -- address of the object (the addr field) rather
549 -- than using the 'Write on the stub itself
550 -- Nod : used to provide sloc for generated code
552 function Specific_Build_Stub_Target
555 RCI_Locator : Entity_Id;
556 Controlling_Parameter : Entity_Id) return RPC_Target;
557 -- Build call target information nodes for use within calling stubs. In the
558 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
559 -- for an RACW, Controlling_Parameter is the entity for the controlling
560 -- formal parameter used to determine the location of the target of the
561 -- call. Decls provides a location where variable declarations can be
562 -- appended to construct the necessary values.
564 procedure Specific_Build_Stub_Type
565 (RACW_Type : Entity_Id;
566 Stub_Type : Entity_Id;
567 Stub_Type_Decl : out Node_Id;
568 RPC_Receiver_Decl : out Node_Id);
569 -- Build a type declaration for the stub type associated with an RACW
570 -- type, and the necessary RPC receiver, if applicable. PCS-specific
571 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
572 -- is generated, then RPC_Receiver_Decl is set to Empty.
574 procedure Specific_Build_RPC_Receiver_Body
575 (RPC_Receiver : Entity_Id;
576 Request : out Entity_Id;
577 Subp_Id : out Entity_Id;
578 Subp_Index : out Entity_Id;
581 -- Make a subprogram body for an RPC receiver, with the given
582 -- defining unit name. On return:
583 -- - Subp_Id is the subprogram identifier from the PCS.
584 -- - Subp_Index is the index in the list of subprograms
585 -- used for dispatching (a variable of type Subprogram_Id).
586 -- - Stmts is the place where the request dispatching
587 -- statements can occur,
588 -- - Decl is the subprogram body declaration.
590 function Specific_Build_Subprogram_Receiving_Stubs
592 Asynchronous : Boolean;
593 Dynamically_Asynchronous : Boolean := False;
594 Stub_Type : Entity_Id := Empty;
595 RACW_Type : Entity_Id := Empty;
596 Parent_Primitive : Entity_Id := Empty) return Node_Id;
597 -- Build the receiving stub for a given subprogram. The subprogram
598 -- declaration is also built by this procedure, and the value returned
599 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
600 -- found in the specification, then its address is read from the stream
601 -- instead of the object itself and converted into an access to
602 -- class-wide type before doing the real call using any of the RACW type
603 -- pointing on the designated type.
605 procedure Specific_Add_Obj_RPC_Receiver_Completion
608 RPC_Receiver : Entity_Id;
609 Stub_Elements : Stub_Structure);
610 -- Add the necessary code to Decls after the completion of generation
611 -- of the RACW RPC receiver described by Stub_Elements.
613 procedure Specific_Add_Receiving_Stubs_To_Declarations
617 -- Add receiving stubs to the declarative part of an RCI unit
619 package GARLIC_Support is
621 -- Support for generating DSA code that uses the GARLIC PCS
623 -- The subprograms below provide the GARLIC versions of the
624 -- corresponding Specific_<subprogram> routine declared above.
626 procedure Add_RACW_Features
627 (RACW_Type : Entity_Id;
628 Stub_Type : Entity_Id;
629 Stub_Type_Access : Entity_Id;
630 RPC_Receiver_Decl : Node_Id;
631 Body_Decls : List_Id);
633 procedure Add_RAST_Features
635 RAS_Type : Entity_Id);
637 procedure Build_General_Calling_Stubs
639 Statements : List_Id;
640 Target_Partition : Entity_Id; -- From RPC_Target
641 Target_RPC_Receiver : Node_Id; -- From RPC_Target
642 Subprogram_Id : Node_Id;
643 Asynchronous : Node_Id := Empty;
644 Is_Known_Asynchronous : Boolean := False;
645 Is_Known_Non_Asynchronous : Boolean := False;
646 Is_Function : Boolean;
648 Stub_Type : Entity_Id := Empty;
649 RACW_Type : Entity_Id := Empty;
652 function Build_Stub_Target
655 RCI_Locator : Entity_Id;
656 Controlling_Parameter : Entity_Id) return RPC_Target;
658 procedure Build_Stub_Type
659 (RACW_Type : Entity_Id;
660 Stub_Type : Entity_Id;
661 Stub_Type_Decl : out Node_Id;
662 RPC_Receiver_Decl : out Node_Id);
664 function Build_Subprogram_Receiving_Stubs
666 Asynchronous : Boolean;
667 Dynamically_Asynchronous : Boolean := False;
668 Stub_Type : Entity_Id := Empty;
669 RACW_Type : Entity_Id := Empty;
670 Parent_Primitive : Entity_Id := Empty) return Node_Id;
672 procedure Add_Obj_RPC_Receiver_Completion
675 RPC_Receiver : Entity_Id;
676 Stub_Elements : Stub_Structure);
678 procedure Add_Receiving_Stubs_To_Declarations
683 procedure Build_RPC_Receiver_Body
684 (RPC_Receiver : Entity_Id;
685 Request : out Entity_Id;
686 Subp_Id : out Entity_Id;
687 Subp_Index : out Entity_Id;
693 package PolyORB_Support is
695 -- Support for generating DSA code that uses the PolyORB PCS
697 -- The subprograms below provide the PolyORB versions of the
698 -- corresponding Specific_<subprogram> routine declared above.
700 procedure Add_RACW_Features
701 (RACW_Type : Entity_Id;
703 Stub_Type : Entity_Id;
704 Stub_Type_Access : Entity_Id;
705 RPC_Receiver_Decl : Node_Id;
706 Body_Decls : List_Id);
708 procedure Add_RAST_Features
710 RAS_Type : Entity_Id);
712 procedure Build_General_Calling_Stubs
714 Statements : List_Id;
715 Target_Object : Node_Id; -- From RPC_Target
716 Subprogram_Id : Node_Id;
717 Asynchronous : Node_Id := Empty;
718 Is_Known_Asynchronous : Boolean := False;
719 Is_Known_Non_Asynchronous : Boolean := False;
720 Is_Function : Boolean;
722 Stub_Type : Entity_Id := Empty;
723 RACW_Type : Entity_Id := Empty;
726 function Build_Stub_Target
729 RCI_Locator : Entity_Id;
730 Controlling_Parameter : Entity_Id) return RPC_Target;
732 procedure Build_Stub_Type
733 (RACW_Type : Entity_Id;
734 Stub_Type : Entity_Id;
735 Stub_Type_Decl : out Node_Id;
736 RPC_Receiver_Decl : out Node_Id);
738 function Build_Subprogram_Receiving_Stubs
740 Asynchronous : Boolean;
741 Dynamically_Asynchronous : Boolean := False;
742 Stub_Type : Entity_Id := Empty;
743 RACW_Type : Entity_Id := Empty;
744 Parent_Primitive : Entity_Id := Empty) return Node_Id;
746 procedure Add_Obj_RPC_Receiver_Completion
749 RPC_Receiver : Entity_Id;
750 Stub_Elements : Stub_Structure);
752 procedure Add_Receiving_Stubs_To_Declarations
757 procedure Build_RPC_Receiver_Body
758 (RPC_Receiver : Entity_Id;
759 Request : out Entity_Id;
760 Subp_Id : out Entity_Id;
761 Subp_Index : out Entity_Id;
765 procedure Reserve_NamingContext_Methods;
766 -- Mark the method names for interface NamingContext as already used in
767 -- the overload table, so no clashes occur with user code (with the
768 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
769 -- their methods to be accessed as objects, for the implementation of
770 -- remote access-to-subprogram types).
774 -- Routines to build distribution helper subprograms for user-defined
775 -- types. For implementation of the Distributed systems annex (DSA)
776 -- over the PolyORB generic middleware components, it is necessary to
777 -- generate several supporting subprograms for each application data
778 -- type used in inter-partition communication. These subprograms are:
780 -- A Typecode function returning a high-level description of the
783 -- Two conversion functions allowing conversion of values of the
784 -- type from and to the generic data containers used by PolyORB.
785 -- These generic containers are called 'Any' type values after the
786 -- CORBA terminology, and hence the conversion subprograms are
787 -- named To_Any and From_Any.
789 function Build_From_Any_Call
792 Decls : List_Id) return Node_Id;
793 -- Build call to From_Any attribute function of type Typ with
794 -- expression N as actual parameter. Decls is the declarations list
795 -- for an appropriate enclosing scope of the point where the call
796 -- will be inserted; if the From_Any attribute for Typ needs to be
797 -- generated at this point, its declaration is appended to Decls.
799 procedure Build_From_Any_Function
803 Fnam : out Entity_Id);
804 -- Build From_Any attribute function for Typ. Loc is the reference
805 -- location for generated nodes, Typ is the type for which the
806 -- conversion function is generated. On return, Decl and Fnam contain
807 -- the declaration and entity for the newly-created function.
809 function Build_To_Any_Call
811 Decls : List_Id) return Node_Id;
812 -- Build call to To_Any attribute function with expression as actual
813 -- parameter. Decls is the declarations list for an appropriate
814 -- enclosing scope of the point where the call will be inserted; if
815 -- the To_Any attribute for Typ needs to be generated at this point,
816 -- its declaration is appended to Decls.
818 procedure Build_To_Any_Function
822 Fnam : out Entity_Id);
823 -- Build To_Any attribute function for Typ. Loc is the reference
824 -- location for generated nodes, Typ is the type for which the
825 -- conversion function is generated. On return, Decl and Fnam contain
826 -- the declaration and entity for the newly-created function.
828 function Build_TypeCode_Call
831 Decls : List_Id) return Node_Id;
832 -- Build call to TypeCode attribute function for Typ. Decls is the
833 -- declarations list for an appropriate enclosing scope of the point
834 -- where the call will be inserted; if the To_Any attribute for Typ
835 -- needs to be generated at this point, its declaration is appended
838 procedure Build_TypeCode_Function
842 Fnam : out Entity_Id);
843 -- Build TypeCode attribute function for Typ. Loc is the reference
844 -- location for generated nodes, Typ is the type for which the
845 -- conversion function is generated. On return, Decl and Fnam contain
846 -- the declaration and entity for the newly-created function.
848 procedure Build_Name_And_Repository_Id
850 Name_Str : out String_Id;
851 Repo_Id_Str : out String_Id);
852 -- In the PolyORB distribution model, each distributed object type
853 -- and each distributed operation has a globally unique identifier,
854 -- its Repository Id. This subprogram builds and returns two strings
855 -- for entity E (a distributed object type or operation): one
856 -- containing the name of E, the second containing its repository id.
862 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
864 function Build_From_Any_Call
867 Decls : List_Id) return Node_Id
868 renames PolyORB_Support.Helpers.Build_From_Any_Call;
870 function Build_To_Any_Call
872 Decls : List_Id) return Node_Id
873 renames PolyORB_Support.Helpers.Build_To_Any_Call;
875 function Build_TypeCode_Call
878 Decls : List_Id) return Node_Id
879 renames PolyORB_Support.Helpers.Build_TypeCode_Call;
881 ------------------------------------
882 -- Local variables and structures --
883 ------------------------------------
886 -- Needs comments ???
888 Output_From_Constrained : constant array (Boolean) of Name_Id :=
889 (False => Name_Output,
891 -- The attribute to choose depending on the fact that the parameter
892 -- is constrained or not. There is no such thing as Input_From_Constrained
893 -- since this require separate mechanisms ('Input is a function while
894 -- 'Read is a procedure).
896 ---------------------------------------
897 -- Add_Calling_Stubs_To_Declarations --
898 ---------------------------------------
900 procedure Add_Calling_Stubs_To_Declarations
904 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
905 -- Subprogram id 0 is reserved for calls received from
906 -- remote access-to-subprogram dereferences.
908 Current_Declaration : Node_Id;
909 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
910 RCI_Instantiation : Node_Id;
911 Subp_Stubs : Node_Id;
912 Subp_Str : String_Id;
914 pragma Warnings (Off, Subp_Str);
917 -- The first thing added is an instantiation of the generic package
918 -- System.Partition_Interface.RCI_Locator with the name of this remote
919 -- package. This will act as an interface with the name server to
920 -- determine the Partition_ID and the RPC_Receiver for the receiver
923 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
924 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
926 Append_To (Decls, RCI_Instantiation);
927 Analyze (RCI_Instantiation);
929 -- For each subprogram declaration visible in the spec, we do build a
930 -- body. We also increment a counter to assign a different Subprogram_Id
931 -- to each subprograms. The receiving stubs processing do use the same
932 -- mechanism and will thus assign the same Id and do the correct
935 Overload_Counter_Table.Reset;
936 PolyORB_Support.Reserve_NamingContext_Methods;
938 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
939 while Present (Current_Declaration) loop
940 if Nkind (Current_Declaration) = N_Subprogram_Declaration
941 and then Comes_From_Source (Current_Declaration)
943 Assign_Subprogram_Identifier
944 (Defining_Unit_Name (Specification (Current_Declaration)),
945 Current_Subprogram_Number,
949 Build_Subprogram_Calling_Stubs (
950 Vis_Decl => Current_Declaration,
952 Build_Subprogram_Id (Loc,
953 Defining_Unit_Name (Specification (Current_Declaration))),
955 Nkind (Specification (Current_Declaration)) =
956 N_Procedure_Specification
958 Is_Asynchronous (Defining_Unit_Name (Specification
959 (Current_Declaration))));
961 Append_To (Decls, Subp_Stubs);
962 Analyze (Subp_Stubs);
964 Current_Subprogram_Number := Current_Subprogram_Number + 1;
967 Next (Current_Declaration);
969 end Add_Calling_Stubs_To_Declarations;
971 -----------------------------
972 -- Add_Parameter_To_NVList --
973 -----------------------------
975 function Add_Parameter_To_NVList
978 Parameter : Entity_Id;
979 Constrained : Boolean;
980 RACW_Ctrl : Boolean := False;
981 Any : Entity_Id) return Node_Id
983 Parameter_Name_String : String_Id;
984 Parameter_Mode : Node_Id;
986 function Parameter_Passing_Mode
988 Parameter : Entity_Id;
989 Constrained : Boolean) return Node_Id;
990 -- Return an expression that denotes the parameter passing mode to be
991 -- used for Parameter in distribution stubs, where Constrained is
992 -- Parameter's constrained status.
994 ----------------------------
995 -- Parameter_Passing_Mode --
996 ----------------------------
998 function Parameter_Passing_Mode
1000 Parameter : Entity_Id;
1001 Constrained : Boolean) return Node_Id
1006 if Out_Present (Parameter) then
1007 if In_Present (Parameter)
1008 or else not Constrained
1010 -- Unconstrained formals must be translated
1011 -- to 'in' or 'inout', not 'out', because
1012 -- they need to be constrained by the actual.
1014 Lib_RE := RE_Mode_Inout;
1016 Lib_RE := RE_Mode_Out;
1020 Lib_RE := RE_Mode_In;
1023 return New_Occurrence_Of (RTE (Lib_RE), Loc);
1024 end Parameter_Passing_Mode;
1026 -- Start of processing for Add_Parameter_To_NVList
1029 if Nkind (Parameter) = N_Defining_Identifier then
1030 Get_Name_String (Chars (Parameter));
1032 Get_Name_String (Chars (Defining_Identifier (Parameter)));
1035 Parameter_Name_String := String_From_Name_Buffer;
1037 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1039 -- When the parameter passed to Add_Parameter_To_NVList is an
1040 -- Extra_Constrained parameter, Parameter is an N_Defining_
1041 -- Identifier, instead of a complete N_Parameter_Specification.
1042 -- Thus, we explicitly set 'in' mode in this case.
1044 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1048 Parameter_Passing_Mode (Loc, Parameter, Constrained);
1052 Make_Procedure_Call_Statement (Loc,
1055 (RTE (RE_NVList_Add_Item), Loc),
1056 Parameter_Associations => New_List (
1057 New_Occurrence_Of (NVList, Loc),
1058 Make_Function_Call (Loc,
1061 (RTE (RE_To_PolyORB_String), Loc),
1062 Parameter_Associations => New_List (
1063 Make_String_Literal (Loc,
1064 Strval => Parameter_Name_String))),
1065 New_Occurrence_Of (Any, Loc),
1067 end Add_Parameter_To_NVList;
1069 --------------------------------
1070 -- Add_RACW_Asynchronous_Flag --
1071 --------------------------------
1073 procedure Add_RACW_Asynchronous_Flag
1074 (Declarations : List_Id;
1075 RACW_Type : Entity_Id)
1077 Loc : constant Source_Ptr := Sloc (RACW_Type);
1079 Asynchronous_Flag : constant Entity_Id :=
1080 Make_Defining_Identifier (Loc,
1081 New_External_Name (Chars (RACW_Type), 'A'));
1084 -- Declare the asynchronous flag. This flag will be changed to True
1085 -- whenever it is known that the RACW type is asynchronous.
1087 Append_To (Declarations,
1088 Make_Object_Declaration (Loc,
1089 Defining_Identifier => Asynchronous_Flag,
1090 Constant_Present => True,
1091 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1092 Expression => New_Occurrence_Of (Standard_False, Loc)));
1094 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1095 end Add_RACW_Asynchronous_Flag;
1097 -----------------------
1098 -- Add_RACW_Features --
1099 -----------------------
1101 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1102 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1103 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1107 Body_Decls : List_Id;
1109 Stub_Type : Entity_Id;
1110 Stub_Type_Access : Entity_Id;
1111 RPC_Receiver_Decl : Node_Id;
1114 -- True when appropriate stubs have already been generated (this is the
1115 -- case when another RACW with the same designated type has already been
1116 -- encountered), in which case we reuse the previous stubs rather than
1117 -- generating new ones.
1120 if not Expander_Active then
1124 -- Mark the current package declaration as containing an RACW, so that
1125 -- the bodies for the calling stubs and the RACW stream subprograms
1126 -- are attached to the tree when the corresponding body is encountered.
1128 Set_Has_RACW (Current_Scope);
1130 -- Look for place to declare the RACW stub type and RACW operations
1136 -- Case of declaring the RACW in the same package as its designated
1137 -- type: we know that the designated type is a private type, so we
1138 -- use the private declarations list.
1140 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1142 if Present (Private_Declarations (Pkg_Spec)) then
1143 Decls := Private_Declarations (Pkg_Spec);
1145 Decls := Visible_Declarations (Pkg_Spec);
1150 -- Case of declaring the RACW in another package than its designated
1151 -- type: use the private declarations list if present; otherwise
1152 -- use the visible declarations.
1154 Decls := List_Containing (Declaration_Node (RACW_Type));
1158 -- If we were unable to find the declarations, that means that the
1159 -- completion of the type was missing. We can safely return and let the
1160 -- error be caught by the semantic analysis.
1167 (Designated_Type => Desig,
1168 RACW_Type => RACW_Type,
1170 Stub_Type => Stub_Type,
1171 Stub_Type_Access => Stub_Type_Access,
1172 RPC_Receiver_Decl => RPC_Receiver_Decl,
1173 Body_Decls => Body_Decls,
1174 Existing => Existing);
1176 -- If this RACW is not in the main unit, do not generate primitive or
1179 if not Entity_Is_In_Main_Unit (RACW_Type) then
1180 Body_Decls := No_List;
1183 Add_RACW_Asynchronous_Flag
1184 (Declarations => Decls,
1185 RACW_Type => RACW_Type);
1187 Specific_Add_RACW_Features
1188 (RACW_Type => RACW_Type,
1190 Stub_Type => Stub_Type,
1191 Stub_Type_Access => Stub_Type_Access,
1192 RPC_Receiver_Decl => RPC_Receiver_Decl,
1193 Body_Decls => Body_Decls);
1195 -- If we already have stubs for this designated type, nothing to do
1201 if Is_Frozen (Desig) then
1202 Validate_RACW_Primitives (RACW_Type);
1203 Add_RACW_Primitive_Declarations_And_Bodies
1204 (Designated_Type => Desig,
1205 Insertion_Node => RPC_Receiver_Decl,
1206 Body_Decls => Body_Decls);
1209 -- Validate_RACW_Primitives requires the list of all primitives of
1210 -- the designated type, so defer processing until Desig is frozen.
1211 -- See Exp_Ch3.Freeze_Type.
1213 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1215 end Add_RACW_Features;
1217 ------------------------------------------------
1218 -- Add_RACW_Primitive_Declarations_And_Bodies --
1219 ------------------------------------------------
1221 procedure Add_RACW_Primitive_Declarations_And_Bodies
1222 (Designated_Type : Entity_Id;
1223 Insertion_Node : Node_Id;
1224 Body_Decls : List_Id)
1226 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1227 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1228 -- the declarations are recognized as belonging to the current package.
1230 Stub_Elements : constant Stub_Structure :=
1231 Stubs_Table.Get (Designated_Type);
1233 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1235 Is_RAS : constant Boolean :=
1236 not Comes_From_Source (Stub_Elements.RACW_Type);
1237 -- Case of the RACW generated to implement a remote access-to-
1240 Build_Bodies : constant Boolean :=
1241 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1242 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1243 -- only when the main unit is the unit that contains the stub type.
1245 Current_Insertion_Node : Node_Id := Insertion_Node;
1247 RPC_Receiver : Entity_Id;
1248 RPC_Receiver_Statements : List_Id;
1249 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1250 RPC_Receiver_Elsif_Parts : List_Id;
1251 RPC_Receiver_Request : Entity_Id;
1252 RPC_Receiver_Subp_Id : Entity_Id;
1253 RPC_Receiver_Subp_Index : Entity_Id;
1255 Subp_Str : String_Id;
1257 Current_Primitive_Elmt : Elmt_Id;
1258 Current_Primitive : Entity_Id;
1259 Current_Primitive_Body : Node_Id;
1260 Current_Primitive_Spec : Node_Id;
1261 Current_Primitive_Decl : Node_Id;
1262 Current_Primitive_Number : Int := 0;
1263 Current_Primitive_Alias : Node_Id;
1264 Current_Receiver : Entity_Id;
1265 Current_Receiver_Body : Node_Id;
1266 RPC_Receiver_Decl : Node_Id;
1267 Possibly_Asynchronous : Boolean;
1270 if not Expander_Active then
1276 Make_Defining_Identifier (Loc,
1277 Chars => New_Internal_Name ('P'));
1279 Specific_Build_RPC_Receiver_Body
1280 (RPC_Receiver => RPC_Receiver,
1281 Request => RPC_Receiver_Request,
1282 Subp_Id => RPC_Receiver_Subp_Id,
1283 Subp_Index => RPC_Receiver_Subp_Index,
1284 Stmts => RPC_Receiver_Statements,
1285 Decl => RPC_Receiver_Decl);
1287 if Get_PCS_Name = Name_PolyORB_DSA then
1289 -- For the case of PolyORB, we need to map a textual operation
1290 -- name into a primitive index. Currently we do so using a simple
1291 -- sequence of string comparisons.
1293 RPC_Receiver_Elsif_Parts := New_List;
1297 -- Build callers, receivers for every primitive operations and a RPC
1298 -- receiver for this type.
1300 if Present (Primitive_Operations (Designated_Type)) then
1301 Overload_Counter_Table.Reset;
1303 Current_Primitive_Elmt :=
1304 First_Elmt (Primitive_Operations (Designated_Type));
1305 while Current_Primitive_Elmt /= No_Elmt loop
1306 Current_Primitive := Node (Current_Primitive_Elmt);
1308 -- Copy the primitive of all the parents, except predefined ones
1309 -- that are not remotely dispatching. Also omit hidden primitives
1310 -- (occurs in the case of primitives of interface progenitors
1311 -- other than immediate ancestors of the Designated_Type).
1313 if Chars (Current_Primitive) /= Name_uSize
1314 and then Chars (Current_Primitive) /= Name_uAlignment
1316 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1317 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1318 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1319 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1320 Is_TSS (Current_Primitive, TSS_Stream_Write))
1321 and then not Is_Hidden (Current_Primitive)
1323 -- The first thing to do is build an up-to-date copy of the
1324 -- spec with all the formals referencing Designated_Type
1325 -- transformed into formals referencing Stub_Type. Since this
1326 -- primitive may have been inherited, go back the alias chain
1327 -- until the real primitive has been found.
1329 Current_Primitive_Alias := Current_Primitive;
1330 while Present (Alias (Current_Primitive_Alias)) loop
1332 (Current_Primitive_Alias
1333 /= Alias (Current_Primitive_Alias));
1334 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
1337 -- Copy the spec from the original declaration for the purpose
1338 -- of declaring an overriding subprogram: we need to replace
1339 -- the type of each controlling formal with Stub_Type. The
1340 -- primitive may have been declared for Designated_Type or
1341 -- inherited from some ancestor type for which we do not have
1342 -- an easily determined Entity_Id. We have no systematic way
1343 -- of knowing which type to substitute Stub_Type for. Instead,
1344 -- Copy_Specification relies on the flag Is_Controlling_Formal
1345 -- to determine which formals to change.
1347 Current_Primitive_Spec :=
1348 Copy_Specification (Loc,
1349 Spec => Parent (Current_Primitive_Alias),
1350 Ctrl_Type => Stub_Elements.Stub_Type);
1352 Current_Primitive_Decl :=
1353 Make_Subprogram_Declaration (Loc,
1354 Specification => Current_Primitive_Spec);
1356 Insert_After_And_Analyze (Current_Insertion_Node,
1357 Current_Primitive_Decl);
1358 Current_Insertion_Node := Current_Primitive_Decl;
1360 Possibly_Asynchronous :=
1361 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1362 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1364 Assign_Subprogram_Identifier (
1365 Defining_Unit_Name (Current_Primitive_Spec),
1366 Current_Primitive_Number,
1369 if Build_Bodies then
1370 Current_Primitive_Body :=
1371 Build_Subprogram_Calling_Stubs
1372 (Vis_Decl => Current_Primitive_Decl,
1374 Build_Subprogram_Id (Loc,
1375 Defining_Unit_Name (Current_Primitive_Spec)),
1376 Asynchronous => Possibly_Asynchronous,
1377 Dynamically_Asynchronous => Possibly_Asynchronous,
1378 Stub_Type => Stub_Elements.Stub_Type,
1379 RACW_Type => Stub_Elements.RACW_Type);
1380 Append_To (Body_Decls, Current_Primitive_Body);
1382 -- Analyzing the body here would cause the Stub type to
1383 -- be frozen, thus preventing subsequent primitive
1384 -- declarations. For this reason, it will be analyzed
1385 -- later in the regular flow (and in the context of the
1386 -- appropriate unit body, see Append_RACW_Bodies).
1390 -- Build the receiver stubs
1392 if Build_Bodies and then not Is_RAS then
1393 Current_Receiver_Body :=
1394 Specific_Build_Subprogram_Receiving_Stubs
1395 (Vis_Decl => Current_Primitive_Decl,
1396 Asynchronous => Possibly_Asynchronous,
1397 Dynamically_Asynchronous => Possibly_Asynchronous,
1398 Stub_Type => Stub_Elements.Stub_Type,
1399 RACW_Type => Stub_Elements.RACW_Type,
1400 Parent_Primitive => Current_Primitive);
1402 Current_Receiver := Defining_Unit_Name (
1403 Specification (Current_Receiver_Body));
1405 Append_To (Body_Decls, Current_Receiver_Body);
1407 -- Add a case alternative to the receiver
1409 if Get_PCS_Name = Name_PolyORB_DSA then
1410 Append_To (RPC_Receiver_Elsif_Parts,
1411 Make_Elsif_Part (Loc,
1413 Make_Function_Call (Loc,
1416 RTE (RE_Caseless_String_Eq), Loc),
1417 Parameter_Associations => New_List (
1418 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1419 Make_String_Literal (Loc, Subp_Str))),
1421 Then_Statements => New_List (
1422 Make_Assignment_Statement (Loc,
1423 Name => New_Occurrence_Of (
1424 RPC_Receiver_Subp_Index, Loc),
1426 Make_Integer_Literal (Loc,
1427 Intval => Current_Primitive_Number)))));
1430 Append_To (RPC_Receiver_Case_Alternatives,
1431 Make_Case_Statement_Alternative (Loc,
1432 Discrete_Choices => New_List (
1433 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1435 Statements => New_List (
1436 Make_Procedure_Call_Statement (Loc,
1438 New_Occurrence_Of (Current_Receiver, Loc),
1439 Parameter_Associations => New_List (
1440 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1443 -- Increment the index of current primitive
1445 Current_Primitive_Number := Current_Primitive_Number + 1;
1448 Next_Elmt (Current_Primitive_Elmt);
1452 -- Build the case statement and the heart of the subprogram
1454 if Build_Bodies and then not Is_RAS then
1455 if Get_PCS_Name = Name_PolyORB_DSA
1456 and then Present (First (RPC_Receiver_Elsif_Parts))
1458 Append_To (RPC_Receiver_Statements,
1459 Make_Implicit_If_Statement (Designated_Type,
1460 Condition => New_Occurrence_Of (Standard_False, Loc),
1461 Then_Statements => New_List,
1462 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1465 Append_To (RPC_Receiver_Case_Alternatives,
1466 Make_Case_Statement_Alternative (Loc,
1467 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1468 Statements => New_List (Make_Null_Statement (Loc))));
1470 Append_To (RPC_Receiver_Statements,
1471 Make_Case_Statement (Loc,
1473 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1474 Alternatives => RPC_Receiver_Case_Alternatives));
1476 Append_To (Body_Decls, RPC_Receiver_Decl);
1477 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1478 Body_Decls, RPC_Receiver, Stub_Elements);
1480 -- Do not analyze RPC receiver body at this stage since it references
1481 -- subprograms that have not been analyzed yet. It will be analyzed in
1482 -- the regular flow (see Append_RACW_Bodies).
1485 end Add_RACW_Primitive_Declarations_And_Bodies;
1487 -----------------------------
1488 -- Add_RAS_Dereference_TSS --
1489 -----------------------------
1491 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1492 Loc : constant Source_Ptr := Sloc (N);
1494 Type_Def : constant Node_Id := Type_Definition (N);
1495 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1496 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1497 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1499 RACW_Primitive_Name : Node_Id;
1501 Proc : constant Entity_Id :=
1502 Make_Defining_Identifier (Loc,
1503 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1505 Proc_Spec : Node_Id;
1506 Param_Specs : List_Id;
1507 Param_Assoc : constant List_Id := New_List;
1508 Stmts : constant List_Id := New_List;
1510 RAS_Parameter : constant Entity_Id :=
1511 Make_Defining_Identifier (Loc,
1512 Chars => New_Internal_Name ('P'));
1514 Is_Function : constant Boolean :=
1515 Nkind (Type_Def) = N_Access_Function_Definition;
1517 Is_Degenerate : Boolean;
1518 -- Set to True if the subprogram_specification for this RAS has an
1519 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1521 Spec : constant Node_Id := Type_Def;
1523 Current_Parameter : Node_Id;
1525 -- Start of processing for Add_RAS_Dereference_TSS
1528 -- The Dereference TSS for a remote access-to-subprogram type has the
1531 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1534 -- This is called whenever a value of a RAS type is dereferenced
1536 -- First construct a list of parameter specifications:
1538 -- The first formal is the RAS values
1540 Param_Specs := New_List (
1541 Make_Parameter_Specification (Loc,
1542 Defining_Identifier => RAS_Parameter,
1545 New_Occurrence_Of (Fat_Type, Loc)));
1547 -- The following formals are copied from the type declaration
1549 Is_Degenerate := False;
1550 Current_Parameter := First (Parameter_Specifications (Type_Def));
1551 Parameters : while Present (Current_Parameter) loop
1552 if Nkind (Parameter_Type (Current_Parameter)) =
1555 Is_Degenerate := True;
1558 Append_To (Param_Specs,
1559 Make_Parameter_Specification (Loc,
1560 Defining_Identifier =>
1561 Make_Defining_Identifier (Loc,
1562 Chars => Chars (Defining_Identifier (Current_Parameter))),
1563 In_Present => In_Present (Current_Parameter),
1564 Out_Present => Out_Present (Current_Parameter),
1566 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1568 New_Copy_Tree (Expression (Current_Parameter))));
1570 Append_To (Param_Assoc,
1571 Make_Identifier (Loc,
1572 Chars => Chars (Defining_Identifier (Current_Parameter))));
1574 Next (Current_Parameter);
1575 end loop Parameters;
1577 if Is_Degenerate then
1578 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1580 -- Generate a dummy body. This code will never actually be executed,
1581 -- because null is the only legal value for a degenerate RAS type.
1582 -- For legality's sake (in order to avoid generating a function that
1583 -- does not contain a return statement), we include a dummy recursive
1584 -- call on the TSS itself.
1587 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1588 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1591 -- For a normal RAS type, we cast the RAS formal to the corresponding
1592 -- tagged type, and perform a dispatching call to its Call primitive
1595 Prepend_To (Param_Assoc,
1596 Unchecked_Convert_To (RACW_Type,
1597 New_Occurrence_Of (RAS_Parameter, Loc)));
1599 RACW_Primitive_Name :=
1600 Make_Selected_Component (Loc,
1601 Prefix => Scope (RACW_Type),
1602 Selector_Name => Name_uCall);
1607 Make_Simple_Return_Statement (Loc,
1609 Make_Function_Call (Loc,
1610 Name => RACW_Primitive_Name,
1611 Parameter_Associations => Param_Assoc)));
1615 Make_Procedure_Call_Statement (Loc,
1616 Name => RACW_Primitive_Name,
1617 Parameter_Associations => Param_Assoc));
1620 -- Build the complete subprogram
1624 Make_Function_Specification (Loc,
1625 Defining_Unit_Name => Proc,
1626 Parameter_Specifications => Param_Specs,
1627 Result_Definition =>
1629 Entity (Result_Definition (Spec)), Loc));
1631 Set_Ekind (Proc, E_Function);
1633 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1637 Make_Procedure_Specification (Loc,
1638 Defining_Unit_Name => Proc,
1639 Parameter_Specifications => Param_Specs);
1641 Set_Ekind (Proc, E_Procedure);
1642 Set_Etype (Proc, Standard_Void_Type);
1646 Make_Subprogram_Body (Loc,
1647 Specification => Proc_Spec,
1648 Declarations => New_List,
1649 Handled_Statement_Sequence =>
1650 Make_Handled_Sequence_Of_Statements (Loc,
1651 Statements => Stmts)));
1653 Set_TSS (Fat_Type, Proc);
1654 end Add_RAS_Dereference_TSS;
1656 -------------------------------
1657 -- Add_RAS_Proxy_And_Analyze --
1658 -------------------------------
1660 procedure Add_RAS_Proxy_And_Analyze
1663 All_Calls_Remote_E : Entity_Id;
1664 Proxy_Object_Addr : out Entity_Id)
1666 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1668 Subp_Name : constant Entity_Id :=
1669 Defining_Unit_Name (Specification (Vis_Decl));
1671 Pkg_Name : constant Entity_Id :=
1672 Make_Defining_Identifier (Loc,
1673 Chars => New_External_Name (Chars (Subp_Name), 'P', -1));
1675 Proxy_Type : constant Entity_Id :=
1676 Make_Defining_Identifier (Loc,
1679 (Related_Id => Chars (Subp_Name),
1682 Proxy_Type_Full_View : constant Entity_Id :=
1683 Make_Defining_Identifier (Loc,
1684 Chars (Proxy_Type));
1686 Subp_Decl_Spec : constant Node_Id :=
1687 Build_RAS_Primitive_Specification
1688 (Subp_Spec => Specification (Vis_Decl),
1689 Remote_Object_Type => Proxy_Type);
1691 Subp_Body_Spec : constant Node_Id :=
1692 Build_RAS_Primitive_Specification
1693 (Subp_Spec => Specification (Vis_Decl),
1694 Remote_Object_Type => Proxy_Type);
1696 Vis_Decls : constant List_Id := New_List;
1697 Pvt_Decls : constant List_Id := New_List;
1698 Actuals : constant List_Id := New_List;
1700 Perform_Call : Node_Id;
1703 -- type subpP is tagged limited private;
1705 Append_To (Vis_Decls,
1706 Make_Private_Type_Declaration (Loc,
1707 Defining_Identifier => Proxy_Type,
1708 Tagged_Present => True,
1709 Limited_Present => True));
1711 -- [subprogram] Call
1712 -- (Self : access subpP;
1713 -- ...other-formals...)
1716 Append_To (Vis_Decls,
1717 Make_Subprogram_Declaration (Loc,
1718 Specification => Subp_Decl_Spec));
1720 -- A : constant System.Address;
1722 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1724 Append_To (Vis_Decls,
1725 Make_Object_Declaration (Loc,
1726 Defining_Identifier => Proxy_Object_Addr,
1727 Constant_Present => True,
1728 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)));
1732 -- type subpP is tagged limited record
1733 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1737 Append_To (Pvt_Decls,
1738 Make_Full_Type_Declaration (Loc,
1739 Defining_Identifier => Proxy_Type_Full_View,
1741 Build_Remote_Subprogram_Proxy_Type (Loc,
1742 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1744 -- Trick semantic analysis into swapping the public and full view when
1745 -- freezing the public view.
1747 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1750 -- (Self : access O;
1751 -- ...other-formals...) is
1753 -- P (...other-formals...);
1757 -- (Self : access O;
1758 -- ...other-formals...)
1761 -- return F (...other-formals...);
1764 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1766 Make_Procedure_Call_Statement (Loc,
1767 Name => New_Occurrence_Of (Subp_Name, Loc),
1768 Parameter_Associations => Actuals);
1771 Make_Simple_Return_Statement (Loc,
1773 Make_Function_Call (Loc,
1774 Name => New_Occurrence_Of (Subp_Name, Loc),
1775 Parameter_Associations => Actuals));
1778 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1779 pragma Assert (Present (Formal));
1782 exit when No (Formal);
1784 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1787 -- O : aliased subpP;
1789 Append_To (Pvt_Decls,
1790 Make_Object_Declaration (Loc,
1791 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
1792 Aliased_Present => True,
1793 Object_Definition => New_Occurrence_Of (Proxy_Type, Loc)));
1795 -- A : constant System.Address := O'Address;
1797 Append_To (Pvt_Decls,
1798 Make_Object_Declaration (Loc,
1799 Defining_Identifier =>
1800 Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)),
1801 Constant_Present => True,
1802 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc),
1804 Make_Attribute_Reference (Loc,
1805 Prefix => New_Occurrence_Of (
1806 Defining_Identifier (Last (Pvt_Decls)), Loc),
1807 Attribute_Name => Name_Address)));
1810 Make_Package_Declaration (Loc,
1811 Specification => Make_Package_Specification (Loc,
1812 Defining_Unit_Name => Pkg_Name,
1813 Visible_Declarations => Vis_Decls,
1814 Private_Declarations => Pvt_Decls,
1815 End_Label => Empty)));
1816 Analyze (Last (Decls));
1819 Make_Package_Body (Loc,
1820 Defining_Unit_Name =>
1821 Make_Defining_Identifier (Loc, Chars (Pkg_Name)),
1822 Declarations => New_List (
1823 Make_Subprogram_Body (Loc,
1824 Specification => Subp_Body_Spec,
1825 Declarations => New_List,
1826 Handled_Statement_Sequence =>
1827 Make_Handled_Sequence_Of_Statements (Loc,
1828 Statements => New_List (Perform_Call))))));
1829 Analyze (Last (Decls));
1830 end Add_RAS_Proxy_And_Analyze;
1832 -----------------------
1833 -- Add_RAST_Features --
1834 -----------------------
1836 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1837 RAS_Type : constant Entity_Id :=
1838 Equivalent_Type (Defining_Identifier (Vis_Decl));
1840 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1841 Add_RAS_Dereference_TSS (Vis_Decl);
1842 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1843 end Add_RAST_Features;
1849 procedure Add_Stub_Type
1850 (Designated_Type : Entity_Id;
1851 RACW_Type : Entity_Id;
1853 Stub_Type : out Entity_Id;
1854 Stub_Type_Access : out Entity_Id;
1855 RPC_Receiver_Decl : out Node_Id;
1856 Body_Decls : out List_Id;
1857 Existing : out Boolean)
1859 Loc : constant Source_Ptr := Sloc (RACW_Type);
1861 Stub_Elements : constant Stub_Structure :=
1862 Stubs_Table.Get (Designated_Type);
1863 Stub_Type_Decl : Node_Id;
1864 Stub_Type_Access_Decl : Node_Id;
1867 if Stub_Elements /= Empty_Stub_Structure then
1868 Stub_Type := Stub_Elements.Stub_Type;
1869 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1870 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1871 Body_Decls := Stub_Elements.Body_Decls;
1878 Make_Defining_Identifier (Loc,
1879 Chars => New_Internal_Name ('S'));
1880 Set_Ekind (Stub_Type, E_Record_Type);
1881 Set_Is_RACW_Stub_Type (Stub_Type);
1883 Make_Defining_Identifier (Loc,
1884 Chars => New_External_Name
1885 (Related_Id => Chars (Stub_Type), Suffix => 'A'));
1887 Specific_Build_Stub_Type
1888 (RACW_Type, Stub_Type,
1889 Stub_Type_Decl, RPC_Receiver_Decl);
1891 Stub_Type_Access_Decl :=
1892 Make_Full_Type_Declaration (Loc,
1893 Defining_Identifier => Stub_Type_Access,
1895 Make_Access_To_Object_Definition (Loc,
1896 All_Present => True,
1897 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1899 Append_To (Decls, Stub_Type_Decl);
1900 Analyze (Last (Decls));
1901 Append_To (Decls, Stub_Type_Access_Decl);
1902 Analyze (Last (Decls));
1904 -- This is in no way a type derivation, but we fake it to make sure that
1905 -- the dispatching table gets built with the corresponding primitive
1906 -- operations at the right place.
1908 Derive_Subprograms (Parent_Type => Designated_Type,
1909 Derived_Type => Stub_Type);
1911 if Present (RPC_Receiver_Decl) then
1912 Append_To (Decls, RPC_Receiver_Decl);
1914 RPC_Receiver_Decl := Last (Decls);
1917 Body_Decls := New_List;
1919 Stubs_Table.Set (Designated_Type,
1920 (Stub_Type => Stub_Type,
1921 Stub_Type_Access => Stub_Type_Access,
1922 RPC_Receiver_Decl => RPC_Receiver_Decl,
1923 Body_Decls => Body_Decls,
1924 RACW_Type => RACW_Type));
1927 ------------------------
1928 -- Append_RACW_Bodies --
1929 ------------------------
1931 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
1934 E := First_Entity (Spec_Id);
1935 while Present (E) loop
1936 if Is_Remote_Access_To_Class_Wide_Type (E) then
1937 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
1942 end Append_RACW_Bodies;
1944 ----------------------------------
1945 -- Assign_Subprogram_Identifier --
1946 ----------------------------------
1948 procedure Assign_Subprogram_Identifier
1953 N : constant Name_Id := Chars (Def);
1955 Overload_Order : constant Int :=
1956 Overload_Counter_Table.Get (N) + 1;
1959 Overload_Counter_Table.Set (N, Overload_Order);
1961 Get_Name_String (N);
1963 -- Homonym handling: as in Exp_Dbug, but much simpler,
1964 -- because the only entities for which we have to generate
1965 -- names here need only to be disambiguated within their
1968 if Overload_Order > 1 then
1969 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
1970 Name_Len := Name_Len + 2;
1971 Add_Nat_To_Name_Buffer (Overload_Order);
1974 Id := String_From_Name_Buffer;
1975 Subprogram_Identifier_Table.Set (Def,
1976 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
1977 end Assign_Subprogram_Identifier;
1979 -------------------------------------
1980 -- Build_Actual_Object_Declaration --
1981 -------------------------------------
1983 procedure Build_Actual_Object_Declaration
1984 (Object : Entity_Id;
1990 Loc : constant Source_Ptr := Sloc (Object);
1992 -- Declare a temporary object for the actual, possibly initialized with
1993 -- a 'Input/From_Any call.
1995 -- Complication arises in the case of limited types, for which such a
1996 -- declaration is illegal in Ada 95. In that case, we first generate a
1997 -- renaming declaration of the 'Input call, and then if needed we
1998 -- generate an overlaid non-constant view.
2000 if Ada_Version <= Ada_95
2001 and then Is_Limited_Type (Etyp)
2002 and then Present (Expr)
2005 -- Object : Etyp renames <func-call>
2008 Make_Object_Renaming_Declaration (Loc,
2009 Defining_Identifier => Object,
2010 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
2015 -- The name defined by the renaming declaration denotes a
2016 -- constant view; create a non-constant object at the same address
2017 -- to be used as the actual.
2020 Constant_Object : constant Entity_Id :=
2021 Make_Defining_Identifier (Loc,
2022 New_Internal_Name ('P'));
2024 Set_Defining_Identifier
2025 (Last (Decls), Constant_Object);
2027 -- We have an unconstrained Etyp: build the actual constrained
2028 -- subtype for the value we just read from the stream.
2030 -- subtype S is <actual subtype of Constant_Object>;
2033 Build_Actual_Subtype (Etyp,
2034 New_Occurrence_Of (Constant_Object, Loc)));
2039 Make_Object_Declaration (Loc,
2040 Defining_Identifier => Object,
2041 Object_Definition =>
2043 (Defining_Identifier (Last (Decls)), Loc)));
2044 Set_Ekind (Object, E_Variable);
2046 -- Suppress default initialization:
2047 -- pragma Import (Ada, Object);
2051 Chars => Name_Import,
2052 Pragma_Argument_Associations => New_List (
2053 Make_Pragma_Argument_Association (Loc,
2054 Chars => Name_Convention,
2055 Expression => Make_Identifier (Loc, Name_Ada)),
2056 Make_Pragma_Argument_Association (Loc,
2057 Chars => Name_Entity,
2058 Expression => New_Occurrence_Of (Object, Loc)))));
2060 -- for Object'Address use Constant_Object'Address;
2063 Make_Attribute_Definition_Clause (Loc,
2064 Name => New_Occurrence_Of (Object, Loc),
2065 Chars => Name_Address,
2067 Make_Attribute_Reference (Loc,
2068 Prefix => New_Occurrence_Of (Constant_Object, Loc),
2069 Attribute_Name => Name_Address)));
2075 -- General case of a regular object declaration. Object is flagged
2076 -- constant unless it has mode out or in out, to allow the backend
2077 -- to optimize where possible.
2079 -- Object : [constant] Etyp [:= <expr>];
2082 Make_Object_Declaration (Loc,
2083 Defining_Identifier => Object,
2084 Constant_Present => Present (Expr) and then not Variable,
2085 Object_Definition => New_Occurrence_Of (Etyp, Loc),
2086 Expression => Expr));
2088 if Constant_Present (Last (Decls)) then
2089 Set_Ekind (Object, E_Constant);
2091 Set_Ekind (Object, E_Variable);
2094 end Build_Actual_Object_Declaration;
2096 ------------------------------
2097 -- Build_Get_Unique_RP_Call --
2098 ------------------------------
2100 function Build_Get_Unique_RP_Call
2102 Pointer : Entity_Id;
2103 Stub_Type : Entity_Id) return List_Id
2107 Make_Procedure_Call_Statement (Loc,
2109 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2110 Parameter_Associations => New_List (
2111 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2112 New_Occurrence_Of (Pointer, Loc)))),
2114 Make_Assignment_Statement (Loc,
2116 Make_Selected_Component (Loc,
2117 Prefix => New_Occurrence_Of (Pointer, Loc),
2119 New_Occurrence_Of (First_Tag_Component
2120 (Designated_Type (Etype (Pointer))), Loc)),
2122 Make_Attribute_Reference (Loc,
2123 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2124 Attribute_Name => Name_Tag)));
2126 -- Note: The assignment to Pointer._Tag is safe here because
2127 -- we carefully ensured that Stub_Type has exactly the same layout
2128 -- as System.Partition_Interface.RACW_Stub_Type.
2130 end Build_Get_Unique_RP_Call;
2132 -----------------------------------
2133 -- Build_Ordered_Parameters_List --
2134 -----------------------------------
2136 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2137 Constrained_List : List_Id;
2138 Unconstrained_List : List_Id;
2139 Current_Parameter : Node_Id;
2142 First_Parameter : Node_Id;
2143 For_RAS : Boolean := False;
2146 if No (Parameter_Specifications (Spec)) then
2150 Constrained_List := New_List;
2151 Unconstrained_List := New_List;
2152 First_Parameter := First (Parameter_Specifications (Spec));
2154 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2155 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2160 -- Loop through the parameters and add them to the right list. Note that
2161 -- we treat a parameter of a null-excluding access type as unconstrained
2162 -- because we can't declare an object of such a type with default
2165 Current_Parameter := First_Parameter;
2166 while Present (Current_Parameter) loop
2167 Ptyp := Parameter_Type (Current_Parameter);
2169 if (Nkind (Ptyp) = N_Access_Definition
2170 or else not Transmit_As_Unconstrained (Etype (Ptyp)))
2171 and then not (For_RAS and then Current_Parameter = First_Parameter)
2173 Append_To (Constrained_List, New_Copy (Current_Parameter));
2175 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2178 Next (Current_Parameter);
2181 -- Unconstrained parameters are returned first
2183 Append_List_To (Unconstrained_List, Constrained_List);
2185 return Unconstrained_List;
2186 end Build_Ordered_Parameters_List;
2188 ----------------------------------
2189 -- Build_Passive_Partition_Stub --
2190 ----------------------------------
2192 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2194 Pkg_Name : String_Id;
2197 Loc : constant Source_Ptr := Sloc (U);
2200 -- Verify that the implementation supports distribution, by accessing
2201 -- a type defined in the proper version of system.rpc
2204 Dist_OK : Entity_Id;
2205 pragma Warnings (Off, Dist_OK);
2207 Dist_OK := RTE (RE_Params_Stream_Type);
2210 -- Use body if present, spec otherwise
2212 if Nkind (U) = N_Package_Declaration then
2213 Pkg_Spec := Specification (U);
2214 L := Visible_Declarations (Pkg_Spec);
2216 Pkg_Spec := Parent (Corresponding_Spec (U));
2217 L := Declarations (U);
2220 Get_Library_Unit_Name_String (Pkg_Spec);
2221 Pkg_Name := String_From_Name_Buffer;
2223 Make_Procedure_Call_Statement (Loc,
2225 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2226 Parameter_Associations => New_List (
2227 Make_String_Literal (Loc, Pkg_Name),
2228 Make_Attribute_Reference (Loc,
2230 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2231 Attribute_Name => Name_Version)));
2234 end Build_Passive_Partition_Stub;
2236 --------------------------------------
2237 -- Build_RPC_Receiver_Specification --
2238 --------------------------------------
2240 function Build_RPC_Receiver_Specification
2241 (RPC_Receiver : Entity_Id;
2242 Request_Parameter : Entity_Id) return Node_Id
2244 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2247 Make_Procedure_Specification (Loc,
2248 Defining_Unit_Name => RPC_Receiver,
2249 Parameter_Specifications => New_List (
2250 Make_Parameter_Specification (Loc,
2251 Defining_Identifier => Request_Parameter,
2253 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2254 end Build_RPC_Receiver_Specification;
2256 ----------------------------------------
2257 -- Build_Remote_Subprogram_Proxy_Type --
2258 ----------------------------------------
2260 function Build_Remote_Subprogram_Proxy_Type
2262 ACR_Expression : Node_Id) return Node_Id
2266 Make_Record_Definition (Loc,
2267 Tagged_Present => True,
2268 Limited_Present => True,
2270 Make_Component_List (Loc,
2272 Component_Items => New_List (
2273 Make_Component_Declaration (Loc,
2274 Defining_Identifier =>
2275 Make_Defining_Identifier (Loc,
2276 Name_All_Calls_Remote),
2277 Component_Definition =>
2278 Make_Component_Definition (Loc,
2279 Subtype_Indication =>
2280 New_Occurrence_Of (Standard_Boolean, Loc)),
2284 Make_Component_Declaration (Loc,
2285 Defining_Identifier =>
2286 Make_Defining_Identifier (Loc,
2288 Component_Definition =>
2289 Make_Component_Definition (Loc,
2290 Subtype_Indication =>
2291 New_Occurrence_Of (RTE (RE_Address), Loc)),
2293 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2295 Make_Component_Declaration (Loc,
2296 Defining_Identifier =>
2297 Make_Defining_Identifier (Loc,
2299 Component_Definition =>
2300 Make_Component_Definition (Loc,
2301 Subtype_Indication =>
2302 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2303 end Build_Remote_Subprogram_Proxy_Type;
2305 --------------------
2306 -- Build_Stub_Tag --
2307 --------------------
2309 function Build_Stub_Tag
2311 RACW_Type : Entity_Id) return Node_Id
2313 Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type);
2316 Make_Attribute_Reference (Loc,
2317 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2318 Attribute_Name => Name_Tag);
2321 ------------------------------------
2322 -- Build_Subprogram_Calling_Stubs --
2323 ------------------------------------
2325 function Build_Subprogram_Calling_Stubs
2326 (Vis_Decl : Node_Id;
2328 Asynchronous : Boolean;
2329 Dynamically_Asynchronous : Boolean := False;
2330 Stub_Type : Entity_Id := Empty;
2331 RACW_Type : Entity_Id := Empty;
2332 Locator : Entity_Id := Empty;
2333 New_Name : Name_Id := No_Name) return Node_Id
2335 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2337 Decls : constant List_Id := New_List;
2338 Statements : constant List_Id := New_List;
2340 Subp_Spec : Node_Id;
2341 -- The specification of the body
2343 Controlling_Parameter : Entity_Id := Empty;
2345 Asynchronous_Expr : Node_Id := Empty;
2347 RCI_Locator : Entity_Id;
2349 Spec_To_Use : Node_Id;
2351 procedure Insert_Partition_Check (Parameter : Node_Id);
2352 -- Check that the parameter has been elaborated on the same partition
2353 -- than the controlling parameter (E.4(19)).
2355 ----------------------------
2356 -- Insert_Partition_Check --
2357 ----------------------------
2359 procedure Insert_Partition_Check (Parameter : Node_Id) is
2360 Parameter_Entity : constant Entity_Id :=
2361 Defining_Identifier (Parameter);
2363 -- The expression that will be built is of the form:
2365 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2366 -- raise Constraint_Error;
2369 -- We do not check that Parameter is in Stub_Type since such a check
2370 -- has been inserted at the point of call already (a tag check since
2371 -- we have multiple controlling operands).
2374 Make_Raise_Constraint_Error (Loc,
2378 Make_Function_Call (Loc,
2380 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2381 Parameter_Associations =>
2383 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2384 New_Occurrence_Of (Parameter_Entity, Loc)),
2385 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2386 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2387 Reason => CE_Partition_Check_Failed));
2388 end Insert_Partition_Check;
2390 -- Start of processing for Build_Subprogram_Calling_Stubs
2393 Subp_Spec := Copy_Specification (Loc,
2394 Spec => Specification (Vis_Decl),
2395 New_Name => New_Name);
2397 if Locator = Empty then
2398 RCI_Locator := RCI_Cache;
2399 Spec_To_Use := Specification (Vis_Decl);
2401 RCI_Locator := Locator;
2402 Spec_To_Use := Subp_Spec;
2405 -- Find a controlling argument if we have a stub type. Also check
2406 -- if this subprogram can be made asynchronous.
2408 if Present (Stub_Type)
2409 and then Present (Parameter_Specifications (Spec_To_Use))
2412 Current_Parameter : Node_Id :=
2413 First (Parameter_Specifications
2416 while Present (Current_Parameter) loop
2418 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2420 if Controlling_Parameter = Empty then
2421 Controlling_Parameter :=
2422 Defining_Identifier (Current_Parameter);
2424 Insert_Partition_Check (Current_Parameter);
2428 Next (Current_Parameter);
2433 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2435 if Dynamically_Asynchronous then
2436 Asynchronous_Expr := Make_Selected_Component (Loc,
2437 Prefix => Controlling_Parameter,
2438 Selector_Name => Name_Asynchronous);
2441 Specific_Build_General_Calling_Stubs
2443 Statements => Statements,
2444 Target => Specific_Build_Stub_Target (Loc,
2445 Decls, RCI_Locator, Controlling_Parameter),
2446 Subprogram_Id => Subp_Id,
2447 Asynchronous => Asynchronous_Expr,
2448 Is_Known_Asynchronous => Asynchronous
2449 and then not Dynamically_Asynchronous,
2450 Is_Known_Non_Asynchronous
2452 and then not Dynamically_Asynchronous,
2453 Is_Function => Nkind (Spec_To_Use) =
2454 N_Function_Specification,
2455 Spec => Spec_To_Use,
2456 Stub_Type => Stub_Type,
2457 RACW_Type => RACW_Type,
2460 RCI_Calling_Stubs_Table.Set
2461 (Defining_Unit_Name (Specification (Vis_Decl)),
2462 Defining_Unit_Name (Spec_To_Use));
2465 Make_Subprogram_Body (Loc,
2466 Specification => Subp_Spec,
2467 Declarations => Decls,
2468 Handled_Statement_Sequence =>
2469 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2470 end Build_Subprogram_Calling_Stubs;
2472 -------------------------
2473 -- Build_Subprogram_Id --
2474 -------------------------
2476 function Build_Subprogram_Id
2478 E : Entity_Id) return Node_Id
2481 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2483 Current_Declaration : Node_Id;
2484 Current_Subp : Entity_Id;
2485 Current_Subp_Str : String_Id;
2486 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2488 pragma Warnings (Off, Current_Subp_Str);
2491 -- Build_Subprogram_Id is called outside of the context of
2492 -- generating calling or receiving stubs. Hence we are processing
2493 -- an 'Access attribute_reference for an RCI subprogram, for the
2494 -- purpose of obtaining a RAS value.
2497 (Is_Remote_Call_Interface (Scope (E))
2499 (Nkind (Parent (E)) = N_Procedure_Specification
2501 Nkind (Parent (E)) = N_Function_Specification));
2503 Current_Declaration :=
2504 First (Visible_Declarations
2505 (Package_Specification_Of_Scope (Scope (E))));
2506 while Present (Current_Declaration) loop
2507 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2508 and then Comes_From_Source (Current_Declaration)
2510 Current_Subp := Defining_Unit_Name (Specification (
2511 Current_Declaration));
2513 Assign_Subprogram_Identifier
2514 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2516 Current_Subp_Number := Current_Subp_Number + 1;
2519 Next (Current_Declaration);
2524 case Get_PCS_Name is
2525 when Name_PolyORB_DSA =>
2526 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2528 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2530 end Build_Subprogram_Id;
2532 ------------------------
2533 -- Copy_Specification --
2534 ------------------------
2536 function Copy_Specification
2539 Ctrl_Type : Entity_Id := Empty;
2540 New_Name : Name_Id := No_Name) return Node_Id
2542 Parameters : List_Id := No_List;
2544 Current_Parameter : Node_Id;
2545 Current_Identifier : Entity_Id;
2546 Current_Type : Node_Id;
2548 Name_For_New_Spec : Name_Id;
2550 New_Identifier : Entity_Id;
2552 -- Comments needed in body below ???
2555 if New_Name = No_Name then
2556 pragma Assert (Nkind (Spec) = N_Function_Specification
2557 or else Nkind (Spec) = N_Procedure_Specification);
2559 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2561 Name_For_New_Spec := New_Name;
2564 if Present (Parameter_Specifications (Spec)) then
2565 Parameters := New_List;
2566 Current_Parameter := First (Parameter_Specifications (Spec));
2567 while Present (Current_Parameter) loop
2568 Current_Identifier := Defining_Identifier (Current_Parameter);
2569 Current_Type := Parameter_Type (Current_Parameter);
2571 if Nkind (Current_Type) = N_Access_Definition then
2572 if Present (Ctrl_Type) then
2573 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2575 Make_Access_Definition (Loc,
2576 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2577 Null_Exclusion_Present =>
2578 Null_Exclusion_Present (Current_Type));
2582 Make_Access_Definition (Loc,
2584 New_Copy_Tree (Subtype_Mark (Current_Type)),
2585 Null_Exclusion_Present =>
2586 Null_Exclusion_Present (Current_Type));
2590 if Present (Ctrl_Type)
2591 and then Is_Controlling_Formal (Current_Identifier)
2593 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2595 Current_Type := New_Copy_Tree (Current_Type);
2599 New_Identifier := Make_Defining_Identifier (Loc,
2600 Chars (Current_Identifier));
2602 Append_To (Parameters,
2603 Make_Parameter_Specification (Loc,
2604 Defining_Identifier => New_Identifier,
2605 Parameter_Type => Current_Type,
2606 In_Present => In_Present (Current_Parameter),
2607 Out_Present => Out_Present (Current_Parameter),
2609 New_Copy_Tree (Expression (Current_Parameter))));
2611 -- For a regular formal parameter (that needs to be marshalled
2612 -- in the context of remote calls), set the Etype now, because
2613 -- marshalling processing might need it.
2615 if Is_Entity_Name (Current_Type) then
2616 Set_Etype (New_Identifier, Entity (Current_Type));
2618 -- Current_Type is an access definition, special processing
2619 -- (not requiring etype) will occur for marshalling.
2625 Next (Current_Parameter);
2629 case Nkind (Spec) is
2631 when N_Function_Specification | N_Access_Function_Definition =>
2633 Make_Function_Specification (Loc,
2634 Defining_Unit_Name =>
2635 Make_Defining_Identifier (Loc,
2636 Chars => Name_For_New_Spec),
2637 Parameter_Specifications => Parameters,
2638 Result_Definition =>
2639 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2641 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2643 Make_Procedure_Specification (Loc,
2644 Defining_Unit_Name =>
2645 Make_Defining_Identifier (Loc,
2646 Chars => Name_For_New_Spec),
2647 Parameter_Specifications => Parameters);
2650 raise Program_Error;
2652 end Copy_Specification;
2654 -----------------------------
2655 -- Corresponding_Stub_Type --
2656 -----------------------------
2658 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2659 Desig : constant Entity_Id :=
2660 Etype (Designated_Type (RACW_Type));
2661 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2663 return Stub_Elements.Stub_Type;
2664 end Corresponding_Stub_Type;
2666 ---------------------------
2667 -- Could_Be_Asynchronous --
2668 ---------------------------
2670 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2671 Current_Parameter : Node_Id;
2674 if Present (Parameter_Specifications (Spec)) then
2675 Current_Parameter := First (Parameter_Specifications (Spec));
2676 while Present (Current_Parameter) loop
2677 if Out_Present (Current_Parameter) then
2681 Next (Current_Parameter);
2686 end Could_Be_Asynchronous;
2688 ---------------------------
2689 -- Declare_Create_NVList --
2690 ---------------------------
2692 procedure Declare_Create_NVList
2700 Make_Object_Declaration (Loc,
2701 Defining_Identifier => NVList,
2702 Aliased_Present => False,
2703 Object_Definition =>
2704 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2707 Make_Procedure_Call_Statement (Loc,
2708 Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2709 Parameter_Associations => New_List (
2710 New_Occurrence_Of (NVList, Loc))));
2711 end Declare_Create_NVList;
2713 ---------------------------------------------
2714 -- Expand_All_Calls_Remote_Subprogram_Call --
2715 ---------------------------------------------
2717 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2718 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2719 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2720 Loc : constant Source_Ptr := Sloc (N);
2721 RCI_Locator : Node_Id;
2722 RCI_Cache : Entity_Id;
2723 Calling_Stubs : Node_Id;
2724 E_Calling_Stubs : Entity_Id;
2727 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2729 if E_Calling_Stubs = Empty then
2730 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2732 if RCI_Cache = Empty then
2735 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2736 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2738 -- The RCI_Locator package is inserted at the top level in the
2739 -- current unit, and must appear in the proper scope, so that it
2740 -- is not prematurely removed by the GCC back-end.
2743 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2746 if Ekind (Scop) = E_Package_Body then
2747 Push_Scope (Spec_Entity (Scop));
2749 elsif Ekind (Scop) = E_Subprogram_Body then
2751 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2757 Analyze (RCI_Locator);
2761 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2764 RCI_Locator := Parent (RCI_Cache);
2767 Calling_Stubs := Build_Subprogram_Calling_Stubs
2768 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2770 Build_Subprogram_Id (Loc, Called_Subprogram),
2771 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2773 Is_Asynchronous (Called_Subprogram),
2774 Locator => RCI_Cache,
2775 New_Name => New_Internal_Name ('S'));
2776 Insert_After (RCI_Locator, Calling_Stubs);
2777 Analyze (Calling_Stubs);
2778 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2781 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2782 end Expand_All_Calls_Remote_Subprogram_Call;
2784 ---------------------------------
2785 -- Expand_Calling_Stubs_Bodies --
2786 ---------------------------------
2788 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2789 Spec : constant Node_Id := Specification (Unit_Node);
2790 Decls : constant List_Id := Visible_Declarations (Spec);
2792 Push_Scope (Scope_Of_Spec (Spec));
2793 Add_Calling_Stubs_To_Declarations
2794 (Specification (Unit_Node), Decls);
2796 end Expand_Calling_Stubs_Bodies;
2798 -----------------------------------
2799 -- Expand_Receiving_Stubs_Bodies --
2800 -----------------------------------
2802 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2805 Stubs_Decls : List_Id;
2806 Stubs_Stmts : List_Id;
2809 if Nkind (Unit_Node) = N_Package_Declaration then
2810 Spec := Specification (Unit_Node);
2811 Decls := Private_Declarations (Spec);
2814 Decls := Visible_Declarations (Spec);
2817 Push_Scope (Scope_Of_Spec (Spec));
2818 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2822 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2823 Decls := Declarations (Unit_Node);
2825 Push_Scope (Scope_Of_Spec (Unit_Node));
2826 Stubs_Decls := New_List;
2827 Stubs_Stmts := New_List;
2828 Specific_Add_Receiving_Stubs_To_Declarations
2829 (Spec, Stubs_Decls, Stubs_Stmts);
2831 Insert_List_Before (First (Decls), Stubs_Decls);
2834 HSS_Stmts : constant List_Id :=
2835 Statements (Handled_Statement_Sequence (Unit_Node));
2837 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2840 if No (First_HSS_Stmt) then
2841 Append_List_To (HSS_Stmts, Stubs_Stmts);
2843 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2849 end Expand_Receiving_Stubs_Bodies;
2851 --------------------
2852 -- GARLIC_Support --
2853 --------------------
2855 package body GARLIC_Support is
2857 -- Local subprograms
2859 procedure Add_RACW_Read_Attribute
2860 (RACW_Type : Entity_Id;
2861 Stub_Type : Entity_Id;
2862 Stub_Type_Access : Entity_Id;
2863 Body_Decls : List_Id);
2864 -- Add Read attribute for the RACW type. The declaration and attribute
2865 -- definition clauses are inserted right after the declaration of
2866 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2867 -- appended to it (case where the RACW declaration is in the main unit).
2869 procedure Add_RACW_Write_Attribute
2870 (RACW_Type : Entity_Id;
2871 Stub_Type : Entity_Id;
2872 Stub_Type_Access : Entity_Id;
2873 RPC_Receiver : Node_Id;
2874 Body_Decls : List_Id);
2875 -- Same as above for the Write attribute
2877 function Stream_Parameter return Node_Id;
2878 function Result return Node_Id;
2879 function Object return Node_Id renames Result;
2880 -- Functions to create occurrences of the formal parameter names of the
2881 -- 'Read and 'Write attributes.
2884 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2885 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2887 procedure Add_RAS_Access_TSS (N : Node_Id);
2888 -- Add a subprogram body for RAS Access TSS
2890 -------------------------------------
2891 -- Add_Obj_RPC_Receiver_Completion --
2892 -------------------------------------
2894 procedure Add_Obj_RPC_Receiver_Completion
2897 RPC_Receiver : Entity_Id;
2898 Stub_Elements : Stub_Structure)
2901 -- The RPC receiver body should not be the completion of the
2902 -- declaration recorded in the stub structure, because then the
2903 -- occurrences of the formal parameters within the body should refer
2904 -- to the entities from the declaration, not from the completion, to
2905 -- which we do not have easy access. Instead, the RPC receiver body
2906 -- acts as its own declaration, and the RPC receiver declaration is
2907 -- completed by a renaming-as-body.
2910 Make_Subprogram_Renaming_Declaration (Loc,
2912 Copy_Specification (Loc,
2913 Specification (Stub_Elements.RPC_Receiver_Decl)),
2914 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2915 end Add_Obj_RPC_Receiver_Completion;
2917 -----------------------
2918 -- Add_RACW_Features --
2919 -----------------------
2921 procedure Add_RACW_Features
2922 (RACW_Type : Entity_Id;
2923 Stub_Type : Entity_Id;
2924 Stub_Type_Access : Entity_Id;
2925 RPC_Receiver_Decl : Node_Id;
2926 Body_Decls : List_Id)
2928 RPC_Receiver : Node_Id;
2929 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2932 Loc := Sloc (RACW_Type);
2936 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2937 -- of the corresponding distributed object type. We retrieve its
2938 -- address from the local proxy object.
2940 RPC_Receiver := Make_Selected_Component (Loc,
2942 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2943 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2946 RPC_Receiver := Make_Attribute_Reference (Loc,
2947 Prefix => New_Occurrence_Of (
2948 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2949 Attribute_Name => Name_Address);
2952 Add_RACW_Write_Attribute
2959 Add_RACW_Read_Attribute
2964 end Add_RACW_Features;
2966 -----------------------------
2967 -- Add_RACW_Read_Attribute --
2968 -----------------------------
2970 procedure Add_RACW_Read_Attribute
2971 (RACW_Type : Entity_Id;
2972 Stub_Type : Entity_Id;
2973 Stub_Type_Access : Entity_Id;
2974 Body_Decls : List_Id)
2976 Proc_Decl : Node_Id;
2977 Attr_Decl : Node_Id;
2979 Body_Node : Node_Id;
2981 Statements : constant List_Id := New_List;
2983 Local_Statements : List_Id;
2984 Remote_Statements : List_Id;
2985 -- Various parts of the procedure
2987 Pnam : constant Entity_Id :=
2988 Make_Defining_Identifier
2989 (Loc, New_Internal_Name ('R'));
2990 Asynchronous_Flag : constant Entity_Id :=
2991 Asynchronous_Flags_Table.Get (RACW_Type);
2992 pragma Assert (Present (Asynchronous_Flag));
2994 -- Prepare local identifiers
2996 Source_Partition : Entity_Id;
2997 Source_Receiver : Entity_Id;
2998 Source_Address : Entity_Id;
2999 Local_Stub : Entity_Id;
3000 Stubbed_Result : Entity_Id;
3002 -- Start of processing for Add_RACW_Read_Attribute
3005 Build_Stream_Procedure (Loc,
3006 RACW_Type, Body_Node, Pnam, Statements, Outp => True);
3007 Proc_Decl := Make_Subprogram_Declaration (Loc,
3008 Copy_Specification (Loc, Specification (Body_Node)));
3011 Make_Attribute_Definition_Clause (Loc,
3012 Name => New_Occurrence_Of (RACW_Type, Loc),
3016 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3018 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3019 Insert_After (Proc_Decl, Attr_Decl);
3021 if No (Body_Decls) then
3023 -- Case of processing an RACW type from another unit than the
3024 -- main one: do not generate a body.
3029 -- Prepare local identifiers
3032 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3034 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3036 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3038 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
3040 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3042 -- Generate object declarations
3045 Make_Object_Declaration (Loc,
3046 Defining_Identifier => Source_Partition,
3047 Object_Definition =>
3048 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
3050 Make_Object_Declaration (Loc,
3051 Defining_Identifier => Source_Receiver,
3052 Object_Definition =>
3053 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3055 Make_Object_Declaration (Loc,
3056 Defining_Identifier => Source_Address,
3057 Object_Definition =>
3058 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3060 Make_Object_Declaration (Loc,
3061 Defining_Identifier => Local_Stub,
3062 Aliased_Present => True,
3063 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
3065 Make_Object_Declaration (Loc,
3066 Defining_Identifier => Stubbed_Result,
3067 Object_Definition =>
3068 New_Occurrence_Of (Stub_Type_Access, Loc),
3070 Make_Attribute_Reference (Loc,
3072 New_Occurrence_Of (Local_Stub, Loc),
3074 Name_Unchecked_Access)));
3076 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3078 Append_List_To (Statements, New_List (
3079 Make_Attribute_Reference (Loc,
3081 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3082 Attribute_Name => Name_Read,
3083 Expressions => New_List (
3085 New_Occurrence_Of (Source_Partition, Loc))),
3087 Make_Attribute_Reference (Loc,
3089 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3092 Expressions => New_List (
3094 New_Occurrence_Of (Source_Receiver, Loc))),
3096 Make_Attribute_Reference (Loc,
3098 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3101 Expressions => New_List (
3103 New_Occurrence_Of (Source_Address, Loc)))));
3105 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3107 Set_Etype (Stubbed_Result, Stub_Type_Access);
3109 -- If the Address is Null_Address, then return a null object, unless
3110 -- RACW_Type is null-excluding, in which case unconditionally raise
3111 -- CONSTRAINT_ERROR instead.
3114 Zero_Statements : List_Id;
3115 -- Statements executed when a zero value is received
3118 if Can_Never_Be_Null (RACW_Type) then
3119 Zero_Statements := New_List (
3120 Make_Raise_Constraint_Error (Loc,
3121 Reason => CE_Null_Not_Allowed));
3123 Zero_Statements := New_List (
3124 Make_Assignment_Statement (Loc,
3126 Expression => Make_Null (Loc)),
3127 Make_Simple_Return_Statement (Loc));
3130 Append_To (Statements,
3131 Make_Implicit_If_Statement (RACW_Type,
3134 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3135 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3136 Then_Statements => Zero_Statements));
3139 -- If the RACW denotes an object created on the current partition,
3140 -- Local_Statements will be executed. The real object will be used.
3142 Local_Statements := New_List (
3143 Make_Assignment_Statement (Loc,
3146 Unchecked_Convert_To (RACW_Type,
3147 OK_Convert_To (RTE (RE_Address),
3148 New_Occurrence_Of (Source_Address, Loc)))));
3150 -- If the object is located on another partition, then a stub object
3151 -- will be created with all the information needed to rebuild the
3152 -- real object at the other end.
3154 Remote_Statements := New_List (
3156 Make_Assignment_Statement (Loc,
3157 Name => Make_Selected_Component (Loc,
3158 Prefix => Stubbed_Result,
3159 Selector_Name => Name_Origin),
3161 New_Occurrence_Of (Source_Partition, Loc)),
3163 Make_Assignment_Statement (Loc,
3164 Name => Make_Selected_Component (Loc,
3165 Prefix => Stubbed_Result,
3166 Selector_Name => Name_Receiver),
3168 New_Occurrence_Of (Source_Receiver, Loc)),
3170 Make_Assignment_Statement (Loc,
3171 Name => Make_Selected_Component (Loc,
3172 Prefix => Stubbed_Result,
3173 Selector_Name => Name_Addr),
3175 New_Occurrence_Of (Source_Address, Loc)));
3177 Append_To (Remote_Statements,
3178 Make_Assignment_Statement (Loc,
3179 Name => Make_Selected_Component (Loc,
3180 Prefix => Stubbed_Result,
3181 Selector_Name => Name_Asynchronous),
3183 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3185 Append_List_To (Remote_Statements,
3186 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3187 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3188 -- set on the stub type if, and only if, the RACW type has a pragma
3189 -- Asynchronous. This is incorrect for RACWs that implement RAS
3190 -- types, because in that case the /designated subprogram/ (not the
3191 -- type) might be asynchronous, and that causes the stub to need to
3192 -- be asynchronous too. A solution is to transport a RAS as a struct
3193 -- containing a RACW and an asynchronous flag, and to properly alter
3194 -- the Asynchronous component in the stub type in the RAS's Input
3197 Append_To (Remote_Statements,
3198 Make_Assignment_Statement (Loc,
3200 Expression => Unchecked_Convert_To (RACW_Type,
3201 New_Occurrence_Of (Stubbed_Result, Loc))));
3203 -- Distinguish between the local and remote cases, and execute the
3204 -- appropriate piece of code.
3206 Append_To (Statements,
3207 Make_Implicit_If_Statement (RACW_Type,
3211 Make_Function_Call (Loc,
3212 Name => New_Occurrence_Of (
3213 RTE (RE_Get_Local_Partition_Id), Loc)),
3214 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3215 Then_Statements => Local_Statements,
3216 Else_Statements => Remote_Statements));
3218 Set_Declarations (Body_Node, Decls);
3219 Append_To (Body_Decls, Body_Node);
3220 end Add_RACW_Read_Attribute;
3222 ------------------------------
3223 -- Add_RACW_Write_Attribute --
3224 ------------------------------
3226 procedure Add_RACW_Write_Attribute
3227 (RACW_Type : Entity_Id;
3228 Stub_Type : Entity_Id;
3229 Stub_Type_Access : Entity_Id;
3230 RPC_Receiver : Node_Id;
3231 Body_Decls : List_Id)
3233 Body_Node : Node_Id;
3234 Proc_Decl : Node_Id;
3235 Attr_Decl : Node_Id;
3237 Statements : constant List_Id := New_List;
3238 Local_Statements : List_Id;
3239 Remote_Statements : List_Id;
3240 Null_Statements : List_Id;
3242 Pnam : constant Entity_Id :=
3243 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3246 Build_Stream_Procedure
3247 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
3249 Proc_Decl := Make_Subprogram_Declaration (Loc,
3250 Copy_Specification (Loc, Specification (Body_Node)));
3253 Make_Attribute_Definition_Clause (Loc,
3254 Name => New_Occurrence_Of (RACW_Type, Loc),
3255 Chars => Name_Write,
3258 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3260 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3261 Insert_After (Proc_Decl, Attr_Decl);
3263 if No (Body_Decls) then
3267 -- Build the code fragment corresponding to the marshalling of a
3270 Local_Statements := New_List (
3272 Pack_Entity_Into_Stream_Access (Loc,
3273 Stream => Stream_Parameter,
3274 Object => RTE (RE_Get_Local_Partition_Id)),
3276 Pack_Node_Into_Stream_Access (Loc,
3277 Stream => Stream_Parameter,
3278 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3279 Etyp => RTE (RE_Unsigned_64)),
3281 Pack_Node_Into_Stream_Access (Loc,
3282 Stream => Stream_Parameter,
3283 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3284 Make_Attribute_Reference (Loc,
3286 Make_Explicit_Dereference (Loc,
3288 Attribute_Name => Name_Address)),
3289 Etyp => RTE (RE_Unsigned_64)));
3291 -- Build the code fragment corresponding to the marshalling of
3294 Remote_Statements := New_List (
3295 Pack_Node_Into_Stream_Access (Loc,
3296 Stream => Stream_Parameter,
3298 Make_Selected_Component (Loc,
3300 Unchecked_Convert_To (Stub_Type_Access, Object),
3301 Selector_Name => Make_Identifier (Loc, Name_Origin)),
3302 Etyp => RTE (RE_Partition_ID)),
3304 Pack_Node_Into_Stream_Access (Loc,
3305 Stream => Stream_Parameter,
3307 Make_Selected_Component (Loc,
3309 Unchecked_Convert_To (Stub_Type_Access, Object),
3310 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
3311 Etyp => RTE (RE_Unsigned_64)),
3313 Pack_Node_Into_Stream_Access (Loc,
3314 Stream => Stream_Parameter,
3316 Make_Selected_Component (Loc,
3318 Unchecked_Convert_To (Stub_Type_Access, Object),
3319 Selector_Name => Make_Identifier (Loc, Name_Addr)),
3320 Etyp => RTE (RE_Unsigned_64)));
3322 -- Build code fragment corresponding to marshalling of a null object
3324 Null_Statements := New_List (
3326 Pack_Entity_Into_Stream_Access (Loc,
3327 Stream => Stream_Parameter,
3328 Object => RTE (RE_Get_Local_Partition_Id)),
3330 Pack_Node_Into_Stream_Access (Loc,
3331 Stream => Stream_Parameter,
3332 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3333 Etyp => RTE (RE_Unsigned_64)),
3335 Pack_Node_Into_Stream_Access (Loc,
3336 Stream => Stream_Parameter,
3337 Object => Make_Integer_Literal (Loc, Uint_0),
3338 Etyp => RTE (RE_Unsigned_64)));
3340 Append_To (Statements,
3341 Make_Implicit_If_Statement (RACW_Type,
3344 Left_Opnd => Object,
3345 Right_Opnd => Make_Null (Loc)),
3347 Then_Statements => Null_Statements,
3349 Elsif_Parts => New_List (
3350 Make_Elsif_Part (Loc,
3354 Make_Attribute_Reference (Loc,
3356 Attribute_Name => Name_Tag),
3359 Make_Attribute_Reference (Loc,
3360 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3361 Attribute_Name => Name_Tag)),
3362 Then_Statements => Remote_Statements)),
3363 Else_Statements => Local_Statements));
3365 Append_To (Body_Decls, Body_Node);
3366 end Add_RACW_Write_Attribute;
3368 ------------------------
3369 -- Add_RAS_Access_TSS --
3370 ------------------------
3372 procedure Add_RAS_Access_TSS (N : Node_Id) is
3373 Loc : constant Source_Ptr := Sloc (N);
3375 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3376 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3377 -- Ras_Type is the access to subprogram type while Fat_Type is the
3378 -- corresponding record type.
3380 RACW_Type : constant Entity_Id :=
3381 Underlying_RACW_Type (Ras_Type);
3382 Desig : constant Entity_Id :=
3383 Etype (Designated_Type (RACW_Type));
3385 Stub_Elements : constant Stub_Structure :=
3386 Stubs_Table.Get (Desig);
3387 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3389 Proc : constant Entity_Id :=
3390 Make_Defining_Identifier (Loc,
3391 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3393 Proc_Spec : Node_Id;
3395 -- Formal parameters
3397 Package_Name : constant Entity_Id :=
3398 Make_Defining_Identifier (Loc,
3402 Subp_Id : constant Entity_Id :=
3403 Make_Defining_Identifier (Loc,
3405 -- Target subprogram
3407 Asynch_P : constant Entity_Id :=
3408 Make_Defining_Identifier (Loc,
3409 Chars => Name_Asynchronous);
3410 -- Is the procedure to which the 'Access applies asynchronous?
3412 All_Calls_Remote : constant Entity_Id :=
3413 Make_Defining_Identifier (Loc,
3414 Chars => Name_All_Calls_Remote);
3415 -- True if an All_Calls_Remote pragma applies to the RCI unit
3416 -- that contains the subprogram.
3418 -- Common local variables
3420 Proc_Decls : List_Id;
3421 Proc_Statements : List_Id;
3423 Origin : constant Entity_Id :=
3424 Make_Defining_Identifier (Loc,
3425 Chars => New_Internal_Name ('P'));
3427 -- Additional local variables for the local case
3429 Proxy_Addr : constant Entity_Id :=
3430 Make_Defining_Identifier (Loc,
3431 Chars => New_Internal_Name ('P'));
3433 -- Additional local variables for the remote case
3435 Local_Stub : constant Entity_Id :=
3436 Make_Defining_Identifier (Loc,
3437 Chars => New_Internal_Name ('L'));
3439 Stub_Ptr : constant Entity_Id :=
3440 Make_Defining_Identifier (Loc,
3441 Chars => New_Internal_Name ('S'));
3444 (Field_Name : Name_Id;
3445 Value : Node_Id) return Node_Id;
3446 -- Construct an assignment that sets the named component in the
3454 (Field_Name : Name_Id;
3455 Value : Node_Id) return Node_Id
3459 Make_Assignment_Statement (Loc,
3461 Make_Selected_Component (Loc,
3463 Selector_Name => Field_Name),
3464 Expression => Value);
3467 -- Start of processing for Add_RAS_Access_TSS
3470 Proc_Decls := New_List (
3472 -- Common declarations
3474 Make_Object_Declaration (Loc,
3475 Defining_Identifier => Origin,
3476 Constant_Present => True,
3477 Object_Definition =>
3478 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3480 Make_Function_Call (Loc,
3482 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3483 Parameter_Associations => New_List (
3484 New_Occurrence_Of (Package_Name, Loc)))),
3486 -- Declaration use only in the local case: proxy address
3488 Make_Object_Declaration (Loc,
3489 Defining_Identifier => Proxy_Addr,
3490 Object_Definition =>
3491 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3493 -- Declarations used only in the remote case: stub object and
3496 Make_Object_Declaration (Loc,
3497 Defining_Identifier => Local_Stub,
3498 Aliased_Present => True,
3499 Object_Definition =>
3500 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3502 Make_Object_Declaration (Loc,
3503 Defining_Identifier =>
3505 Object_Definition =>
3506 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3508 Make_Attribute_Reference (Loc,
3509 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3510 Attribute_Name => Name_Unchecked_Access)));
3512 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3514 -- Build_Get_Unique_RP_Call needs above information
3516 -- Note: Here we assume that the Fat_Type is a record
3517 -- containing just a pointer to a proxy or stub object.
3519 Proc_Statements := New_List (
3523 -- Get_RAS_Info (Pkg, Subp, PA);
3524 -- if Origin = Local_Partition_Id
3525 -- and then not All_Calls_Remote
3527 -- return Fat_Type!(PA);
3530 Make_Procedure_Call_Statement (Loc,
3531 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3532 Parameter_Associations => New_List (
3533 New_Occurrence_Of (Package_Name, Loc),
3534 New_Occurrence_Of (Subp_Id, Loc),
3535 New_Occurrence_Of (Proxy_Addr, Loc))),
3537 Make_Implicit_If_Statement (N,
3543 New_Occurrence_Of (Origin, Loc),
3545 Make_Function_Call (Loc,
3547 RTE (RE_Get_Local_Partition_Id), Loc))),
3551 New_Occurrence_Of (All_Calls_Remote, Loc))),
3553 Then_Statements => New_List (
3554 Make_Simple_Return_Statement (Loc,
3555 Unchecked_Convert_To (Fat_Type,
3556 OK_Convert_To (RTE (RE_Address),
3557 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3559 Set_Field (Name_Origin,
3560 New_Occurrence_Of (Origin, Loc)),
3562 Set_Field (Name_Receiver,
3563 Make_Function_Call (Loc,
3565 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3566 Parameter_Associations => New_List (
3567 New_Occurrence_Of (Package_Name, Loc)))),
3569 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3571 -- E.4.1(9) A remote call is asynchronous if it is a call to
3572 -- a procedure or a call through a value of an access-to-procedure
3573 -- type to which a pragma Asynchronous applies.
3575 -- Asynch_P is true when the procedure is asynchronous;
3576 -- Asynch_T is true when the type is asynchronous.
3578 Set_Field (Name_Asynchronous,
3580 New_Occurrence_Of (Asynch_P, Loc),
3581 New_Occurrence_Of (Boolean_Literals (
3582 Is_Asynchronous (Ras_Type)), Loc))));
3584 Append_List_To (Proc_Statements,
3585 Build_Get_Unique_RP_Call
3586 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3588 -- Return the newly created value
3590 Append_To (Proc_Statements,
3591 Make_Simple_Return_Statement (Loc,
3593 Unchecked_Convert_To (Fat_Type,
3594 New_Occurrence_Of (Stub_Ptr, Loc))));
3597 Make_Function_Specification (Loc,
3598 Defining_Unit_Name => Proc,
3599 Parameter_Specifications => New_List (
3600 Make_Parameter_Specification (Loc,
3601 Defining_Identifier => Package_Name,
3603 New_Occurrence_Of (Standard_String, Loc)),
3605 Make_Parameter_Specification (Loc,
3606 Defining_Identifier => Subp_Id,
3608 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3610 Make_Parameter_Specification (Loc,
3611 Defining_Identifier => Asynch_P,
3613 New_Occurrence_Of (Standard_Boolean, Loc)),
3615 Make_Parameter_Specification (Loc,
3616 Defining_Identifier => All_Calls_Remote,
3618 New_Occurrence_Of (Standard_Boolean, Loc))),
3620 Result_Definition =>
3621 New_Occurrence_Of (Fat_Type, Loc));
3623 -- Set the kind and return type of the function to prevent
3624 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3626 Set_Ekind (Proc, E_Function);
3627 Set_Etype (Proc, Fat_Type);
3630 Make_Subprogram_Body (Loc,
3631 Specification => Proc_Spec,
3632 Declarations => Proc_Decls,
3633 Handled_Statement_Sequence =>
3634 Make_Handled_Sequence_Of_Statements (Loc,
3635 Statements => Proc_Statements)));
3637 Set_TSS (Fat_Type, Proc);
3638 end Add_RAS_Access_TSS;
3640 -----------------------
3641 -- Add_RAST_Features --
3642 -----------------------
3644 procedure Add_RAST_Features
3645 (Vis_Decl : Node_Id;
3646 RAS_Type : Entity_Id)
3648 pragma Unreferenced (RAS_Type);
3650 Add_RAS_Access_TSS (Vis_Decl);
3651 end Add_RAST_Features;
3653 -----------------------------------------
3654 -- Add_Receiving_Stubs_To_Declarations --
3655 -----------------------------------------
3657 procedure Add_Receiving_Stubs_To_Declarations
3658 (Pkg_Spec : Node_Id;
3662 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3664 Request_Parameter : Node_Id;
3666 Pkg_RPC_Receiver : constant Entity_Id :=
3667 Make_Defining_Identifier (Loc,
3668 New_Internal_Name ('H'));
3669 Pkg_RPC_Receiver_Statements : List_Id;
3670 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3671 Pkg_RPC_Receiver_Body : Node_Id;
3672 -- A Pkg_RPC_Receiver is built to decode the request
3674 Lookup_RAS_Info : constant Entity_Id :=
3675 Make_Defining_Identifier (Loc,
3676 Chars => New_Internal_Name ('R'));
3677 -- A remote subprogram is created to allow peers to look up
3678 -- RAS information using subprogram ids.
3680 Subp_Id : Entity_Id;
3681 Subp_Index : Entity_Id;
3682 -- Subprogram_Id as read from the incoming stream
3684 Current_Declaration : Node_Id;
3685 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3686 Current_Stubs : Node_Id;
3688 Subp_Info_Array : constant Entity_Id :=
3689 Make_Defining_Identifier (Loc,
3690 Chars => New_Internal_Name ('I'));
3692 Subp_Info_List : constant List_Id := New_List;
3694 Register_Pkg_Actuals : constant List_Id := New_List;
3696 All_Calls_Remote_E : Entity_Id;
3697 Proxy_Object_Addr : Entity_Id;
3699 procedure Append_Stubs_To
3700 (RPC_Receiver_Cases : List_Id;
3702 Subprogram_Number : Int);
3703 -- Add one case to the specified RPC receiver case list
3704 -- associating Subprogram_Number with the subprogram declared
3705 -- by Declaration, for which we have receiving stubs in Stubs.
3707 ---------------------
3708 -- Append_Stubs_To --
3709 ---------------------
3711 procedure Append_Stubs_To
3712 (RPC_Receiver_Cases : List_Id;
3714 Subprogram_Number : Int)
3717 Append_To (RPC_Receiver_Cases,
3718 Make_Case_Statement_Alternative (Loc,
3720 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3723 Make_Procedure_Call_Statement (Loc,
3725 New_Occurrence_Of (Defining_Entity (Stubs), Loc),
3726 Parameter_Associations => New_List (
3727 New_Occurrence_Of (Request_Parameter, Loc))))));
3728 end Append_Stubs_To;
3730 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3733 -- Building receiving stubs consist in several operations:
3735 -- - a package RPC receiver must be built. This subprogram
3736 -- will get a Subprogram_Id from the incoming stream
3737 -- and will dispatch the call to the right subprogram;
3739 -- - a receiving stub for each subprogram visible in the package
3740 -- spec. This stub will read all the parameters from the stream,
3741 -- and put the result as well as the exception occurrence in the
3744 -- - a dummy package with an empty spec and a body made of an
3745 -- elaboration part, whose job is to register the receiving
3746 -- part of this RCI package on the name server. This is done
3747 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3749 Build_RPC_Receiver_Body (
3750 RPC_Receiver => Pkg_RPC_Receiver,
3751 Request => Request_Parameter,
3753 Subp_Index => Subp_Index,
3754 Stmts => Pkg_RPC_Receiver_Statements,
3755 Decl => Pkg_RPC_Receiver_Body);
3756 pragma Assert (Subp_Id = Subp_Index);
3758 -- A null subp_id denotes a call through a RAS, in which case the
3759 -- next Uint_64 element in the stream is the address of the local
3760 -- proxy object, from which we can retrieve the actual subprogram id.
3762 Append_To (Pkg_RPC_Receiver_Statements,
3763 Make_Implicit_If_Statement (Pkg_Spec,
3766 New_Occurrence_Of (Subp_Id, Loc),
3767 Make_Integer_Literal (Loc, 0)),
3769 Then_Statements => New_List (
3770 Make_Assignment_Statement (Loc,
3772 New_Occurrence_Of (Subp_Id, Loc),
3775 Make_Selected_Component (Loc,
3777 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3778 OK_Convert_To (RTE (RE_Address),
3779 Make_Attribute_Reference (Loc,
3781 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3784 Expressions => New_List (
3785 Make_Selected_Component (Loc,
3786 Prefix => Request_Parameter,
3787 Selector_Name => Name_Params))))),
3790 Make_Identifier (Loc, Name_Subp_Id))))));
3792 -- Build a subprogram for RAS information lookups
3794 Current_Declaration :=
3795 Make_Subprogram_Declaration (Loc,
3797 Make_Function_Specification (Loc,
3798 Defining_Unit_Name =>
3800 Parameter_Specifications => New_List (
3801 Make_Parameter_Specification (Loc,
3802 Defining_Identifier =>
3803 Make_Defining_Identifier (Loc, Name_Subp_Id),
3807 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3808 Result_Definition =>
3809 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3811 Append_To (Decls, Current_Declaration);
3812 Analyze (Current_Declaration);
3814 Current_Stubs := Build_Subprogram_Receiving_Stubs
3815 (Vis_Decl => Current_Declaration,
3816 Asynchronous => False);
3817 Append_To (Decls, Current_Stubs);
3818 Analyze (Current_Stubs);
3820 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3823 Subprogram_Number => 1);
3825 -- For each subprogram, the receiving stub will be built and a
3826 -- case statement will be made on the Subprogram_Id to dispatch
3827 -- to the right subprogram.
3829 All_Calls_Remote_E :=
3831 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3833 Overload_Counter_Table.Reset;
3835 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3836 while Present (Current_Declaration) loop
3837 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3838 and then Comes_From_Source (Current_Declaration)
3841 Loc : constant Source_Ptr := Sloc (Current_Declaration);
3842 -- While specifically processing Current_Declaration, use
3843 -- its Sloc as the location of all generated nodes.
3845 Subp_Def : constant Entity_Id :=
3847 (Specification (Current_Declaration));
3849 Subp_Val : String_Id;
3850 pragma Warnings (Off, Subp_Val);
3853 -- Build receiving stub
3856 Build_Subprogram_Receiving_Stubs
3857 (Vis_Decl => Current_Declaration,
3859 Nkind (Specification (Current_Declaration)) =
3860 N_Procedure_Specification
3861 and then Is_Asynchronous (Subp_Def));
3863 Append_To (Decls, Current_Stubs);
3864 Analyze (Current_Stubs);
3868 Add_RAS_Proxy_And_Analyze (Decls,
3869 Vis_Decl => Current_Declaration,
3870 All_Calls_Remote_E => All_Calls_Remote_E,
3871 Proxy_Object_Addr => Proxy_Object_Addr);
3873 -- Compute distribution identifier
3875 Assign_Subprogram_Identifier
3877 Current_Subprogram_Number,
3881 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
3883 -- Add subprogram descriptor (RCI_Subp_Info) to the
3884 -- subprograms table for this receiver. The aggregate
3885 -- below must be kept consistent with the declaration
3886 -- of type RCI_Subp_Info in System.Partition_Interface.
3888 Append_To (Subp_Info_List,
3889 Make_Component_Association (Loc,
3890 Choices => New_List (
3891 Make_Integer_Literal (Loc,
3892 Current_Subprogram_Number)),
3895 Make_Aggregate (Loc,
3896 Component_Associations => New_List (
3897 Make_Component_Association (Loc,
3898 Choices => New_List (
3899 Make_Identifier (Loc, Name_Addr)),
3902 Proxy_Object_Addr, Loc))))));
3904 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3905 Stubs => Current_Stubs,
3906 Subprogram_Number => Current_Subprogram_Number);
3909 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3912 Next (Current_Declaration);
3915 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3916 -- rather than raising an exception since we do not want someone
3917 -- to crash a remote partition by sending invalid subprogram ids.
3918 -- This is consistent with the other parts of the case statement
3919 -- since even in presence of incorrect parameters in the stream,
3920 -- every exception will be caught and (if the subprogram is not an
3921 -- APC) put into the result stream and sent away.
3923 Append_To (Pkg_RPC_Receiver_Cases,
3924 Make_Case_Statement_Alternative (Loc,
3925 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
3926 Statements => New_List (Make_Null_Statement (Loc))));
3928 Append_To (Pkg_RPC_Receiver_Statements,
3929 Make_Case_Statement (Loc,
3930 Expression => New_Occurrence_Of (Subp_Id, Loc),
3931 Alternatives => Pkg_RPC_Receiver_Cases));
3934 Make_Object_Declaration (Loc,
3935 Defining_Identifier => Subp_Info_Array,
3936 Constant_Present => True,
3937 Aliased_Present => True,
3938 Object_Definition =>
3939 Make_Subtype_Indication (Loc,
3941 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3943 Make_Index_Or_Discriminant_Constraint (Loc,
3946 Low_Bound => Make_Integer_Literal (Loc,
3947 First_RCI_Subprogram_Id),
3949 Make_Integer_Literal (Loc,
3951 First_RCI_Subprogram_Id
3952 + List_Length (Subp_Info_List) - 1)))))));
3954 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3955 -- has zero length, and the declaration is for an empty array, in
3956 -- which case no initialization aggregate must be generated.
3958 if Present (First (Subp_Info_List)) then
3959 Set_Expression (Last (Decls),
3960 Make_Aggregate (Loc,
3961 Component_Associations => Subp_Info_List));
3963 -- No initialization provided: remove CONSTANT so that the
3964 -- declaration is not an incomplete deferred constant.
3967 Set_Constant_Present (Last (Decls), False);
3970 Analyze (Last (Decls));
3973 Subp_Info_Addr : Node_Id;
3974 -- Return statement for Lookup_RAS_Info: address of the subprogram
3975 -- information record for the requested subprogram id.
3978 if Present (First (Subp_Info_List)) then
3980 Make_Selected_Component (Loc,
3982 Make_Indexed_Component (Loc,
3983 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
3984 Expressions => New_List (
3985 Convert_To (Standard_Integer,
3986 Make_Identifier (Loc, Name_Subp_Id)))),
3987 Selector_Name => Make_Identifier (Loc, Name_Addr));
3989 -- Case of no visible subprogram: just raise Constraint_Error, we
3990 -- know for sure we got junk from a remote partition.
3994 Make_Raise_Constraint_Error (Loc,
3995 Reason => CE_Range_Check_Failed);
3996 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
4000 Make_Subprogram_Body (Loc,
4002 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
4003 Declarations => No_List,
4004 Handled_Statement_Sequence =>
4005 Make_Handled_Sequence_Of_Statements (Loc,
4006 Statements => New_List (
4007 Make_Simple_Return_Statement (Loc,
4010 (RTE (RE_Unsigned_64), Subp_Info_Addr))))));
4013 Analyze (Last (Decls));
4015 Append_To (Decls, Pkg_RPC_Receiver_Body);
4016 Analyze (Last (Decls));
4018 Get_Library_Unit_Name_String (Pkg_Spec);
4022 Append_To (Register_Pkg_Actuals,
4023 Make_String_Literal (Loc,
4024 Strval => String_From_Name_Buffer));
4028 Append_To (Register_Pkg_Actuals,
4029 Make_Attribute_Reference (Loc,
4030 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
4031 Attribute_Name => Name_Unrestricted_Access));
4035 Append_To (Register_Pkg_Actuals,
4036 Make_Attribute_Reference (Loc,
4038 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
4039 Attribute_Name => Name_Version));
4043 Append_To (Register_Pkg_Actuals,
4044 Make_Attribute_Reference (Loc,
4045 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4046 Attribute_Name => Name_Address));
4050 Append_To (Register_Pkg_Actuals,
4051 Make_Attribute_Reference (Loc,
4052 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4053 Attribute_Name => Name_Length));
4055 -- Generate the call
4058 Make_Procedure_Call_Statement (Loc,
4060 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
4061 Parameter_Associations => Register_Pkg_Actuals));
4062 Analyze (Last (Stmts));
4063 end Add_Receiving_Stubs_To_Declarations;
4065 ---------------------------------
4066 -- Build_General_Calling_Stubs --
4067 ---------------------------------
4069 procedure Build_General_Calling_Stubs
4071 Statements : List_Id;
4072 Target_Partition : Entity_Id;
4073 Target_RPC_Receiver : Node_Id;
4074 Subprogram_Id : Node_Id;
4075 Asynchronous : Node_Id := Empty;
4076 Is_Known_Asynchronous : Boolean := False;
4077 Is_Known_Non_Asynchronous : Boolean := False;
4078 Is_Function : Boolean;
4080 Stub_Type : Entity_Id := Empty;
4081 RACW_Type : Entity_Id := Empty;
4084 Loc : constant Source_Ptr := Sloc (Nod);
4086 Stream_Parameter : Node_Id;
4087 -- Name of the stream used to transmit parameters to the
4090 Result_Parameter : Node_Id;
4091 -- Name of the result parameter (in non-APC cases) which get the
4092 -- result of the remote subprogram.
4094 Exception_Return_Parameter : Node_Id;
4095 -- Name of the parameter which will hold the exception sent by the
4096 -- remote subprogram.
4098 Current_Parameter : Node_Id;
4099 -- Current parameter being handled
4101 Ordered_Parameters_List : constant List_Id :=
4102 Build_Ordered_Parameters_List (Spec);
4104 Asynchronous_Statements : List_Id := No_List;
4105 Non_Asynchronous_Statements : List_Id := No_List;
4106 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4108 Extra_Formal_Statements : constant List_Id := New_List;
4109 -- List of statements for extra formal parameters. It will appear
4110 -- after the regular statements for writing out parameters.
4112 pragma Unreferenced (RACW_Type);
4113 -- Used only for the PolyORB case
4116 -- The general form of a calling stub for a given subprogram is:
4118 -- procedure X (...) is P : constant Partition_ID :=
4119 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4120 -- System.RPC.Params_Stream_Type (0); begin
4121 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4122 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4123 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4124 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4126 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4128 -- There are some variations: Do_APC is called for an asynchronous
4129 -- procedure and the part after the call is completely ommitted as
4130 -- well as the declaration of Result. For a function call, 'Input is
4131 -- always used to read the result even if it is constrained.
4134 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4137 Make_Object_Declaration (Loc,
4138 Defining_Identifier => Stream_Parameter,
4139 Aliased_Present => True,
4140 Object_Definition =>
4141 Make_Subtype_Indication (Loc,
4143 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4145 Make_Index_Or_Discriminant_Constraint (Loc,
4147 New_List (Make_Integer_Literal (Loc, 0))))));
4149 if not Is_Known_Asynchronous then
4151 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4154 Make_Object_Declaration (Loc,
4155 Defining_Identifier => Result_Parameter,
4156 Aliased_Present => True,
4157 Object_Definition =>
4158 Make_Subtype_Indication (Loc,
4160 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4162 Make_Index_Or_Discriminant_Constraint (Loc,
4164 New_List (Make_Integer_Literal (Loc, 0))))));
4166 Exception_Return_Parameter :=
4167 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4170 Make_Object_Declaration (Loc,
4171 Defining_Identifier => Exception_Return_Parameter,
4172 Object_Definition =>
4173 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4176 Result_Parameter := Empty;
4177 Exception_Return_Parameter := Empty;
4180 -- Put first the RPC receiver corresponding to the remote package
4182 Append_To (Statements,
4183 Make_Attribute_Reference (Loc,
4185 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4186 Attribute_Name => Name_Write,
4187 Expressions => New_List (
4188 Make_Attribute_Reference (Loc,
4189 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4190 Attribute_Name => Name_Access),
4191 Target_RPC_Receiver)));
4193 -- Then put the Subprogram_Id of the subprogram we want to call in
4196 Append_To (Statements,
4197 Make_Attribute_Reference (Loc,
4198 Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4199 Attribute_Name => Name_Write,
4200 Expressions => New_List (
4201 Make_Attribute_Reference (Loc,
4202 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4203 Attribute_Name => Name_Access),
4206 Current_Parameter := First (Ordered_Parameters_List);
4207 while Present (Current_Parameter) loop
4209 Typ : constant Node_Id :=
4210 Parameter_Type (Current_Parameter);
4212 Constrained : Boolean;
4214 Extra_Parameter : Entity_Id;
4217 if Is_RACW_Controlling_Formal
4218 (Current_Parameter, Stub_Type)
4220 -- In the case of a controlling formal argument, we marshall
4221 -- its addr field rather than the local stub.
4223 Append_To (Statements,
4224 Pack_Node_Into_Stream (Loc,
4225 Stream => Stream_Parameter,
4227 Make_Selected_Component (Loc,
4229 Defining_Identifier (Current_Parameter),
4230 Selector_Name => Name_Addr),
4231 Etyp => RTE (RE_Unsigned_64)));
4236 (Defining_Identifier (Current_Parameter), Loc);
4238 -- Access type parameters are transmitted as in out
4239 -- parameters. However, a dereference is needed so that
4240 -- we marshall the designated object.
4242 if Nkind (Typ) = N_Access_Definition then
4243 Value := Make_Explicit_Dereference (Loc, Value);
4244 Etyp := Etype (Subtype_Mark (Typ));
4246 Etyp := Etype (Typ);
4249 Constrained := not Transmit_As_Unconstrained (Etyp);
4251 -- Any parameter but unconstrained out parameters are
4252 -- transmitted to the peer.
4254 if In_Present (Current_Parameter)
4255 or else not Out_Present (Current_Parameter)
4256 or else not Constrained
4258 Append_To (Statements,
4259 Make_Attribute_Reference (Loc,
4260 Prefix => New_Occurrence_Of (Etyp, Loc),
4262 Output_From_Constrained (Constrained),
4263 Expressions => New_List (
4264 Make_Attribute_Reference (Loc,
4266 New_Occurrence_Of (Stream_Parameter, Loc),
4267 Attribute_Name => Name_Access),
4272 -- If the current parameter has a dynamic constrained status,
4273 -- then this status is transmitted as well.
4274 -- This should be done for accessibility as well ???
4276 if Nkind (Typ) /= N_Access_Definition
4277 and then Need_Extra_Constrained (Current_Parameter)
4279 -- In this block, we do not use the extra formal that has
4280 -- been created because it does not exist at the time of
4281 -- expansion when building calling stubs for remote access
4282 -- to subprogram types. We create an extra variable of this
4283 -- type and push it in the stream after the regular
4286 Extra_Parameter := Make_Defining_Identifier
4287 (Loc, New_Internal_Name ('P'));
4290 Make_Object_Declaration (Loc,
4291 Defining_Identifier => Extra_Parameter,
4292 Constant_Present => True,
4293 Object_Definition =>
4294 New_Occurrence_Of (Standard_Boolean, Loc),
4296 Make_Attribute_Reference (Loc,
4299 Defining_Identifier (Current_Parameter), Loc),
4300 Attribute_Name => Name_Constrained)));
4302 Append_To (Extra_Formal_Statements,
4303 Make_Attribute_Reference (Loc,
4305 New_Occurrence_Of (Standard_Boolean, Loc),
4306 Attribute_Name => Name_Write,
4307 Expressions => New_List (
4308 Make_Attribute_Reference (Loc,
4311 (Stream_Parameter, Loc), Attribute_Name =>
4313 New_Occurrence_Of (Extra_Parameter, Loc))));
4316 Next (Current_Parameter);
4320 -- Append the formal statements list to the statements
4322 Append_List_To (Statements, Extra_Formal_Statements);
4324 if not Is_Known_Non_Asynchronous then
4326 -- Build the call to System.RPC.Do_APC
4328 Asynchronous_Statements := New_List (
4329 Make_Procedure_Call_Statement (Loc,
4331 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4332 Parameter_Associations => New_List (
4333 New_Occurrence_Of (Target_Partition, Loc),
4334 Make_Attribute_Reference (Loc,
4336 New_Occurrence_Of (Stream_Parameter, Loc),
4337 Attribute_Name => Name_Access))));
4339 Asynchronous_Statements := No_List;
4342 if not Is_Known_Asynchronous then
4344 -- Build the call to System.RPC.Do_RPC
4346 Non_Asynchronous_Statements := New_List (
4347 Make_Procedure_Call_Statement (Loc,
4349 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4350 Parameter_Associations => New_List (
4351 New_Occurrence_Of (Target_Partition, Loc),
4353 Make_Attribute_Reference (Loc,
4355 New_Occurrence_Of (Stream_Parameter, Loc),
4356 Attribute_Name => Name_Access),
4358 Make_Attribute_Reference (Loc,
4360 New_Occurrence_Of (Result_Parameter, Loc),
4361 Attribute_Name => Name_Access))));
4363 -- Read the exception occurrence from the result stream and
4364 -- reraise it. It does no harm if this is a Null_Occurrence since
4365 -- this does nothing.
4367 Append_To (Non_Asynchronous_Statements,
4368 Make_Attribute_Reference (Loc,
4370 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4372 Attribute_Name => Name_Read,
4374 Expressions => New_List (
4375 Make_Attribute_Reference (Loc,
4377 New_Occurrence_Of (Result_Parameter, Loc),
4378 Attribute_Name => Name_Access),
4379 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4381 Append_To (Non_Asynchronous_Statements,
4382 Make_Procedure_Call_Statement (Loc,
4384 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4385 Parameter_Associations => New_List (
4386 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4390 -- If this is a function call, then read the value and return
4391 -- it. The return value is written/read using 'Output/'Input.
4393 Append_To (Non_Asynchronous_Statements,
4394 Make_Tag_Check (Loc,
4395 Make_Simple_Return_Statement (Loc,
4397 Make_Attribute_Reference (Loc,
4400 Etype (Result_Definition (Spec)), Loc),
4402 Attribute_Name => Name_Input,
4404 Expressions => New_List (
4405 Make_Attribute_Reference (Loc,
4407 New_Occurrence_Of (Result_Parameter, Loc),
4408 Attribute_Name => Name_Access))))));
4411 -- Loop around parameters and assign out (or in out)
4412 -- parameters. In the case of RACW, controlling arguments
4413 -- cannot possibly have changed since they are remote, so we do
4414 -- not read them from the stream.
4416 Current_Parameter := First (Ordered_Parameters_List);
4417 while Present (Current_Parameter) loop
4419 Typ : constant Node_Id :=
4420 Parameter_Type (Current_Parameter);
4427 (Defining_Identifier (Current_Parameter), Loc);
4429 if Nkind (Typ) = N_Access_Definition then
4430 Value := Make_Explicit_Dereference (Loc, Value);
4431 Etyp := Etype (Subtype_Mark (Typ));
4433 Etyp := Etype (Typ);
4436 if (Out_Present (Current_Parameter)
4437 or else Nkind (Typ) = N_Access_Definition)
4438 and then Etyp /= Stub_Type
4440 Append_To (Non_Asynchronous_Statements,
4441 Make_Attribute_Reference (Loc,
4443 New_Occurrence_Of (Etyp, Loc),
4445 Attribute_Name => Name_Read,
4447 Expressions => New_List (
4448 Make_Attribute_Reference (Loc,
4450 New_Occurrence_Of (Result_Parameter, Loc),
4451 Attribute_Name => Name_Access),
4456 Next (Current_Parameter);
4461 if Is_Known_Asynchronous then
4462 Append_List_To (Statements, Asynchronous_Statements);
4464 elsif Is_Known_Non_Asynchronous then
4465 Append_List_To (Statements, Non_Asynchronous_Statements);
4468 pragma Assert (Present (Asynchronous));
4469 Prepend_To (Asynchronous_Statements,
4470 Make_Attribute_Reference (Loc,
4471 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4472 Attribute_Name => Name_Write,
4473 Expressions => New_List (
4474 Make_Attribute_Reference (Loc,
4476 New_Occurrence_Of (Stream_Parameter, Loc),
4477 Attribute_Name => Name_Access),
4478 New_Occurrence_Of (Standard_True, Loc))));
4480 Prepend_To (Non_Asynchronous_Statements,
4481 Make_Attribute_Reference (Loc,
4482 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4483 Attribute_Name => Name_Write,
4484 Expressions => New_List (
4485 Make_Attribute_Reference (Loc,
4487 New_Occurrence_Of (Stream_Parameter, Loc),
4488 Attribute_Name => Name_Access),
4489 New_Occurrence_Of (Standard_False, Loc))));
4491 Append_To (Statements,
4492 Make_Implicit_If_Statement (Nod,
4493 Condition => Asynchronous,
4494 Then_Statements => Asynchronous_Statements,
4495 Else_Statements => Non_Asynchronous_Statements));
4497 end Build_General_Calling_Stubs;
4499 -----------------------------
4500 -- Build_RPC_Receiver_Body --
4501 -----------------------------
4503 procedure Build_RPC_Receiver_Body
4504 (RPC_Receiver : Entity_Id;
4505 Request : out Entity_Id;
4506 Subp_Id : out Entity_Id;
4507 Subp_Index : out Entity_Id;
4508 Stmts : out List_Id;
4511 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4513 RPC_Receiver_Spec : Node_Id;
4514 RPC_Receiver_Decls : List_Id;
4517 Request := Make_Defining_Identifier (Loc, Name_R);
4519 RPC_Receiver_Spec :=
4520 Build_RPC_Receiver_Specification
4521 (RPC_Receiver => RPC_Receiver,
4522 Request_Parameter => Request);
4524 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4525 Subp_Index := Subp_Id;
4527 -- Subp_Id may not be a constant, because in the case of the RPC
4528 -- receiver for an RCI package, when a call is received from a RAS
4529 -- dereference, it will be assigned during subsequent processing.
4531 RPC_Receiver_Decls := New_List (
4532 Make_Object_Declaration (Loc,
4533 Defining_Identifier => Subp_Id,
4534 Object_Definition =>
4535 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4537 Make_Attribute_Reference (Loc,
4539 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4540 Attribute_Name => Name_Input,
4541 Expressions => New_List (
4542 Make_Selected_Component (Loc,
4544 Selector_Name => Name_Params)))));
4549 Make_Subprogram_Body (Loc,
4550 Specification => RPC_Receiver_Spec,
4551 Declarations => RPC_Receiver_Decls,
4552 Handled_Statement_Sequence =>
4553 Make_Handled_Sequence_Of_Statements (Loc,
4554 Statements => Stmts));
4555 end Build_RPC_Receiver_Body;
4557 -----------------------
4558 -- Build_Stub_Target --
4559 -----------------------
4561 function Build_Stub_Target
4564 RCI_Locator : Entity_Id;
4565 Controlling_Parameter : Entity_Id) return RPC_Target
4567 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4569 Target_Info.Partition :=
4570 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4571 if Present (Controlling_Parameter) then
4573 Make_Object_Declaration (Loc,
4574 Defining_Identifier => Target_Info.Partition,
4575 Constant_Present => True,
4576 Object_Definition =>
4577 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4580 Make_Selected_Component (Loc,
4581 Prefix => Controlling_Parameter,
4582 Selector_Name => Name_Origin)));
4584 Target_Info.RPC_Receiver :=
4585 Make_Selected_Component (Loc,
4586 Prefix => Controlling_Parameter,
4587 Selector_Name => Name_Receiver);
4591 Make_Object_Declaration (Loc,
4592 Defining_Identifier => Target_Info.Partition,
4593 Constant_Present => True,
4594 Object_Definition =>
4595 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4598 Make_Function_Call (Loc,
4599 Name => Make_Selected_Component (Loc,
4601 Make_Identifier (Loc, Chars (RCI_Locator)),
4603 Make_Identifier (Loc,
4604 Name_Get_Active_Partition_ID)))));
4606 Target_Info.RPC_Receiver :=
4607 Make_Selected_Component (Loc,
4609 Make_Identifier (Loc, Chars (RCI_Locator)),
4611 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4614 end Build_Stub_Target;
4616 ---------------------
4617 -- Build_Stub_Type --
4618 ---------------------
4620 procedure Build_Stub_Type
4621 (RACW_Type : Entity_Id;
4622 Stub_Type : Entity_Id;
4623 Stub_Type_Decl : out Node_Id;
4624 RPC_Receiver_Decl : out Node_Id)
4626 Loc : constant Source_Ptr := Sloc (Stub_Type);
4627 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4631 Make_Full_Type_Declaration (Loc,
4632 Defining_Identifier => Stub_Type,
4634 Make_Record_Definition (Loc,
4635 Tagged_Present => True,
4636 Limited_Present => True,
4638 Make_Component_List (Loc,
4639 Component_Items => New_List (
4641 Make_Component_Declaration (Loc,
4642 Defining_Identifier =>
4643 Make_Defining_Identifier (Loc, Name_Origin),
4644 Component_Definition =>
4645 Make_Component_Definition (Loc,
4646 Aliased_Present => False,
4647 Subtype_Indication =>
4649 RTE (RE_Partition_ID), Loc))),
4651 Make_Component_Declaration (Loc,
4652 Defining_Identifier =>
4653 Make_Defining_Identifier (Loc, Name_Receiver),
4654 Component_Definition =>
4655 Make_Component_Definition (Loc,
4656 Aliased_Present => False,
4657 Subtype_Indication =>
4658 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4660 Make_Component_Declaration (Loc,
4661 Defining_Identifier =>
4662 Make_Defining_Identifier (Loc, Name_Addr),
4663 Component_Definition =>
4664 Make_Component_Definition (Loc,
4665 Aliased_Present => False,
4666 Subtype_Indication =>
4667 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4669 Make_Component_Declaration (Loc,
4670 Defining_Identifier =>
4671 Make_Defining_Identifier (Loc, Name_Asynchronous),
4672 Component_Definition =>
4673 Make_Component_Definition (Loc,
4674 Aliased_Present => False,
4675 Subtype_Indication =>
4677 Standard_Boolean, Loc)))))));
4680 RPC_Receiver_Decl := Empty;
4683 RPC_Receiver_Request : constant Entity_Id :=
4684 Make_Defining_Identifier (Loc, Name_R);
4686 RPC_Receiver_Decl :=
4687 Make_Subprogram_Declaration (Loc,
4688 Build_RPC_Receiver_Specification (
4689 RPC_Receiver => Make_Defining_Identifier (Loc,
4690 New_Internal_Name ('R')),
4691 Request_Parameter => RPC_Receiver_Request));
4694 end Build_Stub_Type;
4696 --------------------------------------
4697 -- Build_Subprogram_Receiving_Stubs --
4698 --------------------------------------
4700 function Build_Subprogram_Receiving_Stubs
4701 (Vis_Decl : Node_Id;
4702 Asynchronous : Boolean;
4703 Dynamically_Asynchronous : Boolean := False;
4704 Stub_Type : Entity_Id := Empty;
4705 RACW_Type : Entity_Id := Empty;
4706 Parent_Primitive : Entity_Id := Empty) return Node_Id
4708 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4710 Request_Parameter : constant Entity_Id :=
4711 Make_Defining_Identifier (Loc,
4712 New_Internal_Name ('R'));
4713 -- Formal parameter for receiving stubs: a descriptor for an incoming
4716 Decls : constant List_Id := New_List;
4717 -- All the parameters will get declared before calling the real
4718 -- subprograms. Also the out parameters will be declared.
4720 Statements : constant List_Id := New_List;
4722 Extra_Formal_Statements : constant List_Id := New_List;
4723 -- Statements concerning extra formal parameters
4725 After_Statements : constant List_Id := New_List;
4726 -- Statements to be executed after the subprogram call
4728 Inner_Decls : List_Id := No_List;
4729 -- In case of a function, the inner declarations are needed since
4730 -- the result may be unconstrained.
4732 Excep_Handlers : List_Id := No_List;
4733 Excep_Choice : Entity_Id;
4734 Excep_Code : List_Id;
4736 Parameter_List : constant List_Id := New_List;
4737 -- List of parameters to be passed to the subprogram
4739 Current_Parameter : Node_Id;
4741 Ordered_Parameters_List : constant List_Id :=
4742 Build_Ordered_Parameters_List
4743 (Specification (Vis_Decl));
4745 Subp_Spec : Node_Id;
4746 -- Subprogram specification
4748 Called_Subprogram : Node_Id;
4749 -- The subprogram to call
4751 Null_Raise_Statement : Node_Id;
4753 Dynamic_Async : Entity_Id;
4756 if Present (RACW_Type) then
4757 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4759 Called_Subprogram :=
4761 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4764 if Dynamically_Asynchronous then
4766 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4768 Dynamic_Async := Empty;
4771 if not Asynchronous or Dynamically_Asynchronous then
4773 -- The first statement after the subprogram call is a statement to
4774 -- write a Null_Occurrence into the result stream.
4776 Null_Raise_Statement :=
4777 Make_Attribute_Reference (Loc,
4779 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4780 Attribute_Name => Name_Write,
4781 Expressions => New_List (
4782 Make_Selected_Component (Loc,
4783 Prefix => Request_Parameter,
4784 Selector_Name => Name_Result),
4785 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4787 if Dynamically_Asynchronous then
4788 Null_Raise_Statement :=
4789 Make_Implicit_If_Statement (Vis_Decl,
4791 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4792 Then_Statements => New_List (Null_Raise_Statement));
4795 Append_To (After_Statements, Null_Raise_Statement);
4798 -- Loop through every parameter and get its value from the stream. If
4799 -- the parameter is unconstrained, then the parameter is read using
4800 -- 'Input at the point of declaration.
4802 Current_Parameter := First (Ordered_Parameters_List);
4803 while Present (Current_Parameter) loop
4806 Constrained : Boolean;
4808 Need_Extra_Constrained : Boolean;
4809 -- True when an Extra_Constrained actual is required
4811 Object : constant Entity_Id :=
4812 Make_Defining_Identifier (Loc,
4813 New_Internal_Name ('P'));
4815 Expr : Node_Id := Empty;
4817 Is_Controlling_Formal : constant Boolean :=
4818 Is_RACW_Controlling_Formal
4819 (Current_Parameter, Stub_Type);
4822 if Is_Controlling_Formal then
4824 -- We have a controlling formal parameter. Read its address
4825 -- rather than a real object. The address is in Unsigned_64
4828 Etyp := RTE (RE_Unsigned_64);
4830 Etyp := Etype (Parameter_Type (Current_Parameter));
4833 Constrained := not Transmit_As_Unconstrained (Etyp);
4835 if In_Present (Current_Parameter)
4836 or else not Out_Present (Current_Parameter)
4837 or else not Constrained
4838 or else Is_Controlling_Formal
4840 -- If an input parameter is constrained, then the read of
4841 -- the parameter is deferred until the beginning of the
4842 -- subprogram body. If it is unconstrained, then an
4843 -- expression is built for the object declaration and the
4844 -- variable is set using 'Input instead of 'Read. Note that
4845 -- this deferral does not change the order in which the
4846 -- actuals are read because Build_Ordered_Parameter_List
4847 -- puts them unconstrained first.
4850 Append_To (Statements,
4851 Make_Attribute_Reference (Loc,
4852 Prefix => New_Occurrence_Of (Etyp, Loc),
4853 Attribute_Name => Name_Read,
4854 Expressions => New_List (
4855 Make_Selected_Component (Loc,
4856 Prefix => Request_Parameter,
4857 Selector_Name => Name_Params),
4858 New_Occurrence_Of (Object, Loc))));
4862 -- Build and append Input_With_Tag_Check function
4865 Input_With_Tag_Check (Loc,
4868 Make_Selected_Component (Loc,
4869 Prefix => Request_Parameter,
4870 Selector_Name => Name_Params)));
4872 -- Prepare function call expression
4875 Make_Function_Call (Loc,
4879 (Specification (Last (Decls))), Loc));
4883 Need_Extra_Constrained :=
4884 Nkind (Parameter_Type (Current_Parameter)) /=
4887 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4889 Present (Extra_Constrained
4890 (Defining_Identifier (Current_Parameter)));
4892 -- We may not associate an extra constrained actual to a
4893 -- constant object, so if one is needed, declare the actual
4894 -- as a variable even if it won't be modified.
4896 Build_Actual_Object_Declaration
4899 Variable => Need_Extra_Constrained
4900 or else Out_Present (Current_Parameter),
4904 -- An out parameter may be written back using a 'Write
4905 -- attribute instead of a 'Output because it has been
4906 -- constrained by the parameter given to the caller. Note that
4907 -- out controlling arguments in the case of a RACW are not put
4908 -- back in the stream because the pointer on them has not
4911 if Out_Present (Current_Parameter)
4913 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4915 Append_To (After_Statements,
4916 Make_Attribute_Reference (Loc,
4917 Prefix => New_Occurrence_Of (Etyp, Loc),
4918 Attribute_Name => Name_Write,
4919 Expressions => New_List (
4920 Make_Selected_Component (Loc,
4921 Prefix => Request_Parameter,
4922 Selector_Name => Name_Result),
4923 New_Occurrence_Of (Object, Loc))));
4926 -- For RACW controlling formals, the Etyp of Object is always
4927 -- an RACW, even if the parameter is not of an anonymous access
4928 -- type. In such case, we need to dereference it at call time.
4930 if Is_Controlling_Formal then
4931 if Nkind (Parameter_Type (Current_Parameter)) /=
4934 Append_To (Parameter_List,
4935 Make_Parameter_Association (Loc,
4938 Defining_Identifier (Current_Parameter), Loc),
4939 Explicit_Actual_Parameter =>
4940 Make_Explicit_Dereference (Loc,
4941 Unchecked_Convert_To (RACW_Type,
4942 OK_Convert_To (RTE (RE_Address),
4943 New_Occurrence_Of (Object, Loc))))));
4946 Append_To (Parameter_List,
4947 Make_Parameter_Association (Loc,
4950 Defining_Identifier (Current_Parameter), Loc),
4951 Explicit_Actual_Parameter =>
4952 Unchecked_Convert_To (RACW_Type,
4953 OK_Convert_To (RTE (RE_Address),
4954 New_Occurrence_Of (Object, Loc)))));
4958 Append_To (Parameter_List,
4959 Make_Parameter_Association (Loc,
4962 Defining_Identifier (Current_Parameter), Loc),
4963 Explicit_Actual_Parameter =>
4964 New_Occurrence_Of (Object, Loc)));
4967 -- If the current parameter needs an extra formal, then read it
4968 -- from the stream and set the corresponding semantic field in
4969 -- the variable. If the kind of the parameter identifier is
4970 -- E_Void, then this is a compiler generated parameter that
4971 -- doesn't need an extra constrained status.
4973 -- The case of Extra_Accessibility should also be handled ???
4975 if Need_Extra_Constrained then
4977 Extra_Parameter : constant Entity_Id :=
4979 (Defining_Identifier
4980 (Current_Parameter));
4982 Formal_Entity : constant Entity_Id :=
4983 Make_Defining_Identifier
4984 (Loc, Chars (Extra_Parameter));
4986 Formal_Type : constant Entity_Id :=
4987 Etype (Extra_Parameter);
4991 Make_Object_Declaration (Loc,
4992 Defining_Identifier => Formal_Entity,
4993 Object_Definition =>
4994 New_Occurrence_Of (Formal_Type, Loc)));
4996 Append_To (Extra_Formal_Statements,
4997 Make_Attribute_Reference (Loc,
4998 Prefix => New_Occurrence_Of (
5000 Attribute_Name => Name_Read,
5001 Expressions => New_List (
5002 Make_Selected_Component (Loc,
5003 Prefix => Request_Parameter,
5004 Selector_Name => Name_Params),
5005 New_Occurrence_Of (Formal_Entity, Loc))));
5007 -- Note: the call to Set_Extra_Constrained below relies
5008 -- on the fact that Object's Ekind has been set by
5009 -- Build_Actual_Object_Declaration.
5011 Set_Extra_Constrained (Object, Formal_Entity);
5016 Next (Current_Parameter);
5019 -- Append the formal statements list at the end of regular statements
5021 Append_List_To (Statements, Extra_Formal_Statements);
5023 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
5025 -- The remote subprogram is a function. We build an inner block to
5026 -- be able to hold a potentially unconstrained result in a
5030 Etyp : constant Entity_Id :=
5031 Etype (Result_Definition (Specification (Vis_Decl)));
5032 Result : constant Node_Id :=
5033 Make_Defining_Identifier (Loc,
5034 New_Internal_Name ('R'));
5036 Inner_Decls := New_List (
5037 Make_Object_Declaration (Loc,
5038 Defining_Identifier => Result,
5039 Constant_Present => True,
5040 Object_Definition => New_Occurrence_Of (Etyp, Loc),
5042 Make_Function_Call (Loc,
5043 Name => Called_Subprogram,
5044 Parameter_Associations => Parameter_List)));
5046 if Is_Class_Wide_Type (Etyp) then
5048 -- For a remote call to a function with a class-wide type,
5049 -- check that the returned value satisfies the requirements
5052 Append_To (Inner_Decls,
5053 Make_Transportable_Check (Loc,
5054 New_Occurrence_Of (Result, Loc)));
5058 Append_To (After_Statements,
5059 Make_Attribute_Reference (Loc,
5060 Prefix => New_Occurrence_Of (Etyp, Loc),
5061 Attribute_Name => Name_Output,
5062 Expressions => New_List (
5063 Make_Selected_Component (Loc,
5064 Prefix => Request_Parameter,
5065 Selector_Name => Name_Result),
5066 New_Occurrence_Of (Result, Loc))));
5069 Append_To (Statements,
5070 Make_Block_Statement (Loc,
5071 Declarations => Inner_Decls,
5072 Handled_Statement_Sequence =>
5073 Make_Handled_Sequence_Of_Statements (Loc,
5074 Statements => After_Statements)));
5077 -- The remote subprogram is a procedure. We do not need any inner
5078 -- block in this case.
5080 if Dynamically_Asynchronous then
5082 Make_Object_Declaration (Loc,
5083 Defining_Identifier => Dynamic_Async,
5084 Object_Definition =>
5085 New_Occurrence_Of (Standard_Boolean, Loc)));
5087 Append_To (Statements,
5088 Make_Attribute_Reference (Loc,
5089 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5090 Attribute_Name => Name_Read,
5091 Expressions => New_List (
5092 Make_Selected_Component (Loc,
5093 Prefix => Request_Parameter,
5094 Selector_Name => Name_Params),
5095 New_Occurrence_Of (Dynamic_Async, Loc))));
5098 Append_To (Statements,
5099 Make_Procedure_Call_Statement (Loc,
5100 Name => Called_Subprogram,
5101 Parameter_Associations => Parameter_List));
5103 Append_List_To (Statements, After_Statements);
5106 if Asynchronous and then not Dynamically_Asynchronous then
5108 -- For an asynchronous procedure, add a null exception handler
5110 Excep_Handlers := New_List (
5111 Make_Implicit_Exception_Handler (Loc,
5112 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5113 Statements => New_List (Make_Null_Statement (Loc))));
5116 -- In the other cases, if an exception is raised, then the
5117 -- exception occurrence is copied into the output stream and
5118 -- no other output parameter is written.
5121 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5123 Excep_Code := New_List (
5124 Make_Attribute_Reference (Loc,
5126 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5127 Attribute_Name => Name_Write,
5128 Expressions => New_List (
5129 Make_Selected_Component (Loc,
5130 Prefix => Request_Parameter,
5131 Selector_Name => Name_Result),
5132 New_Occurrence_Of (Excep_Choice, Loc))));
5134 if Dynamically_Asynchronous then
5135 Excep_Code := New_List (
5136 Make_Implicit_If_Statement (Vis_Decl,
5137 Condition => Make_Op_Not (Loc,
5138 New_Occurrence_Of (Dynamic_Async, Loc)),
5139 Then_Statements => Excep_Code));
5142 Excep_Handlers := New_List (
5143 Make_Implicit_Exception_Handler (Loc,
5144 Choice_Parameter => Excep_Choice,
5145 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5146 Statements => Excep_Code));
5151 Make_Procedure_Specification (Loc,
5152 Defining_Unit_Name =>
5153 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
5155 Parameter_Specifications => New_List (
5156 Make_Parameter_Specification (Loc,
5157 Defining_Identifier => Request_Parameter,
5159 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5162 Make_Subprogram_Body (Loc,
5163 Specification => Subp_Spec,
5164 Declarations => Decls,
5165 Handled_Statement_Sequence =>
5166 Make_Handled_Sequence_Of_Statements (Loc,
5167 Statements => Statements,
5168 Exception_Handlers => Excep_Handlers));
5169 end Build_Subprogram_Receiving_Stubs;
5175 function Result return Node_Id is
5177 return Make_Identifier (Loc, Name_V);
5180 ----------------------
5181 -- Stream_Parameter --
5182 ----------------------
5184 function Stream_Parameter return Node_Id is
5186 return Make_Identifier (Loc, Name_S);
5187 end Stream_Parameter;
5191 -------------------------------
5192 -- Get_And_Reset_RACW_Bodies --
5193 -------------------------------
5195 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5196 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
5197 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5199 Body_Decls : List_Id;
5200 -- Returned list of declarations
5203 if Stub_Elements = Empty_Stub_Structure then
5205 -- Stub elements may be missing as a consequence of a previously
5211 Body_Decls := Stub_Elements.Body_Decls;
5212 Stub_Elements.Body_Decls := No_List;
5213 Stubs_Table.Set (Desig, Stub_Elements);
5215 end Get_And_Reset_RACW_Bodies;
5217 -----------------------
5218 -- Get_Stub_Elements --
5219 -----------------------
5221 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is
5222 Desig : constant Entity_Id :=
5223 Etype (Designated_Type (RACW_Type));
5224 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
5226 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5227 return Stub_Elements;
5228 end Get_Stub_Elements;
5230 -----------------------
5231 -- Get_Subprogram_Id --
5232 -----------------------
5234 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5235 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5237 pragma Assert (Result /= No_String);
5239 end Get_Subprogram_Id;
5241 -----------------------
5242 -- Get_Subprogram_Id --
5243 -----------------------
5245 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5247 return Get_Subprogram_Ids (Def).Int_Identifier;
5248 end Get_Subprogram_Id;
5250 ------------------------
5251 -- Get_Subprogram_Ids --
5252 ------------------------
5254 function Get_Subprogram_Ids
5255 (Def : Entity_Id) return Subprogram_Identifiers
5258 return Subprogram_Identifier_Table.Get (Def);
5259 end Get_Subprogram_Ids;
5265 function Hash (F : Entity_Id) return Hash_Index is
5267 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5270 function Hash (F : Name_Id) return Hash_Index is
5272 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5275 --------------------------
5276 -- Input_With_Tag_Check --
5277 --------------------------
5279 function Input_With_Tag_Check
5281 Var_Type : Entity_Id;
5282 Stream : Node_Id) return Node_Id
5286 Make_Subprogram_Body (Loc,
5287 Specification => Make_Function_Specification (Loc,
5288 Defining_Unit_Name =>
5289 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
5290 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5291 Declarations => No_List,
5292 Handled_Statement_Sequence =>
5293 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5294 Make_Tag_Check (Loc,
5295 Make_Simple_Return_Statement (Loc,
5296 Make_Attribute_Reference (Loc,
5297 Prefix => New_Occurrence_Of (Var_Type, Loc),
5298 Attribute_Name => Name_Input,
5300 New_List (Stream)))))));
5301 end Input_With_Tag_Check;
5303 --------------------------------
5304 -- Is_RACW_Controlling_Formal --
5305 --------------------------------
5307 function Is_RACW_Controlling_Formal
5308 (Parameter : Node_Id;
5309 Stub_Type : Entity_Id) return Boolean
5314 -- If the kind of the parameter is E_Void, then it is not a
5315 -- controlling formal (this can happen in the context of RAS).
5317 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5321 -- If the parameter is not a controlling formal, then it cannot
5322 -- be possibly a RACW_Controlling_Formal.
5324 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5328 Typ := Parameter_Type (Parameter);
5329 return (Nkind (Typ) = N_Access_Definition
5330 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5331 or else Etype (Typ) = Stub_Type;
5332 end Is_RACW_Controlling_Formal;
5334 ------------------------------
5335 -- Make_Transportable_Check --
5336 ------------------------------
5338 function Make_Transportable_Check
5340 Expr : Node_Id) return Node_Id is
5343 Make_Raise_Program_Error (Loc,
5346 Build_Get_Transportable (Loc,
5347 Make_Selected_Component (Loc,
5349 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5350 Reason => PE_Non_Transportable_Actual);
5351 end Make_Transportable_Check;
5353 -----------------------------
5354 -- Make_Selected_Component --
5355 -----------------------------
5357 function Make_Selected_Component
5360 Selector_Name : Name_Id) return Node_Id
5363 return Make_Selected_Component (Loc,
5364 Prefix => New_Occurrence_Of (Prefix, Loc),
5365 Selector_Name => Make_Identifier (Loc, Selector_Name));
5366 end Make_Selected_Component;
5368 --------------------
5369 -- Make_Tag_Check --
5370 --------------------
5372 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5373 Occ : constant Entity_Id :=
5374 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5377 return Make_Block_Statement (Loc,
5378 Handled_Statement_Sequence =>
5379 Make_Handled_Sequence_Of_Statements (Loc,
5380 Statements => New_List (N),
5382 Exception_Handlers => New_List (
5383 Make_Implicit_Exception_Handler (Loc,
5384 Choice_Parameter => Occ,
5386 Exception_Choices =>
5387 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5390 New_List (Make_Procedure_Call_Statement (Loc,
5392 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5393 New_List (New_Occurrence_Of (Occ, Loc))))))));
5396 ----------------------------
5397 -- Need_Extra_Constrained --
5398 ----------------------------
5400 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5401 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5403 return Out_Present (Parameter)
5404 and then Has_Discriminants (Etyp)
5405 and then not Is_Constrained (Etyp)
5406 and then not Is_Indefinite_Subtype (Etyp);
5407 end Need_Extra_Constrained;
5409 ------------------------------------
5410 -- Pack_Entity_Into_Stream_Access --
5411 ------------------------------------
5413 function Pack_Entity_Into_Stream_Access
5417 Etyp : Entity_Id := Empty) return Node_Id
5422 if Present (Etyp) then
5425 Typ := Etype (Object);
5429 Pack_Node_Into_Stream_Access (Loc,
5431 Object => New_Occurrence_Of (Object, Loc),
5433 end Pack_Entity_Into_Stream_Access;
5435 ---------------------------
5436 -- Pack_Node_Into_Stream --
5437 ---------------------------
5439 function Pack_Node_Into_Stream
5443 Etyp : Entity_Id) return Node_Id
5445 Write_Attribute : Name_Id := Name_Write;
5448 if not Is_Constrained (Etyp) then
5449 Write_Attribute := Name_Output;
5453 Make_Attribute_Reference (Loc,
5454 Prefix => New_Occurrence_Of (Etyp, Loc),
5455 Attribute_Name => Write_Attribute,
5456 Expressions => New_List (
5457 Make_Attribute_Reference (Loc,
5458 Prefix => New_Occurrence_Of (Stream, Loc),
5459 Attribute_Name => Name_Access),
5461 end Pack_Node_Into_Stream;
5463 ----------------------------------
5464 -- Pack_Node_Into_Stream_Access --
5465 ----------------------------------
5467 function Pack_Node_Into_Stream_Access
5471 Etyp : Entity_Id) return Node_Id
5473 Write_Attribute : Name_Id := Name_Write;
5476 if not Is_Constrained (Etyp) then
5477 Write_Attribute := Name_Output;
5481 Make_Attribute_Reference (Loc,
5482 Prefix => New_Occurrence_Of (Etyp, Loc),
5483 Attribute_Name => Write_Attribute,
5484 Expressions => New_List (
5487 end Pack_Node_Into_Stream_Access;
5489 ---------------------
5490 -- PolyORB_Support --
5491 ---------------------
5493 package body PolyORB_Support is
5495 -- Local subprograms
5497 procedure Add_RACW_Read_Attribute
5498 (RACW_Type : Entity_Id;
5499 Stub_Type : Entity_Id;
5500 Stub_Type_Access : Entity_Id;
5501 Body_Decls : List_Id);
5502 -- Add Read attribute for the RACW type. The declaration and attribute
5503 -- definition clauses are inserted right after the declaration of
5504 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5505 -- appended to it (case where the RACW declaration is in the main unit).
5507 procedure Add_RACW_Write_Attribute
5508 (RACW_Type : Entity_Id;
5509 Stub_Type : Entity_Id;
5510 Stub_Type_Access : Entity_Id;
5511 Body_Decls : List_Id);
5512 -- Same as above for the Write attribute
5514 procedure Add_RACW_From_Any
5515 (RACW_Type : Entity_Id;
5516 Body_Decls : List_Id);
5517 -- Add the From_Any TSS for this RACW type
5519 procedure Add_RACW_To_Any
5520 (RACW_Type : Entity_Id;
5521 Body_Decls : List_Id);
5522 -- Add the To_Any TSS for this RACW type
5524 procedure Add_RACW_TypeCode
5525 (Designated_Type : Entity_Id;
5526 RACW_Type : Entity_Id;
5527 Body_Decls : List_Id);
5528 -- Add the TypeCode TSS for this RACW type
5530 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5531 -- Add the From_Any TSS for this RAS type
5533 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5534 -- Add the To_Any TSS for this RAS type
5536 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5537 -- Add the TypeCode TSS for this RAS type
5539 procedure Add_RAS_Access_TSS (N : Node_Id);
5540 -- Add a subprogram body for RAS Access TSS
5542 -------------------------------------
5543 -- Add_Obj_RPC_Receiver_Completion --
5544 -------------------------------------
5546 procedure Add_Obj_RPC_Receiver_Completion
5549 RPC_Receiver : Entity_Id;
5550 Stub_Elements : Stub_Structure)
5552 Desig : constant Entity_Id :=
5553 Etype (Designated_Type (Stub_Elements.RACW_Type));
5556 Make_Procedure_Call_Statement (Loc,
5559 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5561 Parameter_Associations => New_List (
5565 Make_String_Literal (Loc,
5566 Full_Qualified_Name (Desig)),
5570 Make_Attribute_Reference (Loc,
5573 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5579 Make_Attribute_Reference (Loc,
5582 Defining_Identifier (
5583 Stub_Elements.RPC_Receiver_Decl), Loc),
5586 end Add_Obj_RPC_Receiver_Completion;
5588 -----------------------
5589 -- Add_RACW_Features --
5590 -----------------------
5592 procedure Add_RACW_Features
5593 (RACW_Type : Entity_Id;
5595 Stub_Type : Entity_Id;
5596 Stub_Type_Access : Entity_Id;
5597 RPC_Receiver_Decl : Node_Id;
5598 Body_Decls : List_Id)
5600 pragma Unreferenced (RPC_Receiver_Decl);
5604 (RACW_Type => RACW_Type,
5605 Body_Decls => Body_Decls);
5608 (RACW_Type => RACW_Type,
5609 Body_Decls => Body_Decls);
5611 Add_RACW_Write_Attribute
5612 (RACW_Type => RACW_Type,
5613 Stub_Type => Stub_Type,
5614 Stub_Type_Access => Stub_Type_Access,
5615 Body_Decls => Body_Decls);
5617 Add_RACW_Read_Attribute
5618 (RACW_Type => RACW_Type,
5619 Stub_Type => Stub_Type,
5620 Stub_Type_Access => Stub_Type_Access,
5621 Body_Decls => Body_Decls);
5624 (Designated_Type => Desig,
5625 RACW_Type => RACW_Type,
5626 Body_Decls => Body_Decls);
5627 end Add_RACW_Features;
5629 -----------------------
5630 -- Add_RACW_From_Any --
5631 -----------------------
5633 procedure Add_RACW_From_Any
5634 (RACW_Type : Entity_Id;
5635 Body_Decls : List_Id)
5637 Loc : constant Source_Ptr := Sloc (RACW_Type);
5638 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5640 Fnam : constant Entity_Id :=
5641 Make_Defining_Identifier (Loc,
5642 Chars => New_External_Name (Chars (RACW_Type), 'F'));
5644 Func_Spec : Node_Id;
5645 Func_Decl : Node_Id;
5646 Func_Body : Node_Id;
5648 Statements : List_Id;
5649 -- Various parts of the subprogram
5651 Any_Parameter : constant Entity_Id :=
5652 Make_Defining_Identifier (Loc, Name_A);
5654 Asynchronous_Flag : constant Entity_Id :=
5655 Asynchronous_Flags_Table.Get (RACW_Type);
5656 -- The flag object declared in Add_RACW_Asynchronous_Flag
5660 Make_Function_Specification (Loc,
5661 Defining_Unit_Name =>
5663 Parameter_Specifications => New_List (
5664 Make_Parameter_Specification (Loc,
5665 Defining_Identifier =>
5668 New_Occurrence_Of (RTE (RE_Any), Loc))),
5669 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5671 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5672 -- entity in the declaration spec, not those of the body spec.
5674 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5675 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5676 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5678 if No (Body_Decls) then
5682 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5683 -- set on the stub type if, and only if, the RACW type has a pragma
5684 -- Asynchronous. This is incorrect for RACWs that implement RAS
5685 -- types, because in that case the /designated subprogram/ (not the
5686 -- type) might be asynchronous, and that causes the stub to need to
5687 -- be asynchronous too. A solution is to transport a RAS as a struct
5688 -- containing a RACW and an asynchronous flag, and to properly alter
5689 -- the Asynchronous component in the stub type in the RAS's _From_Any
5692 Statements := New_List (
5693 Make_Simple_Return_Statement (Loc,
5694 Expression => Unchecked_Convert_To (RACW_Type,
5695 Make_Function_Call (Loc,
5696 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5697 Parameter_Associations => New_List (
5698 Make_Function_Call (Loc,
5699 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5700 Parameter_Associations => New_List (
5701 New_Occurrence_Of (Any_Parameter, Loc))),
5702 Build_Stub_Tag (Loc, RACW_Type),
5703 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5704 New_Occurrence_Of (Asynchronous_Flag, Loc))))));
5707 Make_Subprogram_Body (Loc,
5708 Specification => Copy_Specification (Loc, Func_Spec),
5709 Declarations => No_List,
5710 Handled_Statement_Sequence =>
5711 Make_Handled_Sequence_Of_Statements (Loc,
5712 Statements => Statements));
5714 Append_To (Body_Decls, Func_Body);
5715 end Add_RACW_From_Any;
5717 -----------------------------
5718 -- Add_RACW_Read_Attribute --
5719 -----------------------------
5721 procedure Add_RACW_Read_Attribute
5722 (RACW_Type : Entity_Id;
5723 Stub_Type : Entity_Id;
5724 Stub_Type_Access : Entity_Id;
5725 Body_Decls : List_Id)
5727 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5729 Loc : constant Source_Ptr := Sloc (RACW_Type);
5731 Proc_Decl : Node_Id;
5732 Attr_Decl : Node_Id;
5734 Body_Node : Node_Id;
5736 Decls : constant List_Id := New_List;
5737 Statements : constant List_Id := New_List;
5738 Reference : constant Entity_Id :=
5739 Make_Defining_Identifier (Loc, Name_R);
5740 -- Various parts of the procedure
5742 Pnam : constant Entity_Id := Make_Defining_Identifier (Loc,
5743 New_Internal_Name ('R'));
5745 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5747 Asynchronous_Flag : constant Entity_Id :=
5748 Asynchronous_Flags_Table.Get (RACW_Type);
5749 pragma Assert (Present (Asynchronous_Flag));
5751 function Stream_Parameter return Node_Id;
5752 function Result return Node_Id;
5754 -- Functions to create occurrences of the formal parameter names
5760 function Result return Node_Id is
5762 return Make_Identifier (Loc, Name_V);
5765 ----------------------
5766 -- Stream_Parameter --
5767 ----------------------
5769 function Stream_Parameter return Node_Id is
5771 return Make_Identifier (Loc, Name_S);
5772 end Stream_Parameter;
5774 -- Start of processing for Add_RACW_Read_Attribute
5777 Build_Stream_Procedure
5778 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
5780 Proc_Decl := Make_Subprogram_Declaration (Loc,
5781 Copy_Specification (Loc, Specification (Body_Node)));
5784 Make_Attribute_Definition_Clause (Loc,
5785 Name => New_Occurrence_Of (RACW_Type, Loc),
5789 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5791 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5792 Insert_After (Proc_Decl, Attr_Decl);
5794 if No (Body_Decls) then
5799 Make_Object_Declaration (Loc,
5800 Defining_Identifier =>
5802 Object_Definition =>
5803 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5805 Append_List_To (Statements, New_List (
5806 Make_Attribute_Reference (Loc,
5808 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5809 Attribute_Name => Name_Read,
5810 Expressions => New_List (
5812 New_Occurrence_Of (Reference, Loc))),
5814 Make_Assignment_Statement (Loc,
5818 Unchecked_Convert_To (RACW_Type,
5819 Make_Function_Call (Loc,
5821 New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5822 Parameter_Associations => New_List (
5823 New_Occurrence_Of (Reference, Loc),
5824 Build_Stub_Tag (Loc, RACW_Type),
5825 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5826 New_Occurrence_Of (Asynchronous_Flag, Loc)))))));
5828 Set_Declarations (Body_Node, Decls);
5829 Append_To (Body_Decls, Body_Node);
5830 end Add_RACW_Read_Attribute;
5832 ---------------------
5833 -- Add_RACW_To_Any --
5834 ---------------------
5836 procedure Add_RACW_To_Any
5837 (RACW_Type : Entity_Id;
5838 Body_Decls : List_Id)
5840 Loc : constant Source_Ptr := Sloc (RACW_Type);
5842 Fnam : constant Entity_Id :=
5843 Make_Defining_Identifier (Loc,
5844 Chars => New_External_Name (Chars (RACW_Type), 'T'));
5846 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5848 Stub_Elements : constant Stub_Structure :=
5849 Get_Stub_Elements (RACW_Type);
5851 Func_Spec : Node_Id;
5852 Func_Decl : Node_Id;
5853 Func_Body : Node_Id;
5856 Statements : List_Id;
5857 -- Various parts of the subprogram
5859 RACW_Parameter : constant Entity_Id :=
5860 Make_Defining_Identifier (Loc, Name_R);
5862 Reference : constant Entity_Id :=
5863 Make_Defining_Identifier
5864 (Loc, New_Internal_Name ('R'));
5865 Any : constant Entity_Id :=
5866 Make_Defining_Identifier
5867 (Loc, New_Internal_Name ('A'));
5871 Make_Function_Specification (Loc,
5872 Defining_Unit_Name =>
5874 Parameter_Specifications => New_List (
5875 Make_Parameter_Specification (Loc,
5876 Defining_Identifier =>
5879 New_Occurrence_Of (RACW_Type, Loc))),
5880 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5882 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5883 -- entity in the declaration spec, not in the body spec.
5885 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5887 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5888 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5890 if No (Body_Decls) then
5896 -- R : constant Object_Ref :=
5902 -- RPC_Receiver'Access);
5906 Make_Object_Declaration (Loc,
5907 Defining_Identifier => Reference,
5908 Constant_Present => True,
5909 Object_Definition =>
5910 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5912 Make_Function_Call (Loc,
5913 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5914 Parameter_Associations => New_List (
5915 Unchecked_Convert_To (RTE (RE_Address),
5916 New_Occurrence_Of (RACW_Parameter, Loc)),
5917 Make_String_Literal (Loc,
5918 Strval => Full_Qualified_Name
5919 (Etype (Designated_Type (RACW_Type)))),
5920 Build_Stub_Tag (Loc, RACW_Type),
5921 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5922 Make_Attribute_Reference (Loc,
5925 (Defining_Identifier
5926 (Stub_Elements.RPC_Receiver_Decl), Loc),
5927 Attribute_Name => Name_Access)))),
5929 Make_Object_Declaration (Loc,
5930 Defining_Identifier => Any,
5931 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)));
5935 -- Any := TA_ObjRef (Reference);
5936 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5939 Statements := New_List (
5940 Make_Assignment_Statement (Loc,
5941 Name => New_Occurrence_Of (Any, Loc),
5943 Make_Function_Call (Loc,
5944 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5945 Parameter_Associations => New_List (
5946 New_Occurrence_Of (Reference, Loc)))),
5948 Make_Procedure_Call_Statement (Loc,
5949 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5950 Parameter_Associations => New_List (
5951 New_Occurrence_Of (Any, Loc),
5952 Make_Selected_Component (Loc,
5954 Defining_Identifier (
5955 Stub_Elements.RPC_Receiver_Decl),
5956 Selector_Name => Name_Obj_TypeCode))),
5958 Make_Simple_Return_Statement (Loc,
5959 Expression => New_Occurrence_Of (Any, Loc)));
5962 Make_Subprogram_Body (Loc,
5963 Specification => Copy_Specification (Loc, Func_Spec),
5964 Declarations => Decls,
5965 Handled_Statement_Sequence =>
5966 Make_Handled_Sequence_Of_Statements (Loc,
5967 Statements => Statements));
5968 Append_To (Body_Decls, Func_Body);
5969 end Add_RACW_To_Any;
5971 -----------------------
5972 -- Add_RACW_TypeCode --
5973 -----------------------
5975 procedure Add_RACW_TypeCode
5976 (Designated_Type : Entity_Id;
5977 RACW_Type : Entity_Id;
5978 Body_Decls : List_Id)
5980 Loc : constant Source_Ptr := Sloc (RACW_Type);
5982 Fnam : constant Entity_Id :=
5983 Make_Defining_Identifier (Loc,
5984 Chars => New_External_Name (Chars (RACW_Type), 'Y'));
5986 Stub_Elements : constant Stub_Structure :=
5987 Stubs_Table.Get (Designated_Type);
5988 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5990 Func_Spec : Node_Id;
5991 Func_Decl : Node_Id;
5992 Func_Body : Node_Id;
5996 -- The spec for this subprogram has a dummy 'access RACW' argument,
5997 -- which serves only for overloading purposes.
6000 Make_Function_Specification (Loc,
6001 Defining_Unit_Name => Fnam,
6002 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6004 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6005 -- entity in the declaration spec, not those of the body spec.
6007 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6008 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6009 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6011 if No (Body_Decls) then
6016 Make_Subprogram_Body (Loc,
6017 Specification => Copy_Specification (Loc, Func_Spec),
6018 Declarations => Empty_List,
6019 Handled_Statement_Sequence =>
6020 Make_Handled_Sequence_Of_Statements (Loc,
6021 Statements => New_List (
6022 Make_Simple_Return_Statement (Loc,
6024 Make_Selected_Component (Loc,
6027 (Stub_Elements.RPC_Receiver_Decl),
6028 Selector_Name => Name_Obj_TypeCode)))));
6030 Append_To (Body_Decls, Func_Body);
6031 end Add_RACW_TypeCode;
6033 ------------------------------
6034 -- Add_RACW_Write_Attribute --
6035 ------------------------------
6037 procedure Add_RACW_Write_Attribute
6038 (RACW_Type : Entity_Id;
6039 Stub_Type : Entity_Id;
6040 Stub_Type_Access : Entity_Id;
6041 Body_Decls : List_Id)
6043 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6045 Loc : constant Source_Ptr := Sloc (RACW_Type);
6047 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
6049 Stub_Elements : constant Stub_Structure :=
6050 Get_Stub_Elements (RACW_Type);
6052 Body_Node : Node_Id;
6053 Proc_Decl : Node_Id;
6054 Attr_Decl : Node_Id;
6056 Statements : constant List_Id := New_List;
6057 Pnam : constant Entity_Id :=
6058 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
6060 function Stream_Parameter return Node_Id;
6061 function Object return Node_Id;
6062 -- Functions to create occurrences of the formal parameter names
6068 function Object return Node_Id is
6070 return Make_Identifier (Loc, Name_V);
6073 ----------------------
6074 -- Stream_Parameter --
6075 ----------------------
6077 function Stream_Parameter return Node_Id is
6079 return Make_Identifier (Loc, Name_S);
6080 end Stream_Parameter;
6082 -- Start of processing for Add_RACW_Write_Attribute
6085 Build_Stream_Procedure
6086 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
6089 Make_Subprogram_Declaration (Loc,
6090 Copy_Specification (Loc, Specification (Body_Node)));
6093 Make_Attribute_Definition_Clause (Loc,
6094 Name => New_Occurrence_Of (RACW_Type, Loc),
6095 Chars => Name_Write,
6098 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6100 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6101 Insert_After (Proc_Decl, Attr_Decl);
6103 if No (Body_Decls) then
6107 Append_To (Statements,
6108 Pack_Node_Into_Stream_Access (Loc,
6109 Stream => Stream_Parameter,
6111 Make_Function_Call (Loc,
6112 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6113 Parameter_Associations => New_List (
6114 Unchecked_Convert_To (RTE (RE_Address), Object),
6115 Make_String_Literal (Loc,
6116 Strval => Full_Qualified_Name
6117 (Etype (Designated_Type (RACW_Type)))),
6118 Build_Stub_Tag (Loc, RACW_Type),
6119 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
6120 Make_Attribute_Reference (Loc,
6123 (Defining_Identifier
6124 (Stub_Elements.RPC_Receiver_Decl), Loc),
6125 Attribute_Name => Name_Access))),
6127 Etyp => RTE (RE_Object_Ref)));
6129 Append_To (Body_Decls, Body_Node);
6130 end Add_RACW_Write_Attribute;
6132 -----------------------
6133 -- Add_RAST_Features --
6134 -----------------------
6136 procedure Add_RAST_Features
6137 (Vis_Decl : Node_Id;
6138 RAS_Type : Entity_Id)
6141 Add_RAS_Access_TSS (Vis_Decl);
6143 Add_RAS_From_Any (RAS_Type);
6144 Add_RAS_TypeCode (RAS_Type);
6146 -- To_Any uses TypeCode, and therefore needs to be generated last
6148 Add_RAS_To_Any (RAS_Type);
6149 end Add_RAST_Features;
6151 ------------------------
6152 -- Add_RAS_Access_TSS --
6153 ------------------------
6155 procedure Add_RAS_Access_TSS (N : Node_Id) is
6156 Loc : constant Source_Ptr := Sloc (N);
6158 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6159 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6160 -- Ras_Type is the access to subprogram type; Fat_Type is the
6161 -- corresponding record type.
6163 RACW_Type : constant Entity_Id :=
6164 Underlying_RACW_Type (Ras_Type);
6166 Stub_Elements : constant Stub_Structure :=
6167 Get_Stub_Elements (RACW_Type);
6169 Proc : constant Entity_Id :=
6170 Make_Defining_Identifier (Loc,
6171 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6173 Proc_Spec : Node_Id;
6175 -- Formal parameters
6177 Package_Name : constant Entity_Id :=
6178 Make_Defining_Identifier (Loc,
6183 Subp_Id : constant Entity_Id :=
6184 Make_Defining_Identifier (Loc,
6187 -- Target subprogram
6189 Asynch_P : constant Entity_Id :=
6190 Make_Defining_Identifier (Loc,
6191 Chars => Name_Asynchronous);
6192 -- Is the procedure to which the 'Access applies asynchronous?
6194 All_Calls_Remote : constant Entity_Id :=
6195 Make_Defining_Identifier (Loc,
6196 Chars => Name_All_Calls_Remote);
6197 -- True if an All_Calls_Remote pragma applies to the RCI unit
6198 -- that contains the subprogram.
6200 -- Common local variables
6202 Proc_Decls : List_Id;
6203 Proc_Statements : List_Id;
6205 Subp_Ref : constant Entity_Id :=
6206 Make_Defining_Identifier (Loc, Name_R);
6207 -- Reference that designates the target subprogram (returned
6208 -- by Get_RAS_Info).
6210 Is_Local : constant Entity_Id :=
6211 Make_Defining_Identifier (Loc, Name_L);
6212 Local_Addr : constant Entity_Id :=
6213 Make_Defining_Identifier (Loc, Name_A);
6214 -- For the call to Get_Local_Address
6216 -- Additional local variables for the remote case
6218 Local_Stub : constant Entity_Id :=
6219 Make_Defining_Identifier (Loc,
6220 Chars => New_Internal_Name ('L'));
6222 Stub_Ptr : constant Entity_Id :=
6223 Make_Defining_Identifier (Loc,
6224 Chars => New_Internal_Name ('S'));
6227 (Field_Name : Name_Id;
6228 Value : Node_Id) return Node_Id;
6229 -- Construct an assignment that sets the named component in the
6237 (Field_Name : Name_Id;
6238 Value : Node_Id) return Node_Id
6242 Make_Assignment_Statement (Loc,
6244 Make_Selected_Component (Loc,
6246 Selector_Name => Field_Name),
6247 Expression => Value);
6250 -- Start of processing for Add_RAS_Access_TSS
6253 Proc_Decls := New_List (
6255 -- Common declarations
6257 Make_Object_Declaration (Loc,
6258 Defining_Identifier => Subp_Ref,
6259 Object_Definition =>
6260 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6262 Make_Object_Declaration (Loc,
6263 Defining_Identifier => Is_Local,
6264 Object_Definition =>
6265 New_Occurrence_Of (Standard_Boolean, Loc)),
6267 Make_Object_Declaration (Loc,
6268 Defining_Identifier => Local_Addr,
6269 Object_Definition =>
6270 New_Occurrence_Of (RTE (RE_Address), Loc)),
6272 Make_Object_Declaration (Loc,
6273 Defining_Identifier => Local_Stub,
6274 Aliased_Present => True,
6275 Object_Definition =>
6276 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6278 Make_Object_Declaration (Loc,
6279 Defining_Identifier => Stub_Ptr,
6280 Object_Definition =>
6281 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6283 Make_Attribute_Reference (Loc,
6284 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6285 Attribute_Name => Name_Unchecked_Access)));
6287 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6288 -- Build_Get_Unique_RP_Call needs this information
6290 -- Get_RAS_Info (Pkg, Subp, R);
6291 -- Obtain a reference to the target subprogram
6293 Proc_Statements := New_List (
6294 Make_Procedure_Call_Statement (Loc,
6295 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6296 Parameter_Associations => New_List (
6297 New_Occurrence_Of (Package_Name, Loc),
6298 New_Occurrence_Of (Subp_Id, Loc),
6299 New_Occurrence_Of (Subp_Ref, Loc))),
6301 -- Get_Local_Address (R, L, A);
6302 -- Determine whether the subprogram is local (L), and if so
6303 -- obtain the local address of its proxy (A).
6305 Make_Procedure_Call_Statement (Loc,
6306 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6307 Parameter_Associations => New_List (
6308 New_Occurrence_Of (Subp_Ref, Loc),
6309 New_Occurrence_Of (Is_Local, Loc),
6310 New_Occurrence_Of (Local_Addr, Loc))));
6312 -- Note: Here we assume that the Fat_Type is a record containing just
6313 -- an access to a proxy or stub object.
6315 Append_To (Proc_Statements,
6319 Make_Implicit_If_Statement (N,
6320 Condition => New_Occurrence_Of (Is_Local, Loc),
6322 Then_Statements => New_List (
6324 -- if A.Target = null then
6326 Make_Implicit_If_Statement (N,
6329 Make_Selected_Component (Loc,
6331 Unchecked_Convert_To
6332 (RTE (RE_RAS_Proxy_Type_Access),
6333 New_Occurrence_Of (Local_Addr, Loc)),
6334 Selector_Name => Make_Identifier (Loc, Name_Target)),
6337 Then_Statements => New_List (
6339 -- A.Target := Entity_Of (Ref);
6341 Make_Assignment_Statement (Loc,
6343 Make_Selected_Component (Loc,
6345 Unchecked_Convert_To
6346 (RTE (RE_RAS_Proxy_Type_Access),
6347 New_Occurrence_Of (Local_Addr, Loc)),
6348 Selector_Name => Make_Identifier (Loc, Name_Target)),
6350 Make_Function_Call (Loc,
6351 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6352 Parameter_Associations => New_List (
6353 New_Occurrence_Of (Subp_Ref, Loc)))),
6355 -- Inc_Usage (A.Target);
6357 Make_Procedure_Call_Statement (Loc,
6358 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6359 Parameter_Associations => New_List (
6360 Make_Selected_Component (Loc,
6362 Unchecked_Convert_To
6363 (RTE (RE_RAS_Proxy_Type_Access),
6364 New_Occurrence_Of (Local_Addr, Loc)),
6366 Make_Identifier (Loc, Name_Target)))))),
6369 -- if not All_Calls_Remote then
6370 -- return Fat_Type!(A);
6373 Make_Implicit_If_Statement (N,
6377 New_Occurrence_Of (All_Calls_Remote, Loc)),
6379 Then_Statements => New_List (
6380 Make_Simple_Return_Statement (Loc,
6382 Unchecked_Convert_To
6383 (Fat_Type, New_Occurrence_Of (Local_Addr, Loc))))))));
6385 Append_List_To (Proc_Statements, New_List (
6387 -- Stub.Target := Entity_Of (Ref);
6389 Set_Field (Name_Target,
6390 Make_Function_Call (Loc,
6391 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6392 Parameter_Associations => New_List (
6393 New_Occurrence_Of (Subp_Ref, Loc)))),
6395 -- Inc_Usage (Stub.Target);
6397 Make_Procedure_Call_Statement (Loc,
6398 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6399 Parameter_Associations => New_List (
6400 Make_Selected_Component (Loc,
6402 Selector_Name => Name_Target))),
6404 -- E.4.1(9) A remote call is asynchronous if it is a call to
6405 -- a procedure, or a call through a value of an access-to-procedure
6406 -- type, to which a pragma Asynchronous applies.
6408 -- Parameter Asynch_P is true when the procedure is asynchronous;
6409 -- Expression Asynch_T is true when the type is asynchronous.
6411 Set_Field (Name_Asynchronous,
6413 Left_Opnd => New_Occurrence_Of (Asynch_P, Loc),
6416 (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc)))));
6418 Append_List_To (Proc_Statements,
6419 Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
6421 Append_To (Proc_Statements,
6422 Make_Simple_Return_Statement (Loc,
6424 Unchecked_Convert_To (Fat_Type,
6425 New_Occurrence_Of (Stub_Ptr, Loc))));
6428 Make_Function_Specification (Loc,
6429 Defining_Unit_Name => Proc,
6430 Parameter_Specifications => New_List (
6431 Make_Parameter_Specification (Loc,
6432 Defining_Identifier => Package_Name,
6434 New_Occurrence_Of (Standard_String, Loc)),
6436 Make_Parameter_Specification (Loc,
6437 Defining_Identifier => Subp_Id,
6439 New_Occurrence_Of (Standard_String, Loc)),
6441 Make_Parameter_Specification (Loc,
6442 Defining_Identifier => Asynch_P,
6444 New_Occurrence_Of (Standard_Boolean, Loc)),
6446 Make_Parameter_Specification (Loc,
6447 Defining_Identifier => All_Calls_Remote,
6449 New_Occurrence_Of (Standard_Boolean, Loc))),
6451 Result_Definition =>
6452 New_Occurrence_Of (Fat_Type, Loc));
6454 -- Set the kind and return type of the function to prevent
6455 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6457 Set_Ekind (Proc, E_Function);
6458 Set_Etype (Proc, Fat_Type);
6461 Make_Subprogram_Body (Loc,
6462 Specification => Proc_Spec,
6463 Declarations => Proc_Decls,
6464 Handled_Statement_Sequence =>
6465 Make_Handled_Sequence_Of_Statements (Loc,
6466 Statements => Proc_Statements)));
6468 Set_TSS (Fat_Type, Proc);
6469 end Add_RAS_Access_TSS;
6471 ----------------------
6472 -- Add_RAS_From_Any --
6473 ----------------------
6475 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6476 Loc : constant Source_Ptr := Sloc (RAS_Type);
6478 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6479 Make_TSS_Name (RAS_Type, TSS_From_Any));
6481 Func_Spec : Node_Id;
6483 Statements : List_Id;
6485 Any_Parameter : constant Entity_Id :=
6486 Make_Defining_Identifier (Loc, Name_A);
6489 Statements := New_List (
6490 Make_Simple_Return_Statement (Loc,
6492 Make_Aggregate (Loc,
6493 Component_Associations => New_List (
6494 Make_Component_Association (Loc,
6495 Choices => New_List (
6496 Make_Identifier (Loc, Name_Ras)),
6498 PolyORB_Support.Helpers.Build_From_Any_Call (
6499 Underlying_RACW_Type (RAS_Type),
6500 New_Occurrence_Of (Any_Parameter, Loc),
6504 Make_Function_Specification (Loc,
6505 Defining_Unit_Name => Fnam,
6506 Parameter_Specifications => New_List (
6507 Make_Parameter_Specification (Loc,
6508 Defining_Identifier => Any_Parameter,
6509 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
6510 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6513 Make_Subprogram_Body (Loc,
6514 Specification => Func_Spec,
6515 Declarations => No_List,
6516 Handled_Statement_Sequence =>
6517 Make_Handled_Sequence_Of_Statements (Loc,
6518 Statements => Statements)));
6519 Set_TSS (RAS_Type, Fnam);
6520 end Add_RAS_From_Any;
6522 --------------------
6523 -- Add_RAS_To_Any --
6524 --------------------
6526 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6527 Loc : constant Source_Ptr := Sloc (RAS_Type);
6529 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6530 Make_TSS_Name (RAS_Type, TSS_To_Any));
6533 Statements : List_Id;
6535 Func_Spec : Node_Id;
6537 Any : constant Entity_Id :=
6538 Make_Defining_Identifier (Loc,
6539 Chars => New_Internal_Name ('A'));
6540 RAS_Parameter : constant Entity_Id :=
6541 Make_Defining_Identifier (Loc,
6542 Chars => New_Internal_Name ('R'));
6543 RACW_Parameter : constant Node_Id :=
6544 Make_Selected_Component (Loc,
6545 Prefix => RAS_Parameter,
6546 Selector_Name => Name_Ras);
6549 -- Object declarations
6551 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6553 Make_Object_Declaration (Loc,
6554 Defining_Identifier => Any,
6555 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc),
6557 PolyORB_Support.Helpers.Build_To_Any_Call
6558 (RACW_Parameter, No_List)));
6560 Statements := New_List (
6561 Make_Procedure_Call_Statement (Loc,
6562 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6563 Parameter_Associations => New_List (
6564 New_Occurrence_Of (Any, Loc),
6565 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6568 Make_Simple_Return_Statement (Loc,
6569 Expression => New_Occurrence_Of (Any, Loc)));
6572 Make_Function_Specification (Loc,
6573 Defining_Unit_Name => Fnam,
6574 Parameter_Specifications => New_List (
6575 Make_Parameter_Specification (Loc,
6576 Defining_Identifier => RAS_Parameter,
6577 Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))),
6578 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6581 Make_Subprogram_Body (Loc,
6582 Specification => Func_Spec,
6583 Declarations => Decls,
6584 Handled_Statement_Sequence =>
6585 Make_Handled_Sequence_Of_Statements (Loc,
6586 Statements => Statements)));
6587 Set_TSS (RAS_Type, Fnam);
6590 ----------------------
6591 -- Add_RAS_TypeCode --
6592 ----------------------
6594 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6595 Loc : constant Source_Ptr := Sloc (RAS_Type);
6597 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6598 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6600 Func_Spec : Node_Id;
6601 Decls : constant List_Id := New_List;
6602 Name_String : String_Id;
6603 Repo_Id_String : String_Id;
6607 Make_Function_Specification (Loc,
6608 Defining_Unit_Name => Fnam,
6609 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6611 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6612 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6615 Make_Subprogram_Body (Loc,
6616 Specification => Func_Spec,
6617 Declarations => Decls,
6618 Handled_Statement_Sequence =>
6619 Make_Handled_Sequence_Of_Statements (Loc,
6620 Statements => New_List (
6621 Make_Simple_Return_Statement (Loc,
6623 Make_Function_Call (Loc,
6624 Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6625 Parameter_Associations => New_List (
6626 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6627 Make_Aggregate (Loc,
6630 Make_Function_Call (Loc,
6633 (RTE (RE_TA_Std_String), Loc),
6634 Parameter_Associations => New_List (
6635 Make_String_Literal (Loc, Name_String))),
6636 Make_Function_Call (Loc,
6639 (RTE (RE_TA_Std_String), Loc),
6640 Parameter_Associations => New_List (
6641 Make_String_Literal (Loc,
6642 Strval => Repo_Id_String))))))))))));
6643 Set_TSS (RAS_Type, Fnam);
6644 end Add_RAS_TypeCode;
6646 -----------------------------------------
6647 -- Add_Receiving_Stubs_To_Declarations --
6648 -----------------------------------------
6650 procedure Add_Receiving_Stubs_To_Declarations
6651 (Pkg_Spec : Node_Id;
6655 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6657 Pkg_RPC_Receiver : constant Entity_Id :=
6658 Make_Defining_Identifier (Loc,
6659 New_Internal_Name ('H'));
6660 Pkg_RPC_Receiver_Object : Node_Id;
6661 Pkg_RPC_Receiver_Body : Node_Id;
6662 Pkg_RPC_Receiver_Decls : List_Id;
6663 Pkg_RPC_Receiver_Statements : List_Id;
6665 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6666 -- A Pkg_RPC_Receiver is built to decode the request
6669 -- Request object received from neutral layer
6671 Subp_Id : Entity_Id;
6672 -- Subprogram identifier as received from the neutral
6673 -- distribution core.
6675 Subp_Index : Entity_Id;
6676 -- Internal index as determined by matching either the method name
6677 -- from the request structure, or the local subprogram address (in
6680 Is_Local : constant Entity_Id :=
6681 Make_Defining_Identifier (Loc,
6682 Chars => New_Internal_Name ('L'));
6684 Local_Address : constant Entity_Id :=
6685 Make_Defining_Identifier (Loc,
6686 Chars => New_Internal_Name ('A'));
6687 -- Address of a local subprogram designated by a reference
6688 -- corresponding to a RAS.
6690 Dispatch_On_Address : constant List_Id := New_List;
6691 Dispatch_On_Name : constant List_Id := New_List;
6693 Current_Declaration : Node_Id;
6694 Current_Stubs : Node_Id;
6695 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6697 Subp_Info_Array : constant Entity_Id :=
6698 Make_Defining_Identifier (Loc,
6699 Chars => New_Internal_Name ('I'));
6701 Subp_Info_List : constant List_Id := New_List;
6703 Register_Pkg_Actuals : constant List_Id := New_List;
6705 All_Calls_Remote_E : Entity_Id;
6707 procedure Append_Stubs_To
6708 (RPC_Receiver_Cases : List_Id;
6709 Declaration : Node_Id;
6712 Subp_Dist_Name : Entity_Id;
6713 Subp_Proxy_Addr : Entity_Id);
6714 -- Add one case to the specified RPC receiver case list associating
6715 -- Subprogram_Number with the subprogram declared by Declaration, for
6716 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6717 -- subprogram index. Subp_Dist_Name is the string used to call the
6718 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6719 -- object, used in the context of calls through remote
6720 -- access-to-subprogram types.
6722 ---------------------
6723 -- Append_Stubs_To --
6724 ---------------------
6726 procedure Append_Stubs_To
6727 (RPC_Receiver_Cases : List_Id;
6728 Declaration : Node_Id;
6731 Subp_Dist_Name : Entity_Id;
6732 Subp_Proxy_Addr : Entity_Id)
6734 Case_Stmts : List_Id;
6736 Case_Stmts := New_List (
6737 Make_Procedure_Call_Statement (Loc,
6740 Defining_Entity (Stubs), Loc),
6741 Parameter_Associations =>
6742 New_List (New_Occurrence_Of (Request, Loc))));
6744 if Nkind (Specification (Declaration)) = N_Function_Specification
6746 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6748 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6751 Append_To (RPC_Receiver_Cases,
6752 Make_Case_Statement_Alternative (Loc,
6754 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6755 Statements => Case_Stmts));
6757 Append_To (Dispatch_On_Name,
6758 Make_Elsif_Part (Loc,
6760 Make_Function_Call (Loc,
6762 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6763 Parameter_Associations => New_List (
6764 New_Occurrence_Of (Subp_Id, Loc),
6765 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6767 Then_Statements => New_List (
6768 Make_Assignment_Statement (Loc,
6769 New_Occurrence_Of (Subp_Index, Loc),
6770 Make_Integer_Literal (Loc, Subp_Number)))));
6772 Append_To (Dispatch_On_Address,
6773 Make_Elsif_Part (Loc,
6776 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6777 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6779 Then_Statements => New_List (
6780 Make_Assignment_Statement (Loc,
6781 New_Occurrence_Of (Subp_Index, Loc),
6782 Make_Integer_Literal (Loc, Subp_Number)))));
6783 end Append_Stubs_To;
6785 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6788 -- Building receiving stubs consist in several operations:
6790 -- - a package RPC receiver must be built. This subprogram
6791 -- will get a Subprogram_Id from the incoming stream
6792 -- and will dispatch the call to the right subprogram;
6794 -- - a receiving stub for each subprogram visible in the package
6795 -- spec. This stub will read all the parameters from the stream,
6796 -- and put the result as well as the exception occurrence in the
6799 -- - a dummy package with an empty spec and a body made of an
6800 -- elaboration part, whose job is to register the receiving
6801 -- part of this RCI package on the name server. This is done
6802 -- by calling System.Partition_Interface.Register_Receiving_Stub.
6804 Build_RPC_Receiver_Body (
6805 RPC_Receiver => Pkg_RPC_Receiver,
6808 Subp_Index => Subp_Index,
6809 Stmts => Pkg_RPC_Receiver_Statements,
6810 Decl => Pkg_RPC_Receiver_Body);
6811 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6813 -- Extract local address information from the target reference:
6814 -- if non-null, that means that this is a reference that denotes
6815 -- one particular operation, and hence that the operation name
6816 -- must not be taken into account for dispatching.
6818 Append_To (Pkg_RPC_Receiver_Decls,
6819 Make_Object_Declaration (Loc,
6820 Defining_Identifier => Is_Local,
6821 Object_Definition =>
6822 New_Occurrence_Of (Standard_Boolean, Loc)));
6824 Append_To (Pkg_RPC_Receiver_Decls,
6825 Make_Object_Declaration (Loc,
6826 Defining_Identifier => Local_Address,
6827 Object_Definition =>
6828 New_Occurrence_Of (RTE (RE_Address), Loc)));
6830 Append_To (Pkg_RPC_Receiver_Statements,
6831 Make_Procedure_Call_Statement (Loc,
6832 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6833 Parameter_Associations => New_List (
6834 Make_Selected_Component (Loc,
6836 Selector_Name => Name_Target),
6837 New_Occurrence_Of (Is_Local, Loc),
6838 New_Occurrence_Of (Local_Address, Loc))));
6840 -- For each subprogram, the receiving stub will be built and a
6841 -- case statement will be made on the Subprogram_Id to dispatch
6842 -- to the right subprogram.
6844 All_Calls_Remote_E := Boolean_Literals (
6845 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6847 Overload_Counter_Table.Reset;
6848 Reserve_NamingContext_Methods;
6850 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
6851 while Present (Current_Declaration) loop
6852 if Nkind (Current_Declaration) = N_Subprogram_Declaration
6853 and then Comes_From_Source (Current_Declaration)
6856 Loc : constant Source_Ptr := Sloc (Current_Declaration);
6857 -- While specifically processing Current_Declaration, use
6858 -- its Sloc as the location of all generated nodes.
6860 Subp_Def : constant Entity_Id :=
6862 (Specification (Current_Declaration));
6864 Subp_Val : String_Id;
6866 Subp_Dist_Name : constant Entity_Id :=
6867 Make_Defining_Identifier (Loc,
6870 (Related_Id => Chars (Subp_Def),
6872 Suffix_Index => -1));
6874 Proxy_Object_Addr : Entity_Id;
6877 -- Build receiving stub
6880 Build_Subprogram_Receiving_Stubs
6881 (Vis_Decl => Current_Declaration,
6883 Nkind (Specification (Current_Declaration)) =
6884 N_Procedure_Specification
6885 and then Is_Asynchronous (Subp_Def));
6887 Append_To (Decls, Current_Stubs);
6888 Analyze (Current_Stubs);
6892 Add_RAS_Proxy_And_Analyze (Decls,
6893 Vis_Decl => Current_Declaration,
6894 All_Calls_Remote_E => All_Calls_Remote_E,
6895 Proxy_Object_Addr => Proxy_Object_Addr);
6897 -- Compute distribution identifier
6899 Assign_Subprogram_Identifier
6901 Current_Subprogram_Number,
6905 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
6908 Make_Object_Declaration (Loc,
6909 Defining_Identifier => Subp_Dist_Name,
6910 Constant_Present => True,
6911 Object_Definition =>
6912 New_Occurrence_Of (Standard_String, Loc),
6914 Make_String_Literal (Loc, Subp_Val)));
6915 Analyze (Last (Decls));
6917 -- Add subprogram descriptor (RCI_Subp_Info) to the
6918 -- subprograms table for this receiver. The aggregate
6919 -- below must be kept consistent with the declaration
6920 -- of type RCI_Subp_Info in System.Partition_Interface.
6922 Append_To (Subp_Info_List,
6923 Make_Component_Association (Loc,
6924 Choices => New_List (
6925 Make_Integer_Literal (Loc, Current_Subprogram_Number)),
6928 Make_Aggregate (Loc,
6929 Expressions => New_List (
6930 Make_Attribute_Reference (Loc,
6932 New_Occurrence_Of (Subp_Dist_Name, Loc),
6933 Attribute_Name => Name_Address),
6935 Make_Attribute_Reference (Loc,
6937 New_Occurrence_Of (Subp_Dist_Name, Loc),
6938 Attribute_Name => Name_Length),
6940 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
6942 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6943 Declaration => Current_Declaration,
6944 Stubs => Current_Stubs,
6945 Subp_Number => Current_Subprogram_Number,
6946 Subp_Dist_Name => Subp_Dist_Name,
6947 Subp_Proxy_Addr => Proxy_Object_Addr);
6950 Current_Subprogram_Number := Current_Subprogram_Number + 1;
6953 Next (Current_Declaration);
6957 Make_Object_Declaration (Loc,
6958 Defining_Identifier => Subp_Info_Array,
6959 Constant_Present => True,
6960 Aliased_Present => True,
6961 Object_Definition =>
6962 Make_Subtype_Indication (Loc,
6964 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6966 Make_Index_Or_Discriminant_Constraint (Loc,
6970 Make_Integer_Literal (Loc,
6971 Intval => First_RCI_Subprogram_Id),
6973 Make_Integer_Literal (Loc,
6975 First_RCI_Subprogram_Id
6976 + List_Length (Subp_Info_List) - 1)))))));
6978 if Present (First (Subp_Info_List)) then
6979 Set_Expression (Last (Decls),
6980 Make_Aggregate (Loc,
6981 Component_Associations => Subp_Info_List));
6983 -- Generate the dispatch statement to determine the subprogram id
6984 -- of the called subprogram.
6986 -- We first test whether the reference that was used to make the
6987 -- call was the base RCI reference (in which case Local_Address is
6988 -- zero, and the method identifier from the request must be used
6989 -- to determine which subprogram is called) or a reference
6990 -- identifying one particular subprogram (in which case
6991 -- Local_Address is the address of that subprogram, and the
6992 -- method name from the request is ignored). The latter occurs
6993 -- for the case of a call through a remote access-to-subprogram.
6995 -- In each case, cascaded elsifs are used to determine the proper
6996 -- subprogram index. Using hash tables might be more efficient.
6998 Append_To (Pkg_RPC_Receiver_Statements,
6999 Make_Implicit_If_Statement (Pkg_Spec,
7002 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
7003 Right_Opnd => New_Occurrence_Of
7004 (RTE (RE_Null_Address), Loc)),
7006 Then_Statements => New_List (
7007 Make_Implicit_If_Statement (Pkg_Spec,
7008 Condition => New_Occurrence_Of (Standard_False, Loc),
7009 Then_Statements => New_List (
7010 Make_Null_Statement (Loc)),
7011 Elsif_Parts => Dispatch_On_Address)),
7013 Else_Statements => New_List (
7014 Make_Implicit_If_Statement (Pkg_Spec,
7015 Condition => New_Occurrence_Of (Standard_False, Loc),
7016 Then_Statements => New_List (Make_Null_Statement (Loc)),
7017 Elsif_Parts => Dispatch_On_Name))));
7020 -- For a degenerate RCI with no visible subprograms,
7021 -- Subp_Info_List has zero length, and the declaration is for an
7022 -- empty array, in which case no initialization aggregate must be
7023 -- generated. We do not generate a Dispatch_Statement either.
7025 -- No initialization provided: remove CONSTANT so that the
7026 -- declaration is not an incomplete deferred constant.
7028 Set_Constant_Present (Last (Decls), False);
7031 -- Analyze Subp_Info_Array declaration
7033 Analyze (Last (Decls));
7035 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7036 -- rather than raising an exception since we do not want someone
7037 -- to crash a remote partition by sending invalid subprogram ids.
7038 -- This is consistent with the other parts of the case statement
7039 -- since even in presence of incorrect parameters in the stream,
7040 -- every exception will be caught and (if the subprogram is not an
7041 -- APC) put into the result stream and sent away.
7043 Append_To (Pkg_RPC_Receiver_Cases,
7044 Make_Case_Statement_Alternative (Loc,
7045 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
7046 Statements => New_List (Make_Null_Statement (Loc))));
7048 Append_To (Pkg_RPC_Receiver_Statements,
7049 Make_Case_Statement (Loc,
7050 Expression => New_Occurrence_Of (Subp_Index, Loc),
7051 Alternatives => Pkg_RPC_Receiver_Cases));
7053 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7056 Append_To (Decls, Pkg_RPC_Receiver_Body);
7057 Analyze (Last (Decls));
7059 Pkg_RPC_Receiver_Object :=
7060 Make_Object_Declaration (Loc,
7061 Defining_Identifier =>
7062 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
7063 Aliased_Present => True,
7064 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
7065 Append_To (Decls, Pkg_RPC_Receiver_Object);
7066 Analyze (Last (Decls));
7068 Get_Library_Unit_Name_String (Pkg_Spec);
7072 Append_To (Register_Pkg_Actuals,
7073 Make_String_Literal (Loc,
7074 Strval => String_From_Name_Buffer));
7078 Append_To (Register_Pkg_Actuals,
7079 Make_Attribute_Reference (Loc,
7082 (Defining_Entity (Pkg_Spec), Loc),
7083 Attribute_Name => Name_Version));
7087 Append_To (Register_Pkg_Actuals,
7088 Make_Attribute_Reference (Loc,
7090 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7091 Attribute_Name => Name_Access));
7095 Append_To (Register_Pkg_Actuals,
7096 Make_Attribute_Reference (Loc,
7099 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc),
7100 Attribute_Name => Name_Access));
7104 Append_To (Register_Pkg_Actuals,
7105 Make_Attribute_Reference (Loc,
7106 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7107 Attribute_Name => Name_Address));
7111 Append_To (Register_Pkg_Actuals,
7112 Make_Attribute_Reference (Loc,
7113 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7114 Attribute_Name => Name_Length));
7116 -- Is_All_Calls_Remote
7118 Append_To (Register_Pkg_Actuals,
7119 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7124 Make_Procedure_Call_Statement (Loc,
7126 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7127 Parameter_Associations => Register_Pkg_Actuals));
7128 Analyze (Last (Stmts));
7129 end Add_Receiving_Stubs_To_Declarations;
7131 ---------------------------------
7132 -- Build_General_Calling_Stubs --
7133 ---------------------------------
7135 procedure Build_General_Calling_Stubs
7137 Statements : List_Id;
7138 Target_Object : Node_Id;
7139 Subprogram_Id : Node_Id;
7140 Asynchronous : Node_Id := Empty;
7141 Is_Known_Asynchronous : Boolean := False;
7142 Is_Known_Non_Asynchronous : Boolean := False;
7143 Is_Function : Boolean;
7145 Stub_Type : Entity_Id := Empty;
7146 RACW_Type : Entity_Id := Empty;
7149 Loc : constant Source_Ptr := Sloc (Nod);
7151 Request : constant Entity_Id :=
7152 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7153 -- The request object constructed by these stubs
7154 -- Could we use Name_R instead??? (see GLADE client stubs)
7156 function Make_Request_RTE_Call
7158 Actuals : List_Id := New_List) return Node_Id;
7159 -- Generate a procedure call statement calling RE with the given
7160 -- actuals. Request is appended to the list.
7162 ---------------------------
7163 -- Make_Request_RTE_Call --
7164 ---------------------------
7166 function Make_Request_RTE_Call
7168 Actuals : List_Id := New_List) return Node_Id
7171 Append_To (Actuals, New_Occurrence_Of (Request, Loc));
7172 return Make_Procedure_Call_Statement (Loc,
7174 New_Occurrence_Of (RTE (RE), Loc),
7175 Parameter_Associations => Actuals);
7176 end Make_Request_RTE_Call;
7178 Arguments : Node_Id;
7179 -- Name of the named values list used to transmit parameters
7180 -- to the remote package
7183 -- Name of the result named value (in non-APC cases) which get the
7184 -- result of the remote subprogram.
7186 Result_TC : Node_Id;
7187 -- Typecode expression for the result of the request (void
7188 -- typecode for procedures).
7190 Exception_Return_Parameter : Node_Id;
7191 -- Name of the parameter which will hold the exception sent by the
7192 -- remote subprogram.
7194 Current_Parameter : Node_Id;
7195 -- Current parameter being handled
7197 Ordered_Parameters_List : constant List_Id :=
7198 Build_Ordered_Parameters_List (Spec);
7200 Asynchronous_P : Node_Id;
7201 -- A Boolean expression indicating whether this call is asynchronous
7203 Asynchronous_Statements : List_Id := No_List;
7204 Non_Asynchronous_Statements : List_Id := No_List;
7205 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7207 Extra_Formal_Statements : constant List_Id := New_List;
7208 -- List of statements for extra formal parameters. It will appear
7209 -- after the regular statements for writing out parameters.
7211 After_Statements : constant List_Id := New_List;
7212 -- Statements to be executed after call returns (to assign IN OUT or
7213 -- OUT parameter values).
7216 -- The type of the formal parameter being processed
7218 Is_Controlling_Formal : Boolean;
7219 Is_First_Controlling_Formal : Boolean;
7220 First_Controlling_Formal_Seen : Boolean := False;
7221 -- Controlling formal parameters of distributed object primitives
7222 -- require special handling, and the first such parameter needs even
7223 -- more special handling.
7226 -- ??? document general form of stub subprograms for the PolyORB case
7229 Make_Object_Declaration (Loc,
7230 Defining_Identifier => Request,
7231 Aliased_Present => False,
7232 Object_Definition =>
7233 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
7236 Make_Defining_Identifier (Loc,
7237 Chars => New_Internal_Name ('R'));
7241 PolyORB_Support.Helpers.Build_TypeCode_Call
7242 (Loc, Etype (Result_Definition (Spec)), Decls);
7244 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7248 Make_Object_Declaration (Loc,
7249 Defining_Identifier => Result,
7250 Aliased_Present => False,
7251 Object_Definition =>
7252 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7254 Make_Aggregate (Loc,
7255 Component_Associations => New_List (
7256 Make_Component_Association (Loc,
7257 Choices => New_List (Make_Identifier (Loc, Name_Name)),
7259 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7260 Make_Component_Association (Loc,
7261 Choices => New_List (
7262 Make_Identifier (Loc, Name_Argument)),
7264 Make_Function_Call (Loc,
7265 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7266 Parameter_Associations => New_List (Result_TC))),
7267 Make_Component_Association (Loc,
7268 Choices => New_List (
7269 Make_Identifier (Loc, Name_Arg_Modes)),
7270 Expression => Make_Integer_Literal (Loc, 0))))));
7272 if not Is_Known_Asynchronous then
7273 Exception_Return_Parameter :=
7274 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7277 Make_Object_Declaration (Loc,
7278 Defining_Identifier => Exception_Return_Parameter,
7279 Object_Definition =>
7280 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7283 Exception_Return_Parameter := Empty;
7286 -- Initialize and fill in arguments list
7289 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7290 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7292 Current_Parameter := First (Ordered_Parameters_List);
7293 while Present (Current_Parameter) loop
7294 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7295 Is_Controlling_Formal := True;
7296 Is_First_Controlling_Formal :=
7297 not First_Controlling_Formal_Seen;
7298 First_Controlling_Formal_Seen := True;
7301 Is_Controlling_Formal := False;
7302 Is_First_Controlling_Formal := False;
7305 if Is_Controlling_Formal then
7307 -- For a controlling formal argument, we send its reference
7312 Etyp := Etype (Parameter_Type (Current_Parameter));
7315 -- The first controlling formal parameter is treated specially:
7316 -- it is used to set the target object of the call.
7318 if not Is_First_Controlling_Formal then
7320 Constrained : constant Boolean :=
7321 Is_Constrained (Etyp)
7322 or else Is_Elementary_Type (Etyp);
7324 Any : constant Entity_Id :=
7325 Make_Defining_Identifier (Loc,
7326 New_Internal_Name ('A'));
7328 Actual_Parameter : Node_Id :=
7330 Defining_Identifier (
7331 Current_Parameter), Loc);
7336 if Is_Controlling_Formal then
7338 -- For a controlling formal parameter (other than the
7339 -- first one), use the corresponding RACW. If the
7340 -- parameter is not an anonymous access parameter, that
7341 -- involves taking its 'Unrestricted_Access.
7343 if Nkind (Parameter_Type (Current_Parameter))
7344 = N_Access_Definition
7346 Actual_Parameter := OK_Convert_To
7347 (Etyp, Actual_Parameter);
7349 Actual_Parameter := OK_Convert_To (Etyp,
7350 Make_Attribute_Reference (Loc,
7351 Prefix => Actual_Parameter,
7352 Attribute_Name => Name_Unrestricted_Access));
7357 if In_Present (Current_Parameter)
7358 or else not Out_Present (Current_Parameter)
7359 or else not Constrained
7360 or else Is_Controlling_Formal
7362 -- The parameter has an input value, is constrained at
7363 -- runtime by an input value, or is a controlling formal
7364 -- parameter (always passed as a reference) other than
7367 Expr := PolyORB_Support.Helpers.Build_To_Any_Call
7368 (Actual_Parameter, Decls);
7371 Expr := Make_Function_Call (Loc,
7372 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7373 Parameter_Associations => New_List (
7374 PolyORB_Support.Helpers.Build_TypeCode_Call
7375 (Loc, Etyp, Decls)));
7379 Make_Object_Declaration (Loc,
7380 Defining_Identifier => Any,
7381 Aliased_Present => False,
7382 Object_Definition =>
7383 New_Occurrence_Of (RTE (RE_Any), Loc),
7384 Expression => Expr));
7386 Append_To (Statements,
7387 Add_Parameter_To_NVList (Loc,
7388 Parameter => Current_Parameter,
7389 NVList => Arguments,
7390 Constrained => Constrained,
7393 if Out_Present (Current_Parameter)
7394 and then not Is_Controlling_Formal
7396 Append_To (After_Statements,
7397 Make_Assignment_Statement (Loc,
7400 Defining_Identifier (Current_Parameter), Loc),
7402 PolyORB_Support.Helpers.Build_From_Any_Call
7403 (Etype (Parameter_Type (Current_Parameter)),
7404 New_Occurrence_Of (Any, Loc),
7411 -- If the current parameter has a dynamic constrained status, then
7412 -- this status is transmitted as well.
7413 -- This should be done for accessibility as well ???
7415 if Nkind (Parameter_Type (Current_Parameter)) /=
7417 and then Need_Extra_Constrained (Current_Parameter)
7419 -- In this block, we do not use the extra formal that has been
7420 -- created because it does not exist at the time of expansion
7421 -- when building calling stubs for remote access to subprogram
7422 -- types. We create an extra variable of this type and push it
7423 -- in the stream after the regular parameters.
7426 Extra_Any_Parameter : constant Entity_Id :=
7427 Make_Defining_Identifier
7428 (Loc, New_Internal_Name ('P'));
7430 Parameter_Exp : constant Node_Id :=
7431 Make_Attribute_Reference (Loc,
7432 Prefix => New_Occurrence_Of (
7433 Defining_Identifier (Current_Parameter), Loc),
7434 Attribute_Name => Name_Constrained);
7437 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7440 Make_Object_Declaration (Loc,
7441 Defining_Identifier => Extra_Any_Parameter,
7442 Aliased_Present => False,
7443 Object_Definition =>
7444 New_Occurrence_Of (RTE (RE_Any), Loc),
7446 PolyORB_Support.Helpers.Build_To_Any_Call
7447 (Parameter_Exp, Decls)));
7449 Append_To (Extra_Formal_Statements,
7450 Add_Parameter_To_NVList (Loc,
7451 Parameter => Extra_Any_Parameter,
7452 NVList => Arguments,
7453 Constrained => True,
7454 Any => Extra_Any_Parameter));
7458 Next (Current_Parameter);
7461 -- Append the formal statements list to the statements
7463 Append_List_To (Statements, Extra_Formal_Statements);
7465 Append_To (Statements,
7466 Make_Request_RTE_Call (RE_Request_Create, New_List (
7469 New_Occurrence_Of (Arguments, Loc),
7470 New_Occurrence_Of (Result, Loc),
7472 (RTE (RE_Nil_Exc_List), Loc))));
7475 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7477 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7480 (Boolean_Literals (Is_Known_Asynchronous), Loc);
7483 pragma Assert (Present (Asynchronous));
7484 Asynchronous_P := New_Copy_Tree (Asynchronous);
7486 -- The expression node Asynchronous will be used to build an 'if'
7487 -- statement at the end of Build_General_Calling_Stubs: we need to
7488 -- make a copy here.
7491 Append_To (Parameter_Associations (Last (Statements)),
7492 Make_Indexed_Component (Loc,
7495 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7496 Expressions => New_List (Asynchronous_P)));
7498 Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke));
7500 -- Asynchronous case
7502 if not Is_Known_Non_Asynchronous then
7503 Asynchronous_Statements :=
7504 New_List (Make_Request_RTE_Call (RE_Request_Destroy));
7507 -- Non-asynchronous case
7509 if not Is_Known_Asynchronous then
7510 -- Reraise an exception occurrence from the completed request.
7511 -- If the exception occurrence is empty, this is a no-op.
7513 Non_Asynchronous_Statements := New_List (
7514 Make_Procedure_Call_Statement (Loc,
7516 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7517 Parameter_Associations => New_List (
7518 New_Occurrence_Of (Request, Loc))));
7522 Append_To (Non_Asynchronous_Statements,
7523 Make_Request_RTE_Call (RE_Request_Destroy));
7525 -- If this is a function call, read the value and return it
7527 Append_To (Non_Asynchronous_Statements,
7528 Make_Tag_Check (Loc,
7529 Make_Simple_Return_Statement (Loc,
7530 PolyORB_Support.Helpers.Build_From_Any_Call
7531 (Etype (Result_Definition (Spec)),
7532 Make_Selected_Component (Loc,
7534 Selector_Name => Name_Argument),
7539 -- Case of a procedure: deal with IN OUT and OUT formals
7541 Append_List_To (Non_Asynchronous_Statements, After_Statements);
7543 Append_To (Non_Asynchronous_Statements,
7544 Make_Request_RTE_Call (RE_Request_Destroy));
7548 if Is_Known_Asynchronous then
7549 Append_List_To (Statements, Asynchronous_Statements);
7551 elsif Is_Known_Non_Asynchronous then
7552 Append_List_To (Statements, Non_Asynchronous_Statements);
7555 pragma Assert (Present (Asynchronous));
7556 Append_To (Statements,
7557 Make_Implicit_If_Statement (Nod,
7558 Condition => Asynchronous,
7559 Then_Statements => Asynchronous_Statements,
7560 Else_Statements => Non_Asynchronous_Statements));
7562 end Build_General_Calling_Stubs;
7564 -----------------------
7565 -- Build_Stub_Target --
7566 -----------------------
7568 function Build_Stub_Target
7571 RCI_Locator : Entity_Id;
7572 Controlling_Parameter : Entity_Id) return RPC_Target
7574 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7575 Target_Reference : constant Entity_Id :=
7576 Make_Defining_Identifier (Loc,
7577 New_Internal_Name ('T'));
7579 if Present (Controlling_Parameter) then
7581 Make_Object_Declaration (Loc,
7582 Defining_Identifier => Target_Reference,
7584 Object_Definition =>
7585 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7588 Make_Function_Call (Loc,
7590 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7591 Parameter_Associations => New_List (
7592 Make_Selected_Component (Loc,
7593 Prefix => Controlling_Parameter,
7594 Selector_Name => Name_Target)))));
7596 -- Note: Controlling_Parameter has the same components as
7597 -- System.Partition_Interface.RACW_Stub_Type.
7599 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7602 Target_Info.Object :=
7603 Make_Selected_Component (Loc,
7604 Prefix => Make_Identifier (Loc, Chars (RCI_Locator)),
7606 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7610 end Build_Stub_Target;
7612 ---------------------
7613 -- Build_Stub_Type --
7614 ---------------------
7616 procedure Build_Stub_Type
7617 (RACW_Type : Entity_Id;
7618 Stub_Type : Entity_Id;
7619 Stub_Type_Decl : out Node_Id;
7620 RPC_Receiver_Decl : out Node_Id)
7622 Loc : constant Source_Ptr := Sloc (Stub_Type);
7624 pragma Unreferenced (RACW_Type);
7628 Make_Full_Type_Declaration (Loc,
7629 Defining_Identifier => Stub_Type,
7631 Make_Record_Definition (Loc,
7632 Tagged_Present => True,
7633 Limited_Present => True,
7635 Make_Component_List (Loc,
7636 Component_Items => New_List (
7638 Make_Component_Declaration (Loc,
7639 Defining_Identifier =>
7640 Make_Defining_Identifier (Loc, Name_Target),
7641 Component_Definition =>
7642 Make_Component_Definition (Loc,
7643 Aliased_Present => False,
7644 Subtype_Indication =>
7645 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7647 Make_Component_Declaration (Loc,
7648 Defining_Identifier =>
7649 Make_Defining_Identifier (Loc, Name_Asynchronous),
7651 Component_Definition =>
7652 Make_Component_Definition (Loc,
7653 Aliased_Present => False,
7654 Subtype_Indication =>
7655 New_Occurrence_Of (Standard_Boolean, Loc)))))));
7657 RPC_Receiver_Decl :=
7658 Make_Object_Declaration (Loc,
7659 Defining_Identifier => Make_Defining_Identifier (Loc,
7660 New_Internal_Name ('R')),
7661 Aliased_Present => True,
7662 Object_Definition =>
7663 New_Occurrence_Of (RTE (RE_Servant), Loc));
7664 end Build_Stub_Type;
7666 -----------------------------
7667 -- Build_RPC_Receiver_Body --
7668 -----------------------------
7670 procedure Build_RPC_Receiver_Body
7671 (RPC_Receiver : Entity_Id;
7672 Request : out Entity_Id;
7673 Subp_Id : out Entity_Id;
7674 Subp_Index : out Entity_Id;
7675 Stmts : out List_Id;
7678 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7680 RPC_Receiver_Spec : Node_Id;
7681 RPC_Receiver_Decls : List_Id;
7684 Request := Make_Defining_Identifier (Loc, Name_R);
7686 RPC_Receiver_Spec :=
7687 Build_RPC_Receiver_Specification
7688 (RPC_Receiver => RPC_Receiver,
7689 Request_Parameter => Request);
7691 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7692 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7694 RPC_Receiver_Decls := New_List (
7695 Make_Object_Renaming_Declaration (Loc,
7696 Defining_Identifier => Subp_Id,
7697 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7699 Make_Explicit_Dereference (Loc,
7701 Make_Selected_Component (Loc,
7703 Selector_Name => Name_Operation))),
7705 Make_Object_Declaration (Loc,
7706 Defining_Identifier => Subp_Index,
7707 Object_Definition =>
7708 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7710 Make_Attribute_Reference (Loc,
7712 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7713 Attribute_Name => Name_Last)));
7718 Make_Subprogram_Body (Loc,
7719 Specification => RPC_Receiver_Spec,
7720 Declarations => RPC_Receiver_Decls,
7721 Handled_Statement_Sequence =>
7722 Make_Handled_Sequence_Of_Statements (Loc,
7723 Statements => Stmts));
7724 end Build_RPC_Receiver_Body;
7726 --------------------------------------
7727 -- Build_Subprogram_Receiving_Stubs --
7728 --------------------------------------
7730 function Build_Subprogram_Receiving_Stubs
7731 (Vis_Decl : Node_Id;
7732 Asynchronous : Boolean;
7733 Dynamically_Asynchronous : Boolean := False;
7734 Stub_Type : Entity_Id := Empty;
7735 RACW_Type : Entity_Id := Empty;
7736 Parent_Primitive : Entity_Id := Empty) return Node_Id
7738 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7740 Request_Parameter : constant Entity_Id :=
7741 Make_Defining_Identifier (Loc,
7742 New_Internal_Name ('R'));
7743 -- Formal parameter for receiving stubs: a descriptor for an incoming
7746 Outer_Decls : constant List_Id := New_List;
7747 -- At the outermost level, an NVList and Any's are declared for all
7748 -- parameters. The Dynamic_Async flag also needs to be declared there
7749 -- to be visible from the exception handling code.
7751 Outer_Statements : constant List_Id := New_List;
7752 -- Statements that occur prior to the declaration of the actual
7753 -- parameter variables.
7755 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7756 -- Statements concerning extra formal parameters, prior to the
7757 -- declaration of the actual parameter variables.
7759 Decls : constant List_Id := New_List;
7760 -- All the parameters will get declared before calling the real
7761 -- subprograms. Also the out parameters will be declared.
7762 -- At this level, parameters may be unconstrained.
7764 Statements : constant List_Id := New_List;
7766 After_Statements : constant List_Id := New_List;
7767 -- Statements to be executed after the subprogram call
7769 Inner_Decls : List_Id := No_List;
7770 -- In case of a function, the inner declarations are needed since
7771 -- the result may be unconstrained.
7773 Excep_Handlers : List_Id := No_List;
7775 Parameter_List : constant List_Id := New_List;
7776 -- List of parameters to be passed to the subprogram
7778 First_Controlling_Formal_Seen : Boolean := False;
7780 Current_Parameter : Node_Id;
7782 Ordered_Parameters_List : constant List_Id :=
7783 Build_Ordered_Parameters_List
7784 (Specification (Vis_Decl));
7786 Arguments : constant Entity_Id :=
7787 Make_Defining_Identifier (Loc,
7788 New_Internal_Name ('A'));
7789 -- Name of the named values list used to retrieve parameters
7791 Subp_Spec : Node_Id;
7792 -- Subprogram specification
7794 Called_Subprogram : Node_Id;
7795 -- The subprogram to call
7798 if Present (RACW_Type) then
7799 Called_Subprogram :=
7800 New_Occurrence_Of (Parent_Primitive, Loc);
7802 Called_Subprogram :=
7804 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7807 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7809 -- Loop through every parameter and get its value from the stream. If
7810 -- the parameter is unconstrained, then the parameter is read using
7811 -- 'Input at the point of declaration.
7813 Current_Parameter := First (Ordered_Parameters_List);
7814 while Present (Current_Parameter) loop
7817 Constrained : Boolean;
7818 Any : Entity_Id := Empty;
7819 Object : constant Entity_Id :=
7820 Make_Defining_Identifier (Loc,
7821 Chars => New_Internal_Name ('P'));
7822 Expr : Node_Id := Empty;
7824 Is_Controlling_Formal : constant Boolean :=
7825 Is_RACW_Controlling_Formal
7826 (Current_Parameter, Stub_Type);
7828 Is_First_Controlling_Formal : Boolean := False;
7830 Need_Extra_Constrained : Boolean;
7831 -- True when an extra constrained actual is required
7834 if Is_Controlling_Formal then
7836 -- Controlling formals in distributed object primitive
7837 -- operations are handled specially:
7838 -- - the first controlling formal is used as the
7839 -- target of the call;
7840 -- - the remaining controlling formals are transmitted
7844 Is_First_Controlling_Formal :=
7845 not First_Controlling_Formal_Seen;
7846 First_Controlling_Formal_Seen := True;
7849 Etyp := Etype (Parameter_Type (Current_Parameter));
7853 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
7855 if not Is_First_Controlling_Formal then
7857 Make_Defining_Identifier (Loc,
7858 Chars => New_Internal_Name ('A'));
7860 Append_To (Outer_Decls,
7861 Make_Object_Declaration (Loc,
7862 Defining_Identifier => Any,
7863 Object_Definition =>
7864 New_Occurrence_Of (RTE (RE_Any), Loc),
7866 Make_Function_Call (Loc,
7867 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7868 Parameter_Associations => New_List (
7869 PolyORB_Support.Helpers.Build_TypeCode_Call
7870 (Loc, Etyp, Outer_Decls)))));
7872 Append_To (Outer_Statements,
7873 Add_Parameter_To_NVList (Loc,
7874 Parameter => Current_Parameter,
7875 NVList => Arguments,
7876 Constrained => Constrained,
7880 if Is_First_Controlling_Formal then
7882 Addr : constant Entity_Id :=
7883 Make_Defining_Identifier (Loc,
7884 Chars => New_Internal_Name ('A'));
7886 Is_Local : constant Entity_Id :=
7887 Make_Defining_Identifier (Loc,
7888 Chars => New_Internal_Name ('L'));
7891 -- Special case: obtain the first controlling formal
7892 -- from the target of the remote call, instead of the
7895 Append_To (Outer_Decls,
7896 Make_Object_Declaration (Loc,
7897 Defining_Identifier => Addr,
7898 Object_Definition =>
7899 New_Occurrence_Of (RTE (RE_Address), Loc)));
7901 Append_To (Outer_Decls,
7902 Make_Object_Declaration (Loc,
7903 Defining_Identifier => Is_Local,
7904 Object_Definition =>
7905 New_Occurrence_Of (Standard_Boolean, Loc)));
7907 Append_To (Outer_Statements,
7908 Make_Procedure_Call_Statement (Loc,
7910 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7911 Parameter_Associations => New_List (
7912 Make_Selected_Component (Loc,
7915 Request_Parameter, Loc),
7917 Make_Identifier (Loc, Name_Target)),
7918 New_Occurrence_Of (Is_Local, Loc),
7919 New_Occurrence_Of (Addr, Loc))));
7921 Expr := Unchecked_Convert_To (RACW_Type,
7922 New_Occurrence_Of (Addr, Loc));
7925 elsif In_Present (Current_Parameter)
7926 or else not Out_Present (Current_Parameter)
7927 or else not Constrained
7929 -- If an input parameter is constrained, then its reading is
7930 -- deferred until the beginning of the subprogram body. If
7931 -- it is unconstrained, then an expression is built for
7932 -- the object declaration and the variable is set using
7933 -- 'Input instead of 'Read.
7935 Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
7936 Etyp, New_Occurrence_Of (Any, Loc), Decls);
7939 Append_To (Statements,
7940 Make_Assignment_Statement (Loc,
7941 Name => New_Occurrence_Of (Object, Loc),
7942 Expression => Expr));
7947 -- Expr will be used to initialize (and constrain) the
7948 -- parameter when it is declared.
7953 Need_Extra_Constrained :=
7954 Nkind (Parameter_Type (Current_Parameter)) /=
7957 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7959 Present (Extra_Constrained
7960 (Defining_Identifier (Current_Parameter)));
7962 -- We may not associate an extra constrained actual to a
7963 -- constant object, so if one is needed, declare the actual
7964 -- as a variable even if it won't be modified.
7966 Build_Actual_Object_Declaration
7969 Variable => Need_Extra_Constrained
7970 or else Out_Present (Current_Parameter),
7973 Set_Etype (Object, Etyp);
7975 -- An out parameter may be written back using a 'Write
7976 -- attribute instead of a 'Output because it has been
7977 -- constrained by the parameter given to the caller. Note that
7978 -- out controlling arguments in the case of a RACW are not put
7979 -- back in the stream because the pointer on them has not
7982 if Out_Present (Current_Parameter)
7983 and then not Is_Controlling_Formal
7985 Append_To (After_Statements,
7986 Make_Procedure_Call_Statement (Loc,
7987 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
7988 Parameter_Associations => New_List (
7989 New_Occurrence_Of (Any, Loc),
7990 PolyORB_Support.Helpers.Build_To_Any_Call
7991 (New_Occurrence_Of (Object, Loc), Decls))));
7994 -- For RACW controlling formals, the Etyp of Object is always
7995 -- an RACW, even if the parameter is not of an anonymous access
7996 -- type. In such case, we need to dereference it at call time.
7998 if Is_Controlling_Formal then
7999 if Nkind (Parameter_Type (Current_Parameter)) /=
8002 Append_To (Parameter_List,
8003 Make_Parameter_Association (Loc,
8006 (Defining_Identifier (Current_Parameter), Loc),
8007 Explicit_Actual_Parameter =>
8008 Make_Explicit_Dereference (Loc,
8010 Unchecked_Convert_To (RACW_Type,
8011 OK_Convert_To (RTE (RE_Address),
8012 New_Occurrence_Of (Object, Loc))))));
8015 Append_To (Parameter_List,
8016 Make_Parameter_Association (Loc,
8019 (Defining_Identifier (Current_Parameter), Loc),
8021 Explicit_Actual_Parameter =>
8022 Unchecked_Convert_To (RACW_Type,
8023 OK_Convert_To (RTE (RE_Address),
8024 New_Occurrence_Of (Object, Loc)))));
8028 Append_To (Parameter_List,
8029 Make_Parameter_Association (Loc,
8032 Defining_Identifier (Current_Parameter), Loc),
8033 Explicit_Actual_Parameter =>
8034 New_Occurrence_Of (Object, Loc)));
8037 -- If the current parameter needs an extra formal, then read it
8038 -- from the stream and set the corresponding semantic field in
8039 -- the variable. If the kind of the parameter identifier is
8040 -- E_Void, then this is a compiler generated parameter that
8041 -- doesn't need an extra constrained status.
8043 -- The case of Extra_Accessibility should also be handled ???
8045 if Need_Extra_Constrained then
8047 Extra_Parameter : constant Entity_Id :=
8049 (Defining_Identifier
8050 (Current_Parameter));
8052 Extra_Any : constant Entity_Id :=
8053 Make_Defining_Identifier (Loc,
8054 Chars => New_Internal_Name ('A'));
8056 Formal_Entity : constant Entity_Id :=
8057 Make_Defining_Identifier (Loc,
8058 Chars => Chars (Extra_Parameter));
8060 Formal_Type : constant Entity_Id :=
8061 Etype (Extra_Parameter);
8064 Append_To (Outer_Decls,
8065 Make_Object_Declaration (Loc,
8066 Defining_Identifier => Extra_Any,
8067 Object_Definition =>
8068 New_Occurrence_Of (RTE (RE_Any), Loc),
8070 Make_Function_Call (Loc,
8072 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8073 Parameter_Associations => New_List (
8074 PolyORB_Support.Helpers.Build_TypeCode_Call
8075 (Loc, Formal_Type, Outer_Decls)))));
8077 Append_To (Outer_Extra_Formal_Statements,
8078 Add_Parameter_To_NVList (Loc,
8079 Parameter => Extra_Parameter,
8080 NVList => Arguments,
8081 Constrained => True,
8085 Make_Object_Declaration (Loc,
8086 Defining_Identifier => Formal_Entity,
8087 Object_Definition =>
8088 New_Occurrence_Of (Formal_Type, Loc)));
8090 Append_To (Statements,
8091 Make_Assignment_Statement (Loc,
8092 Name => New_Occurrence_Of (Formal_Entity, Loc),
8094 PolyORB_Support.Helpers.Build_From_Any_Call
8096 New_Occurrence_Of (Extra_Any, Loc),
8098 Set_Extra_Constrained (Object, Formal_Entity);
8103 Next (Current_Parameter);
8106 -- Extra Formals should go after all the other parameters
8108 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8110 Append_To (Outer_Statements,
8111 Make_Procedure_Call_Statement (Loc,
8112 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8113 Parameter_Associations => New_List (
8114 New_Occurrence_Of (Request_Parameter, Loc),
8115 New_Occurrence_Of (Arguments, Loc))));
8117 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8119 -- The remote subprogram is a function: Build an inner block to be
8120 -- able to hold a potentially unconstrained result in a variable.
8123 Etyp : constant Entity_Id :=
8124 Etype (Result_Definition (Specification (Vis_Decl)));
8125 Result : constant Node_Id :=
8126 Make_Defining_Identifier (Loc,
8127 Chars => New_Internal_Name ('R'));
8130 Inner_Decls := New_List (
8131 Make_Object_Declaration (Loc,
8132 Defining_Identifier => Result,
8133 Constant_Present => True,
8134 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8136 Make_Function_Call (Loc,
8137 Name => Called_Subprogram,
8138 Parameter_Associations => Parameter_List)));
8140 if Is_Class_Wide_Type (Etyp) then
8142 -- For a remote call to a function with a class-wide type,
8143 -- check that the returned value satisfies the requirements
8146 Append_To (Inner_Decls,
8147 Make_Transportable_Check (Loc,
8148 New_Occurrence_Of (Result, Loc)));
8152 Set_Etype (Result, Etyp);
8153 Append_To (After_Statements,
8154 Make_Procedure_Call_Statement (Loc,
8155 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8156 Parameter_Associations => New_List (
8157 New_Occurrence_Of (Request_Parameter, Loc),
8158 PolyORB_Support.Helpers.Build_To_Any_Call
8159 (New_Occurrence_Of (Result, Loc), Decls))));
8161 -- A DSA function does not have out or inout arguments
8164 Append_To (Statements,
8165 Make_Block_Statement (Loc,
8166 Declarations => Inner_Decls,
8167 Handled_Statement_Sequence =>
8168 Make_Handled_Sequence_Of_Statements (Loc,
8169 Statements => After_Statements)));
8172 -- The remote subprogram is a procedure. We do not need any inner
8173 -- block in this case. No specific processing is required here for
8174 -- the dynamically asynchronous case: the indication of whether
8175 -- call is asynchronous or not is managed by the Sync_Scope
8176 -- attibute of the request, and is handled entirely in the
8179 Append_To (After_Statements,
8180 Make_Procedure_Call_Statement (Loc,
8181 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8182 Parameter_Associations => New_List (
8183 New_Occurrence_Of (Request_Parameter, Loc))));
8185 Append_To (Statements,
8186 Make_Procedure_Call_Statement (Loc,
8187 Name => Called_Subprogram,
8188 Parameter_Associations => Parameter_List));
8190 Append_List_To (Statements, After_Statements);
8194 Make_Procedure_Specification (Loc,
8195 Defining_Unit_Name =>
8196 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
8198 Parameter_Specifications => New_List (
8199 Make_Parameter_Specification (Loc,
8200 Defining_Identifier => Request_Parameter,
8202 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8204 -- An exception raised during the execution of an incoming
8205 -- remote subprogram call and that needs to be sent back
8206 -- to the caller is propagated by the receiving stubs, and
8207 -- will be handled by the caller (the distribution runtime).
8209 if Asynchronous and then not Dynamically_Asynchronous then
8211 -- For an asynchronous procedure, add a null exception handler
8213 Excep_Handlers := New_List (
8214 Make_Implicit_Exception_Handler (Loc,
8215 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8216 Statements => New_List (Make_Null_Statement (Loc))));
8219 -- In the other cases, if an exception is raised, then the
8220 -- exception occurrence is propagated.
8225 Append_To (Outer_Statements,
8226 Make_Block_Statement (Loc,
8227 Declarations => Decls,
8228 Handled_Statement_Sequence =>
8229 Make_Handled_Sequence_Of_Statements (Loc,
8230 Statements => Statements)));
8233 Make_Subprogram_Body (Loc,
8234 Specification => Subp_Spec,
8235 Declarations => Outer_Decls,
8236 Handled_Statement_Sequence =>
8237 Make_Handled_Sequence_Of_Statements (Loc,
8238 Statements => Outer_Statements,
8239 Exception_Handlers => Excep_Handlers));
8240 end Build_Subprogram_Receiving_Stubs;
8246 package body Helpers is
8248 -----------------------
8249 -- Local Subprograms --
8250 -----------------------
8252 function Find_Numeric_Representation
8253 (Typ : Entity_Id) return Entity_Id;
8254 -- Given a numeric type Typ, return the smallest integer or floating
8255 -- point type from Standard, or the smallest unsigned (modular) type
8256 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8258 function Make_Helper_Function_Name
8261 Nam : Name_Id) return Entity_Id;
8262 -- Return the name to be assigned for helper subprogram Nam of Typ
8264 ------------------------------------------------------------
8265 -- Common subprograms for building various tree fragments --
8266 ------------------------------------------------------------
8268 function Build_Get_Aggregate_Element
8272 Idx : Node_Id) return Node_Id;
8273 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8274 -- returning the Idx'th element.
8277 Subprogram : Entity_Id;
8278 -- Reference location for constructed nodes
8281 -- For 'Range and Etype
8284 -- For the construction of the innermost element expression
8286 with procedure Add_Process_Element
8289 Counter : Entity_Id;
8292 procedure Append_Array_Traversal
8295 Counter : Entity_Id := Empty;
8297 -- Build nested loop statements that iterate over the elements of an
8298 -- array Arry. The statement(s) built by Add_Process_Element are
8299 -- executed for each element; Indices is the list of indices to be
8300 -- used in the construction of the indexed component that denotes the
8301 -- current element. Subprogram is the entity for the subprogram for
8302 -- which this iterator is generated. The generated statements are
8303 -- appended to Stmts.
8307 -- The record entity being dealt with
8309 with procedure Add_Process_Element
8311 Container : Node_Or_Entity_Id;
8312 Counter : in out Int;
8315 -- Rec is the instance of the record type, or Empty.
8316 -- Field is either the N_Defining_Identifier for a component,
8317 -- or an N_Variant_Part.
8319 procedure Append_Record_Traversal
8322 Container : Node_Or_Entity_Id;
8323 Counter : in out Int);
8324 -- Process component list Clist. Individual fields are passed
8325 -- to Field_Processing. Each variant part is also processed.
8326 -- Container is the outer Any (for From_Any/To_Any),
8327 -- the outer typecode (for TC) to which the operation applies.
8329 -----------------------------
8330 -- Append_Record_Traversal --
8331 -----------------------------
8333 procedure Append_Record_Traversal
8336 Container : Node_Or_Entity_Id;
8337 Counter : in out Int)
8341 -- Clist's Component_Items and Variant_Part
8351 CI := Component_Items (Clist);
8352 VP := Variant_Part (Clist);
8355 while Present (Item) loop
8356 Def := Defining_Identifier (Item);
8358 if not Is_Internal_Name (Chars (Def)) then
8360 (Stmts, Container, Counter, Rec, Def);
8366 if Present (VP) then
8367 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8369 end Append_Record_Traversal;
8371 -------------------------
8372 -- Build_From_Any_Call --
8373 -------------------------
8375 function Build_From_Any_Call
8378 Decls : List_Id) return Node_Id
8380 Loc : constant Source_Ptr := Sloc (N);
8382 U_Type : Entity_Id := Underlying_Type (Typ);
8384 Fnam : Entity_Id := Empty;
8385 Lib_RE : RE_Id := RE_Null;
8389 -- First simple case where the From_Any function is present
8390 -- in the type's TSS.
8392 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8394 if Sloc (U_Type) <= Standard_Location then
8395 U_Type := Base_Type (U_Type);
8398 -- Check first for Boolean and Character. These are enumeration
8399 -- types, but we treat them specially, since they may require
8400 -- special handling in the transfer protocol. However, this
8401 -- special handling only applies if they have standard
8402 -- representation, otherwise they are treated like any other
8403 -- enumeration type.
8405 if Present (Fnam) then
8408 elsif U_Type = Standard_Boolean then
8411 elsif U_Type = Standard_Character then
8414 elsif U_Type = Standard_Wide_Character then
8417 elsif U_Type = Standard_Wide_Wide_Character then
8418 Lib_RE := RE_FA_WWC;
8420 -- Floating point types
8422 elsif U_Type = Standard_Short_Float then
8425 elsif U_Type = Standard_Float then
8428 elsif U_Type = Standard_Long_Float then
8431 elsif U_Type = Standard_Long_Long_Float then
8432 Lib_RE := RE_FA_LLF;
8436 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8437 Lib_RE := RE_FA_SSI;
8439 elsif U_Type = Etype (Standard_Short_Integer) then
8442 elsif U_Type = Etype (Standard_Integer) then
8445 elsif U_Type = Etype (Standard_Long_Integer) then
8448 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8449 Lib_RE := RE_FA_LLI;
8451 -- Unsigned integer types
8453 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8454 Lib_RE := RE_FA_SSU;
8456 elsif U_Type = RTE (RE_Short_Unsigned) then
8459 elsif U_Type = RTE (RE_Unsigned) then
8462 elsif U_Type = RTE (RE_Long_Unsigned) then
8465 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8466 Lib_RE := RE_FA_LLU;
8468 elsif Is_RTE (U_Type, RE_Unbounded_String) then
8469 Lib_RE := RE_FA_String;
8471 -- Special DSA types
8473 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
8476 -- Other (non-primitive) types
8481 Typ : Entity_Id := U_Type;
8484 -- For the subtype representing a generic actual type, go
8485 -- to the base type.
8487 if Is_Generic_Actual_Type (Typ) then
8488 Typ := Base_Type (Typ);
8491 Build_From_Any_Function (Loc, Typ, Decl, Fnam);
8492 Append_To (Decls, Decl);
8496 -- Call the function
8498 if Lib_RE /= RE_Null then
8499 pragma Assert (No (Fnam));
8500 Fnam := RTE (Lib_RE);
8504 Make_Function_Call (Loc,
8505 Name => New_Occurrence_Of (Fnam, Loc),
8506 Parameter_Associations => New_List (N));
8508 -- We must set the type of Result, so the unchecked conversion
8509 -- from the underlying type to the base type is properly done.
8511 Set_Etype (Result, U_Type);
8513 return Unchecked_Convert_To (Typ, Result);
8514 end Build_From_Any_Call;
8516 -----------------------------
8517 -- Build_From_Any_Function --
8518 -----------------------------
8520 procedure Build_From_Any_Function
8524 Fnam : out Entity_Id)
8527 Decls : constant List_Id := New_List;
8528 Stms : constant List_Id := New_List;
8530 Any_Parameter : constant Entity_Id :=
8531 Make_Defining_Identifier (Loc,
8532 New_Internal_Name ('A'));
8534 Use_Opaque_Representation : Boolean;
8537 if Is_Itype (Typ) then
8538 Build_From_Any_Function
8546 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
8549 Make_Function_Specification (Loc,
8550 Defining_Unit_Name => Fnam,
8551 Parameter_Specifications => New_List (
8552 Make_Parameter_Specification (Loc,
8553 Defining_Identifier => Any_Parameter,
8554 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
8555 Result_Definition => New_Occurrence_Of (Typ, Loc));
8557 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8560 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8562 Use_Opaque_Representation := False;
8564 if Has_Stream_Attribute_Definition
8565 (Typ, TSS_Stream_Output, At_Any_Place => True)
8567 Has_Stream_Attribute_Definition
8568 (Typ, TSS_Stream_Write, At_Any_Place => True)
8570 -- If user-defined stream attributes are specified for this
8571 -- type, use them and transmit data as an opaque sequence of
8574 Use_Opaque_Representation := True;
8576 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
8578 Make_Simple_Return_Statement (Loc,
8583 New_Occurrence_Of (Any_Parameter, Loc),
8586 elsif Is_Record_Type (Typ)
8587 and then not Is_Derived_Type (Typ)
8588 and then not Is_Tagged_Type (Typ)
8590 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8592 Make_Simple_Return_Statement (Loc,
8596 New_Occurrence_Of (Any_Parameter, Loc),
8601 Disc : Entity_Id := Empty;
8602 Discriminant_Associations : List_Id;
8603 Rdef : constant Node_Id :=
8605 (Declaration_Node (Typ));
8606 Component_Counter : Int := 0;
8608 -- The returned object
8610 Res : constant Entity_Id :=
8611 Make_Defining_Identifier (Loc,
8612 New_Internal_Name ('R'));
8614 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8616 procedure FA_Rec_Add_Process_Element
8619 Counter : in out Int;
8623 procedure FA_Append_Record_Traversal is
8624 new Append_Record_Traversal
8626 Add_Process_Element => FA_Rec_Add_Process_Element);
8628 --------------------------------
8629 -- FA_Rec_Add_Process_Element --
8630 --------------------------------
8632 procedure FA_Rec_Add_Process_Element
8635 Counter : in out Int;
8640 if Nkind (Field) = N_Defining_Identifier then
8642 -- A regular component
8645 Make_Assignment_Statement (Loc,
8646 Name => Make_Selected_Component (Loc,
8648 New_Occurrence_Of (Rec, Loc),
8650 New_Occurrence_Of (Field, Loc)),
8652 Build_From_Any_Call (Etype (Field),
8653 Build_Get_Aggregate_Element (Loc,
8655 TC => Build_TypeCode_Call (Loc,
8656 Etype (Field), Decls),
8657 Idx => Make_Integer_Literal (Loc,
8666 Struct_Counter : Int := 0;
8668 Block_Decls : constant List_Id := New_List;
8669 Block_Stmts : constant List_Id := New_List;
8672 Alt_List : constant List_Id := New_List;
8673 Choice_List : List_Id;
8675 Struct_Any : constant Entity_Id :=
8676 Make_Defining_Identifier (Loc,
8677 New_Internal_Name ('S'));
8681 Make_Object_Declaration (Loc,
8682 Defining_Identifier => Struct_Any,
8683 Constant_Present => True,
8684 Object_Definition =>
8685 New_Occurrence_Of (RTE (RE_Any), Loc),
8687 Make_Function_Call (Loc,
8690 (RTE (RE_Extract_Union_Value), Loc),
8692 Parameter_Associations => New_List (
8693 Build_Get_Aggregate_Element (Loc,
8696 Make_Function_Call (Loc,
8697 Name => New_Occurrence_Of (
8698 RTE (RE_Any_Member_Type), Loc),
8699 Parameter_Associations =>
8701 New_Occurrence_Of (Any, Loc),
8702 Make_Integer_Literal (Loc,
8703 Intval => Counter))),
8705 Make_Integer_Literal (Loc,
8706 Intval => Counter))))));
8709 Make_Block_Statement (Loc,
8710 Declarations => Block_Decls,
8711 Handled_Statement_Sequence =>
8712 Make_Handled_Sequence_Of_Statements (Loc,
8713 Statements => Block_Stmts)));
8715 Append_To (Block_Stmts,
8716 Make_Case_Statement (Loc,
8718 Make_Selected_Component (Loc,
8720 Selector_Name => Chars (Name (Field))),
8721 Alternatives => Alt_List));
8723 Variant := First_Non_Pragma (Variants (Field));
8724 while Present (Variant) loop
8727 (Discrete_Choices (Variant));
8729 VP_Stmts := New_List;
8731 -- Struct_Counter should be reset before
8732 -- handling a variant part. Indeed only one
8733 -- of the case statement alternatives will be
8734 -- executed at run-time, so the counter must
8735 -- start at 0 for every case statement.
8737 Struct_Counter := 0;
8739 FA_Append_Record_Traversal (
8741 Clist => Component_List (Variant),
8742 Container => Struct_Any,
8743 Counter => Struct_Counter);
8745 Append_To (Alt_List,
8746 Make_Case_Statement_Alternative (Loc,
8747 Discrete_Choices => Choice_List,
8748 Statements => VP_Stmts));
8749 Next_Non_Pragma (Variant);
8754 Counter := Counter + 1;
8755 end FA_Rec_Add_Process_Element;
8758 -- First all discriminants
8760 if Has_Discriminants (Typ) then
8761 Discriminant_Associations := New_List;
8763 Disc := First_Discriminant (Typ);
8764 while Present (Disc) loop
8766 Disc_Var_Name : constant Entity_Id :=
8767 Make_Defining_Identifier (Loc,
8768 Chars => Chars (Disc));
8769 Disc_Type : constant Entity_Id :=
8774 Make_Object_Declaration (Loc,
8775 Defining_Identifier => Disc_Var_Name,
8776 Constant_Present => True,
8777 Object_Definition =>
8778 New_Occurrence_Of (Disc_Type, Loc),
8781 Build_From_Any_Call (Disc_Type,
8782 Build_Get_Aggregate_Element (Loc,
8783 Any => Any_Parameter,
8784 TC => Build_TypeCode_Call
8785 (Loc, Disc_Type, Decls),
8786 Idx => Make_Integer_Literal (Loc,
8787 Intval => Component_Counter)),
8790 Component_Counter := Component_Counter + 1;
8792 Append_To (Discriminant_Associations,
8793 Make_Discriminant_Association (Loc,
8794 Selector_Names => New_List (
8795 New_Occurrence_Of (Disc, Loc)),
8797 New_Occurrence_Of (Disc_Var_Name, Loc)));
8799 Next_Discriminant (Disc);
8803 Make_Subtype_Indication (Loc,
8804 Subtype_Mark => Res_Definition,
8806 Make_Index_Or_Discriminant_Constraint (Loc,
8807 Discriminant_Associations));
8810 -- Now we have all the discriminants in variables, we can
8811 -- declared a constrained object. Note that we are not
8812 -- initializing (non-discriminant) components directly in
8813 -- the object declarations, because which fields to
8814 -- initialize depends (at run time) on the discriminant
8818 Make_Object_Declaration (Loc,
8819 Defining_Identifier => Res,
8820 Object_Definition => Res_Definition));
8822 -- ... then all components
8824 FA_Append_Record_Traversal (Stms,
8825 Clist => Component_List (Rdef),
8826 Container => Any_Parameter,
8827 Counter => Component_Counter);
8830 Make_Simple_Return_Statement (Loc,
8831 Expression => New_Occurrence_Of (Res, Loc)));
8835 elsif Is_Array_Type (Typ) then
8837 Constrained : constant Boolean := Is_Constrained (Typ);
8839 procedure FA_Ary_Add_Process_Element
8842 Counter : Entity_Id;
8844 -- Assign the current element (as identified by Counter) of
8845 -- Any to the variable denoted by name Datum, and advance
8846 -- Counter by 1. If Datum is not an Any, a call to From_Any
8847 -- for its type is inserted.
8849 --------------------------------
8850 -- FA_Ary_Add_Process_Element --
8851 --------------------------------
8853 procedure FA_Ary_Add_Process_Element
8856 Counter : Entity_Id;
8859 Assignment : constant Node_Id :=
8860 Make_Assignment_Statement (Loc,
8862 Expression => Empty);
8864 Element_Any : Node_Id;
8868 Element_TC : Node_Id;
8871 if Etype (Datum) = RTE (RE_Any) then
8873 -- When Datum is an Any the Etype field is not
8874 -- sufficient to determine the typecode of Datum
8875 -- (which can be a TC_SEQUENCE or TC_ARRAY
8876 -- depending on the value of Constrained).
8878 -- Therefore we retrieve the typecode which has
8879 -- been constructed in Append_Array_Traversal with
8880 -- a call to Get_Any_Type.
8883 Make_Function_Call (Loc,
8884 Name => New_Occurrence_Of (
8885 RTE (RE_Get_Any_Type), Loc),
8886 Parameter_Associations => New_List (
8887 New_Occurrence_Of (Entity (Datum), Loc)));
8889 -- For non Any Datum we simply construct a typecode
8890 -- matching the Etype of the Datum.
8892 Element_TC := Build_TypeCode_Call
8893 (Loc, Etype (Datum), Decls);
8897 Build_Get_Aggregate_Element (Loc,
8900 Idx => New_Occurrence_Of (Counter, Loc));
8903 -- Note: here we *prepend* statements to Stmts, so
8904 -- we must do it in reverse order.
8907 Make_Assignment_Statement (Loc,
8909 New_Occurrence_Of (Counter, Loc),
8912 Left_Opnd => New_Occurrence_Of (Counter, Loc),
8913 Right_Opnd => Make_Integer_Literal (Loc, 1))));
8915 if Nkind (Datum) /= N_Attribute_Reference then
8917 -- We ignore the value of the length of each
8918 -- dimension, since the target array has already
8919 -- been constrained anyway.
8921 if Etype (Datum) /= RTE (RE_Any) then
8922 Set_Expression (Assignment,
8924 (Component_Type (Typ), Element_Any, Decls));
8926 Set_Expression (Assignment, Element_Any);
8929 Prepend_To (Stmts, Assignment);
8931 end FA_Ary_Add_Process_Element;
8933 ------------------------
8934 -- Local Declarations --
8935 ------------------------
8937 Counter : constant Entity_Id :=
8938 Make_Defining_Identifier (Loc, Name_J);
8940 Initial_Counter_Value : Int := 0;
8942 Component_TC : constant Entity_Id :=
8943 Make_Defining_Identifier (Loc, Name_T);
8945 Res : constant Entity_Id :=
8946 Make_Defining_Identifier (Loc, Name_R);
8948 procedure Append_From_Any_Array_Iterator is
8949 new Append_Array_Traversal (
8952 Indices => New_List,
8953 Add_Process_Element => FA_Ary_Add_Process_Element);
8955 Res_Subtype_Indication : Node_Id :=
8956 New_Occurrence_Of (Typ, Loc);
8959 if not Constrained then
8961 Ndim : constant Int := Number_Dimensions (Typ);
8964 Indx : Node_Id := First_Index (Typ);
8967 Ranges : constant List_Id := New_List;
8970 for J in 1 .. Ndim loop
8971 Lnam := New_External_Name ('L', J);
8972 Hnam := New_External_Name ('H', J);
8974 -- Note, for empty arrays bounds may be out of
8975 -- the range of Etype (Indx).
8977 Indt := Base_Type (Etype (Indx));
8980 Make_Object_Declaration (Loc,
8981 Defining_Identifier =>
8982 Make_Defining_Identifier (Loc, Lnam),
8983 Constant_Present => True,
8984 Object_Definition =>
8985 New_Occurrence_Of (Indt, Loc),
8989 Build_Get_Aggregate_Element (Loc,
8990 Any => Any_Parameter,
8991 TC => Build_TypeCode_Call
8994 Make_Integer_Literal (Loc, J - 1)),
8998 Make_Object_Declaration (Loc,
8999 Defining_Identifier =>
9000 Make_Defining_Identifier (Loc, Hnam),
9002 Constant_Present => True,
9004 Object_Definition =>
9005 New_Occurrence_Of (Indt, Loc),
9007 Expression => Make_Attribute_Reference (Loc,
9009 New_Occurrence_Of (Indt, Loc),
9011 Attribute_Name => Name_Val,
9013 Expressions => New_List (
9014 Make_Op_Subtract (Loc,
9019 Standard_Long_Integer,
9020 Make_Identifier (Loc, Lnam)),
9024 Standard_Long_Integer,
9025 Make_Function_Call (Loc,
9027 New_Occurrence_Of (RTE (
9028 RE_Get_Nested_Sequence_Length
9030 Parameter_Associations =>
9033 Any_Parameter, Loc),
9034 Make_Integer_Literal (Loc,
9038 Make_Integer_Literal (Loc, 1))))));
9042 Low_Bound => Make_Identifier (Loc, Lnam),
9043 High_Bound => Make_Identifier (Loc, Hnam)));
9048 -- Now we have all the necessary bound information:
9049 -- apply the set of range constraints to the
9050 -- (unconstrained) nominal subtype of Res.
9052 Initial_Counter_Value := Ndim;
9053 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9054 Subtype_Mark => Res_Subtype_Indication,
9056 Make_Index_Or_Discriminant_Constraint (Loc,
9057 Constraints => Ranges));
9062 Make_Object_Declaration (Loc,
9063 Defining_Identifier => Res,
9064 Object_Definition => Res_Subtype_Indication));
9065 Set_Etype (Res, Typ);
9068 Make_Object_Declaration (Loc,
9069 Defining_Identifier => Counter,
9070 Object_Definition =>
9071 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
9073 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9076 Make_Object_Declaration (Loc,
9077 Defining_Identifier => Component_TC,
9078 Constant_Present => True,
9079 Object_Definition =>
9080 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9082 Build_TypeCode_Call (Loc,
9083 Component_Type (Typ), Decls)));
9085 Append_From_Any_Array_Iterator
9086 (Stms, Any_Parameter, Counter);
9089 Make_Simple_Return_Statement (Loc,
9090 Expression => New_Occurrence_Of (Res, Loc)));
9093 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9095 Make_Simple_Return_Statement (Loc,
9097 Unchecked_Convert_To (Typ,
9099 (Find_Numeric_Representation (Typ),
9100 New_Occurrence_Of (Any_Parameter, Loc),
9104 Use_Opaque_Representation := True;
9107 if Use_Opaque_Representation then
9109 -- Default: type is represented as an opaque sequence of bytes
9112 Strm : constant Entity_Id :=
9113 Make_Defining_Identifier (Loc,
9114 Chars => New_Internal_Name ('S'));
9115 Res : constant Entity_Id :=
9116 Make_Defining_Identifier (Loc,
9117 Chars => New_Internal_Name ('R'));
9120 -- Strm : Buffer_Stream_Type;
9123 Make_Object_Declaration (Loc,
9124 Defining_Identifier => Strm,
9125 Aliased_Present => True,
9126 Object_Definition =>
9127 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9129 -- Allocate_Buffer (Strm);
9132 Make_Procedure_Call_Statement (Loc,
9134 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9135 Parameter_Associations => New_List (
9136 New_Occurrence_Of (Strm, Loc))));
9138 -- Any_To_BS (Strm, A);
9141 Make_Procedure_Call_Statement (Loc,
9142 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
9143 Parameter_Associations => New_List (
9144 New_Occurrence_Of (Any_Parameter, Loc),
9145 New_Occurrence_Of (Strm, Loc))));
9147 if Transmit_As_Unconstrained (Typ) then
9150 -- Res : constant T := T'Input (Strm);
9152 -- Release_Buffer (Strm);
9156 Append_To (Stms, Make_Block_Statement (Loc,
9157 Declarations => New_List (
9158 Make_Object_Declaration (Loc,
9159 Defining_Identifier => Res,
9160 Constant_Present => True,
9161 Object_Definition => New_Occurrence_Of (Typ, Loc),
9163 Make_Attribute_Reference (Loc,
9164 Prefix => New_Occurrence_Of (Typ, Loc),
9165 Attribute_Name => Name_Input,
9166 Expressions => New_List (
9167 Make_Attribute_Reference (Loc,
9169 New_Occurrence_Of (Strm, Loc),
9170 Attribute_Name => Name_Access))))),
9172 Handled_Statement_Sequence =>
9173 Make_Handled_Sequence_Of_Statements (Loc,
9174 Statements => New_List (
9175 Make_Procedure_Call_Statement (Loc,
9178 (RTE (RE_Release_Buffer), Loc),
9179 Parameter_Associations =>
9180 New_List (New_Occurrence_Of (Strm, Loc))),
9182 Make_Simple_Return_Statement (Loc,
9183 Expression => New_Occurrence_Of (Res, Loc))))));
9189 -- T'Read (Strm, Res);
9190 -- Release_Buffer (Strm);
9194 Append_To (Stms, Make_Block_Statement (Loc,
9195 Declarations => New_List (
9196 Make_Object_Declaration (Loc,
9197 Defining_Identifier => Res,
9198 Constant_Present => False,
9199 Object_Definition =>
9200 New_Occurrence_Of (Typ, Loc))),
9202 Handled_Statement_Sequence =>
9203 Make_Handled_Sequence_Of_Statements (Loc,
9204 Statements => New_List (
9205 Make_Attribute_Reference (Loc,
9206 Prefix => New_Occurrence_Of (Typ, Loc),
9207 Attribute_Name => Name_Read,
9208 Expressions => New_List (
9209 Make_Attribute_Reference (Loc,
9211 New_Occurrence_Of (Strm, Loc),
9212 Attribute_Name => Name_Access),
9213 New_Occurrence_Of (Res, Loc))),
9215 Make_Procedure_Call_Statement (Loc,
9218 (RTE (RE_Release_Buffer), Loc),
9219 Parameter_Associations =>
9220 New_List (New_Occurrence_Of (Strm, Loc))),
9222 Make_Simple_Return_Statement (Loc,
9223 Expression => New_Occurrence_Of (Res, Loc))))));
9229 Make_Subprogram_Body (Loc,
9230 Specification => Spec,
9231 Declarations => Decls,
9232 Handled_Statement_Sequence =>
9233 Make_Handled_Sequence_Of_Statements (Loc,
9234 Statements => Stms));
9235 end Build_From_Any_Function;
9237 ---------------------------------
9238 -- Build_Get_Aggregate_Element --
9239 ---------------------------------
9241 function Build_Get_Aggregate_Element
9245 Idx : Node_Id) return Node_Id
9248 return Make_Function_Call (Loc,
9250 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc),
9251 Parameter_Associations => New_List (
9252 New_Occurrence_Of (Any, Loc),
9255 end Build_Get_Aggregate_Element;
9257 -------------------------
9258 -- Build_Reposiroty_Id --
9259 -------------------------
9261 procedure Build_Name_And_Repository_Id
9263 Name_Str : out String_Id;
9264 Repo_Id_Str : out String_Id)
9268 Store_String_Chars ("DSA:");
9269 Get_Library_Unit_Name_String (Scope (E));
9271 (Name_Buffer (Name_Buffer'First ..
9272 Name_Buffer'First + Name_Len - 1));
9273 Store_String_Char ('.');
9274 Get_Name_String (Chars (E));
9276 (Name_Buffer (Name_Buffer'First ..
9277 Name_Buffer'First + Name_Len - 1));
9278 Store_String_Chars (":1.0");
9279 Repo_Id_Str := End_String;
9280 Name_Str := String_From_Name_Buffer;
9281 end Build_Name_And_Repository_Id;
9283 -----------------------
9284 -- Build_To_Any_Call --
9285 -----------------------
9287 function Build_To_Any_Call
9289 Decls : List_Id) return Node_Id
9291 Loc : constant Source_Ptr := Sloc (N);
9293 Typ : Entity_Id := Etype (N);
9296 Fnam : Entity_Id := Empty;
9297 Lib_RE : RE_Id := RE_Null;
9300 -- If N is a selected component, then maybe its Etype has not been
9301 -- set yet: try to use Etype of the selector_name in that case.
9303 if No (Typ) and then Nkind (N) = N_Selected_Component then
9304 Typ := Etype (Selector_Name (N));
9306 pragma Assert (Present (Typ));
9308 -- Get full view for private type, completion for incomplete type
9310 U_Type := Underlying_Type (Typ);
9312 -- First simple case where the To_Any function is present in the
9315 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9317 -- Check first for Boolean and Character. These are enumeration
9318 -- types, but we treat them specially, since they may require
9319 -- special handling in the transfer protocol. However, this
9320 -- special handling only applies if they have standard
9321 -- representation, otherwise they are treated like any other
9322 -- enumeration type.
9324 if Sloc (U_Type) <= Standard_Location then
9325 U_Type := Base_Type (U_Type);
9328 if Present (Fnam) then
9331 elsif U_Type = Standard_Boolean then
9334 elsif U_Type = Standard_Character then
9337 elsif U_Type = Standard_Wide_Character then
9340 elsif U_Type = Standard_Wide_Wide_Character then
9341 Lib_RE := RE_TA_WWC;
9343 -- Floating point types
9345 elsif U_Type = Standard_Short_Float then
9348 elsif U_Type = Standard_Float then
9351 elsif U_Type = Standard_Long_Float then
9354 elsif U_Type = Standard_Long_Long_Float then
9355 Lib_RE := RE_TA_LLF;
9359 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9360 Lib_RE := RE_TA_SSI;
9362 elsif U_Type = Etype (Standard_Short_Integer) then
9365 elsif U_Type = Etype (Standard_Integer) then
9368 elsif U_Type = Etype (Standard_Long_Integer) then
9371 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9372 Lib_RE := RE_TA_LLI;
9374 -- Unsigned integer types
9376 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9377 Lib_RE := RE_TA_SSU;
9379 elsif U_Type = RTE (RE_Short_Unsigned) then
9382 elsif U_Type = RTE (RE_Unsigned) then
9385 elsif U_Type = RTE (RE_Long_Unsigned) then
9388 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9389 Lib_RE := RE_TA_LLU;
9391 elsif Is_RTE (U_Type, RE_Unbounded_String) then
9392 Lib_RE := RE_TA_String;
9394 -- Special DSA types
9396 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
9400 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9402 -- No corresponding FA_TC ???
9406 -- Other (non-primitive) types
9412 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9413 Append_To (Decls, Decl);
9417 -- Call the function
9419 if Lib_RE /= RE_Null then
9420 pragma Assert (No (Fnam));
9421 Fnam := RTE (Lib_RE);
9424 -- If Fnam is already analyzed, find the proper expected type,
9425 -- else we have a newly constructed To_Any function and we know
9426 -- that the expected type of its parameter is U_Type.
9428 if Ekind (Fnam) = E_Function
9429 and then Present (First_Formal (Fnam))
9431 C_Type := Etype (First_Formal (Fnam));
9437 Make_Function_Call (Loc,
9438 Name => New_Occurrence_Of (Fnam, Loc),
9439 Parameter_Associations =>
9440 New_List (OK_Convert_To (C_Type, N)));
9441 end Build_To_Any_Call;
9443 ---------------------------
9444 -- Build_To_Any_Function --
9445 ---------------------------
9447 procedure Build_To_Any_Function
9451 Fnam : out Entity_Id)
9454 Decls : constant List_Id := New_List;
9455 Stms : constant List_Id := New_List;
9457 Expr_Parameter : constant Entity_Id :=
9458 Make_Defining_Identifier (Loc, Name_E);
9460 Any : constant Entity_Id :=
9461 Make_Defining_Identifier (Loc, Name_A);
9464 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9466 Use_Opaque_Representation : Boolean;
9467 -- When True, use stream attributes and represent type as an
9468 -- opaque sequence of bytes.
9471 if Is_Itype (Typ) then
9472 Build_To_Any_Function
9480 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
9483 Make_Function_Specification (Loc,
9484 Defining_Unit_Name => Fnam,
9485 Parameter_Specifications => New_List (
9486 Make_Parameter_Specification (Loc,
9487 Defining_Identifier => Expr_Parameter,
9488 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9489 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9490 Set_Etype (Expr_Parameter, Typ);
9493 Make_Object_Declaration (Loc,
9494 Defining_Identifier => Any,
9495 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9497 Use_Opaque_Representation := False;
9499 if Has_Stream_Attribute_Definition
9500 (Typ, TSS_Stream_Output, At_Any_Place => True)
9502 Has_Stream_Attribute_Definition
9503 (Typ, TSS_Stream_Write, At_Any_Place => True)
9505 -- If user-defined stream attributes are specified for this
9506 -- type, use them and transmit data as an opaque sequence of
9509 Use_Opaque_Representation := True;
9511 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9513 -- Non-tagged derived type: convert to root type
9516 Rt_Type : constant Entity_Id := Root_Type (Typ);
9517 Expr : constant Node_Id :=
9520 New_Occurrence_Of (Expr_Parameter, Loc));
9522 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9525 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9527 -- Non-tagged record type
9529 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9531 Rt_Type : constant Entity_Id := Etype (Typ);
9532 Expr : constant Node_Id :=
9533 OK_Convert_To (Rt_Type,
9534 New_Occurrence_Of (Expr_Parameter, Loc));
9538 (Any_Decl, Build_To_Any_Call (Expr, Decls));
9541 -- Comment needed here (and label on declare block ???)
9545 Disc : Entity_Id := Empty;
9546 Rdef : constant Node_Id :=
9547 Type_Definition (Declaration_Node (Typ));
9549 Elements : constant List_Id := New_List;
9551 procedure TA_Rec_Add_Process_Element
9553 Container : Node_Or_Entity_Id;
9554 Counter : in out Int;
9557 -- Processing routine for traversal below
9559 procedure TA_Append_Record_Traversal is
9560 new Append_Record_Traversal
9561 (Rec => Expr_Parameter,
9562 Add_Process_Element => TA_Rec_Add_Process_Element);
9564 --------------------------------
9565 -- TA_Rec_Add_Process_Element --
9566 --------------------------------
9568 procedure TA_Rec_Add_Process_Element
9570 Container : Node_Or_Entity_Id;
9571 Counter : in out Int;
9575 Field_Ref : Node_Id;
9578 if Nkind (Field) = N_Defining_Identifier then
9580 -- A regular component
9582 Field_Ref := Make_Selected_Component (Loc,
9583 Prefix => New_Occurrence_Of (Rec, Loc),
9584 Selector_Name => New_Occurrence_Of (Field, Loc));
9585 Set_Etype (Field_Ref, Etype (Field));
9588 Make_Procedure_Call_Statement (Loc,
9591 RTE (RE_Add_Aggregate_Element), Loc),
9592 Parameter_Associations => New_List (
9593 New_Occurrence_Of (Container, Loc),
9594 Build_To_Any_Call (Field_Ref, Decls))));
9599 Variant_Part : declare
9601 Struct_Counter : Int := 0;
9603 Block_Decls : constant List_Id := New_List;
9604 Block_Stmts : constant List_Id := New_List;
9607 Alt_List : constant List_Id := New_List;
9608 Choice_List : List_Id;
9610 Union_Any : constant Entity_Id :=
9611 Make_Defining_Identifier (Loc,
9612 New_Internal_Name ('V'));
9614 Struct_Any : constant Entity_Id :=
9615 Make_Defining_Identifier (Loc,
9616 New_Internal_Name ('S'));
9618 function Make_Discriminant_Reference
9620 -- Build reference to the discriminant for this
9623 ---------------------------------
9624 -- Make_Discriminant_Reference --
9625 ---------------------------------
9627 function Make_Discriminant_Reference
9630 Nod : constant Node_Id :=
9631 Make_Selected_Component (Loc,
9634 Chars (Name (Field)));
9636 Set_Etype (Nod, Etype (Name (Field)));
9638 end Make_Discriminant_Reference;
9640 -- Start of processing for Variant_Part
9644 Make_Block_Statement (Loc,
9647 Handled_Statement_Sequence =>
9648 Make_Handled_Sequence_Of_Statements (Loc,
9649 Statements => Block_Stmts)));
9651 -- Declare variant part aggregate (Union_Any).
9652 -- Knowing the position of this VP in the
9653 -- variant record, we can fetch the VP typecode
9656 Append_To (Block_Decls,
9657 Make_Object_Declaration (Loc,
9658 Defining_Identifier => Union_Any,
9659 Object_Definition =>
9660 New_Occurrence_Of (RTE (RE_Any), Loc),
9662 Make_Function_Call (Loc,
9663 Name => New_Occurrence_Of (
9664 RTE (RE_Create_Any), Loc),
9665 Parameter_Associations => New_List (
9666 Make_Function_Call (Loc,
9669 RTE (RE_Any_Member_Type), Loc),
9670 Parameter_Associations => New_List (
9671 New_Occurrence_Of (Container, Loc),
9672 Make_Integer_Literal (Loc,
9675 -- Declare inner struct aggregate (which
9676 -- contains the components of this VP).
9678 Append_To (Block_Decls,
9679 Make_Object_Declaration (Loc,
9680 Defining_Identifier => Struct_Any,
9681 Object_Definition =>
9682 New_Occurrence_Of (RTE (RE_Any), Loc),
9684 Make_Function_Call (Loc,
9685 Name => New_Occurrence_Of (
9686 RTE (RE_Create_Any), Loc),
9687 Parameter_Associations => New_List (
9688 Make_Function_Call (Loc,
9691 RTE (RE_Any_Member_Type), Loc),
9692 Parameter_Associations => New_List (
9693 New_Occurrence_Of (Union_Any, Loc),
9694 Make_Integer_Literal (Loc,
9697 -- Build case statement
9699 Append_To (Block_Stmts,
9700 Make_Case_Statement (Loc,
9701 Expression => Make_Discriminant_Reference,
9702 Alternatives => Alt_List));
9704 Variant := First_Non_Pragma (Variants (Field));
9705 while Present (Variant) loop
9706 Choice_List := New_Copy_List_Tree
9707 (Discrete_Choices (Variant));
9709 VP_Stmts := New_List;
9711 -- Append discriminant val to union aggregate
9713 Append_To (VP_Stmts,
9714 Make_Procedure_Call_Statement (Loc,
9717 RTE (RE_Add_Aggregate_Element), Loc),
9718 Parameter_Associations => New_List (
9719 New_Occurrence_Of (Union_Any, Loc),
9721 (Make_Discriminant_Reference,
9724 -- Populate inner struct aggregate
9726 -- Struct_Counter should be reset before
9727 -- handling a variant part. Indeed only one
9728 -- of the case statement alternatives will be
9729 -- executed at run-time, so the counter must
9730 -- start at 0 for every case statement.
9732 Struct_Counter := 0;
9734 TA_Append_Record_Traversal (
9736 Clist => Component_List (Variant),
9737 Container => Struct_Any,
9738 Counter => Struct_Counter);
9740 -- Append inner struct to union aggregate
9742 Append_To (VP_Stmts,
9743 Make_Procedure_Call_Statement (Loc,
9746 RTE (RE_Add_Aggregate_Element), Loc),
9747 Parameter_Associations => New_List (
9748 New_Occurrence_Of (Union_Any, Loc),
9749 New_Occurrence_Of (Struct_Any, Loc))));
9751 -- Append union to outer aggregate
9753 Append_To (VP_Stmts,
9754 Make_Procedure_Call_Statement (Loc,
9757 RTE (RE_Add_Aggregate_Element), Loc),
9758 Parameter_Associations => New_List (
9759 New_Occurrence_Of (Container, Loc),
9761 (Union_Any, Loc))));
9763 Append_To (Alt_List,
9764 Make_Case_Statement_Alternative (Loc,
9765 Discrete_Choices => Choice_List,
9766 Statements => VP_Stmts));
9768 Next_Non_Pragma (Variant);
9773 Counter := Counter + 1;
9774 end TA_Rec_Add_Process_Element;
9777 -- Records are encoded in a TC_STRUCT aggregate:
9779 -- -- Outer aggregate (TC_STRUCT)
9780 -- | [discriminant1]
9781 -- | [discriminant2]
9788 -- A component can be a common component or variant part
9790 -- A variant part is encoded as a TC_UNION aggregate:
9792 -- -- Variant Part Aggregate (TC_UNION)
9793 -- | [discriminant choice for this Variant Part]
9795 -- | -- Inner struct (TC_STRUCT)
9800 -- Let's start by building the outer aggregate. First we
9801 -- construct Elements array containing all discriminants.
9803 if Has_Discriminants (Typ) then
9804 Disc := First_Discriminant (Typ);
9805 while Present (Disc) loop
9807 Discriminant : constant Entity_Id :=
9808 Make_Selected_Component (Loc,
9815 Set_Etype (Discriminant, Etype (Disc));
9817 Append_To (Elements,
9818 Make_Component_Association (Loc,
9819 Choices => New_List (
9820 Make_Integer_Literal (Loc, Counter)),
9822 Build_To_Any_Call (Discriminant, Decls)));
9825 Counter := Counter + 1;
9826 Next_Discriminant (Disc);
9830 -- If there are no discriminants, we declare an empty
9834 Dummy_Any : constant Entity_Id :=
9835 Make_Defining_Identifier (Loc,
9836 Chars => New_Internal_Name ('A'));
9840 Make_Object_Declaration (Loc,
9841 Defining_Identifier => Dummy_Any,
9842 Object_Definition =>
9843 New_Occurrence_Of (RTE (RE_Any), Loc)));
9845 Append_To (Elements,
9846 Make_Component_Association (Loc,
9847 Choices => New_List (
9850 Make_Integer_Literal (Loc, 1),
9852 Make_Integer_Literal (Loc, 0))),
9854 New_Occurrence_Of (Dummy_Any, Loc)));
9858 -- We build the result aggregate with discriminants
9859 -- as the first elements.
9861 Set_Expression (Any_Decl,
9862 Make_Function_Call (Loc,
9863 Name => New_Occurrence_Of (
9864 RTE (RE_Any_Aggregate_Build), Loc),
9865 Parameter_Associations => New_List (
9867 Make_Aggregate (Loc,
9868 Component_Associations => Elements))));
9871 -- Then we append all the components to the result
9874 TA_Append_Record_Traversal (Stms,
9875 Clist => Component_List (Rdef),
9877 Counter => Counter);
9881 elsif Is_Array_Type (Typ) then
9883 -- Constrained and unconstrained array types
9886 Constrained : constant Boolean := Is_Constrained (Typ);
9888 procedure TA_Ary_Add_Process_Element
9891 Counter : Entity_Id;
9894 --------------------------------
9895 -- TA_Ary_Add_Process_Element --
9896 --------------------------------
9898 procedure TA_Ary_Add_Process_Element
9901 Counter : Entity_Id;
9904 pragma Unreferenced (Counter);
9906 Element_Any : Node_Id;
9909 if Etype (Datum) = RTE (RE_Any) then
9910 Element_Any := Datum;
9912 Element_Any := Build_To_Any_Call (Datum, Decls);
9916 Make_Procedure_Call_Statement (Loc,
9917 Name => New_Occurrence_Of (
9918 RTE (RE_Add_Aggregate_Element), Loc),
9919 Parameter_Associations => New_List (
9920 New_Occurrence_Of (Any, Loc),
9922 end TA_Ary_Add_Process_Element;
9924 procedure Append_To_Any_Array_Iterator is
9925 new Append_Array_Traversal (
9927 Arry => Expr_Parameter,
9928 Indices => New_List,
9929 Add_Process_Element => TA_Ary_Add_Process_Element);
9934 Set_Expression (Any_Decl,
9935 Make_Function_Call (Loc,
9937 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9938 Parameter_Associations => New_List (Result_TC)));
9941 if not Constrained then
9942 Index := First_Index (Typ);
9943 for J in 1 .. Number_Dimensions (Typ) loop
9945 Make_Procedure_Call_Statement (Loc,
9948 RTE (RE_Add_Aggregate_Element), Loc),
9949 Parameter_Associations => New_List (
9950 New_Occurrence_Of (Any, Loc),
9952 OK_Convert_To (Etype (Index),
9953 Make_Attribute_Reference (Loc,
9955 New_Occurrence_Of (Expr_Parameter, Loc),
9956 Attribute_Name => Name_First,
9957 Expressions => New_List (
9958 Make_Integer_Literal (Loc, J)))),
9964 Append_To_Any_Array_Iterator (Stms, Any);
9967 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9971 Set_Expression (Any_Decl,
9974 Find_Numeric_Representation (Typ),
9975 New_Occurrence_Of (Expr_Parameter, Loc)),
9979 -- Default case, including tagged types: opaque representation
9981 Use_Opaque_Representation := True;
9984 if Use_Opaque_Representation then
9986 Strm : constant Entity_Id :=
9987 Make_Defining_Identifier (Loc,
9988 Chars => New_Internal_Name ('S'));
9989 -- Stream used to store data representation produced by
9990 -- stream attribute.
9994 -- Strm : aliased Buffer_Stream_Type;
9997 Make_Object_Declaration (Loc,
9998 Defining_Identifier =>
10002 Object_Definition =>
10003 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
10006 -- Allocate_Buffer (Strm);
10009 Make_Procedure_Call_Statement (Loc,
10011 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
10012 Parameter_Associations => New_List (
10013 New_Occurrence_Of (Strm, Loc))));
10016 -- T'Output (Strm'Access, E);
10019 Make_Attribute_Reference (Loc,
10020 Prefix => New_Occurrence_Of (Typ, Loc),
10021 Attribute_Name => Name_Output,
10022 Expressions => New_List (
10023 Make_Attribute_Reference (Loc,
10024 Prefix => New_Occurrence_Of (Strm, Loc),
10025 Attribute_Name => Name_Access),
10026 New_Occurrence_Of (Expr_Parameter, Loc))));
10029 -- BS_To_Any (Strm, A);
10032 Make_Procedure_Call_Statement (Loc,
10033 Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
10034 Parameter_Associations => New_List (
10035 New_Occurrence_Of (Strm, Loc),
10036 New_Occurrence_Of (Any, Loc))));
10039 -- Release_Buffer (Strm);
10042 Make_Procedure_Call_Statement (Loc,
10043 Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
10044 Parameter_Associations => New_List (
10045 New_Occurrence_Of (Strm, Loc))));
10049 Append_To (Decls, Any_Decl);
10051 if Present (Result_TC) then
10053 Make_Procedure_Call_Statement (Loc,
10054 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
10055 Parameter_Associations => New_List (
10056 New_Occurrence_Of (Any, Loc),
10061 Make_Simple_Return_Statement (Loc,
10062 Expression => New_Occurrence_Of (Any, Loc)));
10065 Make_Subprogram_Body (Loc,
10066 Specification => Spec,
10067 Declarations => Decls,
10068 Handled_Statement_Sequence =>
10069 Make_Handled_Sequence_Of_Statements (Loc,
10070 Statements => Stms));
10071 end Build_To_Any_Function;
10073 -------------------------
10074 -- Build_TypeCode_Call --
10075 -------------------------
10077 function Build_TypeCode_Call
10080 Decls : List_Id) return Node_Id
10082 U_Type : Entity_Id := Underlying_Type (Typ);
10083 -- The full view, if Typ is private; the completion,
10084 -- if Typ is incomplete.
10086 Fnam : Entity_Id := Empty;
10087 Lib_RE : RE_Id := RE_Null;
10091 -- Special case System.PolyORB.Interface.Any: its primitives have
10092 -- not been set yet, so can't call Find_Inherited_TSS.
10094 if Typ = RTE (RE_Any) then
10095 Fnam := RTE (RE_TC_A);
10098 -- First simple case where the TypeCode is present
10099 -- in the type's TSS.
10101 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10105 if Sloc (U_Type) <= Standard_Location then
10107 -- Do not try to build alias typecodes for subtypes from
10110 U_Type := Base_Type (U_Type);
10113 if U_Type = Standard_Boolean then
10116 elsif U_Type = Standard_Character then
10119 elsif U_Type = Standard_Wide_Character then
10120 Lib_RE := RE_TC_WC;
10122 elsif U_Type = Standard_Wide_Wide_Character then
10123 Lib_RE := RE_TC_WWC;
10125 -- Floating point types
10127 elsif U_Type = Standard_Short_Float then
10128 Lib_RE := RE_TC_SF;
10130 elsif U_Type = Standard_Float then
10133 elsif U_Type = Standard_Long_Float then
10134 Lib_RE := RE_TC_LF;
10136 elsif U_Type = Standard_Long_Long_Float then
10137 Lib_RE := RE_TC_LLF;
10139 -- Integer types (walk back to the base type)
10141 elsif U_Type = Etype (Standard_Short_Short_Integer) then
10142 Lib_RE := RE_TC_SSI;
10144 elsif U_Type = Etype (Standard_Short_Integer) then
10145 Lib_RE := RE_TC_SI;
10147 elsif U_Type = Etype (Standard_Integer) then
10150 elsif U_Type = Etype (Standard_Long_Integer) then
10151 Lib_RE := RE_TC_LI;
10153 elsif U_Type = Etype (Standard_Long_Long_Integer) then
10154 Lib_RE := RE_TC_LLI;
10156 -- Unsigned integer types
10158 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
10159 Lib_RE := RE_TC_SSU;
10161 elsif U_Type = RTE (RE_Short_Unsigned) then
10162 Lib_RE := RE_TC_SU;
10164 elsif U_Type = RTE (RE_Unsigned) then
10167 elsif U_Type = RTE (RE_Long_Unsigned) then
10168 Lib_RE := RE_TC_LU;
10170 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
10171 Lib_RE := RE_TC_LLU;
10173 elsif Is_RTE (U_Type, RE_Unbounded_String) then
10174 Lib_RE := RE_TC_String;
10176 -- Special DSA types
10178 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
10181 -- Other (non-primitive) types
10187 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10188 Append_To (Decls, Decl);
10192 if Lib_RE /= RE_Null then
10193 Fnam := RTE (Lib_RE);
10197 -- Call the function
10200 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10202 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10204 Set_Etype (Expr, RTE (RE_TypeCode));
10207 end Build_TypeCode_Call;
10209 -----------------------------
10210 -- Build_TypeCode_Function --
10211 -----------------------------
10213 procedure Build_TypeCode_Function
10216 Decl : out Node_Id;
10217 Fnam : out Entity_Id)
10220 Decls : constant List_Id := New_List;
10221 Stms : constant List_Id := New_List;
10223 TCNam : constant Entity_Id :=
10224 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
10226 Parameters : List_Id;
10228 procedure Add_String_Parameter
10230 Parameter_List : List_Id);
10231 -- Add a literal for S to Parameters
10233 procedure Add_TypeCode_Parameter
10234 (TC_Node : Node_Id;
10235 Parameter_List : List_Id);
10236 -- Add the typecode for Typ to Parameters
10238 procedure Add_Long_Parameter
10239 (Expr_Node : Node_Id;
10240 Parameter_List : List_Id);
10241 -- Add a signed long integer expression to Parameters
10243 procedure Initialize_Parameter_List
10244 (Name_String : String_Id;
10245 Repo_Id_String : String_Id;
10246 Parameter_List : out List_Id);
10247 -- Return a list that contains the first two parameters
10248 -- for a parameterized typecode: name and repository id.
10250 function Make_Constructed_TypeCode
10252 Parameters : List_Id) return Node_Id;
10253 -- Call TC_Build with the given kind and parameters
10255 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10256 -- Make a return statement that calls TC_Build with the given
10257 -- typecode kind, and the constructed parameters list.
10259 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10260 -- Return a typecode that is a TC_Alias for the given typecode
10262 --------------------------
10263 -- Add_String_Parameter --
10264 --------------------------
10266 procedure Add_String_Parameter
10268 Parameter_List : List_Id)
10271 Append_To (Parameter_List,
10272 Make_Function_Call (Loc,
10273 Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc),
10274 Parameter_Associations => New_List (
10275 Make_String_Literal (Loc, S))));
10276 end Add_String_Parameter;
10278 ----------------------------
10279 -- Add_TypeCode_Parameter --
10280 ----------------------------
10282 procedure Add_TypeCode_Parameter
10283 (TC_Node : Node_Id;
10284 Parameter_List : List_Id)
10287 Append_To (Parameter_List,
10288 Make_Function_Call (Loc,
10289 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10290 Parameter_Associations => New_List (TC_Node)));
10291 end Add_TypeCode_Parameter;
10293 ------------------------
10294 -- Add_Long_Parameter --
10295 ------------------------
10297 procedure Add_Long_Parameter
10298 (Expr_Node : Node_Id;
10299 Parameter_List : List_Id)
10302 Append_To (Parameter_List,
10303 Make_Function_Call (Loc,
10304 Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc),
10305 Parameter_Associations => New_List (Expr_Node)));
10306 end Add_Long_Parameter;
10308 -------------------------------
10309 -- Initialize_Parameter_List --
10310 -------------------------------
10312 procedure Initialize_Parameter_List
10313 (Name_String : String_Id;
10314 Repo_Id_String : String_Id;
10315 Parameter_List : out List_Id)
10318 Parameter_List := New_List;
10319 Add_String_Parameter (Name_String, Parameter_List);
10320 Add_String_Parameter (Repo_Id_String, Parameter_List);
10321 end Initialize_Parameter_List;
10323 ---------------------------
10324 -- Return_Alias_TypeCode --
10325 ---------------------------
10327 procedure Return_Alias_TypeCode
10328 (Base_TypeCode : Node_Id)
10331 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10332 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
10333 end Return_Alias_TypeCode;
10335 -------------------------------
10336 -- Make_Constructed_TypeCode --
10337 -------------------------------
10339 function Make_Constructed_TypeCode
10341 Parameters : List_Id) return Node_Id
10343 Constructed_TC : constant Node_Id :=
10344 Make_Function_Call (Loc,
10346 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
10347 Parameter_Associations => New_List (
10348 New_Occurrence_Of (Kind, Loc),
10349 Make_Aggregate (Loc,
10350 Expressions => Parameters)));
10352 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10353 return Constructed_TC;
10354 end Make_Constructed_TypeCode;
10356 ---------------------------------
10357 -- Return_Constructed_TypeCode --
10358 ---------------------------------
10360 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10363 Make_Simple_Return_Statement (Loc,
10365 Make_Constructed_TypeCode (Kind, Parameters)));
10366 end Return_Constructed_TypeCode;
10372 procedure TC_Rec_Add_Process_Element
10375 Counter : in out Int;
10379 procedure TC_Append_Record_Traversal is
10380 new Append_Record_Traversal (
10382 Add_Process_Element => TC_Rec_Add_Process_Element);
10384 --------------------------------
10385 -- TC_Rec_Add_Process_Element --
10386 --------------------------------
10388 procedure TC_Rec_Add_Process_Element
10391 Counter : in out Int;
10395 pragma Unreferenced (Any, Counter, Rec);
10398 if Nkind (Field) = N_Defining_Identifier then
10400 -- A regular component
10402 Add_TypeCode_Parameter
10403 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10404 Get_Name_String (Chars (Field));
10405 Add_String_Parameter (String_From_Name_Buffer, Params);
10412 Discriminant_Type : constant Entity_Id :=
10413 Etype (Name (Field));
10415 Is_Enum : constant Boolean :=
10416 Is_Enumeration_Type (Discriminant_Type);
10418 Union_TC_Params : List_Id;
10420 U_Name : constant Name_Id :=
10421 New_External_Name (Chars (Typ), 'V', -1);
10423 Name_Str : String_Id;
10424 Struct_TC_Params : List_Id;
10428 Default : constant Node_Id :=
10429 Make_Integer_Literal (Loc, -1);
10431 Dummy_Counter : Int := 0;
10433 Choice_Index : Int := 0;
10435 procedure Add_Params_For_Variant_Components;
10436 -- Add a struct TypeCode and a corresponding member name
10437 -- to the union parameter list.
10439 -- Ordering of declarations is a complete mess in this
10440 -- area, it is supposed to be types/variables, then
10441 -- subprogram specs, then subprogram bodies ???
10443 ---------------------------------------
10444 -- Add_Params_For_Variant_Components --
10445 ---------------------------------------
10447 procedure Add_Params_For_Variant_Components
10449 S_Name : constant Name_Id :=
10450 New_External_Name (U_Name, 'S', -1);
10453 Get_Name_String (S_Name);
10454 Name_Str := String_From_Name_Buffer;
10455 Initialize_Parameter_List
10456 (Name_Str, Name_Str, Struct_TC_Params);
10458 -- Build struct parameters
10460 TC_Append_Record_Traversal (Struct_TC_Params,
10461 Component_List (Variant),
10465 Add_TypeCode_Parameter
10466 (Make_Constructed_TypeCode
10467 (RTE (RE_TC_Struct), Struct_TC_Params),
10470 Add_String_Parameter (Name_Str, Union_TC_Params);
10471 end Add_Params_For_Variant_Components;
10474 Get_Name_String (U_Name);
10475 Name_Str := String_From_Name_Buffer;
10477 Initialize_Parameter_List
10478 (Name_Str, Name_Str, Union_TC_Params);
10480 -- Add union in enclosing parameter list
10482 Add_TypeCode_Parameter
10483 (Make_Constructed_TypeCode
10484 (RTE (RE_TC_Union), Union_TC_Params),
10487 Add_String_Parameter (Name_Str, Params);
10489 -- Build union parameters
10491 Add_TypeCode_Parameter
10492 (Build_TypeCode_Call
10493 (Loc, Discriminant_Type, Decls),
10496 Add_Long_Parameter (Default, Union_TC_Params);
10498 Variant := First_Non_Pragma (Variants (Field));
10499 while Present (Variant) loop
10500 Choice := First (Discrete_Choices (Variant));
10501 while Present (Choice) loop
10502 case Nkind (Choice) is
10505 L : constant Uint :=
10506 Expr_Value (Low_Bound (Choice));
10507 H : constant Uint :=
10508 Expr_Value (High_Bound (Choice));
10510 -- 3.8.1(8) guarantees that the bounds of
10511 -- this range are static.
10518 Expr := New_Occurrence_Of (
10519 Get_Enum_Lit_From_Pos (
10520 Discriminant_Type, J, Loc), Loc);
10523 Make_Integer_Literal (Loc, J);
10525 Append_To (Union_TC_Params,
10526 Build_To_Any_Call (Expr, Decls));
10528 Add_Params_For_Variant_Components;
10533 when N_Others_Choice =>
10535 -- This variant possess a default choice.
10536 -- We must therefore set the default
10537 -- parameter to the current choice index. The
10538 -- default parameter is by construction the
10539 -- fourth in the Union_TC_Params list.
10542 Default_Node : constant Node_Id :=
10543 Pick (Union_TC_Params, 4);
10545 New_Default_Node : constant Node_Id :=
10546 Make_Function_Call (Loc,
10549 (RTE (RE_TA_LI), Loc),
10550 Parameter_Associations =>
10552 Make_Integer_Literal
10553 (Loc, Choice_Index)));
10559 Remove (Default_Node);
10562 -- Add a placeholder member label
10563 -- for the default case.
10564 -- It must be of the discriminant type.
10567 Exp : constant Node_Id :=
10568 Make_Attribute_Reference (Loc,
10569 Prefix => New_Occurrence_Of
10570 (Discriminant_Type, Loc),
10571 Attribute_Name => Name_First);
10573 Set_Etype (Exp, Discriminant_Type);
10574 Append_To (Union_TC_Params,
10575 Build_To_Any_Call (Exp, Decls));
10578 Add_Params_For_Variant_Components;
10582 -- Case of an explicit choice
10585 Exp : constant Node_Id :=
10586 New_Copy_Tree (Choice);
10588 Append_To (Union_TC_Params,
10589 Build_To_Any_Call (Exp, Decls));
10592 Add_Params_For_Variant_Components;
10596 Choice_Index := Choice_Index + 1;
10599 Next_Non_Pragma (Variant);
10603 end TC_Rec_Add_Process_Element;
10605 Type_Name_Str : String_Id;
10606 Type_Repo_Id_Str : String_Id;
10609 if Is_Itype (Typ) then
10610 Build_TypeCode_Function
10612 Typ => Etype (Typ),
10621 Make_Function_Specification (Loc,
10622 Defining_Unit_Name => Fnam,
10623 Parameter_Specifications => Empty_List,
10624 Result_Definition =>
10625 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10627 Build_Name_And_Repository_Id (Typ,
10628 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10630 Initialize_Parameter_List
10631 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10633 if Has_Stream_Attribute_Definition
10634 (Typ, TSS_Stream_Output, At_Any_Place => True)
10636 Has_Stream_Attribute_Definition
10637 (Typ, TSS_Stream_Write, At_Any_Place => True)
10639 -- If user-defined stream attributes are specified for this
10640 -- type, use them and transmit data as an opaque sequence of
10641 -- stream elements.
10643 Return_Alias_TypeCode
10644 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10646 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
10647 Return_Alias_TypeCode (
10648 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10650 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10651 Return_Alias_TypeCode (
10652 Build_TypeCode_Call (Loc,
10653 Find_Numeric_Representation (Typ), Decls));
10655 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
10657 -- Record typecodes are encoded as follows:
10661 -- | [Repository Id]
10663 -- Then for each discriminant:
10665 -- | [Discriminant Type Code]
10666 -- | [Discriminant Name]
10669 -- Then for each component:
10671 -- | [Component Type Code]
10672 -- | [Component Name]
10675 -- Variants components type codes are encoded as follows:
10679 -- | [Repository Id]
10680 -- | [Discriminant Type Code]
10681 -- | [Index of Default Variant Part or -1 for no default]
10683 -- Then for each Variant Part :
10688 -- | | [Variant Part Name]
10689 -- | | [Variant Part Repository Id]
10691 -- | Then for each VP component:
10692 -- | | [VP component Typecode]
10693 -- | | [VP component Name]
10699 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10700 Return_Alias_TypeCode
10701 (Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10705 Disc : Entity_Id := Empty;
10706 Rdef : constant Node_Id :=
10707 Type_Definition (Declaration_Node (Typ));
10708 Dummy_Counter : Int := 0;
10711 -- Construct the discriminants typecodes
10713 if Has_Discriminants (Typ) then
10714 Disc := First_Discriminant (Typ);
10717 while Present (Disc) loop
10718 Add_TypeCode_Parameter (
10719 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10721 Get_Name_String (Chars (Disc));
10722 Add_String_Parameter (
10723 String_From_Name_Buffer,
10725 Next_Discriminant (Disc);
10728 -- then the components typecodes
10730 TC_Append_Record_Traversal
10731 (Parameters, Component_List (Rdef),
10732 Empty, Dummy_Counter);
10733 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10737 elsif Is_Array_Type (Typ) then
10739 Ndim : constant Pos := Number_Dimensions (Typ);
10740 Inner_TypeCode : Node_Id;
10741 Constrained : constant Boolean := Is_Constrained (Typ);
10742 Indx : Node_Id := First_Index (Typ);
10746 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls);
10748 for J in 1 .. Ndim loop
10749 if Constrained then
10750 Inner_TypeCode := Make_Constructed_TypeCode
10751 (RTE (RE_TC_Array), New_List (
10752 Build_To_Any_Call (
10753 OK_Convert_To (RTE (RE_Long_Unsigned),
10754 Make_Attribute_Reference (Loc,
10755 Prefix => New_Occurrence_Of (Typ, Loc),
10756 Attribute_Name => Name_Length,
10757 Expressions => New_List (
10758 Make_Integer_Literal (Loc,
10759 Intval => Ndim - J + 1)))),
10761 Build_To_Any_Call (Inner_TypeCode, Decls)));
10764 -- Unconstrained case: add low bound for each
10767 Add_TypeCode_Parameter
10768 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10770 Get_Name_String (New_External_Name ('L', J));
10771 Add_String_Parameter (
10772 String_From_Name_Buffer,
10776 Inner_TypeCode := Make_Constructed_TypeCode
10777 (RTE (RE_TC_Sequence), New_List (
10778 Build_To_Any_Call (
10779 OK_Convert_To (RTE (RE_Long_Unsigned),
10780 Make_Integer_Literal (Loc, 0)),
10782 Build_To_Any_Call (Inner_TypeCode, Decls)));
10786 if Constrained then
10787 Return_Alias_TypeCode (Inner_TypeCode);
10789 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10791 Store_String_Char ('V');
10792 Add_String_Parameter (End_String, Parameters);
10793 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10798 -- Default: type is represented as an opaque sequence of bytes
10800 Return_Alias_TypeCode
10801 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10805 Make_Subprogram_Body (Loc,
10806 Specification => Spec,
10807 Declarations => Decls,
10808 Handled_Statement_Sequence =>
10809 Make_Handled_Sequence_Of_Statements (Loc,
10810 Statements => Stms));
10811 end Build_TypeCode_Function;
10813 ---------------------------------
10814 -- Find_Numeric_Representation --
10815 ---------------------------------
10817 function Find_Numeric_Representation
10818 (Typ : Entity_Id) return Entity_Id
10820 FST : constant Entity_Id := First_Subtype (Typ);
10821 P_Size : constant Uint := Esize (FST);
10824 if Is_Unsigned_Type (Typ) then
10825 if P_Size <= Standard_Short_Short_Integer_Size then
10826 return RTE (RE_Short_Short_Unsigned);
10828 elsif P_Size <= Standard_Short_Integer_Size then
10829 return RTE (RE_Short_Unsigned);
10831 elsif P_Size <= Standard_Integer_Size then
10832 return RTE (RE_Unsigned);
10834 elsif P_Size <= Standard_Long_Integer_Size then
10835 return RTE (RE_Long_Unsigned);
10838 return RTE (RE_Long_Long_Unsigned);
10841 elsif Is_Integer_Type (Typ) then
10842 if P_Size <= Standard_Short_Short_Integer_Size then
10843 return Standard_Short_Short_Integer;
10845 elsif P_Size <= Standard_Short_Integer_Size then
10846 return Standard_Short_Integer;
10848 elsif P_Size <= Standard_Integer_Size then
10849 return Standard_Integer;
10851 elsif P_Size <= Standard_Long_Integer_Size then
10852 return Standard_Long_Integer;
10855 return Standard_Long_Long_Integer;
10858 elsif Is_Floating_Point_Type (Typ) then
10859 if P_Size <= Standard_Short_Float_Size then
10860 return Standard_Short_Float;
10862 elsif P_Size <= Standard_Float_Size then
10863 return Standard_Float;
10865 elsif P_Size <= Standard_Long_Float_Size then
10866 return Standard_Long_Float;
10869 return Standard_Long_Long_Float;
10873 raise Program_Error;
10876 -- TBD: fixed point types???
10877 -- TBverified numeric types with a biased representation???
10879 end Find_Numeric_Representation;
10881 ---------------------------
10882 -- Append_Array_Traversal --
10883 ---------------------------
10885 procedure Append_Array_Traversal
10888 Counter : Entity_Id := Empty;
10891 Loc : constant Source_Ptr := Sloc (Subprogram);
10892 Typ : constant Entity_Id := Etype (Arry);
10893 Constrained : constant Boolean := Is_Constrained (Typ);
10894 Ndim : constant Pos := Number_Dimensions (Typ);
10896 Inner_Any, Inner_Counter : Entity_Id;
10898 Loop_Stm : Node_Id;
10899 Inner_Stmts : constant List_Id := New_List;
10902 if Depth > Ndim then
10904 -- Processing for one element of an array
10907 Element_Expr : constant Node_Id :=
10908 Make_Indexed_Component (Loc,
10909 New_Occurrence_Of (Arry, Loc),
10912 Set_Etype (Element_Expr, Component_Type (Typ));
10913 Add_Process_Element (Stmts,
10915 Counter => Counter,
10916 Datum => Element_Expr);
10922 Append_To (Indices,
10923 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10925 if not Constrained or else Depth > 1 then
10926 Inner_Any := Make_Defining_Identifier (Loc,
10927 New_External_Name ('A', Depth));
10928 Set_Etype (Inner_Any, RTE (RE_Any));
10930 Inner_Any := Empty;
10933 if Present (Counter) then
10934 Inner_Counter := Make_Defining_Identifier (Loc,
10935 New_External_Name ('J', Depth));
10937 Inner_Counter := Empty;
10941 Loop_Any : Node_Id := Inner_Any;
10944 -- For the first dimension of a constrained array, we add
10945 -- elements directly in the corresponding Any; there is no
10946 -- intervening inner Any.
10948 if No (Loop_Any) then
10952 Append_Array_Traversal (Inner_Stmts,
10954 Counter => Inner_Counter,
10955 Depth => Depth + 1);
10959 Make_Implicit_Loop_Statement (Subprogram,
10960 Iteration_Scheme =>
10961 Make_Iteration_Scheme (Loc,
10962 Loop_Parameter_Specification =>
10963 Make_Loop_Parameter_Specification (Loc,
10964 Defining_Identifier =>
10965 Make_Defining_Identifier (Loc,
10966 Chars => New_External_Name ('L', Depth)),
10968 Discrete_Subtype_Definition =>
10969 Make_Attribute_Reference (Loc,
10970 Prefix => New_Occurrence_Of (Arry, Loc),
10971 Attribute_Name => Name_Range,
10973 Expressions => New_List (
10974 Make_Integer_Literal (Loc, Depth))))),
10975 Statements => Inner_Stmts);
10978 Decls : constant List_Id := New_List;
10979 Dimen_Stmts : constant List_Id := New_List;
10980 Length_Node : Node_Id;
10982 Inner_Any_TypeCode : constant Entity_Id :=
10983 Make_Defining_Identifier (Loc,
10984 New_External_Name ('T', Depth));
10986 Inner_Any_TypeCode_Expr : Node_Id;
10990 if Constrained then
10991 Inner_Any_TypeCode_Expr :=
10992 Make_Function_Call (Loc,
10993 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
10994 Parameter_Associations => New_List (
10995 New_Occurrence_Of (Any, Loc)));
10997 Inner_Any_TypeCode_Expr :=
10998 Make_Function_Call (Loc,
11000 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
11001 Parameter_Associations => New_List (
11002 New_Occurrence_Of (Any, Loc),
11003 Make_Integer_Literal (Loc, Ndim)));
11006 Inner_Any_TypeCode_Expr :=
11007 Make_Function_Call (Loc,
11008 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc),
11009 Parameter_Associations => New_List (
11010 Make_Identifier (Loc,
11011 Chars => New_External_Name ('T', Depth - 1))));
11015 Make_Object_Declaration (Loc,
11016 Defining_Identifier => Inner_Any_TypeCode,
11017 Constant_Present => True,
11018 Object_Definition => New_Occurrence_Of (
11019 RTE (RE_TypeCode), Loc),
11020 Expression => Inner_Any_TypeCode_Expr));
11022 if Present (Inner_Any) then
11024 Make_Object_Declaration (Loc,
11025 Defining_Identifier => Inner_Any,
11026 Object_Definition =>
11027 New_Occurrence_Of (RTE (RE_Any), Loc),
11029 Make_Function_Call (Loc,
11031 New_Occurrence_Of (
11032 RTE (RE_Create_Any), Loc),
11033 Parameter_Associations => New_List (
11034 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
11037 if Present (Inner_Counter) then
11039 Make_Object_Declaration (Loc,
11040 Defining_Identifier => Inner_Counter,
11041 Object_Definition =>
11042 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
11044 Make_Integer_Literal (Loc, 0)));
11047 if not Constrained then
11048 Length_Node := Make_Attribute_Reference (Loc,
11049 Prefix => New_Occurrence_Of (Arry, Loc),
11050 Attribute_Name => Name_Length,
11052 New_List (Make_Integer_Literal (Loc, Depth)));
11053 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
11055 Add_Process_Element (Dimen_Stmts,
11056 Datum => Length_Node,
11058 Counter => Inner_Counter);
11061 -- Loop_Stm does appropriate processing for each element
11064 Append_To (Dimen_Stmts, Loop_Stm);
11066 -- Link outer and inner any
11068 if Present (Inner_Any) then
11069 Add_Process_Element (Dimen_Stmts,
11071 Counter => Counter,
11072 Datum => New_Occurrence_Of (Inner_Any, Loc));
11076 Make_Block_Statement (Loc,
11079 Handled_Statement_Sequence =>
11080 Make_Handled_Sequence_Of_Statements (Loc,
11081 Statements => Dimen_Stmts)));
11083 end Append_Array_Traversal;
11085 -------------------------------
11086 -- Make_Helper_Function_Name --
11087 -------------------------------
11089 function Make_Helper_Function_Name
11092 Nam : Name_Id) return Entity_Id
11097 -- For tagged types, we use a canonical name so that it matches
11098 -- the primitive spec. For all other cases, we use a serialized
11099 -- name so that multiple generations of the same procedure do
11103 if not Is_Tagged_Type (Typ) then
11104 Serial := Increment_Serial_Number;
11107 -- Use prefixed underscore to avoid potential clash with used
11108 -- identifier (we use attribute names for Nam).
11111 Make_Defining_Identifier (Loc,
11114 (Related_Id => Nam,
11115 Suffix => ' ', Suffix_Index => Serial,
11118 end Make_Helper_Function_Name;
11121 -----------------------------------
11122 -- Reserve_NamingContext_Methods --
11123 -----------------------------------
11125 procedure Reserve_NamingContext_Methods is
11126 Str_Resolve : constant String := "resolve";
11128 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11129 Name_Len := Str_Resolve'Length;
11130 Overload_Counter_Table.Set (Name_Find, 1);
11131 end Reserve_NamingContext_Methods;
11133 end PolyORB_Support;
11135 -------------------------------
11136 -- RACW_Type_Is_Asynchronous --
11137 -------------------------------
11139 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11140 Asynchronous_Flag : constant Entity_Id :=
11141 Asynchronous_Flags_Table.Get (RACW_Type);
11143 Replace (Expression (Parent (Asynchronous_Flag)),
11144 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11145 end RACW_Type_Is_Asynchronous;
11147 -------------------------
11148 -- RCI_Package_Locator --
11149 -------------------------
11151 function RCI_Package_Locator
11153 Package_Spec : Node_Id) return Node_Id
11156 Pkg_Name : String_Id;
11159 Get_Library_Unit_Name_String (Package_Spec);
11160 Pkg_Name := String_From_Name_Buffer;
11162 Make_Package_Instantiation (Loc,
11163 Defining_Unit_Name =>
11164 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
11166 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11167 Generic_Associations => New_List (
11168 Make_Generic_Association (Loc,
11170 Make_Identifier (Loc, Name_RCI_Name),
11171 Explicit_Generic_Actual_Parameter =>
11172 Make_String_Literal (Loc,
11173 Strval => Pkg_Name)),
11174 Make_Generic_Association (Loc,
11176 Make_Identifier (Loc, Name_Version),
11177 Explicit_Generic_Actual_Parameter =>
11178 Make_Attribute_Reference (Loc,
11180 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11184 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
11185 Defining_Unit_Name (Inst));
11187 end RCI_Package_Locator;
11189 -----------------------------------------------
11190 -- Remote_Types_Tagged_Full_View_Encountered --
11191 -----------------------------------------------
11193 procedure Remote_Types_Tagged_Full_View_Encountered
11194 (Full_View : Entity_Id)
11196 Stub_Elements : constant Stub_Structure :=
11197 Stubs_Table.Get (Full_View);
11200 -- For an RACW encountered before the freeze point of its designated
11201 -- type, the stub type is generated at the point of the RACW declaration
11202 -- but the primitives are generated only once the designated type is
11203 -- frozen. That freeze can occur in another scope, for example when the
11204 -- RACW is declared in a nested package. In that case we need to
11205 -- reestablish the stub type's scope prior to generating its primitive
11208 if Stub_Elements /= Empty_Stub_Structure then
11210 Saved_Scope : constant Entity_Id := Current_Scope;
11211 Stubs_Scope : constant Entity_Id :=
11212 Scope (Stub_Elements.Stub_Type);
11215 if Current_Scope /= Stubs_Scope then
11216 Push_Scope (Stubs_Scope);
11219 Add_RACW_Primitive_Declarations_And_Bodies
11221 Stub_Elements.RPC_Receiver_Decl,
11222 Stub_Elements.Body_Decls);
11224 if Current_Scope /= Saved_Scope then
11229 end Remote_Types_Tagged_Full_View_Encountered;
11231 -------------------
11232 -- Scope_Of_Spec --
11233 -------------------
11235 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11236 Unit_Name : Node_Id;
11239 Unit_Name := Defining_Unit_Name (Spec);
11240 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11241 Unit_Name := Defining_Identifier (Unit_Name);
11247 ----------------------
11248 -- Set_Renaming_TSS --
11249 ----------------------
11251 procedure Set_Renaming_TSS
11254 TSS_Nam : TSS_Name_Type)
11256 Loc : constant Source_Ptr := Sloc (Nam);
11257 Spec : constant Node_Id := Parent (Nam);
11259 TSS_Node : constant Node_Id :=
11260 Make_Subprogram_Renaming_Declaration (Loc,
11262 Copy_Specification (Loc,
11264 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11265 Name => New_Occurrence_Of (Nam, Loc));
11267 Snam : constant Entity_Id :=
11268 Defining_Unit_Name (Specification (TSS_Node));
11271 if Nkind (Spec) = N_Function_Specification then
11272 Set_Ekind (Snam, E_Function);
11273 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11275 Set_Ekind (Snam, E_Procedure);
11276 Set_Etype (Snam, Standard_Void_Type);
11279 Set_TSS (Typ, Snam);
11280 end Set_Renaming_TSS;
11282 ----------------------------------------------
11283 -- Specific_Add_Obj_RPC_Receiver_Completion --
11284 ----------------------------------------------
11286 procedure Specific_Add_Obj_RPC_Receiver_Completion
11289 RPC_Receiver : Entity_Id;
11290 Stub_Elements : Stub_Structure)
11293 case Get_PCS_Name is
11294 when Name_PolyORB_DSA =>
11295 PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11296 Decls, RPC_Receiver, Stub_Elements);
11298 GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11299 Decls, RPC_Receiver, Stub_Elements);
11301 end Specific_Add_Obj_RPC_Receiver_Completion;
11303 --------------------------------
11304 -- Specific_Add_RACW_Features --
11305 --------------------------------
11307 procedure Specific_Add_RACW_Features
11308 (RACW_Type : Entity_Id;
11310 Stub_Type : Entity_Id;
11311 Stub_Type_Access : Entity_Id;
11312 RPC_Receiver_Decl : Node_Id;
11313 Body_Decls : List_Id)
11316 case Get_PCS_Name is
11317 when Name_PolyORB_DSA =>
11318 PolyORB_Support.Add_RACW_Features
11327 GARLIC_Support.Add_RACW_Features
11334 end Specific_Add_RACW_Features;
11336 --------------------------------
11337 -- Specific_Add_RAST_Features --
11338 --------------------------------
11340 procedure Specific_Add_RAST_Features
11341 (Vis_Decl : Node_Id;
11342 RAS_Type : Entity_Id)
11345 case Get_PCS_Name is
11346 when Name_PolyORB_DSA =>
11347 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11349 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11351 end Specific_Add_RAST_Features;
11353 --------------------------------------------------
11354 -- Specific_Add_Receiving_Stubs_To_Declarations --
11355 --------------------------------------------------
11357 procedure Specific_Add_Receiving_Stubs_To_Declarations
11358 (Pkg_Spec : Node_Id;
11363 case Get_PCS_Name is
11364 when Name_PolyORB_DSA =>
11365 PolyORB_Support.Add_Receiving_Stubs_To_Declarations
11366 (Pkg_Spec, Decls, Stmts);
11368 GARLIC_Support.Add_Receiving_Stubs_To_Declarations
11369 (Pkg_Spec, Decls, Stmts);
11371 end Specific_Add_Receiving_Stubs_To_Declarations;
11373 ------------------------------------------
11374 -- Specific_Build_General_Calling_Stubs --
11375 ------------------------------------------
11377 procedure Specific_Build_General_Calling_Stubs
11379 Statements : List_Id;
11380 Target : RPC_Target;
11381 Subprogram_Id : Node_Id;
11382 Asynchronous : Node_Id := Empty;
11383 Is_Known_Asynchronous : Boolean := False;
11384 Is_Known_Non_Asynchronous : Boolean := False;
11385 Is_Function : Boolean;
11387 Stub_Type : Entity_Id := Empty;
11388 RACW_Type : Entity_Id := Empty;
11392 case Get_PCS_Name is
11393 when Name_PolyORB_DSA =>
11394 PolyORB_Support.Build_General_Calling_Stubs
11400 Is_Known_Asynchronous,
11401 Is_Known_Non_Asynchronous,
11409 GARLIC_Support.Build_General_Calling_Stubs
11413 Target.RPC_Receiver,
11416 Is_Known_Asynchronous,
11417 Is_Known_Non_Asynchronous,
11424 end Specific_Build_General_Calling_Stubs;
11426 --------------------------------------
11427 -- Specific_Build_RPC_Receiver_Body --
11428 --------------------------------------
11430 procedure Specific_Build_RPC_Receiver_Body
11431 (RPC_Receiver : Entity_Id;
11432 Request : out Entity_Id;
11433 Subp_Id : out Entity_Id;
11434 Subp_Index : out Entity_Id;
11435 Stmts : out List_Id;
11436 Decl : out Node_Id)
11439 case Get_PCS_Name is
11440 when Name_PolyORB_DSA =>
11441 PolyORB_Support.Build_RPC_Receiver_Body
11450 GARLIC_Support.Build_RPC_Receiver_Body
11458 end Specific_Build_RPC_Receiver_Body;
11460 --------------------------------
11461 -- Specific_Build_Stub_Target --
11462 --------------------------------
11464 function Specific_Build_Stub_Target
11467 RCI_Locator : Entity_Id;
11468 Controlling_Parameter : Entity_Id) return RPC_Target
11471 case Get_PCS_Name is
11472 when Name_PolyORB_DSA =>
11473 return PolyORB_Support.Build_Stub_Target (Loc,
11474 Decls, RCI_Locator, Controlling_Parameter);
11477 return GARLIC_Support.Build_Stub_Target (Loc,
11478 Decls, RCI_Locator, Controlling_Parameter);
11480 end Specific_Build_Stub_Target;
11482 ------------------------------
11483 -- Specific_Build_Stub_Type --
11484 ------------------------------
11486 procedure Specific_Build_Stub_Type
11487 (RACW_Type : Entity_Id;
11488 Stub_Type : Entity_Id;
11489 Stub_Type_Decl : out Node_Id;
11490 RPC_Receiver_Decl : out Node_Id)
11493 case Get_PCS_Name is
11494 when Name_PolyORB_DSA =>
11495 PolyORB_Support.Build_Stub_Type (
11496 RACW_Type, Stub_Type,
11497 Stub_Type_Decl, RPC_Receiver_Decl);
11500 GARLIC_Support.Build_Stub_Type (
11501 RACW_Type, Stub_Type,
11502 Stub_Type_Decl, RPC_Receiver_Decl);
11504 end Specific_Build_Stub_Type;
11506 function Specific_Build_Subprogram_Receiving_Stubs
11507 (Vis_Decl : Node_Id;
11508 Asynchronous : Boolean;
11509 Dynamically_Asynchronous : Boolean := False;
11510 Stub_Type : Entity_Id := Empty;
11511 RACW_Type : Entity_Id := Empty;
11512 Parent_Primitive : Entity_Id := Empty) return Node_Id
11515 case Get_PCS_Name is
11516 when Name_PolyORB_DSA =>
11517 return PolyORB_Support.Build_Subprogram_Receiving_Stubs
11520 Dynamically_Asynchronous,
11526 return GARLIC_Support.Build_Subprogram_Receiving_Stubs
11529 Dynamically_Asynchronous,
11534 end Specific_Build_Subprogram_Receiving_Stubs;
11536 -------------------------------
11537 -- Transmit_As_Unconstrained --
11538 -------------------------------
11540 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
11543 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
11544 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
11545 end Transmit_As_Unconstrained;
11547 --------------------------
11548 -- Underlying_RACW_Type --
11549 --------------------------
11551 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11552 Record_Type : Entity_Id;
11555 if Ekind (RAS_Typ) = E_Record_Type then
11556 Record_Type := RAS_Typ;
11558 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11559 Record_Type := Equivalent_Type (RAS_Typ);
11563 Etype (Subtype_Indication
11564 (Component_Definition
11565 (First (Component_Items
11568 (Declaration_Node (Record_Type))))))));
11569 end Underlying_RACW_Type;