1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Exp_Strm; use Exp_Strm;
31 with Exp_Tss; use Exp_Tss;
32 with Exp_Util; use Exp_Util;
33 with GNAT.HTable; use GNAT.HTable;
35 with Namet; use Namet;
36 with Nlists; use Nlists;
37 with Nmake; use Nmake;
39 with Rtsfind; use Rtsfind;
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 Snames; use Snames;
48 with Stand; use Stand;
49 with Stringt; use Stringt;
50 with Tbuild; use Tbuild;
51 with Ttypes; use Ttypes;
52 with Uintp; use Uintp;
54 package body Exp_Dist is
56 -- The following model has been used to implement distributed objects:
57 -- given a designated type D and a RACW type R, then a record of the
60 -- type Stub is tagged record
61 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
64 -- is built. This type has two properties:
66 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
67 -- converted to and from this type to make it suitable for
68 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
69 -- to avoid memory leaks when the same remote object arrive on the
70 -- same partition through several paths;
72 -- 2) It also has the same dispatching table as the designated type D,
73 -- and thus can be used as an object designated by a value of type
74 -- R on any partition other than the one on which the object has
75 -- been created, since only dispatching calls will be performed and
76 -- the fields themselves will not be used. We call Derive_Subprograms
77 -- to fake half a derivation to ensure that the subprograms do have
78 -- the same dispatching table.
80 First_RCI_Subprogram_Id : constant := 2;
81 -- RCI subprograms are numbered starting at 2. The RCI receiver for
82 -- an RCI package can thus identify calls received through remote
83 -- access-to-subprogram dereferences by the fact that they have a
84 -- (primitive) subprogram id of 0, and 1 is used for the internal
85 -- RAS information lookup operation. (This is for the Garlic code
86 -- generation, where subprograms are identified by numbers; in the
87 -- PolyORB version, they are identified by name, with a numeric suffix
90 type Hash_Index is range 0 .. 50;
92 -----------------------
93 -- Local subprograms --
94 -----------------------
96 function Hash (F : Entity_Id) return Hash_Index;
97 -- DSA expansion associates stubs to distributed object types using
98 -- a hash table on entity ids.
100 function Hash (F : Name_Id) return Hash_Index;
101 -- The generation of subprogram identifiers requires an overload counter
102 -- to be associated with each remote subprogram names. These counters
103 -- are maintained in a hash table on name ids.
105 type Subprogram_Identifiers is record
106 Str_Identifier : String_Id;
107 Int_Identifier : Int;
110 package Subprogram_Identifier_Table is
111 new Simple_HTable (Header_Num => Hash_Index,
112 Element => Subprogram_Identifiers,
113 No_Element => (No_String, 0),
117 -- Mapping between a remote subprogram and the corresponding
118 -- subprogram identifiers.
120 package Overload_Counter_Table is
121 new Simple_HTable (Header_Num => Hash_Index,
127 -- Mapping between a subprogram name and an integer that
128 -- counts the number of defining subprogram names with that
129 -- Name_Id encountered so far in a given context (an interface).
131 function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
132 function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
133 function Get_Subprogram_Id (Def : Entity_Id) return Int;
134 -- Given a subprogram defined in a RCI package, get its distribution
135 -- subprogram identifiers (the distribution identifiers are a unique
136 -- subprogram number, and the non-qualified subprogram name, in the
137 -- casing used for the subprogram declaration; if the name is overloaded,
138 -- a double underscore and a serial number are appended.
140 -- The integer identifier is used to perform remote calls with GARLIC;
141 -- the string identifier is used in the case of PolyORB.
143 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
144 -- when receiving a call, the calling stubs will create requests with the
145 -- exact casing of the defining unit name of the called subprogram, so as
146 -- to allow calls to subprograms on distributed nodes that do distinguish
149 -- NOTE: Another design would be to allow a representation clause on
150 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
152 pragma Warnings (Off, Get_Subprogram_Id);
153 -- One homonym only is unreferenced (specific to the GARLIC version)
155 procedure Add_RAS_Dereference_TSS (N : Node_Id);
156 -- Add a subprogram body for RAS Dereference TSS
158 procedure Add_RAS_Proxy_And_Analyze
161 All_Calls_Remote_E : Entity_Id;
162 Proxy_Object_Addr : out Entity_Id);
163 -- Add the proxy type necessary to call the subprogram declared
164 -- by Vis_Decl through a remote access to subprogram type.
165 -- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote
166 -- applies, Standard_False otherwise. The new proxy type is appended
167 -- to Decls. Proxy_Object_Addr is a constant of type System.Address that
168 -- designates an instance of the proxy object.
170 function Build_Remote_Subprogram_Proxy_Type
172 ACR_Expression : Node_Id) return Node_Id;
173 -- Build and return a tagged record type definition for an RCI
174 -- subprogram proxy type.
175 -- ACR_Expression is use as the initialization value for
176 -- the All_Calls_Remote component.
178 function Build_Get_Unique_RP_Call
181 Stub_Type : Entity_Id) return List_Id;
182 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
183 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
184 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
186 function Build_Subprogram_Calling_Stubs
189 Asynchronous : Boolean;
190 Dynamically_Asynchronous : Boolean := False;
191 Stub_Type : Entity_Id := Empty;
192 RACW_Type : Entity_Id := Empty;
193 Locator : Entity_Id := Empty;
194 New_Name : Name_Id := No_Name) return Node_Id;
195 -- Build the calling stub for a given subprogram with the subprogram ID
196 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
197 -- parameters of this type will be marshalled instead of the object
198 -- itself. It will then be converted into Stub_Type before performing
199 -- the real call. If Dynamically_Asynchronous is True, then it will be
200 -- computed at run time whether the call is asynchronous or not.
201 -- Otherwise, the value of the formal Asynchronous will be used.
202 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
203 -- New_Name is given, then it will be used instead of the original name.
205 function Build_RPC_Receiver_Specification
206 (RPC_Receiver : Entity_Id;
207 Request_Parameter : Entity_Id) return Node_Id;
208 -- Make a subprogram specification for an RPC receiver, with the given
209 -- defining unit name and formal parameter.
211 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
212 -- Return an ordered parameter list: unconstrained parameters are put
213 -- at the beginning of the list and constrained ones are put after. If
214 -- there are no parameters, an empty list is returned. Special case:
215 -- the controlling formal of the equivalent RACW operation for a RAS
216 -- type is always left in first position.
218 procedure Add_Calling_Stubs_To_Declarations
221 -- Add calling stubs to the declarative part
223 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
224 -- Return True if nothing prevents the program whose specification is
225 -- given to be asynchronous (i.e. no out parameter).
227 function Pack_Entity_Into_Stream_Access
231 Etyp : Entity_Id := Empty) return Node_Id;
232 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
233 -- then Etype (Object) will be used if present. If the type is
234 -- constrained, then 'Write will be used to output the object,
235 -- If the type is unconstrained, 'Output will be used.
237 function Pack_Node_Into_Stream
241 Etyp : Entity_Id) return Node_Id;
242 -- Similar to above, with an arbitrary node instead of an entity
244 function Pack_Node_Into_Stream_Access
248 Etyp : Entity_Id) return Node_Id;
249 -- Similar to above, with Stream instead of Stream'Access
251 function Make_Selected_Component
254 Selector_Name : Name_Id) return Node_Id;
255 -- Return a selected_component whose prefix denotes the given entity,
256 -- and with the given Selector_Name.
258 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
259 -- Return the scope represented by a given spec
261 procedure Set_Renaming_TSS
264 TSS_Nam : TSS_Name_Type);
265 -- Create a renaming declaration of subprogram Nam,
266 -- and register it as a TSS for Typ with name TSS_Nam.
268 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
269 -- Return True if the current parameter needs an extra formal to reflect
270 -- its constrained status.
272 function Is_RACW_Controlling_Formal
273 (Parameter : Node_Id;
274 Stub_Type : Entity_Id) return Boolean;
275 -- Return True if the current parameter is a controlling formal argument
276 -- of type Stub_Type or access to Stub_Type.
278 procedure Declare_Create_NVList
283 -- Append the declaration of NVList to Decls, and its
284 -- initialization to Stmts.
286 function Add_Parameter_To_NVList
289 Parameter : Entity_Id;
290 Constrained : Boolean;
291 RACW_Ctrl : Boolean := False;
292 Any : Entity_Id) return Node_Id;
293 -- Return a call to Add_Item to add the Any corresponding
294 -- to the designated formal Parameter (with the indicated
295 -- Constrained status) to NVList. RACW_Ctrl must be set to
296 -- True for controlling formals of distributed object primitive
299 type Stub_Structure is record
300 Stub_Type : Entity_Id;
301 Stub_Type_Access : Entity_Id;
302 RPC_Receiver_Decl : Node_Id;
303 RACW_Type : Entity_Id;
305 -- This structure is necessary because of the two phases analysis of
306 -- a RACW declaration occurring in the same Remote_Types package as the
307 -- designated type. RACW_Type is any of the RACW types pointing on this
308 -- designated type, it is used here to save an anonymous type creation
309 -- for each primitive operation.
311 -- For a RACW that implements a RAS, no object RPC receiver is generated.
312 -- Instead, RPC_Receiver_Decl is the declaration after which the
313 -- RPC receiver would have been inserted.
315 Empty_Stub_Structure : constant Stub_Structure :=
316 (Empty, Empty, Empty, Empty);
318 package Stubs_Table is
319 new Simple_HTable (Header_Num => Hash_Index,
320 Element => Stub_Structure,
321 No_Element => Empty_Stub_Structure,
325 -- Mapping between a RACW designated type and its stub type
327 package Asynchronous_Flags_Table is
328 new Simple_HTable (Header_Num => Hash_Index,
329 Element => Entity_Id,
334 -- Mapping between a RACW type and a constant having the value True
335 -- if the RACW is asynchronous and False otherwise.
337 package RCI_Locator_Table is
338 new Simple_HTable (Header_Num => Hash_Index,
339 Element => Entity_Id,
344 -- Mapping between a RCI package on which All_Calls_Remote applies and
345 -- the generic instantiation of RCI_Locator for this package.
347 package RCI_Calling_Stubs_Table is
348 new Simple_HTable (Header_Num => Hash_Index,
349 Element => Entity_Id,
354 -- Mapping between a RCI subprogram and the corresponding calling stubs
356 procedure Add_Stub_Type
357 (Designated_Type : Entity_Id;
358 RACW_Type : Entity_Id;
360 Stub_Type : out Entity_Id;
361 Stub_Type_Access : out Entity_Id;
362 RPC_Receiver_Decl : out Node_Id;
363 Existing : out Boolean);
364 -- Add the declaration of the stub type, the access to stub type and the
365 -- object RPC receiver at the end of Decls. If these already exist,
366 -- then nothing is added in the tree but the right values are returned
367 -- anyhow and Existing is set to True.
369 procedure Add_RACW_Asynchronous_Flag
370 (Declarations : List_Id;
371 RACW_Type : Entity_Id);
372 -- Declare a boolean constant associated with RACW_Type whose value
373 -- indicates at run time whether a pragma Asynchronous applies to it.
375 procedure Assign_Subprogram_Identifier
379 -- Determine the distribution subprogram identifier to
380 -- be used for remote subprogram Def, return it in Id and
381 -- store it in a hash table for later retrieval by
382 -- Get_Subprogram_Id. Spn is the subprogram number.
384 function RCI_Package_Locator
386 Package_Spec : Node_Id) return Node_Id;
387 -- Instantiate the generic package RCI_Locator in order to locate the
388 -- RCI package whose spec is given as argument.
390 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
391 -- Surround a node N by a tag check, as in:
395 -- when E : Ada.Tags.Tag_Error =>
396 -- Raise_Exception (Program_Error'Identity,
397 -- Exception_Message (E));
400 function Input_With_Tag_Check
402 Var_Type : Entity_Id;
403 Stream : Node_Id) return Node_Id;
404 -- Return a function with the following form:
405 -- function R return Var_Type is
407 -- return Var_Type'Input (S);
409 -- when E : Ada.Tags.Tag_Error =>
410 -- Raise_Exception (Program_Error'Identity,
411 -- Exception_Message (E));
414 --------------------------------------------
415 -- Hooks for PCS-specific code generation --
416 --------------------------------------------
418 -- Part of the code generation circuitry for distribution needs to be
419 -- tailored for each implementation of the PCS. For each routine that
420 -- needs to be specialized, a Specific_<routine> wrapper is created,
421 -- which calls the corresponding <routine> in package
422 -- <pcs_implementation>_Support.
424 procedure Specific_Add_RACW_Features
425 (RACW_Type : Entity_Id;
427 Stub_Type : Entity_Id;
428 Stub_Type_Access : Entity_Id;
429 RPC_Receiver_Decl : Node_Id;
430 Declarations : List_Id);
431 -- Add declaration for TSSs for a given RACW type. The declarations are
432 -- added just after the declaration of the RACW type itself, while the
433 -- bodies are inserted at the end of Decls. Runtime-specific ancillary
434 -- subprogram for Add_RACW_Features.
436 procedure Specific_Add_RAST_Features
438 RAS_Type : Entity_Id);
439 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
440 -- subprogram for Add_RAST_Features.
442 -- An RPC_Target record is used during construction of calling stubs
443 -- to pass PCS-specific tree fragments corresponding to the information
444 -- necessary to locate the target of a remote subprogram call.
446 type RPC_Target (PCS_Kind : PCS_Names) is record
448 when Name_PolyORB_DSA =>
450 -- An expression whose value is a PolyORB reference to the target
453 Partition : Entity_Id;
454 -- A variable containing the Partition_ID of the target parition
456 RPC_Receiver : Node_Id;
457 -- An expression whose value is the address of the target RPC
462 procedure Specific_Build_General_Calling_Stubs
464 Statements : List_Id;
466 Subprogram_Id : Node_Id;
467 Asynchronous : Node_Id := Empty;
468 Is_Known_Asynchronous : Boolean := False;
469 Is_Known_Non_Asynchronous : Boolean := False;
470 Is_Function : Boolean;
472 Stub_Type : Entity_Id := Empty;
473 RACW_Type : Entity_Id := Empty;
475 -- Build calling stubs for general purpose. The parameters are:
476 -- Decls : a place to put declarations
477 -- Statements : a place to put statements
478 -- Target : PCS-specific target information (see details
479 -- in RPC_Target declaration).
480 -- Subprogram_Id : a node containing the subprogram ID
481 -- Asynchronous : True if an APC must be made instead of an RPC.
482 -- The value needs not be supplied if one of the
483 -- Is_Known_... is True.
484 -- Is_Known_Async... : True if we know that this is asynchronous
485 -- Is_Known_Non_A... : True if we know that this is not asynchronous
486 -- Spec : a node with a Parameter_Specifications and
487 -- a Result_Definition if applicable
488 -- Stub_Type : in case of RACW stubs, parameters of type access
489 -- to Stub_Type will be marshalled using the
490 -- address of the object (the addr field) rather
491 -- than using the 'Write on the stub itself
492 -- Nod : used to provide sloc for generated code
494 function Specific_Build_Stub_Target
497 RCI_Locator : Entity_Id;
498 Controlling_Parameter : Entity_Id) return RPC_Target;
499 -- Build call target information nodes for use within calling stubs. In the
500 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
501 -- for an RACW, Controlling_Parameter is the entity for the controlling
502 -- formal parameter used to determine the location of the target of the
503 -- call. Decls provides a location where variable declarations can be
504 -- appended to construct the necessary values.
506 procedure Specific_Build_Stub_Type
507 (RACW_Type : Entity_Id;
508 Stub_Type : Entity_Id;
509 Stub_Type_Decl : out Node_Id;
510 RPC_Receiver_Decl : out Node_Id);
511 -- Build a type declaration for the stub type associated with an RACW
512 -- type, and the necessary RPC receiver, if applicable. PCS-specific
513 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
514 -- is generated, then RPC_Receiver_Decl is set to Empty.
516 procedure Specific_Build_RPC_Receiver_Body
517 (RPC_Receiver : Entity_Id;
518 Request : out Entity_Id;
519 Subp_Id : out Entity_Id;
520 Subp_Index : out Entity_Id;
523 -- Make a subprogram body for an RPC receiver, with the given
524 -- defining unit name. On return:
525 -- - Subp_Id is the subprogram identifier from the PCS.
526 -- - Subp_Index is the index in the list of subprograms
527 -- used for dispatching (a variable of type Subprogram_Id).
528 -- - Stmts is the place where the request dispatching
529 -- statements can occur,
530 -- - Decl is the subprogram body declaration.
532 function Specific_Build_Subprogram_Receiving_Stubs
534 Asynchronous : Boolean;
535 Dynamically_Asynchronous : Boolean := False;
536 Stub_Type : Entity_Id := Empty;
537 RACW_Type : Entity_Id := Empty;
538 Parent_Primitive : Entity_Id := Empty) return Node_Id;
539 -- Build the receiving stub for a given subprogram. The subprogram
540 -- declaration is also built by this procedure, and the value returned
541 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
542 -- found in the specification, then its address is read from the stream
543 -- instead of the object itself and converted into an access to
544 -- class-wide type before doing the real call using any of the RACW type
545 -- pointing on the designated type.
547 procedure Specific_Add_Obj_RPC_Receiver_Completion
550 RPC_Receiver : Entity_Id;
551 Stub_Elements : Stub_Structure);
552 -- Add the necessary code to Decls after the completion of generation
553 -- of the RACW RPC receiver described by Stub_Elements.
555 procedure Specific_Add_Receiving_Stubs_To_Declarations
558 -- Add receiving stubs to the declarative part of an RCI unit
560 package GARLIC_Support is
562 -- Support for generating DSA code that uses the GARLIC PCS
564 -- The subprograms below provide the GARLIC versions of
565 -- the corresponding Specific_<subprogram> routine declared
568 procedure Add_RACW_Features
569 (RACW_Type : Entity_Id;
570 Stub_Type : Entity_Id;
571 Stub_Type_Access : Entity_Id;
572 RPC_Receiver_Decl : Node_Id;
573 Declarations : List_Id);
575 procedure Add_RAST_Features
577 RAS_Type : Entity_Id);
579 procedure Build_General_Calling_Stubs
581 Statements : List_Id;
582 Target_Partition : Entity_Id; -- From RPC_Target
583 Target_RPC_Receiver : Node_Id; -- From RPC_Target
584 Subprogram_Id : Node_Id;
585 Asynchronous : Node_Id := Empty;
586 Is_Known_Asynchronous : Boolean := False;
587 Is_Known_Non_Asynchronous : Boolean := False;
588 Is_Function : Boolean;
590 Stub_Type : Entity_Id := Empty;
591 RACW_Type : Entity_Id := Empty;
594 function Build_Stub_Target
597 RCI_Locator : Entity_Id;
598 Controlling_Parameter : Entity_Id) return RPC_Target;
600 procedure Build_Stub_Type
601 (RACW_Type : Entity_Id;
602 Stub_Type : Entity_Id;
603 Stub_Type_Decl : out Node_Id;
604 RPC_Receiver_Decl : out Node_Id);
606 function Build_Subprogram_Receiving_Stubs
608 Asynchronous : Boolean;
609 Dynamically_Asynchronous : Boolean := False;
610 Stub_Type : Entity_Id := Empty;
611 RACW_Type : Entity_Id := Empty;
612 Parent_Primitive : Entity_Id := Empty) return Node_Id;
614 procedure Add_Obj_RPC_Receiver_Completion
617 RPC_Receiver : Entity_Id;
618 Stub_Elements : Stub_Structure);
620 procedure Add_Receiving_Stubs_To_Declarations
624 procedure Build_RPC_Receiver_Body
625 (RPC_Receiver : Entity_Id;
626 Request : out Entity_Id;
627 Subp_Id : out Entity_Id;
628 Subp_Index : out Entity_Id;
634 package PolyORB_Support is
636 -- Support for generating DSA code that uses the PolyORB PCS
638 -- The subprograms below provide the PolyORB versions of
639 -- the corresponding Specific_<subprogram> routine declared
642 procedure Add_RACW_Features
643 (RACW_Type : Entity_Id;
645 Stub_Type : Entity_Id;
646 Stub_Type_Access : Entity_Id;
647 RPC_Receiver_Decl : Node_Id;
648 Declarations : List_Id);
650 procedure Add_RAST_Features
652 RAS_Type : Entity_Id);
654 procedure Build_General_Calling_Stubs
656 Statements : List_Id;
657 Target_Object : Node_Id; -- From RPC_Target
658 Subprogram_Id : Node_Id;
659 Asynchronous : Node_Id := Empty;
660 Is_Known_Asynchronous : Boolean := False;
661 Is_Known_Non_Asynchronous : Boolean := False;
662 Is_Function : Boolean;
664 Stub_Type : Entity_Id := Empty;
665 RACW_Type : Entity_Id := Empty;
668 function Build_Stub_Target
671 RCI_Locator : Entity_Id;
672 Controlling_Parameter : Entity_Id) return RPC_Target;
674 procedure Build_Stub_Type
675 (RACW_Type : Entity_Id;
676 Stub_Type : Entity_Id;
677 Stub_Type_Decl : out Node_Id;
678 RPC_Receiver_Decl : out Node_Id);
680 function Build_Subprogram_Receiving_Stubs
682 Asynchronous : Boolean;
683 Dynamically_Asynchronous : Boolean := False;
684 Stub_Type : Entity_Id := Empty;
685 RACW_Type : Entity_Id := Empty;
686 Parent_Primitive : Entity_Id := Empty) return Node_Id;
688 procedure Add_Obj_RPC_Receiver_Completion
691 RPC_Receiver : Entity_Id;
692 Stub_Elements : Stub_Structure);
694 procedure Add_Receiving_Stubs_To_Declarations
698 procedure Build_RPC_Receiver_Body
699 (RPC_Receiver : Entity_Id;
700 Request : out Entity_Id;
701 Subp_Id : out Entity_Id;
702 Subp_Index : out Entity_Id;
706 procedure Reserve_NamingContext_Methods;
707 -- Mark the method names for interface NamingContext as already used in
708 -- the overload table, so no clashes occur with user code (with the
709 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
710 -- their methods to be accessed as objects, for the implementation of
711 -- remote access-to-subprogram types).
715 -- Routines to build distribtion helper subprograms for user-defined
716 -- types. For implementation of the Distributed systems annex (DSA)
717 -- over the PolyORB generic middleware components, it is necessary to
718 -- generate several supporting subprograms for each application data
719 -- type used in inter-partition communication. These subprograms are:
720 -- * a Typecode function returning a high-level description of the
722 -- * two conversion functions allowing conversion of values of the
723 -- type from and to the generic data containers used by PolyORB.
724 -- These generic containers are called 'Any' type values after
725 -- the CORBA terminology, and hence the conversion subprograms
726 -- are named To_Any and From_Any.
728 function Build_From_Any_Call
731 Decls : List_Id) return Node_Id;
732 -- Build call to From_Any attribute function of type Typ with
733 -- expression N as actual parameter. Decls is the declarations list
734 -- for an appropriate enclosing scope of the point where the call
735 -- will be inserted; if the From_Any attribute for Typ needs to be
736 -- generated at this point, its declaration is appended to Decls.
738 procedure Build_From_Any_Function
742 Fnam : out Entity_Id);
743 -- Build From_Any attribute function for Typ. Loc is the reference
744 -- location for generated nodes, Typ is the type for which the
745 -- conversion function is generated. On return, Decl and Fnam contain
746 -- the declaration and entity for the newly-created function.
748 function Build_To_Any_Call
750 Decls : List_Id) return Node_Id;
751 -- Build call to To_Any attribute function with expression as actual
752 -- parameter. Decls is the declarations list for an appropriate
753 -- enclosing scope of the point where the call will be inserted; if
754 -- the To_Any attribute for Typ needs to be generated at this point,
755 -- its declaration is appended to Decls.
757 procedure Build_To_Any_Function
761 Fnam : out Entity_Id);
762 -- Build To_Any attribute function for Typ. Loc is the reference
763 -- location for generated nodes, Typ is the type for which the
764 -- conversion function is generated. On return, Decl and Fnam contain
765 -- the declaration and entity for the newly-created function.
767 function Build_TypeCode_Call
770 Decls : List_Id) return Node_Id;
771 -- Build call to TypeCode attribute function for Typ. Decls is the
772 -- declarations list for an appropriate enclosing scope of the point
773 -- where the call will be inserted; if the To_Any attribute for Typ
774 -- needs to be generated at this point, its declaration is appended
777 procedure Build_TypeCode_Function
781 Fnam : out Entity_Id);
782 -- Build TypeCode attribute function for Typ. Loc is the reference
783 -- location for generated nodes, Typ is the type for which the
784 -- conversion function is generated. On return, Decl and Fnam contain
785 -- the declaration and entity for the newly-created function.
787 procedure Build_Name_And_Repository_Id
789 Name_Str : out String_Id;
790 Repo_Id_Str : out String_Id);
791 -- In the PolyORB distribution model, each distributed object type
792 -- and each distributed operation has a globally unique identifier,
793 -- its Repository Id. This subprogram builds and returns two strings
794 -- for entity E (a distributed object type or operation): one
795 -- containing the name of E, the second containing its repository id.
801 ------------------------------------
802 -- Local variables and structures --
803 ------------------------------------
806 -- Needs comments ???
808 Output_From_Constrained : constant array (Boolean) of Name_Id :=
809 (False => Name_Output,
811 -- The attribute to choose depending on the fact that the parameter
812 -- is constrained or not. There is no such thing as Input_From_Constrained
813 -- since this require separate mechanisms ('Input is a function while
814 -- 'Read is a procedure).
816 ---------------------------------------
817 -- Add_Calling_Stubs_To_Declarations --
818 ---------------------------------------
820 procedure Add_Calling_Stubs_To_Declarations
824 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
825 -- Subprogram id 0 is reserved for calls received from
826 -- remote access-to-subprogram dereferences.
828 Current_Declaration : Node_Id;
829 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
830 RCI_Instantiation : Node_Id;
831 Subp_Stubs : Node_Id;
832 Subp_Str : String_Id;
835 -- The first thing added is an instantiation of the generic package
836 -- System.Partition_Interface.RCI_Locator with the name of this
837 -- remote package. This will act as an interface with the name server
838 -- to determine the Partition_ID and the RPC_Receiver for the
839 -- receiver of this package.
841 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
842 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
844 Append_To (Decls, RCI_Instantiation);
845 Analyze (RCI_Instantiation);
847 -- For each subprogram declaration visible in the spec, we do
848 -- build a body. We also increment a counter to assign a different
849 -- Subprogram_Id to each subprograms. The receiving stubs processing
850 -- do use the same mechanism and will thus assign the same Id and
851 -- do the correct dispatching.
853 Overload_Counter_Table.Reset;
854 PolyORB_Support.Reserve_NamingContext_Methods;
856 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
858 while Present (Current_Declaration) loop
859 if Nkind (Current_Declaration) = N_Subprogram_Declaration
860 and then Comes_From_Source (Current_Declaration)
862 Assign_Subprogram_Identifier (
863 Defining_Unit_Name (Specification (Current_Declaration)),
864 Current_Subprogram_Number,
868 Build_Subprogram_Calling_Stubs (
869 Vis_Decl => Current_Declaration,
871 Build_Subprogram_Id (Loc,
872 Defining_Unit_Name (Specification (Current_Declaration))),
874 Nkind (Specification (Current_Declaration)) =
875 N_Procedure_Specification
877 Is_Asynchronous (Defining_Unit_Name (Specification
878 (Current_Declaration))));
880 Append_To (Decls, Subp_Stubs);
881 Analyze (Subp_Stubs);
883 Current_Subprogram_Number := Current_Subprogram_Number + 1;
886 Next (Current_Declaration);
888 end Add_Calling_Stubs_To_Declarations;
890 -----------------------------
891 -- Add_Parameter_To_NVList --
892 -----------------------------
894 function Add_Parameter_To_NVList
897 Parameter : Entity_Id;
898 Constrained : Boolean;
899 RACW_Ctrl : Boolean := False;
900 Any : Entity_Id) return Node_Id
902 Parameter_Name_String : String_Id;
903 Parameter_Mode : Node_Id;
905 function Parameter_Passing_Mode
907 Parameter : Entity_Id;
908 Constrained : Boolean) return Node_Id;
909 -- Return an expression that denotes the parameter passing
910 -- mode to be used for Parameter in distribution stubs,
911 -- where Constrained is Parameter's constrained status.
913 ----------------------------
914 -- Parameter_Passing_Mode --
915 ----------------------------
917 function Parameter_Passing_Mode
919 Parameter : Entity_Id;
920 Constrained : Boolean) return Node_Id
925 if Out_Present (Parameter) then
926 if In_Present (Parameter)
927 or else not Constrained
929 -- Unconstrained formals must be translated
930 -- to 'in' or 'inout', not 'out', because
931 -- they need to be constrained by the actual.
933 Lib_RE := RE_Mode_Inout;
935 Lib_RE := RE_Mode_Out;
939 Lib_RE := RE_Mode_In;
942 return New_Occurrence_Of (RTE (Lib_RE), Loc);
943 end Parameter_Passing_Mode;
945 -- Start of processing for Add_Parameter_To_NVList
948 if Nkind (Parameter) = N_Defining_Identifier then
949 Get_Name_String (Chars (Parameter));
951 Get_Name_String (Chars (Defining_Identifier
955 Parameter_Name_String := String_From_Name_Buffer;
958 Parameter_Mode := New_Occurrence_Of
959 (RTE (RE_Mode_In), Loc);
961 Parameter_Mode := Parameter_Passing_Mode (Loc,
962 Parameter, Constrained);
966 Make_Procedure_Call_Statement (Loc,
969 (RTE (RE_NVList_Add_Item), Loc),
970 Parameter_Associations => New_List (
971 New_Occurrence_Of (NVList, Loc),
972 Make_Function_Call (Loc,
975 (RTE (RE_To_PolyORB_String), Loc),
976 Parameter_Associations => New_List (
977 Make_String_Literal (Loc,
978 Strval => Parameter_Name_String))),
979 New_Occurrence_Of (Any, Loc),
981 end Add_Parameter_To_NVList;
983 --------------------------------
984 -- Add_RACW_Asynchronous_Flag --
985 --------------------------------
987 procedure Add_RACW_Asynchronous_Flag
988 (Declarations : List_Id;
989 RACW_Type : Entity_Id)
991 Loc : constant Source_Ptr := Sloc (RACW_Type);
993 Asynchronous_Flag : constant Entity_Id :=
994 Make_Defining_Identifier (Loc,
995 New_External_Name (Chars (RACW_Type), 'A'));
998 -- Declare the asynchronous flag. This flag will be changed to True
999 -- whenever it is known that the RACW type is asynchronous.
1001 Append_To (Declarations,
1002 Make_Object_Declaration (Loc,
1003 Defining_Identifier => Asynchronous_Flag,
1004 Constant_Present => True,
1005 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1006 Expression => New_Occurrence_Of (Standard_False, Loc)));
1008 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1009 end Add_RACW_Asynchronous_Flag;
1011 -----------------------
1012 -- Add_RACW_Features --
1013 -----------------------
1015 procedure Add_RACW_Features (RACW_Type : Entity_Id)
1017 Desig : constant Entity_Id :=
1018 Etype (Designated_Type (RACW_Type));
1020 List_Containing (Declaration_Node (RACW_Type));
1022 Same_Scope : constant Boolean :=
1023 Scope (Desig) = Scope (RACW_Type);
1025 Stub_Type : Entity_Id;
1026 Stub_Type_Access : Entity_Id;
1027 RPC_Receiver_Decl : Node_Id;
1031 if not Expander_Active then
1037 -- We are declaring a RACW in the same package than its designated
1038 -- type, so the list to use for late declarations must be the
1039 -- private part of the package. We do know that this private part
1040 -- exists since the designated type has to be a private one.
1042 Decls := Private_Declarations
1043 (Package_Specification_Of_Scope (Current_Scope));
1045 elsif Nkind (Parent (Decls)) = N_Package_Specification
1046 and then Present (Private_Declarations (Parent (Decls)))
1048 Decls := Private_Declarations (Parent (Decls));
1051 -- If we were unable to find the declarations, that means that the
1052 -- completion of the type was missing. We can safely return and let
1053 -- the error be caught by the semantic analysis.
1060 (Designated_Type => Desig,
1061 RACW_Type => RACW_Type,
1063 Stub_Type => Stub_Type,
1064 Stub_Type_Access => Stub_Type_Access,
1065 RPC_Receiver_Decl => RPC_Receiver_Decl,
1066 Existing => Existing);
1068 Add_RACW_Asynchronous_Flag
1069 (Declarations => Decls,
1070 RACW_Type => RACW_Type);
1072 Specific_Add_RACW_Features
1073 (RACW_Type => RACW_Type,
1075 Stub_Type => Stub_Type,
1076 Stub_Type_Access => Stub_Type_Access,
1077 RPC_Receiver_Decl => RPC_Receiver_Decl,
1078 Declarations => Decls);
1080 if not Same_Scope and then not Existing then
1082 -- The RACW has been declared in another scope than the designated
1083 -- type and has not been handled by another RACW in the same package
1084 -- as the first one, so add primitive for the stub type here.
1086 Add_RACW_Primitive_Declarations_And_Bodies
1087 (Designated_Type => Desig,
1088 Insertion_Node => RPC_Receiver_Decl,
1092 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1094 end Add_RACW_Features;
1096 ------------------------------------------------
1097 -- Add_RACW_Primitive_Declarations_And_Bodies --
1098 ------------------------------------------------
1100 procedure Add_RACW_Primitive_Declarations_And_Bodies
1101 (Designated_Type : Entity_Id;
1102 Insertion_Node : Node_Id;
1105 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1106 -- the declarations are recognized as belonging to the current package.
1108 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1110 Stub_Elements : constant Stub_Structure :=
1111 Stubs_Table.Get (Designated_Type);
1113 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1114 Is_RAS : constant Boolean :=
1115 not Comes_From_Source (Stub_Elements.RACW_Type);
1117 Current_Insertion_Node : Node_Id := Insertion_Node;
1119 RPC_Receiver : Entity_Id;
1120 RPC_Receiver_Statements : List_Id;
1121 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1122 RPC_Receiver_Elsif_Parts : List_Id;
1123 RPC_Receiver_Request : Entity_Id;
1124 RPC_Receiver_Subp_Id : Entity_Id;
1125 RPC_Receiver_Subp_Index : Entity_Id;
1127 Subp_Str : String_Id;
1129 Current_Primitive_Elmt : Elmt_Id;
1130 Current_Primitive : Entity_Id;
1131 Current_Primitive_Body : Node_Id;
1132 Current_Primitive_Spec : Node_Id;
1133 Current_Primitive_Decl : Node_Id;
1134 Current_Primitive_Number : Int := 0;
1136 Current_Primitive_Alias : Node_Id;
1138 Current_Receiver : Entity_Id;
1139 Current_Receiver_Body : Node_Id;
1141 RPC_Receiver_Decl : Node_Id;
1143 Possibly_Asynchronous : Boolean;
1146 if not Expander_Active then
1151 RPC_Receiver := Make_Defining_Identifier (Loc,
1152 New_Internal_Name ('P'));
1153 Specific_Build_RPC_Receiver_Body (
1154 RPC_Receiver => RPC_Receiver,
1155 Request => RPC_Receiver_Request,
1156 Subp_Id => RPC_Receiver_Subp_Id,
1157 Subp_Index => RPC_Receiver_Subp_Index,
1158 Stmts => RPC_Receiver_Statements,
1159 Decl => RPC_Receiver_Decl);
1161 if Get_PCS_Name = Name_PolyORB_DSA then
1163 -- For the case of PolyORB, we need to map a textual operation
1164 -- name into a primitive index. Currently we do so using a
1165 -- simple sequence of string comparisons.
1167 RPC_Receiver_Elsif_Parts := New_List;
1171 -- Build callers, receivers for every primitive operations and a RPC
1172 -- receiver for this type.
1174 if Present (Primitive_Operations (Designated_Type)) then
1175 Overload_Counter_Table.Reset;
1177 Current_Primitive_Elmt :=
1178 First_Elmt (Primitive_Operations (Designated_Type));
1179 while Current_Primitive_Elmt /= No_Elmt loop
1180 Current_Primitive := Node (Current_Primitive_Elmt);
1182 -- Copy the primitive of all the parents, except predefined
1183 -- ones that are not remotely dispatching.
1185 if Chars (Current_Primitive) /= Name_uSize
1186 and then Chars (Current_Primitive) /= Name_uAlignment
1187 and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize)
1189 -- The first thing to do is build an up-to-date copy of
1190 -- the spec with all the formals referencing Designated_Type
1191 -- transformed into formals referencing Stub_Type. Since this
1192 -- primitive may have been inherited, go back the alias chain
1193 -- until the real primitive has been found.
1195 Current_Primitive_Alias := Current_Primitive;
1196 while Present (Alias (Current_Primitive_Alias)) loop
1198 (Current_Primitive_Alias
1199 /= Alias (Current_Primitive_Alias));
1200 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
1203 Current_Primitive_Spec :=
1204 Copy_Specification (Loc,
1205 Spec => Parent (Current_Primitive_Alias),
1206 Object_Type => Designated_Type,
1207 Stub_Type => Stub_Elements.Stub_Type);
1209 Current_Primitive_Decl :=
1210 Make_Subprogram_Declaration (Loc,
1211 Specification => Current_Primitive_Spec);
1213 Insert_After (Current_Insertion_Node, Current_Primitive_Decl);
1214 Analyze (Current_Primitive_Decl);
1215 Current_Insertion_Node := Current_Primitive_Decl;
1217 Possibly_Asynchronous :=
1218 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1219 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1221 Assign_Subprogram_Identifier (
1222 Defining_Unit_Name (Current_Primitive_Spec),
1223 Current_Primitive_Number,
1226 Current_Primitive_Body :=
1227 Build_Subprogram_Calling_Stubs
1228 (Vis_Decl => Current_Primitive_Decl,
1230 Build_Subprogram_Id (Loc,
1231 Defining_Unit_Name (Current_Primitive_Spec)),
1232 Asynchronous => Possibly_Asynchronous,
1233 Dynamically_Asynchronous => Possibly_Asynchronous,
1234 Stub_Type => Stub_Elements.Stub_Type,
1235 RACW_Type => Stub_Elements.RACW_Type);
1236 Append_To (Decls, Current_Primitive_Body);
1238 -- Analyzing the body here would cause the Stub type to be
1239 -- frozen, thus preventing subsequent primitive declarations.
1240 -- For this reason, it will be analyzed later in the
1243 -- Build the receiver stubs
1246 Current_Receiver_Body :=
1247 Specific_Build_Subprogram_Receiving_Stubs
1248 (Vis_Decl => Current_Primitive_Decl,
1249 Asynchronous => Possibly_Asynchronous,
1250 Dynamically_Asynchronous => Possibly_Asynchronous,
1251 Stub_Type => Stub_Elements.Stub_Type,
1252 RACW_Type => Stub_Elements.RACW_Type,
1253 Parent_Primitive => Current_Primitive);
1255 Current_Receiver := Defining_Unit_Name (
1256 Specification (Current_Receiver_Body));
1258 Append_To (Decls, Current_Receiver_Body);
1260 -- Add a case alternative to the receiver
1262 if Get_PCS_Name = Name_PolyORB_DSA then
1263 Append_To (RPC_Receiver_Elsif_Parts,
1264 Make_Elsif_Part (Loc,
1266 Make_Function_Call (Loc,
1269 RTE (RE_Caseless_String_Eq), Loc),
1270 Parameter_Associations => New_List (
1271 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1272 Make_String_Literal (Loc, Subp_Str))),
1273 Then_Statements => New_List (
1274 Make_Assignment_Statement (Loc,
1275 Name => New_Occurrence_Of (
1276 RPC_Receiver_Subp_Index, Loc),
1278 Make_Integer_Literal (Loc,
1279 Current_Primitive_Number)))));
1282 Append_To (RPC_Receiver_Case_Alternatives,
1283 Make_Case_Statement_Alternative (Loc,
1284 Discrete_Choices => New_List (
1285 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1287 Statements => New_List (
1288 Make_Procedure_Call_Statement (Loc,
1290 New_Occurrence_Of (Current_Receiver, Loc),
1291 Parameter_Associations => New_List (
1292 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1295 -- Increment the index of current primitive
1297 Current_Primitive_Number := Current_Primitive_Number + 1;
1300 Next_Elmt (Current_Primitive_Elmt);
1304 -- Build the case statement and the heart of the subprogram
1307 if Get_PCS_Name = Name_PolyORB_DSA
1308 and then Present (First (RPC_Receiver_Elsif_Parts))
1310 Append_To (RPC_Receiver_Statements,
1311 Make_Implicit_If_Statement (Designated_Type,
1312 Condition => New_Occurrence_Of (Standard_False, Loc),
1313 Then_Statements => New_List,
1314 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1317 Append_To (RPC_Receiver_Case_Alternatives,
1318 Make_Case_Statement_Alternative (Loc,
1319 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1320 Statements => New_List (Make_Null_Statement (Loc))));
1322 Append_To (RPC_Receiver_Statements,
1323 Make_Case_Statement (Loc,
1325 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1326 Alternatives => RPC_Receiver_Case_Alternatives));
1328 Append_To (Decls, RPC_Receiver_Decl);
1329 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1330 Decls, RPC_Receiver, Stub_Elements);
1333 -- Do not analyze RPC receiver at this stage since it will otherwise
1334 -- reference subprograms that have not been analyzed yet. It will
1335 -- be analyzed in the regular flow.
1337 end Add_RACW_Primitive_Declarations_And_Bodies;
1339 -----------------------------
1340 -- Add_RAS_Dereference_TSS --
1341 -----------------------------
1343 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1344 Loc : constant Source_Ptr := Sloc (N);
1346 Type_Def : constant Node_Id := Type_Definition (N);
1348 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1349 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1350 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1351 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1353 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
1354 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1356 RACW_Primitive_Name : Node_Id;
1358 Proc : constant Entity_Id :=
1359 Make_Defining_Identifier (Loc,
1360 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1362 Proc_Spec : Node_Id;
1363 Param_Specs : List_Id;
1364 Param_Assoc : constant List_Id := New_List;
1365 Stmts : constant List_Id := New_List;
1367 RAS_Parameter : constant Entity_Id :=
1368 Make_Defining_Identifier (Loc,
1369 Chars => New_Internal_Name ('P'));
1371 Is_Function : constant Boolean :=
1372 Nkind (Type_Def) = N_Access_Function_Definition;
1374 Is_Degenerate : Boolean;
1375 -- Set to True if the subprogram_specification for this RAS has
1376 -- an anonymous access parameter (see Process_Remote_AST_Declaration).
1378 Spec : constant Node_Id := Type_Def;
1380 Current_Parameter : Node_Id;
1382 -- Start of processing for Add_RAS_Dereference_TSS
1385 -- The Dereference TSS for a remote access-to-subprogram type
1388 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1391 -- This is called whenever a value of a RAS type is dereferenced
1393 -- First construct a list of parameter specifications:
1395 -- The first formal is the RAS values
1397 Param_Specs := New_List (
1398 Make_Parameter_Specification (Loc,
1399 Defining_Identifier => RAS_Parameter,
1402 New_Occurrence_Of (Fat_Type, Loc)));
1404 -- The following formals are copied from the type declaration
1406 Is_Degenerate := False;
1407 Current_Parameter := First (Parameter_Specifications (Type_Def));
1408 Parameters : while Present (Current_Parameter) loop
1409 if Nkind (Parameter_Type (Current_Parameter))
1410 = N_Access_Definition
1412 Is_Degenerate := True;
1414 Append_To (Param_Specs,
1415 Make_Parameter_Specification (Loc,
1416 Defining_Identifier =>
1417 Make_Defining_Identifier (Loc,
1418 Chars => Chars (Defining_Identifier (Current_Parameter))),
1419 In_Present => In_Present (Current_Parameter),
1420 Out_Present => Out_Present (Current_Parameter),
1422 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1424 New_Copy_Tree (Expression (Current_Parameter))));
1426 Append_To (Param_Assoc,
1427 Make_Identifier (Loc,
1428 Chars => Chars (Defining_Identifier (Current_Parameter))));
1430 Next (Current_Parameter);
1431 end loop Parameters;
1433 if Is_Degenerate then
1434 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1436 -- Generate a dummy body. This code will never actually be executed,
1437 -- because null is the only legal value for a degenerate RAS type.
1438 -- For legality's sake (in order to avoid generating a function
1439 -- that does not contain a return statement), we include a dummy
1440 -- recursive call on the TSS itself.
1443 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1444 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1447 -- For a normal RAS type, we cast the RAS formal to the corresponding
1448 -- tagged type, and perform a dispatching call to its Call
1449 -- primitive operation.
1451 Prepend_To (Param_Assoc,
1452 Unchecked_Convert_To (RACW_Type,
1453 New_Occurrence_Of (RAS_Parameter, Loc)));
1455 RACW_Primitive_Name := Make_Selected_Component (Loc,
1456 Prefix => Scope (RACW_Type),
1457 Selector_Name => Name_Call);
1462 Make_Return_Statement (Loc,
1464 Make_Function_Call (Loc,
1466 RACW_Primitive_Name,
1467 Parameter_Associations => Param_Assoc)));
1471 Make_Procedure_Call_Statement (Loc,
1473 RACW_Primitive_Name,
1474 Parameter_Associations => Param_Assoc));
1477 -- Build the complete subprogram
1481 Make_Function_Specification (Loc,
1482 Defining_Unit_Name => Proc,
1483 Parameter_Specifications => Param_Specs,
1484 Result_Definition =>
1486 Entity (Result_Definition (Spec)), Loc));
1488 Set_Ekind (Proc, E_Function);
1490 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1494 Make_Procedure_Specification (Loc,
1495 Defining_Unit_Name => Proc,
1496 Parameter_Specifications => Param_Specs);
1498 Set_Ekind (Proc, E_Procedure);
1499 Set_Etype (Proc, Standard_Void_Type);
1503 Make_Subprogram_Body (Loc,
1504 Specification => Proc_Spec,
1505 Declarations => New_List,
1506 Handled_Statement_Sequence =>
1507 Make_Handled_Sequence_Of_Statements (Loc,
1508 Statements => Stmts)));
1510 Set_TSS (Fat_Type, Proc);
1511 end Add_RAS_Dereference_TSS;
1513 -------------------------------
1514 -- Add_RAS_Proxy_And_Analyze --
1515 -------------------------------
1517 procedure Add_RAS_Proxy_And_Analyze
1520 All_Calls_Remote_E : Entity_Id;
1521 Proxy_Object_Addr : out Entity_Id)
1523 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1525 Subp_Name : constant Entity_Id :=
1526 Defining_Unit_Name (Specification (Vis_Decl));
1528 Pkg_Name : constant Entity_Id :=
1529 Make_Defining_Identifier (Loc,
1531 New_External_Name (Chars (Subp_Name), 'P', -1));
1533 Proxy_Type : constant Entity_Id :=
1534 Make_Defining_Identifier (Loc,
1537 Related_Id => Chars (Subp_Name),
1540 Proxy_Type_Full_View : constant Entity_Id :=
1541 Make_Defining_Identifier (Loc,
1542 Chars (Proxy_Type));
1544 Subp_Decl_Spec : constant Node_Id :=
1545 Build_RAS_Primitive_Specification
1546 (Subp_Spec => Specification (Vis_Decl),
1547 Remote_Object_Type => Proxy_Type);
1549 Subp_Body_Spec : constant Node_Id :=
1550 Build_RAS_Primitive_Specification
1551 (Subp_Spec => Specification (Vis_Decl),
1552 Remote_Object_Type => Proxy_Type);
1554 Vis_Decls : constant List_Id := New_List;
1555 Pvt_Decls : constant List_Id := New_List;
1556 Actuals : constant List_Id := New_List;
1558 Perform_Call : Node_Id;
1561 -- type subpP is tagged limited private;
1563 Append_To (Vis_Decls,
1564 Make_Private_Type_Declaration (Loc,
1565 Defining_Identifier => Proxy_Type,
1566 Tagged_Present => True,
1567 Limited_Present => True));
1569 -- [subprogram] Call
1570 -- (Self : access subpP;
1571 -- ...other-formals...)
1574 Append_To (Vis_Decls,
1575 Make_Subprogram_Declaration (Loc,
1576 Specification => Subp_Decl_Spec));
1578 -- A : constant System.Address;
1580 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1582 Append_To (Vis_Decls,
1583 Make_Object_Declaration (Loc,
1584 Defining_Identifier =>
1588 Object_Definition =>
1589 New_Occurrence_Of (RTE (RE_Address), Loc)));
1593 -- type subpP is tagged limited record
1594 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1598 Append_To (Pvt_Decls,
1599 Make_Full_Type_Declaration (Loc,
1600 Defining_Identifier =>
1601 Proxy_Type_Full_View,
1603 Build_Remote_Subprogram_Proxy_Type (Loc,
1604 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1606 -- Trick semantic analysis into swapping the public and
1607 -- full view when freezing the public view.
1609 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1612 -- (Self : access O;
1613 -- ...other-formals...) is
1615 -- P (...other-formals...);
1619 -- (Self : access O;
1620 -- ...other-formals...)
1623 -- return F (...other-formals...);
1626 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1628 Make_Procedure_Call_Statement (Loc,
1630 New_Occurrence_Of (Subp_Name, Loc),
1631 Parameter_Associations =>
1635 Make_Return_Statement (Loc,
1637 Make_Function_Call (Loc,
1639 New_Occurrence_Of (Subp_Name, Loc),
1640 Parameter_Associations =>
1644 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1645 pragma Assert (Present (Formal));
1648 exit when No (Formal);
1650 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1653 -- O : aliased subpP;
1655 Append_To (Pvt_Decls,
1656 Make_Object_Declaration (Loc,
1657 Defining_Identifier =>
1658 Make_Defining_Identifier (Loc,
1662 Object_Definition =>
1663 New_Occurrence_Of (Proxy_Type, Loc)));
1665 -- A : constant System.Address := O'Address;
1667 Append_To (Pvt_Decls,
1668 Make_Object_Declaration (Loc,
1669 Defining_Identifier =>
1670 Make_Defining_Identifier (Loc,
1671 Chars (Proxy_Object_Addr)),
1674 Object_Definition =>
1675 New_Occurrence_Of (RTE (RE_Address), Loc),
1677 Make_Attribute_Reference (Loc,
1678 Prefix => New_Occurrence_Of (
1679 Defining_Identifier (Last (Pvt_Decls)), Loc),
1684 Make_Package_Declaration (Loc,
1685 Specification => Make_Package_Specification (Loc,
1686 Defining_Unit_Name => Pkg_Name,
1687 Visible_Declarations => Vis_Decls,
1688 Private_Declarations => Pvt_Decls,
1689 End_Label => Empty)));
1690 Analyze (Last (Decls));
1693 Make_Package_Body (Loc,
1694 Defining_Unit_Name =>
1695 Make_Defining_Identifier (Loc,
1697 Declarations => New_List (
1698 Make_Subprogram_Body (Loc,
1701 Declarations => New_List,
1702 Handled_Statement_Sequence =>
1703 Make_Handled_Sequence_Of_Statements (Loc,
1704 Statements => New_List (Perform_Call))))));
1705 Analyze (Last (Decls));
1706 end Add_RAS_Proxy_And_Analyze;
1708 -----------------------
1709 -- Add_RAST_Features --
1710 -----------------------
1712 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1713 RAS_Type : constant Entity_Id :=
1714 Equivalent_Type (Defining_Identifier (Vis_Decl));
1716 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1717 Add_RAS_Dereference_TSS (Vis_Decl);
1718 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1719 end Add_RAST_Features;
1725 procedure Add_Stub_Type
1726 (Designated_Type : Entity_Id;
1727 RACW_Type : Entity_Id;
1729 Stub_Type : out Entity_Id;
1730 Stub_Type_Access : out Entity_Id;
1731 RPC_Receiver_Decl : out Node_Id;
1732 Existing : out Boolean)
1734 Loc : constant Source_Ptr := Sloc (RACW_Type);
1736 Stub_Elements : constant Stub_Structure :=
1737 Stubs_Table.Get (Designated_Type);
1738 Stub_Type_Decl : Node_Id;
1739 Stub_Type_Access_Decl : Node_Id;
1742 if Stub_Elements /= Empty_Stub_Structure then
1743 Stub_Type := Stub_Elements.Stub_Type;
1744 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1745 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1752 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1754 Make_Defining_Identifier (Loc,
1756 Related_Id => Chars (Stub_Type),
1759 Specific_Build_Stub_Type (
1760 RACW_Type, Stub_Type,
1761 Stub_Type_Decl, RPC_Receiver_Decl);
1763 Stub_Type_Access_Decl :=
1764 Make_Full_Type_Declaration (Loc,
1765 Defining_Identifier => Stub_Type_Access,
1767 Make_Access_To_Object_Definition (Loc,
1768 All_Present => True,
1769 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1771 Append_To (Decls, Stub_Type_Decl);
1772 Analyze (Last (Decls));
1773 Append_To (Decls, Stub_Type_Access_Decl);
1774 Analyze (Last (Decls));
1776 -- This is in no way a type derivation, but we fake it to make
1777 -- sure that the dispatching table gets built with the corresponding
1778 -- primitive operations at the right place.
1780 Derive_Subprograms (Parent_Type => Designated_Type,
1781 Derived_Type => Stub_Type);
1783 if Present (RPC_Receiver_Decl) then
1784 Append_To (Decls, RPC_Receiver_Decl);
1786 RPC_Receiver_Decl := Last (Decls);
1789 Stubs_Table.Set (Designated_Type,
1790 (Stub_Type => Stub_Type,
1791 Stub_Type_Access => Stub_Type_Access,
1792 RPC_Receiver_Decl => RPC_Receiver_Decl,
1793 RACW_Type => RACW_Type));
1796 ----------------------------------
1797 -- Assign_Subprogram_Identifier --
1798 ----------------------------------
1800 procedure Assign_Subprogram_Identifier
1805 N : constant Name_Id := Chars (Def);
1807 Overload_Order : constant Int :=
1808 Overload_Counter_Table.Get (N) + 1;
1811 Overload_Counter_Table.Set (N, Overload_Order);
1813 Get_Name_String (N);
1815 -- Homonym handling: as in Exp_Dbug, but much simpler,
1816 -- because the only entities for which we have to generate
1817 -- names here need only to be disambiguated within their
1820 if Overload_Order > 1 then
1821 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
1822 Name_Len := Name_Len + 2;
1823 Add_Nat_To_Name_Buffer (Overload_Order);
1826 Id := String_From_Name_Buffer;
1827 Subprogram_Identifier_Table.Set (Def,
1828 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
1829 end Assign_Subprogram_Identifier;
1831 ------------------------------
1832 -- Build_Get_Unique_RP_Call --
1833 ------------------------------
1835 function Build_Get_Unique_RP_Call
1837 Pointer : Entity_Id;
1838 Stub_Type : Entity_Id) return List_Id
1842 Make_Procedure_Call_Statement (Loc,
1844 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
1845 Parameter_Associations => New_List (
1846 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
1847 New_Occurrence_Of (Pointer, Loc)))),
1849 Make_Assignment_Statement (Loc,
1851 Make_Selected_Component (Loc,
1853 New_Occurrence_Of (Pointer, Loc),
1855 New_Occurrence_Of (First_Tag_Component
1856 (Designated_Type (Etype (Pointer))), Loc)),
1858 Make_Attribute_Reference (Loc,
1860 New_Occurrence_Of (Stub_Type, Loc),
1864 -- Note: The assignment to Pointer._Tag is safe here because
1865 -- we carefully ensured that Stub_Type has exactly the same layout
1866 -- as System.Partition_Interface.RACW_Stub_Type.
1868 end Build_Get_Unique_RP_Call;
1870 -----------------------------------
1871 -- Build_Ordered_Parameters_List --
1872 -----------------------------------
1874 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
1875 Constrained_List : List_Id;
1876 Unconstrained_List : List_Id;
1877 Current_Parameter : Node_Id;
1879 First_Parameter : Node_Id;
1880 For_RAS : Boolean := False;
1883 if No (Parameter_Specifications (Spec)) then
1887 Constrained_List := New_List;
1888 Unconstrained_List := New_List;
1889 First_Parameter := First (Parameter_Specifications (Spec));
1891 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
1892 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
1897 -- Loop through the parameters and add them to the right list
1899 Current_Parameter := First_Parameter;
1900 while Present (Current_Parameter) loop
1901 if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
1903 Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
1905 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
1906 and then not (For_RAS and then Current_Parameter = First_Parameter)
1908 Append_To (Constrained_List, New_Copy (Current_Parameter));
1910 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
1913 Next (Current_Parameter);
1916 -- Unconstrained parameters are returned first
1918 Append_List_To (Unconstrained_List, Constrained_List);
1920 return Unconstrained_List;
1921 end Build_Ordered_Parameters_List;
1923 ----------------------------------
1924 -- Build_Passive_Partition_Stub --
1925 ----------------------------------
1927 procedure Build_Passive_Partition_Stub (U : Node_Id) is
1929 Pkg_Name : String_Id;
1932 Loc : constant Source_Ptr := Sloc (U);
1935 -- Verify that the implementation supports distribution, by accessing
1936 -- a type defined in the proper version of system.rpc
1939 Dist_OK : Entity_Id;
1940 pragma Warnings (Off, Dist_OK);
1942 Dist_OK := RTE (RE_Params_Stream_Type);
1945 -- Use body if present, spec otherwise
1947 if Nkind (U) = N_Package_Declaration then
1948 Pkg_Spec := Specification (U);
1949 L := Visible_Declarations (Pkg_Spec);
1951 Pkg_Spec := Parent (Corresponding_Spec (U));
1952 L := Declarations (U);
1955 Get_Library_Unit_Name_String (Pkg_Spec);
1956 Pkg_Name := String_From_Name_Buffer;
1958 Make_Procedure_Call_Statement (Loc,
1960 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
1961 Parameter_Associations => New_List (
1962 Make_String_Literal (Loc, Pkg_Name),
1963 Make_Attribute_Reference (Loc,
1965 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
1970 end Build_Passive_Partition_Stub;
1972 --------------------------------------
1973 -- Build_RPC_Receiver_Specification --
1974 --------------------------------------
1976 function Build_RPC_Receiver_Specification
1977 (RPC_Receiver : Entity_Id;
1978 Request_Parameter : Entity_Id) return Node_Id
1980 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
1983 Make_Procedure_Specification (Loc,
1984 Defining_Unit_Name => RPC_Receiver,
1985 Parameter_Specifications => New_List (
1986 Make_Parameter_Specification (Loc,
1987 Defining_Identifier => Request_Parameter,
1989 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
1990 end Build_RPC_Receiver_Specification;
1992 ----------------------------------------
1993 -- Build_Remote_Subprogram_Proxy_Type --
1994 ----------------------------------------
1996 function Build_Remote_Subprogram_Proxy_Type
1998 ACR_Expression : Node_Id) return Node_Id
2002 Make_Record_Definition (Loc,
2003 Tagged_Present => True,
2004 Limited_Present => True,
2006 Make_Component_List (Loc,
2008 Component_Items => New_List (
2009 Make_Component_Declaration (Loc,
2010 Defining_Identifier =>
2011 Make_Defining_Identifier (Loc,
2012 Name_All_Calls_Remote),
2013 Component_Definition =>
2014 Make_Component_Definition (Loc,
2015 Subtype_Indication =>
2016 New_Occurrence_Of (Standard_Boolean, Loc)),
2020 Make_Component_Declaration (Loc,
2021 Defining_Identifier =>
2022 Make_Defining_Identifier (Loc,
2024 Component_Definition =>
2025 Make_Component_Definition (Loc,
2026 Subtype_Indication =>
2027 New_Occurrence_Of (RTE (RE_Address), Loc)),
2029 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2031 Make_Component_Declaration (Loc,
2032 Defining_Identifier =>
2033 Make_Defining_Identifier (Loc,
2035 Component_Definition =>
2036 Make_Component_Definition (Loc,
2037 Subtype_Indication =>
2038 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2039 end Build_Remote_Subprogram_Proxy_Type;
2041 ------------------------------------
2042 -- Build_Subprogram_Calling_Stubs --
2043 ------------------------------------
2045 function Build_Subprogram_Calling_Stubs
2046 (Vis_Decl : Node_Id;
2048 Asynchronous : Boolean;
2049 Dynamically_Asynchronous : Boolean := False;
2050 Stub_Type : Entity_Id := Empty;
2051 RACW_Type : Entity_Id := Empty;
2052 Locator : Entity_Id := Empty;
2053 New_Name : Name_Id := No_Name) return Node_Id
2055 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2057 Decls : constant List_Id := New_List;
2058 Statements : constant List_Id := New_List;
2060 Subp_Spec : Node_Id;
2061 -- The specification of the body
2063 Controlling_Parameter : Entity_Id := Empty;
2065 Asynchronous_Expr : Node_Id := Empty;
2067 RCI_Locator : Entity_Id;
2069 Spec_To_Use : Node_Id;
2071 procedure Insert_Partition_Check (Parameter : Node_Id);
2072 -- Check that the parameter has been elaborated on the same partition
2073 -- than the controlling parameter (E.4(19)).
2075 ----------------------------
2076 -- Insert_Partition_Check --
2077 ----------------------------
2079 procedure Insert_Partition_Check (Parameter : Node_Id) is
2080 Parameter_Entity : constant Entity_Id :=
2081 Defining_Identifier (Parameter);
2083 -- The expression that will be built is of the form:
2085 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2086 -- raise Constraint_Error;
2089 -- We do not check that Parameter is in Stub_Type since such a check
2090 -- has been inserted at the point of call already (a tag check since
2091 -- we have multiple controlling operands).
2094 Make_Raise_Constraint_Error (Loc,
2098 Make_Function_Call (Loc,
2100 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2101 Parameter_Associations =>
2103 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2104 New_Occurrence_Of (Parameter_Entity, Loc)),
2105 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2106 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2107 Reason => CE_Partition_Check_Failed));
2108 end Insert_Partition_Check;
2110 -- Start of processing for Build_Subprogram_Calling_Stubs
2113 Subp_Spec := Copy_Specification (Loc,
2114 Spec => Specification (Vis_Decl),
2115 New_Name => New_Name);
2117 if Locator = Empty then
2118 RCI_Locator := RCI_Cache;
2119 Spec_To_Use := Specification (Vis_Decl);
2121 RCI_Locator := Locator;
2122 Spec_To_Use := Subp_Spec;
2125 -- Find a controlling argument if we have a stub type. Also check
2126 -- if this subprogram can be made asynchronous.
2128 if Present (Stub_Type)
2129 and then Present (Parameter_Specifications (Spec_To_Use))
2132 Current_Parameter : Node_Id :=
2133 First (Parameter_Specifications
2136 while Present (Current_Parameter) loop
2138 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2140 if Controlling_Parameter = Empty then
2141 Controlling_Parameter :=
2142 Defining_Identifier (Current_Parameter);
2144 Insert_Partition_Check (Current_Parameter);
2148 Next (Current_Parameter);
2153 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2155 if Dynamically_Asynchronous then
2156 Asynchronous_Expr := Make_Selected_Component (Loc,
2157 Prefix => Controlling_Parameter,
2158 Selector_Name => Name_Asynchronous);
2161 Specific_Build_General_Calling_Stubs
2163 Statements => Statements,
2164 Target => Specific_Build_Stub_Target (Loc,
2165 Decls, RCI_Locator, Controlling_Parameter),
2166 Subprogram_Id => Subp_Id,
2167 Asynchronous => Asynchronous_Expr,
2168 Is_Known_Asynchronous => Asynchronous
2169 and then not Dynamically_Asynchronous,
2170 Is_Known_Non_Asynchronous
2172 and then not Dynamically_Asynchronous,
2173 Is_Function => Nkind (Spec_To_Use) =
2174 N_Function_Specification,
2175 Spec => Spec_To_Use,
2176 Stub_Type => Stub_Type,
2177 RACW_Type => RACW_Type,
2180 RCI_Calling_Stubs_Table.Set
2181 (Defining_Unit_Name (Specification (Vis_Decl)),
2182 Defining_Unit_Name (Spec_To_Use));
2185 Make_Subprogram_Body (Loc,
2186 Specification => Subp_Spec,
2187 Declarations => Decls,
2188 Handled_Statement_Sequence =>
2189 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2190 end Build_Subprogram_Calling_Stubs;
2192 -------------------------
2193 -- Build_Subprogram_Id --
2194 -------------------------
2196 function Build_Subprogram_Id
2198 E : Entity_Id) return Node_Id
2201 case Get_PCS_Name is
2202 when Name_PolyORB_DSA =>
2203 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2205 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2207 end Build_Subprogram_Id;
2209 ------------------------
2210 -- Copy_Specification --
2211 ------------------------
2213 function Copy_Specification
2216 Object_Type : Entity_Id := Empty;
2217 Stub_Type : Entity_Id := Empty;
2218 New_Name : Name_Id := No_Name) return Node_Id
2220 Parameters : List_Id := No_List;
2222 Current_Parameter : Node_Id;
2223 Current_Identifier : Entity_Id;
2224 Current_Type : Node_Id;
2225 Current_Etype : Entity_Id;
2227 Name_For_New_Spec : Name_Id;
2229 New_Identifier : Entity_Id;
2231 -- Comments needed in body below ???
2234 if New_Name = No_Name then
2235 pragma Assert (Nkind (Spec) = N_Function_Specification
2236 or else Nkind (Spec) = N_Procedure_Specification);
2238 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2240 Name_For_New_Spec := New_Name;
2243 if Present (Parameter_Specifications (Spec)) then
2244 Parameters := New_List;
2245 Current_Parameter := First (Parameter_Specifications (Spec));
2246 while Present (Current_Parameter) loop
2247 Current_Identifier := Defining_Identifier (Current_Parameter);
2248 Current_Type := Parameter_Type (Current_Parameter);
2250 if Nkind (Current_Type) = N_Access_Definition then
2251 Current_Etype := Entity (Subtype_Mark (Current_Type));
2253 if Present (Object_Type) then
2255 Root_Type (Current_Etype) = Root_Type (Object_Type));
2257 Make_Access_Definition (Loc,
2258 Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc),
2259 Null_Exclusion_Present =>
2260 Null_Exclusion_Present (Current_Type));
2264 Make_Access_Definition (Loc,
2266 New_Occurrence_Of (Current_Etype, Loc),
2267 Null_Exclusion_Present =>
2268 Null_Exclusion_Present (Current_Type));
2272 Current_Etype := Entity (Current_Type);
2274 if Present (Object_Type)
2275 and then Current_Etype = Object_Type
2277 Current_Type := New_Occurrence_Of (Stub_Type, Loc);
2279 Current_Type := New_Occurrence_Of (Current_Etype, Loc);
2283 New_Identifier := Make_Defining_Identifier (Loc,
2284 Chars (Current_Identifier));
2286 Append_To (Parameters,
2287 Make_Parameter_Specification (Loc,
2288 Defining_Identifier => New_Identifier,
2289 Parameter_Type => Current_Type,
2290 In_Present => In_Present (Current_Parameter),
2291 Out_Present => Out_Present (Current_Parameter),
2293 New_Copy_Tree (Expression (Current_Parameter))));
2295 -- For a regular formal parameter (that needs to be marshalled
2296 -- in the context of remote calls), set the Etype now, because
2297 -- marshalling processing might need it.
2299 if Is_Entity_Name (Current_Type) then
2300 Set_Etype (New_Identifier, Entity (Current_Type));
2302 -- Current_Type is an access definition, special processing
2303 -- (not requiring etype) will occur for marshalling.
2309 Next (Current_Parameter);
2313 case Nkind (Spec) is
2315 when N_Function_Specification | N_Access_Function_Definition =>
2317 Make_Function_Specification (Loc,
2318 Defining_Unit_Name =>
2319 Make_Defining_Identifier (Loc,
2320 Chars => Name_For_New_Spec),
2321 Parameter_Specifications => Parameters,
2322 Result_Definition =>
2323 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2325 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2327 Make_Procedure_Specification (Loc,
2328 Defining_Unit_Name =>
2329 Make_Defining_Identifier (Loc,
2330 Chars => Name_For_New_Spec),
2331 Parameter_Specifications => Parameters);
2334 raise Program_Error;
2336 end Copy_Specification;
2338 ---------------------------
2339 -- Could_Be_Asynchronous --
2340 ---------------------------
2342 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2343 Current_Parameter : Node_Id;
2346 if Present (Parameter_Specifications (Spec)) then
2347 Current_Parameter := First (Parameter_Specifications (Spec));
2348 while Present (Current_Parameter) loop
2349 if Out_Present (Current_Parameter) then
2353 Next (Current_Parameter);
2358 end Could_Be_Asynchronous;
2360 ---------------------------
2361 -- Declare_Create_NVList --
2362 ---------------------------
2364 procedure Declare_Create_NVList
2372 Make_Object_Declaration (Loc,
2373 Defining_Identifier => NVList,
2374 Aliased_Present => False,
2375 Object_Definition =>
2376 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2379 Make_Procedure_Call_Statement (Loc,
2381 New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2382 Parameter_Associations => New_List (
2383 New_Occurrence_Of (NVList, Loc))));
2384 end Declare_Create_NVList;
2386 ---------------------------------------------
2387 -- Expand_All_Calls_Remote_Subprogram_Call --
2388 ---------------------------------------------
2390 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2391 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2392 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2393 Loc : constant Source_Ptr := Sloc (N);
2394 RCI_Locator : Node_Id;
2395 RCI_Cache : Entity_Id;
2396 Calling_Stubs : Node_Id;
2397 E_Calling_Stubs : Entity_Id;
2400 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2402 if E_Calling_Stubs = Empty then
2403 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2405 if RCI_Cache = Empty then
2408 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2409 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2411 -- The RCI_Locator package is inserted at the top level in the
2412 -- current unit, and must appear in the proper scope, so that it
2413 -- is not prematurely removed by the GCC back-end.
2416 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2419 if Ekind (Scop) = E_Package_Body then
2420 New_Scope (Spec_Entity (Scop));
2422 elsif Ekind (Scop) = E_Subprogram_Body then
2424 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2430 Analyze (RCI_Locator);
2434 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2437 RCI_Locator := Parent (RCI_Cache);
2440 Calling_Stubs := Build_Subprogram_Calling_Stubs
2441 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2443 Build_Subprogram_Id (Loc, Called_Subprogram),
2444 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2446 Is_Asynchronous (Called_Subprogram),
2447 Locator => RCI_Cache,
2448 New_Name => New_Internal_Name ('S'));
2449 Insert_After (RCI_Locator, Calling_Stubs);
2450 Analyze (Calling_Stubs);
2451 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2454 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2455 end Expand_All_Calls_Remote_Subprogram_Call;
2457 ---------------------------------
2458 -- Expand_Calling_Stubs_Bodies --
2459 ---------------------------------
2461 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2462 Spec : constant Node_Id := Specification (Unit_Node);
2463 Decls : constant List_Id := Visible_Declarations (Spec);
2465 New_Scope (Scope_Of_Spec (Spec));
2466 Add_Calling_Stubs_To_Declarations
2467 (Specification (Unit_Node), Decls);
2469 end Expand_Calling_Stubs_Bodies;
2471 -----------------------------------
2472 -- Expand_Receiving_Stubs_Bodies --
2473 -----------------------------------
2475 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2481 if Nkind (Unit_Node) = N_Package_Declaration then
2482 Spec := Specification (Unit_Node);
2483 Decls := Private_Declarations (Spec);
2486 Decls := Visible_Declarations (Spec);
2489 New_Scope (Scope_Of_Spec (Spec));
2490 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls);
2494 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2495 Decls := Declarations (Unit_Node);
2496 New_Scope (Scope_Of_Spec (Unit_Node));
2498 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp);
2499 Insert_List_Before (First (Decls), Temp);
2503 end Expand_Receiving_Stubs_Bodies;
2505 --------------------
2506 -- GARLIC_Support --
2507 --------------------
2509 package body GARLIC_Support is
2511 -- Local subprograms
2513 procedure Add_RACW_Read_Attribute
2514 (RACW_Type : Entity_Id;
2515 Stub_Type : Entity_Id;
2516 Stub_Type_Access : Entity_Id;
2517 Declarations : List_Id);
2518 -- Add Read attribute in Decls for the RACW type. The Read attribute
2519 -- is added right after the RACW_Type declaration while the body is
2520 -- inserted after Declarations.
2522 procedure Add_RACW_Write_Attribute
2523 (RACW_Type : Entity_Id;
2524 Stub_Type : Entity_Id;
2525 Stub_Type_Access : Entity_Id;
2526 RPC_Receiver : Node_Id;
2527 Declarations : List_Id);
2528 -- Same thing for the Write attribute
2530 function Stream_Parameter return Node_Id;
2531 function Result return Node_Id;
2532 function Object return Node_Id renames Result;
2533 -- Functions to create occurrences of the formal parameter names of
2534 -- the 'Read and 'Write attributes.
2537 -- Shared source location used by Add_{Read,Write}_Read_Attribute
2538 -- and their ancillary subroutines (set on entry by Add_RACW_Features).
2540 procedure Add_RAS_Access_TSS (N : Node_Id);
2541 -- Add a subprogram body for RAS Access TSS
2543 -------------------------------------
2544 -- Add_Obj_RPC_Receiver_Completion --
2545 -------------------------------------
2547 procedure Add_Obj_RPC_Receiver_Completion
2550 RPC_Receiver : Entity_Id;
2551 Stub_Elements : Stub_Structure) is
2553 -- The RPC receiver body should not be the completion of the
2554 -- declaration recorded in the stub structure, because then the
2555 -- occurrences of the formal parameters within the body should
2556 -- refer to the entities from the declaration, not from the
2557 -- completion, to which we do not have easy access. Instead, the
2558 -- RPC receiver body acts as its own declaration, and the RPC
2559 -- receiver declaration is completed by a renaming-as-body.
2562 Make_Subprogram_Renaming_Declaration (Loc,
2564 Copy_Specification (Loc,
2565 Specification (Stub_Elements.RPC_Receiver_Decl)),
2566 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2567 end Add_Obj_RPC_Receiver_Completion;
2569 -----------------------
2570 -- Add_RACW_Features --
2571 -----------------------
2573 procedure Add_RACW_Features
2574 (RACW_Type : Entity_Id;
2575 Stub_Type : Entity_Id;
2576 Stub_Type_Access : Entity_Id;
2577 RPC_Receiver_Decl : Node_Id;
2578 Declarations : List_Id)
2580 RPC_Receiver : Node_Id;
2581 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2584 Loc := Sloc (RACW_Type);
2588 -- For a RAS, the RPC receiver is that of the RCI unit,
2589 -- not that of the corresponding distributed object type.
2590 -- We retrieve its address from the local proxy object.
2592 RPC_Receiver := Make_Selected_Component (Loc,
2594 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2595 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2598 RPC_Receiver := Make_Attribute_Reference (Loc,
2599 Prefix => New_Occurrence_Of (
2600 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2601 Attribute_Name => Name_Address);
2604 Add_RACW_Write_Attribute (
2611 Add_RACW_Read_Attribute (
2616 end Add_RACW_Features;
2618 -----------------------------
2619 -- Add_RACW_Read_Attribute --
2620 -----------------------------
2622 procedure Add_RACW_Read_Attribute
2623 (RACW_Type : Entity_Id;
2624 Stub_Type : Entity_Id;
2625 Stub_Type_Access : Entity_Id;
2626 Declarations : List_Id)
2628 Proc_Decl : Node_Id;
2629 Attr_Decl : Node_Id;
2631 Body_Node : Node_Id;
2634 Statements : List_Id;
2635 Local_Statements : List_Id;
2636 Remote_Statements : List_Id;
2637 -- Various parts of the procedure
2639 Procedure_Name : constant Name_Id :=
2640 New_Internal_Name ('R');
2641 Source_Partition : constant Entity_Id :=
2642 Make_Defining_Identifier
2643 (Loc, New_Internal_Name ('P'));
2644 Source_Receiver : constant Entity_Id :=
2645 Make_Defining_Identifier
2646 (Loc, New_Internal_Name ('S'));
2647 Source_Address : constant Entity_Id :=
2648 Make_Defining_Identifier
2649 (Loc, New_Internal_Name ('P'));
2650 Local_Stub : constant Entity_Id :=
2651 Make_Defining_Identifier
2652 (Loc, New_Internal_Name ('L'));
2653 Stubbed_Result : constant Entity_Id :=
2654 Make_Defining_Identifier
2655 (Loc, New_Internal_Name ('S'));
2656 Asynchronous_Flag : constant Entity_Id :=
2657 Asynchronous_Flags_Table.Get (RACW_Type);
2658 pragma Assert (Present (Asynchronous_Flag));
2660 -- Start of processing for Add_RACW_Read_Attribute
2663 -- Generate object declarations
2666 Make_Object_Declaration (Loc,
2667 Defining_Identifier => Source_Partition,
2668 Object_Definition =>
2669 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
2671 Make_Object_Declaration (Loc,
2672 Defining_Identifier => Source_Receiver,
2673 Object_Definition =>
2674 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2676 Make_Object_Declaration (Loc,
2677 Defining_Identifier => Source_Address,
2678 Object_Definition =>
2679 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2681 Make_Object_Declaration (Loc,
2682 Defining_Identifier => Local_Stub,
2683 Aliased_Present => True,
2684 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
2686 Make_Object_Declaration (Loc,
2687 Defining_Identifier => Stubbed_Result,
2688 Object_Definition =>
2689 New_Occurrence_Of (Stub_Type_Access, Loc),
2691 Make_Attribute_Reference (Loc,
2693 New_Occurrence_Of (Local_Stub, Loc),
2695 Name_Unchecked_Access)));
2697 -- Read the source Partition_ID and RPC_Receiver from incoming stream
2699 Statements := New_List (
2700 Make_Attribute_Reference (Loc,
2702 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
2703 Attribute_Name => Name_Read,
2704 Expressions => New_List (
2706 New_Occurrence_Of (Source_Partition, Loc))),
2708 Make_Attribute_Reference (Loc,
2710 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2713 Expressions => New_List (
2715 New_Occurrence_Of (Source_Receiver, Loc))),
2717 Make_Attribute_Reference (Loc,
2719 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2722 Expressions => New_List (
2724 New_Occurrence_Of (Source_Address, Loc))));
2726 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
2728 Set_Etype (Stubbed_Result, Stub_Type_Access);
2730 -- If the Address is Null_Address, then return a null object
2732 Append_To (Statements,
2733 Make_Implicit_If_Statement (RACW_Type,
2736 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
2737 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
2738 Then_Statements => New_List (
2739 Make_Assignment_Statement (Loc,
2741 Expression => Make_Null (Loc)),
2742 Make_Return_Statement (Loc))));
2744 -- If the RACW denotes an object created on the current partition,
2745 -- Local_Statements will be executed. The real object will be used.
2747 Local_Statements := New_List (
2748 Make_Assignment_Statement (Loc,
2751 Unchecked_Convert_To (RACW_Type,
2752 OK_Convert_To (RTE (RE_Address),
2753 New_Occurrence_Of (Source_Address, Loc)))));
2755 -- If the object is located on another partition, then a stub object
2756 -- will be created with all the information needed to rebuild the
2757 -- real object at the other end.
2759 Remote_Statements := New_List (
2761 Make_Assignment_Statement (Loc,
2762 Name => Make_Selected_Component (Loc,
2763 Prefix => Stubbed_Result,
2764 Selector_Name => Name_Origin),
2766 New_Occurrence_Of (Source_Partition, Loc)),
2768 Make_Assignment_Statement (Loc,
2769 Name => Make_Selected_Component (Loc,
2770 Prefix => Stubbed_Result,
2771 Selector_Name => Name_Receiver),
2773 New_Occurrence_Of (Source_Receiver, Loc)),
2775 Make_Assignment_Statement (Loc,
2776 Name => Make_Selected_Component (Loc,
2777 Prefix => Stubbed_Result,
2778 Selector_Name => Name_Addr),
2780 New_Occurrence_Of (Source_Address, Loc)));
2782 Append_To (Remote_Statements,
2783 Make_Assignment_Statement (Loc,
2784 Name => Make_Selected_Component (Loc,
2785 Prefix => Stubbed_Result,
2786 Selector_Name => Name_Asynchronous),
2788 New_Occurrence_Of (Asynchronous_Flag, Loc)));
2790 Append_List_To (Remote_Statements,
2791 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
2792 -- ??? Issue with asynchronous calls here: the Asynchronous
2793 -- flag is set on the stub type if, and only if, the RACW type
2794 -- has a pragma Asynchronous. This is incorrect for RACWs that
2795 -- implement RAS types, because in that case the /designated
2796 -- subprogram/ (not the type) might be asynchronous, and
2797 -- that causes the stub to need to be asynchronous too.
2798 -- A solution is to transport a RAS as a struct containing
2799 -- a RACW and an asynchronous flag, and to properly alter
2800 -- the Asynchronous component in the stub type in the RAS's
2803 Append_To (Remote_Statements,
2804 Make_Assignment_Statement (Loc,
2806 Expression => Unchecked_Convert_To (RACW_Type,
2807 New_Occurrence_Of (Stubbed_Result, Loc))));
2809 -- Distinguish between the local and remote cases, and execute the
2810 -- appropriate piece of code.
2812 Append_To (Statements,
2813 Make_Implicit_If_Statement (RACW_Type,
2817 Make_Function_Call (Loc,
2818 Name => New_Occurrence_Of (
2819 RTE (RE_Get_Local_Partition_Id), Loc)),
2820 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
2821 Then_Statements => Local_Statements,
2822 Else_Statements => Remote_Statements));
2824 Build_Stream_Procedure
2825 (Loc, RACW_Type, Body_Node,
2826 Make_Defining_Identifier (Loc, Procedure_Name),
2827 Statements, Outp => True);
2828 Set_Declarations (Body_Node, Decls);
2830 Proc_Decl := Make_Subprogram_Declaration (Loc,
2831 Copy_Specification (Loc, Specification (Body_Node)));
2834 Make_Attribute_Definition_Clause (Loc,
2835 Name => New_Occurrence_Of (RACW_Type, Loc),
2839 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2841 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2842 Insert_After (Proc_Decl, Attr_Decl);
2843 Append_To (Declarations, Body_Node);
2844 end Add_RACW_Read_Attribute;
2846 ------------------------------
2847 -- Add_RACW_Write_Attribute --
2848 ------------------------------
2850 procedure Add_RACW_Write_Attribute
2851 (RACW_Type : Entity_Id;
2852 Stub_Type : Entity_Id;
2853 Stub_Type_Access : Entity_Id;
2854 RPC_Receiver : Node_Id;
2855 Declarations : List_Id)
2857 Body_Node : Node_Id;
2858 Proc_Decl : Node_Id;
2859 Attr_Decl : Node_Id;
2861 Statements : List_Id;
2862 Local_Statements : List_Id;
2863 Remote_Statements : List_Id;
2864 Null_Statements : List_Id;
2866 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
2869 -- Build the code fragment corresponding to the marshalling of a
2872 Local_Statements := New_List (
2874 Pack_Entity_Into_Stream_Access (Loc,
2875 Stream => Stream_Parameter,
2876 Object => RTE (RE_Get_Local_Partition_Id)),
2878 Pack_Node_Into_Stream_Access (Loc,
2879 Stream => Stream_Parameter,
2880 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2881 Etyp => RTE (RE_Unsigned_64)),
2883 Pack_Node_Into_Stream_Access (Loc,
2884 Stream => Stream_Parameter,
2885 Object => OK_Convert_To (RTE (RE_Unsigned_64),
2886 Make_Attribute_Reference (Loc,
2888 Make_Explicit_Dereference (Loc,
2890 Attribute_Name => Name_Address)),
2891 Etyp => RTE (RE_Unsigned_64)));
2893 -- Build the code fragment corresponding to the marshalling of
2896 Remote_Statements := New_List (
2898 Pack_Node_Into_Stream_Access (Loc,
2899 Stream => Stream_Parameter,
2901 Make_Selected_Component (Loc,
2902 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2905 Make_Identifier (Loc, Name_Origin)),
2906 Etyp => RTE (RE_Partition_ID)),
2908 Pack_Node_Into_Stream_Access (Loc,
2909 Stream => Stream_Parameter,
2911 Make_Selected_Component (Loc,
2912 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2915 Make_Identifier (Loc, Name_Receiver)),
2916 Etyp => RTE (RE_Unsigned_64)),
2918 Pack_Node_Into_Stream_Access (Loc,
2919 Stream => Stream_Parameter,
2921 Make_Selected_Component (Loc,
2922 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2925 Make_Identifier (Loc, Name_Addr)),
2926 Etyp => RTE (RE_Unsigned_64)));
2928 -- Build code fragment corresponding to marshalling of a null object
2930 Null_Statements := New_List (
2932 Pack_Entity_Into_Stream_Access (Loc,
2933 Stream => Stream_Parameter,
2934 Object => RTE (RE_Get_Local_Partition_Id)),
2936 Pack_Node_Into_Stream_Access (Loc,
2937 Stream => Stream_Parameter,
2938 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2939 Etyp => RTE (RE_Unsigned_64)),
2941 Pack_Node_Into_Stream_Access (Loc,
2942 Stream => Stream_Parameter,
2943 Object => Make_Integer_Literal (Loc, Uint_0),
2944 Etyp => RTE (RE_Unsigned_64)));
2946 Statements := New_List (
2947 Make_Implicit_If_Statement (RACW_Type,
2950 Left_Opnd => Object,
2951 Right_Opnd => Make_Null (Loc)),
2952 Then_Statements => Null_Statements,
2953 Elsif_Parts => New_List (
2954 Make_Elsif_Part (Loc,
2958 Make_Attribute_Reference (Loc,
2960 Attribute_Name => Name_Tag),
2962 Make_Attribute_Reference (Loc,
2963 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2964 Attribute_Name => Name_Tag)),
2965 Then_Statements => Remote_Statements)),
2966 Else_Statements => Local_Statements));
2968 Build_Stream_Procedure
2969 (Loc, RACW_Type, Body_Node,
2970 Make_Defining_Identifier (Loc, Procedure_Name),
2971 Statements, Outp => False);
2973 Proc_Decl := Make_Subprogram_Declaration (Loc,
2974 Copy_Specification (Loc, Specification (Body_Node)));
2977 Make_Attribute_Definition_Clause (Loc,
2978 Name => New_Occurrence_Of (RACW_Type, Loc),
2979 Chars => Name_Write,
2982 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2984 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2985 Insert_After (Proc_Decl, Attr_Decl);
2986 Append_To (Declarations, Body_Node);
2987 end Add_RACW_Write_Attribute;
2989 ------------------------
2990 -- Add_RAS_Access_TSS --
2991 ------------------------
2993 procedure Add_RAS_Access_TSS (N : Node_Id) is
2994 Loc : constant Source_Ptr := Sloc (N);
2996 Ras_Type : constant Entity_Id := Defining_Identifier (N);
2997 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
2998 -- Ras_Type is the access to subprogram type while Fat_Type is the
2999 -- corresponding record type.
3001 RACW_Type : constant Entity_Id :=
3002 Underlying_RACW_Type (Ras_Type);
3003 Desig : constant Entity_Id :=
3004 Etype (Designated_Type (RACW_Type));
3006 Stub_Elements : constant Stub_Structure :=
3007 Stubs_Table.Get (Desig);
3008 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3010 Proc : constant Entity_Id :=
3011 Make_Defining_Identifier (Loc,
3012 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3014 Proc_Spec : Node_Id;
3016 -- Formal parameters
3018 Package_Name : constant Entity_Id :=
3019 Make_Defining_Identifier (Loc,
3023 Subp_Id : constant Entity_Id :=
3024 Make_Defining_Identifier (Loc,
3026 -- Target subprogram
3028 Asynch_P : constant Entity_Id :=
3029 Make_Defining_Identifier (Loc,
3030 Chars => Name_Asynchronous);
3031 -- Is the procedure to which the 'Access applies asynchronous?
3033 All_Calls_Remote : constant Entity_Id :=
3034 Make_Defining_Identifier (Loc,
3035 Chars => Name_All_Calls_Remote);
3036 -- True if an All_Calls_Remote pragma applies to the RCI unit
3037 -- that contains the subprogram.
3039 -- Common local variables
3041 Proc_Decls : List_Id;
3042 Proc_Statements : List_Id;
3044 Origin : constant Entity_Id :=
3045 Make_Defining_Identifier (Loc,
3046 Chars => New_Internal_Name ('P'));
3048 -- Additional local variables for the local case
3050 Proxy_Addr : constant Entity_Id :=
3051 Make_Defining_Identifier (Loc,
3052 Chars => New_Internal_Name ('P'));
3054 -- Additional local variables for the remote case
3056 Local_Stub : constant Entity_Id :=
3057 Make_Defining_Identifier (Loc,
3058 Chars => New_Internal_Name ('L'));
3060 Stub_Ptr : constant Entity_Id :=
3061 Make_Defining_Identifier (Loc,
3062 Chars => New_Internal_Name ('S'));
3065 (Field_Name : Name_Id;
3066 Value : Node_Id) return Node_Id;
3067 -- Construct an assignment that sets the named component in the
3075 (Field_Name : Name_Id;
3076 Value : Node_Id) return Node_Id
3080 Make_Assignment_Statement (Loc,
3082 Make_Selected_Component (Loc,
3084 Selector_Name => Field_Name),
3085 Expression => Value);
3088 -- Start of processing for Add_RAS_Access_TSS
3091 Proc_Decls := New_List (
3093 -- Common declarations
3095 Make_Object_Declaration (Loc,
3096 Defining_Identifier => Origin,
3097 Constant_Present => True,
3098 Object_Definition =>
3099 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3101 Make_Function_Call (Loc,
3103 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3104 Parameter_Associations => New_List (
3105 New_Occurrence_Of (Package_Name, Loc)))),
3107 -- Declaration use only in the local case: proxy address
3109 Make_Object_Declaration (Loc,
3110 Defining_Identifier => Proxy_Addr,
3111 Object_Definition =>
3112 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3114 -- Declarations used only in the remote case: stub object and
3117 Make_Object_Declaration (Loc,
3118 Defining_Identifier => Local_Stub,
3119 Aliased_Present => True,
3120 Object_Definition =>
3121 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3123 Make_Object_Declaration (Loc,
3124 Defining_Identifier =>
3126 Object_Definition =>
3127 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3129 Make_Attribute_Reference (Loc,
3130 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3131 Attribute_Name => Name_Unchecked_Access)));
3133 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3134 -- Build_Get_Unique_RP_Call needs this information
3136 -- Note: Here we assume that the Fat_Type is a record
3137 -- containing just a pointer to a proxy or stub object.
3139 Proc_Statements := New_List (
3143 -- Get_RAS_Info (Pkg, Subp, PA);
3144 -- if Origin = Local_Partition_Id
3145 -- and then not All_Calls_Remote
3147 -- return Fat_Type!(PA);
3150 Make_Procedure_Call_Statement (Loc,
3152 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3153 Parameter_Associations => New_List (
3154 New_Occurrence_Of (Package_Name, Loc),
3155 New_Occurrence_Of (Subp_Id, Loc),
3156 New_Occurrence_Of (Proxy_Addr, Loc))),
3158 Make_Implicit_If_Statement (N,
3164 New_Occurrence_Of (Origin, Loc),
3166 Make_Function_Call (Loc,
3168 RTE (RE_Get_Local_Partition_Id), Loc))),
3171 New_Occurrence_Of (All_Calls_Remote, Loc))),
3172 Then_Statements => New_List (
3173 Make_Return_Statement (Loc,
3174 Unchecked_Convert_To (Fat_Type,
3175 OK_Convert_To (RTE (RE_Address),
3176 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3178 Set_Field (Name_Origin,
3179 New_Occurrence_Of (Origin, Loc)),
3181 Set_Field (Name_Receiver,
3182 Make_Function_Call (Loc,
3184 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3185 Parameter_Associations => New_List (
3186 New_Occurrence_Of (Package_Name, Loc)))),
3188 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3190 -- E.4.1(9) A remote call is asynchronous if it is a call to
3191 -- a procedure, or a call through a value of an access-to-procedure
3192 -- type, to which a pragma Asynchronous applies.
3194 -- Parameter Asynch_P is true when the procedure is asynchronous;
3195 -- Expression Asynch_T is true when the type is asynchronous.
3197 Set_Field (Name_Asynchronous,
3199 New_Occurrence_Of (Asynch_P, Loc),
3200 New_Occurrence_Of (Boolean_Literals (
3201 Is_Asynchronous (Ras_Type)), Loc))));
3203 Append_List_To (Proc_Statements,
3204 Build_Get_Unique_RP_Call
3205 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3207 -- Return the newly created value
3209 Append_To (Proc_Statements,
3210 Make_Return_Statement (Loc,
3212 Unchecked_Convert_To (Fat_Type,
3213 New_Occurrence_Of (Stub_Ptr, Loc))));
3216 Make_Function_Specification (Loc,
3217 Defining_Unit_Name => Proc,
3218 Parameter_Specifications => New_List (
3219 Make_Parameter_Specification (Loc,
3220 Defining_Identifier => Package_Name,
3222 New_Occurrence_Of (Standard_String, Loc)),
3224 Make_Parameter_Specification (Loc,
3225 Defining_Identifier => Subp_Id,
3227 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3229 Make_Parameter_Specification (Loc,
3230 Defining_Identifier => Asynch_P,
3232 New_Occurrence_Of (Standard_Boolean, Loc)),
3234 Make_Parameter_Specification (Loc,
3235 Defining_Identifier => All_Calls_Remote,
3237 New_Occurrence_Of (Standard_Boolean, Loc))),
3239 Result_Definition =>
3240 New_Occurrence_Of (Fat_Type, Loc));
3242 -- Set the kind and return type of the function to prevent
3243 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3245 Set_Ekind (Proc, E_Function);
3246 Set_Etype (Proc, Fat_Type);
3249 Make_Subprogram_Body (Loc,
3250 Specification => Proc_Spec,
3251 Declarations => Proc_Decls,
3252 Handled_Statement_Sequence =>
3253 Make_Handled_Sequence_Of_Statements (Loc,
3254 Statements => Proc_Statements)));
3256 Set_TSS (Fat_Type, Proc);
3257 end Add_RAS_Access_TSS;
3259 -----------------------
3260 -- Add_RAST_Features --
3261 -----------------------
3263 procedure Add_RAST_Features
3264 (Vis_Decl : Node_Id;
3265 RAS_Type : Entity_Id)
3267 pragma Warnings (Off);
3268 pragma Unreferenced (RAS_Type);
3269 pragma Warnings (On);
3271 Add_RAS_Access_TSS (Vis_Decl);
3272 end Add_RAST_Features;
3274 -----------------------------------------
3275 -- Add_Receiving_Stubs_To_Declarations --
3276 -----------------------------------------
3278 procedure Add_Receiving_Stubs_To_Declarations
3279 (Pkg_Spec : Node_Id;
3282 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3284 Request_Parameter : Node_Id;
3286 Pkg_RPC_Receiver : constant Entity_Id :=
3287 Make_Defining_Identifier (Loc,
3288 New_Internal_Name ('H'));
3289 Pkg_RPC_Receiver_Statements : List_Id;
3290 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3291 Pkg_RPC_Receiver_Body : Node_Id;
3292 -- A Pkg_RPC_Receiver is built to decode the request
3294 Lookup_RAS_Info : constant Entity_Id :=
3295 Make_Defining_Identifier (Loc,
3296 Chars => New_Internal_Name ('R'));
3297 -- A remote subprogram is created to allow peers to look up
3298 -- RAS information using subprogram ids.
3300 Subp_Id : Entity_Id;
3301 Subp_Index : Entity_Id;
3302 -- Subprogram_Id as read from the incoming stream
3304 Current_Declaration : Node_Id;
3305 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3306 Current_Stubs : Node_Id;
3308 Subp_Info_Array : constant Entity_Id :=
3309 Make_Defining_Identifier (Loc,
3310 Chars => New_Internal_Name ('I'));
3312 Subp_Info_List : constant List_Id := New_List;
3314 Register_Pkg_Actuals : constant List_Id := New_List;
3316 All_Calls_Remote_E : Entity_Id;
3317 Proxy_Object_Addr : Entity_Id;
3319 procedure Append_Stubs_To
3320 (RPC_Receiver_Cases : List_Id;
3322 Subprogram_Number : Int);
3323 -- Add one case to the specified RPC receiver case list
3324 -- associating Subprogram_Number with the subprogram declared
3325 -- by Declaration, for which we have receiving stubs in Stubs.
3327 ---------------------
3328 -- Append_Stubs_To --
3329 ---------------------
3331 procedure Append_Stubs_To
3332 (RPC_Receiver_Cases : List_Id;
3334 Subprogram_Number : Int)
3337 Append_To (RPC_Receiver_Cases,
3338 Make_Case_Statement_Alternative (Loc,
3340 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3343 Make_Procedure_Call_Statement (Loc,
3346 Defining_Entity (Stubs), Loc),
3347 Parameter_Associations => New_List (
3348 New_Occurrence_Of (Request_Parameter, Loc))))));
3349 end Append_Stubs_To;
3351 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3354 -- Building receiving stubs consist in several operations:
3356 -- - a package RPC receiver must be built. This subprogram
3357 -- will get a Subprogram_Id from the incoming stream
3358 -- and will dispatch the call to the right subprogram
3360 -- - a receiving stub for any subprogram visible in the package
3361 -- spec. This stub will read all the parameters from the stream,
3362 -- and put the result as well as the exception occurrence in the
3365 -- - a dummy package with an empty spec and a body made of an
3366 -- elaboration part, whose job is to register the receiving
3367 -- part of this RCI package on the name server. This is done
3368 -- by calling System.Partition_Interface.Register_Receiving_Stub
3370 Build_RPC_Receiver_Body (
3371 RPC_Receiver => Pkg_RPC_Receiver,
3372 Request => Request_Parameter,
3374 Subp_Index => Subp_Index,
3375 Stmts => Pkg_RPC_Receiver_Statements,
3376 Decl => Pkg_RPC_Receiver_Body);
3377 pragma Assert (Subp_Id = Subp_Index);
3379 -- A null subp_id denotes a call through a RAS, in which case the
3380 -- next Uint_64 element in the stream is the address of the local
3381 -- proxy object, from which we can retrieve the actual subprogram id.
3383 Append_To (Pkg_RPC_Receiver_Statements,
3384 Make_Implicit_If_Statement (Pkg_Spec,
3387 New_Occurrence_Of (Subp_Id, Loc),
3388 Make_Integer_Literal (Loc, 0)),
3389 Then_Statements => New_List (
3390 Make_Assignment_Statement (Loc,
3392 New_Occurrence_Of (Subp_Id, Loc),
3394 Make_Selected_Component (Loc,
3396 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3397 OK_Convert_To (RTE (RE_Address),
3398 Make_Attribute_Reference (Loc,
3400 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3403 Expressions => New_List (
3404 Make_Selected_Component (Loc,
3405 Prefix => Request_Parameter,
3406 Selector_Name => Name_Params))))),
3408 Make_Identifier (Loc, Name_Subp_Id))))));
3410 -- Build a subprogram for RAS information lookups
3412 Current_Declaration :=
3413 Make_Subprogram_Declaration (Loc,
3415 Make_Function_Specification (Loc,
3416 Defining_Unit_Name =>
3418 Parameter_Specifications => New_List (
3419 Make_Parameter_Specification (Loc,
3420 Defining_Identifier =>
3421 Make_Defining_Identifier (Loc, Name_Subp_Id),
3425 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3426 Result_Definition =>
3427 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3428 Append_To (Decls, Current_Declaration);
3429 Analyze (Current_Declaration);
3431 Current_Stubs := Build_Subprogram_Receiving_Stubs
3432 (Vis_Decl => Current_Declaration,
3433 Asynchronous => False);
3434 Append_To (Decls, Current_Stubs);
3435 Analyze (Current_Stubs);
3437 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3440 Subprogram_Number => 1);
3442 -- For each subprogram, the receiving stub will be built and a
3443 -- case statement will be made on the Subprogram_Id to dispatch
3444 -- to the right subprogram.
3446 All_Calls_Remote_E := Boolean_Literals (
3447 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3449 Overload_Counter_Table.Reset;
3451 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3452 while Present (Current_Declaration) loop
3453 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3454 and then Comes_From_Source (Current_Declaration)
3457 Loc : constant Source_Ptr :=
3458 Sloc (Current_Declaration);
3459 -- While specifically processing Current_Declaration, use
3460 -- its Sloc as the location of all generated nodes.
3462 Subp_Def : constant Entity_Id :=
3464 (Specification (Current_Declaration));
3466 Subp_Val : String_Id;
3469 pragma Assert (Current_Subprogram_Number =
3470 Get_Subprogram_Id (Subp_Def));
3472 -- Build receiving stub
3475 Build_Subprogram_Receiving_Stubs
3476 (Vis_Decl => Current_Declaration,
3478 Nkind (Specification (Current_Declaration)) =
3479 N_Procedure_Specification
3480 and then Is_Asynchronous (Subp_Def));
3482 Append_To (Decls, Current_Stubs);
3483 Analyze (Current_Stubs);
3487 Add_RAS_Proxy_And_Analyze (Decls,
3489 Current_Declaration,
3490 All_Calls_Remote_E =>
3492 Proxy_Object_Addr =>
3495 -- Compute distribution identifier
3497 Assign_Subprogram_Identifier (
3499 Current_Subprogram_Number,
3502 -- Add subprogram descriptor (RCI_Subp_Info) to the
3503 -- subprograms table for this receiver. The aggregate
3504 -- below must be kept consistent with the declaration
3505 -- of type RCI_Subp_Info in System.Partition_Interface.
3507 Append_To (Subp_Info_List,
3508 Make_Component_Association (Loc,
3509 Choices => New_List (
3510 Make_Integer_Literal (Loc,
3511 Current_Subprogram_Number)),
3513 Make_Aggregate (Loc,
3514 Component_Associations => New_List (
3515 Make_Component_Association (Loc,
3516 Choices => New_List (
3517 Make_Identifier (Loc, Name_Addr)),
3520 Proxy_Object_Addr, Loc))))));
3522 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3525 Subprogram_Number =>
3526 Current_Subprogram_Number);
3529 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3532 Next (Current_Declaration);
3535 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3536 -- rather than raising an exception since we do not want someone
3537 -- to crash a remote partition by sending invalid subprogram ids.
3538 -- This is consistent with the other parts of the case statement
3539 -- since even in presence of incorrect parameters in the stream,
3540 -- every exception will be caught and (if the subprogram is not an
3541 -- APC) put into the result stream and sent away.
3543 Append_To (Pkg_RPC_Receiver_Cases,
3544 Make_Case_Statement_Alternative (Loc,
3546 New_List (Make_Others_Choice (Loc)),
3548 New_List (Make_Null_Statement (Loc))));
3550 Append_To (Pkg_RPC_Receiver_Statements,
3551 Make_Case_Statement (Loc,
3553 New_Occurrence_Of (Subp_Id, Loc),
3554 Alternatives => Pkg_RPC_Receiver_Cases));
3557 Make_Object_Declaration (Loc,
3558 Defining_Identifier => Subp_Info_Array,
3559 Constant_Present => True,
3560 Aliased_Present => True,
3561 Object_Definition =>
3562 Make_Subtype_Indication (Loc,
3564 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3566 Make_Index_Or_Discriminant_Constraint (Loc,
3569 Low_Bound => Make_Integer_Literal (Loc,
3570 First_RCI_Subprogram_Id),
3572 Make_Integer_Literal (Loc,
3573 First_RCI_Subprogram_Id
3574 + List_Length (Subp_Info_List) - 1))))),
3576 Make_Aggregate (Loc,
3577 Component_Associations => Subp_Info_List)));
3578 Analyze (Last (Decls));
3581 Make_Subprogram_Body (Loc,
3583 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
3586 Handled_Statement_Sequence =>
3587 Make_Handled_Sequence_Of_Statements (Loc,
3588 Statements => New_List (
3589 Make_Return_Statement (Loc,
3590 Expression => OK_Convert_To (RTE (RE_Unsigned_64),
3591 Make_Selected_Component (Loc,
3593 Make_Indexed_Component (Loc,
3595 New_Occurrence_Of (Subp_Info_Array, Loc),
3596 Expressions => New_List (
3597 Convert_To (Standard_Integer,
3598 Make_Identifier (Loc, Name_Subp_Id)))),
3600 Make_Identifier (Loc, Name_Addr))))))));
3601 Analyze (Last (Decls));
3603 Append_To (Decls, Pkg_RPC_Receiver_Body);
3604 Analyze (Last (Decls));
3606 Get_Library_Unit_Name_String (Pkg_Spec);
3607 Append_To (Register_Pkg_Actuals,
3609 Make_String_Literal (Loc,
3610 Strval => String_From_Name_Buffer));
3612 Append_To (Register_Pkg_Actuals,
3614 Make_Attribute_Reference (Loc,
3616 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
3618 Name_Unrestricted_Access));
3620 Append_To (Register_Pkg_Actuals,
3622 Make_Attribute_Reference (Loc,
3624 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
3628 Append_To (Register_Pkg_Actuals,
3630 Make_Attribute_Reference (Loc,
3632 New_Occurrence_Of (Subp_Info_Array, Loc),
3636 Append_To (Register_Pkg_Actuals,
3638 Make_Attribute_Reference (Loc,
3640 New_Occurrence_Of (Subp_Info_Array, Loc),
3645 Make_Procedure_Call_Statement (Loc,
3647 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
3648 Parameter_Associations => Register_Pkg_Actuals));
3649 Analyze (Last (Decls));
3650 end Add_Receiving_Stubs_To_Declarations;
3652 ---------------------------------
3653 -- Build_General_Calling_Stubs --
3654 ---------------------------------
3656 procedure Build_General_Calling_Stubs
3658 Statements : List_Id;
3659 Target_Partition : Entity_Id;
3660 Target_RPC_Receiver : Node_Id;
3661 Subprogram_Id : Node_Id;
3662 Asynchronous : Node_Id := Empty;
3663 Is_Known_Asynchronous : Boolean := False;
3664 Is_Known_Non_Asynchronous : Boolean := False;
3665 Is_Function : Boolean;
3667 Stub_Type : Entity_Id := Empty;
3668 RACW_Type : Entity_Id := Empty;
3671 Loc : constant Source_Ptr := Sloc (Nod);
3673 Stream_Parameter : Node_Id;
3674 -- Name of the stream used to transmit parameters to the
3677 Result_Parameter : Node_Id;
3678 -- Name of the result parameter (in non-APC cases) which get the
3679 -- result of the remote subprogram.
3681 Exception_Return_Parameter : Node_Id;
3682 -- Name of the parameter which will hold the exception sent by the
3683 -- remote subprogram.
3685 Current_Parameter : Node_Id;
3686 -- Current parameter being handled
3688 Ordered_Parameters_List : constant List_Id :=
3689 Build_Ordered_Parameters_List (Spec);
3691 Asynchronous_Statements : List_Id := No_List;
3692 Non_Asynchronous_Statements : List_Id := No_List;
3693 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
3695 Extra_Formal_Statements : constant List_Id := New_List;
3696 -- List of statements for extra formal parameters. It will appear
3697 -- after the regular statements for writing out parameters.
3699 pragma Warnings (Off);
3700 pragma Unreferenced (RACW_Type);
3701 -- Used only for the PolyORB case
3702 pragma Warnings (On);
3705 -- The general form of a calling stub for a given subprogram is:
3707 -- procedure X (...) is P : constant Partition_ID :=
3708 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
3709 -- System.RPC.Params_Stream_Type (0); begin
3710 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
3711 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
3712 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
3713 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
3715 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
3717 -- There are some variations: Do_APC is called for an asynchronous
3718 -- procedure and the part after the call is completely ommitted as
3719 -- well as the declaration of Result. For a function call, 'Input is
3720 -- always used to read the result even if it is constrained.
3723 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3726 Make_Object_Declaration (Loc,
3727 Defining_Identifier => Stream_Parameter,
3728 Aliased_Present => True,
3729 Object_Definition =>
3730 Make_Subtype_Indication (Loc,
3732 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
3734 Make_Index_Or_Discriminant_Constraint (Loc,
3736 New_List (Make_Integer_Literal (Loc, 0))))));
3738 if not Is_Known_Asynchronous then
3740 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3743 Make_Object_Declaration (Loc,
3744 Defining_Identifier => Result_Parameter,
3745 Aliased_Present => True,
3746 Object_Definition =>
3747 Make_Subtype_Indication (Loc,
3749 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
3751 Make_Index_Or_Discriminant_Constraint (Loc,
3753 New_List (Make_Integer_Literal (Loc, 0))))));
3755 Exception_Return_Parameter :=
3756 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3759 Make_Object_Declaration (Loc,
3760 Defining_Identifier => Exception_Return_Parameter,
3761 Object_Definition =>
3762 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
3765 Result_Parameter := Empty;
3766 Exception_Return_Parameter := Empty;
3769 -- Put first the RPC receiver corresponding to the remote package
3771 Append_To (Statements,
3772 Make_Attribute_Reference (Loc,
3774 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3775 Attribute_Name => Name_Write,
3776 Expressions => New_List (
3777 Make_Attribute_Reference (Loc,
3779 New_Occurrence_Of (Stream_Parameter, Loc),
3782 Target_RPC_Receiver)));
3784 -- Then put the Subprogram_Id of the subprogram we want to call in
3787 Append_To (Statements,
3788 Make_Attribute_Reference (Loc,
3790 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
3793 Expressions => New_List (
3794 Make_Attribute_Reference (Loc,
3796 New_Occurrence_Of (Stream_Parameter, Loc),
3797 Attribute_Name => Name_Access),
3800 Current_Parameter := First (Ordered_Parameters_List);
3801 while Present (Current_Parameter) loop
3803 Typ : constant Node_Id :=
3804 Parameter_Type (Current_Parameter);
3806 Constrained : Boolean;
3808 Extra_Parameter : Entity_Id;
3811 if Is_RACW_Controlling_Formal
3812 (Current_Parameter, Stub_Type)
3814 -- In the case of a controlling formal argument, we marshall
3815 -- its addr field rather than the local stub.
3817 Append_To (Statements,
3818 Pack_Node_Into_Stream (Loc,
3819 Stream => Stream_Parameter,
3821 Make_Selected_Component (Loc,
3823 Defining_Identifier (Current_Parameter),
3824 Selector_Name => Name_Addr),
3825 Etyp => RTE (RE_Unsigned_64)));
3828 Value := New_Occurrence_Of
3829 (Defining_Identifier (Current_Parameter), Loc);
3831 -- Access type parameters are transmitted as in out
3832 -- parameters. However, a dereference is needed so that
3833 -- we marshall the designated object.
3835 if Nkind (Typ) = N_Access_Definition then
3836 Value := Make_Explicit_Dereference (Loc, Value);
3837 Etyp := Etype (Subtype_Mark (Typ));
3839 Etyp := Etype (Typ);
3843 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
3845 -- Any parameter but unconstrained out parameters are
3846 -- transmitted to the peer.
3848 if In_Present (Current_Parameter)
3849 or else not Out_Present (Current_Parameter)
3850 or else not Constrained
3852 Append_To (Statements,
3853 Make_Attribute_Reference (Loc,
3855 New_Occurrence_Of (Etyp, Loc),
3857 Output_From_Constrained (Constrained),
3858 Expressions => New_List (
3859 Make_Attribute_Reference (Loc,
3861 New_Occurrence_Of (Stream_Parameter, Loc),
3862 Attribute_Name => Name_Access),
3867 -- If the current parameter has a dynamic constrained status,
3868 -- then this status is transmitted as well.
3869 -- This should be done for accessibility as well ???
3871 if Nkind (Typ) /= N_Access_Definition
3872 and then Need_Extra_Constrained (Current_Parameter)
3874 -- In this block, we do not use the extra formal that has
3875 -- been created because it does not exist at the time of
3876 -- expansion when building calling stubs for remote access
3877 -- to subprogram types. We create an extra variable of this
3878 -- type and push it in the stream after the regular
3881 Extra_Parameter := Make_Defining_Identifier
3882 (Loc, New_Internal_Name ('P'));
3885 Make_Object_Declaration (Loc,
3886 Defining_Identifier => Extra_Parameter,
3887 Constant_Present => True,
3888 Object_Definition =>
3889 New_Occurrence_Of (Standard_Boolean, Loc),
3891 Make_Attribute_Reference (Loc,
3894 Defining_Identifier (Current_Parameter), Loc),
3895 Attribute_Name => Name_Constrained)));
3897 Append_To (Extra_Formal_Statements,
3898 Make_Attribute_Reference (Loc,
3900 New_Occurrence_Of (Standard_Boolean, Loc),
3903 Expressions => New_List (
3904 Make_Attribute_Reference (Loc,
3906 New_Occurrence_Of (Stream_Parameter, Loc),
3909 New_Occurrence_Of (Extra_Parameter, Loc))));
3912 Next (Current_Parameter);
3916 -- Append the formal statements list to the statements
3918 Append_List_To (Statements, Extra_Formal_Statements);
3920 if not Is_Known_Non_Asynchronous then
3922 -- Build the call to System.RPC.Do_APC
3924 Asynchronous_Statements := New_List (
3925 Make_Procedure_Call_Statement (Loc,
3927 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
3928 Parameter_Associations => New_List (
3929 New_Occurrence_Of (Target_Partition, Loc),
3930 Make_Attribute_Reference (Loc,
3932 New_Occurrence_Of (Stream_Parameter, Loc),
3936 Asynchronous_Statements := No_List;
3939 if not Is_Known_Asynchronous then
3941 -- Build the call to System.RPC.Do_RPC
3943 Non_Asynchronous_Statements := New_List (
3944 Make_Procedure_Call_Statement (Loc,
3946 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
3947 Parameter_Associations => New_List (
3948 New_Occurrence_Of (Target_Partition, Loc),
3950 Make_Attribute_Reference (Loc,
3952 New_Occurrence_Of (Stream_Parameter, Loc),
3956 Make_Attribute_Reference (Loc,
3958 New_Occurrence_Of (Result_Parameter, Loc),
3962 -- Read the exception occurrence from the result stream and
3963 -- reraise it. It does no harm if this is a Null_Occurrence since
3964 -- this does nothing.
3966 Append_To (Non_Asynchronous_Statements,
3967 Make_Attribute_Reference (Loc,
3969 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
3974 Expressions => New_List (
3975 Make_Attribute_Reference (Loc,
3977 New_Occurrence_Of (Result_Parameter, Loc),
3980 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
3982 Append_To (Non_Asynchronous_Statements,
3983 Make_Procedure_Call_Statement (Loc,
3985 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
3986 Parameter_Associations => New_List (
3987 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
3991 -- If this is a function call, then read the value and return
3992 -- it. The return value is written/read using 'Output/'Input.
3994 Append_To (Non_Asynchronous_Statements,
3995 Make_Tag_Check (Loc,
3996 Make_Return_Statement (Loc,
3998 Make_Attribute_Reference (Loc,
4001 Etype (Result_Definition (Spec)), Loc),
4003 Attribute_Name => Name_Input,
4005 Expressions => New_List (
4006 Make_Attribute_Reference (Loc,
4008 New_Occurrence_Of (Result_Parameter, Loc),
4009 Attribute_Name => Name_Access))))));
4012 -- Loop around parameters and assign out (or in out)
4013 -- parameters. In the case of RACW, controlling arguments
4014 -- cannot possibly have changed since they are remote, so we do
4015 -- not read them from the stream.
4017 Current_Parameter := First (Ordered_Parameters_List);
4018 while Present (Current_Parameter) loop
4020 Typ : constant Node_Id :=
4021 Parameter_Type (Current_Parameter);
4028 (Defining_Identifier (Current_Parameter), Loc);
4030 if Nkind (Typ) = N_Access_Definition then
4031 Value := Make_Explicit_Dereference (Loc, Value);
4032 Etyp := Etype (Subtype_Mark (Typ));
4034 Etyp := Etype (Typ);
4037 if (Out_Present (Current_Parameter)
4038 or else Nkind (Typ) = N_Access_Definition)
4039 and then Etyp /= Stub_Type
4041 Append_To (Non_Asynchronous_Statements,
4042 Make_Attribute_Reference (Loc,
4044 New_Occurrence_Of (Etyp, Loc),
4046 Attribute_Name => Name_Read,
4048 Expressions => New_List (
4049 Make_Attribute_Reference (Loc,
4051 New_Occurrence_Of (Result_Parameter, Loc),
4058 Next (Current_Parameter);
4063 if Is_Known_Asynchronous then
4064 Append_List_To (Statements, Asynchronous_Statements);
4066 elsif Is_Known_Non_Asynchronous then
4067 Append_List_To (Statements, Non_Asynchronous_Statements);
4070 pragma Assert (Present (Asynchronous));
4071 Prepend_To (Asynchronous_Statements,
4072 Make_Attribute_Reference (Loc,
4073 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4074 Attribute_Name => Name_Write,
4075 Expressions => New_List (
4076 Make_Attribute_Reference (Loc,
4078 New_Occurrence_Of (Stream_Parameter, Loc),
4079 Attribute_Name => Name_Access),
4080 New_Occurrence_Of (Standard_True, Loc))));
4082 Prepend_To (Non_Asynchronous_Statements,
4083 Make_Attribute_Reference (Loc,
4084 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4085 Attribute_Name => Name_Write,
4086 Expressions => New_List (
4087 Make_Attribute_Reference (Loc,
4089 New_Occurrence_Of (Stream_Parameter, Loc),
4090 Attribute_Name => Name_Access),
4091 New_Occurrence_Of (Standard_False, Loc))));
4093 Append_To (Statements,
4094 Make_Implicit_If_Statement (Nod,
4095 Condition => Asynchronous,
4096 Then_Statements => Asynchronous_Statements,
4097 Else_Statements => Non_Asynchronous_Statements));
4099 end Build_General_Calling_Stubs;
4101 -----------------------------
4102 -- Build_RPC_Receiver_Body --
4103 -----------------------------
4105 procedure Build_RPC_Receiver_Body
4106 (RPC_Receiver : Entity_Id;
4107 Request : out Entity_Id;
4108 Subp_Id : out Entity_Id;
4109 Subp_Index : out Entity_Id;
4110 Stmts : out List_Id;
4113 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4115 RPC_Receiver_Spec : Node_Id;
4116 RPC_Receiver_Decls : List_Id;
4119 Request := Make_Defining_Identifier (Loc, Name_R);
4121 RPC_Receiver_Spec :=
4122 Build_RPC_Receiver_Specification
4123 (RPC_Receiver => RPC_Receiver,
4124 Request_Parameter => Request);
4126 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4127 Subp_Index := Subp_Id;
4129 -- Subp_Id may not be a constant, because in the case of the RPC
4130 -- receiver for an RCI package, when a call is received from a RAS
4131 -- dereference, it will be assigned during subsequent processing.
4133 RPC_Receiver_Decls := New_List (
4134 Make_Object_Declaration (Loc,
4135 Defining_Identifier => Subp_Id,
4136 Object_Definition =>
4137 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4139 Make_Attribute_Reference (Loc,
4141 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4142 Attribute_Name => Name_Input,
4143 Expressions => New_List (
4144 Make_Selected_Component (Loc,
4146 Selector_Name => Name_Params)))));
4151 Make_Subprogram_Body (Loc,
4152 Specification => RPC_Receiver_Spec,
4153 Declarations => RPC_Receiver_Decls,
4154 Handled_Statement_Sequence =>
4155 Make_Handled_Sequence_Of_Statements (Loc,
4156 Statements => Stmts));
4157 end Build_RPC_Receiver_Body;
4159 -----------------------
4160 -- Build_Stub_Target --
4161 -----------------------
4163 function Build_Stub_Target
4166 RCI_Locator : Entity_Id;
4167 Controlling_Parameter : Entity_Id) return RPC_Target
4169 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4171 Target_Info.Partition :=
4172 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4173 if Present (Controlling_Parameter) then
4175 Make_Object_Declaration (Loc,
4176 Defining_Identifier => Target_Info.Partition,
4177 Constant_Present => True,
4178 Object_Definition =>
4179 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4182 Make_Selected_Component (Loc,
4183 Prefix => Controlling_Parameter,
4184 Selector_Name => Name_Origin)));
4186 Target_Info.RPC_Receiver :=
4187 Make_Selected_Component (Loc,
4188 Prefix => Controlling_Parameter,
4189 Selector_Name => Name_Receiver);
4193 Make_Object_Declaration (Loc,
4194 Defining_Identifier => Target_Info.Partition,
4195 Constant_Present => True,
4196 Object_Definition =>
4197 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4200 Make_Function_Call (Loc,
4201 Name => Make_Selected_Component (Loc,
4203 Make_Identifier (Loc, Chars (RCI_Locator)),
4205 Make_Identifier (Loc,
4206 Name_Get_Active_Partition_ID)))));
4208 Target_Info.RPC_Receiver :=
4209 Make_Selected_Component (Loc,
4211 Make_Identifier (Loc, Chars (RCI_Locator)),
4213 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4216 end Build_Stub_Target;
4218 ---------------------
4219 -- Build_Stub_Type --
4220 ---------------------
4222 procedure Build_Stub_Type
4223 (RACW_Type : Entity_Id;
4224 Stub_Type : Entity_Id;
4225 Stub_Type_Decl : out Node_Id;
4226 RPC_Receiver_Decl : out Node_Id)
4228 Loc : constant Source_Ptr := Sloc (Stub_Type);
4229 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4233 Make_Full_Type_Declaration (Loc,
4234 Defining_Identifier => Stub_Type,
4236 Make_Record_Definition (Loc,
4237 Tagged_Present => True,
4238 Limited_Present => True,
4240 Make_Component_List (Loc,
4241 Component_Items => New_List (
4243 Make_Component_Declaration (Loc,
4244 Defining_Identifier =>
4245 Make_Defining_Identifier (Loc, Name_Origin),
4246 Component_Definition =>
4247 Make_Component_Definition (Loc,
4248 Aliased_Present => False,
4249 Subtype_Indication =>
4251 RTE (RE_Partition_ID), Loc))),
4253 Make_Component_Declaration (Loc,
4254 Defining_Identifier =>
4255 Make_Defining_Identifier (Loc, Name_Receiver),
4256 Component_Definition =>
4257 Make_Component_Definition (Loc,
4258 Aliased_Present => False,
4259 Subtype_Indication =>
4260 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4262 Make_Component_Declaration (Loc,
4263 Defining_Identifier =>
4264 Make_Defining_Identifier (Loc, Name_Addr),
4265 Component_Definition =>
4266 Make_Component_Definition (Loc,
4267 Aliased_Present => False,
4268 Subtype_Indication =>
4269 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4271 Make_Component_Declaration (Loc,
4272 Defining_Identifier =>
4273 Make_Defining_Identifier (Loc, Name_Asynchronous),
4274 Component_Definition =>
4275 Make_Component_Definition (Loc,
4276 Aliased_Present => False,
4277 Subtype_Indication =>
4279 Standard_Boolean, Loc)))))));
4282 RPC_Receiver_Decl := Empty;
4285 RPC_Receiver_Request : constant Entity_Id :=
4286 Make_Defining_Identifier (Loc, Name_R);
4288 RPC_Receiver_Decl :=
4289 Make_Subprogram_Declaration (Loc,
4290 Build_RPC_Receiver_Specification (
4291 RPC_Receiver => Make_Defining_Identifier (Loc,
4292 New_Internal_Name ('R')),
4293 Request_Parameter => RPC_Receiver_Request));
4296 end Build_Stub_Type;
4298 --------------------------------------
4299 -- Build_Subprogram_Receiving_Stubs --
4300 --------------------------------------
4302 function Build_Subprogram_Receiving_Stubs
4303 (Vis_Decl : Node_Id;
4304 Asynchronous : Boolean;
4305 Dynamically_Asynchronous : Boolean := False;
4306 Stub_Type : Entity_Id := Empty;
4307 RACW_Type : Entity_Id := Empty;
4308 Parent_Primitive : Entity_Id := Empty) return Node_Id
4310 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4312 Request_Parameter : Node_Id;
4315 Decls : constant List_Id := New_List;
4316 -- All the parameters will get declared before calling the real
4317 -- subprograms. Also the out parameters will be declared.
4319 Statements : constant List_Id := New_List;
4321 Extra_Formal_Statements : constant List_Id := New_List;
4322 -- Statements concerning extra formal parameters
4324 After_Statements : constant List_Id := New_List;
4325 -- Statements to be executed after the subprogram call
4327 Inner_Decls : List_Id := No_List;
4328 -- In case of a function, the inner declarations are needed since
4329 -- the result may be unconstrained.
4331 Excep_Handlers : List_Id := No_List;
4332 Excep_Choice : Entity_Id;
4333 Excep_Code : List_Id;
4335 Parameter_List : constant List_Id := New_List;
4336 -- List of parameters to be passed to the subprogram
4338 Current_Parameter : Node_Id;
4340 Ordered_Parameters_List : constant List_Id :=
4341 Build_Ordered_Parameters_List
4342 (Specification (Vis_Decl));
4344 Subp_Spec : Node_Id;
4345 -- Subprogram specification
4347 Called_Subprogram : Node_Id;
4348 -- The subprogram to call
4350 Null_Raise_Statement : Node_Id;
4352 Dynamic_Async : Entity_Id;
4355 if Present (RACW_Type) then
4356 Called_Subprogram :=
4357 New_Occurrence_Of (Parent_Primitive, Loc);
4359 Called_Subprogram :=
4361 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4364 Request_Parameter :=
4365 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4367 if Dynamically_Asynchronous then
4369 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4371 Dynamic_Async := Empty;
4374 if not Asynchronous or Dynamically_Asynchronous then
4376 -- The first statement after the subprogram call is a statement to
4377 -- writes a Null_Occurrence into the result stream.
4379 Null_Raise_Statement :=
4380 Make_Attribute_Reference (Loc,
4382 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4383 Attribute_Name => Name_Write,
4384 Expressions => New_List (
4385 Make_Selected_Component (Loc,
4386 Prefix => Request_Parameter,
4387 Selector_Name => Name_Result),
4388 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4390 if Dynamically_Asynchronous then
4391 Null_Raise_Statement :=
4392 Make_Implicit_If_Statement (Vis_Decl,
4394 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4395 Then_Statements => New_List (Null_Raise_Statement));
4398 Append_To (After_Statements, Null_Raise_Statement);
4401 -- Loop through every parameter and get its value from the stream. If
4402 -- the parameter is unconstrained, then the parameter is read using
4403 -- 'Input at the point of declaration.
4405 Current_Parameter := First (Ordered_Parameters_List);
4406 while Present (Current_Parameter) loop
4409 Constrained : Boolean;
4411 Object : constant Entity_Id :=
4412 Make_Defining_Identifier (Loc,
4413 New_Internal_Name ('P'));
4415 Expr : Node_Id := Empty;
4417 Is_Controlling_Formal : constant Boolean :=
4418 Is_RACW_Controlling_Formal
4419 (Current_Parameter, Stub_Type);
4422 Set_Ekind (Object, E_Variable);
4424 if Is_Controlling_Formal then
4426 -- We have a controlling formal parameter. Read its address
4427 -- rather than a real object. The address is in Unsigned_64
4430 Etyp := RTE (RE_Unsigned_64);
4432 Etyp := Etype (Parameter_Type (Current_Parameter));
4436 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
4438 if In_Present (Current_Parameter)
4439 or else not Out_Present (Current_Parameter)
4440 or else not Constrained
4441 or else Is_Controlling_Formal
4443 -- If an input parameter is contrained, then its reading is
4444 -- deferred until the beginning of the subprogram body. If
4445 -- it is unconstrained, then an expression is built for
4446 -- the object declaration and the variable is set using
4447 -- 'Input instead of 'Read.
4449 if Constrained and then not Is_Controlling_Formal then
4450 Append_To (Statements,
4451 Make_Attribute_Reference (Loc,
4452 Prefix => New_Occurrence_Of (Etyp, Loc),
4453 Attribute_Name => Name_Read,
4454 Expressions => New_List (
4455 Make_Selected_Component (Loc,
4456 Prefix => Request_Parameter,
4457 Selector_Name => Name_Params),
4458 New_Occurrence_Of (Object, Loc))));
4461 Expr := Input_With_Tag_Check (Loc,
4463 Stream => Make_Selected_Component (Loc,
4464 Prefix => Request_Parameter,
4465 Selector_Name => Name_Params));
4466 Append_To (Decls, Expr);
4467 Expr := Make_Function_Call (Loc,
4468 New_Occurrence_Of (Defining_Unit_Name
4469 (Specification (Expr)), Loc));
4473 -- If we do not have to output the current parameter, then it
4474 -- can well be flagged as constant. This may allow further
4475 -- optimizations done by the back end.
4478 Make_Object_Declaration (Loc,
4479 Defining_Identifier => Object,
4480 Constant_Present => not Constrained
4481 and then not Out_Present (Current_Parameter),
4482 Object_Definition =>
4483 New_Occurrence_Of (Etyp, Loc),
4484 Expression => Expr));
4486 -- An out parameter may be written back using a 'Write
4487 -- attribute instead of a 'Output because it has been
4488 -- constrained by the parameter given to the caller. Note that
4489 -- out controlling arguments in the case of a RACW are not put
4490 -- back in the stream because the pointer on them has not
4493 if Out_Present (Current_Parameter)
4495 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4497 Append_To (After_Statements,
4498 Make_Attribute_Reference (Loc,
4499 Prefix => New_Occurrence_Of (Etyp, Loc),
4500 Attribute_Name => Name_Write,
4501 Expressions => New_List (
4502 Make_Selected_Component (Loc,
4503 Prefix => Request_Parameter,
4504 Selector_Name => Name_Result),
4505 New_Occurrence_Of (Object, Loc))));
4508 -- For RACW controlling formals, the Etyp of Object is always
4509 -- an RACW, even if the parameter is not of an anonymous access
4510 -- type. In such case, we need to dereference it at call time.
4512 if Is_Controlling_Formal then
4513 if Nkind (Parameter_Type (Current_Parameter)) /=
4516 Append_To (Parameter_List,
4517 Make_Parameter_Association (Loc,
4520 Defining_Identifier (Current_Parameter), Loc),
4521 Explicit_Actual_Parameter =>
4522 Make_Explicit_Dereference (Loc,
4523 Unchecked_Convert_To (RACW_Type,
4524 OK_Convert_To (RTE (RE_Address),
4525 New_Occurrence_Of (Object, Loc))))));
4528 Append_To (Parameter_List,
4529 Make_Parameter_Association (Loc,
4532 Defining_Identifier (Current_Parameter), Loc),
4533 Explicit_Actual_Parameter =>
4534 Unchecked_Convert_To (RACW_Type,
4535 OK_Convert_To (RTE (RE_Address),
4536 New_Occurrence_Of (Object, Loc)))));
4540 Append_To (Parameter_List,
4541 Make_Parameter_Association (Loc,
4544 Defining_Identifier (Current_Parameter), Loc),
4545 Explicit_Actual_Parameter =>
4546 New_Occurrence_Of (Object, Loc)));
4549 -- If the current parameter needs an extra formal, then read it
4550 -- from the stream and set the corresponding semantic field in
4551 -- the variable. If the kind of the parameter identifier is
4552 -- E_Void, then this is a compiler generated parameter that
4553 -- doesn't need an extra constrained status.
4555 -- The case of Extra_Accessibility should also be handled ???
4557 if Nkind (Parameter_Type (Current_Parameter)) /=
4560 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4562 Present (Extra_Constrained
4563 (Defining_Identifier (Current_Parameter)))
4566 Extra_Parameter : constant Entity_Id :=
4568 (Defining_Identifier
4569 (Current_Parameter));
4571 Formal_Entity : constant Entity_Id :=
4572 Make_Defining_Identifier
4573 (Loc, Chars (Extra_Parameter));
4575 Formal_Type : constant Entity_Id :=
4576 Etype (Extra_Parameter);
4580 Make_Object_Declaration (Loc,
4581 Defining_Identifier => Formal_Entity,
4582 Object_Definition =>
4583 New_Occurrence_Of (Formal_Type, Loc)));
4585 Append_To (Extra_Formal_Statements,
4586 Make_Attribute_Reference (Loc,
4587 Prefix => New_Occurrence_Of (
4589 Attribute_Name => Name_Read,
4590 Expressions => New_List (
4591 Make_Selected_Component (Loc,
4592 Prefix => Request_Parameter,
4593 Selector_Name => Name_Params),
4594 New_Occurrence_Of (Formal_Entity, Loc))));
4595 Set_Extra_Constrained (Object, Formal_Entity);
4600 Next (Current_Parameter);
4603 -- Append the formal statements list at the end of regular statements
4605 Append_List_To (Statements, Extra_Formal_Statements);
4607 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
4609 -- The remote subprogram is a function. We build an inner block to
4610 -- be able to hold a potentially unconstrained result in a
4614 Etyp : constant Entity_Id :=
4615 Etype (Result_Definition (Specification (Vis_Decl)));
4616 Result : constant Node_Id :=
4617 Make_Defining_Identifier (Loc,
4618 New_Internal_Name ('R'));
4620 Inner_Decls := New_List (
4621 Make_Object_Declaration (Loc,
4622 Defining_Identifier => Result,
4623 Constant_Present => True,
4624 Object_Definition => New_Occurrence_Of (Etyp, Loc),
4626 Make_Function_Call (Loc,
4627 Name => Called_Subprogram,
4628 Parameter_Associations => Parameter_List)));
4630 Append_To (After_Statements,
4631 Make_Attribute_Reference (Loc,
4632 Prefix => New_Occurrence_Of (Etyp, Loc),
4633 Attribute_Name => Name_Output,
4634 Expressions => New_List (
4635 Make_Selected_Component (Loc,
4636 Prefix => Request_Parameter,
4637 Selector_Name => Name_Result),
4638 New_Occurrence_Of (Result, Loc))));
4641 Append_To (Statements,
4642 Make_Block_Statement (Loc,
4643 Declarations => Inner_Decls,
4644 Handled_Statement_Sequence =>
4645 Make_Handled_Sequence_Of_Statements (Loc,
4646 Statements => After_Statements)));
4649 -- The remote subprogram is a procedure. We do not need any inner
4650 -- block in this case.
4652 if Dynamically_Asynchronous then
4654 Make_Object_Declaration (Loc,
4655 Defining_Identifier => Dynamic_Async,
4656 Object_Definition =>
4657 New_Occurrence_Of (Standard_Boolean, Loc)));
4659 Append_To (Statements,
4660 Make_Attribute_Reference (Loc,
4661 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4662 Attribute_Name => Name_Read,
4663 Expressions => New_List (
4664 Make_Selected_Component (Loc,
4665 Prefix => Request_Parameter,
4666 Selector_Name => Name_Params),
4667 New_Occurrence_Of (Dynamic_Async, Loc))));
4670 Append_To (Statements,
4671 Make_Procedure_Call_Statement (Loc,
4672 Name => Called_Subprogram,
4673 Parameter_Associations => Parameter_List));
4675 Append_List_To (Statements, After_Statements);
4678 if Asynchronous and then not Dynamically_Asynchronous then
4680 -- For an asynchronous procedure, add a null exception handler
4682 Excep_Handlers := New_List (
4683 Make_Exception_Handler (Loc,
4684 Exception_Choices => New_List (Make_Others_Choice (Loc)),
4685 Statements => New_List (Make_Null_Statement (Loc))));
4688 -- In the other cases, if an exception is raised, then the
4689 -- exception occurrence is copied into the output stream and
4690 -- no other output parameter is written.
4693 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4695 Excep_Code := New_List (
4696 Make_Attribute_Reference (Loc,
4698 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4699 Attribute_Name => Name_Write,
4700 Expressions => New_List (
4701 Make_Selected_Component (Loc,
4702 Prefix => Request_Parameter,
4703 Selector_Name => Name_Result),
4704 New_Occurrence_Of (Excep_Choice, Loc))));
4706 if Dynamically_Asynchronous then
4707 Excep_Code := New_List (
4708 Make_Implicit_If_Statement (Vis_Decl,
4709 Condition => Make_Op_Not (Loc,
4710 New_Occurrence_Of (Dynamic_Async, Loc)),
4711 Then_Statements => Excep_Code));
4714 Excep_Handlers := New_List (
4715 Make_Exception_Handler (Loc,
4716 Choice_Parameter => Excep_Choice,
4717 Exception_Choices => New_List (Make_Others_Choice (Loc)),
4718 Statements => Excep_Code));
4723 Make_Procedure_Specification (Loc,
4724 Defining_Unit_Name =>
4725 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
4727 Parameter_Specifications => New_List (
4728 Make_Parameter_Specification (Loc,
4729 Defining_Identifier => Request_Parameter,
4731 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
4734 Make_Subprogram_Body (Loc,
4735 Specification => Subp_Spec,
4736 Declarations => Decls,
4737 Handled_Statement_Sequence =>
4738 Make_Handled_Sequence_Of_Statements (Loc,
4739 Statements => Statements,
4740 Exception_Handlers => Excep_Handlers));
4741 end Build_Subprogram_Receiving_Stubs;
4747 function Result return Node_Id is
4749 return Make_Identifier (Loc, Name_V);
4752 ----------------------
4753 -- Stream_Parameter --
4754 ----------------------
4756 function Stream_Parameter return Node_Id is
4758 return Make_Identifier (Loc, Name_S);
4759 end Stream_Parameter;
4763 -----------------------------
4764 -- Make_Selected_Component --
4765 -----------------------------
4767 function Make_Selected_Component
4770 Selector_Name : Name_Id) return Node_Id
4773 return Make_Selected_Component (Loc,
4774 Prefix => New_Occurrence_Of (Prefix, Loc),
4775 Selector_Name => Make_Identifier (Loc, Selector_Name));
4776 end Make_Selected_Component;
4778 -----------------------
4779 -- Get_Subprogram_Id --
4780 -----------------------
4782 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
4784 return Get_Subprogram_Ids (Def).Str_Identifier;
4785 end Get_Subprogram_Id;
4787 -----------------------
4788 -- Get_Subprogram_Id --
4789 -----------------------
4791 function Get_Subprogram_Id (Def : Entity_Id) return Int is
4793 return Get_Subprogram_Ids (Def).Int_Identifier;
4794 end Get_Subprogram_Id;
4796 ------------------------
4797 -- Get_Subprogram_Ids --
4798 ------------------------
4800 function Get_Subprogram_Ids
4801 (Def : Entity_Id) return Subprogram_Identifiers
4803 Result : Subprogram_Identifiers :=
4804 Subprogram_Identifier_Table.Get (Def);
4806 Current_Declaration : Node_Id;
4807 Current_Subp : Entity_Id;
4808 Current_Subp_Str : String_Id;
4809 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
4812 if Result.Str_Identifier = No_String then
4814 -- We are looking up this subprogram's identifier outside of the
4815 -- context of generating calling or receiving stubs. Hence we are
4816 -- processing an 'Access attribute_reference for an RCI subprogram,
4817 -- for the purpose of obtaining a RAS value.
4820 (Is_Remote_Call_Interface (Scope (Def))
4822 (Nkind (Parent (Def)) = N_Procedure_Specification
4824 Nkind (Parent (Def)) = N_Function_Specification));
4826 Current_Declaration :=
4827 First (Visible_Declarations
4828 (Package_Specification_Of_Scope (Scope (Def))));
4829 while Present (Current_Declaration) loop
4830 if Nkind (Current_Declaration) = N_Subprogram_Declaration
4831 and then Comes_From_Source (Current_Declaration)
4833 Current_Subp := Defining_Unit_Name (Specification (
4834 Current_Declaration));
4835 Assign_Subprogram_Identifier
4836 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
4838 if Current_Subp = Def then
4839 Result := (Current_Subp_Str, Current_Subp_Number);
4842 Current_Subp_Number := Current_Subp_Number + 1;
4845 Next (Current_Declaration);
4849 pragma Assert (Result.Str_Identifier /= No_String);
4851 end Get_Subprogram_Ids;
4857 function Hash (F : Entity_Id) return Hash_Index is
4859 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
4862 function Hash (F : Name_Id) return Hash_Index is
4864 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
4867 --------------------------
4868 -- Input_With_Tag_Check --
4869 --------------------------
4871 function Input_With_Tag_Check
4873 Var_Type : Entity_Id;
4874 Stream : Node_Id) return Node_Id
4878 Make_Subprogram_Body (Loc,
4879 Specification => Make_Function_Specification (Loc,
4880 Defining_Unit_Name =>
4881 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
4882 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
4883 Declarations => No_List,
4884 Handled_Statement_Sequence =>
4885 Make_Handled_Sequence_Of_Statements (Loc, New_List (
4886 Make_Tag_Check (Loc,
4887 Make_Return_Statement (Loc,
4888 Make_Attribute_Reference (Loc,
4889 Prefix => New_Occurrence_Of (Var_Type, Loc),
4890 Attribute_Name => Name_Input,
4892 New_List (Stream)))))));
4893 end Input_With_Tag_Check;
4895 --------------------------------
4896 -- Is_RACW_Controlling_Formal --
4897 --------------------------------
4899 function Is_RACW_Controlling_Formal
4900 (Parameter : Node_Id;
4901 Stub_Type : Entity_Id) return Boolean
4906 -- If the kind of the parameter is E_Void, then it is not a
4907 -- controlling formal (this can happen in the context of RAS).
4909 if Ekind (Defining_Identifier (Parameter)) = E_Void then
4913 -- If the parameter is not a controlling formal, then it cannot
4914 -- be possibly a RACW_Controlling_Formal.
4916 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
4920 Typ := Parameter_Type (Parameter);
4921 return (Nkind (Typ) = N_Access_Definition
4922 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
4923 or else Etype (Typ) = Stub_Type;
4924 end Is_RACW_Controlling_Formal;
4926 --------------------
4927 -- Make_Tag_Check --
4928 --------------------
4930 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
4931 Occ : constant Entity_Id :=
4932 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4935 return Make_Block_Statement (Loc,
4936 Handled_Statement_Sequence =>
4937 Make_Handled_Sequence_Of_Statements (Loc,
4938 Statements => New_List (N),
4940 Exception_Handlers => New_List (
4941 Make_Exception_Handler (Loc,
4942 Choice_Parameter => Occ,
4944 Exception_Choices =>
4945 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
4948 New_List (Make_Procedure_Call_Statement (Loc,
4950 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
4951 New_List (New_Occurrence_Of (Occ, Loc))))))));
4954 ----------------------------
4955 -- Need_Extra_Constrained --
4956 ----------------------------
4958 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
4959 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
4961 return Out_Present (Parameter)
4962 and then Has_Discriminants (Etyp)
4963 and then not Is_Constrained (Etyp)
4964 and then not Is_Indefinite_Subtype (Etyp);
4965 end Need_Extra_Constrained;
4967 ------------------------------------
4968 -- Pack_Entity_Into_Stream_Access --
4969 ------------------------------------
4971 function Pack_Entity_Into_Stream_Access
4975 Etyp : Entity_Id := Empty) return Node_Id
4980 if Present (Etyp) then
4983 Typ := Etype (Object);
4987 Pack_Node_Into_Stream_Access (Loc,
4989 Object => New_Occurrence_Of (Object, Loc),
4991 end Pack_Entity_Into_Stream_Access;
4993 ---------------------------
4994 -- Pack_Node_Into_Stream --
4995 ---------------------------
4997 function Pack_Node_Into_Stream
5001 Etyp : Entity_Id) return Node_Id
5003 Write_Attribute : Name_Id := Name_Write;
5006 if not Is_Constrained (Etyp) then
5007 Write_Attribute := Name_Output;
5011 Make_Attribute_Reference (Loc,
5012 Prefix => New_Occurrence_Of (Etyp, Loc),
5013 Attribute_Name => Write_Attribute,
5014 Expressions => New_List (
5015 Make_Attribute_Reference (Loc,
5016 Prefix => New_Occurrence_Of (Stream, Loc),
5017 Attribute_Name => Name_Access),
5019 end Pack_Node_Into_Stream;
5021 ----------------------------------
5022 -- Pack_Node_Into_Stream_Access --
5023 ----------------------------------
5025 function Pack_Node_Into_Stream_Access
5029 Etyp : Entity_Id) return Node_Id
5031 Write_Attribute : Name_Id := Name_Write;
5034 if not Is_Constrained (Etyp) then
5035 Write_Attribute := Name_Output;
5039 Make_Attribute_Reference (Loc,
5040 Prefix => New_Occurrence_Of (Etyp, Loc),
5041 Attribute_Name => Write_Attribute,
5042 Expressions => New_List (
5045 end Pack_Node_Into_Stream_Access;
5047 ---------------------
5048 -- PolyORB_Support --
5049 ---------------------
5051 package body PolyORB_Support is
5053 -- Local subprograms
5055 procedure Add_RACW_Read_Attribute
5056 (RACW_Type : Entity_Id;
5057 Stub_Type : Entity_Id;
5058 Stub_Type_Access : Entity_Id;
5059 Declarations : List_Id);
5060 -- Add Read attribute in Decls for the RACW type. The Read attribute
5061 -- is added right after the RACW_Type declaration while the body is
5062 -- inserted after Declarations.
5064 procedure Add_RACW_Write_Attribute
5065 (RACW_Type : Entity_Id;
5066 Stub_Type : Entity_Id;
5067 Stub_Type_Access : Entity_Id;
5068 Declarations : List_Id);
5069 -- Same thing for the Write attribute
5071 procedure Add_RACW_From_Any
5072 (RACW_Type : Entity_Id;
5073 Stub_Type : Entity_Id;
5074 Stub_Type_Access : Entity_Id;
5075 Declarations : List_Id);
5076 -- Add the From_Any TSS for this RACW type
5078 procedure Add_RACW_To_Any
5079 (Designated_Type : Entity_Id;
5080 RACW_Type : Entity_Id;
5081 Stub_Type : Entity_Id;
5082 Stub_Type_Access : Entity_Id;
5083 Declarations : List_Id);
5084 -- Add the To_Any TSS for this RACW type
5086 procedure Add_RACW_TypeCode
5087 (Designated_Type : Entity_Id;
5088 RACW_Type : Entity_Id;
5089 Declarations : List_Id);
5090 -- Add the TypeCode TSS for this RACW type
5092 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5093 -- Add the From_Any TSS for this RAS type
5095 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5096 -- Add the To_Any TSS for this RAS type
5098 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5099 -- Add the TypeCode TSS for this RAS type
5101 procedure Add_RAS_Access_TSS (N : Node_Id);
5102 -- Add a subprogram body for RAS Access TSS
5104 -------------------------------------
5105 -- Add_Obj_RPC_Receiver_Completion --
5106 -------------------------------------
5108 procedure Add_Obj_RPC_Receiver_Completion
5111 RPC_Receiver : Entity_Id;
5112 Stub_Elements : Stub_Structure)
5114 Desig : constant Entity_Id :=
5115 Etype (Designated_Type (Stub_Elements.RACW_Type));
5118 Make_Procedure_Call_Statement (Loc,
5121 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5123 Parameter_Associations => New_List (
5127 Make_String_Literal (Loc,
5128 Full_Qualified_Name (Desig)),
5132 Make_Attribute_Reference (Loc,
5135 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5141 Make_Attribute_Reference (Loc,
5144 Defining_Identifier (
5145 Stub_Elements.RPC_Receiver_Decl), Loc),
5148 end Add_Obj_RPC_Receiver_Completion;
5150 -----------------------
5151 -- Add_RACW_Features --
5152 -----------------------
5154 procedure Add_RACW_Features
5155 (RACW_Type : Entity_Id;
5157 Stub_Type : Entity_Id;
5158 Stub_Type_Access : Entity_Id;
5159 RPC_Receiver_Decl : Node_Id;
5160 Declarations : List_Id)
5162 pragma Warnings (Off);
5163 pragma Unreferenced (RPC_Receiver_Decl);
5164 pragma Warnings (On);
5168 (RACW_Type => RACW_Type,
5169 Stub_Type => Stub_Type,
5170 Stub_Type_Access => Stub_Type_Access,
5171 Declarations => Declarations);
5174 (Designated_Type => Desig,
5175 RACW_Type => RACW_Type,
5176 Stub_Type => Stub_Type,
5177 Stub_Type_Access => Stub_Type_Access,
5178 Declarations => Declarations);
5180 -- In the PolyORB case, the RACW 'Read and 'Write attributes
5181 -- are implemented in terms of the From_Any and To_Any TSSs,
5182 -- so these TSSs must be expanded before 'Read and 'Write.
5184 Add_RACW_Write_Attribute
5185 (RACW_Type => RACW_Type,
5186 Stub_Type => Stub_Type,
5187 Stub_Type_Access => Stub_Type_Access,
5188 Declarations => Declarations);
5190 Add_RACW_Read_Attribute
5191 (RACW_Type => RACW_Type,
5192 Stub_Type => Stub_Type,
5193 Stub_Type_Access => Stub_Type_Access,
5194 Declarations => Declarations);
5197 (Designated_Type => Desig,
5198 RACW_Type => RACW_Type,
5199 Declarations => Declarations);
5200 end Add_RACW_Features;
5202 -----------------------
5203 -- Add_RACW_From_Any --
5204 -----------------------
5206 procedure Add_RACW_From_Any
5207 (RACW_Type : Entity_Id;
5208 Stub_Type : Entity_Id;
5209 Stub_Type_Access : Entity_Id;
5210 Declarations : List_Id)
5212 Loc : constant Source_Ptr := Sloc (RACW_Type);
5213 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5215 Fnam : constant Entity_Id :=
5216 Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
5218 Func_Spec : Node_Id;
5219 Func_Decl : Node_Id;
5220 Func_Body : Node_Id;
5223 Statements : List_Id;
5224 Stub_Statements : List_Id;
5225 Local_Statements : List_Id;
5226 -- Various parts of the subprogram
5228 Any_Parameter : constant Entity_Id :=
5229 Make_Defining_Identifier (Loc, Name_A);
5230 Reference : constant Entity_Id :=
5231 Make_Defining_Identifier
5232 (Loc, New_Internal_Name ('R'));
5233 Is_Local : constant Entity_Id :=
5234 Make_Defining_Identifier
5235 (Loc, New_Internal_Name ('L'));
5236 Addr : constant Entity_Id :=
5237 Make_Defining_Identifier
5238 (Loc, New_Internal_Name ('A'));
5239 Local_Stub : constant Entity_Id :=
5240 Make_Defining_Identifier
5241 (Loc, New_Internal_Name ('L'));
5242 Stubbed_Result : constant Entity_Id :=
5243 Make_Defining_Identifier
5244 (Loc, New_Internal_Name ('S'));
5246 Stub_Condition : Node_Id;
5247 -- An expression that determines whether we create a stub for the
5248 -- newly-unpacked RACW. Normally we create a stub only for remote
5249 -- objects, but in the case of an RACW used to implement a RAS,
5250 -- we also create a stub for local subprograms if a pragma
5251 -- All_Calls_Remote applies.
5253 Asynchronous_Flag : constant Entity_Id :=
5254 Asynchronous_Flags_Table.Get (RACW_Type);
5255 -- The flag object declared in Add_RACW_Asynchronous_Flag
5258 -- Object declarations
5261 Make_Object_Declaration (Loc,
5262 Defining_Identifier =>
5264 Object_Definition =>
5265 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5267 Make_Function_Call (Loc,
5269 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5270 Parameter_Associations => New_List (
5271 New_Occurrence_Of (Any_Parameter, Loc)))),
5273 Make_Object_Declaration (Loc,
5274 Defining_Identifier => Local_Stub,
5275 Aliased_Present => True,
5276 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
5278 Make_Object_Declaration (Loc,
5279 Defining_Identifier => Stubbed_Result,
5280 Object_Definition =>
5281 New_Occurrence_Of (Stub_Type_Access, Loc),
5283 Make_Attribute_Reference (Loc,
5285 New_Occurrence_Of (Local_Stub, Loc),
5287 Name_Unchecked_Access)),
5289 Make_Object_Declaration (Loc,
5290 Defining_Identifier => Is_Local,
5291 Object_Definition =>
5292 New_Occurrence_Of (Standard_Boolean, Loc)),
5294 Make_Object_Declaration (Loc,
5295 Defining_Identifier => Addr,
5296 Object_Definition =>
5297 New_Occurrence_Of (RTE (RE_Address), Loc)));
5299 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5301 Set_Etype (Stubbed_Result, Stub_Type_Access);
5303 -- If the ref Is_Nil, return a null pointer
5305 Statements := New_List (
5306 Make_Implicit_If_Statement (RACW_Type,
5308 Make_Function_Call (Loc,
5310 New_Occurrence_Of (RTE (RE_Is_Nil), Loc),
5311 Parameter_Associations => New_List (
5312 New_Occurrence_Of (Reference, Loc))),
5313 Then_Statements => New_List (
5314 Make_Return_Statement (Loc,
5316 Make_Null (Loc)))));
5318 Append_To (Statements,
5319 Make_Procedure_Call_Statement (Loc,
5321 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
5322 Parameter_Associations => New_List (
5323 New_Occurrence_Of (Reference, Loc),
5324 New_Occurrence_Of (Is_Local, Loc),
5325 New_Occurrence_Of (Addr, Loc))));
5327 -- If the object is located on another partition, then a stub object
5328 -- will be created with all the information needed to rebuild the
5329 -- real object at the other end. This stanza is always used in the
5330 -- case of RAS types, for which a stub is required even for local
5333 Stub_Statements := New_List (
5334 Make_Assignment_Statement (Loc,
5335 Name => Make_Selected_Component (Loc,
5336 Prefix => Stubbed_Result,
5337 Selector_Name => Name_Target),
5339 Make_Function_Call (Loc,
5341 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
5342 Parameter_Associations => New_List (
5343 New_Occurrence_Of (Reference, Loc)))),
5345 Make_Procedure_Call_Statement (Loc,
5347 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
5348 Parameter_Associations => New_List (
5349 Make_Selected_Component (Loc,
5350 Prefix => Stubbed_Result,
5351 Selector_Name => Name_Target))),
5353 Make_Assignment_Statement (Loc,
5354 Name => Make_Selected_Component (Loc,
5355 Prefix => Stubbed_Result,
5356 Selector_Name => Name_Asynchronous),
5358 New_Occurrence_Of (Asynchronous_Flag, Loc)));
5360 -- ??? Issue with asynchronous calls here: the Asynchronous
5361 -- flag is set on the stub type if, and only if, the RACW type
5362 -- has a pragma Asynchronous. This is incorrect for RACWs that
5363 -- implement RAS types, because in that case the /designated
5364 -- subprogram/ (not the type) might be asynchronous, and
5365 -- that causes the stub to need to be asynchronous too.
5366 -- A solution is to transport a RAS as a struct containing
5367 -- a RACW and an asynchronous flag, and to properly alter
5368 -- the Asynchronous component in the stub type in the RAS's
5371 Append_List_To (Stub_Statements,
5372 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
5374 -- Distinguish between the local and remote cases, and execute the
5375 -- appropriate piece of code.
5377 Stub_Condition := New_Occurrence_Of (Is_Local, Loc);
5380 Stub_Condition := Make_And_Then (Loc,
5384 Make_Selected_Component (Loc,
5386 Unchecked_Convert_To (
5387 RTE (RE_RAS_Proxy_Type_Access),
5388 New_Occurrence_Of (Addr, Loc)),
5390 Make_Identifier (Loc,
5391 Name_All_Calls_Remote)));
5394 Local_Statements := New_List (
5395 Make_Return_Statement (Loc,
5397 Unchecked_Convert_To (RACW_Type,
5398 New_Occurrence_Of (Addr, Loc))));
5400 Append_To (Statements,
5401 Make_Implicit_If_Statement (RACW_Type,
5404 Then_Statements => Local_Statements,
5405 Else_Statements => Stub_Statements));
5407 Append_To (Statements,
5408 Make_Return_Statement (Loc,
5409 Expression => Unchecked_Convert_To (RACW_Type,
5410 New_Occurrence_Of (Stubbed_Result, Loc))));
5413 Make_Function_Specification (Loc,
5414 Defining_Unit_Name =>
5416 Parameter_Specifications => New_List (
5417 Make_Parameter_Specification (Loc,
5418 Defining_Identifier =>
5421 New_Occurrence_Of (RTE (RE_Any), Loc))),
5422 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5424 -- NOTE: The usage occurrences of RACW_Parameter must
5425 -- refer to the entity in the declaration spec, not those
5426 -- of the body spec.
5428 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5431 Make_Subprogram_Body (Loc,
5433 Copy_Specification (Loc, Func_Spec),
5434 Declarations => Decls,
5435 Handled_Statement_Sequence =>
5436 Make_Handled_Sequence_Of_Statements (Loc,
5437 Statements => Statements));
5439 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5440 Append_To (Declarations, Func_Body);
5442 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5443 end Add_RACW_From_Any;
5445 -----------------------------
5446 -- Add_RACW_Read_Attribute --
5447 -----------------------------
5449 procedure Add_RACW_Read_Attribute
5450 (RACW_Type : Entity_Id;
5451 Stub_Type : Entity_Id;
5452 Stub_Type_Access : Entity_Id;
5453 Declarations : List_Id)
5455 pragma Warnings (Off);
5456 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5457 pragma Warnings (On);
5458 Loc : constant Source_Ptr := Sloc (RACW_Type);
5460 Proc_Decl : Node_Id;
5461 Attr_Decl : Node_Id;
5463 Body_Node : Node_Id;
5466 Statements : List_Id;
5467 -- Various parts of the procedure
5469 Procedure_Name : constant Name_Id :=
5470 New_Internal_Name ('R');
5471 Source_Ref : constant Entity_Id :=
5472 Make_Defining_Identifier
5473 (Loc, New_Internal_Name ('R'));
5474 Asynchronous_Flag : constant Entity_Id :=
5475 Asynchronous_Flags_Table.Get (RACW_Type);
5476 pragma Assert (Present (Asynchronous_Flag));
5478 function Stream_Parameter return Node_Id;
5479 function Result return Node_Id;
5480 -- Functions to create occurrences of the formal parameter names
5486 function Result return Node_Id is
5488 return Make_Identifier (Loc, Name_V);
5491 ----------------------
5492 -- Stream_Parameter --
5493 ----------------------
5495 function Stream_Parameter return Node_Id is
5497 return Make_Identifier (Loc, Name_S);
5498 end Stream_Parameter;
5500 -- Start of processing for Add_RACW_Read_Attribute
5503 -- Generate object declarations
5506 Make_Object_Declaration (Loc,
5507 Defining_Identifier => Source_Ref,
5508 Object_Definition =>
5509 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5511 Statements := New_List (
5512 Make_Attribute_Reference (Loc,
5514 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5515 Attribute_Name => Name_Read,
5516 Expressions => New_List (
5518 New_Occurrence_Of (Source_Ref, Loc))),
5519 Make_Assignment_Statement (Loc,
5523 PolyORB_Support.Helpers.Build_From_Any_Call (
5525 Make_Function_Call (Loc,
5527 New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5528 Parameter_Associations => New_List (
5529 New_Occurrence_Of (Source_Ref, Loc))),
5532 Build_Stream_Procedure
5533 (Loc, RACW_Type, Body_Node,
5534 Make_Defining_Identifier (Loc, Procedure_Name),
5535 Statements, Outp => True);
5536 Set_Declarations (Body_Node, Decls);
5538 Proc_Decl := Make_Subprogram_Declaration (Loc,
5539 Copy_Specification (Loc, Specification (Body_Node)));
5542 Make_Attribute_Definition_Clause (Loc,
5543 Name => New_Occurrence_Of (RACW_Type, Loc),
5547 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5549 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5550 Insert_After (Proc_Decl, Attr_Decl);
5551 Append_To (Declarations, Body_Node);
5552 end Add_RACW_Read_Attribute;
5554 ---------------------
5555 -- Add_RACW_To_Any --
5556 ---------------------
5558 procedure Add_RACW_To_Any
5559 (Designated_Type : Entity_Id;
5560 RACW_Type : Entity_Id;
5561 Stub_Type : Entity_Id;
5562 Stub_Type_Access : Entity_Id;
5563 Declarations : List_Id)
5565 Loc : constant Source_Ptr := Sloc (RACW_Type);
5567 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5571 Stub_Elements : constant Stub_Structure :=
5572 Stubs_Table.Get (Designated_Type);
5573 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5575 Func_Spec : Node_Id;
5576 Func_Decl : Node_Id;
5577 Func_Body : Node_Id;
5580 Statements : List_Id;
5581 Null_Statements : List_Id;
5582 Local_Statements : List_Id := No_List;
5583 Stub_Statements : List_Id;
5585 -- Various parts of the subprogram
5587 RACW_Parameter : constant Entity_Id
5588 := Make_Defining_Identifier (Loc, Name_R);
5590 Reference : constant Entity_Id :=
5591 Make_Defining_Identifier
5592 (Loc, New_Internal_Name ('R'));
5593 Any : constant Entity_Id :=
5594 Make_Defining_Identifier
5595 (Loc, New_Internal_Name ('A'));
5598 -- Object declarations
5601 Make_Object_Declaration (Loc,
5602 Defining_Identifier =>
5604 Object_Definition =>
5605 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
5606 Make_Object_Declaration (Loc,
5607 Defining_Identifier =>
5609 Object_Definition =>
5610 New_Occurrence_Of (RTE (RE_Any), Loc)));
5612 -- If the object is null, nothing to do (Reference is already
5615 Null_Statements := New_List (Make_Null_Statement (Loc));
5619 -- If the object is a RAS designating a local subprogram,
5620 -- we already have a target reference.
5622 Local_Statements := New_List (
5623 Make_Procedure_Call_Statement (Loc,
5625 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
5626 Parameter_Associations => New_List (
5627 New_Occurrence_Of (Reference, Loc),
5628 Make_Selected_Component (Loc,
5630 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
5631 New_Occurrence_Of (RACW_Parameter, Loc)),
5632 Selector_Name => Make_Identifier (Loc, Name_Target)))));
5635 -- If the object is a local RACW object, use Get_Reference now
5636 -- to obtain a reference.
5638 Local_Statements := New_List (
5639 Make_Procedure_Call_Statement (Loc,
5641 New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5642 Parameter_Associations => New_List (
5643 Unchecked_Convert_To (
5645 New_Occurrence_Of (RACW_Parameter, Loc)),
5646 Make_String_Literal (Loc,
5647 Full_Qualified_Name (Designated_Type)),
5648 Make_Attribute_Reference (Loc,
5651 Defining_Identifier (
5652 Stub_Elements.RPC_Receiver_Decl), Loc),
5655 New_Occurrence_Of (Reference, Loc))));
5658 -- If the object is located on another partition, use the target
5661 Stub_Statements := New_List (
5662 Make_Procedure_Call_Statement (Loc,
5664 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
5665 Parameter_Associations => New_List (
5666 New_Occurrence_Of (Reference, Loc),
5667 Make_Selected_Component (Loc,
5668 Prefix => Unchecked_Convert_To (Stub_Type_Access,
5669 New_Occurrence_Of (RACW_Parameter, Loc)),
5671 Make_Identifier (Loc, Name_Target)))));
5673 -- Distinguish between the null, local and remote cases,
5674 -- and execute the appropriate piece of code.
5677 Make_Implicit_If_Statement (RACW_Type,
5680 Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc),
5681 Right_Opnd => Make_Null (Loc)),
5682 Then_Statements => Null_Statements,
5683 Elsif_Parts => New_List (
5684 Make_Elsif_Part (Loc,
5688 Make_Attribute_Reference (Loc,
5690 New_Occurrence_Of (RACW_Parameter, Loc),
5691 Attribute_Name => Name_Tag),
5693 Make_Attribute_Reference (Loc,
5694 Prefix => New_Occurrence_Of (Stub_Type, Loc),
5695 Attribute_Name => Name_Tag)),
5696 Then_Statements => Local_Statements)),
5697 Else_Statements => Stub_Statements);
5699 Statements := New_List (
5701 Make_Assignment_Statement (Loc,
5703 New_Occurrence_Of (Any, Loc),
5705 Make_Function_Call (Loc,
5706 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5707 Parameter_Associations => New_List (
5708 New_Occurrence_Of (Reference, Loc)))),
5709 Make_Procedure_Call_Statement (Loc,
5711 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5712 Parameter_Associations => New_List (
5713 New_Occurrence_Of (Any, Loc),
5714 Make_Selected_Component (Loc,
5716 Defining_Identifier (
5717 Stub_Elements.RPC_Receiver_Decl),
5718 Selector_Name => Name_Obj_TypeCode))),
5719 Make_Return_Statement (Loc,
5721 New_Occurrence_Of (Any, Loc)));
5723 Fnam := Make_Defining_Identifier (
5724 Loc, New_Internal_Name ('T'));
5727 Make_Function_Specification (Loc,
5728 Defining_Unit_Name =>
5730 Parameter_Specifications => New_List (
5731 Make_Parameter_Specification (Loc,
5732 Defining_Identifier =>
5735 New_Occurrence_Of (RACW_Type, Loc))),
5736 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5738 -- NOTE: The usage occurrences of RACW_Parameter must
5739 -- refer to the entity in the declaration spec, not in
5742 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5745 Make_Subprogram_Body (Loc,
5747 Copy_Specification (Loc, Func_Spec),
5748 Declarations => Decls,
5749 Handled_Statement_Sequence =>
5750 Make_Handled_Sequence_Of_Statements (Loc,
5751 Statements => Statements));
5753 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5754 Append_To (Declarations, Func_Body);
5756 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5757 end Add_RACW_To_Any;
5759 -----------------------
5760 -- Add_RACW_TypeCode --
5761 -----------------------
5763 procedure Add_RACW_TypeCode
5764 (Designated_Type : Entity_Id;
5765 RACW_Type : Entity_Id;
5766 Declarations : List_Id)
5768 Loc : constant Source_Ptr := Sloc (RACW_Type);
5772 Stub_Elements : constant Stub_Structure :=
5773 Stubs_Table.Get (Designated_Type);
5774 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5776 Func_Spec : Node_Id;
5777 Func_Decl : Node_Id;
5778 Func_Body : Node_Id;
5782 Make_Defining_Identifier (Loc,
5783 Chars => New_Internal_Name ('T'));
5785 -- The spec for this subprogram has a dummy 'access RACW'
5786 -- argument, which serves only for overloading purposes.
5789 Make_Function_Specification (Loc,
5790 Defining_Unit_Name =>
5792 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
5794 -- NOTE: The usage occurrences of RACW_Parameter must
5795 -- refer to the entity in the declaration spec, not those
5796 -- of the body spec.
5798 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5801 Make_Subprogram_Body (Loc,
5803 Copy_Specification (Loc, Func_Spec),
5804 Declarations => Empty_List,
5805 Handled_Statement_Sequence =>
5806 Make_Handled_Sequence_Of_Statements (Loc,
5807 Statements => New_List (
5808 Make_Return_Statement (Loc,
5810 Make_Selected_Component (Loc,
5812 Defining_Identifier (
5813 Stub_Elements.RPC_Receiver_Decl),
5814 Selector_Name => Name_Obj_TypeCode)))));
5816 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5817 Append_To (Declarations, Func_Body);
5819 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
5820 end Add_RACW_TypeCode;
5822 ------------------------------
5823 -- Add_RACW_Write_Attribute --
5824 ------------------------------
5826 procedure Add_RACW_Write_Attribute
5827 (RACW_Type : Entity_Id;
5828 Stub_Type : Entity_Id;
5829 Stub_Type_Access : Entity_Id;
5830 Declarations : List_Id)
5832 Loc : constant Source_Ptr := Sloc (RACW_Type);
5833 pragma Warnings (Off);
5834 pragma Unreferenced (
5838 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5839 pragma Unreferenced (Is_RAS);
5840 pragma Warnings (On);
5842 Body_Node : Node_Id;
5843 Proc_Decl : Node_Id;
5844 Attr_Decl : Node_Id;
5846 Statements : List_Id;
5847 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
5849 function Stream_Parameter return Node_Id;
5850 function Object return Node_Id;
5851 -- Functions to create occurrences of the formal parameter names
5857 function Object return Node_Id is
5858 Object_Ref : constant Node_Id :=
5859 Make_Identifier (Loc, Name_V);
5862 -- Etype must be set for Build_To_Any_Call
5864 Set_Etype (Object_Ref, RACW_Type);
5869 ----------------------
5870 -- Stream_Parameter --
5871 ----------------------
5873 function Stream_Parameter return Node_Id is
5875 return Make_Identifier (Loc, Name_S);
5876 end Stream_Parameter;
5878 -- Start of processing for Add_RACW_Write_Attribute
5881 Statements := New_List (
5882 Pack_Node_Into_Stream_Access (Loc,
5883 Stream => Stream_Parameter,
5885 Make_Function_Call (Loc,
5887 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5888 Parameter_Associations => New_List (
5889 PolyORB_Support.Helpers.Build_To_Any_Call
5890 (Object, Declarations))),
5891 Etyp => RTE (RE_Object_Ref)));
5893 Build_Stream_Procedure
5894 (Loc, RACW_Type, Body_Node,
5895 Make_Defining_Identifier (Loc, Procedure_Name),
5896 Statements, Outp => False);
5899 Make_Subprogram_Declaration (Loc,
5900 Copy_Specification (Loc, Specification (Body_Node)));
5903 Make_Attribute_Definition_Clause (Loc,
5904 Name => New_Occurrence_Of (RACW_Type, Loc),
5905 Chars => Name_Write,
5908 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5910 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5911 Insert_After (Proc_Decl, Attr_Decl);
5912 Append_To (Declarations, Body_Node);
5913 end Add_RACW_Write_Attribute;
5915 -----------------------
5916 -- Add_RAST_Features --
5917 -----------------------
5919 procedure Add_RAST_Features
5920 (Vis_Decl : Node_Id;
5921 RAS_Type : Entity_Id)
5924 Add_RAS_Access_TSS (Vis_Decl);
5926 Add_RAS_From_Any (RAS_Type);
5927 Add_RAS_TypeCode (RAS_Type);
5929 -- To_Any uses TypeCode, and therefore needs to be generated last
5931 Add_RAS_To_Any (RAS_Type);
5932 end Add_RAST_Features;
5934 ------------------------
5935 -- Add_RAS_Access_TSS --
5936 ------------------------
5938 procedure Add_RAS_Access_TSS (N : Node_Id) is
5939 Loc : constant Source_Ptr := Sloc (N);
5941 Ras_Type : constant Entity_Id := Defining_Identifier (N);
5942 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
5943 -- Ras_Type is the access to subprogram type; Fat_Type is the
5944 -- corresponding record type.
5946 RACW_Type : constant Entity_Id :=
5947 Underlying_RACW_Type (Ras_Type);
5948 Desig : constant Entity_Id :=
5949 Etype (Designated_Type (RACW_Type));
5951 Stub_Elements : constant Stub_Structure :=
5952 Stubs_Table.Get (Desig);
5953 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5955 Proc : constant Entity_Id :=
5956 Make_Defining_Identifier (Loc,
5957 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
5959 Proc_Spec : Node_Id;
5961 -- Formal parameters
5963 Package_Name : constant Entity_Id :=
5964 Make_Defining_Identifier (Loc,
5969 Subp_Id : constant Entity_Id :=
5970 Make_Defining_Identifier (Loc,
5973 -- Target subprogram
5975 Asynch_P : constant Entity_Id :=
5976 Make_Defining_Identifier (Loc,
5977 Chars => Name_Asynchronous);
5978 -- Is the procedure to which the 'Access applies asynchronous?
5980 All_Calls_Remote : constant Entity_Id :=
5981 Make_Defining_Identifier (Loc,
5982 Chars => Name_All_Calls_Remote);
5983 -- True if an All_Calls_Remote pragma applies to the RCI unit
5984 -- that contains the subprogram.
5986 -- Common local variables
5988 Proc_Decls : List_Id;
5989 Proc_Statements : List_Id;
5991 Subp_Ref : constant Entity_Id :=
5992 Make_Defining_Identifier (Loc, Name_R);
5993 -- Reference that designates the target subprogram (returned
5994 -- by Get_RAS_Info).
5996 Is_Local : constant Entity_Id :=
5997 Make_Defining_Identifier (Loc, Name_L);
5998 Local_Addr : constant Entity_Id :=
5999 Make_Defining_Identifier (Loc, Name_A);
6000 -- For the call to Get_Local_Address
6002 -- Additional local variables for the remote case
6004 Local_Stub : constant Entity_Id :=
6005 Make_Defining_Identifier (Loc,
6006 Chars => New_Internal_Name ('L'));
6008 Stub_Ptr : constant Entity_Id :=
6009 Make_Defining_Identifier (Loc,
6010 Chars => New_Internal_Name ('S'));
6013 (Field_Name : Name_Id;
6014 Value : Node_Id) return Node_Id;
6015 -- Construct an assignment that sets the named component in the
6023 (Field_Name : Name_Id;
6024 Value : Node_Id) return Node_Id
6028 Make_Assignment_Statement (Loc,
6030 Make_Selected_Component (Loc,
6032 Selector_Name => Field_Name),
6033 Expression => Value);
6036 -- Start of processing for Add_RAS_Access_TSS
6039 Proc_Decls := New_List (
6041 -- Common declarations
6043 Make_Object_Declaration (Loc,
6044 Defining_Identifier => Subp_Ref,
6045 Object_Definition =>
6046 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6048 Make_Object_Declaration (Loc,
6049 Defining_Identifier => Is_Local,
6050 Object_Definition =>
6051 New_Occurrence_Of (Standard_Boolean, Loc)),
6053 Make_Object_Declaration (Loc,
6054 Defining_Identifier => Local_Addr,
6055 Object_Definition =>
6056 New_Occurrence_Of (RTE (RE_Address), Loc)),
6058 Make_Object_Declaration (Loc,
6059 Defining_Identifier => Local_Stub,
6060 Aliased_Present => True,
6061 Object_Definition =>
6062 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6064 Make_Object_Declaration (Loc,
6065 Defining_Identifier =>
6067 Object_Definition =>
6068 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6070 Make_Attribute_Reference (Loc,
6071 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6072 Attribute_Name => Name_Unchecked_Access)));
6074 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6075 -- Build_Get_Unique_RP_Call needs this information
6077 -- Get_RAS_Info (Pkg, Subp, R);
6078 -- Obtain a reference to the target subprogram
6080 Proc_Statements := New_List (
6081 Make_Procedure_Call_Statement (Loc,
6083 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6084 Parameter_Associations => New_List (
6085 New_Occurrence_Of (Package_Name, Loc),
6086 New_Occurrence_Of (Subp_Id, Loc),
6087 New_Occurrence_Of (Subp_Ref, Loc))),
6089 -- Get_Local_Address (R, L, A);
6090 -- Determine whether the subprogram is local (L), and if so
6091 -- obtain the local address of its proxy (A).
6093 Make_Procedure_Call_Statement (Loc,
6095 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6096 Parameter_Associations => New_List (
6097 New_Occurrence_Of (Subp_Ref, Loc),
6098 New_Occurrence_Of (Is_Local, Loc),
6099 New_Occurrence_Of (Local_Addr, Loc))));
6101 -- Note: Here we assume that the Fat_Type is a record containing just
6102 -- an access to a proxy or stub object.
6104 Append_To (Proc_Statements,
6108 Make_Implicit_If_Statement (N,
6110 New_Occurrence_Of (Is_Local, Loc),
6112 Then_Statements => New_List (
6114 -- if A.Target = null then
6116 Make_Implicit_If_Statement (N,
6119 Make_Selected_Component (Loc,
6121 Unchecked_Convert_To (
6122 RTE (RE_RAS_Proxy_Type_Access),
6123 New_Occurrence_Of (Local_Addr, Loc)),
6125 Make_Identifier (Loc, Name_Target)),
6128 Then_Statements => New_List (
6130 -- A.Target := Entity_Of (Ref);
6132 Make_Assignment_Statement (Loc,
6134 Make_Selected_Component (Loc,
6136 Unchecked_Convert_To (
6137 RTE (RE_RAS_Proxy_Type_Access),
6138 New_Occurrence_Of (Local_Addr, Loc)),
6140 Make_Identifier (Loc, Name_Target)),
6142 Make_Function_Call (Loc,
6144 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6145 Parameter_Associations => New_List (
6146 New_Occurrence_Of (Subp_Ref, Loc)))),
6148 -- Inc_Usage (A.Target);
6150 Make_Procedure_Call_Statement (Loc,
6152 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6153 Parameter_Associations => New_List (
6154 Make_Selected_Component (Loc,
6156 Unchecked_Convert_To (
6157 RTE (RE_RAS_Proxy_Type_Access),
6158 New_Occurrence_Of (Local_Addr, Loc)),
6159 Selector_Name => Make_Identifier (Loc,
6163 -- if not All_Calls_Remote then
6164 -- return Fat_Type!(A);
6167 Make_Implicit_If_Statement (N,
6170 New_Occurrence_Of (All_Calls_Remote, Loc)),
6172 Then_Statements => New_List (
6173 Make_Return_Statement (Loc,
6174 Unchecked_Convert_To (Fat_Type,
6175 New_Occurrence_Of (Local_Addr, Loc))))))));
6177 Append_List_To (Proc_Statements, New_List (
6179 -- Stub.Target := Entity_Of (Ref);
6181 Set_Field (Name_Target,
6182 Make_Function_Call (Loc,
6184 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6185 Parameter_Associations => New_List (
6186 New_Occurrence_Of (Subp_Ref, Loc)))),
6188 -- Inc_Usage (Stub.Target);
6190 Make_Procedure_Call_Statement (Loc,
6192 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6193 Parameter_Associations => New_List (
6194 Make_Selected_Component (Loc,
6196 Selector_Name => Name_Target))),
6198 -- E.4.1(9) A remote call is asynchronous if it is a call to
6199 -- a procedure, or a call through a value of an access-to-procedure
6200 -- type, to which a pragma Asynchronous applies.
6202 -- Parameter Asynch_P is true when the procedure is asynchronous;
6203 -- Expression Asynch_T is true when the type is asynchronous.
6205 Set_Field (Name_Asynchronous,
6207 New_Occurrence_Of (Asynch_P, Loc),
6208 New_Occurrence_Of (Boolean_Literals (
6209 Is_Asynchronous (Ras_Type)), Loc)))));
6211 Append_List_To (Proc_Statements,
6212 Build_Get_Unique_RP_Call (Loc,
6213 Stub_Ptr, Stub_Elements.Stub_Type));
6215 Append_To (Proc_Statements,
6216 Make_Return_Statement (Loc,
6218 Unchecked_Convert_To (Fat_Type,
6219 New_Occurrence_Of (Stub_Ptr, Loc))));
6222 Make_Function_Specification (Loc,
6223 Defining_Unit_Name => Proc,
6224 Parameter_Specifications => New_List (
6225 Make_Parameter_Specification (Loc,
6226 Defining_Identifier => Package_Name,
6228 New_Occurrence_Of (Standard_String, Loc)),
6230 Make_Parameter_Specification (Loc,
6231 Defining_Identifier => Subp_Id,
6233 New_Occurrence_Of (Standard_String, Loc)),
6235 Make_Parameter_Specification (Loc,
6236 Defining_Identifier => Asynch_P,
6238 New_Occurrence_Of (Standard_Boolean, Loc)),
6240 Make_Parameter_Specification (Loc,
6241 Defining_Identifier => All_Calls_Remote,
6243 New_Occurrence_Of (Standard_Boolean, Loc))),
6245 Result_Definition =>
6246 New_Occurrence_Of (Fat_Type, Loc));
6248 -- Set the kind and return type of the function to prevent
6249 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6251 Set_Ekind (Proc, E_Function);
6252 Set_Etype (Proc, Fat_Type);
6255 Make_Subprogram_Body (Loc,
6256 Specification => Proc_Spec,
6257 Declarations => Proc_Decls,
6258 Handled_Statement_Sequence =>
6259 Make_Handled_Sequence_Of_Statements (Loc,
6260 Statements => Proc_Statements)));
6262 Set_TSS (Fat_Type, Proc);
6263 end Add_RAS_Access_TSS;
6265 ----------------------
6266 -- Add_RAS_From_Any --
6267 ----------------------
6269 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6270 Loc : constant Source_Ptr := Sloc (RAS_Type);
6272 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6273 Make_TSS_Name (RAS_Type, TSS_From_Any));
6275 Func_Spec : Node_Id;
6277 Statements : List_Id;
6279 Any_Parameter : constant Entity_Id :=
6280 Make_Defining_Identifier (Loc, Name_A);
6283 Statements := New_List (
6284 Make_Return_Statement (Loc,
6286 Make_Aggregate (Loc,
6287 Component_Associations => New_List (
6288 Make_Component_Association (Loc,
6289 Choices => New_List (
6290 Make_Identifier (Loc, Name_Ras)),
6292 PolyORB_Support.Helpers.Build_From_Any_Call (
6293 Underlying_RACW_Type (RAS_Type),
6294 New_Occurrence_Of (Any_Parameter, Loc),
6298 Make_Function_Specification (Loc,
6299 Defining_Unit_Name =>
6301 Parameter_Specifications => New_List (
6302 Make_Parameter_Specification (Loc,
6303 Defining_Identifier =>
6306 New_Occurrence_Of (RTE (RE_Any), Loc))),
6307 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6310 Make_Subprogram_Body (Loc,
6311 Specification => Func_Spec,
6312 Declarations => No_List,
6313 Handled_Statement_Sequence =>
6314 Make_Handled_Sequence_Of_Statements (Loc,
6315 Statements => Statements)));
6316 Set_TSS (RAS_Type, Fnam);
6317 end Add_RAS_From_Any;
6319 --------------------
6320 -- Add_RAS_To_Any --
6321 --------------------
6323 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6324 Loc : constant Source_Ptr := Sloc (RAS_Type);
6326 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6327 Make_TSS_Name (RAS_Type, TSS_To_Any));
6330 Statements : List_Id;
6332 Func_Spec : Node_Id;
6334 Any : constant Entity_Id :=
6335 Make_Defining_Identifier (Loc,
6336 Chars => New_Internal_Name ('A'));
6337 RAS_Parameter : constant Entity_Id :=
6338 Make_Defining_Identifier (Loc,
6339 Chars => New_Internal_Name ('R'));
6340 RACW_Parameter : constant Node_Id :=
6341 Make_Selected_Component (Loc,
6342 Prefix => RAS_Parameter,
6343 Selector_Name => Name_Ras);
6346 -- Object declarations
6348 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6350 Make_Object_Declaration (Loc,
6351 Defining_Identifier =>
6353 Object_Definition =>
6354 New_Occurrence_Of (RTE (RE_Any), Loc),
6356 PolyORB_Support.Helpers.Build_To_Any_Call
6357 (RACW_Parameter, No_List)));
6359 Statements := New_List (
6360 Make_Procedure_Call_Statement (Loc,
6362 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6363 Parameter_Associations => New_List (
6364 New_Occurrence_Of (Any, Loc),
6365 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6367 Make_Return_Statement (Loc,
6369 New_Occurrence_Of (Any, Loc)));
6372 Make_Function_Specification (Loc,
6373 Defining_Unit_Name =>
6375 Parameter_Specifications => New_List (
6376 Make_Parameter_Specification (Loc,
6377 Defining_Identifier =>
6380 New_Occurrence_Of (RAS_Type, Loc))),
6381 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6384 Make_Subprogram_Body (Loc,
6385 Specification => Func_Spec,
6386 Declarations => Decls,
6387 Handled_Statement_Sequence =>
6388 Make_Handled_Sequence_Of_Statements (Loc,
6389 Statements => Statements)));
6390 Set_TSS (RAS_Type, Fnam);
6393 ----------------------
6394 -- Add_RAS_TypeCode --
6395 ----------------------
6397 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6398 Loc : constant Source_Ptr := Sloc (RAS_Type);
6400 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6401 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6403 Func_Spec : Node_Id;
6405 Decls : constant List_Id := New_List;
6406 Name_String, Repo_Id_String : String_Id;
6410 Make_Function_Specification (Loc,
6411 Defining_Unit_Name =>
6413 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6415 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6416 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6419 Make_Subprogram_Body (Loc,
6420 Specification => Func_Spec,
6421 Declarations => Decls,
6422 Handled_Statement_Sequence =>
6423 Make_Handled_Sequence_Of_Statements (Loc,
6424 Statements => New_List (
6425 Make_Return_Statement (Loc,
6427 Make_Function_Call (Loc,
6429 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6430 Parameter_Associations => New_List (
6431 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6432 Make_Aggregate (Loc,
6435 Make_Function_Call (Loc,
6436 Name => New_Occurrence_Of (
6437 RTE (RE_TA_String), Loc),
6438 Parameter_Associations => New_List (
6439 Make_String_Literal (Loc, Name_String))),
6440 Make_Function_Call (Loc,
6441 Name => New_Occurrence_Of (
6442 RTE (RE_TA_String), Loc),
6443 Parameter_Associations => New_List (
6444 Make_String_Literal (Loc,
6445 Repo_Id_String))))))))))));
6446 Set_TSS (RAS_Type, Fnam);
6447 end Add_RAS_TypeCode;
6449 -----------------------------------------
6450 -- Add_Receiving_Stubs_To_Declarations --
6451 -----------------------------------------
6453 procedure Add_Receiving_Stubs_To_Declarations
6454 (Pkg_Spec : Node_Id;
6457 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6459 Pkg_RPC_Receiver : constant Entity_Id :=
6460 Make_Defining_Identifier (Loc,
6461 New_Internal_Name ('H'));
6462 Pkg_RPC_Receiver_Object : Node_Id;
6464 Pkg_RPC_Receiver_Body : Node_Id;
6465 Pkg_RPC_Receiver_Decls : List_Id;
6466 Pkg_RPC_Receiver_Statements : List_Id;
6467 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6468 -- A Pkg_RPC_Receiver is built to decode the request
6471 -- Request object received from neutral layer
6473 Subp_Id : Entity_Id;
6474 -- Subprogram identifier as received from the neutral
6475 -- distribution core.
6477 Subp_Index : Entity_Id;
6478 -- Internal index as determined by matching either the
6479 -- method name from the request structure, or the local
6480 -- subprogram address (in case of a RAS).
6482 Is_Local : constant Entity_Id :=
6483 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
6484 Local_Address : constant Entity_Id :=
6485 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
6486 -- Address of a local subprogram designated by a
6487 -- reference corresponding to a RAS.
6489 Dispatch_On_Address : constant List_Id := New_List;
6490 Dispatch_On_Name : constant List_Id := New_List;
6492 Current_Declaration : Node_Id;
6493 Current_Stubs : Node_Id;
6494 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6496 Subp_Info_Array : constant Entity_Id :=
6497 Make_Defining_Identifier (Loc,
6498 Chars => New_Internal_Name ('I'));
6500 Subp_Info_List : constant List_Id := New_List;
6502 Register_Pkg_Actuals : constant List_Id := New_List;
6504 All_Calls_Remote_E : Entity_Id;
6506 procedure Append_Stubs_To
6507 (RPC_Receiver_Cases : List_Id;
6508 Declaration : Node_Id;
6511 Subp_Dist_Name : Entity_Id;
6512 Subp_Proxy_Addr : Entity_Id);
6513 -- Add one case to the specified RPC receiver case list associating
6514 -- Subprogram_Number with the subprogram declared by Declaration, for
6515 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6516 -- subprogram index. Subp_Dist_Name is the string used to call the
6517 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6518 -- object, used in the context of calls through remote
6519 -- access-to-subprogram types.
6521 ---------------------
6522 -- Append_Stubs_To --
6523 ---------------------
6525 procedure Append_Stubs_To
6526 (RPC_Receiver_Cases : List_Id;
6527 Declaration : Node_Id;
6530 Subp_Dist_Name : Entity_Id;
6531 Subp_Proxy_Addr : Entity_Id)
6533 Case_Stmts : List_Id;
6535 Case_Stmts := New_List (
6536 Make_Procedure_Call_Statement (Loc,
6539 Defining_Entity (Stubs), Loc),
6540 Parameter_Associations =>
6541 New_List (New_Occurrence_Of (Request, Loc))));
6542 if Nkind (Specification (Declaration))
6543 = N_Function_Specification
6545 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6547 Append_To (Case_Stmts, Make_Return_Statement (Loc));
6550 Append_To (RPC_Receiver_Cases,
6551 Make_Case_Statement_Alternative (Loc,
6553 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6557 Append_To (Dispatch_On_Name,
6558 Make_Elsif_Part (Loc,
6560 Make_Function_Call (Loc,
6562 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6563 Parameter_Associations => New_List (
6564 New_Occurrence_Of (Subp_Id, Loc),
6565 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6566 Then_Statements => New_List (
6567 Make_Assignment_Statement (Loc,
6568 New_Occurrence_Of (Subp_Index, Loc),
6569 Make_Integer_Literal (Loc,
6572 Append_To (Dispatch_On_Address,
6573 Make_Elsif_Part (Loc,
6577 New_Occurrence_Of (Local_Address, Loc),
6579 New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6580 Then_Statements => New_List (
6581 Make_Assignment_Statement (Loc,
6582 New_Occurrence_Of (Subp_Index, Loc),
6583 Make_Integer_Literal (Loc,
6585 end Append_Stubs_To;
6587 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6590 -- Building receiving stubs consist in several operations:
6592 -- - a package RPC receiver must be built. This subprogram
6593 -- will get a Subprogram_Id from the incoming stream
6594 -- and will dispatch the call to the right subprogram
6596 -- - a receiving stub for any subprogram visible in the package
6597 -- spec. This stub will read all the parameters from the stream,
6598 -- and put the result as well as the exception occurrence in the
6601 -- - a dummy package with an empty spec and a body made of an
6602 -- elaboration part, whose job is to register the receiving
6603 -- part of this RCI package on the name server. This is done
6604 -- by calling System.Partition_Interface.Register_Receiving_Stub
6606 Build_RPC_Receiver_Body (
6607 RPC_Receiver => Pkg_RPC_Receiver,
6610 Subp_Index => Subp_Index,
6611 Stmts => Pkg_RPC_Receiver_Statements,
6612 Decl => Pkg_RPC_Receiver_Body);
6613 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6615 -- Extract local address information from the target reference:
6616 -- if non-null, that means that this is a reference that denotes
6617 -- one particular operation, and hence that the operation name
6618 -- must not be taken into account for dispatching.
6620 Append_To (Pkg_RPC_Receiver_Decls,
6621 Make_Object_Declaration (Loc,
6622 Defining_Identifier =>
6624 Object_Definition =>
6625 New_Occurrence_Of (Standard_Boolean, Loc)));
6626 Append_To (Pkg_RPC_Receiver_Decls,
6627 Make_Object_Declaration (Loc,
6628 Defining_Identifier =>
6630 Object_Definition =>
6631 New_Occurrence_Of (RTE (RE_Address), Loc)));
6632 Append_To (Pkg_RPC_Receiver_Statements,
6633 Make_Procedure_Call_Statement (Loc,
6635 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6636 Parameter_Associations => New_List (
6637 Make_Selected_Component (Loc,
6639 Selector_Name => Name_Target),
6640 New_Occurrence_Of (Is_Local, Loc),
6641 New_Occurrence_Of (Local_Address, Loc))));
6643 -- Determine whether the reference that was used to make
6644 -- the call was the base RCI reference (in which case
6645 -- Local_Address is 0, and the method identifier from the
6646 -- request must be used to determine which subprogram is
6647 -- called) or a reference identifying one particular subprogram
6648 -- (in which case Local_Address is the address of that
6649 -- subprogram, and the method name from the request is
6651 -- In each case, cascaded elsifs are used to determine the
6652 -- proper subprogram index. Using hash tables might be
6655 Append_To (Pkg_RPC_Receiver_Statements,
6656 Make_Implicit_If_Statement (Pkg_Spec,
6659 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6660 Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
6661 Then_Statements => New_List (
6662 Make_Implicit_If_Statement (Pkg_Spec,
6664 New_Occurrence_Of (Standard_False, Loc),
6665 Then_Statements => New_List (
6666 Make_Null_Statement (Loc)),
6668 Dispatch_On_Address)),
6669 Else_Statements => New_List (
6670 Make_Implicit_If_Statement (Pkg_Spec,
6672 New_Occurrence_Of (Standard_False, Loc),
6673 Then_Statements => New_List (
6674 Make_Null_Statement (Loc)),
6676 Dispatch_On_Name))));
6678 -- For each subprogram, the receiving stub will be built and a
6679 -- case statement will be made on the Subprogram_Id to dispatch
6680 -- to the right subprogram.
6682 All_Calls_Remote_E := Boolean_Literals (
6683 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6685 Overload_Counter_Table.Reset;
6686 Reserve_NamingContext_Methods;
6688 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
6689 while Present (Current_Declaration) loop
6690 if Nkind (Current_Declaration) = N_Subprogram_Declaration
6691 and then Comes_From_Source (Current_Declaration)
6694 Loc : constant Source_Ptr :=
6695 Sloc (Current_Declaration);
6696 -- While specifically processing Current_Declaration, use
6697 -- its Sloc as the location of all generated nodes.
6699 Subp_Def : constant Entity_Id :=
6701 (Specification (Current_Declaration));
6703 Subp_Val : String_Id;
6705 Subp_Dist_Name : constant Entity_Id :=
6706 Make_Defining_Identifier (Loc,
6708 Related_Id => Chars (Subp_Def),
6710 Suffix_Index => -1));
6712 Proxy_Object_Addr : Entity_Id;
6715 pragma Assert (Current_Subprogram_Number =
6716 Get_Subprogram_Id (Subp_Def));
6718 -- Build receiving stub
6721 Build_Subprogram_Receiving_Stubs
6722 (Vis_Decl => Current_Declaration,
6724 Nkind (Specification (Current_Declaration)) =
6725 N_Procedure_Specification
6726 and then Is_Asynchronous (Subp_Def));
6728 Append_To (Decls, Current_Stubs);
6729 Analyze (Current_Stubs);
6733 Add_RAS_Proxy_And_Analyze (Decls,
6735 Current_Declaration,
6736 All_Calls_Remote_E =>
6738 Proxy_Object_Addr =>
6741 -- Compute distribution identifier
6743 Assign_Subprogram_Identifier (
6745 Current_Subprogram_Number,
6749 Make_Object_Declaration (Loc,
6750 Defining_Identifier => Subp_Dist_Name,
6751 Constant_Present => True,
6752 Object_Definition => New_Occurrence_Of (
6753 Standard_String, Loc),
6755 Make_String_Literal (Loc, Subp_Val)));
6756 Analyze (Last (Decls));
6758 -- Add subprogram descriptor (RCI_Subp_Info) to the
6759 -- subprograms table for this receiver. The aggregate
6760 -- below must be kept consistent with the declaration
6761 -- of type RCI_Subp_Info in System.Partition_Interface.
6763 Append_To (Subp_Info_List,
6764 Make_Component_Association (Loc,
6765 Choices => New_List (
6766 Make_Integer_Literal (Loc,
6767 Current_Subprogram_Number)),
6769 Make_Aggregate (Loc,
6770 Expressions => New_List (
6771 Make_Attribute_Reference (Loc,
6774 Subp_Dist_Name, Loc),
6775 Attribute_Name => Name_Address),
6776 Make_Attribute_Reference (Loc,
6779 Subp_Dist_Name, Loc),
6780 Attribute_Name => Name_Length),
6781 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
6783 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6784 Declaration => Current_Declaration,
6785 Stubs => Current_Stubs,
6786 Subp_Number => Current_Subprogram_Number,
6787 Subp_Dist_Name => Subp_Dist_Name,
6788 Subp_Proxy_Addr => Proxy_Object_Addr);
6791 Current_Subprogram_Number := Current_Subprogram_Number + 1;
6794 Next (Current_Declaration);
6797 -- If we receive an invalid Subprogram_Id, it is best to do nothing
6798 -- rather than raising an exception since we do not want someone
6799 -- to crash a remote partition by sending invalid subprogram ids.
6800 -- This is consistent with the other parts of the case statement
6801 -- since even in presence of incorrect parameters in the stream,
6802 -- every exception will be caught and (if the subprogram is not an
6803 -- APC) put into the result stream and sent away.
6805 Append_To (Pkg_RPC_Receiver_Cases,
6806 Make_Case_Statement_Alternative (Loc,
6808 New_List (Make_Others_Choice (Loc)),
6810 New_List (Make_Null_Statement (Loc))));
6812 Append_To (Pkg_RPC_Receiver_Statements,
6813 Make_Case_Statement (Loc,
6815 New_Occurrence_Of (Subp_Index, Loc),
6816 Alternatives => Pkg_RPC_Receiver_Cases));
6819 Make_Object_Declaration (Loc,
6820 Defining_Identifier => Subp_Info_Array,
6821 Constant_Present => True,
6822 Aliased_Present => True,
6823 Object_Definition =>
6824 Make_Subtype_Indication (Loc,
6826 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6828 Make_Index_Or_Discriminant_Constraint (Loc,
6831 Low_Bound => Make_Integer_Literal (Loc,
6832 First_RCI_Subprogram_Id),
6834 Make_Integer_Literal (Loc,
6835 First_RCI_Subprogram_Id
6836 + List_Length (Subp_Info_List) - 1))))),
6838 Make_Aggregate (Loc,
6839 Component_Associations => Subp_Info_List)));
6840 Analyze (Last (Decls));
6842 Append_To (Decls, Pkg_RPC_Receiver_Body);
6843 Analyze (Last (Decls));
6845 Pkg_RPC_Receiver_Object :=
6846 Make_Object_Declaration (Loc,
6847 Defining_Identifier =>
6848 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
6849 Aliased_Present => True,
6850 Object_Definition =>
6851 New_Occurrence_Of (RTE (RE_Servant), Loc));
6852 Append_To (Decls, Pkg_RPC_Receiver_Object);
6853 Analyze (Last (Decls));
6855 Get_Library_Unit_Name_String (Pkg_Spec);
6856 Append_To (Register_Pkg_Actuals,
6858 Make_String_Literal (Loc,
6859 Strval => String_From_Name_Buffer));
6861 Append_To (Register_Pkg_Actuals,
6863 Make_Attribute_Reference (Loc,
6866 (Defining_Entity (Pkg_Spec), Loc),
6870 Append_To (Register_Pkg_Actuals,
6872 Make_Attribute_Reference (Loc,
6874 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
6875 Attribute_Name => Name_Access));
6877 Append_To (Register_Pkg_Actuals,
6879 Make_Attribute_Reference (Loc,
6882 Defining_Identifier (
6883 Pkg_RPC_Receiver_Object), Loc),
6887 Append_To (Register_Pkg_Actuals,
6889 Make_Attribute_Reference (Loc,
6891 New_Occurrence_Of (Subp_Info_Array, Loc),
6895 Append_To (Register_Pkg_Actuals,
6897 Make_Attribute_Reference (Loc,
6899 New_Occurrence_Of (Subp_Info_Array, Loc),
6903 Append_To (Register_Pkg_Actuals,
6904 -- Is_All_Calls_Remote
6905 New_Occurrence_Of (All_Calls_Remote_E, Loc));
6908 Make_Procedure_Call_Statement (Loc,
6910 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
6911 Parameter_Associations => Register_Pkg_Actuals));
6912 Analyze (Last (Decls));
6914 end Add_Receiving_Stubs_To_Declarations;
6916 ---------------------------------
6917 -- Build_General_Calling_Stubs --
6918 ---------------------------------
6920 procedure Build_General_Calling_Stubs
6922 Statements : List_Id;
6923 Target_Object : Node_Id;
6924 Subprogram_Id : Node_Id;
6925 Asynchronous : Node_Id := Empty;
6926 Is_Known_Asynchronous : Boolean := False;
6927 Is_Known_Non_Asynchronous : Boolean := False;
6928 Is_Function : Boolean;
6930 Stub_Type : Entity_Id := Empty;
6931 RACW_Type : Entity_Id := Empty;
6934 Loc : constant Source_Ptr := Sloc (Nod);
6936 Arguments : Node_Id;
6937 -- Name of the named values list used to transmit parameters
6938 -- to the remote package
6941 -- The request object constructed by these stubs
6944 -- Name of the result named value (in non-APC cases) which get the
6945 -- result of the remote subprogram.
6947 Result_TC : Node_Id;
6948 -- Typecode expression for the result of the request (void
6949 -- typecode for procedures).
6951 Exception_Return_Parameter : Node_Id;
6952 -- Name of the parameter which will hold the exception sent by the
6953 -- remote subprogram.
6955 Current_Parameter : Node_Id;
6956 -- Current parameter being handled
6958 Ordered_Parameters_List : constant List_Id :=
6959 Build_Ordered_Parameters_List (Spec);
6961 Asynchronous_P : Node_Id;
6962 -- A Boolean expression indicating whether this call is asynchronous
6964 Asynchronous_Statements : List_Id := No_List;
6965 Non_Asynchronous_Statements : List_Id := No_List;
6966 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
6968 Extra_Formal_Statements : constant List_Id := New_List;
6969 -- List of statements for extra formal parameters. It will appear
6970 -- after the regular statements for writing out parameters.
6972 After_Statements : constant List_Id := New_List;
6973 -- Statements to be executed after call returns (to assign
6974 -- in out or out parameter values).
6977 -- The type of the formal parameter being processed
6979 Is_Controlling_Formal : Boolean;
6980 Is_First_Controlling_Formal : Boolean;
6981 First_Controlling_Formal_Seen : Boolean := False;
6982 -- Controlling formal parameters of distributed object
6983 -- primitives require special handling, and the first
6984 -- such parameter needs even more.
6987 -- ??? document general form of stub subprograms for the PolyORB case
6989 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
6992 Make_Object_Declaration (Loc,
6993 Defining_Identifier => Request,
6994 Aliased_Present => False,
6995 Object_Definition =>
6996 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
6999 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7002 Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7003 Etype (Result_Definition (Spec)), Decls);
7005 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7009 Make_Object_Declaration (Loc,
7010 Defining_Identifier => Result,
7011 Aliased_Present => False,
7012 Object_Definition =>
7013 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7015 Make_Aggregate (Loc,
7016 Component_Associations => New_List (
7017 Make_Component_Association (Loc,
7018 Choices => New_List (
7019 Make_Identifier (Loc, Name_Name)),
7021 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7022 Make_Component_Association (Loc,
7023 Choices => New_List (
7024 Make_Identifier (Loc, Name_Argument)),
7026 Make_Function_Call (Loc,
7028 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7029 Parameter_Associations => New_List (
7031 Make_Component_Association (Loc,
7032 Choices => New_List (
7033 Make_Identifier (Loc, Name_Arg_Modes)),
7035 Make_Integer_Literal (Loc, 0))))));
7037 if not Is_Known_Asynchronous then
7038 Exception_Return_Parameter :=
7039 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7042 Make_Object_Declaration (Loc,
7043 Defining_Identifier => Exception_Return_Parameter,
7044 Object_Definition =>
7045 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7048 Exception_Return_Parameter := Empty;
7051 -- Initialize and fill in arguments list
7054 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7055 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7057 Current_Parameter := First (Ordered_Parameters_List);
7058 while Present (Current_Parameter) loop
7060 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7061 Is_Controlling_Formal := True;
7062 Is_First_Controlling_Formal :=
7063 not First_Controlling_Formal_Seen;
7064 First_Controlling_Formal_Seen := True;
7066 Is_Controlling_Formal := False;
7067 Is_First_Controlling_Formal := False;
7070 if Is_Controlling_Formal then
7072 -- In the case of a controlling formal argument, we send
7078 Etyp := Etype (Parameter_Type (Current_Parameter));
7081 -- The first controlling formal parameter is treated
7082 -- specially: it is used to set the target object of
7085 if not Is_First_Controlling_Formal then
7088 Constrained : constant Boolean :=
7089 Is_Constrained (Etyp)
7090 or else Is_Elementary_Type (Etyp);
7092 Any : constant Entity_Id :=
7093 Make_Defining_Identifier (Loc,
7094 New_Internal_Name ('A'));
7096 Actual_Parameter : Node_Id :=
7098 Defining_Identifier (
7099 Current_Parameter), Loc);
7104 if Is_Controlling_Formal then
7106 -- For a controlling formal parameter (other
7107 -- than the first one), use the corresponding
7108 -- RACW. If the parameter is not an anonymous
7109 -- access parameter, that involves taking
7110 -- its 'Unrestricted_Access.
7112 if Nkind (Parameter_Type (Current_Parameter))
7113 = N_Access_Definition
7115 Actual_Parameter := OK_Convert_To
7116 (Etyp, Actual_Parameter);
7118 Actual_Parameter := OK_Convert_To (Etyp,
7119 Make_Attribute_Reference (Loc,
7123 Name_Unrestricted_Access));
7128 if In_Present (Current_Parameter)
7129 or else not Out_Present (Current_Parameter)
7130 or else not Constrained
7131 or else Is_Controlling_Formal
7133 -- The parameter has an input value, is constrained
7134 -- at runtime by an input value, or is a controlling
7135 -- formal parameter (always passed as a reference)
7136 -- other than the first one.
7138 Expr := PolyORB_Support.Helpers.Build_To_Any_Call (
7139 Actual_Parameter, Decls);
7141 Expr := Make_Function_Call (Loc,
7143 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7144 Parameter_Associations => New_List (
7145 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7150 Make_Object_Declaration (Loc,
7151 Defining_Identifier =>
7153 Aliased_Present => False,
7154 Object_Definition =>
7155 New_Occurrence_Of (RTE (RE_Any), Loc),
7159 Append_To (Statements,
7160 Add_Parameter_To_NVList (Loc,
7161 Parameter => Current_Parameter,
7162 NVList => Arguments,
7163 Constrained => Constrained,
7166 if Out_Present (Current_Parameter)
7167 and then not Is_Controlling_Formal
7169 Append_To (After_Statements,
7170 Make_Assignment_Statement (Loc,
7173 Defining_Identifier (Current_Parameter), Loc),
7175 PolyORB_Support.Helpers.Build_From_Any_Call (
7176 Etype (Parameter_Type (Current_Parameter)),
7177 New_Occurrence_Of (Any, Loc),
7184 -- If the current parameter has a dynamic constrained status,
7185 -- then this status is transmitted as well.
7186 -- This should be done for accessibility as well ???
7188 if Nkind (Parameter_Type (Current_Parameter))
7189 /= N_Access_Definition
7190 and then Need_Extra_Constrained (Current_Parameter)
7192 -- In this block, we do not use the extra formal that has been
7193 -- created because it does not exist at the time of expansion
7194 -- when building calling stubs for remote access to subprogram
7195 -- types. We create an extra variable of this type and push it
7196 -- in the stream after the regular parameters.
7199 Extra_Any_Parameter : constant Entity_Id :=
7200 Make_Defining_Identifier
7201 (Loc, New_Internal_Name ('P'));
7205 Make_Object_Declaration (Loc,
7206 Defining_Identifier =>
7207 Extra_Any_Parameter,
7208 Aliased_Present => False,
7209 Object_Definition =>
7210 New_Occurrence_Of (RTE (RE_Any), Loc),
7212 PolyORB_Support.Helpers.Build_To_Any_Call (
7213 Make_Attribute_Reference (Loc,
7216 Defining_Identifier (Current_Parameter), Loc),
7217 Attribute_Name => Name_Constrained),
7219 Append_To (Extra_Formal_Statements,
7220 Add_Parameter_To_NVList (Loc,
7221 Parameter => Extra_Any_Parameter,
7222 NVList => Arguments,
7223 Constrained => True,
7224 Any => Extra_Any_Parameter));
7228 Next (Current_Parameter);
7231 -- Append the formal statements list to the statements
7233 Append_List_To (Statements, Extra_Formal_Statements);
7235 Append_To (Statements,
7236 Make_Procedure_Call_Statement (Loc,
7238 New_Occurrence_Of (RTE (RE_Request_Create), Loc),
7239 Parameter_Associations => New_List (
7242 New_Occurrence_Of (Arguments, Loc),
7243 New_Occurrence_Of (Result, Loc),
7244 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7246 Append_To (Parameter_Associations (Last (Statements)),
7247 New_Occurrence_Of (Request, Loc));
7250 not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7251 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7252 Asynchronous_P := New_Occurrence_Of (
7253 Boolean_Literals (Is_Known_Asynchronous), Loc);
7255 pragma Assert (Present (Asynchronous));
7256 Asynchronous_P := New_Copy_Tree (Asynchronous);
7257 -- The expression node Asynchronous will be used to build
7258 -- an 'if' statement at the end of Build_General_Calling_Stubs:
7259 -- we need to make a copy here.
7262 Append_To (Parameter_Associations (Last (Statements)),
7263 Make_Indexed_Component (Loc,
7266 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7267 Expressions => New_List (Asynchronous_P)));
7269 Append_To (Statements,
7270 Make_Procedure_Call_Statement (Loc,
7272 New_Occurrence_Of (RTE (RE_Request_Invoke), Loc),
7273 Parameter_Associations => New_List (
7274 New_Occurrence_Of (Request, Loc))));
7276 Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7277 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7279 if not Is_Known_Asynchronous then
7281 -- Reraise an exception occurrence from the completed request.
7282 -- If the exception occurrence is empty, this is a no-op.
7284 Append_To (Non_Asynchronous_Statements,
7285 Make_Procedure_Call_Statement (Loc,
7287 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7288 Parameter_Associations => New_List (
7289 New_Occurrence_Of (Request, Loc))));
7293 -- If this is a function call, then read the value and
7296 Append_To (Non_Asynchronous_Statements,
7297 Make_Tag_Check (Loc,
7298 Make_Return_Statement (Loc,
7299 PolyORB_Support.Helpers.Build_From_Any_Call (
7300 Etype (Result_Definition (Spec)),
7301 Make_Selected_Component (Loc,
7303 Selector_Name => Name_Argument),
7308 Append_List_To (Non_Asynchronous_Statements,
7311 if Is_Known_Asynchronous then
7312 Append_List_To (Statements, Asynchronous_Statements);
7314 elsif Is_Known_Non_Asynchronous then
7315 Append_List_To (Statements, Non_Asynchronous_Statements);
7318 pragma Assert (Present (Asynchronous));
7319 Append_To (Statements,
7320 Make_Implicit_If_Statement (Nod,
7321 Condition => Asynchronous,
7322 Then_Statements => Asynchronous_Statements,
7323 Else_Statements => Non_Asynchronous_Statements));
7325 end Build_General_Calling_Stubs;
7327 -----------------------
7328 -- Build_Stub_Target --
7329 -----------------------
7331 function Build_Stub_Target
7334 RCI_Locator : Entity_Id;
7335 Controlling_Parameter : Entity_Id) return RPC_Target
7337 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7338 Target_Reference : constant Entity_Id :=
7339 Make_Defining_Identifier (Loc,
7340 New_Internal_Name ('T'));
7342 if Present (Controlling_Parameter) then
7344 Make_Object_Declaration (Loc,
7345 Defining_Identifier => Target_Reference,
7346 Object_Definition =>
7347 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7349 Make_Function_Call (Loc,
7351 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7352 Parameter_Associations => New_List (
7353 Make_Selected_Component (Loc,
7354 Prefix => Controlling_Parameter,
7355 Selector_Name => Name_Target)))));
7356 -- Controlling_Parameter has the same components
7357 -- as System.Partition_Interface.RACW_Stub_Type.
7359 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7362 Target_Info.Object :=
7363 Make_Selected_Component (Loc,
7365 Make_Identifier (Loc, Chars (RCI_Locator)),
7367 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7370 end Build_Stub_Target;
7372 ---------------------
7373 -- Build_Stub_Type --
7374 ---------------------
7376 procedure Build_Stub_Type
7377 (RACW_Type : Entity_Id;
7378 Stub_Type : Entity_Id;
7379 Stub_Type_Decl : out Node_Id;
7380 RPC_Receiver_Decl : out Node_Id)
7382 Loc : constant Source_Ptr := Sloc (Stub_Type);
7383 pragma Warnings (Off);
7384 pragma Unreferenced (RACW_Type);
7385 pragma Warnings (On);
7389 Make_Full_Type_Declaration (Loc,
7390 Defining_Identifier => Stub_Type,
7392 Make_Record_Definition (Loc,
7393 Tagged_Present => True,
7394 Limited_Present => True,
7396 Make_Component_List (Loc,
7397 Component_Items => New_List (
7399 Make_Component_Declaration (Loc,
7400 Defining_Identifier =>
7401 Make_Defining_Identifier (Loc, Name_Target),
7402 Component_Definition =>
7403 Make_Component_Definition (Loc,
7406 Subtype_Indication =>
7407 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7409 Make_Component_Declaration (Loc,
7410 Defining_Identifier =>
7411 Make_Defining_Identifier (Loc, Name_Asynchronous),
7412 Component_Definition =>
7413 Make_Component_Definition (Loc,
7414 Aliased_Present => False,
7415 Subtype_Indication =>
7417 Standard_Boolean, Loc)))))));
7419 RPC_Receiver_Decl :=
7420 Make_Object_Declaration (Loc,
7421 Defining_Identifier => Make_Defining_Identifier (Loc,
7422 New_Internal_Name ('R')),
7423 Aliased_Present => True,
7424 Object_Definition =>
7425 New_Occurrence_Of (RTE (RE_Servant), Loc));
7426 end Build_Stub_Type;
7428 -----------------------------
7429 -- Build_RPC_Receiver_Body --
7430 -----------------------------
7432 procedure Build_RPC_Receiver_Body
7433 (RPC_Receiver : Entity_Id;
7434 Request : out Entity_Id;
7435 Subp_Id : out Entity_Id;
7436 Subp_Index : out Entity_Id;
7437 Stmts : out List_Id;
7440 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7442 RPC_Receiver_Spec : Node_Id;
7443 RPC_Receiver_Decls : List_Id;
7446 Request := Make_Defining_Identifier (Loc, Name_R);
7448 RPC_Receiver_Spec :=
7449 Build_RPC_Receiver_Specification (
7450 RPC_Receiver => RPC_Receiver,
7451 Request_Parameter => Request);
7453 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7454 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7456 RPC_Receiver_Decls := New_List (
7457 Make_Object_Renaming_Declaration (Loc,
7458 Defining_Identifier => Subp_Id,
7459 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7461 Make_Explicit_Dereference (Loc,
7463 Make_Selected_Component (Loc,
7465 Selector_Name => Name_Operation))),
7467 Make_Object_Declaration (Loc,
7468 Defining_Identifier => Subp_Index,
7469 Object_Definition =>
7470 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7472 Make_Attribute_Reference (Loc,
7474 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7475 Attribute_Name => Name_Last)));
7480 Make_Subprogram_Body (Loc,
7481 Specification => RPC_Receiver_Spec,
7482 Declarations => RPC_Receiver_Decls,
7483 Handled_Statement_Sequence =>
7484 Make_Handled_Sequence_Of_Statements (Loc,
7485 Statements => Stmts));
7486 end Build_RPC_Receiver_Body;
7488 --------------------------------------
7489 -- Build_Subprogram_Receiving_Stubs --
7490 --------------------------------------
7492 function Build_Subprogram_Receiving_Stubs
7493 (Vis_Decl : Node_Id;
7494 Asynchronous : Boolean;
7495 Dynamically_Asynchronous : Boolean := False;
7496 Stub_Type : Entity_Id := Empty;
7497 RACW_Type : Entity_Id := Empty;
7498 Parent_Primitive : Entity_Id := Empty) return Node_Id
7500 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7502 Request_Parameter : Node_Id;
7505 Outer_Decls : constant List_Id := New_List;
7506 -- At the outermost level, an NVList and Any's are
7507 -- declared for all parameters. The Dynamic_Async
7508 -- flag also needs to be declared there to be visible
7509 -- from the exception handling code.
7511 Outer_Statements : constant List_Id := New_List;
7512 -- Statements that occur prior to the declaration of the actual
7513 -- parameter variables.
7515 Decls : constant List_Id := New_List;
7516 -- All the parameters will get declared before calling the real
7517 -- subprograms. Also the out parameters will be declared.
7518 -- At this level, parameters may be unconstrained.
7520 Statements : constant List_Id := New_List;
7522 Extra_Formal_Statements : constant List_Id := New_List;
7523 -- Statements concerning extra formal parameters
7525 After_Statements : constant List_Id := New_List;
7526 -- Statements to be executed after the subprogram call
7528 Inner_Decls : List_Id := No_List;
7529 -- In case of a function, the inner declarations are needed since
7530 -- the result may be unconstrained.
7532 Excep_Handlers : List_Id := No_List;
7534 Parameter_List : constant List_Id := New_List;
7535 -- List of parameters to be passed to the subprogram
7537 First_Controlling_Formal_Seen : Boolean := False;
7539 Current_Parameter : Node_Id;
7541 Ordered_Parameters_List : constant List_Id :=
7542 Build_Ordered_Parameters_List
7543 (Specification (Vis_Decl));
7545 Arguments : Node_Id;
7546 -- Name of the named values list used to retrieve parameters
7548 Subp_Spec : Node_Id;
7549 -- Subprogram specification
7551 Called_Subprogram : Node_Id;
7552 -- The subprogram to call
7555 if Present (RACW_Type) then
7556 Called_Subprogram :=
7557 New_Occurrence_Of (Parent_Primitive, Loc);
7559 Called_Subprogram :=
7561 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7564 Request_Parameter :=
7565 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7568 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7569 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7571 -- Loop through every parameter and get its value from the stream. If
7572 -- the parameter is unconstrained, then the parameter is read using
7573 -- 'Input at the point of declaration.
7575 Current_Parameter := First (Ordered_Parameters_List);
7576 while Present (Current_Parameter) loop
7579 Constrained : Boolean;
7580 Any : Entity_Id := Empty;
7581 Object : constant Entity_Id :=
7582 Make_Defining_Identifier (Loc,
7583 New_Internal_Name ('P'));
7584 Expr : Node_Id := Empty;
7586 Is_Controlling_Formal : constant Boolean
7587 := Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
7589 Is_First_Controlling_Formal : Boolean := False;
7591 Set_Ekind (Object, E_Variable);
7593 if Is_Controlling_Formal then
7595 -- Controlling formals in distributed object primitive
7596 -- operations are handled specially:
7597 -- - the first controlling formal is used as the
7598 -- target of the call;
7599 -- - the remaining controlling formals are transmitted
7603 Is_First_Controlling_Formal :=
7604 not First_Controlling_Formal_Seen;
7605 First_Controlling_Formal_Seen := True;
7607 Etyp := Etype (Parameter_Type (Current_Parameter));
7611 Is_Constrained (Etyp)
7612 or else Is_Elementary_Type (Etyp);
7614 if not Is_First_Controlling_Formal then
7615 Any := Make_Defining_Identifier (Loc,
7616 New_Internal_Name ('A'));
7617 Append_To (Outer_Decls,
7618 Make_Object_Declaration (Loc,
7619 Defining_Identifier =>
7621 Object_Definition =>
7622 New_Occurrence_Of (RTE (RE_Any), Loc),
7624 Make_Function_Call (Loc,
7626 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7627 Parameter_Associations => New_List (
7628 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7629 Etyp, Outer_Decls)))));
7631 Append_To (Outer_Statements,
7632 Add_Parameter_To_NVList (Loc,
7633 Parameter => Current_Parameter,
7634 NVList => Arguments,
7635 Constrained => Constrained,
7639 if Is_First_Controlling_Formal then
7641 Addr : constant Entity_Id :=
7642 Make_Defining_Identifier (Loc,
7643 New_Internal_Name ('A'));
7644 Is_Local : constant Entity_Id :=
7645 Make_Defining_Identifier (Loc,
7646 New_Internal_Name ('L'));
7649 -- Special case: obtain the first controlling
7650 -- formal from the target of the remote call,
7651 -- instead of the argument list.
7653 Append_To (Outer_Decls,
7654 Make_Object_Declaration (Loc,
7655 Defining_Identifier =>
7657 Object_Definition =>
7658 New_Occurrence_Of (RTE (RE_Address), Loc)));
7659 Append_To (Outer_Decls,
7660 Make_Object_Declaration (Loc,
7661 Defining_Identifier =>
7663 Object_Definition =>
7664 New_Occurrence_Of (Standard_Boolean, Loc)));
7665 Append_To (Outer_Statements,
7666 Make_Procedure_Call_Statement (Loc,
7669 RTE (RE_Get_Local_Address), Loc),
7670 Parameter_Associations => New_List (
7671 Make_Selected_Component (Loc,
7674 Request_Parameter, Loc),
7676 Make_Identifier (Loc, Name_Target)),
7677 New_Occurrence_Of (Is_Local, Loc),
7678 New_Occurrence_Of (Addr, Loc))));
7680 Expr := Unchecked_Convert_To (RACW_Type,
7681 New_Occurrence_Of (Addr, Loc));
7684 elsif In_Present (Current_Parameter)
7685 or else not Out_Present (Current_Parameter)
7686 or else not Constrained
7688 -- If an input parameter is contrained, then its reading is
7689 -- deferred until the beginning of the subprogram body. If
7690 -- it is unconstrained, then an expression is built for
7691 -- the object declaration and the variable is set using
7692 -- 'Input instead of 'Read.
7694 Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
7695 Etyp, New_Occurrence_Of (Any, Loc), Decls);
7699 Append_To (Statements,
7700 Make_Assignment_Statement (Loc,
7702 New_Occurrence_Of (Object, Loc),
7708 -- Expr will be used to initialize (and constrain)
7709 -- the parameter when it is declared.
7714 -- If we do not have to output the current parameter, then
7715 -- it can well be flagged as constant. This may allow further
7716 -- optimizations done by the back end.
7719 Make_Object_Declaration (Loc,
7720 Defining_Identifier => Object,
7721 Constant_Present => not Constrained
7722 and then not Out_Present (Current_Parameter),
7723 Object_Definition =>
7724 New_Occurrence_Of (Etyp, Loc),
7725 Expression => Expr));
7726 Set_Etype (Object, Etyp);
7728 -- An out parameter may be written back using a 'Write
7729 -- attribute instead of a 'Output because it has been
7730 -- constrained by the parameter given to the caller. Note that
7731 -- out controlling arguments in the case of a RACW are not put
7732 -- back in the stream because the pointer on them has not
7735 if Out_Present (Current_Parameter)
7736 and then not Is_Controlling_Formal
7738 Append_To (After_Statements,
7739 Make_Procedure_Call_Statement (Loc,
7741 New_Occurrence_Of (RTE (RE_Copy_Any_Value), Loc),
7742 Parameter_Associations => New_List (
7743 New_Occurrence_Of (Any, Loc),
7744 PolyORB_Support.Helpers.Build_To_Any_Call (
7745 New_Occurrence_Of (Object, Loc),
7749 -- For RACW controlling formals, the Etyp of Object is always
7750 -- an RACW, even if the parameter is not of an anonymous access
7751 -- type. In such case, we need to dereference it at call time.
7753 if Is_Controlling_Formal then
7754 if Nkind (Parameter_Type (Current_Parameter)) /=
7757 Append_To (Parameter_List,
7758 Make_Parameter_Association (Loc,
7761 Defining_Identifier (Current_Parameter), Loc),
7762 Explicit_Actual_Parameter =>
7763 Make_Explicit_Dereference (Loc,
7764 Unchecked_Convert_To (RACW_Type,
7765 OK_Convert_To (RTE (RE_Address),
7766 New_Occurrence_Of (Object, Loc))))));
7769 Append_To (Parameter_List,
7770 Make_Parameter_Association (Loc,
7773 Defining_Identifier (Current_Parameter), Loc),
7774 Explicit_Actual_Parameter =>
7775 Unchecked_Convert_To (RACW_Type,
7776 OK_Convert_To (RTE (RE_Address),
7777 New_Occurrence_Of (Object, Loc)))));
7781 Append_To (Parameter_List,
7782 Make_Parameter_Association (Loc,
7785 Defining_Identifier (Current_Parameter), Loc),
7786 Explicit_Actual_Parameter =>
7787 New_Occurrence_Of (Object, Loc)));
7790 -- If the current parameter needs an extra formal, then read it
7791 -- from the stream and set the corresponding semantic field in
7792 -- the variable. If the kind of the parameter identifier is
7793 -- E_Void, then this is a compiler generated parameter that
7794 -- doesn't need an extra constrained status.
7796 -- The case of Extra_Accessibility should also be handled ???
7798 if Nkind (Parameter_Type (Current_Parameter)) /=
7801 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7803 Present (Extra_Constrained
7804 (Defining_Identifier (Current_Parameter)))
7807 Extra_Parameter : constant Entity_Id :=
7809 (Defining_Identifier
7810 (Current_Parameter));
7811 Extra_Any : constant Entity_Id :=
7812 Make_Defining_Identifier
7813 (Loc, New_Internal_Name ('A'));
7814 Formal_Entity : constant Entity_Id :=
7815 Make_Defining_Identifier
7816 (Loc, Chars (Extra_Parameter));
7818 Formal_Type : constant Entity_Id :=
7819 Etype (Extra_Parameter);
7821 Append_To (Outer_Decls,
7822 Make_Object_Declaration (Loc,
7823 Defining_Identifier =>
7825 Object_Definition =>
7826 New_Occurrence_Of (RTE (RE_Any), Loc)));
7828 Append_To (Outer_Statements,
7829 Add_Parameter_To_NVList (Loc,
7830 Parameter => Extra_Parameter,
7831 NVList => Arguments,
7832 Constrained => True,
7836 Make_Object_Declaration (Loc,
7837 Defining_Identifier => Formal_Entity,
7838 Object_Definition =>
7839 New_Occurrence_Of (Formal_Type, Loc)));
7841 Append_To (Extra_Formal_Statements,
7842 Make_Assignment_Statement (Loc,
7844 New_Occurrence_Of (Extra_Parameter, Loc),
7846 PolyORB_Support.Helpers.Build_From_Any_Call (
7847 Etype (Extra_Parameter),
7848 New_Occurrence_Of (Extra_Any, Loc),
7850 Set_Extra_Constrained (Object, Formal_Entity);
7856 Next (Current_Parameter);
7859 Append_To (Outer_Statements,
7860 Make_Procedure_Call_Statement (Loc,
7862 New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
7863 Parameter_Associations => New_List (
7864 New_Occurrence_Of (Request_Parameter, Loc),
7865 New_Occurrence_Of (Arguments, Loc))));
7867 Append_List_To (Statements, Extra_Formal_Statements);
7869 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
7871 -- The remote subprogram is a function. We build an inner block to
7872 -- be able to hold a potentially unconstrained result in a
7876 Etyp : constant Entity_Id :=
7877 Etype (Result_Definition (Specification (Vis_Decl)));
7878 Result : constant Node_Id :=
7879 Make_Defining_Identifier (Loc,
7880 New_Internal_Name ('R'));
7882 Inner_Decls := New_List (
7883 Make_Object_Declaration (Loc,
7884 Defining_Identifier => Result,
7885 Constant_Present => True,
7886 Object_Definition => New_Occurrence_Of (Etyp, Loc),
7888 Make_Function_Call (Loc,
7889 Name => Called_Subprogram,
7890 Parameter_Associations => Parameter_List)));
7892 Set_Etype (Result, Etyp);
7893 Append_To (After_Statements,
7894 Make_Procedure_Call_Statement (Loc,
7896 New_Occurrence_Of (RTE (RE_Set_Result), Loc),
7897 Parameter_Associations => New_List (
7898 New_Occurrence_Of (Request_Parameter, Loc),
7899 PolyORB_Support.Helpers.Build_To_Any_Call (
7900 New_Occurrence_Of (Result, Loc),
7902 -- A DSA function does not have out or inout arguments
7905 Append_To (Statements,
7906 Make_Block_Statement (Loc,
7907 Declarations => Inner_Decls,
7908 Handled_Statement_Sequence =>
7909 Make_Handled_Sequence_Of_Statements (Loc,
7910 Statements => After_Statements)));
7913 -- The remote subprogram is a procedure. We do not need any inner
7914 -- block in this case. No specific processing is required here for
7915 -- the dynamically asynchronous case: the indication of whether
7916 -- call is asynchronous or not is managed by the Sync_Scope
7917 -- attibute of the request, and is handled entirely in the
7920 Append_To (After_Statements,
7921 Make_Procedure_Call_Statement (Loc,
7923 New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
7924 Parameter_Associations => New_List (
7925 New_Occurrence_Of (Request_Parameter, Loc))));
7927 Append_To (Statements,
7928 Make_Procedure_Call_Statement (Loc,
7929 Name => Called_Subprogram,
7930 Parameter_Associations => Parameter_List));
7932 Append_List_To (Statements, After_Statements);
7936 Make_Procedure_Specification (Loc,
7937 Defining_Unit_Name =>
7938 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
7940 Parameter_Specifications => New_List (
7941 Make_Parameter_Specification (Loc,
7942 Defining_Identifier => Request_Parameter,
7944 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
7946 -- An exception raised during the execution of an incoming
7947 -- remote subprogram call and that needs to be sent back
7948 -- to the caller is propagated by the receiving stubs, and
7949 -- will be handled by the caller (the distribution runtime).
7951 if Asynchronous and then not Dynamically_Asynchronous then
7953 -- For an asynchronous procedure, add a null exception handler
7955 Excep_Handlers := New_List (
7956 Make_Exception_Handler (Loc,
7957 Exception_Choices => New_List (Make_Others_Choice (Loc)),
7958 Statements => New_List (Make_Null_Statement (Loc))));
7962 -- In the other cases, if an exception is raised, then the
7963 -- exception occurrence is propagated.
7968 Append_To (Outer_Statements,
7969 Make_Block_Statement (Loc,
7972 Handled_Statement_Sequence =>
7973 Make_Handled_Sequence_Of_Statements (Loc,
7974 Statements => Statements)));
7977 Make_Subprogram_Body (Loc,
7978 Specification => Subp_Spec,
7979 Declarations => Outer_Decls,
7980 Handled_Statement_Sequence =>
7981 Make_Handled_Sequence_Of_Statements (Loc,
7982 Statements => Outer_Statements,
7983 Exception_Handlers => Excep_Handlers));
7984 end Build_Subprogram_Receiving_Stubs;
7989 package body Helpers is
7991 -----------------------
7992 -- Local Subprograms --
7993 -----------------------
7995 function Find_Numeric_Representation
7996 (Typ : Entity_Id) return Entity_Id;
7997 -- Given a numeric type Typ, return the smallest integer or floarting
7998 -- point type from Standard, or the smallest unsigned (modular) type
7999 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8001 function Make_Stream_Procedure_Function_Name
8004 Nam : Name_Id) return Entity_Id;
8005 -- Return the name to be assigned for stream subprogram Nam of Typ.
8006 -- (copied from exp_strm.adb, should be shared???)
8008 ------------------------------------------------------------
8009 -- Common subprograms for building various tree fragments --
8010 ------------------------------------------------------------
8012 function Build_Get_Aggregate_Element
8016 Idx : Node_Id) return Node_Id;
8017 -- Build a call to Get_Aggregate_Element on Any
8018 -- for typecode TC, returning the Idx'th element.
8021 Subprogram : Entity_Id;
8022 -- Reference location for constructed nodes
8025 -- For 'Range and Etype
8028 -- For the construction of the innermost element expression
8030 with procedure Add_Process_Element
8033 Counter : Entity_Id;
8036 procedure Append_Array_Traversal
8039 Counter : Entity_Id := Empty;
8041 -- Build nested loop statements that iterate over the elements of an
8042 -- array Arry. The statement(s) built by Add_Process_Element are
8043 -- executed for each element; Indices is the list of indices to be
8044 -- used in the construction of the indexed component that denotes the
8045 -- current element. Subprogram is the entity for the subprogram for
8046 -- which this iterator is generated. The generated statements are
8047 -- appended to Stmts.
8051 -- The record entity being dealt with
8053 with procedure Add_Process_Element
8055 Container : Node_Or_Entity_Id;
8056 Counter : in out Int;
8059 -- Rec is the instance of the record type, or Empty.
8060 -- Field is either the N_Defining_Identifier for a component,
8061 -- or an N_Variant_Part.
8063 procedure Append_Record_Traversal
8066 Container : Node_Or_Entity_Id;
8067 Counter : in out Int);
8068 -- Process component list Clist. Individual fields are passed
8069 -- to Field_Processing. Each variant part is also processed.
8070 -- Container is the outer Any (for From_Any/To_Any),
8071 -- the outer typecode (for TC) to which the operation applies.
8073 -----------------------------
8074 -- Append_Record_Traversal --
8075 -----------------------------
8077 procedure Append_Record_Traversal
8080 Container : Node_Or_Entity_Id;
8081 Counter : in out Int)
8083 CI : constant List_Id := Component_Items (Clist);
8084 VP : constant Node_Id := Variant_Part (Clist);
8086 Item : Node_Id := First (CI);
8090 while Present (Item) loop
8091 Def := Defining_Identifier (Item);
8092 if not Is_Internal_Name (Chars (Def)) then
8094 (Stmts, Container, Counter, Rec, Def);
8099 if Present (VP) then
8100 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8102 end Append_Record_Traversal;
8104 -------------------------
8105 -- Build_From_Any_Call --
8106 -------------------------
8108 function Build_From_Any_Call
8111 Decls : List_Id) return Node_Id
8113 Loc : constant Source_Ptr := Sloc (N);
8115 U_Type : Entity_Id := Underlying_Type (Typ);
8117 Fnam : Entity_Id := Empty;
8118 Lib_RE : RE_Id := RE_Null;
8122 -- First simple case where the From_Any function is present
8123 -- in the type's TSS.
8125 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8127 if Sloc (U_Type) <= Standard_Location then
8128 U_Type := Base_Type (U_Type);
8131 -- Check first for Boolean and Character. These are enumeration
8132 -- types, but we treat them specially, since they may require
8133 -- special handling in the transfer protocol. However, this
8134 -- special handling only applies if they have standard
8135 -- representation, otherwise they are treated like any other
8136 -- enumeration type.
8138 if Present (Fnam) then
8141 elsif U_Type = Standard_Boolean then
8144 elsif U_Type = Standard_Character then
8147 elsif U_Type = Standard_Wide_Character then
8150 elsif U_Type = Standard_Wide_Wide_Character then
8151 Lib_RE := RE_FA_WWC;
8153 -- Floating point types
8155 elsif U_Type = Standard_Short_Float then
8158 elsif U_Type = Standard_Float then
8161 elsif U_Type = Standard_Long_Float then
8164 elsif U_Type = Standard_Long_Long_Float then
8165 Lib_RE := RE_FA_LLF;
8169 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8170 Lib_RE := RE_FA_SSI;
8172 elsif U_Type = Etype (Standard_Short_Integer) then
8175 elsif U_Type = Etype (Standard_Integer) then
8178 elsif U_Type = Etype (Standard_Long_Integer) then
8181 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8182 Lib_RE := RE_FA_LLI;
8184 -- Unsigned integer types
8186 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8187 Lib_RE := RE_FA_SSU;
8189 elsif U_Type = RTE (RE_Short_Unsigned) then
8192 elsif U_Type = RTE (RE_Unsigned) then
8195 elsif U_Type = RTE (RE_Long_Unsigned) then
8198 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8199 Lib_RE := RE_FA_LLU;
8201 elsif U_Type = Standard_String then
8202 Lib_RE := RE_FA_String;
8204 -- Other (non-primitive) types
8210 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8211 Append_To (Decls, Decl);
8215 -- Call the function
8217 if Lib_RE /= RE_Null then
8218 pragma Assert (No (Fnam));
8219 Fnam := RTE (Lib_RE);
8223 Make_Function_Call (Loc,
8224 Name => New_Occurrence_Of (Fnam, Loc),
8225 Parameter_Associations => New_List (N));
8226 end Build_From_Any_Call;
8228 -----------------------------
8229 -- Build_From_Any_Function --
8230 -----------------------------
8232 procedure Build_From_Any_Function
8236 Fnam : out Entity_Id)
8239 Decls : constant List_Id := New_List;
8240 Stms : constant List_Id := New_List;
8241 Any_Parameter : constant Entity_Id
8242 := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
8244 Fnam := Make_Stream_Procedure_Function_Name (Loc,
8245 Typ, Name_uFrom_Any);
8248 Make_Function_Specification (Loc,
8249 Defining_Unit_Name => Fnam,
8250 Parameter_Specifications => New_List (
8251 Make_Parameter_Specification (Loc,
8252 Defining_Identifier =>
8255 New_Occurrence_Of (RTE (RE_Any), Loc))),
8256 Result_Definition => New_Occurrence_Of (Typ, Loc));
8258 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8261 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8263 if Is_Derived_Type (Typ)
8264 and then not Is_Tagged_Type (Typ)
8267 Make_Return_Statement (Loc,
8271 Build_From_Any_Call (
8273 New_Occurrence_Of (Any_Parameter, Loc),
8276 elsif Is_Record_Type (Typ)
8277 and then not Is_Derived_Type (Typ)
8278 and then not Is_Tagged_Type (Typ)
8280 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8282 Make_Return_Statement (Loc,
8286 Build_From_Any_Call (
8288 New_Occurrence_Of (Any_Parameter, Loc),
8292 Disc : Entity_Id := Empty;
8293 Discriminant_Associations : List_Id;
8294 Rdef : constant Node_Id :=
8295 Type_Definition (Declaration_Node (Typ));
8296 Component_Counter : Int := 0;
8298 -- The returned object
8300 Res : constant Entity_Id :=
8301 Make_Defining_Identifier (Loc,
8302 New_Internal_Name ('R'));
8304 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8306 procedure FA_Rec_Add_Process_Element
8309 Counter : in out Int;
8313 procedure FA_Append_Record_Traversal is
8314 new Append_Record_Traversal
8316 Add_Process_Element => FA_Rec_Add_Process_Element);
8318 --------------------------------
8319 -- FA_Rec_Add_Process_Element --
8320 --------------------------------
8322 procedure FA_Rec_Add_Process_Element
8325 Counter : in out Int;
8330 if Nkind (Field) = N_Defining_Identifier then
8332 -- A regular component
8335 Make_Assignment_Statement (Loc,
8336 Name => Make_Selected_Component (Loc,
8338 New_Occurrence_Of (Rec, Loc),
8340 New_Occurrence_Of (Field, Loc)),
8342 Build_From_Any_Call (Etype (Field),
8343 Build_Get_Aggregate_Element (Loc,
8345 Tc => Build_TypeCode_Call (Loc,
8346 Etype (Field), Decls),
8347 Idx => Make_Integer_Literal (Loc,
8356 Struct_Counter : Int := 0;
8358 Block_Decls : constant List_Id := New_List;
8359 Block_Stmts : constant List_Id := New_List;
8362 Alt_List : constant List_Id := New_List;
8363 Choice_List : List_Id;
8365 Struct_Any : constant Entity_Id :=
8366 Make_Defining_Identifier (Loc,
8367 New_Internal_Name ('S'));
8371 Make_Object_Declaration (Loc,
8372 Defining_Identifier =>
8376 Object_Definition =>
8377 New_Occurrence_Of (RTE (RE_Any), Loc),
8379 Make_Function_Call (Loc,
8380 Name => New_Occurrence_Of (
8381 RTE (RE_Extract_Union_Value), Loc),
8382 Parameter_Associations => New_List (
8383 Build_Get_Aggregate_Element (Loc,
8385 Tc => Make_Function_Call (Loc,
8386 Name => New_Occurrence_Of (
8387 RTE (RE_Any_Member_Type), Loc),
8388 Parameter_Associations =>
8390 New_Occurrence_Of (Any, Loc),
8391 Make_Integer_Literal (Loc,
8393 Idx => Make_Integer_Literal (Loc,
8397 Make_Block_Statement (Loc,
8400 Handled_Statement_Sequence =>
8401 Make_Handled_Sequence_Of_Statements (Loc,
8402 Statements => Block_Stmts)));
8404 Append_To (Block_Stmts,
8405 Make_Case_Statement (Loc,
8407 Make_Selected_Component (Loc,
8410 Chars (Name (Field))),
8414 Variant := First_Non_Pragma (Variants (Field));
8416 while Present (Variant) loop
8417 Choice_List := New_Copy_List_Tree
8418 (Discrete_Choices (Variant));
8420 VP_Stmts := New_List;
8421 FA_Append_Record_Traversal (
8423 Clist => Component_List (Variant),
8424 Container => Struct_Any,
8425 Counter => Struct_Counter);
8427 Append_To (Alt_List,
8428 Make_Case_Statement_Alternative (Loc,
8429 Discrete_Choices => Choice_List,
8432 Next_Non_Pragma (Variant);
8436 Counter := Counter + 1;
8437 end FA_Rec_Add_Process_Element;
8440 -- First all discriminants
8442 if Has_Discriminants (Typ) then
8443 Disc := First_Discriminant (Typ);
8444 Discriminant_Associations := New_List;
8446 while Present (Disc) loop
8448 Disc_Var_Name : constant Entity_Id :=
8449 Make_Defining_Identifier (Loc, Chars (Disc));
8450 Disc_Type : constant Entity_Id :=
8454 Make_Object_Declaration (Loc,
8455 Defining_Identifier =>
8457 Constant_Present => True,
8458 Object_Definition =>
8459 New_Occurrence_Of (Disc_Type, Loc),
8461 Build_From_Any_Call (Etype (Disc),
8462 Build_Get_Aggregate_Element (Loc,
8463 Any => Any_Parameter,
8464 Tc => Build_TypeCode_Call
8465 (Loc, Etype (Disc), Decls),
8466 Idx => Make_Integer_Literal
8467 (Loc, Component_Counter)),
8469 Component_Counter := Component_Counter + 1;
8471 Append_To (Discriminant_Associations,
8472 Make_Discriminant_Association (Loc,
8473 Selector_Names => New_List (
8474 New_Occurrence_Of (Disc, Loc)),
8476 New_Occurrence_Of (Disc_Var_Name, Loc)));
8478 Next_Discriminant (Disc);
8481 Res_Definition := Make_Subtype_Indication (Loc,
8482 Subtype_Mark => Res_Definition,
8484 Make_Index_Or_Discriminant_Constraint (Loc,
8485 Discriminant_Associations));
8488 -- Now we have all the discriminants in variables, we can
8489 -- declared a constrained object. Note that we are not
8490 -- initializing (non-discriminant) components directly in
8491 -- the object declarations, because which fields to
8492 -- initialize depends (at run time) on the discriminant
8496 Make_Object_Declaration (Loc,
8497 Defining_Identifier =>
8499 Object_Definition =>
8502 -- ... then all components
8504 FA_Append_Record_Traversal (Stms,
8505 Clist => Component_List (Rdef),
8506 Container => Any_Parameter,
8507 Counter => Component_Counter);
8510 Make_Return_Statement (Loc,
8511 Expression => New_Occurrence_Of (Res, Loc)));
8515 elsif Is_Array_Type (Typ) then
8517 Constrained : constant Boolean := Is_Constrained (Typ);
8519 procedure FA_Ary_Add_Process_Element
8522 Counter : Entity_Id;
8524 -- Assign the current element (as identified by Counter) of
8525 -- Any to the variable denoted by name Datum, and advance
8526 -- Counter by 1. If Datum is not an Any, a call to From_Any
8527 -- for its type is inserted.
8529 --------------------------------
8530 -- FA_Ary_Add_Process_Element --
8531 --------------------------------
8533 procedure FA_Ary_Add_Process_Element
8536 Counter : Entity_Id;
8539 Assignment : constant Node_Id :=
8540 Make_Assignment_Statement (Loc,
8542 Expression => Empty);
8544 Element_Any : constant Node_Id :=
8545 Build_Get_Aggregate_Element (Loc,
8547 Tc => Build_TypeCode_Call (Loc,
8548 Etype (Datum), Decls),
8549 Idx => New_Occurrence_Of (Counter, Loc));
8552 -- Note: here we *prepend* statements to Stmts, so
8553 -- we must do it in reverse order.
8556 Make_Assignment_Statement (Loc,
8558 New_Occurrence_Of (Counter, Loc),
8562 New_Occurrence_Of (Counter, Loc),
8564 Make_Integer_Literal (Loc, 1))));
8566 if Nkind (Datum) /= N_Attribute_Reference then
8568 -- We ignore the value of the length of each
8569 -- dimension, since the target array has already
8570 -- been constrained anyway.
8572 if Etype (Datum) /= RTE (RE_Any) then
8573 Set_Expression (Assignment,
8574 Build_From_Any_Call (
8575 Component_Type (Typ),
8579 Set_Expression (Assignment, Element_Any);
8581 Prepend_To (Stmts, Assignment);
8583 end FA_Ary_Add_Process_Element;
8585 Counter : constant Entity_Id :=
8586 Make_Defining_Identifier (Loc, Name_J);
8588 Initial_Counter_Value : Int := 0;
8590 Component_TC : constant Entity_Id :=
8591 Make_Defining_Identifier (Loc, Name_T);
8593 Res : constant Entity_Id :=
8594 Make_Defining_Identifier (Loc, Name_R);
8596 procedure Append_From_Any_Array_Iterator is
8597 new Append_Array_Traversal (
8600 Indices => New_List,
8601 Add_Process_Element => FA_Ary_Add_Process_Element);
8603 Res_Subtype_Indication : Node_Id :=
8604 New_Occurrence_Of (Typ, Loc);
8607 if not Constrained then
8609 Ndim : constant Int := Number_Dimensions (Typ);
8612 Indx : Node_Id := First_Index (Typ);
8615 Ranges : constant List_Id := New_List;
8618 for J in 1 .. Ndim loop
8619 Lnam := New_External_Name ('L', J);
8620 Hnam := New_External_Name ('H', J);
8621 Indt := Etype (Indx);
8624 Make_Object_Declaration (Loc,
8625 Defining_Identifier =>
8626 Make_Defining_Identifier (Loc, Lnam),
8629 Object_Definition =>
8630 New_Occurrence_Of (Indt, Loc),
8632 Build_From_Any_Call (
8634 Build_Get_Aggregate_Element (Loc,
8635 Any => Any_Parameter,
8636 Tc => Build_TypeCode_Call (Loc,
8638 Idx => Make_Integer_Literal (Loc, J - 1)),
8642 Make_Object_Declaration (Loc,
8643 Defining_Identifier =>
8644 Make_Defining_Identifier (Loc, Hnam),
8647 Object_Definition =>
8648 New_Occurrence_Of (Indt, Loc),
8649 Expression => Make_Attribute_Reference (Loc,
8651 New_Occurrence_Of (Indt, Loc),
8652 Attribute_Name => Name_Val,
8653 Expressions => New_List (
8654 Make_Op_Subtract (Loc,
8658 Make_Attribute_Reference (Loc,
8660 New_Occurrence_Of (Indt, Loc),
8663 Expressions => New_List (
8664 Make_Identifier (Loc, Lnam))),
8666 Make_Function_Call (Loc,
8667 Name => New_Occurrence_Of (RTE (
8668 RE_Get_Nested_Sequence_Length),
8670 Parameter_Associations =>
8673 Any_Parameter, Loc),
8674 Make_Integer_Literal (Loc,
8677 Make_Integer_Literal (Loc, 1))))));
8681 Low_Bound => Make_Identifier (Loc, Lnam),
8682 High_Bound => Make_Identifier (Loc, Hnam)));
8687 -- Now we have all the necessary bound information:
8688 -- apply the set of range constraints to the
8689 -- (unconstrained) nominal subtype of Res.
8691 Initial_Counter_Value := Ndim;
8692 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
8694 Res_Subtype_Indication,
8696 Make_Index_Or_Discriminant_Constraint (Loc,
8697 Constraints => Ranges));
8702 Make_Object_Declaration (Loc,
8703 Defining_Identifier => Res,
8704 Object_Definition => Res_Subtype_Indication));
8705 Set_Etype (Res, Typ);
8708 Make_Object_Declaration (Loc,
8709 Defining_Identifier => Counter,
8710 Object_Definition =>
8711 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
8713 Make_Integer_Literal (Loc, Initial_Counter_Value)));
8716 Make_Object_Declaration (Loc,
8717 Defining_Identifier => Component_TC,
8718 Constant_Present => True,
8719 Object_Definition =>
8720 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
8722 Build_TypeCode_Call (Loc,
8723 Component_Type (Typ), Decls)));
8725 Append_From_Any_Array_Iterator (Stms,
8726 Any_Parameter, Counter);
8729 Make_Return_Statement (Loc,
8730 Expression => New_Occurrence_Of (Res, Loc)));
8733 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
8735 Make_Return_Statement (Loc,
8737 Unchecked_Convert_To (
8739 Build_From_Any_Call (
8740 Find_Numeric_Representation (Typ),
8741 New_Occurrence_Of (Any_Parameter, Loc),
8745 -- Default: type is represented as an opaque sequence of bytes
8748 Strm : constant Entity_Id :=
8749 Make_Defining_Identifier (Loc,
8750 Chars => New_Internal_Name ('S'));
8751 Res : constant Entity_Id :=
8752 Make_Defining_Identifier (Loc,
8753 Chars => New_Internal_Name ('R'));
8756 -- Strm : Buffer_Stream_Type;
8759 Make_Object_Declaration (Loc,
8760 Defining_Identifier =>
8764 Object_Definition =>
8765 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
8767 -- Any_To_BS (Strm, A);
8770 Make_Procedure_Call_Statement (Loc,
8772 New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
8773 Parameter_Associations => New_List (
8774 New_Occurrence_Of (Any_Parameter, Loc),
8775 New_Occurrence_Of (Strm, Loc))));
8778 -- Res : constant T := T'Input (Strm);
8780 -- Release_Buffer (Strm);
8784 Append_To (Stms, Make_Block_Statement (Loc,
8785 Declarations => New_List (
8786 Make_Object_Declaration (Loc,
8787 Defining_Identifier => Res,
8788 Constant_Present => True,
8789 Object_Definition =>
8790 New_Occurrence_Of (Typ, Loc),
8792 Make_Attribute_Reference (Loc,
8793 Prefix => New_Occurrence_Of (Typ, Loc),
8794 Attribute_Name => Name_Input,
8795 Expressions => New_List (
8796 Make_Attribute_Reference (Loc,
8797 Prefix => New_Occurrence_Of (Strm, Loc),
8798 Attribute_Name => Name_Access))))),
8800 Handled_Statement_Sequence =>
8801 Make_Handled_Sequence_Of_Statements (Loc,
8802 Statements => New_List (
8803 Make_Procedure_Call_Statement (Loc,
8805 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
8806 Parameter_Associations =>
8808 New_Occurrence_Of (Strm, Loc))),
8809 Make_Return_Statement (Loc,
8810 Expression => New_Occurrence_Of (Res, Loc))))));
8816 Make_Subprogram_Body (Loc,
8817 Specification => Spec,
8818 Declarations => Decls,
8819 Handled_Statement_Sequence =>
8820 Make_Handled_Sequence_Of_Statements (Loc,
8821 Statements => Stms));
8822 end Build_From_Any_Function;
8824 ---------------------------------
8825 -- Build_Get_Aggregate_Element --
8826 ---------------------------------
8828 function Build_Get_Aggregate_Element
8832 Idx : Node_Id) return Node_Id
8835 return Make_Function_Call (Loc,
8838 RTE (RE_Get_Aggregate_Element), Loc),
8839 Parameter_Associations => New_List (
8840 New_Occurrence_Of (Any, Loc),
8843 end Build_Get_Aggregate_Element;
8845 -------------------------
8846 -- Build_Reposiroty_Id --
8847 -------------------------
8849 procedure Build_Name_And_Repository_Id
8851 Name_Str : out String_Id;
8852 Repo_Id_Str : out String_Id)
8856 Store_String_Chars ("DSA:");
8857 Get_Library_Unit_Name_String (Scope (E));
8858 Store_String_Chars (
8859 Name_Buffer (Name_Buffer'First
8860 .. Name_Buffer'First + Name_Len - 1));
8861 Store_String_Char ('.');
8862 Get_Name_String (Chars (E));
8863 Store_String_Chars (
8864 Name_Buffer (Name_Buffer'First
8865 .. Name_Buffer'First + Name_Len - 1));
8866 Store_String_Chars (":1.0");
8867 Repo_Id_Str := End_String;
8868 Name_Str := String_From_Name_Buffer;
8869 end Build_Name_And_Repository_Id;
8871 -----------------------
8872 -- Build_To_Any_Call --
8873 -----------------------
8875 function Build_To_Any_Call
8877 Decls : List_Id) return Node_Id
8879 Loc : constant Source_Ptr := Sloc (N);
8881 Typ : Entity_Id := Etype (N);
8884 Fnam : Entity_Id := Empty;
8885 Lib_RE : RE_Id := RE_Null;
8888 -- If N is a selected component, then maybe its Etype
8889 -- has not been set yet: try to use the Etype of the
8890 -- selector_name in that case.
8892 if No (Typ) and then Nkind (N) = N_Selected_Component then
8893 Typ := Etype (Selector_Name (N));
8895 pragma Assert (Present (Typ));
8897 -- The full view, if Typ is private; the completion,
8898 -- if Typ is incomplete.
8900 U_Type := Underlying_Type (Typ);
8902 -- First simple case where the To_Any function is present
8903 -- in the type's TSS.
8905 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
8907 -- Check first for Boolean and Character. These are enumeration
8908 -- types, but we treat them specially, since they may require
8909 -- special handling in the transfer protocol. However, this
8910 -- special handling only applies if they have standard
8911 -- representation, otherwise they are treated like any other
8912 -- enumeration type.
8914 if Sloc (U_Type) <= Standard_Location then
8915 U_Type := Base_Type (U_Type);
8918 if Present (Fnam) then
8921 elsif U_Type = Standard_Boolean then
8924 elsif U_Type = Standard_Character then
8927 elsif U_Type = Standard_Wide_Character then
8930 elsif U_Type = Standard_Wide_Wide_Character then
8931 Lib_RE := RE_TA_WWC;
8933 -- Floating point types
8935 elsif U_Type = Standard_Short_Float then
8938 elsif U_Type = Standard_Float then
8941 elsif U_Type = Standard_Long_Float then
8944 elsif U_Type = Standard_Long_Long_Float then
8945 Lib_RE := RE_TA_LLF;
8949 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8950 Lib_RE := RE_TA_SSI;
8952 elsif U_Type = Etype (Standard_Short_Integer) then
8955 elsif U_Type = Etype (Standard_Integer) then
8958 elsif U_Type = Etype (Standard_Long_Integer) then
8961 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8962 Lib_RE := RE_TA_LLI;
8964 -- Unsigned integer types
8966 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8967 Lib_RE := RE_TA_SSU;
8969 elsif U_Type = RTE (RE_Short_Unsigned) then
8972 elsif U_Type = RTE (RE_Unsigned) then
8975 elsif U_Type = RTE (RE_Long_Unsigned) then
8978 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8979 Lib_RE := RE_TA_LLU;
8981 elsif U_Type = Standard_String then
8982 Lib_RE := RE_TA_String;
8984 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
8987 -- Other (non-primitive) types
8993 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
8994 Append_To (Decls, Decl);
8998 -- Call the function
9000 if Lib_RE /= RE_Null then
9001 pragma Assert (No (Fnam));
9002 Fnam := RTE (Lib_RE);
9006 Make_Function_Call (Loc,
9007 Name => New_Occurrence_Of (Fnam, Loc),
9008 Parameter_Associations => New_List (N));
9009 end Build_To_Any_Call;
9011 ---------------------------
9012 -- Build_To_Any_Function --
9013 ---------------------------
9015 procedure Build_To_Any_Function
9019 Fnam : out Entity_Id)
9022 Decls : constant List_Id := New_List;
9023 Stms : constant List_Id := New_List;
9025 Expr_Parameter : constant Entity_Id :=
9026 Make_Defining_Identifier (Loc, Name_E);
9028 Any : constant Entity_Id :=
9029 Make_Defining_Identifier (Loc, Name_A);
9032 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9035 Fnam := Make_Stream_Procedure_Function_Name (Loc,
9039 Make_Function_Specification (Loc,
9040 Defining_Unit_Name => Fnam,
9041 Parameter_Specifications => New_List (
9042 Make_Parameter_Specification (Loc,
9043 Defining_Identifier =>
9046 New_Occurrence_Of (Typ, Loc))),
9047 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9048 Set_Etype (Expr_Parameter, Typ);
9051 Make_Object_Declaration (Loc,
9052 Defining_Identifier =>
9054 Object_Definition =>
9055 New_Occurrence_Of (RTE (RE_Any), Loc));
9057 if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9059 Rt_Type : constant Entity_Id
9061 Expr : constant Node_Id
9064 New_Occurrence_Of (Expr_Parameter, Loc));
9066 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9069 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9070 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9072 Rt_Type : constant Entity_Id
9074 Expr : constant Node_Id
9077 New_Occurrence_Of (Expr_Parameter, Loc));
9080 Set_Expression (Any_Decl,
9081 Build_To_Any_Call (Expr, Decls));
9086 Disc : Entity_Id := Empty;
9087 Rdef : constant Node_Id :=
9088 Type_Definition (Declaration_Node (Typ));
9090 Elements : constant List_Id := New_List;
9092 procedure TA_Rec_Add_Process_Element
9094 Container : Node_Or_Entity_Id;
9095 Counter : in out Int;
9099 procedure TA_Append_Record_Traversal is
9100 new Append_Record_Traversal
9101 (Rec => Expr_Parameter,
9102 Add_Process_Element => TA_Rec_Add_Process_Element);
9104 --------------------------------
9105 -- TA_Rec_Add_Process_Element --
9106 --------------------------------
9108 procedure TA_Rec_Add_Process_Element
9110 Container : Node_Or_Entity_Id;
9111 Counter : in out Int;
9115 Field_Ref : Node_Id;
9118 if Nkind (Field) = N_Defining_Identifier then
9120 -- A regular component
9122 Field_Ref := Make_Selected_Component (Loc,
9123 Prefix => New_Occurrence_Of (Rec, Loc),
9124 Selector_Name => New_Occurrence_Of (Field, Loc));
9125 Set_Etype (Field_Ref, Etype (Field));
9128 Make_Procedure_Call_Statement (Loc,
9131 RTE (RE_Add_Aggregate_Element), Loc),
9132 Parameter_Associations => New_List (
9133 New_Occurrence_Of (Any, Loc),
9134 Build_To_Any_Call (Field_Ref, Decls))));
9141 Struct_Counter : Int := 0;
9143 Block_Decls : constant List_Id := New_List;
9144 Block_Stmts : constant List_Id := New_List;
9147 Alt_List : constant List_Id := New_List;
9148 Choice_List : List_Id;
9150 Union_Any : constant Entity_Id :=
9151 Make_Defining_Identifier (Loc,
9152 New_Internal_Name ('U'));
9154 Struct_Any : constant Entity_Id :=
9155 Make_Defining_Identifier (Loc,
9156 New_Internal_Name ('S'));
9158 function Make_Discriminant_Reference
9160 -- Build a selected component for the
9161 -- discriminant of this variant part.
9163 ---------------------------------
9164 -- Make_Discriminant_Reference --
9165 ---------------------------------
9167 function Make_Discriminant_Reference
9170 Nod : constant Node_Id :=
9171 Make_Selected_Component (Loc,
9174 Chars (Name (Field)));
9176 Set_Etype (Nod, Name (Field));
9178 end Make_Discriminant_Reference;
9182 Make_Block_Statement (Loc,
9185 Handled_Statement_Sequence =>
9186 Make_Handled_Sequence_Of_Statements (Loc,
9187 Statements => Block_Stmts)));
9189 Append_To (Block_Decls,
9190 Make_Object_Declaration (Loc,
9191 Defining_Identifier => Union_Any,
9192 Object_Definition =>
9193 New_Occurrence_Of (RTE (RE_Any), Loc),
9195 Make_Function_Call (Loc,
9196 Name => New_Occurrence_Of (
9197 RTE (RE_Create_Any), Loc),
9198 Parameter_Associations => New_List (
9199 Make_Function_Call (Loc,
9202 RTE (RE_Any_Member_Type), Loc),
9203 Parameter_Associations => New_List (
9204 New_Occurrence_Of (Container, Loc),
9205 Make_Integer_Literal (Loc,
9208 Append_To (Block_Decls,
9209 Make_Object_Declaration (Loc,
9210 Defining_Identifier => Struct_Any,
9211 Object_Definition =>
9212 New_Occurrence_Of (RTE (RE_Any), Loc),
9214 Make_Function_Call (Loc,
9215 Name => New_Occurrence_Of (
9216 RTE (RE_Create_Any), Loc),
9217 Parameter_Associations => New_List (
9218 Make_Function_Call (Loc,
9221 RTE (RE_Any_Member_Type), Loc),
9222 Parameter_Associations => New_List (
9223 New_Occurrence_Of (Union_Any, Loc),
9224 Make_Integer_Literal (Loc,
9227 Append_To (Block_Stmts,
9228 Make_Case_Statement (Loc,
9230 Make_Discriminant_Reference,
9234 Variant := First_Non_Pragma (Variants (Field));
9235 while Present (Variant) loop
9236 Choice_List := New_Copy_List_Tree
9237 (Discrete_Choices (Variant));
9239 VP_Stmts := New_List;
9240 TA_Append_Record_Traversal (
9242 Clist => Component_List (Variant),
9243 Container => Struct_Any,
9244 Counter => Struct_Counter);
9246 -- Append discriminant value and inner struct
9247 -- to union aggregate.
9249 Append_To (VP_Stmts,
9250 Make_Procedure_Call_Statement (Loc,
9253 RTE (RE_Add_Aggregate_Element), Loc),
9254 Parameter_Associations => New_List (
9255 New_Occurrence_Of (Union_Any, Loc),
9257 Make_Discriminant_Reference,
9260 Append_To (VP_Stmts,
9261 Make_Procedure_Call_Statement (Loc,
9264 RTE (RE_Add_Aggregate_Element), Loc),
9265 Parameter_Associations => New_List (
9266 New_Occurrence_Of (Union_Any, Loc),
9267 New_Occurrence_Of (Struct_Any, Loc))));
9269 -- Append union to outer aggregate
9271 Append_To (VP_Stmts,
9272 Make_Procedure_Call_Statement (Loc,
9275 RTE (RE_Add_Aggregate_Element), Loc),
9276 Parameter_Associations => New_List (
9277 New_Occurrence_Of (Container, Loc),
9278 Make_Function_Call (Loc,
9279 Name => New_Occurrence_Of (
9280 RTE (RE_Any_Aggregate_Build), Loc),
9281 Parameter_Associations => New_List (
9283 Union_Any, Loc))))));
9285 Append_To (Alt_List,
9286 Make_Case_Statement_Alternative (Loc,
9287 Discrete_Choices => Choice_List,
9290 Next_Non_Pragma (Variant);
9294 end TA_Rec_Add_Process_Element;
9297 -- First all discriminants
9299 if Has_Discriminants (Typ) then
9300 Disc := First_Discriminant (Typ);
9302 while Present (Disc) loop
9303 Append_To (Elements,
9304 Make_Component_Association (Loc,
9305 Choices => New_List (
9306 Make_Integer_Literal (Loc, Counter)),
9309 Make_Selected_Component (Loc,
9310 Prefix => Expr_Parameter,
9311 Selector_Name => Chars (Disc)),
9313 Counter := Counter + 1;
9314 Next_Discriminant (Disc);
9318 -- Make elements an empty array
9321 Dummy_Any : constant Entity_Id :=
9322 Make_Defining_Identifier (Loc,
9323 Chars => New_Internal_Name ('A'));
9327 Make_Object_Declaration (Loc,
9328 Defining_Identifier => Dummy_Any,
9329 Object_Definition =>
9330 New_Occurrence_Of (RTE (RE_Any), Loc)));
9332 Append_To (Elements,
9333 Make_Component_Association (Loc,
9334 Choices => New_List (
9337 Make_Integer_Literal (Loc, 1),
9339 Make_Integer_Literal (Loc, 0))),
9341 New_Occurrence_Of (Dummy_Any, Loc)));
9345 Set_Expression (Any_Decl,
9346 Make_Function_Call (Loc,
9347 Name => New_Occurrence_Of (
9348 RTE (RE_Any_Aggregate_Build), Loc),
9349 Parameter_Associations => New_List (
9351 Make_Aggregate (Loc,
9352 Component_Associations => Elements))));
9355 -- ... then all components
9357 TA_Append_Record_Traversal (Stms,
9358 Clist => Component_List (Rdef),
9360 Counter => Counter);
9364 elsif Is_Array_Type (Typ) then
9366 Constrained : constant Boolean := Is_Constrained (Typ);
9368 procedure TA_Ary_Add_Process_Element
9371 Counter : Entity_Id;
9374 --------------------------------
9375 -- TA_Ary_Add_Process_Element --
9376 --------------------------------
9378 procedure TA_Ary_Add_Process_Element
9381 Counter : Entity_Id;
9384 pragma Warnings (Off);
9385 pragma Unreferenced (Counter);
9386 pragma Warnings (On);
9388 Element_Any : Node_Id;
9391 if Etype (Datum) = RTE (RE_Any) then
9392 Element_Any := Datum;
9394 Element_Any := Build_To_Any_Call (Datum, Decls);
9398 Make_Procedure_Call_Statement (Loc,
9399 Name => New_Occurrence_Of (
9400 RTE (RE_Add_Aggregate_Element), Loc),
9401 Parameter_Associations => New_List (
9402 New_Occurrence_Of (Any, Loc),
9404 end TA_Ary_Add_Process_Element;
9406 procedure Append_To_Any_Array_Iterator is
9407 new Append_Array_Traversal (
9409 Arry => Expr_Parameter,
9410 Indices => New_List,
9411 Add_Process_Element => TA_Ary_Add_Process_Element);
9416 Set_Expression (Any_Decl,
9417 Make_Function_Call (Loc,
9419 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9420 Parameter_Associations => New_List (Result_TC)));
9423 if not Constrained then
9424 Index := First_Index (Typ);
9425 for J in 1 .. Number_Dimensions (Typ) loop
9427 Make_Procedure_Call_Statement (Loc,
9430 RTE (RE_Add_Aggregate_Element), Loc),
9431 Parameter_Associations => New_List (
9432 New_Occurrence_Of (Any, Loc),
9434 OK_Convert_To (Etype (Index),
9435 Make_Attribute_Reference (Loc,
9437 New_Occurrence_Of (Expr_Parameter, Loc),
9438 Attribute_Name => Name_First,
9439 Expressions => New_List (
9440 Make_Integer_Literal (Loc, J)))),
9446 Append_To_Any_Array_Iterator (Stms, Any);
9449 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9450 Set_Expression (Any_Decl,
9453 Find_Numeric_Representation (Typ),
9454 New_Occurrence_Of (Expr_Parameter, Loc)),
9458 -- Default: type is represented as an opaque sequence of bytes
9461 Strm : constant Entity_Id := Make_Defining_Identifier (Loc,
9462 New_Internal_Name ('S'));
9465 -- Strm : aliased Buffer_Stream_Type;
9468 Make_Object_Declaration (Loc,
9469 Defining_Identifier =>
9473 Object_Definition =>
9474 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9476 -- Allocate_Buffer (Strm);
9479 Make_Procedure_Call_Statement (Loc,
9481 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9482 Parameter_Associations => New_List (
9483 New_Occurrence_Of (Strm, Loc))));
9485 -- T'Output (Strm'Access, E);
9488 Make_Attribute_Reference (Loc,
9489 Prefix => New_Occurrence_Of (Typ, Loc),
9490 Attribute_Name => Name_Output,
9491 Expressions => New_List (
9492 Make_Attribute_Reference (Loc,
9493 Prefix => New_Occurrence_Of (Strm, Loc),
9494 Attribute_Name => Name_Access),
9495 New_Occurrence_Of (Expr_Parameter, Loc))));
9497 -- BS_To_Any (Strm, A);
9500 Make_Procedure_Call_Statement (Loc,
9502 New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
9503 Parameter_Associations => New_List (
9504 New_Occurrence_Of (Strm, Loc),
9505 New_Occurrence_Of (Any, Loc))));
9507 -- Release_Buffer (Strm);
9510 Make_Procedure_Call_Statement (Loc,
9512 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
9513 Parameter_Associations => New_List (
9514 New_Occurrence_Of (Strm, Loc))));
9518 Append_To (Decls, Any_Decl);
9520 if Present (Result_TC) then
9522 Make_Procedure_Call_Statement (Loc,
9523 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
9524 Parameter_Associations => New_List (
9525 New_Occurrence_Of (Any, Loc),
9530 Make_Return_Statement (Loc,
9531 Expression => New_Occurrence_Of (Any, Loc)));
9534 Make_Subprogram_Body (Loc,
9535 Specification => Spec,
9536 Declarations => Decls,
9537 Handled_Statement_Sequence =>
9538 Make_Handled_Sequence_Of_Statements (Loc,
9539 Statements => Stms));
9540 end Build_To_Any_Function;
9542 -------------------------
9543 -- Build_TypeCode_Call --
9544 -------------------------
9546 function Build_TypeCode_Call
9549 Decls : List_Id) return Node_Id
9551 U_Type : Entity_Id := Underlying_Type (Typ);
9552 -- The full view, if Typ is private; the completion,
9553 -- if Typ is incomplete.
9555 Fnam : Entity_Id := Empty;
9556 Lib_RE : RE_Id := RE_Null;
9561 -- Special case System.PolyORB.Interface.Any: its primitives have
9562 -- not been set yet, so can't call Find_Inherited_TSS.
9564 if Typ = RTE (RE_Any) then
9565 Fnam := RTE (RE_TC_Any);
9568 -- First simple case where the TypeCode is present
9569 -- in the type's TSS.
9571 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
9575 if Sloc (U_Type) <= Standard_Location then
9577 -- Do not try to build alias typecodes for subtypes from
9580 U_Type := Base_Type (U_Type);
9583 if U_Type = Standard_Boolean then
9586 elsif U_Type = Standard_Character then
9589 elsif U_Type = Standard_Wide_Character then
9592 elsif U_Type = Standard_Wide_Wide_Character then
9593 Lib_RE := RE_TC_WWC;
9595 -- Floating point types
9597 elsif U_Type = Standard_Short_Float then
9600 elsif U_Type = Standard_Float then
9603 elsif U_Type = Standard_Long_Float then
9606 elsif U_Type = Standard_Long_Long_Float then
9607 Lib_RE := RE_TC_LLF;
9609 -- Integer types (walk back to the base type)
9611 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9612 Lib_RE := RE_TC_SSI;
9614 elsif U_Type = Etype (Standard_Short_Integer) then
9617 elsif U_Type = Etype (Standard_Integer) then
9620 elsif U_Type = Etype (Standard_Long_Integer) then
9623 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9624 Lib_RE := RE_TC_LLI;
9626 -- Unsigned integer types
9628 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9629 Lib_RE := RE_TC_SSU;
9631 elsif U_Type = RTE (RE_Short_Unsigned) then
9634 elsif U_Type = RTE (RE_Unsigned) then
9637 elsif U_Type = RTE (RE_Long_Unsigned) then
9640 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9641 Lib_RE := RE_TC_LLU;
9643 elsif U_Type = Standard_String then
9644 Lib_RE := RE_TC_String;
9646 -- Other (non-primitive) types
9652 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
9653 Append_To (Decls, Decl);
9657 if Lib_RE /= RE_Null then
9658 Fnam := RTE (Lib_RE);
9662 -- Call the function
9665 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
9667 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
9669 Set_Etype (Expr, RTE (RE_TypeCode));
9672 end Build_TypeCode_Call;
9674 -----------------------------
9675 -- Build_TypeCode_Function --
9676 -----------------------------
9678 procedure Build_TypeCode_Function
9682 Fnam : out Entity_Id)
9685 Decls : constant List_Id := New_List;
9686 Stms : constant List_Id := New_List;
9688 TCNam : constant Entity_Id :=
9689 Make_Stream_Procedure_Function_Name (Loc,
9690 Typ, Name_uTypeCode);
9692 Parameters : List_Id;
9694 procedure Add_String_Parameter
9696 Parameter_List : List_Id);
9697 -- Add a literal for S to Parameters
9699 procedure Add_TypeCode_Parameter
9701 Parameter_List : List_Id);
9702 -- Add the typecode for Typ to Parameters
9704 procedure Add_Long_Parameter
9705 (Expr_Node : Node_Id;
9706 Parameter_List : List_Id);
9707 -- Add a signed long integer expression to Parameters
9709 procedure Initialize_Parameter_List
9710 (Name_String : String_Id;
9711 Repo_Id_String : String_Id;
9712 Parameter_List : out List_Id);
9713 -- Return a list that contains the first two parameters
9714 -- for a parameterized typecode: name and repository id.
9716 function Make_Constructed_TypeCode
9718 Parameters : List_Id) return Node_Id;
9719 -- Call TC_Build with the given kind and parameters
9721 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
9722 -- Make a return statement that calls TC_Build with the given
9723 -- typecode kind, and the constructed parameters list.
9725 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
9726 -- Return a typecode that is a TC_Alias for the given typecode
9728 --------------------------
9729 -- Add_String_Parameter --
9730 --------------------------
9732 procedure Add_String_Parameter
9734 Parameter_List : List_Id)
9737 Append_To (Parameter_List,
9738 Make_Function_Call (Loc,
9740 New_Occurrence_Of (RTE (RE_TA_String), Loc),
9741 Parameter_Associations => New_List (
9742 Make_String_Literal (Loc, S))));
9743 end Add_String_Parameter;
9745 ----------------------------
9746 -- Add_TypeCode_Parameter --
9747 ----------------------------
9749 procedure Add_TypeCode_Parameter
9751 Parameter_List : List_Id)
9754 Append_To (Parameter_List,
9755 Make_Function_Call (Loc,
9757 New_Occurrence_Of (RTE (RE_TA_TC), Loc),
9758 Parameter_Associations => New_List (
9760 end Add_TypeCode_Parameter;
9762 ------------------------
9763 -- Add_Long_Parameter --
9764 ------------------------
9766 procedure Add_Long_Parameter
9767 (Expr_Node : Node_Id;
9768 Parameter_List : List_Id)
9771 Append_To (Parameter_List,
9772 Make_Function_Call (Loc,
9774 New_Occurrence_Of (RTE (RE_TA_LI), Loc),
9775 Parameter_Associations => New_List (Expr_Node)));
9776 end Add_Long_Parameter;
9778 -------------------------------
9779 -- Initialize_Parameter_List --
9780 -------------------------------
9782 procedure Initialize_Parameter_List
9783 (Name_String : String_Id;
9784 Repo_Id_String : String_Id;
9785 Parameter_List : out List_Id)
9788 Parameter_List := New_List;
9789 Add_String_Parameter (Name_String, Parameter_List);
9790 Add_String_Parameter (Repo_Id_String, Parameter_List);
9791 end Initialize_Parameter_List;
9793 ---------------------------
9794 -- Return_Alias_TypeCode --
9795 ---------------------------
9797 procedure Return_Alias_TypeCode
9798 (Base_TypeCode : Node_Id)
9801 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
9802 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
9803 end Return_Alias_TypeCode;
9805 -------------------------------
9806 -- Make_Constructed_TypeCode --
9807 -------------------------------
9809 function Make_Constructed_TypeCode
9811 Parameters : List_Id) return Node_Id
9813 Constructed_TC : constant Node_Id :=
9814 Make_Function_Call (Loc,
9816 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
9817 Parameter_Associations => New_List (
9818 New_Occurrence_Of (Kind, Loc),
9819 Make_Aggregate (Loc,
9820 Expressions => Parameters)));
9822 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
9823 return Constructed_TC;
9824 end Make_Constructed_TypeCode;
9826 ---------------------------------
9827 -- Return_Constructed_TypeCode --
9828 ---------------------------------
9830 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
9833 Make_Return_Statement (Loc,
9835 Make_Constructed_TypeCode (Kind, Parameters)));
9836 end Return_Constructed_TypeCode;
9842 procedure TC_Rec_Add_Process_Element
9845 Counter : in out Int;
9849 procedure TC_Append_Record_Traversal is
9850 new Append_Record_Traversal (
9852 Add_Process_Element => TC_Rec_Add_Process_Element);
9854 --------------------------------
9855 -- TC_Rec_Add_Process_Element --
9856 --------------------------------
9858 procedure TC_Rec_Add_Process_Element
9861 Counter : in out Int;
9865 pragma Warnings (Off);
9866 pragma Unreferenced (Any, Counter, Rec);
9867 pragma Warnings (On);
9870 if Nkind (Field) = N_Defining_Identifier then
9872 -- A regular component
9874 Add_TypeCode_Parameter (
9875 Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
9876 Get_Name_String (Chars (Field));
9877 Add_String_Parameter (String_From_Name_Buffer, Params);
9884 Discriminant_Type : constant Entity_Id :=
9885 Etype (Name (Field));
9887 Is_Enum : constant Boolean :=
9888 Is_Enumeration_Type (Discriminant_Type);
9890 Union_TC_Params : List_Id;
9892 U_Name : constant Name_Id :=
9893 New_External_Name (Chars (Typ), 'U', -1);
9895 Name_Str : String_Id;
9896 Struct_TC_Params : List_Id;
9900 Default : constant Node_Id :=
9901 Make_Integer_Literal (Loc, -1);
9903 Dummy_Counter : Int := 0;
9905 procedure Add_Params_For_Variant_Components;
9906 -- Add a struct TypeCode and a corresponding member name
9907 -- to the union parameter list.
9909 -- Ordering of declarations is a complete mess in this
9910 -- area, it is supposed to be types/varibles, then
9911 -- subprogram specs, then subprogram bodies ???
9913 ---------------------------------------
9914 -- Add_Params_For_Variant_Components --
9915 ---------------------------------------
9917 procedure Add_Params_For_Variant_Components
9919 S_Name : constant Name_Id :=
9920 New_External_Name (U_Name, 'S', -1);
9923 Get_Name_String (S_Name);
9924 Name_Str := String_From_Name_Buffer;
9925 Initialize_Parameter_List
9926 (Name_Str, Name_Str, Struct_TC_Params);
9928 -- Build struct parameters
9930 TC_Append_Record_Traversal (Struct_TC_Params,
9931 Component_List (Variant),
9935 Add_TypeCode_Parameter
9936 (Make_Constructed_TypeCode
9937 (RTE (RE_TC_Struct), Struct_TC_Params),
9940 Add_String_Parameter (Name_Str, Union_TC_Params);
9941 end Add_Params_For_Variant_Components;
9944 Get_Name_String (U_Name);
9945 Name_Str := String_From_Name_Buffer;
9947 Initialize_Parameter_List
9948 (Name_Str, Name_Str, Union_TC_Params);
9950 Add_String_Parameter (Name_Str, Params);
9952 -- Add union in enclosing parameter list
9954 Add_TypeCode_Parameter
9955 (Make_Constructed_TypeCode
9956 (RTE (RE_TC_Union), Union_TC_Params),
9959 -- Build union parameters
9961 Add_TypeCode_Parameter
9962 (Discriminant_Type, Union_TC_Params);
9963 Add_Long_Parameter (Default, Union_TC_Params);
9965 Variant := First_Non_Pragma (Variants (Field));
9966 while Present (Variant) loop
9967 Choice := First (Discrete_Choices (Variant));
9968 while Present (Choice) loop
9969 case Nkind (Choice) is
9972 L : constant Uint :=
9973 Expr_Value (Low_Bound (Choice));
9974 H : constant Uint :=
9975 Expr_Value (High_Bound (Choice));
9977 -- 3.8.1(8) guarantees that the bounds of
9978 -- this range are static.
9985 Expr := New_Occurrence_Of (
9986 Get_Enum_Lit_From_Pos (
9987 Discriminant_Type, J, Loc), Loc);
9990 Make_Integer_Literal (Loc, J);
9992 Append_To (Union_TC_Params,
9993 Build_To_Any_Call (Expr, Decls));
9994 Add_Params_For_Variant_Components;
9999 when N_Others_Choice =>
10000 Add_Long_Parameter (
10001 Make_Integer_Literal (Loc, 0),
10003 Add_Params_For_Variant_Components;
10006 Append_To (Union_TC_Params,
10007 Build_To_Any_Call (Choice, Decls));
10008 Add_Params_For_Variant_Components;
10014 Next_Non_Pragma (Variant);
10019 end TC_Rec_Add_Process_Element;
10021 Type_Name_Str : String_Id;
10022 Type_Repo_Id_Str : String_Id;
10025 pragma Assert (not Is_Itype (Typ));
10029 Make_Function_Specification (Loc,
10030 Defining_Unit_Name => Fnam,
10031 Parameter_Specifications => Empty_List,
10032 Result_Definition =>
10033 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10035 Build_Name_And_Repository_Id (Typ,
10036 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10037 Initialize_Parameter_List
10038 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10040 if Is_Derived_Type (Typ)
10041 and then not Is_Tagged_Type (Typ)
10044 Parent_Type : Entity_Id := Etype (Typ);
10047 if Is_Itype (Parent_Type) then
10049 -- Skip implicit base type
10051 Parent_Type := Etype (Parent_Type);
10054 Return_Alias_TypeCode (
10055 Build_TypeCode_Call (Loc, Parent_Type, Decls));
10058 elsif Is_Integer_Type (Typ)
10059 or else Is_Unsigned_Type (Typ)
10061 Return_Alias_TypeCode (
10062 Build_TypeCode_Call (Loc,
10063 Find_Numeric_Representation (Typ), Decls));
10065 elsif Is_Record_Type (Typ)
10066 and then not Is_Tagged_Type (Typ)
10068 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10069 Return_Alias_TypeCode (
10070 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10073 Disc : Entity_Id := Empty;
10074 Rdef : constant Node_Id :=
10075 Type_Definition (Declaration_Node (Typ));
10076 Dummy_Counter : Int := 0;
10078 -- First all discriminants
10080 if Has_Discriminants (Typ) then
10081 Disc := First_Discriminant (Typ);
10083 while Present (Disc) loop
10084 Add_TypeCode_Parameter (
10085 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10087 Get_Name_String (Chars (Disc));
10088 Add_String_Parameter (
10089 String_From_Name_Buffer,
10091 Next_Discriminant (Disc);
10094 -- ... then all components
10096 TC_Append_Record_Traversal
10097 (Parameters, Component_List (Rdef),
10098 Empty, Dummy_Counter);
10099 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10103 elsif Is_Array_Type (Typ) then
10105 Ndim : constant Pos := Number_Dimensions (Typ);
10106 Inner_TypeCode : Node_Id;
10107 Constrained : constant Boolean := Is_Constrained (Typ);
10108 Indx : Node_Id := First_Index (Typ);
10111 Inner_TypeCode := Build_TypeCode_Call (Loc,
10112 Component_Type (Typ),
10115 for J in 1 .. Ndim loop
10116 if Constrained then
10117 Inner_TypeCode := Make_Constructed_TypeCode
10118 (RTE (RE_TC_Array), New_List (
10119 Build_To_Any_Call (
10120 OK_Convert_To (RTE (RE_Long_Unsigned),
10121 Make_Attribute_Reference (Loc,
10123 New_Occurrence_Of (Typ, Loc),
10126 Expressions => New_List (
10127 Make_Integer_Literal (Loc,
10130 Build_To_Any_Call (Inner_TypeCode, Decls)));
10133 -- Unconstrained case: add low bound for each
10136 Add_TypeCode_Parameter
10137 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10139 Get_Name_String (New_External_Name ('L', J));
10140 Add_String_Parameter (
10141 String_From_Name_Buffer,
10145 Inner_TypeCode := Make_Constructed_TypeCode
10146 (RTE (RE_TC_Sequence), New_List (
10147 Build_To_Any_Call (
10148 OK_Convert_To (RTE (RE_Long_Unsigned),
10149 Make_Integer_Literal (Loc, 0)),
10151 Build_To_Any_Call (Inner_TypeCode, Decls)));
10155 if Constrained then
10156 Return_Alias_TypeCode (Inner_TypeCode);
10158 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10160 Store_String_Char ('V');
10161 Add_String_Parameter (End_String, Parameters);
10162 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10167 -- Default: type is represented as an opaque sequence of bytes
10169 Return_Alias_TypeCode
10170 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10174 Make_Subprogram_Body (Loc,
10175 Specification => Spec,
10176 Declarations => Decls,
10177 Handled_Statement_Sequence =>
10178 Make_Handled_Sequence_Of_Statements (Loc,
10179 Statements => Stms));
10180 end Build_TypeCode_Function;
10182 ---------------------------------
10183 -- Find_Numeric_Representation --
10184 ---------------------------------
10186 function Find_Numeric_Representation
10187 (Typ : Entity_Id) return Entity_Id
10189 FST : constant Entity_Id := First_Subtype (Typ);
10190 P_Size : constant Uint := Esize (FST);
10193 if Is_Unsigned_Type (Typ) then
10194 if P_Size <= Standard_Short_Short_Integer_Size then
10195 return RTE (RE_Short_Short_Unsigned);
10197 elsif P_Size <= Standard_Short_Integer_Size then
10198 return RTE (RE_Short_Unsigned);
10200 elsif P_Size <= Standard_Integer_Size then
10201 return RTE (RE_Unsigned);
10203 elsif P_Size <= Standard_Long_Integer_Size then
10204 return RTE (RE_Long_Unsigned);
10207 return RTE (RE_Long_Long_Unsigned);
10210 elsif Is_Integer_Type (Typ) then
10211 if P_Size <= Standard_Short_Short_Integer_Size then
10212 return Standard_Short_Short_Integer;
10214 elsif P_Size <= Standard_Short_Integer_Size then
10215 return Standard_Short_Integer;
10217 elsif P_Size <= Standard_Integer_Size then
10218 return Standard_Integer;
10220 elsif P_Size <= Standard_Long_Integer_Size then
10221 return Standard_Long_Integer;
10224 return Standard_Long_Long_Integer;
10227 elsif Is_Floating_Point_Type (Typ) then
10228 if P_Size <= Standard_Short_Float_Size then
10229 return Standard_Short_Float;
10231 elsif P_Size <= Standard_Float_Size then
10232 return Standard_Float;
10234 elsif P_Size <= Standard_Long_Float_Size then
10235 return Standard_Long_Float;
10238 return Standard_Long_Long_Float;
10242 raise Program_Error;
10245 -- TBD: fixed point types???
10246 -- TBverified numeric types with a biased representation???
10248 end Find_Numeric_Representation;
10250 ---------------------------
10251 -- Append_Array_Traversal --
10252 ---------------------------
10254 procedure Append_Array_Traversal
10257 Counter : Entity_Id := Empty;
10260 Loc : constant Source_Ptr := Sloc (Subprogram);
10261 Typ : constant Entity_Id := Etype (Arry);
10262 Constrained : constant Boolean := Is_Constrained (Typ);
10263 Ndim : constant Pos := Number_Dimensions (Typ);
10265 Inner_Any, Inner_Counter : Entity_Id;
10267 Loop_Stm : Node_Id;
10268 Inner_Stmts : constant List_Id := New_List;
10271 if Depth > Ndim then
10273 -- Processing for one element of an array
10276 Element_Expr : constant Node_Id :=
10277 Make_Indexed_Component (Loc,
10278 New_Occurrence_Of (Arry, Loc),
10282 Set_Etype (Element_Expr, Component_Type (Typ));
10283 Add_Process_Element (Stmts,
10285 Counter => Counter,
10286 Datum => Element_Expr);
10292 Append_To (Indices,
10293 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10295 if not Constrained or else Depth > 1 then
10296 Inner_Any := Make_Defining_Identifier (Loc,
10297 New_External_Name ('A', Depth));
10298 Set_Etype (Inner_Any, RTE (RE_Any));
10300 Inner_Any := Empty;
10303 if Present (Counter) then
10304 Inner_Counter := Make_Defining_Identifier (Loc,
10305 New_External_Name ('J', Depth));
10307 Inner_Counter := Empty;
10311 Loop_Any : Node_Id := Inner_Any;
10314 -- For the first dimension of a constrained array, we add
10315 -- elements directly in the corresponding Any; there is no
10316 -- intervening inner Any.
10318 if No (Loop_Any) then
10322 Append_Array_Traversal (Inner_Stmts,
10324 Counter => Inner_Counter,
10325 Depth => Depth + 1);
10329 Make_Implicit_Loop_Statement (Subprogram,
10330 Iteration_Scheme =>
10331 Make_Iteration_Scheme (Loc,
10332 Loop_Parameter_Specification =>
10333 Make_Loop_Parameter_Specification (Loc,
10334 Defining_Identifier =>
10335 Make_Defining_Identifier (Loc,
10336 Chars => New_External_Name ('L', Depth)),
10338 Discrete_Subtype_Definition =>
10339 Make_Attribute_Reference (Loc,
10340 Prefix => New_Occurrence_Of (Arry, Loc),
10341 Attribute_Name => Name_Range,
10343 Expressions => New_List (
10344 Make_Integer_Literal (Loc, Depth))))),
10345 Statements => Inner_Stmts);
10348 Decls : constant List_Id := New_List;
10349 Dimen_Stmts : constant List_Id := New_List;
10350 Length_Node : Node_Id;
10352 Inner_Any_TypeCode : constant Entity_Id :=
10353 Make_Defining_Identifier (Loc,
10354 New_External_Name ('T', Depth));
10356 Inner_Any_TypeCode_Expr : Node_Id;
10360 if Constrained then
10361 Inner_Any_TypeCode_Expr :=
10362 Make_Function_Call (Loc,
10364 New_Occurrence_Of (RTE (RE_Get_TC), Loc),
10365 Parameter_Associations => New_List (
10366 New_Occurrence_Of (Any, Loc)));
10368 Inner_Any_TypeCode_Expr :=
10369 Make_Function_Call (Loc,
10371 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
10372 Parameter_Associations => New_List (
10373 New_Occurrence_Of (Any, Loc),
10374 Make_Integer_Literal (Loc, Ndim)));
10377 Inner_Any_TypeCode_Expr :=
10378 Make_Function_Call (Loc,
10380 New_Occurrence_Of (RTE (RE_Content_Type), Loc),
10381 Parameter_Associations => New_List (
10382 Make_Identifier (Loc,
10383 New_External_Name ('T', Depth - 1))));
10387 Make_Object_Declaration (Loc,
10388 Defining_Identifier => Inner_Any_TypeCode,
10389 Constant_Present => True,
10390 Object_Definition => New_Occurrence_Of (
10391 RTE (RE_TypeCode), Loc),
10392 Expression => Inner_Any_TypeCode_Expr));
10394 if Present (Inner_Any) then
10396 Make_Object_Declaration (Loc,
10397 Defining_Identifier => Inner_Any,
10398 Object_Definition =>
10399 New_Occurrence_Of (RTE (RE_Any), Loc),
10401 Make_Function_Call (Loc,
10403 New_Occurrence_Of (
10404 RTE (RE_Create_Any), Loc),
10405 Parameter_Associations => New_List (
10406 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
10409 if Present (Inner_Counter) then
10411 Make_Object_Declaration (Loc,
10412 Defining_Identifier => Inner_Counter,
10413 Object_Definition =>
10414 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
10416 Make_Integer_Literal (Loc, 0)));
10419 if not Constrained then
10420 Length_Node := Make_Attribute_Reference (Loc,
10421 Prefix => New_Occurrence_Of (Arry, Loc),
10422 Attribute_Name => Name_Length,
10424 New_List (Make_Integer_Literal (Loc, Depth)));
10425 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
10427 Add_Process_Element (Dimen_Stmts,
10428 Datum => Length_Node,
10430 Counter => Inner_Counter);
10433 -- Loop_Stm does approrpriate processing for each element
10436 Append_To (Dimen_Stmts, Loop_Stm);
10438 -- Link outer and inner any
10440 if Present (Inner_Any) then
10441 Add_Process_Element (Dimen_Stmts,
10443 Counter => Counter,
10444 Datum => New_Occurrence_Of (Inner_Any, Loc));
10448 Make_Block_Statement (Loc,
10451 Handled_Statement_Sequence =>
10452 Make_Handled_Sequence_Of_Statements (Loc,
10453 Statements => Dimen_Stmts)));
10455 end Append_Array_Traversal;
10457 -----------------------------------------
10458 -- Make_Stream_Procedure_Function_Name --
10459 -----------------------------------------
10461 function Make_Stream_Procedure_Function_Name
10464 Nam : Name_Id) return Entity_Id
10467 -- For tagged types, we use a canonical name so that it matches
10468 -- the primitive spec. For all other cases, we use a serialized
10469 -- name so that multiple generations of the same procedure do not
10472 if Is_Tagged_Type (Typ) then
10473 return Make_Defining_Identifier (Loc, Nam);
10475 return Make_Defining_Identifier (Loc,
10477 New_External_Name (Nam, ' ', Increment_Serial_Number));
10479 end Make_Stream_Procedure_Function_Name;
10482 -----------------------------------
10483 -- Reserve_NamingContext_Methods --
10484 -----------------------------------
10486 procedure Reserve_NamingContext_Methods is
10487 Str_Resolve : constant String := "resolve";
10489 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
10490 Name_Len := Str_Resolve'Length;
10491 Overload_Counter_Table.Set (Name_Find, 1);
10492 end Reserve_NamingContext_Methods;
10494 end PolyORB_Support;
10496 -------------------------------
10497 -- RACW_Type_Is_Asynchronous --
10498 -------------------------------
10500 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
10501 Asynchronous_Flag : constant Entity_Id :=
10502 Asynchronous_Flags_Table.Get (RACW_Type);
10504 Replace (Expression (Parent (Asynchronous_Flag)),
10505 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
10506 end RACW_Type_Is_Asynchronous;
10508 -------------------------
10509 -- RCI_Package_Locator --
10510 -------------------------
10512 function RCI_Package_Locator
10514 Package_Spec : Node_Id) return Node_Id
10517 Pkg_Name : String_Id;
10520 Get_Library_Unit_Name_String (Package_Spec);
10521 Pkg_Name := String_From_Name_Buffer;
10523 Make_Package_Instantiation (Loc,
10524 Defining_Unit_Name =>
10525 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
10527 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
10528 Generic_Associations => New_List (
10529 Make_Generic_Association (Loc,
10531 Make_Identifier (Loc, Name_RCI_Name),
10532 Explicit_Generic_Actual_Parameter =>
10533 Make_String_Literal (Loc,
10534 Strval => Pkg_Name))));
10536 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
10537 Defining_Unit_Name (Inst));
10539 end RCI_Package_Locator;
10541 -----------------------------------------------
10542 -- Remote_Types_Tagged_Full_View_Encountered --
10543 -----------------------------------------------
10545 procedure Remote_Types_Tagged_Full_View_Encountered
10546 (Full_View : Entity_Id)
10548 Stub_Elements : constant Stub_Structure :=
10549 Stubs_Table.Get (Full_View);
10551 if Stub_Elements /= Empty_Stub_Structure then
10552 Add_RACW_Primitive_Declarations_And_Bodies
10554 Stub_Elements.RPC_Receiver_Decl,
10555 List_Containing (Declaration_Node (Full_View)));
10557 end Remote_Types_Tagged_Full_View_Encountered;
10559 -------------------
10560 -- Scope_Of_Spec --
10561 -------------------
10563 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
10564 Unit_Name : Node_Id;
10567 Unit_Name := Defining_Unit_Name (Spec);
10568 while Nkind (Unit_Name) /= N_Defining_Identifier loop
10569 Unit_Name := Defining_Identifier (Unit_Name);
10575 ----------------------
10576 -- Set_Renaming_TSS --
10577 ----------------------
10579 procedure Set_Renaming_TSS
10582 TSS_Nam : TSS_Name_Type)
10584 Loc : constant Source_Ptr := Sloc (Nam);
10585 Spec : constant Node_Id := Parent (Nam);
10587 TSS_Node : constant Node_Id :=
10588 Make_Subprogram_Renaming_Declaration (Loc,
10590 Copy_Specification (Loc,
10592 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
10593 Name => New_Occurrence_Of (Nam, Loc));
10595 Snam : constant Entity_Id :=
10596 Defining_Unit_Name (Specification (TSS_Node));
10599 if Nkind (Spec) = N_Function_Specification then
10600 Set_Ekind (Snam, E_Function);
10601 Set_Etype (Snam, Entity (Result_Definition (Spec)));
10603 Set_Ekind (Snam, E_Procedure);
10604 Set_Etype (Snam, Standard_Void_Type);
10607 Set_TSS (Typ, Snam);
10608 end Set_Renaming_TSS;
10610 ----------------------------------------------
10611 -- Specific_Add_Obj_RPC_Receiver_Completion --
10612 ----------------------------------------------
10614 procedure Specific_Add_Obj_RPC_Receiver_Completion
10617 RPC_Receiver : Entity_Id;
10618 Stub_Elements : Stub_Structure) is
10620 case Get_PCS_Name is
10621 when Name_PolyORB_DSA =>
10622 PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
10623 Decls, RPC_Receiver, Stub_Elements);
10625 GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
10626 Decls, RPC_Receiver, Stub_Elements);
10628 end Specific_Add_Obj_RPC_Receiver_Completion;
10630 --------------------------------
10631 -- Specific_Add_RACW_Features --
10632 --------------------------------
10634 procedure Specific_Add_RACW_Features
10635 (RACW_Type : Entity_Id;
10637 Stub_Type : Entity_Id;
10638 Stub_Type_Access : Entity_Id;
10639 RPC_Receiver_Decl : Node_Id;
10640 Declarations : List_Id) is
10642 case Get_PCS_Name is
10643 when Name_PolyORB_DSA =>
10644 PolyORB_Support.Add_RACW_Features (
10653 GARLIC_Support.Add_RACW_Features (
10660 end Specific_Add_RACW_Features;
10662 --------------------------------
10663 -- Specific_Add_RAST_Features --
10664 --------------------------------
10666 procedure Specific_Add_RAST_Features
10667 (Vis_Decl : Node_Id;
10668 RAS_Type : Entity_Id) is
10670 case Get_PCS_Name is
10671 when Name_PolyORB_DSA =>
10672 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
10674 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
10676 end Specific_Add_RAST_Features;
10678 --------------------------------------------------
10679 -- Specific_Add_Receiving_Stubs_To_Declarations --
10680 --------------------------------------------------
10682 procedure Specific_Add_Receiving_Stubs_To_Declarations
10683 (Pkg_Spec : Node_Id;
10687 case Get_PCS_Name is
10688 when Name_PolyORB_DSA =>
10689 PolyORB_Support.Add_Receiving_Stubs_To_Declarations (
10692 GARLIC_Support.Add_Receiving_Stubs_To_Declarations (
10695 end Specific_Add_Receiving_Stubs_To_Declarations;
10697 ------------------------------------------
10698 -- Specific_Build_General_Calling_Stubs --
10699 ------------------------------------------
10701 procedure Specific_Build_General_Calling_Stubs
10703 Statements : List_Id;
10704 Target : RPC_Target;
10705 Subprogram_Id : Node_Id;
10706 Asynchronous : Node_Id := Empty;
10707 Is_Known_Asynchronous : Boolean := False;
10708 Is_Known_Non_Asynchronous : Boolean := False;
10709 Is_Function : Boolean;
10711 Stub_Type : Entity_Id := Empty;
10712 RACW_Type : Entity_Id := Empty;
10716 case Get_PCS_Name is
10717 when Name_PolyORB_DSA =>
10718 PolyORB_Support.Build_General_Calling_Stubs (
10724 Is_Known_Asynchronous,
10725 Is_Known_Non_Asynchronous,
10732 GARLIC_Support.Build_General_Calling_Stubs (
10736 Target.RPC_Receiver,
10739 Is_Known_Asynchronous,
10740 Is_Known_Non_Asynchronous,
10747 end Specific_Build_General_Calling_Stubs;
10749 --------------------------------------
10750 -- Specific_Build_RPC_Receiver_Body --
10751 --------------------------------------
10753 procedure Specific_Build_RPC_Receiver_Body
10754 (RPC_Receiver : Entity_Id;
10755 Request : out Entity_Id;
10756 Subp_Id : out Entity_Id;
10757 Subp_Index : out Entity_Id;
10758 Stmts : out List_Id;
10759 Decl : out Node_Id)
10762 case Get_PCS_Name is
10763 when Name_PolyORB_DSA =>
10764 PolyORB_Support.Build_RPC_Receiver_Body
10772 GARLIC_Support.Build_RPC_Receiver_Body
10780 end Specific_Build_RPC_Receiver_Body;
10782 --------------------------------
10783 -- Specific_Build_Stub_Target --
10784 --------------------------------
10786 function Specific_Build_Stub_Target
10789 RCI_Locator : Entity_Id;
10790 Controlling_Parameter : Entity_Id) return RPC_Target
10793 case Get_PCS_Name is
10794 when Name_PolyORB_DSA =>
10795 return PolyORB_Support.Build_Stub_Target (Loc,
10796 Decls, RCI_Locator, Controlling_Parameter);
10798 return GARLIC_Support.Build_Stub_Target (Loc,
10799 Decls, RCI_Locator, Controlling_Parameter);
10801 end Specific_Build_Stub_Target;
10803 ------------------------------
10804 -- Specific_Build_Stub_Type --
10805 ------------------------------
10807 procedure Specific_Build_Stub_Type
10808 (RACW_Type : Entity_Id;
10809 Stub_Type : Entity_Id;
10810 Stub_Type_Decl : out Node_Id;
10811 RPC_Receiver_Decl : out Node_Id)
10814 case Get_PCS_Name is
10815 when Name_PolyORB_DSA =>
10816 PolyORB_Support.Build_Stub_Type (
10817 RACW_Type, Stub_Type,
10818 Stub_Type_Decl, RPC_Receiver_Decl);
10820 GARLIC_Support.Build_Stub_Type (
10821 RACW_Type, Stub_Type,
10822 Stub_Type_Decl, RPC_Receiver_Decl);
10824 end Specific_Build_Stub_Type;
10826 function Specific_Build_Subprogram_Receiving_Stubs
10827 (Vis_Decl : Node_Id;
10828 Asynchronous : Boolean;
10829 Dynamically_Asynchronous : Boolean := False;
10830 Stub_Type : Entity_Id := Empty;
10831 RACW_Type : Entity_Id := Empty;
10832 Parent_Primitive : Entity_Id := Empty) return Node_Id
10835 case Get_PCS_Name is
10836 when Name_PolyORB_DSA =>
10837 return PolyORB_Support.Build_Subprogram_Receiving_Stubs (
10840 Dynamically_Asynchronous,
10845 return GARLIC_Support.Build_Subprogram_Receiving_Stubs (
10848 Dynamically_Asynchronous,
10853 end Specific_Build_Subprogram_Receiving_Stubs;
10855 --------------------------
10856 -- Underlying_RACW_Type --
10857 --------------------------
10859 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
10860 Record_Type : Entity_Id;
10863 if Ekind (RAS_Typ) = E_Record_Type then
10864 Record_Type := RAS_Typ;
10866 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
10867 Record_Type := Equivalent_Type (RAS_Typ);
10871 Etype (Subtype_Indication (
10872 Component_Definition (
10873 First (Component_Items (Component_List (
10874 Type_Definition (Declaration_Node (Record_Type))))))));
10875 end Underlying_RACW_Type;