1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Exp_Atag; use Exp_Atag;
31 with Exp_Strm; use Exp_Strm;
32 with Exp_Tss; use Exp_Tss;
33 with Exp_Util; use Exp_Util;
35 with Nlists; use Nlists;
36 with Nmake; use Nmake;
38 with Rtsfind; use Rtsfind;
40 with Sem_Cat; use Sem_Cat;
41 with Sem_Ch3; use Sem_Ch3;
42 with Sem_Ch8; use Sem_Ch8;
43 with Sem_Dist; use Sem_Dist;
44 with Sem_Eval; use Sem_Eval;
45 with Sem_Util; use Sem_Util;
46 with Sinfo; use Sinfo;
47 with 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 with GNAT.HTable; use GNAT.HTable;
56 package body Exp_Dist is
58 -- The following model has been used to implement distributed objects:
59 -- given a designated type D and a RACW type R, then a record of the
62 -- type Stub is tagged record
63 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
66 -- is built. This type has two properties:
68 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
69 -- converted to and from this type to make it suitable for
70 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
71 -- to avoid memory leaks when the same remote object arrive on the
72 -- same partition through several paths;
74 -- 2) It also has the same dispatching table as the designated type D,
75 -- and thus can be used as an object designated by a value of type
76 -- R on any partition other than the one on which the object has
77 -- been created, since only dispatching calls will be performed and
78 -- the fields themselves will not be used. We call Derive_Subprograms
79 -- to fake half a derivation to ensure that the subprograms do have
80 -- the same dispatching table.
82 First_RCI_Subprogram_Id : constant := 2;
83 -- RCI subprograms are numbered starting at 2. The RCI receiver for
84 -- an RCI package can thus identify calls received through remote
85 -- access-to-subprogram dereferences by the fact that they have a
86 -- (primitive) subprogram id of 0, and 1 is used for the internal
87 -- RAS information lookup operation. (This is for the Garlic code
88 -- generation, where subprograms are identified by numbers; in the
89 -- PolyORB version, they are identified by name, with a numeric suffix
92 type Hash_Index is range 0 .. 50;
94 -----------------------
95 -- Local subprograms --
96 -----------------------
98 function Hash (F : Entity_Id) return Hash_Index;
99 -- DSA expansion associates stubs to distributed object types using
100 -- a hash table on entity ids.
102 function Hash (F : Name_Id) return Hash_Index;
103 -- The generation of subprogram identifiers requires an overload counter
104 -- to be associated with each remote subprogram names. These counters
105 -- are maintained in a hash table on name ids.
107 type Subprogram_Identifiers is record
108 Str_Identifier : String_Id;
109 Int_Identifier : Int;
112 package Subprogram_Identifier_Table is
113 new Simple_HTable (Header_Num => Hash_Index,
114 Element => Subprogram_Identifiers,
115 No_Element => (No_String, 0),
119 -- Mapping between a remote subprogram and the corresponding
120 -- subprogram identifiers.
122 package Overload_Counter_Table is
123 new Simple_HTable (Header_Num => Hash_Index,
129 -- Mapping between a subprogram name and an integer that
130 -- counts the number of defining subprogram names with that
131 -- Name_Id encountered so far in a given context (an interface).
133 function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
134 function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
135 function Get_Subprogram_Id (Def : Entity_Id) return Int;
136 -- Given a subprogram defined in a RCI package, get its distribution
137 -- subprogram identifiers (the distribution identifiers are a unique
138 -- subprogram number, and the non-qualified subprogram name, in the
139 -- casing used for the subprogram declaration; if the name is overloaded,
140 -- a double underscore and a serial number are appended.
142 -- The integer identifier is used to perform remote calls with GARLIC;
143 -- the string identifier is used in the case of PolyORB.
145 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
146 -- when receiving a call, the calling stubs will create requests with the
147 -- exact casing of the defining unit name of the called subprogram, so as
148 -- to allow calls to subprograms on distributed nodes that do distinguish
151 -- NOTE: Another design would be to allow a representation clause on
152 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
154 pragma Warnings (Off, Get_Subprogram_Id);
155 -- One homonym only is unreferenced (specific to the GARLIC version)
157 procedure Add_RAS_Dereference_TSS (N : Node_Id);
158 -- Add a subprogram body for RAS Dereference TSS
160 procedure Add_RAS_Proxy_And_Analyze
163 All_Calls_Remote_E : Entity_Id;
164 Proxy_Object_Addr : out Entity_Id);
165 -- Add the proxy type required, on the receiving (server) side, to handle
166 -- calls to the subprogram declared by Vis_Decl through a remote access
167 -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
168 -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
169 -- is appended to Decls. Proxy_Object_Addr is a constant of type
170 -- System.Address that designates an instance of the proxy object.
172 function Build_Remote_Subprogram_Proxy_Type
174 ACR_Expression : Node_Id) return Node_Id;
175 -- Build and return a tagged record type definition for an RCI
176 -- subprogram proxy type.
177 -- ACR_Expression is use as the initialization value for
178 -- the All_Calls_Remote component.
180 function Build_Get_Unique_RP_Call
183 Stub_Type : Entity_Id) return List_Id;
184 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
185 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
186 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
188 function Build_Subprogram_Calling_Stubs
191 Asynchronous : Boolean;
192 Dynamically_Asynchronous : Boolean := False;
193 Stub_Type : Entity_Id := Empty;
194 RACW_Type : Entity_Id := Empty;
195 Locator : Entity_Id := Empty;
196 New_Name : Name_Id := No_Name) return Node_Id;
197 -- Build the calling stub for a given subprogram with the subprogram ID
198 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
199 -- parameters of this type will be marshalled instead of the object
200 -- itself. It will then be converted into Stub_Type before performing
201 -- the real call. If Dynamically_Asynchronous is True, then it will be
202 -- computed at run time whether the call is asynchronous or not.
203 -- Otherwise, the value of the formal Asynchronous will be used.
204 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
205 -- New_Name is given, then it will be used instead of the original name.
207 function Build_RPC_Receiver_Specification
208 (RPC_Receiver : Entity_Id;
209 Request_Parameter : Entity_Id) return Node_Id;
210 -- Make a subprogram specification for an RPC receiver, with the given
211 -- defining unit name and formal parameter.
213 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
214 -- Return an ordered parameter list: unconstrained parameters are put
215 -- at the beginning of the list and constrained ones are put after. If
216 -- there are no parameters, an empty list is returned. Special case:
217 -- the controlling formal of the equivalent RACW operation for a RAS
218 -- type is always left in first position.
220 procedure Add_Calling_Stubs_To_Declarations
223 -- Add calling stubs to the declarative part
225 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
226 -- Return True if nothing prevents the program whose specification is
227 -- given to be asynchronous (i.e. no out parameter).
229 function Pack_Entity_Into_Stream_Access
233 Etyp : Entity_Id := Empty) return Node_Id;
234 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
235 -- then Etype (Object) will be used if present. If the type is
236 -- constrained, then 'Write will be used to output the object,
237 -- If the type is unconstrained, 'Output will be used.
239 function Pack_Node_Into_Stream
243 Etyp : Entity_Id) return Node_Id;
244 -- Similar to above, with an arbitrary node instead of an entity
246 function Pack_Node_Into_Stream_Access
250 Etyp : Entity_Id) return Node_Id;
251 -- Similar to above, with Stream instead of Stream'Access
253 function Make_Selected_Component
256 Selector_Name : Name_Id) return Node_Id;
257 -- Return a selected_component whose prefix denotes the given entity,
258 -- and with the given Selector_Name.
260 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
261 -- Return the scope represented by a given spec
263 procedure Set_Renaming_TSS
266 TSS_Nam : TSS_Name_Type);
267 -- Create a renaming declaration of subprogram Nam,
268 -- and register it as a TSS for Typ with name TSS_Nam.
270 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
271 -- Return True if the current parameter needs an extra formal to reflect
272 -- its constrained status.
274 function Is_RACW_Controlling_Formal
275 (Parameter : Node_Id;
276 Stub_Type : Entity_Id) return Boolean;
277 -- Return True if the current parameter is a controlling formal argument
278 -- of type Stub_Type or access to Stub_Type.
280 procedure Declare_Create_NVList
285 -- Append the declaration of NVList to Decls, and its
286 -- initialization to Stmts.
288 function Add_Parameter_To_NVList
291 Parameter : Entity_Id;
292 Constrained : Boolean;
293 RACW_Ctrl : Boolean := False;
294 Any : Entity_Id) return Node_Id;
295 -- Return a call to Add_Item to add the Any corresponding to the designated
296 -- formal Parameter (with the indicated Constrained status) to NVList.
297 -- RACW_Ctrl must be set to True for controlling formals of distributed
298 -- object primitive operations.
304 -- This record describes various tree fragments associated with the
305 -- generation of RACW calling stubs. One such record exists for every
306 -- distributed object type, i.e. each tagged type that is the designated
307 -- type of one or more RACW type.
309 type Stub_Structure is record
310 Stub_Type : Entity_Id;
311 -- Stub type: this type has the same primitive operations as the
312 -- designated types, but the provided bodies for these operations
313 -- a remote call to an actual target object potentially located on
314 -- another partition; each value of the stub type encapsulates a
315 -- reference to a remote object.
317 Stub_Type_Access : Entity_Id;
318 -- A local access type designating the stub type (this is not an RACW
321 RPC_Receiver_Decl : Node_Id;
322 -- Declaration for the RPC receiver entity associated with the
323 -- designated type. As an exception, for the case of an RACW that
324 -- implements a RAS, no object RPC receiver is generated. Instead,
325 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
326 -- would have been inserted.
328 Body_Decls : List_Id;
329 -- List of subprogram bodies to be included in generated code: bodies
330 -- for the RACW's stream attributes, and for the primitive operations
333 RACW_Type : Entity_Id;
334 -- One of the RACW types designating this distributed object type
335 -- (they are all interchangeable; we use any one of them in order to
336 -- avoid having to create various anonymous access types).
340 Empty_Stub_Structure : constant Stub_Structure :=
341 (Empty, Empty, Empty, No_List, Empty);
343 package Stubs_Table is
344 new Simple_HTable (Header_Num => Hash_Index,
345 Element => Stub_Structure,
346 No_Element => Empty_Stub_Structure,
350 -- Mapping between a RACW designated type and its stub type
352 package Asynchronous_Flags_Table is
353 new Simple_HTable (Header_Num => Hash_Index,
354 Element => Entity_Id,
359 -- Mapping between a RACW type and a constant having the value True
360 -- if the RACW is asynchronous and False otherwise.
362 package RCI_Locator_Table is
363 new Simple_HTable (Header_Num => Hash_Index,
364 Element => Entity_Id,
369 -- Mapping between a RCI package on which All_Calls_Remote applies and
370 -- the generic instantiation of RCI_Locator for this package.
372 package RCI_Calling_Stubs_Table is
373 new Simple_HTable (Header_Num => Hash_Index,
374 Element => Entity_Id,
379 -- Mapping between a RCI subprogram and the corresponding calling stubs
381 procedure Add_Stub_Type
382 (Designated_Type : Entity_Id;
383 RACW_Type : Entity_Id;
385 Stub_Type : out Entity_Id;
386 Stub_Type_Access : out Entity_Id;
387 RPC_Receiver_Decl : out Node_Id;
388 Body_Decls : out List_Id;
389 Existing : out Boolean);
390 -- Add the declaration of the stub type, the access to stub type and the
391 -- object RPC receiver at the end of Decls. If these already exist,
392 -- then nothing is added in the tree but the right values are returned
393 -- anyhow and Existing is set to True.
395 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
396 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
397 -- structure table, reset it to No_List, and return the previous value.
399 procedure Add_RACW_Asynchronous_Flag
400 (Declarations : List_Id;
401 RACW_Type : Entity_Id);
402 -- Declare a boolean constant associated with RACW_Type whose value
403 -- indicates at run time whether a pragma Asynchronous applies to it.
405 procedure Assign_Subprogram_Identifier
409 -- Determine the distribution subprogram identifier to
410 -- be used for remote subprogram Def, return it in Id and
411 -- store it in a hash table for later retrieval by
412 -- Get_Subprogram_Id. Spn is the subprogram number.
414 function RCI_Package_Locator
416 Package_Spec : Node_Id) return Node_Id;
417 -- Instantiate the generic package RCI_Locator in order to locate the
418 -- RCI package whose spec is given as argument.
420 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
421 -- Surround a node N by a tag check, as in:
425 -- when E : Ada.Tags.Tag_Error =>
426 -- Raise_Exception (Program_Error'Identity,
427 -- Exception_Message (E));
430 function Input_With_Tag_Check
432 Var_Type : Entity_Id;
433 Stream : Node_Id) return Node_Id;
434 -- Return a function with the following form:
435 -- function R return Var_Type is
437 -- return Var_Type'Input (S);
439 -- when E : Ada.Tags.Tag_Error =>
440 -- Raise_Exception (Program_Error'Identity,
441 -- Exception_Message (E));
444 procedure Build_Actual_Object_Declaration
450 -- Build the declaration of an object with the given defining identifier,
451 -- initialized with Expr if provided, to serve as actual parameter in a
452 -- server stub. If Variable is true, the declared object will be a variable
453 -- (case of an out or in out formal), else it will be a constant. Object's
454 -- Ekind is set accordingly. The declaration, as well as any other
455 -- declarations it requires, are appended to Decls.
457 --------------------------------------------
458 -- Hooks for PCS-specific code generation --
459 --------------------------------------------
461 -- Part of the code generation circuitry for distribution needs to be
462 -- tailored for each implementation of the PCS. For each routine that
463 -- needs to be specialized, a Specific_<routine> wrapper is created,
464 -- which calls the corresponding <routine> in package
465 -- <pcs_implementation>_Support.
467 procedure Specific_Add_RACW_Features
468 (RACW_Type : Entity_Id;
470 Stub_Type : Entity_Id;
471 Stub_Type_Access : Entity_Id;
472 RPC_Receiver_Decl : Node_Id;
473 Body_Decls : List_Id);
474 -- Add declaration for TSSs for a given RACW type. The declarations are
475 -- added just after the declaration of the RACW type itself, while the
476 -- bodies are inserted at the end of Body_Decls. Runtime-specific ancillary
477 -- subprogram for Add_RACW_Features.
479 procedure Specific_Add_RAST_Features
481 RAS_Type : Entity_Id);
482 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
483 -- subprogram for Add_RAST_Features.
485 -- An RPC_Target record is used during construction of calling stubs
486 -- to pass PCS-specific tree fragments corresponding to the information
487 -- necessary to locate the target of a remote subprogram call.
489 type RPC_Target (PCS_Kind : PCS_Names) is record
491 when Name_PolyORB_DSA =>
493 -- An expression whose value is a PolyORB reference to the target
497 Partition : Entity_Id;
498 -- A variable containing the Partition_ID of the target parition
500 RPC_Receiver : Node_Id;
501 -- An expression whose value is the address of the target RPC
506 procedure Specific_Build_General_Calling_Stubs
508 Statements : List_Id;
510 Subprogram_Id : Node_Id;
511 Asynchronous : Node_Id := Empty;
512 Is_Known_Asynchronous : Boolean := False;
513 Is_Known_Non_Asynchronous : Boolean := False;
514 Is_Function : Boolean;
516 Stub_Type : Entity_Id := Empty;
517 RACW_Type : Entity_Id := Empty;
519 -- Build calling stubs for general purpose. The parameters are:
520 -- Decls : a place to put declarations
521 -- Statements : a place to put statements
522 -- Target : PCS-specific target information (see details
523 -- in RPC_Target declaration).
524 -- Subprogram_Id : a node containing the subprogram ID
525 -- Asynchronous : True if an APC must be made instead of an RPC.
526 -- The value needs not be supplied if one of the
527 -- Is_Known_... is True.
528 -- Is_Known_Async... : True if we know that this is asynchronous
529 -- Is_Known_Non_A... : True if we know that this is not asynchronous
530 -- Spec : a node with a Parameter_Specifications and
531 -- a Result_Definition if applicable
532 -- Stub_Type : in case of RACW stubs, parameters of type access
533 -- to Stub_Type will be marshalled using the
534 -- address of the object (the addr field) rather
535 -- than using the 'Write on the stub itself
536 -- Nod : used to provide sloc for generated code
538 function Specific_Build_Stub_Target
541 RCI_Locator : Entity_Id;
542 Controlling_Parameter : Entity_Id) return RPC_Target;
543 -- Build call target information nodes for use within calling stubs. In the
544 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
545 -- for an RACW, Controlling_Parameter is the entity for the controlling
546 -- formal parameter used to determine the location of the target of the
547 -- call. Decls provides a location where variable declarations can be
548 -- appended to construct the necessary values.
550 procedure Specific_Build_Stub_Type
551 (RACW_Type : Entity_Id;
552 Stub_Type : Entity_Id;
553 Stub_Type_Decl : out Node_Id;
554 RPC_Receiver_Decl : out Node_Id);
555 -- Build a type declaration for the stub type associated with an RACW
556 -- type, and the necessary RPC receiver, if applicable. PCS-specific
557 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
558 -- is generated, then RPC_Receiver_Decl is set to Empty.
560 procedure Specific_Build_RPC_Receiver_Body
561 (RPC_Receiver : Entity_Id;
562 Request : out Entity_Id;
563 Subp_Id : out Entity_Id;
564 Subp_Index : out Entity_Id;
567 -- Make a subprogram body for an RPC receiver, with the given
568 -- defining unit name. On return:
569 -- - Subp_Id is the subprogram identifier from the PCS.
570 -- - Subp_Index is the index in the list of subprograms
571 -- used for dispatching (a variable of type Subprogram_Id).
572 -- - Stmts is the place where the request dispatching
573 -- statements can occur,
574 -- - Decl is the subprogram body declaration.
576 function Specific_Build_Subprogram_Receiving_Stubs
578 Asynchronous : Boolean;
579 Dynamically_Asynchronous : Boolean := False;
580 Stub_Type : Entity_Id := Empty;
581 RACW_Type : Entity_Id := Empty;
582 Parent_Primitive : Entity_Id := Empty) return Node_Id;
583 -- Build the receiving stub for a given subprogram. The subprogram
584 -- declaration is also built by this procedure, and the value returned
585 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
586 -- found in the specification, then its address is read from the stream
587 -- instead of the object itself and converted into an access to
588 -- class-wide type before doing the real call using any of the RACW type
589 -- pointing on the designated type.
591 procedure Specific_Add_Obj_RPC_Receiver_Completion
594 RPC_Receiver : Entity_Id;
595 Stub_Elements : Stub_Structure);
596 -- Add the necessary code to Decls after the completion of generation
597 -- of the RACW RPC receiver described by Stub_Elements.
599 procedure Specific_Add_Receiving_Stubs_To_Declarations
603 -- Add receiving stubs to the declarative part of an RCI unit
605 package GARLIC_Support is
607 -- Support for generating DSA code that uses the GARLIC PCS
609 -- The subprograms below provide the GARLIC versions of the
610 -- corresponding Specific_<subprogram> routine declared above.
612 procedure Add_RACW_Features
613 (RACW_Type : Entity_Id;
614 Stub_Type : Entity_Id;
615 Stub_Type_Access : Entity_Id;
616 RPC_Receiver_Decl : Node_Id;
617 Body_Decls : List_Id);
619 procedure Add_RAST_Features
621 RAS_Type : Entity_Id);
623 procedure Build_General_Calling_Stubs
625 Statements : List_Id;
626 Target_Partition : Entity_Id; -- From RPC_Target
627 Target_RPC_Receiver : Node_Id; -- From RPC_Target
628 Subprogram_Id : Node_Id;
629 Asynchronous : Node_Id := Empty;
630 Is_Known_Asynchronous : Boolean := False;
631 Is_Known_Non_Asynchronous : Boolean := False;
632 Is_Function : Boolean;
634 Stub_Type : Entity_Id := Empty;
635 RACW_Type : Entity_Id := Empty;
638 function Build_Stub_Target
641 RCI_Locator : Entity_Id;
642 Controlling_Parameter : Entity_Id) return RPC_Target;
644 procedure Build_Stub_Type
645 (RACW_Type : Entity_Id;
646 Stub_Type : Entity_Id;
647 Stub_Type_Decl : out Node_Id;
648 RPC_Receiver_Decl : out Node_Id);
650 function Build_Subprogram_Receiving_Stubs
652 Asynchronous : Boolean;
653 Dynamically_Asynchronous : Boolean := False;
654 Stub_Type : Entity_Id := Empty;
655 RACW_Type : Entity_Id := Empty;
656 Parent_Primitive : Entity_Id := Empty) return Node_Id;
658 procedure Add_Obj_RPC_Receiver_Completion
661 RPC_Receiver : Entity_Id;
662 Stub_Elements : Stub_Structure);
664 procedure Add_Receiving_Stubs_To_Declarations
669 procedure Build_RPC_Receiver_Body
670 (RPC_Receiver : Entity_Id;
671 Request : out Entity_Id;
672 Subp_Id : out Entity_Id;
673 Subp_Index : out Entity_Id;
679 package PolyORB_Support is
681 -- Support for generating DSA code that uses the PolyORB PCS
683 -- The subprograms below provide the PolyORB versions of the
684 -- corresponding Specific_<subprogram> routine declared above.
686 procedure Add_RACW_Features
687 (RACW_Type : Entity_Id;
689 Stub_Type : Entity_Id;
690 Stub_Type_Access : Entity_Id;
691 RPC_Receiver_Decl : Node_Id;
692 Body_Decls : List_Id);
694 procedure Add_RAST_Features
696 RAS_Type : Entity_Id);
698 procedure Build_General_Calling_Stubs
700 Statements : List_Id;
701 Target_Object : Node_Id; -- From RPC_Target
702 Subprogram_Id : Node_Id;
703 Asynchronous : Node_Id := Empty;
704 Is_Known_Asynchronous : Boolean := False;
705 Is_Known_Non_Asynchronous : Boolean := False;
706 Is_Function : Boolean;
708 Stub_Type : Entity_Id := Empty;
709 RACW_Type : Entity_Id := Empty;
712 function Build_Stub_Target
715 RCI_Locator : Entity_Id;
716 Controlling_Parameter : Entity_Id) return RPC_Target;
718 procedure Build_Stub_Type
719 (RACW_Type : Entity_Id;
720 Stub_Type : Entity_Id;
721 Stub_Type_Decl : out Node_Id;
722 RPC_Receiver_Decl : out Node_Id);
724 function Build_Subprogram_Receiving_Stubs
726 Asynchronous : Boolean;
727 Dynamically_Asynchronous : Boolean := False;
728 Stub_Type : Entity_Id := Empty;
729 RACW_Type : Entity_Id := Empty;
730 Parent_Primitive : Entity_Id := Empty) return Node_Id;
732 procedure Add_Obj_RPC_Receiver_Completion
735 RPC_Receiver : Entity_Id;
736 Stub_Elements : Stub_Structure);
738 procedure Add_Receiving_Stubs_To_Declarations
743 procedure Build_RPC_Receiver_Body
744 (RPC_Receiver : Entity_Id;
745 Request : out Entity_Id;
746 Subp_Id : out Entity_Id;
747 Subp_Index : out Entity_Id;
751 procedure Reserve_NamingContext_Methods;
752 -- Mark the method names for interface NamingContext as already used in
753 -- the overload table, so no clashes occur with user code (with the
754 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
755 -- their methods to be accessed as objects, for the implementation of
756 -- remote access-to-subprogram types).
760 -- Routines to build distribtion helper subprograms for user-defined
761 -- types. For implementation of the Distributed systems annex (DSA)
762 -- over the PolyORB generic middleware components, it is necessary to
763 -- generate several supporting subprograms for each application data
764 -- type used in inter-partition communication. These subprograms are:
766 -- A Typecode function returning a high-level description of the
769 -- Two conversion functions allowing conversion of values of the
770 -- type from and to the generic data containers used by PolyORB.
771 -- These generic containers are called 'Any' type values after the
772 -- CORBA terminology, and hence the conversion subprograms are
773 -- named To_Any and From_Any.
775 function Build_From_Any_Call
778 Decls : List_Id) return Node_Id;
779 -- Build call to From_Any attribute function of type Typ with
780 -- expression N as actual parameter. Decls is the declarations list
781 -- for an appropriate enclosing scope of the point where the call
782 -- will be inserted; if the From_Any attribute for Typ needs to be
783 -- generated at this point, its declaration is appended to Decls.
785 procedure Build_From_Any_Function
789 Fnam : out Entity_Id);
790 -- Build From_Any attribute function for Typ. Loc is the reference
791 -- location for generated nodes, Typ is the type for which the
792 -- conversion function is generated. On return, Decl and Fnam contain
793 -- the declaration and entity for the newly-created function.
795 function Build_To_Any_Call
797 Decls : List_Id) return Node_Id;
798 -- Build call to To_Any attribute function with expression as actual
799 -- parameter. Decls is the declarations list for an appropriate
800 -- enclosing scope of the point where the call will be inserted; if
801 -- the To_Any attribute for Typ needs to be generated at this point,
802 -- its declaration is appended to Decls.
804 procedure Build_To_Any_Function
808 Fnam : out Entity_Id);
809 -- Build To_Any attribute function for Typ. Loc is the reference
810 -- location for generated nodes, Typ is the type for which the
811 -- conversion function is generated. On return, Decl and Fnam contain
812 -- the declaration and entity for the newly-created function.
814 function Build_TypeCode_Call
817 Decls : List_Id) return Node_Id;
818 -- Build call to TypeCode attribute function for Typ. Decls is the
819 -- declarations list for an appropriate enclosing scope of the point
820 -- where the call will be inserted; if the To_Any attribute for Typ
821 -- needs to be generated at this point, its declaration is appended
824 procedure Build_TypeCode_Function
828 Fnam : out Entity_Id);
829 -- Build TypeCode attribute function for Typ. Loc is the reference
830 -- location for generated nodes, Typ is the type for which the
831 -- conversion function is generated. On return, Decl and Fnam contain
832 -- the declaration and entity for the newly-created function.
834 procedure Build_Name_And_Repository_Id
836 Name_Str : out String_Id;
837 Repo_Id_Str : out String_Id);
838 -- In the PolyORB distribution model, each distributed object type
839 -- and each distributed operation has a globally unique identifier,
840 -- its Repository Id. This subprogram builds and returns two strings
841 -- for entity E (a distributed object type or operation): one
842 -- containing the name of E, the second containing its repository id.
848 ------------------------------------
849 -- Local variables and structures --
850 ------------------------------------
853 -- Needs comments ???
855 Output_From_Constrained : constant array (Boolean) of Name_Id :=
856 (False => Name_Output,
858 -- The attribute to choose depending on the fact that the parameter
859 -- is constrained or not. There is no such thing as Input_From_Constrained
860 -- since this require separate mechanisms ('Input is a function while
861 -- 'Read is a procedure).
863 ---------------------------------------
864 -- Add_Calling_Stubs_To_Declarations --
865 ---------------------------------------
867 procedure Add_Calling_Stubs_To_Declarations
871 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
872 -- Subprogram id 0 is reserved for calls received from
873 -- remote access-to-subprogram dereferences.
875 Current_Declaration : Node_Id;
876 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
877 RCI_Instantiation : Node_Id;
878 Subp_Stubs : Node_Id;
879 Subp_Str : String_Id;
882 -- The first thing added is an instantiation of the generic package
883 -- System.Partition_Interface.RCI_Locator with the name of this remote
884 -- package. This will act as an interface with the name server to
885 -- determine the Partition_ID and the RPC_Receiver for the receiver
888 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
889 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
891 Append_To (Decls, RCI_Instantiation);
892 Analyze (RCI_Instantiation);
894 -- For each subprogram declaration visible in the spec, we do build a
895 -- body. We also increment a counter to assign a different Subprogram_Id
896 -- to each subprograms. The receiving stubs processing do use the same
897 -- mechanism and will thus assign the same Id and do the correct
900 Overload_Counter_Table.Reset;
901 PolyORB_Support.Reserve_NamingContext_Methods;
903 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
905 while Present (Current_Declaration) loop
906 if Nkind (Current_Declaration) = N_Subprogram_Declaration
907 and then Comes_From_Source (Current_Declaration)
909 Assign_Subprogram_Identifier (
910 Defining_Unit_Name (Specification (Current_Declaration)),
911 Current_Subprogram_Number,
915 Build_Subprogram_Calling_Stubs (
916 Vis_Decl => Current_Declaration,
918 Build_Subprogram_Id (Loc,
919 Defining_Unit_Name (Specification (Current_Declaration))),
921 Nkind (Specification (Current_Declaration)) =
922 N_Procedure_Specification
924 Is_Asynchronous (Defining_Unit_Name (Specification
925 (Current_Declaration))));
927 Append_To (Decls, Subp_Stubs);
928 Analyze (Subp_Stubs);
930 Current_Subprogram_Number := Current_Subprogram_Number + 1;
933 Next (Current_Declaration);
935 end Add_Calling_Stubs_To_Declarations;
937 -----------------------------
938 -- Add_Parameter_To_NVList --
939 -----------------------------
941 function Add_Parameter_To_NVList
944 Parameter : Entity_Id;
945 Constrained : Boolean;
946 RACW_Ctrl : Boolean := False;
947 Any : Entity_Id) return Node_Id
949 Parameter_Name_String : String_Id;
950 Parameter_Mode : Node_Id;
952 function Parameter_Passing_Mode
954 Parameter : Entity_Id;
955 Constrained : Boolean) return Node_Id;
956 -- Return an expression that denotes the parameter passing
957 -- mode to be used for Parameter in distribution stubs,
958 -- where Constrained is Parameter's constrained status.
960 ----------------------------
961 -- Parameter_Passing_Mode --
962 ----------------------------
964 function Parameter_Passing_Mode
966 Parameter : Entity_Id;
967 Constrained : Boolean) return Node_Id
972 if Out_Present (Parameter) then
973 if In_Present (Parameter)
974 or else not Constrained
976 -- Unconstrained formals must be translated
977 -- to 'in' or 'inout', not 'out', because
978 -- they need to be constrained by the actual.
980 Lib_RE := RE_Mode_Inout;
982 Lib_RE := RE_Mode_Out;
986 Lib_RE := RE_Mode_In;
989 return New_Occurrence_Of (RTE (Lib_RE), Loc);
990 end Parameter_Passing_Mode;
992 -- Start of processing for Add_Parameter_To_NVList
995 if Nkind (Parameter) = N_Defining_Identifier then
996 Get_Name_String (Chars (Parameter));
998 Get_Name_String (Chars (Defining_Identifier (Parameter)));
1001 Parameter_Name_String := String_From_Name_Buffer;
1003 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1005 -- When the parameter passed to Add_Parameter_To_NVList is an
1006 -- Extra_Constrained parameter, Parameter is an N_Defining_
1007 -- Identifier, instead of a complete N_Parameter_Specification.
1008 -- Thus, we explicitly set 'in' mode in this case.
1010 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1014 Parameter_Passing_Mode (Loc, Parameter, Constrained);
1018 Make_Procedure_Call_Statement (Loc,
1021 (RTE (RE_NVList_Add_Item), Loc),
1022 Parameter_Associations => New_List (
1023 New_Occurrence_Of (NVList, Loc),
1024 Make_Function_Call (Loc,
1027 (RTE (RE_To_PolyORB_String), Loc),
1028 Parameter_Associations => New_List (
1029 Make_String_Literal (Loc,
1030 Strval => Parameter_Name_String))),
1031 New_Occurrence_Of (Any, Loc),
1033 end Add_Parameter_To_NVList;
1035 --------------------------------
1036 -- Add_RACW_Asynchronous_Flag --
1037 --------------------------------
1039 procedure Add_RACW_Asynchronous_Flag
1040 (Declarations : List_Id;
1041 RACW_Type : Entity_Id)
1043 Loc : constant Source_Ptr := Sloc (RACW_Type);
1045 Asynchronous_Flag : constant Entity_Id :=
1046 Make_Defining_Identifier (Loc,
1047 New_External_Name (Chars (RACW_Type), 'A'));
1050 -- Declare the asynchronous flag. This flag will be changed to True
1051 -- whenever it is known that the RACW type is asynchronous.
1053 Append_To (Declarations,
1054 Make_Object_Declaration (Loc,
1055 Defining_Identifier => Asynchronous_Flag,
1056 Constant_Present => True,
1057 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1058 Expression => New_Occurrence_Of (Standard_False, Loc)));
1060 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1061 end Add_RACW_Asynchronous_Flag;
1063 -----------------------
1064 -- Add_RACW_Features --
1065 -----------------------
1067 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1068 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1069 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1073 Body_Decls : List_Id;
1075 Stub_Type : Entity_Id;
1076 Stub_Type_Access : Entity_Id;
1077 RPC_Receiver_Decl : Node_Id;
1080 -- True when appropriate stubs have already been generated (this is the
1081 -- case when another RACW with the same designated type has already been
1082 -- encountered, in which case we reuse the previous stubs rather than
1083 -- generating new ones).
1086 if not Expander_Active then
1090 -- Mark the current package declaration as containing an RACW, so that
1091 -- the bodies for the calling stubs and the RACW stream subprograms
1092 -- are attached to the tree when the corresponding body is encountered.
1094 Set_Has_RACW (Current_Scope);
1096 -- Look for place to declare the RACW stub type and RACW operations
1102 -- Case of declaring the RACW in the same package as its designated
1103 -- type: we know that the designated type is a private type, so we
1104 -- use the private declarations list.
1106 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1108 if Present (Private_Declarations (Pkg_Spec)) then
1109 Decls := Private_Declarations (Pkg_Spec);
1111 Decls := Visible_Declarations (Pkg_Spec);
1116 -- Case of declaring the RACW in another package than its designated
1117 -- type: use the private declarations list if present; otherwise
1118 -- use the visible declarations.
1120 Decls := List_Containing (Declaration_Node (RACW_Type));
1124 -- If we were unable to find the declarations, that means that the
1125 -- completion of the type was missing. We can safely return and let the
1126 -- error be caught by the semantic analysis.
1133 (Designated_Type => Desig,
1134 RACW_Type => RACW_Type,
1136 Stub_Type => Stub_Type,
1137 Stub_Type_Access => Stub_Type_Access,
1138 RPC_Receiver_Decl => RPC_Receiver_Decl,
1139 Body_Decls => Body_Decls,
1140 Existing => Existing);
1142 Add_RACW_Asynchronous_Flag
1143 (Declarations => Decls,
1144 RACW_Type => RACW_Type);
1146 Specific_Add_RACW_Features
1147 (RACW_Type => RACW_Type,
1149 Stub_Type => Stub_Type,
1150 Stub_Type_Access => Stub_Type_Access,
1151 RPC_Receiver_Decl => RPC_Receiver_Decl,
1152 Body_Decls => Body_Decls);
1154 if not Same_Scope and then not Existing then
1156 -- The RACW has been declared in another scope than the designated
1157 -- type and has not been handled by another RACW in the same package
1158 -- as the first one, so add primitives for the stub type here.
1160 Validate_RACW_Primitives (RACW_Type);
1161 Add_RACW_Primitive_Declarations_And_Bodies
1162 (Designated_Type => Desig,
1163 Insertion_Node => RPC_Receiver_Decl,
1164 Body_Decls => Body_Decls);
1167 -- Validate_RACW_Primitives will be called when the designated type
1168 -- is frozen, see Exp_Ch3.Freeze_Type.
1170 -- ??? Shouldn't we have a pragma Assert (not Is_Frozen (Desig))?
1172 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1174 end Add_RACW_Features;
1176 ------------------------------------------------
1177 -- Add_RACW_Primitive_Declarations_And_Bodies --
1178 ------------------------------------------------
1180 procedure Add_RACW_Primitive_Declarations_And_Bodies
1181 (Designated_Type : Entity_Id;
1182 Insertion_Node : Node_Id;
1183 Body_Decls : List_Id)
1185 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1186 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1187 -- the declarations are recognized as belonging to the current package.
1189 Stub_Elements : constant Stub_Structure :=
1190 Stubs_Table.Get (Designated_Type);
1192 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1194 Is_RAS : constant Boolean :=
1195 not Comes_From_Source (Stub_Elements.RACW_Type);
1196 -- Case of the RACW generated to implement a remote access-to-
1199 Build_Bodies : constant Boolean :=
1200 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1201 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1202 -- only when the main unit is the unit that contains the stub type.
1204 Current_Insertion_Node : Node_Id := Insertion_Node;
1206 RPC_Receiver : Entity_Id;
1207 RPC_Receiver_Statements : List_Id;
1208 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1209 RPC_Receiver_Elsif_Parts : List_Id;
1210 RPC_Receiver_Request : Entity_Id;
1211 RPC_Receiver_Subp_Id : Entity_Id;
1212 RPC_Receiver_Subp_Index : Entity_Id;
1214 Subp_Str : String_Id;
1216 Current_Primitive_Elmt : Elmt_Id;
1217 Current_Primitive : Entity_Id;
1218 Current_Primitive_Body : Node_Id;
1219 Current_Primitive_Spec : Node_Id;
1220 Current_Primitive_Decl : Node_Id;
1221 Current_Primitive_Number : Int := 0;
1222 Current_Primitive_Alias : Node_Id;
1223 Current_Receiver : Entity_Id;
1224 Current_Receiver_Body : Node_Id;
1225 RPC_Receiver_Decl : Node_Id;
1226 Possibly_Asynchronous : Boolean;
1229 if not Expander_Active then
1235 Make_Defining_Identifier (Loc,
1236 Chars => New_Internal_Name ('P'));
1237 Specific_Build_RPC_Receiver_Body
1238 (RPC_Receiver => RPC_Receiver,
1239 Request => RPC_Receiver_Request,
1240 Subp_Id => RPC_Receiver_Subp_Id,
1241 Subp_Index => RPC_Receiver_Subp_Index,
1242 Stmts => RPC_Receiver_Statements,
1243 Decl => RPC_Receiver_Decl);
1245 if Get_PCS_Name = Name_PolyORB_DSA then
1247 -- For the case of PolyORB, we need to map a textual operation
1248 -- name into a primitive index. Currently we do so using a simple
1249 -- sequence of string comparisons.
1251 RPC_Receiver_Elsif_Parts := New_List;
1255 -- Build callers, receivers for every primitive operations and a RPC
1256 -- receiver for this type.
1258 if Present (Primitive_Operations (Designated_Type)) then
1259 Overload_Counter_Table.Reset;
1261 Current_Primitive_Elmt :=
1262 First_Elmt (Primitive_Operations (Designated_Type));
1263 while Current_Primitive_Elmt /= No_Elmt loop
1264 Current_Primitive := Node (Current_Primitive_Elmt);
1266 -- Copy the primitive of all the parents, except predefined ones
1267 -- that are not remotely dispatching.
1269 if Chars (Current_Primitive) /= Name_uSize
1270 and then Chars (Current_Primitive) /= Name_uAlignment
1272 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1273 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1274 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1275 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1276 Is_TSS (Current_Primitive, TSS_Stream_Write))
1278 -- The first thing to do is build an up-to-date copy of the
1279 -- spec with all the formals referencing Designated_Type
1280 -- transformed into formals referencing Stub_Type. Since this
1281 -- primitive may have been inherited, go back the alias chain
1282 -- until the real primitive has been found.
1284 Current_Primitive_Alias := Current_Primitive;
1285 while Present (Alias (Current_Primitive_Alias)) loop
1287 (Current_Primitive_Alias
1288 /= Alias (Current_Primitive_Alias));
1289 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
1292 -- Copy the spec from the original declaration for the purpose
1293 -- of declaring an overriding subprogram: we need to replace
1294 -- the type of each controlling formal with Stub_Type. The
1295 -- primitive may have been declared for Designated_Type or
1296 -- inherited from some ancestor type for which we do not have
1297 -- an easily determined Entity_Id. We have no systematic way
1298 -- of knowing which type to substitute Stub_Type for. Instead,
1299 -- Copy_Specification relies on the flag Is_Controlling_Formal
1300 -- to determine which formals to change.
1302 Current_Primitive_Spec :=
1303 Copy_Specification (Loc,
1304 Spec => Parent (Current_Primitive_Alias),
1305 Ctrl_Type => Stub_Elements.Stub_Type);
1307 Current_Primitive_Decl :=
1308 Make_Subprogram_Declaration (Loc,
1309 Specification => Current_Primitive_Spec);
1311 Insert_After_And_Analyze (Current_Insertion_Node,
1312 Current_Primitive_Decl);
1313 Current_Insertion_Node := Current_Primitive_Decl;
1315 Possibly_Asynchronous :=
1316 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1317 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1319 Assign_Subprogram_Identifier (
1320 Defining_Unit_Name (Current_Primitive_Spec),
1321 Current_Primitive_Number,
1324 if Build_Bodies then
1325 Current_Primitive_Body :=
1326 Build_Subprogram_Calling_Stubs
1327 (Vis_Decl => Current_Primitive_Decl,
1329 Build_Subprogram_Id (Loc,
1330 Defining_Unit_Name (Current_Primitive_Spec)),
1331 Asynchronous => Possibly_Asynchronous,
1332 Dynamically_Asynchronous => Possibly_Asynchronous,
1333 Stub_Type => Stub_Elements.Stub_Type,
1334 RACW_Type => Stub_Elements.RACW_Type);
1335 Append_To (Body_Decls, Current_Primitive_Body);
1337 -- Analyzing the body here would cause the Stub type to
1338 -- be frozen, thus preventing subsequent primitive
1339 -- declarations. For this reason, it will be analyzed
1340 -- later in the regular flow (and in the context of the
1341 -- appropriate unit body, see Append_RACW_Bodies).
1345 -- Build the receiver stubs
1347 if Build_Bodies and then not Is_RAS then
1348 Current_Receiver_Body :=
1349 Specific_Build_Subprogram_Receiving_Stubs
1350 (Vis_Decl => Current_Primitive_Decl,
1351 Asynchronous => Possibly_Asynchronous,
1352 Dynamically_Asynchronous => Possibly_Asynchronous,
1353 Stub_Type => Stub_Elements.Stub_Type,
1354 RACW_Type => Stub_Elements.RACW_Type,
1355 Parent_Primitive => Current_Primitive);
1357 Current_Receiver := Defining_Unit_Name (
1358 Specification (Current_Receiver_Body));
1360 Append_To (Body_Decls, Current_Receiver_Body);
1362 -- Add a case alternative to the receiver
1364 if Get_PCS_Name = Name_PolyORB_DSA then
1365 Append_To (RPC_Receiver_Elsif_Parts,
1366 Make_Elsif_Part (Loc,
1368 Make_Function_Call (Loc,
1371 RTE (RE_Caseless_String_Eq), Loc),
1372 Parameter_Associations => New_List (
1373 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1374 Make_String_Literal (Loc, Subp_Str))),
1375 Then_Statements => New_List (
1376 Make_Assignment_Statement (Loc,
1377 Name => New_Occurrence_Of (
1378 RPC_Receiver_Subp_Index, Loc),
1380 Make_Integer_Literal (Loc,
1381 Current_Primitive_Number)))));
1384 Append_To (RPC_Receiver_Case_Alternatives,
1385 Make_Case_Statement_Alternative (Loc,
1386 Discrete_Choices => New_List (
1387 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1389 Statements => New_List (
1390 Make_Procedure_Call_Statement (Loc,
1392 New_Occurrence_Of (Current_Receiver, Loc),
1393 Parameter_Associations => New_List (
1394 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1397 -- Increment the index of current primitive
1399 Current_Primitive_Number := Current_Primitive_Number + 1;
1402 Next_Elmt (Current_Primitive_Elmt);
1406 -- Build the case statement and the heart of the subprogram
1408 if Build_Bodies and then not Is_RAS then
1409 if Get_PCS_Name = Name_PolyORB_DSA
1410 and then Present (First (RPC_Receiver_Elsif_Parts))
1412 Append_To (RPC_Receiver_Statements,
1413 Make_Implicit_If_Statement (Designated_Type,
1414 Condition => New_Occurrence_Of (Standard_False, Loc),
1415 Then_Statements => New_List,
1416 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1419 Append_To (RPC_Receiver_Case_Alternatives,
1420 Make_Case_Statement_Alternative (Loc,
1421 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1422 Statements => New_List (Make_Null_Statement (Loc))));
1424 Append_To (RPC_Receiver_Statements,
1425 Make_Case_Statement (Loc,
1427 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1428 Alternatives => RPC_Receiver_Case_Alternatives));
1430 Append_To (Body_Decls, RPC_Receiver_Decl);
1431 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1432 Body_Decls, RPC_Receiver, Stub_Elements);
1434 -- Do not analyze RPC receiver body at this stage since it references
1435 -- subprograms that have not been analyzed yet. It will be analyzed in
1436 -- the regular flow (see Append_RACW_Bodies).
1439 end Add_RACW_Primitive_Declarations_And_Bodies;
1441 -----------------------------
1442 -- Add_RAS_Dereference_TSS --
1443 -----------------------------
1445 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1446 Loc : constant Source_Ptr := Sloc (N);
1448 Type_Def : constant Node_Id := Type_Definition (N);
1449 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1450 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1451 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1452 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1454 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
1455 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1457 RACW_Primitive_Name : Node_Id;
1459 Proc : constant Entity_Id :=
1460 Make_Defining_Identifier (Loc,
1461 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1463 Proc_Spec : Node_Id;
1464 Param_Specs : List_Id;
1465 Param_Assoc : constant List_Id := New_List;
1466 Stmts : constant List_Id := New_List;
1468 RAS_Parameter : constant Entity_Id :=
1469 Make_Defining_Identifier (Loc,
1470 Chars => New_Internal_Name ('P'));
1472 Is_Function : constant Boolean :=
1473 Nkind (Type_Def) = N_Access_Function_Definition;
1475 Is_Degenerate : Boolean;
1476 -- Set to True if the subprogram_specification for this RAS has an
1477 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1479 Spec : constant Node_Id := Type_Def;
1481 Current_Parameter : Node_Id;
1483 -- Start of processing for Add_RAS_Dereference_TSS
1486 -- The Dereference TSS for a remote access-to-subprogram type has the
1489 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1492 -- This is called whenever a value of a RAS type is dereferenced
1494 -- First construct a list of parameter specifications:
1496 -- The first formal is the RAS values
1498 Param_Specs := New_List (
1499 Make_Parameter_Specification (Loc,
1500 Defining_Identifier => RAS_Parameter,
1503 New_Occurrence_Of (Fat_Type, Loc)));
1505 -- The following formals are copied from the type declaration
1507 Is_Degenerate := False;
1508 Current_Parameter := First (Parameter_Specifications (Type_Def));
1509 Parameters : while Present (Current_Parameter) loop
1510 if Nkind (Parameter_Type (Current_Parameter)) =
1513 Is_Degenerate := True;
1516 Append_To (Param_Specs,
1517 Make_Parameter_Specification (Loc,
1518 Defining_Identifier =>
1519 Make_Defining_Identifier (Loc,
1520 Chars => Chars (Defining_Identifier (Current_Parameter))),
1521 In_Present => In_Present (Current_Parameter),
1522 Out_Present => Out_Present (Current_Parameter),
1524 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1526 New_Copy_Tree (Expression (Current_Parameter))));
1528 Append_To (Param_Assoc,
1529 Make_Identifier (Loc,
1530 Chars => Chars (Defining_Identifier (Current_Parameter))));
1532 Next (Current_Parameter);
1533 end loop Parameters;
1535 if Is_Degenerate then
1536 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1538 -- Generate a dummy body. This code will never actually be executed,
1539 -- because null is the only legal value for a degenerate RAS type.
1540 -- For legality's sake (in order to avoid generating a function that
1541 -- does not contain a return statement), we include a dummy recursive
1542 -- call on the TSS itself.
1545 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1546 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1549 -- For a normal RAS type, we cast the RAS formal to the corresponding
1550 -- tagged type, and perform a dispatching call to its Call primitive
1553 Prepend_To (Param_Assoc,
1554 Unchecked_Convert_To (RACW_Type,
1555 New_Occurrence_Of (RAS_Parameter, Loc)));
1557 RACW_Primitive_Name :=
1558 Make_Selected_Component (Loc,
1559 Prefix => Scope (RACW_Type),
1560 Selector_Name => Name_uCall);
1565 Make_Simple_Return_Statement (Loc,
1567 Make_Function_Call (Loc,
1568 Name => RACW_Primitive_Name,
1569 Parameter_Associations => Param_Assoc)));
1573 Make_Procedure_Call_Statement (Loc,
1574 Name => RACW_Primitive_Name,
1575 Parameter_Associations => Param_Assoc));
1578 -- Build the complete subprogram
1582 Make_Function_Specification (Loc,
1583 Defining_Unit_Name => Proc,
1584 Parameter_Specifications => Param_Specs,
1585 Result_Definition =>
1587 Entity (Result_Definition (Spec)), Loc));
1589 Set_Ekind (Proc, E_Function);
1591 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1595 Make_Procedure_Specification (Loc,
1596 Defining_Unit_Name => Proc,
1597 Parameter_Specifications => Param_Specs);
1599 Set_Ekind (Proc, E_Procedure);
1600 Set_Etype (Proc, Standard_Void_Type);
1604 Make_Subprogram_Body (Loc,
1605 Specification => Proc_Spec,
1606 Declarations => New_List,
1607 Handled_Statement_Sequence =>
1608 Make_Handled_Sequence_Of_Statements (Loc,
1609 Statements => Stmts)));
1611 Set_TSS (Fat_Type, Proc);
1612 end Add_RAS_Dereference_TSS;
1614 -------------------------------
1615 -- Add_RAS_Proxy_And_Analyze --
1616 -------------------------------
1618 procedure Add_RAS_Proxy_And_Analyze
1621 All_Calls_Remote_E : Entity_Id;
1622 Proxy_Object_Addr : out Entity_Id)
1624 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1626 Subp_Name : constant Entity_Id :=
1627 Defining_Unit_Name (Specification (Vis_Decl));
1629 Pkg_Name : constant Entity_Id :=
1630 Make_Defining_Identifier (Loc,
1632 New_External_Name (Chars (Subp_Name), 'P', -1));
1634 Proxy_Type : constant Entity_Id :=
1635 Make_Defining_Identifier (Loc,
1638 Related_Id => Chars (Subp_Name),
1641 Proxy_Type_Full_View : constant Entity_Id :=
1642 Make_Defining_Identifier (Loc,
1643 Chars (Proxy_Type));
1645 Subp_Decl_Spec : constant Node_Id :=
1646 Build_RAS_Primitive_Specification
1647 (Subp_Spec => Specification (Vis_Decl),
1648 Remote_Object_Type => Proxy_Type);
1650 Subp_Body_Spec : constant Node_Id :=
1651 Build_RAS_Primitive_Specification
1652 (Subp_Spec => Specification (Vis_Decl),
1653 Remote_Object_Type => Proxy_Type);
1655 Vis_Decls : constant List_Id := New_List;
1656 Pvt_Decls : constant List_Id := New_List;
1657 Actuals : constant List_Id := New_List;
1659 Perform_Call : Node_Id;
1662 -- type subpP is tagged limited private;
1664 Append_To (Vis_Decls,
1665 Make_Private_Type_Declaration (Loc,
1666 Defining_Identifier => Proxy_Type,
1667 Tagged_Present => True,
1668 Limited_Present => True));
1670 -- [subprogram] Call
1671 -- (Self : access subpP;
1672 -- ...other-formals...)
1675 Append_To (Vis_Decls,
1676 Make_Subprogram_Declaration (Loc,
1677 Specification => Subp_Decl_Spec));
1679 -- A : constant System.Address;
1681 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1683 Append_To (Vis_Decls,
1684 Make_Object_Declaration (Loc,
1685 Defining_Identifier =>
1689 Object_Definition =>
1690 New_Occurrence_Of (RTE (RE_Address), Loc)));
1694 -- type subpP is tagged limited record
1695 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1699 Append_To (Pvt_Decls,
1700 Make_Full_Type_Declaration (Loc,
1701 Defining_Identifier =>
1702 Proxy_Type_Full_View,
1704 Build_Remote_Subprogram_Proxy_Type (Loc,
1705 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1707 -- Trick semantic analysis into swapping the public and full view when
1708 -- freezing the public view.
1710 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1713 -- (Self : access O;
1714 -- ...other-formals...) is
1716 -- P (...other-formals...);
1720 -- (Self : access O;
1721 -- ...other-formals...)
1724 -- return F (...other-formals...);
1727 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1729 Make_Procedure_Call_Statement (Loc,
1731 New_Occurrence_Of (Subp_Name, Loc),
1732 Parameter_Associations =>
1736 Make_Simple_Return_Statement (Loc,
1738 Make_Function_Call (Loc,
1740 New_Occurrence_Of (Subp_Name, Loc),
1741 Parameter_Associations =>
1745 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1746 pragma Assert (Present (Formal));
1749 exit when No (Formal);
1751 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1754 -- O : aliased subpP;
1756 Append_To (Pvt_Decls,
1757 Make_Object_Declaration (Loc,
1758 Defining_Identifier =>
1759 Make_Defining_Identifier (Loc,
1763 Object_Definition =>
1764 New_Occurrence_Of (Proxy_Type, Loc)));
1766 -- A : constant System.Address := O'Address;
1768 Append_To (Pvt_Decls,
1769 Make_Object_Declaration (Loc,
1770 Defining_Identifier =>
1771 Make_Defining_Identifier (Loc,
1772 Chars (Proxy_Object_Addr)),
1775 Object_Definition =>
1776 New_Occurrence_Of (RTE (RE_Address), Loc),
1778 Make_Attribute_Reference (Loc,
1779 Prefix => New_Occurrence_Of (
1780 Defining_Identifier (Last (Pvt_Decls)), Loc),
1785 Make_Package_Declaration (Loc,
1786 Specification => Make_Package_Specification (Loc,
1787 Defining_Unit_Name => Pkg_Name,
1788 Visible_Declarations => Vis_Decls,
1789 Private_Declarations => Pvt_Decls,
1790 End_Label => Empty)));
1791 Analyze (Last (Decls));
1794 Make_Package_Body (Loc,
1795 Defining_Unit_Name =>
1796 Make_Defining_Identifier (Loc,
1798 Declarations => New_List (
1799 Make_Subprogram_Body (Loc,
1802 Declarations => New_List,
1803 Handled_Statement_Sequence =>
1804 Make_Handled_Sequence_Of_Statements (Loc,
1805 Statements => New_List (Perform_Call))))));
1806 Analyze (Last (Decls));
1807 end Add_RAS_Proxy_And_Analyze;
1809 -----------------------
1810 -- Add_RAST_Features --
1811 -----------------------
1813 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1814 RAS_Type : constant Entity_Id :=
1815 Equivalent_Type (Defining_Identifier (Vis_Decl));
1817 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1818 Add_RAS_Dereference_TSS (Vis_Decl);
1819 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1820 end Add_RAST_Features;
1826 procedure Add_Stub_Type
1827 (Designated_Type : Entity_Id;
1828 RACW_Type : Entity_Id;
1830 Stub_Type : out Entity_Id;
1831 Stub_Type_Access : out Entity_Id;
1832 RPC_Receiver_Decl : out Node_Id;
1833 Body_Decls : out List_Id;
1834 Existing : out Boolean)
1836 Loc : constant Source_Ptr := Sloc (RACW_Type);
1838 Stub_Elements : constant Stub_Structure :=
1839 Stubs_Table.Get (Designated_Type);
1840 Stub_Type_Decl : Node_Id;
1841 Stub_Type_Access_Decl : Node_Id;
1844 if Stub_Elements /= Empty_Stub_Structure then
1845 Stub_Type := Stub_Elements.Stub_Type;
1846 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1847 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1848 Body_Decls := Stub_Elements.Body_Decls;
1855 Make_Defining_Identifier (Loc,
1856 Chars => New_Internal_Name ('S'));
1858 Make_Defining_Identifier (Loc,
1859 Chars => New_External_Name
1860 (Related_Id => Chars (Stub_Type), Suffix => 'A'));
1862 Specific_Build_Stub_Type
1863 (RACW_Type, Stub_Type,
1864 Stub_Type_Decl, RPC_Receiver_Decl);
1866 Stub_Type_Access_Decl :=
1867 Make_Full_Type_Declaration (Loc,
1868 Defining_Identifier => Stub_Type_Access,
1870 Make_Access_To_Object_Definition (Loc,
1871 All_Present => True,
1872 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1874 Append_To (Decls, Stub_Type_Decl);
1875 Analyze (Last (Decls));
1876 Append_To (Decls, Stub_Type_Access_Decl);
1877 Analyze (Last (Decls));
1879 -- This is in no way a type derivation, but we fake it to make sure that
1880 -- the dispatching table gets built with the corresponding primitive
1881 -- operations at the right place.
1883 Derive_Subprograms (Parent_Type => Designated_Type,
1884 Derived_Type => Stub_Type);
1886 if Present (RPC_Receiver_Decl) then
1887 Append_To (Decls, RPC_Receiver_Decl);
1889 RPC_Receiver_Decl := Last (Decls);
1892 Body_Decls := New_List;
1894 Stubs_Table.Set (Designated_Type,
1895 (Stub_Type => Stub_Type,
1896 Stub_Type_Access => Stub_Type_Access,
1897 RPC_Receiver_Decl => RPC_Receiver_Decl,
1898 Body_Decls => Body_Decls,
1899 RACW_Type => RACW_Type));
1902 ------------------------
1903 -- Append_RACW_Bodies --
1904 ------------------------
1906 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
1909 E := First_Entity (Spec_Id);
1910 while Present (E) loop
1911 if Is_Remote_Access_To_Class_Wide_Type (E) then
1912 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
1917 end Append_RACW_Bodies;
1919 ----------------------------------
1920 -- Assign_Subprogram_Identifier --
1921 ----------------------------------
1923 procedure Assign_Subprogram_Identifier
1928 N : constant Name_Id := Chars (Def);
1930 Overload_Order : constant Int :=
1931 Overload_Counter_Table.Get (N) + 1;
1934 Overload_Counter_Table.Set (N, Overload_Order);
1936 Get_Name_String (N);
1938 -- Homonym handling: as in Exp_Dbug, but much simpler,
1939 -- because the only entities for which we have to generate
1940 -- names here need only to be disambiguated within their
1943 if Overload_Order > 1 then
1944 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
1945 Name_Len := Name_Len + 2;
1946 Add_Nat_To_Name_Buffer (Overload_Order);
1949 Id := String_From_Name_Buffer;
1950 Subprogram_Identifier_Table.Set (Def,
1951 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
1952 end Assign_Subprogram_Identifier;
1954 -------------------------------------
1955 -- Build_Actual_Object_Declaration --
1956 -------------------------------------
1958 procedure Build_Actual_Object_Declaration
1959 (Object : Entity_Id;
1965 Loc : constant Source_Ptr := Sloc (Object);
1967 -- Declare a temporary object for the actual, possibly initialized with
1968 -- a 'Input/From_Any call.
1970 -- Complication arises in the case of limited types, for which such a
1971 -- declaration is illegal in Ada 95. In that case, we first generate a
1972 -- renaming declaration of the 'Input call, and then if needed we
1973 -- generate an overlaid non-constant view.
1975 if Ada_Version <= Ada_95
1976 and then Is_Limited_Type (Etyp)
1977 and then Present (Expr)
1980 -- Object : Etyp renames <func-call>
1983 Make_Object_Renaming_Declaration (Loc,
1984 Defining_Identifier => Object,
1985 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
1990 -- The name defined by the renaming declaration denotes a
1991 -- constant view; create a non-constant object at the same address
1992 -- to be used as the actual.
1995 Constant_Object : constant Entity_Id :=
1996 Make_Defining_Identifier (Loc,
1997 New_Internal_Name ('P'));
1999 Set_Defining_Identifier
2000 (Last (Decls), Constant_Object);
2002 -- We have an unconstrained Etyp: build the actual constrained
2003 -- subtype for the value we just read from the stream.
2005 -- suubtype S is <actual subtype of Constant_Object>;
2008 Build_Actual_Subtype (Etyp,
2009 New_Occurrence_Of (Constant_Object, Loc)));
2014 Make_Object_Declaration (Loc,
2015 Defining_Identifier => Object,
2016 Object_Definition =>
2018 (Defining_Identifier (Last (Decls)), Loc)));
2019 Set_Ekind (Object, E_Variable);
2021 -- Suppress default initialization:
2022 -- pragma Import (Ada, Object);
2026 Chars => Name_Import,
2027 Pragma_Argument_Associations => New_List (
2028 Make_Pragma_Argument_Association (Loc,
2029 Chars => Name_Convention,
2030 Expression => Make_Identifier (Loc, Name_Ada)),
2031 Make_Pragma_Argument_Association (Loc,
2032 Chars => Name_Entity,
2033 Expression => New_Occurrence_Of (Object, Loc)))));
2035 -- for Object'Address use Constant_Object'Address;
2038 Make_Attribute_Definition_Clause (Loc,
2039 Name => New_Occurrence_Of (Object, Loc),
2040 Chars => Name_Address,
2042 Make_Attribute_Reference (Loc,
2044 New_Occurrence_Of (Constant_Object, Loc),
2052 -- General case of a regular object declaration. Object is flagged
2053 -- constant unless it has mode out or in out, to allow the backend
2054 -- to optimize where possible.
2056 -- Object : [constant] Etyp [:= <expr>];
2059 Make_Object_Declaration (Loc,
2060 Defining_Identifier => Object,
2061 Constant_Present => Present (Expr) and then not Variable,
2062 Object_Definition =>
2063 New_Occurrence_Of (Etyp, Loc),
2064 Expression => Expr));
2066 if Constant_Present (Last (Decls)) then
2067 Set_Ekind (Object, E_Constant);
2069 Set_Ekind (Object, E_Variable);
2072 end Build_Actual_Object_Declaration;
2074 ------------------------------
2075 -- Build_Get_Unique_RP_Call --
2076 ------------------------------
2078 function Build_Get_Unique_RP_Call
2080 Pointer : Entity_Id;
2081 Stub_Type : Entity_Id) return List_Id
2085 Make_Procedure_Call_Statement (Loc,
2087 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2088 Parameter_Associations => New_List (
2089 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2090 New_Occurrence_Of (Pointer, Loc)))),
2092 Make_Assignment_Statement (Loc,
2094 Make_Selected_Component (Loc,
2096 New_Occurrence_Of (Pointer, Loc),
2098 New_Occurrence_Of (First_Tag_Component
2099 (Designated_Type (Etype (Pointer))), Loc)),
2101 Make_Attribute_Reference (Loc,
2103 New_Occurrence_Of (Stub_Type, Loc),
2107 -- Note: The assignment to Pointer._Tag is safe here because
2108 -- we carefully ensured that Stub_Type has exactly the same layout
2109 -- as System.Partition_Interface.RACW_Stub_Type.
2111 end Build_Get_Unique_RP_Call;
2113 -----------------------------------
2114 -- Build_Ordered_Parameters_List --
2115 -----------------------------------
2117 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2118 Constrained_List : List_Id;
2119 Unconstrained_List : List_Id;
2120 Current_Parameter : Node_Id;
2122 First_Parameter : Node_Id;
2123 For_RAS : Boolean := False;
2126 if No (Parameter_Specifications (Spec)) then
2130 Constrained_List := New_List;
2131 Unconstrained_List := New_List;
2132 First_Parameter := First (Parameter_Specifications (Spec));
2134 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2135 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2140 -- Loop through the parameters and add them to the right list
2142 Current_Parameter := First_Parameter;
2143 while Present (Current_Parameter) loop
2144 if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
2146 Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
2148 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
2149 and then not (For_RAS and then Current_Parameter = First_Parameter)
2151 Append_To (Constrained_List, New_Copy (Current_Parameter));
2153 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2156 Next (Current_Parameter);
2159 -- Unconstrained parameters are returned first
2161 Append_List_To (Unconstrained_List, Constrained_List);
2163 return Unconstrained_List;
2164 end Build_Ordered_Parameters_List;
2166 ----------------------------------
2167 -- Build_Passive_Partition_Stub --
2168 ----------------------------------
2170 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2172 Pkg_Name : String_Id;
2175 Loc : constant Source_Ptr := Sloc (U);
2178 -- Verify that the implementation supports distribution, by accessing
2179 -- a type defined in the proper version of system.rpc
2182 Dist_OK : Entity_Id;
2183 pragma Warnings (Off, Dist_OK);
2185 Dist_OK := RTE (RE_Params_Stream_Type);
2188 -- Use body if present, spec otherwise
2190 if Nkind (U) = N_Package_Declaration then
2191 Pkg_Spec := Specification (U);
2192 L := Visible_Declarations (Pkg_Spec);
2194 Pkg_Spec := Parent (Corresponding_Spec (U));
2195 L := Declarations (U);
2198 Get_Library_Unit_Name_String (Pkg_Spec);
2199 Pkg_Name := String_From_Name_Buffer;
2201 Make_Procedure_Call_Statement (Loc,
2203 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2204 Parameter_Associations => New_List (
2205 Make_String_Literal (Loc, Pkg_Name),
2206 Make_Attribute_Reference (Loc,
2208 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2213 end Build_Passive_Partition_Stub;
2215 --------------------------------------
2216 -- Build_RPC_Receiver_Specification --
2217 --------------------------------------
2219 function Build_RPC_Receiver_Specification
2220 (RPC_Receiver : Entity_Id;
2221 Request_Parameter : Entity_Id) return Node_Id
2223 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2226 Make_Procedure_Specification (Loc,
2227 Defining_Unit_Name => RPC_Receiver,
2228 Parameter_Specifications => New_List (
2229 Make_Parameter_Specification (Loc,
2230 Defining_Identifier => Request_Parameter,
2232 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2233 end Build_RPC_Receiver_Specification;
2235 ----------------------------------------
2236 -- Build_Remote_Subprogram_Proxy_Type --
2237 ----------------------------------------
2239 function Build_Remote_Subprogram_Proxy_Type
2241 ACR_Expression : Node_Id) return Node_Id
2245 Make_Record_Definition (Loc,
2246 Tagged_Present => True,
2247 Limited_Present => True,
2249 Make_Component_List (Loc,
2251 Component_Items => New_List (
2252 Make_Component_Declaration (Loc,
2253 Defining_Identifier =>
2254 Make_Defining_Identifier (Loc,
2255 Name_All_Calls_Remote),
2256 Component_Definition =>
2257 Make_Component_Definition (Loc,
2258 Subtype_Indication =>
2259 New_Occurrence_Of (Standard_Boolean, Loc)),
2263 Make_Component_Declaration (Loc,
2264 Defining_Identifier =>
2265 Make_Defining_Identifier (Loc,
2267 Component_Definition =>
2268 Make_Component_Definition (Loc,
2269 Subtype_Indication =>
2270 New_Occurrence_Of (RTE (RE_Address), Loc)),
2272 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2274 Make_Component_Declaration (Loc,
2275 Defining_Identifier =>
2276 Make_Defining_Identifier (Loc,
2278 Component_Definition =>
2279 Make_Component_Definition (Loc,
2280 Subtype_Indication =>
2281 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2282 end Build_Remote_Subprogram_Proxy_Type;
2284 ------------------------------------
2285 -- Build_Subprogram_Calling_Stubs --
2286 ------------------------------------
2288 function Build_Subprogram_Calling_Stubs
2289 (Vis_Decl : Node_Id;
2291 Asynchronous : Boolean;
2292 Dynamically_Asynchronous : Boolean := False;
2293 Stub_Type : Entity_Id := Empty;
2294 RACW_Type : Entity_Id := Empty;
2295 Locator : Entity_Id := Empty;
2296 New_Name : Name_Id := No_Name) return Node_Id
2298 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2300 Decls : constant List_Id := New_List;
2301 Statements : constant List_Id := New_List;
2303 Subp_Spec : Node_Id;
2304 -- The specification of the body
2306 Controlling_Parameter : Entity_Id := Empty;
2308 Asynchronous_Expr : Node_Id := Empty;
2310 RCI_Locator : Entity_Id;
2312 Spec_To_Use : Node_Id;
2314 procedure Insert_Partition_Check (Parameter : Node_Id);
2315 -- Check that the parameter has been elaborated on the same partition
2316 -- than the controlling parameter (E.4(19)).
2318 ----------------------------
2319 -- Insert_Partition_Check --
2320 ----------------------------
2322 procedure Insert_Partition_Check (Parameter : Node_Id) is
2323 Parameter_Entity : constant Entity_Id :=
2324 Defining_Identifier (Parameter);
2326 -- The expression that will be built is of the form:
2328 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2329 -- raise Constraint_Error;
2332 -- We do not check that Parameter is in Stub_Type since such a check
2333 -- has been inserted at the point of call already (a tag check since
2334 -- we have multiple controlling operands).
2337 Make_Raise_Constraint_Error (Loc,
2341 Make_Function_Call (Loc,
2343 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2344 Parameter_Associations =>
2346 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2347 New_Occurrence_Of (Parameter_Entity, Loc)),
2348 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2349 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2350 Reason => CE_Partition_Check_Failed));
2351 end Insert_Partition_Check;
2353 -- Start of processing for Build_Subprogram_Calling_Stubs
2356 Subp_Spec := Copy_Specification (Loc,
2357 Spec => Specification (Vis_Decl),
2358 New_Name => New_Name);
2360 if Locator = Empty then
2361 RCI_Locator := RCI_Cache;
2362 Spec_To_Use := Specification (Vis_Decl);
2364 RCI_Locator := Locator;
2365 Spec_To_Use := Subp_Spec;
2368 -- Find a controlling argument if we have a stub type. Also check
2369 -- if this subprogram can be made asynchronous.
2371 if Present (Stub_Type)
2372 and then Present (Parameter_Specifications (Spec_To_Use))
2375 Current_Parameter : Node_Id :=
2376 First (Parameter_Specifications
2379 while Present (Current_Parameter) loop
2381 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2383 if Controlling_Parameter = Empty then
2384 Controlling_Parameter :=
2385 Defining_Identifier (Current_Parameter);
2387 Insert_Partition_Check (Current_Parameter);
2391 Next (Current_Parameter);
2396 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2398 if Dynamically_Asynchronous then
2399 Asynchronous_Expr := Make_Selected_Component (Loc,
2400 Prefix => Controlling_Parameter,
2401 Selector_Name => Name_Asynchronous);
2404 Specific_Build_General_Calling_Stubs
2406 Statements => Statements,
2407 Target => Specific_Build_Stub_Target (Loc,
2408 Decls, RCI_Locator, Controlling_Parameter),
2409 Subprogram_Id => Subp_Id,
2410 Asynchronous => Asynchronous_Expr,
2411 Is_Known_Asynchronous => Asynchronous
2412 and then not Dynamically_Asynchronous,
2413 Is_Known_Non_Asynchronous
2415 and then not Dynamically_Asynchronous,
2416 Is_Function => Nkind (Spec_To_Use) =
2417 N_Function_Specification,
2418 Spec => Spec_To_Use,
2419 Stub_Type => Stub_Type,
2420 RACW_Type => RACW_Type,
2423 RCI_Calling_Stubs_Table.Set
2424 (Defining_Unit_Name (Specification (Vis_Decl)),
2425 Defining_Unit_Name (Spec_To_Use));
2428 Make_Subprogram_Body (Loc,
2429 Specification => Subp_Spec,
2430 Declarations => Decls,
2431 Handled_Statement_Sequence =>
2432 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2433 end Build_Subprogram_Calling_Stubs;
2435 -------------------------
2436 -- Build_Subprogram_Id --
2437 -------------------------
2439 function Build_Subprogram_Id
2441 E : Entity_Id) return Node_Id
2444 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2446 Current_Declaration : Node_Id;
2447 Current_Subp : Entity_Id;
2448 Current_Subp_Str : String_Id;
2449 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2452 -- Build_Subprogram_Id is called outside of the context of
2453 -- generating calling or receiving stubs. Hence we are processing
2454 -- an 'Access attribute_reference for an RCI subprogram, for the
2455 -- purpose of obtaining a RAS value.
2458 (Is_Remote_Call_Interface (Scope (E))
2460 (Nkind (Parent (E)) = N_Procedure_Specification
2462 Nkind (Parent (E)) = N_Function_Specification));
2464 Current_Declaration :=
2465 First (Visible_Declarations
2466 (Package_Specification_Of_Scope (Scope (E))));
2467 while Present (Current_Declaration) loop
2468 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2469 and then Comes_From_Source (Current_Declaration)
2471 Current_Subp := Defining_Unit_Name (Specification (
2472 Current_Declaration));
2474 Assign_Subprogram_Identifier
2475 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2477 Current_Subp_Number := Current_Subp_Number + 1;
2480 Next (Current_Declaration);
2485 case Get_PCS_Name is
2486 when Name_PolyORB_DSA =>
2487 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2489 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2491 end Build_Subprogram_Id;
2493 ------------------------
2494 -- Copy_Specification --
2495 ------------------------
2497 function Copy_Specification
2500 Ctrl_Type : Entity_Id := Empty;
2501 New_Name : Name_Id := No_Name) return Node_Id
2503 Parameters : List_Id := No_List;
2505 Current_Parameter : Node_Id;
2506 Current_Identifier : Entity_Id;
2507 Current_Type : Node_Id;
2509 Name_For_New_Spec : Name_Id;
2511 New_Identifier : Entity_Id;
2513 -- Comments needed in body below ???
2516 if New_Name = No_Name then
2517 pragma Assert (Nkind (Spec) = N_Function_Specification
2518 or else Nkind (Spec) = N_Procedure_Specification);
2520 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2522 Name_For_New_Spec := New_Name;
2525 if Present (Parameter_Specifications (Spec)) then
2526 Parameters := New_List;
2527 Current_Parameter := First (Parameter_Specifications (Spec));
2528 while Present (Current_Parameter) loop
2529 Current_Identifier := Defining_Identifier (Current_Parameter);
2530 Current_Type := Parameter_Type (Current_Parameter);
2532 if Nkind (Current_Type) = N_Access_Definition then
2533 if Present (Ctrl_Type) then
2534 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2536 Make_Access_Definition (Loc,
2537 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2538 Null_Exclusion_Present =>
2539 Null_Exclusion_Present (Current_Type));
2543 Make_Access_Definition (Loc,
2545 New_Copy_Tree (Subtype_Mark (Current_Type)),
2546 Null_Exclusion_Present =>
2547 Null_Exclusion_Present (Current_Type));
2551 if Present (Ctrl_Type)
2552 and then Is_Controlling_Formal (Current_Identifier)
2554 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2556 Current_Type := New_Copy_Tree (Current_Type);
2560 New_Identifier := Make_Defining_Identifier (Loc,
2561 Chars (Current_Identifier));
2563 Append_To (Parameters,
2564 Make_Parameter_Specification (Loc,
2565 Defining_Identifier => New_Identifier,
2566 Parameter_Type => Current_Type,
2567 In_Present => In_Present (Current_Parameter),
2568 Out_Present => Out_Present (Current_Parameter),
2570 New_Copy_Tree (Expression (Current_Parameter))));
2572 -- For a regular formal parameter (that needs to be marshalled
2573 -- in the context of remote calls), set the Etype now, because
2574 -- marshalling processing might need it.
2576 if Is_Entity_Name (Current_Type) then
2577 Set_Etype (New_Identifier, Entity (Current_Type));
2579 -- Current_Type is an access definition, special processing
2580 -- (not requiring etype) will occur for marshalling.
2586 Next (Current_Parameter);
2590 case Nkind (Spec) is
2592 when N_Function_Specification | N_Access_Function_Definition =>
2594 Make_Function_Specification (Loc,
2595 Defining_Unit_Name =>
2596 Make_Defining_Identifier (Loc,
2597 Chars => Name_For_New_Spec),
2598 Parameter_Specifications => Parameters,
2599 Result_Definition =>
2600 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2602 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2604 Make_Procedure_Specification (Loc,
2605 Defining_Unit_Name =>
2606 Make_Defining_Identifier (Loc,
2607 Chars => Name_For_New_Spec),
2608 Parameter_Specifications => Parameters);
2611 raise Program_Error;
2613 end Copy_Specification;
2615 -----------------------------
2616 -- Corresponding_Stub_Type --
2617 -----------------------------
2619 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2620 Desig : constant Entity_Id :=
2621 Etype (Designated_Type (RACW_Type));
2622 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2624 return Stub_Elements.Stub_Type;
2625 end Corresponding_Stub_Type;
2627 ---------------------------
2628 -- Could_Be_Asynchronous --
2629 ---------------------------
2631 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2632 Current_Parameter : Node_Id;
2635 if Present (Parameter_Specifications (Spec)) then
2636 Current_Parameter := First (Parameter_Specifications (Spec));
2637 while Present (Current_Parameter) loop
2638 if Out_Present (Current_Parameter) then
2642 Next (Current_Parameter);
2647 end Could_Be_Asynchronous;
2649 ---------------------------
2650 -- Declare_Create_NVList --
2651 ---------------------------
2653 procedure Declare_Create_NVList
2661 Make_Object_Declaration (Loc,
2662 Defining_Identifier => NVList,
2663 Aliased_Present => False,
2664 Object_Definition =>
2665 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2668 Make_Procedure_Call_Statement (Loc,
2670 New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2671 Parameter_Associations => New_List (
2672 New_Occurrence_Of (NVList, Loc))));
2673 end Declare_Create_NVList;
2675 ---------------------------------------------
2676 -- Expand_All_Calls_Remote_Subprogram_Call --
2677 ---------------------------------------------
2679 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2680 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2681 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2682 Loc : constant Source_Ptr := Sloc (N);
2683 RCI_Locator : Node_Id;
2684 RCI_Cache : Entity_Id;
2685 Calling_Stubs : Node_Id;
2686 E_Calling_Stubs : Entity_Id;
2689 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2691 if E_Calling_Stubs = Empty then
2692 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2694 if RCI_Cache = Empty then
2697 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2698 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2700 -- The RCI_Locator package is inserted at the top level in the
2701 -- current unit, and must appear in the proper scope, so that it
2702 -- is not prematurely removed by the GCC back-end.
2705 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2708 if Ekind (Scop) = E_Package_Body then
2709 Push_Scope (Spec_Entity (Scop));
2711 elsif Ekind (Scop) = E_Subprogram_Body then
2713 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2719 Analyze (RCI_Locator);
2723 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2726 RCI_Locator := Parent (RCI_Cache);
2729 Calling_Stubs := Build_Subprogram_Calling_Stubs
2730 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2732 Build_Subprogram_Id (Loc, Called_Subprogram),
2733 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2735 Is_Asynchronous (Called_Subprogram),
2736 Locator => RCI_Cache,
2737 New_Name => New_Internal_Name ('S'));
2738 Insert_After (RCI_Locator, Calling_Stubs);
2739 Analyze (Calling_Stubs);
2740 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2743 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2744 end Expand_All_Calls_Remote_Subprogram_Call;
2746 ---------------------------------
2747 -- Expand_Calling_Stubs_Bodies --
2748 ---------------------------------
2750 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2751 Spec : constant Node_Id := Specification (Unit_Node);
2752 Decls : constant List_Id := Visible_Declarations (Spec);
2754 Push_Scope (Scope_Of_Spec (Spec));
2755 Add_Calling_Stubs_To_Declarations
2756 (Specification (Unit_Node), Decls);
2758 end Expand_Calling_Stubs_Bodies;
2760 -----------------------------------
2761 -- Expand_Receiving_Stubs_Bodies --
2762 -----------------------------------
2764 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2767 Stubs_Decls : List_Id;
2768 Stubs_Stmts : List_Id;
2771 if Nkind (Unit_Node) = N_Package_Declaration then
2772 Spec := Specification (Unit_Node);
2773 Decls := Private_Declarations (Spec);
2776 Decls := Visible_Declarations (Spec);
2779 Push_Scope (Scope_Of_Spec (Spec));
2780 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2784 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2785 Decls := Declarations (Unit_Node);
2787 Push_Scope (Scope_Of_Spec (Unit_Node));
2788 Stubs_Decls := New_List;
2789 Stubs_Stmts := New_List;
2790 Specific_Add_Receiving_Stubs_To_Declarations
2791 (Spec, Stubs_Decls, Stubs_Stmts);
2793 Insert_List_Before (First (Decls), Stubs_Decls);
2796 HSS_Stmts : constant List_Id :=
2797 Statements (Handled_Statement_Sequence (Unit_Node));
2798 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2800 if No (First_HSS_Stmt) then
2801 Append_List_To (HSS_Stmts, Stubs_Stmts);
2803 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2809 end Expand_Receiving_Stubs_Bodies;
2811 --------------------
2812 -- GARLIC_Support --
2813 --------------------
2815 package body GARLIC_Support is
2817 -- Local subprograms
2819 procedure Add_RACW_Read_Attribute
2820 (RACW_Type : Entity_Id;
2821 Stub_Type : Entity_Id;
2822 Stub_Type_Access : Entity_Id;
2823 Body_Decls : List_Id);
2824 -- Add Read attribute for the RACW type. The declaration and attribute
2825 -- definition clauses are inserted right after the declaration of
2826 -- RACW_Type, while the subprogram body is appended to Body_Decls.
2828 procedure Add_RACW_Write_Attribute
2829 (RACW_Type : Entity_Id;
2830 Stub_Type : Entity_Id;
2831 Stub_Type_Access : Entity_Id;
2832 RPC_Receiver : Node_Id;
2833 Body_Decls : List_Id);
2834 -- Same as above for the Write attribute
2836 function Stream_Parameter return Node_Id;
2837 function Result return Node_Id;
2838 function Object return Node_Id renames Result;
2839 -- Functions to create occurrences of the formal parameter names of the
2840 -- 'Read and 'Write attributes.
2843 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2844 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2846 procedure Add_RAS_Access_TSS (N : Node_Id);
2847 -- Add a subprogram body for RAS Access TSS
2849 -------------------------------------
2850 -- Add_Obj_RPC_Receiver_Completion --
2851 -------------------------------------
2853 procedure Add_Obj_RPC_Receiver_Completion
2856 RPC_Receiver : Entity_Id;
2857 Stub_Elements : Stub_Structure) is
2859 -- The RPC receiver body should not be the completion of the
2860 -- declaration recorded in the stub structure, because then the
2861 -- occurrences of the formal parameters within the body should refer
2862 -- to the entities from the declaration, not from the completion, to
2863 -- which we do not have easy access. Instead, the RPC receiver body
2864 -- acts as its own declaration, and the RPC receiver declaration is
2865 -- completed by a renaming-as-body.
2868 Make_Subprogram_Renaming_Declaration (Loc,
2870 Copy_Specification (Loc,
2871 Specification (Stub_Elements.RPC_Receiver_Decl)),
2872 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2873 end Add_Obj_RPC_Receiver_Completion;
2875 -----------------------
2876 -- Add_RACW_Features --
2877 -----------------------
2879 procedure Add_RACW_Features
2880 (RACW_Type : Entity_Id;
2881 Stub_Type : Entity_Id;
2882 Stub_Type_Access : Entity_Id;
2883 RPC_Receiver_Decl : Node_Id;
2884 Body_Decls : List_Id)
2886 RPC_Receiver : Node_Id;
2887 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2890 Loc := Sloc (RACW_Type);
2894 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2895 -- of the corresponding distributed object type. We retrieve its
2896 -- address from the local proxy object.
2898 RPC_Receiver := Make_Selected_Component (Loc,
2900 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2901 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2904 RPC_Receiver := Make_Attribute_Reference (Loc,
2905 Prefix => New_Occurrence_Of (
2906 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2907 Attribute_Name => Name_Address);
2910 Add_RACW_Write_Attribute (
2917 Add_RACW_Read_Attribute (
2922 end Add_RACW_Features;
2924 -----------------------------
2925 -- Add_RACW_Read_Attribute --
2926 -----------------------------
2928 procedure Add_RACW_Read_Attribute
2929 (RACW_Type : Entity_Id;
2930 Stub_Type : Entity_Id;
2931 Stub_Type_Access : Entity_Id;
2932 Body_Decls : List_Id)
2934 Proc_Decl : Node_Id;
2935 Attr_Decl : Node_Id;
2937 Body_Node : Node_Id;
2940 Statements : List_Id;
2941 Local_Statements : List_Id;
2942 Remote_Statements : List_Id;
2943 -- Various parts of the procedure
2945 Procedure_Name : constant Name_Id :=
2946 New_Internal_Name ('R');
2947 Source_Partition : constant Entity_Id :=
2948 Make_Defining_Identifier
2949 (Loc, New_Internal_Name ('P'));
2950 Source_Receiver : constant Entity_Id :=
2951 Make_Defining_Identifier
2952 (Loc, New_Internal_Name ('S'));
2953 Source_Address : constant Entity_Id :=
2954 Make_Defining_Identifier
2955 (Loc, New_Internal_Name ('P'));
2956 Local_Stub : constant Entity_Id :=
2957 Make_Defining_Identifier
2958 (Loc, New_Internal_Name ('L'));
2959 Stubbed_Result : constant Entity_Id :=
2960 Make_Defining_Identifier
2961 (Loc, New_Internal_Name ('S'));
2962 Asynchronous_Flag : constant Entity_Id :=
2963 Asynchronous_Flags_Table.Get (RACW_Type);
2964 pragma Assert (Present (Asynchronous_Flag));
2966 -- Start of processing for Add_RACW_Read_Attribute
2969 -- Generate object declarations
2972 Make_Object_Declaration (Loc,
2973 Defining_Identifier => Source_Partition,
2974 Object_Definition =>
2975 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
2977 Make_Object_Declaration (Loc,
2978 Defining_Identifier => Source_Receiver,
2979 Object_Definition =>
2980 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2982 Make_Object_Declaration (Loc,
2983 Defining_Identifier => Source_Address,
2984 Object_Definition =>
2985 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2987 Make_Object_Declaration (Loc,
2988 Defining_Identifier => Local_Stub,
2989 Aliased_Present => True,
2990 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
2992 Make_Object_Declaration (Loc,
2993 Defining_Identifier => Stubbed_Result,
2994 Object_Definition =>
2995 New_Occurrence_Of (Stub_Type_Access, Loc),
2997 Make_Attribute_Reference (Loc,
2999 New_Occurrence_Of (Local_Stub, Loc),
3001 Name_Unchecked_Access)));
3003 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3005 Statements := New_List (
3006 Make_Attribute_Reference (Loc,
3008 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3009 Attribute_Name => Name_Read,
3010 Expressions => New_List (
3012 New_Occurrence_Of (Source_Partition, Loc))),
3014 Make_Attribute_Reference (Loc,
3016 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3019 Expressions => New_List (
3021 New_Occurrence_Of (Source_Receiver, Loc))),
3023 Make_Attribute_Reference (Loc,
3025 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3028 Expressions => New_List (
3030 New_Occurrence_Of (Source_Address, Loc))));
3032 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3034 Set_Etype (Stubbed_Result, Stub_Type_Access);
3036 -- If the Address is Null_Address, then return a null object
3038 Append_To (Statements,
3039 Make_Implicit_If_Statement (RACW_Type,
3042 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3043 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3044 Then_Statements => New_List (
3045 Make_Assignment_Statement (Loc,
3047 Expression => Make_Null (Loc)),
3048 Make_Simple_Return_Statement (Loc))));
3050 -- If the RACW denotes an object created on the current partition,
3051 -- Local_Statements will be executed. The real object will be used.
3053 Local_Statements := New_List (
3054 Make_Assignment_Statement (Loc,
3057 Unchecked_Convert_To (RACW_Type,
3058 OK_Convert_To (RTE (RE_Address),
3059 New_Occurrence_Of (Source_Address, Loc)))));
3061 -- If the object is located on another partition, then a stub object
3062 -- will be created with all the information needed to rebuild the
3063 -- real object at the other end.
3065 Remote_Statements := New_List (
3067 Make_Assignment_Statement (Loc,
3068 Name => Make_Selected_Component (Loc,
3069 Prefix => Stubbed_Result,
3070 Selector_Name => Name_Origin),
3072 New_Occurrence_Of (Source_Partition, Loc)),
3074 Make_Assignment_Statement (Loc,
3075 Name => Make_Selected_Component (Loc,
3076 Prefix => Stubbed_Result,
3077 Selector_Name => Name_Receiver),
3079 New_Occurrence_Of (Source_Receiver, Loc)),
3081 Make_Assignment_Statement (Loc,
3082 Name => Make_Selected_Component (Loc,
3083 Prefix => Stubbed_Result,
3084 Selector_Name => Name_Addr),
3086 New_Occurrence_Of (Source_Address, Loc)));
3088 Append_To (Remote_Statements,
3089 Make_Assignment_Statement (Loc,
3090 Name => Make_Selected_Component (Loc,
3091 Prefix => Stubbed_Result,
3092 Selector_Name => Name_Asynchronous),
3094 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3096 Append_List_To (Remote_Statements,
3097 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3098 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3099 -- set on the stub type if, and only if, the RACW type has a pragma
3100 -- Asynchronous. This is incorrect for RACWs that implement RAS
3101 -- types, because in that case the /designated subprogram/ (not the
3102 -- type) might be asynchronous, and that causes the stub to need to
3103 -- be asynchronous too. A solution is to transport a RAS as a struct
3104 -- containing a RACW and an asynchronous flag, and to properly alter
3105 -- the Asynchronous component in the stub type in the RAS's Input
3108 Append_To (Remote_Statements,
3109 Make_Assignment_Statement (Loc,
3111 Expression => Unchecked_Convert_To (RACW_Type,
3112 New_Occurrence_Of (Stubbed_Result, Loc))));
3114 -- Distinguish between the local and remote cases, and execute the
3115 -- appropriate piece of code.
3117 Append_To (Statements,
3118 Make_Implicit_If_Statement (RACW_Type,
3122 Make_Function_Call (Loc,
3123 Name => New_Occurrence_Of (
3124 RTE (RE_Get_Local_Partition_Id), Loc)),
3125 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3126 Then_Statements => Local_Statements,
3127 Else_Statements => Remote_Statements));
3129 Build_Stream_Procedure
3130 (Loc, RACW_Type, Body_Node,
3131 Make_Defining_Identifier (Loc, Procedure_Name),
3132 Statements, Outp => True);
3133 Set_Declarations (Body_Node, Decls);
3135 Proc_Decl := Make_Subprogram_Declaration (Loc,
3136 Copy_Specification (Loc, Specification (Body_Node)));
3139 Make_Attribute_Definition_Clause (Loc,
3140 Name => New_Occurrence_Of (RACW_Type, Loc),
3144 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3146 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3147 Insert_After (Proc_Decl, Attr_Decl);
3148 Append_To (Body_Decls, Body_Node);
3149 end Add_RACW_Read_Attribute;
3151 ------------------------------
3152 -- Add_RACW_Write_Attribute --
3153 ------------------------------
3155 procedure Add_RACW_Write_Attribute
3156 (RACW_Type : Entity_Id;
3157 Stub_Type : Entity_Id;
3158 Stub_Type_Access : Entity_Id;
3159 RPC_Receiver : Node_Id;
3160 Body_Decls : List_Id)
3162 Body_Node : Node_Id;
3163 Proc_Decl : Node_Id;
3164 Attr_Decl : Node_Id;
3166 Statements : List_Id;
3167 Local_Statements : List_Id;
3168 Remote_Statements : List_Id;
3169 Null_Statements : List_Id;
3171 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
3174 -- Build the code fragment corresponding to the marshalling of a
3177 Local_Statements := New_List (
3179 Pack_Entity_Into_Stream_Access (Loc,
3180 Stream => Stream_Parameter,
3181 Object => RTE (RE_Get_Local_Partition_Id)),
3183 Pack_Node_Into_Stream_Access (Loc,
3184 Stream => Stream_Parameter,
3185 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3186 Etyp => RTE (RE_Unsigned_64)),
3188 Pack_Node_Into_Stream_Access (Loc,
3189 Stream => Stream_Parameter,
3190 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3191 Make_Attribute_Reference (Loc,
3193 Make_Explicit_Dereference (Loc,
3195 Attribute_Name => Name_Address)),
3196 Etyp => RTE (RE_Unsigned_64)));
3198 -- Build the code fragment corresponding to the marshalling of
3201 Remote_Statements := New_List (
3203 Pack_Node_Into_Stream_Access (Loc,
3204 Stream => Stream_Parameter,
3206 Make_Selected_Component (Loc,
3207 Prefix => Unchecked_Convert_To (Stub_Type_Access,
3210 Make_Identifier (Loc, Name_Origin)),
3211 Etyp => RTE (RE_Partition_ID)),
3213 Pack_Node_Into_Stream_Access (Loc,
3214 Stream => Stream_Parameter,
3216 Make_Selected_Component (Loc,
3217 Prefix => Unchecked_Convert_To (Stub_Type_Access,
3220 Make_Identifier (Loc, Name_Receiver)),
3221 Etyp => RTE (RE_Unsigned_64)),
3223 Pack_Node_Into_Stream_Access (Loc,
3224 Stream => Stream_Parameter,
3226 Make_Selected_Component (Loc,
3227 Prefix => Unchecked_Convert_To (Stub_Type_Access,
3230 Make_Identifier (Loc, Name_Addr)),
3231 Etyp => RTE (RE_Unsigned_64)));
3233 -- Build code fragment corresponding to marshalling of a null object
3235 Null_Statements := New_List (
3237 Pack_Entity_Into_Stream_Access (Loc,
3238 Stream => Stream_Parameter,
3239 Object => RTE (RE_Get_Local_Partition_Id)),
3241 Pack_Node_Into_Stream_Access (Loc,
3242 Stream => Stream_Parameter,
3243 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3244 Etyp => RTE (RE_Unsigned_64)),
3246 Pack_Node_Into_Stream_Access (Loc,
3247 Stream => Stream_Parameter,
3248 Object => Make_Integer_Literal (Loc, Uint_0),
3249 Etyp => RTE (RE_Unsigned_64)));
3251 Statements := New_List (
3252 Make_Implicit_If_Statement (RACW_Type,
3255 Left_Opnd => Object,
3256 Right_Opnd => Make_Null (Loc)),
3257 Then_Statements => Null_Statements,
3258 Elsif_Parts => New_List (
3259 Make_Elsif_Part (Loc,
3263 Make_Attribute_Reference (Loc,
3265 Attribute_Name => Name_Tag),
3267 Make_Attribute_Reference (Loc,
3268 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3269 Attribute_Name => Name_Tag)),
3270 Then_Statements => Remote_Statements)),
3271 Else_Statements => Local_Statements));
3273 Build_Stream_Procedure
3274 (Loc, RACW_Type, Body_Node,
3275 Make_Defining_Identifier (Loc, Procedure_Name),
3276 Statements, Outp => False);
3278 Proc_Decl := Make_Subprogram_Declaration (Loc,
3279 Copy_Specification (Loc, Specification (Body_Node)));
3282 Make_Attribute_Definition_Clause (Loc,
3283 Name => New_Occurrence_Of (RACW_Type, Loc),
3284 Chars => Name_Write,
3287 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3289 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3290 Insert_After (Proc_Decl, Attr_Decl);
3291 Append_To (Body_Decls, Body_Node);
3292 end Add_RACW_Write_Attribute;
3294 ------------------------
3295 -- Add_RAS_Access_TSS --
3296 ------------------------
3298 procedure Add_RAS_Access_TSS (N : Node_Id) is
3299 Loc : constant Source_Ptr := Sloc (N);
3301 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3302 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3303 -- Ras_Type is the access to subprogram type while Fat_Type is the
3304 -- corresponding record type.
3306 RACW_Type : constant Entity_Id :=
3307 Underlying_RACW_Type (Ras_Type);
3308 Desig : constant Entity_Id :=
3309 Etype (Designated_Type (RACW_Type));
3311 Stub_Elements : constant Stub_Structure :=
3312 Stubs_Table.Get (Desig);
3313 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3315 Proc : constant Entity_Id :=
3316 Make_Defining_Identifier (Loc,
3317 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3319 Proc_Spec : Node_Id;
3321 -- Formal parameters
3323 Package_Name : constant Entity_Id :=
3324 Make_Defining_Identifier (Loc,
3328 Subp_Id : constant Entity_Id :=
3329 Make_Defining_Identifier (Loc,
3331 -- Target subprogram
3333 Asynch_P : constant Entity_Id :=
3334 Make_Defining_Identifier (Loc,
3335 Chars => Name_Asynchronous);
3336 -- Is the procedure to which the 'Access applies asynchronous?
3338 All_Calls_Remote : constant Entity_Id :=
3339 Make_Defining_Identifier (Loc,
3340 Chars => Name_All_Calls_Remote);
3341 -- True if an All_Calls_Remote pragma applies to the RCI unit
3342 -- that contains the subprogram.
3344 -- Common local variables
3346 Proc_Decls : List_Id;
3347 Proc_Statements : List_Id;
3349 Origin : constant Entity_Id :=
3350 Make_Defining_Identifier (Loc,
3351 Chars => New_Internal_Name ('P'));
3353 -- Additional local variables for the local case
3355 Proxy_Addr : constant Entity_Id :=
3356 Make_Defining_Identifier (Loc,
3357 Chars => New_Internal_Name ('P'));
3359 -- Additional local variables for the remote case
3361 Local_Stub : constant Entity_Id :=
3362 Make_Defining_Identifier (Loc,
3363 Chars => New_Internal_Name ('L'));
3365 Stub_Ptr : constant Entity_Id :=
3366 Make_Defining_Identifier (Loc,
3367 Chars => New_Internal_Name ('S'));
3370 (Field_Name : Name_Id;
3371 Value : Node_Id) return Node_Id;
3372 -- Construct an assignment that sets the named component in the
3380 (Field_Name : Name_Id;
3381 Value : Node_Id) return Node_Id
3385 Make_Assignment_Statement (Loc,
3387 Make_Selected_Component (Loc,
3389 Selector_Name => Field_Name),
3390 Expression => Value);
3393 -- Start of processing for Add_RAS_Access_TSS
3396 Proc_Decls := New_List (
3398 -- Common declarations
3400 Make_Object_Declaration (Loc,
3401 Defining_Identifier => Origin,
3402 Constant_Present => True,
3403 Object_Definition =>
3404 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3406 Make_Function_Call (Loc,
3408 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3409 Parameter_Associations => New_List (
3410 New_Occurrence_Of (Package_Name, Loc)))),
3412 -- Declaration use only in the local case: proxy address
3414 Make_Object_Declaration (Loc,
3415 Defining_Identifier => Proxy_Addr,
3416 Object_Definition =>
3417 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3419 -- Declarations used only in the remote case: stub object and
3422 Make_Object_Declaration (Loc,
3423 Defining_Identifier => Local_Stub,
3424 Aliased_Present => True,
3425 Object_Definition =>
3426 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3428 Make_Object_Declaration (Loc,
3429 Defining_Identifier =>
3431 Object_Definition =>
3432 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3434 Make_Attribute_Reference (Loc,
3435 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3436 Attribute_Name => Name_Unchecked_Access)));
3438 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3439 -- Build_Get_Unique_RP_Call needs this information
3441 -- Note: Here we assume that the Fat_Type is a record
3442 -- containing just a pointer to a proxy or stub object.
3444 Proc_Statements := New_List (
3448 -- Get_RAS_Info (Pkg, Subp, PA);
3449 -- if Origin = Local_Partition_Id
3450 -- and then not All_Calls_Remote
3452 -- return Fat_Type!(PA);
3455 Make_Procedure_Call_Statement (Loc,
3457 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3458 Parameter_Associations => New_List (
3459 New_Occurrence_Of (Package_Name, Loc),
3460 New_Occurrence_Of (Subp_Id, Loc),
3461 New_Occurrence_Of (Proxy_Addr, Loc))),
3463 Make_Implicit_If_Statement (N,
3469 New_Occurrence_Of (Origin, Loc),
3471 Make_Function_Call (Loc,
3473 RTE (RE_Get_Local_Partition_Id), Loc))),
3476 New_Occurrence_Of (All_Calls_Remote, Loc))),
3477 Then_Statements => New_List (
3478 Make_Simple_Return_Statement (Loc,
3479 Unchecked_Convert_To (Fat_Type,
3480 OK_Convert_To (RTE (RE_Address),
3481 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3483 Set_Field (Name_Origin,
3484 New_Occurrence_Of (Origin, Loc)),
3486 Set_Field (Name_Receiver,
3487 Make_Function_Call (Loc,
3489 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3490 Parameter_Associations => New_List (
3491 New_Occurrence_Of (Package_Name, Loc)))),
3493 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3495 -- E.4.1(9) A remote call is asynchronous if it is a call to
3496 -- a procedure, or a call through a value of an access-to-procedure
3497 -- type, to which a pragma Asynchronous applies.
3499 -- Parameter Asynch_P is true when the procedure is asynchronous;
3500 -- Expression Asynch_T is true when the type is asynchronous.
3502 Set_Field (Name_Asynchronous,
3504 New_Occurrence_Of (Asynch_P, Loc),
3505 New_Occurrence_Of (Boolean_Literals (
3506 Is_Asynchronous (Ras_Type)), Loc))));
3508 Append_List_To (Proc_Statements,
3509 Build_Get_Unique_RP_Call
3510 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3512 -- Return the newly created value
3514 Append_To (Proc_Statements,
3515 Make_Simple_Return_Statement (Loc,
3517 Unchecked_Convert_To (Fat_Type,
3518 New_Occurrence_Of (Stub_Ptr, Loc))));
3521 Make_Function_Specification (Loc,
3522 Defining_Unit_Name => Proc,
3523 Parameter_Specifications => New_List (
3524 Make_Parameter_Specification (Loc,
3525 Defining_Identifier => Package_Name,
3527 New_Occurrence_Of (Standard_String, Loc)),
3529 Make_Parameter_Specification (Loc,
3530 Defining_Identifier => Subp_Id,
3532 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3534 Make_Parameter_Specification (Loc,
3535 Defining_Identifier => Asynch_P,
3537 New_Occurrence_Of (Standard_Boolean, Loc)),
3539 Make_Parameter_Specification (Loc,
3540 Defining_Identifier => All_Calls_Remote,
3542 New_Occurrence_Of (Standard_Boolean, Loc))),
3544 Result_Definition =>
3545 New_Occurrence_Of (Fat_Type, Loc));
3547 -- Set the kind and return type of the function to prevent
3548 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3550 Set_Ekind (Proc, E_Function);
3551 Set_Etype (Proc, Fat_Type);
3554 Make_Subprogram_Body (Loc,
3555 Specification => Proc_Spec,
3556 Declarations => Proc_Decls,
3557 Handled_Statement_Sequence =>
3558 Make_Handled_Sequence_Of_Statements (Loc,
3559 Statements => Proc_Statements)));
3561 Set_TSS (Fat_Type, Proc);
3562 end Add_RAS_Access_TSS;
3564 -----------------------
3565 -- Add_RAST_Features --
3566 -----------------------
3568 procedure Add_RAST_Features
3569 (Vis_Decl : Node_Id;
3570 RAS_Type : Entity_Id)
3572 pragma Warnings (Off);
3573 pragma Unreferenced (RAS_Type);
3574 pragma Warnings (On);
3576 Add_RAS_Access_TSS (Vis_Decl);
3577 end Add_RAST_Features;
3579 -----------------------------------------
3580 -- Add_Receiving_Stubs_To_Declarations --
3581 -----------------------------------------
3583 procedure Add_Receiving_Stubs_To_Declarations
3584 (Pkg_Spec : Node_Id;
3588 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3590 Request_Parameter : Node_Id;
3592 Pkg_RPC_Receiver : constant Entity_Id :=
3593 Make_Defining_Identifier (Loc,
3594 New_Internal_Name ('H'));
3595 Pkg_RPC_Receiver_Statements : List_Id;
3596 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3597 Pkg_RPC_Receiver_Body : Node_Id;
3598 -- A Pkg_RPC_Receiver is built to decode the request
3600 Lookup_RAS_Info : constant Entity_Id :=
3601 Make_Defining_Identifier (Loc,
3602 Chars => New_Internal_Name ('R'));
3603 -- A remote subprogram is created to allow peers to look up
3604 -- RAS information using subprogram ids.
3606 Subp_Id : Entity_Id;
3607 Subp_Index : Entity_Id;
3608 -- Subprogram_Id as read from the incoming stream
3610 Current_Declaration : Node_Id;
3611 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3612 Current_Stubs : Node_Id;
3614 Subp_Info_Array : constant Entity_Id :=
3615 Make_Defining_Identifier (Loc,
3616 Chars => New_Internal_Name ('I'));
3618 Subp_Info_List : constant List_Id := New_List;
3620 Register_Pkg_Actuals : constant List_Id := New_List;
3622 All_Calls_Remote_E : Entity_Id;
3623 Proxy_Object_Addr : Entity_Id;
3625 procedure Append_Stubs_To
3626 (RPC_Receiver_Cases : List_Id;
3628 Subprogram_Number : Int);
3629 -- Add one case to the specified RPC receiver case list
3630 -- associating Subprogram_Number with the subprogram declared
3631 -- by Declaration, for which we have receiving stubs in Stubs.
3633 ---------------------
3634 -- Append_Stubs_To --
3635 ---------------------
3637 procedure Append_Stubs_To
3638 (RPC_Receiver_Cases : List_Id;
3640 Subprogram_Number : Int)
3643 Append_To (RPC_Receiver_Cases,
3644 Make_Case_Statement_Alternative (Loc,
3646 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3649 Make_Procedure_Call_Statement (Loc,
3652 Defining_Entity (Stubs), Loc),
3653 Parameter_Associations => New_List (
3654 New_Occurrence_Of (Request_Parameter, Loc))))));
3655 end Append_Stubs_To;
3657 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3660 -- Building receiving stubs consist in several operations:
3662 -- - a package RPC receiver must be built. This subprogram
3663 -- will get a Subprogram_Id from the incoming stream
3664 -- and will dispatch the call to the right subprogram;
3666 -- - a receiving stub for each subprogram visible in the package
3667 -- spec. This stub will read all the parameters from the stream,
3668 -- and put the result as well as the exception occurrence in the
3671 -- - a dummy package with an empty spec and a body made of an
3672 -- elaboration part, whose job is to register the receiving
3673 -- part of this RCI package on the name server. This is done
3674 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3676 Build_RPC_Receiver_Body (
3677 RPC_Receiver => Pkg_RPC_Receiver,
3678 Request => Request_Parameter,
3680 Subp_Index => Subp_Index,
3681 Stmts => Pkg_RPC_Receiver_Statements,
3682 Decl => Pkg_RPC_Receiver_Body);
3683 pragma Assert (Subp_Id = Subp_Index);
3685 -- A null subp_id denotes a call through a RAS, in which case the
3686 -- next Uint_64 element in the stream is the address of the local
3687 -- proxy object, from which we can retrieve the actual subprogram id.
3689 Append_To (Pkg_RPC_Receiver_Statements,
3690 Make_Implicit_If_Statement (Pkg_Spec,
3693 New_Occurrence_Of (Subp_Id, Loc),
3694 Make_Integer_Literal (Loc, 0)),
3695 Then_Statements => New_List (
3696 Make_Assignment_Statement (Loc,
3698 New_Occurrence_Of (Subp_Id, Loc),
3700 Make_Selected_Component (Loc,
3702 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3703 OK_Convert_To (RTE (RE_Address),
3704 Make_Attribute_Reference (Loc,
3706 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3709 Expressions => New_List (
3710 Make_Selected_Component (Loc,
3711 Prefix => Request_Parameter,
3712 Selector_Name => Name_Params))))),
3714 Make_Identifier (Loc, Name_Subp_Id))))));
3716 -- Build a subprogram for RAS information lookups
3718 Current_Declaration :=
3719 Make_Subprogram_Declaration (Loc,
3721 Make_Function_Specification (Loc,
3722 Defining_Unit_Name =>
3724 Parameter_Specifications => New_List (
3725 Make_Parameter_Specification (Loc,
3726 Defining_Identifier =>
3727 Make_Defining_Identifier (Loc, Name_Subp_Id),
3731 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3732 Result_Definition =>
3733 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3734 Append_To (Decls, Current_Declaration);
3735 Analyze (Current_Declaration);
3737 Current_Stubs := Build_Subprogram_Receiving_Stubs
3738 (Vis_Decl => Current_Declaration,
3739 Asynchronous => False);
3740 Append_To (Decls, Current_Stubs);
3741 Analyze (Current_Stubs);
3743 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3746 Subprogram_Number => 1);
3748 -- For each subprogram, the receiving stub will be built and a
3749 -- case statement will be made on the Subprogram_Id to dispatch
3750 -- to the right subprogram.
3752 All_Calls_Remote_E := Boolean_Literals (
3753 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3755 Overload_Counter_Table.Reset;
3757 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3758 while Present (Current_Declaration) loop
3759 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3760 and then Comes_From_Source (Current_Declaration)
3763 Loc : constant Source_Ptr :=
3764 Sloc (Current_Declaration);
3765 -- While specifically processing Current_Declaration, use
3766 -- its Sloc as the location of all generated nodes.
3768 Subp_Def : constant Entity_Id :=
3770 (Specification (Current_Declaration));
3772 Subp_Val : String_Id;
3775 -- Build receiving stub
3778 Build_Subprogram_Receiving_Stubs
3779 (Vis_Decl => Current_Declaration,
3781 Nkind (Specification (Current_Declaration)) =
3782 N_Procedure_Specification
3783 and then Is_Asynchronous (Subp_Def));
3785 Append_To (Decls, Current_Stubs);
3786 Analyze (Current_Stubs);
3790 Add_RAS_Proxy_And_Analyze (Decls,
3792 Current_Declaration,
3793 All_Calls_Remote_E =>
3795 Proxy_Object_Addr =>
3798 -- Compute distribution identifier
3800 Assign_Subprogram_Identifier (
3802 Current_Subprogram_Number,
3805 pragma Assert (Current_Subprogram_Number =
3806 Get_Subprogram_Id (Subp_Def));
3808 -- Add subprogram descriptor (RCI_Subp_Info) to the
3809 -- subprograms table for this receiver. The aggregate
3810 -- below must be kept consistent with the declaration
3811 -- of type RCI_Subp_Info in System.Partition_Interface.
3813 Append_To (Subp_Info_List,
3814 Make_Component_Association (Loc,
3815 Choices => New_List (
3816 Make_Integer_Literal (Loc,
3817 Current_Subprogram_Number)),
3819 Make_Aggregate (Loc,
3820 Component_Associations => New_List (
3821 Make_Component_Association (Loc,
3822 Choices => New_List (
3823 Make_Identifier (Loc, Name_Addr)),
3826 Proxy_Object_Addr, Loc))))));
3828 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3831 Subprogram_Number =>
3832 Current_Subprogram_Number);
3835 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3838 Next (Current_Declaration);
3841 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3842 -- rather than raising an exception since we do not want someone
3843 -- to crash a remote partition by sending invalid subprogram ids.
3844 -- This is consistent with the other parts of the case statement
3845 -- since even in presence of incorrect parameters in the stream,
3846 -- every exception will be caught and (if the subprogram is not an
3847 -- APC) put into the result stream and sent away.
3849 Append_To (Pkg_RPC_Receiver_Cases,
3850 Make_Case_Statement_Alternative (Loc,
3852 New_List (Make_Others_Choice (Loc)),
3854 New_List (Make_Null_Statement (Loc))));
3856 Append_To (Pkg_RPC_Receiver_Statements,
3857 Make_Case_Statement (Loc,
3859 New_Occurrence_Of (Subp_Id, Loc),
3860 Alternatives => Pkg_RPC_Receiver_Cases));
3863 Make_Object_Declaration (Loc,
3864 Defining_Identifier => Subp_Info_Array,
3865 Constant_Present => True,
3866 Aliased_Present => True,
3867 Object_Definition =>
3868 Make_Subtype_Indication (Loc,
3870 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3872 Make_Index_Or_Discriminant_Constraint (Loc,
3875 Low_Bound => Make_Integer_Literal (Loc,
3876 First_RCI_Subprogram_Id),
3878 Make_Integer_Literal (Loc,
3879 First_RCI_Subprogram_Id
3880 + List_Length (Subp_Info_List) - 1)))))));
3882 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3883 -- has zero length, and the declaration is for an empty array, in
3884 -- which case no initialization aggregate must be generated.
3886 if Present (First (Subp_Info_List)) then
3887 Set_Expression (Last (Decls),
3888 Make_Aggregate (Loc,
3889 Component_Associations => Subp_Info_List));
3891 -- No initialization provided: remove CONSTANT so that the
3892 -- declaration is not an incomplete deferred constant.
3895 Set_Constant_Present (Last (Decls), False);
3898 Analyze (Last (Decls));
3901 Subp_Info_Addr : Node_Id;
3902 -- Return statement for Lookup_RAS_Info: address of the subprogram
3903 -- information record for the requested subprogram id.
3906 if Present (First (Subp_Info_List)) then
3908 Make_Selected_Component (Loc,
3910 Make_Indexed_Component (Loc,
3912 New_Occurrence_Of (Subp_Info_Array, Loc),
3913 Expressions => New_List (
3914 Convert_To (Standard_Integer,
3915 Make_Identifier (Loc, Name_Subp_Id)))),
3917 Make_Identifier (Loc, Name_Addr));
3919 -- Case of no visible subprogram: just raise Constraint_Error, we
3920 -- know for sure we got junk from a remote partition.
3924 Make_Raise_Constraint_Error (Loc,
3925 Reason => CE_Range_Check_Failed);
3926 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
3930 Make_Subprogram_Body (Loc,
3932 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
3935 Handled_Statement_Sequence =>
3936 Make_Handled_Sequence_Of_Statements (Loc,
3937 Statements => New_List (
3938 Make_Simple_Return_Statement (Loc,
3940 OK_Convert_To (RTE (RE_Unsigned_64),
3941 Subp_Info_Addr))))));
3944 Analyze (Last (Decls));
3946 Append_To (Decls, Pkg_RPC_Receiver_Body);
3947 Analyze (Last (Decls));
3949 Get_Library_Unit_Name_String (Pkg_Spec);
3953 Append_To (Register_Pkg_Actuals,
3954 Make_String_Literal (Loc,
3955 Strval => String_From_Name_Buffer));
3959 Append_To (Register_Pkg_Actuals,
3960 Make_Attribute_Reference (Loc,
3962 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
3964 Name_Unrestricted_Access));
3968 Append_To (Register_Pkg_Actuals,
3969 Make_Attribute_Reference (Loc,
3971 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
3977 Append_To (Register_Pkg_Actuals,
3978 Make_Attribute_Reference (Loc,
3980 New_Occurrence_Of (Subp_Info_Array, Loc),
3986 Append_To (Register_Pkg_Actuals,
3987 Make_Attribute_Reference (Loc,
3989 New_Occurrence_Of (Subp_Info_Array, Loc),
3993 -- Generate the call
3996 Make_Procedure_Call_Statement (Loc,
3998 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
3999 Parameter_Associations => Register_Pkg_Actuals));
4000 Analyze (Last (Stmts));
4001 end Add_Receiving_Stubs_To_Declarations;
4003 ---------------------------------
4004 -- Build_General_Calling_Stubs --
4005 ---------------------------------
4007 procedure Build_General_Calling_Stubs
4009 Statements : List_Id;
4010 Target_Partition : Entity_Id;
4011 Target_RPC_Receiver : Node_Id;
4012 Subprogram_Id : Node_Id;
4013 Asynchronous : Node_Id := Empty;
4014 Is_Known_Asynchronous : Boolean := False;
4015 Is_Known_Non_Asynchronous : Boolean := False;
4016 Is_Function : Boolean;
4018 Stub_Type : Entity_Id := Empty;
4019 RACW_Type : Entity_Id := Empty;
4022 Loc : constant Source_Ptr := Sloc (Nod);
4024 Stream_Parameter : Node_Id;
4025 -- Name of the stream used to transmit parameters to the
4028 Result_Parameter : Node_Id;
4029 -- Name of the result parameter (in non-APC cases) which get the
4030 -- result of the remote subprogram.
4032 Exception_Return_Parameter : Node_Id;
4033 -- Name of the parameter which will hold the exception sent by the
4034 -- remote subprogram.
4036 Current_Parameter : Node_Id;
4037 -- Current parameter being handled
4039 Ordered_Parameters_List : constant List_Id :=
4040 Build_Ordered_Parameters_List (Spec);
4042 Asynchronous_Statements : List_Id := No_List;
4043 Non_Asynchronous_Statements : List_Id := No_List;
4044 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4046 Extra_Formal_Statements : constant List_Id := New_List;
4047 -- List of statements for extra formal parameters. It will appear
4048 -- after the regular statements for writing out parameters.
4050 pragma Warnings (Off);
4051 pragma Unreferenced (RACW_Type);
4052 -- Used only for the PolyORB case
4053 pragma Warnings (On);
4056 -- The general form of a calling stub for a given subprogram is:
4058 -- procedure X (...) is P : constant Partition_ID :=
4059 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4060 -- System.RPC.Params_Stream_Type (0); begin
4061 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4062 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4063 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4064 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4066 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4068 -- There are some variations: Do_APC is called for an asynchronous
4069 -- procedure and the part after the call is completely ommitted as
4070 -- well as the declaration of Result. For a function call, 'Input is
4071 -- always used to read the result even if it is constrained.
4074 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4077 Make_Object_Declaration (Loc,
4078 Defining_Identifier => Stream_Parameter,
4079 Aliased_Present => True,
4080 Object_Definition =>
4081 Make_Subtype_Indication (Loc,
4083 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4085 Make_Index_Or_Discriminant_Constraint (Loc,
4087 New_List (Make_Integer_Literal (Loc, 0))))));
4089 if not Is_Known_Asynchronous then
4091 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4094 Make_Object_Declaration (Loc,
4095 Defining_Identifier => Result_Parameter,
4096 Aliased_Present => True,
4097 Object_Definition =>
4098 Make_Subtype_Indication (Loc,
4100 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4102 Make_Index_Or_Discriminant_Constraint (Loc,
4104 New_List (Make_Integer_Literal (Loc, 0))))));
4106 Exception_Return_Parameter :=
4107 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4110 Make_Object_Declaration (Loc,
4111 Defining_Identifier => Exception_Return_Parameter,
4112 Object_Definition =>
4113 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4116 Result_Parameter := Empty;
4117 Exception_Return_Parameter := Empty;
4120 -- Put first the RPC receiver corresponding to the remote package
4122 Append_To (Statements,
4123 Make_Attribute_Reference (Loc,
4125 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4126 Attribute_Name => Name_Write,
4127 Expressions => New_List (
4128 Make_Attribute_Reference (Loc,
4130 New_Occurrence_Of (Stream_Parameter, Loc),
4133 Target_RPC_Receiver)));
4135 -- Then put the Subprogram_Id of the subprogram we want to call in
4138 Append_To (Statements,
4139 Make_Attribute_Reference (Loc,
4141 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4144 Expressions => New_List (
4145 Make_Attribute_Reference (Loc,
4147 New_Occurrence_Of (Stream_Parameter, Loc),
4148 Attribute_Name => Name_Access),
4151 Current_Parameter := First (Ordered_Parameters_List);
4152 while Present (Current_Parameter) loop
4154 Typ : constant Node_Id :=
4155 Parameter_Type (Current_Parameter);
4157 Constrained : Boolean;
4159 Extra_Parameter : Entity_Id;
4162 if Is_RACW_Controlling_Formal
4163 (Current_Parameter, Stub_Type)
4165 -- In the case of a controlling formal argument, we marshall
4166 -- its addr field rather than the local stub.
4168 Append_To (Statements,
4169 Pack_Node_Into_Stream (Loc,
4170 Stream => Stream_Parameter,
4172 Make_Selected_Component (Loc,
4174 Defining_Identifier (Current_Parameter),
4175 Selector_Name => Name_Addr),
4176 Etyp => RTE (RE_Unsigned_64)));
4179 Value := New_Occurrence_Of
4180 (Defining_Identifier (Current_Parameter), Loc);
4182 -- Access type parameters are transmitted as in out
4183 -- parameters. However, a dereference is needed so that
4184 -- we marshall the designated object.
4186 if Nkind (Typ) = N_Access_Definition then
4187 Value := Make_Explicit_Dereference (Loc, Value);
4188 Etyp := Etype (Subtype_Mark (Typ));
4190 Etyp := Etype (Typ);
4194 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
4196 -- Any parameter but unconstrained out parameters are
4197 -- transmitted to the peer.
4199 if In_Present (Current_Parameter)
4200 or else not Out_Present (Current_Parameter)
4201 or else not Constrained
4203 Append_To (Statements,
4204 Make_Attribute_Reference (Loc,
4206 New_Occurrence_Of (Etyp, Loc),
4208 Output_From_Constrained (Constrained),
4209 Expressions => New_List (
4210 Make_Attribute_Reference (Loc,
4212 New_Occurrence_Of (Stream_Parameter, Loc),
4213 Attribute_Name => Name_Access),
4218 -- If the current parameter has a dynamic constrained status,
4219 -- then this status is transmitted as well.
4220 -- This should be done for accessibility as well ???
4222 if Nkind (Typ) /= N_Access_Definition
4223 and then Need_Extra_Constrained (Current_Parameter)
4225 -- In this block, we do not use the extra formal that has
4226 -- been created because it does not exist at the time of
4227 -- expansion when building calling stubs for remote access
4228 -- to subprogram types. We create an extra variable of this
4229 -- type and push it in the stream after the regular
4232 Extra_Parameter := Make_Defining_Identifier
4233 (Loc, New_Internal_Name ('P'));
4236 Make_Object_Declaration (Loc,
4237 Defining_Identifier => Extra_Parameter,
4238 Constant_Present => True,
4239 Object_Definition =>
4240 New_Occurrence_Of (Standard_Boolean, Loc),
4242 Make_Attribute_Reference (Loc,
4245 Defining_Identifier (Current_Parameter), Loc),
4246 Attribute_Name => Name_Constrained)));
4248 Append_To (Extra_Formal_Statements,
4249 Make_Attribute_Reference (Loc,
4251 New_Occurrence_Of (Standard_Boolean, Loc),
4254 Expressions => New_List (
4255 Make_Attribute_Reference (Loc,
4257 New_Occurrence_Of (Stream_Parameter, Loc),
4260 New_Occurrence_Of (Extra_Parameter, Loc))));
4263 Next (Current_Parameter);
4267 -- Append the formal statements list to the statements
4269 Append_List_To (Statements, Extra_Formal_Statements);
4271 if not Is_Known_Non_Asynchronous then
4273 -- Build the call to System.RPC.Do_APC
4275 Asynchronous_Statements := New_List (
4276 Make_Procedure_Call_Statement (Loc,
4278 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4279 Parameter_Associations => New_List (
4280 New_Occurrence_Of (Target_Partition, Loc),
4281 Make_Attribute_Reference (Loc,
4283 New_Occurrence_Of (Stream_Parameter, Loc),
4287 Asynchronous_Statements := No_List;
4290 if not Is_Known_Asynchronous then
4292 -- Build the call to System.RPC.Do_RPC
4294 Non_Asynchronous_Statements := New_List (
4295 Make_Procedure_Call_Statement (Loc,
4297 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4298 Parameter_Associations => New_List (
4299 New_Occurrence_Of (Target_Partition, Loc),
4301 Make_Attribute_Reference (Loc,
4303 New_Occurrence_Of (Stream_Parameter, Loc),
4307 Make_Attribute_Reference (Loc,
4309 New_Occurrence_Of (Result_Parameter, Loc),
4313 -- Read the exception occurrence from the result stream and
4314 -- reraise it. It does no harm if this is a Null_Occurrence since
4315 -- this does nothing.
4317 Append_To (Non_Asynchronous_Statements,
4318 Make_Attribute_Reference (Loc,
4320 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4325 Expressions => New_List (
4326 Make_Attribute_Reference (Loc,
4328 New_Occurrence_Of (Result_Parameter, Loc),
4331 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4333 Append_To (Non_Asynchronous_Statements,
4334 Make_Procedure_Call_Statement (Loc,
4336 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4337 Parameter_Associations => New_List (
4338 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4342 -- If this is a function call, then read the value and return
4343 -- it. The return value is written/read using 'Output/'Input.
4345 Append_To (Non_Asynchronous_Statements,
4346 Make_Tag_Check (Loc,
4347 Make_Simple_Return_Statement (Loc,
4349 Make_Attribute_Reference (Loc,
4352 Etype (Result_Definition (Spec)), Loc),
4354 Attribute_Name => Name_Input,
4356 Expressions => New_List (
4357 Make_Attribute_Reference (Loc,
4359 New_Occurrence_Of (Result_Parameter, Loc),
4360 Attribute_Name => Name_Access))))));
4363 -- Loop around parameters and assign out (or in out)
4364 -- parameters. In the case of RACW, controlling arguments
4365 -- cannot possibly have changed since they are remote, so we do
4366 -- not read them from the stream.
4368 Current_Parameter := First (Ordered_Parameters_List);
4369 while Present (Current_Parameter) loop
4371 Typ : constant Node_Id :=
4372 Parameter_Type (Current_Parameter);
4379 (Defining_Identifier (Current_Parameter), Loc);
4381 if Nkind (Typ) = N_Access_Definition then
4382 Value := Make_Explicit_Dereference (Loc, Value);
4383 Etyp := Etype (Subtype_Mark (Typ));
4385 Etyp := Etype (Typ);
4388 if (Out_Present (Current_Parameter)
4389 or else Nkind (Typ) = N_Access_Definition)
4390 and then Etyp /= Stub_Type
4392 Append_To (Non_Asynchronous_Statements,
4393 Make_Attribute_Reference (Loc,
4395 New_Occurrence_Of (Etyp, Loc),
4397 Attribute_Name => Name_Read,
4399 Expressions => New_List (
4400 Make_Attribute_Reference (Loc,
4402 New_Occurrence_Of (Result_Parameter, Loc),
4409 Next (Current_Parameter);
4414 if Is_Known_Asynchronous then
4415 Append_List_To (Statements, Asynchronous_Statements);
4417 elsif Is_Known_Non_Asynchronous then
4418 Append_List_To (Statements, Non_Asynchronous_Statements);
4421 pragma Assert (Present (Asynchronous));
4422 Prepend_To (Asynchronous_Statements,
4423 Make_Attribute_Reference (Loc,
4424 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4425 Attribute_Name => Name_Write,
4426 Expressions => New_List (
4427 Make_Attribute_Reference (Loc,
4429 New_Occurrence_Of (Stream_Parameter, Loc),
4430 Attribute_Name => Name_Access),
4431 New_Occurrence_Of (Standard_True, Loc))));
4433 Prepend_To (Non_Asynchronous_Statements,
4434 Make_Attribute_Reference (Loc,
4435 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4436 Attribute_Name => Name_Write,
4437 Expressions => New_List (
4438 Make_Attribute_Reference (Loc,
4440 New_Occurrence_Of (Stream_Parameter, Loc),
4441 Attribute_Name => Name_Access),
4442 New_Occurrence_Of (Standard_False, Loc))));
4444 Append_To (Statements,
4445 Make_Implicit_If_Statement (Nod,
4446 Condition => Asynchronous,
4447 Then_Statements => Asynchronous_Statements,
4448 Else_Statements => Non_Asynchronous_Statements));
4450 end Build_General_Calling_Stubs;
4452 -----------------------------
4453 -- Build_RPC_Receiver_Body --
4454 -----------------------------
4456 procedure Build_RPC_Receiver_Body
4457 (RPC_Receiver : Entity_Id;
4458 Request : out Entity_Id;
4459 Subp_Id : out Entity_Id;
4460 Subp_Index : out Entity_Id;
4461 Stmts : out List_Id;
4464 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4466 RPC_Receiver_Spec : Node_Id;
4467 RPC_Receiver_Decls : List_Id;
4470 Request := Make_Defining_Identifier (Loc, Name_R);
4472 RPC_Receiver_Spec :=
4473 Build_RPC_Receiver_Specification
4474 (RPC_Receiver => RPC_Receiver,
4475 Request_Parameter => Request);
4477 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4478 Subp_Index := Subp_Id;
4480 -- Subp_Id may not be a constant, because in the case of the RPC
4481 -- receiver for an RCI package, when a call is received from a RAS
4482 -- dereference, it will be assigned during subsequent processing.
4484 RPC_Receiver_Decls := New_List (
4485 Make_Object_Declaration (Loc,
4486 Defining_Identifier => Subp_Id,
4487 Object_Definition =>
4488 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4490 Make_Attribute_Reference (Loc,
4492 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4493 Attribute_Name => Name_Input,
4494 Expressions => New_List (
4495 Make_Selected_Component (Loc,
4497 Selector_Name => Name_Params)))));
4502 Make_Subprogram_Body (Loc,
4503 Specification => RPC_Receiver_Spec,
4504 Declarations => RPC_Receiver_Decls,
4505 Handled_Statement_Sequence =>
4506 Make_Handled_Sequence_Of_Statements (Loc,
4507 Statements => Stmts));
4508 end Build_RPC_Receiver_Body;
4510 -----------------------
4511 -- Build_Stub_Target --
4512 -----------------------
4514 function Build_Stub_Target
4517 RCI_Locator : Entity_Id;
4518 Controlling_Parameter : Entity_Id) return RPC_Target
4520 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4522 Target_Info.Partition :=
4523 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4524 if Present (Controlling_Parameter) then
4526 Make_Object_Declaration (Loc,
4527 Defining_Identifier => Target_Info.Partition,
4528 Constant_Present => True,
4529 Object_Definition =>
4530 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4533 Make_Selected_Component (Loc,
4534 Prefix => Controlling_Parameter,
4535 Selector_Name => Name_Origin)));
4537 Target_Info.RPC_Receiver :=
4538 Make_Selected_Component (Loc,
4539 Prefix => Controlling_Parameter,
4540 Selector_Name => Name_Receiver);
4544 Make_Object_Declaration (Loc,
4545 Defining_Identifier => Target_Info.Partition,
4546 Constant_Present => True,
4547 Object_Definition =>
4548 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4551 Make_Function_Call (Loc,
4552 Name => Make_Selected_Component (Loc,
4554 Make_Identifier (Loc, Chars (RCI_Locator)),
4556 Make_Identifier (Loc,
4557 Name_Get_Active_Partition_ID)))));
4559 Target_Info.RPC_Receiver :=
4560 Make_Selected_Component (Loc,
4562 Make_Identifier (Loc, Chars (RCI_Locator)),
4564 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4567 end Build_Stub_Target;
4569 ---------------------
4570 -- Build_Stub_Type --
4571 ---------------------
4573 procedure Build_Stub_Type
4574 (RACW_Type : Entity_Id;
4575 Stub_Type : Entity_Id;
4576 Stub_Type_Decl : out Node_Id;
4577 RPC_Receiver_Decl : out Node_Id)
4579 Loc : constant Source_Ptr := Sloc (Stub_Type);
4580 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4584 Make_Full_Type_Declaration (Loc,
4585 Defining_Identifier => Stub_Type,
4587 Make_Record_Definition (Loc,
4588 Tagged_Present => True,
4589 Limited_Present => True,
4591 Make_Component_List (Loc,
4592 Component_Items => New_List (
4594 Make_Component_Declaration (Loc,
4595 Defining_Identifier =>
4596 Make_Defining_Identifier (Loc, Name_Origin),
4597 Component_Definition =>
4598 Make_Component_Definition (Loc,
4599 Aliased_Present => False,
4600 Subtype_Indication =>
4602 RTE (RE_Partition_ID), Loc))),
4604 Make_Component_Declaration (Loc,
4605 Defining_Identifier =>
4606 Make_Defining_Identifier (Loc, Name_Receiver),
4607 Component_Definition =>
4608 Make_Component_Definition (Loc,
4609 Aliased_Present => False,
4610 Subtype_Indication =>
4611 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4613 Make_Component_Declaration (Loc,
4614 Defining_Identifier =>
4615 Make_Defining_Identifier (Loc, Name_Addr),
4616 Component_Definition =>
4617 Make_Component_Definition (Loc,
4618 Aliased_Present => False,
4619 Subtype_Indication =>
4620 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4622 Make_Component_Declaration (Loc,
4623 Defining_Identifier =>
4624 Make_Defining_Identifier (Loc, Name_Asynchronous),
4625 Component_Definition =>
4626 Make_Component_Definition (Loc,
4627 Aliased_Present => False,
4628 Subtype_Indication =>
4630 Standard_Boolean, Loc)))))));
4633 RPC_Receiver_Decl := Empty;
4636 RPC_Receiver_Request : constant Entity_Id :=
4637 Make_Defining_Identifier (Loc, Name_R);
4639 RPC_Receiver_Decl :=
4640 Make_Subprogram_Declaration (Loc,
4641 Build_RPC_Receiver_Specification (
4642 RPC_Receiver => Make_Defining_Identifier (Loc,
4643 New_Internal_Name ('R')),
4644 Request_Parameter => RPC_Receiver_Request));
4647 end Build_Stub_Type;
4649 --------------------------------------
4650 -- Build_Subprogram_Receiving_Stubs --
4651 --------------------------------------
4653 function Build_Subprogram_Receiving_Stubs
4654 (Vis_Decl : Node_Id;
4655 Asynchronous : Boolean;
4656 Dynamically_Asynchronous : Boolean := False;
4657 Stub_Type : Entity_Id := Empty;
4658 RACW_Type : Entity_Id := Empty;
4659 Parent_Primitive : Entity_Id := Empty) return Node_Id
4661 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4663 Request_Parameter : constant Entity_Id :=
4664 Make_Defining_Identifier (Loc,
4665 New_Internal_Name ('R'));
4666 -- Formal parameter for receiving stubs: a descriptor for an incoming
4669 Decls : constant List_Id := New_List;
4670 -- All the parameters will get declared before calling the real
4671 -- subprograms. Also the out parameters will be declared.
4673 Statements : constant List_Id := New_List;
4675 Extra_Formal_Statements : constant List_Id := New_List;
4676 -- Statements concerning extra formal parameters
4678 After_Statements : constant List_Id := New_List;
4679 -- Statements to be executed after the subprogram call
4681 Inner_Decls : List_Id := No_List;
4682 -- In case of a function, the inner declarations are needed since
4683 -- the result may be unconstrained.
4685 Excep_Handlers : List_Id := No_List;
4686 Excep_Choice : Entity_Id;
4687 Excep_Code : List_Id;
4689 Parameter_List : constant List_Id := New_List;
4690 -- List of parameters to be passed to the subprogram
4692 Current_Parameter : Node_Id;
4694 Ordered_Parameters_List : constant List_Id :=
4695 Build_Ordered_Parameters_List
4696 (Specification (Vis_Decl));
4698 Subp_Spec : Node_Id;
4699 -- Subprogram specification
4701 Called_Subprogram : Node_Id;
4702 -- The subprogram to call
4704 Null_Raise_Statement : Node_Id;
4706 Dynamic_Async : Entity_Id;
4709 if Present (RACW_Type) then
4710 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4712 Called_Subprogram :=
4714 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4717 if Dynamically_Asynchronous then
4719 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4721 Dynamic_Async := Empty;
4724 if not Asynchronous or Dynamically_Asynchronous then
4726 -- The first statement after the subprogram call is a statement to
4727 -- write a Null_Occurrence into the result stream.
4729 Null_Raise_Statement :=
4730 Make_Attribute_Reference (Loc,
4732 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4733 Attribute_Name => Name_Write,
4734 Expressions => New_List (
4735 Make_Selected_Component (Loc,
4736 Prefix => Request_Parameter,
4737 Selector_Name => Name_Result),
4738 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4740 if Dynamically_Asynchronous then
4741 Null_Raise_Statement :=
4742 Make_Implicit_If_Statement (Vis_Decl,
4744 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4745 Then_Statements => New_List (Null_Raise_Statement));
4748 Append_To (After_Statements, Null_Raise_Statement);
4751 -- Loop through every parameter and get its value from the stream. If
4752 -- the parameter is unconstrained, then the parameter is read using
4753 -- 'Input at the point of declaration.
4755 Current_Parameter := First (Ordered_Parameters_List);
4756 while Present (Current_Parameter) loop
4759 Constrained : Boolean;
4761 Need_Extra_Constrained : Boolean;
4762 -- True when an Extra_Constrained actual is required
4764 Object : constant Entity_Id :=
4765 Make_Defining_Identifier (Loc,
4766 New_Internal_Name ('P'));
4768 Expr : Node_Id := Empty;
4770 Is_Controlling_Formal : constant Boolean :=
4771 Is_RACW_Controlling_Formal
4772 (Current_Parameter, Stub_Type);
4775 if Is_Controlling_Formal then
4777 -- We have a controlling formal parameter. Read its address
4778 -- rather than a real object. The address is in Unsigned_64
4781 Etyp := RTE (RE_Unsigned_64);
4783 Etyp := Etype (Parameter_Type (Current_Parameter));
4787 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
4789 if In_Present (Current_Parameter)
4790 or else not Out_Present (Current_Parameter)
4791 or else not Constrained
4792 or else Is_Controlling_Formal
4794 -- If an input parameter is constrained, then the read of
4795 -- the parameter is deferred until the beginning of the
4796 -- subprogram body. If it is unconstrained, then an
4797 -- expression is built for the object declaration and the
4798 -- variable is set using 'Input instead of 'Read. Note that
4799 -- this deferral does not change the order in which the
4800 -- actuals are read because Build_Ordered_Parameter_List
4801 -- puts them unconstrained first.
4804 Append_To (Statements,
4805 Make_Attribute_Reference (Loc,
4806 Prefix => New_Occurrence_Of (Etyp, Loc),
4807 Attribute_Name => Name_Read,
4808 Expressions => New_List (
4809 Make_Selected_Component (Loc,
4810 Prefix => Request_Parameter,
4811 Selector_Name => Name_Params),
4812 New_Occurrence_Of (Object, Loc))));
4816 -- Build and append Input_With_Tag_Check function
4819 Input_With_Tag_Check (Loc,
4821 Stream => Make_Selected_Component (Loc,
4822 Prefix => Request_Parameter,
4823 Selector_Name => Name_Params)));
4825 -- Prepare function call expression
4827 Expr := Make_Function_Call (Loc,
4828 New_Occurrence_Of (Defining_Unit_Name
4829 (Specification (Last (Decls))), Loc));
4833 Need_Extra_Constrained :=
4834 Nkind (Parameter_Type (Current_Parameter)) /=
4837 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4839 Present (Extra_Constrained
4840 (Defining_Identifier (Current_Parameter)));
4842 -- We may not associate an extra constrained actual to a
4843 -- constant object, so if one is needed, declare the actual
4844 -- as a variable even if it won't be modified.
4846 Build_Actual_Object_Declaration
4849 Variable => Need_Extra_Constrained
4850 or else Out_Present (Current_Parameter),
4854 -- An out parameter may be written back using a 'Write
4855 -- attribute instead of a 'Output because it has been
4856 -- constrained by the parameter given to the caller. Note that
4857 -- out controlling arguments in the case of a RACW are not put
4858 -- back in the stream because the pointer on them has not
4861 if Out_Present (Current_Parameter)
4863 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4865 Append_To (After_Statements,
4866 Make_Attribute_Reference (Loc,
4867 Prefix => New_Occurrence_Of (Etyp, Loc),
4868 Attribute_Name => Name_Write,
4869 Expressions => New_List (
4870 Make_Selected_Component (Loc,
4871 Prefix => Request_Parameter,
4872 Selector_Name => Name_Result),
4873 New_Occurrence_Of (Object, Loc))));
4876 -- For RACW controlling formals, the Etyp of Object is always
4877 -- an RACW, even if the parameter is not of an anonymous access
4878 -- type. In such case, we need to dereference it at call time.
4880 if Is_Controlling_Formal then
4881 if Nkind (Parameter_Type (Current_Parameter)) /=
4884 Append_To (Parameter_List,
4885 Make_Parameter_Association (Loc,
4888 Defining_Identifier (Current_Parameter), Loc),
4889 Explicit_Actual_Parameter =>
4890 Make_Explicit_Dereference (Loc,
4891 Unchecked_Convert_To (RACW_Type,
4892 OK_Convert_To (RTE (RE_Address),
4893 New_Occurrence_Of (Object, Loc))))));
4896 Append_To (Parameter_List,
4897 Make_Parameter_Association (Loc,
4900 Defining_Identifier (Current_Parameter), Loc),
4901 Explicit_Actual_Parameter =>
4902 Unchecked_Convert_To (RACW_Type,
4903 OK_Convert_To (RTE (RE_Address),
4904 New_Occurrence_Of (Object, Loc)))));
4908 Append_To (Parameter_List,
4909 Make_Parameter_Association (Loc,
4912 Defining_Identifier (Current_Parameter), Loc),
4913 Explicit_Actual_Parameter =>
4914 New_Occurrence_Of (Object, Loc)));
4917 -- If the current parameter needs an extra formal, then read it
4918 -- from the stream and set the corresponding semantic field in
4919 -- the variable. If the kind of the parameter identifier is
4920 -- E_Void, then this is a compiler generated parameter that
4921 -- doesn't need an extra constrained status.
4923 -- The case of Extra_Accessibility should also be handled ???
4925 if Need_Extra_Constrained then
4927 Extra_Parameter : constant Entity_Id :=
4929 (Defining_Identifier
4930 (Current_Parameter));
4932 Formal_Entity : constant Entity_Id :=
4933 Make_Defining_Identifier
4934 (Loc, Chars (Extra_Parameter));
4936 Formal_Type : constant Entity_Id :=
4937 Etype (Extra_Parameter);
4941 Make_Object_Declaration (Loc,
4942 Defining_Identifier => Formal_Entity,
4943 Object_Definition =>
4944 New_Occurrence_Of (Formal_Type, Loc)));
4946 Append_To (Extra_Formal_Statements,
4947 Make_Attribute_Reference (Loc,
4948 Prefix => New_Occurrence_Of (
4950 Attribute_Name => Name_Read,
4951 Expressions => New_List (
4952 Make_Selected_Component (Loc,
4953 Prefix => Request_Parameter,
4954 Selector_Name => Name_Params),
4955 New_Occurrence_Of (Formal_Entity, Loc))));
4957 -- Note: the call to Set_Extra_Constrained below relies
4958 -- on the fact that Object's Ekind has been set by
4959 -- Build_Actual_Object_Declaration.
4961 Set_Extra_Constrained (Object, Formal_Entity);
4966 Next (Current_Parameter);
4969 -- Append the formal statements list at the end of regular statements
4971 Append_List_To (Statements, Extra_Formal_Statements);
4973 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
4975 -- The remote subprogram is a function. We build an inner block to
4976 -- be able to hold a potentially unconstrained result in a
4980 Etyp : constant Entity_Id :=
4981 Etype (Result_Definition (Specification (Vis_Decl)));
4982 Result : constant Node_Id :=
4983 Make_Defining_Identifier (Loc,
4984 New_Internal_Name ('R'));
4986 Inner_Decls := New_List (
4987 Make_Object_Declaration (Loc,
4988 Defining_Identifier => Result,
4989 Constant_Present => True,
4990 Object_Definition => New_Occurrence_Of (Etyp, Loc),
4992 Make_Function_Call (Loc,
4993 Name => Called_Subprogram,
4994 Parameter_Associations => Parameter_List)));
4996 if Is_Class_Wide_Type (Etyp) then
4998 -- For a remote call to a function with a class-wide type,
4999 -- check that the returned value satisfies the requirements
5002 Append_To (Inner_Decls,
5003 Make_Transportable_Check (Loc,
5004 New_Occurrence_Of (Result, Loc)));
5008 Append_To (After_Statements,
5009 Make_Attribute_Reference (Loc,
5010 Prefix => New_Occurrence_Of (Etyp, Loc),
5011 Attribute_Name => Name_Output,
5012 Expressions => New_List (
5013 Make_Selected_Component (Loc,
5014 Prefix => Request_Parameter,
5015 Selector_Name => Name_Result),
5016 New_Occurrence_Of (Result, Loc))));
5019 Append_To (Statements,
5020 Make_Block_Statement (Loc,
5021 Declarations => Inner_Decls,
5022 Handled_Statement_Sequence =>
5023 Make_Handled_Sequence_Of_Statements (Loc,
5024 Statements => After_Statements)));
5027 -- The remote subprogram is a procedure. We do not need any inner
5028 -- block in this case.
5030 if Dynamically_Asynchronous then
5032 Make_Object_Declaration (Loc,
5033 Defining_Identifier => Dynamic_Async,
5034 Object_Definition =>
5035 New_Occurrence_Of (Standard_Boolean, Loc)));
5037 Append_To (Statements,
5038 Make_Attribute_Reference (Loc,
5039 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5040 Attribute_Name => Name_Read,
5041 Expressions => New_List (
5042 Make_Selected_Component (Loc,
5043 Prefix => Request_Parameter,
5044 Selector_Name => Name_Params),
5045 New_Occurrence_Of (Dynamic_Async, Loc))));
5048 Append_To (Statements,
5049 Make_Procedure_Call_Statement (Loc,
5050 Name => Called_Subprogram,
5051 Parameter_Associations => Parameter_List));
5053 Append_List_To (Statements, After_Statements);
5056 if Asynchronous and then not Dynamically_Asynchronous then
5058 -- For an asynchronous procedure, add a null exception handler
5060 Excep_Handlers := New_List (
5061 Make_Implicit_Exception_Handler (Loc,
5062 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5063 Statements => New_List (Make_Null_Statement (Loc))));
5066 -- In the other cases, if an exception is raised, then the
5067 -- exception occurrence is copied into the output stream and
5068 -- no other output parameter is written.
5071 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5073 Excep_Code := New_List (
5074 Make_Attribute_Reference (Loc,
5076 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5077 Attribute_Name => Name_Write,
5078 Expressions => New_List (
5079 Make_Selected_Component (Loc,
5080 Prefix => Request_Parameter,
5081 Selector_Name => Name_Result),
5082 New_Occurrence_Of (Excep_Choice, Loc))));
5084 if Dynamically_Asynchronous then
5085 Excep_Code := New_List (
5086 Make_Implicit_If_Statement (Vis_Decl,
5087 Condition => Make_Op_Not (Loc,
5088 New_Occurrence_Of (Dynamic_Async, Loc)),
5089 Then_Statements => Excep_Code));
5092 Excep_Handlers := New_List (
5093 Make_Implicit_Exception_Handler (Loc,
5094 Choice_Parameter => Excep_Choice,
5095 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5096 Statements => Excep_Code));
5101 Make_Procedure_Specification (Loc,
5102 Defining_Unit_Name =>
5103 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
5105 Parameter_Specifications => New_List (
5106 Make_Parameter_Specification (Loc,
5107 Defining_Identifier => Request_Parameter,
5109 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5112 Make_Subprogram_Body (Loc,
5113 Specification => Subp_Spec,
5114 Declarations => Decls,
5115 Handled_Statement_Sequence =>
5116 Make_Handled_Sequence_Of_Statements (Loc,
5117 Statements => Statements,
5118 Exception_Handlers => Excep_Handlers));
5119 end Build_Subprogram_Receiving_Stubs;
5125 function Result return Node_Id is
5127 return Make_Identifier (Loc, Name_V);
5130 ----------------------
5131 -- Stream_Parameter --
5132 ----------------------
5134 function Stream_Parameter return Node_Id is
5136 return Make_Identifier (Loc, Name_S);
5137 end Stream_Parameter;
5141 -------------------------------
5142 -- Get_And_Reset_RACW_Bodies --
5143 -------------------------------
5145 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5146 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
5147 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5149 Body_Decls : List_Id;
5150 -- Returned list of declarations
5153 if Stub_Elements = Empty_Stub_Structure then
5155 -- Stub elements may be missing as a consequence of a previously
5161 Body_Decls := Stub_Elements.Body_Decls;
5162 Stub_Elements.Body_Decls := No_List;
5163 Stubs_Table.Set (Desig, Stub_Elements);
5165 end Get_And_Reset_RACW_Bodies;
5167 -----------------------
5168 -- Get_Subprogram_Id --
5169 -----------------------
5171 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5172 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5174 pragma Assert (Result /= No_String);
5176 end Get_Subprogram_Id;
5178 -----------------------
5179 -- Get_Subprogram_Id --
5180 -----------------------
5182 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5184 return Get_Subprogram_Ids (Def).Int_Identifier;
5185 end Get_Subprogram_Id;
5187 ------------------------
5188 -- Get_Subprogram_Ids --
5189 ------------------------
5191 function Get_Subprogram_Ids
5192 (Def : Entity_Id) return Subprogram_Identifiers
5195 return Subprogram_Identifier_Table.Get (Def);
5196 end Get_Subprogram_Ids;
5202 function Hash (F : Entity_Id) return Hash_Index is
5204 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5207 function Hash (F : Name_Id) return Hash_Index is
5209 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5212 --------------------------
5213 -- Input_With_Tag_Check --
5214 --------------------------
5216 function Input_With_Tag_Check
5218 Var_Type : Entity_Id;
5219 Stream : Node_Id) return Node_Id
5223 Make_Subprogram_Body (Loc,
5224 Specification => Make_Function_Specification (Loc,
5225 Defining_Unit_Name =>
5226 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
5227 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5228 Declarations => No_List,
5229 Handled_Statement_Sequence =>
5230 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5231 Make_Tag_Check (Loc,
5232 Make_Simple_Return_Statement (Loc,
5233 Make_Attribute_Reference (Loc,
5234 Prefix => New_Occurrence_Of (Var_Type, Loc),
5235 Attribute_Name => Name_Input,
5237 New_List (Stream)))))));
5238 end Input_With_Tag_Check;
5240 --------------------------------
5241 -- Is_RACW_Controlling_Formal --
5242 --------------------------------
5244 function Is_RACW_Controlling_Formal
5245 (Parameter : Node_Id;
5246 Stub_Type : Entity_Id) return Boolean
5251 -- If the kind of the parameter is E_Void, then it is not a
5252 -- controlling formal (this can happen in the context of RAS).
5254 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5258 -- If the parameter is not a controlling formal, then it cannot
5259 -- be possibly a RACW_Controlling_Formal.
5261 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5265 Typ := Parameter_Type (Parameter);
5266 return (Nkind (Typ) = N_Access_Definition
5267 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5268 or else Etype (Typ) = Stub_Type;
5269 end Is_RACW_Controlling_Formal;
5271 ------------------------------
5272 -- Make_Transportable_Check --
5273 ------------------------------
5275 function Make_Transportable_Check
5277 Expr : Node_Id) return Node_Id is
5280 Make_Raise_Program_Error (Loc,
5283 Build_Get_Transportable (Loc,
5284 Make_Selected_Component (Loc,
5286 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5287 Reason => PE_Non_Transportable_Actual);
5288 end Make_Transportable_Check;
5290 -----------------------------
5291 -- Make_Selected_Component --
5292 -----------------------------
5294 function Make_Selected_Component
5297 Selector_Name : Name_Id) return Node_Id
5300 return Make_Selected_Component (Loc,
5301 Prefix => New_Occurrence_Of (Prefix, Loc),
5302 Selector_Name => Make_Identifier (Loc, Selector_Name));
5303 end Make_Selected_Component;
5305 --------------------
5306 -- Make_Tag_Check --
5307 --------------------
5309 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5310 Occ : constant Entity_Id :=
5311 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5314 return Make_Block_Statement (Loc,
5315 Handled_Statement_Sequence =>
5316 Make_Handled_Sequence_Of_Statements (Loc,
5317 Statements => New_List (N),
5319 Exception_Handlers => New_List (
5320 Make_Implicit_Exception_Handler (Loc,
5321 Choice_Parameter => Occ,
5323 Exception_Choices =>
5324 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5327 New_List (Make_Procedure_Call_Statement (Loc,
5329 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5330 New_List (New_Occurrence_Of (Occ, Loc))))))));
5333 ----------------------------
5334 -- Need_Extra_Constrained --
5335 ----------------------------
5337 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5338 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5340 return Out_Present (Parameter)
5341 and then Has_Discriminants (Etyp)
5342 and then not Is_Constrained (Etyp)
5343 and then not Is_Indefinite_Subtype (Etyp);
5344 end Need_Extra_Constrained;
5346 ------------------------------------
5347 -- Pack_Entity_Into_Stream_Access --
5348 ------------------------------------
5350 function Pack_Entity_Into_Stream_Access
5354 Etyp : Entity_Id := Empty) return Node_Id
5359 if Present (Etyp) then
5362 Typ := Etype (Object);
5366 Pack_Node_Into_Stream_Access (Loc,
5368 Object => New_Occurrence_Of (Object, Loc),
5370 end Pack_Entity_Into_Stream_Access;
5372 ---------------------------
5373 -- Pack_Node_Into_Stream --
5374 ---------------------------
5376 function Pack_Node_Into_Stream
5380 Etyp : Entity_Id) return Node_Id
5382 Write_Attribute : Name_Id := Name_Write;
5385 if not Is_Constrained (Etyp) then
5386 Write_Attribute := Name_Output;
5390 Make_Attribute_Reference (Loc,
5391 Prefix => New_Occurrence_Of (Etyp, Loc),
5392 Attribute_Name => Write_Attribute,
5393 Expressions => New_List (
5394 Make_Attribute_Reference (Loc,
5395 Prefix => New_Occurrence_Of (Stream, Loc),
5396 Attribute_Name => Name_Access),
5398 end Pack_Node_Into_Stream;
5400 ----------------------------------
5401 -- Pack_Node_Into_Stream_Access --
5402 ----------------------------------
5404 function Pack_Node_Into_Stream_Access
5408 Etyp : Entity_Id) return Node_Id
5410 Write_Attribute : Name_Id := Name_Write;
5413 if not Is_Constrained (Etyp) then
5414 Write_Attribute := Name_Output;
5418 Make_Attribute_Reference (Loc,
5419 Prefix => New_Occurrence_Of (Etyp, Loc),
5420 Attribute_Name => Write_Attribute,
5421 Expressions => New_List (
5424 end Pack_Node_Into_Stream_Access;
5426 ---------------------
5427 -- PolyORB_Support --
5428 ---------------------
5430 package body PolyORB_Support is
5432 -- Local subprograms
5434 procedure Add_RACW_Read_Attribute
5435 (RACW_Type : Entity_Id;
5436 Stub_Type : Entity_Id;
5437 Stub_Type_Access : Entity_Id;
5438 Body_Decls : List_Id);
5439 -- Add Read attribute for the RACW type. The declaration and attribute
5440 -- definition clauses are inserted right after the declaration of
5441 -- RACW_Type, while the subprogram body is appended to Body_Decls.
5443 procedure Add_RACW_Write_Attribute
5444 (RACW_Type : Entity_Id;
5445 Stub_Type : Entity_Id;
5446 Stub_Type_Access : Entity_Id;
5447 Body_Decls : List_Id);
5448 -- Same as above for the Write attribute
5450 procedure Add_RACW_From_Any
5451 (RACW_Type : Entity_Id;
5452 Stub_Type : Entity_Id;
5453 Stub_Type_Access : Entity_Id;
5454 Body_Decls : List_Id);
5455 -- Add the From_Any TSS for this RACW type
5457 procedure Add_RACW_To_Any
5458 (Designated_Type : Entity_Id;
5459 RACW_Type : Entity_Id;
5460 Stub_Type : Entity_Id;
5461 Stub_Type_Access : Entity_Id;
5462 Body_Decls : List_Id);
5463 -- Add the To_Any TSS for this RACW type
5465 procedure Add_RACW_TypeCode
5466 (Designated_Type : Entity_Id;
5467 RACW_Type : Entity_Id;
5468 Body_Decls : List_Id);
5469 -- Add the TypeCode TSS for this RACW type
5471 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5472 -- Add the From_Any TSS for this RAS type
5474 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5475 -- Add the To_Any TSS for this RAS type
5477 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5478 -- Add the TypeCode TSS for this RAS type
5480 procedure Add_RAS_Access_TSS (N : Node_Id);
5481 -- Add a subprogram body for RAS Access TSS
5483 -------------------------------------
5484 -- Add_Obj_RPC_Receiver_Completion --
5485 -------------------------------------
5487 procedure Add_Obj_RPC_Receiver_Completion
5490 RPC_Receiver : Entity_Id;
5491 Stub_Elements : Stub_Structure)
5493 Desig : constant Entity_Id :=
5494 Etype (Designated_Type (Stub_Elements.RACW_Type));
5497 Make_Procedure_Call_Statement (Loc,
5500 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5502 Parameter_Associations => New_List (
5506 Make_String_Literal (Loc,
5507 Full_Qualified_Name (Desig)),
5511 Make_Attribute_Reference (Loc,
5514 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5520 Make_Attribute_Reference (Loc,
5523 Defining_Identifier (
5524 Stub_Elements.RPC_Receiver_Decl), Loc),
5527 end Add_Obj_RPC_Receiver_Completion;
5529 -----------------------
5530 -- Add_RACW_Features --
5531 -----------------------
5533 procedure Add_RACW_Features
5534 (RACW_Type : Entity_Id;
5536 Stub_Type : Entity_Id;
5537 Stub_Type_Access : Entity_Id;
5538 RPC_Receiver_Decl : Node_Id;
5539 Body_Decls : List_Id)
5541 pragma Warnings (Off);
5542 pragma Unreferenced (RPC_Receiver_Decl);
5543 pragma Warnings (On);
5547 (RACW_Type => RACW_Type,
5548 Stub_Type => Stub_Type,
5549 Stub_Type_Access => Stub_Type_Access,
5550 Body_Decls => Body_Decls);
5553 (Designated_Type => Desig,
5554 RACW_Type => RACW_Type,
5555 Stub_Type => Stub_Type,
5556 Stub_Type_Access => Stub_Type_Access,
5557 Body_Decls => Body_Decls);
5559 -- In the PolyORB case, the RACW 'Read and 'Write attributes are
5560 -- implemented in terms of the From_Any and To_Any TSSs, so these
5561 -- TSSs must be expanded before 'Read and 'Write.
5563 Add_RACW_Write_Attribute
5564 (RACW_Type => RACW_Type,
5565 Stub_Type => Stub_Type,
5566 Stub_Type_Access => Stub_Type_Access,
5567 Body_Decls => Body_Decls);
5569 Add_RACW_Read_Attribute
5570 (RACW_Type => RACW_Type,
5571 Stub_Type => Stub_Type,
5572 Stub_Type_Access => Stub_Type_Access,
5573 Body_Decls => Body_Decls);
5576 (Designated_Type => Desig,
5577 RACW_Type => RACW_Type,
5578 Body_Decls => Body_Decls);
5579 end Add_RACW_Features;
5581 -----------------------
5582 -- Add_RACW_From_Any --
5583 -----------------------
5585 procedure Add_RACW_From_Any
5586 (RACW_Type : Entity_Id;
5587 Stub_Type : Entity_Id;
5588 Stub_Type_Access : Entity_Id;
5589 Body_Decls : List_Id)
5591 Loc : constant Source_Ptr := Sloc (RACW_Type);
5592 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5594 Fnam : constant Entity_Id :=
5595 Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
5597 Func_Spec : Node_Id;
5598 Func_Decl : Node_Id;
5599 Func_Body : Node_Id;
5602 Statements : List_Id;
5603 Stub_Statements : List_Id;
5604 Local_Statements : List_Id;
5605 -- Various parts of the subprogram
5607 Any_Parameter : constant Entity_Id :=
5608 Make_Defining_Identifier (Loc, Name_A);
5609 Reference : constant Entity_Id :=
5610 Make_Defining_Identifier
5611 (Loc, New_Internal_Name ('R'));
5612 Is_Local : constant Entity_Id :=
5613 Make_Defining_Identifier
5614 (Loc, New_Internal_Name ('L'));
5615 Addr : constant Entity_Id :=
5616 Make_Defining_Identifier
5617 (Loc, New_Internal_Name ('A'));
5618 Local_Stub : constant Entity_Id :=
5619 Make_Defining_Identifier
5620 (Loc, New_Internal_Name ('L'));
5621 Stubbed_Result : constant Entity_Id :=
5622 Make_Defining_Identifier
5623 (Loc, New_Internal_Name ('S'));
5625 Stub_Condition : Node_Id;
5626 -- An expression that determines whether we create a stub for the
5627 -- newly-unpacked RACW. Normally we create a stub only for remote
5628 -- objects, but in the case of an RACW used to implement a RAS, we
5629 -- also create a stub for local subprograms if a pragma
5630 -- All_Calls_Remote applies.
5632 Asynchronous_Flag : constant Entity_Id :=
5633 Asynchronous_Flags_Table.Get (RACW_Type);
5634 -- The flag object declared in Add_RACW_Asynchronous_Flag
5638 -- Object declarations
5641 Make_Object_Declaration (Loc,
5642 Defining_Identifier =>
5644 Object_Definition =>
5645 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5647 Make_Function_Call (Loc,
5649 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5650 Parameter_Associations => New_List (
5651 New_Occurrence_Of (Any_Parameter, Loc)))),
5653 Make_Object_Declaration (Loc,
5654 Defining_Identifier => Local_Stub,
5655 Aliased_Present => True,
5656 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
5658 Make_Object_Declaration (Loc,
5659 Defining_Identifier => Stubbed_Result,
5660 Object_Definition =>
5661 New_Occurrence_Of (Stub_Type_Access, Loc),
5663 Make_Attribute_Reference (Loc,
5665 New_Occurrence_Of (Local_Stub, Loc),
5667 Name_Unchecked_Access)),
5669 Make_Object_Declaration (Loc,
5670 Defining_Identifier => Is_Local,
5671 Object_Definition =>
5672 New_Occurrence_Of (Standard_Boolean, Loc)),
5674 Make_Object_Declaration (Loc,
5675 Defining_Identifier => Addr,
5676 Object_Definition =>
5677 New_Occurrence_Of (RTE (RE_Address), Loc)));
5679 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5681 Set_Etype (Stubbed_Result, Stub_Type_Access);
5683 -- If the ref Is_Nil, return a null pointer
5685 Statements := New_List (
5686 Make_Implicit_If_Statement (RACW_Type,
5688 Make_Function_Call (Loc,
5690 New_Occurrence_Of (RTE (RE_Is_Nil), Loc),
5691 Parameter_Associations => New_List (
5692 New_Occurrence_Of (Reference, Loc))),
5693 Then_Statements => New_List (
5694 Make_Simple_Return_Statement (Loc,
5696 Make_Null (Loc)))));
5698 Append_To (Statements,
5699 Make_Procedure_Call_Statement (Loc,
5701 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
5702 Parameter_Associations => New_List (
5703 New_Occurrence_Of (Reference, Loc),
5704 New_Occurrence_Of (Is_Local, Loc),
5705 New_Occurrence_Of (Addr, Loc))));
5707 -- If the object is located on another partition, then a stub object
5708 -- will be created with all the information needed to rebuild the
5709 -- real object at the other end. This stanza is always used in the
5710 -- case of RAS types, for which a stub is required even for local
5713 Stub_Statements := New_List (
5714 Make_Assignment_Statement (Loc,
5715 Name => Make_Selected_Component (Loc,
5716 Prefix => Stubbed_Result,
5717 Selector_Name => Name_Target),
5719 Make_Function_Call (Loc,
5721 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
5722 Parameter_Associations => New_List (
5723 New_Occurrence_Of (Reference, Loc)))),
5725 Make_Procedure_Call_Statement (Loc,
5727 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
5728 Parameter_Associations => New_List (
5729 Make_Selected_Component (Loc,
5730 Prefix => Stubbed_Result,
5731 Selector_Name => Name_Target))),
5733 Make_Assignment_Statement (Loc,
5734 Name => Make_Selected_Component (Loc,
5735 Prefix => Stubbed_Result,
5736 Selector_Name => Name_Asynchronous),
5738 New_Occurrence_Of (Asynchronous_Flag, Loc)));
5740 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5741 -- set on the stub type if, and only if, the RACW type has a pragma
5742 -- Asynchronous. This is incorrect for RACWs that implement RAS
5743 -- types, because in that case the /designated subprogram/ (not the
5744 -- type) might be asynchronous, and that causes the stub to need to
5745 -- be asynchronous too. A solution is to transport a RAS as a struct
5746 -- containing a RACW and an asynchronous flag, and to properly alter
5747 -- the Asynchronous component in the stub type in the RAS's _From_Any
5750 Append_List_To (Stub_Statements,
5751 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
5753 -- Distinguish between the local and remote cases, and execute the
5754 -- appropriate piece of code.
5756 Stub_Condition := New_Occurrence_Of (Is_Local, Loc);
5759 Stub_Condition := Make_And_Then (Loc,
5763 Make_Selected_Component (Loc,
5765 Unchecked_Convert_To (
5766 RTE (RE_RAS_Proxy_Type_Access),
5767 New_Occurrence_Of (Addr, Loc)),
5769 Make_Identifier (Loc,
5770 Name_All_Calls_Remote)));
5773 Local_Statements := New_List (
5774 Make_Simple_Return_Statement (Loc,
5776 Unchecked_Convert_To (RACW_Type,
5777 New_Occurrence_Of (Addr, Loc))));
5779 Append_To (Statements,
5780 Make_Implicit_If_Statement (RACW_Type,
5783 Then_Statements => Local_Statements,
5784 Else_Statements => Stub_Statements));
5786 Append_To (Statements,
5787 Make_Simple_Return_Statement (Loc,
5788 Expression => Unchecked_Convert_To (RACW_Type,
5789 New_Occurrence_Of (Stubbed_Result, Loc))));
5792 Make_Function_Specification (Loc,
5793 Defining_Unit_Name =>
5795 Parameter_Specifications => New_List (
5796 Make_Parameter_Specification (Loc,
5797 Defining_Identifier =>
5800 New_Occurrence_Of (RTE (RE_Any), Loc))),
5801 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5803 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5804 -- entity in the declaration spec, not those of the body spec.
5806 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5809 Make_Subprogram_Body (Loc,
5811 Copy_Specification (Loc, Func_Spec),
5812 Declarations => Decls,
5813 Handled_Statement_Sequence =>
5814 Make_Handled_Sequence_Of_Statements (Loc,
5815 Statements => Statements));
5817 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5818 Append_To (Body_Decls, Func_Body);
5820 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5821 end Add_RACW_From_Any;
5823 -----------------------------
5824 -- Add_RACW_Read_Attribute --
5825 -----------------------------
5827 procedure Add_RACW_Read_Attribute
5828 (RACW_Type : Entity_Id;
5829 Stub_Type : Entity_Id;
5830 Stub_Type_Access : Entity_Id;
5831 Body_Decls : List_Id)
5833 pragma Warnings (Off);
5834 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5835 pragma Warnings (On);
5836 Loc : constant Source_Ptr := Sloc (RACW_Type);
5838 Proc_Decl : Node_Id;
5839 Attr_Decl : Node_Id;
5841 Body_Node : Node_Id;
5844 Statements : List_Id;
5845 -- Various parts of the procedure
5847 Procedure_Name : constant Name_Id :=
5848 New_Internal_Name ('R');
5849 Source_Ref : constant Entity_Id :=
5850 Make_Defining_Identifier
5851 (Loc, New_Internal_Name ('R'));
5852 Asynchronous_Flag : constant Entity_Id :=
5853 Asynchronous_Flags_Table.Get (RACW_Type);
5854 pragma Assert (Present (Asynchronous_Flag));
5856 function Stream_Parameter return Node_Id;
5857 function Result return Node_Id;
5858 -- Functions to create occurrences of the formal parameter names
5864 function Result return Node_Id is
5866 return Make_Identifier (Loc, Name_V);
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_Read_Attribute
5881 -- Generate object declarations
5884 Make_Object_Declaration (Loc,
5885 Defining_Identifier => Source_Ref,
5886 Object_Definition =>
5887 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5889 Statements := New_List (
5890 Make_Attribute_Reference (Loc,
5892 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5893 Attribute_Name => Name_Read,
5894 Expressions => New_List (
5896 New_Occurrence_Of (Source_Ref, Loc))),
5897 Make_Assignment_Statement (Loc,
5901 PolyORB_Support.Helpers.Build_From_Any_Call (
5903 Make_Function_Call (Loc,
5905 New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5906 Parameter_Associations => New_List (
5907 New_Occurrence_Of (Source_Ref, Loc))),
5910 Build_Stream_Procedure
5911 (Loc, RACW_Type, Body_Node,
5912 Make_Defining_Identifier (Loc, Procedure_Name),
5913 Statements, Outp => True);
5914 Set_Declarations (Body_Node, Decls);
5916 Proc_Decl := Make_Subprogram_Declaration (Loc,
5917 Copy_Specification (Loc, Specification (Body_Node)));
5920 Make_Attribute_Definition_Clause (Loc,
5921 Name => New_Occurrence_Of (RACW_Type, Loc),
5925 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5927 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5928 Insert_After (Proc_Decl, Attr_Decl);
5929 Append_To (Body_Decls, Body_Node);
5930 end Add_RACW_Read_Attribute;
5932 ---------------------
5933 -- Add_RACW_To_Any --
5934 ---------------------
5936 procedure Add_RACW_To_Any
5937 (Designated_Type : Entity_Id;
5938 RACW_Type : Entity_Id;
5939 Stub_Type : Entity_Id;
5940 Stub_Type_Access : Entity_Id;
5941 Body_Decls : List_Id)
5943 Loc : constant Source_Ptr := Sloc (RACW_Type);
5945 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5949 Stub_Elements : constant Stub_Structure :=
5950 Stubs_Table.Get (Designated_Type);
5951 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5953 Func_Spec : Node_Id;
5954 Func_Decl : Node_Id;
5955 Func_Body : Node_Id;
5958 Statements : List_Id;
5959 Null_Statements : List_Id;
5960 Local_Statements : List_Id := No_List;
5961 Stub_Statements : List_Id;
5963 -- Various parts of the subprogram
5965 RACW_Parameter : constant Entity_Id
5966 := Make_Defining_Identifier (Loc, Name_R);
5968 Reference : constant Entity_Id :=
5969 Make_Defining_Identifier
5970 (Loc, New_Internal_Name ('R'));
5971 Any : constant Entity_Id :=
5972 Make_Defining_Identifier
5973 (Loc, New_Internal_Name ('A'));
5977 -- Object declarations
5980 Make_Object_Declaration (Loc,
5981 Defining_Identifier =>
5983 Object_Definition =>
5984 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
5985 Make_Object_Declaration (Loc,
5986 Defining_Identifier =>
5988 Object_Definition =>
5989 New_Occurrence_Of (RTE (RE_Any), Loc)));
5991 -- If the object is null, nothing to do (Reference is already
5994 Null_Statements := New_List (Make_Null_Statement (Loc));
5998 -- If the object is a RAS designating a local subprogram, we
5999 -- already have a target reference.
6001 Local_Statements := New_List (
6002 Make_Procedure_Call_Statement (Loc,
6004 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
6005 Parameter_Associations => New_List (
6006 New_Occurrence_Of (Reference, Loc),
6007 Make_Selected_Component (Loc,
6009 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
6010 New_Occurrence_Of (RACW_Parameter, Loc)),
6011 Selector_Name => Make_Identifier (Loc, Name_Target)))));
6014 -- If the object is a local RACW object, use Get_Reference now to
6015 -- obtain a reference.
6017 Local_Statements := New_List (
6018 Make_Procedure_Call_Statement (Loc,
6020 New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6021 Parameter_Associations => New_List (
6022 Unchecked_Convert_To (
6024 New_Occurrence_Of (RACW_Parameter, Loc)),
6025 Make_String_Literal (Loc,
6026 Full_Qualified_Name (Designated_Type)),
6027 Make_Attribute_Reference (Loc,
6030 Defining_Identifier (
6031 Stub_Elements.RPC_Receiver_Decl), Loc),
6034 New_Occurrence_Of (Reference, Loc))));
6037 -- If the object is located on another partition, use the target from
6040 Stub_Statements := New_List (
6041 Make_Procedure_Call_Statement (Loc,
6043 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
6044 Parameter_Associations => New_List (
6045 New_Occurrence_Of (Reference, Loc),
6046 Make_Selected_Component (Loc,
6047 Prefix => Unchecked_Convert_To (Stub_Type_Access,
6048 New_Occurrence_Of (RACW_Parameter, Loc)),
6050 Make_Identifier (Loc, Name_Target)))));
6052 -- Distinguish between the null, local and remote cases, and execute
6053 -- the appropriate piece of code.
6056 Make_Implicit_If_Statement (RACW_Type,
6059 Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc),
6060 Right_Opnd => Make_Null (Loc)),
6061 Then_Statements => Null_Statements,
6062 Elsif_Parts => New_List (
6063 Make_Elsif_Part (Loc,
6067 Make_Attribute_Reference (Loc,
6069 New_Occurrence_Of (RACW_Parameter, Loc),
6070 Attribute_Name => Name_Tag),
6072 Make_Attribute_Reference (Loc,
6073 Prefix => New_Occurrence_Of (Stub_Type, Loc),
6074 Attribute_Name => Name_Tag)),
6075 Then_Statements => Local_Statements)),
6076 Else_Statements => Stub_Statements);
6078 Statements := New_List (
6080 Make_Assignment_Statement (Loc,
6082 New_Occurrence_Of (Any, Loc),
6084 Make_Function_Call (Loc,
6085 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
6086 Parameter_Associations => New_List (
6087 New_Occurrence_Of (Reference, Loc)))),
6088 Make_Procedure_Call_Statement (Loc,
6090 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6091 Parameter_Associations => New_List (
6092 New_Occurrence_Of (Any, Loc),
6093 Make_Selected_Component (Loc,
6095 Defining_Identifier (
6096 Stub_Elements.RPC_Receiver_Decl),
6097 Selector_Name => Name_Obj_TypeCode))),
6098 Make_Simple_Return_Statement (Loc,
6100 New_Occurrence_Of (Any, Loc)));
6102 Fnam := Make_Defining_Identifier (
6103 Loc, New_Internal_Name ('T'));
6106 Make_Function_Specification (Loc,
6107 Defining_Unit_Name =>
6109 Parameter_Specifications => New_List (
6110 Make_Parameter_Specification (Loc,
6111 Defining_Identifier =>
6114 New_Occurrence_Of (RACW_Type, Loc))),
6115 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6117 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6118 -- entity in the declaration spec, not in the body spec.
6120 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6123 Make_Subprogram_Body (Loc,
6125 Copy_Specification (Loc, Func_Spec),
6126 Declarations => Decls,
6127 Handled_Statement_Sequence =>
6128 Make_Handled_Sequence_Of_Statements (Loc,
6129 Statements => Statements));
6131 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6132 Append_To (Body_Decls, Func_Body);
6134 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
6135 end Add_RACW_To_Any;
6137 -----------------------
6138 -- Add_RACW_TypeCode --
6139 -----------------------
6141 procedure Add_RACW_TypeCode
6142 (Designated_Type : Entity_Id;
6143 RACW_Type : Entity_Id;
6144 Body_Decls : List_Id)
6146 Loc : constant Source_Ptr := Sloc (RACW_Type);
6150 Stub_Elements : constant Stub_Structure :=
6151 Stubs_Table.Get (Designated_Type);
6152 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6154 Func_Spec : Node_Id;
6155 Func_Decl : Node_Id;
6156 Func_Body : Node_Id;
6160 Make_Defining_Identifier (Loc,
6161 Chars => New_Internal_Name ('T'));
6163 -- The spec for this subprogram has a dummy 'access RACW' argument,
6164 -- which serves only for overloading purposes.
6167 Make_Function_Specification (Loc,
6168 Defining_Unit_Name =>
6170 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6172 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6173 -- entity in the declaration spec, not those of the body spec.
6175 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6178 Make_Subprogram_Body (Loc,
6180 Copy_Specification (Loc, Func_Spec),
6181 Declarations => Empty_List,
6182 Handled_Statement_Sequence =>
6183 Make_Handled_Sequence_Of_Statements (Loc,
6184 Statements => New_List (
6185 Make_Simple_Return_Statement (Loc,
6187 Make_Selected_Component (Loc,
6189 Defining_Identifier (
6190 Stub_Elements.RPC_Receiver_Decl),
6191 Selector_Name => Name_Obj_TypeCode)))));
6193 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6194 Append_To (Body_Decls, Func_Body);
6196 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6197 end Add_RACW_TypeCode;
6199 ------------------------------
6200 -- Add_RACW_Write_Attribute --
6201 ------------------------------
6203 procedure Add_RACW_Write_Attribute
6204 (RACW_Type : Entity_Id;
6205 Stub_Type : Entity_Id;
6206 Stub_Type_Access : Entity_Id;
6207 Body_Decls : List_Id)
6209 pragma Warnings (Off);
6210 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6211 pragma Warnings (On);
6213 Loc : constant Source_Ptr := Sloc (RACW_Type);
6215 Body_Node : Node_Id;
6216 Proc_Decl : Node_Id;
6217 Attr_Decl : Node_Id;
6219 Statements : List_Id;
6220 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
6222 function Stream_Parameter return Node_Id;
6223 function Object return Node_Id;
6224 -- Functions to create occurrences of the formal parameter names
6230 function Object return Node_Id is
6231 Object_Ref : constant Node_Id :=
6232 Make_Identifier (Loc, Name_V);
6235 -- Etype must be set for Build_To_Any_Call
6237 Set_Etype (Object_Ref, RACW_Type);
6242 ----------------------
6243 -- Stream_Parameter --
6244 ----------------------
6246 function Stream_Parameter return Node_Id is
6248 return Make_Identifier (Loc, Name_S);
6249 end Stream_Parameter;
6251 -- Start of processing for Add_RACW_Write_Attribute
6254 Statements := New_List (
6255 Pack_Node_Into_Stream_Access (Loc,
6256 Stream => Stream_Parameter,
6258 Make_Function_Call (Loc,
6260 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
6261 Parameter_Associations => New_List (
6262 PolyORB_Support.Helpers.Build_To_Any_Call
6263 (Object, Body_Decls))),
6264 Etyp => RTE (RE_Object_Ref)));
6266 Build_Stream_Procedure
6267 (Loc, RACW_Type, Body_Node,
6268 Make_Defining_Identifier (Loc, Procedure_Name),
6269 Statements, Outp => False);
6272 Make_Subprogram_Declaration (Loc,
6273 Copy_Specification (Loc, Specification (Body_Node)));
6276 Make_Attribute_Definition_Clause (Loc,
6277 Name => New_Occurrence_Of (RACW_Type, Loc),
6278 Chars => Name_Write,
6281 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6283 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6284 Insert_After (Proc_Decl, Attr_Decl);
6285 Append_To (Body_Decls, Body_Node);
6286 end Add_RACW_Write_Attribute;
6288 -----------------------
6289 -- Add_RAST_Features --
6290 -----------------------
6292 procedure Add_RAST_Features
6293 (Vis_Decl : Node_Id;
6294 RAS_Type : Entity_Id)
6297 Add_RAS_Access_TSS (Vis_Decl);
6299 Add_RAS_From_Any (RAS_Type);
6300 Add_RAS_TypeCode (RAS_Type);
6302 -- To_Any uses TypeCode, and therefore needs to be generated last
6304 Add_RAS_To_Any (RAS_Type);
6305 end Add_RAST_Features;
6307 ------------------------
6308 -- Add_RAS_Access_TSS --
6309 ------------------------
6311 procedure Add_RAS_Access_TSS (N : Node_Id) is
6312 Loc : constant Source_Ptr := Sloc (N);
6314 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6315 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6316 -- Ras_Type is the access to subprogram type; Fat_Type is the
6317 -- corresponding record type.
6319 RACW_Type : constant Entity_Id :=
6320 Underlying_RACW_Type (Ras_Type);
6321 Desig : constant Entity_Id :=
6322 Etype (Designated_Type (RACW_Type));
6324 Stub_Elements : constant Stub_Structure :=
6325 Stubs_Table.Get (Desig);
6326 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6328 Proc : constant Entity_Id :=
6329 Make_Defining_Identifier (Loc,
6330 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6332 Proc_Spec : Node_Id;
6334 -- Formal parameters
6336 Package_Name : constant Entity_Id :=
6337 Make_Defining_Identifier (Loc,
6342 Subp_Id : constant Entity_Id :=
6343 Make_Defining_Identifier (Loc,
6346 -- Target subprogram
6348 Asynch_P : constant Entity_Id :=
6349 Make_Defining_Identifier (Loc,
6350 Chars => Name_Asynchronous);
6351 -- Is the procedure to which the 'Access applies asynchronous?
6353 All_Calls_Remote : constant Entity_Id :=
6354 Make_Defining_Identifier (Loc,
6355 Chars => Name_All_Calls_Remote);
6356 -- True if an All_Calls_Remote pragma applies to the RCI unit
6357 -- that contains the subprogram.
6359 -- Common local variables
6361 Proc_Decls : List_Id;
6362 Proc_Statements : List_Id;
6364 Subp_Ref : constant Entity_Id :=
6365 Make_Defining_Identifier (Loc, Name_R);
6366 -- Reference that designates the target subprogram (returned
6367 -- by Get_RAS_Info).
6369 Is_Local : constant Entity_Id :=
6370 Make_Defining_Identifier (Loc, Name_L);
6371 Local_Addr : constant Entity_Id :=
6372 Make_Defining_Identifier (Loc, Name_A);
6373 -- For the call to Get_Local_Address
6375 -- Additional local variables for the remote case
6377 Local_Stub : constant Entity_Id :=
6378 Make_Defining_Identifier (Loc,
6379 Chars => New_Internal_Name ('L'));
6381 Stub_Ptr : constant Entity_Id :=
6382 Make_Defining_Identifier (Loc,
6383 Chars => New_Internal_Name ('S'));
6386 (Field_Name : Name_Id;
6387 Value : Node_Id) return Node_Id;
6388 -- Construct an assignment that sets the named component in the
6396 (Field_Name : Name_Id;
6397 Value : Node_Id) return Node_Id
6401 Make_Assignment_Statement (Loc,
6403 Make_Selected_Component (Loc,
6405 Selector_Name => Field_Name),
6406 Expression => Value);
6409 -- Start of processing for Add_RAS_Access_TSS
6412 Proc_Decls := New_List (
6414 -- Common declarations
6416 Make_Object_Declaration (Loc,
6417 Defining_Identifier => Subp_Ref,
6418 Object_Definition =>
6419 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6421 Make_Object_Declaration (Loc,
6422 Defining_Identifier => Is_Local,
6423 Object_Definition =>
6424 New_Occurrence_Of (Standard_Boolean, Loc)),
6426 Make_Object_Declaration (Loc,
6427 Defining_Identifier => Local_Addr,
6428 Object_Definition =>
6429 New_Occurrence_Of (RTE (RE_Address), Loc)),
6431 Make_Object_Declaration (Loc,
6432 Defining_Identifier => Local_Stub,
6433 Aliased_Present => True,
6434 Object_Definition =>
6435 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6437 Make_Object_Declaration (Loc,
6438 Defining_Identifier =>
6440 Object_Definition =>
6441 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6443 Make_Attribute_Reference (Loc,
6444 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6445 Attribute_Name => Name_Unchecked_Access)));
6447 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6448 -- Build_Get_Unique_RP_Call needs this information
6450 -- Get_RAS_Info (Pkg, Subp, R);
6451 -- Obtain a reference to the target subprogram
6453 Proc_Statements := New_List (
6454 Make_Procedure_Call_Statement (Loc,
6456 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6457 Parameter_Associations => New_List (
6458 New_Occurrence_Of (Package_Name, Loc),
6459 New_Occurrence_Of (Subp_Id, Loc),
6460 New_Occurrence_Of (Subp_Ref, Loc))),
6462 -- Get_Local_Address (R, L, A);
6463 -- Determine whether the subprogram is local (L), and if so
6464 -- obtain the local address of its proxy (A).
6466 Make_Procedure_Call_Statement (Loc,
6468 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6469 Parameter_Associations => New_List (
6470 New_Occurrence_Of (Subp_Ref, Loc),
6471 New_Occurrence_Of (Is_Local, Loc),
6472 New_Occurrence_Of (Local_Addr, Loc))));
6474 -- Note: Here we assume that the Fat_Type is a record containing just
6475 -- an access to a proxy or stub object.
6477 Append_To (Proc_Statements,
6481 Make_Implicit_If_Statement (N,
6483 New_Occurrence_Of (Is_Local, Loc),
6485 Then_Statements => New_List (
6487 -- if A.Target = null then
6489 Make_Implicit_If_Statement (N,
6492 Make_Selected_Component (Loc,
6494 Unchecked_Convert_To (
6495 RTE (RE_RAS_Proxy_Type_Access),
6496 New_Occurrence_Of (Local_Addr, Loc)),
6498 Make_Identifier (Loc, Name_Target)),
6501 Then_Statements => New_List (
6503 -- A.Target := Entity_Of (Ref);
6505 Make_Assignment_Statement (Loc,
6507 Make_Selected_Component (Loc,
6509 Unchecked_Convert_To (
6510 RTE (RE_RAS_Proxy_Type_Access),
6511 New_Occurrence_Of (Local_Addr, Loc)),
6513 Make_Identifier (Loc, Name_Target)),
6515 Make_Function_Call (Loc,
6517 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6518 Parameter_Associations => New_List (
6519 New_Occurrence_Of (Subp_Ref, Loc)))),
6521 -- Inc_Usage (A.Target);
6523 Make_Procedure_Call_Statement (Loc,
6525 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6526 Parameter_Associations => New_List (
6527 Make_Selected_Component (Loc,
6529 Unchecked_Convert_To (
6530 RTE (RE_RAS_Proxy_Type_Access),
6531 New_Occurrence_Of (Local_Addr, Loc)),
6532 Selector_Name => Make_Identifier (Loc,
6536 -- if not All_Calls_Remote then
6537 -- return Fat_Type!(A);
6540 Make_Implicit_If_Statement (N,
6543 New_Occurrence_Of (All_Calls_Remote, Loc)),
6545 Then_Statements => New_List (
6546 Make_Simple_Return_Statement (Loc,
6547 Unchecked_Convert_To (Fat_Type,
6548 New_Occurrence_Of (Local_Addr, Loc))))))));
6550 Append_List_To (Proc_Statements, New_List (
6552 -- Stub.Target := Entity_Of (Ref);
6554 Set_Field (Name_Target,
6555 Make_Function_Call (Loc,
6557 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6558 Parameter_Associations => New_List (
6559 New_Occurrence_Of (Subp_Ref, Loc)))),
6561 -- Inc_Usage (Stub.Target);
6563 Make_Procedure_Call_Statement (Loc,
6565 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6566 Parameter_Associations => New_List (
6567 Make_Selected_Component (Loc,
6569 Selector_Name => Name_Target))),
6571 -- E.4.1(9) A remote call is asynchronous if it is a call to
6572 -- a procedure, or a call through a value of an access-to-procedure
6573 -- type, to which a pragma Asynchronous applies.
6575 -- Parameter Asynch_P is true when the procedure is asynchronous;
6576 -- Expression Asynch_T is true when the type is asynchronous.
6578 Set_Field (Name_Asynchronous,
6580 New_Occurrence_Of (Asynch_P, Loc),
6581 New_Occurrence_Of (Boolean_Literals (
6582 Is_Asynchronous (Ras_Type)), Loc)))));
6584 Append_List_To (Proc_Statements,
6585 Build_Get_Unique_RP_Call (Loc,
6586 Stub_Ptr, Stub_Elements.Stub_Type));
6588 Append_To (Proc_Statements,
6589 Make_Simple_Return_Statement (Loc,
6591 Unchecked_Convert_To (Fat_Type,
6592 New_Occurrence_Of (Stub_Ptr, Loc))));
6595 Make_Function_Specification (Loc,
6596 Defining_Unit_Name => Proc,
6597 Parameter_Specifications => New_List (
6598 Make_Parameter_Specification (Loc,
6599 Defining_Identifier => Package_Name,
6601 New_Occurrence_Of (Standard_String, Loc)),
6603 Make_Parameter_Specification (Loc,
6604 Defining_Identifier => Subp_Id,
6606 New_Occurrence_Of (Standard_String, Loc)),
6608 Make_Parameter_Specification (Loc,
6609 Defining_Identifier => Asynch_P,
6611 New_Occurrence_Of (Standard_Boolean, Loc)),
6613 Make_Parameter_Specification (Loc,
6614 Defining_Identifier => All_Calls_Remote,
6616 New_Occurrence_Of (Standard_Boolean, Loc))),
6618 Result_Definition =>
6619 New_Occurrence_Of (Fat_Type, Loc));
6621 -- Set the kind and return type of the function to prevent
6622 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6624 Set_Ekind (Proc, E_Function);
6625 Set_Etype (Proc, Fat_Type);
6628 Make_Subprogram_Body (Loc,
6629 Specification => Proc_Spec,
6630 Declarations => Proc_Decls,
6631 Handled_Statement_Sequence =>
6632 Make_Handled_Sequence_Of_Statements (Loc,
6633 Statements => Proc_Statements)));
6635 Set_TSS (Fat_Type, Proc);
6636 end Add_RAS_Access_TSS;
6638 ----------------------
6639 -- Add_RAS_From_Any --
6640 ----------------------
6642 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6643 Loc : constant Source_Ptr := Sloc (RAS_Type);
6645 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6646 Make_TSS_Name (RAS_Type, TSS_From_Any));
6648 Func_Spec : Node_Id;
6650 Statements : List_Id;
6652 Any_Parameter : constant Entity_Id :=
6653 Make_Defining_Identifier (Loc, Name_A);
6656 Statements := New_List (
6657 Make_Simple_Return_Statement (Loc,
6659 Make_Aggregate (Loc,
6660 Component_Associations => New_List (
6661 Make_Component_Association (Loc,
6662 Choices => New_List (
6663 Make_Identifier (Loc, Name_Ras)),
6665 PolyORB_Support.Helpers.Build_From_Any_Call (
6666 Underlying_RACW_Type (RAS_Type),
6667 New_Occurrence_Of (Any_Parameter, Loc),
6671 Make_Function_Specification (Loc,
6672 Defining_Unit_Name =>
6674 Parameter_Specifications => New_List (
6675 Make_Parameter_Specification (Loc,
6676 Defining_Identifier =>
6679 New_Occurrence_Of (RTE (RE_Any), Loc))),
6680 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6683 Make_Subprogram_Body (Loc,
6684 Specification => Func_Spec,
6685 Declarations => No_List,
6686 Handled_Statement_Sequence =>
6687 Make_Handled_Sequence_Of_Statements (Loc,
6688 Statements => Statements)));
6689 Set_TSS (RAS_Type, Fnam);
6690 end Add_RAS_From_Any;
6692 --------------------
6693 -- Add_RAS_To_Any --
6694 --------------------
6696 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6697 Loc : constant Source_Ptr := Sloc (RAS_Type);
6699 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6700 Make_TSS_Name (RAS_Type, TSS_To_Any));
6703 Statements : List_Id;
6705 Func_Spec : Node_Id;
6707 Any : constant Entity_Id :=
6708 Make_Defining_Identifier (Loc,
6709 Chars => New_Internal_Name ('A'));
6710 RAS_Parameter : constant Entity_Id :=
6711 Make_Defining_Identifier (Loc,
6712 Chars => New_Internal_Name ('R'));
6713 RACW_Parameter : constant Node_Id :=
6714 Make_Selected_Component (Loc,
6715 Prefix => RAS_Parameter,
6716 Selector_Name => Name_Ras);
6719 -- Object declarations
6721 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6723 Make_Object_Declaration (Loc,
6724 Defining_Identifier =>
6726 Object_Definition =>
6727 New_Occurrence_Of (RTE (RE_Any), Loc),
6729 PolyORB_Support.Helpers.Build_To_Any_Call
6730 (RACW_Parameter, No_List)));
6732 Statements := New_List (
6733 Make_Procedure_Call_Statement (Loc,
6735 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6736 Parameter_Associations => New_List (
6737 New_Occurrence_Of (Any, Loc),
6738 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6740 Make_Simple_Return_Statement (Loc,
6742 New_Occurrence_Of (Any, Loc)));
6745 Make_Function_Specification (Loc,
6746 Defining_Unit_Name =>
6748 Parameter_Specifications => New_List (
6749 Make_Parameter_Specification (Loc,
6750 Defining_Identifier =>
6753 New_Occurrence_Of (RAS_Type, Loc))),
6754 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6757 Make_Subprogram_Body (Loc,
6758 Specification => Func_Spec,
6759 Declarations => Decls,
6760 Handled_Statement_Sequence =>
6761 Make_Handled_Sequence_Of_Statements (Loc,
6762 Statements => Statements)));
6763 Set_TSS (RAS_Type, Fnam);
6766 ----------------------
6767 -- Add_RAS_TypeCode --
6768 ----------------------
6770 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6771 Loc : constant Source_Ptr := Sloc (RAS_Type);
6773 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6774 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6776 Func_Spec : Node_Id;
6778 Decls : constant List_Id := New_List;
6779 Name_String, Repo_Id_String : String_Id;
6783 Make_Function_Specification (Loc,
6784 Defining_Unit_Name =>
6786 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6788 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6789 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6792 Make_Subprogram_Body (Loc,
6793 Specification => Func_Spec,
6794 Declarations => Decls,
6795 Handled_Statement_Sequence =>
6796 Make_Handled_Sequence_Of_Statements (Loc,
6797 Statements => New_List (
6798 Make_Simple_Return_Statement (Loc,
6800 Make_Function_Call (Loc,
6802 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6803 Parameter_Associations => New_List (
6804 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6805 Make_Aggregate (Loc,
6808 Make_Function_Call (Loc,
6809 Name => New_Occurrence_Of (
6810 RTE (RE_TA_String), Loc),
6811 Parameter_Associations => New_List (
6812 Make_String_Literal (Loc, Name_String))),
6813 Make_Function_Call (Loc,
6814 Name => New_Occurrence_Of (
6815 RTE (RE_TA_String), Loc),
6816 Parameter_Associations => New_List (
6817 Make_String_Literal (Loc,
6818 Repo_Id_String))))))))))));
6819 Set_TSS (RAS_Type, Fnam);
6820 end Add_RAS_TypeCode;
6822 -----------------------------------------
6823 -- Add_Receiving_Stubs_To_Declarations --
6824 -----------------------------------------
6826 procedure Add_Receiving_Stubs_To_Declarations
6827 (Pkg_Spec : Node_Id;
6831 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6833 Pkg_RPC_Receiver : constant Entity_Id :=
6834 Make_Defining_Identifier (Loc,
6835 New_Internal_Name ('H'));
6836 Pkg_RPC_Receiver_Object : Node_Id;
6838 Pkg_RPC_Receiver_Body : Node_Id;
6839 Pkg_RPC_Receiver_Decls : List_Id;
6840 Pkg_RPC_Receiver_Statements : List_Id;
6841 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6842 -- A Pkg_RPC_Receiver is built to decode the request
6845 -- Request object received from neutral layer
6847 Subp_Id : Entity_Id;
6848 -- Subprogram identifier as received from the neutral
6849 -- distribution core.
6851 Subp_Index : Entity_Id;
6852 -- Internal index as determined by matching either the
6853 -- method name from the request structure, or the local
6854 -- subprogram address (in case of a RAS).
6856 Is_Local : constant Entity_Id :=
6857 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
6858 Local_Address : constant Entity_Id :=
6859 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
6860 -- Address of a local subprogram designated by a
6861 -- reference corresponding to a RAS.
6863 Dispatch_On_Address : constant List_Id := New_List;
6864 Dispatch_On_Name : constant List_Id := New_List;
6866 Current_Declaration : Node_Id;
6867 Current_Stubs : Node_Id;
6868 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6870 Subp_Info_Array : constant Entity_Id :=
6871 Make_Defining_Identifier (Loc,
6872 Chars => New_Internal_Name ('I'));
6874 Subp_Info_List : constant List_Id := New_List;
6876 Register_Pkg_Actuals : constant List_Id := New_List;
6878 All_Calls_Remote_E : Entity_Id;
6880 procedure Append_Stubs_To
6881 (RPC_Receiver_Cases : List_Id;
6882 Declaration : Node_Id;
6885 Subp_Dist_Name : Entity_Id;
6886 Subp_Proxy_Addr : Entity_Id);
6887 -- Add one case to the specified RPC receiver case list associating
6888 -- Subprogram_Number with the subprogram declared by Declaration, for
6889 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6890 -- subprogram index. Subp_Dist_Name is the string used to call the
6891 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6892 -- object, used in the context of calls through remote
6893 -- access-to-subprogram types.
6895 ---------------------
6896 -- Append_Stubs_To --
6897 ---------------------
6899 procedure Append_Stubs_To
6900 (RPC_Receiver_Cases : List_Id;
6901 Declaration : Node_Id;
6904 Subp_Dist_Name : Entity_Id;
6905 Subp_Proxy_Addr : Entity_Id)
6907 Case_Stmts : List_Id;
6909 Case_Stmts := New_List (
6910 Make_Procedure_Call_Statement (Loc,
6913 Defining_Entity (Stubs), Loc),
6914 Parameter_Associations =>
6915 New_List (New_Occurrence_Of (Request, Loc))));
6916 if Nkind (Specification (Declaration))
6917 = N_Function_Specification
6919 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6921 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6924 Append_To (RPC_Receiver_Cases,
6925 Make_Case_Statement_Alternative (Loc,
6927 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6931 Append_To (Dispatch_On_Name,
6932 Make_Elsif_Part (Loc,
6934 Make_Function_Call (Loc,
6936 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6937 Parameter_Associations => New_List (
6938 New_Occurrence_Of (Subp_Id, Loc),
6939 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6940 Then_Statements => New_List (
6941 Make_Assignment_Statement (Loc,
6942 New_Occurrence_Of (Subp_Index, Loc),
6943 Make_Integer_Literal (Loc,
6946 Append_To (Dispatch_On_Address,
6947 Make_Elsif_Part (Loc,
6951 New_Occurrence_Of (Local_Address, Loc),
6953 New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6954 Then_Statements => New_List (
6955 Make_Assignment_Statement (Loc,
6956 New_Occurrence_Of (Subp_Index, Loc),
6957 Make_Integer_Literal (Loc,
6959 end Append_Stubs_To;
6961 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6964 -- Building receiving stubs consist in several operations:
6966 -- - a package RPC receiver must be built. This subprogram
6967 -- will get a Subprogram_Id from the incoming stream
6968 -- and will dispatch the call to the right subprogram;
6970 -- - a receiving stub for each subprogram visible in the package
6971 -- spec. This stub will read all the parameters from the stream,
6972 -- and put the result as well as the exception occurrence in the
6975 -- - a dummy package with an empty spec and a body made of an
6976 -- elaboration part, whose job is to register the receiving
6977 -- part of this RCI package on the name server. This is done
6978 -- by calling System.Partition_Interface.Register_Receiving_Stub.
6980 Build_RPC_Receiver_Body (
6981 RPC_Receiver => Pkg_RPC_Receiver,
6984 Subp_Index => Subp_Index,
6985 Stmts => Pkg_RPC_Receiver_Statements,
6986 Decl => Pkg_RPC_Receiver_Body);
6987 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6989 -- Extract local address information from the target reference:
6990 -- if non-null, that means that this is a reference that denotes
6991 -- one particular operation, and hence that the operation name
6992 -- must not be taken into account for dispatching.
6994 Append_To (Pkg_RPC_Receiver_Decls,
6995 Make_Object_Declaration (Loc,
6996 Defining_Identifier =>
6998 Object_Definition =>
6999 New_Occurrence_Of (Standard_Boolean, Loc)));
7000 Append_To (Pkg_RPC_Receiver_Decls,
7001 Make_Object_Declaration (Loc,
7002 Defining_Identifier =>
7004 Object_Definition =>
7005 New_Occurrence_Of (RTE (RE_Address), Loc)));
7006 Append_To (Pkg_RPC_Receiver_Statements,
7007 Make_Procedure_Call_Statement (Loc,
7009 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7010 Parameter_Associations => New_List (
7011 Make_Selected_Component (Loc,
7013 Selector_Name => Name_Target),
7014 New_Occurrence_Of (Is_Local, Loc),
7015 New_Occurrence_Of (Local_Address, Loc))));
7017 -- For each subprogram, the receiving stub will be built and a
7018 -- case statement will be made on the Subprogram_Id to dispatch
7019 -- to the right subprogram.
7021 All_Calls_Remote_E := Boolean_Literals (
7022 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
7024 Overload_Counter_Table.Reset;
7025 Reserve_NamingContext_Methods;
7027 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
7028 while Present (Current_Declaration) loop
7029 if Nkind (Current_Declaration) = N_Subprogram_Declaration
7030 and then Comes_From_Source (Current_Declaration)
7033 Loc : constant Source_Ptr :=
7034 Sloc (Current_Declaration);
7035 -- While specifically processing Current_Declaration, use
7036 -- its Sloc as the location of all generated nodes.
7038 Subp_Def : constant Entity_Id :=
7040 (Specification (Current_Declaration));
7042 Subp_Val : String_Id;
7044 Subp_Dist_Name : constant Entity_Id :=
7045 Make_Defining_Identifier (Loc,
7047 Related_Id => Chars (Subp_Def),
7049 Suffix_Index => -1));
7051 Proxy_Object_Addr : Entity_Id;
7054 -- Build receiving stub
7057 Build_Subprogram_Receiving_Stubs
7058 (Vis_Decl => Current_Declaration,
7060 Nkind (Specification (Current_Declaration)) =
7061 N_Procedure_Specification
7062 and then Is_Asynchronous (Subp_Def));
7064 Append_To (Decls, Current_Stubs);
7065 Analyze (Current_Stubs);
7069 Add_RAS_Proxy_And_Analyze (Decls,
7071 Current_Declaration,
7072 All_Calls_Remote_E =>
7074 Proxy_Object_Addr =>
7077 -- Compute distribution identifier
7079 Assign_Subprogram_Identifier (
7081 Current_Subprogram_Number,
7084 pragma Assert (Current_Subprogram_Number =
7085 Get_Subprogram_Id (Subp_Def));
7088 Make_Object_Declaration (Loc,
7089 Defining_Identifier => Subp_Dist_Name,
7090 Constant_Present => True,
7091 Object_Definition => New_Occurrence_Of (
7092 Standard_String, Loc),
7094 Make_String_Literal (Loc, Subp_Val)));
7095 Analyze (Last (Decls));
7097 -- Add subprogram descriptor (RCI_Subp_Info) to the
7098 -- subprograms table for this receiver. The aggregate
7099 -- below must be kept consistent with the declaration
7100 -- of type RCI_Subp_Info in System.Partition_Interface.
7102 Append_To (Subp_Info_List,
7103 Make_Component_Association (Loc,
7104 Choices => New_List (
7105 Make_Integer_Literal (Loc,
7106 Current_Subprogram_Number)),
7108 Make_Aggregate (Loc,
7109 Expressions => New_List (
7110 Make_Attribute_Reference (Loc,
7113 Subp_Dist_Name, Loc),
7114 Attribute_Name => Name_Address),
7115 Make_Attribute_Reference (Loc,
7118 Subp_Dist_Name, Loc),
7119 Attribute_Name => Name_Length),
7120 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
7122 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
7123 Declaration => Current_Declaration,
7124 Stubs => Current_Stubs,
7125 Subp_Number => Current_Subprogram_Number,
7126 Subp_Dist_Name => Subp_Dist_Name,
7127 Subp_Proxy_Addr => Proxy_Object_Addr);
7130 Current_Subprogram_Number := Current_Subprogram_Number + 1;
7133 Next (Current_Declaration);
7137 Make_Object_Declaration (Loc,
7138 Defining_Identifier => Subp_Info_Array,
7139 Constant_Present => True,
7140 Aliased_Present => True,
7141 Object_Definition =>
7142 Make_Subtype_Indication (Loc,
7144 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
7146 Make_Index_Or_Discriminant_Constraint (Loc,
7149 Low_Bound => Make_Integer_Literal (Loc,
7150 First_RCI_Subprogram_Id),
7152 Make_Integer_Literal (Loc,
7153 First_RCI_Subprogram_Id
7154 + List_Length (Subp_Info_List) - 1)))))));
7156 if Present (First (Subp_Info_List)) then
7157 Set_Expression (Last (Decls),
7158 Make_Aggregate (Loc,
7159 Component_Associations => Subp_Info_List));
7161 -- Generate the dispatch statement to determine the subprogram id
7162 -- of the called subprogram.
7164 -- We first test whether the reference that was used to make the
7165 -- call was the base RCI reference (in which case Local_Address is
7166 -- zero, and the method identifier from the request must be used
7167 -- to determine which subprogram is called) or a reference
7168 -- identifying one particular subprogram (in which case
7169 -- Local_Address is the address of that subprogram, and the
7170 -- method name from the request is ignored). The latter occurs
7171 -- for the case of a call through a remote access-to-subprogram.
7173 -- In each case, cascaded elsifs are used to determine the proper
7174 -- subprogram index. Using hash tables might be more efficient.
7176 Append_To (Pkg_RPC_Receiver_Statements,
7177 Make_Implicit_If_Statement (Pkg_Spec,
7180 Left_Opnd => New_Occurrence_Of
7181 (Local_Address, Loc),
7182 Right_Opnd => New_Occurrence_Of
7183 (RTE (RE_Null_Address), Loc)),
7184 Then_Statements => New_List (
7185 Make_Implicit_If_Statement (Pkg_Spec,
7187 New_Occurrence_Of (Standard_False, Loc),
7188 Then_Statements => New_List (
7189 Make_Null_Statement (Loc)),
7191 Dispatch_On_Address)),
7193 Else_Statements => New_List (
7194 Make_Implicit_If_Statement (Pkg_Spec,
7196 New_Occurrence_Of (Standard_False, Loc),
7197 Then_Statements => New_List (
7198 Make_Null_Statement (Loc)),
7200 Dispatch_On_Name))));
7203 -- For a degenerate RCI with no visible subprograms,
7204 -- Subp_Info_List has zero length, and the declaration is for an
7205 -- empty array, in which case no initialization aggregate must be
7206 -- generated. We do not generate a Dispatch_Statement either.
7208 -- No initialization provided: remove CONSTANT so that the
7209 -- declaration is not an incomplete deferred constant.
7211 Set_Constant_Present (Last (Decls), False);
7214 -- Analyze Subp_Info_Array declaration
7216 Analyze (Last (Decls));
7218 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7219 -- rather than raising an exception since we do not want someone
7220 -- to crash a remote partition by sending invalid subprogram ids.
7221 -- This is consistent with the other parts of the case statement
7222 -- since even in presence of incorrect parameters in the stream,
7223 -- every exception will be caught and (if the subprogram is not an
7224 -- APC) put into the result stream and sent away.
7226 Append_To (Pkg_RPC_Receiver_Cases,
7227 Make_Case_Statement_Alternative (Loc,
7229 New_List (Make_Others_Choice (Loc)),
7231 New_List (Make_Null_Statement (Loc))));
7233 Append_To (Pkg_RPC_Receiver_Statements,
7234 Make_Case_Statement (Loc,
7236 New_Occurrence_Of (Subp_Index, Loc),
7237 Alternatives => Pkg_RPC_Receiver_Cases));
7239 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7242 Append_To (Decls, Pkg_RPC_Receiver_Body);
7243 Analyze (Last (Decls));
7245 Pkg_RPC_Receiver_Object :=
7246 Make_Object_Declaration (Loc,
7247 Defining_Identifier =>
7248 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
7249 Aliased_Present => True,
7250 Object_Definition =>
7251 New_Occurrence_Of (RTE (RE_Servant), Loc));
7252 Append_To (Decls, Pkg_RPC_Receiver_Object);
7253 Analyze (Last (Decls));
7255 Get_Library_Unit_Name_String (Pkg_Spec);
7256 Append_To (Register_Pkg_Actuals,
7258 Make_String_Literal (Loc,
7259 Strval => String_From_Name_Buffer));
7261 Append_To (Register_Pkg_Actuals,
7263 Make_Attribute_Reference (Loc,
7266 (Defining_Entity (Pkg_Spec), Loc),
7270 Append_To (Register_Pkg_Actuals,
7272 Make_Attribute_Reference (Loc,
7274 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7275 Attribute_Name => Name_Access));
7277 Append_To (Register_Pkg_Actuals,
7279 Make_Attribute_Reference (Loc,
7282 Defining_Identifier (
7283 Pkg_RPC_Receiver_Object), Loc),
7287 Append_To (Register_Pkg_Actuals,
7289 Make_Attribute_Reference (Loc,
7291 New_Occurrence_Of (Subp_Info_Array, Loc),
7295 Append_To (Register_Pkg_Actuals,
7297 Make_Attribute_Reference (Loc,
7299 New_Occurrence_Of (Subp_Info_Array, Loc),
7303 Append_To (Register_Pkg_Actuals,
7304 -- Is_All_Calls_Remote
7305 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7308 Make_Procedure_Call_Statement (Loc,
7310 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7311 Parameter_Associations => Register_Pkg_Actuals));
7312 Analyze (Last (Stmts));
7314 end Add_Receiving_Stubs_To_Declarations;
7316 ---------------------------------
7317 -- Build_General_Calling_Stubs --
7318 ---------------------------------
7320 procedure Build_General_Calling_Stubs
7322 Statements : List_Id;
7323 Target_Object : Node_Id;
7324 Subprogram_Id : Node_Id;
7325 Asynchronous : Node_Id := Empty;
7326 Is_Known_Asynchronous : Boolean := False;
7327 Is_Known_Non_Asynchronous : Boolean := False;
7328 Is_Function : Boolean;
7330 Stub_Type : Entity_Id := Empty;
7331 RACW_Type : Entity_Id := Empty;
7334 Loc : constant Source_Ptr := Sloc (Nod);
7336 Arguments : Node_Id;
7337 -- Name of the named values list used to transmit parameters
7338 -- to the remote package
7341 -- The request object constructed by these stubs
7344 -- Name of the result named value (in non-APC cases) which get the
7345 -- result of the remote subprogram.
7347 Result_TC : Node_Id;
7348 -- Typecode expression for the result of the request (void
7349 -- typecode for procedures).
7351 Exception_Return_Parameter : Node_Id;
7352 -- Name of the parameter which will hold the exception sent by the
7353 -- remote subprogram.
7355 Current_Parameter : Node_Id;
7356 -- Current parameter being handled
7358 Ordered_Parameters_List : constant List_Id :=
7359 Build_Ordered_Parameters_List (Spec);
7361 Asynchronous_P : Node_Id;
7362 -- A Boolean expression indicating whether this call is asynchronous
7364 Asynchronous_Statements : List_Id := No_List;
7365 Non_Asynchronous_Statements : List_Id := No_List;
7366 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7368 Extra_Formal_Statements : constant List_Id := New_List;
7369 -- List of statements for extra formal parameters. It will appear
7370 -- after the regular statements for writing out parameters.
7372 After_Statements : constant List_Id := New_List;
7373 -- Statements to be executed after call returns (to assign
7374 -- in out or out parameter values).
7377 -- The type of the formal parameter being processed
7379 Is_Controlling_Formal : Boolean;
7380 Is_First_Controlling_Formal : Boolean;
7381 First_Controlling_Formal_Seen : Boolean := False;
7382 -- Controlling formal parameters of distributed object primitives
7383 -- require special handling, and the first such parameter needs even
7384 -- more special handling.
7387 -- ??? document general form of stub subprograms for the PolyORB case
7389 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7392 Make_Object_Declaration (Loc,
7393 Defining_Identifier => Request,
7394 Aliased_Present => False,
7395 Object_Definition =>
7396 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
7399 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7402 Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7403 Etype (Result_Definition (Spec)), Decls);
7405 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7409 Make_Object_Declaration (Loc,
7410 Defining_Identifier => Result,
7411 Aliased_Present => False,
7412 Object_Definition =>
7413 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7415 Make_Aggregate (Loc,
7416 Component_Associations => New_List (
7417 Make_Component_Association (Loc,
7418 Choices => New_List (
7419 Make_Identifier (Loc, Name_Name)),
7421 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7422 Make_Component_Association (Loc,
7423 Choices => New_List (
7424 Make_Identifier (Loc, Name_Argument)),
7426 Make_Function_Call (Loc,
7428 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7429 Parameter_Associations => New_List (
7431 Make_Component_Association (Loc,
7432 Choices => New_List (
7433 Make_Identifier (Loc, Name_Arg_Modes)),
7435 Make_Integer_Literal (Loc, 0))))));
7437 if not Is_Known_Asynchronous then
7438 Exception_Return_Parameter :=
7439 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7442 Make_Object_Declaration (Loc,
7443 Defining_Identifier => Exception_Return_Parameter,
7444 Object_Definition =>
7445 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7448 Exception_Return_Parameter := Empty;
7451 -- Initialize and fill in arguments list
7454 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7455 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7457 Current_Parameter := First (Ordered_Parameters_List);
7458 while Present (Current_Parameter) loop
7460 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7461 Is_Controlling_Formal := True;
7462 Is_First_Controlling_Formal :=
7463 not First_Controlling_Formal_Seen;
7464 First_Controlling_Formal_Seen := True;
7466 Is_Controlling_Formal := False;
7467 Is_First_Controlling_Formal := False;
7470 if Is_Controlling_Formal then
7472 -- In the case of a controlling formal argument, we send its
7478 Etyp := Etype (Parameter_Type (Current_Parameter));
7481 -- The first controlling formal parameter is treated specially: it
7482 -- is used to set the target object of the call.
7484 if not Is_First_Controlling_Formal then
7487 Constrained : constant Boolean :=
7488 Is_Constrained (Etyp)
7489 or else Is_Elementary_Type (Etyp);
7491 Any : constant Entity_Id :=
7492 Make_Defining_Identifier (Loc,
7493 New_Internal_Name ('A'));
7495 Actual_Parameter : Node_Id :=
7497 Defining_Identifier (
7498 Current_Parameter), Loc);
7503 if Is_Controlling_Formal then
7505 -- For a controlling formal parameter (other than the
7506 -- first one), use the corresponding RACW. If the
7507 -- parameter is not an anonymous access parameter, that
7508 -- involves taking its 'Unrestricted_Access.
7510 if Nkind (Parameter_Type (Current_Parameter))
7511 = N_Access_Definition
7513 Actual_Parameter := OK_Convert_To
7514 (Etyp, Actual_Parameter);
7516 Actual_Parameter := OK_Convert_To (Etyp,
7517 Make_Attribute_Reference (Loc,
7521 Name_Unrestricted_Access));
7526 if In_Present (Current_Parameter)
7527 or else not Out_Present (Current_Parameter)
7528 or else not Constrained
7529 or else Is_Controlling_Formal
7531 -- The parameter has an input value, is constrained at
7532 -- runtime by an input value, or is a controlling formal
7533 -- parameter (always passed as a reference) other than
7536 Expr := PolyORB_Support.Helpers.Build_To_Any_Call (
7537 Actual_Parameter, Decls);
7539 Expr := Make_Function_Call (Loc,
7541 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7542 Parameter_Associations => New_List (
7543 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7548 Make_Object_Declaration (Loc,
7549 Defining_Identifier =>
7551 Aliased_Present => False,
7552 Object_Definition =>
7553 New_Occurrence_Of (RTE (RE_Any), Loc),
7557 Append_To (Statements,
7558 Add_Parameter_To_NVList (Loc,
7559 Parameter => Current_Parameter,
7560 NVList => Arguments,
7561 Constrained => Constrained,
7564 if Out_Present (Current_Parameter)
7565 and then not Is_Controlling_Formal
7567 Append_To (After_Statements,
7568 Make_Assignment_Statement (Loc,
7571 Defining_Identifier (Current_Parameter), Loc),
7573 PolyORB_Support.Helpers.Build_From_Any_Call (
7574 Etype (Parameter_Type (Current_Parameter)),
7575 New_Occurrence_Of (Any, Loc),
7582 -- If the current parameter has a dynamic constrained status, then
7583 -- this status is transmitted as well.
7584 -- This should be done for accessibility as well ???
7586 if Nkind (Parameter_Type (Current_Parameter))
7587 /= N_Access_Definition
7588 and then Need_Extra_Constrained (Current_Parameter)
7590 -- In this block, we do not use the extra formal that has been
7591 -- created because it does not exist at the time of expansion
7592 -- when building calling stubs for remote access to subprogram
7593 -- types. We create an extra variable of this type and push it
7594 -- in the stream after the regular parameters.
7597 Extra_Any_Parameter : constant Entity_Id :=
7598 Make_Defining_Identifier
7599 (Loc, New_Internal_Name ('P'));
7601 Parameter_Exp : constant Node_Id :=
7602 Make_Attribute_Reference (Loc,
7603 Prefix => New_Occurrence_Of (
7604 Defining_Identifier (Current_Parameter), Loc),
7605 Attribute_Name => Name_Constrained);
7607 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7610 Make_Object_Declaration (Loc,
7611 Defining_Identifier =>
7612 Extra_Any_Parameter,
7613 Aliased_Present => False,
7614 Object_Definition =>
7615 New_Occurrence_Of (RTE (RE_Any), Loc),
7617 PolyORB_Support.Helpers.Build_To_Any_Call (
7621 Append_To (Extra_Formal_Statements,
7622 Add_Parameter_To_NVList (Loc,
7623 Parameter => Extra_Any_Parameter,
7624 NVList => Arguments,
7625 Constrained => True,
7626 Any => Extra_Any_Parameter));
7630 Next (Current_Parameter);
7633 -- Append the formal statements list to the statements
7635 Append_List_To (Statements, Extra_Formal_Statements);
7637 Append_To (Statements,
7638 Make_Procedure_Call_Statement (Loc,
7640 New_Occurrence_Of (RTE (RE_Request_Create), Loc),
7641 Parameter_Associations => New_List (
7644 New_Occurrence_Of (Arguments, Loc),
7645 New_Occurrence_Of (Result, Loc),
7646 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7648 Append_To (Parameter_Associations (Last (Statements)),
7649 New_Occurrence_Of (Request, Loc));
7652 not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7653 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7654 Asynchronous_P := New_Occurrence_Of (
7655 Boolean_Literals (Is_Known_Asynchronous), Loc);
7657 pragma Assert (Present (Asynchronous));
7658 Asynchronous_P := New_Copy_Tree (Asynchronous);
7659 -- The expression node Asynchronous will be used to build an 'if'
7660 -- statement at the end of Build_General_Calling_Stubs: we need to
7661 -- make a copy here.
7664 Append_To (Parameter_Associations (Last (Statements)),
7665 Make_Indexed_Component (Loc,
7668 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7669 Expressions => New_List (Asynchronous_P)));
7671 Append_To (Statements,
7672 Make_Procedure_Call_Statement (Loc,
7674 New_Occurrence_Of (RTE (RE_Request_Invoke), Loc),
7675 Parameter_Associations => New_List (
7676 New_Occurrence_Of (Request, Loc))));
7678 Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7679 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7681 if not Is_Known_Asynchronous then
7683 -- Reraise an exception occurrence from the completed request.
7684 -- If the exception occurrence is empty, this is a no-op.
7686 Append_To (Non_Asynchronous_Statements,
7687 Make_Procedure_Call_Statement (Loc,
7689 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7690 Parameter_Associations => New_List (
7691 New_Occurrence_Of (Request, Loc))));
7695 -- If this is a function call, read the value and return it
7697 Append_To (Non_Asynchronous_Statements,
7698 Make_Tag_Check (Loc,
7699 Make_Simple_Return_Statement (Loc,
7700 PolyORB_Support.Helpers.Build_From_Any_Call (
7701 Etype (Result_Definition (Spec)),
7702 Make_Selected_Component (Loc,
7704 Selector_Name => Name_Argument),
7709 Append_List_To (Non_Asynchronous_Statements,
7712 if Is_Known_Asynchronous then
7713 Append_List_To (Statements, Asynchronous_Statements);
7715 elsif Is_Known_Non_Asynchronous then
7716 Append_List_To (Statements, Non_Asynchronous_Statements);
7719 pragma Assert (Present (Asynchronous));
7720 Append_To (Statements,
7721 Make_Implicit_If_Statement (Nod,
7722 Condition => Asynchronous,
7723 Then_Statements => Asynchronous_Statements,
7724 Else_Statements => Non_Asynchronous_Statements));
7726 end Build_General_Calling_Stubs;
7728 -----------------------
7729 -- Build_Stub_Target --
7730 -----------------------
7732 function Build_Stub_Target
7735 RCI_Locator : Entity_Id;
7736 Controlling_Parameter : Entity_Id) return RPC_Target
7738 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7739 Target_Reference : constant Entity_Id :=
7740 Make_Defining_Identifier (Loc,
7741 New_Internal_Name ('T'));
7743 if Present (Controlling_Parameter) then
7745 Make_Object_Declaration (Loc,
7746 Defining_Identifier => Target_Reference,
7747 Object_Definition =>
7748 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7750 Make_Function_Call (Loc,
7752 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7753 Parameter_Associations => New_List (
7754 Make_Selected_Component (Loc,
7755 Prefix => Controlling_Parameter,
7756 Selector_Name => Name_Target)))));
7757 -- Controlling_Parameter has the same components as
7758 -- System.Partition_Interface.RACW_Stub_Type.
7760 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7763 Target_Info.Object :=
7764 Make_Selected_Component (Loc,
7766 Make_Identifier (Loc, Chars (RCI_Locator)),
7768 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7771 end Build_Stub_Target;
7773 ---------------------
7774 -- Build_Stub_Type --
7775 ---------------------
7777 procedure Build_Stub_Type
7778 (RACW_Type : Entity_Id;
7779 Stub_Type : Entity_Id;
7780 Stub_Type_Decl : out Node_Id;
7781 RPC_Receiver_Decl : out Node_Id)
7783 Loc : constant Source_Ptr := Sloc (Stub_Type);
7784 pragma Warnings (Off);
7785 pragma Unreferenced (RACW_Type);
7786 pragma Warnings (On);
7790 Make_Full_Type_Declaration (Loc,
7791 Defining_Identifier => Stub_Type,
7793 Make_Record_Definition (Loc,
7794 Tagged_Present => True,
7795 Limited_Present => True,
7797 Make_Component_List (Loc,
7798 Component_Items => New_List (
7800 Make_Component_Declaration (Loc,
7801 Defining_Identifier =>
7802 Make_Defining_Identifier (Loc, Name_Target),
7803 Component_Definition =>
7804 Make_Component_Definition (Loc,
7807 Subtype_Indication =>
7808 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7810 Make_Component_Declaration (Loc,
7811 Defining_Identifier =>
7812 Make_Defining_Identifier (Loc, Name_Asynchronous),
7813 Component_Definition =>
7814 Make_Component_Definition (Loc,
7815 Aliased_Present => False,
7816 Subtype_Indication =>
7818 Standard_Boolean, Loc)))))));
7820 RPC_Receiver_Decl :=
7821 Make_Object_Declaration (Loc,
7822 Defining_Identifier => Make_Defining_Identifier (Loc,
7823 New_Internal_Name ('R')),
7824 Aliased_Present => True,
7825 Object_Definition =>
7826 New_Occurrence_Of (RTE (RE_Servant), Loc));
7827 end Build_Stub_Type;
7829 -----------------------------
7830 -- Build_RPC_Receiver_Body --
7831 -----------------------------
7833 procedure Build_RPC_Receiver_Body
7834 (RPC_Receiver : Entity_Id;
7835 Request : out Entity_Id;
7836 Subp_Id : out Entity_Id;
7837 Subp_Index : out Entity_Id;
7838 Stmts : out List_Id;
7841 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7843 RPC_Receiver_Spec : Node_Id;
7844 RPC_Receiver_Decls : List_Id;
7847 Request := Make_Defining_Identifier (Loc, Name_R);
7849 RPC_Receiver_Spec :=
7850 Build_RPC_Receiver_Specification (
7851 RPC_Receiver => RPC_Receiver,
7852 Request_Parameter => Request);
7854 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7855 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7857 RPC_Receiver_Decls := New_List (
7858 Make_Object_Renaming_Declaration (Loc,
7859 Defining_Identifier => Subp_Id,
7860 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7862 Make_Explicit_Dereference (Loc,
7864 Make_Selected_Component (Loc,
7866 Selector_Name => Name_Operation))),
7868 Make_Object_Declaration (Loc,
7869 Defining_Identifier => Subp_Index,
7870 Object_Definition =>
7871 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7873 Make_Attribute_Reference (Loc,
7875 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7876 Attribute_Name => Name_Last)));
7881 Make_Subprogram_Body (Loc,
7882 Specification => RPC_Receiver_Spec,
7883 Declarations => RPC_Receiver_Decls,
7884 Handled_Statement_Sequence =>
7885 Make_Handled_Sequence_Of_Statements (Loc,
7886 Statements => Stmts));
7887 end Build_RPC_Receiver_Body;
7889 --------------------------------------
7890 -- Build_Subprogram_Receiving_Stubs --
7891 --------------------------------------
7893 function Build_Subprogram_Receiving_Stubs
7894 (Vis_Decl : Node_Id;
7895 Asynchronous : Boolean;
7896 Dynamically_Asynchronous : Boolean := False;
7897 Stub_Type : Entity_Id := Empty;
7898 RACW_Type : Entity_Id := Empty;
7899 Parent_Primitive : Entity_Id := Empty) return Node_Id
7901 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7903 Request_Parameter : constant Entity_Id :=
7904 Make_Defining_Identifier (Loc,
7905 New_Internal_Name ('R'));
7906 -- Formal parameter for receiving stubs: a descriptor for an incoming
7909 Outer_Decls : constant List_Id := New_List;
7910 -- At the outermost level, an NVList and Any's are declared for all
7911 -- parameters. The Dynamic_Async flag also needs to be declared there
7912 -- to be visible from the exception handling code.
7914 Outer_Statements : constant List_Id := New_List;
7915 -- Statements that occur prior to the declaration of the actual
7916 -- parameter variables.
7918 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7919 -- Statements concerning extra formal parameters, prior to the
7920 -- declaration of the actual parameter variables.
7922 Decls : constant List_Id := New_List;
7923 -- All the parameters will get declared before calling the real
7924 -- subprograms. Also the out parameters will be declared.
7925 -- At this level, parameters may be unconstrained.
7927 Statements : constant List_Id := New_List;
7929 After_Statements : constant List_Id := New_List;
7930 -- Statements to be executed after the subprogram call
7932 Inner_Decls : List_Id := No_List;
7933 -- In case of a function, the inner declarations are needed since
7934 -- the result may be unconstrained.
7936 Excep_Handlers : List_Id := No_List;
7938 Parameter_List : constant List_Id := New_List;
7939 -- List of parameters to be passed to the subprogram
7941 First_Controlling_Formal_Seen : Boolean := False;
7943 Current_Parameter : Node_Id;
7945 Ordered_Parameters_List : constant List_Id :=
7946 Build_Ordered_Parameters_List
7947 (Specification (Vis_Decl));
7949 Arguments : constant Entity_Id :=
7950 Make_Defining_Identifier (Loc,
7951 New_Internal_Name ('A'));
7952 -- Name of the named values list used to retrieve parameters
7954 Subp_Spec : Node_Id;
7955 -- Subprogram specification
7957 Called_Subprogram : Node_Id;
7958 -- The subprogram to call
7961 if Present (RACW_Type) then
7962 Called_Subprogram :=
7963 New_Occurrence_Of (Parent_Primitive, Loc);
7965 Called_Subprogram :=
7967 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7970 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7972 -- Loop through every parameter and get its value from the stream. If
7973 -- the parameter is unconstrained, then the parameter is read using
7974 -- 'Input at the point of declaration.
7976 Current_Parameter := First (Ordered_Parameters_List);
7977 while Present (Current_Parameter) loop
7980 Constrained : Boolean;
7981 Any : Entity_Id := Empty;
7982 Object : constant Entity_Id :=
7983 Make_Defining_Identifier (Loc,
7984 New_Internal_Name ('P'));
7985 Expr : Node_Id := Empty;
7987 Is_Controlling_Formal : constant Boolean
7988 := Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
7990 Is_First_Controlling_Formal : Boolean := False;
7992 Need_Extra_Constrained : Boolean;
7993 -- True when an extra constrained actual is required
7996 if Is_Controlling_Formal then
7998 -- Controlling formals in distributed object primitive
7999 -- operations are handled specially:
8000 -- - the first controlling formal is used as the
8001 -- target of the call;
8002 -- - the remaining controlling formals are transmitted
8006 Is_First_Controlling_Formal :=
8007 not First_Controlling_Formal_Seen;
8008 First_Controlling_Formal_Seen := True;
8010 Etyp := Etype (Parameter_Type (Current_Parameter));
8014 Is_Constrained (Etyp)
8015 or else Is_Elementary_Type (Etyp);
8017 if not Is_First_Controlling_Formal then
8018 Any := Make_Defining_Identifier (Loc,
8019 New_Internal_Name ('A'));
8020 Append_To (Outer_Decls,
8021 Make_Object_Declaration (Loc,
8022 Defining_Identifier =>
8024 Object_Definition =>
8025 New_Occurrence_Of (RTE (RE_Any), Loc),
8027 Make_Function_Call (Loc,
8029 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8030 Parameter_Associations => New_List (
8031 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
8032 Etyp, Outer_Decls)))));
8034 Append_To (Outer_Statements,
8035 Add_Parameter_To_NVList (Loc,
8036 Parameter => Current_Parameter,
8037 NVList => Arguments,
8038 Constrained => Constrained,
8042 if Is_First_Controlling_Formal then
8044 Addr : constant Entity_Id :=
8045 Make_Defining_Identifier (Loc,
8046 New_Internal_Name ('A'));
8047 Is_Local : constant Entity_Id :=
8048 Make_Defining_Identifier (Loc,
8049 New_Internal_Name ('L'));
8052 -- Special case: obtain the first controlling formal
8053 -- from the target of the remote call, instead of the
8056 Append_To (Outer_Decls,
8057 Make_Object_Declaration (Loc,
8058 Defining_Identifier =>
8060 Object_Definition =>
8061 New_Occurrence_Of (RTE (RE_Address), Loc)));
8062 Append_To (Outer_Decls,
8063 Make_Object_Declaration (Loc,
8064 Defining_Identifier =>
8066 Object_Definition =>
8067 New_Occurrence_Of (Standard_Boolean, Loc)));
8068 Append_To (Outer_Statements,
8069 Make_Procedure_Call_Statement (Loc,
8072 RTE (RE_Get_Local_Address), Loc),
8073 Parameter_Associations => New_List (
8074 Make_Selected_Component (Loc,
8077 Request_Parameter, Loc),
8079 Make_Identifier (Loc, Name_Target)),
8080 New_Occurrence_Of (Is_Local, Loc),
8081 New_Occurrence_Of (Addr, Loc))));
8083 Expr := Unchecked_Convert_To (RACW_Type,
8084 New_Occurrence_Of (Addr, Loc));
8087 elsif In_Present (Current_Parameter)
8088 or else not Out_Present (Current_Parameter)
8089 or else not Constrained
8091 -- If an input parameter is constrained, then its reading is
8092 -- deferred until the beginning of the subprogram body. If
8093 -- it is unconstrained, then an expression is built for
8094 -- the object declaration and the variable is set using
8095 -- 'Input instead of 'Read.
8097 Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
8098 Etyp, New_Occurrence_Of (Any, Loc), Decls);
8101 Append_To (Statements,
8102 Make_Assignment_Statement (Loc,
8104 New_Occurrence_Of (Object, Loc),
8110 -- Expr will be used to initialize (and constrain) the
8111 -- parameter when it is declared.
8116 Need_Extra_Constrained :=
8117 Nkind (Parameter_Type (Current_Parameter)) /=
8120 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
8122 Present (Extra_Constrained
8123 (Defining_Identifier (Current_Parameter)));
8125 -- We may not associate an extra constrained actual to a
8126 -- constant object, so if one is needed, declare the actual
8127 -- as a variable even if it won't be modified.
8129 Build_Actual_Object_Declaration
8132 Variable => Need_Extra_Constrained
8133 or else Out_Present (Current_Parameter),
8136 Set_Etype (Object, Etyp);
8138 -- An out parameter may be written back using a 'Write
8139 -- attribute instead of a 'Output because it has been
8140 -- constrained by the parameter given to the caller. Note that
8141 -- out controlling arguments in the case of a RACW are not put
8142 -- back in the stream because the pointer on them has not
8145 if Out_Present (Current_Parameter)
8146 and then not Is_Controlling_Formal
8148 Append_To (After_Statements,
8149 Make_Procedure_Call_Statement (Loc,
8151 New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
8152 Parameter_Associations => New_List (
8153 New_Occurrence_Of (Any, Loc),
8154 PolyORB_Support.Helpers.Build_To_Any_Call (
8155 New_Occurrence_Of (Object, Loc),
8159 -- For RACW controlling formals, the Etyp of Object is always
8160 -- an RACW, even if the parameter is not of an anonymous access
8161 -- type. In such case, we need to dereference it at call time.
8163 if Is_Controlling_Formal then
8164 if Nkind (Parameter_Type (Current_Parameter)) /=
8167 Append_To (Parameter_List,
8168 Make_Parameter_Association (Loc,
8171 Defining_Identifier (Current_Parameter), Loc),
8172 Explicit_Actual_Parameter =>
8173 Make_Explicit_Dereference (Loc,
8174 Unchecked_Convert_To (RACW_Type,
8175 OK_Convert_To (RTE (RE_Address),
8176 New_Occurrence_Of (Object, Loc))))));
8179 Append_To (Parameter_List,
8180 Make_Parameter_Association (Loc,
8183 Defining_Identifier (Current_Parameter), Loc),
8184 Explicit_Actual_Parameter =>
8185 Unchecked_Convert_To (RACW_Type,
8186 OK_Convert_To (RTE (RE_Address),
8187 New_Occurrence_Of (Object, Loc)))));
8191 Append_To (Parameter_List,
8192 Make_Parameter_Association (Loc,
8195 Defining_Identifier (Current_Parameter), Loc),
8196 Explicit_Actual_Parameter =>
8197 New_Occurrence_Of (Object, Loc)));
8200 -- If the current parameter needs an extra formal, then read it
8201 -- from the stream and set the corresponding semantic field in
8202 -- the variable. If the kind of the parameter identifier is
8203 -- E_Void, then this is a compiler generated parameter that
8204 -- doesn't need an extra constrained status.
8206 -- The case of Extra_Accessibility should also be handled ???
8208 if Need_Extra_Constrained then
8210 Extra_Parameter : constant Entity_Id :=
8212 (Defining_Identifier
8213 (Current_Parameter));
8214 Extra_Any : constant Entity_Id :=
8215 Make_Defining_Identifier
8216 (Loc, New_Internal_Name ('A'));
8218 Formal_Entity : constant Entity_Id :=
8219 Make_Defining_Identifier
8220 (Loc, Chars (Extra_Parameter));
8222 Formal_Type : constant Entity_Id :=
8223 Etype (Extra_Parameter);
8225 Append_To (Outer_Decls,
8226 Make_Object_Declaration (Loc,
8227 Defining_Identifier =>
8229 Object_Definition =>
8230 New_Occurrence_Of (RTE (RE_Any), Loc),
8232 Make_Function_Call (Loc,
8234 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8235 Parameter_Associations => New_List (
8236 PolyORB_Support.Helpers.Build_TypeCode_Call
8237 (Loc, Formal_Type, Outer_Decls)))));
8239 Append_To (Outer_Extra_Formal_Statements,
8240 Add_Parameter_To_NVList (Loc,
8241 Parameter => Extra_Parameter,
8242 NVList => Arguments,
8243 Constrained => True,
8247 Make_Object_Declaration (Loc,
8248 Defining_Identifier => Formal_Entity,
8249 Object_Definition =>
8250 New_Occurrence_Of (Formal_Type, Loc)));
8252 Append_To (Statements,
8253 Make_Assignment_Statement (Loc,
8255 New_Occurrence_Of (Formal_Entity, Loc),
8257 PolyORB_Support.Helpers.Build_From_Any_Call (
8259 New_Occurrence_Of (Extra_Any, Loc),
8261 Set_Extra_Constrained (Object, Formal_Entity);
8266 Next (Current_Parameter);
8269 -- Extra Formals should go after all the other parameters
8271 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8273 Append_To (Outer_Statements,
8274 Make_Procedure_Call_Statement (Loc,
8276 New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8277 Parameter_Associations => New_List (
8278 New_Occurrence_Of (Request_Parameter, Loc),
8279 New_Occurrence_Of (Arguments, Loc))));
8281 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8283 -- The remote subprogram is a function. We build an inner block to
8284 -- be able to hold a potentially unconstrained result in a
8288 Etyp : constant Entity_Id :=
8289 Etype (Result_Definition (Specification (Vis_Decl)));
8290 Result : constant Node_Id :=
8291 Make_Defining_Identifier (Loc,
8292 New_Internal_Name ('R'));
8294 Inner_Decls := New_List (
8295 Make_Object_Declaration (Loc,
8296 Defining_Identifier => Result,
8297 Constant_Present => True,
8298 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8300 Make_Function_Call (Loc,
8301 Name => Called_Subprogram,
8302 Parameter_Associations => Parameter_List)));
8304 if Is_Class_Wide_Type (Etyp) then
8306 -- For a remote call to a function with a class-wide type,
8307 -- check that the returned value satisfies the requirements
8310 Append_To (Inner_Decls,
8311 Make_Transportable_Check (Loc,
8312 New_Occurrence_Of (Result, Loc)));
8316 Set_Etype (Result, Etyp);
8317 Append_To (After_Statements,
8318 Make_Procedure_Call_Statement (Loc,
8320 New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8321 Parameter_Associations => New_List (
8322 New_Occurrence_Of (Request_Parameter, Loc),
8323 PolyORB_Support.Helpers.Build_To_Any_Call (
8324 New_Occurrence_Of (Result, Loc),
8326 -- A DSA function does not have out or inout arguments
8329 Append_To (Statements,
8330 Make_Block_Statement (Loc,
8331 Declarations => Inner_Decls,
8332 Handled_Statement_Sequence =>
8333 Make_Handled_Sequence_Of_Statements (Loc,
8334 Statements => After_Statements)));
8337 -- The remote subprogram is a procedure. We do not need any inner
8338 -- block in this case. No specific processing is required here for
8339 -- the dynamically asynchronous case: the indication of whether
8340 -- call is asynchronous or not is managed by the Sync_Scope
8341 -- attibute of the request, and is handled entirely in the
8344 Append_To (After_Statements,
8345 Make_Procedure_Call_Statement (Loc,
8347 New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8348 Parameter_Associations => New_List (
8349 New_Occurrence_Of (Request_Parameter, Loc))));
8351 Append_To (Statements,
8352 Make_Procedure_Call_Statement (Loc,
8353 Name => Called_Subprogram,
8354 Parameter_Associations => Parameter_List));
8356 Append_List_To (Statements, After_Statements);
8360 Make_Procedure_Specification (Loc,
8361 Defining_Unit_Name =>
8362 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
8364 Parameter_Specifications => New_List (
8365 Make_Parameter_Specification (Loc,
8366 Defining_Identifier => Request_Parameter,
8368 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8370 -- An exception raised during the execution of an incoming
8371 -- remote subprogram call and that needs to be sent back
8372 -- to the caller is propagated by the receiving stubs, and
8373 -- will be handled by the caller (the distribution runtime).
8375 if Asynchronous and then not Dynamically_Asynchronous then
8377 -- For an asynchronous procedure, add a null exception handler
8379 Excep_Handlers := New_List (
8380 Make_Implicit_Exception_Handler (Loc,
8381 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8382 Statements => New_List (Make_Null_Statement (Loc))));
8386 -- In the other cases, if an exception is raised, then the
8387 -- exception occurrence is propagated.
8392 Append_To (Outer_Statements,
8393 Make_Block_Statement (Loc,
8396 Handled_Statement_Sequence =>
8397 Make_Handled_Sequence_Of_Statements (Loc,
8398 Statements => Statements)));
8401 Make_Subprogram_Body (Loc,
8402 Specification => Subp_Spec,
8403 Declarations => Outer_Decls,
8404 Handled_Statement_Sequence =>
8405 Make_Handled_Sequence_Of_Statements (Loc,
8406 Statements => Outer_Statements,
8407 Exception_Handlers => Excep_Handlers));
8408 end Build_Subprogram_Receiving_Stubs;
8414 package body Helpers is
8416 -----------------------
8417 -- Local Subprograms --
8418 -----------------------
8420 function Find_Numeric_Representation
8421 (Typ : Entity_Id) return Entity_Id;
8422 -- Given a numeric type Typ, return the smallest integer or floarting
8423 -- point type from Standard, or the smallest unsigned (modular) type
8424 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8426 function Make_Stream_Procedure_Function_Name
8429 Nam : Name_Id) return Entity_Id;
8430 -- Return the name to be assigned for stream subprogram Nam of Typ.
8431 -- (copied from exp_strm.adb, should be shared???)
8433 ------------------------------------------------------------
8434 -- Common subprograms for building various tree fragments --
8435 ------------------------------------------------------------
8437 function Build_Get_Aggregate_Element
8441 Idx : Node_Id) return Node_Id;
8442 -- Build a call to Get_Aggregate_Element on Any
8443 -- for typecode TC, returning the Idx'th element.
8446 Subprogram : Entity_Id;
8447 -- Reference location for constructed nodes
8450 -- For 'Range and Etype
8453 -- For the construction of the innermost element expression
8455 with procedure Add_Process_Element
8458 Counter : Entity_Id;
8461 procedure Append_Array_Traversal
8464 Counter : Entity_Id := Empty;
8466 -- Build nested loop statements that iterate over the elements of an
8467 -- array Arry. The statement(s) built by Add_Process_Element are
8468 -- executed for each element; Indices is the list of indices to be
8469 -- used in the construction of the indexed component that denotes the
8470 -- current element. Subprogram is the entity for the subprogram for
8471 -- which this iterator is generated. The generated statements are
8472 -- appended to Stmts.
8476 -- The record entity being dealt with
8478 with procedure Add_Process_Element
8480 Container : Node_Or_Entity_Id;
8481 Counter : in out Int;
8484 -- Rec is the instance of the record type, or Empty.
8485 -- Field is either the N_Defining_Identifier for a component,
8486 -- or an N_Variant_Part.
8488 procedure Append_Record_Traversal
8491 Container : Node_Or_Entity_Id;
8492 Counter : in out Int);
8493 -- Process component list Clist. Individual fields are passed
8494 -- to Field_Processing. Each variant part is also processed.
8495 -- Container is the outer Any (for From_Any/To_Any),
8496 -- the outer typecode (for TC) to which the operation applies.
8498 -----------------------------
8499 -- Append_Record_Traversal --
8500 -----------------------------
8502 procedure Append_Record_Traversal
8505 Container : Node_Or_Entity_Id;
8506 Counter : in out Int)
8510 -- Clist's Component_Items and Variant_Part
8520 CI := Component_Items (Clist);
8521 VP := Variant_Part (Clist);
8524 while Present (Item) loop
8525 Def := Defining_Identifier (Item);
8526 if not Is_Internal_Name (Chars (Def)) then
8528 (Stmts, Container, Counter, Rec, Def);
8533 if Present (VP) then
8534 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8536 end Append_Record_Traversal;
8538 -------------------------
8539 -- Build_From_Any_Call --
8540 -------------------------
8542 function Build_From_Any_Call
8545 Decls : List_Id) return Node_Id
8547 Loc : constant Source_Ptr := Sloc (N);
8549 U_Type : Entity_Id := Underlying_Type (Typ);
8551 Fnam : Entity_Id := Empty;
8552 Lib_RE : RE_Id := RE_Null;
8556 -- First simple case where the From_Any function is present
8557 -- in the type's TSS.
8559 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8561 if Sloc (U_Type) <= Standard_Location then
8562 U_Type := Base_Type (U_Type);
8565 -- Check first for Boolean and Character. These are enumeration
8566 -- types, but we treat them specially, since they may require
8567 -- special handling in the transfer protocol. However, this
8568 -- special handling only applies if they have standard
8569 -- representation, otherwise they are treated like any other
8570 -- enumeration type.
8572 if Present (Fnam) then
8575 elsif U_Type = Standard_Boolean then
8578 elsif U_Type = Standard_Character then
8581 elsif U_Type = Standard_Wide_Character then
8584 elsif U_Type = Standard_Wide_Wide_Character then
8585 Lib_RE := RE_FA_WWC;
8587 -- Floating point types
8589 elsif U_Type = Standard_Short_Float then
8592 elsif U_Type = Standard_Float then
8595 elsif U_Type = Standard_Long_Float then
8598 elsif U_Type = Standard_Long_Long_Float then
8599 Lib_RE := RE_FA_LLF;
8603 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8604 Lib_RE := RE_FA_SSI;
8606 elsif U_Type = Etype (Standard_Short_Integer) then
8609 elsif U_Type = Etype (Standard_Integer) then
8612 elsif U_Type = Etype (Standard_Long_Integer) then
8615 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8616 Lib_RE := RE_FA_LLI;
8618 -- Unsigned integer types
8620 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8621 Lib_RE := RE_FA_SSU;
8623 elsif U_Type = RTE (RE_Short_Unsigned) then
8626 elsif U_Type = RTE (RE_Unsigned) then
8629 elsif U_Type = RTE (RE_Long_Unsigned) then
8632 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8633 Lib_RE := RE_FA_LLU;
8635 elsif U_Type = Standard_String then
8636 Lib_RE := RE_FA_String;
8638 -- Other (non-primitive) types
8644 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8645 Append_To (Decls, Decl);
8649 -- Call the function
8651 if Lib_RE /= RE_Null then
8652 pragma Assert (No (Fnam));
8653 Fnam := RTE (Lib_RE);
8657 Make_Function_Call (Loc,
8658 Name => New_Occurrence_Of (Fnam, Loc),
8659 Parameter_Associations => New_List (N));
8661 -- We must set the type of Result, so the unchecked conversion
8662 -- from the underlying type to the base type is properly done.
8664 Set_Etype (Result, U_Type);
8666 return Unchecked_Convert_To (Typ, Result);
8667 end Build_From_Any_Call;
8669 -----------------------------
8670 -- Build_From_Any_Function --
8671 -----------------------------
8673 procedure Build_From_Any_Function
8677 Fnam : out Entity_Id)
8680 Decls : constant List_Id := New_List;
8681 Stms : constant List_Id := New_List;
8682 Any_Parameter : constant Entity_Id
8683 := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
8685 if Is_Itype (Typ) then
8686 Build_From_Any_Function
8694 Fnam := Make_Stream_Procedure_Function_Name (Loc,
8695 Typ, Name_uFrom_Any);
8698 Make_Function_Specification (Loc,
8699 Defining_Unit_Name => Fnam,
8700 Parameter_Specifications => New_List (
8701 Make_Parameter_Specification (Loc,
8702 Defining_Identifier =>
8705 New_Occurrence_Of (RTE (RE_Any), Loc))),
8706 Result_Definition => New_Occurrence_Of (Typ, Loc));
8708 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8711 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8713 if Is_Derived_Type (Typ)
8714 and then not Is_Tagged_Type (Typ)
8717 Make_Simple_Return_Statement (Loc,
8721 Build_From_Any_Call (
8723 New_Occurrence_Of (Any_Parameter, Loc),
8726 elsif Is_Record_Type (Typ)
8727 and then not Is_Derived_Type (Typ)
8728 and then not Is_Tagged_Type (Typ)
8730 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8732 Make_Simple_Return_Statement (Loc,
8736 Build_From_Any_Call (
8738 New_Occurrence_Of (Any_Parameter, Loc),
8742 Disc : Entity_Id := Empty;
8743 Discriminant_Associations : List_Id;
8744 Rdef : constant Node_Id :=
8745 Type_Definition (Declaration_Node (Typ));
8746 Component_Counter : Int := 0;
8748 -- The returned object
8750 Res : constant Entity_Id :=
8751 Make_Defining_Identifier (Loc,
8752 New_Internal_Name ('R'));
8754 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8756 procedure FA_Rec_Add_Process_Element
8759 Counter : in out Int;
8763 procedure FA_Append_Record_Traversal is
8764 new Append_Record_Traversal
8766 Add_Process_Element => FA_Rec_Add_Process_Element);
8768 --------------------------------
8769 -- FA_Rec_Add_Process_Element --
8770 --------------------------------
8772 procedure FA_Rec_Add_Process_Element
8775 Counter : in out Int;
8780 if Nkind (Field) = N_Defining_Identifier then
8782 -- A regular component
8785 Make_Assignment_Statement (Loc,
8786 Name => Make_Selected_Component (Loc,
8788 New_Occurrence_Of (Rec, Loc),
8790 New_Occurrence_Of (Field, Loc)),
8792 Build_From_Any_Call (Etype (Field),
8793 Build_Get_Aggregate_Element (Loc,
8795 Tc => Build_TypeCode_Call (Loc,
8796 Etype (Field), Decls),
8797 Idx => Make_Integer_Literal (Loc,
8806 Struct_Counter : Int := 0;
8808 Block_Decls : constant List_Id := New_List;
8809 Block_Stmts : constant List_Id := New_List;
8812 Alt_List : constant List_Id := New_List;
8813 Choice_List : List_Id;
8815 Struct_Any : constant Entity_Id :=
8816 Make_Defining_Identifier (Loc,
8817 New_Internal_Name ('S'));
8821 Make_Object_Declaration (Loc,
8822 Defining_Identifier =>
8826 Object_Definition =>
8827 New_Occurrence_Of (RTE (RE_Any), Loc),
8829 Make_Function_Call (Loc,
8830 Name => New_Occurrence_Of (
8831 RTE (RE_Extract_Union_Value), Loc),
8832 Parameter_Associations => New_List (
8833 Build_Get_Aggregate_Element (Loc,
8835 Tc => Make_Function_Call (Loc,
8836 Name => New_Occurrence_Of (
8837 RTE (RE_Any_Member_Type), Loc),
8838 Parameter_Associations =>
8840 New_Occurrence_Of (Any, Loc),
8841 Make_Integer_Literal (Loc,
8843 Idx => Make_Integer_Literal (Loc,
8847 Make_Block_Statement (Loc,
8850 Handled_Statement_Sequence =>
8851 Make_Handled_Sequence_Of_Statements (Loc,
8852 Statements => Block_Stmts)));
8854 Append_To (Block_Stmts,
8855 Make_Case_Statement (Loc,
8857 Make_Selected_Component (Loc,
8860 Chars (Name (Field))),
8864 Variant := First_Non_Pragma (Variants (Field));
8866 while Present (Variant) loop
8867 Choice_List := New_Copy_List_Tree
8868 (Discrete_Choices (Variant));
8870 VP_Stmts := New_List;
8872 -- Struct_Counter should be reset before
8873 -- handling a variant part. Indeed only one
8874 -- of the case statement alternatives will be
8875 -- executed at run-time, so the counter must
8876 -- start at 0 for every case statement.
8878 Struct_Counter := 0;
8880 FA_Append_Record_Traversal (
8882 Clist => Component_List (Variant),
8883 Container => Struct_Any,
8884 Counter => Struct_Counter);
8886 Append_To (Alt_List,
8887 Make_Case_Statement_Alternative (Loc,
8888 Discrete_Choices => Choice_List,
8891 Next_Non_Pragma (Variant);
8895 Counter := Counter + 1;
8896 end FA_Rec_Add_Process_Element;
8899 -- First all discriminants
8901 if Has_Discriminants (Typ) then
8902 Disc := First_Discriminant (Typ);
8903 Discriminant_Associations := New_List;
8905 while Present (Disc) loop
8907 Disc_Var_Name : constant Entity_Id :=
8908 Make_Defining_Identifier (Loc, Chars (Disc));
8909 Disc_Type : constant Entity_Id :=
8913 Make_Object_Declaration (Loc,
8914 Defining_Identifier =>
8916 Constant_Present => True,
8917 Object_Definition =>
8918 New_Occurrence_Of (Disc_Type, Loc),
8920 Build_From_Any_Call (Disc_Type,
8921 Build_Get_Aggregate_Element (Loc,
8922 Any => Any_Parameter,
8923 Tc => Build_TypeCode_Call
8924 (Loc, Disc_Type, Decls),
8925 Idx => Make_Integer_Literal
8926 (Loc, Component_Counter)),
8928 Component_Counter := Component_Counter + 1;
8930 Append_To (Discriminant_Associations,
8931 Make_Discriminant_Association (Loc,
8932 Selector_Names => New_List (
8933 New_Occurrence_Of (Disc, Loc)),
8935 New_Occurrence_Of (Disc_Var_Name, Loc)));
8937 Next_Discriminant (Disc);
8940 Res_Definition := Make_Subtype_Indication (Loc,
8941 Subtype_Mark => Res_Definition,
8943 Make_Index_Or_Discriminant_Constraint (Loc,
8944 Discriminant_Associations));
8947 -- Now we have all the discriminants in variables, we can
8948 -- declared a constrained object. Note that we are not
8949 -- initializing (non-discriminant) components directly in
8950 -- the object declarations, because which fields to
8951 -- initialize depends (at run time) on the discriminant
8955 Make_Object_Declaration (Loc,
8956 Defining_Identifier =>
8958 Object_Definition =>
8961 -- ... then all components
8963 FA_Append_Record_Traversal (Stms,
8964 Clist => Component_List (Rdef),
8965 Container => Any_Parameter,
8966 Counter => Component_Counter);
8969 Make_Simple_Return_Statement (Loc,
8970 Expression => New_Occurrence_Of (Res, Loc)));
8974 elsif Is_Array_Type (Typ) then
8976 Constrained : constant Boolean := Is_Constrained (Typ);
8978 procedure FA_Ary_Add_Process_Element
8981 Counter : Entity_Id;
8983 -- Assign the current element (as identified by Counter) of
8984 -- Any to the variable denoted by name Datum, and advance
8985 -- Counter by 1. If Datum is not an Any, a call to From_Any
8986 -- for its type is inserted.
8988 --------------------------------
8989 -- FA_Ary_Add_Process_Element --
8990 --------------------------------
8992 procedure FA_Ary_Add_Process_Element
8995 Counter : Entity_Id;
8998 Assignment : constant Node_Id :=
8999 Make_Assignment_Statement (Loc,
9001 Expression => Empty);
9003 Element_Any : Node_Id;
9007 Element_TC : Node_Id;
9010 if Etype (Datum) = RTE (RE_Any) then
9012 -- When Datum is an Any the Etype field is not
9013 -- sufficient to determine the typecode of Datum
9014 -- (which can be a TC_SEQUENCE or TC_ARRAY
9015 -- depending on the value of Constrained).
9016 -- Therefore we retrieve the typecode which has
9017 -- been constructed in Append_Array_Traversal with
9018 -- a call to Get_Any_Type.
9021 Make_Function_Call (Loc,
9022 Name => New_Occurrence_Of (
9023 RTE (RE_Get_Any_Type), Loc),
9024 Parameter_Associations => New_List (
9025 New_Occurrence_Of (Entity (Datum), Loc)));
9027 -- For non Any Datum we simply construct a typecode
9028 -- matching the Etype of the Datum.
9030 Element_TC := Build_TypeCode_Call
9031 (Loc, Etype (Datum), Decls);
9035 Build_Get_Aggregate_Element (Loc,
9038 Idx => New_Occurrence_Of (Counter, Loc));
9041 -- Note: here we *prepend* statements to Stmts, so
9042 -- we must do it in reverse order.
9045 Make_Assignment_Statement (Loc,
9047 New_Occurrence_Of (Counter, Loc),
9051 New_Occurrence_Of (Counter, Loc),
9053 Make_Integer_Literal (Loc, 1))));
9055 if Nkind (Datum) /= N_Attribute_Reference then
9057 -- We ignore the value of the length of each
9058 -- dimension, since the target array has already
9059 -- been constrained anyway.
9061 if Etype (Datum) /= RTE (RE_Any) then
9062 Set_Expression (Assignment,
9063 Build_From_Any_Call (
9064 Component_Type (Typ),
9068 Set_Expression (Assignment, Element_Any);
9070 Prepend_To (Stmts, Assignment);
9072 end FA_Ary_Add_Process_Element;
9074 Counter : constant Entity_Id :=
9075 Make_Defining_Identifier (Loc, Name_J);
9077 Initial_Counter_Value : Int := 0;
9079 Component_TC : constant Entity_Id :=
9080 Make_Defining_Identifier (Loc, Name_T);
9082 Res : constant Entity_Id :=
9083 Make_Defining_Identifier (Loc, Name_R);
9085 procedure Append_From_Any_Array_Iterator is
9086 new Append_Array_Traversal (
9089 Indices => New_List,
9090 Add_Process_Element => FA_Ary_Add_Process_Element);
9092 Res_Subtype_Indication : Node_Id :=
9093 New_Occurrence_Of (Typ, Loc);
9096 if not Constrained then
9098 Ndim : constant Int := Number_Dimensions (Typ);
9101 Indx : Node_Id := First_Index (Typ);
9104 Ranges : constant List_Id := New_List;
9107 for J in 1 .. Ndim loop
9108 Lnam := New_External_Name ('L', J);
9109 Hnam := New_External_Name ('H', J);
9110 Indt := Etype (Indx);
9113 Make_Object_Declaration (Loc,
9114 Defining_Identifier =>
9115 Make_Defining_Identifier (Loc, Lnam),
9118 Object_Definition =>
9119 New_Occurrence_Of (Indt, Loc),
9121 Build_From_Any_Call (
9123 Build_Get_Aggregate_Element (Loc,
9124 Any => Any_Parameter,
9125 Tc => Build_TypeCode_Call (Loc,
9127 Idx => Make_Integer_Literal (Loc, J - 1)),
9131 Make_Object_Declaration (Loc,
9132 Defining_Identifier =>
9133 Make_Defining_Identifier (Loc, Hnam),
9136 Object_Definition =>
9137 New_Occurrence_Of (Indt, Loc),
9138 Expression => Make_Attribute_Reference (Loc,
9140 New_Occurrence_Of (Indt, Loc),
9141 Attribute_Name => Name_Val,
9142 Expressions => New_List (
9143 Make_Op_Subtract (Loc,
9148 Standard_Long_Integer,
9149 Make_Identifier (Loc, Lnam)),
9152 Standard_Long_Integer,
9153 Make_Function_Call (Loc,
9154 Name => New_Occurrence_Of (RTE (
9155 RE_Get_Nested_Sequence_Length
9157 Parameter_Associations =>
9160 Any_Parameter, Loc),
9161 Make_Integer_Literal (Loc,
9164 Make_Integer_Literal (Loc, 1))))));
9168 Low_Bound => Make_Identifier (Loc, Lnam),
9169 High_Bound => Make_Identifier (Loc, Hnam)));
9174 -- Now we have all the necessary bound information:
9175 -- apply the set of range constraints to the
9176 -- (unconstrained) nominal subtype of Res.
9178 Initial_Counter_Value := Ndim;
9179 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9181 Res_Subtype_Indication,
9183 Make_Index_Or_Discriminant_Constraint (Loc,
9184 Constraints => Ranges));
9189 Make_Object_Declaration (Loc,
9190 Defining_Identifier => Res,
9191 Object_Definition => Res_Subtype_Indication));
9192 Set_Etype (Res, Typ);
9195 Make_Object_Declaration (Loc,
9196 Defining_Identifier => Counter,
9197 Object_Definition =>
9198 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
9200 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9203 Make_Object_Declaration (Loc,
9204 Defining_Identifier => Component_TC,
9205 Constant_Present => True,
9206 Object_Definition =>
9207 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9209 Build_TypeCode_Call (Loc,
9210 Component_Type (Typ), Decls)));
9212 Append_From_Any_Array_Iterator (Stms,
9213 Any_Parameter, Counter);
9216 Make_Simple_Return_Statement (Loc,
9217 Expression => New_Occurrence_Of (Res, Loc)));
9220 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9222 Make_Simple_Return_Statement (Loc,
9224 Unchecked_Convert_To (
9226 Build_From_Any_Call (
9227 Find_Numeric_Representation (Typ),
9228 New_Occurrence_Of (Any_Parameter, Loc),
9232 -- Default: type is represented as an opaque sequence of bytes
9235 Strm : constant Entity_Id :=
9236 Make_Defining_Identifier (Loc,
9237 Chars => New_Internal_Name ('S'));
9238 Res : constant Entity_Id :=
9239 Make_Defining_Identifier (Loc,
9240 Chars => New_Internal_Name ('R'));
9243 -- Strm : Buffer_Stream_Type;
9246 Make_Object_Declaration (Loc,
9247 Defining_Identifier =>
9251 Object_Definition =>
9252 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9254 -- Allocate_Buffer (Strm);
9257 Make_Procedure_Call_Statement (Loc,
9259 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9260 Parameter_Associations => New_List (
9261 New_Occurrence_Of (Strm, Loc))));
9263 -- Any_To_BS (Strm, A);
9266 Make_Procedure_Call_Statement (Loc,
9268 New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
9269 Parameter_Associations => New_List (
9270 New_Occurrence_Of (Any_Parameter, Loc),
9271 New_Occurrence_Of (Strm, Loc))));
9274 -- Res : constant T := T'Input (Strm);
9276 -- Release_Buffer (Strm);
9280 Append_To (Stms, Make_Block_Statement (Loc,
9281 Declarations => New_List (
9282 Make_Object_Declaration (Loc,
9283 Defining_Identifier => Res,
9284 Constant_Present => True,
9285 Object_Definition =>
9286 New_Occurrence_Of (Typ, Loc),
9288 Make_Attribute_Reference (Loc,
9289 Prefix => New_Occurrence_Of (Typ, Loc),
9290 Attribute_Name => Name_Input,
9291 Expressions => New_List (
9292 Make_Attribute_Reference (Loc,
9293 Prefix => New_Occurrence_Of (Strm, Loc),
9294 Attribute_Name => Name_Access))))),
9296 Handled_Statement_Sequence =>
9297 Make_Handled_Sequence_Of_Statements (Loc,
9298 Statements => New_List (
9299 Make_Procedure_Call_Statement (Loc,
9301 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
9302 Parameter_Associations =>
9304 New_Occurrence_Of (Strm, Loc))),
9305 Make_Simple_Return_Statement (Loc,
9306 Expression => New_Occurrence_Of (Res, Loc))))));
9312 Make_Subprogram_Body (Loc,
9313 Specification => Spec,
9314 Declarations => Decls,
9315 Handled_Statement_Sequence =>
9316 Make_Handled_Sequence_Of_Statements (Loc,
9317 Statements => Stms));
9318 end Build_From_Any_Function;
9320 ---------------------------------
9321 -- Build_Get_Aggregate_Element --
9322 ---------------------------------
9324 function Build_Get_Aggregate_Element
9328 Idx : Node_Id) return Node_Id
9331 return Make_Function_Call (Loc,
9334 RTE (RE_Get_Aggregate_Element), Loc),
9335 Parameter_Associations => New_List (
9336 New_Occurrence_Of (Any, Loc),
9339 end Build_Get_Aggregate_Element;
9341 -------------------------
9342 -- Build_Reposiroty_Id --
9343 -------------------------
9345 procedure Build_Name_And_Repository_Id
9347 Name_Str : out String_Id;
9348 Repo_Id_Str : out String_Id)
9352 Store_String_Chars ("DSA:");
9353 Get_Library_Unit_Name_String (Scope (E));
9354 Store_String_Chars (
9355 Name_Buffer (Name_Buffer'First
9356 .. Name_Buffer'First + Name_Len - 1));
9357 Store_String_Char ('.');
9358 Get_Name_String (Chars (E));
9359 Store_String_Chars (
9360 Name_Buffer (Name_Buffer'First
9361 .. Name_Buffer'First + Name_Len - 1));
9362 Store_String_Chars (":1.0");
9363 Repo_Id_Str := End_String;
9364 Name_Str := String_From_Name_Buffer;
9365 end Build_Name_And_Repository_Id;
9367 -----------------------
9368 -- Build_To_Any_Call --
9369 -----------------------
9371 function Build_To_Any_Call
9373 Decls : List_Id) return Node_Id
9375 Loc : constant Source_Ptr := Sloc (N);
9377 Typ : Entity_Id := Etype (N);
9380 Fnam : Entity_Id := Empty;
9381 Lib_RE : RE_Id := RE_Null;
9384 -- If N is a selected component, then maybe its Etype has not been
9385 -- set yet: try to use the Etype of the selector_name in that
9388 if No (Typ) and then Nkind (N) = N_Selected_Component then
9389 Typ := Etype (Selector_Name (N));
9391 pragma Assert (Present (Typ));
9393 -- The full view, if Typ is private; the completion, if Typ is
9396 U_Type := Underlying_Type (Typ);
9398 -- First simple case where the To_Any function is present in the
9401 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9403 -- Check first for Boolean and Character. These are enumeration
9404 -- types, but we treat them specially, since they may require
9405 -- special handling in the transfer protocol. However, this
9406 -- special handling only applies if they have standard
9407 -- representation, otherwise they are treated like any other
9408 -- enumeration type.
9410 if Sloc (U_Type) <= Standard_Location then
9411 U_Type := Base_Type (U_Type);
9414 if Present (Fnam) then
9417 elsif U_Type = Standard_Boolean then
9420 elsif U_Type = Standard_Character then
9423 elsif U_Type = Standard_Wide_Character then
9426 elsif U_Type = Standard_Wide_Wide_Character then
9427 Lib_RE := RE_TA_WWC;
9429 -- Floating point types
9431 elsif U_Type = Standard_Short_Float then
9434 elsif U_Type = Standard_Float then
9437 elsif U_Type = Standard_Long_Float then
9440 elsif U_Type = Standard_Long_Long_Float then
9441 Lib_RE := RE_TA_LLF;
9445 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9446 Lib_RE := RE_TA_SSI;
9448 elsif U_Type = Etype (Standard_Short_Integer) then
9451 elsif U_Type = Etype (Standard_Integer) then
9454 elsif U_Type = Etype (Standard_Long_Integer) then
9457 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9458 Lib_RE := RE_TA_LLI;
9460 -- Unsigned integer types
9462 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9463 Lib_RE := RE_TA_SSU;
9465 elsif U_Type = RTE (RE_Short_Unsigned) then
9468 elsif U_Type = RTE (RE_Unsigned) then
9471 elsif U_Type = RTE (RE_Long_Unsigned) then
9474 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9475 Lib_RE := RE_TA_LLU;
9477 elsif U_Type = Standard_String then
9478 Lib_RE := RE_TA_String;
9480 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9483 -- Other (non-primitive) types
9489 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9490 Append_To (Decls, Decl);
9494 -- Call the function
9496 if Lib_RE /= RE_Null then
9497 pragma Assert (No (Fnam));
9498 Fnam := RTE (Lib_RE);
9502 Make_Function_Call (Loc,
9503 Name => New_Occurrence_Of (Fnam, Loc),
9504 Parameter_Associations =>
9505 New_List (Unchecked_Convert_To (U_Type, N)));
9506 end Build_To_Any_Call;
9508 ---------------------------
9509 -- Build_To_Any_Function --
9510 ---------------------------
9512 procedure Build_To_Any_Function
9516 Fnam : out Entity_Id)
9519 Decls : constant List_Id := New_List;
9520 Stms : constant List_Id := New_List;
9522 Expr_Parameter : constant Entity_Id :=
9523 Make_Defining_Identifier (Loc, Name_E);
9525 Any : constant Entity_Id :=
9526 Make_Defining_Identifier (Loc, Name_A);
9529 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9532 if Is_Itype (Typ) then
9533 Build_To_Any_Function
9541 Fnam := Make_Stream_Procedure_Function_Name (Loc,
9545 Make_Function_Specification (Loc,
9546 Defining_Unit_Name => Fnam,
9547 Parameter_Specifications => New_List (
9548 Make_Parameter_Specification (Loc,
9549 Defining_Identifier =>
9552 New_Occurrence_Of (Typ, Loc))),
9553 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9554 Set_Etype (Expr_Parameter, Typ);
9557 Make_Object_Declaration (Loc,
9558 Defining_Identifier =>
9560 Object_Definition =>
9561 New_Occurrence_Of (RTE (RE_Any), Loc));
9563 if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9565 Rt_Type : constant Entity_Id
9567 Expr : constant Node_Id
9570 New_Occurrence_Of (Expr_Parameter, Loc));
9572 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9575 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9576 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9578 Rt_Type : constant Entity_Id
9580 Expr : constant Node_Id
9583 New_Occurrence_Of (Expr_Parameter, Loc));
9586 Set_Expression (Any_Decl,
9587 Build_To_Any_Call (Expr, Decls));
9592 Disc : Entity_Id := Empty;
9593 Rdef : constant Node_Id :=
9594 Type_Definition (Declaration_Node (Typ));
9596 Elements : constant List_Id := New_List;
9598 procedure TA_Rec_Add_Process_Element
9600 Container : Node_Or_Entity_Id;
9601 Counter : in out Int;
9605 procedure TA_Append_Record_Traversal is
9606 new Append_Record_Traversal
9607 (Rec => Expr_Parameter,
9608 Add_Process_Element => TA_Rec_Add_Process_Element);
9610 --------------------------------
9611 -- TA_Rec_Add_Process_Element --
9612 --------------------------------
9614 procedure TA_Rec_Add_Process_Element
9616 Container : Node_Or_Entity_Id;
9617 Counter : in out Int;
9621 Field_Ref : Node_Id;
9624 if Nkind (Field) = N_Defining_Identifier then
9626 -- A regular component
9628 Field_Ref := Make_Selected_Component (Loc,
9629 Prefix => New_Occurrence_Of (Rec, Loc),
9630 Selector_Name => New_Occurrence_Of (Field, Loc));
9631 Set_Etype (Field_Ref, Etype (Field));
9634 Make_Procedure_Call_Statement (Loc,
9637 RTE (RE_Add_Aggregate_Element), Loc),
9638 Parameter_Associations => New_List (
9639 New_Occurrence_Of (Container, Loc),
9640 Build_To_Any_Call (Field_Ref, Decls))));
9647 Struct_Counter : Int := 0;
9649 Block_Decls : constant List_Id := New_List;
9650 Block_Stmts : constant List_Id := New_List;
9653 Alt_List : constant List_Id := New_List;
9654 Choice_List : List_Id;
9656 Union_Any : constant Entity_Id :=
9657 Make_Defining_Identifier (Loc,
9658 New_Internal_Name ('V'));
9660 Struct_Any : constant Entity_Id :=
9661 Make_Defining_Identifier (Loc,
9662 New_Internal_Name ('S'));
9664 function Make_Discriminant_Reference
9666 -- Build a selected component for the
9667 -- discriminant of this variant part.
9669 ---------------------------------
9670 -- Make_Discriminant_Reference --
9671 ---------------------------------
9673 function Make_Discriminant_Reference
9676 Nod : constant Node_Id :=
9677 Make_Selected_Component (Loc,
9680 Chars (Name (Field)));
9682 Set_Etype (Nod, Etype (Name (Field)));
9684 end Make_Discriminant_Reference;
9688 Make_Block_Statement (Loc,
9691 Handled_Statement_Sequence =>
9692 Make_Handled_Sequence_Of_Statements (Loc,
9693 Statements => Block_Stmts)));
9695 -- Declare the Variant Part aggregate
9697 -- Knowing the position of this VP in
9698 -- the variant record, we can fetch the
9699 -- VP typecode from Container.
9701 Append_To (Block_Decls,
9702 Make_Object_Declaration (Loc,
9703 Defining_Identifier => Union_Any,
9704 Object_Definition =>
9705 New_Occurrence_Of (RTE (RE_Any), Loc),
9707 Make_Function_Call (Loc,
9708 Name => New_Occurrence_Of (
9709 RTE (RE_Create_Any), Loc),
9710 Parameter_Associations => New_List (
9711 Make_Function_Call (Loc,
9714 RTE (RE_Any_Member_Type), Loc),
9715 Parameter_Associations => New_List (
9716 New_Occurrence_Of (Container, Loc),
9717 Make_Integer_Literal (Loc,
9720 -- Declare the inner struct aggregate
9721 -- (that will contain the components
9724 Append_To (Block_Decls,
9725 Make_Object_Declaration (Loc,
9726 Defining_Identifier => Struct_Any,
9727 Object_Definition =>
9728 New_Occurrence_Of (RTE (RE_Any), Loc),
9730 Make_Function_Call (Loc,
9731 Name => New_Occurrence_Of (
9732 RTE (RE_Create_Any), Loc),
9733 Parameter_Associations => New_List (
9734 Make_Function_Call (Loc,
9737 RTE (RE_Any_Member_Type), Loc),
9738 Parameter_Associations => New_List (
9739 New_Occurrence_Of (Union_Any, Loc),
9740 Make_Integer_Literal (Loc,
9743 -- Construct a case statement that will choose
9744 -- the appropriate code at runtime depending on
9745 -- the discriminant.
9747 Append_To (Block_Stmts,
9748 Make_Case_Statement (Loc,
9750 Make_Discriminant_Reference,
9754 Variant := First_Non_Pragma (Variants (Field));
9755 while Present (Variant) loop
9756 Choice_List := New_Copy_List_Tree
9757 (Discrete_Choices (Variant));
9759 VP_Stmts := New_List;
9761 -- Append discriminant value to union
9764 Append_To (VP_Stmts,
9765 Make_Procedure_Call_Statement (Loc,
9768 RTE (RE_Add_Aggregate_Element), Loc),
9769 Parameter_Associations => New_List (
9770 New_Occurrence_Of (Union_Any, Loc),
9772 Make_Discriminant_Reference,
9775 -- Populate inner struct aggregate
9777 -- Struct_Counter should be reset before
9778 -- handling a variant part. Indeed only one
9779 -- of the case statement alternatives will be
9780 -- executed at run-time, so the counter must
9781 -- start at 0 for every case statement.
9783 Struct_Counter := 0;
9785 TA_Append_Record_Traversal (
9787 Clist => Component_List (Variant),
9788 Container => Struct_Any,
9789 Counter => Struct_Counter);
9791 -- Append inner struct to union aggregate
9793 Append_To (VP_Stmts,
9794 Make_Procedure_Call_Statement (Loc,
9797 RTE (RE_Add_Aggregate_Element), Loc),
9798 Parameter_Associations => New_List (
9799 New_Occurrence_Of (Union_Any, Loc),
9800 New_Occurrence_Of (Struct_Any, Loc))));
9802 -- Append union to outer aggregate
9804 Append_To (VP_Stmts,
9805 Make_Procedure_Call_Statement (Loc,
9808 RTE (RE_Add_Aggregate_Element), Loc),
9809 Parameter_Associations => New_List (
9810 New_Occurrence_Of (Container, Loc),
9812 (Union_Any, Loc))));
9814 Append_To (Alt_List,
9815 Make_Case_Statement_Alternative (Loc,
9816 Discrete_Choices => Choice_List,
9817 Statements => VP_Stmts));
9819 Next_Non_Pragma (Variant);
9823 Counter := Counter + 1;
9824 end TA_Rec_Add_Process_Element;
9827 -- Records are encoded in a TC_STRUCT aggregate:
9828 -- -- Outer aggregate (TC_STRUCT)
9829 -- | [discriminant1]
9830 -- | [discriminant2]
9837 -- A component can be a common component or a variant
9840 -- A variant part is encoded as a TC_UNION aggregate:
9841 -- -- Variant Part Aggregate (TC_UNION)
9842 -- | [discriminant choice for this Variant Part]
9844 -- | -- Inner struct (TC_STRUCT)
9849 -- Let's start by building the outer aggregate
9850 -- First we construct an Elements array containing all
9851 -- the discriminants.
9853 if Has_Discriminants (Typ) then
9854 Disc := First_Discriminant (Typ);
9856 while Present (Disc) loop
9859 Discriminant : constant Entity_Id :=
9860 Make_Selected_Component (Loc,
9861 Prefix => Expr_Parameter,
9862 Selector_Name => Chars (Disc));
9864 Set_Etype (Discriminant, Etype (Disc));
9866 Append_To (Elements,
9867 Make_Component_Association (Loc,
9868 Choices => New_List (
9869 Make_Integer_Literal (Loc, Counter)),
9871 Build_To_Any_Call (Discriminant, Decls)));
9873 Counter := Counter + 1;
9874 Next_Discriminant (Disc);
9878 -- If there are no discriminants, we declare an empty
9882 Dummy_Any : constant Entity_Id :=
9883 Make_Defining_Identifier (Loc,
9884 Chars => New_Internal_Name ('A'));
9888 Make_Object_Declaration (Loc,
9889 Defining_Identifier => Dummy_Any,
9890 Object_Definition =>
9891 New_Occurrence_Of (RTE (RE_Any), Loc)));
9893 Append_To (Elements,
9894 Make_Component_Association (Loc,
9895 Choices => New_List (
9898 Make_Integer_Literal (Loc, 1),
9900 Make_Integer_Literal (Loc, 0))),
9902 New_Occurrence_Of (Dummy_Any, Loc)));
9906 -- We build the result aggregate with discriminants
9907 -- as the first elements.
9909 Set_Expression (Any_Decl,
9910 Make_Function_Call (Loc,
9911 Name => New_Occurrence_Of (
9912 RTE (RE_Any_Aggregate_Build), Loc),
9913 Parameter_Associations => New_List (
9915 Make_Aggregate (Loc,
9916 Component_Associations => Elements))));
9919 -- Then we append all the components to the result
9922 TA_Append_Record_Traversal (Stms,
9923 Clist => Component_List (Rdef),
9925 Counter => Counter);
9929 elsif Is_Array_Type (Typ) then
9931 Constrained : constant Boolean := Is_Constrained (Typ);
9933 procedure TA_Ary_Add_Process_Element
9936 Counter : Entity_Id;
9939 --------------------------------
9940 -- TA_Ary_Add_Process_Element --
9941 --------------------------------
9943 procedure TA_Ary_Add_Process_Element
9946 Counter : Entity_Id;
9949 pragma Warnings (Off);
9950 pragma Unreferenced (Counter);
9951 pragma Warnings (On);
9953 Element_Any : Node_Id;
9956 if Etype (Datum) = RTE (RE_Any) then
9957 Element_Any := Datum;
9959 Element_Any := Build_To_Any_Call (Datum, Decls);
9963 Make_Procedure_Call_Statement (Loc,
9964 Name => New_Occurrence_Of (
9965 RTE (RE_Add_Aggregate_Element), Loc),
9966 Parameter_Associations => New_List (
9967 New_Occurrence_Of (Any, Loc),
9969 end TA_Ary_Add_Process_Element;
9971 procedure Append_To_Any_Array_Iterator is
9972 new Append_Array_Traversal (
9974 Arry => Expr_Parameter,
9975 Indices => New_List,
9976 Add_Process_Element => TA_Ary_Add_Process_Element);
9981 Set_Expression (Any_Decl,
9982 Make_Function_Call (Loc,
9984 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9985 Parameter_Associations => New_List (Result_TC)));
9988 if not Constrained then
9989 Index := First_Index (Typ);
9990 for J in 1 .. Number_Dimensions (Typ) loop
9992 Make_Procedure_Call_Statement (Loc,
9995 RTE (RE_Add_Aggregate_Element), Loc),
9996 Parameter_Associations => New_List (
9997 New_Occurrence_Of (Any, Loc),
9999 OK_Convert_To (Etype (Index),
10000 Make_Attribute_Reference (Loc,
10002 New_Occurrence_Of (Expr_Parameter, Loc),
10003 Attribute_Name => Name_First,
10004 Expressions => New_List (
10005 Make_Integer_Literal (Loc, J)))),
10007 Next_Index (Index);
10011 Append_To_Any_Array_Iterator (Stms, Any);
10014 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10015 Set_Expression (Any_Decl,
10016 Build_To_Any_Call (
10018 Find_Numeric_Representation (Typ),
10019 New_Occurrence_Of (Expr_Parameter, Loc)),
10023 -- Default: type is represented as an opaque sequence of bytes
10026 Strm : constant Entity_Id := Make_Defining_Identifier (Loc,
10027 New_Internal_Name ('S'));
10030 -- Strm : aliased Buffer_Stream_Type;
10033 Make_Object_Declaration (Loc,
10034 Defining_Identifier =>
10038 Object_Definition =>
10039 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
10041 -- Allocate_Buffer (Strm);
10044 Make_Procedure_Call_Statement (Loc,
10046 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
10047 Parameter_Associations => New_List (
10048 New_Occurrence_Of (Strm, Loc))));
10050 -- T'Output (Strm'Access, E);
10053 Make_Attribute_Reference (Loc,
10054 Prefix => New_Occurrence_Of (Typ, Loc),
10055 Attribute_Name => Name_Output,
10056 Expressions => New_List (
10057 Make_Attribute_Reference (Loc,
10058 Prefix => New_Occurrence_Of (Strm, Loc),
10059 Attribute_Name => Name_Access),
10060 New_Occurrence_Of (Expr_Parameter, Loc))));
10062 -- BS_To_Any (Strm, A);
10065 Make_Procedure_Call_Statement (Loc,
10067 New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
10068 Parameter_Associations => New_List (
10069 New_Occurrence_Of (Strm, Loc),
10070 New_Occurrence_Of (Any, Loc))));
10072 -- Release_Buffer (Strm);
10075 Make_Procedure_Call_Statement (Loc,
10077 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
10078 Parameter_Associations => New_List (
10079 New_Occurrence_Of (Strm, Loc))));
10083 Append_To (Decls, Any_Decl);
10085 if Present (Result_TC) then
10087 Make_Procedure_Call_Statement (Loc,
10088 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
10089 Parameter_Associations => New_List (
10090 New_Occurrence_Of (Any, Loc),
10095 Make_Simple_Return_Statement (Loc,
10096 Expression => New_Occurrence_Of (Any, Loc)));
10099 Make_Subprogram_Body (Loc,
10100 Specification => Spec,
10101 Declarations => Decls,
10102 Handled_Statement_Sequence =>
10103 Make_Handled_Sequence_Of_Statements (Loc,
10104 Statements => Stms));
10105 end Build_To_Any_Function;
10107 -------------------------
10108 -- Build_TypeCode_Call --
10109 -------------------------
10111 function Build_TypeCode_Call
10114 Decls : List_Id) return Node_Id
10116 U_Type : Entity_Id := Underlying_Type (Typ);
10117 -- The full view, if Typ is private; the completion,
10118 -- if Typ is incomplete.
10120 Fnam : Entity_Id := Empty;
10121 Lib_RE : RE_Id := RE_Null;
10126 -- Special case System.PolyORB.Interface.Any: its primitives have
10127 -- not been set yet, so can't call Find_Inherited_TSS.
10129 if Typ = RTE (RE_Any) then
10130 Fnam := RTE (RE_TC_Any);
10133 -- First simple case where the TypeCode is present
10134 -- in the type's TSS.
10136 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10140 if Sloc (U_Type) <= Standard_Location then
10142 -- Do not try to build alias typecodes for subtypes from
10145 U_Type := Base_Type (U_Type);
10148 if U_Type = Standard_Boolean then
10151 elsif U_Type = Standard_Character then
10154 elsif U_Type = Standard_Wide_Character then
10155 Lib_RE := RE_TC_WC;
10157 elsif U_Type = Standard_Wide_Wide_Character then
10158 Lib_RE := RE_TC_WWC;
10160 -- Floating point types
10162 elsif U_Type = Standard_Short_Float then
10163 Lib_RE := RE_TC_SF;
10165 elsif U_Type = Standard_Float then
10168 elsif U_Type = Standard_Long_Float then
10169 Lib_RE := RE_TC_LF;
10171 elsif U_Type = Standard_Long_Long_Float then
10172 Lib_RE := RE_TC_LLF;
10174 -- Integer types (walk back to the base type)
10176 elsif U_Type = Etype (Standard_Short_Short_Integer) then
10177 Lib_RE := RE_TC_SSI;
10179 elsif U_Type = Etype (Standard_Short_Integer) then
10180 Lib_RE := RE_TC_SI;
10182 elsif U_Type = Etype (Standard_Integer) then
10185 elsif U_Type = Etype (Standard_Long_Integer) then
10186 Lib_RE := RE_TC_LI;
10188 elsif U_Type = Etype (Standard_Long_Long_Integer) then
10189 Lib_RE := RE_TC_LLI;
10191 -- Unsigned integer types
10193 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
10194 Lib_RE := RE_TC_SSU;
10196 elsif U_Type = RTE (RE_Short_Unsigned) then
10197 Lib_RE := RE_TC_SU;
10199 elsif U_Type = RTE (RE_Unsigned) then
10202 elsif U_Type = RTE (RE_Long_Unsigned) then
10203 Lib_RE := RE_TC_LU;
10205 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
10206 Lib_RE := RE_TC_LLU;
10208 elsif U_Type = Standard_String then
10209 Lib_RE := RE_TC_String;
10211 -- Other (non-primitive) types
10217 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10218 Append_To (Decls, Decl);
10222 if Lib_RE /= RE_Null then
10223 Fnam := RTE (Lib_RE);
10227 -- Call the function
10230 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10232 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10234 Set_Etype (Expr, RTE (RE_TypeCode));
10237 end Build_TypeCode_Call;
10239 -----------------------------
10240 -- Build_TypeCode_Function --
10241 -----------------------------
10243 procedure Build_TypeCode_Function
10246 Decl : out Node_Id;
10247 Fnam : out Entity_Id)
10250 Decls : constant List_Id := New_List;
10251 Stms : constant List_Id := New_List;
10253 TCNam : constant Entity_Id :=
10254 Make_Stream_Procedure_Function_Name (Loc,
10255 Typ, Name_uTypeCode);
10257 Parameters : List_Id;
10259 procedure Add_String_Parameter
10261 Parameter_List : List_Id);
10262 -- Add a literal for S to Parameters
10264 procedure Add_TypeCode_Parameter
10265 (TC_Node : Node_Id;
10266 Parameter_List : List_Id);
10267 -- Add the typecode for Typ to Parameters
10269 procedure Add_Long_Parameter
10270 (Expr_Node : Node_Id;
10271 Parameter_List : List_Id);
10272 -- Add a signed long integer expression to Parameters
10274 procedure Initialize_Parameter_List
10275 (Name_String : String_Id;
10276 Repo_Id_String : String_Id;
10277 Parameter_List : out List_Id);
10278 -- Return a list that contains the first two parameters
10279 -- for a parameterized typecode: name and repository id.
10281 function Make_Constructed_TypeCode
10283 Parameters : List_Id) return Node_Id;
10284 -- Call TC_Build with the given kind and parameters
10286 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10287 -- Make a return statement that calls TC_Build with the given
10288 -- typecode kind, and the constructed parameters list.
10290 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10291 -- Return a typecode that is a TC_Alias for the given typecode
10293 --------------------------
10294 -- Add_String_Parameter --
10295 --------------------------
10297 procedure Add_String_Parameter
10299 Parameter_List : List_Id)
10302 Append_To (Parameter_List,
10303 Make_Function_Call (Loc,
10305 New_Occurrence_Of (RTE (RE_TA_String), Loc),
10306 Parameter_Associations => New_List (
10307 Make_String_Literal (Loc, S))));
10308 end Add_String_Parameter;
10310 ----------------------------
10311 -- Add_TypeCode_Parameter --
10312 ----------------------------
10314 procedure Add_TypeCode_Parameter
10315 (TC_Node : Node_Id;
10316 Parameter_List : List_Id)
10319 Append_To (Parameter_List,
10320 Make_Function_Call (Loc,
10322 New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10323 Parameter_Associations => New_List (
10325 end Add_TypeCode_Parameter;
10327 ------------------------
10328 -- Add_Long_Parameter --
10329 ------------------------
10331 procedure Add_Long_Parameter
10332 (Expr_Node : Node_Id;
10333 Parameter_List : List_Id)
10336 Append_To (Parameter_List,
10337 Make_Function_Call (Loc,
10339 New_Occurrence_Of (RTE (RE_TA_LI), Loc),
10340 Parameter_Associations => New_List (Expr_Node)));
10341 end Add_Long_Parameter;
10343 -------------------------------
10344 -- Initialize_Parameter_List --
10345 -------------------------------
10347 procedure Initialize_Parameter_List
10348 (Name_String : String_Id;
10349 Repo_Id_String : String_Id;
10350 Parameter_List : out List_Id)
10353 Parameter_List := New_List;
10354 Add_String_Parameter (Name_String, Parameter_List);
10355 Add_String_Parameter (Repo_Id_String, Parameter_List);
10356 end Initialize_Parameter_List;
10358 ---------------------------
10359 -- Return_Alias_TypeCode --
10360 ---------------------------
10362 procedure Return_Alias_TypeCode
10363 (Base_TypeCode : Node_Id)
10366 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10367 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
10368 end Return_Alias_TypeCode;
10370 -------------------------------
10371 -- Make_Constructed_TypeCode --
10372 -------------------------------
10374 function Make_Constructed_TypeCode
10376 Parameters : List_Id) return Node_Id
10378 Constructed_TC : constant Node_Id :=
10379 Make_Function_Call (Loc,
10381 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
10382 Parameter_Associations => New_List (
10383 New_Occurrence_Of (Kind, Loc),
10384 Make_Aggregate (Loc,
10385 Expressions => Parameters)));
10387 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10388 return Constructed_TC;
10389 end Make_Constructed_TypeCode;
10391 ---------------------------------
10392 -- Return_Constructed_TypeCode --
10393 ---------------------------------
10395 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10398 Make_Simple_Return_Statement (Loc,
10400 Make_Constructed_TypeCode (Kind, Parameters)));
10401 end Return_Constructed_TypeCode;
10407 procedure TC_Rec_Add_Process_Element
10410 Counter : in out Int;
10414 procedure TC_Append_Record_Traversal is
10415 new Append_Record_Traversal (
10417 Add_Process_Element => TC_Rec_Add_Process_Element);
10419 --------------------------------
10420 -- TC_Rec_Add_Process_Element --
10421 --------------------------------
10423 procedure TC_Rec_Add_Process_Element
10426 Counter : in out Int;
10430 pragma Warnings (Off);
10431 pragma Unreferenced (Any, Counter, Rec);
10432 pragma Warnings (On);
10435 if Nkind (Field) = N_Defining_Identifier then
10437 -- A regular component
10439 Add_TypeCode_Parameter (
10440 Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10441 Get_Name_String (Chars (Field));
10442 Add_String_Parameter (String_From_Name_Buffer, Params);
10449 Discriminant_Type : constant Entity_Id :=
10450 Etype (Name (Field));
10452 Is_Enum : constant Boolean :=
10453 Is_Enumeration_Type (Discriminant_Type);
10455 Union_TC_Params : List_Id;
10457 U_Name : constant Name_Id :=
10458 New_External_Name (Chars (Typ), 'V', -1);
10460 Name_Str : String_Id;
10461 Struct_TC_Params : List_Id;
10465 Default : constant Node_Id :=
10466 Make_Integer_Literal (Loc, -1);
10468 Dummy_Counter : Int := 0;
10470 Choice_Index : Int := 0;
10472 procedure Add_Params_For_Variant_Components;
10473 -- Add a struct TypeCode and a corresponding member name
10474 -- to the union parameter list.
10476 -- Ordering of declarations is a complete mess in this
10477 -- area, it is supposed to be types/varibles, then
10478 -- subprogram specs, then subprogram bodies ???
10480 ---------------------------------------
10481 -- Add_Params_For_Variant_Components --
10482 ---------------------------------------
10484 procedure Add_Params_For_Variant_Components
10486 S_Name : constant Name_Id :=
10487 New_External_Name (U_Name, 'S', -1);
10490 Get_Name_String (S_Name);
10491 Name_Str := String_From_Name_Buffer;
10492 Initialize_Parameter_List
10493 (Name_Str, Name_Str, Struct_TC_Params);
10495 -- Build struct parameters
10497 TC_Append_Record_Traversal (Struct_TC_Params,
10498 Component_List (Variant),
10502 Add_TypeCode_Parameter
10503 (Make_Constructed_TypeCode
10504 (RTE (RE_TC_Struct), Struct_TC_Params),
10507 Add_String_Parameter (Name_Str, Union_TC_Params);
10508 end Add_Params_For_Variant_Components;
10511 Get_Name_String (U_Name);
10512 Name_Str := String_From_Name_Buffer;
10514 Initialize_Parameter_List
10515 (Name_Str, Name_Str, Union_TC_Params);
10517 -- Add union in enclosing parameter list
10519 Add_TypeCode_Parameter
10520 (Make_Constructed_TypeCode
10521 (RTE (RE_TC_Union), Union_TC_Params),
10524 Add_String_Parameter (Name_Str, Params);
10526 -- Build union parameters
10528 Add_TypeCode_Parameter
10529 (Build_TypeCode_Call
10530 (Loc, Discriminant_Type, Decls),
10533 Add_Long_Parameter (Default, Union_TC_Params);
10535 Variant := First_Non_Pragma (Variants (Field));
10536 while Present (Variant) loop
10537 Choice := First (Discrete_Choices (Variant));
10538 while Present (Choice) loop
10539 case Nkind (Choice) is
10542 L : constant Uint :=
10543 Expr_Value (Low_Bound (Choice));
10544 H : constant Uint :=
10545 Expr_Value (High_Bound (Choice));
10547 -- 3.8.1(8) guarantees that the bounds of
10548 -- this range are static.
10555 Expr := New_Occurrence_Of (
10556 Get_Enum_Lit_From_Pos (
10557 Discriminant_Type, J, Loc), Loc);
10560 Make_Integer_Literal (Loc, J);
10562 Append_To (Union_TC_Params,
10563 Build_To_Any_Call (Expr, Decls));
10565 Add_Params_For_Variant_Components;
10570 when N_Others_Choice =>
10572 -- This variant possess a default choice.
10573 -- We must therefore set the default
10574 -- parameter to the current choice index. The
10575 -- default parameter is by construction the
10576 -- fourth in the Union_TC_Params list.
10579 Default_Node : constant Node_Id :=
10580 Pick (Union_TC_Params, 4);
10582 New_Default_Node : constant Node_Id :=
10583 Make_Function_Call (Loc,
10586 (RTE (RE_TA_LI), Loc),
10587 Parameter_Associations =>
10589 Make_Integer_Literal
10590 (Loc, Choice_Index)));
10596 Remove (Default_Node);
10599 -- Add a placeholder member label
10600 -- for the default case.
10601 -- It must be of the discriminant type.
10604 Exp : constant Node_Id :=
10605 Make_Attribute_Reference (Loc,
10606 Prefix => New_Occurrence_Of
10607 (Discriminant_Type, Loc),
10608 Attribute_Name => Name_First);
10610 Set_Etype (Exp, Discriminant_Type);
10611 Append_To (Union_TC_Params,
10612 Build_To_Any_Call (Exp, Decls));
10615 Add_Params_For_Variant_Components;
10619 -- Case of an explicit choice
10622 Exp : constant Node_Id :=
10623 New_Copy_Tree (Choice);
10625 Append_To (Union_TC_Params,
10626 Build_To_Any_Call (Exp, Decls));
10629 Add_Params_For_Variant_Components;
10632 Choice_Index := Choice_Index + 1;
10636 Next_Non_Pragma (Variant);
10641 end TC_Rec_Add_Process_Element;
10643 Type_Name_Str : String_Id;
10644 Type_Repo_Id_Str : String_Id;
10647 if Is_Itype (Typ) then
10648 Build_TypeCode_Function
10650 Typ => Etype (Typ),
10659 Make_Function_Specification (Loc,
10660 Defining_Unit_Name => Fnam,
10661 Parameter_Specifications => Empty_List,
10662 Result_Definition =>
10663 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10665 Build_Name_And_Repository_Id (Typ,
10666 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10667 Initialize_Parameter_List
10668 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10670 if Is_Derived_Type (Typ)
10671 and then not Is_Tagged_Type (Typ)
10673 Return_Alias_TypeCode (
10674 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10676 elsif Is_Integer_Type (Typ)
10677 or else Is_Unsigned_Type (Typ)
10679 Return_Alias_TypeCode (
10680 Build_TypeCode_Call (Loc,
10681 Find_Numeric_Representation (Typ), Decls));
10683 elsif Is_Record_Type (Typ)
10684 and then not Is_Tagged_Type (Typ)
10687 -- Record typecodes are encoded as follows:
10691 -- | [Repository Id]
10693 -- Then for each discriminant:
10695 -- | [Discriminant Type Code]
10696 -- | [Discriminant Name]
10699 -- Then for each component:
10701 -- | [Component Type Code]
10702 -- | [Component Name]
10705 -- Variants components type codes are encoded as follows:
10709 -- | [Repository Id]
10710 -- | [Discriminant Type Code]
10711 -- | [Index of Default Variant Part or -1 for no default]
10713 -- Then for each Variant Part :
10718 -- | | [Variant Part Name]
10719 -- | | [Variant Part Repository Id]
10721 -- | Then for each VP component:
10722 -- | | [VP component Typecode]
10723 -- | | [VP component Name]
10729 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10730 Return_Alias_TypeCode (
10731 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10734 Disc : Entity_Id := Empty;
10735 Rdef : constant Node_Id :=
10736 Type_Definition (Declaration_Node (Typ));
10737 Dummy_Counter : Int := 0;
10739 -- Construct the discriminants typecodes
10741 if Has_Discriminants (Typ) then
10742 Disc := First_Discriminant (Typ);
10744 while Present (Disc) loop
10745 Add_TypeCode_Parameter (
10746 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10748 Get_Name_String (Chars (Disc));
10749 Add_String_Parameter (
10750 String_From_Name_Buffer,
10752 Next_Discriminant (Disc);
10755 -- then the components typecodes
10757 TC_Append_Record_Traversal
10758 (Parameters, Component_List (Rdef),
10759 Empty, Dummy_Counter);
10760 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10764 elsif Is_Array_Type (Typ) then
10766 Ndim : constant Pos := Number_Dimensions (Typ);
10767 Inner_TypeCode : Node_Id;
10768 Constrained : constant Boolean := Is_Constrained (Typ);
10769 Indx : Node_Id := First_Index (Typ);
10772 Inner_TypeCode := Build_TypeCode_Call (Loc,
10773 Component_Type (Typ),
10776 for J in 1 .. Ndim loop
10777 if Constrained then
10778 Inner_TypeCode := Make_Constructed_TypeCode
10779 (RTE (RE_TC_Array), New_List (
10780 Build_To_Any_Call (
10781 OK_Convert_To (RTE (RE_Long_Unsigned),
10782 Make_Attribute_Reference (Loc,
10784 New_Occurrence_Of (Typ, Loc),
10787 Expressions => New_List (
10788 Make_Integer_Literal (Loc,
10791 Build_To_Any_Call (Inner_TypeCode, Decls)));
10794 -- Unconstrained case: add low bound for each
10797 Add_TypeCode_Parameter
10798 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10800 Get_Name_String (New_External_Name ('L', J));
10801 Add_String_Parameter (
10802 String_From_Name_Buffer,
10806 Inner_TypeCode := Make_Constructed_TypeCode
10807 (RTE (RE_TC_Sequence), New_List (
10808 Build_To_Any_Call (
10809 OK_Convert_To (RTE (RE_Long_Unsigned),
10810 Make_Integer_Literal (Loc, 0)),
10812 Build_To_Any_Call (Inner_TypeCode, Decls)));
10816 if Constrained then
10817 Return_Alias_TypeCode (Inner_TypeCode);
10819 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10821 Store_String_Char ('V');
10822 Add_String_Parameter (End_String, Parameters);
10823 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10828 -- Default: type is represented as an opaque sequence of bytes
10830 Return_Alias_TypeCode
10831 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10835 Make_Subprogram_Body (Loc,
10836 Specification => Spec,
10837 Declarations => Decls,
10838 Handled_Statement_Sequence =>
10839 Make_Handled_Sequence_Of_Statements (Loc,
10840 Statements => Stms));
10841 end Build_TypeCode_Function;
10843 ---------------------------------
10844 -- Find_Numeric_Representation --
10845 ---------------------------------
10847 function Find_Numeric_Representation
10848 (Typ : Entity_Id) return Entity_Id
10850 FST : constant Entity_Id := First_Subtype (Typ);
10851 P_Size : constant Uint := Esize (FST);
10854 if Is_Unsigned_Type (Typ) then
10855 if P_Size <= Standard_Short_Short_Integer_Size then
10856 return RTE (RE_Short_Short_Unsigned);
10858 elsif P_Size <= Standard_Short_Integer_Size then
10859 return RTE (RE_Short_Unsigned);
10861 elsif P_Size <= Standard_Integer_Size then
10862 return RTE (RE_Unsigned);
10864 elsif P_Size <= Standard_Long_Integer_Size then
10865 return RTE (RE_Long_Unsigned);
10868 return RTE (RE_Long_Long_Unsigned);
10871 elsif Is_Integer_Type (Typ) then
10872 if P_Size <= Standard_Short_Short_Integer_Size then
10873 return Standard_Short_Short_Integer;
10875 elsif P_Size <= Standard_Short_Integer_Size then
10876 return Standard_Short_Integer;
10878 elsif P_Size <= Standard_Integer_Size then
10879 return Standard_Integer;
10881 elsif P_Size <= Standard_Long_Integer_Size then
10882 return Standard_Long_Integer;
10885 return Standard_Long_Long_Integer;
10888 elsif Is_Floating_Point_Type (Typ) then
10889 if P_Size <= Standard_Short_Float_Size then
10890 return Standard_Short_Float;
10892 elsif P_Size <= Standard_Float_Size then
10893 return Standard_Float;
10895 elsif P_Size <= Standard_Long_Float_Size then
10896 return Standard_Long_Float;
10899 return Standard_Long_Long_Float;
10903 raise Program_Error;
10906 -- TBD: fixed point types???
10907 -- TBverified numeric types with a biased representation???
10909 end Find_Numeric_Representation;
10911 ---------------------------
10912 -- Append_Array_Traversal --
10913 ---------------------------
10915 procedure Append_Array_Traversal
10918 Counter : Entity_Id := Empty;
10921 Loc : constant Source_Ptr := Sloc (Subprogram);
10922 Typ : constant Entity_Id := Etype (Arry);
10923 Constrained : constant Boolean := Is_Constrained (Typ);
10924 Ndim : constant Pos := Number_Dimensions (Typ);
10926 Inner_Any, Inner_Counter : Entity_Id;
10928 Loop_Stm : Node_Id;
10929 Inner_Stmts : constant List_Id := New_List;
10932 if Depth > Ndim then
10934 -- Processing for one element of an array
10937 Element_Expr : constant Node_Id :=
10938 Make_Indexed_Component (Loc,
10939 New_Occurrence_Of (Arry, Loc),
10943 Set_Etype (Element_Expr, Component_Type (Typ));
10944 Add_Process_Element (Stmts,
10946 Counter => Counter,
10947 Datum => Element_Expr);
10953 Append_To (Indices,
10954 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10956 if not Constrained or else Depth > 1 then
10957 Inner_Any := Make_Defining_Identifier (Loc,
10958 New_External_Name ('A', Depth));
10959 Set_Etype (Inner_Any, RTE (RE_Any));
10961 Inner_Any := Empty;
10964 if Present (Counter) then
10965 Inner_Counter := Make_Defining_Identifier (Loc,
10966 New_External_Name ('J', Depth));
10968 Inner_Counter := Empty;
10972 Loop_Any : Node_Id := Inner_Any;
10975 -- For the first dimension of a constrained array, we add
10976 -- elements directly in the corresponding Any; there is no
10977 -- intervening inner Any.
10979 if No (Loop_Any) then
10983 Append_Array_Traversal (Inner_Stmts,
10985 Counter => Inner_Counter,
10986 Depth => Depth + 1);
10990 Make_Implicit_Loop_Statement (Subprogram,
10991 Iteration_Scheme =>
10992 Make_Iteration_Scheme (Loc,
10993 Loop_Parameter_Specification =>
10994 Make_Loop_Parameter_Specification (Loc,
10995 Defining_Identifier =>
10996 Make_Defining_Identifier (Loc,
10997 Chars => New_External_Name ('L', Depth)),
10999 Discrete_Subtype_Definition =>
11000 Make_Attribute_Reference (Loc,
11001 Prefix => New_Occurrence_Of (Arry, Loc),
11002 Attribute_Name => Name_Range,
11004 Expressions => New_List (
11005 Make_Integer_Literal (Loc, Depth))))),
11006 Statements => Inner_Stmts);
11009 Decls : constant List_Id := New_List;
11010 Dimen_Stmts : constant List_Id := New_List;
11011 Length_Node : Node_Id;
11013 Inner_Any_TypeCode : constant Entity_Id :=
11014 Make_Defining_Identifier (Loc,
11015 New_External_Name ('T', Depth));
11017 Inner_Any_TypeCode_Expr : Node_Id;
11021 if Constrained then
11022 Inner_Any_TypeCode_Expr :=
11023 Make_Function_Call (Loc,
11025 New_Occurrence_Of (RTE (RE_Get_TC), Loc),
11026 Parameter_Associations => New_List (
11027 New_Occurrence_Of (Any, Loc)));
11029 Inner_Any_TypeCode_Expr :=
11030 Make_Function_Call (Loc,
11032 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
11033 Parameter_Associations => New_List (
11034 New_Occurrence_Of (Any, Loc),
11035 Make_Integer_Literal (Loc, Ndim)));
11038 Inner_Any_TypeCode_Expr :=
11039 Make_Function_Call (Loc,
11041 New_Occurrence_Of (RTE (RE_Content_Type), Loc),
11042 Parameter_Associations => New_List (
11043 Make_Identifier (Loc,
11044 New_External_Name ('T', Depth - 1))));
11048 Make_Object_Declaration (Loc,
11049 Defining_Identifier => Inner_Any_TypeCode,
11050 Constant_Present => True,
11051 Object_Definition => New_Occurrence_Of (
11052 RTE (RE_TypeCode), Loc),
11053 Expression => Inner_Any_TypeCode_Expr));
11055 if Present (Inner_Any) then
11057 Make_Object_Declaration (Loc,
11058 Defining_Identifier => Inner_Any,
11059 Object_Definition =>
11060 New_Occurrence_Of (RTE (RE_Any), Loc),
11062 Make_Function_Call (Loc,
11064 New_Occurrence_Of (
11065 RTE (RE_Create_Any), Loc),
11066 Parameter_Associations => New_List (
11067 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
11070 if Present (Inner_Counter) then
11072 Make_Object_Declaration (Loc,
11073 Defining_Identifier => Inner_Counter,
11074 Object_Definition =>
11075 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
11077 Make_Integer_Literal (Loc, 0)));
11080 if not Constrained then
11081 Length_Node := Make_Attribute_Reference (Loc,
11082 Prefix => New_Occurrence_Of (Arry, Loc),
11083 Attribute_Name => Name_Length,
11085 New_List (Make_Integer_Literal (Loc, Depth)));
11086 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
11088 Add_Process_Element (Dimen_Stmts,
11089 Datum => Length_Node,
11091 Counter => Inner_Counter);
11094 -- Loop_Stm does appropriate processing for each element
11097 Append_To (Dimen_Stmts, Loop_Stm);
11099 -- Link outer and inner any
11101 if Present (Inner_Any) then
11102 Add_Process_Element (Dimen_Stmts,
11104 Counter => Counter,
11105 Datum => New_Occurrence_Of (Inner_Any, Loc));
11109 Make_Block_Statement (Loc,
11112 Handled_Statement_Sequence =>
11113 Make_Handled_Sequence_Of_Statements (Loc,
11114 Statements => Dimen_Stmts)));
11116 end Append_Array_Traversal;
11118 -----------------------------------------
11119 -- Make_Stream_Procedure_Function_Name --
11120 -----------------------------------------
11122 function Make_Stream_Procedure_Function_Name
11125 Nam : Name_Id) return Entity_Id
11128 -- For tagged types, we use a canonical name so that it matches
11129 -- the primitive spec. For all other cases, we use a serialized
11130 -- name so that multiple generations of the same procedure do not
11133 if Is_Tagged_Type (Typ) then
11134 return Make_Defining_Identifier (Loc, Nam);
11136 return Make_Defining_Identifier (Loc,
11138 New_External_Name (Nam, ' ', Increment_Serial_Number));
11140 end Make_Stream_Procedure_Function_Name;
11143 -----------------------------------
11144 -- Reserve_NamingContext_Methods --
11145 -----------------------------------
11147 procedure Reserve_NamingContext_Methods is
11148 Str_Resolve : constant String := "resolve";
11150 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11151 Name_Len := Str_Resolve'Length;
11152 Overload_Counter_Table.Set (Name_Find, 1);
11153 end Reserve_NamingContext_Methods;
11155 end PolyORB_Support;
11157 -------------------------------
11158 -- RACW_Type_Is_Asynchronous --
11159 -------------------------------
11161 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11162 Asynchronous_Flag : constant Entity_Id :=
11163 Asynchronous_Flags_Table.Get (RACW_Type);
11165 Replace (Expression (Parent (Asynchronous_Flag)),
11166 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11167 end RACW_Type_Is_Asynchronous;
11169 -------------------------
11170 -- RCI_Package_Locator --
11171 -------------------------
11173 function RCI_Package_Locator
11175 Package_Spec : Node_Id) return Node_Id
11178 Pkg_Name : String_Id;
11181 Get_Library_Unit_Name_String (Package_Spec);
11182 Pkg_Name := String_From_Name_Buffer;
11184 Make_Package_Instantiation (Loc,
11185 Defining_Unit_Name =>
11186 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
11188 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11189 Generic_Associations => New_List (
11190 Make_Generic_Association (Loc,
11192 Make_Identifier (Loc, Name_RCI_Name),
11193 Explicit_Generic_Actual_Parameter =>
11194 Make_String_Literal (Loc,
11195 Strval => Pkg_Name)),
11196 Make_Generic_Association (Loc,
11198 Make_Identifier (Loc, Name_Version),
11199 Explicit_Generic_Actual_Parameter =>
11200 Make_Attribute_Reference (Loc,
11202 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11206 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
11207 Defining_Unit_Name (Inst));
11209 end RCI_Package_Locator;
11211 -----------------------------------------------
11212 -- Remote_Types_Tagged_Full_View_Encountered --
11213 -----------------------------------------------
11215 procedure Remote_Types_Tagged_Full_View_Encountered
11216 (Full_View : Entity_Id)
11218 Stub_Elements : constant Stub_Structure :=
11219 Stubs_Table.Get (Full_View);
11221 if Stub_Elements /= Empty_Stub_Structure then
11222 Add_RACW_Primitive_Declarations_And_Bodies
11224 Stub_Elements.RPC_Receiver_Decl,
11225 Stub_Elements.Body_Decls);
11227 end Remote_Types_Tagged_Full_View_Encountered;
11229 -------------------
11230 -- Scope_Of_Spec --
11231 -------------------
11233 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11234 Unit_Name : Node_Id;
11237 Unit_Name := Defining_Unit_Name (Spec);
11238 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11239 Unit_Name := Defining_Identifier (Unit_Name);
11245 ----------------------
11246 -- Set_Renaming_TSS --
11247 ----------------------
11249 procedure Set_Renaming_TSS
11252 TSS_Nam : TSS_Name_Type)
11254 Loc : constant Source_Ptr := Sloc (Nam);
11255 Spec : constant Node_Id := Parent (Nam);
11257 TSS_Node : constant Node_Id :=
11258 Make_Subprogram_Renaming_Declaration (Loc,
11260 Copy_Specification (Loc,
11262 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11263 Name => New_Occurrence_Of (Nam, Loc));
11265 Snam : constant Entity_Id :=
11266 Defining_Unit_Name (Specification (TSS_Node));
11269 if Nkind (Spec) = N_Function_Specification then
11270 Set_Ekind (Snam, E_Function);
11271 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11273 Set_Ekind (Snam, E_Procedure);
11274 Set_Etype (Snam, Standard_Void_Type);
11277 Set_TSS (Typ, Snam);
11278 end Set_Renaming_TSS;
11280 ----------------------------------------------
11281 -- Specific_Add_Obj_RPC_Receiver_Completion --
11282 ----------------------------------------------
11284 procedure Specific_Add_Obj_RPC_Receiver_Completion
11287 RPC_Receiver : Entity_Id;
11288 Stub_Elements : Stub_Structure) is
11290 case Get_PCS_Name is
11291 when Name_PolyORB_DSA =>
11292 PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11293 Decls, RPC_Receiver, Stub_Elements);
11295 GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11296 Decls, RPC_Receiver, Stub_Elements);
11298 end Specific_Add_Obj_RPC_Receiver_Completion;
11300 --------------------------------
11301 -- Specific_Add_RACW_Features --
11302 --------------------------------
11304 procedure Specific_Add_RACW_Features
11305 (RACW_Type : Entity_Id;
11307 Stub_Type : Entity_Id;
11308 Stub_Type_Access : Entity_Id;
11309 RPC_Receiver_Decl : Node_Id;
11310 Body_Decls : List_Id) is
11312 case Get_PCS_Name is
11313 when Name_PolyORB_DSA =>
11314 PolyORB_Support.Add_RACW_Features (
11323 GARLIC_Support.Add_RACW_Features (
11330 end Specific_Add_RACW_Features;
11332 --------------------------------
11333 -- Specific_Add_RAST_Features --
11334 --------------------------------
11336 procedure Specific_Add_RAST_Features
11337 (Vis_Decl : Node_Id;
11338 RAS_Type : Entity_Id) is
11340 case Get_PCS_Name is
11341 when Name_PolyORB_DSA =>
11342 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11344 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11346 end Specific_Add_RAST_Features;
11348 --------------------------------------------------
11349 -- Specific_Add_Receiving_Stubs_To_Declarations --
11350 --------------------------------------------------
11352 procedure Specific_Add_Receiving_Stubs_To_Declarations
11353 (Pkg_Spec : Node_Id;
11358 case Get_PCS_Name is
11359 when Name_PolyORB_DSA =>
11360 PolyORB_Support.Add_Receiving_Stubs_To_Declarations (
11361 Pkg_Spec, Decls, Stmts);
11363 GARLIC_Support.Add_Receiving_Stubs_To_Declarations (
11364 Pkg_Spec, Decls, Stmts);
11366 end Specific_Add_Receiving_Stubs_To_Declarations;
11368 ------------------------------------------
11369 -- Specific_Build_General_Calling_Stubs --
11370 ------------------------------------------
11372 procedure Specific_Build_General_Calling_Stubs
11374 Statements : List_Id;
11375 Target : RPC_Target;
11376 Subprogram_Id : Node_Id;
11377 Asynchronous : Node_Id := Empty;
11378 Is_Known_Asynchronous : Boolean := False;
11379 Is_Known_Non_Asynchronous : Boolean := False;
11380 Is_Function : Boolean;
11382 Stub_Type : Entity_Id := Empty;
11383 RACW_Type : Entity_Id := Empty;
11387 case Get_PCS_Name is
11388 when Name_PolyORB_DSA =>
11389 PolyORB_Support.Build_General_Calling_Stubs (
11395 Is_Known_Asynchronous,
11396 Is_Known_Non_Asynchronous,
11403 GARLIC_Support.Build_General_Calling_Stubs (
11407 Target.RPC_Receiver,
11410 Is_Known_Asynchronous,
11411 Is_Known_Non_Asynchronous,
11418 end Specific_Build_General_Calling_Stubs;
11420 --------------------------------------
11421 -- Specific_Build_RPC_Receiver_Body --
11422 --------------------------------------
11424 procedure Specific_Build_RPC_Receiver_Body
11425 (RPC_Receiver : Entity_Id;
11426 Request : out Entity_Id;
11427 Subp_Id : out Entity_Id;
11428 Subp_Index : out Entity_Id;
11429 Stmts : out List_Id;
11430 Decl : out Node_Id)
11433 case Get_PCS_Name is
11434 when Name_PolyORB_DSA =>
11435 PolyORB_Support.Build_RPC_Receiver_Body
11443 GARLIC_Support.Build_RPC_Receiver_Body
11451 end Specific_Build_RPC_Receiver_Body;
11453 --------------------------------
11454 -- Specific_Build_Stub_Target --
11455 --------------------------------
11457 function Specific_Build_Stub_Target
11460 RCI_Locator : Entity_Id;
11461 Controlling_Parameter : Entity_Id) return RPC_Target
11464 case Get_PCS_Name is
11465 when Name_PolyORB_DSA =>
11466 return PolyORB_Support.Build_Stub_Target (Loc,
11467 Decls, RCI_Locator, Controlling_Parameter);
11469 return GARLIC_Support.Build_Stub_Target (Loc,
11470 Decls, RCI_Locator, Controlling_Parameter);
11472 end Specific_Build_Stub_Target;
11474 ------------------------------
11475 -- Specific_Build_Stub_Type --
11476 ------------------------------
11478 procedure Specific_Build_Stub_Type
11479 (RACW_Type : Entity_Id;
11480 Stub_Type : Entity_Id;
11481 Stub_Type_Decl : out Node_Id;
11482 RPC_Receiver_Decl : out Node_Id)
11485 case Get_PCS_Name is
11486 when Name_PolyORB_DSA =>
11487 PolyORB_Support.Build_Stub_Type (
11488 RACW_Type, Stub_Type,
11489 Stub_Type_Decl, RPC_Receiver_Decl);
11491 GARLIC_Support.Build_Stub_Type (
11492 RACW_Type, Stub_Type,
11493 Stub_Type_Decl, RPC_Receiver_Decl);
11495 end Specific_Build_Stub_Type;
11497 function Specific_Build_Subprogram_Receiving_Stubs
11498 (Vis_Decl : Node_Id;
11499 Asynchronous : Boolean;
11500 Dynamically_Asynchronous : Boolean := False;
11501 Stub_Type : Entity_Id := Empty;
11502 RACW_Type : Entity_Id := Empty;
11503 Parent_Primitive : Entity_Id := Empty) return Node_Id
11506 case Get_PCS_Name is
11507 when Name_PolyORB_DSA =>
11508 return PolyORB_Support.Build_Subprogram_Receiving_Stubs (
11511 Dynamically_Asynchronous,
11516 return GARLIC_Support.Build_Subprogram_Receiving_Stubs (
11519 Dynamically_Asynchronous,
11524 end Specific_Build_Subprogram_Receiving_Stubs;
11526 --------------------------
11527 -- Underlying_RACW_Type --
11528 --------------------------
11530 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11531 Record_Type : Entity_Id;
11534 if Ekind (RAS_Typ) = E_Record_Type then
11535 Record_Type := RAS_Typ;
11537 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11538 Record_Type := Equivalent_Type (RAS_Typ);
11542 Etype (Subtype_Indication (
11543 Component_Definition (
11544 First (Component_Items (Component_List (
11545 Type_Definition (Declaration_Node (Record_Type))))))));
11546 end Underlying_RACW_Type;