1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 function Get_PCS_Name return PCS_Names;
156 -- Return the name of a literal of type
157 -- System.Partition_Interface.DSA_Implementation_Type
158 -- indicating what PCS is currently in use.
160 procedure Add_RAS_Dereference_TSS (N : Node_Id);
161 -- Add a subprogram body for RAS Dereference TSS
163 procedure Add_RAS_Proxy_And_Analyze
166 All_Calls_Remote_E : Entity_Id;
167 Proxy_Object_Addr : out Entity_Id);
168 -- Add the proxy type necessary to call the subprogram declared
169 -- by Vis_Decl through a remote access to subprogram type.
170 -- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote
171 -- applies, Standard_False otherwise. The new proxy type is appended
172 -- to Decls. Proxy_Object_Addr is a constant of type System.Address that
173 -- designates an instance of the proxy object.
175 function Build_Remote_Subprogram_Proxy_Type
177 ACR_Expression : Node_Id) return Node_Id;
178 -- Build and return a tagged record type definition for an RCI
179 -- subprogram proxy type.
180 -- ACR_Expression is use as the initialization value for
181 -- the All_Calls_Remote component.
183 function Build_Get_Unique_RP_Call
186 Stub_Type : Entity_Id) return List_Id;
187 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
188 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
189 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
191 function Build_Subprogram_Calling_Stubs
194 Asynchronous : Boolean;
195 Dynamically_Asynchronous : Boolean := False;
196 Stub_Type : Entity_Id := Empty;
197 RACW_Type : Entity_Id := Empty;
198 Locator : Entity_Id := Empty;
199 New_Name : Name_Id := No_Name) return Node_Id;
200 -- Build the calling stub for a given subprogram with the subprogram ID
201 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
202 -- parameters of this type will be marshalled instead of the object
203 -- itself. It will then be converted into Stub_Type before performing
204 -- the real call. If Dynamically_Asynchronous is True, then it will be
205 -- computed at run time whether the call is asynchronous or not.
206 -- Otherwise, the value of the formal Asynchronous will be used.
207 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
208 -- New_Name is given, then it will be used instead of the original name.
210 function Build_RPC_Receiver_Specification
211 (RPC_Receiver : Entity_Id;
212 Request_Parameter : Entity_Id) return Node_Id;
213 -- Make a subprogram specification for an RPC receiver, with the given
214 -- defining unit name and formal parameter.
216 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
217 -- Return an ordered parameter list: unconstrained parameters are put
218 -- at the beginning of the list and constrained ones are put after. If
219 -- there are no parameters, an empty list is returned. Special case:
220 -- the controlling formal of the equivalent RACW operation for a RAS
221 -- type is always left in first position.
223 procedure Add_Calling_Stubs_To_Declarations
226 -- Add calling stubs to the declarative part
228 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
229 -- Return True if nothing prevents the program whose specification is
230 -- given to be asynchronous (i.e. no out parameter).
232 function Pack_Entity_Into_Stream_Access
236 Etyp : Entity_Id := Empty) return Node_Id;
237 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
238 -- then Etype (Object) will be used if present. If the type is
239 -- constrained, then 'Write will be used to output the object,
240 -- If the type is unconstrained, 'Output will be used.
242 function Pack_Node_Into_Stream
246 Etyp : Entity_Id) return Node_Id;
247 -- Similar to above, with an arbitrary node instead of an entity
249 function Pack_Node_Into_Stream_Access
253 Etyp : Entity_Id) return Node_Id;
254 -- Similar to above, with Stream instead of Stream'Access
256 function Make_Selected_Component
259 Selector_Name : Name_Id) return Node_Id;
260 -- Return a selected_component whose prefix denotes the given entity,
261 -- and with the given Selector_Name.
263 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
264 -- Return the scope represented by a given spec
266 procedure Set_Renaming_TSS
269 TSS_Nam : TSS_Name_Type);
270 -- Create a renaming declaration of subprogram Nam,
271 -- and register it as a TSS for Typ with name TSS_Nam.
273 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
274 -- Return True if the current parameter needs an extra formal to reflect
275 -- its constrained status.
277 function Is_RACW_Controlling_Formal
278 (Parameter : Node_Id; Stub_Type : Entity_Id) return Boolean;
279 -- Return True if the current parameter is a controlling formal argument
280 -- of type Stub_Type or access to Stub_Type.
282 procedure Declare_Create_NVList
287 -- Append the declaration of NVList to Decls, and its
288 -- initialization to Stmts.
290 function Add_Parameter_To_NVList
293 Parameter : Entity_Id;
294 Constrained : Boolean;
295 RACW_Ctrl : Boolean := False;
296 Any : Entity_Id) return Node_Id;
297 -- Return a call to Add_Item to add the Any corresponding
298 -- to the designated formal Parameter (with the indicated
299 -- Constrained status) to NVList. RACW_Ctrl must be set to
300 -- True for controlling formals of distributed object primitive
303 type Stub_Structure is record
304 Stub_Type : Entity_Id;
305 Stub_Type_Access : Entity_Id;
306 RPC_Receiver_Decl : Node_Id;
307 RACW_Type : Entity_Id;
309 -- This structure is necessary because of the two phases analysis of
310 -- a RACW declaration occurring in the same Remote_Types package as the
311 -- designated type. RACW_Type is any of the RACW types pointing on this
312 -- designated type, it is used here to save an anonymous type creation
313 -- for each primitive operation.
315 -- For a RACW that implements a RAS, no object RPC receiver is generated.
316 -- Instead, RPC_Receiver_Decl is the declaration after which the
317 -- RPC receiver would have been inserted.
319 Empty_Stub_Structure : constant Stub_Structure :=
320 (Empty, Empty, Empty, Empty);
322 package Stubs_Table is
323 new Simple_HTable (Header_Num => Hash_Index,
324 Element => Stub_Structure,
325 No_Element => Empty_Stub_Structure,
329 -- Mapping between a RACW designated type and its stub type
331 package Asynchronous_Flags_Table is
332 new Simple_HTable (Header_Num => Hash_Index,
333 Element => Entity_Id,
338 -- Mapping between a RACW type and a constant having the value True
339 -- if the RACW is asynchronous and False otherwise.
341 package RCI_Locator_Table is
342 new Simple_HTable (Header_Num => Hash_Index,
343 Element => Entity_Id,
348 -- Mapping between a RCI package on which All_Calls_Remote applies and
349 -- the generic instantiation of RCI_Locator for this package.
351 package RCI_Calling_Stubs_Table is
352 new Simple_HTable (Header_Num => Hash_Index,
353 Element => Entity_Id,
358 -- Mapping between a RCI subprogram and the corresponding calling stubs
360 procedure Add_Stub_Type
361 (Designated_Type : Entity_Id;
362 RACW_Type : Entity_Id;
364 Stub_Type : out Entity_Id;
365 Stub_Type_Access : out Entity_Id;
366 RPC_Receiver_Decl : out Node_Id;
367 Existing : out Boolean);
368 -- Add the declaration of the stub type, the access to stub type and the
369 -- object RPC receiver at the end of Decls. If these already exist,
370 -- then nothing is added in the tree but the right values are returned
371 -- anyhow and Existing is set to True.
373 procedure Add_RACW_Asynchronous_Flag
374 (Declarations : List_Id;
375 RACW_Type : Entity_Id);
376 -- Declare a boolean constant associated with RACW_Type whose value
377 -- indicates at run time whether a pragma Asynchronous applies to it.
379 procedure Assign_Subprogram_Identifier
383 -- Determine the distribution subprogram identifier to
384 -- be used for remote subprogram Def, return it in Id and
385 -- store it in a hash table for later retrieval by
386 -- Get_Subprogram_Id. Spn is the subprogram number.
388 function RCI_Package_Locator
390 Package_Spec : Node_Id) return Node_Id;
391 -- Instantiate the generic package RCI_Locator in order to locate the
392 -- RCI package whose spec is given as argument.
394 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
395 -- Surround a node N by a tag check, as in:
399 -- when E : Ada.Tags.Tag_Error =>
400 -- Raise_Exception (Program_Error'Identity,
401 -- Exception_Message (E));
404 function Input_With_Tag_Check
406 Var_Type : Entity_Id;
407 Stream : Node_Id) return Node_Id;
408 -- Return a function with the following form:
409 -- function R return Var_Type is
411 -- return Var_Type'Input (S);
413 -- when E : Ada.Tags.Tag_Error =>
414 -- Raise_Exception (Program_Error'Identity,
415 -- Exception_Message (E));
418 --------------------------------------------
419 -- Hooks for PCS-specific code generation --
420 --------------------------------------------
422 -- Part of the code generation circuitry for distribution needs to be
423 -- tailored for each implementation of the PCS. For each routine that
424 -- needs to be specialized, a Specific_<routine> wrapper is created,
425 -- which calls the corresponding <routine> in package
426 -- <pcs_implementation>_Support.
428 procedure Specific_Add_RACW_Features
429 (RACW_Type : Entity_Id;
431 Stub_Type : Entity_Id;
432 Stub_Type_Access : Entity_Id;
433 RPC_Receiver_Decl : Node_Id;
434 Declarations : List_Id);
435 -- Add declaration for TSSs for a given RACW type. The declarations are
436 -- added just after the declaration of the RACW type itself, while the
437 -- bodies are inserted at the end of Decls. Runtime-specific ancillary
438 -- subprogram for Add_RACW_Features.
440 procedure Specific_Add_RAST_Features
442 RAS_Type : Entity_Id;
444 -- Add declaration for TSSs for a given RAS type. The declarations are
445 -- added just after the declaration of the RAS type itself, while the
446 -- bodies are inserted at the end of Decls. PCS-specific ancillary
447 -- subprogram for Add_RAST_Features.
449 -- An RPC_Target record is used during construction of calling stubs
450 -- to pass PCS-specific tree fragments corresponding to the information
451 -- necessary to locate the target of a remote subprogram call.
453 type RPC_Target (PCS_Kind : PCS_Names) is record
455 when Name_PolyORB_DSA =>
457 -- An expression whose value is a PolyORB reference to the target
460 Partition : Entity_Id;
461 -- A variable containing the Partition_ID of the target parition
463 RPC_Receiver : Node_Id;
464 -- An expression whose value is the address of the target RPC
469 procedure Specific_Build_General_Calling_Stubs
471 Statements : List_Id;
473 Subprogram_Id : Node_Id;
474 Asynchronous : Node_Id := Empty;
475 Is_Known_Asynchronous : Boolean := False;
476 Is_Known_Non_Asynchronous : Boolean := False;
477 Is_Function : Boolean;
479 Stub_Type : Entity_Id := Empty;
480 RACW_Type : Entity_Id := Empty;
482 -- Build calling stubs for general purpose. The parameters are:
483 -- Decls : a place to put declarations
484 -- Statements : a place to put statements
485 -- Target : PCS-specific target information (see details
486 -- in RPC_Target declaration).
487 -- Subprogram_Id : a node containing the subprogram ID
488 -- Asynchronous : True if an APC must be made instead of an RPC.
489 -- The value needs not be supplied if one of the
490 -- Is_Known_... is True.
491 -- Is_Known_Async... : True if we know that this is asynchronous
492 -- Is_Known_Non_A... : True if we know that this is not asynchronous
493 -- Spec : a node with a Parameter_Specifications and
494 -- a Subtype_Mark if applicable
495 -- Stub_Type : in case of RACW stubs, parameters of type access
496 -- to Stub_Type will be marshalled using the
497 -- address of the object (the addr field) rather
498 -- than using the 'Write on the stub itself
499 -- Nod : used to provide sloc for generated code
501 function Specific_Build_Stub_Target
504 RCI_Locator : Entity_Id;
505 Controlling_Parameter : Entity_Id) return RPC_Target;
506 -- Build call target information nodes for use within calling stubs. In the
507 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
508 -- for an RACW, Controlling_Parameter is the entity for the controlling
509 -- formal parameter used to determine the location of the target of the
510 -- call. Decls provides a location where variable declarations can be
511 -- appended to construct the necessary values.
513 procedure Specific_Build_Stub_Type
514 (RACW_Type : Entity_Id;
515 Stub_Type : Entity_Id;
516 Stub_Type_Decl : out Node_Id;
517 RPC_Receiver_Decl : out Node_Id);
518 -- Build a type declaration for the stub type associated with an RACW
519 -- type, and the necessary RPC receiver, if applicable. PCS-specific
520 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
521 -- is generated, then RPC_Receiver_Decl is set to Empty.
523 procedure Specific_Build_RPC_Receiver_Body
524 (RPC_Receiver : Entity_Id;
525 Request : out Entity_Id;
526 Subp_Id : out Entity_Id;
527 Subp_Index : out Entity_Id;
530 -- Make a subprogram body for an RPC receiver, with the given
531 -- defining unit name. On return:
532 -- - Subp_Id is the subprogram identifier from the PCS.
533 -- - Subp_Index is the index in the list of subprograms
534 -- used for dispatching (a variable of type Subprogram_Id).
535 -- - Stmts is the place where the request dispatching
536 -- statements can occur,
537 -- - Decl is the subprogram body declaration.
539 function Specific_Build_Subprogram_Receiving_Stubs
541 Asynchronous : Boolean;
542 Dynamically_Asynchronous : Boolean := False;
543 Stub_Type : Entity_Id := Empty;
544 RACW_Type : Entity_Id := Empty;
545 Parent_Primitive : Entity_Id := Empty) return Node_Id;
546 -- Build the receiving stub for a given subprogram. The subprogram
547 -- declaration is also built by this procedure, and the value returned
548 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
549 -- found in the specification, then its address is read from the stream
550 -- instead of the object itself and converted into an access to
551 -- class-wide type before doing the real call using any of the RACW type
552 -- pointing on the designated type.
554 procedure Specific_Add_Obj_RPC_Receiver_Completion
557 RPC_Receiver : Entity_Id;
558 Stub_Elements : Stub_Structure);
559 -- Add the necessary code to Decls after the completion of generation
560 -- of the RACW RPC receiver described by Stub_Elements.
562 procedure Specific_Add_Receiving_Stubs_To_Declarations
565 -- Add receiving stubs to the declarative part of an RCI unit
567 package GARLIC_Support is
569 -- Support for generating DSA code that uses the GARLIC PCS
571 -- The subprograms below provide the GARLIC versions of
572 -- the corresponding Specific_<subprogram> routine declared
575 procedure Add_RACW_Features
576 (RACW_Type : Entity_Id;
577 Stub_Type : Entity_Id;
578 Stub_Type_Access : Entity_Id;
579 RPC_Receiver_Decl : Node_Id;
580 Declarations : List_Id);
582 procedure Add_RAST_Features
584 RAS_Type : Entity_Id;
587 procedure Build_General_Calling_Stubs
589 Statements : List_Id;
590 Target_Partition : Entity_Id; -- From RPC_Target
591 Target_RPC_Receiver : Node_Id; -- From RPC_Target
592 Subprogram_Id : Node_Id;
593 Asynchronous : Node_Id := Empty;
594 Is_Known_Asynchronous : Boolean := False;
595 Is_Known_Non_Asynchronous : Boolean := False;
596 Is_Function : Boolean;
598 Stub_Type : Entity_Id := Empty;
599 RACW_Type : Entity_Id := Empty;
602 function Build_Stub_Target
605 RCI_Locator : Entity_Id;
606 Controlling_Parameter : Entity_Id) return RPC_Target;
608 procedure Build_Stub_Type
609 (RACW_Type : Entity_Id;
610 Stub_Type : Entity_Id;
611 Stub_Type_Decl : out Node_Id;
612 RPC_Receiver_Decl : out Node_Id);
614 function Build_Subprogram_Receiving_Stubs
616 Asynchronous : Boolean;
617 Dynamically_Asynchronous : Boolean := False;
618 Stub_Type : Entity_Id := Empty;
619 RACW_Type : Entity_Id := Empty;
620 Parent_Primitive : Entity_Id := Empty) return Node_Id;
622 procedure Add_Obj_RPC_Receiver_Completion
625 RPC_Receiver : Entity_Id;
626 Stub_Elements : Stub_Structure);
628 procedure Add_Receiving_Stubs_To_Declarations
632 procedure Build_RPC_Receiver_Body
633 (RPC_Receiver : Entity_Id;
634 Request : out Entity_Id;
635 Subp_Id : out Entity_Id;
636 Subp_Index : out Entity_Id;
642 package PolyORB_Support is
644 -- Support for generating DSA code that uses the PolyORB PCS
646 -- The subprograms below provide the PolyORB versions of
647 -- the corresponding Specific_<subprogram> routine declared
650 procedure Add_RACW_Features
651 (RACW_Type : Entity_Id;
653 Stub_Type : Entity_Id;
654 Stub_Type_Access : Entity_Id;
655 RPC_Receiver_Decl : Node_Id;
656 Declarations : List_Id);
658 procedure Add_RAST_Features
660 RAS_Type : Entity_Id;
663 procedure Build_General_Calling_Stubs
665 Statements : List_Id;
666 Target_Object : Node_Id; -- From RPC_Target
667 Subprogram_Id : Node_Id;
668 Asynchronous : Node_Id := Empty;
669 Is_Known_Asynchronous : Boolean := False;
670 Is_Known_Non_Asynchronous : Boolean := False;
671 Is_Function : Boolean;
673 Stub_Type : Entity_Id := Empty;
674 RACW_Type : Entity_Id := Empty;
677 function Build_Stub_Target
680 RCI_Locator : Entity_Id;
681 Controlling_Parameter : Entity_Id) return RPC_Target;
683 procedure Build_Stub_Type
684 (RACW_Type : Entity_Id;
685 Stub_Type : Entity_Id;
686 Stub_Type_Decl : out Node_Id;
687 RPC_Receiver_Decl : out Node_Id);
689 function Build_Subprogram_Receiving_Stubs
691 Asynchronous : Boolean;
692 Dynamically_Asynchronous : Boolean := False;
693 Stub_Type : Entity_Id := Empty;
694 RACW_Type : Entity_Id := Empty;
695 Parent_Primitive : Entity_Id := Empty) return Node_Id;
697 procedure Add_Obj_RPC_Receiver_Completion
700 RPC_Receiver : Entity_Id;
701 Stub_Elements : Stub_Structure);
703 procedure Add_Receiving_Stubs_To_Declarations
707 procedure Build_RPC_Receiver_Body
708 (RPC_Receiver : Entity_Id;
709 Request : out Entity_Id;
710 Subp_Id : out Entity_Id;
711 Subp_Index : out Entity_Id;
715 procedure Reserve_NamingContext_Methods;
716 -- Mark the method names for interface NamingContext as already used in
717 -- the overload table, so no clashes occur with user code (with the
718 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
719 -- their methods to be accessed as objects, for the implementation of
720 -- remote access-to-subprogram types).
724 -- Routines to build distribtion helper subprograms for user-defined
725 -- types. For implementation of the Distributed systems annex (DSA)
726 -- over the PolyORB generic middleware components, it is necessary to
727 -- generate several supporting subprograms for each application data
728 -- type used in inter-partition communication. These subprograms are:
729 -- * a Typecode function returning a high-level description of the
731 -- * two conversion functions allowing conversion of values of the
732 -- type from and to the generic data containers used by PolyORB.
733 -- These generic containers are called 'Any' type values after
734 -- the CORBA terminology, and hence the conversion subprograms
735 -- are named To_Any and From_Any.
737 function Build_From_Any_Call
740 Decls : List_Id) return Node_Id;
741 -- Build call to From_Any attribute function of type Typ with
742 -- expression N as actual parameter. Decls is the declarations list
743 -- for an appropriate enclosing scope of the point where the call
744 -- will be inserted; if the From_Any attribute for Typ needs to be
745 -- generated at this point, its declaration is appended to Decls.
747 procedure Build_From_Any_Function
751 Fnam : out Entity_Id);
752 -- Build From_Any attribute function for Typ. Loc is the reference
753 -- location for generated nodes, Typ is the type for which the
754 -- conversion function is generated. On return, Decl and Fnam contain
755 -- the declaration and entity for the newly-created function.
757 function Build_To_Any_Call
759 Decls : List_Id) return Node_Id;
760 -- Build call to To_Any attribute function with expression as actual
761 -- parameter. Decls is the declarations list for an appropriate
762 -- enclosing scope of the point where the call will be inserted; if
763 -- the To_Any attribute for Typ needs to be generated at this point,
764 -- its declaration is appended to Decls.
766 procedure Build_To_Any_Function
770 Fnam : out Entity_Id);
771 -- Build To_Any attribute function for Typ. Loc is the reference
772 -- location for generated nodes, Typ is the type for which the
773 -- conversion function is generated. On return, Decl and Fnam contain
774 -- the declaration and entity for the newly-created function.
776 function Build_TypeCode_Call
779 Decls : List_Id) return Node_Id;
780 -- Build call to TypeCode attribute function for Typ. Decls is the
781 -- declarations list for an appropriate enclosing scope of the point
782 -- where the call will be inserted; if the To_Any attribute for Typ
783 -- needs to be generated at this point, its declaration is appended
786 procedure Build_TypeCode_Function
790 Fnam : out Entity_Id);
791 -- Build TypeCode attribute function for Typ. Loc is the reference
792 -- location for generated nodes, Typ is the type for which the
793 -- conversion function is generated. On return, Decl and Fnam contain
794 -- the declaration and entity for the newly-created function.
796 procedure Build_Name_And_Repository_Id
798 Name_Str : out String_Id;
799 Repo_Id_Str : out String_Id);
800 -- In the PolyORB distribution model, each distributed object type
801 -- and each distributed operation has a globally unique identifier,
802 -- its Repository Id. This subprogram builds and returns two strings
803 -- for entity E (a distributed object type or operation): one
804 -- containing the name of E, the second containing its repository id.
810 ------------------------------------
811 -- Local variables and structures --
812 ------------------------------------
815 -- Needs comments ???
817 Output_From_Constrained : constant array (Boolean) of Name_Id :=
818 (False => Name_Output,
820 -- The attribute to choose depending on the fact that the parameter
821 -- is constrained or not. There is no such thing as Input_From_Constrained
822 -- since this require separate mechanisms ('Input is a function while
823 -- 'Read is a procedure).
825 ---------------------------------------
826 -- Add_Calling_Stubs_To_Declarations --
827 ---------------------------------------
829 procedure Add_Calling_Stubs_To_Declarations
833 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
834 -- Subprogram id 0 is reserved for calls received from
835 -- remote access-to-subprogram dereferences.
837 Current_Declaration : Node_Id;
838 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
839 RCI_Instantiation : Node_Id;
840 Subp_Stubs : Node_Id;
841 Subp_Str : String_Id;
844 -- The first thing added is an instantiation of the generic package
845 -- System.Partition_Interface.RCI_Locator with the name of this
846 -- remote package. This will act as an interface with the name server
847 -- to determine the Partition_ID and the RPC_Receiver for the
848 -- receiver of this package.
850 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
851 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
853 Append_To (Decls, RCI_Instantiation);
854 Analyze (RCI_Instantiation);
856 -- For each subprogram declaration visible in the spec, we do
857 -- build a body. We also increment a counter to assign a different
858 -- Subprogram_Id to each subprograms. The receiving stubs processing
859 -- do use the same mechanism and will thus assign the same Id and
860 -- do the correct dispatching.
862 Overload_Counter_Table.Reset;
863 PolyORB_Support.Reserve_NamingContext_Methods;
865 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
867 while Present (Current_Declaration) loop
868 if Nkind (Current_Declaration) = N_Subprogram_Declaration
869 and then Comes_From_Source (Current_Declaration)
871 Assign_Subprogram_Identifier (
872 Defining_Unit_Name (Specification (Current_Declaration)),
873 Current_Subprogram_Number,
877 Build_Subprogram_Calling_Stubs (
878 Vis_Decl => Current_Declaration,
880 Build_Subprogram_Id (Loc,
881 Defining_Unit_Name (Specification (Current_Declaration))),
883 Nkind (Specification (Current_Declaration)) =
884 N_Procedure_Specification
886 Is_Asynchronous (Defining_Unit_Name (Specification
887 (Current_Declaration))));
889 Append_To (Decls, Subp_Stubs);
890 Analyze (Subp_Stubs);
892 Current_Subprogram_Number := Current_Subprogram_Number + 1;
895 Next (Current_Declaration);
897 end Add_Calling_Stubs_To_Declarations;
899 -----------------------------
900 -- Add_Parameter_To_NVList --
901 -----------------------------
903 function Add_Parameter_To_NVList
906 Parameter : Entity_Id;
907 Constrained : Boolean;
908 RACW_Ctrl : Boolean := False;
909 Any : Entity_Id) return Node_Id
911 Parameter_Name_String : String_Id;
912 Parameter_Mode : Node_Id;
914 function Parameter_Passing_Mode
916 Parameter : Entity_Id;
917 Constrained : Boolean) return Node_Id;
918 -- Return an expression that denotes the parameter passing
919 -- mode to be used for Parameter in distribution stubs,
920 -- where Constrained is Parameter's constrained status.
922 ----------------------------
923 -- Parameter_Passing_Mode --
924 ----------------------------
926 function Parameter_Passing_Mode
928 Parameter : Entity_Id;
929 Constrained : Boolean) return Node_Id
934 if Out_Present (Parameter) then
935 if In_Present (Parameter)
936 or else not Constrained
938 -- Unconstrained formals must be translated
939 -- to 'in' or 'inout', not 'out', because
940 -- they need to be constrained by the actual.
942 Lib_RE := RE_Mode_Inout;
944 Lib_RE := RE_Mode_Out;
948 Lib_RE := RE_Mode_In;
951 return New_Occurrence_Of (RTE (Lib_RE), Loc);
952 end Parameter_Passing_Mode;
954 -- Start of processing for Add_Parameter_To_NVList
957 if Nkind (Parameter) = N_Defining_Identifier then
958 Get_Name_String (Chars (Parameter));
960 Get_Name_String (Chars (Defining_Identifier
964 Parameter_Name_String := String_From_Name_Buffer;
967 Parameter_Mode := New_Occurrence_Of
968 (RTE (RE_Mode_In), Loc);
970 Parameter_Mode := Parameter_Passing_Mode (Loc,
971 Parameter, Constrained);
975 Make_Procedure_Call_Statement (Loc,
978 (RTE (RE_NVList_Add_Item), Loc),
979 Parameter_Associations => New_List (
980 New_Occurrence_Of (NVList, Loc),
981 Make_Function_Call (Loc,
984 (RTE (RE_To_PolyORB_String), Loc),
985 Parameter_Associations => New_List (
986 Make_String_Literal (Loc,
987 Strval => Parameter_Name_String))),
988 New_Occurrence_Of (Any, Loc),
990 end Add_Parameter_To_NVList;
992 --------------------------------
993 -- Add_RACW_Asynchronous_Flag --
994 --------------------------------
996 procedure Add_RACW_Asynchronous_Flag
997 (Declarations : List_Id;
998 RACW_Type : Entity_Id)
1000 Loc : constant Source_Ptr := Sloc (RACW_Type);
1002 Asynchronous_Flag : constant Entity_Id :=
1003 Make_Defining_Identifier (Loc,
1004 New_External_Name (Chars (RACW_Type), 'A'));
1007 -- Declare the asynchronous flag. This flag will be changed to True
1008 -- whenever it is known that the RACW type is asynchronous.
1010 Append_To (Declarations,
1011 Make_Object_Declaration (Loc,
1012 Defining_Identifier => Asynchronous_Flag,
1013 Constant_Present => True,
1014 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1015 Expression => New_Occurrence_Of (Standard_False, Loc)));
1017 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1018 end Add_RACW_Asynchronous_Flag;
1020 -----------------------
1021 -- Add_RACW_Features --
1022 -----------------------
1024 procedure Add_RACW_Features (RACW_Type : Entity_Id)
1026 Desig : constant Entity_Id :=
1027 Etype (Designated_Type (RACW_Type));
1029 List_Containing (Declaration_Node (RACW_Type));
1031 Same_Scope : constant Boolean :=
1032 Scope (Desig) = Scope (RACW_Type);
1034 Stub_Type : Entity_Id;
1035 Stub_Type_Access : Entity_Id;
1036 RPC_Receiver_Decl : Node_Id;
1040 if not Expander_Active then
1046 -- We are declaring a RACW in the same package than its designated
1047 -- type, so the list to use for late declarations must be the
1048 -- private part of the package. We do know that this private part
1049 -- exists since the designated type has to be a private one.
1051 Decls := Private_Declarations
1052 (Package_Specification_Of_Scope (Current_Scope));
1054 elsif Nkind (Parent (Decls)) = N_Package_Specification
1055 and then Present (Private_Declarations (Parent (Decls)))
1057 Decls := Private_Declarations (Parent (Decls));
1060 -- If we were unable to find the declarations, that means that the
1061 -- completion of the type was missing. We can safely return and let
1062 -- the error be caught by the semantic analysis.
1069 (Designated_Type => Desig,
1070 RACW_Type => RACW_Type,
1072 Stub_Type => Stub_Type,
1073 Stub_Type_Access => Stub_Type_Access,
1074 RPC_Receiver_Decl => RPC_Receiver_Decl,
1075 Existing => Existing);
1077 Add_RACW_Asynchronous_Flag
1078 (Declarations => Decls,
1079 RACW_Type => RACW_Type);
1081 Specific_Add_RACW_Features
1082 (RACW_Type => RACW_Type,
1084 Stub_Type => Stub_Type,
1085 Stub_Type_Access => Stub_Type_Access,
1086 RPC_Receiver_Decl => RPC_Receiver_Decl,
1087 Declarations => Decls);
1089 if not Same_Scope and then not Existing then
1091 -- The RACW has been declared in another scope than the designated
1092 -- type and has not been handled by another RACW in the same package
1093 -- as the first one, so add primitive for the stub type here.
1095 Add_RACW_Primitive_Declarations_And_Bodies
1096 (Designated_Type => Desig,
1097 Insertion_Node => RPC_Receiver_Decl,
1101 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1103 end Add_RACW_Features;
1105 ------------------------------------------------
1106 -- Add_RACW_Primitive_Declarations_And_Bodies --
1107 ------------------------------------------------
1109 procedure Add_RACW_Primitive_Declarations_And_Bodies
1110 (Designated_Type : Entity_Id;
1111 Insertion_Node : Node_Id;
1114 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1115 -- the declarations are recognized as belonging to the current package.
1117 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1119 Stub_Elements : constant Stub_Structure :=
1120 Stubs_Table.Get (Designated_Type);
1122 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1123 Is_RAS : constant Boolean :=
1124 not Comes_From_Source (Stub_Elements.RACW_Type);
1126 Current_Insertion_Node : Node_Id := Insertion_Node;
1128 RPC_Receiver : Entity_Id;
1129 RPC_Receiver_Statements : List_Id;
1130 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1131 RPC_Receiver_Elsif_Parts : List_Id;
1132 RPC_Receiver_Request : Entity_Id;
1133 RPC_Receiver_Subp_Id : Entity_Id;
1134 RPC_Receiver_Subp_Index : Entity_Id;
1136 Subp_Str : String_Id;
1138 Current_Primitive_Elmt : Elmt_Id;
1139 Current_Primitive : Entity_Id;
1140 Current_Primitive_Body : Node_Id;
1141 Current_Primitive_Spec : Node_Id;
1142 Current_Primitive_Decl : Node_Id;
1143 Current_Primitive_Number : Int := 0;
1145 Current_Primitive_Alias : Node_Id;
1147 Current_Receiver : Entity_Id;
1148 Current_Receiver_Body : Node_Id;
1150 RPC_Receiver_Decl : Node_Id;
1152 Possibly_Asynchronous : Boolean;
1155 if not Expander_Active then
1160 RPC_Receiver := Make_Defining_Identifier (Loc,
1161 New_Internal_Name ('P'));
1162 Specific_Build_RPC_Receiver_Body (
1163 RPC_Receiver => RPC_Receiver,
1164 Request => RPC_Receiver_Request,
1165 Subp_Id => RPC_Receiver_Subp_Id,
1166 Subp_Index => RPC_Receiver_Subp_Index,
1167 Stmts => RPC_Receiver_Statements,
1168 Decl => RPC_Receiver_Decl);
1170 if Get_PCS_Name = Name_PolyORB_DSA then
1172 -- For the case of PolyORB, we need to map a textual operation
1173 -- name into a primitive index. Currently we do so using a
1174 -- simple sequence of string comparisons.
1176 RPC_Receiver_Elsif_Parts := New_List;
1177 Append_To (RPC_Receiver_Statements,
1178 Make_Implicit_If_Statement (Designated_Type,
1179 Condition => New_Occurrence_Of (Standard_False, Loc),
1180 Then_Statements => New_List,
1181 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1185 -- Build callers, receivers for every primitive operations and a RPC
1186 -- receiver for this type.
1188 if Present (Primitive_Operations (Designated_Type)) then
1189 Overload_Counter_Table.Reset;
1191 Current_Primitive_Elmt :=
1192 First_Elmt (Primitive_Operations (Designated_Type));
1193 while Current_Primitive_Elmt /= No_Elmt loop
1194 Current_Primitive := Node (Current_Primitive_Elmt);
1196 -- Copy the primitive of all the parents, except predefined
1197 -- ones that are not remotely dispatching.
1199 if Chars (Current_Primitive) /= Name_uSize
1200 and then Chars (Current_Primitive) /= Name_uAlignment
1201 and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize)
1203 -- The first thing to do is build an up-to-date copy of
1204 -- the spec with all the formals referencing Designated_Type
1205 -- transformed into formals referencing Stub_Type. Since this
1206 -- primitive may have been inherited, go back the alias chain
1207 -- until the real primitive has been found.
1209 Current_Primitive_Alias := Current_Primitive;
1210 while Present (Alias (Current_Primitive_Alias)) loop
1212 (Current_Primitive_Alias
1213 /= Alias (Current_Primitive_Alias));
1214 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
1217 Current_Primitive_Spec :=
1218 Copy_Specification (Loc,
1219 Spec => Parent (Current_Primitive_Alias),
1220 Object_Type => Designated_Type,
1221 Stub_Type => Stub_Elements.Stub_Type);
1223 Current_Primitive_Decl :=
1224 Make_Subprogram_Declaration (Loc,
1225 Specification => Current_Primitive_Spec);
1227 Insert_After (Current_Insertion_Node, Current_Primitive_Decl);
1228 Analyze (Current_Primitive_Decl);
1229 Current_Insertion_Node := Current_Primitive_Decl;
1231 Possibly_Asynchronous :=
1232 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1233 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1235 Assign_Subprogram_Identifier (
1236 Defining_Unit_Name (Current_Primitive_Spec),
1237 Current_Primitive_Number,
1240 Current_Primitive_Body :=
1241 Build_Subprogram_Calling_Stubs
1242 (Vis_Decl => Current_Primitive_Decl,
1244 Build_Subprogram_Id (Loc,
1245 Defining_Unit_Name (Current_Primitive_Spec)),
1246 Asynchronous => Possibly_Asynchronous,
1247 Dynamically_Asynchronous => Possibly_Asynchronous,
1248 Stub_Type => Stub_Elements.Stub_Type,
1249 RACW_Type => Stub_Elements.RACW_Type);
1250 Append_To (Decls, Current_Primitive_Body);
1252 -- Analyzing the body here would cause the Stub type to be
1253 -- frozen, thus preventing subsequent primitive declarations.
1254 -- For this reason, it will be analyzed later in the
1257 -- Build the receiver stubs
1260 Current_Receiver_Body :=
1261 Specific_Build_Subprogram_Receiving_Stubs
1262 (Vis_Decl => Current_Primitive_Decl,
1263 Asynchronous => Possibly_Asynchronous,
1264 Dynamically_Asynchronous => Possibly_Asynchronous,
1265 Stub_Type => Stub_Elements.Stub_Type,
1266 RACW_Type => Stub_Elements.RACW_Type,
1267 Parent_Primitive => Current_Primitive);
1269 Current_Receiver := Defining_Unit_Name (
1270 Specification (Current_Receiver_Body));
1272 Append_To (Decls, Current_Receiver_Body);
1274 -- Add a case alternative to the receiver
1276 if Get_PCS_Name = Name_PolyORB_DSA then
1277 Append_To (RPC_Receiver_Elsif_Parts,
1278 Make_Elsif_Part (Loc,
1280 Make_Function_Call (Loc,
1283 RTE (RE_Caseless_String_Eq), Loc),
1284 Parameter_Associations => New_List (
1285 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1286 Make_String_Literal (Loc, Subp_Str))),
1287 Then_Statements => New_List (
1288 Make_Assignment_Statement (Loc,
1289 Name => New_Occurrence_Of (
1290 RPC_Receiver_Subp_Index, Loc),
1292 Make_Integer_Literal (Loc,
1293 Current_Primitive_Number)))));
1296 Append_To (RPC_Receiver_Case_Alternatives,
1297 Make_Case_Statement_Alternative (Loc,
1298 Discrete_Choices => New_List (
1299 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1301 Statements => New_List (
1302 Make_Procedure_Call_Statement (Loc,
1304 New_Occurrence_Of (Current_Receiver, Loc),
1305 Parameter_Associations => New_List (
1306 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1309 -- Increment the index of current primitive
1311 Current_Primitive_Number := Current_Primitive_Number + 1;
1314 Next_Elmt (Current_Primitive_Elmt);
1318 -- Build the case statement and the heart of the subprogram
1321 Append_To (RPC_Receiver_Case_Alternatives,
1322 Make_Case_Statement_Alternative (Loc,
1323 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1324 Statements => New_List (Make_Null_Statement (Loc))));
1326 Append_To (RPC_Receiver_Statements,
1327 Make_Case_Statement (Loc,
1329 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1330 Alternatives => RPC_Receiver_Case_Alternatives));
1332 Append_To (Decls, RPC_Receiver_Decl);
1333 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1334 Decls, RPC_Receiver, Stub_Elements);
1337 -- Do not analyze RPC receiver at this stage since it will otherwise
1338 -- reference subprograms that have not been analyzed yet. It will
1339 -- be analyzed in the regular flow.
1341 end Add_RACW_Primitive_Declarations_And_Bodies;
1343 -----------------------------
1344 -- Add_RAS_Dereference_TSS --
1345 -----------------------------
1347 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1348 Loc : constant Source_Ptr := Sloc (N);
1350 Type_Def : constant Node_Id := Type_Definition (N);
1352 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1353 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1354 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1355 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1357 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
1358 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1360 RACW_Primitive_Name : Node_Id;
1362 Proc : constant Entity_Id :=
1363 Make_Defining_Identifier (Loc,
1364 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1366 Proc_Spec : Node_Id;
1367 Param_Specs : List_Id;
1368 Param_Assoc : constant List_Id := New_List;
1369 Stmts : constant List_Id := New_List;
1371 RAS_Parameter : constant Entity_Id :=
1372 Make_Defining_Identifier (Loc,
1373 Chars => New_Internal_Name ('P'));
1375 Is_Function : constant Boolean :=
1376 Nkind (Type_Def) = N_Access_Function_Definition;
1378 Is_Degenerate : Boolean;
1379 -- Set to True if the subprogram_specification for this RAS has
1380 -- an anonymous access parameter (see Process_Remote_AST_Declaration).
1382 Spec : constant Node_Id := Type_Def;
1384 Current_Parameter : Node_Id;
1386 -- Start of processing for Add_RAS_Dereference_TSS
1389 -- The Dereference TSS for a remote access-to-subprogram type
1392 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1395 -- This is called whenever a value of a RAS type is dereferenced
1397 -- First construct a list of parameter specifications:
1399 -- The first formal is the RAS values
1401 Param_Specs := New_List (
1402 Make_Parameter_Specification (Loc,
1403 Defining_Identifier => RAS_Parameter,
1406 New_Occurrence_Of (Fat_Type, Loc)));
1408 -- The following formals are copied from the type declaration
1410 Is_Degenerate := False;
1411 Current_Parameter := First (Parameter_Specifications (Type_Def));
1412 Parameters : while Present (Current_Parameter) loop
1413 if Nkind (Parameter_Type (Current_Parameter))
1414 = N_Access_Definition
1416 Is_Degenerate := True;
1418 Append_To (Param_Specs,
1419 Make_Parameter_Specification (Loc,
1420 Defining_Identifier =>
1421 Make_Defining_Identifier (Loc,
1422 Chars => Chars (Defining_Identifier (Current_Parameter))),
1423 In_Present => In_Present (Current_Parameter),
1424 Out_Present => Out_Present (Current_Parameter),
1426 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1428 New_Copy_Tree (Expression (Current_Parameter))));
1430 Append_To (Param_Assoc,
1431 Make_Identifier (Loc,
1432 Chars => Chars (Defining_Identifier (Current_Parameter))));
1434 Next (Current_Parameter);
1435 end loop Parameters;
1437 if Is_Degenerate then
1438 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1440 -- Generate a dummy body. This code will never actually be executed,
1441 -- because null is the only legal value for a degenerate RAS type.
1442 -- For legality's sake (in order to avoid generating a function
1443 -- that does not contain a return statement), we include a dummy
1444 -- recursive call on the TSS itself.
1447 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1448 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1451 -- For a normal RAS type, we cast the RAS formal to the corresponding
1452 -- tagged type, and perform a dispatching call to its Call
1453 -- primitive operation.
1455 Prepend_To (Param_Assoc,
1456 Unchecked_Convert_To (RACW_Type,
1457 New_Occurrence_Of (RAS_Parameter, Loc)));
1459 RACW_Primitive_Name := Make_Selected_Component (Loc,
1460 Prefix => Scope (RACW_Type),
1461 Selector_Name => Name_Call);
1466 Make_Return_Statement (Loc,
1468 Make_Function_Call (Loc,
1470 RACW_Primitive_Name,
1471 Parameter_Associations => Param_Assoc)));
1475 Make_Procedure_Call_Statement (Loc,
1477 RACW_Primitive_Name,
1478 Parameter_Associations => Param_Assoc));
1481 -- Build the complete subprogram
1485 Make_Function_Specification (Loc,
1486 Defining_Unit_Name => Proc,
1487 Parameter_Specifications => Param_Specs,
1490 Entity (Subtype_Mark (Spec)), Loc));
1492 Set_Ekind (Proc, E_Function);
1494 New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
1498 Make_Procedure_Specification (Loc,
1499 Defining_Unit_Name => Proc,
1500 Parameter_Specifications => Param_Specs);
1502 Set_Ekind (Proc, E_Procedure);
1503 Set_Etype (Proc, Standard_Void_Type);
1507 Make_Subprogram_Body (Loc,
1508 Specification => Proc_Spec,
1509 Declarations => New_List,
1510 Handled_Statement_Sequence =>
1511 Make_Handled_Sequence_Of_Statements (Loc,
1512 Statements => Stmts)));
1514 Set_TSS (Fat_Type, Proc);
1515 end Add_RAS_Dereference_TSS;
1517 -------------------------------
1518 -- Add_RAS_Proxy_And_Analyze --
1519 -------------------------------
1521 procedure Add_RAS_Proxy_And_Analyze
1524 All_Calls_Remote_E : Entity_Id;
1525 Proxy_Object_Addr : out Entity_Id)
1527 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1529 Subp_Name : constant Entity_Id :=
1530 Defining_Unit_Name (Specification (Vis_Decl));
1532 Pkg_Name : constant Entity_Id :=
1533 Make_Defining_Identifier (Loc,
1535 New_External_Name (Chars (Subp_Name), 'P', -1));
1537 Proxy_Type : constant Entity_Id :=
1538 Make_Defining_Identifier (Loc,
1541 Related_Id => Chars (Subp_Name),
1544 Proxy_Type_Full_View : constant Entity_Id :=
1545 Make_Defining_Identifier (Loc,
1546 Chars (Proxy_Type));
1548 Subp_Decl_Spec : constant Node_Id :=
1549 Build_RAS_Primitive_Specification
1550 (Subp_Spec => Specification (Vis_Decl),
1551 Remote_Object_Type => Proxy_Type);
1553 Subp_Body_Spec : constant Node_Id :=
1554 Build_RAS_Primitive_Specification
1555 (Subp_Spec => Specification (Vis_Decl),
1556 Remote_Object_Type => Proxy_Type);
1558 Vis_Decls : constant List_Id := New_List;
1559 Pvt_Decls : constant List_Id := New_List;
1560 Actuals : constant List_Id := New_List;
1562 Perform_Call : Node_Id;
1565 -- type subpP is tagged limited private;
1567 Append_To (Vis_Decls,
1568 Make_Private_Type_Declaration (Loc,
1569 Defining_Identifier => Proxy_Type,
1570 Tagged_Present => True,
1571 Limited_Present => True));
1573 -- [subprogram] Call
1574 -- (Self : access subpP;
1575 -- ...other-formals...)
1578 Append_To (Vis_Decls,
1579 Make_Subprogram_Declaration (Loc,
1580 Specification => Subp_Decl_Spec));
1582 -- A : constant System.Address;
1584 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1586 Append_To (Vis_Decls,
1587 Make_Object_Declaration (Loc,
1588 Defining_Identifier =>
1592 Object_Definition =>
1593 New_Occurrence_Of (RTE (RE_Address), Loc)));
1597 -- type subpP is tagged limited record
1598 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1602 Append_To (Pvt_Decls,
1603 Make_Full_Type_Declaration (Loc,
1604 Defining_Identifier =>
1605 Proxy_Type_Full_View,
1607 Build_Remote_Subprogram_Proxy_Type (Loc,
1608 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1610 -- Trick semantic analysis into swapping the public and
1611 -- full view when freezing the public view.
1613 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1616 -- (Self : access O;
1617 -- ...other-formals...) is
1619 -- P (...other-formals...);
1623 -- (Self : access O;
1624 -- ...other-formals...)
1627 -- return F (...other-formals...);
1630 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1632 Make_Procedure_Call_Statement (Loc,
1634 New_Occurrence_Of (Subp_Name, Loc),
1635 Parameter_Associations =>
1639 Make_Return_Statement (Loc,
1641 Make_Function_Call (Loc,
1643 New_Occurrence_Of (Subp_Name, Loc),
1644 Parameter_Associations =>
1648 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1649 pragma Assert (Present (Formal));
1652 exit when No (Formal);
1654 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1657 -- O : aliased subpP;
1659 Append_To (Pvt_Decls,
1660 Make_Object_Declaration (Loc,
1661 Defining_Identifier =>
1662 Make_Defining_Identifier (Loc,
1666 Object_Definition =>
1667 New_Occurrence_Of (Proxy_Type, Loc)));
1669 -- A : constant System.Address := O'Address;
1671 Append_To (Pvt_Decls,
1672 Make_Object_Declaration (Loc,
1673 Defining_Identifier =>
1674 Make_Defining_Identifier (Loc,
1675 Chars (Proxy_Object_Addr)),
1678 Object_Definition =>
1679 New_Occurrence_Of (RTE (RE_Address), Loc),
1681 Make_Attribute_Reference (Loc,
1682 Prefix => New_Occurrence_Of (
1683 Defining_Identifier (Last (Pvt_Decls)), Loc),
1688 Make_Package_Declaration (Loc,
1689 Specification => Make_Package_Specification (Loc,
1690 Defining_Unit_Name => Pkg_Name,
1691 Visible_Declarations => Vis_Decls,
1692 Private_Declarations => Pvt_Decls,
1693 End_Label => Empty)));
1694 Analyze (Last (Decls));
1697 Make_Package_Body (Loc,
1698 Defining_Unit_Name =>
1699 Make_Defining_Identifier (Loc,
1701 Declarations => New_List (
1702 Make_Subprogram_Body (Loc,
1705 Declarations => New_List,
1706 Handled_Statement_Sequence =>
1707 Make_Handled_Sequence_Of_Statements (Loc,
1708 Statements => New_List (Perform_Call))))));
1709 Analyze (Last (Decls));
1710 end Add_RAS_Proxy_And_Analyze;
1712 -----------------------
1713 -- Add_RAST_Features --
1714 -----------------------
1716 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1717 RAS_Type : constant Entity_Id :=
1718 Equivalent_Type (Defining_Identifier (Vis_Decl));
1720 Spec : constant Node_Id :=
1721 Specification (Unit (Enclosing_Lib_Unit_Node (Vis_Decl)));
1722 Decls : List_Id := Private_Declarations (Spec);
1725 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1728 Decls := Visible_Declarations (Spec);
1731 Add_RAS_Dereference_TSS (Vis_Decl);
1732 Specific_Add_RAST_Features (Vis_Decl, RAS_Type, Decls);
1733 end Add_RAST_Features;
1739 procedure Add_Stub_Type
1740 (Designated_Type : Entity_Id;
1741 RACW_Type : Entity_Id;
1743 Stub_Type : out Entity_Id;
1744 Stub_Type_Access : out Entity_Id;
1745 RPC_Receiver_Decl : out Node_Id;
1746 Existing : out Boolean)
1748 Loc : constant Source_Ptr := Sloc (RACW_Type);
1750 Stub_Elements : constant Stub_Structure :=
1751 Stubs_Table.Get (Designated_Type);
1752 Stub_Type_Decl : Node_Id;
1753 Stub_Type_Access_Decl : Node_Id;
1756 if Stub_Elements /= Empty_Stub_Structure then
1757 Stub_Type := Stub_Elements.Stub_Type;
1758 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1759 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1766 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1768 Make_Defining_Identifier (Loc,
1770 Related_Id => Chars (Stub_Type),
1773 Specific_Build_Stub_Type (
1774 RACW_Type, Stub_Type,
1775 Stub_Type_Decl, RPC_Receiver_Decl);
1777 Stub_Type_Access_Decl :=
1778 Make_Full_Type_Declaration (Loc,
1779 Defining_Identifier => Stub_Type_Access,
1781 Make_Access_To_Object_Definition (Loc,
1782 All_Present => True,
1783 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1785 Append_To (Decls, Stub_Type_Decl);
1786 Analyze (Last (Decls));
1787 Append_To (Decls, Stub_Type_Access_Decl);
1788 Analyze (Last (Decls));
1790 -- This is in no way a type derivation, but we fake it to make
1791 -- sure that the dispatching table gets built with the corresponding
1792 -- primitive operations at the right place.
1794 Derive_Subprograms (Parent_Type => Designated_Type,
1795 Derived_Type => Stub_Type);
1797 if Present (RPC_Receiver_Decl) then
1798 Append_To (Decls, RPC_Receiver_Decl);
1800 RPC_Receiver_Decl := Last (Decls);
1803 Stubs_Table.Set (Designated_Type,
1804 (Stub_Type => Stub_Type,
1805 Stub_Type_Access => Stub_Type_Access,
1806 RPC_Receiver_Decl => RPC_Receiver_Decl,
1807 RACW_Type => RACW_Type));
1810 ----------------------------------
1811 -- Assign_Subprogram_Identifier --
1812 ----------------------------------
1814 procedure Assign_Subprogram_Identifier
1819 N : constant Name_Id := Chars (Def);
1821 Overload_Order : constant Int :=
1822 Overload_Counter_Table.Get (N) + 1;
1825 Overload_Counter_Table.Set (N, Overload_Order);
1827 Get_Name_String (N);
1829 -- Homonym handling: as in Exp_Dbug, but much simpler,
1830 -- because the only entities for which we have to generate
1831 -- names here need only to be disambiguated within their
1834 if Overload_Order > 1 then
1835 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
1836 Name_Len := Name_Len + 2;
1837 Add_Nat_To_Name_Buffer (Overload_Order);
1840 Id := String_From_Name_Buffer;
1841 Subprogram_Identifier_Table.Set (Def,
1842 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
1843 end Assign_Subprogram_Identifier;
1845 ------------------------------
1846 -- Build_Get_Unique_RP_Call --
1847 ------------------------------
1849 function Build_Get_Unique_RP_Call
1851 Pointer : Entity_Id;
1852 Stub_Type : Entity_Id) return List_Id
1856 Make_Procedure_Call_Statement (Loc,
1858 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
1859 Parameter_Associations => New_List (
1860 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
1861 New_Occurrence_Of (Pointer, Loc)))),
1863 Make_Assignment_Statement (Loc,
1865 Make_Selected_Component (Loc,
1867 New_Occurrence_Of (Pointer, Loc),
1869 New_Occurrence_Of (First_Tag_Component
1870 (Designated_Type (Etype (Pointer))), Loc)),
1872 Make_Attribute_Reference (Loc,
1874 New_Occurrence_Of (Stub_Type, Loc),
1878 -- Note: The assignment to Pointer._Tag is safe here because
1879 -- we carefully ensured that Stub_Type has exactly the same layout
1880 -- as System.Partition_Interface.RACW_Stub_Type.
1882 end Build_Get_Unique_RP_Call;
1884 -----------------------------------
1885 -- Build_Ordered_Parameters_List --
1886 -----------------------------------
1888 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
1889 Constrained_List : List_Id;
1890 Unconstrained_List : List_Id;
1891 Current_Parameter : Node_Id;
1893 First_Parameter : Node_Id;
1894 For_RAS : Boolean := False;
1897 if not Present (Parameter_Specifications (Spec)) then
1901 Constrained_List := New_List;
1902 Unconstrained_List := New_List;
1903 First_Parameter := First (Parameter_Specifications (Spec));
1905 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
1906 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
1911 -- Loop through the parameters and add them to the right list
1913 Current_Parameter := First_Parameter;
1914 while Present (Current_Parameter) loop
1915 if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
1917 Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
1919 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
1920 and then not (For_RAS and then Current_Parameter = First_Parameter)
1922 Append_To (Constrained_List, New_Copy (Current_Parameter));
1924 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
1927 Next (Current_Parameter);
1930 -- Unconstrained parameters are returned first
1932 Append_List_To (Unconstrained_List, Constrained_List);
1934 return Unconstrained_List;
1935 end Build_Ordered_Parameters_List;
1937 ----------------------------------
1938 -- Build_Passive_Partition_Stub --
1939 ----------------------------------
1941 procedure Build_Passive_Partition_Stub (U : Node_Id) is
1943 Pkg_Name : String_Id;
1946 Loc : constant Source_Ptr := Sloc (U);
1949 -- Verify that the implementation supports distribution, by accessing
1950 -- a type defined in the proper version of system.rpc
1953 Dist_OK : Entity_Id;
1954 pragma Warnings (Off, Dist_OK);
1956 Dist_OK := RTE (RE_Params_Stream_Type);
1959 -- Use body if present, spec otherwise
1961 if Nkind (U) = N_Package_Declaration then
1962 Pkg_Spec := Specification (U);
1963 L := Visible_Declarations (Pkg_Spec);
1965 Pkg_Spec := Parent (Corresponding_Spec (U));
1966 L := Declarations (U);
1969 Get_Library_Unit_Name_String (Pkg_Spec);
1970 Pkg_Name := String_From_Name_Buffer;
1972 Make_Procedure_Call_Statement (Loc,
1974 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
1975 Parameter_Associations => New_List (
1976 Make_String_Literal (Loc, Pkg_Name),
1977 Make_Attribute_Reference (Loc,
1979 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
1984 end Build_Passive_Partition_Stub;
1986 --------------------------------------
1987 -- Build_RPC_Receiver_Specification --
1988 --------------------------------------
1990 function Build_RPC_Receiver_Specification
1991 (RPC_Receiver : Entity_Id;
1992 Request_Parameter : Entity_Id) return Node_Id
1994 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
1997 Make_Procedure_Specification (Loc,
1998 Defining_Unit_Name => RPC_Receiver,
1999 Parameter_Specifications => New_List (
2000 Make_Parameter_Specification (Loc,
2001 Defining_Identifier => Request_Parameter,
2003 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2004 end Build_RPC_Receiver_Specification;
2006 ----------------------------------------
2007 -- Build_Remote_Subprogram_Proxy_Type --
2008 ----------------------------------------
2010 function Build_Remote_Subprogram_Proxy_Type
2012 ACR_Expression : Node_Id) return Node_Id
2016 Make_Record_Definition (Loc,
2017 Tagged_Present => True,
2018 Limited_Present => True,
2020 Make_Component_List (Loc,
2022 Component_Items => New_List (
2023 Make_Component_Declaration (Loc,
2024 Defining_Identifier =>
2025 Make_Defining_Identifier (Loc,
2026 Name_All_Calls_Remote),
2027 Component_Definition =>
2028 Make_Component_Definition (Loc,
2029 Subtype_Indication =>
2030 New_Occurrence_Of (Standard_Boolean, Loc)),
2034 Make_Component_Declaration (Loc,
2035 Defining_Identifier =>
2036 Make_Defining_Identifier (Loc,
2038 Component_Definition =>
2039 Make_Component_Definition (Loc,
2040 Subtype_Indication =>
2041 New_Occurrence_Of (RTE (RE_Address), Loc)),
2043 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2045 Make_Component_Declaration (Loc,
2046 Defining_Identifier =>
2047 Make_Defining_Identifier (Loc,
2049 Component_Definition =>
2050 Make_Component_Definition (Loc,
2051 Subtype_Indication =>
2052 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2053 end Build_Remote_Subprogram_Proxy_Type;
2055 ------------------------------------
2056 -- Build_Subprogram_Calling_Stubs --
2057 ------------------------------------
2059 function Build_Subprogram_Calling_Stubs
2060 (Vis_Decl : Node_Id;
2062 Asynchronous : Boolean;
2063 Dynamically_Asynchronous : Boolean := False;
2064 Stub_Type : Entity_Id := Empty;
2065 RACW_Type : Entity_Id := Empty;
2066 Locator : Entity_Id := Empty;
2067 New_Name : Name_Id := No_Name) return Node_Id
2069 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2071 Decls : constant List_Id := New_List;
2072 Statements : constant List_Id := New_List;
2074 Subp_Spec : Node_Id;
2075 -- The specification of the body
2077 Controlling_Parameter : Entity_Id := Empty;
2079 Asynchronous_Expr : Node_Id := Empty;
2081 RCI_Locator : Entity_Id;
2083 Spec_To_Use : Node_Id;
2085 procedure Insert_Partition_Check (Parameter : Node_Id);
2086 -- Check that the parameter has been elaborated on the same partition
2087 -- than the controlling parameter (E.4(19)).
2089 ----------------------------
2090 -- Insert_Partition_Check --
2091 ----------------------------
2093 procedure Insert_Partition_Check (Parameter : Node_Id) is
2094 Parameter_Entity : constant Entity_Id :=
2095 Defining_Identifier (Parameter);
2097 -- The expression that will be built is of the form:
2099 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2100 -- raise Constraint_Error;
2103 -- We do not check that Parameter is in Stub_Type since such a check
2104 -- has been inserted at the point of call already (a tag check since
2105 -- we have multiple controlling operands).
2108 Make_Raise_Constraint_Error (Loc,
2112 Make_Function_Call (Loc,
2114 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2115 Parameter_Associations =>
2117 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2118 New_Occurrence_Of (Parameter_Entity, Loc)),
2119 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2120 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2121 Reason => CE_Partition_Check_Failed));
2122 end Insert_Partition_Check;
2124 -- Start of processing for Build_Subprogram_Calling_Stubs
2127 Subp_Spec := Copy_Specification (Loc,
2128 Spec => Specification (Vis_Decl),
2129 New_Name => New_Name);
2131 if Locator = Empty then
2132 RCI_Locator := RCI_Cache;
2133 Spec_To_Use := Specification (Vis_Decl);
2135 RCI_Locator := Locator;
2136 Spec_To_Use := Subp_Spec;
2139 -- Find a controlling argument if we have a stub type. Also check
2140 -- if this subprogram can be made asynchronous.
2142 if Present (Stub_Type)
2143 and then Present (Parameter_Specifications (Spec_To_Use))
2146 Current_Parameter : Node_Id :=
2147 First (Parameter_Specifications
2150 while Present (Current_Parameter) loop
2152 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2154 if Controlling_Parameter = Empty then
2155 Controlling_Parameter :=
2156 Defining_Identifier (Current_Parameter);
2158 Insert_Partition_Check (Current_Parameter);
2162 Next (Current_Parameter);
2167 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2169 if Dynamically_Asynchronous then
2170 Asynchronous_Expr := Make_Selected_Component (Loc,
2171 Prefix => Controlling_Parameter,
2172 Selector_Name => Name_Asynchronous);
2175 Specific_Build_General_Calling_Stubs
2177 Statements => Statements,
2178 Target => Specific_Build_Stub_Target (Loc,
2179 Decls, RCI_Locator, Controlling_Parameter),
2180 Subprogram_Id => Subp_Id,
2181 Asynchronous => Asynchronous_Expr,
2182 Is_Known_Asynchronous => Asynchronous
2183 and then not Dynamically_Asynchronous,
2184 Is_Known_Non_Asynchronous
2186 and then not Dynamically_Asynchronous,
2187 Is_Function => Nkind (Spec_To_Use) =
2188 N_Function_Specification,
2189 Spec => Spec_To_Use,
2190 Stub_Type => Stub_Type,
2191 RACW_Type => RACW_Type,
2194 RCI_Calling_Stubs_Table.Set
2195 (Defining_Unit_Name (Specification (Vis_Decl)),
2196 Defining_Unit_Name (Spec_To_Use));
2199 Make_Subprogram_Body (Loc,
2200 Specification => Subp_Spec,
2201 Declarations => Decls,
2202 Handled_Statement_Sequence =>
2203 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2204 end Build_Subprogram_Calling_Stubs;
2206 -------------------------
2207 -- Build_Subprogram_Id --
2208 -------------------------
2210 function Build_Subprogram_Id
2212 E : Entity_Id) return Node_Id
2215 case Get_PCS_Name is
2216 when Name_PolyORB_DSA =>
2217 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2219 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2221 end Build_Subprogram_Id;
2223 ------------------------
2224 -- Copy_Specification --
2225 ------------------------
2227 function Copy_Specification
2230 Object_Type : Entity_Id := Empty;
2231 Stub_Type : Entity_Id := Empty;
2232 New_Name : Name_Id := No_Name) return Node_Id
2234 Parameters : List_Id := No_List;
2236 Current_Parameter : Node_Id;
2237 Current_Identifier : Entity_Id;
2238 Current_Type : Node_Id;
2239 Current_Etype : Entity_Id;
2241 Name_For_New_Spec : Name_Id;
2243 New_Identifier : Entity_Id;
2245 -- Comments needed in body below ???
2248 if New_Name = No_Name then
2249 pragma Assert (Nkind (Spec) = N_Function_Specification
2250 or else Nkind (Spec) = N_Procedure_Specification);
2252 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2254 Name_For_New_Spec := New_Name;
2257 if Present (Parameter_Specifications (Spec)) then
2258 Parameters := New_List;
2259 Current_Parameter := First (Parameter_Specifications (Spec));
2260 while Present (Current_Parameter) loop
2261 Current_Identifier := Defining_Identifier (Current_Parameter);
2262 Current_Type := Parameter_Type (Current_Parameter);
2264 if Nkind (Current_Type) = N_Access_Definition then
2265 Current_Etype := Entity (Subtype_Mark (Current_Type));
2267 if Present (Object_Type) then
2269 Root_Type (Current_Etype) = Root_Type (Object_Type));
2271 Make_Access_Definition (Loc,
2272 Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
2275 Make_Access_Definition (Loc,
2277 New_Occurrence_Of (Current_Etype, Loc));
2281 Current_Etype := Entity (Current_Type);
2283 if Present (Object_Type)
2284 and then Current_Etype = Object_Type
2286 Current_Type := New_Occurrence_Of (Stub_Type, Loc);
2288 Current_Type := New_Occurrence_Of (Current_Etype, Loc);
2292 New_Identifier := Make_Defining_Identifier (Loc,
2293 Chars (Current_Identifier));
2295 Append_To (Parameters,
2296 Make_Parameter_Specification (Loc,
2297 Defining_Identifier => New_Identifier,
2298 Parameter_Type => Current_Type,
2299 In_Present => In_Present (Current_Parameter),
2300 Out_Present => Out_Present (Current_Parameter),
2302 New_Copy_Tree (Expression (Current_Parameter))));
2304 -- For a regular formal parameter (that needs to be marshalled
2305 -- in the context of remote calls), set the Etype now, because
2306 -- marshalling processing might need it.
2308 if Is_Entity_Name (Current_Type) then
2309 Set_Etype (New_Identifier, Entity (Current_Type));
2311 -- Current_Type is an access definition, special processing
2312 -- (not requiring etype) will occur for marshalling.
2318 Next (Current_Parameter);
2322 case Nkind (Spec) is
2324 when N_Function_Specification | N_Access_Function_Definition =>
2326 Make_Function_Specification (Loc,
2327 Defining_Unit_Name =>
2328 Make_Defining_Identifier (Loc,
2329 Chars => Name_For_New_Spec),
2330 Parameter_Specifications => Parameters,
2332 New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
2334 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2336 Make_Procedure_Specification (Loc,
2337 Defining_Unit_Name =>
2338 Make_Defining_Identifier (Loc,
2339 Chars => Name_For_New_Spec),
2340 Parameter_Specifications => Parameters);
2343 raise Program_Error;
2345 end Copy_Specification;
2347 ---------------------------
2348 -- Could_Be_Asynchronous --
2349 ---------------------------
2351 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2352 Current_Parameter : Node_Id;
2355 if Present (Parameter_Specifications (Spec)) then
2356 Current_Parameter := First (Parameter_Specifications (Spec));
2357 while Present (Current_Parameter) loop
2358 if Out_Present (Current_Parameter) then
2362 Next (Current_Parameter);
2367 end Could_Be_Asynchronous;
2369 ---------------------------
2370 -- Declare_Create_NVList --
2371 ---------------------------
2373 procedure Declare_Create_NVList
2381 Make_Object_Declaration (Loc,
2382 Defining_Identifier => NVList,
2383 Aliased_Present => False,
2384 Object_Definition =>
2385 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2388 Make_Procedure_Call_Statement (Loc,
2390 New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2391 Parameter_Associations => New_List (
2392 New_Occurrence_Of (NVList, Loc))));
2393 end Declare_Create_NVList;
2395 ---------------------------------------------
2396 -- Expand_All_Calls_Remote_Subprogram_Call --
2397 ---------------------------------------------
2399 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2400 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2401 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2402 Loc : constant Source_Ptr := Sloc (N);
2403 RCI_Locator : Node_Id;
2404 RCI_Cache : Entity_Id;
2405 Calling_Stubs : Node_Id;
2406 E_Calling_Stubs : Entity_Id;
2409 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2411 if E_Calling_Stubs = Empty then
2412 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2414 if RCI_Cache = Empty then
2417 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2418 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2420 -- The RCI_Locator package is inserted at the top level in the
2421 -- current unit, and must appear in the proper scope, so that it
2422 -- is not prematurely removed by the GCC back-end.
2425 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2428 if Ekind (Scop) = E_Package_Body then
2429 New_Scope (Spec_Entity (Scop));
2431 elsif Ekind (Scop) = E_Subprogram_Body then
2433 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2439 Analyze (RCI_Locator);
2443 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2446 RCI_Locator := Parent (RCI_Cache);
2449 Calling_Stubs := Build_Subprogram_Calling_Stubs
2450 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2452 Build_Subprogram_Id (Loc, Called_Subprogram),
2453 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2455 Is_Asynchronous (Called_Subprogram),
2456 Locator => RCI_Cache,
2457 New_Name => New_Internal_Name ('S'));
2458 Insert_After (RCI_Locator, Calling_Stubs);
2459 Analyze (Calling_Stubs);
2460 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2463 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2464 end Expand_All_Calls_Remote_Subprogram_Call;
2466 ---------------------------------
2467 -- Expand_Calling_Stubs_Bodies --
2468 ---------------------------------
2470 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2471 Spec : constant Node_Id := Specification (Unit_Node);
2472 Decls : constant List_Id := Visible_Declarations (Spec);
2474 New_Scope (Scope_Of_Spec (Spec));
2475 Add_Calling_Stubs_To_Declarations
2476 (Specification (Unit_Node), Decls);
2478 end Expand_Calling_Stubs_Bodies;
2480 -----------------------------------
2481 -- Expand_Receiving_Stubs_Bodies --
2482 -----------------------------------
2484 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2490 if Nkind (Unit_Node) = N_Package_Declaration then
2491 Spec := Specification (Unit_Node);
2492 Decls := Private_Declarations (Spec);
2495 Decls := Visible_Declarations (Spec);
2498 New_Scope (Scope_Of_Spec (Spec));
2499 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls);
2503 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2504 Decls := Declarations (Unit_Node);
2505 New_Scope (Scope_Of_Spec (Unit_Node));
2507 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp);
2508 Insert_List_Before (First (Decls), Temp);
2512 end Expand_Receiving_Stubs_Bodies;
2514 --------------------
2515 -- GARLIC_Support --
2516 --------------------
2518 package body GARLIC_Support is
2520 -- Local subprograms
2522 procedure Add_RACW_Read_Attribute
2523 (RACW_Type : Entity_Id;
2524 Stub_Type : Entity_Id;
2525 Stub_Type_Access : Entity_Id;
2526 Declarations : List_Id);
2527 -- Add Read attribute in Decls for the RACW type. The Read attribute
2528 -- is added right after the RACW_Type declaration while the body is
2529 -- inserted after Declarations.
2531 procedure Add_RACW_Write_Attribute
2532 (RACW_Type : Entity_Id;
2533 Stub_Type : Entity_Id;
2534 Stub_Type_Access : Entity_Id;
2535 RPC_Receiver : Node_Id;
2536 Declarations : List_Id);
2537 -- Same thing for the Write attribute
2539 function Stream_Parameter return Node_Id;
2540 function Result return Node_Id;
2541 function Object return Node_Id renames Result;
2542 -- Functions to create occurrences of the formal parameter names of
2543 -- the 'Read and 'Write attributes.
2546 -- Shared source location used by Add_{Read,Write}_Read_Attribute
2547 -- and their ancillary subroutines (set on entry by Add_RACW_Features).
2549 procedure Add_RAS_Access_TSS (N : Node_Id);
2550 -- Add a subprogram body for RAS Access TSS
2552 -------------------------------------
2553 -- Add_Obj_RPC_Receiver_Completion --
2554 -------------------------------------
2556 procedure Add_Obj_RPC_Receiver_Completion
2559 RPC_Receiver : Entity_Id;
2560 Stub_Elements : Stub_Structure) is
2562 -- The RPC receiver body should not be the completion of the
2563 -- declaration recorded in the stub structure, because then the
2564 -- occurrences of the formal parameters within the body should
2565 -- refer to the entities from the declaration, not from the
2566 -- completion, to which we do not have easy access. Instead, the
2567 -- RPC receiver body acts as its own declaration, and the RPC
2568 -- receiver declaration is completed by a renaming-as-body.
2571 Make_Subprogram_Renaming_Declaration (Loc,
2573 Copy_Specification (Loc,
2574 Specification (Stub_Elements.RPC_Receiver_Decl)),
2575 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2576 end Add_Obj_RPC_Receiver_Completion;
2578 -----------------------
2579 -- Add_RACW_Features --
2580 -----------------------
2582 procedure Add_RACW_Features
2583 (RACW_Type : Entity_Id;
2584 Stub_Type : Entity_Id;
2585 Stub_Type_Access : Entity_Id;
2586 RPC_Receiver_Decl : Node_Id;
2587 Declarations : List_Id)
2589 RPC_Receiver : Node_Id;
2590 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2593 Loc := Sloc (RACW_Type);
2597 -- For a RAS, the RPC receiver is that of the RCI unit,
2598 -- not that of the corresponding distributed object type.
2599 -- We retrieve its address from the local proxy object.
2601 RPC_Receiver := Make_Selected_Component (Loc,
2603 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2604 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2607 RPC_Receiver := Make_Attribute_Reference (Loc,
2608 Prefix => New_Occurrence_Of (
2609 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2610 Attribute_Name => Name_Address);
2613 Add_RACW_Write_Attribute (
2620 Add_RACW_Read_Attribute (
2625 end Add_RACW_Features;
2627 -----------------------------
2628 -- Add_RACW_Read_Attribute --
2629 -----------------------------
2631 procedure Add_RACW_Read_Attribute
2632 (RACW_Type : Entity_Id;
2633 Stub_Type : Entity_Id;
2634 Stub_Type_Access : Entity_Id;
2635 Declarations : List_Id)
2637 Proc_Decl : Node_Id;
2638 Attr_Decl : Node_Id;
2640 Body_Node : Node_Id;
2643 Statements : List_Id;
2644 Local_Statements : List_Id;
2645 Remote_Statements : List_Id;
2646 -- Various parts of the procedure
2648 Procedure_Name : constant Name_Id :=
2649 New_Internal_Name ('R');
2650 Source_Partition : constant Entity_Id :=
2651 Make_Defining_Identifier
2652 (Loc, New_Internal_Name ('P'));
2653 Source_Receiver : constant Entity_Id :=
2654 Make_Defining_Identifier
2655 (Loc, New_Internal_Name ('S'));
2656 Source_Address : constant Entity_Id :=
2657 Make_Defining_Identifier
2658 (Loc, New_Internal_Name ('P'));
2659 Local_Stub : constant Entity_Id :=
2660 Make_Defining_Identifier
2661 (Loc, New_Internal_Name ('L'));
2662 Stubbed_Result : constant Entity_Id :=
2663 Make_Defining_Identifier
2664 (Loc, New_Internal_Name ('S'));
2665 Asynchronous_Flag : constant Entity_Id :=
2666 Asynchronous_Flags_Table.Get (RACW_Type);
2667 pragma Assert (Present (Asynchronous_Flag));
2669 -- Start of processing for Add_RACW_Read_Attribute
2672 -- Generate object declarations
2675 Make_Object_Declaration (Loc,
2676 Defining_Identifier => Source_Partition,
2677 Object_Definition =>
2678 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
2680 Make_Object_Declaration (Loc,
2681 Defining_Identifier => Source_Receiver,
2682 Object_Definition =>
2683 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2685 Make_Object_Declaration (Loc,
2686 Defining_Identifier => Source_Address,
2687 Object_Definition =>
2688 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2690 Make_Object_Declaration (Loc,
2691 Defining_Identifier => Local_Stub,
2692 Aliased_Present => True,
2693 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
2695 Make_Object_Declaration (Loc,
2696 Defining_Identifier => Stubbed_Result,
2697 Object_Definition =>
2698 New_Occurrence_Of (Stub_Type_Access, Loc),
2700 Make_Attribute_Reference (Loc,
2702 New_Occurrence_Of (Local_Stub, Loc),
2704 Name_Unchecked_Access)));
2706 -- Read the source Partition_ID and RPC_Receiver from incoming stream
2708 Statements := New_List (
2709 Make_Attribute_Reference (Loc,
2711 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
2712 Attribute_Name => Name_Read,
2713 Expressions => New_List (
2715 New_Occurrence_Of (Source_Partition, Loc))),
2717 Make_Attribute_Reference (Loc,
2719 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2722 Expressions => New_List (
2724 New_Occurrence_Of (Source_Receiver, Loc))),
2726 Make_Attribute_Reference (Loc,
2728 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2731 Expressions => New_List (
2733 New_Occurrence_Of (Source_Address, Loc))));
2735 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
2737 Set_Etype (Stubbed_Result, Stub_Type_Access);
2739 -- If the Address is Null_Address, then return a null object
2741 Append_To (Statements,
2742 Make_Implicit_If_Statement (RACW_Type,
2745 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
2746 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
2747 Then_Statements => New_List (
2748 Make_Assignment_Statement (Loc,
2750 Expression => Make_Null (Loc)),
2751 Make_Return_Statement (Loc))));
2753 -- If the RACW denotes an object created on the current partition,
2754 -- Local_Statements will be executed. The real object will be used.
2756 Local_Statements := New_List (
2757 Make_Assignment_Statement (Loc,
2760 Unchecked_Convert_To (RACW_Type,
2761 OK_Convert_To (RTE (RE_Address),
2762 New_Occurrence_Of (Source_Address, Loc)))));
2764 -- If the object is located on another partition, then a stub object
2765 -- will be created with all the information needed to rebuild the
2766 -- real object at the other end.
2768 Remote_Statements := New_List (
2770 Make_Assignment_Statement (Loc,
2771 Name => Make_Selected_Component (Loc,
2772 Prefix => Stubbed_Result,
2773 Selector_Name => Name_Origin),
2775 New_Occurrence_Of (Source_Partition, Loc)),
2777 Make_Assignment_Statement (Loc,
2778 Name => Make_Selected_Component (Loc,
2779 Prefix => Stubbed_Result,
2780 Selector_Name => Name_Receiver),
2782 New_Occurrence_Of (Source_Receiver, Loc)),
2784 Make_Assignment_Statement (Loc,
2785 Name => Make_Selected_Component (Loc,
2786 Prefix => Stubbed_Result,
2787 Selector_Name => Name_Addr),
2789 New_Occurrence_Of (Source_Address, Loc)));
2791 Append_To (Remote_Statements,
2792 Make_Assignment_Statement (Loc,
2793 Name => Make_Selected_Component (Loc,
2794 Prefix => Stubbed_Result,
2795 Selector_Name => Name_Asynchronous),
2797 New_Occurrence_Of (Asynchronous_Flag, Loc)));
2799 Append_List_To (Remote_Statements,
2800 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
2801 -- ??? Issue with asynchronous calls here: the Asynchronous
2802 -- flag is set on the stub type if, and only if, the RACW type
2803 -- has a pragma Asynchronous. This is incorrect for RACWs that
2804 -- implement RAS types, because in that case the /designated
2805 -- subprogram/ (not the type) might be asynchronous, and
2806 -- that causes the stub to need to be asynchronous too.
2807 -- A solution is to transport a RAS as a struct containing
2808 -- a RACW and an asynchronous flag, and to properly alter
2809 -- the Asynchronous component in the stub type in the RAS's
2812 Append_To (Remote_Statements,
2813 Make_Assignment_Statement (Loc,
2815 Expression => Unchecked_Convert_To (RACW_Type,
2816 New_Occurrence_Of (Stubbed_Result, Loc))));
2818 -- Distinguish between the local and remote cases, and execute the
2819 -- appropriate piece of code.
2821 Append_To (Statements,
2822 Make_Implicit_If_Statement (RACW_Type,
2826 Make_Function_Call (Loc,
2827 Name => New_Occurrence_Of (
2828 RTE (RE_Get_Local_Partition_Id), Loc)),
2829 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
2830 Then_Statements => Local_Statements,
2831 Else_Statements => Remote_Statements));
2833 Build_Stream_Procedure
2834 (Loc, RACW_Type, Body_Node,
2835 Make_Defining_Identifier (Loc, Procedure_Name),
2836 Statements, Outp => True);
2837 Set_Declarations (Body_Node, Decls);
2839 Proc_Decl := Make_Subprogram_Declaration (Loc,
2840 Copy_Specification (Loc, Specification (Body_Node)));
2843 Make_Attribute_Definition_Clause (Loc,
2844 Name => New_Occurrence_Of (RACW_Type, Loc),
2848 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2850 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2851 Insert_After (Proc_Decl, Attr_Decl);
2852 Append_To (Declarations, Body_Node);
2853 end Add_RACW_Read_Attribute;
2855 ------------------------------
2856 -- Add_RACW_Write_Attribute --
2857 ------------------------------
2859 procedure Add_RACW_Write_Attribute
2860 (RACW_Type : Entity_Id;
2861 Stub_Type : Entity_Id;
2862 Stub_Type_Access : Entity_Id;
2863 RPC_Receiver : Node_Id;
2864 Declarations : List_Id)
2866 Body_Node : Node_Id;
2867 Proc_Decl : Node_Id;
2868 Attr_Decl : Node_Id;
2870 Statements : List_Id;
2871 Local_Statements : List_Id;
2872 Remote_Statements : List_Id;
2873 Null_Statements : List_Id;
2875 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
2878 -- Build the code fragment corresponding to the marshalling of a
2881 Local_Statements := New_List (
2883 Pack_Entity_Into_Stream_Access (Loc,
2884 Stream => Stream_Parameter,
2885 Object => RTE (RE_Get_Local_Partition_Id)),
2887 Pack_Node_Into_Stream_Access (Loc,
2888 Stream => Stream_Parameter,
2889 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2890 Etyp => RTE (RE_Unsigned_64)),
2892 Pack_Node_Into_Stream_Access (Loc,
2893 Stream => Stream_Parameter,
2894 Object => OK_Convert_To (RTE (RE_Unsigned_64),
2895 Make_Attribute_Reference (Loc,
2897 Make_Explicit_Dereference (Loc,
2899 Attribute_Name => Name_Address)),
2900 Etyp => RTE (RE_Unsigned_64)));
2902 -- Build the code fragment corresponding to the marshalling of
2905 Remote_Statements := New_List (
2907 Pack_Node_Into_Stream_Access (Loc,
2908 Stream => Stream_Parameter,
2910 Make_Selected_Component (Loc,
2911 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2914 Make_Identifier (Loc, Name_Origin)),
2915 Etyp => RTE (RE_Partition_ID)),
2917 Pack_Node_Into_Stream_Access (Loc,
2918 Stream => Stream_Parameter,
2920 Make_Selected_Component (Loc,
2921 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2924 Make_Identifier (Loc, Name_Receiver)),
2925 Etyp => RTE (RE_Unsigned_64)),
2927 Pack_Node_Into_Stream_Access (Loc,
2928 Stream => Stream_Parameter,
2930 Make_Selected_Component (Loc,
2931 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2934 Make_Identifier (Loc, Name_Addr)),
2935 Etyp => RTE (RE_Unsigned_64)));
2937 -- Build code fragment corresponding to marshalling of a null object
2939 Null_Statements := New_List (
2941 Pack_Entity_Into_Stream_Access (Loc,
2942 Stream => Stream_Parameter,
2943 Object => RTE (RE_Get_Local_Partition_Id)),
2945 Pack_Node_Into_Stream_Access (Loc,
2946 Stream => Stream_Parameter,
2947 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2948 Etyp => RTE (RE_Unsigned_64)),
2950 Pack_Node_Into_Stream_Access (Loc,
2951 Stream => Stream_Parameter,
2952 Object => Make_Integer_Literal (Loc, Uint_0),
2953 Etyp => RTE (RE_Unsigned_64)));
2955 Statements := New_List (
2956 Make_Implicit_If_Statement (RACW_Type,
2959 Left_Opnd => Object,
2960 Right_Opnd => Make_Null (Loc)),
2961 Then_Statements => Null_Statements,
2962 Elsif_Parts => New_List (
2963 Make_Elsif_Part (Loc,
2967 Make_Attribute_Reference (Loc,
2969 Attribute_Name => Name_Tag),
2971 Make_Attribute_Reference (Loc,
2972 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2973 Attribute_Name => Name_Tag)),
2974 Then_Statements => Remote_Statements)),
2975 Else_Statements => Local_Statements));
2977 Build_Stream_Procedure
2978 (Loc, RACW_Type, Body_Node,
2979 Make_Defining_Identifier (Loc, Procedure_Name),
2980 Statements, Outp => False);
2982 Proc_Decl := Make_Subprogram_Declaration (Loc,
2983 Copy_Specification (Loc, Specification (Body_Node)));
2986 Make_Attribute_Definition_Clause (Loc,
2987 Name => New_Occurrence_Of (RACW_Type, Loc),
2988 Chars => Name_Write,
2991 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2993 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2994 Insert_After (Proc_Decl, Attr_Decl);
2995 Append_To (Declarations, Body_Node);
2996 end Add_RACW_Write_Attribute;
2998 ------------------------
2999 -- Add_RAS_Access_TSS --
3000 ------------------------
3002 procedure Add_RAS_Access_TSS (N : Node_Id) is
3003 Loc : constant Source_Ptr := Sloc (N);
3005 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3006 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3007 -- Ras_Type is the access to subprogram type while Fat_Type is the
3008 -- corresponding record type.
3010 RACW_Type : constant Entity_Id :=
3011 Underlying_RACW_Type (Ras_Type);
3012 Desig : constant Entity_Id :=
3013 Etype (Designated_Type (RACW_Type));
3015 Stub_Elements : constant Stub_Structure :=
3016 Stubs_Table.Get (Desig);
3017 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3019 Proc : constant Entity_Id :=
3020 Make_Defining_Identifier (Loc,
3021 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3023 Proc_Spec : Node_Id;
3025 -- Formal parameters
3027 Package_Name : constant Entity_Id :=
3028 Make_Defining_Identifier (Loc,
3032 Subp_Id : constant Entity_Id :=
3033 Make_Defining_Identifier (Loc,
3035 -- Target subprogram
3037 Asynch_P : constant Entity_Id :=
3038 Make_Defining_Identifier (Loc,
3039 Chars => Name_Asynchronous);
3040 -- Is the procedure to which the 'Access applies asynchronous?
3042 All_Calls_Remote : constant Entity_Id :=
3043 Make_Defining_Identifier (Loc,
3044 Chars => Name_All_Calls_Remote);
3045 -- True if an All_Calls_Remote pragma applies to the RCI unit
3046 -- that contains the subprogram.
3048 -- Common local variables
3050 Proc_Decls : List_Id;
3051 Proc_Statements : List_Id;
3053 Origin : constant Entity_Id :=
3054 Make_Defining_Identifier (Loc,
3055 Chars => New_Internal_Name ('P'));
3057 -- Additional local variables for the local case
3059 Proxy_Addr : constant Entity_Id :=
3060 Make_Defining_Identifier (Loc,
3061 Chars => New_Internal_Name ('P'));
3063 -- Additional local variables for the remote case
3065 Local_Stub : constant Entity_Id :=
3066 Make_Defining_Identifier (Loc,
3067 Chars => New_Internal_Name ('L'));
3069 Stub_Ptr : constant Entity_Id :=
3070 Make_Defining_Identifier (Loc,
3071 Chars => New_Internal_Name ('S'));
3074 (Field_Name : Name_Id;
3075 Value : Node_Id) return Node_Id;
3076 -- Construct an assignment that sets the named component in the
3084 (Field_Name : Name_Id;
3085 Value : Node_Id) return Node_Id
3089 Make_Assignment_Statement (Loc,
3091 Make_Selected_Component (Loc,
3093 Selector_Name => Field_Name),
3094 Expression => Value);
3097 -- Start of processing for Add_RAS_Access_TSS
3100 Proc_Decls := New_List (
3102 -- Common declarations
3104 Make_Object_Declaration (Loc,
3105 Defining_Identifier => Origin,
3106 Constant_Present => True,
3107 Object_Definition =>
3108 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3110 Make_Function_Call (Loc,
3112 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3113 Parameter_Associations => New_List (
3114 New_Occurrence_Of (Package_Name, Loc)))),
3116 -- Declaration use only in the local case: proxy address
3118 Make_Object_Declaration (Loc,
3119 Defining_Identifier => Proxy_Addr,
3120 Object_Definition =>
3121 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3123 -- Declarations used only in the remote case: stub object and
3126 Make_Object_Declaration (Loc,
3127 Defining_Identifier => Local_Stub,
3128 Aliased_Present => True,
3129 Object_Definition =>
3130 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3132 Make_Object_Declaration (Loc,
3133 Defining_Identifier =>
3135 Object_Definition =>
3136 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3138 Make_Attribute_Reference (Loc,
3139 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3140 Attribute_Name => Name_Unchecked_Access)));
3142 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3143 -- Build_Get_Unique_RP_Call needs this information
3145 -- Note: Here we assume that the Fat_Type is a record
3146 -- containing just a pointer to a proxy or stub object.
3148 Proc_Statements := New_List (
3152 -- Get_RAS_Info (Pkg, Subp, PA);
3153 -- if Origin = Local_Partition_Id
3154 -- and then not All_Calls_Remote
3156 -- return Fat_Type!(PA);
3159 Make_Procedure_Call_Statement (Loc,
3161 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3162 Parameter_Associations => New_List (
3163 New_Occurrence_Of (Package_Name, Loc),
3164 New_Occurrence_Of (Subp_Id, Loc),
3165 New_Occurrence_Of (Proxy_Addr, Loc))),
3167 Make_Implicit_If_Statement (N,
3173 New_Occurrence_Of (Origin, Loc),
3175 Make_Function_Call (Loc,
3177 RTE (RE_Get_Local_Partition_Id), Loc))),
3180 New_Occurrence_Of (All_Calls_Remote, Loc))),
3181 Then_Statements => New_List (
3182 Make_Return_Statement (Loc,
3183 Unchecked_Convert_To (Fat_Type,
3184 OK_Convert_To (RTE (RE_Address),
3185 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3187 Set_Field (Name_Origin,
3188 New_Occurrence_Of (Origin, Loc)),
3190 Set_Field (Name_Receiver,
3191 Make_Function_Call (Loc,
3193 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3194 Parameter_Associations => New_List (
3195 New_Occurrence_Of (Package_Name, Loc)))),
3197 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3199 -- E.4.1(9) A remote call is asynchronous if it is a call to
3200 -- a procedure, or a call through a value of an access-to-procedure
3201 -- type, to which a pragma Asynchronous applies.
3203 -- Parameter Asynch_P is true when the procedure is asynchronous;
3204 -- Expression Asynch_T is true when the type is asynchronous.
3206 Set_Field (Name_Asynchronous,
3208 New_Occurrence_Of (Asynch_P, Loc),
3209 New_Occurrence_Of (Boolean_Literals (
3210 Is_Asynchronous (Ras_Type)), Loc))));
3212 Append_List_To (Proc_Statements,
3213 Build_Get_Unique_RP_Call
3214 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3216 -- Return the newly created value
3218 Append_To (Proc_Statements,
3219 Make_Return_Statement (Loc,
3221 Unchecked_Convert_To (Fat_Type,
3222 New_Occurrence_Of (Stub_Ptr, Loc))));
3225 Make_Function_Specification (Loc,
3226 Defining_Unit_Name => Proc,
3227 Parameter_Specifications => New_List (
3228 Make_Parameter_Specification (Loc,
3229 Defining_Identifier => Package_Name,
3231 New_Occurrence_Of (Standard_String, Loc)),
3233 Make_Parameter_Specification (Loc,
3234 Defining_Identifier => Subp_Id,
3236 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3238 Make_Parameter_Specification (Loc,
3239 Defining_Identifier => Asynch_P,
3241 New_Occurrence_Of (Standard_Boolean, Loc)),
3243 Make_Parameter_Specification (Loc,
3244 Defining_Identifier => All_Calls_Remote,
3246 New_Occurrence_Of (Standard_Boolean, Loc))),
3249 New_Occurrence_Of (Fat_Type, Loc));
3251 -- Set the kind and return type of the function to prevent
3252 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3254 Set_Ekind (Proc, E_Function);
3255 Set_Etype (Proc, Fat_Type);
3258 Make_Subprogram_Body (Loc,
3259 Specification => Proc_Spec,
3260 Declarations => Proc_Decls,
3261 Handled_Statement_Sequence =>
3262 Make_Handled_Sequence_Of_Statements (Loc,
3263 Statements => Proc_Statements)));
3265 Set_TSS (Fat_Type, Proc);
3266 end Add_RAS_Access_TSS;
3268 -----------------------
3269 -- Add_RAST_Features --
3270 -----------------------
3272 procedure Add_RAST_Features
3273 (Vis_Decl : Node_Id;
3274 RAS_Type : Entity_Id;
3277 pragma Warnings (Off);
3278 pragma Unreferenced (RAS_Type, Decls);
3279 pragma Warnings (On);
3281 Add_RAS_Access_TSS (Vis_Decl);
3282 end Add_RAST_Features;
3284 -----------------------------------------
3285 -- Add_Receiving_Stubs_To_Declarations --
3286 -----------------------------------------
3288 procedure Add_Receiving_Stubs_To_Declarations
3289 (Pkg_Spec : Node_Id;
3292 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3294 Request_Parameter : Node_Id;
3296 Pkg_RPC_Receiver : constant Entity_Id :=
3297 Make_Defining_Identifier (Loc,
3298 New_Internal_Name ('H'));
3299 Pkg_RPC_Receiver_Statements : List_Id;
3300 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3301 Pkg_RPC_Receiver_Body : Node_Id;
3302 -- A Pkg_RPC_Receiver is built to decode the request
3304 Lookup_RAS_Info : constant Entity_Id :=
3305 Make_Defining_Identifier (Loc,
3306 Chars => New_Internal_Name ('R'));
3307 -- A remote subprogram is created to allow peers to look up
3308 -- RAS information using subprogram ids.
3310 Subp_Id : Entity_Id;
3311 Subp_Index : Entity_Id;
3312 -- Subprogram_Id as read from the incoming stream
3314 Current_Declaration : Node_Id;
3315 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3316 Current_Stubs : Node_Id;
3318 Subp_Info_Array : constant Entity_Id :=
3319 Make_Defining_Identifier (Loc,
3320 Chars => New_Internal_Name ('I'));
3322 Subp_Info_List : constant List_Id := New_List;
3324 Register_Pkg_Actuals : constant List_Id := New_List;
3326 All_Calls_Remote_E : Entity_Id;
3327 Proxy_Object_Addr : Entity_Id;
3329 procedure Append_Stubs_To
3330 (RPC_Receiver_Cases : List_Id;
3332 Subprogram_Number : Int);
3333 -- Add one case to the specified RPC receiver case list
3334 -- associating Subprogram_Number with the subprogram declared
3335 -- by Declaration, for which we have receiving stubs in Stubs.
3337 ---------------------
3338 -- Append_Stubs_To --
3339 ---------------------
3341 procedure Append_Stubs_To
3342 (RPC_Receiver_Cases : List_Id;
3344 Subprogram_Number : Int)
3347 Append_To (RPC_Receiver_Cases,
3348 Make_Case_Statement_Alternative (Loc,
3350 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3353 Make_Procedure_Call_Statement (Loc,
3356 Defining_Entity (Stubs), Loc),
3357 Parameter_Associations => New_List (
3358 New_Occurrence_Of (Request_Parameter, Loc))))));
3359 end Append_Stubs_To;
3361 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3364 -- Building receiving stubs consist in several operations:
3366 -- - a package RPC receiver must be built. This subprogram
3367 -- will get a Subprogram_Id from the incoming stream
3368 -- and will dispatch the call to the right subprogram
3370 -- - a receiving stub for any subprogram visible in the package
3371 -- spec. This stub will read all the parameters from the stream,
3372 -- and put the result as well as the exception occurrence in the
3375 -- - a dummy package with an empty spec and a body made of an
3376 -- elaboration part, whose job is to register the receiving
3377 -- part of this RCI package on the name server. This is done
3378 -- by calling System.Partition_Interface.Register_Receiving_Stub
3380 Build_RPC_Receiver_Body (
3381 RPC_Receiver => Pkg_RPC_Receiver,
3382 Request => Request_Parameter,
3384 Subp_Index => Subp_Index,
3385 Stmts => Pkg_RPC_Receiver_Statements,
3386 Decl => Pkg_RPC_Receiver_Body);
3387 pragma Assert (Subp_Id = Subp_Index);
3389 -- A null subp_id denotes a call through a RAS, in which case the
3390 -- next Uint_64 element in the stream is the address of the local
3391 -- proxy object, from which we can retrieve the actual subprogram id.
3393 Append_To (Pkg_RPC_Receiver_Statements,
3394 Make_Implicit_If_Statement (Pkg_Spec,
3397 New_Occurrence_Of (Subp_Id, Loc),
3398 Make_Integer_Literal (Loc, 0)),
3399 Then_Statements => New_List (
3400 Make_Assignment_Statement (Loc,
3402 New_Occurrence_Of (Subp_Id, Loc),
3404 Make_Selected_Component (Loc,
3406 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3407 OK_Convert_To (RTE (RE_Address),
3408 Make_Attribute_Reference (Loc,
3410 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3413 Expressions => New_List (
3414 Make_Selected_Component (Loc,
3415 Prefix => Request_Parameter,
3416 Selector_Name => Name_Params))))),
3418 Make_Identifier (Loc, Name_Subp_Id))))));
3420 -- Build a subprogram for RAS information lookups
3422 Current_Declaration :=
3423 Make_Subprogram_Declaration (Loc,
3425 Make_Function_Specification (Loc,
3426 Defining_Unit_Name =>
3428 Parameter_Specifications => New_List (
3429 Make_Parameter_Specification (Loc,
3430 Defining_Identifier =>
3431 Make_Defining_Identifier (Loc, Name_Subp_Id),
3435 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3437 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3438 Append_To (Decls, Current_Declaration);
3439 Analyze (Current_Declaration);
3441 Current_Stubs := Build_Subprogram_Receiving_Stubs
3442 (Vis_Decl => Current_Declaration,
3443 Asynchronous => False);
3444 Append_To (Decls, Current_Stubs);
3445 Analyze (Current_Stubs);
3447 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3450 Subprogram_Number => 1);
3452 -- For each subprogram, the receiving stub will be built and a
3453 -- case statement will be made on the Subprogram_Id to dispatch
3454 -- to the right subprogram.
3456 All_Calls_Remote_E := Boolean_Literals (
3457 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3459 Overload_Counter_Table.Reset;
3461 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3462 while Present (Current_Declaration) loop
3463 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3464 and then Comes_From_Source (Current_Declaration)
3467 Loc : constant Source_Ptr :=
3468 Sloc (Current_Declaration);
3469 -- While specifically processing Current_Declaration, use
3470 -- its Sloc as the location of all generated nodes.
3472 Subp_Def : constant Entity_Id :=
3474 (Specification (Current_Declaration));
3476 Subp_Val : String_Id;
3479 pragma Assert (Current_Subprogram_Number =
3480 Get_Subprogram_Id (Subp_Def));
3482 -- Build receiving stub
3485 Build_Subprogram_Receiving_Stubs
3486 (Vis_Decl => Current_Declaration,
3488 Nkind (Specification (Current_Declaration)) =
3489 N_Procedure_Specification
3490 and then Is_Asynchronous (Subp_Def));
3492 Append_To (Decls, Current_Stubs);
3493 Analyze (Current_Stubs);
3497 Add_RAS_Proxy_And_Analyze (Decls,
3499 Current_Declaration,
3500 All_Calls_Remote_E =>
3502 Proxy_Object_Addr =>
3505 -- Compute distribution identifier
3507 Assign_Subprogram_Identifier (
3509 Current_Subprogram_Number,
3512 -- Add subprogram descriptor (RCI_Subp_Info) to the
3513 -- subprograms table for this receiver. The aggregate
3514 -- below must be kept consistent with the declaration
3515 -- of type RCI_Subp_Info in System.Partition_Interface.
3517 Append_To (Subp_Info_List,
3518 Make_Component_Association (Loc,
3519 Choices => New_List (
3520 Make_Integer_Literal (Loc,
3521 Current_Subprogram_Number)),
3523 Make_Aggregate (Loc,
3524 Component_Associations => New_List (
3525 Make_Component_Association (Loc,
3526 Choices => New_List (
3527 Make_Identifier (Loc, Name_Addr)),
3530 Proxy_Object_Addr, Loc))))));
3532 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3535 Subprogram_Number =>
3536 Current_Subprogram_Number);
3539 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3542 Next (Current_Declaration);
3545 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3546 -- rather than raising an exception since we do not want someone
3547 -- to crash a remote partition by sending invalid subprogram ids.
3548 -- This is consistent with the other parts of the case statement
3549 -- since even in presence of incorrect parameters in the stream,
3550 -- every exception will be caught and (if the subprogram is not an
3551 -- APC) put into the result stream and sent away.
3553 Append_To (Pkg_RPC_Receiver_Cases,
3554 Make_Case_Statement_Alternative (Loc,
3556 New_List (Make_Others_Choice (Loc)),
3558 New_List (Make_Null_Statement (Loc))));
3560 Append_To (Pkg_RPC_Receiver_Statements,
3561 Make_Case_Statement (Loc,
3563 New_Occurrence_Of (Subp_Id, Loc),
3564 Alternatives => Pkg_RPC_Receiver_Cases));
3567 Make_Object_Declaration (Loc,
3568 Defining_Identifier => Subp_Info_Array,
3569 Constant_Present => True,
3570 Aliased_Present => True,
3571 Object_Definition =>
3572 Make_Subtype_Indication (Loc,
3574 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3576 Make_Index_Or_Discriminant_Constraint (Loc,
3579 Low_Bound => Make_Integer_Literal (Loc,
3580 First_RCI_Subprogram_Id),
3582 Make_Integer_Literal (Loc,
3583 First_RCI_Subprogram_Id
3584 + List_Length (Subp_Info_List) - 1))))),
3586 Make_Aggregate (Loc,
3587 Component_Associations => Subp_Info_List)));
3588 Analyze (Last (Decls));
3591 Make_Subprogram_Body (Loc,
3593 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
3596 Handled_Statement_Sequence =>
3597 Make_Handled_Sequence_Of_Statements (Loc,
3598 Statements => New_List (
3599 Make_Return_Statement (Loc,
3600 Expression => OK_Convert_To (RTE (RE_Unsigned_64),
3601 Make_Selected_Component (Loc,
3603 Make_Indexed_Component (Loc,
3605 New_Occurrence_Of (Subp_Info_Array, Loc),
3606 Expressions => New_List (
3607 Convert_To (Standard_Integer,
3608 Make_Identifier (Loc, Name_Subp_Id)))),
3610 Make_Identifier (Loc, Name_Addr))))))));
3611 Analyze (Last (Decls));
3613 Append_To (Decls, Pkg_RPC_Receiver_Body);
3614 Analyze (Last (Decls));
3616 Get_Library_Unit_Name_String (Pkg_Spec);
3617 Append_To (Register_Pkg_Actuals,
3619 Make_String_Literal (Loc,
3620 Strval => String_From_Name_Buffer));
3622 Append_To (Register_Pkg_Actuals,
3624 Make_Attribute_Reference (Loc,
3626 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
3628 Name_Unrestricted_Access));
3630 Append_To (Register_Pkg_Actuals,
3632 Make_Attribute_Reference (Loc,
3634 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
3638 Append_To (Register_Pkg_Actuals,
3640 Make_Attribute_Reference (Loc,
3642 New_Occurrence_Of (Subp_Info_Array, Loc),
3646 Append_To (Register_Pkg_Actuals,
3648 Make_Attribute_Reference (Loc,
3650 New_Occurrence_Of (Subp_Info_Array, Loc),
3655 Make_Procedure_Call_Statement (Loc,
3657 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
3658 Parameter_Associations => Register_Pkg_Actuals));
3659 Analyze (Last (Decls));
3660 end Add_Receiving_Stubs_To_Declarations;
3662 ---------------------------------
3663 -- Build_General_Calling_Stubs --
3664 ---------------------------------
3666 procedure Build_General_Calling_Stubs
3668 Statements : List_Id;
3669 Target_Partition : Entity_Id;
3670 Target_RPC_Receiver : Node_Id;
3671 Subprogram_Id : Node_Id;
3672 Asynchronous : Node_Id := Empty;
3673 Is_Known_Asynchronous : Boolean := False;
3674 Is_Known_Non_Asynchronous : Boolean := False;
3675 Is_Function : Boolean;
3677 Stub_Type : Entity_Id := Empty;
3678 RACW_Type : Entity_Id := Empty;
3681 Loc : constant Source_Ptr := Sloc (Nod);
3683 Stream_Parameter : Node_Id;
3684 -- Name of the stream used to transmit parameters to the
3687 Result_Parameter : Node_Id;
3688 -- Name of the result parameter (in non-APC cases) which get the
3689 -- result of the remote subprogram.
3691 Exception_Return_Parameter : Node_Id;
3692 -- Name of the parameter which will hold the exception sent by the
3693 -- remote subprogram.
3695 Current_Parameter : Node_Id;
3696 -- Current parameter being handled
3698 Ordered_Parameters_List : constant List_Id :=
3699 Build_Ordered_Parameters_List (Spec);
3701 Asynchronous_Statements : List_Id := No_List;
3702 Non_Asynchronous_Statements : List_Id := No_List;
3703 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
3705 Extra_Formal_Statements : constant List_Id := New_List;
3706 -- List of statements for extra formal parameters. It will appear
3707 -- after the regular statements for writing out parameters.
3709 pragma Warnings (Off);
3710 pragma Unreferenced (RACW_Type);
3711 -- Used only for the PolyORB case
3712 pragma Warnings (On);
3715 -- The general form of a calling stub for a given subprogram is:
3717 -- procedure X (...) is P : constant Partition_ID :=
3718 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
3719 -- System.RPC.Params_Stream_Type (0); begin
3720 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
3721 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
3722 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
3723 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
3725 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
3727 -- There are some variations: Do_APC is called for an asynchronous
3728 -- procedure and the part after the call is completely ommitted as
3729 -- well as the declaration of Result. For a function call, 'Input is
3730 -- always used to read the result even if it is constrained.
3733 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3736 Make_Object_Declaration (Loc,
3737 Defining_Identifier => Stream_Parameter,
3738 Aliased_Present => True,
3739 Object_Definition =>
3740 Make_Subtype_Indication (Loc,
3742 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
3744 Make_Index_Or_Discriminant_Constraint (Loc,
3746 New_List (Make_Integer_Literal (Loc, 0))))));
3748 if not Is_Known_Asynchronous then
3750 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3753 Make_Object_Declaration (Loc,
3754 Defining_Identifier => Result_Parameter,
3755 Aliased_Present => True,
3756 Object_Definition =>
3757 Make_Subtype_Indication (Loc,
3759 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
3761 Make_Index_Or_Discriminant_Constraint (Loc,
3763 New_List (Make_Integer_Literal (Loc, 0))))));
3765 Exception_Return_Parameter :=
3766 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3769 Make_Object_Declaration (Loc,
3770 Defining_Identifier => Exception_Return_Parameter,
3771 Object_Definition =>
3772 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
3775 Result_Parameter := Empty;
3776 Exception_Return_Parameter := Empty;
3779 -- Put first the RPC receiver corresponding to the remote package
3781 Append_To (Statements,
3782 Make_Attribute_Reference (Loc,
3784 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3785 Attribute_Name => Name_Write,
3786 Expressions => New_List (
3787 Make_Attribute_Reference (Loc,
3789 New_Occurrence_Of (Stream_Parameter, Loc),
3792 Target_RPC_Receiver)));
3794 -- Then put the Subprogram_Id of the subprogram we want to call in
3797 Append_To (Statements,
3798 Make_Attribute_Reference (Loc,
3800 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
3803 Expressions => New_List (
3804 Make_Attribute_Reference (Loc,
3806 New_Occurrence_Of (Stream_Parameter, Loc),
3807 Attribute_Name => Name_Access),
3810 Current_Parameter := First (Ordered_Parameters_List);
3811 while Present (Current_Parameter) loop
3813 Typ : constant Node_Id :=
3814 Parameter_Type (Current_Parameter);
3816 Constrained : Boolean;
3818 Extra_Parameter : Entity_Id;
3821 if Is_RACW_Controlling_Formal
3822 (Current_Parameter, Stub_Type)
3824 -- In the case of a controlling formal argument, we marshall
3825 -- its addr field rather than the local stub.
3827 Append_To (Statements,
3828 Pack_Node_Into_Stream (Loc,
3829 Stream => Stream_Parameter,
3831 Make_Selected_Component (Loc,
3833 Defining_Identifier (Current_Parameter),
3834 Selector_Name => Name_Addr),
3835 Etyp => RTE (RE_Unsigned_64)));
3838 Value := New_Occurrence_Of
3839 (Defining_Identifier (Current_Parameter), Loc);
3841 -- Access type parameters are transmitted as in out
3842 -- parameters. However, a dereference is needed so that
3843 -- we marshall the designated object.
3845 if Nkind (Typ) = N_Access_Definition then
3846 Value := Make_Explicit_Dereference (Loc, Value);
3847 Etyp := Etype (Subtype_Mark (Typ));
3849 Etyp := Etype (Typ);
3853 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
3855 -- Any parameter but unconstrained out parameters are
3856 -- transmitted to the peer.
3858 if In_Present (Current_Parameter)
3859 or else not Out_Present (Current_Parameter)
3860 or else not Constrained
3862 Append_To (Statements,
3863 Make_Attribute_Reference (Loc,
3865 New_Occurrence_Of (Etyp, Loc),
3867 Output_From_Constrained (Constrained),
3868 Expressions => New_List (
3869 Make_Attribute_Reference (Loc,
3871 New_Occurrence_Of (Stream_Parameter, Loc),
3872 Attribute_Name => Name_Access),
3877 -- If the current parameter has a dynamic constrained status,
3878 -- then this status is transmitted as well.
3879 -- This should be done for accessibility as well ???
3881 if Nkind (Typ) /= N_Access_Definition
3882 and then Need_Extra_Constrained (Current_Parameter)
3884 -- In this block, we do not use the extra formal that has
3885 -- been created because it does not exist at the time of
3886 -- expansion when building calling stubs for remote access
3887 -- to subprogram types. We create an extra variable of this
3888 -- type and push it in the stream after the regular
3891 Extra_Parameter := Make_Defining_Identifier
3892 (Loc, New_Internal_Name ('P'));
3895 Make_Object_Declaration (Loc,
3896 Defining_Identifier => Extra_Parameter,
3897 Constant_Present => True,
3898 Object_Definition =>
3899 New_Occurrence_Of (Standard_Boolean, Loc),
3901 Make_Attribute_Reference (Loc,
3904 Defining_Identifier (Current_Parameter), Loc),
3905 Attribute_Name => Name_Constrained)));
3907 Append_To (Extra_Formal_Statements,
3908 Make_Attribute_Reference (Loc,
3910 New_Occurrence_Of (Standard_Boolean, Loc),
3913 Expressions => New_List (
3914 Make_Attribute_Reference (Loc,
3916 New_Occurrence_Of (Stream_Parameter, Loc),
3919 New_Occurrence_Of (Extra_Parameter, Loc))));
3922 Next (Current_Parameter);
3926 -- Append the formal statements list to the statements
3928 Append_List_To (Statements, Extra_Formal_Statements);
3930 if not Is_Known_Non_Asynchronous then
3932 -- Build the call to System.RPC.Do_APC
3934 Asynchronous_Statements := New_List (
3935 Make_Procedure_Call_Statement (Loc,
3937 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
3938 Parameter_Associations => New_List (
3939 New_Occurrence_Of (Target_Partition, Loc),
3940 Make_Attribute_Reference (Loc,
3942 New_Occurrence_Of (Stream_Parameter, Loc),
3946 Asynchronous_Statements := No_List;
3949 if not Is_Known_Asynchronous then
3951 -- Build the call to System.RPC.Do_RPC
3953 Non_Asynchronous_Statements := New_List (
3954 Make_Procedure_Call_Statement (Loc,
3956 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
3957 Parameter_Associations => New_List (
3958 New_Occurrence_Of (Target_Partition, Loc),
3960 Make_Attribute_Reference (Loc,
3962 New_Occurrence_Of (Stream_Parameter, Loc),
3966 Make_Attribute_Reference (Loc,
3968 New_Occurrence_Of (Result_Parameter, Loc),
3972 -- Read the exception occurrence from the result stream and
3973 -- reraise it. It does no harm if this is a Null_Occurrence since
3974 -- this does nothing.
3976 Append_To (Non_Asynchronous_Statements,
3977 Make_Attribute_Reference (Loc,
3979 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
3984 Expressions => New_List (
3985 Make_Attribute_Reference (Loc,
3987 New_Occurrence_Of (Result_Parameter, Loc),
3990 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
3992 Append_To (Non_Asynchronous_Statements,
3993 Make_Procedure_Call_Statement (Loc,
3995 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
3996 Parameter_Associations => New_List (
3997 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4001 -- If this is a function call, then read the value and return
4002 -- it. The return value is written/read using 'Output/'Input.
4004 Append_To (Non_Asynchronous_Statements,
4005 Make_Tag_Check (Loc,
4006 Make_Return_Statement (Loc,
4008 Make_Attribute_Reference (Loc,
4011 Etype (Subtype_Mark (Spec)), Loc),
4013 Attribute_Name => Name_Input,
4015 Expressions => New_List (
4016 Make_Attribute_Reference (Loc,
4018 New_Occurrence_Of (Result_Parameter, Loc),
4019 Attribute_Name => Name_Access))))));
4022 -- Loop around parameters and assign out (or in out)
4023 -- parameters. In the case of RACW, controlling arguments
4024 -- cannot possibly have changed since they are remote, so we do
4025 -- not read them from the stream.
4027 Current_Parameter := First (Ordered_Parameters_List);
4028 while Present (Current_Parameter) loop
4030 Typ : constant Node_Id :=
4031 Parameter_Type (Current_Parameter);
4038 (Defining_Identifier (Current_Parameter), Loc);
4040 if Nkind (Typ) = N_Access_Definition then
4041 Value := Make_Explicit_Dereference (Loc, Value);
4042 Etyp := Etype (Subtype_Mark (Typ));
4044 Etyp := Etype (Typ);
4047 if (Out_Present (Current_Parameter)
4048 or else Nkind (Typ) = N_Access_Definition)
4049 and then Etyp /= Stub_Type
4051 Append_To (Non_Asynchronous_Statements,
4052 Make_Attribute_Reference (Loc,
4054 New_Occurrence_Of (Etyp, Loc),
4056 Attribute_Name => Name_Read,
4058 Expressions => New_List (
4059 Make_Attribute_Reference (Loc,
4061 New_Occurrence_Of (Result_Parameter, Loc),
4068 Next (Current_Parameter);
4073 if Is_Known_Asynchronous then
4074 Append_List_To (Statements, Asynchronous_Statements);
4076 elsif Is_Known_Non_Asynchronous then
4077 Append_List_To (Statements, Non_Asynchronous_Statements);
4080 pragma Assert (Present (Asynchronous));
4081 Prepend_To (Asynchronous_Statements,
4082 Make_Attribute_Reference (Loc,
4083 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4084 Attribute_Name => Name_Write,
4085 Expressions => New_List (
4086 Make_Attribute_Reference (Loc,
4088 New_Occurrence_Of (Stream_Parameter, Loc),
4089 Attribute_Name => Name_Access),
4090 New_Occurrence_Of (Standard_True, Loc))));
4092 Prepend_To (Non_Asynchronous_Statements,
4093 Make_Attribute_Reference (Loc,
4094 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4095 Attribute_Name => Name_Write,
4096 Expressions => New_List (
4097 Make_Attribute_Reference (Loc,
4099 New_Occurrence_Of (Stream_Parameter, Loc),
4100 Attribute_Name => Name_Access),
4101 New_Occurrence_Of (Standard_False, Loc))));
4103 Append_To (Statements,
4104 Make_Implicit_If_Statement (Nod,
4105 Condition => Asynchronous,
4106 Then_Statements => Asynchronous_Statements,
4107 Else_Statements => Non_Asynchronous_Statements));
4109 end Build_General_Calling_Stubs;
4111 -----------------------------
4112 -- Build_RPC_Receiver_Body --
4113 -----------------------------
4115 procedure Build_RPC_Receiver_Body
4116 (RPC_Receiver : Entity_Id;
4117 Request : out Entity_Id;
4118 Subp_Id : out Entity_Id;
4119 Subp_Index : out Entity_Id;
4120 Stmts : out List_Id;
4123 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4125 RPC_Receiver_Spec : Node_Id;
4126 RPC_Receiver_Decls : List_Id;
4129 Request := Make_Defining_Identifier (Loc, Name_R);
4131 RPC_Receiver_Spec :=
4132 Build_RPC_Receiver_Specification
4133 (RPC_Receiver => RPC_Receiver,
4134 Request_Parameter => Request);
4136 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4137 Subp_Index := Subp_Id;
4139 -- Subp_Id may not be a constant, because in the case of the RPC
4140 -- receiver for an RCI package, when a call is received from a RAS
4141 -- dereference, it will be assigned during subsequent processing.
4143 RPC_Receiver_Decls := New_List (
4144 Make_Object_Declaration (Loc,
4145 Defining_Identifier => Subp_Id,
4146 Object_Definition =>
4147 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4149 Make_Attribute_Reference (Loc,
4151 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4152 Attribute_Name => Name_Input,
4153 Expressions => New_List (
4154 Make_Selected_Component (Loc,
4156 Selector_Name => Name_Params)))));
4161 Make_Subprogram_Body (Loc,
4162 Specification => RPC_Receiver_Spec,
4163 Declarations => RPC_Receiver_Decls,
4164 Handled_Statement_Sequence =>
4165 Make_Handled_Sequence_Of_Statements (Loc,
4166 Statements => Stmts));
4167 end Build_RPC_Receiver_Body;
4169 -----------------------
4170 -- Build_Stub_Target --
4171 -----------------------
4173 function Build_Stub_Target
4176 RCI_Locator : Entity_Id;
4177 Controlling_Parameter : Entity_Id) return RPC_Target
4179 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4181 Target_Info.Partition :=
4182 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4183 if Present (Controlling_Parameter) then
4185 Make_Object_Declaration (Loc,
4186 Defining_Identifier => Target_Info.Partition,
4187 Constant_Present => True,
4188 Object_Definition =>
4189 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4192 Make_Selected_Component (Loc,
4193 Prefix => Controlling_Parameter,
4194 Selector_Name => Name_Origin)));
4196 Target_Info.RPC_Receiver :=
4197 Make_Selected_Component (Loc,
4198 Prefix => Controlling_Parameter,
4199 Selector_Name => Name_Receiver);
4203 Make_Object_Declaration (Loc,
4204 Defining_Identifier => Target_Info.Partition,
4205 Constant_Present => True,
4206 Object_Definition =>
4207 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4210 Make_Function_Call (Loc,
4211 Name => Make_Selected_Component (Loc,
4213 Make_Identifier (Loc, Chars (RCI_Locator)),
4215 Make_Identifier (Loc,
4216 Name_Get_Active_Partition_ID)))));
4218 Target_Info.RPC_Receiver :=
4219 Make_Selected_Component (Loc,
4221 Make_Identifier (Loc, Chars (RCI_Locator)),
4223 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4226 end Build_Stub_Target;
4228 ---------------------
4229 -- Build_Stub_Type --
4230 ---------------------
4232 procedure Build_Stub_Type
4233 (RACW_Type : Entity_Id;
4234 Stub_Type : Entity_Id;
4235 Stub_Type_Decl : out Node_Id;
4236 RPC_Receiver_Decl : out Node_Id)
4238 Loc : constant Source_Ptr := Sloc (Stub_Type);
4239 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4243 Make_Full_Type_Declaration (Loc,
4244 Defining_Identifier => Stub_Type,
4246 Make_Record_Definition (Loc,
4247 Tagged_Present => True,
4248 Limited_Present => True,
4250 Make_Component_List (Loc,
4251 Component_Items => New_List (
4253 Make_Component_Declaration (Loc,
4254 Defining_Identifier =>
4255 Make_Defining_Identifier (Loc, Name_Origin),
4256 Component_Definition =>
4257 Make_Component_Definition (Loc,
4258 Aliased_Present => False,
4259 Subtype_Indication =>
4261 RTE (RE_Partition_ID), Loc))),
4263 Make_Component_Declaration (Loc,
4264 Defining_Identifier =>
4265 Make_Defining_Identifier (Loc, Name_Receiver),
4266 Component_Definition =>
4267 Make_Component_Definition (Loc,
4268 Aliased_Present => False,
4269 Subtype_Indication =>
4270 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4272 Make_Component_Declaration (Loc,
4273 Defining_Identifier =>
4274 Make_Defining_Identifier (Loc, Name_Addr),
4275 Component_Definition =>
4276 Make_Component_Definition (Loc,
4277 Aliased_Present => False,
4278 Subtype_Indication =>
4279 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4281 Make_Component_Declaration (Loc,
4282 Defining_Identifier =>
4283 Make_Defining_Identifier (Loc, Name_Asynchronous),
4284 Component_Definition =>
4285 Make_Component_Definition (Loc,
4286 Aliased_Present => False,
4287 Subtype_Indication =>
4289 Standard_Boolean, Loc)))))));
4292 RPC_Receiver_Decl := Empty;
4295 RPC_Receiver_Request : constant Entity_Id :=
4296 Make_Defining_Identifier (Loc, Name_R);
4298 RPC_Receiver_Decl :=
4299 Make_Subprogram_Declaration (Loc,
4300 Build_RPC_Receiver_Specification (
4301 RPC_Receiver => Make_Defining_Identifier (Loc,
4302 New_Internal_Name ('R')),
4303 Request_Parameter => RPC_Receiver_Request));
4306 end Build_Stub_Type;
4308 --------------------------------------
4309 -- Build_Subprogram_Receiving_Stubs --
4310 --------------------------------------
4312 function Build_Subprogram_Receiving_Stubs
4313 (Vis_Decl : Node_Id;
4314 Asynchronous : Boolean;
4315 Dynamically_Asynchronous : Boolean := False;
4316 Stub_Type : Entity_Id := Empty;
4317 RACW_Type : Entity_Id := Empty;
4318 Parent_Primitive : Entity_Id := Empty) return Node_Id
4320 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4322 Request_Parameter : Node_Id;
4325 Decls : constant List_Id := New_List;
4326 -- All the parameters will get declared before calling the real
4327 -- subprograms. Also the out parameters will be declared.
4329 Statements : constant List_Id := New_List;
4331 Extra_Formal_Statements : constant List_Id := New_List;
4332 -- Statements concerning extra formal parameters
4334 After_Statements : constant List_Id := New_List;
4335 -- Statements to be executed after the subprogram call
4337 Inner_Decls : List_Id := No_List;
4338 -- In case of a function, the inner declarations are needed since
4339 -- the result may be unconstrained.
4341 Excep_Handlers : List_Id := No_List;
4342 Excep_Choice : Entity_Id;
4343 Excep_Code : List_Id;
4345 Parameter_List : constant List_Id := New_List;
4346 -- List of parameters to be passed to the subprogram
4348 Current_Parameter : Node_Id;
4350 Ordered_Parameters_List : constant List_Id :=
4351 Build_Ordered_Parameters_List
4352 (Specification (Vis_Decl));
4354 Subp_Spec : Node_Id;
4355 -- Subprogram specification
4357 Called_Subprogram : Node_Id;
4358 -- The subprogram to call
4360 Null_Raise_Statement : Node_Id;
4362 Dynamic_Async : Entity_Id;
4365 if Present (RACW_Type) then
4366 Called_Subprogram :=
4367 New_Occurrence_Of (Parent_Primitive, Loc);
4369 Called_Subprogram :=
4371 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4374 Request_Parameter :=
4375 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4377 if Dynamically_Asynchronous then
4379 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4381 Dynamic_Async := Empty;
4384 if not Asynchronous or Dynamically_Asynchronous then
4386 -- The first statement after the subprogram call is a statement to
4387 -- writes a Null_Occurrence into the result stream.
4389 Null_Raise_Statement :=
4390 Make_Attribute_Reference (Loc,
4392 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4393 Attribute_Name => Name_Write,
4394 Expressions => New_List (
4395 Make_Selected_Component (Loc,
4396 Prefix => Request_Parameter,
4397 Selector_Name => Name_Result),
4398 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4400 if Dynamically_Asynchronous then
4401 Null_Raise_Statement :=
4402 Make_Implicit_If_Statement (Vis_Decl,
4404 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4405 Then_Statements => New_List (Null_Raise_Statement));
4408 Append_To (After_Statements, Null_Raise_Statement);
4411 -- Loop through every parameter and get its value from the stream. If
4412 -- the parameter is unconstrained, then the parameter is read using
4413 -- 'Input at the point of declaration.
4415 Current_Parameter := First (Ordered_Parameters_List);
4416 while Present (Current_Parameter) loop
4419 Constrained : Boolean;
4421 Object : constant Entity_Id :=
4422 Make_Defining_Identifier (Loc,
4423 New_Internal_Name ('P'));
4425 Expr : Node_Id := Empty;
4427 Is_Controlling_Formal : constant Boolean :=
4428 Is_RACW_Controlling_Formal
4429 (Current_Parameter, Stub_Type);
4432 Set_Ekind (Object, E_Variable);
4434 if Is_Controlling_Formal then
4436 -- We have a controlling formal parameter. Read its address
4437 -- rather than a real object. The address is in Unsigned_64
4440 Etyp := RTE (RE_Unsigned_64);
4442 Etyp := Etype (Parameter_Type (Current_Parameter));
4446 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
4448 if In_Present (Current_Parameter)
4449 or else not Out_Present (Current_Parameter)
4450 or else not Constrained
4451 or else Is_Controlling_Formal
4453 -- If an input parameter is contrained, then its reading is
4454 -- deferred until the beginning of the subprogram body. If
4455 -- it is unconstrained, then an expression is built for
4456 -- the object declaration and the variable is set using
4457 -- 'Input instead of 'Read.
4459 if Constrained and then not Is_Controlling_Formal then
4460 Append_To (Statements,
4461 Make_Attribute_Reference (Loc,
4462 Prefix => New_Occurrence_Of (Etyp, Loc),
4463 Attribute_Name => Name_Read,
4464 Expressions => New_List (
4465 Make_Selected_Component (Loc,
4466 Prefix => Request_Parameter,
4467 Selector_Name => Name_Params),
4468 New_Occurrence_Of (Object, Loc))));
4471 Expr := Input_With_Tag_Check (Loc,
4473 Stream => Make_Selected_Component (Loc,
4474 Prefix => Request_Parameter,
4475 Selector_Name => Name_Params));
4476 Append_To (Decls, Expr);
4477 Expr := Make_Function_Call (Loc,
4478 New_Occurrence_Of (Defining_Unit_Name
4479 (Specification (Expr)), Loc));
4483 -- If we do not have to output the current parameter, then it
4484 -- can well be flagged as constant. This may allow further
4485 -- optimizations done by the back end.
4488 Make_Object_Declaration (Loc,
4489 Defining_Identifier => Object,
4490 Constant_Present => not Constrained
4491 and then not Out_Present (Current_Parameter),
4492 Object_Definition =>
4493 New_Occurrence_Of (Etyp, Loc),
4494 Expression => Expr));
4496 -- An out parameter may be written back using a 'Write
4497 -- attribute instead of a 'Output because it has been
4498 -- constrained by the parameter given to the caller. Note that
4499 -- out controlling arguments in the case of a RACW are not put
4500 -- back in the stream because the pointer on them has not
4503 if Out_Present (Current_Parameter)
4505 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4507 Append_To (After_Statements,
4508 Make_Attribute_Reference (Loc,
4509 Prefix => New_Occurrence_Of (Etyp, Loc),
4510 Attribute_Name => Name_Write,
4511 Expressions => New_List (
4512 Make_Selected_Component (Loc,
4513 Prefix => Request_Parameter,
4514 Selector_Name => Name_Result),
4515 New_Occurrence_Of (Object, Loc))));
4518 -- For RACW controlling formals, the Etyp of Object is always
4519 -- an RACW, even if the parameter is not of an anonymous access
4520 -- type. In such case, we need to dereference it at call time.
4522 if Is_Controlling_Formal then
4523 if Nkind (Parameter_Type (Current_Parameter)) /=
4526 Append_To (Parameter_List,
4527 Make_Parameter_Association (Loc,
4530 Defining_Identifier (Current_Parameter), Loc),
4531 Explicit_Actual_Parameter =>
4532 Make_Explicit_Dereference (Loc,
4533 Unchecked_Convert_To (RACW_Type,
4534 OK_Convert_To (RTE (RE_Address),
4535 New_Occurrence_Of (Object, Loc))))));
4538 Append_To (Parameter_List,
4539 Make_Parameter_Association (Loc,
4542 Defining_Identifier (Current_Parameter), Loc),
4543 Explicit_Actual_Parameter =>
4544 Unchecked_Convert_To (RACW_Type,
4545 OK_Convert_To (RTE (RE_Address),
4546 New_Occurrence_Of (Object, Loc)))));
4550 Append_To (Parameter_List,
4551 Make_Parameter_Association (Loc,
4554 Defining_Identifier (Current_Parameter), Loc),
4555 Explicit_Actual_Parameter =>
4556 New_Occurrence_Of (Object, Loc)));
4559 -- If the current parameter needs an extra formal, then read it
4560 -- from the stream and set the corresponding semantic field in
4561 -- the variable. If the kind of the parameter identifier is
4562 -- E_Void, then this is a compiler generated parameter that
4563 -- doesn't need an extra constrained status.
4565 -- The case of Extra_Accessibility should also be handled ???
4567 if Nkind (Parameter_Type (Current_Parameter)) /=
4570 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4572 Present (Extra_Constrained
4573 (Defining_Identifier (Current_Parameter)))
4576 Extra_Parameter : constant Entity_Id :=
4578 (Defining_Identifier
4579 (Current_Parameter));
4581 Formal_Entity : constant Entity_Id :=
4582 Make_Defining_Identifier
4583 (Loc, Chars (Extra_Parameter));
4585 Formal_Type : constant Entity_Id :=
4586 Etype (Extra_Parameter);
4590 Make_Object_Declaration (Loc,
4591 Defining_Identifier => Formal_Entity,
4592 Object_Definition =>
4593 New_Occurrence_Of (Formal_Type, Loc)));
4595 Append_To (Extra_Formal_Statements,
4596 Make_Attribute_Reference (Loc,
4597 Prefix => New_Occurrence_Of (
4599 Attribute_Name => Name_Read,
4600 Expressions => New_List (
4601 Make_Selected_Component (Loc,
4602 Prefix => Request_Parameter,
4603 Selector_Name => Name_Params),
4604 New_Occurrence_Of (Formal_Entity, Loc))));
4605 Set_Extra_Constrained (Object, Formal_Entity);
4610 Next (Current_Parameter);
4613 -- Append the formal statements list at the end of regular statements
4615 Append_List_To (Statements, Extra_Formal_Statements);
4617 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
4619 -- The remote subprogram is a function. We build an inner block to
4620 -- be able to hold a potentially unconstrained result in a
4624 Etyp : constant Entity_Id :=
4625 Etype (Subtype_Mark (Specification (Vis_Decl)));
4626 Result : constant Node_Id :=
4627 Make_Defining_Identifier (Loc,
4628 New_Internal_Name ('R'));
4630 Inner_Decls := New_List (
4631 Make_Object_Declaration (Loc,
4632 Defining_Identifier => Result,
4633 Constant_Present => True,
4634 Object_Definition => New_Occurrence_Of (Etyp, Loc),
4636 Make_Function_Call (Loc,
4637 Name => Called_Subprogram,
4638 Parameter_Associations => Parameter_List)));
4640 Append_To (After_Statements,
4641 Make_Attribute_Reference (Loc,
4642 Prefix => New_Occurrence_Of (Etyp, Loc),
4643 Attribute_Name => Name_Output,
4644 Expressions => New_List (
4645 Make_Selected_Component (Loc,
4646 Prefix => Request_Parameter,
4647 Selector_Name => Name_Result),
4648 New_Occurrence_Of (Result, Loc))));
4651 Append_To (Statements,
4652 Make_Block_Statement (Loc,
4653 Declarations => Inner_Decls,
4654 Handled_Statement_Sequence =>
4655 Make_Handled_Sequence_Of_Statements (Loc,
4656 Statements => After_Statements)));
4659 -- The remote subprogram is a procedure. We do not need any inner
4660 -- block in this case.
4662 if Dynamically_Asynchronous then
4664 Make_Object_Declaration (Loc,
4665 Defining_Identifier => Dynamic_Async,
4666 Object_Definition =>
4667 New_Occurrence_Of (Standard_Boolean, Loc)));
4669 Append_To (Statements,
4670 Make_Attribute_Reference (Loc,
4671 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4672 Attribute_Name => Name_Read,
4673 Expressions => New_List (
4674 Make_Selected_Component (Loc,
4675 Prefix => Request_Parameter,
4676 Selector_Name => Name_Params),
4677 New_Occurrence_Of (Dynamic_Async, Loc))));
4680 Append_To (Statements,
4681 Make_Procedure_Call_Statement (Loc,
4682 Name => Called_Subprogram,
4683 Parameter_Associations => Parameter_List));
4685 Append_List_To (Statements, After_Statements);
4688 if Asynchronous and then not Dynamically_Asynchronous then
4690 -- For an asynchronous procedure, add a null exception handler
4692 Excep_Handlers := New_List (
4693 Make_Exception_Handler (Loc,
4694 Exception_Choices => New_List (Make_Others_Choice (Loc)),
4695 Statements => New_List (Make_Null_Statement (Loc))));
4698 -- In the other cases, if an exception is raised, then the
4699 -- exception occurrence is copied into the output stream and
4700 -- no other output parameter is written.
4703 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4705 Excep_Code := New_List (
4706 Make_Attribute_Reference (Loc,
4708 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4709 Attribute_Name => Name_Write,
4710 Expressions => New_List (
4711 Make_Selected_Component (Loc,
4712 Prefix => Request_Parameter,
4713 Selector_Name => Name_Result),
4714 New_Occurrence_Of (Excep_Choice, Loc))));
4716 if Dynamically_Asynchronous then
4717 Excep_Code := New_List (
4718 Make_Implicit_If_Statement (Vis_Decl,
4719 Condition => Make_Op_Not (Loc,
4720 New_Occurrence_Of (Dynamic_Async, Loc)),
4721 Then_Statements => Excep_Code));
4724 Excep_Handlers := New_List (
4725 Make_Exception_Handler (Loc,
4726 Choice_Parameter => Excep_Choice,
4727 Exception_Choices => New_List (Make_Others_Choice (Loc)),
4728 Statements => Excep_Code));
4733 Make_Procedure_Specification (Loc,
4734 Defining_Unit_Name =>
4735 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
4737 Parameter_Specifications => New_List (
4738 Make_Parameter_Specification (Loc,
4739 Defining_Identifier => Request_Parameter,
4741 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
4744 Make_Subprogram_Body (Loc,
4745 Specification => Subp_Spec,
4746 Declarations => Decls,
4747 Handled_Statement_Sequence =>
4748 Make_Handled_Sequence_Of_Statements (Loc,
4749 Statements => Statements,
4750 Exception_Handlers => Excep_Handlers));
4751 end Build_Subprogram_Receiving_Stubs;
4757 function Result return Node_Id is
4759 return Make_Identifier (Loc, Name_V);
4762 ----------------------
4763 -- Stream_Parameter --
4764 ----------------------
4766 function Stream_Parameter return Node_Id is
4768 return Make_Identifier (Loc, Name_S);
4769 end Stream_Parameter;
4773 -----------------------------
4774 -- Make_Selected_Component --
4775 -----------------------------
4777 function Make_Selected_Component
4780 Selector_Name : Name_Id) return Node_Id
4783 return Make_Selected_Component (Loc,
4784 Prefix => New_Occurrence_Of (Prefix, Loc),
4785 Selector_Name => Make_Identifier (Loc, Selector_Name));
4786 end Make_Selected_Component;
4792 function Get_PCS_Name return PCS_Names is
4793 PCS_Name : constant PCS_Names :=
4794 Chars (Entity (Expression
4795 (Parent (RTE (RE_DSA_Implementation)))));
4800 -----------------------
4801 -- Get_Subprogram_Id --
4802 -----------------------
4804 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
4806 return Get_Subprogram_Ids (Def).Str_Identifier;
4807 end Get_Subprogram_Id;
4809 -----------------------
4810 -- Get_Subprogram_Id --
4811 -----------------------
4813 function Get_Subprogram_Id (Def : Entity_Id) return Int is
4815 return Get_Subprogram_Ids (Def).Int_Identifier;
4816 end Get_Subprogram_Id;
4818 ------------------------
4819 -- Get_Subprogram_Ids --
4820 ------------------------
4822 function Get_Subprogram_Ids
4823 (Def : Entity_Id) return Subprogram_Identifiers
4825 Result : Subprogram_Identifiers :=
4826 Subprogram_Identifier_Table.Get (Def);
4828 Current_Declaration : Node_Id;
4829 Current_Subp : Entity_Id;
4830 Current_Subp_Str : String_Id;
4831 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
4834 if Result.Str_Identifier = No_String then
4836 -- We are looking up this subprogram's identifier outside of the
4837 -- context of generating calling or receiving stubs. Hence we are
4838 -- processing an 'Access attribute_reference for an RCI subprogram,
4839 -- for the purpose of obtaining a RAS value.
4842 (Is_Remote_Call_Interface (Scope (Def))
4844 (Nkind (Parent (Def)) = N_Procedure_Specification
4846 Nkind (Parent (Def)) = N_Function_Specification));
4848 Current_Declaration :=
4849 First (Visible_Declarations
4850 (Package_Specification_Of_Scope (Scope (Def))));
4851 while Present (Current_Declaration) loop
4852 if Nkind (Current_Declaration) = N_Subprogram_Declaration
4853 and then Comes_From_Source (Current_Declaration)
4855 Current_Subp := Defining_Unit_Name (Specification (
4856 Current_Declaration));
4857 Assign_Subprogram_Identifier
4858 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
4860 if Current_Subp = Def then
4861 Result := (Current_Subp_Str, Current_Subp_Number);
4864 Current_Subp_Number := Current_Subp_Number + 1;
4867 Next (Current_Declaration);
4871 pragma Assert (Result.Str_Identifier /= No_String);
4873 end Get_Subprogram_Ids;
4879 function Hash (F : Entity_Id) return Hash_Index is
4881 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
4884 function Hash (F : Name_Id) return Hash_Index is
4886 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
4889 --------------------------
4890 -- Input_With_Tag_Check --
4891 --------------------------
4893 function Input_With_Tag_Check
4895 Var_Type : Entity_Id;
4896 Stream : Node_Id) return Node_Id
4900 Make_Subprogram_Body (Loc,
4901 Specification => Make_Function_Specification (Loc,
4902 Defining_Unit_Name =>
4903 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
4904 Subtype_Mark => New_Occurrence_Of (Var_Type, Loc)),
4905 Declarations => No_List,
4906 Handled_Statement_Sequence =>
4907 Make_Handled_Sequence_Of_Statements (Loc, New_List (
4908 Make_Tag_Check (Loc,
4909 Make_Return_Statement (Loc,
4910 Make_Attribute_Reference (Loc,
4911 Prefix => New_Occurrence_Of (Var_Type, Loc),
4912 Attribute_Name => Name_Input,
4914 New_List (Stream)))))));
4915 end Input_With_Tag_Check;
4917 --------------------------------
4918 -- Is_RACW_Controlling_Formal --
4919 --------------------------------
4921 function Is_RACW_Controlling_Formal
4922 (Parameter : Node_Id;
4923 Stub_Type : Entity_Id) return Boolean
4928 -- If the kind of the parameter is E_Void, then it is not a
4929 -- controlling formal (this can happen in the context of RAS).
4931 if Ekind (Defining_Identifier (Parameter)) = E_Void then
4935 -- If the parameter is not a controlling formal, then it cannot
4936 -- be possibly a RACW_Controlling_Formal.
4938 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
4942 Typ := Parameter_Type (Parameter);
4943 return (Nkind (Typ) = N_Access_Definition
4944 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
4945 or else Etype (Typ) = Stub_Type;
4946 end Is_RACW_Controlling_Formal;
4948 --------------------
4949 -- Make_Tag_Check --
4950 --------------------
4952 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
4953 Occ : constant Entity_Id :=
4954 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4957 return Make_Block_Statement (Loc,
4958 Handled_Statement_Sequence =>
4959 Make_Handled_Sequence_Of_Statements (Loc,
4960 Statements => New_List (N),
4962 Exception_Handlers => New_List (
4963 Make_Exception_Handler (Loc,
4964 Choice_Parameter => Occ,
4966 Exception_Choices =>
4967 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
4970 New_List (Make_Procedure_Call_Statement (Loc,
4972 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
4973 New_List (New_Occurrence_Of (Occ, Loc))))))));
4976 ----------------------------
4977 -- Need_Extra_Constrained --
4978 ----------------------------
4980 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
4981 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
4983 return Out_Present (Parameter)
4984 and then Has_Discriminants (Etyp)
4985 and then not Is_Constrained (Etyp)
4986 and then not Is_Indefinite_Subtype (Etyp);
4987 end Need_Extra_Constrained;
4989 ------------------------------------
4990 -- Pack_Entity_Into_Stream_Access --
4991 ------------------------------------
4993 function Pack_Entity_Into_Stream_Access
4997 Etyp : Entity_Id := Empty) return Node_Id
5002 if Present (Etyp) then
5005 Typ := Etype (Object);
5009 Pack_Node_Into_Stream_Access (Loc,
5011 Object => New_Occurrence_Of (Object, Loc),
5013 end Pack_Entity_Into_Stream_Access;
5015 ---------------------------
5016 -- Pack_Node_Into_Stream --
5017 ---------------------------
5019 function Pack_Node_Into_Stream
5023 Etyp : Entity_Id) return Node_Id
5025 Write_Attribute : Name_Id := Name_Write;
5028 if not Is_Constrained (Etyp) then
5029 Write_Attribute := Name_Output;
5033 Make_Attribute_Reference (Loc,
5034 Prefix => New_Occurrence_Of (Etyp, Loc),
5035 Attribute_Name => Write_Attribute,
5036 Expressions => New_List (
5037 Make_Attribute_Reference (Loc,
5038 Prefix => New_Occurrence_Of (Stream, Loc),
5039 Attribute_Name => Name_Access),
5041 end Pack_Node_Into_Stream;
5043 ----------------------------------
5044 -- Pack_Node_Into_Stream_Access --
5045 ----------------------------------
5047 function Pack_Node_Into_Stream_Access
5051 Etyp : Entity_Id) return Node_Id
5053 Write_Attribute : Name_Id := Name_Write;
5056 if not Is_Constrained (Etyp) then
5057 Write_Attribute := Name_Output;
5061 Make_Attribute_Reference (Loc,
5062 Prefix => New_Occurrence_Of (Etyp, Loc),
5063 Attribute_Name => Write_Attribute,
5064 Expressions => New_List (
5067 end Pack_Node_Into_Stream_Access;
5069 ---------------------
5070 -- PolyORB_Support --
5071 ---------------------
5073 package body PolyORB_Support is
5075 -- Local subprograms
5077 procedure Add_RACW_Read_Attribute
5078 (RACW_Type : Entity_Id;
5079 Stub_Type : Entity_Id;
5080 Stub_Type_Access : Entity_Id;
5081 Declarations : List_Id);
5082 -- Add Read attribute in Decls for the RACW type. The Read attribute
5083 -- is added right after the RACW_Type declaration while the body is
5084 -- inserted after Declarations.
5086 procedure Add_RACW_Write_Attribute
5087 (RACW_Type : Entity_Id;
5088 Stub_Type : Entity_Id;
5089 Stub_Type_Access : Entity_Id;
5090 Declarations : List_Id);
5091 -- Same thing for the Write attribute
5093 procedure Add_RACW_From_Any
5094 (RACW_Type : Entity_Id;
5095 Stub_Type : Entity_Id;
5096 Stub_Type_Access : Entity_Id;
5097 Declarations : List_Id);
5098 -- Add the From_Any TSS for this RACW type
5100 procedure Add_RACW_To_Any
5101 (Designated_Type : Entity_Id;
5102 RACW_Type : Entity_Id;
5103 Stub_Type : Entity_Id;
5104 Stub_Type_Access : Entity_Id;
5105 Declarations : List_Id);
5106 -- Add the To_Any TSS for this RACW type
5108 procedure Add_RACW_TypeCode
5109 (Designated_Type : Entity_Id;
5110 RACW_Type : Entity_Id;
5111 Declarations : List_Id);
5112 -- Add the TypeCode TSS for this RACW type
5114 procedure Add_RAS_From_Any
5115 (RAS_Type : Entity_Id;
5116 Declarations : List_Id);
5117 -- Add the From_Any TSS for this RAS type
5119 procedure Add_RAS_To_Any
5120 (RAS_Type : Entity_Id;
5121 Declarations : List_Id);
5122 -- Add the To_Any TSS for this RAS type
5124 procedure Add_RAS_TypeCode
5125 (RAS_Type : Entity_Id;
5126 Declarations : List_Id);
5127 -- Add the TypeCode TSS for this RAS type
5129 procedure Add_RAS_Access_TSS (N : Node_Id);
5130 -- Add a subprogram body for RAS Access TSS
5132 -------------------------------------
5133 -- Add_Obj_RPC_Receiver_Completion --
5134 -------------------------------------
5136 procedure Add_Obj_RPC_Receiver_Completion
5139 RPC_Receiver : Entity_Id;
5140 Stub_Elements : Stub_Structure)
5142 Desig : constant Entity_Id :=
5143 Etype (Designated_Type (Stub_Elements.RACW_Type));
5146 Make_Procedure_Call_Statement (Loc,
5149 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5151 Parameter_Associations => New_List (
5155 Make_String_Literal (Loc,
5156 Full_Qualified_Name (Desig)),
5160 Make_Attribute_Reference (Loc,
5163 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5169 Make_Attribute_Reference (Loc,
5172 Defining_Identifier (
5173 Stub_Elements.RPC_Receiver_Decl), Loc),
5176 end Add_Obj_RPC_Receiver_Completion;
5178 -----------------------
5179 -- Add_RACW_Features --
5180 -----------------------
5182 procedure Add_RACW_Features
5183 (RACW_Type : Entity_Id;
5185 Stub_Type : Entity_Id;
5186 Stub_Type_Access : Entity_Id;
5187 RPC_Receiver_Decl : Node_Id;
5188 Declarations : List_Id)
5190 pragma Warnings (Off);
5191 pragma Unreferenced (RPC_Receiver_Decl);
5192 pragma Warnings (On);
5196 (RACW_Type => RACW_Type,
5197 Stub_Type => Stub_Type,
5198 Stub_Type_Access => Stub_Type_Access,
5199 Declarations => Declarations);
5202 (Designated_Type => Desig,
5203 RACW_Type => RACW_Type,
5204 Stub_Type => Stub_Type,
5205 Stub_Type_Access => Stub_Type_Access,
5206 Declarations => Declarations);
5208 -- In the PolyORB case, the RACW 'Read and 'Write attributes
5209 -- are implemented in terms of the From_Any and To_Any TSSs,
5210 -- so these TSSs must be expanded before 'Read and 'Write.
5212 Add_RACW_Write_Attribute
5213 (RACW_Type => RACW_Type,
5214 Stub_Type => Stub_Type,
5215 Stub_Type_Access => Stub_Type_Access,
5216 Declarations => Declarations);
5218 Add_RACW_Read_Attribute
5219 (RACW_Type => RACW_Type,
5220 Stub_Type => Stub_Type,
5221 Stub_Type_Access => Stub_Type_Access,
5222 Declarations => Declarations);
5225 (Designated_Type => Desig,
5226 RACW_Type => RACW_Type,
5227 Declarations => Declarations);
5228 end Add_RACW_Features;
5230 -----------------------
5231 -- Add_RACW_From_Any --
5232 -----------------------
5234 procedure Add_RACW_From_Any
5235 (RACW_Type : Entity_Id;
5236 Stub_Type : Entity_Id;
5237 Stub_Type_Access : Entity_Id;
5238 Declarations : List_Id)
5240 Loc : constant Source_Ptr := Sloc (RACW_Type);
5241 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5243 Fnam : constant Entity_Id :=
5244 Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
5246 Func_Spec : Node_Id;
5247 Func_Decl : Node_Id;
5248 Func_Body : Node_Id;
5251 Statements : List_Id;
5252 Stub_Statements : List_Id;
5253 Local_Statements : List_Id;
5254 -- Various parts of the subprogram
5256 Any_Parameter : constant Entity_Id :=
5257 Make_Defining_Identifier (Loc, Name_A);
5258 Reference : constant Entity_Id :=
5259 Make_Defining_Identifier
5260 (Loc, New_Internal_Name ('R'));
5261 Is_Local : constant Entity_Id :=
5262 Make_Defining_Identifier
5263 (Loc, New_Internal_Name ('L'));
5264 Addr : constant Entity_Id :=
5265 Make_Defining_Identifier
5266 (Loc, New_Internal_Name ('A'));
5267 Local_Stub : constant Entity_Id :=
5268 Make_Defining_Identifier
5269 (Loc, New_Internal_Name ('L'));
5270 Stubbed_Result : constant Entity_Id :=
5271 Make_Defining_Identifier
5272 (Loc, New_Internal_Name ('S'));
5274 Stub_Condition : Node_Id;
5275 -- An expression that determines whether we create a stub for the
5276 -- newly-unpacked RACW. Normally we create a stub only for remote
5277 -- objects, but in the case of an RACW used to implement a RAS,
5278 -- we also create a stub for local subprograms if a pragma
5279 -- All_Calls_Remote applies.
5281 Asynchronous_Flag : constant Entity_Id :=
5282 Asynchronous_Flags_Table.Get (RACW_Type);
5283 -- The flag object declared in Add_RACW_Asynchronous_Flag
5286 -- Object declarations
5289 Make_Object_Declaration (Loc,
5290 Defining_Identifier =>
5292 Object_Definition =>
5293 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5295 Make_Function_Call (Loc,
5297 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5298 Parameter_Associations => New_List (
5299 New_Occurrence_Of (Any_Parameter, Loc)))),
5301 Make_Object_Declaration (Loc,
5302 Defining_Identifier => Local_Stub,
5303 Aliased_Present => True,
5304 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
5306 Make_Object_Declaration (Loc,
5307 Defining_Identifier => Stubbed_Result,
5308 Object_Definition =>
5309 New_Occurrence_Of (Stub_Type_Access, Loc),
5311 Make_Attribute_Reference (Loc,
5313 New_Occurrence_Of (Local_Stub, Loc),
5315 Name_Unchecked_Access)),
5317 Make_Object_Declaration (Loc,
5318 Defining_Identifier => Is_Local,
5319 Object_Definition =>
5320 New_Occurrence_Of (Standard_Boolean, Loc)),
5322 Make_Object_Declaration (Loc,
5323 Defining_Identifier => Addr,
5324 Object_Definition =>
5325 New_Occurrence_Of (RTE (RE_Address), Loc)));
5327 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5329 Set_Etype (Stubbed_Result, Stub_Type_Access);
5331 -- If the ref Is_Nil, return a null pointer
5333 Statements := New_List (
5334 Make_Implicit_If_Statement (RACW_Type,
5336 Make_Function_Call (Loc,
5338 New_Occurrence_Of (RTE (RE_Is_Nil), Loc),
5339 Parameter_Associations => New_List (
5340 New_Occurrence_Of (Reference, Loc))),
5341 Then_Statements => New_List (
5342 Make_Return_Statement (Loc,
5344 Make_Null (Loc)))));
5346 Append_To (Statements,
5347 Make_Procedure_Call_Statement (Loc,
5349 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
5350 Parameter_Associations => New_List (
5351 New_Occurrence_Of (Reference, Loc),
5352 New_Occurrence_Of (Is_Local, Loc),
5353 New_Occurrence_Of (Addr, Loc))));
5355 -- If the object is located on another partition, then a stub object
5356 -- will be created with all the information needed to rebuild the
5357 -- real object at the other end. This stanza is always used in the
5358 -- case of RAS types, for which a stub is required even for local
5361 Stub_Statements := New_List (
5362 Make_Assignment_Statement (Loc,
5363 Name => Make_Selected_Component (Loc,
5364 Prefix => Stubbed_Result,
5365 Selector_Name => Name_Target),
5367 Make_Function_Call (Loc,
5369 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
5370 Parameter_Associations => New_List (
5371 New_Occurrence_Of (Reference, Loc)))),
5373 Make_Procedure_Call_Statement (Loc,
5375 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
5376 Parameter_Associations => New_List (
5377 Make_Selected_Component (Loc,
5378 Prefix => Stubbed_Result,
5379 Selector_Name => Name_Target))),
5381 Make_Assignment_Statement (Loc,
5382 Name => Make_Selected_Component (Loc,
5383 Prefix => Stubbed_Result,
5384 Selector_Name => Name_Asynchronous),
5386 New_Occurrence_Of (Asynchronous_Flag, Loc)));
5388 -- ??? Issue with asynchronous calls here: the Asynchronous
5389 -- flag is set on the stub type if, and only if, the RACW type
5390 -- has a pragma Asynchronous. This is incorrect for RACWs that
5391 -- implement RAS types, because in that case the /designated
5392 -- subprogram/ (not the type) might be asynchronous, and
5393 -- that causes the stub to need to be asynchronous too.
5394 -- A solution is to transport a RAS as a struct containing
5395 -- a RACW and an asynchronous flag, and to properly alter
5396 -- the Asynchronous component in the stub type in the RAS's
5399 Append_List_To (Stub_Statements,
5400 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
5402 -- Distinguish between the local and remote cases, and execute the
5403 -- appropriate piece of code.
5405 Stub_Condition := New_Occurrence_Of (Is_Local, Loc);
5408 Stub_Condition := Make_And_Then (Loc,
5412 Make_Selected_Component (Loc,
5414 Unchecked_Convert_To (
5415 RTE (RE_RAS_Proxy_Type_Access),
5416 New_Occurrence_Of (Addr, Loc)),
5418 Make_Identifier (Loc,
5419 Name_All_Calls_Remote)));
5422 Local_Statements := New_List (
5423 Make_Return_Statement (Loc,
5425 Unchecked_Convert_To (RACW_Type,
5426 New_Occurrence_Of (Addr, Loc))));
5428 Append_To (Statements,
5429 Make_Implicit_If_Statement (RACW_Type,
5432 Then_Statements => Local_Statements,
5433 Else_Statements => Stub_Statements));
5435 Append_To (Statements,
5436 Make_Return_Statement (Loc,
5437 Expression => Unchecked_Convert_To (RACW_Type,
5438 New_Occurrence_Of (Stubbed_Result, Loc))));
5441 Make_Function_Specification (Loc,
5442 Defining_Unit_Name =>
5444 Parameter_Specifications => New_List (
5445 Make_Parameter_Specification (Loc,
5446 Defining_Identifier =>
5449 New_Occurrence_Of (RTE (RE_Any), Loc))),
5450 Subtype_Mark => New_Occurrence_Of (RACW_Type, Loc));
5452 -- NOTE: The usage occurrences of RACW_Parameter must
5453 -- refer to the entity in the declaration spec, not those
5454 -- of the body spec.
5456 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5459 Make_Subprogram_Body (Loc,
5461 Copy_Specification (Loc, Func_Spec),
5462 Declarations => Decls,
5463 Handled_Statement_Sequence =>
5464 Make_Handled_Sequence_Of_Statements (Loc,
5465 Statements => Statements));
5467 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5468 Append_To (Declarations, Func_Body);
5470 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5471 end Add_RACW_From_Any;
5473 -----------------------------
5474 -- Add_RACW_Read_Attribute --
5475 -----------------------------
5477 procedure Add_RACW_Read_Attribute
5478 (RACW_Type : Entity_Id;
5479 Stub_Type : Entity_Id;
5480 Stub_Type_Access : Entity_Id;
5481 Declarations : List_Id)
5483 pragma Warnings (Off);
5484 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5485 pragma Warnings (On);
5486 Loc : constant Source_Ptr := Sloc (RACW_Type);
5488 Proc_Decl : Node_Id;
5489 Attr_Decl : Node_Id;
5491 Body_Node : Node_Id;
5494 Statements : List_Id;
5495 -- Various parts of the procedure
5497 Procedure_Name : constant Name_Id :=
5498 New_Internal_Name ('R');
5499 Source_Ref : constant Entity_Id :=
5500 Make_Defining_Identifier
5501 (Loc, New_Internal_Name ('R'));
5502 Asynchronous_Flag : constant Entity_Id :=
5503 Asynchronous_Flags_Table.Get (RACW_Type);
5504 pragma Assert (Present (Asynchronous_Flag));
5506 function Stream_Parameter return Node_Id;
5507 function Result return Node_Id;
5508 -- Functions to create occurrences of the formal parameter names
5514 function Result return Node_Id is
5516 return Make_Identifier (Loc, Name_V);
5519 ----------------------
5520 -- Stream_Parameter --
5521 ----------------------
5523 function Stream_Parameter return Node_Id is
5525 return Make_Identifier (Loc, Name_S);
5526 end Stream_Parameter;
5528 -- Start of processing for Add_RACW_Read_Attribute
5531 -- Generate object declarations
5534 Make_Object_Declaration (Loc,
5535 Defining_Identifier => Source_Ref,
5536 Object_Definition =>
5537 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5539 Statements := New_List (
5540 Make_Attribute_Reference (Loc,
5542 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5543 Attribute_Name => Name_Read,
5544 Expressions => New_List (
5546 New_Occurrence_Of (Source_Ref, Loc))),
5547 Make_Assignment_Statement (Loc,
5551 PolyORB_Support.Helpers.Build_From_Any_Call (
5553 Make_Function_Call (Loc,
5555 New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5556 Parameter_Associations => New_List (
5557 New_Occurrence_Of (Source_Ref, Loc))),
5560 Build_Stream_Procedure
5561 (Loc, RACW_Type, Body_Node,
5562 Make_Defining_Identifier (Loc, Procedure_Name),
5563 Statements, Outp => True);
5564 Set_Declarations (Body_Node, Decls);
5566 Proc_Decl := Make_Subprogram_Declaration (Loc,
5567 Copy_Specification (Loc, Specification (Body_Node)));
5570 Make_Attribute_Definition_Clause (Loc,
5571 Name => New_Occurrence_Of (RACW_Type, Loc),
5575 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5577 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5578 Insert_After (Proc_Decl, Attr_Decl);
5579 Append_To (Declarations, Body_Node);
5580 end Add_RACW_Read_Attribute;
5582 ---------------------
5583 -- Add_RACW_To_Any --
5584 ---------------------
5586 procedure Add_RACW_To_Any
5587 (Designated_Type : Entity_Id;
5588 RACW_Type : Entity_Id;
5589 Stub_Type : Entity_Id;
5590 Stub_Type_Access : Entity_Id;
5591 Declarations : List_Id)
5593 Loc : constant Source_Ptr := Sloc (RACW_Type);
5595 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5599 Stub_Elements : constant Stub_Structure :=
5600 Stubs_Table.Get (Designated_Type);
5601 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5603 Func_Spec : Node_Id;
5604 Func_Decl : Node_Id;
5605 Func_Body : Node_Id;
5608 Statements : List_Id;
5609 Null_Statements : List_Id;
5610 Local_Statements : List_Id := No_List;
5611 Stub_Statements : List_Id;
5613 -- Various parts of the subprogram
5615 RACW_Parameter : constant Entity_Id
5616 := Make_Defining_Identifier (Loc, Name_R);
5618 Reference : constant Entity_Id :=
5619 Make_Defining_Identifier
5620 (Loc, New_Internal_Name ('R'));
5621 Any : constant Entity_Id :=
5622 Make_Defining_Identifier
5623 (Loc, New_Internal_Name ('A'));
5626 -- Object declarations
5629 Make_Object_Declaration (Loc,
5630 Defining_Identifier =>
5632 Object_Definition =>
5633 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
5634 Make_Object_Declaration (Loc,
5635 Defining_Identifier =>
5637 Object_Definition =>
5638 New_Occurrence_Of (RTE (RE_Any), Loc)));
5640 -- If the object is null, nothing to do (Reference is already
5643 Null_Statements := New_List (Make_Null_Statement (Loc));
5647 -- If the object is a RAS designating a local subprogram,
5648 -- we already have a target reference.
5650 Local_Statements := New_List (
5651 Make_Procedure_Call_Statement (Loc,
5653 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
5654 Parameter_Associations => New_List (
5655 New_Occurrence_Of (Reference, Loc),
5656 Make_Selected_Component (Loc,
5658 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
5659 New_Occurrence_Of (RACW_Parameter, Loc)),
5660 Selector_Name => Make_Identifier (Loc, Name_Target)))));
5663 -- If the object is a local RACW object, use Get_Reference now
5664 -- to obtain a reference.
5666 Local_Statements := New_List (
5667 Make_Procedure_Call_Statement (Loc,
5669 New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5670 Parameter_Associations => New_List (
5671 Unchecked_Convert_To (
5673 New_Occurrence_Of (RACW_Parameter, Loc)),
5674 Make_String_Literal (Loc,
5675 Full_Qualified_Name (Designated_Type)),
5676 Make_Attribute_Reference (Loc,
5679 Defining_Identifier (
5680 Stub_Elements.RPC_Receiver_Decl), Loc),
5683 New_Occurrence_Of (Reference, Loc))));
5686 -- If the object is located on another partition, use the target
5689 Stub_Statements := New_List (
5690 Make_Procedure_Call_Statement (Loc,
5692 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
5693 Parameter_Associations => New_List (
5694 New_Occurrence_Of (Reference, Loc),
5695 Make_Selected_Component (Loc,
5696 Prefix => Unchecked_Convert_To (Stub_Type_Access,
5697 New_Occurrence_Of (RACW_Parameter, Loc)),
5699 Make_Identifier (Loc, Name_Target)))));
5701 -- Distinguish between the null, local and remote cases,
5702 -- and execute the appropriate piece of code.
5705 Make_Implicit_If_Statement (RACW_Type,
5708 Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc),
5709 Right_Opnd => Make_Null (Loc)),
5710 Then_Statements => Null_Statements,
5711 Elsif_Parts => New_List (
5712 Make_Elsif_Part (Loc,
5716 Make_Attribute_Reference (Loc,
5718 New_Occurrence_Of (RACW_Parameter, Loc),
5719 Attribute_Name => Name_Tag),
5721 Make_Attribute_Reference (Loc,
5722 Prefix => New_Occurrence_Of (Stub_Type, Loc),
5723 Attribute_Name => Name_Tag)),
5724 Then_Statements => Local_Statements)),
5725 Else_Statements => Stub_Statements);
5727 Statements := New_List (
5729 Make_Assignment_Statement (Loc,
5731 New_Occurrence_Of (Any, Loc),
5733 Make_Function_Call (Loc,
5734 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5735 Parameter_Associations => New_List (
5736 New_Occurrence_Of (Reference, Loc)))),
5737 Make_Procedure_Call_Statement (Loc,
5739 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5740 Parameter_Associations => New_List (
5741 New_Occurrence_Of (Any, Loc),
5742 Make_Selected_Component (Loc,
5744 Defining_Identifier (
5745 Stub_Elements.RPC_Receiver_Decl),
5746 Selector_Name => Name_Obj_TypeCode))),
5747 Make_Return_Statement (Loc,
5749 New_Occurrence_Of (Any, Loc)));
5751 Fnam := Make_Defining_Identifier (
5752 Loc, New_Internal_Name ('T'));
5755 Make_Function_Specification (Loc,
5756 Defining_Unit_Name =>
5758 Parameter_Specifications => New_List (
5759 Make_Parameter_Specification (Loc,
5760 Defining_Identifier =>
5763 New_Occurrence_Of (RACW_Type, Loc))),
5764 Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), Loc));
5766 -- NOTE: The usage occurrences of RACW_Parameter must
5767 -- refer to the entity in the declaration spec, not in
5770 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5773 Make_Subprogram_Body (Loc,
5775 Copy_Specification (Loc, Func_Spec),
5776 Declarations => Decls,
5777 Handled_Statement_Sequence =>
5778 Make_Handled_Sequence_Of_Statements (Loc,
5779 Statements => Statements));
5781 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5782 Append_To (Declarations, Func_Body);
5784 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5785 end Add_RACW_To_Any;
5787 -----------------------
5788 -- Add_RACW_TypeCode --
5789 -----------------------
5791 procedure Add_RACW_TypeCode
5792 (Designated_Type : Entity_Id;
5793 RACW_Type : Entity_Id;
5794 Declarations : List_Id)
5796 Loc : constant Source_Ptr := Sloc (RACW_Type);
5800 Stub_Elements : constant Stub_Structure :=
5801 Stubs_Table.Get (Designated_Type);
5802 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5804 Func_Spec : Node_Id;
5805 Func_Decl : Node_Id;
5806 Func_Body : Node_Id;
5808 RACW_Parameter : constant Entity_Id :=
5809 Make_Defining_Identifier (Loc, Name_R);
5813 Make_Defining_Identifier (Loc,
5814 Chars => New_Internal_Name ('T'));
5816 -- The spec for this subprogram has a dummy 'access RACW'
5817 -- argument, which serves only for overloading purposes.
5820 Make_Function_Specification (Loc,
5821 Defining_Unit_Name =>
5823 Parameter_Specifications => New_List (
5824 Make_Parameter_Specification (Loc,
5825 Defining_Identifier =>
5828 Make_Access_Definition (Loc,
5830 New_Occurrence_Of (RACW_Type, Loc)))),
5831 Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
5833 -- NOTE: The usage occurrences of RACW_Parameter must
5834 -- refer to the entity in the declaration spec, not those
5835 -- of the body spec.
5837 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5840 Make_Subprogram_Body (Loc,
5842 Copy_Specification (Loc, Func_Spec),
5843 Declarations => Empty_List,
5844 Handled_Statement_Sequence =>
5845 Make_Handled_Sequence_Of_Statements (Loc,
5846 Statements => New_List (
5847 Make_Return_Statement (Loc,
5849 Make_Selected_Component (Loc,
5851 Defining_Identifier (
5852 Stub_Elements.RPC_Receiver_Decl),
5853 Selector_Name => Name_Obj_TypeCode)))));
5855 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5856 Append_To (Declarations, Func_Body);
5858 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
5859 end Add_RACW_TypeCode;
5861 ------------------------------
5862 -- Add_RACW_Write_Attribute --
5863 ------------------------------
5865 procedure Add_RACW_Write_Attribute
5866 (RACW_Type : Entity_Id;
5867 Stub_Type : Entity_Id;
5868 Stub_Type_Access : Entity_Id;
5869 Declarations : List_Id)
5871 Loc : constant Source_Ptr := Sloc (RACW_Type);
5872 pragma Warnings (Off);
5873 pragma Unreferenced (
5877 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5878 pragma Unreferenced (Is_RAS);
5879 pragma Warnings (On);
5881 Body_Node : Node_Id;
5882 Proc_Decl : Node_Id;
5883 Attr_Decl : Node_Id;
5885 Statements : List_Id;
5886 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
5888 function Stream_Parameter return Node_Id;
5889 function Object return Node_Id;
5890 -- Functions to create occurrences of the formal parameter names
5896 function Object return Node_Id is
5897 Object_Ref : constant Node_Id :=
5898 Make_Identifier (Loc, Name_V);
5901 -- Etype must be set for Build_To_Any_Call
5903 Set_Etype (Object_Ref, RACW_Type);
5908 ----------------------
5909 -- Stream_Parameter --
5910 ----------------------
5912 function Stream_Parameter return Node_Id is
5914 return Make_Identifier (Loc, Name_S);
5915 end Stream_Parameter;
5917 -- Start of processing for Add_RACW_Write_Attribute
5920 Statements := New_List (
5921 Pack_Node_Into_Stream_Access (Loc,
5922 Stream => Stream_Parameter,
5924 Make_Function_Call (Loc,
5926 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5927 Parameter_Associations => New_List (
5928 PolyORB_Support.Helpers.Build_To_Any_Call
5929 (Object, Declarations))),
5930 Etyp => RTE (RE_Object_Ref)));
5932 Build_Stream_Procedure
5933 (Loc, RACW_Type, Body_Node,
5934 Make_Defining_Identifier (Loc, Procedure_Name),
5935 Statements, Outp => False);
5938 Make_Subprogram_Declaration (Loc,
5939 Copy_Specification (Loc, Specification (Body_Node)));
5942 Make_Attribute_Definition_Clause (Loc,
5943 Name => New_Occurrence_Of (RACW_Type, Loc),
5944 Chars => Name_Write,
5947 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5949 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5950 Insert_After (Proc_Decl, Attr_Decl);
5951 Append_To (Declarations, Body_Node);
5952 end Add_RACW_Write_Attribute;
5954 -----------------------
5955 -- Add_RAST_Features --
5956 -----------------------
5958 procedure Add_RAST_Features
5959 (Vis_Decl : Node_Id;
5960 RAS_Type : Entity_Id;
5964 Add_RAS_Access_TSS (Vis_Decl);
5966 Add_RAS_From_Any (RAS_Type, Decls);
5967 Add_RAS_TypeCode (RAS_Type, Decls);
5969 -- To_Any uses TypeCode, and therefore needs to be generated last
5971 Add_RAS_To_Any (RAS_Type, Decls);
5972 end Add_RAST_Features;
5974 ------------------------
5975 -- Add_RAS_Access_TSS --
5976 ------------------------
5978 procedure Add_RAS_Access_TSS (N : Node_Id) is
5979 Loc : constant Source_Ptr := Sloc (N);
5981 Ras_Type : constant Entity_Id := Defining_Identifier (N);
5982 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
5983 -- Ras_Type is the access to subprogram type; Fat_Type is the
5984 -- corresponding record type.
5986 RACW_Type : constant Entity_Id :=
5987 Underlying_RACW_Type (Ras_Type);
5988 Desig : constant Entity_Id :=
5989 Etype (Designated_Type (RACW_Type));
5991 Stub_Elements : constant Stub_Structure :=
5992 Stubs_Table.Get (Desig);
5993 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5995 Proc : constant Entity_Id :=
5996 Make_Defining_Identifier (Loc,
5997 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
5999 Proc_Spec : Node_Id;
6001 -- Formal parameters
6003 Package_Name : constant Entity_Id :=
6004 Make_Defining_Identifier (Loc,
6009 Subp_Id : constant Entity_Id :=
6010 Make_Defining_Identifier (Loc,
6013 -- Target subprogram
6015 Asynch_P : constant Entity_Id :=
6016 Make_Defining_Identifier (Loc,
6017 Chars => Name_Asynchronous);
6018 -- Is the procedure to which the 'Access applies asynchronous?
6020 All_Calls_Remote : constant Entity_Id :=
6021 Make_Defining_Identifier (Loc,
6022 Chars => Name_All_Calls_Remote);
6023 -- True if an All_Calls_Remote pragma applies to the RCI unit
6024 -- that contains the subprogram.
6026 -- Common local variables
6028 Proc_Decls : List_Id;
6029 Proc_Statements : List_Id;
6031 Subp_Ref : constant Entity_Id :=
6032 Make_Defining_Identifier (Loc, Name_R);
6033 -- Reference that designates the target subprogram (returned
6034 -- by Get_RAS_Info).
6036 Is_Local : constant Entity_Id :=
6037 Make_Defining_Identifier (Loc, Name_L);
6038 Local_Addr : constant Entity_Id :=
6039 Make_Defining_Identifier (Loc, Name_A);
6040 -- For the call to Get_Local_Address
6042 -- Additional local variables for the remote case
6044 Local_Stub : constant Entity_Id :=
6045 Make_Defining_Identifier (Loc,
6046 Chars => New_Internal_Name ('L'));
6048 Stub_Ptr : constant Entity_Id :=
6049 Make_Defining_Identifier (Loc,
6050 Chars => New_Internal_Name ('S'));
6053 (Field_Name : Name_Id;
6054 Value : Node_Id) return Node_Id;
6055 -- Construct an assignment that sets the named component in the
6063 (Field_Name : Name_Id;
6064 Value : Node_Id) return Node_Id
6068 Make_Assignment_Statement (Loc,
6070 Make_Selected_Component (Loc,
6072 Selector_Name => Field_Name),
6073 Expression => Value);
6076 -- Start of processing for Add_RAS_Access_TSS
6079 Proc_Decls := New_List (
6081 -- Common declarations
6083 Make_Object_Declaration (Loc,
6084 Defining_Identifier => Subp_Ref,
6085 Object_Definition =>
6086 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6088 Make_Object_Declaration (Loc,
6089 Defining_Identifier => Is_Local,
6090 Object_Definition =>
6091 New_Occurrence_Of (Standard_Boolean, Loc)),
6093 Make_Object_Declaration (Loc,
6094 Defining_Identifier => Local_Addr,
6095 Object_Definition =>
6096 New_Occurrence_Of (RTE (RE_Address), Loc)),
6098 Make_Object_Declaration (Loc,
6099 Defining_Identifier => Local_Stub,
6100 Aliased_Present => True,
6101 Object_Definition =>
6102 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6104 Make_Object_Declaration (Loc,
6105 Defining_Identifier =>
6107 Object_Definition =>
6108 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6110 Make_Attribute_Reference (Loc,
6111 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6112 Attribute_Name => Name_Unchecked_Access)));
6114 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6115 -- Build_Get_Unique_RP_Call needs this information
6117 -- Get_RAS_Info (Pkg, Subp, R);
6118 -- Obtain a reference to the target subprogram
6120 Proc_Statements := New_List (
6121 Make_Procedure_Call_Statement (Loc,
6123 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6124 Parameter_Associations => New_List (
6125 New_Occurrence_Of (Package_Name, Loc),
6126 New_Occurrence_Of (Subp_Id, Loc),
6127 New_Occurrence_Of (Subp_Ref, Loc))),
6129 -- Get_Local_Address (R, L, A);
6130 -- Determine whether the subprogram is local (L), and if so
6131 -- obtain the local address of its proxy (A).
6133 Make_Procedure_Call_Statement (Loc,
6135 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6136 Parameter_Associations => New_List (
6137 New_Occurrence_Of (Subp_Ref, Loc),
6138 New_Occurrence_Of (Is_Local, Loc),
6139 New_Occurrence_Of (Local_Addr, Loc))));
6141 -- Note: Here we assume that the Fat_Type is a record containing just
6142 -- an access to a proxy or stub object.
6144 Append_To (Proc_Statements,
6148 Make_Implicit_If_Statement (N,
6150 New_Occurrence_Of (Is_Local, Loc),
6152 Then_Statements => New_List (
6154 -- if A.Target = null then
6156 Make_Implicit_If_Statement (N,
6159 Make_Selected_Component (Loc,
6161 Unchecked_Convert_To (
6162 RTE (RE_RAS_Proxy_Type_Access),
6163 New_Occurrence_Of (Local_Addr, Loc)),
6165 Make_Identifier (Loc, Name_Target)),
6168 Then_Statements => New_List (
6170 -- A.Target := Entity_Of (Ref);
6172 Make_Assignment_Statement (Loc,
6174 Make_Selected_Component (Loc,
6176 Unchecked_Convert_To (
6177 RTE (RE_RAS_Proxy_Type_Access),
6178 New_Occurrence_Of (Local_Addr, Loc)),
6180 Make_Identifier (Loc, 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 (A.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 Unchecked_Convert_To (
6197 RTE (RE_RAS_Proxy_Type_Access),
6198 New_Occurrence_Of (Local_Addr, Loc)),
6199 Selector_Name => Make_Identifier (Loc,
6203 -- if not All_Calls_Remote then
6204 -- return Fat_Type!(A);
6207 Make_Implicit_If_Statement (N,
6210 New_Occurrence_Of (All_Calls_Remote, Loc)),
6212 Then_Statements => New_List (
6213 Make_Return_Statement (Loc,
6214 Unchecked_Convert_To (Fat_Type,
6215 New_Occurrence_Of (Local_Addr, Loc))))))));
6217 Append_List_To (Proc_Statements, New_List (
6219 -- Stub.Target := Entity_Of (Ref);
6221 Set_Field (Name_Target,
6222 Make_Function_Call (Loc,
6224 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6225 Parameter_Associations => New_List (
6226 New_Occurrence_Of (Subp_Ref, Loc)))),
6228 -- Inc_Usage (Stub.Target);
6230 Make_Procedure_Call_Statement (Loc,
6232 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6233 Parameter_Associations => New_List (
6234 Make_Selected_Component (Loc,
6236 Selector_Name => Name_Target))),
6238 -- E.4.1(9) A remote call is asynchronous if it is a call to
6239 -- a procedure, or a call through a value of an access-to-procedure
6240 -- type, to which a pragma Asynchronous applies.
6242 -- Parameter Asynch_P is true when the procedure is asynchronous;
6243 -- Expression Asynch_T is true when the type is asynchronous.
6245 Set_Field (Name_Asynchronous,
6247 New_Occurrence_Of (Asynch_P, Loc),
6248 New_Occurrence_Of (Boolean_Literals (
6249 Is_Asynchronous (Ras_Type)), Loc)))));
6251 Append_List_To (Proc_Statements,
6252 Build_Get_Unique_RP_Call (Loc,
6253 Stub_Ptr, Stub_Elements.Stub_Type));
6255 Append_To (Proc_Statements,
6256 Make_Return_Statement (Loc,
6258 Unchecked_Convert_To (Fat_Type,
6259 New_Occurrence_Of (Stub_Ptr, Loc))));
6262 Make_Function_Specification (Loc,
6263 Defining_Unit_Name => Proc,
6264 Parameter_Specifications => New_List (
6265 Make_Parameter_Specification (Loc,
6266 Defining_Identifier => Package_Name,
6268 New_Occurrence_Of (Standard_String, Loc)),
6270 Make_Parameter_Specification (Loc,
6271 Defining_Identifier => Subp_Id,
6273 New_Occurrence_Of (Standard_String, Loc)),
6275 Make_Parameter_Specification (Loc,
6276 Defining_Identifier => Asynch_P,
6278 New_Occurrence_Of (Standard_Boolean, Loc)),
6280 Make_Parameter_Specification (Loc,
6281 Defining_Identifier => All_Calls_Remote,
6283 New_Occurrence_Of (Standard_Boolean, Loc))),
6286 New_Occurrence_Of (Fat_Type, Loc));
6288 -- Set the kind and return type of the function to prevent
6289 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6291 Set_Ekind (Proc, E_Function);
6292 Set_Etype (Proc, Fat_Type);
6295 Make_Subprogram_Body (Loc,
6296 Specification => Proc_Spec,
6297 Declarations => Proc_Decls,
6298 Handled_Statement_Sequence =>
6299 Make_Handled_Sequence_Of_Statements (Loc,
6300 Statements => Proc_Statements)));
6302 Set_TSS (Fat_Type, Proc);
6303 end Add_RAS_Access_TSS;
6305 ----------------------
6306 -- Add_RAS_From_Any --
6307 ----------------------
6309 procedure Add_RAS_From_Any
6310 (RAS_Type : Entity_Id;
6311 Declarations : List_Id)
6313 Loc : constant Source_Ptr := Sloc (RAS_Type);
6315 Fnam : constant Entity_Id :=
6316 Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
6318 Func_Spec : Node_Id;
6319 Func_Decl : Node_Id;
6320 Func_Body : Node_Id;
6322 Statements : List_Id;
6324 Any_Parameter : constant Entity_Id :=
6325 Make_Defining_Identifier (Loc, Name_A);
6328 Statements := New_List (
6329 Make_Return_Statement (Loc,
6331 Make_Aggregate (Loc,
6332 Component_Associations => New_List (
6333 Make_Component_Association (Loc,
6334 Choices => New_List (
6335 Make_Identifier (Loc, Name_Ras)),
6337 PolyORB_Support.Helpers.Build_From_Any_Call (
6338 Underlying_RACW_Type (RAS_Type),
6339 New_Occurrence_Of (Any_Parameter, Loc),
6343 Make_Function_Specification (Loc,
6344 Defining_Unit_Name =>
6346 Parameter_Specifications => New_List (
6347 Make_Parameter_Specification (Loc,
6348 Defining_Identifier =>
6351 New_Occurrence_Of (RTE (RE_Any), Loc))),
6352 Subtype_Mark => New_Occurrence_Of (RAS_Type, Loc));
6354 -- NOTE: The usage occurrences of RACW_Parameter must
6355 -- refer to the entity in the declaration spec, not those
6356 -- of the body spec.
6358 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6361 Make_Subprogram_Body (Loc,
6363 Copy_Specification (Loc, Func_Spec),
6364 Declarations => No_List,
6365 Handled_Statement_Sequence =>
6366 Make_Handled_Sequence_Of_Statements (Loc,
6367 Statements => Statements));
6369 Insert_After (Declaration_Node (RAS_Type), Func_Decl);
6370 Append_To (Declarations, Func_Body);
6372 Set_Renaming_TSS (RAS_Type, Fnam, TSS_From_Any);
6373 end Add_RAS_From_Any;
6375 --------------------
6376 -- Add_RAS_To_Any --
6377 --------------------
6379 procedure Add_RAS_To_Any
6380 (RAS_Type : Entity_Id;
6381 Declarations : List_Id)
6383 Loc : constant Source_Ptr := Sloc (RAS_Type);
6388 Statements : List_Id;
6390 Func_Spec : Node_Id;
6391 Func_Decl : Node_Id;
6392 Func_Body : Node_Id;
6394 Any : constant Entity_Id :=
6395 Make_Defining_Identifier (Loc,
6396 Chars => New_Internal_Name ('A'));
6397 RAS_Parameter : constant Entity_Id :=
6398 Make_Defining_Identifier (Loc,
6399 Chars => New_Internal_Name ('R'));
6400 RACW_Parameter : constant Node_Id :=
6401 Make_Selected_Component (Loc,
6402 Prefix => RAS_Parameter,
6403 Selector_Name => Name_Ras);
6406 -- Object declarations
6408 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6410 Make_Object_Declaration (Loc,
6411 Defining_Identifier =>
6413 Object_Definition =>
6414 New_Occurrence_Of (RTE (RE_Any), Loc),
6416 PolyORB_Support.Helpers.Build_To_Any_Call
6417 (RACW_Parameter, No_List)));
6419 Statements := New_List (
6420 Make_Procedure_Call_Statement (Loc,
6422 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6423 Parameter_Associations => New_List (
6424 New_Occurrence_Of (Any, Loc),
6425 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6427 Make_Return_Statement (Loc,
6429 New_Occurrence_Of (Any, Loc)));
6431 Fnam := Make_Defining_Identifier (
6432 Loc, New_Internal_Name ('T'));
6435 Make_Function_Specification (Loc,
6436 Defining_Unit_Name =>
6438 Parameter_Specifications => New_List (
6439 Make_Parameter_Specification (Loc,
6440 Defining_Identifier =>
6443 New_Occurrence_Of (RAS_Type, Loc))),
6444 Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), Loc));
6446 -- NOTE: The usage occurrences of RAS_Parameter must
6447 -- refer to the entity in the declaration spec, not in
6450 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6453 Make_Subprogram_Body (Loc,
6455 Copy_Specification (Loc, Func_Spec),
6456 Declarations => Decls,
6457 Handled_Statement_Sequence =>
6458 Make_Handled_Sequence_Of_Statements (Loc,
6459 Statements => Statements));
6461 Insert_After (Declaration_Node (RAS_Type), Func_Decl);
6462 Append_To (Declarations, Func_Body);
6464 Set_Renaming_TSS (RAS_Type, Fnam, TSS_To_Any);
6467 ----------------------
6468 -- Add_RAS_TypeCode --
6469 ----------------------
6471 procedure Add_RAS_TypeCode
6472 (RAS_Type : Entity_Id;
6473 Declarations : List_Id)
6475 Loc : constant Source_Ptr := Sloc (RAS_Type);
6479 Func_Spec : Node_Id;
6480 Func_Decl : Node_Id;
6481 Func_Body : Node_Id;
6483 Decls : constant List_Id := New_List;
6484 Name_String, Repo_Id_String : String_Id;
6486 RAS_Parameter : constant Entity_Id :=
6487 Make_Defining_Identifier (Loc, Name_R);
6492 Make_Defining_Identifier (Loc,
6493 Chars => New_Internal_Name ('T'));
6495 -- The spec for this subprogram has a dummy 'access RAS'
6496 -- argument, which serves only for overloading purposes.
6499 Make_Function_Specification (Loc,
6500 Defining_Unit_Name =>
6502 Parameter_Specifications => New_List (
6503 Make_Parameter_Specification (Loc,
6504 Defining_Identifier =>
6507 Make_Access_Definition (Loc,
6508 Subtype_Mark => New_Occurrence_Of (RAS_Type, Loc)))),
6509 Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6511 -- NOTE: The usage occurrences of RAS_Parameter must
6512 -- refer to the entity in the declaration spec, not those
6513 -- of the body spec.
6515 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6517 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6518 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6521 Make_Subprogram_Body (Loc,
6523 Copy_Specification (Loc, Func_Spec),
6524 Declarations => Decls,
6525 Handled_Statement_Sequence =>
6526 Make_Handled_Sequence_Of_Statements (Loc,
6527 Statements => New_List (
6528 Make_Return_Statement (Loc,
6530 Make_Function_Call (Loc,
6532 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6533 Parameter_Associations => New_List (
6534 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6535 Make_Aggregate (Loc,
6538 Make_Function_Call (Loc,
6539 Name => New_Occurrence_Of (
6540 RTE (RE_TA_String), Loc),
6541 Parameter_Associations => New_List (
6542 Make_String_Literal (Loc, Name_String))),
6543 Make_Function_Call (Loc,
6544 Name => New_Occurrence_Of (
6545 RTE (RE_TA_String), Loc),
6546 Parameter_Associations => New_List (
6547 Make_String_Literal (Loc,
6548 Repo_Id_String)))))))))));
6550 Insert_After (Declaration_Node (RAS_Type), Func_Decl);
6551 Append_To (Declarations, Func_Body);
6553 Set_Renaming_TSS (RAS_Type, Fnam, TSS_TypeCode);
6554 end Add_RAS_TypeCode;
6556 -----------------------------------------
6557 -- Add_Receiving_Stubs_To_Declarations --
6558 -----------------------------------------
6560 procedure Add_Receiving_Stubs_To_Declarations
6561 (Pkg_Spec : Node_Id;
6564 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6566 Pkg_RPC_Receiver : constant Entity_Id :=
6567 Make_Defining_Identifier (Loc,
6568 New_Internal_Name ('H'));
6569 Pkg_RPC_Receiver_Object : Node_Id;
6571 Pkg_RPC_Receiver_Body : Node_Id;
6572 Pkg_RPC_Receiver_Decls : List_Id;
6573 Pkg_RPC_Receiver_Statements : List_Id;
6574 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6575 -- A Pkg_RPC_Receiver is built to decode the request
6578 -- Request object received from neutral layer
6580 Subp_Id : Entity_Id;
6581 -- Subprogram identifier as received from the neutral
6582 -- distribution core.
6584 Subp_Index : Entity_Id;
6585 -- Internal index as determined by matching either the
6586 -- method name from the request structure, or the local
6587 -- subprogram address (in case of a RAS).
6589 Is_Local : constant Entity_Id :=
6590 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
6591 Local_Address : constant Entity_Id :=
6592 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
6593 -- Address of a local subprogram designated by a
6594 -- reference corresponding to a RAS.
6596 Dispatch_On_Address : constant List_Id := New_List;
6597 Dispatch_On_Name : constant List_Id := New_List;
6599 Current_Declaration : Node_Id;
6600 Current_Stubs : Node_Id;
6601 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6603 Subp_Info_Array : constant Entity_Id :=
6604 Make_Defining_Identifier (Loc,
6605 Chars => New_Internal_Name ('I'));
6607 Subp_Info_List : constant List_Id := New_List;
6609 Register_Pkg_Actuals : constant List_Id := New_List;
6611 All_Calls_Remote_E : Entity_Id;
6613 procedure Append_Stubs_To
6614 (RPC_Receiver_Cases : List_Id;
6615 Declaration : Node_Id;
6618 Subp_Dist_Name : Entity_Id;
6619 Subp_Proxy_Addr : Entity_Id);
6620 -- Add one case to the specified RPC receiver case list associating
6621 -- Subprogram_Number with the subprogram declared by Declaration, for
6622 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6623 -- subprogram index. Subp_Dist_Name is the string used to call the
6624 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6625 -- object, used in the context of calls through remote
6626 -- access-to-subprogram types.
6628 ---------------------
6629 -- Append_Stubs_To --
6630 ---------------------
6632 procedure Append_Stubs_To
6633 (RPC_Receiver_Cases : List_Id;
6634 Declaration : Node_Id;
6637 Subp_Dist_Name : Entity_Id;
6638 Subp_Proxy_Addr : Entity_Id)
6640 Case_Stmts : List_Id;
6642 Case_Stmts := New_List (
6643 Make_Procedure_Call_Statement (Loc,
6646 Defining_Entity (Stubs), Loc),
6647 Parameter_Associations =>
6648 New_List (New_Occurrence_Of (Request, Loc))));
6649 if Nkind (Specification (Declaration))
6650 = N_Function_Specification
6652 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6654 Append_To (Case_Stmts, Make_Return_Statement (Loc));
6657 Append_To (RPC_Receiver_Cases,
6658 Make_Case_Statement_Alternative (Loc,
6660 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6664 Append_To (Dispatch_On_Name,
6665 Make_Elsif_Part (Loc,
6667 Make_Function_Call (Loc,
6669 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6670 Parameter_Associations => New_List (
6671 New_Occurrence_Of (Subp_Id, Loc),
6672 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6673 Then_Statements => New_List (
6674 Make_Assignment_Statement (Loc,
6675 New_Occurrence_Of (Subp_Index, Loc),
6676 Make_Integer_Literal (Loc,
6679 Append_To (Dispatch_On_Address,
6680 Make_Elsif_Part (Loc,
6684 New_Occurrence_Of (Local_Address, Loc),
6686 New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6687 Then_Statements => New_List (
6688 Make_Assignment_Statement (Loc,
6689 New_Occurrence_Of (Subp_Index, Loc),
6690 Make_Integer_Literal (Loc,
6692 end Append_Stubs_To;
6694 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6697 -- Building receiving stubs consist in several operations:
6699 -- - a package RPC receiver must be built. This subprogram
6700 -- will get a Subprogram_Id from the incoming stream
6701 -- and will dispatch the call to the right subprogram
6703 -- - a receiving stub for any subprogram visible in the package
6704 -- spec. This stub will read all the parameters from the stream,
6705 -- and put the result as well as the exception occurrence in the
6708 -- - a dummy package with an empty spec and a body made of an
6709 -- elaboration part, whose job is to register the receiving
6710 -- part of this RCI package on the name server. This is done
6711 -- by calling System.Partition_Interface.Register_Receiving_Stub
6713 Build_RPC_Receiver_Body (
6714 RPC_Receiver => Pkg_RPC_Receiver,
6717 Subp_Index => Subp_Index,
6718 Stmts => Pkg_RPC_Receiver_Statements,
6719 Decl => Pkg_RPC_Receiver_Body);
6720 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6722 -- Extract local address information from the target reference:
6723 -- if non-null, that means that this is a reference that denotes
6724 -- one particular operation, and hence that the operation name
6725 -- must not be taken into account for dispatching.
6727 Append_To (Pkg_RPC_Receiver_Decls,
6728 Make_Object_Declaration (Loc,
6729 Defining_Identifier =>
6731 Object_Definition =>
6732 New_Occurrence_Of (Standard_Boolean, Loc)));
6733 Append_To (Pkg_RPC_Receiver_Decls,
6734 Make_Object_Declaration (Loc,
6735 Defining_Identifier =>
6737 Object_Definition =>
6738 New_Occurrence_Of (RTE (RE_Address), Loc)));
6739 Append_To (Pkg_RPC_Receiver_Statements,
6740 Make_Procedure_Call_Statement (Loc,
6742 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6743 Parameter_Associations => New_List (
6744 Make_Selected_Component (Loc,
6746 Selector_Name => Name_Target),
6747 New_Occurrence_Of (Is_Local, Loc),
6748 New_Occurrence_Of (Local_Address, Loc))));
6750 -- Determine whether the reference that was used to make
6751 -- the call was the base RCI reference (in which case
6752 -- Local_Address is 0, and the method identifier from the
6753 -- request must be used to determine which subprogram is
6754 -- called) or a reference identifying one particular subprogram
6755 -- (in which case Local_Address is the address of that
6756 -- subprogram, and the method name from the request is
6758 -- In each case, cascaded elsifs are used to determine the
6759 -- proper subprogram index. Using hash tables might be
6762 Append_To (Pkg_RPC_Receiver_Statements,
6763 Make_Implicit_If_Statement (Pkg_Spec,
6766 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6767 Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
6768 Then_Statements => New_List (
6769 Make_Implicit_If_Statement (Pkg_Spec,
6771 New_Occurrence_Of (Standard_False, Loc),
6772 Then_Statements => New_List (
6773 Make_Null_Statement (Loc)),
6775 Dispatch_On_Address)),
6776 Else_Statements => New_List (
6777 Make_Implicit_If_Statement (Pkg_Spec,
6779 New_Occurrence_Of (Standard_False, Loc),
6780 Then_Statements => New_List (
6781 Make_Null_Statement (Loc)),
6783 Dispatch_On_Name))));
6785 -- For each subprogram, the receiving stub will be built and a
6786 -- case statement will be made on the Subprogram_Id to dispatch
6787 -- to the right subprogram.
6789 All_Calls_Remote_E := Boolean_Literals (
6790 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6792 Overload_Counter_Table.Reset;
6793 Reserve_NamingContext_Methods;
6795 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
6796 while Present (Current_Declaration) loop
6797 if Nkind (Current_Declaration) = N_Subprogram_Declaration
6798 and then Comes_From_Source (Current_Declaration)
6801 Loc : constant Source_Ptr :=
6802 Sloc (Current_Declaration);
6803 -- While specifically processing Current_Declaration, use
6804 -- its Sloc as the location of all generated nodes.
6806 Subp_Def : constant Entity_Id :=
6808 (Specification (Current_Declaration));
6810 Subp_Val : String_Id;
6812 Subp_Dist_Name : constant Entity_Id :=
6813 Make_Defining_Identifier (Loc,
6815 Related_Id => Chars (Subp_Def),
6817 Suffix_Index => -1));
6819 Proxy_Object_Addr : Entity_Id;
6822 pragma Assert (Current_Subprogram_Number =
6823 Get_Subprogram_Id (Subp_Def));
6825 -- Build receiving stub
6828 Build_Subprogram_Receiving_Stubs
6829 (Vis_Decl => Current_Declaration,
6831 Nkind (Specification (Current_Declaration)) =
6832 N_Procedure_Specification
6833 and then Is_Asynchronous (Subp_Def));
6835 Append_To (Decls, Current_Stubs);
6836 Analyze (Current_Stubs);
6840 Add_RAS_Proxy_And_Analyze (Decls,
6842 Current_Declaration,
6843 All_Calls_Remote_E =>
6845 Proxy_Object_Addr =>
6848 -- Compute distribution identifier
6850 Assign_Subprogram_Identifier (
6852 Current_Subprogram_Number,
6856 Make_Object_Declaration (Loc,
6857 Defining_Identifier => Subp_Dist_Name,
6858 Constant_Present => True,
6859 Object_Definition => New_Occurrence_Of (
6860 Standard_String, Loc),
6862 Make_String_Literal (Loc, Subp_Val)));
6863 Analyze (Last (Decls));
6865 -- Add subprogram descriptor (RCI_Subp_Info) to the
6866 -- subprograms table for this receiver. The aggregate
6867 -- below must be kept consistent with the declaration
6868 -- of type RCI_Subp_Info in System.Partition_Interface.
6870 Append_To (Subp_Info_List,
6871 Make_Component_Association (Loc,
6872 Choices => New_List (
6873 Make_Integer_Literal (Loc,
6874 Current_Subprogram_Number)),
6876 Make_Aggregate (Loc,
6877 Expressions => New_List (
6878 Make_Attribute_Reference (Loc,
6881 Subp_Dist_Name, Loc),
6882 Attribute_Name => Name_Address),
6883 Make_Attribute_Reference (Loc,
6886 Subp_Dist_Name, Loc),
6887 Attribute_Name => Name_Length),
6888 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
6890 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6891 Declaration => Current_Declaration,
6892 Stubs => Current_Stubs,
6893 Subp_Number => Current_Subprogram_Number,
6894 Subp_Dist_Name => Subp_Dist_Name,
6895 Subp_Proxy_Addr => Proxy_Object_Addr);
6898 Current_Subprogram_Number := Current_Subprogram_Number + 1;
6901 Next (Current_Declaration);
6904 -- If we receive an invalid Subprogram_Id, it is best to do nothing
6905 -- rather than raising an exception since we do not want someone
6906 -- to crash a remote partition by sending invalid subprogram ids.
6907 -- This is consistent with the other parts of the case statement
6908 -- since even in presence of incorrect parameters in the stream,
6909 -- every exception will be caught and (if the subprogram is not an
6910 -- APC) put into the result stream and sent away.
6912 Append_To (Pkg_RPC_Receiver_Cases,
6913 Make_Case_Statement_Alternative (Loc,
6915 New_List (Make_Others_Choice (Loc)),
6917 New_List (Make_Null_Statement (Loc))));
6919 Append_To (Pkg_RPC_Receiver_Statements,
6920 Make_Case_Statement (Loc,
6922 New_Occurrence_Of (Subp_Index, Loc),
6923 Alternatives => Pkg_RPC_Receiver_Cases));
6926 Make_Object_Declaration (Loc,
6927 Defining_Identifier => Subp_Info_Array,
6928 Constant_Present => True,
6929 Aliased_Present => True,
6930 Object_Definition =>
6931 Make_Subtype_Indication (Loc,
6933 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6935 Make_Index_Or_Discriminant_Constraint (Loc,
6938 Low_Bound => Make_Integer_Literal (Loc,
6939 First_RCI_Subprogram_Id),
6941 Make_Integer_Literal (Loc,
6942 First_RCI_Subprogram_Id
6943 + List_Length (Subp_Info_List) - 1))))),
6945 Make_Aggregate (Loc,
6946 Component_Associations => Subp_Info_List)));
6947 Analyze (Last (Decls));
6949 Append_To (Decls, Pkg_RPC_Receiver_Body);
6950 Analyze (Last (Decls));
6952 Pkg_RPC_Receiver_Object :=
6953 Make_Object_Declaration (Loc,
6954 Defining_Identifier =>
6955 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
6956 Aliased_Present => True,
6957 Object_Definition =>
6958 New_Occurrence_Of (RTE (RE_Servant), Loc));
6959 Append_To (Decls, Pkg_RPC_Receiver_Object);
6960 Analyze (Last (Decls));
6962 Get_Library_Unit_Name_String (Pkg_Spec);
6963 Append_To (Register_Pkg_Actuals,
6965 Make_String_Literal (Loc,
6966 Strval => String_From_Name_Buffer));
6968 Append_To (Register_Pkg_Actuals,
6970 Make_Attribute_Reference (Loc,
6973 (Defining_Entity (Pkg_Spec), Loc),
6977 Append_To (Register_Pkg_Actuals,
6979 Make_Attribute_Reference (Loc,
6981 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
6982 Attribute_Name => Name_Access));
6984 Append_To (Register_Pkg_Actuals,
6986 Make_Attribute_Reference (Loc,
6989 Defining_Identifier (
6990 Pkg_RPC_Receiver_Object), Loc),
6994 Append_To (Register_Pkg_Actuals,
6996 Make_Attribute_Reference (Loc,
6998 New_Occurrence_Of (Subp_Info_Array, Loc),
7002 Append_To (Register_Pkg_Actuals,
7004 Make_Attribute_Reference (Loc,
7006 New_Occurrence_Of (Subp_Info_Array, Loc),
7010 Append_To (Register_Pkg_Actuals,
7011 -- Is_All_Calls_Remote
7012 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7015 Make_Procedure_Call_Statement (Loc,
7017 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7018 Parameter_Associations => Register_Pkg_Actuals));
7019 Analyze (Last (Decls));
7021 end Add_Receiving_Stubs_To_Declarations;
7023 ---------------------------------
7024 -- Build_General_Calling_Stubs --
7025 ---------------------------------
7027 procedure Build_General_Calling_Stubs
7029 Statements : List_Id;
7030 Target_Object : Node_Id;
7031 Subprogram_Id : Node_Id;
7032 Asynchronous : Node_Id := Empty;
7033 Is_Known_Asynchronous : Boolean := False;
7034 Is_Known_Non_Asynchronous : Boolean := False;
7035 Is_Function : Boolean;
7037 Stub_Type : Entity_Id := Empty;
7038 RACW_Type : Entity_Id := Empty;
7041 Loc : constant Source_Ptr := Sloc (Nod);
7043 Arguments : Node_Id;
7044 -- Name of the named values list used to transmit parameters
7045 -- to the remote package
7048 -- The request object constructed by these stubs
7051 -- Name of the result named value (in non-APC cases) which get the
7052 -- result of the remote subprogram.
7054 Result_TC : Node_Id;
7055 -- Typecode expression for the result of the request (void
7056 -- typecode for procedures).
7058 Exception_Return_Parameter : Node_Id;
7059 -- Name of the parameter which will hold the exception sent by the
7060 -- remote subprogram.
7062 Current_Parameter : Node_Id;
7063 -- Current parameter being handled
7065 Ordered_Parameters_List : constant List_Id :=
7066 Build_Ordered_Parameters_List (Spec);
7068 Asynchronous_P : Node_Id;
7069 -- A Boolean expression indicating whether this call is asynchronous
7071 Asynchronous_Statements : List_Id := No_List;
7072 Non_Asynchronous_Statements : List_Id := No_List;
7073 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7075 Extra_Formal_Statements : constant List_Id := New_List;
7076 -- List of statements for extra formal parameters. It will appear
7077 -- after the regular statements for writing out parameters.
7079 After_Statements : constant List_Id := New_List;
7080 -- Statements to be executed after call returns (to assign
7081 -- in out or out parameter values).
7084 -- The type of the formal parameter being processed
7086 Is_Controlling_Formal : Boolean;
7087 Is_First_Controlling_Formal : Boolean;
7088 First_Controlling_Formal_Seen : Boolean := False;
7089 -- Controlling formal parameters of distributed object
7090 -- primitives require special handling, and the first
7091 -- such parameter needs even more.
7094 -- ??? document general form of stub subprograms for the PolyORB case
7096 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7099 Make_Object_Declaration (Loc,
7100 Defining_Identifier => Request,
7101 Aliased_Present => False,
7102 Object_Definition =>
7103 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
7106 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7109 Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7110 Etype (Subtype_Mark (Spec)), Decls);
7112 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7116 Make_Object_Declaration (Loc,
7117 Defining_Identifier => Result,
7118 Aliased_Present => False,
7119 Object_Definition =>
7120 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7122 Make_Aggregate (Loc,
7123 Component_Associations => New_List (
7124 Make_Component_Association (Loc,
7125 Choices => New_List (
7126 Make_Identifier (Loc, Name_Name)),
7128 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7129 Make_Component_Association (Loc,
7130 Choices => New_List (
7131 Make_Identifier (Loc, Name_Argument)),
7133 Make_Function_Call (Loc,
7135 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7136 Parameter_Associations => New_List (
7138 Make_Component_Association (Loc,
7139 Choices => New_List (
7140 Make_Identifier (Loc, Name_Arg_Modes)),
7142 Make_Integer_Literal (Loc, 0))))));
7144 if not Is_Known_Asynchronous then
7145 Exception_Return_Parameter :=
7146 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7149 Make_Object_Declaration (Loc,
7150 Defining_Identifier => Exception_Return_Parameter,
7151 Object_Definition =>
7152 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7155 Exception_Return_Parameter := Empty;
7158 -- Initialize and fill in arguments list
7161 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7162 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7164 Current_Parameter := First (Ordered_Parameters_List);
7165 while Present (Current_Parameter) loop
7167 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7168 Is_Controlling_Formal := True;
7169 Is_First_Controlling_Formal :=
7170 not First_Controlling_Formal_Seen;
7171 First_Controlling_Formal_Seen := True;
7173 Is_Controlling_Formal := False;
7174 Is_First_Controlling_Formal := False;
7177 if Is_Controlling_Formal then
7179 -- In the case of a controlling formal argument, we send
7185 Etyp := Etype (Parameter_Type (Current_Parameter));
7188 -- The first controlling formal parameter is treated
7189 -- specially: it is used to set the target object of
7192 if not Is_First_Controlling_Formal then
7195 Constrained : constant Boolean :=
7196 Is_Constrained (Etyp)
7197 or else Is_Elementary_Type (Etyp);
7199 Any : constant Entity_Id :=
7200 Make_Defining_Identifier (Loc,
7201 New_Internal_Name ('A'));
7203 Actual_Parameter : Node_Id :=
7205 Defining_Identifier (
7206 Current_Parameter), Loc);
7211 if Is_Controlling_Formal then
7213 -- For a controlling formal parameter (other
7214 -- than the first one), use the corresponding
7215 -- RACW. If the parameter is not an anonymous
7216 -- access parameter, that involves taking
7217 -- its 'Unrestricted_Access.
7219 if Nkind (Parameter_Type (Current_Parameter))
7220 = N_Access_Definition
7222 Actual_Parameter := OK_Convert_To
7223 (Etyp, Actual_Parameter);
7225 Actual_Parameter := OK_Convert_To (Etyp,
7226 Make_Attribute_Reference (Loc,
7230 Name_Unrestricted_Access));
7235 if In_Present (Current_Parameter)
7236 or else not Out_Present (Current_Parameter)
7237 or else not Constrained
7238 or else Is_Controlling_Formal
7240 -- The parameter has an input value, is constrained
7241 -- at runtime by an input value, or is a controlling
7242 -- formal parameter (always passed as a reference)
7243 -- other than the first one.
7245 Expr := PolyORB_Support.Helpers.Build_To_Any_Call (
7246 Actual_Parameter, Decls);
7248 Expr := Make_Function_Call (Loc,
7250 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7251 Parameter_Associations => New_List (
7252 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7257 Make_Object_Declaration (Loc,
7258 Defining_Identifier =>
7260 Aliased_Present => False,
7261 Object_Definition =>
7262 New_Occurrence_Of (RTE (RE_Any), Loc),
7266 Append_To (Statements,
7267 Add_Parameter_To_NVList (Loc,
7268 Parameter => Current_Parameter,
7269 NVList => Arguments,
7270 Constrained => Constrained,
7273 if Out_Present (Current_Parameter)
7274 and then not Is_Controlling_Formal
7276 Append_To (After_Statements,
7277 Make_Assignment_Statement (Loc,
7280 Defining_Identifier (Current_Parameter), Loc),
7282 PolyORB_Support.Helpers.Build_From_Any_Call (
7283 Etype (Parameter_Type (Current_Parameter)),
7284 New_Occurrence_Of (Any, Loc),
7291 -- If the current parameter has a dynamic constrained status,
7292 -- then this status is transmitted as well.
7293 -- This should be done for accessibility as well ???
7295 if Nkind (Parameter_Type (Current_Parameter))
7296 /= N_Access_Definition
7297 and then Need_Extra_Constrained (Current_Parameter)
7299 -- In this block, we do not use the extra formal that has been
7300 -- created because it does not exist at the time of expansion
7301 -- when building calling stubs for remote access to subprogram
7302 -- types. We create an extra variable of this type and push it
7303 -- in the stream after the regular parameters.
7306 Extra_Any_Parameter : constant Entity_Id :=
7307 Make_Defining_Identifier
7308 (Loc, New_Internal_Name ('P'));
7312 Make_Object_Declaration (Loc,
7313 Defining_Identifier =>
7314 Extra_Any_Parameter,
7315 Aliased_Present => False,
7316 Object_Definition =>
7317 New_Occurrence_Of (RTE (RE_Any), Loc),
7319 PolyORB_Support.Helpers.Build_To_Any_Call (
7320 Make_Attribute_Reference (Loc,
7323 Defining_Identifier (Current_Parameter), Loc),
7324 Attribute_Name => Name_Constrained),
7326 Append_To (Extra_Formal_Statements,
7327 Add_Parameter_To_NVList (Loc,
7328 Parameter => Extra_Any_Parameter,
7329 NVList => Arguments,
7330 Constrained => True,
7331 Any => Extra_Any_Parameter));
7335 Next (Current_Parameter);
7338 -- Append the formal statements list to the statements
7340 Append_List_To (Statements, Extra_Formal_Statements);
7342 Append_To (Statements,
7343 Make_Procedure_Call_Statement (Loc,
7345 New_Occurrence_Of (RTE (RE_Request_Create), Loc),
7346 Parameter_Associations => New_List (
7349 New_Occurrence_Of (Arguments, Loc),
7350 New_Occurrence_Of (Result, Loc),
7351 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7353 Append_To (Parameter_Associations (Last (Statements)),
7354 New_Occurrence_Of (Request, Loc));
7357 not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7358 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7359 Asynchronous_P := New_Occurrence_Of (
7360 Boolean_Literals (Is_Known_Asynchronous), Loc);
7362 pragma Assert (Present (Asynchronous));
7363 Asynchronous_P := New_Copy_Tree (Asynchronous);
7364 -- The expression node Asynchronous will be used to build
7365 -- an 'if' statement at the end of Build_General_Calling_Stubs:
7366 -- we need to make a copy here.
7369 Append_To (Parameter_Associations (Last (Statements)),
7370 Make_Indexed_Component (Loc,
7373 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7374 Expressions => New_List (Asynchronous_P)));
7376 Append_To (Statements,
7377 Make_Procedure_Call_Statement (Loc,
7379 New_Occurrence_Of (RTE (RE_Request_Invoke), Loc),
7380 Parameter_Associations => New_List (
7381 New_Occurrence_Of (Request, Loc))));
7383 Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7384 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7386 if not Is_Known_Asynchronous then
7388 -- Reraise an exception occurrence from the completed request.
7389 -- If the exception occurrence is empty, this is a no-op.
7391 Append_To (Non_Asynchronous_Statements,
7392 Make_Procedure_Call_Statement (Loc,
7394 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7395 Parameter_Associations => New_List (
7396 New_Occurrence_Of (Request, Loc))));
7400 -- If this is a function call, then read the value and
7403 Append_To (Non_Asynchronous_Statements,
7404 Make_Tag_Check (Loc,
7405 Make_Return_Statement (Loc,
7406 PolyORB_Support.Helpers.Build_From_Any_Call (
7407 Etype (Subtype_Mark (Spec)),
7408 Make_Selected_Component (Loc,
7410 Selector_Name => Name_Argument),
7415 Append_List_To (Non_Asynchronous_Statements,
7418 if Is_Known_Asynchronous then
7419 Append_List_To (Statements, Asynchronous_Statements);
7421 elsif Is_Known_Non_Asynchronous then
7422 Append_List_To (Statements, Non_Asynchronous_Statements);
7425 pragma Assert (Present (Asynchronous));
7426 Append_To (Statements,
7427 Make_Implicit_If_Statement (Nod,
7428 Condition => Asynchronous,
7429 Then_Statements => Asynchronous_Statements,
7430 Else_Statements => Non_Asynchronous_Statements));
7432 end Build_General_Calling_Stubs;
7434 -----------------------
7435 -- Build_Stub_Target --
7436 -----------------------
7438 function Build_Stub_Target
7441 RCI_Locator : Entity_Id;
7442 Controlling_Parameter : Entity_Id) return RPC_Target
7444 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7445 Target_Reference : constant Entity_Id :=
7446 Make_Defining_Identifier (Loc,
7447 New_Internal_Name ('T'));
7449 if Present (Controlling_Parameter) then
7451 Make_Object_Declaration (Loc,
7452 Defining_Identifier => Target_Reference,
7453 Object_Definition =>
7454 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7456 Make_Function_Call (Loc,
7458 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7459 Parameter_Associations => New_List (
7460 Make_Selected_Component (Loc,
7461 Prefix => Controlling_Parameter,
7462 Selector_Name => Name_Target)))));
7463 -- Controlling_Parameter has the same components
7464 -- as System.Partition_Interface.RACW_Stub_Type.
7466 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7469 Target_Info.Object :=
7470 Make_Selected_Component (Loc,
7472 Make_Identifier (Loc, Chars (RCI_Locator)),
7474 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7477 end Build_Stub_Target;
7479 ---------------------
7480 -- Build_Stub_Type --
7481 ---------------------
7483 procedure Build_Stub_Type
7484 (RACW_Type : Entity_Id;
7485 Stub_Type : Entity_Id;
7486 Stub_Type_Decl : out Node_Id;
7487 RPC_Receiver_Decl : out Node_Id)
7489 Loc : constant Source_Ptr := Sloc (Stub_Type);
7490 pragma Warnings (Off);
7491 pragma Unreferenced (RACW_Type);
7492 pragma Warnings (On);
7496 Make_Full_Type_Declaration (Loc,
7497 Defining_Identifier => Stub_Type,
7499 Make_Record_Definition (Loc,
7500 Tagged_Present => True,
7501 Limited_Present => True,
7503 Make_Component_List (Loc,
7504 Component_Items => New_List (
7506 Make_Component_Declaration (Loc,
7507 Defining_Identifier =>
7508 Make_Defining_Identifier (Loc, Name_Target),
7509 Component_Definition =>
7510 Make_Component_Definition (Loc,
7513 Subtype_Indication =>
7514 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7516 Make_Component_Declaration (Loc,
7517 Defining_Identifier =>
7518 Make_Defining_Identifier (Loc, Name_Asynchronous),
7519 Component_Definition =>
7520 Make_Component_Definition (Loc,
7521 Aliased_Present => False,
7522 Subtype_Indication =>
7524 Standard_Boolean, Loc)))))));
7526 RPC_Receiver_Decl :=
7527 Make_Object_Declaration (Loc,
7528 Defining_Identifier => Make_Defining_Identifier (Loc,
7529 New_Internal_Name ('R')),
7530 Aliased_Present => True,
7531 Object_Definition =>
7532 New_Occurrence_Of (RTE (RE_Servant), Loc));
7533 end Build_Stub_Type;
7535 -----------------------------
7536 -- Build_RPC_Receiver_Body --
7537 -----------------------------
7539 procedure Build_RPC_Receiver_Body
7540 (RPC_Receiver : Entity_Id;
7541 Request : out Entity_Id;
7542 Subp_Id : out Entity_Id;
7543 Subp_Index : out Entity_Id;
7544 Stmts : out List_Id;
7547 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7549 RPC_Receiver_Spec : Node_Id;
7550 RPC_Receiver_Decls : List_Id;
7553 Request := Make_Defining_Identifier (Loc, Name_R);
7555 RPC_Receiver_Spec :=
7556 Build_RPC_Receiver_Specification (
7557 RPC_Receiver => RPC_Receiver,
7558 Request_Parameter => Request);
7560 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7561 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7563 RPC_Receiver_Decls := New_List (
7564 Make_Object_Renaming_Declaration (Loc,
7565 Defining_Identifier => Subp_Id,
7566 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7568 Make_Explicit_Dereference (Loc,
7570 Make_Selected_Component (Loc,
7572 Selector_Name => Name_Operation))),
7574 Make_Object_Declaration (Loc,
7575 Defining_Identifier => Subp_Index,
7576 Object_Definition =>
7577 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7579 Make_Attribute_Reference (Loc,
7581 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7582 Attribute_Name => Name_Last)));
7587 Make_Subprogram_Body (Loc,
7588 Specification => RPC_Receiver_Spec,
7589 Declarations => RPC_Receiver_Decls,
7590 Handled_Statement_Sequence =>
7591 Make_Handled_Sequence_Of_Statements (Loc,
7592 Statements => Stmts));
7593 end Build_RPC_Receiver_Body;
7595 --------------------------------------
7596 -- Build_Subprogram_Receiving_Stubs --
7597 --------------------------------------
7599 function Build_Subprogram_Receiving_Stubs
7600 (Vis_Decl : Node_Id;
7601 Asynchronous : Boolean;
7602 Dynamically_Asynchronous : Boolean := False;
7603 Stub_Type : Entity_Id := Empty;
7604 RACW_Type : Entity_Id := Empty;
7605 Parent_Primitive : Entity_Id := Empty) return Node_Id
7607 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7609 Request_Parameter : Node_Id;
7612 Outer_Decls : constant List_Id := New_List;
7613 -- At the outermost level, an NVList and Any's are
7614 -- declared for all parameters. The Dynamic_Async
7615 -- flag also needs to be declared there to be visible
7616 -- from the exception handling code.
7618 Outer_Statements : constant List_Id := New_List;
7619 -- Statements that occur prior to the declaration of the actual
7620 -- parameter variables.
7622 Decls : constant List_Id := New_List;
7623 -- All the parameters will get declared before calling the real
7624 -- subprograms. Also the out parameters will be declared.
7625 -- At this level, parameters may be unconstrained.
7627 Statements : constant List_Id := New_List;
7629 Extra_Formal_Statements : constant List_Id := New_List;
7630 -- Statements concerning extra formal parameters
7632 After_Statements : constant List_Id := New_List;
7633 -- Statements to be executed after the subprogram call
7635 Inner_Decls : List_Id := No_List;
7636 -- In case of a function, the inner declarations are needed since
7637 -- the result may be unconstrained.
7639 Excep_Handlers : List_Id := No_List;
7641 Parameter_List : constant List_Id := New_List;
7642 -- List of parameters to be passed to the subprogram
7644 First_Controlling_Formal_Seen : Boolean := False;
7646 Current_Parameter : Node_Id;
7648 Ordered_Parameters_List : constant List_Id :=
7649 Build_Ordered_Parameters_List
7650 (Specification (Vis_Decl));
7652 Arguments : Node_Id;
7653 -- Name of the named values list used to retrieve parameters
7655 Subp_Spec : Node_Id;
7656 -- Subprogram specification
7658 Called_Subprogram : Node_Id;
7659 -- The subprogram to call
7662 if Present (RACW_Type) then
7663 Called_Subprogram :=
7664 New_Occurrence_Of (Parent_Primitive, Loc);
7666 Called_Subprogram :=
7668 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7671 Request_Parameter :=
7672 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7675 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7676 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7678 -- Loop through every parameter and get its value from the stream. If
7679 -- the parameter is unconstrained, then the parameter is read using
7680 -- 'Input at the point of declaration.
7682 Current_Parameter := First (Ordered_Parameters_List);
7683 while Present (Current_Parameter) loop
7686 Constrained : Boolean;
7687 Any : Entity_Id := Empty;
7688 Object : constant Entity_Id :=
7689 Make_Defining_Identifier (Loc,
7690 New_Internal_Name ('P'));
7691 Expr : Node_Id := Empty;
7693 Is_Controlling_Formal : constant Boolean
7694 := Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
7696 Is_First_Controlling_Formal : Boolean := False;
7698 Set_Ekind (Object, E_Variable);
7700 if Is_Controlling_Formal then
7702 -- Controlling formals in distributed object primitive
7703 -- operations are handled specially:
7704 -- - the first controlling formal is used as the
7705 -- target of the call;
7706 -- - the remaining controlling formals are transmitted
7710 Is_First_Controlling_Formal :=
7711 not First_Controlling_Formal_Seen;
7712 First_Controlling_Formal_Seen := True;
7714 Etyp := Etype (Parameter_Type (Current_Parameter));
7718 Is_Constrained (Etyp)
7719 or else Is_Elementary_Type (Etyp);
7721 if not Is_First_Controlling_Formal then
7722 Any := Make_Defining_Identifier (Loc,
7723 New_Internal_Name ('A'));
7724 Append_To (Outer_Decls,
7725 Make_Object_Declaration (Loc,
7726 Defining_Identifier =>
7728 Object_Definition =>
7729 New_Occurrence_Of (RTE (RE_Any), Loc),
7731 Make_Function_Call (Loc,
7733 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7734 Parameter_Associations => New_List (
7735 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7736 Etyp, Outer_Decls)))));
7738 Append_To (Outer_Statements,
7739 Add_Parameter_To_NVList (Loc,
7740 Parameter => Current_Parameter,
7741 NVList => Arguments,
7742 Constrained => Constrained,
7746 if Is_First_Controlling_Formal then
7748 Addr : constant Entity_Id :=
7749 Make_Defining_Identifier (Loc,
7750 New_Internal_Name ('A'));
7751 Is_Local : constant Entity_Id :=
7752 Make_Defining_Identifier (Loc,
7753 New_Internal_Name ('L'));
7756 -- Special case: obtain the first controlling
7757 -- formal from the target of the remote call,
7758 -- instead of the argument list.
7760 Append_To (Outer_Decls,
7761 Make_Object_Declaration (Loc,
7762 Defining_Identifier =>
7764 Object_Definition =>
7765 New_Occurrence_Of (RTE (RE_Address), Loc)));
7766 Append_To (Outer_Decls,
7767 Make_Object_Declaration (Loc,
7768 Defining_Identifier =>
7770 Object_Definition =>
7771 New_Occurrence_Of (Standard_Boolean, Loc)));
7772 Append_To (Outer_Statements,
7773 Make_Procedure_Call_Statement (Loc,
7776 RTE (RE_Get_Local_Address), Loc),
7777 Parameter_Associations => New_List (
7778 Make_Selected_Component (Loc,
7781 Request_Parameter, Loc),
7783 Make_Identifier (Loc, Name_Target)),
7784 New_Occurrence_Of (Is_Local, Loc),
7785 New_Occurrence_Of (Addr, Loc))));
7787 Expr := Unchecked_Convert_To (RACW_Type,
7788 New_Occurrence_Of (Addr, Loc));
7791 elsif In_Present (Current_Parameter)
7792 or else not Out_Present (Current_Parameter)
7793 or else not Constrained
7795 -- If an input parameter is contrained, then its reading is
7796 -- deferred until the beginning of the subprogram body. If
7797 -- it is unconstrained, then an expression is built for
7798 -- the object declaration and the variable is set using
7799 -- 'Input instead of 'Read.
7801 Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
7802 Etyp, New_Occurrence_Of (Any, Loc), Decls);
7806 Append_To (Statements,
7807 Make_Assignment_Statement (Loc,
7809 New_Occurrence_Of (Object, Loc),
7815 -- Expr will be used to initialize (and constrain)
7816 -- the parameter when it is declared.
7821 -- If we do not have to output the current parameter, then
7822 -- it can well be flagged as constant. This may allow further
7823 -- optimizations done by the back end.
7826 Make_Object_Declaration (Loc,
7827 Defining_Identifier => Object,
7828 Constant_Present => not Constrained
7829 and then not Out_Present (Current_Parameter),
7830 Object_Definition =>
7831 New_Occurrence_Of (Etyp, Loc),
7832 Expression => Expr));
7833 Set_Etype (Object, Etyp);
7835 -- An out parameter may be written back using a 'Write
7836 -- attribute instead of a 'Output because it has been
7837 -- constrained by the parameter given to the caller. Note that
7838 -- out controlling arguments in the case of a RACW are not put
7839 -- back in the stream because the pointer on them has not
7842 if Out_Present (Current_Parameter)
7843 and then not Is_Controlling_Formal
7845 Append_To (After_Statements,
7846 Make_Procedure_Call_Statement (Loc,
7848 New_Occurrence_Of (RTE (RE_Copy_Any_Value), Loc),
7849 Parameter_Associations => New_List (
7850 New_Occurrence_Of (Any, Loc),
7851 PolyORB_Support.Helpers.Build_To_Any_Call (
7852 New_Occurrence_Of (Object, Loc),
7856 -- For RACW controlling formals, the Etyp of Object is always
7857 -- an RACW, even if the parameter is not of an anonymous access
7858 -- type. In such case, we need to dereference it at call time.
7860 if Is_Controlling_Formal then
7861 if Nkind (Parameter_Type (Current_Parameter)) /=
7864 Append_To (Parameter_List,
7865 Make_Parameter_Association (Loc,
7868 Defining_Identifier (Current_Parameter), Loc),
7869 Explicit_Actual_Parameter =>
7870 Make_Explicit_Dereference (Loc,
7871 Unchecked_Convert_To (RACW_Type,
7872 OK_Convert_To (RTE (RE_Address),
7873 New_Occurrence_Of (Object, Loc))))));
7876 Append_To (Parameter_List,
7877 Make_Parameter_Association (Loc,
7880 Defining_Identifier (Current_Parameter), Loc),
7881 Explicit_Actual_Parameter =>
7882 Unchecked_Convert_To (RACW_Type,
7883 OK_Convert_To (RTE (RE_Address),
7884 New_Occurrence_Of (Object, Loc)))));
7888 Append_To (Parameter_List,
7889 Make_Parameter_Association (Loc,
7892 Defining_Identifier (Current_Parameter), Loc),
7893 Explicit_Actual_Parameter =>
7894 New_Occurrence_Of (Object, Loc)));
7897 -- If the current parameter needs an extra formal, then read it
7898 -- from the stream and set the corresponding semantic field in
7899 -- the variable. If the kind of the parameter identifier is
7900 -- E_Void, then this is a compiler generated parameter that
7901 -- doesn't need an extra constrained status.
7903 -- The case of Extra_Accessibility should also be handled ???
7905 if Nkind (Parameter_Type (Current_Parameter)) /=
7908 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7910 Present (Extra_Constrained
7911 (Defining_Identifier (Current_Parameter)))
7914 Extra_Parameter : constant Entity_Id :=
7916 (Defining_Identifier
7917 (Current_Parameter));
7918 Extra_Any : constant Entity_Id :=
7919 Make_Defining_Identifier
7920 (Loc, New_Internal_Name ('A'));
7921 Formal_Entity : constant Entity_Id :=
7922 Make_Defining_Identifier
7923 (Loc, Chars (Extra_Parameter));
7925 Formal_Type : constant Entity_Id :=
7926 Etype (Extra_Parameter);
7928 Append_To (Outer_Decls,
7929 Make_Object_Declaration (Loc,
7930 Defining_Identifier =>
7932 Object_Definition =>
7933 New_Occurrence_Of (RTE (RE_Any), Loc)));
7935 Append_To (Outer_Statements,
7936 Add_Parameter_To_NVList (Loc,
7937 Parameter => Extra_Parameter,
7938 NVList => Arguments,
7939 Constrained => True,
7943 Make_Object_Declaration (Loc,
7944 Defining_Identifier => Formal_Entity,
7945 Object_Definition =>
7946 New_Occurrence_Of (Formal_Type, Loc)));
7948 Append_To (Extra_Formal_Statements,
7949 Make_Assignment_Statement (Loc,
7951 New_Occurrence_Of (Extra_Parameter, Loc),
7953 PolyORB_Support.Helpers.Build_From_Any_Call (
7954 Etype (Extra_Parameter),
7955 New_Occurrence_Of (Extra_Any, Loc),
7957 Set_Extra_Constrained (Object, Formal_Entity);
7963 Next (Current_Parameter);
7966 Append_To (Outer_Statements,
7967 Make_Procedure_Call_Statement (Loc,
7969 New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
7970 Parameter_Associations => New_List (
7971 New_Occurrence_Of (Request_Parameter, Loc),
7972 New_Occurrence_Of (Arguments, Loc))));
7974 Append_List_To (Statements, Extra_Formal_Statements);
7976 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
7978 -- The remote subprogram is a function. We build an inner block to
7979 -- be able to hold a potentially unconstrained result in a
7983 Etyp : constant Entity_Id :=
7984 Etype (Subtype_Mark (Specification (Vis_Decl)));
7985 Result : constant Node_Id :=
7986 Make_Defining_Identifier (Loc,
7987 New_Internal_Name ('R'));
7989 Inner_Decls := New_List (
7990 Make_Object_Declaration (Loc,
7991 Defining_Identifier => Result,
7992 Constant_Present => True,
7993 Object_Definition => New_Occurrence_Of (Etyp, Loc),
7995 Make_Function_Call (Loc,
7996 Name => Called_Subprogram,
7997 Parameter_Associations => Parameter_List)));
7999 Set_Etype (Result, Etyp);
8000 Append_To (After_Statements,
8001 Make_Procedure_Call_Statement (Loc,
8003 New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8004 Parameter_Associations => New_List (
8005 New_Occurrence_Of (Request_Parameter, Loc),
8006 PolyORB_Support.Helpers.Build_To_Any_Call (
8007 New_Occurrence_Of (Result, Loc),
8009 -- A DSA function does not have out or inout arguments
8012 Append_To (Statements,
8013 Make_Block_Statement (Loc,
8014 Declarations => Inner_Decls,
8015 Handled_Statement_Sequence =>
8016 Make_Handled_Sequence_Of_Statements (Loc,
8017 Statements => After_Statements)));
8020 -- The remote subprogram is a procedure. We do not need any inner
8021 -- block in this case. No specific processing is required here for
8022 -- the dynamically asynchronous case: the indication of whether
8023 -- call is asynchronous or not is managed by the Sync_Scope
8024 -- attibute of the request, and is handled entirely in the
8027 Append_To (After_Statements,
8028 Make_Procedure_Call_Statement (Loc,
8030 New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8031 Parameter_Associations => New_List (
8032 New_Occurrence_Of (Request_Parameter, Loc))));
8034 Append_To (Statements,
8035 Make_Procedure_Call_Statement (Loc,
8036 Name => Called_Subprogram,
8037 Parameter_Associations => Parameter_List));
8039 Append_List_To (Statements, After_Statements);
8043 Make_Procedure_Specification (Loc,
8044 Defining_Unit_Name =>
8045 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
8047 Parameter_Specifications => New_List (
8048 Make_Parameter_Specification (Loc,
8049 Defining_Identifier => Request_Parameter,
8051 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8053 -- An exception raised during the execution of an incoming
8054 -- remote subprogram call and that needs to be sent back
8055 -- to the caller is propagated by the receiving stubs, and
8056 -- will be handled by the caller (the distribution runtime).
8058 if Asynchronous and then not Dynamically_Asynchronous then
8060 -- For an asynchronous procedure, add a null exception handler
8062 Excep_Handlers := New_List (
8063 Make_Exception_Handler (Loc,
8064 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8065 Statements => New_List (Make_Null_Statement (Loc))));
8069 -- In the other cases, if an exception is raised, then the
8070 -- exception occurrence is propagated.
8075 Append_To (Outer_Statements,
8076 Make_Block_Statement (Loc,
8079 Handled_Statement_Sequence =>
8080 Make_Handled_Sequence_Of_Statements (Loc,
8081 Statements => Statements)));
8084 Make_Subprogram_Body (Loc,
8085 Specification => Subp_Spec,
8086 Declarations => Outer_Decls,
8087 Handled_Statement_Sequence =>
8088 Make_Handled_Sequence_Of_Statements (Loc,
8089 Statements => Outer_Statements,
8090 Exception_Handlers => Excep_Handlers));
8091 end Build_Subprogram_Receiving_Stubs;
8096 package body Helpers is
8098 -----------------------
8099 -- Local Subprograms --
8100 -----------------------
8102 function Find_Numeric_Representation
8103 (Typ : Entity_Id) return Entity_Id;
8104 -- Given a numeric type Typ, return the smallest integer or floarting
8105 -- point type from Standard, or the smallest unsigned (modular) type
8106 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8108 function Make_Stream_Procedure_Function_Name
8111 Nam : Name_Id) return Entity_Id;
8112 -- Return the name to be assigned for stream subprogram Nam of Typ.
8113 -- (copied from exp_strm.adb, should be shared???)
8115 ------------------------------------------------------------
8116 -- Common subprograms for building various tree fragments --
8117 ------------------------------------------------------------
8119 function Build_Get_Aggregate_Element
8123 Idx : Node_Id) return Node_Id;
8124 -- Build a call to Get_Aggregate_Element on Any
8125 -- for typecode TC, returning the Idx'th element.
8128 Subprogram : Entity_Id;
8129 -- Reference location for constructed nodes
8132 -- For 'Range and Etype
8135 -- For the construction of the innermost element expression
8137 with procedure Add_Process_Element
8140 Counter : Entity_Id;
8143 procedure Append_Array_Traversal
8146 Counter : Entity_Id := Empty;
8148 -- Build nested loop statements that iterate over the elements of an
8149 -- array Arry. The statement(s) built by Add_Process_Element are
8150 -- executed for each element; Indices is the list of indices to be
8151 -- used in the construction of the indexed component that denotes the
8152 -- current element. Subprogram is the entity for the subprogram for
8153 -- which this iterator is generated. The generated statements are
8154 -- appended to Stmts.
8158 -- The record entity being dealt with
8160 with procedure Add_Process_Element
8162 Container : Node_Or_Entity_Id;
8163 Counter : in out Int;
8166 -- Rec is the instance of the record type, or Empty.
8167 -- Field is either the N_Defining_Identifier for a component,
8168 -- or an N_Variant_Part.
8170 procedure Append_Record_Traversal
8173 Container : Node_Or_Entity_Id;
8174 Counter : in out Int);
8175 -- Process component list Clist. Individual fields are passed
8176 -- to Field_Processing. Each variant part is also processed.
8177 -- Container is the outer Any (for From_Any/To_Any),
8178 -- the outer typecode (for TC) to which the operation applies.
8180 -----------------------------
8181 -- Append_Record_Traversal --
8182 -----------------------------
8184 procedure Append_Record_Traversal
8187 Container : Node_Or_Entity_Id;
8188 Counter : in out Int)
8190 CI : constant List_Id := Component_Items (Clist);
8191 VP : constant Node_Id := Variant_Part (Clist);
8193 Item : Node_Id := First (CI);
8197 while Present (Item) loop
8198 Def := Defining_Identifier (Item);
8199 if not Is_Internal_Name (Chars (Def)) then
8201 (Stmts, Container, Counter, Rec, Def);
8206 if Present (VP) then
8207 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8209 end Append_Record_Traversal;
8211 -------------------------
8212 -- Build_From_Any_Call --
8213 -------------------------
8215 function Build_From_Any_Call
8218 Decls : List_Id) return Node_Id
8220 Loc : constant Source_Ptr := Sloc (N);
8222 U_Type : Entity_Id := Underlying_Type (Typ);
8224 Fnam : Entity_Id := Empty;
8225 Lib_RE : RE_Id := RE_Null;
8229 -- First simple case where the From_Any function is present
8230 -- in the type's TSS.
8232 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8234 if Sloc (U_Type) <= Standard_Location then
8235 U_Type := Base_Type (U_Type);
8238 -- Check first for Boolean and Character. These are enumeration
8239 -- types, but we treat them specially, since they may require
8240 -- special handling in the transfer protocol. However, this
8241 -- special handling only applies if they have standard
8242 -- representation, otherwise they are treated like any other
8243 -- enumeration type.
8245 if Present (Fnam) then
8248 elsif U_Type = Standard_Boolean then
8251 elsif U_Type = Standard_Character then
8254 elsif U_Type = Standard_Wide_Character then
8257 elsif U_Type = Standard_Wide_Wide_Character then
8258 Lib_RE := RE_FA_WWC;
8260 -- Floating point types
8262 elsif U_Type = Standard_Short_Float then
8265 elsif U_Type = Standard_Float then
8268 elsif U_Type = Standard_Long_Float then
8271 elsif U_Type = Standard_Long_Long_Float then
8272 Lib_RE := RE_FA_LLF;
8276 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8277 Lib_RE := RE_FA_SSI;
8279 elsif U_Type = Etype (Standard_Short_Integer) then
8282 elsif U_Type = Etype (Standard_Integer) then
8285 elsif U_Type = Etype (Standard_Long_Integer) then
8288 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8289 Lib_RE := RE_FA_LLI;
8291 -- Unsigned integer types
8293 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8294 Lib_RE := RE_FA_SSU;
8296 elsif U_Type = RTE (RE_Short_Unsigned) then
8299 elsif U_Type = RTE (RE_Unsigned) then
8302 elsif U_Type = RTE (RE_Long_Unsigned) then
8305 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8306 Lib_RE := RE_FA_LLU;
8308 elsif U_Type = Standard_String then
8309 Lib_RE := RE_FA_String;
8311 -- Other (non-primitive) types
8317 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8318 Append_To (Decls, Decl);
8322 -- Call the function
8324 if Lib_RE /= RE_Null then
8325 pragma Assert (No (Fnam));
8326 Fnam := RTE (Lib_RE);
8330 Make_Function_Call (Loc,
8331 Name => New_Occurrence_Of (Fnam, Loc),
8332 Parameter_Associations => New_List (N));
8333 end Build_From_Any_Call;
8335 -----------------------------
8336 -- Build_From_Any_Function --
8337 -----------------------------
8339 procedure Build_From_Any_Function
8343 Fnam : out Entity_Id)
8346 Decls : constant List_Id := New_List;
8347 Stms : constant List_Id := New_List;
8348 Any_Parameter : constant Entity_Id
8349 := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
8351 Fnam := Make_Stream_Procedure_Function_Name (Loc,
8352 Typ, Name_uFrom_Any);
8355 Make_Function_Specification (Loc,
8356 Defining_Unit_Name => Fnam,
8357 Parameter_Specifications => New_List (
8358 Make_Parameter_Specification (Loc,
8359 Defining_Identifier =>
8362 New_Occurrence_Of (RTE (RE_Any), Loc))),
8363 Subtype_Mark => New_Occurrence_Of (Typ, Loc));
8365 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8368 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8370 if Is_Derived_Type (Typ)
8371 and then not Is_Tagged_Type (Typ)
8374 Make_Return_Statement (Loc,
8378 Build_From_Any_Call (
8380 New_Occurrence_Of (Any_Parameter, Loc),
8383 elsif Is_Record_Type (Typ)
8384 and then not Is_Derived_Type (Typ)
8385 and then not Is_Tagged_Type (Typ)
8387 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8389 Make_Return_Statement (Loc,
8393 Build_From_Any_Call (
8395 New_Occurrence_Of (Any_Parameter, Loc),
8399 Disc : Entity_Id := Empty;
8400 Discriminant_Associations : List_Id;
8401 Rdef : constant Node_Id :=
8402 Type_Definition (Declaration_Node (Typ));
8403 Component_Counter : Int := 0;
8405 -- The returned object
8407 Res : constant Entity_Id :=
8408 Make_Defining_Identifier (Loc,
8409 New_Internal_Name ('R'));
8411 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8413 procedure FA_Rec_Add_Process_Element
8416 Counter : in out Int;
8420 procedure FA_Append_Record_Traversal is
8421 new Append_Record_Traversal
8423 Add_Process_Element => FA_Rec_Add_Process_Element);
8425 --------------------------------
8426 -- FA_Rec_Add_Process_Element --
8427 --------------------------------
8429 procedure FA_Rec_Add_Process_Element
8432 Counter : in out Int;
8437 if Nkind (Field) = N_Defining_Identifier then
8439 -- A regular component
8442 Make_Assignment_Statement (Loc,
8443 Name => Make_Selected_Component (Loc,
8445 New_Occurrence_Of (Rec, Loc),
8447 New_Occurrence_Of (Field, Loc)),
8449 Build_From_Any_Call (Etype (Field),
8450 Build_Get_Aggregate_Element (Loc,
8452 Tc => Build_TypeCode_Call (Loc,
8453 Etype (Field), Decls),
8454 Idx => Make_Integer_Literal (Loc,
8463 Struct_Counter : Int := 0;
8465 Block_Decls : constant List_Id := New_List;
8466 Block_Stmts : constant List_Id := New_List;
8469 Alt_List : constant List_Id := New_List;
8470 Choice_List : List_Id;
8472 Struct_Any : constant Entity_Id :=
8473 Make_Defining_Identifier (Loc,
8474 New_Internal_Name ('S'));
8478 Make_Object_Declaration (Loc,
8479 Defining_Identifier =>
8483 Object_Definition =>
8484 New_Occurrence_Of (RTE (RE_Any), Loc),
8486 Make_Function_Call (Loc,
8487 Name => New_Occurrence_Of (
8488 RTE (RE_Extract_Union_Value), Loc),
8489 Parameter_Associations => New_List (
8490 Build_Get_Aggregate_Element (Loc,
8492 Tc => Make_Function_Call (Loc,
8493 Name => New_Occurrence_Of (
8494 RTE (RE_Any_Member_Type), Loc),
8495 Parameter_Associations =>
8497 New_Occurrence_Of (Any, Loc),
8498 Make_Integer_Literal (Loc,
8500 Idx => Make_Integer_Literal (Loc,
8504 Make_Block_Statement (Loc,
8507 Handled_Statement_Sequence =>
8508 Make_Handled_Sequence_Of_Statements (Loc,
8509 Statements => Block_Stmts)));
8511 Append_To (Block_Stmts,
8512 Make_Case_Statement (Loc,
8514 Make_Selected_Component (Loc,
8517 Chars (Name (Field))),
8521 Variant := First_Non_Pragma (Variants (Field));
8523 while Present (Variant) loop
8524 Choice_List := New_Copy_List_Tree
8525 (Discrete_Choices (Variant));
8527 VP_Stmts := New_List;
8528 FA_Append_Record_Traversal (
8530 Clist => Component_List (Variant),
8531 Container => Struct_Any,
8532 Counter => Struct_Counter);
8534 Append_To (Alt_List,
8535 Make_Case_Statement_Alternative (Loc,
8536 Discrete_Choices => Choice_List,
8539 Next_Non_Pragma (Variant);
8543 Counter := Counter + 1;
8544 end FA_Rec_Add_Process_Element;
8547 -- First all discriminants
8549 if Has_Discriminants (Typ) then
8550 Disc := First_Discriminant (Typ);
8551 Discriminant_Associations := New_List;
8553 while Present (Disc) loop
8555 Disc_Var_Name : constant Entity_Id :=
8556 Make_Defining_Identifier (Loc, Chars (Disc));
8557 Disc_Type : constant Entity_Id :=
8561 Make_Object_Declaration (Loc,
8562 Defining_Identifier =>
8564 Constant_Present => True,
8565 Object_Definition =>
8566 New_Occurrence_Of (Disc_Type, Loc),
8568 Build_From_Any_Call (Etype (Disc),
8569 Build_Get_Aggregate_Element (Loc,
8570 Any => Any_Parameter,
8571 Tc => Build_TypeCode_Call
8572 (Loc, Etype (Disc), Decls),
8573 Idx => Make_Integer_Literal
8574 (Loc, Component_Counter)),
8576 Component_Counter := Component_Counter + 1;
8578 Append_To (Discriminant_Associations,
8579 Make_Discriminant_Association (Loc,
8580 Selector_Names => New_List (
8581 New_Occurrence_Of (Disc, Loc)),
8583 New_Occurrence_Of (Disc_Var_Name, Loc)));
8585 Next_Discriminant (Disc);
8588 Res_Definition := Make_Subtype_Indication (Loc,
8589 Subtype_Mark => Res_Definition,
8591 Make_Index_Or_Discriminant_Constraint (Loc,
8592 Discriminant_Associations));
8595 -- Now we have all the discriminants in variables, we can
8596 -- declared a constrained object. Note that we are not
8597 -- initializing (non-discriminant) components directly in
8598 -- the object declarations, because which fields to
8599 -- initialize depends (at run time) on the discriminant
8603 Make_Object_Declaration (Loc,
8604 Defining_Identifier =>
8606 Object_Definition =>
8609 -- ... then all components
8611 FA_Append_Record_Traversal (Stms,
8612 Clist => Component_List (Rdef),
8613 Container => Any_Parameter,
8614 Counter => Component_Counter);
8617 Make_Return_Statement (Loc,
8618 Expression => New_Occurrence_Of (Res, Loc)));
8622 elsif Is_Array_Type (Typ) then
8624 Constrained : constant Boolean := Is_Constrained (Typ);
8626 procedure FA_Ary_Add_Process_Element
8629 Counter : Entity_Id;
8631 -- Assign the current element (as identified by Counter) of
8632 -- Any to the variable denoted by name Datum, and advance
8633 -- Counter by 1. If Datum is not an Any, a call to From_Any
8634 -- for its type is inserted.
8636 --------------------------------
8637 -- FA_Ary_Add_Process_Element --
8638 --------------------------------
8640 procedure FA_Ary_Add_Process_Element
8643 Counter : Entity_Id;
8646 Assignment : constant Node_Id :=
8647 Make_Assignment_Statement (Loc,
8649 Expression => Empty);
8651 Element_Any : constant Node_Id :=
8652 Build_Get_Aggregate_Element (Loc,
8654 Tc => Build_TypeCode_Call (Loc,
8655 Etype (Datum), Decls),
8656 Idx => New_Occurrence_Of (Counter, Loc));
8659 -- Note: here we *prepend* statements to Stmts, so
8660 -- we must do it in reverse order.
8663 Make_Assignment_Statement (Loc,
8665 New_Occurrence_Of (Counter, Loc),
8669 New_Occurrence_Of (Counter, Loc),
8671 Make_Integer_Literal (Loc, 1))));
8673 if Nkind (Datum) /= N_Attribute_Reference then
8675 -- We ignore the value of the length of each
8676 -- dimension, since the target array has already
8677 -- been constrained anyway.
8679 if Etype (Datum) /= RTE (RE_Any) then
8680 Set_Expression (Assignment,
8681 Build_From_Any_Call (
8682 Component_Type (Typ),
8686 Set_Expression (Assignment, Element_Any);
8688 Prepend_To (Stmts, Assignment);
8690 end FA_Ary_Add_Process_Element;
8692 Counter : constant Entity_Id :=
8693 Make_Defining_Identifier (Loc, Name_J);
8695 Initial_Counter_Value : Int := 0;
8697 Component_TC : constant Entity_Id :=
8698 Make_Defining_Identifier (Loc, Name_T);
8700 Res : constant Entity_Id :=
8701 Make_Defining_Identifier (Loc, Name_R);
8703 procedure Append_From_Any_Array_Iterator is
8704 new Append_Array_Traversal (
8707 Indices => New_List,
8708 Add_Process_Element => FA_Ary_Add_Process_Element);
8710 Res_Subtype_Indication : Node_Id :=
8711 New_Occurrence_Of (Typ, Loc);
8714 if not Constrained then
8716 Ndim : constant Int := Number_Dimensions (Typ);
8719 Indx : Node_Id := First_Index (Typ);
8722 Ranges : constant List_Id := New_List;
8725 for J in 1 .. Ndim loop
8726 Lnam := New_External_Name ('L', J);
8727 Hnam := New_External_Name ('H', J);
8728 Indt := Etype (Indx);
8731 Make_Object_Declaration (Loc,
8732 Defining_Identifier =>
8733 Make_Defining_Identifier (Loc, Lnam),
8736 Object_Definition =>
8737 New_Occurrence_Of (Indt, Loc),
8739 Build_From_Any_Call (
8741 Build_Get_Aggregate_Element (Loc,
8742 Any => Any_Parameter,
8743 Tc => Build_TypeCode_Call (Loc,
8745 Idx => Make_Integer_Literal (Loc, J - 1)),
8749 Make_Object_Declaration (Loc,
8750 Defining_Identifier =>
8751 Make_Defining_Identifier (Loc, Hnam),
8754 Object_Definition =>
8755 New_Occurrence_Of (Indt, Loc),
8756 Expression => Make_Attribute_Reference (Loc,
8758 New_Occurrence_Of (Indt, Loc),
8759 Attribute_Name => Name_Val,
8760 Expressions => New_List (
8761 Make_Op_Subtract (Loc,
8765 Make_Attribute_Reference (Loc,
8767 New_Occurrence_Of (Indt, Loc),
8770 Expressions => New_List (
8771 Make_Identifier (Loc, Lnam))),
8773 Make_Function_Call (Loc,
8774 Name => New_Occurrence_Of (RTE (
8775 RE_Get_Nested_Sequence_Length),
8777 Parameter_Associations =>
8780 Any_Parameter, Loc),
8781 Make_Integer_Literal (Loc,
8784 Make_Integer_Literal (Loc, 1))))));
8788 Low_Bound => Make_Identifier (Loc, Lnam),
8789 High_Bound => Make_Identifier (Loc, Hnam)));
8794 -- Now we have all the necessary bound information:
8795 -- apply the set of range constraints to the
8796 -- (unconstrained) nominal subtype of Res.
8798 Initial_Counter_Value := Ndim;
8799 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
8801 Res_Subtype_Indication,
8803 Make_Index_Or_Discriminant_Constraint (Loc,
8804 Constraints => Ranges));
8809 Make_Object_Declaration (Loc,
8810 Defining_Identifier => Res,
8811 Object_Definition => Res_Subtype_Indication));
8812 Set_Etype (Res, Typ);
8815 Make_Object_Declaration (Loc,
8816 Defining_Identifier => Counter,
8817 Object_Definition =>
8818 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
8820 Make_Integer_Literal (Loc, Initial_Counter_Value)));
8823 Make_Object_Declaration (Loc,
8824 Defining_Identifier => Component_TC,
8825 Constant_Present => True,
8826 Object_Definition =>
8827 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
8829 Build_TypeCode_Call (Loc,
8830 Component_Type (Typ), Decls)));
8832 Append_From_Any_Array_Iterator (Stms,
8833 Any_Parameter, Counter);
8836 Make_Return_Statement (Loc,
8837 Expression => New_Occurrence_Of (Res, Loc)));
8840 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
8842 Make_Return_Statement (Loc,
8844 Unchecked_Convert_To (
8846 Build_From_Any_Call (
8847 Find_Numeric_Representation (Typ),
8848 New_Occurrence_Of (Any_Parameter, Loc),
8852 -- Default: type is represented as an opaque sequence of bytes
8855 Strm : constant Entity_Id :=
8856 Make_Defining_Identifier (Loc,
8857 Chars => New_Internal_Name ('S'));
8858 Res : constant Entity_Id :=
8859 Make_Defining_Identifier (Loc,
8860 Chars => New_Internal_Name ('R'));
8863 -- Strm : Buffer_Stream_Type;
8866 Make_Object_Declaration (Loc,
8867 Defining_Identifier =>
8871 Object_Definition =>
8872 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
8874 -- Any_To_BS (Strm, A);
8877 Make_Procedure_Call_Statement (Loc,
8879 New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
8880 Parameter_Associations => New_List (
8881 New_Occurrence_Of (Any_Parameter, Loc),
8882 New_Occurrence_Of (Strm, Loc))));
8885 -- Res : constant T := T'Input (Strm);
8887 -- Release_Buffer (Strm);
8891 Append_To (Stms, Make_Block_Statement (Loc,
8892 Declarations => New_List (
8893 Make_Object_Declaration (Loc,
8894 Defining_Identifier => Res,
8895 Constant_Present => True,
8896 Object_Definition =>
8897 New_Occurrence_Of (Typ, Loc),
8899 Make_Attribute_Reference (Loc,
8900 Prefix => New_Occurrence_Of (Typ, Loc),
8901 Attribute_Name => Name_Input,
8902 Expressions => New_List (
8903 Make_Attribute_Reference (Loc,
8904 Prefix => New_Occurrence_Of (Strm, Loc),
8905 Attribute_Name => Name_Access))))),
8907 Handled_Statement_Sequence =>
8908 Make_Handled_Sequence_Of_Statements (Loc,
8909 Statements => New_List (
8910 Make_Procedure_Call_Statement (Loc,
8912 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
8913 Parameter_Associations =>
8915 New_Occurrence_Of (Strm, Loc))),
8916 Make_Return_Statement (Loc,
8917 Expression => New_Occurrence_Of (Res, Loc))))));
8923 Make_Subprogram_Body (Loc,
8924 Specification => Spec,
8925 Declarations => Decls,
8926 Handled_Statement_Sequence =>
8927 Make_Handled_Sequence_Of_Statements (Loc,
8928 Statements => Stms));
8929 end Build_From_Any_Function;
8931 ---------------------------------
8932 -- Build_Get_Aggregate_Element --
8933 ---------------------------------
8935 function Build_Get_Aggregate_Element
8939 Idx : Node_Id) return Node_Id
8942 return Make_Function_Call (Loc,
8945 RTE (RE_Get_Aggregate_Element), Loc),
8946 Parameter_Associations => New_List (
8947 New_Occurrence_Of (Any, Loc),
8950 end Build_Get_Aggregate_Element;
8952 -------------------------
8953 -- Build_Reposiroty_Id --
8954 -------------------------
8956 procedure Build_Name_And_Repository_Id
8958 Name_Str : out String_Id;
8959 Repo_Id_Str : out String_Id)
8963 Store_String_Chars ("DSA:");
8964 Get_Library_Unit_Name_String (Scope (E));
8965 Store_String_Chars (
8966 Name_Buffer (Name_Buffer'First
8967 .. Name_Buffer'First + Name_Len - 1));
8968 Store_String_Char ('.');
8969 Get_Name_String (Chars (E));
8970 Store_String_Chars (
8971 Name_Buffer (Name_Buffer'First
8972 .. Name_Buffer'First + Name_Len - 1));
8973 Store_String_Chars (":1.0");
8974 Repo_Id_Str := End_String;
8975 Name_Str := String_From_Name_Buffer;
8976 end Build_Name_And_Repository_Id;
8978 -----------------------
8979 -- Build_To_Any_Call --
8980 -----------------------
8982 function Build_To_Any_Call
8984 Decls : List_Id) return Node_Id
8986 Loc : constant Source_Ptr := Sloc (N);
8988 Typ : Entity_Id := Etype (N);
8991 Fnam : Entity_Id := Empty;
8992 Lib_RE : RE_Id := RE_Null;
8995 -- If N is a selected component, then maybe its Etype
8996 -- has not been set yet: try to use the Etype of the
8997 -- selector_name in that case.
8999 if No (Typ) and then Nkind (N) = N_Selected_Component then
9000 Typ := Etype (Selector_Name (N));
9002 pragma Assert (Present (Typ));
9004 -- The full view, if Typ is private; the completion,
9005 -- if Typ is incomplete.
9007 U_Type := Underlying_Type (Typ);
9009 -- First simple case where the To_Any function is present
9010 -- in the type's TSS.
9012 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9014 -- Check first for Boolean and Character. These are enumeration
9015 -- types, but we treat them specially, since they may require
9016 -- special handling in the transfer protocol. However, this
9017 -- special handling only applies if they have standard
9018 -- representation, otherwise they are treated like any other
9019 -- enumeration type.
9021 if Sloc (U_Type) <= Standard_Location then
9022 U_Type := Base_Type (U_Type);
9025 if Present (Fnam) then
9028 elsif U_Type = Standard_Boolean then
9031 elsif U_Type = Standard_Character then
9034 elsif U_Type = Standard_Wide_Character then
9037 elsif U_Type = Standard_Wide_Wide_Character then
9038 Lib_RE := RE_TA_WWC;
9040 -- Floating point types
9042 elsif U_Type = Standard_Short_Float then
9045 elsif U_Type = Standard_Float then
9048 elsif U_Type = Standard_Long_Float then
9051 elsif U_Type = Standard_Long_Long_Float then
9052 Lib_RE := RE_TA_LLF;
9056 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9057 Lib_RE := RE_TA_SSI;
9059 elsif U_Type = Etype (Standard_Short_Integer) then
9062 elsif U_Type = Etype (Standard_Integer) then
9065 elsif U_Type = Etype (Standard_Long_Integer) then
9068 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9069 Lib_RE := RE_TA_LLI;
9071 -- Unsigned integer types
9073 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9074 Lib_RE := RE_TA_SSU;
9076 elsif U_Type = RTE (RE_Short_Unsigned) then
9079 elsif U_Type = RTE (RE_Unsigned) then
9082 elsif U_Type = RTE (RE_Long_Unsigned) then
9085 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9086 Lib_RE := RE_TA_LLU;
9088 elsif U_Type = Standard_String then
9089 Lib_RE := RE_TA_String;
9091 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9094 -- Other (non-primitive) types
9100 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9101 Append_To (Decls, Decl);
9105 -- Call the function
9107 if Lib_RE /= RE_Null then
9108 pragma Assert (No (Fnam));
9109 Fnam := RTE (Lib_RE);
9113 Make_Function_Call (Loc,
9114 Name => New_Occurrence_Of (Fnam, Loc),
9115 Parameter_Associations => New_List (N));
9116 end Build_To_Any_Call;
9118 ---------------------------
9119 -- Build_To_Any_Function --
9120 ---------------------------
9122 procedure Build_To_Any_Function
9126 Fnam : out Entity_Id)
9129 Decls : constant List_Id := New_List;
9130 Stms : constant List_Id := New_List;
9132 Expr_Parameter : constant Entity_Id :=
9133 Make_Defining_Identifier (Loc, Name_E);
9135 Any : constant Entity_Id :=
9136 Make_Defining_Identifier (Loc, Name_A);
9139 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9142 Fnam := Make_Stream_Procedure_Function_Name (Loc,
9146 Make_Function_Specification (Loc,
9147 Defining_Unit_Name => Fnam,
9148 Parameter_Specifications => New_List (
9149 Make_Parameter_Specification (Loc,
9150 Defining_Identifier =>
9153 New_Occurrence_Of (Typ, Loc))),
9154 Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), Loc));
9155 Set_Etype (Expr_Parameter, Typ);
9158 Make_Object_Declaration (Loc,
9159 Defining_Identifier =>
9161 Object_Definition =>
9162 New_Occurrence_Of (RTE (RE_Any), Loc));
9164 if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9166 Rt_Type : constant Entity_Id
9168 Expr : constant Node_Id
9171 New_Occurrence_Of (Expr_Parameter, Loc));
9173 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9176 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9177 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9179 Rt_Type : constant Entity_Id
9181 Expr : constant Node_Id
9184 New_Occurrence_Of (Expr_Parameter, Loc));
9187 Set_Expression (Any_Decl,
9188 Build_To_Any_Call (Expr, Decls));
9193 Disc : Entity_Id := Empty;
9194 Rdef : constant Node_Id :=
9195 Type_Definition (Declaration_Node (Typ));
9197 Elements : constant List_Id := New_List;
9199 procedure TA_Rec_Add_Process_Element
9201 Container : Node_Or_Entity_Id;
9202 Counter : in out Int;
9206 procedure TA_Append_Record_Traversal is
9207 new Append_Record_Traversal
9208 (Rec => Expr_Parameter,
9209 Add_Process_Element => TA_Rec_Add_Process_Element);
9211 --------------------------------
9212 -- TA_Rec_Add_Process_Element --
9213 --------------------------------
9215 procedure TA_Rec_Add_Process_Element
9217 Container : Node_Or_Entity_Id;
9218 Counter : in out Int;
9222 Field_Ref : Node_Id;
9225 if Nkind (Field) = N_Defining_Identifier then
9227 -- A regular component
9229 Field_Ref := Make_Selected_Component (Loc,
9230 Prefix => New_Occurrence_Of (Rec, Loc),
9231 Selector_Name => New_Occurrence_Of (Field, Loc));
9232 Set_Etype (Field_Ref, Etype (Field));
9235 Make_Procedure_Call_Statement (Loc,
9238 RTE (RE_Add_Aggregate_Element), Loc),
9239 Parameter_Associations => New_List (
9240 New_Occurrence_Of (Any, Loc),
9241 Build_To_Any_Call (Field_Ref, Decls))));
9248 Struct_Counter : Int := 0;
9250 Block_Decls : constant List_Id := New_List;
9251 Block_Stmts : constant List_Id := New_List;
9254 Alt_List : constant List_Id := New_List;
9255 Choice_List : List_Id;
9257 Union_Any : constant Entity_Id :=
9258 Make_Defining_Identifier (Loc,
9259 New_Internal_Name ('U'));
9261 Struct_Any : constant Entity_Id :=
9262 Make_Defining_Identifier (Loc,
9263 New_Internal_Name ('S'));
9265 function Make_Discriminant_Reference
9267 -- Build a selected component for the
9268 -- discriminant of this variant part.
9270 ---------------------------------
9271 -- Make_Discriminant_Reference --
9272 ---------------------------------
9274 function Make_Discriminant_Reference
9277 Nod : constant Node_Id :=
9278 Make_Selected_Component (Loc,
9281 Chars (Name (Field)));
9283 Set_Etype (Nod, Name (Field));
9285 end Make_Discriminant_Reference;
9289 Make_Block_Statement (Loc,
9292 Handled_Statement_Sequence =>
9293 Make_Handled_Sequence_Of_Statements (Loc,
9294 Statements => Block_Stmts)));
9296 Append_To (Block_Decls,
9297 Make_Object_Declaration (Loc,
9298 Defining_Identifier => Union_Any,
9299 Object_Definition =>
9300 New_Occurrence_Of (RTE (RE_Any), Loc),
9302 Make_Function_Call (Loc,
9303 Name => New_Occurrence_Of (
9304 RTE (RE_Create_Any), Loc),
9305 Parameter_Associations => New_List (
9306 Make_Function_Call (Loc,
9309 RTE (RE_Any_Member_Type), Loc),
9310 Parameter_Associations => New_List (
9311 New_Occurrence_Of (Container, Loc),
9312 Make_Integer_Literal (Loc,
9315 Append_To (Block_Decls,
9316 Make_Object_Declaration (Loc,
9317 Defining_Identifier => Struct_Any,
9318 Object_Definition =>
9319 New_Occurrence_Of (RTE (RE_Any), Loc),
9321 Make_Function_Call (Loc,
9322 Name => New_Occurrence_Of (
9323 RTE (RE_Create_Any), Loc),
9324 Parameter_Associations => New_List (
9325 Make_Function_Call (Loc,
9328 RTE (RE_Any_Member_Type), Loc),
9329 Parameter_Associations => New_List (
9330 New_Occurrence_Of (Union_Any, Loc),
9331 Make_Integer_Literal (Loc,
9334 Append_To (Block_Stmts,
9335 Make_Case_Statement (Loc,
9337 Make_Discriminant_Reference,
9341 Variant := First_Non_Pragma (Variants (Field));
9342 while Present (Variant) loop
9343 Choice_List := New_Copy_List_Tree
9344 (Discrete_Choices (Variant));
9346 VP_Stmts := New_List;
9347 TA_Append_Record_Traversal (
9349 Clist => Component_List (Variant),
9350 Container => Struct_Any,
9351 Counter => Struct_Counter);
9353 -- Append discriminant value and inner struct
9354 -- to union aggregate.
9356 Append_To (VP_Stmts,
9357 Make_Procedure_Call_Statement (Loc,
9360 RTE (RE_Add_Aggregate_Element), Loc),
9361 Parameter_Associations => New_List (
9362 New_Occurrence_Of (Union_Any, Loc),
9364 Make_Discriminant_Reference,
9367 Append_To (VP_Stmts,
9368 Make_Procedure_Call_Statement (Loc,
9371 RTE (RE_Add_Aggregate_Element), Loc),
9372 Parameter_Associations => New_List (
9373 New_Occurrence_Of (Union_Any, Loc),
9374 New_Occurrence_Of (Struct_Any, Loc))));
9376 -- Append union to outer aggregate
9378 Append_To (VP_Stmts,
9379 Make_Procedure_Call_Statement (Loc,
9382 RTE (RE_Add_Aggregate_Element), Loc),
9383 Parameter_Associations => New_List (
9384 New_Occurrence_Of (Container, Loc),
9385 Make_Function_Call (Loc,
9386 Name => New_Occurrence_Of (
9387 RTE (RE_Any_Aggregate_Build), Loc),
9388 Parameter_Associations => New_List (
9390 Union_Any, Loc))))));
9392 Append_To (Alt_List,
9393 Make_Case_Statement_Alternative (Loc,
9394 Discrete_Choices => Choice_List,
9397 Next_Non_Pragma (Variant);
9401 end TA_Rec_Add_Process_Element;
9404 -- First all discriminants
9406 if Has_Discriminants (Typ) then
9407 Disc := First_Discriminant (Typ);
9409 while Present (Disc) loop
9410 Append_To (Elements,
9411 Make_Component_Association (Loc,
9412 Choices => New_List (
9413 Make_Integer_Literal (Loc, Counter)),
9416 Make_Selected_Component (Loc,
9417 Prefix => Expr_Parameter,
9418 Selector_Name => Chars (Disc)),
9420 Counter := Counter + 1;
9421 Next_Discriminant (Disc);
9425 -- Make elements an empty array
9428 Dummy_Any : constant Entity_Id :=
9429 Make_Defining_Identifier (Loc,
9430 Chars => New_Internal_Name ('A'));
9434 Make_Object_Declaration (Loc,
9435 Defining_Identifier => Dummy_Any,
9436 Object_Definition =>
9437 New_Occurrence_Of (RTE (RE_Any), Loc)));
9439 Append_To (Elements,
9440 Make_Component_Association (Loc,
9441 Choices => New_List (
9444 Make_Integer_Literal (Loc, 1),
9446 Make_Integer_Literal (Loc, 0))),
9448 New_Occurrence_Of (Dummy_Any, Loc)));
9452 Set_Expression (Any_Decl,
9453 Make_Function_Call (Loc,
9454 Name => New_Occurrence_Of (
9455 RTE (RE_Any_Aggregate_Build), Loc),
9456 Parameter_Associations => New_List (
9458 Make_Aggregate (Loc,
9459 Component_Associations => Elements))));
9462 -- ... then all components
9464 TA_Append_Record_Traversal (Stms,
9465 Clist => Component_List (Rdef),
9467 Counter => Counter);
9471 elsif Is_Array_Type (Typ) then
9473 Constrained : constant Boolean := Is_Constrained (Typ);
9475 procedure TA_Ary_Add_Process_Element
9478 Counter : Entity_Id;
9481 --------------------------------
9482 -- TA_Ary_Add_Process_Element --
9483 --------------------------------
9485 procedure TA_Ary_Add_Process_Element
9488 Counter : Entity_Id;
9491 pragma Warnings (Off);
9492 pragma Unreferenced (Counter);
9493 pragma Warnings (On);
9495 Element_Any : Node_Id;
9498 if Etype (Datum) = RTE (RE_Any) then
9499 Element_Any := Datum;
9501 Element_Any := Build_To_Any_Call (Datum, Decls);
9505 Make_Procedure_Call_Statement (Loc,
9506 Name => New_Occurrence_Of (
9507 RTE (RE_Add_Aggregate_Element), Loc),
9508 Parameter_Associations => New_List (
9509 New_Occurrence_Of (Any, Loc),
9511 end TA_Ary_Add_Process_Element;
9513 procedure Append_To_Any_Array_Iterator is
9514 new Append_Array_Traversal (
9516 Arry => Expr_Parameter,
9517 Indices => New_List,
9518 Add_Process_Element => TA_Ary_Add_Process_Element);
9523 Set_Expression (Any_Decl,
9524 Make_Function_Call (Loc,
9526 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9527 Parameter_Associations => New_List (Result_TC)));
9530 if not Constrained then
9531 Index := First_Index (Typ);
9532 for J in 1 .. Number_Dimensions (Typ) loop
9534 Make_Procedure_Call_Statement (Loc,
9537 RTE (RE_Add_Aggregate_Element), Loc),
9538 Parameter_Associations => New_List (
9539 New_Occurrence_Of (Any, Loc),
9541 OK_Convert_To (Etype (Index),
9542 Make_Attribute_Reference (Loc,
9544 New_Occurrence_Of (Expr_Parameter, Loc),
9545 Attribute_Name => Name_First,
9546 Expressions => New_List (
9547 Make_Integer_Literal (Loc, J)))),
9553 Append_To_Any_Array_Iterator (Stms, Any);
9556 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9557 Set_Expression (Any_Decl,
9560 Find_Numeric_Representation (Typ),
9561 New_Occurrence_Of (Expr_Parameter, Loc)),
9565 -- Default: type is represented as an opaque sequence of bytes
9568 Strm : constant Entity_Id := Make_Defining_Identifier (Loc,
9569 New_Internal_Name ('S'));
9572 -- Strm : aliased Buffer_Stream_Type;
9575 Make_Object_Declaration (Loc,
9576 Defining_Identifier =>
9580 Object_Definition =>
9581 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9583 -- Allocate_Buffer (Strm);
9586 Make_Procedure_Call_Statement (Loc,
9588 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9589 Parameter_Associations => New_List (
9590 New_Occurrence_Of (Strm, Loc))));
9592 -- T'Output (Strm'Access, E);
9595 Make_Attribute_Reference (Loc,
9596 Prefix => New_Occurrence_Of (Typ, Loc),
9597 Attribute_Name => Name_Output,
9598 Expressions => New_List (
9599 Make_Attribute_Reference (Loc,
9600 Prefix => New_Occurrence_Of (Strm, Loc),
9601 Attribute_Name => Name_Access),
9602 New_Occurrence_Of (Expr_Parameter, Loc))));
9604 -- BS_To_Any (Strm, A);
9607 Make_Procedure_Call_Statement (Loc,
9609 New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
9610 Parameter_Associations => New_List (
9611 New_Occurrence_Of (Strm, Loc),
9612 New_Occurrence_Of (Any, Loc))));
9614 -- Release_Buffer (Strm);
9617 Make_Procedure_Call_Statement (Loc,
9619 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
9620 Parameter_Associations => New_List (
9621 New_Occurrence_Of (Strm, Loc))));
9625 Append_To (Decls, Any_Decl);
9627 if Present (Result_TC) then
9629 Make_Procedure_Call_Statement (Loc,
9630 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
9631 Parameter_Associations => New_List (
9632 New_Occurrence_Of (Any, Loc),
9637 Make_Return_Statement (Loc,
9638 Expression => New_Occurrence_Of (Any, Loc)));
9641 Make_Subprogram_Body (Loc,
9642 Specification => Spec,
9643 Declarations => Decls,
9644 Handled_Statement_Sequence =>
9645 Make_Handled_Sequence_Of_Statements (Loc,
9646 Statements => Stms));
9647 end Build_To_Any_Function;
9649 -------------------------
9650 -- Build_TypeCode_Call --
9651 -------------------------
9653 function Build_TypeCode_Call
9656 Decls : List_Id) return Node_Id
9658 U_Type : Entity_Id := Underlying_Type (Typ);
9659 -- The full view, if Typ is private; the completion,
9660 -- if Typ is incomplete.
9662 Fnam : Entity_Id := Empty;
9663 Tnam : Entity_Id := Empty;
9664 Pnam : Entity_Id := Empty;
9665 Args : List_Id := Empty_List;
9666 Lib_RE : RE_Id := RE_Null;
9671 -- Special case System.PolyORB.Interface.Any: its primitives have
9672 -- not been set yet, so can't call Find_Inherited_TSS.
9674 if Typ = RTE (RE_Any) then
9675 Fnam := RTE (RE_TC_Any);
9678 -- First simple case where the TypeCode is present
9679 -- in the type's TSS.
9681 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
9683 if Present (Fnam) then
9685 -- When a TypeCode TSS exists, it has a single parameter
9686 -- that is an anonymous access to the corresponding type.
9687 -- This parameter is not used in any way; its purpose is
9688 -- solely to provide overloading of the TSS.
9691 Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
9693 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
9696 Make_Full_Type_Declaration (Loc,
9697 Defining_Identifier => Tnam,
9699 Make_Access_To_Object_Definition (Loc,
9700 Subtype_Indication =>
9701 New_Occurrence_Of (U_Type, Loc))));
9703 Make_Object_Declaration (Loc,
9704 Defining_Identifier => Pnam,
9705 Constant_Present => True,
9706 Object_Definition => New_Occurrence_Of (Tnam, Loc),
9708 -- Use a variable here to force proper freezing of Tnam
9710 Expression => Make_Null (Loc)));
9712 -- Normally, calling _TypeCode with a null access parameter
9713 -- should raise Constraint_Error, but this check is
9714 -- suppressed for expanded code, and we do not care anyway
9715 -- because we do not actually ever use this value.
9717 Args := New_List (New_Occurrence_Of (Pnam, Loc));
9722 if Sloc (U_Type) <= Standard_Location then
9724 -- Do not try to build alias typecodes for subtypes from
9727 U_Type := Base_Type (U_Type);
9730 if Is_Itype (U_Type) then
9731 return Build_TypeCode_Call
9732 (Loc, Associated_Node_For_Itype (U_Type), Decls);
9735 if U_Type = Standard_Boolean then
9738 elsif U_Type = Standard_Character then
9741 elsif U_Type = Standard_Wide_Character then
9744 elsif U_Type = Standard_Wide_Wide_Character then
9745 Lib_RE := RE_TC_WWC;
9747 -- Floating point types
9749 elsif U_Type = Standard_Short_Float then
9752 elsif U_Type = Standard_Float then
9755 elsif U_Type = Standard_Long_Float then
9758 elsif U_Type = Standard_Long_Long_Float then
9759 Lib_RE := RE_TC_LLF;
9761 -- Integer types (walk back to the base type)
9763 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9764 Lib_RE := RE_TC_SSI;
9766 elsif U_Type = Etype (Standard_Short_Integer) then
9769 elsif U_Type = Etype (Standard_Integer) then
9772 elsif U_Type = Etype (Standard_Long_Integer) then
9775 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9776 Lib_RE := RE_TC_LLI;
9778 -- Unsigned integer types
9780 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9781 Lib_RE := RE_TC_SSU;
9783 elsif U_Type = RTE (RE_Short_Unsigned) then
9786 elsif U_Type = RTE (RE_Unsigned) then
9789 elsif U_Type = RTE (RE_Long_Unsigned) then
9792 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9793 Lib_RE := RE_TC_LLU;
9795 elsif U_Type = Standard_String then
9796 Lib_RE := RE_TC_String;
9798 -- Other (non-primitive) types
9804 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
9805 Append_To (Decls, Decl);
9809 if Lib_RE /= RE_Null then
9810 Fnam := RTE (Lib_RE);
9814 -- Call the function
9817 Make_Function_Call (Loc,
9818 Name => New_Occurrence_Of (Fnam, Loc),
9819 Parameter_Associations => Args);
9821 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
9823 Set_Etype (Expr, RTE (RE_TypeCode));
9826 end Build_TypeCode_Call;
9828 -----------------------------
9829 -- Build_TypeCode_Function --
9830 -----------------------------
9832 procedure Build_TypeCode_Function
9836 Fnam : out Entity_Id)
9839 Decls : constant List_Id := New_List;
9840 Stms : constant List_Id := New_List;
9842 TCNam : constant Entity_Id :=
9843 Make_Stream_Procedure_Function_Name (Loc,
9844 Typ, Name_uTypeCode);
9846 Parameters : List_Id;
9848 procedure Add_String_Parameter
9850 Parameter_List : List_Id);
9851 -- Add a literal for S to Parameters
9853 procedure Add_TypeCode_Parameter
9855 Parameter_List : List_Id);
9856 -- Add the typecode for Typ to Parameters
9858 procedure Add_Long_Parameter
9859 (Expr_Node : Node_Id;
9860 Parameter_List : List_Id);
9861 -- Add a signed long integer expression to Parameters
9863 procedure Initialize_Parameter_List
9864 (Name_String : String_Id;
9865 Repo_Id_String : String_Id;
9866 Parameter_List : out List_Id);
9867 -- Return a list that contains the first two parameters
9868 -- for a parameterized typecode: name and repository id.
9870 function Make_Constructed_TypeCode
9872 Parameters : List_Id) return Node_Id;
9873 -- Call TC_Build with the given kind and parameters
9875 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
9876 -- Make a return statement that calls TC_Build with the given
9877 -- typecode kind, and the constructed parameters list.
9879 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
9880 -- Return a typecode that is a TC_Alias for the given typecode
9882 --------------------------
9883 -- Add_String_Parameter --
9884 --------------------------
9886 procedure Add_String_Parameter
9888 Parameter_List : List_Id)
9891 Append_To (Parameter_List,
9892 Make_Function_Call (Loc,
9894 New_Occurrence_Of (RTE (RE_TA_String), Loc),
9895 Parameter_Associations => New_List (
9896 Make_String_Literal (Loc, S))));
9897 end Add_String_Parameter;
9899 ----------------------------
9900 -- Add_TypeCode_Parameter --
9901 ----------------------------
9903 procedure Add_TypeCode_Parameter
9905 Parameter_List : List_Id)
9908 Append_To (Parameter_List,
9909 Make_Function_Call (Loc,
9911 New_Occurrence_Of (RTE (RE_TA_TC), Loc),
9912 Parameter_Associations => New_List (
9914 end Add_TypeCode_Parameter;
9916 ------------------------
9917 -- Add_Long_Parameter --
9918 ------------------------
9920 procedure Add_Long_Parameter
9921 (Expr_Node : Node_Id;
9922 Parameter_List : List_Id)
9925 Append_To (Parameter_List,
9926 Make_Function_Call (Loc,
9928 New_Occurrence_Of (RTE (RE_TA_LI), Loc),
9929 Parameter_Associations => New_List (Expr_Node)));
9930 end Add_Long_Parameter;
9932 -------------------------------
9933 -- Initialize_Parameter_List --
9934 -------------------------------
9936 procedure Initialize_Parameter_List
9937 (Name_String : String_Id;
9938 Repo_Id_String : String_Id;
9939 Parameter_List : out List_Id)
9942 Parameter_List := New_List;
9943 Add_String_Parameter (Name_String, Parameter_List);
9944 Add_String_Parameter (Repo_Id_String, Parameter_List);
9945 end Initialize_Parameter_List;
9947 ---------------------------
9948 -- Return_Alias_TypeCode --
9949 ---------------------------
9951 procedure Return_Alias_TypeCode
9952 (Base_TypeCode : Node_Id)
9955 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
9956 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
9957 end Return_Alias_TypeCode;
9959 -------------------------------
9960 -- Make_Constructed_TypeCode --
9961 -------------------------------
9963 function Make_Constructed_TypeCode
9965 Parameters : List_Id) return Node_Id
9967 Constructed_TC : constant Node_Id :=
9968 Make_Function_Call (Loc,
9970 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
9971 Parameter_Associations => New_List (
9972 New_Occurrence_Of (Kind, Loc),
9973 Make_Aggregate (Loc,
9974 Expressions => Parameters)));
9976 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
9977 return Constructed_TC;
9978 end Make_Constructed_TypeCode;
9980 ---------------------------------
9981 -- Return_Constructed_TypeCode --
9982 ---------------------------------
9984 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
9987 Make_Return_Statement (Loc,
9989 Make_Constructed_TypeCode (Kind, Parameters)));
9990 end Return_Constructed_TypeCode;
9996 procedure TC_Rec_Add_Process_Element
9999 Counter : in out Int;
10003 procedure TC_Append_Record_Traversal is
10004 new Append_Record_Traversal (
10006 Add_Process_Element => TC_Rec_Add_Process_Element);
10008 --------------------------------
10009 -- TC_Rec_Add_Process_Element --
10010 --------------------------------
10012 procedure TC_Rec_Add_Process_Element
10015 Counter : in out Int;
10019 pragma Warnings (Off);
10020 pragma Unreferenced (Any, Counter, Rec);
10021 pragma Warnings (On);
10024 if Nkind (Field) = N_Defining_Identifier then
10026 -- A regular component
10028 Add_TypeCode_Parameter (
10029 Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10030 Get_Name_String (Chars (Field));
10031 Add_String_Parameter (String_From_Name_Buffer, Params);
10038 Discriminant_Type : constant Entity_Id :=
10039 Etype (Name (Field));
10041 Is_Enum : constant Boolean :=
10042 Is_Enumeration_Type (Discriminant_Type);
10044 Union_TC_Params : List_Id;
10046 U_Name : constant Name_Id :=
10047 New_External_Name (Chars (Typ), 'U', -1);
10049 Name_Str : String_Id;
10050 Struct_TC_Params : List_Id;
10054 Default : constant Node_Id :=
10055 Make_Integer_Literal (Loc, -1);
10057 Dummy_Counter : Int := 0;
10059 procedure Add_Params_For_Variant_Components;
10060 -- Add a struct TypeCode and a corresponding member name
10061 -- to the union parameter list.
10063 -- Ordering of declarations is a complete mess in this
10064 -- area, it is supposed to be types/varibles, then
10065 -- subprogram specs, then subprogram bodies ???
10067 ---------------------------------------
10068 -- Add_Params_For_Variant_Components --
10069 ---------------------------------------
10071 procedure Add_Params_For_Variant_Components
10073 S_Name : constant Name_Id :=
10074 New_External_Name (U_Name, 'S', -1);
10077 Get_Name_String (S_Name);
10078 Name_Str := String_From_Name_Buffer;
10079 Initialize_Parameter_List
10080 (Name_Str, Name_Str, Struct_TC_Params);
10082 -- Build struct parameters
10084 TC_Append_Record_Traversal (Struct_TC_Params,
10085 Component_List (Variant),
10089 Add_TypeCode_Parameter
10090 (Make_Constructed_TypeCode
10091 (RTE (RE_TC_Struct), Struct_TC_Params),
10094 Add_String_Parameter (Name_Str, Union_TC_Params);
10095 end Add_Params_For_Variant_Components;
10098 Get_Name_String (U_Name);
10099 Name_Str := String_From_Name_Buffer;
10101 Initialize_Parameter_List
10102 (Name_Str, Name_Str, Union_TC_Params);
10104 Add_String_Parameter (Name_Str, Params);
10106 -- Add union in enclosing parameter list
10108 Add_TypeCode_Parameter
10109 (Make_Constructed_TypeCode
10110 (RTE (RE_TC_Union), Union_TC_Params),
10113 -- Build union parameters
10115 Add_TypeCode_Parameter
10116 (Discriminant_Type, Union_TC_Params);
10117 Add_Long_Parameter (Default, Union_TC_Params);
10119 Variant := First_Non_Pragma (Variants (Field));
10120 while Present (Variant) loop
10121 Choice := First (Discrete_Choices (Variant));
10122 while Present (Choice) loop
10123 case Nkind (Choice) is
10126 L : constant Uint :=
10127 Expr_Value (Low_Bound (Choice));
10128 H : constant Uint :=
10129 Expr_Value (High_Bound (Choice));
10131 -- 3.8.1(8) guarantees that the bounds of
10132 -- this range are static.
10139 Expr := New_Occurrence_Of (
10140 Get_Enum_Lit_From_Pos (
10141 Discriminant_Type, J, Loc), Loc);
10144 Make_Integer_Literal (Loc, J);
10146 Append_To (Union_TC_Params,
10147 Build_To_Any_Call (Expr, Decls));
10148 Add_Params_For_Variant_Components;
10153 when N_Others_Choice =>
10154 Add_Long_Parameter (
10155 Make_Integer_Literal (Loc, 0),
10157 Add_Params_For_Variant_Components;
10160 Append_To (Union_TC_Params,
10161 Build_To_Any_Call (Choice, Decls));
10162 Add_Params_For_Variant_Components;
10168 Next_Non_Pragma (Variant);
10173 end TC_Rec_Add_Process_Element;
10175 Type_Name_Str : String_Id;
10176 Type_Repo_Id_Str : String_Id;
10179 pragma Assert (not Is_Itype (Typ));
10183 Make_Function_Specification (Loc,
10184 Defining_Unit_Name => Fnam,
10185 Parameter_Specifications => Empty_List,
10186 Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10188 Build_Name_And_Repository_Id (Typ,
10189 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10190 Initialize_Parameter_List
10191 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10193 if Is_Derived_Type (Typ)
10194 and then not Is_Tagged_Type (Typ)
10197 D_Node : constant Node_Id := Declaration_Node (Typ);
10198 Parent_Type : Entity_Id := Etype (Typ);
10201 if Is_Enumeration_Type (Typ)
10202 and then Nkind (D_Node) = N_Subtype_Declaration
10203 and then Nkind (Original_Node (D_Node))
10204 /= N_Subtype_Declaration
10207 -- Parent_Type is the implicit intermediate base type
10208 -- created by Build_Derived_Enumeration_Type.
10210 Parent_Type := Etype (Parent_Type);
10213 Return_Alias_TypeCode (
10214 Build_TypeCode_Call (Loc, Parent_Type, Decls));
10217 elsif Is_Integer_Type (Typ)
10218 or else Is_Unsigned_Type (Typ)
10220 Return_Alias_TypeCode (
10221 Build_TypeCode_Call (Loc,
10222 Find_Numeric_Representation (Typ), Decls));
10224 elsif Is_Record_Type (Typ)
10225 and then not Is_Tagged_Type (Typ)
10227 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10228 Return_Alias_TypeCode (
10229 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10232 Disc : Entity_Id := Empty;
10233 Rdef : constant Node_Id :=
10234 Type_Definition (Declaration_Node (Typ));
10235 Dummy_Counter : Int := 0;
10237 -- First all discriminants
10239 if Has_Discriminants (Typ) then
10240 Disc := First_Discriminant (Typ);
10242 while Present (Disc) loop
10243 Add_TypeCode_Parameter (
10244 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10246 Get_Name_String (Chars (Disc));
10247 Add_String_Parameter (
10248 String_From_Name_Buffer,
10250 Next_Discriminant (Disc);
10253 -- ... then all components
10255 TC_Append_Record_Traversal
10256 (Parameters, Component_List (Rdef),
10257 Empty, Dummy_Counter);
10258 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10262 elsif Is_Array_Type (Typ) then
10264 Ndim : constant Pos := Number_Dimensions (Typ);
10265 Inner_TypeCode : Node_Id;
10266 Constrained : constant Boolean := Is_Constrained (Typ);
10267 Indx : Node_Id := First_Index (Typ);
10270 Inner_TypeCode := Build_TypeCode_Call (Loc,
10271 Component_Type (Typ),
10274 for J in 1 .. Ndim loop
10275 if Constrained then
10276 Inner_TypeCode := Make_Constructed_TypeCode
10277 (RTE (RE_TC_Array), New_List (
10278 Build_To_Any_Call (
10279 OK_Convert_To (RTE (RE_Long_Unsigned),
10280 Make_Attribute_Reference (Loc,
10282 New_Occurrence_Of (Typ, Loc),
10285 Expressions => New_List (
10286 Make_Integer_Literal (Loc,
10289 Build_To_Any_Call (Inner_TypeCode, Decls)));
10292 -- Unconstrained case: add low bound for each
10295 Add_TypeCode_Parameter
10296 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10298 Get_Name_String (New_External_Name ('L', J));
10299 Add_String_Parameter (
10300 String_From_Name_Buffer,
10304 Inner_TypeCode := Make_Constructed_TypeCode
10305 (RTE (RE_TC_Sequence), New_List (
10306 Build_To_Any_Call (
10307 OK_Convert_To (RTE (RE_Long_Unsigned),
10308 Make_Integer_Literal (Loc, 0)),
10310 Build_To_Any_Call (Inner_TypeCode, Decls)));
10314 if Constrained then
10315 Return_Alias_TypeCode (Inner_TypeCode);
10317 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10319 Store_String_Char ('V');
10320 Add_String_Parameter (End_String, Parameters);
10321 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10326 -- Default: type is represented as an opaque sequence of bytes
10328 Return_Alias_TypeCode
10329 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10333 Make_Subprogram_Body (Loc,
10334 Specification => Spec,
10335 Declarations => Decls,
10336 Handled_Statement_Sequence =>
10337 Make_Handled_Sequence_Of_Statements (Loc,
10338 Statements => Stms));
10339 end Build_TypeCode_Function;
10341 ---------------------------------
10342 -- Find_Numeric_Representation --
10343 ---------------------------------
10345 function Find_Numeric_Representation (Typ : Entity_Id)
10348 FST : constant Entity_Id := First_Subtype (Typ);
10349 P_Size : constant Uint := Esize (FST);
10352 if Is_Unsigned_Type (Typ) then
10353 if P_Size <= Standard_Short_Short_Integer_Size then
10354 return RTE (RE_Short_Short_Unsigned);
10356 elsif P_Size <= Standard_Short_Integer_Size then
10357 return RTE (RE_Short_Unsigned);
10359 elsif P_Size <= Standard_Integer_Size then
10360 return RTE (RE_Unsigned);
10362 elsif P_Size <= Standard_Long_Integer_Size then
10363 return RTE (RE_Long_Unsigned);
10366 return RTE (RE_Long_Long_Unsigned);
10369 elsif Is_Integer_Type (Typ) then
10370 if P_Size <= Standard_Short_Short_Integer_Size then
10371 return Standard_Short_Short_Integer;
10373 elsif P_Size <= Standard_Short_Integer_Size then
10374 return Standard_Short_Integer;
10376 elsif P_Size <= Standard_Integer_Size then
10377 return Standard_Integer;
10379 elsif P_Size <= Standard_Long_Integer_Size then
10380 return Standard_Long_Integer;
10383 return Standard_Long_Long_Integer;
10386 elsif Is_Floating_Point_Type (Typ) then
10387 if P_Size <= Standard_Short_Float_Size then
10388 return Standard_Short_Float;
10390 elsif P_Size <= Standard_Float_Size then
10391 return Standard_Float;
10393 elsif P_Size <= Standard_Long_Float_Size then
10394 return Standard_Long_Float;
10397 return Standard_Long_Long_Float;
10401 raise Program_Error;
10404 -- TBD: fixed point types???
10405 -- TBverified numeric types with a biased representation???
10407 end Find_Numeric_Representation;
10409 ---------------------------
10410 -- Append_Array_Traversal --
10411 ---------------------------
10413 procedure Append_Array_Traversal
10416 Counter : Entity_Id := Empty;
10419 Loc : constant Source_Ptr := Sloc (Subprogram);
10420 Typ : constant Entity_Id := Etype (Arry);
10421 Constrained : constant Boolean := Is_Constrained (Typ);
10422 Ndim : constant Pos := Number_Dimensions (Typ);
10424 Inner_Any, Inner_Counter : Entity_Id;
10426 Loop_Stm : Node_Id;
10427 Inner_Stmts : constant List_Id := New_List;
10430 if Depth > Ndim then
10432 -- Processing for one element of an array
10435 Element_Expr : constant Node_Id :=
10436 Make_Indexed_Component (Loc,
10437 New_Occurrence_Of (Arry, Loc),
10441 Set_Etype (Element_Expr, Component_Type (Typ));
10442 Add_Process_Element (Stmts,
10444 Counter => Counter,
10445 Datum => Element_Expr);
10451 Append_To (Indices,
10452 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10454 if Constrained then
10456 Inner_Counter := Counter;
10458 Inner_Any := Make_Defining_Identifier (Loc,
10459 New_External_Name ('A', Depth));
10460 Set_Etype (Inner_Any, RTE (RE_Any));
10462 if Present (Counter) then
10463 Inner_Counter := Make_Defining_Identifier (Loc,
10464 New_External_Name ('J', Depth));
10466 Inner_Counter := Empty;
10470 Append_Array_Traversal (Inner_Stmts,
10472 Counter => Inner_Counter,
10473 Depth => Depth + 1);
10476 Make_Implicit_Loop_Statement (Subprogram,
10477 Iteration_Scheme =>
10478 Make_Iteration_Scheme (Loc,
10479 Loop_Parameter_Specification =>
10480 Make_Loop_Parameter_Specification (Loc,
10481 Defining_Identifier =>
10482 Make_Defining_Identifier (Loc,
10483 Chars => New_External_Name ('L', Depth)),
10485 Discrete_Subtype_Definition =>
10486 Make_Attribute_Reference (Loc,
10487 Prefix => New_Occurrence_Of (Arry, Loc),
10488 Attribute_Name => Name_Range,
10490 Expressions => New_List (
10491 Make_Integer_Literal (Loc, Depth))))),
10492 Statements => Inner_Stmts);
10494 if Constrained then
10495 Append_To (Stmts, Loop_Stm);
10500 Decls : constant List_Id := New_List;
10501 Dimen_Stmts : constant List_Id := New_List;
10502 Length_Node : Node_Id;
10504 Inner_Any_TypeCode : constant Entity_Id :=
10505 Make_Defining_Identifier (Loc,
10506 New_External_Name ('T', Depth));
10508 Inner_Any_TypeCode_Expr : Node_Id;
10512 Inner_Any_TypeCode_Expr :=
10513 Make_Function_Call (Loc,
10515 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
10516 Parameter_Associations => New_List (
10517 New_Occurrence_Of (Any, Loc),
10518 Make_Integer_Literal (Loc, Ndim)));
10520 Inner_Any_TypeCode_Expr :=
10521 Make_Function_Call (Loc,
10523 New_Occurrence_Of (RTE (RE_Content_Type), Loc),
10524 Parameter_Associations => New_List (
10525 Make_Identifier (Loc,
10526 New_External_Name ('T', Depth - 1))));
10530 Make_Object_Declaration (Loc,
10531 Defining_Identifier => Inner_Any_TypeCode,
10532 Constant_Present => True,
10533 Object_Definition => New_Occurrence_Of (
10534 RTE (RE_TypeCode), Loc),
10535 Expression => Inner_Any_TypeCode_Expr));
10537 Make_Object_Declaration (Loc,
10538 Defining_Identifier => Inner_Any,
10539 Object_Definition =>
10540 New_Occurrence_Of (RTE (RE_Any), Loc),
10542 Make_Function_Call (Loc,
10544 New_Occurrence_Of (
10545 RTE (RE_Create_Any), Loc),
10546 Parameter_Associations => New_List (
10547 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
10549 if Present (Inner_Counter) then
10551 Make_Object_Declaration (Loc,
10552 Defining_Identifier => Inner_Counter,
10553 Object_Definition =>
10554 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
10556 Make_Integer_Literal (Loc, 0)));
10559 Length_Node := Make_Attribute_Reference (Loc,
10560 Prefix => New_Occurrence_Of (Arry, Loc),
10561 Attribute_Name => Name_Length,
10563 New_List (Make_Integer_Literal (Loc, Depth)));
10564 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
10566 Add_Process_Element (Dimen_Stmts,
10567 Datum => Length_Node,
10569 Counter => Inner_Counter);
10571 -- Loop_Stm does approrpriate processing for each element
10574 Append_To (Dimen_Stmts, Loop_Stm);
10576 -- Link outer and inner any
10578 Add_Process_Element (Dimen_Stmts,
10580 Counter => Counter,
10581 Datum => New_Occurrence_Of (Inner_Any, Loc));
10584 Make_Block_Statement (Loc,
10587 Handled_Statement_Sequence =>
10588 Make_Handled_Sequence_Of_Statements (Loc,
10589 Statements => Dimen_Stmts)));
10591 end Append_Array_Traversal;
10593 -----------------------------------------
10594 -- Make_Stream_Procedure_Function_Name --
10595 -----------------------------------------
10597 function Make_Stream_Procedure_Function_Name
10600 Nam : Name_Id) return Entity_Id
10603 -- For tagged types, we use a canonical name so that it matches
10604 -- the primitive spec. For all other cases, we use a serialized
10605 -- name so that multiple generations of the same procedure do not
10608 if Is_Tagged_Type (Typ) then
10609 return Make_Defining_Identifier (Loc, Nam);
10611 return Make_Defining_Identifier (Loc,
10613 New_External_Name (Nam, ' ', Increment_Serial_Number));
10615 end Make_Stream_Procedure_Function_Name;
10618 -----------------------------------
10619 -- Reserve_NamingContext_Methods --
10620 -----------------------------------
10622 procedure Reserve_NamingContext_Methods is
10623 Str_Resolve : constant String := "resolve";
10625 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
10626 Name_Len := Str_Resolve'Length;
10627 Overload_Counter_Table.Set (Name_Find, 1);
10628 end Reserve_NamingContext_Methods;
10630 end PolyORB_Support;
10632 -------------------------------
10633 -- RACW_Type_Is_Asynchronous --
10634 -------------------------------
10636 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
10637 Asynchronous_Flag : constant Entity_Id :=
10638 Asynchronous_Flags_Table.Get (RACW_Type);
10640 Replace (Expression (Parent (Asynchronous_Flag)),
10641 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
10642 end RACW_Type_Is_Asynchronous;
10644 -------------------------
10645 -- RCI_Package_Locator --
10646 -------------------------
10648 function RCI_Package_Locator
10650 Package_Spec : Node_Id) return Node_Id
10653 Pkg_Name : String_Id;
10656 Get_Library_Unit_Name_String (Package_Spec);
10657 Pkg_Name := String_From_Name_Buffer;
10659 Make_Package_Instantiation (Loc,
10660 Defining_Unit_Name =>
10661 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
10663 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
10664 Generic_Associations => New_List (
10665 Make_Generic_Association (Loc,
10667 Make_Identifier (Loc, Name_RCI_Name),
10668 Explicit_Generic_Actual_Parameter =>
10669 Make_String_Literal (Loc,
10670 Strval => Pkg_Name))));
10672 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
10673 Defining_Unit_Name (Inst));
10675 end RCI_Package_Locator;
10677 -----------------------------------------------
10678 -- Remote_Types_Tagged_Full_View_Encountered --
10679 -----------------------------------------------
10681 procedure Remote_Types_Tagged_Full_View_Encountered
10682 (Full_View : Entity_Id)
10684 Stub_Elements : constant Stub_Structure :=
10685 Stubs_Table.Get (Full_View);
10687 if Stub_Elements /= Empty_Stub_Structure then
10688 Add_RACW_Primitive_Declarations_And_Bodies
10690 Stub_Elements.RPC_Receiver_Decl,
10691 List_Containing (Declaration_Node (Full_View)));
10693 end Remote_Types_Tagged_Full_View_Encountered;
10695 -------------------
10696 -- Scope_Of_Spec --
10697 -------------------
10699 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
10700 Unit_Name : Node_Id := Defining_Unit_Name (Spec);
10703 while Nkind (Unit_Name) /= N_Defining_Identifier loop
10704 Unit_Name := Defining_Identifier (Unit_Name);
10710 ----------------------
10711 -- Set_Renaming_TSS --
10712 ----------------------
10714 procedure Set_Renaming_TSS
10717 TSS_Nam : TSS_Name_Type)
10719 Loc : constant Source_Ptr := Sloc (Nam);
10720 Spec : constant Node_Id := Parent (Nam);
10722 TSS_Node : constant Node_Id :=
10723 Make_Subprogram_Renaming_Declaration (Loc,
10725 Copy_Specification (Loc,
10727 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
10728 Name => New_Occurrence_Of (Nam, Loc));
10730 Snam : constant Entity_Id :=
10731 Defining_Unit_Name (Specification (TSS_Node));
10734 if Nkind (Spec) = N_Function_Specification then
10735 Set_Ekind (Snam, E_Function);
10736 Set_Etype (Snam, Entity (Subtype_Mark (Spec)));
10738 Set_Ekind (Snam, E_Procedure);
10739 Set_Etype (Snam, Standard_Void_Type);
10742 Set_TSS (Typ, Snam);
10743 end Set_Renaming_TSS;
10745 ----------------------------------------------
10746 -- Specific_Add_Obj_RPC_Receiver_Completion --
10747 ----------------------------------------------
10749 procedure Specific_Add_Obj_RPC_Receiver_Completion
10752 RPC_Receiver : Entity_Id;
10753 Stub_Elements : Stub_Structure) is
10755 case Get_PCS_Name is
10756 when Name_PolyORB_DSA =>
10757 PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
10758 Decls, RPC_Receiver, Stub_Elements);
10760 GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
10761 Decls, RPC_Receiver, Stub_Elements);
10763 end Specific_Add_Obj_RPC_Receiver_Completion;
10765 --------------------------------
10766 -- Specific_Add_RACW_Features --
10767 --------------------------------
10769 procedure Specific_Add_RACW_Features
10770 (RACW_Type : Entity_Id;
10772 Stub_Type : Entity_Id;
10773 Stub_Type_Access : Entity_Id;
10774 RPC_Receiver_Decl : Node_Id;
10775 Declarations : List_Id) is
10777 case Get_PCS_Name is
10778 when Name_PolyORB_DSA =>
10779 PolyORB_Support.Add_RACW_Features (
10788 GARLIC_Support.Add_RACW_Features (
10795 end Specific_Add_RACW_Features;
10797 --------------------------------
10798 -- Specific_Add_RAST_Features --
10799 --------------------------------
10801 procedure Specific_Add_RAST_Features
10802 (Vis_Decl : Node_Id;
10803 RAS_Type : Entity_Id;
10807 case Get_PCS_Name is
10808 when Name_PolyORB_DSA =>
10809 PolyORB_Support.Add_RAST_Features (
10810 Vis_Decl, RAS_Type, Decls);
10812 GARLIC_Support.Add_RAST_Features (
10813 Vis_Decl, RAS_Type, Decls);
10815 end Specific_Add_RAST_Features;
10817 --------------------------------------------------
10818 -- Specific_Add_Receiving_Stubs_To_Declarations --
10819 --------------------------------------------------
10821 procedure Specific_Add_Receiving_Stubs_To_Declarations
10822 (Pkg_Spec : Node_Id;
10826 case Get_PCS_Name is
10827 when Name_PolyORB_DSA =>
10828 PolyORB_Support.Add_Receiving_Stubs_To_Declarations (
10831 GARLIC_Support.Add_Receiving_Stubs_To_Declarations (
10834 end Specific_Add_Receiving_Stubs_To_Declarations;
10836 ------------------------------------------
10837 -- Specific_Build_General_Calling_Stubs --
10838 ------------------------------------------
10840 procedure Specific_Build_General_Calling_Stubs
10842 Statements : List_Id;
10843 Target : RPC_Target;
10844 Subprogram_Id : Node_Id;
10845 Asynchronous : Node_Id := Empty;
10846 Is_Known_Asynchronous : Boolean := False;
10847 Is_Known_Non_Asynchronous : Boolean := False;
10848 Is_Function : Boolean;
10850 Stub_Type : Entity_Id := Empty;
10851 RACW_Type : Entity_Id := Empty;
10855 case Get_PCS_Name is
10856 when Name_PolyORB_DSA =>
10857 PolyORB_Support.Build_General_Calling_Stubs (
10863 Is_Known_Asynchronous,
10864 Is_Known_Non_Asynchronous,
10871 GARLIC_Support.Build_General_Calling_Stubs (
10875 Target.RPC_Receiver,
10878 Is_Known_Asynchronous,
10879 Is_Known_Non_Asynchronous,
10886 end Specific_Build_General_Calling_Stubs;
10888 --------------------------------------
10889 -- Specific_Build_RPC_Receiver_Body --
10890 --------------------------------------
10892 procedure Specific_Build_RPC_Receiver_Body
10893 (RPC_Receiver : Entity_Id;
10894 Request : out Entity_Id;
10895 Subp_Id : out Entity_Id;
10896 Subp_Index : out Entity_Id;
10897 Stmts : out List_Id;
10898 Decl : out Node_Id)
10901 case Get_PCS_Name is
10902 when Name_PolyORB_DSA =>
10903 PolyORB_Support.Build_RPC_Receiver_Body
10911 GARLIC_Support.Build_RPC_Receiver_Body
10919 end Specific_Build_RPC_Receiver_Body;
10921 --------------------------------
10922 -- Specific_Build_Stub_Target --
10923 --------------------------------
10925 function Specific_Build_Stub_Target
10928 RCI_Locator : Entity_Id;
10929 Controlling_Parameter : Entity_Id) return RPC_Target is
10931 case Get_PCS_Name is
10932 when Name_PolyORB_DSA =>
10933 return PolyORB_Support.Build_Stub_Target (Loc,
10934 Decls, RCI_Locator, Controlling_Parameter);
10936 return GARLIC_Support.Build_Stub_Target (Loc,
10937 Decls, RCI_Locator, Controlling_Parameter);
10939 end Specific_Build_Stub_Target;
10941 ------------------------------
10942 -- Specific_Build_Stub_Type --
10943 ------------------------------
10945 procedure Specific_Build_Stub_Type
10946 (RACW_Type : Entity_Id;
10947 Stub_Type : Entity_Id;
10948 Stub_Type_Decl : out Node_Id;
10949 RPC_Receiver_Decl : out Node_Id)
10952 case Get_PCS_Name is
10953 when Name_PolyORB_DSA =>
10954 PolyORB_Support.Build_Stub_Type (
10955 RACW_Type, Stub_Type,
10956 Stub_Type_Decl, RPC_Receiver_Decl);
10958 GARLIC_Support.Build_Stub_Type (
10959 RACW_Type, Stub_Type,
10960 Stub_Type_Decl, RPC_Receiver_Decl);
10962 end Specific_Build_Stub_Type;
10964 function Specific_Build_Subprogram_Receiving_Stubs
10965 (Vis_Decl : Node_Id;
10966 Asynchronous : Boolean;
10967 Dynamically_Asynchronous : Boolean := False;
10968 Stub_Type : Entity_Id := Empty;
10969 RACW_Type : Entity_Id := Empty;
10970 Parent_Primitive : Entity_Id := Empty) return Node_Id is
10972 case Get_PCS_Name is
10973 when Name_PolyORB_DSA =>
10974 return PolyORB_Support.Build_Subprogram_Receiving_Stubs (
10977 Dynamically_Asynchronous,
10982 return GARLIC_Support.Build_Subprogram_Receiving_Stubs (
10985 Dynamically_Asynchronous,
10990 end Specific_Build_Subprogram_Receiving_Stubs;
10992 --------------------------
10993 -- Underlying_RACW_Type --
10994 --------------------------
10996 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
10997 Record_Type : Entity_Id;
11000 if Ekind (RAS_Typ) = E_Record_Type then
11001 Record_Type := RAS_Typ;
11003 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11004 Record_Type := Equivalent_Type (RAS_Typ);
11008 Etype (Subtype_Indication (
11009 Component_Definition (
11010 First (Component_Items (Component_List (
11011 Type_Definition (Declaration_Node (Record_Type))))))));
11012 end Underlying_RACW_Type;