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 procedure Add_RAS_Dereference_TSS (N : Node_Id);
156 -- Add a subprogram body for RAS Dereference TSS
158 procedure Add_RAS_Proxy_And_Analyze
161 All_Calls_Remote_E : Entity_Id;
162 Proxy_Object_Addr : out Entity_Id);
163 -- Add the proxy type necessary to call the subprogram declared
164 -- by Vis_Decl through a remote access to subprogram type.
165 -- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote
166 -- applies, Standard_False otherwise. The new proxy type is appended
167 -- to Decls. Proxy_Object_Addr is a constant of type System.Address that
168 -- designates an instance of the proxy object.
170 function Build_Remote_Subprogram_Proxy_Type
172 ACR_Expression : Node_Id) return Node_Id;
173 -- Build and return a tagged record type definition for an RCI
174 -- subprogram proxy type.
175 -- ACR_Expression is use as the initialization value for
176 -- the All_Calls_Remote component.
178 function Build_Get_Unique_RP_Call
181 Stub_Type : Entity_Id) return List_Id;
182 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
183 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
184 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
186 function Build_Subprogram_Calling_Stubs
189 Asynchronous : Boolean;
190 Dynamically_Asynchronous : Boolean := False;
191 Stub_Type : Entity_Id := Empty;
192 RACW_Type : Entity_Id := Empty;
193 Locator : Entity_Id := Empty;
194 New_Name : Name_Id := No_Name) return Node_Id;
195 -- Build the calling stub for a given subprogram with the subprogram ID
196 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
197 -- parameters of this type will be marshalled instead of the object
198 -- itself. It will then be converted into Stub_Type before performing
199 -- the real call. If Dynamically_Asynchronous is True, then it will be
200 -- computed at run time whether the call is asynchronous or not.
201 -- Otherwise, the value of the formal Asynchronous will be used.
202 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
203 -- New_Name is given, then it will be used instead of the original name.
205 function Build_RPC_Receiver_Specification
206 (RPC_Receiver : Entity_Id;
207 Request_Parameter : Entity_Id) return Node_Id;
208 -- Make a subprogram specification for an RPC receiver, with the given
209 -- defining unit name and formal parameter.
211 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
212 -- Return an ordered parameter list: unconstrained parameters are put
213 -- at the beginning of the list and constrained ones are put after. If
214 -- there are no parameters, an empty list is returned. Special case:
215 -- the controlling formal of the equivalent RACW operation for a RAS
216 -- type is always left in first position.
218 procedure Add_Calling_Stubs_To_Declarations
221 -- Add calling stubs to the declarative part
223 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
224 -- Return True if nothing prevents the program whose specification is
225 -- given to be asynchronous (i.e. no out parameter).
227 function Pack_Entity_Into_Stream_Access
231 Etyp : Entity_Id := Empty) return Node_Id;
232 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
233 -- then Etype (Object) will be used if present. If the type is
234 -- constrained, then 'Write will be used to output the object,
235 -- If the type is unconstrained, 'Output will be used.
237 function Pack_Node_Into_Stream
241 Etyp : Entity_Id) return Node_Id;
242 -- Similar to above, with an arbitrary node instead of an entity
244 function Pack_Node_Into_Stream_Access
248 Etyp : Entity_Id) return Node_Id;
249 -- Similar to above, with Stream instead of Stream'Access
251 function Make_Selected_Component
254 Selector_Name : Name_Id) return Node_Id;
255 -- Return a selected_component whose prefix denotes the given entity,
256 -- and with the given Selector_Name.
258 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
259 -- Return the scope represented by a given spec
261 procedure Set_Renaming_TSS
264 TSS_Nam : TSS_Name_Type);
265 -- Create a renaming declaration of subprogram Nam,
266 -- and register it as a TSS for Typ with name TSS_Nam.
268 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
269 -- Return True if the current parameter needs an extra formal to reflect
270 -- its constrained status.
272 function Is_RACW_Controlling_Formal
273 (Parameter : Node_Id; Stub_Type : Entity_Id) return Boolean;
274 -- Return True if the current parameter is a controlling formal argument
275 -- of type Stub_Type or access to Stub_Type.
277 procedure Declare_Create_NVList
282 -- Append the declaration of NVList to Decls, and its
283 -- initialization to Stmts.
285 function Add_Parameter_To_NVList
288 Parameter : Entity_Id;
289 Constrained : Boolean;
290 RACW_Ctrl : Boolean := False;
291 Any : Entity_Id) return Node_Id;
292 -- Return a call to Add_Item to add the Any corresponding
293 -- to the designated formal Parameter (with the indicated
294 -- Constrained status) to NVList. RACW_Ctrl must be set to
295 -- True for controlling formals of distributed object primitive
298 type Stub_Structure is record
299 Stub_Type : Entity_Id;
300 Stub_Type_Access : Entity_Id;
301 RPC_Receiver_Decl : Node_Id;
302 RACW_Type : Entity_Id;
304 -- This structure is necessary because of the two phases analysis of
305 -- a RACW declaration occurring in the same Remote_Types package as the
306 -- designated type. RACW_Type is any of the RACW types pointing on this
307 -- designated type, it is used here to save an anonymous type creation
308 -- for each primitive operation.
310 -- For a RACW that implements a RAS, no object RPC receiver is generated.
311 -- Instead, RPC_Receiver_Decl is the declaration after which the
312 -- RPC receiver would have been inserted.
314 Empty_Stub_Structure : constant Stub_Structure :=
315 (Empty, Empty, Empty, Empty);
317 package Stubs_Table is
318 new Simple_HTable (Header_Num => Hash_Index,
319 Element => Stub_Structure,
320 No_Element => Empty_Stub_Structure,
324 -- Mapping between a RACW designated type and its stub type
326 package Asynchronous_Flags_Table is
327 new Simple_HTable (Header_Num => Hash_Index,
328 Element => Entity_Id,
333 -- Mapping between a RACW type and a constant having the value True
334 -- if the RACW is asynchronous and False otherwise.
336 package RCI_Locator_Table is
337 new Simple_HTable (Header_Num => Hash_Index,
338 Element => Entity_Id,
343 -- Mapping between a RCI package on which All_Calls_Remote applies and
344 -- the generic instantiation of RCI_Locator for this package.
346 package RCI_Calling_Stubs_Table is
347 new Simple_HTable (Header_Num => Hash_Index,
348 Element => Entity_Id,
353 -- Mapping between a RCI subprogram and the corresponding calling stubs
355 procedure Add_Stub_Type
356 (Designated_Type : Entity_Id;
357 RACW_Type : Entity_Id;
359 Stub_Type : out Entity_Id;
360 Stub_Type_Access : out Entity_Id;
361 RPC_Receiver_Decl : out Node_Id;
362 Existing : out Boolean);
363 -- Add the declaration of the stub type, the access to stub type and the
364 -- object RPC receiver at the end of Decls. If these already exist,
365 -- then nothing is added in the tree but the right values are returned
366 -- anyhow and Existing is set to True.
368 procedure Add_RACW_Asynchronous_Flag
369 (Declarations : List_Id;
370 RACW_Type : Entity_Id);
371 -- Declare a boolean constant associated with RACW_Type whose value
372 -- indicates at run time whether a pragma Asynchronous applies to it.
374 procedure Assign_Subprogram_Identifier
378 -- Determine the distribution subprogram identifier to
379 -- be used for remote subprogram Def, return it in Id and
380 -- store it in a hash table for later retrieval by
381 -- Get_Subprogram_Id. Spn is the subprogram number.
383 function RCI_Package_Locator
385 Package_Spec : Node_Id) return Node_Id;
386 -- Instantiate the generic package RCI_Locator in order to locate the
387 -- RCI package whose spec is given as argument.
389 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
390 -- Surround a node N by a tag check, as in:
394 -- when E : Ada.Tags.Tag_Error =>
395 -- Raise_Exception (Program_Error'Identity,
396 -- Exception_Message (E));
399 function Input_With_Tag_Check
401 Var_Type : Entity_Id;
402 Stream : Node_Id) return Node_Id;
403 -- Return a function with the following form:
404 -- function R return Var_Type is
406 -- return Var_Type'Input (S);
408 -- when E : Ada.Tags.Tag_Error =>
409 -- Raise_Exception (Program_Error'Identity,
410 -- Exception_Message (E));
413 --------------------------------------------
414 -- Hooks for PCS-specific code generation --
415 --------------------------------------------
417 -- Part of the code generation circuitry for distribution needs to be
418 -- tailored for each implementation of the PCS. For each routine that
419 -- needs to be specialized, a Specific_<routine> wrapper is created,
420 -- which calls the corresponding <routine> in package
421 -- <pcs_implementation>_Support.
423 procedure Specific_Add_RACW_Features
424 (RACW_Type : Entity_Id;
426 Stub_Type : Entity_Id;
427 Stub_Type_Access : Entity_Id;
428 RPC_Receiver_Decl : Node_Id;
429 Declarations : List_Id);
430 -- Add declaration for TSSs for a given RACW type. The declarations are
431 -- added just after the declaration of the RACW type itself, while the
432 -- bodies are inserted at the end of Decls. Runtime-specific ancillary
433 -- subprogram for Add_RACW_Features.
435 procedure Specific_Add_RAST_Features
437 RAS_Type : Entity_Id);
438 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
439 -- subprogram for Add_RAST_Features.
441 -- An RPC_Target record is used during construction of calling stubs
442 -- to pass PCS-specific tree fragments corresponding to the information
443 -- necessary to locate the target of a remote subprogram call.
445 type RPC_Target (PCS_Kind : PCS_Names) is record
447 when Name_PolyORB_DSA =>
449 -- An expression whose value is a PolyORB reference to the target
452 Partition : Entity_Id;
453 -- A variable containing the Partition_ID of the target parition
455 RPC_Receiver : Node_Id;
456 -- An expression whose value is the address of the target RPC
461 procedure Specific_Build_General_Calling_Stubs
463 Statements : List_Id;
465 Subprogram_Id : Node_Id;
466 Asynchronous : Node_Id := Empty;
467 Is_Known_Asynchronous : Boolean := False;
468 Is_Known_Non_Asynchronous : Boolean := False;
469 Is_Function : Boolean;
471 Stub_Type : Entity_Id := Empty;
472 RACW_Type : Entity_Id := Empty;
474 -- Build calling stubs for general purpose. The parameters are:
475 -- Decls : a place to put declarations
476 -- Statements : a place to put statements
477 -- Target : PCS-specific target information (see details
478 -- in RPC_Target declaration).
479 -- Subprogram_Id : a node containing the subprogram ID
480 -- Asynchronous : True if an APC must be made instead of an RPC.
481 -- The value needs not be supplied if one of the
482 -- Is_Known_... is True.
483 -- Is_Known_Async... : True if we know that this is asynchronous
484 -- Is_Known_Non_A... : True if we know that this is not asynchronous
485 -- Spec : a node with a Parameter_Specifications and
486 -- a Subtype_Mark if applicable
487 -- Stub_Type : in case of RACW stubs, parameters of type access
488 -- to Stub_Type will be marshalled using the
489 -- address of the object (the addr field) rather
490 -- than using the 'Write on the stub itself
491 -- Nod : used to provide sloc for generated code
493 function Specific_Build_Stub_Target
496 RCI_Locator : Entity_Id;
497 Controlling_Parameter : Entity_Id) return RPC_Target;
498 -- Build call target information nodes for use within calling stubs. In the
499 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
500 -- for an RACW, Controlling_Parameter is the entity for the controlling
501 -- formal parameter used to determine the location of the target of the
502 -- call. Decls provides a location where variable declarations can be
503 -- appended to construct the necessary values.
505 procedure Specific_Build_Stub_Type
506 (RACW_Type : Entity_Id;
507 Stub_Type : Entity_Id;
508 Stub_Type_Decl : out Node_Id;
509 RPC_Receiver_Decl : out Node_Id);
510 -- Build a type declaration for the stub type associated with an RACW
511 -- type, and the necessary RPC receiver, if applicable. PCS-specific
512 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
513 -- is generated, then RPC_Receiver_Decl is set to Empty.
515 procedure Specific_Build_RPC_Receiver_Body
516 (RPC_Receiver : Entity_Id;
517 Request : out Entity_Id;
518 Subp_Id : out Entity_Id;
519 Subp_Index : out Entity_Id;
522 -- Make a subprogram body for an RPC receiver, with the given
523 -- defining unit name. On return:
524 -- - Subp_Id is the subprogram identifier from the PCS.
525 -- - Subp_Index is the index in the list of subprograms
526 -- used for dispatching (a variable of type Subprogram_Id).
527 -- - Stmts is the place where the request dispatching
528 -- statements can occur,
529 -- - Decl is the subprogram body declaration.
531 function Specific_Build_Subprogram_Receiving_Stubs
533 Asynchronous : Boolean;
534 Dynamically_Asynchronous : Boolean := False;
535 Stub_Type : Entity_Id := Empty;
536 RACW_Type : Entity_Id := Empty;
537 Parent_Primitive : Entity_Id := Empty) return Node_Id;
538 -- Build the receiving stub for a given subprogram. The subprogram
539 -- declaration is also built by this procedure, and the value returned
540 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
541 -- found in the specification, then its address is read from the stream
542 -- instead of the object itself and converted into an access to
543 -- class-wide type before doing the real call using any of the RACW type
544 -- pointing on the designated type.
546 procedure Specific_Add_Obj_RPC_Receiver_Completion
549 RPC_Receiver : Entity_Id;
550 Stub_Elements : Stub_Structure);
551 -- Add the necessary code to Decls after the completion of generation
552 -- of the RACW RPC receiver described by Stub_Elements.
554 procedure Specific_Add_Receiving_Stubs_To_Declarations
557 -- Add receiving stubs to the declarative part of an RCI unit
559 package GARLIC_Support is
561 -- Support for generating DSA code that uses the GARLIC PCS
563 -- The subprograms below provide the GARLIC versions of
564 -- the corresponding Specific_<subprogram> routine declared
567 procedure Add_RACW_Features
568 (RACW_Type : Entity_Id;
569 Stub_Type : Entity_Id;
570 Stub_Type_Access : Entity_Id;
571 RPC_Receiver_Decl : Node_Id;
572 Declarations : List_Id);
574 procedure Add_RAST_Features
576 RAS_Type : Entity_Id);
578 procedure Build_General_Calling_Stubs
580 Statements : List_Id;
581 Target_Partition : Entity_Id; -- From RPC_Target
582 Target_RPC_Receiver : Node_Id; -- From RPC_Target
583 Subprogram_Id : Node_Id;
584 Asynchronous : Node_Id := Empty;
585 Is_Known_Asynchronous : Boolean := False;
586 Is_Known_Non_Asynchronous : Boolean := False;
587 Is_Function : Boolean;
589 Stub_Type : Entity_Id := Empty;
590 RACW_Type : Entity_Id := Empty;
593 function Build_Stub_Target
596 RCI_Locator : Entity_Id;
597 Controlling_Parameter : Entity_Id) return RPC_Target;
599 procedure Build_Stub_Type
600 (RACW_Type : Entity_Id;
601 Stub_Type : Entity_Id;
602 Stub_Type_Decl : out Node_Id;
603 RPC_Receiver_Decl : out Node_Id);
605 function Build_Subprogram_Receiving_Stubs
607 Asynchronous : Boolean;
608 Dynamically_Asynchronous : Boolean := False;
609 Stub_Type : Entity_Id := Empty;
610 RACW_Type : Entity_Id := Empty;
611 Parent_Primitive : Entity_Id := Empty) return Node_Id;
613 procedure Add_Obj_RPC_Receiver_Completion
616 RPC_Receiver : Entity_Id;
617 Stub_Elements : Stub_Structure);
619 procedure Add_Receiving_Stubs_To_Declarations
623 procedure Build_RPC_Receiver_Body
624 (RPC_Receiver : Entity_Id;
625 Request : out Entity_Id;
626 Subp_Id : out Entity_Id;
627 Subp_Index : out Entity_Id;
633 package PolyORB_Support is
635 -- Support for generating DSA code that uses the PolyORB PCS
637 -- The subprograms below provide the PolyORB versions of
638 -- the corresponding Specific_<subprogram> routine declared
641 procedure Add_RACW_Features
642 (RACW_Type : Entity_Id;
644 Stub_Type : Entity_Id;
645 Stub_Type_Access : Entity_Id;
646 RPC_Receiver_Decl : Node_Id;
647 Declarations : List_Id);
649 procedure Add_RAST_Features
651 RAS_Type : Entity_Id);
653 procedure Build_General_Calling_Stubs
655 Statements : List_Id;
656 Target_Object : Node_Id; -- From RPC_Target
657 Subprogram_Id : Node_Id;
658 Asynchronous : Node_Id := Empty;
659 Is_Known_Asynchronous : Boolean := False;
660 Is_Known_Non_Asynchronous : Boolean := False;
661 Is_Function : Boolean;
663 Stub_Type : Entity_Id := Empty;
664 RACW_Type : Entity_Id := Empty;
667 function Build_Stub_Target
670 RCI_Locator : Entity_Id;
671 Controlling_Parameter : Entity_Id) return RPC_Target;
673 procedure Build_Stub_Type
674 (RACW_Type : Entity_Id;
675 Stub_Type : Entity_Id;
676 Stub_Type_Decl : out Node_Id;
677 RPC_Receiver_Decl : out Node_Id);
679 function Build_Subprogram_Receiving_Stubs
681 Asynchronous : Boolean;
682 Dynamically_Asynchronous : Boolean := False;
683 Stub_Type : Entity_Id := Empty;
684 RACW_Type : Entity_Id := Empty;
685 Parent_Primitive : Entity_Id := Empty) return Node_Id;
687 procedure Add_Obj_RPC_Receiver_Completion
690 RPC_Receiver : Entity_Id;
691 Stub_Elements : Stub_Structure);
693 procedure Add_Receiving_Stubs_To_Declarations
697 procedure Build_RPC_Receiver_Body
698 (RPC_Receiver : Entity_Id;
699 Request : out Entity_Id;
700 Subp_Id : out Entity_Id;
701 Subp_Index : out Entity_Id;
705 procedure Reserve_NamingContext_Methods;
706 -- Mark the method names for interface NamingContext as already used in
707 -- the overload table, so no clashes occur with user code (with the
708 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
709 -- their methods to be accessed as objects, for the implementation of
710 -- remote access-to-subprogram types).
714 -- Routines to build distribtion helper subprograms for user-defined
715 -- types. For implementation of the Distributed systems annex (DSA)
716 -- over the PolyORB generic middleware components, it is necessary to
717 -- generate several supporting subprograms for each application data
718 -- type used in inter-partition communication. These subprograms are:
719 -- * a Typecode function returning a high-level description of the
721 -- * two conversion functions allowing conversion of values of the
722 -- type from and to the generic data containers used by PolyORB.
723 -- These generic containers are called 'Any' type values after
724 -- the CORBA terminology, and hence the conversion subprograms
725 -- are named To_Any and From_Any.
727 function Build_From_Any_Call
730 Decls : List_Id) return Node_Id;
731 -- Build call to From_Any attribute function of type Typ with
732 -- expression N as actual parameter. Decls is the declarations list
733 -- for an appropriate enclosing scope of the point where the call
734 -- will be inserted; if the From_Any attribute for Typ needs to be
735 -- generated at this point, its declaration is appended to Decls.
737 procedure Build_From_Any_Function
741 Fnam : out Entity_Id);
742 -- Build From_Any attribute function for Typ. Loc is the reference
743 -- location for generated nodes, Typ is the type for which the
744 -- conversion function is generated. On return, Decl and Fnam contain
745 -- the declaration and entity for the newly-created function.
747 function Build_To_Any_Call
749 Decls : List_Id) return Node_Id;
750 -- Build call to To_Any attribute function with expression as actual
751 -- parameter. Decls is the declarations list for an appropriate
752 -- enclosing scope of the point where the call will be inserted; if
753 -- the To_Any attribute for Typ needs to be generated at this point,
754 -- its declaration is appended to Decls.
756 procedure Build_To_Any_Function
760 Fnam : out Entity_Id);
761 -- Build To_Any attribute function for Typ. Loc is the reference
762 -- location for generated nodes, Typ is the type for which the
763 -- conversion function is generated. On return, Decl and Fnam contain
764 -- the declaration and entity for the newly-created function.
766 function Build_TypeCode_Call
769 Decls : List_Id) return Node_Id;
770 -- Build call to TypeCode attribute function for Typ. Decls is the
771 -- declarations list for an appropriate enclosing scope of the point
772 -- where the call will be inserted; if the To_Any attribute for Typ
773 -- needs to be generated at this point, its declaration is appended
776 procedure Build_TypeCode_Function
780 Fnam : out Entity_Id);
781 -- Build TypeCode attribute function for Typ. Loc is the reference
782 -- location for generated nodes, Typ is the type for which the
783 -- conversion function is generated. On return, Decl and Fnam contain
784 -- the declaration and entity for the newly-created function.
786 procedure Build_Name_And_Repository_Id
788 Name_Str : out String_Id;
789 Repo_Id_Str : out String_Id);
790 -- In the PolyORB distribution model, each distributed object type
791 -- and each distributed operation has a globally unique identifier,
792 -- its Repository Id. This subprogram builds and returns two strings
793 -- for entity E (a distributed object type or operation): one
794 -- containing the name of E, the second containing its repository id.
800 ------------------------------------
801 -- Local variables and structures --
802 ------------------------------------
805 -- Needs comments ???
807 Output_From_Constrained : constant array (Boolean) of Name_Id :=
808 (False => Name_Output,
810 -- The attribute to choose depending on the fact that the parameter
811 -- is constrained or not. There is no such thing as Input_From_Constrained
812 -- since this require separate mechanisms ('Input is a function while
813 -- 'Read is a procedure).
815 ---------------------------------------
816 -- Add_Calling_Stubs_To_Declarations --
817 ---------------------------------------
819 procedure Add_Calling_Stubs_To_Declarations
823 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
824 -- Subprogram id 0 is reserved for calls received from
825 -- remote access-to-subprogram dereferences.
827 Current_Declaration : Node_Id;
828 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
829 RCI_Instantiation : Node_Id;
830 Subp_Stubs : Node_Id;
831 Subp_Str : String_Id;
834 -- The first thing added is an instantiation of the generic package
835 -- System.Partition_Interface.RCI_Locator with the name of this
836 -- remote package. This will act as an interface with the name server
837 -- to determine the Partition_ID and the RPC_Receiver for the
838 -- receiver of this package.
840 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
841 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
843 Append_To (Decls, RCI_Instantiation);
844 Analyze (RCI_Instantiation);
846 -- For each subprogram declaration visible in the spec, we do
847 -- build a body. We also increment a counter to assign a different
848 -- Subprogram_Id to each subprograms. The receiving stubs processing
849 -- do use the same mechanism and will thus assign the same Id and
850 -- do the correct dispatching.
852 Overload_Counter_Table.Reset;
853 PolyORB_Support.Reserve_NamingContext_Methods;
855 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
857 while Present (Current_Declaration) loop
858 if Nkind (Current_Declaration) = N_Subprogram_Declaration
859 and then Comes_From_Source (Current_Declaration)
861 Assign_Subprogram_Identifier (
862 Defining_Unit_Name (Specification (Current_Declaration)),
863 Current_Subprogram_Number,
867 Build_Subprogram_Calling_Stubs (
868 Vis_Decl => Current_Declaration,
870 Build_Subprogram_Id (Loc,
871 Defining_Unit_Name (Specification (Current_Declaration))),
873 Nkind (Specification (Current_Declaration)) =
874 N_Procedure_Specification
876 Is_Asynchronous (Defining_Unit_Name (Specification
877 (Current_Declaration))));
879 Append_To (Decls, Subp_Stubs);
880 Analyze (Subp_Stubs);
882 Current_Subprogram_Number := Current_Subprogram_Number + 1;
885 Next (Current_Declaration);
887 end Add_Calling_Stubs_To_Declarations;
889 -----------------------------
890 -- Add_Parameter_To_NVList --
891 -----------------------------
893 function Add_Parameter_To_NVList
896 Parameter : Entity_Id;
897 Constrained : Boolean;
898 RACW_Ctrl : Boolean := False;
899 Any : Entity_Id) return Node_Id
901 Parameter_Name_String : String_Id;
902 Parameter_Mode : Node_Id;
904 function Parameter_Passing_Mode
906 Parameter : Entity_Id;
907 Constrained : Boolean) return Node_Id;
908 -- Return an expression that denotes the parameter passing
909 -- mode to be used for Parameter in distribution stubs,
910 -- where Constrained is Parameter's constrained status.
912 ----------------------------
913 -- Parameter_Passing_Mode --
914 ----------------------------
916 function Parameter_Passing_Mode
918 Parameter : Entity_Id;
919 Constrained : Boolean) return Node_Id
924 if Out_Present (Parameter) then
925 if In_Present (Parameter)
926 or else not Constrained
928 -- Unconstrained formals must be translated
929 -- to 'in' or 'inout', not 'out', because
930 -- they need to be constrained by the actual.
932 Lib_RE := RE_Mode_Inout;
934 Lib_RE := RE_Mode_Out;
938 Lib_RE := RE_Mode_In;
941 return New_Occurrence_Of (RTE (Lib_RE), Loc);
942 end Parameter_Passing_Mode;
944 -- Start of processing for Add_Parameter_To_NVList
947 if Nkind (Parameter) = N_Defining_Identifier then
948 Get_Name_String (Chars (Parameter));
950 Get_Name_String (Chars (Defining_Identifier
954 Parameter_Name_String := String_From_Name_Buffer;
957 Parameter_Mode := New_Occurrence_Of
958 (RTE (RE_Mode_In), Loc);
960 Parameter_Mode := Parameter_Passing_Mode (Loc,
961 Parameter, Constrained);
965 Make_Procedure_Call_Statement (Loc,
968 (RTE (RE_NVList_Add_Item), Loc),
969 Parameter_Associations => New_List (
970 New_Occurrence_Of (NVList, Loc),
971 Make_Function_Call (Loc,
974 (RTE (RE_To_PolyORB_String), Loc),
975 Parameter_Associations => New_List (
976 Make_String_Literal (Loc,
977 Strval => Parameter_Name_String))),
978 New_Occurrence_Of (Any, Loc),
980 end Add_Parameter_To_NVList;
982 --------------------------------
983 -- Add_RACW_Asynchronous_Flag --
984 --------------------------------
986 procedure Add_RACW_Asynchronous_Flag
987 (Declarations : List_Id;
988 RACW_Type : Entity_Id)
990 Loc : constant Source_Ptr := Sloc (RACW_Type);
992 Asynchronous_Flag : constant Entity_Id :=
993 Make_Defining_Identifier (Loc,
994 New_External_Name (Chars (RACW_Type), 'A'));
997 -- Declare the asynchronous flag. This flag will be changed to True
998 -- whenever it is known that the RACW type is asynchronous.
1000 Append_To (Declarations,
1001 Make_Object_Declaration (Loc,
1002 Defining_Identifier => Asynchronous_Flag,
1003 Constant_Present => True,
1004 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1005 Expression => New_Occurrence_Of (Standard_False, Loc)));
1007 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1008 end Add_RACW_Asynchronous_Flag;
1010 -----------------------
1011 -- Add_RACW_Features --
1012 -----------------------
1014 procedure Add_RACW_Features (RACW_Type : Entity_Id)
1016 Desig : constant Entity_Id :=
1017 Etype (Designated_Type (RACW_Type));
1019 List_Containing (Declaration_Node (RACW_Type));
1021 Same_Scope : constant Boolean :=
1022 Scope (Desig) = Scope (RACW_Type);
1024 Stub_Type : Entity_Id;
1025 Stub_Type_Access : Entity_Id;
1026 RPC_Receiver_Decl : Node_Id;
1030 if not Expander_Active then
1036 -- We are declaring a RACW in the same package than its designated
1037 -- type, so the list to use for late declarations must be the
1038 -- private part of the package. We do know that this private part
1039 -- exists since the designated type has to be a private one.
1041 Decls := Private_Declarations
1042 (Package_Specification_Of_Scope (Current_Scope));
1044 elsif Nkind (Parent (Decls)) = N_Package_Specification
1045 and then Present (Private_Declarations (Parent (Decls)))
1047 Decls := Private_Declarations (Parent (Decls));
1050 -- If we were unable to find the declarations, that means that the
1051 -- completion of the type was missing. We can safely return and let
1052 -- the error be caught by the semantic analysis.
1059 (Designated_Type => Desig,
1060 RACW_Type => RACW_Type,
1062 Stub_Type => Stub_Type,
1063 Stub_Type_Access => Stub_Type_Access,
1064 RPC_Receiver_Decl => RPC_Receiver_Decl,
1065 Existing => Existing);
1067 Add_RACW_Asynchronous_Flag
1068 (Declarations => Decls,
1069 RACW_Type => RACW_Type);
1071 Specific_Add_RACW_Features
1072 (RACW_Type => RACW_Type,
1074 Stub_Type => Stub_Type,
1075 Stub_Type_Access => Stub_Type_Access,
1076 RPC_Receiver_Decl => RPC_Receiver_Decl,
1077 Declarations => Decls);
1079 if not Same_Scope and then not Existing then
1081 -- The RACW has been declared in another scope than the designated
1082 -- type and has not been handled by another RACW in the same package
1083 -- as the first one, so add primitive for the stub type here.
1085 Add_RACW_Primitive_Declarations_And_Bodies
1086 (Designated_Type => Desig,
1087 Insertion_Node => RPC_Receiver_Decl,
1091 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1093 end Add_RACW_Features;
1095 ------------------------------------------------
1096 -- Add_RACW_Primitive_Declarations_And_Bodies --
1097 ------------------------------------------------
1099 procedure Add_RACW_Primitive_Declarations_And_Bodies
1100 (Designated_Type : Entity_Id;
1101 Insertion_Node : Node_Id;
1104 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1105 -- the declarations are recognized as belonging to the current package.
1107 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1109 Stub_Elements : constant Stub_Structure :=
1110 Stubs_Table.Get (Designated_Type);
1112 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1113 Is_RAS : constant Boolean :=
1114 not Comes_From_Source (Stub_Elements.RACW_Type);
1116 Current_Insertion_Node : Node_Id := Insertion_Node;
1118 RPC_Receiver : Entity_Id;
1119 RPC_Receiver_Statements : List_Id;
1120 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1121 RPC_Receiver_Elsif_Parts : List_Id;
1122 RPC_Receiver_Request : Entity_Id;
1123 RPC_Receiver_Subp_Id : Entity_Id;
1124 RPC_Receiver_Subp_Index : Entity_Id;
1126 Subp_Str : String_Id;
1128 Current_Primitive_Elmt : Elmt_Id;
1129 Current_Primitive : Entity_Id;
1130 Current_Primitive_Body : Node_Id;
1131 Current_Primitive_Spec : Node_Id;
1132 Current_Primitive_Decl : Node_Id;
1133 Current_Primitive_Number : Int := 0;
1135 Current_Primitive_Alias : Node_Id;
1137 Current_Receiver : Entity_Id;
1138 Current_Receiver_Body : Node_Id;
1140 RPC_Receiver_Decl : Node_Id;
1142 Possibly_Asynchronous : Boolean;
1145 if not Expander_Active then
1150 RPC_Receiver := Make_Defining_Identifier (Loc,
1151 New_Internal_Name ('P'));
1152 Specific_Build_RPC_Receiver_Body (
1153 RPC_Receiver => RPC_Receiver,
1154 Request => RPC_Receiver_Request,
1155 Subp_Id => RPC_Receiver_Subp_Id,
1156 Subp_Index => RPC_Receiver_Subp_Index,
1157 Stmts => RPC_Receiver_Statements,
1158 Decl => RPC_Receiver_Decl);
1160 if Get_PCS_Name = Name_PolyORB_DSA then
1162 -- For the case of PolyORB, we need to map a textual operation
1163 -- name into a primitive index. Currently we do so using a
1164 -- simple sequence of string comparisons.
1166 RPC_Receiver_Elsif_Parts := New_List;
1167 Append_To (RPC_Receiver_Statements,
1168 Make_Implicit_If_Statement (Designated_Type,
1169 Condition => New_Occurrence_Of (Standard_False, Loc),
1170 Then_Statements => New_List,
1171 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1175 -- Build callers, receivers for every primitive operations and a RPC
1176 -- receiver for this type.
1178 if Present (Primitive_Operations (Designated_Type)) then
1179 Overload_Counter_Table.Reset;
1181 Current_Primitive_Elmt :=
1182 First_Elmt (Primitive_Operations (Designated_Type));
1183 while Current_Primitive_Elmt /= No_Elmt loop
1184 Current_Primitive := Node (Current_Primitive_Elmt);
1186 -- Copy the primitive of all the parents, except predefined
1187 -- ones that are not remotely dispatching.
1189 if Chars (Current_Primitive) /= Name_uSize
1190 and then Chars (Current_Primitive) /= Name_uAlignment
1191 and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize)
1193 -- The first thing to do is build an up-to-date copy of
1194 -- the spec with all the formals referencing Designated_Type
1195 -- transformed into formals referencing Stub_Type. Since this
1196 -- primitive may have been inherited, go back the alias chain
1197 -- until the real primitive has been found.
1199 Current_Primitive_Alias := Current_Primitive;
1200 while Present (Alias (Current_Primitive_Alias)) loop
1202 (Current_Primitive_Alias
1203 /= Alias (Current_Primitive_Alias));
1204 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
1207 Current_Primitive_Spec :=
1208 Copy_Specification (Loc,
1209 Spec => Parent (Current_Primitive_Alias),
1210 Object_Type => Designated_Type,
1211 Stub_Type => Stub_Elements.Stub_Type);
1213 Current_Primitive_Decl :=
1214 Make_Subprogram_Declaration (Loc,
1215 Specification => Current_Primitive_Spec);
1217 Insert_After (Current_Insertion_Node, Current_Primitive_Decl);
1218 Analyze (Current_Primitive_Decl);
1219 Current_Insertion_Node := Current_Primitive_Decl;
1221 Possibly_Asynchronous :=
1222 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1223 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1225 Assign_Subprogram_Identifier (
1226 Defining_Unit_Name (Current_Primitive_Spec),
1227 Current_Primitive_Number,
1230 Current_Primitive_Body :=
1231 Build_Subprogram_Calling_Stubs
1232 (Vis_Decl => Current_Primitive_Decl,
1234 Build_Subprogram_Id (Loc,
1235 Defining_Unit_Name (Current_Primitive_Spec)),
1236 Asynchronous => Possibly_Asynchronous,
1237 Dynamically_Asynchronous => Possibly_Asynchronous,
1238 Stub_Type => Stub_Elements.Stub_Type,
1239 RACW_Type => Stub_Elements.RACW_Type);
1240 Append_To (Decls, Current_Primitive_Body);
1242 -- Analyzing the body here would cause the Stub type to be
1243 -- frozen, thus preventing subsequent primitive declarations.
1244 -- For this reason, it will be analyzed later in the
1247 -- Build the receiver stubs
1250 Current_Receiver_Body :=
1251 Specific_Build_Subprogram_Receiving_Stubs
1252 (Vis_Decl => Current_Primitive_Decl,
1253 Asynchronous => Possibly_Asynchronous,
1254 Dynamically_Asynchronous => Possibly_Asynchronous,
1255 Stub_Type => Stub_Elements.Stub_Type,
1256 RACW_Type => Stub_Elements.RACW_Type,
1257 Parent_Primitive => Current_Primitive);
1259 Current_Receiver := Defining_Unit_Name (
1260 Specification (Current_Receiver_Body));
1262 Append_To (Decls, Current_Receiver_Body);
1264 -- Add a case alternative to the receiver
1266 if Get_PCS_Name = Name_PolyORB_DSA then
1267 Append_To (RPC_Receiver_Elsif_Parts,
1268 Make_Elsif_Part (Loc,
1270 Make_Function_Call (Loc,
1273 RTE (RE_Caseless_String_Eq), Loc),
1274 Parameter_Associations => New_List (
1275 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1276 Make_String_Literal (Loc, Subp_Str))),
1277 Then_Statements => New_List (
1278 Make_Assignment_Statement (Loc,
1279 Name => New_Occurrence_Of (
1280 RPC_Receiver_Subp_Index, Loc),
1282 Make_Integer_Literal (Loc,
1283 Current_Primitive_Number)))));
1286 Append_To (RPC_Receiver_Case_Alternatives,
1287 Make_Case_Statement_Alternative (Loc,
1288 Discrete_Choices => New_List (
1289 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1291 Statements => New_List (
1292 Make_Procedure_Call_Statement (Loc,
1294 New_Occurrence_Of (Current_Receiver, Loc),
1295 Parameter_Associations => New_List (
1296 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1299 -- Increment the index of current primitive
1301 Current_Primitive_Number := Current_Primitive_Number + 1;
1304 Next_Elmt (Current_Primitive_Elmt);
1308 -- Build the case statement and the heart of the subprogram
1311 Append_To (RPC_Receiver_Case_Alternatives,
1312 Make_Case_Statement_Alternative (Loc,
1313 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1314 Statements => New_List (Make_Null_Statement (Loc))));
1316 Append_To (RPC_Receiver_Statements,
1317 Make_Case_Statement (Loc,
1319 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1320 Alternatives => RPC_Receiver_Case_Alternatives));
1322 Append_To (Decls, RPC_Receiver_Decl);
1323 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1324 Decls, RPC_Receiver, Stub_Elements);
1327 -- Do not analyze RPC receiver at this stage since it will otherwise
1328 -- reference subprograms that have not been analyzed yet. It will
1329 -- be analyzed in the regular flow.
1331 end Add_RACW_Primitive_Declarations_And_Bodies;
1333 -----------------------------
1334 -- Add_RAS_Dereference_TSS --
1335 -----------------------------
1337 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1338 Loc : constant Source_Ptr := Sloc (N);
1340 Type_Def : constant Node_Id := Type_Definition (N);
1342 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1343 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1344 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1345 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1347 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
1348 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1350 RACW_Primitive_Name : Node_Id;
1352 Proc : constant Entity_Id :=
1353 Make_Defining_Identifier (Loc,
1354 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1356 Proc_Spec : Node_Id;
1357 Param_Specs : List_Id;
1358 Param_Assoc : constant List_Id := New_List;
1359 Stmts : constant List_Id := New_List;
1361 RAS_Parameter : constant Entity_Id :=
1362 Make_Defining_Identifier (Loc,
1363 Chars => New_Internal_Name ('P'));
1365 Is_Function : constant Boolean :=
1366 Nkind (Type_Def) = N_Access_Function_Definition;
1368 Is_Degenerate : Boolean;
1369 -- Set to True if the subprogram_specification for this RAS has
1370 -- an anonymous access parameter (see Process_Remote_AST_Declaration).
1372 Spec : constant Node_Id := Type_Def;
1374 Current_Parameter : Node_Id;
1376 -- Start of processing for Add_RAS_Dereference_TSS
1379 -- The Dereference TSS for a remote access-to-subprogram type
1382 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1385 -- This is called whenever a value of a RAS type is dereferenced
1387 -- First construct a list of parameter specifications:
1389 -- The first formal is the RAS values
1391 Param_Specs := New_List (
1392 Make_Parameter_Specification (Loc,
1393 Defining_Identifier => RAS_Parameter,
1396 New_Occurrence_Of (Fat_Type, Loc)));
1398 -- The following formals are copied from the type declaration
1400 Is_Degenerate := False;
1401 Current_Parameter := First (Parameter_Specifications (Type_Def));
1402 Parameters : while Present (Current_Parameter) loop
1403 if Nkind (Parameter_Type (Current_Parameter))
1404 = N_Access_Definition
1406 Is_Degenerate := True;
1408 Append_To (Param_Specs,
1409 Make_Parameter_Specification (Loc,
1410 Defining_Identifier =>
1411 Make_Defining_Identifier (Loc,
1412 Chars => Chars (Defining_Identifier (Current_Parameter))),
1413 In_Present => In_Present (Current_Parameter),
1414 Out_Present => Out_Present (Current_Parameter),
1416 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1418 New_Copy_Tree (Expression (Current_Parameter))));
1420 Append_To (Param_Assoc,
1421 Make_Identifier (Loc,
1422 Chars => Chars (Defining_Identifier (Current_Parameter))));
1424 Next (Current_Parameter);
1425 end loop Parameters;
1427 if Is_Degenerate then
1428 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1430 -- Generate a dummy body. This code will never actually be executed,
1431 -- because null is the only legal value for a degenerate RAS type.
1432 -- For legality's sake (in order to avoid generating a function
1433 -- that does not contain a return statement), we include a dummy
1434 -- recursive call on the TSS itself.
1437 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1438 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1441 -- For a normal RAS type, we cast the RAS formal to the corresponding
1442 -- tagged type, and perform a dispatching call to its Call
1443 -- primitive operation.
1445 Prepend_To (Param_Assoc,
1446 Unchecked_Convert_To (RACW_Type,
1447 New_Occurrence_Of (RAS_Parameter, Loc)));
1449 RACW_Primitive_Name := Make_Selected_Component (Loc,
1450 Prefix => Scope (RACW_Type),
1451 Selector_Name => Name_Call);
1456 Make_Return_Statement (Loc,
1458 Make_Function_Call (Loc,
1460 RACW_Primitive_Name,
1461 Parameter_Associations => Param_Assoc)));
1465 Make_Procedure_Call_Statement (Loc,
1467 RACW_Primitive_Name,
1468 Parameter_Associations => Param_Assoc));
1471 -- Build the complete subprogram
1475 Make_Function_Specification (Loc,
1476 Defining_Unit_Name => Proc,
1477 Parameter_Specifications => Param_Specs,
1480 Entity (Subtype_Mark (Spec)), Loc));
1482 Set_Ekind (Proc, E_Function);
1484 New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
1488 Make_Procedure_Specification (Loc,
1489 Defining_Unit_Name => Proc,
1490 Parameter_Specifications => Param_Specs);
1492 Set_Ekind (Proc, E_Procedure);
1493 Set_Etype (Proc, Standard_Void_Type);
1497 Make_Subprogram_Body (Loc,
1498 Specification => Proc_Spec,
1499 Declarations => New_List,
1500 Handled_Statement_Sequence =>
1501 Make_Handled_Sequence_Of_Statements (Loc,
1502 Statements => Stmts)));
1504 Set_TSS (Fat_Type, Proc);
1505 end Add_RAS_Dereference_TSS;
1507 -------------------------------
1508 -- Add_RAS_Proxy_And_Analyze --
1509 -------------------------------
1511 procedure Add_RAS_Proxy_And_Analyze
1514 All_Calls_Remote_E : Entity_Id;
1515 Proxy_Object_Addr : out Entity_Id)
1517 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1519 Subp_Name : constant Entity_Id :=
1520 Defining_Unit_Name (Specification (Vis_Decl));
1522 Pkg_Name : constant Entity_Id :=
1523 Make_Defining_Identifier (Loc,
1525 New_External_Name (Chars (Subp_Name), 'P', -1));
1527 Proxy_Type : constant Entity_Id :=
1528 Make_Defining_Identifier (Loc,
1531 Related_Id => Chars (Subp_Name),
1534 Proxy_Type_Full_View : constant Entity_Id :=
1535 Make_Defining_Identifier (Loc,
1536 Chars (Proxy_Type));
1538 Subp_Decl_Spec : constant Node_Id :=
1539 Build_RAS_Primitive_Specification
1540 (Subp_Spec => Specification (Vis_Decl),
1541 Remote_Object_Type => Proxy_Type);
1543 Subp_Body_Spec : constant Node_Id :=
1544 Build_RAS_Primitive_Specification
1545 (Subp_Spec => Specification (Vis_Decl),
1546 Remote_Object_Type => Proxy_Type);
1548 Vis_Decls : constant List_Id := New_List;
1549 Pvt_Decls : constant List_Id := New_List;
1550 Actuals : constant List_Id := New_List;
1552 Perform_Call : Node_Id;
1555 -- type subpP is tagged limited private;
1557 Append_To (Vis_Decls,
1558 Make_Private_Type_Declaration (Loc,
1559 Defining_Identifier => Proxy_Type,
1560 Tagged_Present => True,
1561 Limited_Present => True));
1563 -- [subprogram] Call
1564 -- (Self : access subpP;
1565 -- ...other-formals...)
1568 Append_To (Vis_Decls,
1569 Make_Subprogram_Declaration (Loc,
1570 Specification => Subp_Decl_Spec));
1572 -- A : constant System.Address;
1574 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1576 Append_To (Vis_Decls,
1577 Make_Object_Declaration (Loc,
1578 Defining_Identifier =>
1582 Object_Definition =>
1583 New_Occurrence_Of (RTE (RE_Address), Loc)));
1587 -- type subpP is tagged limited record
1588 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1592 Append_To (Pvt_Decls,
1593 Make_Full_Type_Declaration (Loc,
1594 Defining_Identifier =>
1595 Proxy_Type_Full_View,
1597 Build_Remote_Subprogram_Proxy_Type (Loc,
1598 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1600 -- Trick semantic analysis into swapping the public and
1601 -- full view when freezing the public view.
1603 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1606 -- (Self : access O;
1607 -- ...other-formals...) is
1609 -- P (...other-formals...);
1613 -- (Self : access O;
1614 -- ...other-formals...)
1617 -- return F (...other-formals...);
1620 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1622 Make_Procedure_Call_Statement (Loc,
1624 New_Occurrence_Of (Subp_Name, Loc),
1625 Parameter_Associations =>
1629 Make_Return_Statement (Loc,
1631 Make_Function_Call (Loc,
1633 New_Occurrence_Of (Subp_Name, Loc),
1634 Parameter_Associations =>
1638 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1639 pragma Assert (Present (Formal));
1642 exit when No (Formal);
1644 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1647 -- O : aliased subpP;
1649 Append_To (Pvt_Decls,
1650 Make_Object_Declaration (Loc,
1651 Defining_Identifier =>
1652 Make_Defining_Identifier (Loc,
1656 Object_Definition =>
1657 New_Occurrence_Of (Proxy_Type, Loc)));
1659 -- A : constant System.Address := O'Address;
1661 Append_To (Pvt_Decls,
1662 Make_Object_Declaration (Loc,
1663 Defining_Identifier =>
1664 Make_Defining_Identifier (Loc,
1665 Chars (Proxy_Object_Addr)),
1668 Object_Definition =>
1669 New_Occurrence_Of (RTE (RE_Address), Loc),
1671 Make_Attribute_Reference (Loc,
1672 Prefix => New_Occurrence_Of (
1673 Defining_Identifier (Last (Pvt_Decls)), Loc),
1678 Make_Package_Declaration (Loc,
1679 Specification => Make_Package_Specification (Loc,
1680 Defining_Unit_Name => Pkg_Name,
1681 Visible_Declarations => Vis_Decls,
1682 Private_Declarations => Pvt_Decls,
1683 End_Label => Empty)));
1684 Analyze (Last (Decls));
1687 Make_Package_Body (Loc,
1688 Defining_Unit_Name =>
1689 Make_Defining_Identifier (Loc,
1691 Declarations => New_List (
1692 Make_Subprogram_Body (Loc,
1695 Declarations => New_List,
1696 Handled_Statement_Sequence =>
1697 Make_Handled_Sequence_Of_Statements (Loc,
1698 Statements => New_List (Perform_Call))))));
1699 Analyze (Last (Decls));
1700 end Add_RAS_Proxy_And_Analyze;
1702 -----------------------
1703 -- Add_RAST_Features --
1704 -----------------------
1706 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1707 RAS_Type : constant Entity_Id :=
1708 Equivalent_Type (Defining_Identifier (Vis_Decl));
1710 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1711 Add_RAS_Dereference_TSS (Vis_Decl);
1712 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1713 end Add_RAST_Features;
1719 procedure Add_Stub_Type
1720 (Designated_Type : Entity_Id;
1721 RACW_Type : Entity_Id;
1723 Stub_Type : out Entity_Id;
1724 Stub_Type_Access : out Entity_Id;
1725 RPC_Receiver_Decl : out Node_Id;
1726 Existing : out Boolean)
1728 Loc : constant Source_Ptr := Sloc (RACW_Type);
1730 Stub_Elements : constant Stub_Structure :=
1731 Stubs_Table.Get (Designated_Type);
1732 Stub_Type_Decl : Node_Id;
1733 Stub_Type_Access_Decl : Node_Id;
1736 if Stub_Elements /= Empty_Stub_Structure then
1737 Stub_Type := Stub_Elements.Stub_Type;
1738 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1739 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1746 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1748 Make_Defining_Identifier (Loc,
1750 Related_Id => Chars (Stub_Type),
1753 Specific_Build_Stub_Type (
1754 RACW_Type, Stub_Type,
1755 Stub_Type_Decl, RPC_Receiver_Decl);
1757 Stub_Type_Access_Decl :=
1758 Make_Full_Type_Declaration (Loc,
1759 Defining_Identifier => Stub_Type_Access,
1761 Make_Access_To_Object_Definition (Loc,
1762 All_Present => True,
1763 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1765 Append_To (Decls, Stub_Type_Decl);
1766 Analyze (Last (Decls));
1767 Append_To (Decls, Stub_Type_Access_Decl);
1768 Analyze (Last (Decls));
1770 -- This is in no way a type derivation, but we fake it to make
1771 -- sure that the dispatching table gets built with the corresponding
1772 -- primitive operations at the right place.
1774 Derive_Subprograms (Parent_Type => Designated_Type,
1775 Derived_Type => Stub_Type);
1777 if Present (RPC_Receiver_Decl) then
1778 Append_To (Decls, RPC_Receiver_Decl);
1780 RPC_Receiver_Decl := Last (Decls);
1783 Stubs_Table.Set (Designated_Type,
1784 (Stub_Type => Stub_Type,
1785 Stub_Type_Access => Stub_Type_Access,
1786 RPC_Receiver_Decl => RPC_Receiver_Decl,
1787 RACW_Type => RACW_Type));
1790 ----------------------------------
1791 -- Assign_Subprogram_Identifier --
1792 ----------------------------------
1794 procedure Assign_Subprogram_Identifier
1799 N : constant Name_Id := Chars (Def);
1801 Overload_Order : constant Int :=
1802 Overload_Counter_Table.Get (N) + 1;
1805 Overload_Counter_Table.Set (N, Overload_Order);
1807 Get_Name_String (N);
1809 -- Homonym handling: as in Exp_Dbug, but much simpler,
1810 -- because the only entities for which we have to generate
1811 -- names here need only to be disambiguated within their
1814 if Overload_Order > 1 then
1815 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
1816 Name_Len := Name_Len + 2;
1817 Add_Nat_To_Name_Buffer (Overload_Order);
1820 Id := String_From_Name_Buffer;
1821 Subprogram_Identifier_Table.Set (Def,
1822 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
1823 end Assign_Subprogram_Identifier;
1825 ------------------------------
1826 -- Build_Get_Unique_RP_Call --
1827 ------------------------------
1829 function Build_Get_Unique_RP_Call
1831 Pointer : Entity_Id;
1832 Stub_Type : Entity_Id) return List_Id
1836 Make_Procedure_Call_Statement (Loc,
1838 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
1839 Parameter_Associations => New_List (
1840 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
1841 New_Occurrence_Of (Pointer, Loc)))),
1843 Make_Assignment_Statement (Loc,
1845 Make_Selected_Component (Loc,
1847 New_Occurrence_Of (Pointer, Loc),
1849 New_Occurrence_Of (First_Tag_Component
1850 (Designated_Type (Etype (Pointer))), Loc)),
1852 Make_Attribute_Reference (Loc,
1854 New_Occurrence_Of (Stub_Type, Loc),
1858 -- Note: The assignment to Pointer._Tag is safe here because
1859 -- we carefully ensured that Stub_Type has exactly the same layout
1860 -- as System.Partition_Interface.RACW_Stub_Type.
1862 end Build_Get_Unique_RP_Call;
1864 -----------------------------------
1865 -- Build_Ordered_Parameters_List --
1866 -----------------------------------
1868 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
1869 Constrained_List : List_Id;
1870 Unconstrained_List : List_Id;
1871 Current_Parameter : Node_Id;
1873 First_Parameter : Node_Id;
1874 For_RAS : Boolean := False;
1877 if not Present (Parameter_Specifications (Spec)) then
1881 Constrained_List := New_List;
1882 Unconstrained_List := New_List;
1883 First_Parameter := First (Parameter_Specifications (Spec));
1885 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
1886 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
1891 -- Loop through the parameters and add them to the right list
1893 Current_Parameter := First_Parameter;
1894 while Present (Current_Parameter) loop
1895 if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
1897 Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
1899 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
1900 and then not (For_RAS and then Current_Parameter = First_Parameter)
1902 Append_To (Constrained_List, New_Copy (Current_Parameter));
1904 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
1907 Next (Current_Parameter);
1910 -- Unconstrained parameters are returned first
1912 Append_List_To (Unconstrained_List, Constrained_List);
1914 return Unconstrained_List;
1915 end Build_Ordered_Parameters_List;
1917 ----------------------------------
1918 -- Build_Passive_Partition_Stub --
1919 ----------------------------------
1921 procedure Build_Passive_Partition_Stub (U : Node_Id) is
1923 Pkg_Name : String_Id;
1926 Loc : constant Source_Ptr := Sloc (U);
1929 -- Verify that the implementation supports distribution, by accessing
1930 -- a type defined in the proper version of system.rpc
1933 Dist_OK : Entity_Id;
1934 pragma Warnings (Off, Dist_OK);
1936 Dist_OK := RTE (RE_Params_Stream_Type);
1939 -- Use body if present, spec otherwise
1941 if Nkind (U) = N_Package_Declaration then
1942 Pkg_Spec := Specification (U);
1943 L := Visible_Declarations (Pkg_Spec);
1945 Pkg_Spec := Parent (Corresponding_Spec (U));
1946 L := Declarations (U);
1949 Get_Library_Unit_Name_String (Pkg_Spec);
1950 Pkg_Name := String_From_Name_Buffer;
1952 Make_Procedure_Call_Statement (Loc,
1954 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
1955 Parameter_Associations => New_List (
1956 Make_String_Literal (Loc, Pkg_Name),
1957 Make_Attribute_Reference (Loc,
1959 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
1964 end Build_Passive_Partition_Stub;
1966 --------------------------------------
1967 -- Build_RPC_Receiver_Specification --
1968 --------------------------------------
1970 function Build_RPC_Receiver_Specification
1971 (RPC_Receiver : Entity_Id;
1972 Request_Parameter : Entity_Id) return Node_Id
1974 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
1977 Make_Procedure_Specification (Loc,
1978 Defining_Unit_Name => RPC_Receiver,
1979 Parameter_Specifications => New_List (
1980 Make_Parameter_Specification (Loc,
1981 Defining_Identifier => Request_Parameter,
1983 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
1984 end Build_RPC_Receiver_Specification;
1986 ----------------------------------------
1987 -- Build_Remote_Subprogram_Proxy_Type --
1988 ----------------------------------------
1990 function Build_Remote_Subprogram_Proxy_Type
1992 ACR_Expression : Node_Id) return Node_Id
1996 Make_Record_Definition (Loc,
1997 Tagged_Present => True,
1998 Limited_Present => True,
2000 Make_Component_List (Loc,
2002 Component_Items => New_List (
2003 Make_Component_Declaration (Loc,
2004 Defining_Identifier =>
2005 Make_Defining_Identifier (Loc,
2006 Name_All_Calls_Remote),
2007 Component_Definition =>
2008 Make_Component_Definition (Loc,
2009 Subtype_Indication =>
2010 New_Occurrence_Of (Standard_Boolean, Loc)),
2014 Make_Component_Declaration (Loc,
2015 Defining_Identifier =>
2016 Make_Defining_Identifier (Loc,
2018 Component_Definition =>
2019 Make_Component_Definition (Loc,
2020 Subtype_Indication =>
2021 New_Occurrence_Of (RTE (RE_Address), Loc)),
2023 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2025 Make_Component_Declaration (Loc,
2026 Defining_Identifier =>
2027 Make_Defining_Identifier (Loc,
2029 Component_Definition =>
2030 Make_Component_Definition (Loc,
2031 Subtype_Indication =>
2032 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2033 end Build_Remote_Subprogram_Proxy_Type;
2035 ------------------------------------
2036 -- Build_Subprogram_Calling_Stubs --
2037 ------------------------------------
2039 function Build_Subprogram_Calling_Stubs
2040 (Vis_Decl : Node_Id;
2042 Asynchronous : Boolean;
2043 Dynamically_Asynchronous : Boolean := False;
2044 Stub_Type : Entity_Id := Empty;
2045 RACW_Type : Entity_Id := Empty;
2046 Locator : Entity_Id := Empty;
2047 New_Name : Name_Id := No_Name) return Node_Id
2049 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2051 Decls : constant List_Id := New_List;
2052 Statements : constant List_Id := New_List;
2054 Subp_Spec : Node_Id;
2055 -- The specification of the body
2057 Controlling_Parameter : Entity_Id := Empty;
2059 Asynchronous_Expr : Node_Id := Empty;
2061 RCI_Locator : Entity_Id;
2063 Spec_To_Use : Node_Id;
2065 procedure Insert_Partition_Check (Parameter : Node_Id);
2066 -- Check that the parameter has been elaborated on the same partition
2067 -- than the controlling parameter (E.4(19)).
2069 ----------------------------
2070 -- Insert_Partition_Check --
2071 ----------------------------
2073 procedure Insert_Partition_Check (Parameter : Node_Id) is
2074 Parameter_Entity : constant Entity_Id :=
2075 Defining_Identifier (Parameter);
2077 -- The expression that will be built is of the form:
2079 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2080 -- raise Constraint_Error;
2083 -- We do not check that Parameter is in Stub_Type since such a check
2084 -- has been inserted at the point of call already (a tag check since
2085 -- we have multiple controlling operands).
2088 Make_Raise_Constraint_Error (Loc,
2092 Make_Function_Call (Loc,
2094 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2095 Parameter_Associations =>
2097 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2098 New_Occurrence_Of (Parameter_Entity, Loc)),
2099 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2100 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2101 Reason => CE_Partition_Check_Failed));
2102 end Insert_Partition_Check;
2104 -- Start of processing for Build_Subprogram_Calling_Stubs
2107 Subp_Spec := Copy_Specification (Loc,
2108 Spec => Specification (Vis_Decl),
2109 New_Name => New_Name);
2111 if Locator = Empty then
2112 RCI_Locator := RCI_Cache;
2113 Spec_To_Use := Specification (Vis_Decl);
2115 RCI_Locator := Locator;
2116 Spec_To_Use := Subp_Spec;
2119 -- Find a controlling argument if we have a stub type. Also check
2120 -- if this subprogram can be made asynchronous.
2122 if Present (Stub_Type)
2123 and then Present (Parameter_Specifications (Spec_To_Use))
2126 Current_Parameter : Node_Id :=
2127 First (Parameter_Specifications
2130 while Present (Current_Parameter) loop
2132 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2134 if Controlling_Parameter = Empty then
2135 Controlling_Parameter :=
2136 Defining_Identifier (Current_Parameter);
2138 Insert_Partition_Check (Current_Parameter);
2142 Next (Current_Parameter);
2147 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2149 if Dynamically_Asynchronous then
2150 Asynchronous_Expr := Make_Selected_Component (Loc,
2151 Prefix => Controlling_Parameter,
2152 Selector_Name => Name_Asynchronous);
2155 Specific_Build_General_Calling_Stubs
2157 Statements => Statements,
2158 Target => Specific_Build_Stub_Target (Loc,
2159 Decls, RCI_Locator, Controlling_Parameter),
2160 Subprogram_Id => Subp_Id,
2161 Asynchronous => Asynchronous_Expr,
2162 Is_Known_Asynchronous => Asynchronous
2163 and then not Dynamically_Asynchronous,
2164 Is_Known_Non_Asynchronous
2166 and then not Dynamically_Asynchronous,
2167 Is_Function => Nkind (Spec_To_Use) =
2168 N_Function_Specification,
2169 Spec => Spec_To_Use,
2170 Stub_Type => Stub_Type,
2171 RACW_Type => RACW_Type,
2174 RCI_Calling_Stubs_Table.Set
2175 (Defining_Unit_Name (Specification (Vis_Decl)),
2176 Defining_Unit_Name (Spec_To_Use));
2179 Make_Subprogram_Body (Loc,
2180 Specification => Subp_Spec,
2181 Declarations => Decls,
2182 Handled_Statement_Sequence =>
2183 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2184 end Build_Subprogram_Calling_Stubs;
2186 -------------------------
2187 -- Build_Subprogram_Id --
2188 -------------------------
2190 function Build_Subprogram_Id
2192 E : Entity_Id) return Node_Id
2195 case Get_PCS_Name is
2196 when Name_PolyORB_DSA =>
2197 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2199 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2201 end Build_Subprogram_Id;
2203 ------------------------
2204 -- Copy_Specification --
2205 ------------------------
2207 function Copy_Specification
2210 Object_Type : Entity_Id := Empty;
2211 Stub_Type : Entity_Id := Empty;
2212 New_Name : Name_Id := No_Name) return Node_Id
2214 Parameters : List_Id := No_List;
2216 Current_Parameter : Node_Id;
2217 Current_Identifier : Entity_Id;
2218 Current_Type : Node_Id;
2219 Current_Etype : Entity_Id;
2221 Name_For_New_Spec : Name_Id;
2223 New_Identifier : Entity_Id;
2225 -- Comments needed in body below ???
2228 if New_Name = No_Name then
2229 pragma Assert (Nkind (Spec) = N_Function_Specification
2230 or else Nkind (Spec) = N_Procedure_Specification);
2232 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2234 Name_For_New_Spec := New_Name;
2237 if Present (Parameter_Specifications (Spec)) then
2238 Parameters := New_List;
2239 Current_Parameter := First (Parameter_Specifications (Spec));
2240 while Present (Current_Parameter) loop
2241 Current_Identifier := Defining_Identifier (Current_Parameter);
2242 Current_Type := Parameter_Type (Current_Parameter);
2244 if Nkind (Current_Type) = N_Access_Definition then
2245 Current_Etype := Entity (Subtype_Mark (Current_Type));
2247 if Present (Object_Type) then
2249 Root_Type (Current_Etype) = Root_Type (Object_Type));
2251 Make_Access_Definition (Loc,
2252 Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
2255 Make_Access_Definition (Loc,
2257 New_Occurrence_Of (Current_Etype, Loc));
2261 Current_Etype := Entity (Current_Type);
2263 if Present (Object_Type)
2264 and then Current_Etype = Object_Type
2266 Current_Type := New_Occurrence_Of (Stub_Type, Loc);
2268 Current_Type := New_Occurrence_Of (Current_Etype, Loc);
2272 New_Identifier := Make_Defining_Identifier (Loc,
2273 Chars (Current_Identifier));
2275 Append_To (Parameters,
2276 Make_Parameter_Specification (Loc,
2277 Defining_Identifier => New_Identifier,
2278 Parameter_Type => Current_Type,
2279 In_Present => In_Present (Current_Parameter),
2280 Out_Present => Out_Present (Current_Parameter),
2282 New_Copy_Tree (Expression (Current_Parameter))));
2284 -- For a regular formal parameter (that needs to be marshalled
2285 -- in the context of remote calls), set the Etype now, because
2286 -- marshalling processing might need it.
2288 if Is_Entity_Name (Current_Type) then
2289 Set_Etype (New_Identifier, Entity (Current_Type));
2291 -- Current_Type is an access definition, special processing
2292 -- (not requiring etype) will occur for marshalling.
2298 Next (Current_Parameter);
2302 case Nkind (Spec) is
2304 when N_Function_Specification | N_Access_Function_Definition =>
2306 Make_Function_Specification (Loc,
2307 Defining_Unit_Name =>
2308 Make_Defining_Identifier (Loc,
2309 Chars => Name_For_New_Spec),
2310 Parameter_Specifications => Parameters,
2312 New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
2314 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2316 Make_Procedure_Specification (Loc,
2317 Defining_Unit_Name =>
2318 Make_Defining_Identifier (Loc,
2319 Chars => Name_For_New_Spec),
2320 Parameter_Specifications => Parameters);
2323 raise Program_Error;
2325 end Copy_Specification;
2327 ---------------------------
2328 -- Could_Be_Asynchronous --
2329 ---------------------------
2331 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2332 Current_Parameter : Node_Id;
2335 if Present (Parameter_Specifications (Spec)) then
2336 Current_Parameter := First (Parameter_Specifications (Spec));
2337 while Present (Current_Parameter) loop
2338 if Out_Present (Current_Parameter) then
2342 Next (Current_Parameter);
2347 end Could_Be_Asynchronous;
2349 ---------------------------
2350 -- Declare_Create_NVList --
2351 ---------------------------
2353 procedure Declare_Create_NVList
2361 Make_Object_Declaration (Loc,
2362 Defining_Identifier => NVList,
2363 Aliased_Present => False,
2364 Object_Definition =>
2365 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2368 Make_Procedure_Call_Statement (Loc,
2370 New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2371 Parameter_Associations => New_List (
2372 New_Occurrence_Of (NVList, Loc))));
2373 end Declare_Create_NVList;
2375 ---------------------------------------------
2376 -- Expand_All_Calls_Remote_Subprogram_Call --
2377 ---------------------------------------------
2379 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2380 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2381 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2382 Loc : constant Source_Ptr := Sloc (N);
2383 RCI_Locator : Node_Id;
2384 RCI_Cache : Entity_Id;
2385 Calling_Stubs : Node_Id;
2386 E_Calling_Stubs : Entity_Id;
2389 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2391 if E_Calling_Stubs = Empty then
2392 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2394 if RCI_Cache = Empty then
2397 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2398 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2400 -- The RCI_Locator package is inserted at the top level in the
2401 -- current unit, and must appear in the proper scope, so that it
2402 -- is not prematurely removed by the GCC back-end.
2405 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2408 if Ekind (Scop) = E_Package_Body then
2409 New_Scope (Spec_Entity (Scop));
2411 elsif Ekind (Scop) = E_Subprogram_Body then
2413 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2419 Analyze (RCI_Locator);
2423 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2426 RCI_Locator := Parent (RCI_Cache);
2429 Calling_Stubs := Build_Subprogram_Calling_Stubs
2430 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2432 Build_Subprogram_Id (Loc, Called_Subprogram),
2433 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2435 Is_Asynchronous (Called_Subprogram),
2436 Locator => RCI_Cache,
2437 New_Name => New_Internal_Name ('S'));
2438 Insert_After (RCI_Locator, Calling_Stubs);
2439 Analyze (Calling_Stubs);
2440 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2443 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2444 end Expand_All_Calls_Remote_Subprogram_Call;
2446 ---------------------------------
2447 -- Expand_Calling_Stubs_Bodies --
2448 ---------------------------------
2450 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2451 Spec : constant Node_Id := Specification (Unit_Node);
2452 Decls : constant List_Id := Visible_Declarations (Spec);
2454 New_Scope (Scope_Of_Spec (Spec));
2455 Add_Calling_Stubs_To_Declarations
2456 (Specification (Unit_Node), Decls);
2458 end Expand_Calling_Stubs_Bodies;
2460 -----------------------------------
2461 -- Expand_Receiving_Stubs_Bodies --
2462 -----------------------------------
2464 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2470 if Nkind (Unit_Node) = N_Package_Declaration then
2471 Spec := Specification (Unit_Node);
2472 Decls := Private_Declarations (Spec);
2475 Decls := Visible_Declarations (Spec);
2478 New_Scope (Scope_Of_Spec (Spec));
2479 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls);
2483 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2484 Decls := Declarations (Unit_Node);
2485 New_Scope (Scope_Of_Spec (Unit_Node));
2487 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp);
2488 Insert_List_Before (First (Decls), Temp);
2492 end Expand_Receiving_Stubs_Bodies;
2494 --------------------
2495 -- GARLIC_Support --
2496 --------------------
2498 package body GARLIC_Support is
2500 -- Local subprograms
2502 procedure Add_RACW_Read_Attribute
2503 (RACW_Type : Entity_Id;
2504 Stub_Type : Entity_Id;
2505 Stub_Type_Access : Entity_Id;
2506 Declarations : List_Id);
2507 -- Add Read attribute in Decls for the RACW type. The Read attribute
2508 -- is added right after the RACW_Type declaration while the body is
2509 -- inserted after Declarations.
2511 procedure Add_RACW_Write_Attribute
2512 (RACW_Type : Entity_Id;
2513 Stub_Type : Entity_Id;
2514 Stub_Type_Access : Entity_Id;
2515 RPC_Receiver : Node_Id;
2516 Declarations : List_Id);
2517 -- Same thing for the Write attribute
2519 function Stream_Parameter return Node_Id;
2520 function Result return Node_Id;
2521 function Object return Node_Id renames Result;
2522 -- Functions to create occurrences of the formal parameter names of
2523 -- the 'Read and 'Write attributes.
2526 -- Shared source location used by Add_{Read,Write}_Read_Attribute
2527 -- and their ancillary subroutines (set on entry by Add_RACW_Features).
2529 procedure Add_RAS_Access_TSS (N : Node_Id);
2530 -- Add a subprogram body for RAS Access TSS
2532 -------------------------------------
2533 -- Add_Obj_RPC_Receiver_Completion --
2534 -------------------------------------
2536 procedure Add_Obj_RPC_Receiver_Completion
2539 RPC_Receiver : Entity_Id;
2540 Stub_Elements : Stub_Structure) is
2542 -- The RPC receiver body should not be the completion of the
2543 -- declaration recorded in the stub structure, because then the
2544 -- occurrences of the formal parameters within the body should
2545 -- refer to the entities from the declaration, not from the
2546 -- completion, to which we do not have easy access. Instead, the
2547 -- RPC receiver body acts as its own declaration, and the RPC
2548 -- receiver declaration is completed by a renaming-as-body.
2551 Make_Subprogram_Renaming_Declaration (Loc,
2553 Copy_Specification (Loc,
2554 Specification (Stub_Elements.RPC_Receiver_Decl)),
2555 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2556 end Add_Obj_RPC_Receiver_Completion;
2558 -----------------------
2559 -- Add_RACW_Features --
2560 -----------------------
2562 procedure Add_RACW_Features
2563 (RACW_Type : Entity_Id;
2564 Stub_Type : Entity_Id;
2565 Stub_Type_Access : Entity_Id;
2566 RPC_Receiver_Decl : Node_Id;
2567 Declarations : List_Id)
2569 RPC_Receiver : Node_Id;
2570 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2573 Loc := Sloc (RACW_Type);
2577 -- For a RAS, the RPC receiver is that of the RCI unit,
2578 -- not that of the corresponding distributed object type.
2579 -- We retrieve its address from the local proxy object.
2581 RPC_Receiver := Make_Selected_Component (Loc,
2583 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2584 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2587 RPC_Receiver := Make_Attribute_Reference (Loc,
2588 Prefix => New_Occurrence_Of (
2589 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2590 Attribute_Name => Name_Address);
2593 Add_RACW_Write_Attribute (
2600 Add_RACW_Read_Attribute (
2605 end Add_RACW_Features;
2607 -----------------------------
2608 -- Add_RACW_Read_Attribute --
2609 -----------------------------
2611 procedure Add_RACW_Read_Attribute
2612 (RACW_Type : Entity_Id;
2613 Stub_Type : Entity_Id;
2614 Stub_Type_Access : Entity_Id;
2615 Declarations : List_Id)
2617 Proc_Decl : Node_Id;
2618 Attr_Decl : Node_Id;
2620 Body_Node : Node_Id;
2623 Statements : List_Id;
2624 Local_Statements : List_Id;
2625 Remote_Statements : List_Id;
2626 -- Various parts of the procedure
2628 Procedure_Name : constant Name_Id :=
2629 New_Internal_Name ('R');
2630 Source_Partition : constant Entity_Id :=
2631 Make_Defining_Identifier
2632 (Loc, New_Internal_Name ('P'));
2633 Source_Receiver : constant Entity_Id :=
2634 Make_Defining_Identifier
2635 (Loc, New_Internal_Name ('S'));
2636 Source_Address : constant Entity_Id :=
2637 Make_Defining_Identifier
2638 (Loc, New_Internal_Name ('P'));
2639 Local_Stub : constant Entity_Id :=
2640 Make_Defining_Identifier
2641 (Loc, New_Internal_Name ('L'));
2642 Stubbed_Result : constant Entity_Id :=
2643 Make_Defining_Identifier
2644 (Loc, New_Internal_Name ('S'));
2645 Asynchronous_Flag : constant Entity_Id :=
2646 Asynchronous_Flags_Table.Get (RACW_Type);
2647 pragma Assert (Present (Asynchronous_Flag));
2649 -- Start of processing for Add_RACW_Read_Attribute
2652 -- Generate object declarations
2655 Make_Object_Declaration (Loc,
2656 Defining_Identifier => Source_Partition,
2657 Object_Definition =>
2658 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
2660 Make_Object_Declaration (Loc,
2661 Defining_Identifier => Source_Receiver,
2662 Object_Definition =>
2663 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2665 Make_Object_Declaration (Loc,
2666 Defining_Identifier => Source_Address,
2667 Object_Definition =>
2668 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2670 Make_Object_Declaration (Loc,
2671 Defining_Identifier => Local_Stub,
2672 Aliased_Present => True,
2673 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
2675 Make_Object_Declaration (Loc,
2676 Defining_Identifier => Stubbed_Result,
2677 Object_Definition =>
2678 New_Occurrence_Of (Stub_Type_Access, Loc),
2680 Make_Attribute_Reference (Loc,
2682 New_Occurrence_Of (Local_Stub, Loc),
2684 Name_Unchecked_Access)));
2686 -- Read the source Partition_ID and RPC_Receiver from incoming stream
2688 Statements := New_List (
2689 Make_Attribute_Reference (Loc,
2691 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
2692 Attribute_Name => Name_Read,
2693 Expressions => New_List (
2695 New_Occurrence_Of (Source_Partition, Loc))),
2697 Make_Attribute_Reference (Loc,
2699 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2702 Expressions => New_List (
2704 New_Occurrence_Of (Source_Receiver, Loc))),
2706 Make_Attribute_Reference (Loc,
2708 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2711 Expressions => New_List (
2713 New_Occurrence_Of (Source_Address, Loc))));
2715 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
2717 Set_Etype (Stubbed_Result, Stub_Type_Access);
2719 -- If the Address is Null_Address, then return a null object
2721 Append_To (Statements,
2722 Make_Implicit_If_Statement (RACW_Type,
2725 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
2726 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
2727 Then_Statements => New_List (
2728 Make_Assignment_Statement (Loc,
2730 Expression => Make_Null (Loc)),
2731 Make_Return_Statement (Loc))));
2733 -- If the RACW denotes an object created on the current partition,
2734 -- Local_Statements will be executed. The real object will be used.
2736 Local_Statements := New_List (
2737 Make_Assignment_Statement (Loc,
2740 Unchecked_Convert_To (RACW_Type,
2741 OK_Convert_To (RTE (RE_Address),
2742 New_Occurrence_Of (Source_Address, Loc)))));
2744 -- If the object is located on another partition, then a stub object
2745 -- will be created with all the information needed to rebuild the
2746 -- real object at the other end.
2748 Remote_Statements := New_List (
2750 Make_Assignment_Statement (Loc,
2751 Name => Make_Selected_Component (Loc,
2752 Prefix => Stubbed_Result,
2753 Selector_Name => Name_Origin),
2755 New_Occurrence_Of (Source_Partition, Loc)),
2757 Make_Assignment_Statement (Loc,
2758 Name => Make_Selected_Component (Loc,
2759 Prefix => Stubbed_Result,
2760 Selector_Name => Name_Receiver),
2762 New_Occurrence_Of (Source_Receiver, Loc)),
2764 Make_Assignment_Statement (Loc,
2765 Name => Make_Selected_Component (Loc,
2766 Prefix => Stubbed_Result,
2767 Selector_Name => Name_Addr),
2769 New_Occurrence_Of (Source_Address, Loc)));
2771 Append_To (Remote_Statements,
2772 Make_Assignment_Statement (Loc,
2773 Name => Make_Selected_Component (Loc,
2774 Prefix => Stubbed_Result,
2775 Selector_Name => Name_Asynchronous),
2777 New_Occurrence_Of (Asynchronous_Flag, Loc)));
2779 Append_List_To (Remote_Statements,
2780 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
2781 -- ??? Issue with asynchronous calls here: the Asynchronous
2782 -- flag is set on the stub type if, and only if, the RACW type
2783 -- has a pragma Asynchronous. This is incorrect for RACWs that
2784 -- implement RAS types, because in that case the /designated
2785 -- subprogram/ (not the type) might be asynchronous, and
2786 -- that causes the stub to need to be asynchronous too.
2787 -- A solution is to transport a RAS as a struct containing
2788 -- a RACW and an asynchronous flag, and to properly alter
2789 -- the Asynchronous component in the stub type in the RAS's
2792 Append_To (Remote_Statements,
2793 Make_Assignment_Statement (Loc,
2795 Expression => Unchecked_Convert_To (RACW_Type,
2796 New_Occurrence_Of (Stubbed_Result, Loc))));
2798 -- Distinguish between the local and remote cases, and execute the
2799 -- appropriate piece of code.
2801 Append_To (Statements,
2802 Make_Implicit_If_Statement (RACW_Type,
2806 Make_Function_Call (Loc,
2807 Name => New_Occurrence_Of (
2808 RTE (RE_Get_Local_Partition_Id), Loc)),
2809 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
2810 Then_Statements => Local_Statements,
2811 Else_Statements => Remote_Statements));
2813 Build_Stream_Procedure
2814 (Loc, RACW_Type, Body_Node,
2815 Make_Defining_Identifier (Loc, Procedure_Name),
2816 Statements, Outp => True);
2817 Set_Declarations (Body_Node, Decls);
2819 Proc_Decl := Make_Subprogram_Declaration (Loc,
2820 Copy_Specification (Loc, Specification (Body_Node)));
2823 Make_Attribute_Definition_Clause (Loc,
2824 Name => New_Occurrence_Of (RACW_Type, Loc),
2828 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2830 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2831 Insert_After (Proc_Decl, Attr_Decl);
2832 Append_To (Declarations, Body_Node);
2833 end Add_RACW_Read_Attribute;
2835 ------------------------------
2836 -- Add_RACW_Write_Attribute --
2837 ------------------------------
2839 procedure Add_RACW_Write_Attribute
2840 (RACW_Type : Entity_Id;
2841 Stub_Type : Entity_Id;
2842 Stub_Type_Access : Entity_Id;
2843 RPC_Receiver : Node_Id;
2844 Declarations : List_Id)
2846 Body_Node : Node_Id;
2847 Proc_Decl : Node_Id;
2848 Attr_Decl : Node_Id;
2850 Statements : List_Id;
2851 Local_Statements : List_Id;
2852 Remote_Statements : List_Id;
2853 Null_Statements : List_Id;
2855 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
2858 -- Build the code fragment corresponding to the marshalling of a
2861 Local_Statements := New_List (
2863 Pack_Entity_Into_Stream_Access (Loc,
2864 Stream => Stream_Parameter,
2865 Object => RTE (RE_Get_Local_Partition_Id)),
2867 Pack_Node_Into_Stream_Access (Loc,
2868 Stream => Stream_Parameter,
2869 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2870 Etyp => RTE (RE_Unsigned_64)),
2872 Pack_Node_Into_Stream_Access (Loc,
2873 Stream => Stream_Parameter,
2874 Object => OK_Convert_To (RTE (RE_Unsigned_64),
2875 Make_Attribute_Reference (Loc,
2877 Make_Explicit_Dereference (Loc,
2879 Attribute_Name => Name_Address)),
2880 Etyp => RTE (RE_Unsigned_64)));
2882 -- Build the code fragment corresponding to the marshalling of
2885 Remote_Statements := New_List (
2887 Pack_Node_Into_Stream_Access (Loc,
2888 Stream => Stream_Parameter,
2890 Make_Selected_Component (Loc,
2891 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2894 Make_Identifier (Loc, Name_Origin)),
2895 Etyp => RTE (RE_Partition_ID)),
2897 Pack_Node_Into_Stream_Access (Loc,
2898 Stream => Stream_Parameter,
2900 Make_Selected_Component (Loc,
2901 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2904 Make_Identifier (Loc, Name_Receiver)),
2905 Etyp => RTE (RE_Unsigned_64)),
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_Addr)),
2915 Etyp => RTE (RE_Unsigned_64)));
2917 -- Build code fragment corresponding to marshalling of a null object
2919 Null_Statements := New_List (
2921 Pack_Entity_Into_Stream_Access (Loc,
2922 Stream => Stream_Parameter,
2923 Object => RTE (RE_Get_Local_Partition_Id)),
2925 Pack_Node_Into_Stream_Access (Loc,
2926 Stream => Stream_Parameter,
2927 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2928 Etyp => RTE (RE_Unsigned_64)),
2930 Pack_Node_Into_Stream_Access (Loc,
2931 Stream => Stream_Parameter,
2932 Object => Make_Integer_Literal (Loc, Uint_0),
2933 Etyp => RTE (RE_Unsigned_64)));
2935 Statements := New_List (
2936 Make_Implicit_If_Statement (RACW_Type,
2939 Left_Opnd => Object,
2940 Right_Opnd => Make_Null (Loc)),
2941 Then_Statements => Null_Statements,
2942 Elsif_Parts => New_List (
2943 Make_Elsif_Part (Loc,
2947 Make_Attribute_Reference (Loc,
2949 Attribute_Name => Name_Tag),
2951 Make_Attribute_Reference (Loc,
2952 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2953 Attribute_Name => Name_Tag)),
2954 Then_Statements => Remote_Statements)),
2955 Else_Statements => Local_Statements));
2957 Build_Stream_Procedure
2958 (Loc, RACW_Type, Body_Node,
2959 Make_Defining_Identifier (Loc, Procedure_Name),
2960 Statements, Outp => False);
2962 Proc_Decl := Make_Subprogram_Declaration (Loc,
2963 Copy_Specification (Loc, Specification (Body_Node)));
2966 Make_Attribute_Definition_Clause (Loc,
2967 Name => New_Occurrence_Of (RACW_Type, Loc),
2968 Chars => Name_Write,
2971 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2973 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2974 Insert_After (Proc_Decl, Attr_Decl);
2975 Append_To (Declarations, Body_Node);
2976 end Add_RACW_Write_Attribute;
2978 ------------------------
2979 -- Add_RAS_Access_TSS --
2980 ------------------------
2982 procedure Add_RAS_Access_TSS (N : Node_Id) is
2983 Loc : constant Source_Ptr := Sloc (N);
2985 Ras_Type : constant Entity_Id := Defining_Identifier (N);
2986 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
2987 -- Ras_Type is the access to subprogram type while Fat_Type is the
2988 -- corresponding record type.
2990 RACW_Type : constant Entity_Id :=
2991 Underlying_RACW_Type (Ras_Type);
2992 Desig : constant Entity_Id :=
2993 Etype (Designated_Type (RACW_Type));
2995 Stub_Elements : constant Stub_Structure :=
2996 Stubs_Table.Get (Desig);
2997 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
2999 Proc : constant Entity_Id :=
3000 Make_Defining_Identifier (Loc,
3001 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3003 Proc_Spec : Node_Id;
3005 -- Formal parameters
3007 Package_Name : constant Entity_Id :=
3008 Make_Defining_Identifier (Loc,
3012 Subp_Id : constant Entity_Id :=
3013 Make_Defining_Identifier (Loc,
3015 -- Target subprogram
3017 Asynch_P : constant Entity_Id :=
3018 Make_Defining_Identifier (Loc,
3019 Chars => Name_Asynchronous);
3020 -- Is the procedure to which the 'Access applies asynchronous?
3022 All_Calls_Remote : constant Entity_Id :=
3023 Make_Defining_Identifier (Loc,
3024 Chars => Name_All_Calls_Remote);
3025 -- True if an All_Calls_Remote pragma applies to the RCI unit
3026 -- that contains the subprogram.
3028 -- Common local variables
3030 Proc_Decls : List_Id;
3031 Proc_Statements : List_Id;
3033 Origin : constant Entity_Id :=
3034 Make_Defining_Identifier (Loc,
3035 Chars => New_Internal_Name ('P'));
3037 -- Additional local variables for the local case
3039 Proxy_Addr : constant Entity_Id :=
3040 Make_Defining_Identifier (Loc,
3041 Chars => New_Internal_Name ('P'));
3043 -- Additional local variables for the remote case
3045 Local_Stub : constant Entity_Id :=
3046 Make_Defining_Identifier (Loc,
3047 Chars => New_Internal_Name ('L'));
3049 Stub_Ptr : constant Entity_Id :=
3050 Make_Defining_Identifier (Loc,
3051 Chars => New_Internal_Name ('S'));
3054 (Field_Name : Name_Id;
3055 Value : Node_Id) return Node_Id;
3056 -- Construct an assignment that sets the named component in the
3064 (Field_Name : Name_Id;
3065 Value : Node_Id) return Node_Id
3069 Make_Assignment_Statement (Loc,
3071 Make_Selected_Component (Loc,
3073 Selector_Name => Field_Name),
3074 Expression => Value);
3077 -- Start of processing for Add_RAS_Access_TSS
3080 Proc_Decls := New_List (
3082 -- Common declarations
3084 Make_Object_Declaration (Loc,
3085 Defining_Identifier => Origin,
3086 Constant_Present => True,
3087 Object_Definition =>
3088 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3090 Make_Function_Call (Loc,
3092 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3093 Parameter_Associations => New_List (
3094 New_Occurrence_Of (Package_Name, Loc)))),
3096 -- Declaration use only in the local case: proxy address
3098 Make_Object_Declaration (Loc,
3099 Defining_Identifier => Proxy_Addr,
3100 Object_Definition =>
3101 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3103 -- Declarations used only in the remote case: stub object and
3106 Make_Object_Declaration (Loc,
3107 Defining_Identifier => Local_Stub,
3108 Aliased_Present => True,
3109 Object_Definition =>
3110 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3112 Make_Object_Declaration (Loc,
3113 Defining_Identifier =>
3115 Object_Definition =>
3116 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3118 Make_Attribute_Reference (Loc,
3119 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3120 Attribute_Name => Name_Unchecked_Access)));
3122 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3123 -- Build_Get_Unique_RP_Call needs this information
3125 -- Note: Here we assume that the Fat_Type is a record
3126 -- containing just a pointer to a proxy or stub object.
3128 Proc_Statements := New_List (
3132 -- Get_RAS_Info (Pkg, Subp, PA);
3133 -- if Origin = Local_Partition_Id
3134 -- and then not All_Calls_Remote
3136 -- return Fat_Type!(PA);
3139 Make_Procedure_Call_Statement (Loc,
3141 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3142 Parameter_Associations => New_List (
3143 New_Occurrence_Of (Package_Name, Loc),
3144 New_Occurrence_Of (Subp_Id, Loc),
3145 New_Occurrence_Of (Proxy_Addr, Loc))),
3147 Make_Implicit_If_Statement (N,
3153 New_Occurrence_Of (Origin, Loc),
3155 Make_Function_Call (Loc,
3157 RTE (RE_Get_Local_Partition_Id), Loc))),
3160 New_Occurrence_Of (All_Calls_Remote, Loc))),
3161 Then_Statements => New_List (
3162 Make_Return_Statement (Loc,
3163 Unchecked_Convert_To (Fat_Type,
3164 OK_Convert_To (RTE (RE_Address),
3165 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3167 Set_Field (Name_Origin,
3168 New_Occurrence_Of (Origin, Loc)),
3170 Set_Field (Name_Receiver,
3171 Make_Function_Call (Loc,
3173 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3174 Parameter_Associations => New_List (
3175 New_Occurrence_Of (Package_Name, Loc)))),
3177 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3179 -- E.4.1(9) A remote call is asynchronous if it is a call to
3180 -- a procedure, or a call through a value of an access-to-procedure
3181 -- type, to which a pragma Asynchronous applies.
3183 -- Parameter Asynch_P is true when the procedure is asynchronous;
3184 -- Expression Asynch_T is true when the type is asynchronous.
3186 Set_Field (Name_Asynchronous,
3188 New_Occurrence_Of (Asynch_P, Loc),
3189 New_Occurrence_Of (Boolean_Literals (
3190 Is_Asynchronous (Ras_Type)), Loc))));
3192 Append_List_To (Proc_Statements,
3193 Build_Get_Unique_RP_Call
3194 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3196 -- Return the newly created value
3198 Append_To (Proc_Statements,
3199 Make_Return_Statement (Loc,
3201 Unchecked_Convert_To (Fat_Type,
3202 New_Occurrence_Of (Stub_Ptr, Loc))));
3205 Make_Function_Specification (Loc,
3206 Defining_Unit_Name => Proc,
3207 Parameter_Specifications => New_List (
3208 Make_Parameter_Specification (Loc,
3209 Defining_Identifier => Package_Name,
3211 New_Occurrence_Of (Standard_String, Loc)),
3213 Make_Parameter_Specification (Loc,
3214 Defining_Identifier => Subp_Id,
3216 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3218 Make_Parameter_Specification (Loc,
3219 Defining_Identifier => Asynch_P,
3221 New_Occurrence_Of (Standard_Boolean, Loc)),
3223 Make_Parameter_Specification (Loc,
3224 Defining_Identifier => All_Calls_Remote,
3226 New_Occurrence_Of (Standard_Boolean, Loc))),
3229 New_Occurrence_Of (Fat_Type, Loc));
3231 -- Set the kind and return type of the function to prevent
3232 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3234 Set_Ekind (Proc, E_Function);
3235 Set_Etype (Proc, Fat_Type);
3238 Make_Subprogram_Body (Loc,
3239 Specification => Proc_Spec,
3240 Declarations => Proc_Decls,
3241 Handled_Statement_Sequence =>
3242 Make_Handled_Sequence_Of_Statements (Loc,
3243 Statements => Proc_Statements)));
3245 Set_TSS (Fat_Type, Proc);
3246 end Add_RAS_Access_TSS;
3248 -----------------------
3249 -- Add_RAST_Features --
3250 -----------------------
3252 procedure Add_RAST_Features
3253 (Vis_Decl : Node_Id;
3254 RAS_Type : Entity_Id)
3256 pragma Warnings (Off);
3257 pragma Unreferenced (RAS_Type);
3258 pragma Warnings (On);
3260 Add_RAS_Access_TSS (Vis_Decl);
3261 end Add_RAST_Features;
3263 -----------------------------------------
3264 -- Add_Receiving_Stubs_To_Declarations --
3265 -----------------------------------------
3267 procedure Add_Receiving_Stubs_To_Declarations
3268 (Pkg_Spec : Node_Id;
3271 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3273 Request_Parameter : Node_Id;
3275 Pkg_RPC_Receiver : constant Entity_Id :=
3276 Make_Defining_Identifier (Loc,
3277 New_Internal_Name ('H'));
3278 Pkg_RPC_Receiver_Statements : List_Id;
3279 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3280 Pkg_RPC_Receiver_Body : Node_Id;
3281 -- A Pkg_RPC_Receiver is built to decode the request
3283 Lookup_RAS_Info : constant Entity_Id :=
3284 Make_Defining_Identifier (Loc,
3285 Chars => New_Internal_Name ('R'));
3286 -- A remote subprogram is created to allow peers to look up
3287 -- RAS information using subprogram ids.
3289 Subp_Id : Entity_Id;
3290 Subp_Index : Entity_Id;
3291 -- Subprogram_Id as read from the incoming stream
3293 Current_Declaration : Node_Id;
3294 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3295 Current_Stubs : Node_Id;
3297 Subp_Info_Array : constant Entity_Id :=
3298 Make_Defining_Identifier (Loc,
3299 Chars => New_Internal_Name ('I'));
3301 Subp_Info_List : constant List_Id := New_List;
3303 Register_Pkg_Actuals : constant List_Id := New_List;
3305 All_Calls_Remote_E : Entity_Id;
3306 Proxy_Object_Addr : Entity_Id;
3308 procedure Append_Stubs_To
3309 (RPC_Receiver_Cases : List_Id;
3311 Subprogram_Number : Int);
3312 -- Add one case to the specified RPC receiver case list
3313 -- associating Subprogram_Number with the subprogram declared
3314 -- by Declaration, for which we have receiving stubs in Stubs.
3316 ---------------------
3317 -- Append_Stubs_To --
3318 ---------------------
3320 procedure Append_Stubs_To
3321 (RPC_Receiver_Cases : List_Id;
3323 Subprogram_Number : Int)
3326 Append_To (RPC_Receiver_Cases,
3327 Make_Case_Statement_Alternative (Loc,
3329 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3332 Make_Procedure_Call_Statement (Loc,
3335 Defining_Entity (Stubs), Loc),
3336 Parameter_Associations => New_List (
3337 New_Occurrence_Of (Request_Parameter, Loc))))));
3338 end Append_Stubs_To;
3340 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3343 -- Building receiving stubs consist in several operations:
3345 -- - a package RPC receiver must be built. This subprogram
3346 -- will get a Subprogram_Id from the incoming stream
3347 -- and will dispatch the call to the right subprogram
3349 -- - a receiving stub for any subprogram visible in the package
3350 -- spec. This stub will read all the parameters from the stream,
3351 -- and put the result as well as the exception occurrence in the
3354 -- - a dummy package with an empty spec and a body made of an
3355 -- elaboration part, whose job is to register the receiving
3356 -- part of this RCI package on the name server. This is done
3357 -- by calling System.Partition_Interface.Register_Receiving_Stub
3359 Build_RPC_Receiver_Body (
3360 RPC_Receiver => Pkg_RPC_Receiver,
3361 Request => Request_Parameter,
3363 Subp_Index => Subp_Index,
3364 Stmts => Pkg_RPC_Receiver_Statements,
3365 Decl => Pkg_RPC_Receiver_Body);
3366 pragma Assert (Subp_Id = Subp_Index);
3368 -- A null subp_id denotes a call through a RAS, in which case the
3369 -- next Uint_64 element in the stream is the address of the local
3370 -- proxy object, from which we can retrieve the actual subprogram id.
3372 Append_To (Pkg_RPC_Receiver_Statements,
3373 Make_Implicit_If_Statement (Pkg_Spec,
3376 New_Occurrence_Of (Subp_Id, Loc),
3377 Make_Integer_Literal (Loc, 0)),
3378 Then_Statements => New_List (
3379 Make_Assignment_Statement (Loc,
3381 New_Occurrence_Of (Subp_Id, Loc),
3383 Make_Selected_Component (Loc,
3385 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3386 OK_Convert_To (RTE (RE_Address),
3387 Make_Attribute_Reference (Loc,
3389 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3392 Expressions => New_List (
3393 Make_Selected_Component (Loc,
3394 Prefix => Request_Parameter,
3395 Selector_Name => Name_Params))))),
3397 Make_Identifier (Loc, Name_Subp_Id))))));
3399 -- Build a subprogram for RAS information lookups
3401 Current_Declaration :=
3402 Make_Subprogram_Declaration (Loc,
3404 Make_Function_Specification (Loc,
3405 Defining_Unit_Name =>
3407 Parameter_Specifications => New_List (
3408 Make_Parameter_Specification (Loc,
3409 Defining_Identifier =>
3410 Make_Defining_Identifier (Loc, Name_Subp_Id),
3414 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3416 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3417 Append_To (Decls, Current_Declaration);
3418 Analyze (Current_Declaration);
3420 Current_Stubs := Build_Subprogram_Receiving_Stubs
3421 (Vis_Decl => Current_Declaration,
3422 Asynchronous => False);
3423 Append_To (Decls, Current_Stubs);
3424 Analyze (Current_Stubs);
3426 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3429 Subprogram_Number => 1);
3431 -- For each subprogram, the receiving stub will be built and a
3432 -- case statement will be made on the Subprogram_Id to dispatch
3433 -- to the right subprogram.
3435 All_Calls_Remote_E := Boolean_Literals (
3436 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3438 Overload_Counter_Table.Reset;
3440 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3441 while Present (Current_Declaration) loop
3442 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3443 and then Comes_From_Source (Current_Declaration)
3446 Loc : constant Source_Ptr :=
3447 Sloc (Current_Declaration);
3448 -- While specifically processing Current_Declaration, use
3449 -- its Sloc as the location of all generated nodes.
3451 Subp_Def : constant Entity_Id :=
3453 (Specification (Current_Declaration));
3455 Subp_Val : String_Id;
3458 pragma Assert (Current_Subprogram_Number =
3459 Get_Subprogram_Id (Subp_Def));
3461 -- Build receiving stub
3464 Build_Subprogram_Receiving_Stubs
3465 (Vis_Decl => Current_Declaration,
3467 Nkind (Specification (Current_Declaration)) =
3468 N_Procedure_Specification
3469 and then Is_Asynchronous (Subp_Def));
3471 Append_To (Decls, Current_Stubs);
3472 Analyze (Current_Stubs);
3476 Add_RAS_Proxy_And_Analyze (Decls,
3478 Current_Declaration,
3479 All_Calls_Remote_E =>
3481 Proxy_Object_Addr =>
3484 -- Compute distribution identifier
3486 Assign_Subprogram_Identifier (
3488 Current_Subprogram_Number,
3491 -- Add subprogram descriptor (RCI_Subp_Info) to the
3492 -- subprograms table for this receiver. The aggregate
3493 -- below must be kept consistent with the declaration
3494 -- of type RCI_Subp_Info in System.Partition_Interface.
3496 Append_To (Subp_Info_List,
3497 Make_Component_Association (Loc,
3498 Choices => New_List (
3499 Make_Integer_Literal (Loc,
3500 Current_Subprogram_Number)),
3502 Make_Aggregate (Loc,
3503 Component_Associations => New_List (
3504 Make_Component_Association (Loc,
3505 Choices => New_List (
3506 Make_Identifier (Loc, Name_Addr)),
3509 Proxy_Object_Addr, Loc))))));
3511 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3514 Subprogram_Number =>
3515 Current_Subprogram_Number);
3518 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3521 Next (Current_Declaration);
3524 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3525 -- rather than raising an exception since we do not want someone
3526 -- to crash a remote partition by sending invalid subprogram ids.
3527 -- This is consistent with the other parts of the case statement
3528 -- since even in presence of incorrect parameters in the stream,
3529 -- every exception will be caught and (if the subprogram is not an
3530 -- APC) put into the result stream and sent away.
3532 Append_To (Pkg_RPC_Receiver_Cases,
3533 Make_Case_Statement_Alternative (Loc,
3535 New_List (Make_Others_Choice (Loc)),
3537 New_List (Make_Null_Statement (Loc))));
3539 Append_To (Pkg_RPC_Receiver_Statements,
3540 Make_Case_Statement (Loc,
3542 New_Occurrence_Of (Subp_Id, Loc),
3543 Alternatives => Pkg_RPC_Receiver_Cases));
3546 Make_Object_Declaration (Loc,
3547 Defining_Identifier => Subp_Info_Array,
3548 Constant_Present => True,
3549 Aliased_Present => True,
3550 Object_Definition =>
3551 Make_Subtype_Indication (Loc,
3553 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3555 Make_Index_Or_Discriminant_Constraint (Loc,
3558 Low_Bound => Make_Integer_Literal (Loc,
3559 First_RCI_Subprogram_Id),
3561 Make_Integer_Literal (Loc,
3562 First_RCI_Subprogram_Id
3563 + List_Length (Subp_Info_List) - 1))))),
3565 Make_Aggregate (Loc,
3566 Component_Associations => Subp_Info_List)));
3567 Analyze (Last (Decls));
3570 Make_Subprogram_Body (Loc,
3572 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
3575 Handled_Statement_Sequence =>
3576 Make_Handled_Sequence_Of_Statements (Loc,
3577 Statements => New_List (
3578 Make_Return_Statement (Loc,
3579 Expression => OK_Convert_To (RTE (RE_Unsigned_64),
3580 Make_Selected_Component (Loc,
3582 Make_Indexed_Component (Loc,
3584 New_Occurrence_Of (Subp_Info_Array, Loc),
3585 Expressions => New_List (
3586 Convert_To (Standard_Integer,
3587 Make_Identifier (Loc, Name_Subp_Id)))),
3589 Make_Identifier (Loc, Name_Addr))))))));
3590 Analyze (Last (Decls));
3592 Append_To (Decls, Pkg_RPC_Receiver_Body);
3593 Analyze (Last (Decls));
3595 Get_Library_Unit_Name_String (Pkg_Spec);
3596 Append_To (Register_Pkg_Actuals,
3598 Make_String_Literal (Loc,
3599 Strval => String_From_Name_Buffer));
3601 Append_To (Register_Pkg_Actuals,
3603 Make_Attribute_Reference (Loc,
3605 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
3607 Name_Unrestricted_Access));
3609 Append_To (Register_Pkg_Actuals,
3611 Make_Attribute_Reference (Loc,
3613 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
3617 Append_To (Register_Pkg_Actuals,
3619 Make_Attribute_Reference (Loc,
3621 New_Occurrence_Of (Subp_Info_Array, Loc),
3625 Append_To (Register_Pkg_Actuals,
3627 Make_Attribute_Reference (Loc,
3629 New_Occurrence_Of (Subp_Info_Array, Loc),
3634 Make_Procedure_Call_Statement (Loc,
3636 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
3637 Parameter_Associations => Register_Pkg_Actuals));
3638 Analyze (Last (Decls));
3639 end Add_Receiving_Stubs_To_Declarations;
3641 ---------------------------------
3642 -- Build_General_Calling_Stubs --
3643 ---------------------------------
3645 procedure Build_General_Calling_Stubs
3647 Statements : List_Id;
3648 Target_Partition : Entity_Id;
3649 Target_RPC_Receiver : Node_Id;
3650 Subprogram_Id : Node_Id;
3651 Asynchronous : Node_Id := Empty;
3652 Is_Known_Asynchronous : Boolean := False;
3653 Is_Known_Non_Asynchronous : Boolean := False;
3654 Is_Function : Boolean;
3656 Stub_Type : Entity_Id := Empty;
3657 RACW_Type : Entity_Id := Empty;
3660 Loc : constant Source_Ptr := Sloc (Nod);
3662 Stream_Parameter : Node_Id;
3663 -- Name of the stream used to transmit parameters to the
3666 Result_Parameter : Node_Id;
3667 -- Name of the result parameter (in non-APC cases) which get the
3668 -- result of the remote subprogram.
3670 Exception_Return_Parameter : Node_Id;
3671 -- Name of the parameter which will hold the exception sent by the
3672 -- remote subprogram.
3674 Current_Parameter : Node_Id;
3675 -- Current parameter being handled
3677 Ordered_Parameters_List : constant List_Id :=
3678 Build_Ordered_Parameters_List (Spec);
3680 Asynchronous_Statements : List_Id := No_List;
3681 Non_Asynchronous_Statements : List_Id := No_List;
3682 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
3684 Extra_Formal_Statements : constant List_Id := New_List;
3685 -- List of statements for extra formal parameters. It will appear
3686 -- after the regular statements for writing out parameters.
3688 pragma Warnings (Off);
3689 pragma Unreferenced (RACW_Type);
3690 -- Used only for the PolyORB case
3691 pragma Warnings (On);
3694 -- The general form of a calling stub for a given subprogram is:
3696 -- procedure X (...) is P : constant Partition_ID :=
3697 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
3698 -- System.RPC.Params_Stream_Type (0); begin
3699 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
3700 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
3701 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
3702 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
3704 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
3706 -- There are some variations: Do_APC is called for an asynchronous
3707 -- procedure and the part after the call is completely ommitted as
3708 -- well as the declaration of Result. For a function call, 'Input is
3709 -- always used to read the result even if it is constrained.
3712 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3715 Make_Object_Declaration (Loc,
3716 Defining_Identifier => Stream_Parameter,
3717 Aliased_Present => True,
3718 Object_Definition =>
3719 Make_Subtype_Indication (Loc,
3721 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
3723 Make_Index_Or_Discriminant_Constraint (Loc,
3725 New_List (Make_Integer_Literal (Loc, 0))))));
3727 if not Is_Known_Asynchronous then
3729 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3732 Make_Object_Declaration (Loc,
3733 Defining_Identifier => Result_Parameter,
3734 Aliased_Present => True,
3735 Object_Definition =>
3736 Make_Subtype_Indication (Loc,
3738 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
3740 Make_Index_Or_Discriminant_Constraint (Loc,
3742 New_List (Make_Integer_Literal (Loc, 0))))));
3744 Exception_Return_Parameter :=
3745 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3748 Make_Object_Declaration (Loc,
3749 Defining_Identifier => Exception_Return_Parameter,
3750 Object_Definition =>
3751 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
3754 Result_Parameter := Empty;
3755 Exception_Return_Parameter := Empty;
3758 -- Put first the RPC receiver corresponding to the remote package
3760 Append_To (Statements,
3761 Make_Attribute_Reference (Loc,
3763 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3764 Attribute_Name => Name_Write,
3765 Expressions => New_List (
3766 Make_Attribute_Reference (Loc,
3768 New_Occurrence_Of (Stream_Parameter, Loc),
3771 Target_RPC_Receiver)));
3773 -- Then put the Subprogram_Id of the subprogram we want to call in
3776 Append_To (Statements,
3777 Make_Attribute_Reference (Loc,
3779 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
3782 Expressions => New_List (
3783 Make_Attribute_Reference (Loc,
3785 New_Occurrence_Of (Stream_Parameter, Loc),
3786 Attribute_Name => Name_Access),
3789 Current_Parameter := First (Ordered_Parameters_List);
3790 while Present (Current_Parameter) loop
3792 Typ : constant Node_Id :=
3793 Parameter_Type (Current_Parameter);
3795 Constrained : Boolean;
3797 Extra_Parameter : Entity_Id;
3800 if Is_RACW_Controlling_Formal
3801 (Current_Parameter, Stub_Type)
3803 -- In the case of a controlling formal argument, we marshall
3804 -- its addr field rather than the local stub.
3806 Append_To (Statements,
3807 Pack_Node_Into_Stream (Loc,
3808 Stream => Stream_Parameter,
3810 Make_Selected_Component (Loc,
3812 Defining_Identifier (Current_Parameter),
3813 Selector_Name => Name_Addr),
3814 Etyp => RTE (RE_Unsigned_64)));
3817 Value := New_Occurrence_Of
3818 (Defining_Identifier (Current_Parameter), Loc);
3820 -- Access type parameters are transmitted as in out
3821 -- parameters. However, a dereference is needed so that
3822 -- we marshall the designated object.
3824 if Nkind (Typ) = N_Access_Definition then
3825 Value := Make_Explicit_Dereference (Loc, Value);
3826 Etyp := Etype (Subtype_Mark (Typ));
3828 Etyp := Etype (Typ);
3832 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
3834 -- Any parameter but unconstrained out parameters are
3835 -- transmitted to the peer.
3837 if In_Present (Current_Parameter)
3838 or else not Out_Present (Current_Parameter)
3839 or else not Constrained
3841 Append_To (Statements,
3842 Make_Attribute_Reference (Loc,
3844 New_Occurrence_Of (Etyp, Loc),
3846 Output_From_Constrained (Constrained),
3847 Expressions => New_List (
3848 Make_Attribute_Reference (Loc,
3850 New_Occurrence_Of (Stream_Parameter, Loc),
3851 Attribute_Name => Name_Access),
3856 -- If the current parameter has a dynamic constrained status,
3857 -- then this status is transmitted as well.
3858 -- This should be done for accessibility as well ???
3860 if Nkind (Typ) /= N_Access_Definition
3861 and then Need_Extra_Constrained (Current_Parameter)
3863 -- In this block, we do not use the extra formal that has
3864 -- been created because it does not exist at the time of
3865 -- expansion when building calling stubs for remote access
3866 -- to subprogram types. We create an extra variable of this
3867 -- type and push it in the stream after the regular
3870 Extra_Parameter := Make_Defining_Identifier
3871 (Loc, New_Internal_Name ('P'));
3874 Make_Object_Declaration (Loc,
3875 Defining_Identifier => Extra_Parameter,
3876 Constant_Present => True,
3877 Object_Definition =>
3878 New_Occurrence_Of (Standard_Boolean, Loc),
3880 Make_Attribute_Reference (Loc,
3883 Defining_Identifier (Current_Parameter), Loc),
3884 Attribute_Name => Name_Constrained)));
3886 Append_To (Extra_Formal_Statements,
3887 Make_Attribute_Reference (Loc,
3889 New_Occurrence_Of (Standard_Boolean, Loc),
3892 Expressions => New_List (
3893 Make_Attribute_Reference (Loc,
3895 New_Occurrence_Of (Stream_Parameter, Loc),
3898 New_Occurrence_Of (Extra_Parameter, Loc))));
3901 Next (Current_Parameter);
3905 -- Append the formal statements list to the statements
3907 Append_List_To (Statements, Extra_Formal_Statements);
3909 if not Is_Known_Non_Asynchronous then
3911 -- Build the call to System.RPC.Do_APC
3913 Asynchronous_Statements := New_List (
3914 Make_Procedure_Call_Statement (Loc,
3916 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
3917 Parameter_Associations => New_List (
3918 New_Occurrence_Of (Target_Partition, Loc),
3919 Make_Attribute_Reference (Loc,
3921 New_Occurrence_Of (Stream_Parameter, Loc),
3925 Asynchronous_Statements := No_List;
3928 if not Is_Known_Asynchronous then
3930 -- Build the call to System.RPC.Do_RPC
3932 Non_Asynchronous_Statements := New_List (
3933 Make_Procedure_Call_Statement (Loc,
3935 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
3936 Parameter_Associations => New_List (
3937 New_Occurrence_Of (Target_Partition, Loc),
3939 Make_Attribute_Reference (Loc,
3941 New_Occurrence_Of (Stream_Parameter, Loc),
3945 Make_Attribute_Reference (Loc,
3947 New_Occurrence_Of (Result_Parameter, Loc),
3951 -- Read the exception occurrence from the result stream and
3952 -- reraise it. It does no harm if this is a Null_Occurrence since
3953 -- this does nothing.
3955 Append_To (Non_Asynchronous_Statements,
3956 Make_Attribute_Reference (Loc,
3958 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
3963 Expressions => New_List (
3964 Make_Attribute_Reference (Loc,
3966 New_Occurrence_Of (Result_Parameter, Loc),
3969 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
3971 Append_To (Non_Asynchronous_Statements,
3972 Make_Procedure_Call_Statement (Loc,
3974 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
3975 Parameter_Associations => New_List (
3976 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
3980 -- If this is a function call, then read the value and return
3981 -- it. The return value is written/read using 'Output/'Input.
3983 Append_To (Non_Asynchronous_Statements,
3984 Make_Tag_Check (Loc,
3985 Make_Return_Statement (Loc,
3987 Make_Attribute_Reference (Loc,
3990 Etype (Subtype_Mark (Spec)), Loc),
3992 Attribute_Name => Name_Input,
3994 Expressions => New_List (
3995 Make_Attribute_Reference (Loc,
3997 New_Occurrence_Of (Result_Parameter, Loc),
3998 Attribute_Name => Name_Access))))));
4001 -- Loop around parameters and assign out (or in out)
4002 -- parameters. In the case of RACW, controlling arguments
4003 -- cannot possibly have changed since they are remote, so we do
4004 -- not read them from the stream.
4006 Current_Parameter := First (Ordered_Parameters_List);
4007 while Present (Current_Parameter) loop
4009 Typ : constant Node_Id :=
4010 Parameter_Type (Current_Parameter);
4017 (Defining_Identifier (Current_Parameter), Loc);
4019 if Nkind (Typ) = N_Access_Definition then
4020 Value := Make_Explicit_Dereference (Loc, Value);
4021 Etyp := Etype (Subtype_Mark (Typ));
4023 Etyp := Etype (Typ);
4026 if (Out_Present (Current_Parameter)
4027 or else Nkind (Typ) = N_Access_Definition)
4028 and then Etyp /= Stub_Type
4030 Append_To (Non_Asynchronous_Statements,
4031 Make_Attribute_Reference (Loc,
4033 New_Occurrence_Of (Etyp, Loc),
4035 Attribute_Name => Name_Read,
4037 Expressions => New_List (
4038 Make_Attribute_Reference (Loc,
4040 New_Occurrence_Of (Result_Parameter, Loc),
4047 Next (Current_Parameter);
4052 if Is_Known_Asynchronous then
4053 Append_List_To (Statements, Asynchronous_Statements);
4055 elsif Is_Known_Non_Asynchronous then
4056 Append_List_To (Statements, Non_Asynchronous_Statements);
4059 pragma Assert (Present (Asynchronous));
4060 Prepend_To (Asynchronous_Statements,
4061 Make_Attribute_Reference (Loc,
4062 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4063 Attribute_Name => Name_Write,
4064 Expressions => New_List (
4065 Make_Attribute_Reference (Loc,
4067 New_Occurrence_Of (Stream_Parameter, Loc),
4068 Attribute_Name => Name_Access),
4069 New_Occurrence_Of (Standard_True, Loc))));
4071 Prepend_To (Non_Asynchronous_Statements,
4072 Make_Attribute_Reference (Loc,
4073 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4074 Attribute_Name => Name_Write,
4075 Expressions => New_List (
4076 Make_Attribute_Reference (Loc,
4078 New_Occurrence_Of (Stream_Parameter, Loc),
4079 Attribute_Name => Name_Access),
4080 New_Occurrence_Of (Standard_False, Loc))));
4082 Append_To (Statements,
4083 Make_Implicit_If_Statement (Nod,
4084 Condition => Asynchronous,
4085 Then_Statements => Asynchronous_Statements,
4086 Else_Statements => Non_Asynchronous_Statements));
4088 end Build_General_Calling_Stubs;
4090 -----------------------------
4091 -- Build_RPC_Receiver_Body --
4092 -----------------------------
4094 procedure Build_RPC_Receiver_Body
4095 (RPC_Receiver : Entity_Id;
4096 Request : out Entity_Id;
4097 Subp_Id : out Entity_Id;
4098 Subp_Index : out Entity_Id;
4099 Stmts : out List_Id;
4102 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4104 RPC_Receiver_Spec : Node_Id;
4105 RPC_Receiver_Decls : List_Id;
4108 Request := Make_Defining_Identifier (Loc, Name_R);
4110 RPC_Receiver_Spec :=
4111 Build_RPC_Receiver_Specification
4112 (RPC_Receiver => RPC_Receiver,
4113 Request_Parameter => Request);
4115 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4116 Subp_Index := Subp_Id;
4118 -- Subp_Id may not be a constant, because in the case of the RPC
4119 -- receiver for an RCI package, when a call is received from a RAS
4120 -- dereference, it will be assigned during subsequent processing.
4122 RPC_Receiver_Decls := New_List (
4123 Make_Object_Declaration (Loc,
4124 Defining_Identifier => Subp_Id,
4125 Object_Definition =>
4126 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4128 Make_Attribute_Reference (Loc,
4130 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4131 Attribute_Name => Name_Input,
4132 Expressions => New_List (
4133 Make_Selected_Component (Loc,
4135 Selector_Name => Name_Params)))));
4140 Make_Subprogram_Body (Loc,
4141 Specification => RPC_Receiver_Spec,
4142 Declarations => RPC_Receiver_Decls,
4143 Handled_Statement_Sequence =>
4144 Make_Handled_Sequence_Of_Statements (Loc,
4145 Statements => Stmts));
4146 end Build_RPC_Receiver_Body;
4148 -----------------------
4149 -- Build_Stub_Target --
4150 -----------------------
4152 function Build_Stub_Target
4155 RCI_Locator : Entity_Id;
4156 Controlling_Parameter : Entity_Id) return RPC_Target
4158 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4160 Target_Info.Partition :=
4161 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4162 if Present (Controlling_Parameter) then
4164 Make_Object_Declaration (Loc,
4165 Defining_Identifier => Target_Info.Partition,
4166 Constant_Present => True,
4167 Object_Definition =>
4168 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4171 Make_Selected_Component (Loc,
4172 Prefix => Controlling_Parameter,
4173 Selector_Name => Name_Origin)));
4175 Target_Info.RPC_Receiver :=
4176 Make_Selected_Component (Loc,
4177 Prefix => Controlling_Parameter,
4178 Selector_Name => Name_Receiver);
4182 Make_Object_Declaration (Loc,
4183 Defining_Identifier => Target_Info.Partition,
4184 Constant_Present => True,
4185 Object_Definition =>
4186 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4189 Make_Function_Call (Loc,
4190 Name => Make_Selected_Component (Loc,
4192 Make_Identifier (Loc, Chars (RCI_Locator)),
4194 Make_Identifier (Loc,
4195 Name_Get_Active_Partition_ID)))));
4197 Target_Info.RPC_Receiver :=
4198 Make_Selected_Component (Loc,
4200 Make_Identifier (Loc, Chars (RCI_Locator)),
4202 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4205 end Build_Stub_Target;
4207 ---------------------
4208 -- Build_Stub_Type --
4209 ---------------------
4211 procedure Build_Stub_Type
4212 (RACW_Type : Entity_Id;
4213 Stub_Type : Entity_Id;
4214 Stub_Type_Decl : out Node_Id;
4215 RPC_Receiver_Decl : out Node_Id)
4217 Loc : constant Source_Ptr := Sloc (Stub_Type);
4218 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4222 Make_Full_Type_Declaration (Loc,
4223 Defining_Identifier => Stub_Type,
4225 Make_Record_Definition (Loc,
4226 Tagged_Present => True,
4227 Limited_Present => True,
4229 Make_Component_List (Loc,
4230 Component_Items => New_List (
4232 Make_Component_Declaration (Loc,
4233 Defining_Identifier =>
4234 Make_Defining_Identifier (Loc, Name_Origin),
4235 Component_Definition =>
4236 Make_Component_Definition (Loc,
4237 Aliased_Present => False,
4238 Subtype_Indication =>
4240 RTE (RE_Partition_ID), Loc))),
4242 Make_Component_Declaration (Loc,
4243 Defining_Identifier =>
4244 Make_Defining_Identifier (Loc, Name_Receiver),
4245 Component_Definition =>
4246 Make_Component_Definition (Loc,
4247 Aliased_Present => False,
4248 Subtype_Indication =>
4249 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4251 Make_Component_Declaration (Loc,
4252 Defining_Identifier =>
4253 Make_Defining_Identifier (Loc, Name_Addr),
4254 Component_Definition =>
4255 Make_Component_Definition (Loc,
4256 Aliased_Present => False,
4257 Subtype_Indication =>
4258 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4260 Make_Component_Declaration (Loc,
4261 Defining_Identifier =>
4262 Make_Defining_Identifier (Loc, Name_Asynchronous),
4263 Component_Definition =>
4264 Make_Component_Definition (Loc,
4265 Aliased_Present => False,
4266 Subtype_Indication =>
4268 Standard_Boolean, Loc)))))));
4271 RPC_Receiver_Decl := Empty;
4274 RPC_Receiver_Request : constant Entity_Id :=
4275 Make_Defining_Identifier (Loc, Name_R);
4277 RPC_Receiver_Decl :=
4278 Make_Subprogram_Declaration (Loc,
4279 Build_RPC_Receiver_Specification (
4280 RPC_Receiver => Make_Defining_Identifier (Loc,
4281 New_Internal_Name ('R')),
4282 Request_Parameter => RPC_Receiver_Request));
4285 end Build_Stub_Type;
4287 --------------------------------------
4288 -- Build_Subprogram_Receiving_Stubs --
4289 --------------------------------------
4291 function Build_Subprogram_Receiving_Stubs
4292 (Vis_Decl : Node_Id;
4293 Asynchronous : Boolean;
4294 Dynamically_Asynchronous : Boolean := False;
4295 Stub_Type : Entity_Id := Empty;
4296 RACW_Type : Entity_Id := Empty;
4297 Parent_Primitive : Entity_Id := Empty) return Node_Id
4299 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4301 Request_Parameter : Node_Id;
4304 Decls : constant List_Id := New_List;
4305 -- All the parameters will get declared before calling the real
4306 -- subprograms. Also the out parameters will be declared.
4308 Statements : constant List_Id := New_List;
4310 Extra_Formal_Statements : constant List_Id := New_List;
4311 -- Statements concerning extra formal parameters
4313 After_Statements : constant List_Id := New_List;
4314 -- Statements to be executed after the subprogram call
4316 Inner_Decls : List_Id := No_List;
4317 -- In case of a function, the inner declarations are needed since
4318 -- the result may be unconstrained.
4320 Excep_Handlers : List_Id := No_List;
4321 Excep_Choice : Entity_Id;
4322 Excep_Code : List_Id;
4324 Parameter_List : constant List_Id := New_List;
4325 -- List of parameters to be passed to the subprogram
4327 Current_Parameter : Node_Id;
4329 Ordered_Parameters_List : constant List_Id :=
4330 Build_Ordered_Parameters_List
4331 (Specification (Vis_Decl));
4333 Subp_Spec : Node_Id;
4334 -- Subprogram specification
4336 Called_Subprogram : Node_Id;
4337 -- The subprogram to call
4339 Null_Raise_Statement : Node_Id;
4341 Dynamic_Async : Entity_Id;
4344 if Present (RACW_Type) then
4345 Called_Subprogram :=
4346 New_Occurrence_Of (Parent_Primitive, Loc);
4348 Called_Subprogram :=
4350 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4353 Request_Parameter :=
4354 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4356 if Dynamically_Asynchronous then
4358 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4360 Dynamic_Async := Empty;
4363 if not Asynchronous or Dynamically_Asynchronous then
4365 -- The first statement after the subprogram call is a statement to
4366 -- writes a Null_Occurrence into the result stream.
4368 Null_Raise_Statement :=
4369 Make_Attribute_Reference (Loc,
4371 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4372 Attribute_Name => Name_Write,
4373 Expressions => New_List (
4374 Make_Selected_Component (Loc,
4375 Prefix => Request_Parameter,
4376 Selector_Name => Name_Result),
4377 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4379 if Dynamically_Asynchronous then
4380 Null_Raise_Statement :=
4381 Make_Implicit_If_Statement (Vis_Decl,
4383 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4384 Then_Statements => New_List (Null_Raise_Statement));
4387 Append_To (After_Statements, Null_Raise_Statement);
4390 -- Loop through every parameter and get its value from the stream. If
4391 -- the parameter is unconstrained, then the parameter is read using
4392 -- 'Input at the point of declaration.
4394 Current_Parameter := First (Ordered_Parameters_List);
4395 while Present (Current_Parameter) loop
4398 Constrained : Boolean;
4400 Object : constant Entity_Id :=
4401 Make_Defining_Identifier (Loc,
4402 New_Internal_Name ('P'));
4404 Expr : Node_Id := Empty;
4406 Is_Controlling_Formal : constant Boolean :=
4407 Is_RACW_Controlling_Formal
4408 (Current_Parameter, Stub_Type);
4411 Set_Ekind (Object, E_Variable);
4413 if Is_Controlling_Formal then
4415 -- We have a controlling formal parameter. Read its address
4416 -- rather than a real object. The address is in Unsigned_64
4419 Etyp := RTE (RE_Unsigned_64);
4421 Etyp := Etype (Parameter_Type (Current_Parameter));
4425 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
4427 if In_Present (Current_Parameter)
4428 or else not Out_Present (Current_Parameter)
4429 or else not Constrained
4430 or else Is_Controlling_Formal
4432 -- If an input parameter is contrained, then its reading is
4433 -- deferred until the beginning of the subprogram body. If
4434 -- it is unconstrained, then an expression is built for
4435 -- the object declaration and the variable is set using
4436 -- 'Input instead of 'Read.
4438 if Constrained and then not Is_Controlling_Formal then
4439 Append_To (Statements,
4440 Make_Attribute_Reference (Loc,
4441 Prefix => New_Occurrence_Of (Etyp, Loc),
4442 Attribute_Name => Name_Read,
4443 Expressions => New_List (
4444 Make_Selected_Component (Loc,
4445 Prefix => Request_Parameter,
4446 Selector_Name => Name_Params),
4447 New_Occurrence_Of (Object, Loc))));
4450 Expr := Input_With_Tag_Check (Loc,
4452 Stream => Make_Selected_Component (Loc,
4453 Prefix => Request_Parameter,
4454 Selector_Name => Name_Params));
4455 Append_To (Decls, Expr);
4456 Expr := Make_Function_Call (Loc,
4457 New_Occurrence_Of (Defining_Unit_Name
4458 (Specification (Expr)), Loc));
4462 -- If we do not have to output the current parameter, then it
4463 -- can well be flagged as constant. This may allow further
4464 -- optimizations done by the back end.
4467 Make_Object_Declaration (Loc,
4468 Defining_Identifier => Object,
4469 Constant_Present => not Constrained
4470 and then not Out_Present (Current_Parameter),
4471 Object_Definition =>
4472 New_Occurrence_Of (Etyp, Loc),
4473 Expression => Expr));
4475 -- An out parameter may be written back using a 'Write
4476 -- attribute instead of a 'Output because it has been
4477 -- constrained by the parameter given to the caller. Note that
4478 -- out controlling arguments in the case of a RACW are not put
4479 -- back in the stream because the pointer on them has not
4482 if Out_Present (Current_Parameter)
4484 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4486 Append_To (After_Statements,
4487 Make_Attribute_Reference (Loc,
4488 Prefix => New_Occurrence_Of (Etyp, Loc),
4489 Attribute_Name => Name_Write,
4490 Expressions => New_List (
4491 Make_Selected_Component (Loc,
4492 Prefix => Request_Parameter,
4493 Selector_Name => Name_Result),
4494 New_Occurrence_Of (Object, Loc))));
4497 -- For RACW controlling formals, the Etyp of Object is always
4498 -- an RACW, even if the parameter is not of an anonymous access
4499 -- type. In such case, we need to dereference it at call time.
4501 if Is_Controlling_Formal then
4502 if Nkind (Parameter_Type (Current_Parameter)) /=
4505 Append_To (Parameter_List,
4506 Make_Parameter_Association (Loc,
4509 Defining_Identifier (Current_Parameter), Loc),
4510 Explicit_Actual_Parameter =>
4511 Make_Explicit_Dereference (Loc,
4512 Unchecked_Convert_To (RACW_Type,
4513 OK_Convert_To (RTE (RE_Address),
4514 New_Occurrence_Of (Object, Loc))))));
4517 Append_To (Parameter_List,
4518 Make_Parameter_Association (Loc,
4521 Defining_Identifier (Current_Parameter), Loc),
4522 Explicit_Actual_Parameter =>
4523 Unchecked_Convert_To (RACW_Type,
4524 OK_Convert_To (RTE (RE_Address),
4525 New_Occurrence_Of (Object, Loc)))));
4529 Append_To (Parameter_List,
4530 Make_Parameter_Association (Loc,
4533 Defining_Identifier (Current_Parameter), Loc),
4534 Explicit_Actual_Parameter =>
4535 New_Occurrence_Of (Object, Loc)));
4538 -- If the current parameter needs an extra formal, then read it
4539 -- from the stream and set the corresponding semantic field in
4540 -- the variable. If the kind of the parameter identifier is
4541 -- E_Void, then this is a compiler generated parameter that
4542 -- doesn't need an extra constrained status.
4544 -- The case of Extra_Accessibility should also be handled ???
4546 if Nkind (Parameter_Type (Current_Parameter)) /=
4549 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4551 Present (Extra_Constrained
4552 (Defining_Identifier (Current_Parameter)))
4555 Extra_Parameter : constant Entity_Id :=
4557 (Defining_Identifier
4558 (Current_Parameter));
4560 Formal_Entity : constant Entity_Id :=
4561 Make_Defining_Identifier
4562 (Loc, Chars (Extra_Parameter));
4564 Formal_Type : constant Entity_Id :=
4565 Etype (Extra_Parameter);
4569 Make_Object_Declaration (Loc,
4570 Defining_Identifier => Formal_Entity,
4571 Object_Definition =>
4572 New_Occurrence_Of (Formal_Type, Loc)));
4574 Append_To (Extra_Formal_Statements,
4575 Make_Attribute_Reference (Loc,
4576 Prefix => New_Occurrence_Of (
4578 Attribute_Name => Name_Read,
4579 Expressions => New_List (
4580 Make_Selected_Component (Loc,
4581 Prefix => Request_Parameter,
4582 Selector_Name => Name_Params),
4583 New_Occurrence_Of (Formal_Entity, Loc))));
4584 Set_Extra_Constrained (Object, Formal_Entity);
4589 Next (Current_Parameter);
4592 -- Append the formal statements list at the end of regular statements
4594 Append_List_To (Statements, Extra_Formal_Statements);
4596 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
4598 -- The remote subprogram is a function. We build an inner block to
4599 -- be able to hold a potentially unconstrained result in a
4603 Etyp : constant Entity_Id :=
4604 Etype (Subtype_Mark (Specification (Vis_Decl)));
4605 Result : constant Node_Id :=
4606 Make_Defining_Identifier (Loc,
4607 New_Internal_Name ('R'));
4609 Inner_Decls := New_List (
4610 Make_Object_Declaration (Loc,
4611 Defining_Identifier => Result,
4612 Constant_Present => True,
4613 Object_Definition => New_Occurrence_Of (Etyp, Loc),
4615 Make_Function_Call (Loc,
4616 Name => Called_Subprogram,
4617 Parameter_Associations => Parameter_List)));
4619 Append_To (After_Statements,
4620 Make_Attribute_Reference (Loc,
4621 Prefix => New_Occurrence_Of (Etyp, Loc),
4622 Attribute_Name => Name_Output,
4623 Expressions => New_List (
4624 Make_Selected_Component (Loc,
4625 Prefix => Request_Parameter,
4626 Selector_Name => Name_Result),
4627 New_Occurrence_Of (Result, Loc))));
4630 Append_To (Statements,
4631 Make_Block_Statement (Loc,
4632 Declarations => Inner_Decls,
4633 Handled_Statement_Sequence =>
4634 Make_Handled_Sequence_Of_Statements (Loc,
4635 Statements => After_Statements)));
4638 -- The remote subprogram is a procedure. We do not need any inner
4639 -- block in this case.
4641 if Dynamically_Asynchronous then
4643 Make_Object_Declaration (Loc,
4644 Defining_Identifier => Dynamic_Async,
4645 Object_Definition =>
4646 New_Occurrence_Of (Standard_Boolean, Loc)));
4648 Append_To (Statements,
4649 Make_Attribute_Reference (Loc,
4650 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4651 Attribute_Name => Name_Read,
4652 Expressions => New_List (
4653 Make_Selected_Component (Loc,
4654 Prefix => Request_Parameter,
4655 Selector_Name => Name_Params),
4656 New_Occurrence_Of (Dynamic_Async, Loc))));
4659 Append_To (Statements,
4660 Make_Procedure_Call_Statement (Loc,
4661 Name => Called_Subprogram,
4662 Parameter_Associations => Parameter_List));
4664 Append_List_To (Statements, After_Statements);
4667 if Asynchronous and then not Dynamically_Asynchronous then
4669 -- For an asynchronous procedure, add a null exception handler
4671 Excep_Handlers := New_List (
4672 Make_Exception_Handler (Loc,
4673 Exception_Choices => New_List (Make_Others_Choice (Loc)),
4674 Statements => New_List (Make_Null_Statement (Loc))));
4677 -- In the other cases, if an exception is raised, then the
4678 -- exception occurrence is copied into the output stream and
4679 -- no other output parameter is written.
4682 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4684 Excep_Code := New_List (
4685 Make_Attribute_Reference (Loc,
4687 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4688 Attribute_Name => Name_Write,
4689 Expressions => New_List (
4690 Make_Selected_Component (Loc,
4691 Prefix => Request_Parameter,
4692 Selector_Name => Name_Result),
4693 New_Occurrence_Of (Excep_Choice, Loc))));
4695 if Dynamically_Asynchronous then
4696 Excep_Code := New_List (
4697 Make_Implicit_If_Statement (Vis_Decl,
4698 Condition => Make_Op_Not (Loc,
4699 New_Occurrence_Of (Dynamic_Async, Loc)),
4700 Then_Statements => Excep_Code));
4703 Excep_Handlers := New_List (
4704 Make_Exception_Handler (Loc,
4705 Choice_Parameter => Excep_Choice,
4706 Exception_Choices => New_List (Make_Others_Choice (Loc)),
4707 Statements => Excep_Code));
4712 Make_Procedure_Specification (Loc,
4713 Defining_Unit_Name =>
4714 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
4716 Parameter_Specifications => New_List (
4717 Make_Parameter_Specification (Loc,
4718 Defining_Identifier => Request_Parameter,
4720 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
4723 Make_Subprogram_Body (Loc,
4724 Specification => Subp_Spec,
4725 Declarations => Decls,
4726 Handled_Statement_Sequence =>
4727 Make_Handled_Sequence_Of_Statements (Loc,
4728 Statements => Statements,
4729 Exception_Handlers => Excep_Handlers));
4730 end Build_Subprogram_Receiving_Stubs;
4736 function Result return Node_Id is
4738 return Make_Identifier (Loc, Name_V);
4741 ----------------------
4742 -- Stream_Parameter --
4743 ----------------------
4745 function Stream_Parameter return Node_Id is
4747 return Make_Identifier (Loc, Name_S);
4748 end Stream_Parameter;
4752 -----------------------------
4753 -- Make_Selected_Component --
4754 -----------------------------
4756 function Make_Selected_Component
4759 Selector_Name : Name_Id) return Node_Id
4762 return Make_Selected_Component (Loc,
4763 Prefix => New_Occurrence_Of (Prefix, Loc),
4764 Selector_Name => Make_Identifier (Loc, Selector_Name));
4765 end Make_Selected_Component;
4767 -----------------------
4768 -- Get_Subprogram_Id --
4769 -----------------------
4771 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
4773 return Get_Subprogram_Ids (Def).Str_Identifier;
4774 end Get_Subprogram_Id;
4776 -----------------------
4777 -- Get_Subprogram_Id --
4778 -----------------------
4780 function Get_Subprogram_Id (Def : Entity_Id) return Int is
4782 return Get_Subprogram_Ids (Def).Int_Identifier;
4783 end Get_Subprogram_Id;
4785 ------------------------
4786 -- Get_Subprogram_Ids --
4787 ------------------------
4789 function Get_Subprogram_Ids
4790 (Def : Entity_Id) return Subprogram_Identifiers
4792 Result : Subprogram_Identifiers :=
4793 Subprogram_Identifier_Table.Get (Def);
4795 Current_Declaration : Node_Id;
4796 Current_Subp : Entity_Id;
4797 Current_Subp_Str : String_Id;
4798 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
4801 if Result.Str_Identifier = No_String then
4803 -- We are looking up this subprogram's identifier outside of the
4804 -- context of generating calling or receiving stubs. Hence we are
4805 -- processing an 'Access attribute_reference for an RCI subprogram,
4806 -- for the purpose of obtaining a RAS value.
4809 (Is_Remote_Call_Interface (Scope (Def))
4811 (Nkind (Parent (Def)) = N_Procedure_Specification
4813 Nkind (Parent (Def)) = N_Function_Specification));
4815 Current_Declaration :=
4816 First (Visible_Declarations
4817 (Package_Specification_Of_Scope (Scope (Def))));
4818 while Present (Current_Declaration) loop
4819 if Nkind (Current_Declaration) = N_Subprogram_Declaration
4820 and then Comes_From_Source (Current_Declaration)
4822 Current_Subp := Defining_Unit_Name (Specification (
4823 Current_Declaration));
4824 Assign_Subprogram_Identifier
4825 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
4827 if Current_Subp = Def then
4828 Result := (Current_Subp_Str, Current_Subp_Number);
4831 Current_Subp_Number := Current_Subp_Number + 1;
4834 Next (Current_Declaration);
4838 pragma Assert (Result.Str_Identifier /= No_String);
4840 end Get_Subprogram_Ids;
4846 function Hash (F : Entity_Id) return Hash_Index is
4848 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
4851 function Hash (F : Name_Id) return Hash_Index is
4853 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
4856 --------------------------
4857 -- Input_With_Tag_Check --
4858 --------------------------
4860 function Input_With_Tag_Check
4862 Var_Type : Entity_Id;
4863 Stream : Node_Id) return Node_Id
4867 Make_Subprogram_Body (Loc,
4868 Specification => Make_Function_Specification (Loc,
4869 Defining_Unit_Name =>
4870 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
4871 Subtype_Mark => New_Occurrence_Of (Var_Type, Loc)),
4872 Declarations => No_List,
4873 Handled_Statement_Sequence =>
4874 Make_Handled_Sequence_Of_Statements (Loc, New_List (
4875 Make_Tag_Check (Loc,
4876 Make_Return_Statement (Loc,
4877 Make_Attribute_Reference (Loc,
4878 Prefix => New_Occurrence_Of (Var_Type, Loc),
4879 Attribute_Name => Name_Input,
4881 New_List (Stream)))))));
4882 end Input_With_Tag_Check;
4884 --------------------------------
4885 -- Is_RACW_Controlling_Formal --
4886 --------------------------------
4888 function Is_RACW_Controlling_Formal
4889 (Parameter : Node_Id;
4890 Stub_Type : Entity_Id) return Boolean
4895 -- If the kind of the parameter is E_Void, then it is not a
4896 -- controlling formal (this can happen in the context of RAS).
4898 if Ekind (Defining_Identifier (Parameter)) = E_Void then
4902 -- If the parameter is not a controlling formal, then it cannot
4903 -- be possibly a RACW_Controlling_Formal.
4905 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
4909 Typ := Parameter_Type (Parameter);
4910 return (Nkind (Typ) = N_Access_Definition
4911 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
4912 or else Etype (Typ) = Stub_Type;
4913 end Is_RACW_Controlling_Formal;
4915 --------------------
4916 -- Make_Tag_Check --
4917 --------------------
4919 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
4920 Occ : constant Entity_Id :=
4921 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4924 return Make_Block_Statement (Loc,
4925 Handled_Statement_Sequence =>
4926 Make_Handled_Sequence_Of_Statements (Loc,
4927 Statements => New_List (N),
4929 Exception_Handlers => New_List (
4930 Make_Exception_Handler (Loc,
4931 Choice_Parameter => Occ,
4933 Exception_Choices =>
4934 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
4937 New_List (Make_Procedure_Call_Statement (Loc,
4939 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
4940 New_List (New_Occurrence_Of (Occ, Loc))))))));
4943 ----------------------------
4944 -- Need_Extra_Constrained --
4945 ----------------------------
4947 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
4948 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
4950 return Out_Present (Parameter)
4951 and then Has_Discriminants (Etyp)
4952 and then not Is_Constrained (Etyp)
4953 and then not Is_Indefinite_Subtype (Etyp);
4954 end Need_Extra_Constrained;
4956 ------------------------------------
4957 -- Pack_Entity_Into_Stream_Access --
4958 ------------------------------------
4960 function Pack_Entity_Into_Stream_Access
4964 Etyp : Entity_Id := Empty) return Node_Id
4969 if Present (Etyp) then
4972 Typ := Etype (Object);
4976 Pack_Node_Into_Stream_Access (Loc,
4978 Object => New_Occurrence_Of (Object, Loc),
4980 end Pack_Entity_Into_Stream_Access;
4982 ---------------------------
4983 -- Pack_Node_Into_Stream --
4984 ---------------------------
4986 function Pack_Node_Into_Stream
4990 Etyp : Entity_Id) return Node_Id
4992 Write_Attribute : Name_Id := Name_Write;
4995 if not Is_Constrained (Etyp) then
4996 Write_Attribute := Name_Output;
5000 Make_Attribute_Reference (Loc,
5001 Prefix => New_Occurrence_Of (Etyp, Loc),
5002 Attribute_Name => Write_Attribute,
5003 Expressions => New_List (
5004 Make_Attribute_Reference (Loc,
5005 Prefix => New_Occurrence_Of (Stream, Loc),
5006 Attribute_Name => Name_Access),
5008 end Pack_Node_Into_Stream;
5010 ----------------------------------
5011 -- Pack_Node_Into_Stream_Access --
5012 ----------------------------------
5014 function Pack_Node_Into_Stream_Access
5018 Etyp : Entity_Id) return Node_Id
5020 Write_Attribute : Name_Id := Name_Write;
5023 if not Is_Constrained (Etyp) then
5024 Write_Attribute := Name_Output;
5028 Make_Attribute_Reference (Loc,
5029 Prefix => New_Occurrence_Of (Etyp, Loc),
5030 Attribute_Name => Write_Attribute,
5031 Expressions => New_List (
5034 end Pack_Node_Into_Stream_Access;
5036 ---------------------
5037 -- PolyORB_Support --
5038 ---------------------
5040 package body PolyORB_Support is
5042 -- Local subprograms
5044 procedure Add_RACW_Read_Attribute
5045 (RACW_Type : Entity_Id;
5046 Stub_Type : Entity_Id;
5047 Stub_Type_Access : Entity_Id;
5048 Declarations : List_Id);
5049 -- Add Read attribute in Decls for the RACW type. The Read attribute
5050 -- is added right after the RACW_Type declaration while the body is
5051 -- inserted after Declarations.
5053 procedure Add_RACW_Write_Attribute
5054 (RACW_Type : Entity_Id;
5055 Stub_Type : Entity_Id;
5056 Stub_Type_Access : Entity_Id;
5057 Declarations : List_Id);
5058 -- Same thing for the Write attribute
5060 procedure Add_RACW_From_Any
5061 (RACW_Type : Entity_Id;
5062 Stub_Type : Entity_Id;
5063 Stub_Type_Access : Entity_Id;
5064 Declarations : List_Id);
5065 -- Add the From_Any TSS for this RACW type
5067 procedure Add_RACW_To_Any
5068 (Designated_Type : Entity_Id;
5069 RACW_Type : Entity_Id;
5070 Stub_Type : Entity_Id;
5071 Stub_Type_Access : Entity_Id;
5072 Declarations : List_Id);
5073 -- Add the To_Any TSS for this RACW type
5075 procedure Add_RACW_TypeCode
5076 (Designated_Type : Entity_Id;
5077 RACW_Type : Entity_Id;
5078 Declarations : List_Id);
5079 -- Add the TypeCode TSS for this RACW type
5081 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5082 -- Add the From_Any TSS for this RAS type
5084 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5085 -- Add the To_Any TSS for this RAS type
5087 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5088 -- Add the TypeCode TSS for this RAS type
5090 procedure Add_RAS_Access_TSS (N : Node_Id);
5091 -- Add a subprogram body for RAS Access TSS
5093 -------------------------------------
5094 -- Add_Obj_RPC_Receiver_Completion --
5095 -------------------------------------
5097 procedure Add_Obj_RPC_Receiver_Completion
5100 RPC_Receiver : Entity_Id;
5101 Stub_Elements : Stub_Structure)
5103 Desig : constant Entity_Id :=
5104 Etype (Designated_Type (Stub_Elements.RACW_Type));
5107 Make_Procedure_Call_Statement (Loc,
5110 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5112 Parameter_Associations => New_List (
5116 Make_String_Literal (Loc,
5117 Full_Qualified_Name (Desig)),
5121 Make_Attribute_Reference (Loc,
5124 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5130 Make_Attribute_Reference (Loc,
5133 Defining_Identifier (
5134 Stub_Elements.RPC_Receiver_Decl), Loc),
5137 end Add_Obj_RPC_Receiver_Completion;
5139 -----------------------
5140 -- Add_RACW_Features --
5141 -----------------------
5143 procedure Add_RACW_Features
5144 (RACW_Type : Entity_Id;
5146 Stub_Type : Entity_Id;
5147 Stub_Type_Access : Entity_Id;
5148 RPC_Receiver_Decl : Node_Id;
5149 Declarations : List_Id)
5151 pragma Warnings (Off);
5152 pragma Unreferenced (RPC_Receiver_Decl);
5153 pragma Warnings (On);
5157 (RACW_Type => RACW_Type,
5158 Stub_Type => Stub_Type,
5159 Stub_Type_Access => Stub_Type_Access,
5160 Declarations => Declarations);
5163 (Designated_Type => Desig,
5164 RACW_Type => RACW_Type,
5165 Stub_Type => Stub_Type,
5166 Stub_Type_Access => Stub_Type_Access,
5167 Declarations => Declarations);
5169 -- In the PolyORB case, the RACW 'Read and 'Write attributes
5170 -- are implemented in terms of the From_Any and To_Any TSSs,
5171 -- so these TSSs must be expanded before 'Read and 'Write.
5173 Add_RACW_Write_Attribute
5174 (RACW_Type => RACW_Type,
5175 Stub_Type => Stub_Type,
5176 Stub_Type_Access => Stub_Type_Access,
5177 Declarations => Declarations);
5179 Add_RACW_Read_Attribute
5180 (RACW_Type => RACW_Type,
5181 Stub_Type => Stub_Type,
5182 Stub_Type_Access => Stub_Type_Access,
5183 Declarations => Declarations);
5186 (Designated_Type => Desig,
5187 RACW_Type => RACW_Type,
5188 Declarations => Declarations);
5189 end Add_RACW_Features;
5191 -----------------------
5192 -- Add_RACW_From_Any --
5193 -----------------------
5195 procedure Add_RACW_From_Any
5196 (RACW_Type : Entity_Id;
5197 Stub_Type : Entity_Id;
5198 Stub_Type_Access : Entity_Id;
5199 Declarations : List_Id)
5201 Loc : constant Source_Ptr := Sloc (RACW_Type);
5202 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5204 Fnam : constant Entity_Id :=
5205 Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
5207 Func_Spec : Node_Id;
5208 Func_Decl : Node_Id;
5209 Func_Body : Node_Id;
5212 Statements : List_Id;
5213 Stub_Statements : List_Id;
5214 Local_Statements : List_Id;
5215 -- Various parts of the subprogram
5217 Any_Parameter : constant Entity_Id :=
5218 Make_Defining_Identifier (Loc, Name_A);
5219 Reference : constant Entity_Id :=
5220 Make_Defining_Identifier
5221 (Loc, New_Internal_Name ('R'));
5222 Is_Local : constant Entity_Id :=
5223 Make_Defining_Identifier
5224 (Loc, New_Internal_Name ('L'));
5225 Addr : constant Entity_Id :=
5226 Make_Defining_Identifier
5227 (Loc, New_Internal_Name ('A'));
5228 Local_Stub : constant Entity_Id :=
5229 Make_Defining_Identifier
5230 (Loc, New_Internal_Name ('L'));
5231 Stubbed_Result : constant Entity_Id :=
5232 Make_Defining_Identifier
5233 (Loc, New_Internal_Name ('S'));
5235 Stub_Condition : Node_Id;
5236 -- An expression that determines whether we create a stub for the
5237 -- newly-unpacked RACW. Normally we create a stub only for remote
5238 -- objects, but in the case of an RACW used to implement a RAS,
5239 -- we also create a stub for local subprograms if a pragma
5240 -- All_Calls_Remote applies.
5242 Asynchronous_Flag : constant Entity_Id :=
5243 Asynchronous_Flags_Table.Get (RACW_Type);
5244 -- The flag object declared in Add_RACW_Asynchronous_Flag
5247 -- Object declarations
5250 Make_Object_Declaration (Loc,
5251 Defining_Identifier =>
5253 Object_Definition =>
5254 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5256 Make_Function_Call (Loc,
5258 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5259 Parameter_Associations => New_List (
5260 New_Occurrence_Of (Any_Parameter, Loc)))),
5262 Make_Object_Declaration (Loc,
5263 Defining_Identifier => Local_Stub,
5264 Aliased_Present => True,
5265 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
5267 Make_Object_Declaration (Loc,
5268 Defining_Identifier => Stubbed_Result,
5269 Object_Definition =>
5270 New_Occurrence_Of (Stub_Type_Access, Loc),
5272 Make_Attribute_Reference (Loc,
5274 New_Occurrence_Of (Local_Stub, Loc),
5276 Name_Unchecked_Access)),
5278 Make_Object_Declaration (Loc,
5279 Defining_Identifier => Is_Local,
5280 Object_Definition =>
5281 New_Occurrence_Of (Standard_Boolean, Loc)),
5283 Make_Object_Declaration (Loc,
5284 Defining_Identifier => Addr,
5285 Object_Definition =>
5286 New_Occurrence_Of (RTE (RE_Address), Loc)));
5288 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5290 Set_Etype (Stubbed_Result, Stub_Type_Access);
5292 -- If the ref Is_Nil, return a null pointer
5294 Statements := New_List (
5295 Make_Implicit_If_Statement (RACW_Type,
5297 Make_Function_Call (Loc,
5299 New_Occurrence_Of (RTE (RE_Is_Nil), Loc),
5300 Parameter_Associations => New_List (
5301 New_Occurrence_Of (Reference, Loc))),
5302 Then_Statements => New_List (
5303 Make_Return_Statement (Loc,
5305 Make_Null (Loc)))));
5307 Append_To (Statements,
5308 Make_Procedure_Call_Statement (Loc,
5310 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
5311 Parameter_Associations => New_List (
5312 New_Occurrence_Of (Reference, Loc),
5313 New_Occurrence_Of (Is_Local, Loc),
5314 New_Occurrence_Of (Addr, Loc))));
5316 -- If the object is located on another partition, then a stub object
5317 -- will be created with all the information needed to rebuild the
5318 -- real object at the other end. This stanza is always used in the
5319 -- case of RAS types, for which a stub is required even for local
5322 Stub_Statements := New_List (
5323 Make_Assignment_Statement (Loc,
5324 Name => Make_Selected_Component (Loc,
5325 Prefix => Stubbed_Result,
5326 Selector_Name => Name_Target),
5328 Make_Function_Call (Loc,
5330 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
5331 Parameter_Associations => New_List (
5332 New_Occurrence_Of (Reference, Loc)))),
5334 Make_Procedure_Call_Statement (Loc,
5336 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
5337 Parameter_Associations => New_List (
5338 Make_Selected_Component (Loc,
5339 Prefix => Stubbed_Result,
5340 Selector_Name => Name_Target))),
5342 Make_Assignment_Statement (Loc,
5343 Name => Make_Selected_Component (Loc,
5344 Prefix => Stubbed_Result,
5345 Selector_Name => Name_Asynchronous),
5347 New_Occurrence_Of (Asynchronous_Flag, Loc)));
5349 -- ??? Issue with asynchronous calls here: the Asynchronous
5350 -- flag is set on the stub type if, and only if, the RACW type
5351 -- has a pragma Asynchronous. This is incorrect for RACWs that
5352 -- implement RAS types, because in that case the /designated
5353 -- subprogram/ (not the type) might be asynchronous, and
5354 -- that causes the stub to need to be asynchronous too.
5355 -- A solution is to transport a RAS as a struct containing
5356 -- a RACW and an asynchronous flag, and to properly alter
5357 -- the Asynchronous component in the stub type in the RAS's
5360 Append_List_To (Stub_Statements,
5361 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
5363 -- Distinguish between the local and remote cases, and execute the
5364 -- appropriate piece of code.
5366 Stub_Condition := New_Occurrence_Of (Is_Local, Loc);
5369 Stub_Condition := Make_And_Then (Loc,
5373 Make_Selected_Component (Loc,
5375 Unchecked_Convert_To (
5376 RTE (RE_RAS_Proxy_Type_Access),
5377 New_Occurrence_Of (Addr, Loc)),
5379 Make_Identifier (Loc,
5380 Name_All_Calls_Remote)));
5383 Local_Statements := New_List (
5384 Make_Return_Statement (Loc,
5386 Unchecked_Convert_To (RACW_Type,
5387 New_Occurrence_Of (Addr, Loc))));
5389 Append_To (Statements,
5390 Make_Implicit_If_Statement (RACW_Type,
5393 Then_Statements => Local_Statements,
5394 Else_Statements => Stub_Statements));
5396 Append_To (Statements,
5397 Make_Return_Statement (Loc,
5398 Expression => Unchecked_Convert_To (RACW_Type,
5399 New_Occurrence_Of (Stubbed_Result, Loc))));
5402 Make_Function_Specification (Loc,
5403 Defining_Unit_Name =>
5405 Parameter_Specifications => New_List (
5406 Make_Parameter_Specification (Loc,
5407 Defining_Identifier =>
5410 New_Occurrence_Of (RTE (RE_Any), Loc))),
5411 Subtype_Mark => New_Occurrence_Of (RACW_Type, Loc));
5413 -- NOTE: The usage occurrences of RACW_Parameter must
5414 -- refer to the entity in the declaration spec, not those
5415 -- of the body spec.
5417 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5420 Make_Subprogram_Body (Loc,
5422 Copy_Specification (Loc, Func_Spec),
5423 Declarations => Decls,
5424 Handled_Statement_Sequence =>
5425 Make_Handled_Sequence_Of_Statements (Loc,
5426 Statements => Statements));
5428 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5429 Append_To (Declarations, Func_Body);
5431 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5432 end Add_RACW_From_Any;
5434 -----------------------------
5435 -- Add_RACW_Read_Attribute --
5436 -----------------------------
5438 procedure Add_RACW_Read_Attribute
5439 (RACW_Type : Entity_Id;
5440 Stub_Type : Entity_Id;
5441 Stub_Type_Access : Entity_Id;
5442 Declarations : List_Id)
5444 pragma Warnings (Off);
5445 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5446 pragma Warnings (On);
5447 Loc : constant Source_Ptr := Sloc (RACW_Type);
5449 Proc_Decl : Node_Id;
5450 Attr_Decl : Node_Id;
5452 Body_Node : Node_Id;
5455 Statements : List_Id;
5456 -- Various parts of the procedure
5458 Procedure_Name : constant Name_Id :=
5459 New_Internal_Name ('R');
5460 Source_Ref : constant Entity_Id :=
5461 Make_Defining_Identifier
5462 (Loc, New_Internal_Name ('R'));
5463 Asynchronous_Flag : constant Entity_Id :=
5464 Asynchronous_Flags_Table.Get (RACW_Type);
5465 pragma Assert (Present (Asynchronous_Flag));
5467 function Stream_Parameter return Node_Id;
5468 function Result return Node_Id;
5469 -- Functions to create occurrences of the formal parameter names
5475 function Result return Node_Id is
5477 return Make_Identifier (Loc, Name_V);
5480 ----------------------
5481 -- Stream_Parameter --
5482 ----------------------
5484 function Stream_Parameter return Node_Id is
5486 return Make_Identifier (Loc, Name_S);
5487 end Stream_Parameter;
5489 -- Start of processing for Add_RACW_Read_Attribute
5492 -- Generate object declarations
5495 Make_Object_Declaration (Loc,
5496 Defining_Identifier => Source_Ref,
5497 Object_Definition =>
5498 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5500 Statements := New_List (
5501 Make_Attribute_Reference (Loc,
5503 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5504 Attribute_Name => Name_Read,
5505 Expressions => New_List (
5507 New_Occurrence_Of (Source_Ref, Loc))),
5508 Make_Assignment_Statement (Loc,
5512 PolyORB_Support.Helpers.Build_From_Any_Call (
5514 Make_Function_Call (Loc,
5516 New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5517 Parameter_Associations => New_List (
5518 New_Occurrence_Of (Source_Ref, Loc))),
5521 Build_Stream_Procedure
5522 (Loc, RACW_Type, Body_Node,
5523 Make_Defining_Identifier (Loc, Procedure_Name),
5524 Statements, Outp => True);
5525 Set_Declarations (Body_Node, Decls);
5527 Proc_Decl := Make_Subprogram_Declaration (Loc,
5528 Copy_Specification (Loc, Specification (Body_Node)));
5531 Make_Attribute_Definition_Clause (Loc,
5532 Name => New_Occurrence_Of (RACW_Type, Loc),
5536 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5538 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5539 Insert_After (Proc_Decl, Attr_Decl);
5540 Append_To (Declarations, Body_Node);
5541 end Add_RACW_Read_Attribute;
5543 ---------------------
5544 -- Add_RACW_To_Any --
5545 ---------------------
5547 procedure Add_RACW_To_Any
5548 (Designated_Type : Entity_Id;
5549 RACW_Type : Entity_Id;
5550 Stub_Type : Entity_Id;
5551 Stub_Type_Access : Entity_Id;
5552 Declarations : List_Id)
5554 Loc : constant Source_Ptr := Sloc (RACW_Type);
5556 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5560 Stub_Elements : constant Stub_Structure :=
5561 Stubs_Table.Get (Designated_Type);
5562 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5564 Func_Spec : Node_Id;
5565 Func_Decl : Node_Id;
5566 Func_Body : Node_Id;
5569 Statements : List_Id;
5570 Null_Statements : List_Id;
5571 Local_Statements : List_Id := No_List;
5572 Stub_Statements : List_Id;
5574 -- Various parts of the subprogram
5576 RACW_Parameter : constant Entity_Id
5577 := Make_Defining_Identifier (Loc, Name_R);
5579 Reference : constant Entity_Id :=
5580 Make_Defining_Identifier
5581 (Loc, New_Internal_Name ('R'));
5582 Any : constant Entity_Id :=
5583 Make_Defining_Identifier
5584 (Loc, New_Internal_Name ('A'));
5587 -- Object declarations
5590 Make_Object_Declaration (Loc,
5591 Defining_Identifier =>
5593 Object_Definition =>
5594 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
5595 Make_Object_Declaration (Loc,
5596 Defining_Identifier =>
5598 Object_Definition =>
5599 New_Occurrence_Of (RTE (RE_Any), Loc)));
5601 -- If the object is null, nothing to do (Reference is already
5604 Null_Statements := New_List (Make_Null_Statement (Loc));
5608 -- If the object is a RAS designating a local subprogram,
5609 -- we already have a target reference.
5611 Local_Statements := New_List (
5612 Make_Procedure_Call_Statement (Loc,
5614 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
5615 Parameter_Associations => New_List (
5616 New_Occurrence_Of (Reference, Loc),
5617 Make_Selected_Component (Loc,
5619 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
5620 New_Occurrence_Of (RACW_Parameter, Loc)),
5621 Selector_Name => Make_Identifier (Loc, Name_Target)))));
5624 -- If the object is a local RACW object, use Get_Reference now
5625 -- to obtain a reference.
5627 Local_Statements := New_List (
5628 Make_Procedure_Call_Statement (Loc,
5630 New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5631 Parameter_Associations => New_List (
5632 Unchecked_Convert_To (
5634 New_Occurrence_Of (RACW_Parameter, Loc)),
5635 Make_String_Literal (Loc,
5636 Full_Qualified_Name (Designated_Type)),
5637 Make_Attribute_Reference (Loc,
5640 Defining_Identifier (
5641 Stub_Elements.RPC_Receiver_Decl), Loc),
5644 New_Occurrence_Of (Reference, Loc))));
5647 -- If the object is located on another partition, use the target
5650 Stub_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,
5657 Prefix => Unchecked_Convert_To (Stub_Type_Access,
5658 New_Occurrence_Of (RACW_Parameter, Loc)),
5660 Make_Identifier (Loc, Name_Target)))));
5662 -- Distinguish between the null, local and remote cases,
5663 -- and execute the appropriate piece of code.
5666 Make_Implicit_If_Statement (RACW_Type,
5669 Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc),
5670 Right_Opnd => Make_Null (Loc)),
5671 Then_Statements => Null_Statements,
5672 Elsif_Parts => New_List (
5673 Make_Elsif_Part (Loc,
5677 Make_Attribute_Reference (Loc,
5679 New_Occurrence_Of (RACW_Parameter, Loc),
5680 Attribute_Name => Name_Tag),
5682 Make_Attribute_Reference (Loc,
5683 Prefix => New_Occurrence_Of (Stub_Type, Loc),
5684 Attribute_Name => Name_Tag)),
5685 Then_Statements => Local_Statements)),
5686 Else_Statements => Stub_Statements);
5688 Statements := New_List (
5690 Make_Assignment_Statement (Loc,
5692 New_Occurrence_Of (Any, Loc),
5694 Make_Function_Call (Loc,
5695 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5696 Parameter_Associations => New_List (
5697 New_Occurrence_Of (Reference, Loc)))),
5698 Make_Procedure_Call_Statement (Loc,
5700 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5701 Parameter_Associations => New_List (
5702 New_Occurrence_Of (Any, Loc),
5703 Make_Selected_Component (Loc,
5705 Defining_Identifier (
5706 Stub_Elements.RPC_Receiver_Decl),
5707 Selector_Name => Name_Obj_TypeCode))),
5708 Make_Return_Statement (Loc,
5710 New_Occurrence_Of (Any, Loc)));
5712 Fnam := Make_Defining_Identifier (
5713 Loc, New_Internal_Name ('T'));
5716 Make_Function_Specification (Loc,
5717 Defining_Unit_Name =>
5719 Parameter_Specifications => New_List (
5720 Make_Parameter_Specification (Loc,
5721 Defining_Identifier =>
5724 New_Occurrence_Of (RACW_Type, Loc))),
5725 Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), Loc));
5727 -- NOTE: The usage occurrences of RACW_Parameter must
5728 -- refer to the entity in the declaration spec, not in
5731 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5734 Make_Subprogram_Body (Loc,
5736 Copy_Specification (Loc, Func_Spec),
5737 Declarations => Decls,
5738 Handled_Statement_Sequence =>
5739 Make_Handled_Sequence_Of_Statements (Loc,
5740 Statements => Statements));
5742 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5743 Append_To (Declarations, Func_Body);
5745 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5746 end Add_RACW_To_Any;
5748 -----------------------
5749 -- Add_RACW_TypeCode --
5750 -----------------------
5752 procedure Add_RACW_TypeCode
5753 (Designated_Type : Entity_Id;
5754 RACW_Type : Entity_Id;
5755 Declarations : List_Id)
5757 Loc : constant Source_Ptr := Sloc (RACW_Type);
5761 Stub_Elements : constant Stub_Structure :=
5762 Stubs_Table.Get (Designated_Type);
5763 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5765 Func_Spec : Node_Id;
5766 Func_Decl : Node_Id;
5767 Func_Body : Node_Id;
5769 RACW_Parameter : constant Entity_Id :=
5770 Make_Defining_Identifier (Loc, Name_R);
5774 Make_Defining_Identifier (Loc,
5775 Chars => New_Internal_Name ('T'));
5777 -- The spec for this subprogram has a dummy 'access RACW'
5778 -- argument, which serves only for overloading purposes.
5781 Make_Function_Specification (Loc,
5782 Defining_Unit_Name =>
5784 Parameter_Specifications => New_List (
5785 Make_Parameter_Specification (Loc,
5786 Defining_Identifier =>
5789 Make_Access_Definition (Loc,
5791 New_Occurrence_Of (RACW_Type, Loc)))),
5792 Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
5794 -- NOTE: The usage occurrences of RACW_Parameter must
5795 -- refer to the entity in the declaration spec, not those
5796 -- of the body spec.
5798 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5801 Make_Subprogram_Body (Loc,
5803 Copy_Specification (Loc, Func_Spec),
5804 Declarations => Empty_List,
5805 Handled_Statement_Sequence =>
5806 Make_Handled_Sequence_Of_Statements (Loc,
5807 Statements => New_List (
5808 Make_Return_Statement (Loc,
5810 Make_Selected_Component (Loc,
5812 Defining_Identifier (
5813 Stub_Elements.RPC_Receiver_Decl),
5814 Selector_Name => Name_Obj_TypeCode)))));
5816 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5817 Append_To (Declarations, Func_Body);
5819 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
5820 end Add_RACW_TypeCode;
5822 ------------------------------
5823 -- Add_RACW_Write_Attribute --
5824 ------------------------------
5826 procedure Add_RACW_Write_Attribute
5827 (RACW_Type : Entity_Id;
5828 Stub_Type : Entity_Id;
5829 Stub_Type_Access : Entity_Id;
5830 Declarations : List_Id)
5832 Loc : constant Source_Ptr := Sloc (RACW_Type);
5833 pragma Warnings (Off);
5834 pragma Unreferenced (
5838 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5839 pragma Unreferenced (Is_RAS);
5840 pragma Warnings (On);
5842 Body_Node : Node_Id;
5843 Proc_Decl : Node_Id;
5844 Attr_Decl : Node_Id;
5846 Statements : List_Id;
5847 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
5849 function Stream_Parameter return Node_Id;
5850 function Object return Node_Id;
5851 -- Functions to create occurrences of the formal parameter names
5857 function Object return Node_Id is
5858 Object_Ref : constant Node_Id :=
5859 Make_Identifier (Loc, Name_V);
5862 -- Etype must be set for Build_To_Any_Call
5864 Set_Etype (Object_Ref, RACW_Type);
5869 ----------------------
5870 -- Stream_Parameter --
5871 ----------------------
5873 function Stream_Parameter return Node_Id is
5875 return Make_Identifier (Loc, Name_S);
5876 end Stream_Parameter;
5878 -- Start of processing for Add_RACW_Write_Attribute
5881 Statements := New_List (
5882 Pack_Node_Into_Stream_Access (Loc,
5883 Stream => Stream_Parameter,
5885 Make_Function_Call (Loc,
5887 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5888 Parameter_Associations => New_List (
5889 PolyORB_Support.Helpers.Build_To_Any_Call
5890 (Object, Declarations))),
5891 Etyp => RTE (RE_Object_Ref)));
5893 Build_Stream_Procedure
5894 (Loc, RACW_Type, Body_Node,
5895 Make_Defining_Identifier (Loc, Procedure_Name),
5896 Statements, Outp => False);
5899 Make_Subprogram_Declaration (Loc,
5900 Copy_Specification (Loc, Specification (Body_Node)));
5903 Make_Attribute_Definition_Clause (Loc,
5904 Name => New_Occurrence_Of (RACW_Type, Loc),
5905 Chars => Name_Write,
5908 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5910 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5911 Insert_After (Proc_Decl, Attr_Decl);
5912 Append_To (Declarations, Body_Node);
5913 end Add_RACW_Write_Attribute;
5915 -----------------------
5916 -- Add_RAST_Features --
5917 -----------------------
5919 procedure Add_RAST_Features
5920 (Vis_Decl : Node_Id;
5921 RAS_Type : Entity_Id)
5924 Add_RAS_Access_TSS (Vis_Decl);
5926 Add_RAS_From_Any (RAS_Type);
5927 Add_RAS_TypeCode (RAS_Type);
5929 -- To_Any uses TypeCode, and therefore needs to be generated last
5931 Add_RAS_To_Any (RAS_Type);
5932 end Add_RAST_Features;
5934 ------------------------
5935 -- Add_RAS_Access_TSS --
5936 ------------------------
5938 procedure Add_RAS_Access_TSS (N : Node_Id) is
5939 Loc : constant Source_Ptr := Sloc (N);
5941 Ras_Type : constant Entity_Id := Defining_Identifier (N);
5942 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
5943 -- Ras_Type is the access to subprogram type; Fat_Type is the
5944 -- corresponding record type.
5946 RACW_Type : constant Entity_Id :=
5947 Underlying_RACW_Type (Ras_Type);
5948 Desig : constant Entity_Id :=
5949 Etype (Designated_Type (RACW_Type));
5951 Stub_Elements : constant Stub_Structure :=
5952 Stubs_Table.Get (Desig);
5953 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5955 Proc : constant Entity_Id :=
5956 Make_Defining_Identifier (Loc,
5957 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
5959 Proc_Spec : Node_Id;
5961 -- Formal parameters
5963 Package_Name : constant Entity_Id :=
5964 Make_Defining_Identifier (Loc,
5969 Subp_Id : constant Entity_Id :=
5970 Make_Defining_Identifier (Loc,
5973 -- Target subprogram
5975 Asynch_P : constant Entity_Id :=
5976 Make_Defining_Identifier (Loc,
5977 Chars => Name_Asynchronous);
5978 -- Is the procedure to which the 'Access applies asynchronous?
5980 All_Calls_Remote : constant Entity_Id :=
5981 Make_Defining_Identifier (Loc,
5982 Chars => Name_All_Calls_Remote);
5983 -- True if an All_Calls_Remote pragma applies to the RCI unit
5984 -- that contains the subprogram.
5986 -- Common local variables
5988 Proc_Decls : List_Id;
5989 Proc_Statements : List_Id;
5991 Subp_Ref : constant Entity_Id :=
5992 Make_Defining_Identifier (Loc, Name_R);
5993 -- Reference that designates the target subprogram (returned
5994 -- by Get_RAS_Info).
5996 Is_Local : constant Entity_Id :=
5997 Make_Defining_Identifier (Loc, Name_L);
5998 Local_Addr : constant Entity_Id :=
5999 Make_Defining_Identifier (Loc, Name_A);
6000 -- For the call to Get_Local_Address
6002 -- Additional local variables for the remote case
6004 Local_Stub : constant Entity_Id :=
6005 Make_Defining_Identifier (Loc,
6006 Chars => New_Internal_Name ('L'));
6008 Stub_Ptr : constant Entity_Id :=
6009 Make_Defining_Identifier (Loc,
6010 Chars => New_Internal_Name ('S'));
6013 (Field_Name : Name_Id;
6014 Value : Node_Id) return Node_Id;
6015 -- Construct an assignment that sets the named component in the
6023 (Field_Name : Name_Id;
6024 Value : Node_Id) return Node_Id
6028 Make_Assignment_Statement (Loc,
6030 Make_Selected_Component (Loc,
6032 Selector_Name => Field_Name),
6033 Expression => Value);
6036 -- Start of processing for Add_RAS_Access_TSS
6039 Proc_Decls := New_List (
6041 -- Common declarations
6043 Make_Object_Declaration (Loc,
6044 Defining_Identifier => Subp_Ref,
6045 Object_Definition =>
6046 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6048 Make_Object_Declaration (Loc,
6049 Defining_Identifier => Is_Local,
6050 Object_Definition =>
6051 New_Occurrence_Of (Standard_Boolean, Loc)),
6053 Make_Object_Declaration (Loc,
6054 Defining_Identifier => Local_Addr,
6055 Object_Definition =>
6056 New_Occurrence_Of (RTE (RE_Address), Loc)),
6058 Make_Object_Declaration (Loc,
6059 Defining_Identifier => Local_Stub,
6060 Aliased_Present => True,
6061 Object_Definition =>
6062 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6064 Make_Object_Declaration (Loc,
6065 Defining_Identifier =>
6067 Object_Definition =>
6068 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6070 Make_Attribute_Reference (Loc,
6071 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6072 Attribute_Name => Name_Unchecked_Access)));
6074 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6075 -- Build_Get_Unique_RP_Call needs this information
6077 -- Get_RAS_Info (Pkg, Subp, R);
6078 -- Obtain a reference to the target subprogram
6080 Proc_Statements := New_List (
6081 Make_Procedure_Call_Statement (Loc,
6083 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6084 Parameter_Associations => New_List (
6085 New_Occurrence_Of (Package_Name, Loc),
6086 New_Occurrence_Of (Subp_Id, Loc),
6087 New_Occurrence_Of (Subp_Ref, Loc))),
6089 -- Get_Local_Address (R, L, A);
6090 -- Determine whether the subprogram is local (L), and if so
6091 -- obtain the local address of its proxy (A).
6093 Make_Procedure_Call_Statement (Loc,
6095 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6096 Parameter_Associations => New_List (
6097 New_Occurrence_Of (Subp_Ref, Loc),
6098 New_Occurrence_Of (Is_Local, Loc),
6099 New_Occurrence_Of (Local_Addr, Loc))));
6101 -- Note: Here we assume that the Fat_Type is a record containing just
6102 -- an access to a proxy or stub object.
6104 Append_To (Proc_Statements,
6108 Make_Implicit_If_Statement (N,
6110 New_Occurrence_Of (Is_Local, Loc),
6112 Then_Statements => New_List (
6114 -- if A.Target = null then
6116 Make_Implicit_If_Statement (N,
6119 Make_Selected_Component (Loc,
6121 Unchecked_Convert_To (
6122 RTE (RE_RAS_Proxy_Type_Access),
6123 New_Occurrence_Of (Local_Addr, Loc)),
6125 Make_Identifier (Loc, Name_Target)),
6128 Then_Statements => New_List (
6130 -- A.Target := Entity_Of (Ref);
6132 Make_Assignment_Statement (Loc,
6134 Make_Selected_Component (Loc,
6136 Unchecked_Convert_To (
6137 RTE (RE_RAS_Proxy_Type_Access),
6138 New_Occurrence_Of (Local_Addr, Loc)),
6140 Make_Identifier (Loc, Name_Target)),
6142 Make_Function_Call (Loc,
6144 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6145 Parameter_Associations => New_List (
6146 New_Occurrence_Of (Subp_Ref, Loc)))),
6148 -- Inc_Usage (A.Target);
6150 Make_Procedure_Call_Statement (Loc,
6152 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6153 Parameter_Associations => New_List (
6154 Make_Selected_Component (Loc,
6156 Unchecked_Convert_To (
6157 RTE (RE_RAS_Proxy_Type_Access),
6158 New_Occurrence_Of (Local_Addr, Loc)),
6159 Selector_Name => Make_Identifier (Loc,
6163 -- if not All_Calls_Remote then
6164 -- return Fat_Type!(A);
6167 Make_Implicit_If_Statement (N,
6170 New_Occurrence_Of (All_Calls_Remote, Loc)),
6172 Then_Statements => New_List (
6173 Make_Return_Statement (Loc,
6174 Unchecked_Convert_To (Fat_Type,
6175 New_Occurrence_Of (Local_Addr, Loc))))))));
6177 Append_List_To (Proc_Statements, New_List (
6179 -- Stub.Target := Entity_Of (Ref);
6181 Set_Field (Name_Target,
6182 Make_Function_Call (Loc,
6184 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6185 Parameter_Associations => New_List (
6186 New_Occurrence_Of (Subp_Ref, Loc)))),
6188 -- Inc_Usage (Stub.Target);
6190 Make_Procedure_Call_Statement (Loc,
6192 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6193 Parameter_Associations => New_List (
6194 Make_Selected_Component (Loc,
6196 Selector_Name => Name_Target))),
6198 -- E.4.1(9) A remote call is asynchronous if it is a call to
6199 -- a procedure, or a call through a value of an access-to-procedure
6200 -- type, to which a pragma Asynchronous applies.
6202 -- Parameter Asynch_P is true when the procedure is asynchronous;
6203 -- Expression Asynch_T is true when the type is asynchronous.
6205 Set_Field (Name_Asynchronous,
6207 New_Occurrence_Of (Asynch_P, Loc),
6208 New_Occurrence_Of (Boolean_Literals (
6209 Is_Asynchronous (Ras_Type)), Loc)))));
6211 Append_List_To (Proc_Statements,
6212 Build_Get_Unique_RP_Call (Loc,
6213 Stub_Ptr, Stub_Elements.Stub_Type));
6215 Append_To (Proc_Statements,
6216 Make_Return_Statement (Loc,
6218 Unchecked_Convert_To (Fat_Type,
6219 New_Occurrence_Of (Stub_Ptr, Loc))));
6222 Make_Function_Specification (Loc,
6223 Defining_Unit_Name => Proc,
6224 Parameter_Specifications => New_List (
6225 Make_Parameter_Specification (Loc,
6226 Defining_Identifier => Package_Name,
6228 New_Occurrence_Of (Standard_String, Loc)),
6230 Make_Parameter_Specification (Loc,
6231 Defining_Identifier => Subp_Id,
6233 New_Occurrence_Of (Standard_String, Loc)),
6235 Make_Parameter_Specification (Loc,
6236 Defining_Identifier => Asynch_P,
6238 New_Occurrence_Of (Standard_Boolean, Loc)),
6240 Make_Parameter_Specification (Loc,
6241 Defining_Identifier => All_Calls_Remote,
6243 New_Occurrence_Of (Standard_Boolean, Loc))),
6246 New_Occurrence_Of (Fat_Type, Loc));
6248 -- Set the kind and return type of the function to prevent
6249 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6251 Set_Ekind (Proc, E_Function);
6252 Set_Etype (Proc, Fat_Type);
6255 Make_Subprogram_Body (Loc,
6256 Specification => Proc_Spec,
6257 Declarations => Proc_Decls,
6258 Handled_Statement_Sequence =>
6259 Make_Handled_Sequence_Of_Statements (Loc,
6260 Statements => Proc_Statements)));
6262 Set_TSS (Fat_Type, Proc);
6263 end Add_RAS_Access_TSS;
6265 ----------------------
6266 -- Add_RAS_From_Any --
6267 ----------------------
6269 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6270 Loc : constant Source_Ptr := Sloc (RAS_Type);
6272 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6273 Make_TSS_Name (RAS_Type, TSS_From_Any));
6275 Func_Spec : Node_Id;
6277 Statements : List_Id;
6279 Any_Parameter : constant Entity_Id :=
6280 Make_Defining_Identifier (Loc, Name_A);
6283 Statements := New_List (
6284 Make_Return_Statement (Loc,
6286 Make_Aggregate (Loc,
6287 Component_Associations => New_List (
6288 Make_Component_Association (Loc,
6289 Choices => New_List (
6290 Make_Identifier (Loc, Name_Ras)),
6292 PolyORB_Support.Helpers.Build_From_Any_Call (
6293 Underlying_RACW_Type (RAS_Type),
6294 New_Occurrence_Of (Any_Parameter, Loc),
6298 Make_Function_Specification (Loc,
6299 Defining_Unit_Name =>
6301 Parameter_Specifications => New_List (
6302 Make_Parameter_Specification (Loc,
6303 Defining_Identifier =>
6306 New_Occurrence_Of (RTE (RE_Any), Loc))),
6307 Subtype_Mark => New_Occurrence_Of (RAS_Type, Loc));
6310 Make_Subprogram_Body (Loc,
6311 Specification => Func_Spec,
6312 Declarations => No_List,
6313 Handled_Statement_Sequence =>
6314 Make_Handled_Sequence_Of_Statements (Loc,
6315 Statements => Statements)));
6316 Set_TSS (RAS_Type, Fnam);
6317 end Add_RAS_From_Any;
6319 --------------------
6320 -- Add_RAS_To_Any --
6321 --------------------
6323 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6324 Loc : constant Source_Ptr := Sloc (RAS_Type);
6326 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6327 Make_TSS_Name (RAS_Type, TSS_To_Any));
6330 Statements : List_Id;
6332 Func_Spec : Node_Id;
6334 Any : constant Entity_Id :=
6335 Make_Defining_Identifier (Loc,
6336 Chars => New_Internal_Name ('A'));
6337 RAS_Parameter : constant Entity_Id :=
6338 Make_Defining_Identifier (Loc,
6339 Chars => New_Internal_Name ('R'));
6340 RACW_Parameter : constant Node_Id :=
6341 Make_Selected_Component (Loc,
6342 Prefix => RAS_Parameter,
6343 Selector_Name => Name_Ras);
6346 -- Object declarations
6348 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6350 Make_Object_Declaration (Loc,
6351 Defining_Identifier =>
6353 Object_Definition =>
6354 New_Occurrence_Of (RTE (RE_Any), Loc),
6356 PolyORB_Support.Helpers.Build_To_Any_Call
6357 (RACW_Parameter, No_List)));
6359 Statements := New_List (
6360 Make_Procedure_Call_Statement (Loc,
6362 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6363 Parameter_Associations => New_List (
6364 New_Occurrence_Of (Any, Loc),
6365 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6367 Make_Return_Statement (Loc,
6369 New_Occurrence_Of (Any, Loc)));
6372 Make_Function_Specification (Loc,
6373 Defining_Unit_Name =>
6375 Parameter_Specifications => New_List (
6376 Make_Parameter_Specification (Loc,
6377 Defining_Identifier =>
6380 New_Occurrence_Of (RAS_Type, Loc))),
6381 Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), Loc));
6384 Make_Subprogram_Body (Loc,
6385 Specification => Func_Spec,
6386 Declarations => Decls,
6387 Handled_Statement_Sequence =>
6388 Make_Handled_Sequence_Of_Statements (Loc,
6389 Statements => Statements)));
6390 Set_TSS (RAS_Type, Fnam);
6393 ----------------------
6394 -- Add_RAS_TypeCode --
6395 ----------------------
6397 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6398 Loc : constant Source_Ptr := Sloc (RAS_Type);
6400 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6401 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6403 Func_Spec : Node_Id;
6405 Decls : constant List_Id := New_List;
6406 Name_String, Repo_Id_String : String_Id;
6408 RAS_Parameter : constant Entity_Id :=
6409 Make_Defining_Identifier (Loc, Name_R);
6412 -- The spec for this subprogram has a dummy 'access RAS'
6413 -- argument, which serves only for overloading purposes.
6416 Make_Function_Specification (Loc,
6417 Defining_Unit_Name =>
6419 Parameter_Specifications => New_List (
6420 Make_Parameter_Specification (Loc,
6421 Defining_Identifier =>
6424 Make_Access_Definition (Loc,
6425 Subtype_Mark => New_Occurrence_Of (RAS_Type, Loc)))),
6426 Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6428 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6429 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6432 Make_Subprogram_Body (Loc,
6433 Specification => Func_Spec,
6434 Declarations => Decls,
6435 Handled_Statement_Sequence =>
6436 Make_Handled_Sequence_Of_Statements (Loc,
6437 Statements => New_List (
6438 Make_Return_Statement (Loc,
6440 Make_Function_Call (Loc,
6442 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6443 Parameter_Associations => New_List (
6444 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6445 Make_Aggregate (Loc,
6448 Make_Function_Call (Loc,
6449 Name => New_Occurrence_Of (
6450 RTE (RE_TA_String), Loc),
6451 Parameter_Associations => New_List (
6452 Make_String_Literal (Loc, Name_String))),
6453 Make_Function_Call (Loc,
6454 Name => New_Occurrence_Of (
6455 RTE (RE_TA_String), Loc),
6456 Parameter_Associations => New_List (
6457 Make_String_Literal (Loc,
6458 Repo_Id_String))))))))))));
6459 Set_TSS (RAS_Type, Fnam);
6460 end Add_RAS_TypeCode;
6462 -----------------------------------------
6463 -- Add_Receiving_Stubs_To_Declarations --
6464 -----------------------------------------
6466 procedure Add_Receiving_Stubs_To_Declarations
6467 (Pkg_Spec : Node_Id;
6470 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6472 Pkg_RPC_Receiver : constant Entity_Id :=
6473 Make_Defining_Identifier (Loc,
6474 New_Internal_Name ('H'));
6475 Pkg_RPC_Receiver_Object : Node_Id;
6477 Pkg_RPC_Receiver_Body : Node_Id;
6478 Pkg_RPC_Receiver_Decls : List_Id;
6479 Pkg_RPC_Receiver_Statements : List_Id;
6480 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6481 -- A Pkg_RPC_Receiver is built to decode the request
6484 -- Request object received from neutral layer
6486 Subp_Id : Entity_Id;
6487 -- Subprogram identifier as received from the neutral
6488 -- distribution core.
6490 Subp_Index : Entity_Id;
6491 -- Internal index as determined by matching either the
6492 -- method name from the request structure, or the local
6493 -- subprogram address (in case of a RAS).
6495 Is_Local : constant Entity_Id :=
6496 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
6497 Local_Address : constant Entity_Id :=
6498 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
6499 -- Address of a local subprogram designated by a
6500 -- reference corresponding to a RAS.
6502 Dispatch_On_Address : constant List_Id := New_List;
6503 Dispatch_On_Name : constant List_Id := New_List;
6505 Current_Declaration : Node_Id;
6506 Current_Stubs : Node_Id;
6507 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6509 Subp_Info_Array : constant Entity_Id :=
6510 Make_Defining_Identifier (Loc,
6511 Chars => New_Internal_Name ('I'));
6513 Subp_Info_List : constant List_Id := New_List;
6515 Register_Pkg_Actuals : constant List_Id := New_List;
6517 All_Calls_Remote_E : Entity_Id;
6519 procedure Append_Stubs_To
6520 (RPC_Receiver_Cases : List_Id;
6521 Declaration : Node_Id;
6524 Subp_Dist_Name : Entity_Id;
6525 Subp_Proxy_Addr : Entity_Id);
6526 -- Add one case to the specified RPC receiver case list associating
6527 -- Subprogram_Number with the subprogram declared by Declaration, for
6528 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6529 -- subprogram index. Subp_Dist_Name is the string used to call the
6530 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6531 -- object, used in the context of calls through remote
6532 -- access-to-subprogram types.
6534 ---------------------
6535 -- Append_Stubs_To --
6536 ---------------------
6538 procedure Append_Stubs_To
6539 (RPC_Receiver_Cases : List_Id;
6540 Declaration : Node_Id;
6543 Subp_Dist_Name : Entity_Id;
6544 Subp_Proxy_Addr : Entity_Id)
6546 Case_Stmts : List_Id;
6548 Case_Stmts := New_List (
6549 Make_Procedure_Call_Statement (Loc,
6552 Defining_Entity (Stubs), Loc),
6553 Parameter_Associations =>
6554 New_List (New_Occurrence_Of (Request, Loc))));
6555 if Nkind (Specification (Declaration))
6556 = N_Function_Specification
6558 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6560 Append_To (Case_Stmts, Make_Return_Statement (Loc));
6563 Append_To (RPC_Receiver_Cases,
6564 Make_Case_Statement_Alternative (Loc,
6566 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6570 Append_To (Dispatch_On_Name,
6571 Make_Elsif_Part (Loc,
6573 Make_Function_Call (Loc,
6575 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6576 Parameter_Associations => New_List (
6577 New_Occurrence_Of (Subp_Id, Loc),
6578 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6579 Then_Statements => New_List (
6580 Make_Assignment_Statement (Loc,
6581 New_Occurrence_Of (Subp_Index, Loc),
6582 Make_Integer_Literal (Loc,
6585 Append_To (Dispatch_On_Address,
6586 Make_Elsif_Part (Loc,
6590 New_Occurrence_Of (Local_Address, Loc),
6592 New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6593 Then_Statements => New_List (
6594 Make_Assignment_Statement (Loc,
6595 New_Occurrence_Of (Subp_Index, Loc),
6596 Make_Integer_Literal (Loc,
6598 end Append_Stubs_To;
6600 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6603 -- Building receiving stubs consist in several operations:
6605 -- - a package RPC receiver must be built. This subprogram
6606 -- will get a Subprogram_Id from the incoming stream
6607 -- and will dispatch the call to the right subprogram
6609 -- - a receiving stub for any subprogram visible in the package
6610 -- spec. This stub will read all the parameters from the stream,
6611 -- and put the result as well as the exception occurrence in the
6614 -- - a dummy package with an empty spec and a body made of an
6615 -- elaboration part, whose job is to register the receiving
6616 -- part of this RCI package on the name server. This is done
6617 -- by calling System.Partition_Interface.Register_Receiving_Stub
6619 Build_RPC_Receiver_Body (
6620 RPC_Receiver => Pkg_RPC_Receiver,
6623 Subp_Index => Subp_Index,
6624 Stmts => Pkg_RPC_Receiver_Statements,
6625 Decl => Pkg_RPC_Receiver_Body);
6626 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6628 -- Extract local address information from the target reference:
6629 -- if non-null, that means that this is a reference that denotes
6630 -- one particular operation, and hence that the operation name
6631 -- must not be taken into account for dispatching.
6633 Append_To (Pkg_RPC_Receiver_Decls,
6634 Make_Object_Declaration (Loc,
6635 Defining_Identifier =>
6637 Object_Definition =>
6638 New_Occurrence_Of (Standard_Boolean, Loc)));
6639 Append_To (Pkg_RPC_Receiver_Decls,
6640 Make_Object_Declaration (Loc,
6641 Defining_Identifier =>
6643 Object_Definition =>
6644 New_Occurrence_Of (RTE (RE_Address), Loc)));
6645 Append_To (Pkg_RPC_Receiver_Statements,
6646 Make_Procedure_Call_Statement (Loc,
6648 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6649 Parameter_Associations => New_List (
6650 Make_Selected_Component (Loc,
6652 Selector_Name => Name_Target),
6653 New_Occurrence_Of (Is_Local, Loc),
6654 New_Occurrence_Of (Local_Address, Loc))));
6656 -- Determine whether the reference that was used to make
6657 -- the call was the base RCI reference (in which case
6658 -- Local_Address is 0, and the method identifier from the
6659 -- request must be used to determine which subprogram is
6660 -- called) or a reference identifying one particular subprogram
6661 -- (in which case Local_Address is the address of that
6662 -- subprogram, and the method name from the request is
6664 -- In each case, cascaded elsifs are used to determine the
6665 -- proper subprogram index. Using hash tables might be
6668 Append_To (Pkg_RPC_Receiver_Statements,
6669 Make_Implicit_If_Statement (Pkg_Spec,
6672 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6673 Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
6674 Then_Statements => New_List (
6675 Make_Implicit_If_Statement (Pkg_Spec,
6677 New_Occurrence_Of (Standard_False, Loc),
6678 Then_Statements => New_List (
6679 Make_Null_Statement (Loc)),
6681 Dispatch_On_Address)),
6682 Else_Statements => New_List (
6683 Make_Implicit_If_Statement (Pkg_Spec,
6685 New_Occurrence_Of (Standard_False, Loc),
6686 Then_Statements => New_List (
6687 Make_Null_Statement (Loc)),
6689 Dispatch_On_Name))));
6691 -- For each subprogram, the receiving stub will be built and a
6692 -- case statement will be made on the Subprogram_Id to dispatch
6693 -- to the right subprogram.
6695 All_Calls_Remote_E := Boolean_Literals (
6696 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6698 Overload_Counter_Table.Reset;
6699 Reserve_NamingContext_Methods;
6701 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
6702 while Present (Current_Declaration) loop
6703 if Nkind (Current_Declaration) = N_Subprogram_Declaration
6704 and then Comes_From_Source (Current_Declaration)
6707 Loc : constant Source_Ptr :=
6708 Sloc (Current_Declaration);
6709 -- While specifically processing Current_Declaration, use
6710 -- its Sloc as the location of all generated nodes.
6712 Subp_Def : constant Entity_Id :=
6714 (Specification (Current_Declaration));
6716 Subp_Val : String_Id;
6718 Subp_Dist_Name : constant Entity_Id :=
6719 Make_Defining_Identifier (Loc,
6721 Related_Id => Chars (Subp_Def),
6723 Suffix_Index => -1));
6725 Proxy_Object_Addr : Entity_Id;
6728 pragma Assert (Current_Subprogram_Number =
6729 Get_Subprogram_Id (Subp_Def));
6731 -- Build receiving stub
6734 Build_Subprogram_Receiving_Stubs
6735 (Vis_Decl => Current_Declaration,
6737 Nkind (Specification (Current_Declaration)) =
6738 N_Procedure_Specification
6739 and then Is_Asynchronous (Subp_Def));
6741 Append_To (Decls, Current_Stubs);
6742 Analyze (Current_Stubs);
6746 Add_RAS_Proxy_And_Analyze (Decls,
6748 Current_Declaration,
6749 All_Calls_Remote_E =>
6751 Proxy_Object_Addr =>
6754 -- Compute distribution identifier
6756 Assign_Subprogram_Identifier (
6758 Current_Subprogram_Number,
6762 Make_Object_Declaration (Loc,
6763 Defining_Identifier => Subp_Dist_Name,
6764 Constant_Present => True,
6765 Object_Definition => New_Occurrence_Of (
6766 Standard_String, Loc),
6768 Make_String_Literal (Loc, Subp_Val)));
6769 Analyze (Last (Decls));
6771 -- Add subprogram descriptor (RCI_Subp_Info) to the
6772 -- subprograms table for this receiver. The aggregate
6773 -- below must be kept consistent with the declaration
6774 -- of type RCI_Subp_Info in System.Partition_Interface.
6776 Append_To (Subp_Info_List,
6777 Make_Component_Association (Loc,
6778 Choices => New_List (
6779 Make_Integer_Literal (Loc,
6780 Current_Subprogram_Number)),
6782 Make_Aggregate (Loc,
6783 Expressions => New_List (
6784 Make_Attribute_Reference (Loc,
6787 Subp_Dist_Name, Loc),
6788 Attribute_Name => Name_Address),
6789 Make_Attribute_Reference (Loc,
6792 Subp_Dist_Name, Loc),
6793 Attribute_Name => Name_Length),
6794 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
6796 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6797 Declaration => Current_Declaration,
6798 Stubs => Current_Stubs,
6799 Subp_Number => Current_Subprogram_Number,
6800 Subp_Dist_Name => Subp_Dist_Name,
6801 Subp_Proxy_Addr => Proxy_Object_Addr);
6804 Current_Subprogram_Number := Current_Subprogram_Number + 1;
6807 Next (Current_Declaration);
6810 -- If we receive an invalid Subprogram_Id, it is best to do nothing
6811 -- rather than raising an exception since we do not want someone
6812 -- to crash a remote partition by sending invalid subprogram ids.
6813 -- This is consistent with the other parts of the case statement
6814 -- since even in presence of incorrect parameters in the stream,
6815 -- every exception will be caught and (if the subprogram is not an
6816 -- APC) put into the result stream and sent away.
6818 Append_To (Pkg_RPC_Receiver_Cases,
6819 Make_Case_Statement_Alternative (Loc,
6821 New_List (Make_Others_Choice (Loc)),
6823 New_List (Make_Null_Statement (Loc))));
6825 Append_To (Pkg_RPC_Receiver_Statements,
6826 Make_Case_Statement (Loc,
6828 New_Occurrence_Of (Subp_Index, Loc),
6829 Alternatives => Pkg_RPC_Receiver_Cases));
6832 Make_Object_Declaration (Loc,
6833 Defining_Identifier => Subp_Info_Array,
6834 Constant_Present => True,
6835 Aliased_Present => True,
6836 Object_Definition =>
6837 Make_Subtype_Indication (Loc,
6839 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6841 Make_Index_Or_Discriminant_Constraint (Loc,
6844 Low_Bound => Make_Integer_Literal (Loc,
6845 First_RCI_Subprogram_Id),
6847 Make_Integer_Literal (Loc,
6848 First_RCI_Subprogram_Id
6849 + List_Length (Subp_Info_List) - 1))))),
6851 Make_Aggregate (Loc,
6852 Component_Associations => Subp_Info_List)));
6853 Analyze (Last (Decls));
6855 Append_To (Decls, Pkg_RPC_Receiver_Body);
6856 Analyze (Last (Decls));
6858 Pkg_RPC_Receiver_Object :=
6859 Make_Object_Declaration (Loc,
6860 Defining_Identifier =>
6861 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
6862 Aliased_Present => True,
6863 Object_Definition =>
6864 New_Occurrence_Of (RTE (RE_Servant), Loc));
6865 Append_To (Decls, Pkg_RPC_Receiver_Object);
6866 Analyze (Last (Decls));
6868 Get_Library_Unit_Name_String (Pkg_Spec);
6869 Append_To (Register_Pkg_Actuals,
6871 Make_String_Literal (Loc,
6872 Strval => String_From_Name_Buffer));
6874 Append_To (Register_Pkg_Actuals,
6876 Make_Attribute_Reference (Loc,
6879 (Defining_Entity (Pkg_Spec), Loc),
6883 Append_To (Register_Pkg_Actuals,
6885 Make_Attribute_Reference (Loc,
6887 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
6888 Attribute_Name => Name_Access));
6890 Append_To (Register_Pkg_Actuals,
6892 Make_Attribute_Reference (Loc,
6895 Defining_Identifier (
6896 Pkg_RPC_Receiver_Object), Loc),
6900 Append_To (Register_Pkg_Actuals,
6902 Make_Attribute_Reference (Loc,
6904 New_Occurrence_Of (Subp_Info_Array, Loc),
6908 Append_To (Register_Pkg_Actuals,
6910 Make_Attribute_Reference (Loc,
6912 New_Occurrence_Of (Subp_Info_Array, Loc),
6916 Append_To (Register_Pkg_Actuals,
6917 -- Is_All_Calls_Remote
6918 New_Occurrence_Of (All_Calls_Remote_E, Loc));
6921 Make_Procedure_Call_Statement (Loc,
6923 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
6924 Parameter_Associations => Register_Pkg_Actuals));
6925 Analyze (Last (Decls));
6927 end Add_Receiving_Stubs_To_Declarations;
6929 ---------------------------------
6930 -- Build_General_Calling_Stubs --
6931 ---------------------------------
6933 procedure Build_General_Calling_Stubs
6935 Statements : List_Id;
6936 Target_Object : Node_Id;
6937 Subprogram_Id : Node_Id;
6938 Asynchronous : Node_Id := Empty;
6939 Is_Known_Asynchronous : Boolean := False;
6940 Is_Known_Non_Asynchronous : Boolean := False;
6941 Is_Function : Boolean;
6943 Stub_Type : Entity_Id := Empty;
6944 RACW_Type : Entity_Id := Empty;
6947 Loc : constant Source_Ptr := Sloc (Nod);
6949 Arguments : Node_Id;
6950 -- Name of the named values list used to transmit parameters
6951 -- to the remote package
6954 -- The request object constructed by these stubs
6957 -- Name of the result named value (in non-APC cases) which get the
6958 -- result of the remote subprogram.
6960 Result_TC : Node_Id;
6961 -- Typecode expression for the result of the request (void
6962 -- typecode for procedures).
6964 Exception_Return_Parameter : Node_Id;
6965 -- Name of the parameter which will hold the exception sent by the
6966 -- remote subprogram.
6968 Current_Parameter : Node_Id;
6969 -- Current parameter being handled
6971 Ordered_Parameters_List : constant List_Id :=
6972 Build_Ordered_Parameters_List (Spec);
6974 Asynchronous_P : Node_Id;
6975 -- A Boolean expression indicating whether this call is asynchronous
6977 Asynchronous_Statements : List_Id := No_List;
6978 Non_Asynchronous_Statements : List_Id := No_List;
6979 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
6981 Extra_Formal_Statements : constant List_Id := New_List;
6982 -- List of statements for extra formal parameters. It will appear
6983 -- after the regular statements for writing out parameters.
6985 After_Statements : constant List_Id := New_List;
6986 -- Statements to be executed after call returns (to assign
6987 -- in out or out parameter values).
6990 -- The type of the formal parameter being processed
6992 Is_Controlling_Formal : Boolean;
6993 Is_First_Controlling_Formal : Boolean;
6994 First_Controlling_Formal_Seen : Boolean := False;
6995 -- Controlling formal parameters of distributed object
6996 -- primitives require special handling, and the first
6997 -- such parameter needs even more.
7000 -- ??? document general form of stub subprograms for the PolyORB case
7002 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7005 Make_Object_Declaration (Loc,
7006 Defining_Identifier => Request,
7007 Aliased_Present => False,
7008 Object_Definition =>
7009 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
7012 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7015 Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7016 Etype (Subtype_Mark (Spec)), Decls);
7018 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7022 Make_Object_Declaration (Loc,
7023 Defining_Identifier => Result,
7024 Aliased_Present => False,
7025 Object_Definition =>
7026 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7028 Make_Aggregate (Loc,
7029 Component_Associations => New_List (
7030 Make_Component_Association (Loc,
7031 Choices => New_List (
7032 Make_Identifier (Loc, Name_Name)),
7034 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7035 Make_Component_Association (Loc,
7036 Choices => New_List (
7037 Make_Identifier (Loc, Name_Argument)),
7039 Make_Function_Call (Loc,
7041 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7042 Parameter_Associations => New_List (
7044 Make_Component_Association (Loc,
7045 Choices => New_List (
7046 Make_Identifier (Loc, Name_Arg_Modes)),
7048 Make_Integer_Literal (Loc, 0))))));
7050 if not Is_Known_Asynchronous then
7051 Exception_Return_Parameter :=
7052 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7055 Make_Object_Declaration (Loc,
7056 Defining_Identifier => Exception_Return_Parameter,
7057 Object_Definition =>
7058 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7061 Exception_Return_Parameter := Empty;
7064 -- Initialize and fill in arguments list
7067 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7068 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7070 Current_Parameter := First (Ordered_Parameters_List);
7071 while Present (Current_Parameter) loop
7073 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7074 Is_Controlling_Formal := True;
7075 Is_First_Controlling_Formal :=
7076 not First_Controlling_Formal_Seen;
7077 First_Controlling_Formal_Seen := True;
7079 Is_Controlling_Formal := False;
7080 Is_First_Controlling_Formal := False;
7083 if Is_Controlling_Formal then
7085 -- In the case of a controlling formal argument, we send
7091 Etyp := Etype (Parameter_Type (Current_Parameter));
7094 -- The first controlling formal parameter is treated
7095 -- specially: it is used to set the target object of
7098 if not Is_First_Controlling_Formal then
7101 Constrained : constant Boolean :=
7102 Is_Constrained (Etyp)
7103 or else Is_Elementary_Type (Etyp);
7105 Any : constant Entity_Id :=
7106 Make_Defining_Identifier (Loc,
7107 New_Internal_Name ('A'));
7109 Actual_Parameter : Node_Id :=
7111 Defining_Identifier (
7112 Current_Parameter), Loc);
7117 if Is_Controlling_Formal then
7119 -- For a controlling formal parameter (other
7120 -- than the first one), use the corresponding
7121 -- RACW. If the parameter is not an anonymous
7122 -- access parameter, that involves taking
7123 -- its 'Unrestricted_Access.
7125 if Nkind (Parameter_Type (Current_Parameter))
7126 = N_Access_Definition
7128 Actual_Parameter := OK_Convert_To
7129 (Etyp, Actual_Parameter);
7131 Actual_Parameter := OK_Convert_To (Etyp,
7132 Make_Attribute_Reference (Loc,
7136 Name_Unrestricted_Access));
7141 if In_Present (Current_Parameter)
7142 or else not Out_Present (Current_Parameter)
7143 or else not Constrained
7144 or else Is_Controlling_Formal
7146 -- The parameter has an input value, is constrained
7147 -- at runtime by an input value, or is a controlling
7148 -- formal parameter (always passed as a reference)
7149 -- other than the first one.
7151 Expr := PolyORB_Support.Helpers.Build_To_Any_Call (
7152 Actual_Parameter, Decls);
7154 Expr := Make_Function_Call (Loc,
7156 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7157 Parameter_Associations => New_List (
7158 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7163 Make_Object_Declaration (Loc,
7164 Defining_Identifier =>
7166 Aliased_Present => False,
7167 Object_Definition =>
7168 New_Occurrence_Of (RTE (RE_Any), Loc),
7172 Append_To (Statements,
7173 Add_Parameter_To_NVList (Loc,
7174 Parameter => Current_Parameter,
7175 NVList => Arguments,
7176 Constrained => Constrained,
7179 if Out_Present (Current_Parameter)
7180 and then not Is_Controlling_Formal
7182 Append_To (After_Statements,
7183 Make_Assignment_Statement (Loc,
7186 Defining_Identifier (Current_Parameter), Loc),
7188 PolyORB_Support.Helpers.Build_From_Any_Call (
7189 Etype (Parameter_Type (Current_Parameter)),
7190 New_Occurrence_Of (Any, Loc),
7197 -- If the current parameter has a dynamic constrained status,
7198 -- then this status is transmitted as well.
7199 -- This should be done for accessibility as well ???
7201 if Nkind (Parameter_Type (Current_Parameter))
7202 /= N_Access_Definition
7203 and then Need_Extra_Constrained (Current_Parameter)
7205 -- In this block, we do not use the extra formal that has been
7206 -- created because it does not exist at the time of expansion
7207 -- when building calling stubs for remote access to subprogram
7208 -- types. We create an extra variable of this type and push it
7209 -- in the stream after the regular parameters.
7212 Extra_Any_Parameter : constant Entity_Id :=
7213 Make_Defining_Identifier
7214 (Loc, New_Internal_Name ('P'));
7218 Make_Object_Declaration (Loc,
7219 Defining_Identifier =>
7220 Extra_Any_Parameter,
7221 Aliased_Present => False,
7222 Object_Definition =>
7223 New_Occurrence_Of (RTE (RE_Any), Loc),
7225 PolyORB_Support.Helpers.Build_To_Any_Call (
7226 Make_Attribute_Reference (Loc,
7229 Defining_Identifier (Current_Parameter), Loc),
7230 Attribute_Name => Name_Constrained),
7232 Append_To (Extra_Formal_Statements,
7233 Add_Parameter_To_NVList (Loc,
7234 Parameter => Extra_Any_Parameter,
7235 NVList => Arguments,
7236 Constrained => True,
7237 Any => Extra_Any_Parameter));
7241 Next (Current_Parameter);
7244 -- Append the formal statements list to the statements
7246 Append_List_To (Statements, Extra_Formal_Statements);
7248 Append_To (Statements,
7249 Make_Procedure_Call_Statement (Loc,
7251 New_Occurrence_Of (RTE (RE_Request_Create), Loc),
7252 Parameter_Associations => New_List (
7255 New_Occurrence_Of (Arguments, Loc),
7256 New_Occurrence_Of (Result, Loc),
7257 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7259 Append_To (Parameter_Associations (Last (Statements)),
7260 New_Occurrence_Of (Request, Loc));
7263 not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7264 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7265 Asynchronous_P := New_Occurrence_Of (
7266 Boolean_Literals (Is_Known_Asynchronous), Loc);
7268 pragma Assert (Present (Asynchronous));
7269 Asynchronous_P := New_Copy_Tree (Asynchronous);
7270 -- The expression node Asynchronous will be used to build
7271 -- an 'if' statement at the end of Build_General_Calling_Stubs:
7272 -- we need to make a copy here.
7275 Append_To (Parameter_Associations (Last (Statements)),
7276 Make_Indexed_Component (Loc,
7279 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7280 Expressions => New_List (Asynchronous_P)));
7282 Append_To (Statements,
7283 Make_Procedure_Call_Statement (Loc,
7285 New_Occurrence_Of (RTE (RE_Request_Invoke), Loc),
7286 Parameter_Associations => New_List (
7287 New_Occurrence_Of (Request, Loc))));
7289 Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7290 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7292 if not Is_Known_Asynchronous then
7294 -- Reraise an exception occurrence from the completed request.
7295 -- If the exception occurrence is empty, this is a no-op.
7297 Append_To (Non_Asynchronous_Statements,
7298 Make_Procedure_Call_Statement (Loc,
7300 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7301 Parameter_Associations => New_List (
7302 New_Occurrence_Of (Request, Loc))));
7306 -- If this is a function call, then read the value and
7309 Append_To (Non_Asynchronous_Statements,
7310 Make_Tag_Check (Loc,
7311 Make_Return_Statement (Loc,
7312 PolyORB_Support.Helpers.Build_From_Any_Call (
7313 Etype (Subtype_Mark (Spec)),
7314 Make_Selected_Component (Loc,
7316 Selector_Name => Name_Argument),
7321 Append_List_To (Non_Asynchronous_Statements,
7324 if Is_Known_Asynchronous then
7325 Append_List_To (Statements, Asynchronous_Statements);
7327 elsif Is_Known_Non_Asynchronous then
7328 Append_List_To (Statements, Non_Asynchronous_Statements);
7331 pragma Assert (Present (Asynchronous));
7332 Append_To (Statements,
7333 Make_Implicit_If_Statement (Nod,
7334 Condition => Asynchronous,
7335 Then_Statements => Asynchronous_Statements,
7336 Else_Statements => Non_Asynchronous_Statements));
7338 end Build_General_Calling_Stubs;
7340 -----------------------
7341 -- Build_Stub_Target --
7342 -----------------------
7344 function Build_Stub_Target
7347 RCI_Locator : Entity_Id;
7348 Controlling_Parameter : Entity_Id) return RPC_Target
7350 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7351 Target_Reference : constant Entity_Id :=
7352 Make_Defining_Identifier (Loc,
7353 New_Internal_Name ('T'));
7355 if Present (Controlling_Parameter) then
7357 Make_Object_Declaration (Loc,
7358 Defining_Identifier => Target_Reference,
7359 Object_Definition =>
7360 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7362 Make_Function_Call (Loc,
7364 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7365 Parameter_Associations => New_List (
7366 Make_Selected_Component (Loc,
7367 Prefix => Controlling_Parameter,
7368 Selector_Name => Name_Target)))));
7369 -- Controlling_Parameter has the same components
7370 -- as System.Partition_Interface.RACW_Stub_Type.
7372 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7375 Target_Info.Object :=
7376 Make_Selected_Component (Loc,
7378 Make_Identifier (Loc, Chars (RCI_Locator)),
7380 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7383 end Build_Stub_Target;
7385 ---------------------
7386 -- Build_Stub_Type --
7387 ---------------------
7389 procedure Build_Stub_Type
7390 (RACW_Type : Entity_Id;
7391 Stub_Type : Entity_Id;
7392 Stub_Type_Decl : out Node_Id;
7393 RPC_Receiver_Decl : out Node_Id)
7395 Loc : constant Source_Ptr := Sloc (Stub_Type);
7396 pragma Warnings (Off);
7397 pragma Unreferenced (RACW_Type);
7398 pragma Warnings (On);
7402 Make_Full_Type_Declaration (Loc,
7403 Defining_Identifier => Stub_Type,
7405 Make_Record_Definition (Loc,
7406 Tagged_Present => True,
7407 Limited_Present => True,
7409 Make_Component_List (Loc,
7410 Component_Items => New_List (
7412 Make_Component_Declaration (Loc,
7413 Defining_Identifier =>
7414 Make_Defining_Identifier (Loc, Name_Target),
7415 Component_Definition =>
7416 Make_Component_Definition (Loc,
7419 Subtype_Indication =>
7420 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7422 Make_Component_Declaration (Loc,
7423 Defining_Identifier =>
7424 Make_Defining_Identifier (Loc, Name_Asynchronous),
7425 Component_Definition =>
7426 Make_Component_Definition (Loc,
7427 Aliased_Present => False,
7428 Subtype_Indication =>
7430 Standard_Boolean, Loc)))))));
7432 RPC_Receiver_Decl :=
7433 Make_Object_Declaration (Loc,
7434 Defining_Identifier => Make_Defining_Identifier (Loc,
7435 New_Internal_Name ('R')),
7436 Aliased_Present => True,
7437 Object_Definition =>
7438 New_Occurrence_Of (RTE (RE_Servant), Loc));
7439 end Build_Stub_Type;
7441 -----------------------------
7442 -- Build_RPC_Receiver_Body --
7443 -----------------------------
7445 procedure Build_RPC_Receiver_Body
7446 (RPC_Receiver : Entity_Id;
7447 Request : out Entity_Id;
7448 Subp_Id : out Entity_Id;
7449 Subp_Index : out Entity_Id;
7450 Stmts : out List_Id;
7453 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7455 RPC_Receiver_Spec : Node_Id;
7456 RPC_Receiver_Decls : List_Id;
7459 Request := Make_Defining_Identifier (Loc, Name_R);
7461 RPC_Receiver_Spec :=
7462 Build_RPC_Receiver_Specification (
7463 RPC_Receiver => RPC_Receiver,
7464 Request_Parameter => Request);
7466 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7467 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7469 RPC_Receiver_Decls := New_List (
7470 Make_Object_Renaming_Declaration (Loc,
7471 Defining_Identifier => Subp_Id,
7472 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7474 Make_Explicit_Dereference (Loc,
7476 Make_Selected_Component (Loc,
7478 Selector_Name => Name_Operation))),
7480 Make_Object_Declaration (Loc,
7481 Defining_Identifier => Subp_Index,
7482 Object_Definition =>
7483 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7485 Make_Attribute_Reference (Loc,
7487 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7488 Attribute_Name => Name_Last)));
7493 Make_Subprogram_Body (Loc,
7494 Specification => RPC_Receiver_Spec,
7495 Declarations => RPC_Receiver_Decls,
7496 Handled_Statement_Sequence =>
7497 Make_Handled_Sequence_Of_Statements (Loc,
7498 Statements => Stmts));
7499 end Build_RPC_Receiver_Body;
7501 --------------------------------------
7502 -- Build_Subprogram_Receiving_Stubs --
7503 --------------------------------------
7505 function Build_Subprogram_Receiving_Stubs
7506 (Vis_Decl : Node_Id;
7507 Asynchronous : Boolean;
7508 Dynamically_Asynchronous : Boolean := False;
7509 Stub_Type : Entity_Id := Empty;
7510 RACW_Type : Entity_Id := Empty;
7511 Parent_Primitive : Entity_Id := Empty) return Node_Id
7513 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7515 Request_Parameter : Node_Id;
7518 Outer_Decls : constant List_Id := New_List;
7519 -- At the outermost level, an NVList and Any's are
7520 -- declared for all parameters. The Dynamic_Async
7521 -- flag also needs to be declared there to be visible
7522 -- from the exception handling code.
7524 Outer_Statements : constant List_Id := New_List;
7525 -- Statements that occur prior to the declaration of the actual
7526 -- parameter variables.
7528 Decls : constant List_Id := New_List;
7529 -- All the parameters will get declared before calling the real
7530 -- subprograms. Also the out parameters will be declared.
7531 -- At this level, parameters may be unconstrained.
7533 Statements : constant List_Id := New_List;
7535 Extra_Formal_Statements : constant List_Id := New_List;
7536 -- Statements concerning extra formal parameters
7538 After_Statements : constant List_Id := New_List;
7539 -- Statements to be executed after the subprogram call
7541 Inner_Decls : List_Id := No_List;
7542 -- In case of a function, the inner declarations are needed since
7543 -- the result may be unconstrained.
7545 Excep_Handlers : List_Id := No_List;
7547 Parameter_List : constant List_Id := New_List;
7548 -- List of parameters to be passed to the subprogram
7550 First_Controlling_Formal_Seen : Boolean := False;
7552 Current_Parameter : Node_Id;
7554 Ordered_Parameters_List : constant List_Id :=
7555 Build_Ordered_Parameters_List
7556 (Specification (Vis_Decl));
7558 Arguments : Node_Id;
7559 -- Name of the named values list used to retrieve parameters
7561 Subp_Spec : Node_Id;
7562 -- Subprogram specification
7564 Called_Subprogram : Node_Id;
7565 -- The subprogram to call
7568 if Present (RACW_Type) then
7569 Called_Subprogram :=
7570 New_Occurrence_Of (Parent_Primitive, Loc);
7572 Called_Subprogram :=
7574 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7577 Request_Parameter :=
7578 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7581 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7582 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7584 -- Loop through every parameter and get its value from the stream. If
7585 -- the parameter is unconstrained, then the parameter is read using
7586 -- 'Input at the point of declaration.
7588 Current_Parameter := First (Ordered_Parameters_List);
7589 while Present (Current_Parameter) loop
7592 Constrained : Boolean;
7593 Any : Entity_Id := Empty;
7594 Object : constant Entity_Id :=
7595 Make_Defining_Identifier (Loc,
7596 New_Internal_Name ('P'));
7597 Expr : Node_Id := Empty;
7599 Is_Controlling_Formal : constant Boolean
7600 := Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
7602 Is_First_Controlling_Formal : Boolean := False;
7604 Set_Ekind (Object, E_Variable);
7606 if Is_Controlling_Formal then
7608 -- Controlling formals in distributed object primitive
7609 -- operations are handled specially:
7610 -- - the first controlling formal is used as the
7611 -- target of the call;
7612 -- - the remaining controlling formals are transmitted
7616 Is_First_Controlling_Formal :=
7617 not First_Controlling_Formal_Seen;
7618 First_Controlling_Formal_Seen := True;
7620 Etyp := Etype (Parameter_Type (Current_Parameter));
7624 Is_Constrained (Etyp)
7625 or else Is_Elementary_Type (Etyp);
7627 if not Is_First_Controlling_Formal then
7628 Any := Make_Defining_Identifier (Loc,
7629 New_Internal_Name ('A'));
7630 Append_To (Outer_Decls,
7631 Make_Object_Declaration (Loc,
7632 Defining_Identifier =>
7634 Object_Definition =>
7635 New_Occurrence_Of (RTE (RE_Any), Loc),
7637 Make_Function_Call (Loc,
7639 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7640 Parameter_Associations => New_List (
7641 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7642 Etyp, Outer_Decls)))));
7644 Append_To (Outer_Statements,
7645 Add_Parameter_To_NVList (Loc,
7646 Parameter => Current_Parameter,
7647 NVList => Arguments,
7648 Constrained => Constrained,
7652 if Is_First_Controlling_Formal then
7654 Addr : constant Entity_Id :=
7655 Make_Defining_Identifier (Loc,
7656 New_Internal_Name ('A'));
7657 Is_Local : constant Entity_Id :=
7658 Make_Defining_Identifier (Loc,
7659 New_Internal_Name ('L'));
7662 -- Special case: obtain the first controlling
7663 -- formal from the target of the remote call,
7664 -- instead of the argument list.
7666 Append_To (Outer_Decls,
7667 Make_Object_Declaration (Loc,
7668 Defining_Identifier =>
7670 Object_Definition =>
7671 New_Occurrence_Of (RTE (RE_Address), Loc)));
7672 Append_To (Outer_Decls,
7673 Make_Object_Declaration (Loc,
7674 Defining_Identifier =>
7676 Object_Definition =>
7677 New_Occurrence_Of (Standard_Boolean, Loc)));
7678 Append_To (Outer_Statements,
7679 Make_Procedure_Call_Statement (Loc,
7682 RTE (RE_Get_Local_Address), Loc),
7683 Parameter_Associations => New_List (
7684 Make_Selected_Component (Loc,
7687 Request_Parameter, Loc),
7689 Make_Identifier (Loc, Name_Target)),
7690 New_Occurrence_Of (Is_Local, Loc),
7691 New_Occurrence_Of (Addr, Loc))));
7693 Expr := Unchecked_Convert_To (RACW_Type,
7694 New_Occurrence_Of (Addr, Loc));
7697 elsif In_Present (Current_Parameter)
7698 or else not Out_Present (Current_Parameter)
7699 or else not Constrained
7701 -- If an input parameter is contrained, then its reading is
7702 -- deferred until the beginning of the subprogram body. If
7703 -- it is unconstrained, then an expression is built for
7704 -- the object declaration and the variable is set using
7705 -- 'Input instead of 'Read.
7707 Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
7708 Etyp, New_Occurrence_Of (Any, Loc), Decls);
7712 Append_To (Statements,
7713 Make_Assignment_Statement (Loc,
7715 New_Occurrence_Of (Object, Loc),
7721 -- Expr will be used to initialize (and constrain)
7722 -- the parameter when it is declared.
7727 -- If we do not have to output the current parameter, then
7728 -- it can well be flagged as constant. This may allow further
7729 -- optimizations done by the back end.
7732 Make_Object_Declaration (Loc,
7733 Defining_Identifier => Object,
7734 Constant_Present => not Constrained
7735 and then not Out_Present (Current_Parameter),
7736 Object_Definition =>
7737 New_Occurrence_Of (Etyp, Loc),
7738 Expression => Expr));
7739 Set_Etype (Object, Etyp);
7741 -- An out parameter may be written back using a 'Write
7742 -- attribute instead of a 'Output because it has been
7743 -- constrained by the parameter given to the caller. Note that
7744 -- out controlling arguments in the case of a RACW are not put
7745 -- back in the stream because the pointer on them has not
7748 if Out_Present (Current_Parameter)
7749 and then not Is_Controlling_Formal
7751 Append_To (After_Statements,
7752 Make_Procedure_Call_Statement (Loc,
7754 New_Occurrence_Of (RTE (RE_Copy_Any_Value), Loc),
7755 Parameter_Associations => New_List (
7756 New_Occurrence_Of (Any, Loc),
7757 PolyORB_Support.Helpers.Build_To_Any_Call (
7758 New_Occurrence_Of (Object, Loc),
7762 -- For RACW controlling formals, the Etyp of Object is always
7763 -- an RACW, even if the parameter is not of an anonymous access
7764 -- type. In such case, we need to dereference it at call time.
7766 if Is_Controlling_Formal then
7767 if Nkind (Parameter_Type (Current_Parameter)) /=
7770 Append_To (Parameter_List,
7771 Make_Parameter_Association (Loc,
7774 Defining_Identifier (Current_Parameter), Loc),
7775 Explicit_Actual_Parameter =>
7776 Make_Explicit_Dereference (Loc,
7777 Unchecked_Convert_To (RACW_Type,
7778 OK_Convert_To (RTE (RE_Address),
7779 New_Occurrence_Of (Object, Loc))))));
7782 Append_To (Parameter_List,
7783 Make_Parameter_Association (Loc,
7786 Defining_Identifier (Current_Parameter), Loc),
7787 Explicit_Actual_Parameter =>
7788 Unchecked_Convert_To (RACW_Type,
7789 OK_Convert_To (RTE (RE_Address),
7790 New_Occurrence_Of (Object, Loc)))));
7794 Append_To (Parameter_List,
7795 Make_Parameter_Association (Loc,
7798 Defining_Identifier (Current_Parameter), Loc),
7799 Explicit_Actual_Parameter =>
7800 New_Occurrence_Of (Object, Loc)));
7803 -- If the current parameter needs an extra formal, then read it
7804 -- from the stream and set the corresponding semantic field in
7805 -- the variable. If the kind of the parameter identifier is
7806 -- E_Void, then this is a compiler generated parameter that
7807 -- doesn't need an extra constrained status.
7809 -- The case of Extra_Accessibility should also be handled ???
7811 if Nkind (Parameter_Type (Current_Parameter)) /=
7814 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7816 Present (Extra_Constrained
7817 (Defining_Identifier (Current_Parameter)))
7820 Extra_Parameter : constant Entity_Id :=
7822 (Defining_Identifier
7823 (Current_Parameter));
7824 Extra_Any : constant Entity_Id :=
7825 Make_Defining_Identifier
7826 (Loc, New_Internal_Name ('A'));
7827 Formal_Entity : constant Entity_Id :=
7828 Make_Defining_Identifier
7829 (Loc, Chars (Extra_Parameter));
7831 Formal_Type : constant Entity_Id :=
7832 Etype (Extra_Parameter);
7834 Append_To (Outer_Decls,
7835 Make_Object_Declaration (Loc,
7836 Defining_Identifier =>
7838 Object_Definition =>
7839 New_Occurrence_Of (RTE (RE_Any), Loc)));
7841 Append_To (Outer_Statements,
7842 Add_Parameter_To_NVList (Loc,
7843 Parameter => Extra_Parameter,
7844 NVList => Arguments,
7845 Constrained => True,
7849 Make_Object_Declaration (Loc,
7850 Defining_Identifier => Formal_Entity,
7851 Object_Definition =>
7852 New_Occurrence_Of (Formal_Type, Loc)));
7854 Append_To (Extra_Formal_Statements,
7855 Make_Assignment_Statement (Loc,
7857 New_Occurrence_Of (Extra_Parameter, Loc),
7859 PolyORB_Support.Helpers.Build_From_Any_Call (
7860 Etype (Extra_Parameter),
7861 New_Occurrence_Of (Extra_Any, Loc),
7863 Set_Extra_Constrained (Object, Formal_Entity);
7869 Next (Current_Parameter);
7872 Append_To (Outer_Statements,
7873 Make_Procedure_Call_Statement (Loc,
7875 New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
7876 Parameter_Associations => New_List (
7877 New_Occurrence_Of (Request_Parameter, Loc),
7878 New_Occurrence_Of (Arguments, Loc))));
7880 Append_List_To (Statements, Extra_Formal_Statements);
7882 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
7884 -- The remote subprogram is a function. We build an inner block to
7885 -- be able to hold a potentially unconstrained result in a
7889 Etyp : constant Entity_Id :=
7890 Etype (Subtype_Mark (Specification (Vis_Decl)));
7891 Result : constant Node_Id :=
7892 Make_Defining_Identifier (Loc,
7893 New_Internal_Name ('R'));
7895 Inner_Decls := New_List (
7896 Make_Object_Declaration (Loc,
7897 Defining_Identifier => Result,
7898 Constant_Present => True,
7899 Object_Definition => New_Occurrence_Of (Etyp, Loc),
7901 Make_Function_Call (Loc,
7902 Name => Called_Subprogram,
7903 Parameter_Associations => Parameter_List)));
7905 Set_Etype (Result, Etyp);
7906 Append_To (After_Statements,
7907 Make_Procedure_Call_Statement (Loc,
7909 New_Occurrence_Of (RTE (RE_Set_Result), Loc),
7910 Parameter_Associations => New_List (
7911 New_Occurrence_Of (Request_Parameter, Loc),
7912 PolyORB_Support.Helpers.Build_To_Any_Call (
7913 New_Occurrence_Of (Result, Loc),
7915 -- A DSA function does not have out or inout arguments
7918 Append_To (Statements,
7919 Make_Block_Statement (Loc,
7920 Declarations => Inner_Decls,
7921 Handled_Statement_Sequence =>
7922 Make_Handled_Sequence_Of_Statements (Loc,
7923 Statements => After_Statements)));
7926 -- The remote subprogram is a procedure. We do not need any inner
7927 -- block in this case. No specific processing is required here for
7928 -- the dynamically asynchronous case: the indication of whether
7929 -- call is asynchronous or not is managed by the Sync_Scope
7930 -- attibute of the request, and is handled entirely in the
7933 Append_To (After_Statements,
7934 Make_Procedure_Call_Statement (Loc,
7936 New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
7937 Parameter_Associations => New_List (
7938 New_Occurrence_Of (Request_Parameter, Loc))));
7940 Append_To (Statements,
7941 Make_Procedure_Call_Statement (Loc,
7942 Name => Called_Subprogram,
7943 Parameter_Associations => Parameter_List));
7945 Append_List_To (Statements, After_Statements);
7949 Make_Procedure_Specification (Loc,
7950 Defining_Unit_Name =>
7951 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
7953 Parameter_Specifications => New_List (
7954 Make_Parameter_Specification (Loc,
7955 Defining_Identifier => Request_Parameter,
7957 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
7959 -- An exception raised during the execution of an incoming
7960 -- remote subprogram call and that needs to be sent back
7961 -- to the caller is propagated by the receiving stubs, and
7962 -- will be handled by the caller (the distribution runtime).
7964 if Asynchronous and then not Dynamically_Asynchronous then
7966 -- For an asynchronous procedure, add a null exception handler
7968 Excep_Handlers := New_List (
7969 Make_Exception_Handler (Loc,
7970 Exception_Choices => New_List (Make_Others_Choice (Loc)),
7971 Statements => New_List (Make_Null_Statement (Loc))));
7975 -- In the other cases, if an exception is raised, then the
7976 -- exception occurrence is propagated.
7981 Append_To (Outer_Statements,
7982 Make_Block_Statement (Loc,
7985 Handled_Statement_Sequence =>
7986 Make_Handled_Sequence_Of_Statements (Loc,
7987 Statements => Statements)));
7990 Make_Subprogram_Body (Loc,
7991 Specification => Subp_Spec,
7992 Declarations => Outer_Decls,
7993 Handled_Statement_Sequence =>
7994 Make_Handled_Sequence_Of_Statements (Loc,
7995 Statements => Outer_Statements,
7996 Exception_Handlers => Excep_Handlers));
7997 end Build_Subprogram_Receiving_Stubs;
8002 package body Helpers is
8004 -----------------------
8005 -- Local Subprograms --
8006 -----------------------
8008 function Find_Numeric_Representation
8009 (Typ : Entity_Id) return Entity_Id;
8010 -- Given a numeric type Typ, return the smallest integer or floarting
8011 -- point type from Standard, or the smallest unsigned (modular) type
8012 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8014 function Make_Stream_Procedure_Function_Name
8017 Nam : Name_Id) return Entity_Id;
8018 -- Return the name to be assigned for stream subprogram Nam of Typ.
8019 -- (copied from exp_strm.adb, should be shared???)
8021 ------------------------------------------------------------
8022 -- Common subprograms for building various tree fragments --
8023 ------------------------------------------------------------
8025 function Build_Get_Aggregate_Element
8029 Idx : Node_Id) return Node_Id;
8030 -- Build a call to Get_Aggregate_Element on Any
8031 -- for typecode TC, returning the Idx'th element.
8034 Subprogram : Entity_Id;
8035 -- Reference location for constructed nodes
8038 -- For 'Range and Etype
8041 -- For the construction of the innermost element expression
8043 with procedure Add_Process_Element
8046 Counter : Entity_Id;
8049 procedure Append_Array_Traversal
8052 Counter : Entity_Id := Empty;
8054 -- Build nested loop statements that iterate over the elements of an
8055 -- array Arry. The statement(s) built by Add_Process_Element are
8056 -- executed for each element; Indices is the list of indices to be
8057 -- used in the construction of the indexed component that denotes the
8058 -- current element. Subprogram is the entity for the subprogram for
8059 -- which this iterator is generated. The generated statements are
8060 -- appended to Stmts.
8064 -- The record entity being dealt with
8066 with procedure Add_Process_Element
8068 Container : Node_Or_Entity_Id;
8069 Counter : in out Int;
8072 -- Rec is the instance of the record type, or Empty.
8073 -- Field is either the N_Defining_Identifier for a component,
8074 -- or an N_Variant_Part.
8076 procedure Append_Record_Traversal
8079 Container : Node_Or_Entity_Id;
8080 Counter : in out Int);
8081 -- Process component list Clist. Individual fields are passed
8082 -- to Field_Processing. Each variant part is also processed.
8083 -- Container is the outer Any (for From_Any/To_Any),
8084 -- the outer typecode (for TC) to which the operation applies.
8086 -----------------------------
8087 -- Append_Record_Traversal --
8088 -----------------------------
8090 procedure Append_Record_Traversal
8093 Container : Node_Or_Entity_Id;
8094 Counter : in out Int)
8096 CI : constant List_Id := Component_Items (Clist);
8097 VP : constant Node_Id := Variant_Part (Clist);
8099 Item : Node_Id := First (CI);
8103 while Present (Item) loop
8104 Def := Defining_Identifier (Item);
8105 if not Is_Internal_Name (Chars (Def)) then
8107 (Stmts, Container, Counter, Rec, Def);
8112 if Present (VP) then
8113 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8115 end Append_Record_Traversal;
8117 -------------------------
8118 -- Build_From_Any_Call --
8119 -------------------------
8121 function Build_From_Any_Call
8124 Decls : List_Id) return Node_Id
8126 Loc : constant Source_Ptr := Sloc (N);
8128 U_Type : Entity_Id := Underlying_Type (Typ);
8130 Fnam : Entity_Id := Empty;
8131 Lib_RE : RE_Id := RE_Null;
8135 -- First simple case where the From_Any function is present
8136 -- in the type's TSS.
8138 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8140 if Sloc (U_Type) <= Standard_Location then
8141 U_Type := Base_Type (U_Type);
8144 -- Check first for Boolean and Character. These are enumeration
8145 -- types, but we treat them specially, since they may require
8146 -- special handling in the transfer protocol. However, this
8147 -- special handling only applies if they have standard
8148 -- representation, otherwise they are treated like any other
8149 -- enumeration type.
8151 if Present (Fnam) then
8154 elsif U_Type = Standard_Boolean then
8157 elsif U_Type = Standard_Character then
8160 elsif U_Type = Standard_Wide_Character then
8163 elsif U_Type = Standard_Wide_Wide_Character then
8164 Lib_RE := RE_FA_WWC;
8166 -- Floating point types
8168 elsif U_Type = Standard_Short_Float then
8171 elsif U_Type = Standard_Float then
8174 elsif U_Type = Standard_Long_Float then
8177 elsif U_Type = Standard_Long_Long_Float then
8178 Lib_RE := RE_FA_LLF;
8182 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8183 Lib_RE := RE_FA_SSI;
8185 elsif U_Type = Etype (Standard_Short_Integer) then
8188 elsif U_Type = Etype (Standard_Integer) then
8191 elsif U_Type = Etype (Standard_Long_Integer) then
8194 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8195 Lib_RE := RE_FA_LLI;
8197 -- Unsigned integer types
8199 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8200 Lib_RE := RE_FA_SSU;
8202 elsif U_Type = RTE (RE_Short_Unsigned) then
8205 elsif U_Type = RTE (RE_Unsigned) then
8208 elsif U_Type = RTE (RE_Long_Unsigned) then
8211 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8212 Lib_RE := RE_FA_LLU;
8214 elsif U_Type = Standard_String then
8215 Lib_RE := RE_FA_String;
8217 -- Other (non-primitive) types
8223 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8224 Append_To (Decls, Decl);
8228 -- Call the function
8230 if Lib_RE /= RE_Null then
8231 pragma Assert (No (Fnam));
8232 Fnam := RTE (Lib_RE);
8236 Make_Function_Call (Loc,
8237 Name => New_Occurrence_Of (Fnam, Loc),
8238 Parameter_Associations => New_List (N));
8239 end Build_From_Any_Call;
8241 -----------------------------
8242 -- Build_From_Any_Function --
8243 -----------------------------
8245 procedure Build_From_Any_Function
8249 Fnam : out Entity_Id)
8252 Decls : constant List_Id := New_List;
8253 Stms : constant List_Id := New_List;
8254 Any_Parameter : constant Entity_Id
8255 := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
8257 Fnam := Make_Stream_Procedure_Function_Name (Loc,
8258 Typ, Name_uFrom_Any);
8261 Make_Function_Specification (Loc,
8262 Defining_Unit_Name => Fnam,
8263 Parameter_Specifications => New_List (
8264 Make_Parameter_Specification (Loc,
8265 Defining_Identifier =>
8268 New_Occurrence_Of (RTE (RE_Any), Loc))),
8269 Subtype_Mark => New_Occurrence_Of (Typ, Loc));
8271 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8274 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8276 if Is_Derived_Type (Typ)
8277 and then not Is_Tagged_Type (Typ)
8280 Make_Return_Statement (Loc,
8284 Build_From_Any_Call (
8286 New_Occurrence_Of (Any_Parameter, Loc),
8289 elsif Is_Record_Type (Typ)
8290 and then not Is_Derived_Type (Typ)
8291 and then not Is_Tagged_Type (Typ)
8293 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8295 Make_Return_Statement (Loc,
8299 Build_From_Any_Call (
8301 New_Occurrence_Of (Any_Parameter, Loc),
8305 Disc : Entity_Id := Empty;
8306 Discriminant_Associations : List_Id;
8307 Rdef : constant Node_Id :=
8308 Type_Definition (Declaration_Node (Typ));
8309 Component_Counter : Int := 0;
8311 -- The returned object
8313 Res : constant Entity_Id :=
8314 Make_Defining_Identifier (Loc,
8315 New_Internal_Name ('R'));
8317 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8319 procedure FA_Rec_Add_Process_Element
8322 Counter : in out Int;
8326 procedure FA_Append_Record_Traversal is
8327 new Append_Record_Traversal
8329 Add_Process_Element => FA_Rec_Add_Process_Element);
8331 --------------------------------
8332 -- FA_Rec_Add_Process_Element --
8333 --------------------------------
8335 procedure FA_Rec_Add_Process_Element
8338 Counter : in out Int;
8343 if Nkind (Field) = N_Defining_Identifier then
8345 -- A regular component
8348 Make_Assignment_Statement (Loc,
8349 Name => Make_Selected_Component (Loc,
8351 New_Occurrence_Of (Rec, Loc),
8353 New_Occurrence_Of (Field, Loc)),
8355 Build_From_Any_Call (Etype (Field),
8356 Build_Get_Aggregate_Element (Loc,
8358 Tc => Build_TypeCode_Call (Loc,
8359 Etype (Field), Decls),
8360 Idx => Make_Integer_Literal (Loc,
8369 Struct_Counter : Int := 0;
8371 Block_Decls : constant List_Id := New_List;
8372 Block_Stmts : constant List_Id := New_List;
8375 Alt_List : constant List_Id := New_List;
8376 Choice_List : List_Id;
8378 Struct_Any : constant Entity_Id :=
8379 Make_Defining_Identifier (Loc,
8380 New_Internal_Name ('S'));
8384 Make_Object_Declaration (Loc,
8385 Defining_Identifier =>
8389 Object_Definition =>
8390 New_Occurrence_Of (RTE (RE_Any), Loc),
8392 Make_Function_Call (Loc,
8393 Name => New_Occurrence_Of (
8394 RTE (RE_Extract_Union_Value), Loc),
8395 Parameter_Associations => New_List (
8396 Build_Get_Aggregate_Element (Loc,
8398 Tc => Make_Function_Call (Loc,
8399 Name => New_Occurrence_Of (
8400 RTE (RE_Any_Member_Type), Loc),
8401 Parameter_Associations =>
8403 New_Occurrence_Of (Any, Loc),
8404 Make_Integer_Literal (Loc,
8406 Idx => Make_Integer_Literal (Loc,
8410 Make_Block_Statement (Loc,
8413 Handled_Statement_Sequence =>
8414 Make_Handled_Sequence_Of_Statements (Loc,
8415 Statements => Block_Stmts)));
8417 Append_To (Block_Stmts,
8418 Make_Case_Statement (Loc,
8420 Make_Selected_Component (Loc,
8423 Chars (Name (Field))),
8427 Variant := First_Non_Pragma (Variants (Field));
8429 while Present (Variant) loop
8430 Choice_List := New_Copy_List_Tree
8431 (Discrete_Choices (Variant));
8433 VP_Stmts := New_List;
8434 FA_Append_Record_Traversal (
8436 Clist => Component_List (Variant),
8437 Container => Struct_Any,
8438 Counter => Struct_Counter);
8440 Append_To (Alt_List,
8441 Make_Case_Statement_Alternative (Loc,
8442 Discrete_Choices => Choice_List,
8445 Next_Non_Pragma (Variant);
8449 Counter := Counter + 1;
8450 end FA_Rec_Add_Process_Element;
8453 -- First all discriminants
8455 if Has_Discriminants (Typ) then
8456 Disc := First_Discriminant (Typ);
8457 Discriminant_Associations := New_List;
8459 while Present (Disc) loop
8461 Disc_Var_Name : constant Entity_Id :=
8462 Make_Defining_Identifier (Loc, Chars (Disc));
8463 Disc_Type : constant Entity_Id :=
8467 Make_Object_Declaration (Loc,
8468 Defining_Identifier =>
8470 Constant_Present => True,
8471 Object_Definition =>
8472 New_Occurrence_Of (Disc_Type, Loc),
8474 Build_From_Any_Call (Etype (Disc),
8475 Build_Get_Aggregate_Element (Loc,
8476 Any => Any_Parameter,
8477 Tc => Build_TypeCode_Call
8478 (Loc, Etype (Disc), Decls),
8479 Idx => Make_Integer_Literal
8480 (Loc, Component_Counter)),
8482 Component_Counter := Component_Counter + 1;
8484 Append_To (Discriminant_Associations,
8485 Make_Discriminant_Association (Loc,
8486 Selector_Names => New_List (
8487 New_Occurrence_Of (Disc, Loc)),
8489 New_Occurrence_Of (Disc_Var_Name, Loc)));
8491 Next_Discriminant (Disc);
8494 Res_Definition := Make_Subtype_Indication (Loc,
8495 Subtype_Mark => Res_Definition,
8497 Make_Index_Or_Discriminant_Constraint (Loc,
8498 Discriminant_Associations));
8501 -- Now we have all the discriminants in variables, we can
8502 -- declared a constrained object. Note that we are not
8503 -- initializing (non-discriminant) components directly in
8504 -- the object declarations, because which fields to
8505 -- initialize depends (at run time) on the discriminant
8509 Make_Object_Declaration (Loc,
8510 Defining_Identifier =>
8512 Object_Definition =>
8515 -- ... then all components
8517 FA_Append_Record_Traversal (Stms,
8518 Clist => Component_List (Rdef),
8519 Container => Any_Parameter,
8520 Counter => Component_Counter);
8523 Make_Return_Statement (Loc,
8524 Expression => New_Occurrence_Of (Res, Loc)));
8528 elsif Is_Array_Type (Typ) then
8530 Constrained : constant Boolean := Is_Constrained (Typ);
8532 procedure FA_Ary_Add_Process_Element
8535 Counter : Entity_Id;
8537 -- Assign the current element (as identified by Counter) of
8538 -- Any to the variable denoted by name Datum, and advance
8539 -- Counter by 1. If Datum is not an Any, a call to From_Any
8540 -- for its type is inserted.
8542 --------------------------------
8543 -- FA_Ary_Add_Process_Element --
8544 --------------------------------
8546 procedure FA_Ary_Add_Process_Element
8549 Counter : Entity_Id;
8552 Assignment : constant Node_Id :=
8553 Make_Assignment_Statement (Loc,
8555 Expression => Empty);
8557 Element_Any : constant Node_Id :=
8558 Build_Get_Aggregate_Element (Loc,
8560 Tc => Build_TypeCode_Call (Loc,
8561 Etype (Datum), Decls),
8562 Idx => New_Occurrence_Of (Counter, Loc));
8565 -- Note: here we *prepend* statements to Stmts, so
8566 -- we must do it in reverse order.
8569 Make_Assignment_Statement (Loc,
8571 New_Occurrence_Of (Counter, Loc),
8575 New_Occurrence_Of (Counter, Loc),
8577 Make_Integer_Literal (Loc, 1))));
8579 if Nkind (Datum) /= N_Attribute_Reference then
8581 -- We ignore the value of the length of each
8582 -- dimension, since the target array has already
8583 -- been constrained anyway.
8585 if Etype (Datum) /= RTE (RE_Any) then
8586 Set_Expression (Assignment,
8587 Build_From_Any_Call (
8588 Component_Type (Typ),
8592 Set_Expression (Assignment, Element_Any);
8594 Prepend_To (Stmts, Assignment);
8596 end FA_Ary_Add_Process_Element;
8598 Counter : constant Entity_Id :=
8599 Make_Defining_Identifier (Loc, Name_J);
8601 Initial_Counter_Value : Int := 0;
8603 Component_TC : constant Entity_Id :=
8604 Make_Defining_Identifier (Loc, Name_T);
8606 Res : constant Entity_Id :=
8607 Make_Defining_Identifier (Loc, Name_R);
8609 procedure Append_From_Any_Array_Iterator is
8610 new Append_Array_Traversal (
8613 Indices => New_List,
8614 Add_Process_Element => FA_Ary_Add_Process_Element);
8616 Res_Subtype_Indication : Node_Id :=
8617 New_Occurrence_Of (Typ, Loc);
8620 if not Constrained then
8622 Ndim : constant Int := Number_Dimensions (Typ);
8625 Indx : Node_Id := First_Index (Typ);
8628 Ranges : constant List_Id := New_List;
8631 for J in 1 .. Ndim loop
8632 Lnam := New_External_Name ('L', J);
8633 Hnam := New_External_Name ('H', J);
8634 Indt := Etype (Indx);
8637 Make_Object_Declaration (Loc,
8638 Defining_Identifier =>
8639 Make_Defining_Identifier (Loc, Lnam),
8642 Object_Definition =>
8643 New_Occurrence_Of (Indt, Loc),
8645 Build_From_Any_Call (
8647 Build_Get_Aggregate_Element (Loc,
8648 Any => Any_Parameter,
8649 Tc => Build_TypeCode_Call (Loc,
8651 Idx => Make_Integer_Literal (Loc, J - 1)),
8655 Make_Object_Declaration (Loc,
8656 Defining_Identifier =>
8657 Make_Defining_Identifier (Loc, Hnam),
8660 Object_Definition =>
8661 New_Occurrence_Of (Indt, Loc),
8662 Expression => Make_Attribute_Reference (Loc,
8664 New_Occurrence_Of (Indt, Loc),
8665 Attribute_Name => Name_Val,
8666 Expressions => New_List (
8667 Make_Op_Subtract (Loc,
8671 Make_Attribute_Reference (Loc,
8673 New_Occurrence_Of (Indt, Loc),
8676 Expressions => New_List (
8677 Make_Identifier (Loc, Lnam))),
8679 Make_Function_Call (Loc,
8680 Name => New_Occurrence_Of (RTE (
8681 RE_Get_Nested_Sequence_Length),
8683 Parameter_Associations =>
8686 Any_Parameter, Loc),
8687 Make_Integer_Literal (Loc,
8690 Make_Integer_Literal (Loc, 1))))));
8694 Low_Bound => Make_Identifier (Loc, Lnam),
8695 High_Bound => Make_Identifier (Loc, Hnam)));
8700 -- Now we have all the necessary bound information:
8701 -- apply the set of range constraints to the
8702 -- (unconstrained) nominal subtype of Res.
8704 Initial_Counter_Value := Ndim;
8705 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
8707 Res_Subtype_Indication,
8709 Make_Index_Or_Discriminant_Constraint (Loc,
8710 Constraints => Ranges));
8715 Make_Object_Declaration (Loc,
8716 Defining_Identifier => Res,
8717 Object_Definition => Res_Subtype_Indication));
8718 Set_Etype (Res, Typ);
8721 Make_Object_Declaration (Loc,
8722 Defining_Identifier => Counter,
8723 Object_Definition =>
8724 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
8726 Make_Integer_Literal (Loc, Initial_Counter_Value)));
8729 Make_Object_Declaration (Loc,
8730 Defining_Identifier => Component_TC,
8731 Constant_Present => True,
8732 Object_Definition =>
8733 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
8735 Build_TypeCode_Call (Loc,
8736 Component_Type (Typ), Decls)));
8738 Append_From_Any_Array_Iterator (Stms,
8739 Any_Parameter, Counter);
8742 Make_Return_Statement (Loc,
8743 Expression => New_Occurrence_Of (Res, Loc)));
8746 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
8748 Make_Return_Statement (Loc,
8750 Unchecked_Convert_To (
8752 Build_From_Any_Call (
8753 Find_Numeric_Representation (Typ),
8754 New_Occurrence_Of (Any_Parameter, Loc),
8758 -- Default: type is represented as an opaque sequence of bytes
8761 Strm : constant Entity_Id :=
8762 Make_Defining_Identifier (Loc,
8763 Chars => New_Internal_Name ('S'));
8764 Res : constant Entity_Id :=
8765 Make_Defining_Identifier (Loc,
8766 Chars => New_Internal_Name ('R'));
8769 -- Strm : Buffer_Stream_Type;
8772 Make_Object_Declaration (Loc,
8773 Defining_Identifier =>
8777 Object_Definition =>
8778 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
8780 -- Any_To_BS (Strm, A);
8783 Make_Procedure_Call_Statement (Loc,
8785 New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
8786 Parameter_Associations => New_List (
8787 New_Occurrence_Of (Any_Parameter, Loc),
8788 New_Occurrence_Of (Strm, Loc))));
8791 -- Res : constant T := T'Input (Strm);
8793 -- Release_Buffer (Strm);
8797 Append_To (Stms, Make_Block_Statement (Loc,
8798 Declarations => New_List (
8799 Make_Object_Declaration (Loc,
8800 Defining_Identifier => Res,
8801 Constant_Present => True,
8802 Object_Definition =>
8803 New_Occurrence_Of (Typ, Loc),
8805 Make_Attribute_Reference (Loc,
8806 Prefix => New_Occurrence_Of (Typ, Loc),
8807 Attribute_Name => Name_Input,
8808 Expressions => New_List (
8809 Make_Attribute_Reference (Loc,
8810 Prefix => New_Occurrence_Of (Strm, Loc),
8811 Attribute_Name => Name_Access))))),
8813 Handled_Statement_Sequence =>
8814 Make_Handled_Sequence_Of_Statements (Loc,
8815 Statements => New_List (
8816 Make_Procedure_Call_Statement (Loc,
8818 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
8819 Parameter_Associations =>
8821 New_Occurrence_Of (Strm, Loc))),
8822 Make_Return_Statement (Loc,
8823 Expression => New_Occurrence_Of (Res, Loc))))));
8829 Make_Subprogram_Body (Loc,
8830 Specification => Spec,
8831 Declarations => Decls,
8832 Handled_Statement_Sequence =>
8833 Make_Handled_Sequence_Of_Statements (Loc,
8834 Statements => Stms));
8835 end Build_From_Any_Function;
8837 ---------------------------------
8838 -- Build_Get_Aggregate_Element --
8839 ---------------------------------
8841 function Build_Get_Aggregate_Element
8845 Idx : Node_Id) return Node_Id
8848 return Make_Function_Call (Loc,
8851 RTE (RE_Get_Aggregate_Element), Loc),
8852 Parameter_Associations => New_List (
8853 New_Occurrence_Of (Any, Loc),
8856 end Build_Get_Aggregate_Element;
8858 -------------------------
8859 -- Build_Reposiroty_Id --
8860 -------------------------
8862 procedure Build_Name_And_Repository_Id
8864 Name_Str : out String_Id;
8865 Repo_Id_Str : out String_Id)
8869 Store_String_Chars ("DSA:");
8870 Get_Library_Unit_Name_String (Scope (E));
8871 Store_String_Chars (
8872 Name_Buffer (Name_Buffer'First
8873 .. Name_Buffer'First + Name_Len - 1));
8874 Store_String_Char ('.');
8875 Get_Name_String (Chars (E));
8876 Store_String_Chars (
8877 Name_Buffer (Name_Buffer'First
8878 .. Name_Buffer'First + Name_Len - 1));
8879 Store_String_Chars (":1.0");
8880 Repo_Id_Str := End_String;
8881 Name_Str := String_From_Name_Buffer;
8882 end Build_Name_And_Repository_Id;
8884 -----------------------
8885 -- Build_To_Any_Call --
8886 -----------------------
8888 function Build_To_Any_Call
8890 Decls : List_Id) return Node_Id
8892 Loc : constant Source_Ptr := Sloc (N);
8894 Typ : Entity_Id := Etype (N);
8897 Fnam : Entity_Id := Empty;
8898 Lib_RE : RE_Id := RE_Null;
8901 -- If N is a selected component, then maybe its Etype
8902 -- has not been set yet: try to use the Etype of the
8903 -- selector_name in that case.
8905 if No (Typ) and then Nkind (N) = N_Selected_Component then
8906 Typ := Etype (Selector_Name (N));
8908 pragma Assert (Present (Typ));
8910 -- The full view, if Typ is private; the completion,
8911 -- if Typ is incomplete.
8913 U_Type := Underlying_Type (Typ);
8915 -- First simple case where the To_Any function is present
8916 -- in the type's TSS.
8918 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
8920 -- Check first for Boolean and Character. These are enumeration
8921 -- types, but we treat them specially, since they may require
8922 -- special handling in the transfer protocol. However, this
8923 -- special handling only applies if they have standard
8924 -- representation, otherwise they are treated like any other
8925 -- enumeration type.
8927 if Sloc (U_Type) <= Standard_Location then
8928 U_Type := Base_Type (U_Type);
8931 if Present (Fnam) then
8934 elsif U_Type = Standard_Boolean then
8937 elsif U_Type = Standard_Character then
8940 elsif U_Type = Standard_Wide_Character then
8943 elsif U_Type = Standard_Wide_Wide_Character then
8944 Lib_RE := RE_TA_WWC;
8946 -- Floating point types
8948 elsif U_Type = Standard_Short_Float then
8951 elsif U_Type = Standard_Float then
8954 elsif U_Type = Standard_Long_Float then
8957 elsif U_Type = Standard_Long_Long_Float then
8958 Lib_RE := RE_TA_LLF;
8962 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8963 Lib_RE := RE_TA_SSI;
8965 elsif U_Type = Etype (Standard_Short_Integer) then
8968 elsif U_Type = Etype (Standard_Integer) then
8971 elsif U_Type = Etype (Standard_Long_Integer) then
8974 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8975 Lib_RE := RE_TA_LLI;
8977 -- Unsigned integer types
8979 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8980 Lib_RE := RE_TA_SSU;
8982 elsif U_Type = RTE (RE_Short_Unsigned) then
8985 elsif U_Type = RTE (RE_Unsigned) then
8988 elsif U_Type = RTE (RE_Long_Unsigned) then
8991 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8992 Lib_RE := RE_TA_LLU;
8994 elsif U_Type = Standard_String then
8995 Lib_RE := RE_TA_String;
8997 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9000 -- Other (non-primitive) types
9006 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9007 Append_To (Decls, Decl);
9011 -- Call the function
9013 if Lib_RE /= RE_Null then
9014 pragma Assert (No (Fnam));
9015 Fnam := RTE (Lib_RE);
9019 Make_Function_Call (Loc,
9020 Name => New_Occurrence_Of (Fnam, Loc),
9021 Parameter_Associations => New_List (N));
9022 end Build_To_Any_Call;
9024 ---------------------------
9025 -- Build_To_Any_Function --
9026 ---------------------------
9028 procedure Build_To_Any_Function
9032 Fnam : out Entity_Id)
9035 Decls : constant List_Id := New_List;
9036 Stms : constant List_Id := New_List;
9038 Expr_Parameter : constant Entity_Id :=
9039 Make_Defining_Identifier (Loc, Name_E);
9041 Any : constant Entity_Id :=
9042 Make_Defining_Identifier (Loc, Name_A);
9045 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9048 Fnam := Make_Stream_Procedure_Function_Name (Loc,
9052 Make_Function_Specification (Loc,
9053 Defining_Unit_Name => Fnam,
9054 Parameter_Specifications => New_List (
9055 Make_Parameter_Specification (Loc,
9056 Defining_Identifier =>
9059 New_Occurrence_Of (Typ, Loc))),
9060 Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), Loc));
9061 Set_Etype (Expr_Parameter, Typ);
9064 Make_Object_Declaration (Loc,
9065 Defining_Identifier =>
9067 Object_Definition =>
9068 New_Occurrence_Of (RTE (RE_Any), Loc));
9070 if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9072 Rt_Type : constant Entity_Id
9074 Expr : constant Node_Id
9077 New_Occurrence_Of (Expr_Parameter, Loc));
9079 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9082 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9083 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9085 Rt_Type : constant Entity_Id
9087 Expr : constant Node_Id
9090 New_Occurrence_Of (Expr_Parameter, Loc));
9093 Set_Expression (Any_Decl,
9094 Build_To_Any_Call (Expr, Decls));
9099 Disc : Entity_Id := Empty;
9100 Rdef : constant Node_Id :=
9101 Type_Definition (Declaration_Node (Typ));
9103 Elements : constant List_Id := New_List;
9105 procedure TA_Rec_Add_Process_Element
9107 Container : Node_Or_Entity_Id;
9108 Counter : in out Int;
9112 procedure TA_Append_Record_Traversal is
9113 new Append_Record_Traversal
9114 (Rec => Expr_Parameter,
9115 Add_Process_Element => TA_Rec_Add_Process_Element);
9117 --------------------------------
9118 -- TA_Rec_Add_Process_Element --
9119 --------------------------------
9121 procedure TA_Rec_Add_Process_Element
9123 Container : Node_Or_Entity_Id;
9124 Counter : in out Int;
9128 Field_Ref : Node_Id;
9131 if Nkind (Field) = N_Defining_Identifier then
9133 -- A regular component
9135 Field_Ref := Make_Selected_Component (Loc,
9136 Prefix => New_Occurrence_Of (Rec, Loc),
9137 Selector_Name => New_Occurrence_Of (Field, Loc));
9138 Set_Etype (Field_Ref, Etype (Field));
9141 Make_Procedure_Call_Statement (Loc,
9144 RTE (RE_Add_Aggregate_Element), Loc),
9145 Parameter_Associations => New_List (
9146 New_Occurrence_Of (Any, Loc),
9147 Build_To_Any_Call (Field_Ref, Decls))));
9154 Struct_Counter : Int := 0;
9156 Block_Decls : constant List_Id := New_List;
9157 Block_Stmts : constant List_Id := New_List;
9160 Alt_List : constant List_Id := New_List;
9161 Choice_List : List_Id;
9163 Union_Any : constant Entity_Id :=
9164 Make_Defining_Identifier (Loc,
9165 New_Internal_Name ('U'));
9167 Struct_Any : constant Entity_Id :=
9168 Make_Defining_Identifier (Loc,
9169 New_Internal_Name ('S'));
9171 function Make_Discriminant_Reference
9173 -- Build a selected component for the
9174 -- discriminant of this variant part.
9176 ---------------------------------
9177 -- Make_Discriminant_Reference --
9178 ---------------------------------
9180 function Make_Discriminant_Reference
9183 Nod : constant Node_Id :=
9184 Make_Selected_Component (Loc,
9187 Chars (Name (Field)));
9189 Set_Etype (Nod, Name (Field));
9191 end Make_Discriminant_Reference;
9195 Make_Block_Statement (Loc,
9198 Handled_Statement_Sequence =>
9199 Make_Handled_Sequence_Of_Statements (Loc,
9200 Statements => Block_Stmts)));
9202 Append_To (Block_Decls,
9203 Make_Object_Declaration (Loc,
9204 Defining_Identifier => Union_Any,
9205 Object_Definition =>
9206 New_Occurrence_Of (RTE (RE_Any), Loc),
9208 Make_Function_Call (Loc,
9209 Name => New_Occurrence_Of (
9210 RTE (RE_Create_Any), Loc),
9211 Parameter_Associations => New_List (
9212 Make_Function_Call (Loc,
9215 RTE (RE_Any_Member_Type), Loc),
9216 Parameter_Associations => New_List (
9217 New_Occurrence_Of (Container, Loc),
9218 Make_Integer_Literal (Loc,
9221 Append_To (Block_Decls,
9222 Make_Object_Declaration (Loc,
9223 Defining_Identifier => Struct_Any,
9224 Object_Definition =>
9225 New_Occurrence_Of (RTE (RE_Any), Loc),
9227 Make_Function_Call (Loc,
9228 Name => New_Occurrence_Of (
9229 RTE (RE_Create_Any), Loc),
9230 Parameter_Associations => New_List (
9231 Make_Function_Call (Loc,
9234 RTE (RE_Any_Member_Type), Loc),
9235 Parameter_Associations => New_List (
9236 New_Occurrence_Of (Union_Any, Loc),
9237 Make_Integer_Literal (Loc,
9240 Append_To (Block_Stmts,
9241 Make_Case_Statement (Loc,
9243 Make_Discriminant_Reference,
9247 Variant := First_Non_Pragma (Variants (Field));
9248 while Present (Variant) loop
9249 Choice_List := New_Copy_List_Tree
9250 (Discrete_Choices (Variant));
9252 VP_Stmts := New_List;
9253 TA_Append_Record_Traversal (
9255 Clist => Component_List (Variant),
9256 Container => Struct_Any,
9257 Counter => Struct_Counter);
9259 -- Append discriminant value and inner struct
9260 -- to union aggregate.
9262 Append_To (VP_Stmts,
9263 Make_Procedure_Call_Statement (Loc,
9266 RTE (RE_Add_Aggregate_Element), Loc),
9267 Parameter_Associations => New_List (
9268 New_Occurrence_Of (Union_Any, Loc),
9270 Make_Discriminant_Reference,
9273 Append_To (VP_Stmts,
9274 Make_Procedure_Call_Statement (Loc,
9277 RTE (RE_Add_Aggregate_Element), Loc),
9278 Parameter_Associations => New_List (
9279 New_Occurrence_Of (Union_Any, Loc),
9280 New_Occurrence_Of (Struct_Any, Loc))));
9282 -- Append union to outer aggregate
9284 Append_To (VP_Stmts,
9285 Make_Procedure_Call_Statement (Loc,
9288 RTE (RE_Add_Aggregate_Element), Loc),
9289 Parameter_Associations => New_List (
9290 New_Occurrence_Of (Container, Loc),
9291 Make_Function_Call (Loc,
9292 Name => New_Occurrence_Of (
9293 RTE (RE_Any_Aggregate_Build), Loc),
9294 Parameter_Associations => New_List (
9296 Union_Any, Loc))))));
9298 Append_To (Alt_List,
9299 Make_Case_Statement_Alternative (Loc,
9300 Discrete_Choices => Choice_List,
9303 Next_Non_Pragma (Variant);
9307 end TA_Rec_Add_Process_Element;
9310 -- First all discriminants
9312 if Has_Discriminants (Typ) then
9313 Disc := First_Discriminant (Typ);
9315 while Present (Disc) loop
9316 Append_To (Elements,
9317 Make_Component_Association (Loc,
9318 Choices => New_List (
9319 Make_Integer_Literal (Loc, Counter)),
9322 Make_Selected_Component (Loc,
9323 Prefix => Expr_Parameter,
9324 Selector_Name => Chars (Disc)),
9326 Counter := Counter + 1;
9327 Next_Discriminant (Disc);
9331 -- Make elements an empty array
9334 Dummy_Any : constant Entity_Id :=
9335 Make_Defining_Identifier (Loc,
9336 Chars => New_Internal_Name ('A'));
9340 Make_Object_Declaration (Loc,
9341 Defining_Identifier => Dummy_Any,
9342 Object_Definition =>
9343 New_Occurrence_Of (RTE (RE_Any), Loc)));
9345 Append_To (Elements,
9346 Make_Component_Association (Loc,
9347 Choices => New_List (
9350 Make_Integer_Literal (Loc, 1),
9352 Make_Integer_Literal (Loc, 0))),
9354 New_Occurrence_Of (Dummy_Any, Loc)));
9358 Set_Expression (Any_Decl,
9359 Make_Function_Call (Loc,
9360 Name => New_Occurrence_Of (
9361 RTE (RE_Any_Aggregate_Build), Loc),
9362 Parameter_Associations => New_List (
9364 Make_Aggregate (Loc,
9365 Component_Associations => Elements))));
9368 -- ... then all components
9370 TA_Append_Record_Traversal (Stms,
9371 Clist => Component_List (Rdef),
9373 Counter => Counter);
9377 elsif Is_Array_Type (Typ) then
9379 Constrained : constant Boolean := Is_Constrained (Typ);
9381 procedure TA_Ary_Add_Process_Element
9384 Counter : Entity_Id;
9387 --------------------------------
9388 -- TA_Ary_Add_Process_Element --
9389 --------------------------------
9391 procedure TA_Ary_Add_Process_Element
9394 Counter : Entity_Id;
9397 pragma Warnings (Off);
9398 pragma Unreferenced (Counter);
9399 pragma Warnings (On);
9401 Element_Any : Node_Id;
9404 if Etype (Datum) = RTE (RE_Any) then
9405 Element_Any := Datum;
9407 Element_Any := Build_To_Any_Call (Datum, Decls);
9411 Make_Procedure_Call_Statement (Loc,
9412 Name => New_Occurrence_Of (
9413 RTE (RE_Add_Aggregate_Element), Loc),
9414 Parameter_Associations => New_List (
9415 New_Occurrence_Of (Any, Loc),
9417 end TA_Ary_Add_Process_Element;
9419 procedure Append_To_Any_Array_Iterator is
9420 new Append_Array_Traversal (
9422 Arry => Expr_Parameter,
9423 Indices => New_List,
9424 Add_Process_Element => TA_Ary_Add_Process_Element);
9429 Set_Expression (Any_Decl,
9430 Make_Function_Call (Loc,
9432 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9433 Parameter_Associations => New_List (Result_TC)));
9436 if not Constrained then
9437 Index := First_Index (Typ);
9438 for J in 1 .. Number_Dimensions (Typ) loop
9440 Make_Procedure_Call_Statement (Loc,
9443 RTE (RE_Add_Aggregate_Element), Loc),
9444 Parameter_Associations => New_List (
9445 New_Occurrence_Of (Any, Loc),
9447 OK_Convert_To (Etype (Index),
9448 Make_Attribute_Reference (Loc,
9450 New_Occurrence_Of (Expr_Parameter, Loc),
9451 Attribute_Name => Name_First,
9452 Expressions => New_List (
9453 Make_Integer_Literal (Loc, J)))),
9459 Append_To_Any_Array_Iterator (Stms, Any);
9462 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9463 Set_Expression (Any_Decl,
9466 Find_Numeric_Representation (Typ),
9467 New_Occurrence_Of (Expr_Parameter, Loc)),
9471 -- Default: type is represented as an opaque sequence of bytes
9474 Strm : constant Entity_Id := Make_Defining_Identifier (Loc,
9475 New_Internal_Name ('S'));
9478 -- Strm : aliased Buffer_Stream_Type;
9481 Make_Object_Declaration (Loc,
9482 Defining_Identifier =>
9486 Object_Definition =>
9487 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9489 -- Allocate_Buffer (Strm);
9492 Make_Procedure_Call_Statement (Loc,
9494 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9495 Parameter_Associations => New_List (
9496 New_Occurrence_Of (Strm, Loc))));
9498 -- T'Output (Strm'Access, E);
9501 Make_Attribute_Reference (Loc,
9502 Prefix => New_Occurrence_Of (Typ, Loc),
9503 Attribute_Name => Name_Output,
9504 Expressions => New_List (
9505 Make_Attribute_Reference (Loc,
9506 Prefix => New_Occurrence_Of (Strm, Loc),
9507 Attribute_Name => Name_Access),
9508 New_Occurrence_Of (Expr_Parameter, Loc))));
9510 -- BS_To_Any (Strm, A);
9513 Make_Procedure_Call_Statement (Loc,
9515 New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
9516 Parameter_Associations => New_List (
9517 New_Occurrence_Of (Strm, Loc),
9518 New_Occurrence_Of (Any, Loc))));
9520 -- Release_Buffer (Strm);
9523 Make_Procedure_Call_Statement (Loc,
9525 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
9526 Parameter_Associations => New_List (
9527 New_Occurrence_Of (Strm, Loc))));
9531 Append_To (Decls, Any_Decl);
9533 if Present (Result_TC) then
9535 Make_Procedure_Call_Statement (Loc,
9536 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
9537 Parameter_Associations => New_List (
9538 New_Occurrence_Of (Any, Loc),
9543 Make_Return_Statement (Loc,
9544 Expression => New_Occurrence_Of (Any, Loc)));
9547 Make_Subprogram_Body (Loc,
9548 Specification => Spec,
9549 Declarations => Decls,
9550 Handled_Statement_Sequence =>
9551 Make_Handled_Sequence_Of_Statements (Loc,
9552 Statements => Stms));
9553 end Build_To_Any_Function;
9555 -------------------------
9556 -- Build_TypeCode_Call --
9557 -------------------------
9559 function Build_TypeCode_Call
9562 Decls : List_Id) return Node_Id
9564 U_Type : Entity_Id := Underlying_Type (Typ);
9565 -- The full view, if Typ is private; the completion,
9566 -- if Typ is incomplete.
9568 Fnam : Entity_Id := Empty;
9569 Tnam : Entity_Id := Empty;
9570 Pnam : Entity_Id := Empty;
9571 Args : List_Id := Empty_List;
9572 Lib_RE : RE_Id := RE_Null;
9577 -- Special case System.PolyORB.Interface.Any: its primitives have
9578 -- not been set yet, so can't call Find_Inherited_TSS.
9580 if Typ = RTE (RE_Any) then
9581 Fnam := RTE (RE_TC_Any);
9584 -- First simple case where the TypeCode is present
9585 -- in the type's TSS.
9587 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
9589 if Present (Fnam) then
9591 -- When a TypeCode TSS exists, it has a single parameter
9592 -- that is an anonymous access to the corresponding type.
9593 -- This parameter is not used in any way; its purpose is
9594 -- solely to provide overloading of the TSS.
9597 Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
9599 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
9602 Make_Full_Type_Declaration (Loc,
9603 Defining_Identifier => Tnam,
9605 Make_Access_To_Object_Definition (Loc,
9606 Subtype_Indication =>
9607 New_Occurrence_Of (U_Type, Loc))));
9609 Make_Object_Declaration (Loc,
9610 Defining_Identifier => Pnam,
9611 Constant_Present => True,
9612 Object_Definition => New_Occurrence_Of (Tnam, Loc),
9614 -- Use a variable here to force proper freezing of Tnam
9616 Expression => Make_Null (Loc)));
9618 -- Normally, calling _TypeCode with a null access parameter
9619 -- should raise Constraint_Error, but this check is
9620 -- suppressed for expanded code, and we do not care anyway
9621 -- because we do not actually ever use this value.
9623 Args := New_List (New_Occurrence_Of (Pnam, Loc));
9628 if Sloc (U_Type) <= Standard_Location then
9630 -- Do not try to build alias typecodes for subtypes from
9633 U_Type := Base_Type (U_Type);
9636 if Is_Itype (U_Type) then
9637 return Build_TypeCode_Call
9638 (Loc, Associated_Node_For_Itype (U_Type), Decls);
9641 if U_Type = Standard_Boolean then
9644 elsif U_Type = Standard_Character then
9647 elsif U_Type = Standard_Wide_Character then
9650 elsif U_Type = Standard_Wide_Wide_Character then
9651 Lib_RE := RE_TC_WWC;
9653 -- Floating point types
9655 elsif U_Type = Standard_Short_Float then
9658 elsif U_Type = Standard_Float then
9661 elsif U_Type = Standard_Long_Float then
9664 elsif U_Type = Standard_Long_Long_Float then
9665 Lib_RE := RE_TC_LLF;
9667 -- Integer types (walk back to the base type)
9669 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9670 Lib_RE := RE_TC_SSI;
9672 elsif U_Type = Etype (Standard_Short_Integer) then
9675 elsif U_Type = Etype (Standard_Integer) then
9678 elsif U_Type = Etype (Standard_Long_Integer) then
9681 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9682 Lib_RE := RE_TC_LLI;
9684 -- Unsigned integer types
9686 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9687 Lib_RE := RE_TC_SSU;
9689 elsif U_Type = RTE (RE_Short_Unsigned) then
9692 elsif U_Type = RTE (RE_Unsigned) then
9695 elsif U_Type = RTE (RE_Long_Unsigned) then
9698 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9699 Lib_RE := RE_TC_LLU;
9701 elsif U_Type = Standard_String then
9702 Lib_RE := RE_TC_String;
9704 -- Other (non-primitive) types
9710 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
9711 Append_To (Decls, Decl);
9715 if Lib_RE /= RE_Null then
9716 Fnam := RTE (Lib_RE);
9720 -- Call the function
9723 Make_Function_Call (Loc,
9724 Name => New_Occurrence_Of (Fnam, Loc),
9725 Parameter_Associations => Args);
9727 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
9729 Set_Etype (Expr, RTE (RE_TypeCode));
9732 end Build_TypeCode_Call;
9734 -----------------------------
9735 -- Build_TypeCode_Function --
9736 -----------------------------
9738 procedure Build_TypeCode_Function
9742 Fnam : out Entity_Id)
9745 Decls : constant List_Id := New_List;
9746 Stms : constant List_Id := New_List;
9748 TCNam : constant Entity_Id :=
9749 Make_Stream_Procedure_Function_Name (Loc,
9750 Typ, Name_uTypeCode);
9752 Parameters : List_Id;
9754 procedure Add_String_Parameter
9756 Parameter_List : List_Id);
9757 -- Add a literal for S to Parameters
9759 procedure Add_TypeCode_Parameter
9761 Parameter_List : List_Id);
9762 -- Add the typecode for Typ to Parameters
9764 procedure Add_Long_Parameter
9765 (Expr_Node : Node_Id;
9766 Parameter_List : List_Id);
9767 -- Add a signed long integer expression to Parameters
9769 procedure Initialize_Parameter_List
9770 (Name_String : String_Id;
9771 Repo_Id_String : String_Id;
9772 Parameter_List : out List_Id);
9773 -- Return a list that contains the first two parameters
9774 -- for a parameterized typecode: name and repository id.
9776 function Make_Constructed_TypeCode
9778 Parameters : List_Id) return Node_Id;
9779 -- Call TC_Build with the given kind and parameters
9781 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
9782 -- Make a return statement that calls TC_Build with the given
9783 -- typecode kind, and the constructed parameters list.
9785 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
9786 -- Return a typecode that is a TC_Alias for the given typecode
9788 --------------------------
9789 -- Add_String_Parameter --
9790 --------------------------
9792 procedure Add_String_Parameter
9794 Parameter_List : List_Id)
9797 Append_To (Parameter_List,
9798 Make_Function_Call (Loc,
9800 New_Occurrence_Of (RTE (RE_TA_String), Loc),
9801 Parameter_Associations => New_List (
9802 Make_String_Literal (Loc, S))));
9803 end Add_String_Parameter;
9805 ----------------------------
9806 -- Add_TypeCode_Parameter --
9807 ----------------------------
9809 procedure Add_TypeCode_Parameter
9811 Parameter_List : List_Id)
9814 Append_To (Parameter_List,
9815 Make_Function_Call (Loc,
9817 New_Occurrence_Of (RTE (RE_TA_TC), Loc),
9818 Parameter_Associations => New_List (
9820 end Add_TypeCode_Parameter;
9822 ------------------------
9823 -- Add_Long_Parameter --
9824 ------------------------
9826 procedure Add_Long_Parameter
9827 (Expr_Node : Node_Id;
9828 Parameter_List : List_Id)
9831 Append_To (Parameter_List,
9832 Make_Function_Call (Loc,
9834 New_Occurrence_Of (RTE (RE_TA_LI), Loc),
9835 Parameter_Associations => New_List (Expr_Node)));
9836 end Add_Long_Parameter;
9838 -------------------------------
9839 -- Initialize_Parameter_List --
9840 -------------------------------
9842 procedure Initialize_Parameter_List
9843 (Name_String : String_Id;
9844 Repo_Id_String : String_Id;
9845 Parameter_List : out List_Id)
9848 Parameter_List := New_List;
9849 Add_String_Parameter (Name_String, Parameter_List);
9850 Add_String_Parameter (Repo_Id_String, Parameter_List);
9851 end Initialize_Parameter_List;
9853 ---------------------------
9854 -- Return_Alias_TypeCode --
9855 ---------------------------
9857 procedure Return_Alias_TypeCode
9858 (Base_TypeCode : Node_Id)
9861 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
9862 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
9863 end Return_Alias_TypeCode;
9865 -------------------------------
9866 -- Make_Constructed_TypeCode --
9867 -------------------------------
9869 function Make_Constructed_TypeCode
9871 Parameters : List_Id) return Node_Id
9873 Constructed_TC : constant Node_Id :=
9874 Make_Function_Call (Loc,
9876 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
9877 Parameter_Associations => New_List (
9878 New_Occurrence_Of (Kind, Loc),
9879 Make_Aggregate (Loc,
9880 Expressions => Parameters)));
9882 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
9883 return Constructed_TC;
9884 end Make_Constructed_TypeCode;
9886 ---------------------------------
9887 -- Return_Constructed_TypeCode --
9888 ---------------------------------
9890 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
9893 Make_Return_Statement (Loc,
9895 Make_Constructed_TypeCode (Kind, Parameters)));
9896 end Return_Constructed_TypeCode;
9902 procedure TC_Rec_Add_Process_Element
9905 Counter : in out Int;
9909 procedure TC_Append_Record_Traversal is
9910 new Append_Record_Traversal (
9912 Add_Process_Element => TC_Rec_Add_Process_Element);
9914 --------------------------------
9915 -- TC_Rec_Add_Process_Element --
9916 --------------------------------
9918 procedure TC_Rec_Add_Process_Element
9921 Counter : in out Int;
9925 pragma Warnings (Off);
9926 pragma Unreferenced (Any, Counter, Rec);
9927 pragma Warnings (On);
9930 if Nkind (Field) = N_Defining_Identifier then
9932 -- A regular component
9934 Add_TypeCode_Parameter (
9935 Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
9936 Get_Name_String (Chars (Field));
9937 Add_String_Parameter (String_From_Name_Buffer, Params);
9944 Discriminant_Type : constant Entity_Id :=
9945 Etype (Name (Field));
9947 Is_Enum : constant Boolean :=
9948 Is_Enumeration_Type (Discriminant_Type);
9950 Union_TC_Params : List_Id;
9952 U_Name : constant Name_Id :=
9953 New_External_Name (Chars (Typ), 'U', -1);
9955 Name_Str : String_Id;
9956 Struct_TC_Params : List_Id;
9960 Default : constant Node_Id :=
9961 Make_Integer_Literal (Loc, -1);
9963 Dummy_Counter : Int := 0;
9965 procedure Add_Params_For_Variant_Components;
9966 -- Add a struct TypeCode and a corresponding member name
9967 -- to the union parameter list.
9969 -- Ordering of declarations is a complete mess in this
9970 -- area, it is supposed to be types/varibles, then
9971 -- subprogram specs, then subprogram bodies ???
9973 ---------------------------------------
9974 -- Add_Params_For_Variant_Components --
9975 ---------------------------------------
9977 procedure Add_Params_For_Variant_Components
9979 S_Name : constant Name_Id :=
9980 New_External_Name (U_Name, 'S', -1);
9983 Get_Name_String (S_Name);
9984 Name_Str := String_From_Name_Buffer;
9985 Initialize_Parameter_List
9986 (Name_Str, Name_Str, Struct_TC_Params);
9988 -- Build struct parameters
9990 TC_Append_Record_Traversal (Struct_TC_Params,
9991 Component_List (Variant),
9995 Add_TypeCode_Parameter
9996 (Make_Constructed_TypeCode
9997 (RTE (RE_TC_Struct), Struct_TC_Params),
10000 Add_String_Parameter (Name_Str, Union_TC_Params);
10001 end Add_Params_For_Variant_Components;
10004 Get_Name_String (U_Name);
10005 Name_Str := String_From_Name_Buffer;
10007 Initialize_Parameter_List
10008 (Name_Str, Name_Str, Union_TC_Params);
10010 Add_String_Parameter (Name_Str, Params);
10012 -- Add union in enclosing parameter list
10014 Add_TypeCode_Parameter
10015 (Make_Constructed_TypeCode
10016 (RTE (RE_TC_Union), Union_TC_Params),
10019 -- Build union parameters
10021 Add_TypeCode_Parameter
10022 (Discriminant_Type, Union_TC_Params);
10023 Add_Long_Parameter (Default, Union_TC_Params);
10025 Variant := First_Non_Pragma (Variants (Field));
10026 while Present (Variant) loop
10027 Choice := First (Discrete_Choices (Variant));
10028 while Present (Choice) loop
10029 case Nkind (Choice) is
10032 L : constant Uint :=
10033 Expr_Value (Low_Bound (Choice));
10034 H : constant Uint :=
10035 Expr_Value (High_Bound (Choice));
10037 -- 3.8.1(8) guarantees that the bounds of
10038 -- this range are static.
10045 Expr := New_Occurrence_Of (
10046 Get_Enum_Lit_From_Pos (
10047 Discriminant_Type, J, Loc), Loc);
10050 Make_Integer_Literal (Loc, J);
10052 Append_To (Union_TC_Params,
10053 Build_To_Any_Call (Expr, Decls));
10054 Add_Params_For_Variant_Components;
10059 when N_Others_Choice =>
10060 Add_Long_Parameter (
10061 Make_Integer_Literal (Loc, 0),
10063 Add_Params_For_Variant_Components;
10066 Append_To (Union_TC_Params,
10067 Build_To_Any_Call (Choice, Decls));
10068 Add_Params_For_Variant_Components;
10074 Next_Non_Pragma (Variant);
10079 end TC_Rec_Add_Process_Element;
10081 Type_Name_Str : String_Id;
10082 Type_Repo_Id_Str : String_Id;
10085 pragma Assert (not Is_Itype (Typ));
10089 Make_Function_Specification (Loc,
10090 Defining_Unit_Name => Fnam,
10091 Parameter_Specifications => Empty_List,
10092 Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10094 Build_Name_And_Repository_Id (Typ,
10095 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10096 Initialize_Parameter_List
10097 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10099 if Is_Derived_Type (Typ)
10100 and then not Is_Tagged_Type (Typ)
10103 D_Node : constant Node_Id := Declaration_Node (Typ);
10104 Parent_Type : Entity_Id := Etype (Typ);
10107 if Is_Enumeration_Type (Typ)
10108 and then Nkind (D_Node) = N_Subtype_Declaration
10109 and then Nkind (Original_Node (D_Node))
10110 /= N_Subtype_Declaration
10113 -- Parent_Type is the implicit intermediate base type
10114 -- created by Build_Derived_Enumeration_Type.
10116 Parent_Type := Etype (Parent_Type);
10119 Return_Alias_TypeCode (
10120 Build_TypeCode_Call (Loc, Parent_Type, Decls));
10123 elsif Is_Integer_Type (Typ)
10124 or else Is_Unsigned_Type (Typ)
10126 Return_Alias_TypeCode (
10127 Build_TypeCode_Call (Loc,
10128 Find_Numeric_Representation (Typ), Decls));
10130 elsif Is_Record_Type (Typ)
10131 and then not Is_Tagged_Type (Typ)
10133 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10134 Return_Alias_TypeCode (
10135 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10138 Disc : Entity_Id := Empty;
10139 Rdef : constant Node_Id :=
10140 Type_Definition (Declaration_Node (Typ));
10141 Dummy_Counter : Int := 0;
10143 -- First all discriminants
10145 if Has_Discriminants (Typ) then
10146 Disc := First_Discriminant (Typ);
10148 while Present (Disc) loop
10149 Add_TypeCode_Parameter (
10150 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10152 Get_Name_String (Chars (Disc));
10153 Add_String_Parameter (
10154 String_From_Name_Buffer,
10156 Next_Discriminant (Disc);
10159 -- ... then all components
10161 TC_Append_Record_Traversal
10162 (Parameters, Component_List (Rdef),
10163 Empty, Dummy_Counter);
10164 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10168 elsif Is_Array_Type (Typ) then
10170 Ndim : constant Pos := Number_Dimensions (Typ);
10171 Inner_TypeCode : Node_Id;
10172 Constrained : constant Boolean := Is_Constrained (Typ);
10173 Indx : Node_Id := First_Index (Typ);
10176 Inner_TypeCode := Build_TypeCode_Call (Loc,
10177 Component_Type (Typ),
10180 for J in 1 .. Ndim loop
10181 if Constrained then
10182 Inner_TypeCode := Make_Constructed_TypeCode
10183 (RTE (RE_TC_Array), New_List (
10184 Build_To_Any_Call (
10185 OK_Convert_To (RTE (RE_Long_Unsigned),
10186 Make_Attribute_Reference (Loc,
10188 New_Occurrence_Of (Typ, Loc),
10191 Expressions => New_List (
10192 Make_Integer_Literal (Loc,
10195 Build_To_Any_Call (Inner_TypeCode, Decls)));
10198 -- Unconstrained case: add low bound for each
10201 Add_TypeCode_Parameter
10202 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10204 Get_Name_String (New_External_Name ('L', J));
10205 Add_String_Parameter (
10206 String_From_Name_Buffer,
10210 Inner_TypeCode := Make_Constructed_TypeCode
10211 (RTE (RE_TC_Sequence), New_List (
10212 Build_To_Any_Call (
10213 OK_Convert_To (RTE (RE_Long_Unsigned),
10214 Make_Integer_Literal (Loc, 0)),
10216 Build_To_Any_Call (Inner_TypeCode, Decls)));
10220 if Constrained then
10221 Return_Alias_TypeCode (Inner_TypeCode);
10223 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10225 Store_String_Char ('V');
10226 Add_String_Parameter (End_String, Parameters);
10227 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10232 -- Default: type is represented as an opaque sequence of bytes
10234 Return_Alias_TypeCode
10235 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10239 Make_Subprogram_Body (Loc,
10240 Specification => Spec,
10241 Declarations => Decls,
10242 Handled_Statement_Sequence =>
10243 Make_Handled_Sequence_Of_Statements (Loc,
10244 Statements => Stms));
10245 end Build_TypeCode_Function;
10247 ---------------------------------
10248 -- Find_Numeric_Representation --
10249 ---------------------------------
10251 function Find_Numeric_Representation (Typ : Entity_Id)
10254 FST : constant Entity_Id := First_Subtype (Typ);
10255 P_Size : constant Uint := Esize (FST);
10258 if Is_Unsigned_Type (Typ) then
10259 if P_Size <= Standard_Short_Short_Integer_Size then
10260 return RTE (RE_Short_Short_Unsigned);
10262 elsif P_Size <= Standard_Short_Integer_Size then
10263 return RTE (RE_Short_Unsigned);
10265 elsif P_Size <= Standard_Integer_Size then
10266 return RTE (RE_Unsigned);
10268 elsif P_Size <= Standard_Long_Integer_Size then
10269 return RTE (RE_Long_Unsigned);
10272 return RTE (RE_Long_Long_Unsigned);
10275 elsif Is_Integer_Type (Typ) then
10276 if P_Size <= Standard_Short_Short_Integer_Size then
10277 return Standard_Short_Short_Integer;
10279 elsif P_Size <= Standard_Short_Integer_Size then
10280 return Standard_Short_Integer;
10282 elsif P_Size <= Standard_Integer_Size then
10283 return Standard_Integer;
10285 elsif P_Size <= Standard_Long_Integer_Size then
10286 return Standard_Long_Integer;
10289 return Standard_Long_Long_Integer;
10292 elsif Is_Floating_Point_Type (Typ) then
10293 if P_Size <= Standard_Short_Float_Size then
10294 return Standard_Short_Float;
10296 elsif P_Size <= Standard_Float_Size then
10297 return Standard_Float;
10299 elsif P_Size <= Standard_Long_Float_Size then
10300 return Standard_Long_Float;
10303 return Standard_Long_Long_Float;
10307 raise Program_Error;
10310 -- TBD: fixed point types???
10311 -- TBverified numeric types with a biased representation???
10313 end Find_Numeric_Representation;
10315 ---------------------------
10316 -- Append_Array_Traversal --
10317 ---------------------------
10319 procedure Append_Array_Traversal
10322 Counter : Entity_Id := Empty;
10325 Loc : constant Source_Ptr := Sloc (Subprogram);
10326 Typ : constant Entity_Id := Etype (Arry);
10327 Constrained : constant Boolean := Is_Constrained (Typ);
10328 Ndim : constant Pos := Number_Dimensions (Typ);
10330 Inner_Any, Inner_Counter : Entity_Id;
10332 Loop_Stm : Node_Id;
10333 Inner_Stmts : constant List_Id := New_List;
10336 if Depth > Ndim then
10338 -- Processing for one element of an array
10341 Element_Expr : constant Node_Id :=
10342 Make_Indexed_Component (Loc,
10343 New_Occurrence_Of (Arry, Loc),
10347 Set_Etype (Element_Expr, Component_Type (Typ));
10348 Add_Process_Element (Stmts,
10350 Counter => Counter,
10351 Datum => Element_Expr);
10357 Append_To (Indices,
10358 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10360 if Constrained then
10362 Inner_Counter := Counter;
10364 Inner_Any := Make_Defining_Identifier (Loc,
10365 New_External_Name ('A', Depth));
10366 Set_Etype (Inner_Any, RTE (RE_Any));
10368 if Present (Counter) then
10369 Inner_Counter := Make_Defining_Identifier (Loc,
10370 New_External_Name ('J', Depth));
10372 Inner_Counter := Empty;
10376 Append_Array_Traversal (Inner_Stmts,
10378 Counter => Inner_Counter,
10379 Depth => Depth + 1);
10382 Make_Implicit_Loop_Statement (Subprogram,
10383 Iteration_Scheme =>
10384 Make_Iteration_Scheme (Loc,
10385 Loop_Parameter_Specification =>
10386 Make_Loop_Parameter_Specification (Loc,
10387 Defining_Identifier =>
10388 Make_Defining_Identifier (Loc,
10389 Chars => New_External_Name ('L', Depth)),
10391 Discrete_Subtype_Definition =>
10392 Make_Attribute_Reference (Loc,
10393 Prefix => New_Occurrence_Of (Arry, Loc),
10394 Attribute_Name => Name_Range,
10396 Expressions => New_List (
10397 Make_Integer_Literal (Loc, Depth))))),
10398 Statements => Inner_Stmts);
10400 if Constrained then
10401 Append_To (Stmts, Loop_Stm);
10406 Decls : constant List_Id := New_List;
10407 Dimen_Stmts : constant List_Id := New_List;
10408 Length_Node : Node_Id;
10410 Inner_Any_TypeCode : constant Entity_Id :=
10411 Make_Defining_Identifier (Loc,
10412 New_External_Name ('T', Depth));
10414 Inner_Any_TypeCode_Expr : Node_Id;
10418 Inner_Any_TypeCode_Expr :=
10419 Make_Function_Call (Loc,
10421 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
10422 Parameter_Associations => New_List (
10423 New_Occurrence_Of (Any, Loc),
10424 Make_Integer_Literal (Loc, Ndim)));
10426 Inner_Any_TypeCode_Expr :=
10427 Make_Function_Call (Loc,
10429 New_Occurrence_Of (RTE (RE_Content_Type), Loc),
10430 Parameter_Associations => New_List (
10431 Make_Identifier (Loc,
10432 New_External_Name ('T', Depth - 1))));
10436 Make_Object_Declaration (Loc,
10437 Defining_Identifier => Inner_Any_TypeCode,
10438 Constant_Present => True,
10439 Object_Definition => New_Occurrence_Of (
10440 RTE (RE_TypeCode), Loc),
10441 Expression => Inner_Any_TypeCode_Expr));
10443 Make_Object_Declaration (Loc,
10444 Defining_Identifier => Inner_Any,
10445 Object_Definition =>
10446 New_Occurrence_Of (RTE (RE_Any), Loc),
10448 Make_Function_Call (Loc,
10450 New_Occurrence_Of (
10451 RTE (RE_Create_Any), Loc),
10452 Parameter_Associations => New_List (
10453 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
10455 if Present (Inner_Counter) then
10457 Make_Object_Declaration (Loc,
10458 Defining_Identifier => Inner_Counter,
10459 Object_Definition =>
10460 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
10462 Make_Integer_Literal (Loc, 0)));
10465 Length_Node := Make_Attribute_Reference (Loc,
10466 Prefix => New_Occurrence_Of (Arry, Loc),
10467 Attribute_Name => Name_Length,
10469 New_List (Make_Integer_Literal (Loc, Depth)));
10470 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
10472 Add_Process_Element (Dimen_Stmts,
10473 Datum => Length_Node,
10475 Counter => Inner_Counter);
10477 -- Loop_Stm does approrpriate processing for each element
10480 Append_To (Dimen_Stmts, Loop_Stm);
10482 -- Link outer and inner any
10484 Add_Process_Element (Dimen_Stmts,
10486 Counter => Counter,
10487 Datum => New_Occurrence_Of (Inner_Any, Loc));
10490 Make_Block_Statement (Loc,
10493 Handled_Statement_Sequence =>
10494 Make_Handled_Sequence_Of_Statements (Loc,
10495 Statements => Dimen_Stmts)));
10497 end Append_Array_Traversal;
10499 -----------------------------------------
10500 -- Make_Stream_Procedure_Function_Name --
10501 -----------------------------------------
10503 function Make_Stream_Procedure_Function_Name
10506 Nam : Name_Id) return Entity_Id
10509 -- For tagged types, we use a canonical name so that it matches
10510 -- the primitive spec. For all other cases, we use a serialized
10511 -- name so that multiple generations of the same procedure do not
10514 if Is_Tagged_Type (Typ) then
10515 return Make_Defining_Identifier (Loc, Nam);
10517 return Make_Defining_Identifier (Loc,
10519 New_External_Name (Nam, ' ', Increment_Serial_Number));
10521 end Make_Stream_Procedure_Function_Name;
10524 -----------------------------------
10525 -- Reserve_NamingContext_Methods --
10526 -----------------------------------
10528 procedure Reserve_NamingContext_Methods is
10529 Str_Resolve : constant String := "resolve";
10531 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
10532 Name_Len := Str_Resolve'Length;
10533 Overload_Counter_Table.Set (Name_Find, 1);
10534 end Reserve_NamingContext_Methods;
10536 end PolyORB_Support;
10538 -------------------------------
10539 -- RACW_Type_Is_Asynchronous --
10540 -------------------------------
10542 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
10543 Asynchronous_Flag : constant Entity_Id :=
10544 Asynchronous_Flags_Table.Get (RACW_Type);
10546 Replace (Expression (Parent (Asynchronous_Flag)),
10547 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
10548 end RACW_Type_Is_Asynchronous;
10550 -------------------------
10551 -- RCI_Package_Locator --
10552 -------------------------
10554 function RCI_Package_Locator
10556 Package_Spec : Node_Id) return Node_Id
10559 Pkg_Name : String_Id;
10562 Get_Library_Unit_Name_String (Package_Spec);
10563 Pkg_Name := String_From_Name_Buffer;
10565 Make_Package_Instantiation (Loc,
10566 Defining_Unit_Name =>
10567 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
10569 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
10570 Generic_Associations => New_List (
10571 Make_Generic_Association (Loc,
10573 Make_Identifier (Loc, Name_RCI_Name),
10574 Explicit_Generic_Actual_Parameter =>
10575 Make_String_Literal (Loc,
10576 Strval => Pkg_Name))));
10578 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
10579 Defining_Unit_Name (Inst));
10581 end RCI_Package_Locator;
10583 -----------------------------------------------
10584 -- Remote_Types_Tagged_Full_View_Encountered --
10585 -----------------------------------------------
10587 procedure Remote_Types_Tagged_Full_View_Encountered
10588 (Full_View : Entity_Id)
10590 Stub_Elements : constant Stub_Structure :=
10591 Stubs_Table.Get (Full_View);
10593 if Stub_Elements /= Empty_Stub_Structure then
10594 Add_RACW_Primitive_Declarations_And_Bodies
10596 Stub_Elements.RPC_Receiver_Decl,
10597 List_Containing (Declaration_Node (Full_View)));
10599 end Remote_Types_Tagged_Full_View_Encountered;
10601 -------------------
10602 -- Scope_Of_Spec --
10603 -------------------
10605 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
10606 Unit_Name : Node_Id := Defining_Unit_Name (Spec);
10609 while Nkind (Unit_Name) /= N_Defining_Identifier loop
10610 Unit_Name := Defining_Identifier (Unit_Name);
10616 ----------------------
10617 -- Set_Renaming_TSS --
10618 ----------------------
10620 procedure Set_Renaming_TSS
10623 TSS_Nam : TSS_Name_Type)
10625 Loc : constant Source_Ptr := Sloc (Nam);
10626 Spec : constant Node_Id := Parent (Nam);
10628 TSS_Node : constant Node_Id :=
10629 Make_Subprogram_Renaming_Declaration (Loc,
10631 Copy_Specification (Loc,
10633 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
10634 Name => New_Occurrence_Of (Nam, Loc));
10636 Snam : constant Entity_Id :=
10637 Defining_Unit_Name (Specification (TSS_Node));
10640 if Nkind (Spec) = N_Function_Specification then
10641 Set_Ekind (Snam, E_Function);
10642 Set_Etype (Snam, Entity (Subtype_Mark (Spec)));
10644 Set_Ekind (Snam, E_Procedure);
10645 Set_Etype (Snam, Standard_Void_Type);
10648 Set_TSS (Typ, Snam);
10649 end Set_Renaming_TSS;
10651 ----------------------------------------------
10652 -- Specific_Add_Obj_RPC_Receiver_Completion --
10653 ----------------------------------------------
10655 procedure Specific_Add_Obj_RPC_Receiver_Completion
10658 RPC_Receiver : Entity_Id;
10659 Stub_Elements : Stub_Structure) is
10661 case Get_PCS_Name is
10662 when Name_PolyORB_DSA =>
10663 PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
10664 Decls, RPC_Receiver, Stub_Elements);
10666 GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
10667 Decls, RPC_Receiver, Stub_Elements);
10669 end Specific_Add_Obj_RPC_Receiver_Completion;
10671 --------------------------------
10672 -- Specific_Add_RACW_Features --
10673 --------------------------------
10675 procedure Specific_Add_RACW_Features
10676 (RACW_Type : Entity_Id;
10678 Stub_Type : Entity_Id;
10679 Stub_Type_Access : Entity_Id;
10680 RPC_Receiver_Decl : Node_Id;
10681 Declarations : List_Id) is
10683 case Get_PCS_Name is
10684 when Name_PolyORB_DSA =>
10685 PolyORB_Support.Add_RACW_Features (
10694 GARLIC_Support.Add_RACW_Features (
10701 end Specific_Add_RACW_Features;
10703 --------------------------------
10704 -- Specific_Add_RAST_Features --
10705 --------------------------------
10707 procedure Specific_Add_RAST_Features
10708 (Vis_Decl : Node_Id;
10709 RAS_Type : Entity_Id) is
10711 case Get_PCS_Name is
10712 when Name_PolyORB_DSA =>
10713 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
10715 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
10717 end Specific_Add_RAST_Features;
10719 --------------------------------------------------
10720 -- Specific_Add_Receiving_Stubs_To_Declarations --
10721 --------------------------------------------------
10723 procedure Specific_Add_Receiving_Stubs_To_Declarations
10724 (Pkg_Spec : Node_Id;
10728 case Get_PCS_Name is
10729 when Name_PolyORB_DSA =>
10730 PolyORB_Support.Add_Receiving_Stubs_To_Declarations (
10733 GARLIC_Support.Add_Receiving_Stubs_To_Declarations (
10736 end Specific_Add_Receiving_Stubs_To_Declarations;
10738 ------------------------------------------
10739 -- Specific_Build_General_Calling_Stubs --
10740 ------------------------------------------
10742 procedure Specific_Build_General_Calling_Stubs
10744 Statements : List_Id;
10745 Target : RPC_Target;
10746 Subprogram_Id : Node_Id;
10747 Asynchronous : Node_Id := Empty;
10748 Is_Known_Asynchronous : Boolean := False;
10749 Is_Known_Non_Asynchronous : Boolean := False;
10750 Is_Function : Boolean;
10752 Stub_Type : Entity_Id := Empty;
10753 RACW_Type : Entity_Id := Empty;
10757 case Get_PCS_Name is
10758 when Name_PolyORB_DSA =>
10759 PolyORB_Support.Build_General_Calling_Stubs (
10765 Is_Known_Asynchronous,
10766 Is_Known_Non_Asynchronous,
10773 GARLIC_Support.Build_General_Calling_Stubs (
10777 Target.RPC_Receiver,
10780 Is_Known_Asynchronous,
10781 Is_Known_Non_Asynchronous,
10788 end Specific_Build_General_Calling_Stubs;
10790 --------------------------------------
10791 -- Specific_Build_RPC_Receiver_Body --
10792 --------------------------------------
10794 procedure Specific_Build_RPC_Receiver_Body
10795 (RPC_Receiver : Entity_Id;
10796 Request : out Entity_Id;
10797 Subp_Id : out Entity_Id;
10798 Subp_Index : out Entity_Id;
10799 Stmts : out List_Id;
10800 Decl : out Node_Id)
10803 case Get_PCS_Name is
10804 when Name_PolyORB_DSA =>
10805 PolyORB_Support.Build_RPC_Receiver_Body
10813 GARLIC_Support.Build_RPC_Receiver_Body
10821 end Specific_Build_RPC_Receiver_Body;
10823 --------------------------------
10824 -- Specific_Build_Stub_Target --
10825 --------------------------------
10827 function Specific_Build_Stub_Target
10830 RCI_Locator : Entity_Id;
10831 Controlling_Parameter : Entity_Id) return RPC_Target is
10833 case Get_PCS_Name is
10834 when Name_PolyORB_DSA =>
10835 return PolyORB_Support.Build_Stub_Target (Loc,
10836 Decls, RCI_Locator, Controlling_Parameter);
10838 return GARLIC_Support.Build_Stub_Target (Loc,
10839 Decls, RCI_Locator, Controlling_Parameter);
10841 end Specific_Build_Stub_Target;
10843 ------------------------------
10844 -- Specific_Build_Stub_Type --
10845 ------------------------------
10847 procedure Specific_Build_Stub_Type
10848 (RACW_Type : Entity_Id;
10849 Stub_Type : Entity_Id;
10850 Stub_Type_Decl : out Node_Id;
10851 RPC_Receiver_Decl : out Node_Id)
10854 case Get_PCS_Name is
10855 when Name_PolyORB_DSA =>
10856 PolyORB_Support.Build_Stub_Type (
10857 RACW_Type, Stub_Type,
10858 Stub_Type_Decl, RPC_Receiver_Decl);
10860 GARLIC_Support.Build_Stub_Type (
10861 RACW_Type, Stub_Type,
10862 Stub_Type_Decl, RPC_Receiver_Decl);
10864 end Specific_Build_Stub_Type;
10866 function Specific_Build_Subprogram_Receiving_Stubs
10867 (Vis_Decl : Node_Id;
10868 Asynchronous : Boolean;
10869 Dynamically_Asynchronous : Boolean := False;
10870 Stub_Type : Entity_Id := Empty;
10871 RACW_Type : Entity_Id := Empty;
10872 Parent_Primitive : Entity_Id := Empty) return Node_Id is
10874 case Get_PCS_Name is
10875 when Name_PolyORB_DSA =>
10876 return PolyORB_Support.Build_Subprogram_Receiving_Stubs (
10879 Dynamically_Asynchronous,
10884 return GARLIC_Support.Build_Subprogram_Receiving_Stubs (
10887 Dynamically_Asynchronous,
10892 end Specific_Build_Subprogram_Receiving_Stubs;
10894 --------------------------
10895 -- Underlying_RACW_Type --
10896 --------------------------
10898 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
10899 Record_Type : Entity_Id;
10902 if Ekind (RAS_Typ) = E_Record_Type then
10903 Record_Type := RAS_Typ;
10905 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
10906 Record_Type := Equivalent_Type (RAS_Typ);
10910 Etype (Subtype_Indication (
10911 Component_Definition (
10912 First (Component_Items (Component_List (
10913 Type_Definition (Declaration_Node (Record_Type))))))));
10914 end Underlying_RACW_Type;