1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Exp_Strm; use Exp_Strm;
31 with Exp_Tss; use Exp_Tss;
32 with Exp_Util; use Exp_Util;
34 with Namet; use Namet;
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 necessary to call the subprogram declared
166 -- by Vis_Decl through a remote access to subprogram type.
167 -- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote
168 -- applies, Standard_False otherwise. The new proxy type is appended
169 -- to Decls. Proxy_Object_Addr is a constant of type System.Address that
170 -- 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
496 Partition : Entity_Id;
497 -- A variable containing the Partition_ID of the target parition
499 RPC_Receiver : Node_Id;
500 -- An expression whose value is the address of the target RPC
505 procedure Specific_Build_General_Calling_Stubs
507 Statements : List_Id;
509 Subprogram_Id : Node_Id;
510 Asynchronous : Node_Id := Empty;
511 Is_Known_Asynchronous : Boolean := False;
512 Is_Known_Non_Asynchronous : Boolean := False;
513 Is_Function : Boolean;
515 Stub_Type : Entity_Id := Empty;
516 RACW_Type : Entity_Id := Empty;
518 -- Build calling stubs for general purpose. The parameters are:
519 -- Decls : a place to put declarations
520 -- Statements : a place to put statements
521 -- Target : PCS-specific target information (see details
522 -- in RPC_Target declaration).
523 -- Subprogram_Id : a node containing the subprogram ID
524 -- Asynchronous : True if an APC must be made instead of an RPC.
525 -- The value needs not be supplied if one of the
526 -- Is_Known_... is True.
527 -- Is_Known_Async... : True if we know that this is asynchronous
528 -- Is_Known_Non_A... : True if we know that this is not asynchronous
529 -- Spec : a node with a Parameter_Specifications and
530 -- a Result_Definition if applicable
531 -- Stub_Type : in case of RACW stubs, parameters of type access
532 -- to Stub_Type will be marshalled using the
533 -- address of the object (the addr field) rather
534 -- than using the 'Write on the stub itself
535 -- Nod : used to provide sloc for generated code
537 function Specific_Build_Stub_Target
540 RCI_Locator : Entity_Id;
541 Controlling_Parameter : Entity_Id) return RPC_Target;
542 -- Build call target information nodes for use within calling stubs. In the
543 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
544 -- for an RACW, Controlling_Parameter is the entity for the controlling
545 -- formal parameter used to determine the location of the target of the
546 -- call. Decls provides a location where variable declarations can be
547 -- appended to construct the necessary values.
549 procedure Specific_Build_Stub_Type
550 (RACW_Type : Entity_Id;
551 Stub_Type : Entity_Id;
552 Stub_Type_Decl : out Node_Id;
553 RPC_Receiver_Decl : out Node_Id);
554 -- Build a type declaration for the stub type associated with an RACW
555 -- type, and the necessary RPC receiver, if applicable. PCS-specific
556 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
557 -- is generated, then RPC_Receiver_Decl is set to Empty.
559 procedure Specific_Build_RPC_Receiver_Body
560 (RPC_Receiver : Entity_Id;
561 Request : out Entity_Id;
562 Subp_Id : out Entity_Id;
563 Subp_Index : out Entity_Id;
566 -- Make a subprogram body for an RPC receiver, with the given
567 -- defining unit name. On return:
568 -- - Subp_Id is the subprogram identifier from the PCS.
569 -- - Subp_Index is the index in the list of subprograms
570 -- used for dispatching (a variable of type Subprogram_Id).
571 -- - Stmts is the place where the request dispatching
572 -- statements can occur,
573 -- - Decl is the subprogram body declaration.
575 function Specific_Build_Subprogram_Receiving_Stubs
577 Asynchronous : Boolean;
578 Dynamically_Asynchronous : Boolean := False;
579 Stub_Type : Entity_Id := Empty;
580 RACW_Type : Entity_Id := Empty;
581 Parent_Primitive : Entity_Id := Empty) return Node_Id;
582 -- Build the receiving stub for a given subprogram. The subprogram
583 -- declaration is also built by this procedure, and the value returned
584 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
585 -- found in the specification, then its address is read from the stream
586 -- instead of the object itself and converted into an access to
587 -- class-wide type before doing the real call using any of the RACW type
588 -- pointing on the designated type.
590 procedure Specific_Add_Obj_RPC_Receiver_Completion
593 RPC_Receiver : Entity_Id;
594 Stub_Elements : Stub_Structure);
595 -- Add the necessary code to Decls after the completion of generation
596 -- of the RACW RPC receiver described by Stub_Elements.
598 procedure Specific_Add_Receiving_Stubs_To_Declarations
602 -- Add receiving stubs to the declarative part of an RCI unit
604 package GARLIC_Support is
606 -- Support for generating DSA code that uses the GARLIC PCS
608 -- The subprograms below provide the GARLIC versions of
609 -- the corresponding Specific_<subprogram> routine declared
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
684 -- the corresponding Specific_<subprogram> routine declared
687 procedure Add_RACW_Features
688 (RACW_Type : Entity_Id;
690 Stub_Type : Entity_Id;
691 Stub_Type_Access : Entity_Id;
692 RPC_Receiver_Decl : Node_Id;
693 Body_Decls : List_Id);
695 procedure Add_RAST_Features
697 RAS_Type : Entity_Id);
699 procedure Build_General_Calling_Stubs
701 Statements : List_Id;
702 Target_Object : Node_Id; -- From RPC_Target
703 Subprogram_Id : Node_Id;
704 Asynchronous : Node_Id := Empty;
705 Is_Known_Asynchronous : Boolean := False;
706 Is_Known_Non_Asynchronous : Boolean := False;
707 Is_Function : Boolean;
709 Stub_Type : Entity_Id := Empty;
710 RACW_Type : Entity_Id := Empty;
713 function Build_Stub_Target
716 RCI_Locator : Entity_Id;
717 Controlling_Parameter : Entity_Id) return RPC_Target;
719 procedure Build_Stub_Type
720 (RACW_Type : Entity_Id;
721 Stub_Type : Entity_Id;
722 Stub_Type_Decl : out Node_Id;
723 RPC_Receiver_Decl : out Node_Id);
725 function Build_Subprogram_Receiving_Stubs
727 Asynchronous : Boolean;
728 Dynamically_Asynchronous : Boolean := False;
729 Stub_Type : Entity_Id := Empty;
730 RACW_Type : Entity_Id := Empty;
731 Parent_Primitive : Entity_Id := Empty) return Node_Id;
733 procedure Add_Obj_RPC_Receiver_Completion
736 RPC_Receiver : Entity_Id;
737 Stub_Elements : Stub_Structure);
739 procedure Add_Receiving_Stubs_To_Declarations
744 procedure Build_RPC_Receiver_Body
745 (RPC_Receiver : Entity_Id;
746 Request : out Entity_Id;
747 Subp_Id : out Entity_Id;
748 Subp_Index : out Entity_Id;
752 procedure Reserve_NamingContext_Methods;
753 -- Mark the method names for interface NamingContext as already used in
754 -- the overload table, so no clashes occur with user code (with the
755 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
756 -- their methods to be accessed as objects, for the implementation of
757 -- remote access-to-subprogram types).
761 -- Routines to build distribtion helper subprograms for user-defined
762 -- types. For implementation of the Distributed systems annex (DSA)
763 -- over the PolyORB generic middleware components, it is necessary to
764 -- generate several supporting subprograms for each application data
765 -- type used in inter-partition communication. These subprograms are:
766 -- * a Typecode function returning a high-level description of the
768 -- * two conversion functions allowing conversion of values of the
769 -- type from and to the generic data containers used by PolyORB.
770 -- These generic containers are called 'Any' type values after
771 -- the CORBA terminology, and hence the conversion subprograms
772 -- are named To_Any and From_Any.
774 function Build_From_Any_Call
777 Decls : List_Id) return Node_Id;
778 -- Build call to From_Any attribute function of type Typ with
779 -- expression N as actual parameter. Decls is the declarations list
780 -- for an appropriate enclosing scope of the point where the call
781 -- will be inserted; if the From_Any attribute for Typ needs to be
782 -- generated at this point, its declaration is appended to Decls.
784 procedure Build_From_Any_Function
788 Fnam : out Entity_Id);
789 -- Build From_Any attribute function for Typ. Loc is the reference
790 -- location for generated nodes, Typ is the type for which the
791 -- conversion function is generated. On return, Decl and Fnam contain
792 -- the declaration and entity for the newly-created function.
794 function Build_To_Any_Call
796 Decls : List_Id) return Node_Id;
797 -- Build call to To_Any attribute function with expression as actual
798 -- parameter. Decls is the declarations list for an appropriate
799 -- enclosing scope of the point where the call will be inserted; if
800 -- the To_Any attribute for Typ needs to be generated at this point,
801 -- its declaration is appended to Decls.
803 procedure Build_To_Any_Function
807 Fnam : out Entity_Id);
808 -- Build To_Any attribute function for Typ. Loc is the reference
809 -- location for generated nodes, Typ is the type for which the
810 -- conversion function is generated. On return, Decl and Fnam contain
811 -- the declaration and entity for the newly-created function.
813 function Build_TypeCode_Call
816 Decls : List_Id) return Node_Id;
817 -- Build call to TypeCode attribute function for Typ. Decls is the
818 -- declarations list for an appropriate enclosing scope of the point
819 -- where the call will be inserted; if the To_Any attribute for Typ
820 -- needs to be generated at this point, its declaration is appended
823 procedure Build_TypeCode_Function
827 Fnam : out Entity_Id);
828 -- Build TypeCode attribute function for Typ. Loc is the reference
829 -- location for generated nodes, Typ is the type for which the
830 -- conversion function is generated. On return, Decl and Fnam contain
831 -- the declaration and entity for the newly-created function.
833 procedure Build_Name_And_Repository_Id
835 Name_Str : out String_Id;
836 Repo_Id_Str : out String_Id);
837 -- In the PolyORB distribution model, each distributed object type
838 -- and each distributed operation has a globally unique identifier,
839 -- its Repository Id. This subprogram builds and returns two strings
840 -- for entity E (a distributed object type or operation): one
841 -- containing the name of E, the second containing its repository id.
847 ------------------------------------
848 -- Local variables and structures --
849 ------------------------------------
852 -- Needs comments ???
854 Output_From_Constrained : constant array (Boolean) of Name_Id :=
855 (False => Name_Output,
857 -- The attribute to choose depending on the fact that the parameter
858 -- is constrained or not. There is no such thing as Input_From_Constrained
859 -- since this require separate mechanisms ('Input is a function while
860 -- 'Read is a procedure).
862 ---------------------------------------
863 -- Add_Calling_Stubs_To_Declarations --
864 ---------------------------------------
866 procedure Add_Calling_Stubs_To_Declarations
870 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
871 -- Subprogram id 0 is reserved for calls received from
872 -- remote access-to-subprogram dereferences.
874 Current_Declaration : Node_Id;
875 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
876 RCI_Instantiation : Node_Id;
877 Subp_Stubs : Node_Id;
878 Subp_Str : String_Id;
881 -- The first thing added is an instantiation of the generic package
882 -- System.Partition_Interface.RCI_Locator with the name of this
883 -- remote package. This will act as an interface with the name server
884 -- to determine the Partition_ID and the RPC_Receiver for the
885 -- receiver of this package.
887 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
888 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
890 Append_To (Decls, RCI_Instantiation);
891 Analyze (RCI_Instantiation);
893 -- For each subprogram declaration visible in the spec, we do
894 -- build a body. We also increment a counter to assign a different
895 -- Subprogram_Id to each subprograms. The receiving stubs processing
896 -- do use the same mechanism and will thus assign the same Id and
897 -- do the correct dispatching.
899 Overload_Counter_Table.Reset;
900 PolyORB_Support.Reserve_NamingContext_Methods;
902 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
904 while Present (Current_Declaration) loop
905 if Nkind (Current_Declaration) = N_Subprogram_Declaration
906 and then Comes_From_Source (Current_Declaration)
908 Assign_Subprogram_Identifier (
909 Defining_Unit_Name (Specification (Current_Declaration)),
910 Current_Subprogram_Number,
914 Build_Subprogram_Calling_Stubs (
915 Vis_Decl => Current_Declaration,
917 Build_Subprogram_Id (Loc,
918 Defining_Unit_Name (Specification (Current_Declaration))),
920 Nkind (Specification (Current_Declaration)) =
921 N_Procedure_Specification
923 Is_Asynchronous (Defining_Unit_Name (Specification
924 (Current_Declaration))));
926 Append_To (Decls, Subp_Stubs);
927 Analyze (Subp_Stubs);
929 Current_Subprogram_Number := Current_Subprogram_Number + 1;
932 Next (Current_Declaration);
934 end Add_Calling_Stubs_To_Declarations;
936 -----------------------------
937 -- Add_Parameter_To_NVList --
938 -----------------------------
940 function Add_Parameter_To_NVList
943 Parameter : Entity_Id;
944 Constrained : Boolean;
945 RACW_Ctrl : Boolean := False;
946 Any : Entity_Id) return Node_Id
948 Parameter_Name_String : String_Id;
949 Parameter_Mode : Node_Id;
951 function Parameter_Passing_Mode
953 Parameter : Entity_Id;
954 Constrained : Boolean) return Node_Id;
955 -- Return an expression that denotes the parameter passing
956 -- mode to be used for Parameter in distribution stubs,
957 -- where Constrained is Parameter's constrained status.
959 ----------------------------
960 -- Parameter_Passing_Mode --
961 ----------------------------
963 function Parameter_Passing_Mode
965 Parameter : Entity_Id;
966 Constrained : Boolean) return Node_Id
971 if Out_Present (Parameter) then
972 if In_Present (Parameter)
973 or else not Constrained
975 -- Unconstrained formals must be translated
976 -- to 'in' or 'inout', not 'out', because
977 -- they need to be constrained by the actual.
979 Lib_RE := RE_Mode_Inout;
981 Lib_RE := RE_Mode_Out;
985 Lib_RE := RE_Mode_In;
988 return New_Occurrence_Of (RTE (Lib_RE), Loc);
989 end Parameter_Passing_Mode;
991 -- Start of processing for Add_Parameter_To_NVList
994 if Nkind (Parameter) = N_Defining_Identifier then
995 Get_Name_String (Chars (Parameter));
997 Get_Name_String (Chars (Defining_Identifier
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);
1013 Parameter_Mode := Parameter_Passing_Mode (Loc,
1014 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.
1169 -- ??? Shouldn't we have a pragma Assert (not Is_Frozen (Desig))?
1171 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1173 end Add_RACW_Features;
1175 ------------------------------------------------
1176 -- Add_RACW_Primitive_Declarations_And_Bodies --
1177 ------------------------------------------------
1179 procedure Add_RACW_Primitive_Declarations_And_Bodies
1180 (Designated_Type : Entity_Id;
1181 Insertion_Node : Node_Id;
1182 Body_Decls : List_Id)
1184 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1185 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1186 -- the declarations are recognized as belonging to the current package.
1188 Stub_Elements : constant Stub_Structure :=
1189 Stubs_Table.Get (Designated_Type);
1191 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1193 Is_RAS : constant Boolean :=
1194 not Comes_From_Source (Stub_Elements.RACW_Type);
1195 -- Case of the RACW generated to implement a remote access-to-
1198 Build_Bodies : constant Boolean :=
1199 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1200 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1201 -- only when the main unit is the unit that contains the stub type.
1203 Current_Insertion_Node : Node_Id := Insertion_Node;
1205 RPC_Receiver : Entity_Id;
1206 RPC_Receiver_Statements : List_Id;
1207 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1208 RPC_Receiver_Elsif_Parts : List_Id;
1209 RPC_Receiver_Request : Entity_Id;
1210 RPC_Receiver_Subp_Id : Entity_Id;
1211 RPC_Receiver_Subp_Index : Entity_Id;
1213 Subp_Str : String_Id;
1215 Current_Primitive_Elmt : Elmt_Id;
1216 Current_Primitive : Entity_Id;
1217 Current_Primitive_Body : Node_Id;
1218 Current_Primitive_Spec : Node_Id;
1219 Current_Primitive_Decl : Node_Id;
1220 Current_Primitive_Number : Int := 0;
1222 Current_Primitive_Alias : Node_Id;
1224 Current_Receiver : Entity_Id;
1225 Current_Receiver_Body : Node_Id;
1227 RPC_Receiver_Decl : Node_Id;
1229 Possibly_Asynchronous : Boolean;
1232 if not Expander_Active then
1237 RPC_Receiver := Make_Defining_Identifier (Loc,
1238 New_Internal_Name ('P'));
1239 Specific_Build_RPC_Receiver_Body (
1240 RPC_Receiver => RPC_Receiver,
1241 Request => RPC_Receiver_Request,
1242 Subp_Id => RPC_Receiver_Subp_Id,
1243 Subp_Index => RPC_Receiver_Subp_Index,
1244 Stmts => RPC_Receiver_Statements,
1245 Decl => RPC_Receiver_Decl);
1247 if Get_PCS_Name = Name_PolyORB_DSA then
1249 -- For the case of PolyORB, we need to map a textual operation
1250 -- name into a primitive index. Currently we do so using a simple
1251 -- sequence of string comparisons.
1253 RPC_Receiver_Elsif_Parts := New_List;
1257 -- Build callers, receivers for every primitive operations and a RPC
1258 -- receiver for this type.
1260 if Present (Primitive_Operations (Designated_Type)) then
1261 Overload_Counter_Table.Reset;
1263 Current_Primitive_Elmt :=
1264 First_Elmt (Primitive_Operations (Designated_Type));
1265 while Current_Primitive_Elmt /= No_Elmt loop
1266 Current_Primitive := Node (Current_Primitive_Elmt);
1268 -- Copy the primitive of all the parents, except predefined ones
1269 -- that are not remotely dispatching.
1271 if Chars (Current_Primitive) /= Name_uSize
1272 and then Chars (Current_Primitive) /= Name_uAlignment
1273 and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize)
1275 -- The first thing to do is build an up-to-date copy of the
1276 -- spec with all the formals referencing Designated_Type
1277 -- transformed into formals referencing Stub_Type. Since this
1278 -- primitive may have been inherited, go back the alias chain
1279 -- until the real primitive has been found.
1281 Current_Primitive_Alias := Current_Primitive;
1282 while Present (Alias (Current_Primitive_Alias)) loop
1284 (Current_Primitive_Alias
1285 /= Alias (Current_Primitive_Alias));
1286 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
1289 -- Copy the spec from the original declaration for the purpose
1290 -- of declaring an overriding subprogram: we need to replace
1291 -- the type of each controlling formal with Stub_Type. The
1292 -- primitive may have been declared for Designated_Type or
1293 -- inherited from some ancestor type for which we do not have
1294 -- an easily determined Entity_Id. We have no systematic way
1295 -- of knowing which type to substitute Stub_Type for. Instead,
1296 -- Copy_Specification relies on the flag Is_Controlling_Formal
1297 -- to determine which formals to change.
1299 Current_Primitive_Spec :=
1300 Copy_Specification (Loc,
1301 Spec => Parent (Current_Primitive_Alias),
1302 Ctrl_Type => Stub_Elements.Stub_Type);
1304 Current_Primitive_Decl :=
1305 Make_Subprogram_Declaration (Loc,
1306 Specification => Current_Primitive_Spec);
1308 Insert_After_And_Analyze (Current_Insertion_Node,
1309 Current_Primitive_Decl);
1310 Current_Insertion_Node := Current_Primitive_Decl;
1312 Possibly_Asynchronous :=
1313 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1314 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1316 Assign_Subprogram_Identifier (
1317 Defining_Unit_Name (Current_Primitive_Spec),
1318 Current_Primitive_Number,
1321 if Build_Bodies then
1322 Current_Primitive_Body :=
1323 Build_Subprogram_Calling_Stubs
1324 (Vis_Decl => Current_Primitive_Decl,
1326 Build_Subprogram_Id (Loc,
1327 Defining_Unit_Name (Current_Primitive_Spec)),
1328 Asynchronous => Possibly_Asynchronous,
1329 Dynamically_Asynchronous => Possibly_Asynchronous,
1330 Stub_Type => Stub_Elements.Stub_Type,
1331 RACW_Type => Stub_Elements.RACW_Type);
1332 Append_To (Body_Decls, Current_Primitive_Body);
1334 -- Analyzing the body here would cause the Stub type to be
1335 -- frozen, thus preventing subsequent primitive
1336 -- declarations. For this reason, it will be analyzed later
1337 -- in the regular flow (and in the context of the
1338 -- appropriate unit body, see Append_RACW_Bodies).
1342 -- Build the receiver stubs
1344 if Build_Bodies and then not Is_RAS then
1345 Current_Receiver_Body :=
1346 Specific_Build_Subprogram_Receiving_Stubs
1347 (Vis_Decl => Current_Primitive_Decl,
1348 Asynchronous => Possibly_Asynchronous,
1349 Dynamically_Asynchronous => Possibly_Asynchronous,
1350 Stub_Type => Stub_Elements.Stub_Type,
1351 RACW_Type => Stub_Elements.RACW_Type,
1352 Parent_Primitive => Current_Primitive);
1354 Current_Receiver := Defining_Unit_Name (
1355 Specification (Current_Receiver_Body));
1357 Append_To (Body_Decls, Current_Receiver_Body);
1359 -- Add a case alternative to the receiver
1361 if Get_PCS_Name = Name_PolyORB_DSA then
1362 Append_To (RPC_Receiver_Elsif_Parts,
1363 Make_Elsif_Part (Loc,
1365 Make_Function_Call (Loc,
1368 RTE (RE_Caseless_String_Eq), Loc),
1369 Parameter_Associations => New_List (
1370 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1371 Make_String_Literal (Loc, Subp_Str))),
1372 Then_Statements => New_List (
1373 Make_Assignment_Statement (Loc,
1374 Name => New_Occurrence_Of (
1375 RPC_Receiver_Subp_Index, Loc),
1377 Make_Integer_Literal (Loc,
1378 Current_Primitive_Number)))));
1381 Append_To (RPC_Receiver_Case_Alternatives,
1382 Make_Case_Statement_Alternative (Loc,
1383 Discrete_Choices => New_List (
1384 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1386 Statements => New_List (
1387 Make_Procedure_Call_Statement (Loc,
1389 New_Occurrence_Of (Current_Receiver, Loc),
1390 Parameter_Associations => New_List (
1391 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1394 -- Increment the index of current primitive
1396 Current_Primitive_Number := Current_Primitive_Number + 1;
1399 Next_Elmt (Current_Primitive_Elmt);
1403 -- Build the case statement and the heart of the subprogram
1405 if Build_Bodies and then not Is_RAS then
1406 if Get_PCS_Name = Name_PolyORB_DSA
1407 and then Present (First (RPC_Receiver_Elsif_Parts))
1409 Append_To (RPC_Receiver_Statements,
1410 Make_Implicit_If_Statement (Designated_Type,
1411 Condition => New_Occurrence_Of (Standard_False, Loc),
1412 Then_Statements => New_List,
1413 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1416 Append_To (RPC_Receiver_Case_Alternatives,
1417 Make_Case_Statement_Alternative (Loc,
1418 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1419 Statements => New_List (Make_Null_Statement (Loc))));
1421 Append_To (RPC_Receiver_Statements,
1422 Make_Case_Statement (Loc,
1424 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1425 Alternatives => RPC_Receiver_Case_Alternatives));
1427 Append_To (Body_Decls, RPC_Receiver_Decl);
1428 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1429 Body_Decls, RPC_Receiver, Stub_Elements);
1431 -- Do not analyze RPC receiver body at this stage since it references
1432 -- subprograms that have not been analyzed yet. It will be analyzed in
1433 -- the regular flow (see Append_RACW_Bodies).
1436 end Add_RACW_Primitive_Declarations_And_Bodies;
1438 -----------------------------
1439 -- Add_RAS_Dereference_TSS --
1440 -----------------------------
1442 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1443 Loc : constant Source_Ptr := Sloc (N);
1445 Type_Def : constant Node_Id := Type_Definition (N);
1447 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1448 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1449 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1450 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1452 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
1453 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1455 RACW_Primitive_Name : Node_Id;
1457 Proc : constant Entity_Id :=
1458 Make_Defining_Identifier (Loc,
1459 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1461 Proc_Spec : Node_Id;
1462 Param_Specs : List_Id;
1463 Param_Assoc : constant List_Id := New_List;
1464 Stmts : constant List_Id := New_List;
1466 RAS_Parameter : constant Entity_Id :=
1467 Make_Defining_Identifier (Loc,
1468 Chars => New_Internal_Name ('P'));
1470 Is_Function : constant Boolean :=
1471 Nkind (Type_Def) = N_Access_Function_Definition;
1473 Is_Degenerate : Boolean;
1474 -- Set to True if the subprogram_specification for this RAS has an
1475 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1477 Spec : constant Node_Id := Type_Def;
1479 Current_Parameter : Node_Id;
1481 -- Start of processing for Add_RAS_Dereference_TSS
1484 -- The Dereference TSS for a remote access-to-subprogram type has the
1487 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1490 -- This is called whenever a value of a RAS type is dereferenced
1492 -- First construct a list of parameter specifications:
1494 -- The first formal is the RAS values
1496 Param_Specs := New_List (
1497 Make_Parameter_Specification (Loc,
1498 Defining_Identifier => RAS_Parameter,
1501 New_Occurrence_Of (Fat_Type, Loc)));
1503 -- The following formals are copied from the type declaration
1505 Is_Degenerate := False;
1506 Current_Parameter := First (Parameter_Specifications (Type_Def));
1507 Parameters : while Present (Current_Parameter) loop
1508 if Nkind (Parameter_Type (Current_Parameter)) =
1511 Is_Degenerate := True;
1514 Append_To (Param_Specs,
1515 Make_Parameter_Specification (Loc,
1516 Defining_Identifier =>
1517 Make_Defining_Identifier (Loc,
1518 Chars => Chars (Defining_Identifier (Current_Parameter))),
1519 In_Present => In_Present (Current_Parameter),
1520 Out_Present => Out_Present (Current_Parameter),
1522 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1524 New_Copy_Tree (Expression (Current_Parameter))));
1526 Append_To (Param_Assoc,
1527 Make_Identifier (Loc,
1528 Chars => Chars (Defining_Identifier (Current_Parameter))));
1530 Next (Current_Parameter);
1531 end loop Parameters;
1533 if Is_Degenerate then
1534 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1536 -- Generate a dummy body. This code will never actually be executed,
1537 -- because null is the only legal value for a degenerate RAS type.
1538 -- For legality's sake (in order to avoid generating a function
1539 -- that does not contain a return statement), we include a dummy
1540 -- recursive call on the TSS itself.
1543 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1544 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1547 -- For a normal RAS type, we cast the RAS formal to the corresponding
1548 -- tagged type, and perform a dispatching call to its Call primitive
1551 Prepend_To (Param_Assoc,
1552 Unchecked_Convert_To (RACW_Type,
1553 New_Occurrence_Of (RAS_Parameter, Loc)));
1555 RACW_Primitive_Name :=
1556 Make_Selected_Component (Loc,
1557 Prefix => Scope (RACW_Type),
1558 Selector_Name => Name_uCall);
1563 Make_Return_Statement (Loc,
1565 Make_Function_Call (Loc,
1566 Name => RACW_Primitive_Name,
1567 Parameter_Associations => Param_Assoc)));
1571 Make_Procedure_Call_Statement (Loc,
1572 Name => RACW_Primitive_Name,
1573 Parameter_Associations => Param_Assoc));
1576 -- Build the complete subprogram
1580 Make_Function_Specification (Loc,
1581 Defining_Unit_Name => Proc,
1582 Parameter_Specifications => Param_Specs,
1583 Result_Definition =>
1585 Entity (Result_Definition (Spec)), Loc));
1587 Set_Ekind (Proc, E_Function);
1589 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1593 Make_Procedure_Specification (Loc,
1594 Defining_Unit_Name => Proc,
1595 Parameter_Specifications => Param_Specs);
1597 Set_Ekind (Proc, E_Procedure);
1598 Set_Etype (Proc, Standard_Void_Type);
1602 Make_Subprogram_Body (Loc,
1603 Specification => Proc_Spec,
1604 Declarations => New_List,
1605 Handled_Statement_Sequence =>
1606 Make_Handled_Sequence_Of_Statements (Loc,
1607 Statements => Stmts)));
1609 Set_TSS (Fat_Type, Proc);
1610 end Add_RAS_Dereference_TSS;
1612 -------------------------------
1613 -- Add_RAS_Proxy_And_Analyze --
1614 -------------------------------
1616 procedure Add_RAS_Proxy_And_Analyze
1619 All_Calls_Remote_E : Entity_Id;
1620 Proxy_Object_Addr : out Entity_Id)
1622 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1624 Subp_Name : constant Entity_Id :=
1625 Defining_Unit_Name (Specification (Vis_Decl));
1627 Pkg_Name : constant Entity_Id :=
1628 Make_Defining_Identifier (Loc,
1630 New_External_Name (Chars (Subp_Name), 'P', -1));
1632 Proxy_Type : constant Entity_Id :=
1633 Make_Defining_Identifier (Loc,
1636 Related_Id => Chars (Subp_Name),
1639 Proxy_Type_Full_View : constant Entity_Id :=
1640 Make_Defining_Identifier (Loc,
1641 Chars (Proxy_Type));
1643 Subp_Decl_Spec : constant Node_Id :=
1644 Build_RAS_Primitive_Specification
1645 (Subp_Spec => Specification (Vis_Decl),
1646 Remote_Object_Type => Proxy_Type);
1648 Subp_Body_Spec : constant Node_Id :=
1649 Build_RAS_Primitive_Specification
1650 (Subp_Spec => Specification (Vis_Decl),
1651 Remote_Object_Type => Proxy_Type);
1653 Vis_Decls : constant List_Id := New_List;
1654 Pvt_Decls : constant List_Id := New_List;
1655 Actuals : constant List_Id := New_List;
1657 Perform_Call : Node_Id;
1660 -- type subpP is tagged limited private;
1662 Append_To (Vis_Decls,
1663 Make_Private_Type_Declaration (Loc,
1664 Defining_Identifier => Proxy_Type,
1665 Tagged_Present => True,
1666 Limited_Present => True));
1668 -- [subprogram] Call
1669 -- (Self : access subpP;
1670 -- ...other-formals...)
1673 Append_To (Vis_Decls,
1674 Make_Subprogram_Declaration (Loc,
1675 Specification => Subp_Decl_Spec));
1677 -- A : constant System.Address;
1679 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1681 Append_To (Vis_Decls,
1682 Make_Object_Declaration (Loc,
1683 Defining_Identifier =>
1687 Object_Definition =>
1688 New_Occurrence_Of (RTE (RE_Address), Loc)));
1692 -- type subpP is tagged limited record
1693 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1697 Append_To (Pvt_Decls,
1698 Make_Full_Type_Declaration (Loc,
1699 Defining_Identifier =>
1700 Proxy_Type_Full_View,
1702 Build_Remote_Subprogram_Proxy_Type (Loc,
1703 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1705 -- Trick semantic analysis into swapping the public and full view when
1706 -- freezing the public view.
1708 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1711 -- (Self : access O;
1712 -- ...other-formals...) is
1714 -- P (...other-formals...);
1718 -- (Self : access O;
1719 -- ...other-formals...)
1722 -- return F (...other-formals...);
1725 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1727 Make_Procedure_Call_Statement (Loc,
1729 New_Occurrence_Of (Subp_Name, Loc),
1730 Parameter_Associations =>
1734 Make_Return_Statement (Loc,
1736 Make_Function_Call (Loc,
1738 New_Occurrence_Of (Subp_Name, Loc),
1739 Parameter_Associations =>
1743 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1744 pragma Assert (Present (Formal));
1747 exit when No (Formal);
1749 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1752 -- O : aliased subpP;
1754 Append_To (Pvt_Decls,
1755 Make_Object_Declaration (Loc,
1756 Defining_Identifier =>
1757 Make_Defining_Identifier (Loc,
1761 Object_Definition =>
1762 New_Occurrence_Of (Proxy_Type, Loc)));
1764 -- A : constant System.Address := O'Address;
1766 Append_To (Pvt_Decls,
1767 Make_Object_Declaration (Loc,
1768 Defining_Identifier =>
1769 Make_Defining_Identifier (Loc,
1770 Chars (Proxy_Object_Addr)),
1773 Object_Definition =>
1774 New_Occurrence_Of (RTE (RE_Address), Loc),
1776 Make_Attribute_Reference (Loc,
1777 Prefix => New_Occurrence_Of (
1778 Defining_Identifier (Last (Pvt_Decls)), Loc),
1783 Make_Package_Declaration (Loc,
1784 Specification => Make_Package_Specification (Loc,
1785 Defining_Unit_Name => Pkg_Name,
1786 Visible_Declarations => Vis_Decls,
1787 Private_Declarations => Pvt_Decls,
1788 End_Label => Empty)));
1789 Analyze (Last (Decls));
1792 Make_Package_Body (Loc,
1793 Defining_Unit_Name =>
1794 Make_Defining_Identifier (Loc,
1796 Declarations => New_List (
1797 Make_Subprogram_Body (Loc,
1800 Declarations => New_List,
1801 Handled_Statement_Sequence =>
1802 Make_Handled_Sequence_Of_Statements (Loc,
1803 Statements => New_List (Perform_Call))))));
1804 Analyze (Last (Decls));
1805 end Add_RAS_Proxy_And_Analyze;
1807 -----------------------
1808 -- Add_RAST_Features --
1809 -----------------------
1811 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1812 RAS_Type : constant Entity_Id :=
1813 Equivalent_Type (Defining_Identifier (Vis_Decl));
1815 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1816 Add_RAS_Dereference_TSS (Vis_Decl);
1817 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1818 end Add_RAST_Features;
1824 procedure Add_Stub_Type
1825 (Designated_Type : Entity_Id;
1826 RACW_Type : Entity_Id;
1828 Stub_Type : out Entity_Id;
1829 Stub_Type_Access : out Entity_Id;
1830 RPC_Receiver_Decl : out Node_Id;
1831 Body_Decls : out List_Id;
1832 Existing : out Boolean)
1834 Loc : constant Source_Ptr := Sloc (RACW_Type);
1836 Stub_Elements : constant Stub_Structure :=
1837 Stubs_Table.Get (Designated_Type);
1838 Stub_Type_Decl : Node_Id;
1839 Stub_Type_Access_Decl : Node_Id;
1842 if Stub_Elements /= Empty_Stub_Structure then
1843 Stub_Type := Stub_Elements.Stub_Type;
1844 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1845 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1846 Body_Decls := Stub_Elements.Body_Decls;
1853 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1855 Make_Defining_Identifier (Loc,
1857 Related_Id => Chars (Stub_Type),
1860 Specific_Build_Stub_Type (
1861 RACW_Type, Stub_Type,
1862 Stub_Type_Decl, RPC_Receiver_Decl);
1864 Stub_Type_Access_Decl :=
1865 Make_Full_Type_Declaration (Loc,
1866 Defining_Identifier => Stub_Type_Access,
1868 Make_Access_To_Object_Definition (Loc,
1869 All_Present => True,
1870 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1872 Append_To (Decls, Stub_Type_Decl);
1873 Analyze (Last (Decls));
1874 Append_To (Decls, Stub_Type_Access_Decl);
1875 Analyze (Last (Decls));
1877 -- This is in no way a type derivation, but we fake it to make sure that
1878 -- the dispatching table gets built with the corresponding primitive
1879 -- operations at the right place.
1881 Derive_Subprograms (Parent_Type => Designated_Type,
1882 Derived_Type => Stub_Type);
1884 if Present (RPC_Receiver_Decl) then
1885 Append_To (Decls, RPC_Receiver_Decl);
1887 RPC_Receiver_Decl := Last (Decls);
1890 Body_Decls := New_List;
1892 Stubs_Table.Set (Designated_Type,
1893 (Stub_Type => Stub_Type,
1894 Stub_Type_Access => Stub_Type_Access,
1895 RPC_Receiver_Decl => RPC_Receiver_Decl,
1896 Body_Decls => Body_Decls,
1897 RACW_Type => RACW_Type));
1900 ------------------------
1901 -- Append_RACW_Bodies --
1902 ------------------------
1904 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
1908 E := First_Entity (Spec_Id);
1909 while Present (E) loop
1910 if Is_Remote_Access_To_Class_Wide_Type (E) then
1911 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
1916 end Append_RACW_Bodies;
1918 ----------------------------------
1919 -- Assign_Subprogram_Identifier --
1920 ----------------------------------
1922 procedure Assign_Subprogram_Identifier
1927 N : constant Name_Id := Chars (Def);
1929 Overload_Order : constant Int :=
1930 Overload_Counter_Table.Get (N) + 1;
1933 Overload_Counter_Table.Set (N, Overload_Order);
1935 Get_Name_String (N);
1937 -- Homonym handling: as in Exp_Dbug, but much simpler,
1938 -- because the only entities for which we have to generate
1939 -- names here need only to be disambiguated within their
1942 if Overload_Order > 1 then
1943 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
1944 Name_Len := Name_Len + 2;
1945 Add_Nat_To_Name_Buffer (Overload_Order);
1948 Id := String_From_Name_Buffer;
1949 Subprogram_Identifier_Table.Set (Def,
1950 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
1951 end Assign_Subprogram_Identifier;
1953 -------------------------------------
1954 -- Build_Actual_Object_Declaration --
1955 -------------------------------------
1957 procedure Build_Actual_Object_Declaration
1958 (Object : Entity_Id;
1964 Loc : constant Source_Ptr := Sloc (Object);
1966 -- Declare a temporary object for the actual, possibly initialized with
1967 -- a 'Input/From_Any call.
1969 -- Complication arises in the case of limited types, for which such a
1970 -- declaration is illegal in Ada 95. In that case, we first generate a
1971 -- renaming declaration of the 'Input call, and then if needed we
1972 -- generate an overlaid non-constant view.
1974 if Ada_Version <= Ada_95
1975 and then Is_Limited_Type (Etyp)
1976 and then Present (Expr)
1979 -- Object : Etyp renames <func-call>
1982 Make_Object_Renaming_Declaration (Loc,
1983 Defining_Identifier => Object,
1984 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
1989 -- The name defined by the renaming declaration denotes a
1990 -- constant view; create a non-constant object at the same address
1991 -- to be used as the actual.
1994 Constant_Object : constant Entity_Id :=
1995 Make_Defining_Identifier (Loc,
1996 New_Internal_Name ('P'));
1998 Set_Defining_Identifier
1999 (Last (Decls), Constant_Object);
2001 -- We have an unconstrained Etyp: build the actual constrained
2002 -- subtype for the value we just read from the stream.
2004 -- suubtype S is <actual subtype of Constant_Object>;
2007 Build_Actual_Subtype (Etyp,
2008 New_Occurrence_Of (Constant_Object, Loc)));
2013 Make_Object_Declaration (Loc,
2014 Defining_Identifier => Object,
2015 Object_Definition =>
2017 (Defining_Identifier (Last (Decls)), Loc)));
2018 Set_Ekind (Object, E_Variable);
2020 -- Suppress default initialization:
2021 -- pragma Import (Ada, Object);
2025 Chars => Name_Import,
2026 Pragma_Argument_Associations => New_List (
2027 Make_Pragma_Argument_Association (Loc,
2028 Chars => Name_Convention,
2029 Expression => Make_Identifier (Loc, Name_Ada)),
2030 Make_Pragma_Argument_Association (Loc,
2031 Chars => Name_Entity,
2032 Expression => New_Occurrence_Of (Object, Loc)))));
2034 -- for Object'Address use Constant_Object'Address;
2037 Make_Attribute_Definition_Clause (Loc,
2038 Name => New_Occurrence_Of (Object, Loc),
2039 Chars => Name_Address,
2041 Make_Attribute_Reference (Loc,
2043 New_Occurrence_Of (Constant_Object, Loc),
2051 -- General case of a regular object declaration. Object is flagged
2052 -- constant unless it has mode out or in out, to allow the backend
2053 -- to optimize where possible.
2055 -- Object : [constant] Etyp [:= <expr>];
2058 Make_Object_Declaration (Loc,
2059 Defining_Identifier => Object,
2060 Constant_Present => Present (Expr) and then not Variable,
2061 Object_Definition =>
2062 New_Occurrence_Of (Etyp, Loc),
2063 Expression => Expr));
2065 if Constant_Present (Last (Decls)) then
2066 Set_Ekind (Object, E_Constant);
2068 Set_Ekind (Object, E_Variable);
2071 end Build_Actual_Object_Declaration;
2073 ------------------------------
2074 -- Build_Get_Unique_RP_Call --
2075 ------------------------------
2077 function Build_Get_Unique_RP_Call
2079 Pointer : Entity_Id;
2080 Stub_Type : Entity_Id) return List_Id
2084 Make_Procedure_Call_Statement (Loc,
2086 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2087 Parameter_Associations => New_List (
2088 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2089 New_Occurrence_Of (Pointer, Loc)))),
2091 Make_Assignment_Statement (Loc,
2093 Make_Selected_Component (Loc,
2095 New_Occurrence_Of (Pointer, Loc),
2097 New_Occurrence_Of (First_Tag_Component
2098 (Designated_Type (Etype (Pointer))), Loc)),
2100 Make_Attribute_Reference (Loc,
2102 New_Occurrence_Of (Stub_Type, Loc),
2106 -- Note: The assignment to Pointer._Tag is safe here because
2107 -- we carefully ensured that Stub_Type has exactly the same layout
2108 -- as System.Partition_Interface.RACW_Stub_Type.
2110 end Build_Get_Unique_RP_Call;
2112 -----------------------------------
2113 -- Build_Ordered_Parameters_List --
2114 -----------------------------------
2116 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2117 Constrained_List : List_Id;
2118 Unconstrained_List : List_Id;
2119 Current_Parameter : Node_Id;
2121 First_Parameter : Node_Id;
2122 For_RAS : Boolean := False;
2125 if No (Parameter_Specifications (Spec)) then
2129 Constrained_List := New_List;
2130 Unconstrained_List := New_List;
2131 First_Parameter := First (Parameter_Specifications (Spec));
2133 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2134 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2139 -- Loop through the parameters and add them to the right list
2141 Current_Parameter := First_Parameter;
2142 while Present (Current_Parameter) loop
2143 if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
2145 Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
2147 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
2148 and then not (For_RAS and then Current_Parameter = First_Parameter)
2150 Append_To (Constrained_List, New_Copy (Current_Parameter));
2152 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2155 Next (Current_Parameter);
2158 -- Unconstrained parameters are returned first
2160 Append_List_To (Unconstrained_List, Constrained_List);
2162 return Unconstrained_List;
2163 end Build_Ordered_Parameters_List;
2165 ----------------------------------
2166 -- Build_Passive_Partition_Stub --
2167 ----------------------------------
2169 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2171 Pkg_Name : String_Id;
2174 Loc : constant Source_Ptr := Sloc (U);
2177 -- Verify that the implementation supports distribution, by accessing
2178 -- a type defined in the proper version of system.rpc
2181 Dist_OK : Entity_Id;
2182 pragma Warnings (Off, Dist_OK);
2184 Dist_OK := RTE (RE_Params_Stream_Type);
2187 -- Use body if present, spec otherwise
2189 if Nkind (U) = N_Package_Declaration then
2190 Pkg_Spec := Specification (U);
2191 L := Visible_Declarations (Pkg_Spec);
2193 Pkg_Spec := Parent (Corresponding_Spec (U));
2194 L := Declarations (U);
2197 Get_Library_Unit_Name_String (Pkg_Spec);
2198 Pkg_Name := String_From_Name_Buffer;
2200 Make_Procedure_Call_Statement (Loc,
2202 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2203 Parameter_Associations => New_List (
2204 Make_String_Literal (Loc, Pkg_Name),
2205 Make_Attribute_Reference (Loc,
2207 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2212 end Build_Passive_Partition_Stub;
2214 --------------------------------------
2215 -- Build_RPC_Receiver_Specification --
2216 --------------------------------------
2218 function Build_RPC_Receiver_Specification
2219 (RPC_Receiver : Entity_Id;
2220 Request_Parameter : Entity_Id) return Node_Id
2222 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2225 Make_Procedure_Specification (Loc,
2226 Defining_Unit_Name => RPC_Receiver,
2227 Parameter_Specifications => New_List (
2228 Make_Parameter_Specification (Loc,
2229 Defining_Identifier => Request_Parameter,
2231 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2232 end Build_RPC_Receiver_Specification;
2234 ----------------------------------------
2235 -- Build_Remote_Subprogram_Proxy_Type --
2236 ----------------------------------------
2238 function Build_Remote_Subprogram_Proxy_Type
2240 ACR_Expression : Node_Id) return Node_Id
2244 Make_Record_Definition (Loc,
2245 Tagged_Present => True,
2246 Limited_Present => True,
2248 Make_Component_List (Loc,
2250 Component_Items => New_List (
2251 Make_Component_Declaration (Loc,
2252 Defining_Identifier =>
2253 Make_Defining_Identifier (Loc,
2254 Name_All_Calls_Remote),
2255 Component_Definition =>
2256 Make_Component_Definition (Loc,
2257 Subtype_Indication =>
2258 New_Occurrence_Of (Standard_Boolean, Loc)),
2262 Make_Component_Declaration (Loc,
2263 Defining_Identifier =>
2264 Make_Defining_Identifier (Loc,
2266 Component_Definition =>
2267 Make_Component_Definition (Loc,
2268 Subtype_Indication =>
2269 New_Occurrence_Of (RTE (RE_Address), Loc)),
2271 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2273 Make_Component_Declaration (Loc,
2274 Defining_Identifier =>
2275 Make_Defining_Identifier (Loc,
2277 Component_Definition =>
2278 Make_Component_Definition (Loc,
2279 Subtype_Indication =>
2280 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2281 end Build_Remote_Subprogram_Proxy_Type;
2283 ------------------------------------
2284 -- Build_Subprogram_Calling_Stubs --
2285 ------------------------------------
2287 function Build_Subprogram_Calling_Stubs
2288 (Vis_Decl : Node_Id;
2290 Asynchronous : Boolean;
2291 Dynamically_Asynchronous : Boolean := False;
2292 Stub_Type : Entity_Id := Empty;
2293 RACW_Type : Entity_Id := Empty;
2294 Locator : Entity_Id := Empty;
2295 New_Name : Name_Id := No_Name) return Node_Id
2297 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2299 Decls : constant List_Id := New_List;
2300 Statements : constant List_Id := New_List;
2302 Subp_Spec : Node_Id;
2303 -- The specification of the body
2305 Controlling_Parameter : Entity_Id := Empty;
2307 Asynchronous_Expr : Node_Id := Empty;
2309 RCI_Locator : Entity_Id;
2311 Spec_To_Use : Node_Id;
2313 procedure Insert_Partition_Check (Parameter : Node_Id);
2314 -- Check that the parameter has been elaborated on the same partition
2315 -- than the controlling parameter (E.4(19)).
2317 ----------------------------
2318 -- Insert_Partition_Check --
2319 ----------------------------
2321 procedure Insert_Partition_Check (Parameter : Node_Id) is
2322 Parameter_Entity : constant Entity_Id :=
2323 Defining_Identifier (Parameter);
2325 -- The expression that will be built is of the form:
2327 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2328 -- raise Constraint_Error;
2331 -- We do not check that Parameter is in Stub_Type since such a check
2332 -- has been inserted at the point of call already (a tag check since
2333 -- we have multiple controlling operands).
2336 Make_Raise_Constraint_Error (Loc,
2340 Make_Function_Call (Loc,
2342 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2343 Parameter_Associations =>
2345 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2346 New_Occurrence_Of (Parameter_Entity, Loc)),
2347 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2348 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2349 Reason => CE_Partition_Check_Failed));
2350 end Insert_Partition_Check;
2352 -- Start of processing for Build_Subprogram_Calling_Stubs
2355 Subp_Spec := Copy_Specification (Loc,
2356 Spec => Specification (Vis_Decl),
2357 New_Name => New_Name);
2359 if Locator = Empty then
2360 RCI_Locator := RCI_Cache;
2361 Spec_To_Use := Specification (Vis_Decl);
2363 RCI_Locator := Locator;
2364 Spec_To_Use := Subp_Spec;
2367 -- Find a controlling argument if we have a stub type. Also check
2368 -- if this subprogram can be made asynchronous.
2370 if Present (Stub_Type)
2371 and then Present (Parameter_Specifications (Spec_To_Use))
2374 Current_Parameter : Node_Id :=
2375 First (Parameter_Specifications
2378 while Present (Current_Parameter) loop
2380 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2382 if Controlling_Parameter = Empty then
2383 Controlling_Parameter :=
2384 Defining_Identifier (Current_Parameter);
2386 Insert_Partition_Check (Current_Parameter);
2390 Next (Current_Parameter);
2395 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2397 if Dynamically_Asynchronous then
2398 Asynchronous_Expr := Make_Selected_Component (Loc,
2399 Prefix => Controlling_Parameter,
2400 Selector_Name => Name_Asynchronous);
2403 Specific_Build_General_Calling_Stubs
2405 Statements => Statements,
2406 Target => Specific_Build_Stub_Target (Loc,
2407 Decls, RCI_Locator, Controlling_Parameter),
2408 Subprogram_Id => Subp_Id,
2409 Asynchronous => Asynchronous_Expr,
2410 Is_Known_Asynchronous => Asynchronous
2411 and then not Dynamically_Asynchronous,
2412 Is_Known_Non_Asynchronous
2414 and then not Dynamically_Asynchronous,
2415 Is_Function => Nkind (Spec_To_Use) =
2416 N_Function_Specification,
2417 Spec => Spec_To_Use,
2418 Stub_Type => Stub_Type,
2419 RACW_Type => RACW_Type,
2422 RCI_Calling_Stubs_Table.Set
2423 (Defining_Unit_Name (Specification (Vis_Decl)),
2424 Defining_Unit_Name (Spec_To_Use));
2427 Make_Subprogram_Body (Loc,
2428 Specification => Subp_Spec,
2429 Declarations => Decls,
2430 Handled_Statement_Sequence =>
2431 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2432 end Build_Subprogram_Calling_Stubs;
2434 -------------------------
2435 -- Build_Subprogram_Id --
2436 -------------------------
2438 function Build_Subprogram_Id
2440 E : Entity_Id) return Node_Id
2443 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2445 Current_Declaration : Node_Id;
2446 Current_Subp : Entity_Id;
2447 Current_Subp_Str : String_Id;
2448 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2451 -- Build_Subprogram_Id is called outside of the context of
2452 -- generating calling or receiving stubs. Hence we are processing
2453 -- an 'Access attribute_reference for an RCI subprogram, for the
2454 -- purpose of obtaining a RAS value.
2457 (Is_Remote_Call_Interface (Scope (E))
2459 (Nkind (Parent (E)) = N_Procedure_Specification
2461 Nkind (Parent (E)) = N_Function_Specification));
2463 Current_Declaration :=
2464 First (Visible_Declarations
2465 (Package_Specification_Of_Scope (Scope (E))));
2466 while Present (Current_Declaration) loop
2467 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2468 and then Comes_From_Source (Current_Declaration)
2470 Current_Subp := Defining_Unit_Name (Specification (
2471 Current_Declaration));
2473 Assign_Subprogram_Identifier
2474 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2476 Current_Subp_Number := Current_Subp_Number + 1;
2479 Next (Current_Declaration);
2484 case Get_PCS_Name is
2485 when Name_PolyORB_DSA =>
2486 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2488 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2490 end Build_Subprogram_Id;
2492 ------------------------
2493 -- Copy_Specification --
2494 ------------------------
2496 function Copy_Specification
2499 Ctrl_Type : Entity_Id := Empty;
2500 New_Name : Name_Id := No_Name) return Node_Id
2502 Parameters : List_Id := No_List;
2504 Current_Parameter : Node_Id;
2505 Current_Identifier : Entity_Id;
2506 Current_Type : Node_Id;
2508 Name_For_New_Spec : Name_Id;
2510 New_Identifier : Entity_Id;
2512 -- Comments needed in body below ???
2515 if New_Name = No_Name then
2516 pragma Assert (Nkind (Spec) = N_Function_Specification
2517 or else Nkind (Spec) = N_Procedure_Specification);
2519 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2521 Name_For_New_Spec := New_Name;
2524 if Present (Parameter_Specifications (Spec)) then
2525 Parameters := New_List;
2526 Current_Parameter := First (Parameter_Specifications (Spec));
2527 while Present (Current_Parameter) loop
2528 Current_Identifier := Defining_Identifier (Current_Parameter);
2529 Current_Type := Parameter_Type (Current_Parameter);
2531 if Nkind (Current_Type) = N_Access_Definition then
2532 if Present (Ctrl_Type) then
2533 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2535 Make_Access_Definition (Loc,
2536 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2537 Null_Exclusion_Present =>
2538 Null_Exclusion_Present (Current_Type));
2542 Make_Access_Definition (Loc,
2544 New_Copy_Tree (Subtype_Mark (Current_Type)),
2545 Null_Exclusion_Present =>
2546 Null_Exclusion_Present (Current_Type));
2550 if Present (Ctrl_Type)
2551 and then Is_Controlling_Formal (Current_Identifier)
2553 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2555 Current_Type := New_Copy_Tree (Current_Type);
2559 New_Identifier := Make_Defining_Identifier (Loc,
2560 Chars (Current_Identifier));
2562 Append_To (Parameters,
2563 Make_Parameter_Specification (Loc,
2564 Defining_Identifier => New_Identifier,
2565 Parameter_Type => Current_Type,
2566 In_Present => In_Present (Current_Parameter),
2567 Out_Present => Out_Present (Current_Parameter),
2569 New_Copy_Tree (Expression (Current_Parameter))));
2571 -- For a regular formal parameter (that needs to be marshalled
2572 -- in the context of remote calls), set the Etype now, because
2573 -- marshalling processing might need it.
2575 if Is_Entity_Name (Current_Type) then
2576 Set_Etype (New_Identifier, Entity (Current_Type));
2578 -- Current_Type is an access definition, special processing
2579 -- (not requiring etype) will occur for marshalling.
2585 Next (Current_Parameter);
2589 case Nkind (Spec) is
2591 when N_Function_Specification | N_Access_Function_Definition =>
2593 Make_Function_Specification (Loc,
2594 Defining_Unit_Name =>
2595 Make_Defining_Identifier (Loc,
2596 Chars => Name_For_New_Spec),
2597 Parameter_Specifications => Parameters,
2598 Result_Definition =>
2599 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2601 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2603 Make_Procedure_Specification (Loc,
2604 Defining_Unit_Name =>
2605 Make_Defining_Identifier (Loc,
2606 Chars => Name_For_New_Spec),
2607 Parameter_Specifications => Parameters);
2610 raise Program_Error;
2612 end Copy_Specification;
2614 -----------------------------
2615 -- Corresponding_Stub_Type --
2616 -----------------------------
2618 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2619 Desig : constant Entity_Id :=
2620 Etype (Designated_Type (RACW_Type));
2621 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2623 return Stub_Elements.Stub_Type;
2624 end Corresponding_Stub_Type;
2626 ---------------------------
2627 -- Could_Be_Asynchronous --
2628 ---------------------------
2630 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2631 Current_Parameter : Node_Id;
2634 if Present (Parameter_Specifications (Spec)) then
2635 Current_Parameter := First (Parameter_Specifications (Spec));
2636 while Present (Current_Parameter) loop
2637 if Out_Present (Current_Parameter) then
2641 Next (Current_Parameter);
2646 end Could_Be_Asynchronous;
2648 ---------------------------
2649 -- Declare_Create_NVList --
2650 ---------------------------
2652 procedure Declare_Create_NVList
2660 Make_Object_Declaration (Loc,
2661 Defining_Identifier => NVList,
2662 Aliased_Present => False,
2663 Object_Definition =>
2664 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2667 Make_Procedure_Call_Statement (Loc,
2669 New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2670 Parameter_Associations => New_List (
2671 New_Occurrence_Of (NVList, Loc))));
2672 end Declare_Create_NVList;
2674 ---------------------------------------------
2675 -- Expand_All_Calls_Remote_Subprogram_Call --
2676 ---------------------------------------------
2678 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2679 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2680 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2681 Loc : constant Source_Ptr := Sloc (N);
2682 RCI_Locator : Node_Id;
2683 RCI_Cache : Entity_Id;
2684 Calling_Stubs : Node_Id;
2685 E_Calling_Stubs : Entity_Id;
2688 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2690 if E_Calling_Stubs = Empty then
2691 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2693 if RCI_Cache = Empty then
2696 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2697 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2699 -- The RCI_Locator package is inserted at the top level in the
2700 -- current unit, and must appear in the proper scope, so that it
2701 -- is not prematurely removed by the GCC back-end.
2704 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2707 if Ekind (Scop) = E_Package_Body then
2708 New_Scope (Spec_Entity (Scop));
2710 elsif Ekind (Scop) = E_Subprogram_Body then
2712 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2718 Analyze (RCI_Locator);
2722 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2725 RCI_Locator := Parent (RCI_Cache);
2728 Calling_Stubs := Build_Subprogram_Calling_Stubs
2729 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2731 Build_Subprogram_Id (Loc, Called_Subprogram),
2732 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2734 Is_Asynchronous (Called_Subprogram),
2735 Locator => RCI_Cache,
2736 New_Name => New_Internal_Name ('S'));
2737 Insert_After (RCI_Locator, Calling_Stubs);
2738 Analyze (Calling_Stubs);
2739 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2742 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2743 end Expand_All_Calls_Remote_Subprogram_Call;
2745 ---------------------------------
2746 -- Expand_Calling_Stubs_Bodies --
2747 ---------------------------------
2749 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2750 Spec : constant Node_Id := Specification (Unit_Node);
2751 Decls : constant List_Id := Visible_Declarations (Spec);
2753 New_Scope (Scope_Of_Spec (Spec));
2754 Add_Calling_Stubs_To_Declarations
2755 (Specification (Unit_Node), Decls);
2757 end Expand_Calling_Stubs_Bodies;
2759 -----------------------------------
2760 -- Expand_Receiving_Stubs_Bodies --
2761 -----------------------------------
2763 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2769 if Nkind (Unit_Node) = N_Package_Declaration then
2770 Spec := Specification (Unit_Node);
2771 Decls := Private_Declarations (Spec);
2774 Decls := Visible_Declarations (Spec);
2777 New_Scope (Scope_Of_Spec (Spec));
2778 Specific_Add_Receiving_Stubs_To_Declarations
2779 (Spec, Decls, Decls);
2782 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2783 Decls := Declarations (Unit_Node);
2785 New_Scope (Scope_Of_Spec (Unit_Node));
2787 Specific_Add_Receiving_Stubs_To_Declarations
2788 (Spec, Temp, Statements (Handled_Statement_Sequence (Unit_Node)));
2789 Insert_List_Before (First (Decls), Temp);
2793 end Expand_Receiving_Stubs_Bodies;
2795 --------------------
2796 -- GARLIC_Support --
2797 --------------------
2799 package body GARLIC_Support is
2801 -- Local subprograms
2803 procedure Add_RACW_Read_Attribute
2804 (RACW_Type : Entity_Id;
2805 Stub_Type : Entity_Id;
2806 Stub_Type_Access : Entity_Id;
2807 Body_Decls : List_Id);
2808 -- Add Read attribute for the RACW type. The declaration and attribute
2809 -- definition clauses are inserted right after the declaration of
2810 -- RACW_Type, while the subprogram body is appended to Body_Decls.
2812 procedure Add_RACW_Write_Attribute
2813 (RACW_Type : Entity_Id;
2814 Stub_Type : Entity_Id;
2815 Stub_Type_Access : Entity_Id;
2816 RPC_Receiver : Node_Id;
2817 Body_Decls : List_Id);
2818 -- Same as above for the Write attribute
2820 function Stream_Parameter return Node_Id;
2821 function Result return Node_Id;
2822 function Object return Node_Id renames Result;
2823 -- Functions to create occurrences of the formal parameter names of the
2824 -- 'Read and 'Write attributes.
2827 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2828 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2830 procedure Add_RAS_Access_TSS (N : Node_Id);
2831 -- Add a subprogram body for RAS Access TSS
2833 -------------------------------------
2834 -- Add_Obj_RPC_Receiver_Completion --
2835 -------------------------------------
2837 procedure Add_Obj_RPC_Receiver_Completion
2840 RPC_Receiver : Entity_Id;
2841 Stub_Elements : Stub_Structure) is
2843 -- The RPC receiver body should not be the completion of the
2844 -- declaration recorded in the stub structure, because then the
2845 -- occurrences of the formal parameters within the body should refer
2846 -- to the entities from the declaration, not from the completion, to
2847 -- which we do not have easy access. Instead, the RPC receiver body
2848 -- acts as its own declaration, and the RPC receiver declaration is
2849 -- completed by a renaming-as-body.
2852 Make_Subprogram_Renaming_Declaration (Loc,
2854 Copy_Specification (Loc,
2855 Specification (Stub_Elements.RPC_Receiver_Decl)),
2856 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2857 end Add_Obj_RPC_Receiver_Completion;
2859 -----------------------
2860 -- Add_RACW_Features --
2861 -----------------------
2863 procedure Add_RACW_Features
2864 (RACW_Type : Entity_Id;
2865 Stub_Type : Entity_Id;
2866 Stub_Type_Access : Entity_Id;
2867 RPC_Receiver_Decl : Node_Id;
2868 Body_Decls : List_Id)
2870 RPC_Receiver : Node_Id;
2871 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2874 Loc := Sloc (RACW_Type);
2878 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2879 -- of the corresponding distributed object type. We retrieve its
2880 -- address from the local proxy object.
2882 RPC_Receiver := Make_Selected_Component (Loc,
2884 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2885 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2888 RPC_Receiver := Make_Attribute_Reference (Loc,
2889 Prefix => New_Occurrence_Of (
2890 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2891 Attribute_Name => Name_Address);
2894 Add_RACW_Write_Attribute (
2901 Add_RACW_Read_Attribute (
2906 end Add_RACW_Features;
2908 -----------------------------
2909 -- Add_RACW_Read_Attribute --
2910 -----------------------------
2912 procedure Add_RACW_Read_Attribute
2913 (RACW_Type : Entity_Id;
2914 Stub_Type : Entity_Id;
2915 Stub_Type_Access : Entity_Id;
2916 Body_Decls : List_Id)
2918 Proc_Decl : Node_Id;
2919 Attr_Decl : Node_Id;
2921 Body_Node : Node_Id;
2924 Statements : List_Id;
2925 Local_Statements : List_Id;
2926 Remote_Statements : List_Id;
2927 -- Various parts of the procedure
2929 Procedure_Name : constant Name_Id :=
2930 New_Internal_Name ('R');
2931 Source_Partition : constant Entity_Id :=
2932 Make_Defining_Identifier
2933 (Loc, New_Internal_Name ('P'));
2934 Source_Receiver : constant Entity_Id :=
2935 Make_Defining_Identifier
2936 (Loc, New_Internal_Name ('S'));
2937 Source_Address : constant Entity_Id :=
2938 Make_Defining_Identifier
2939 (Loc, New_Internal_Name ('P'));
2940 Local_Stub : constant Entity_Id :=
2941 Make_Defining_Identifier
2942 (Loc, New_Internal_Name ('L'));
2943 Stubbed_Result : constant Entity_Id :=
2944 Make_Defining_Identifier
2945 (Loc, New_Internal_Name ('S'));
2946 Asynchronous_Flag : constant Entity_Id :=
2947 Asynchronous_Flags_Table.Get (RACW_Type);
2948 pragma Assert (Present (Asynchronous_Flag));
2950 -- Start of processing for Add_RACW_Read_Attribute
2953 -- Generate object declarations
2956 Make_Object_Declaration (Loc,
2957 Defining_Identifier => Source_Partition,
2958 Object_Definition =>
2959 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
2961 Make_Object_Declaration (Loc,
2962 Defining_Identifier => Source_Receiver,
2963 Object_Definition =>
2964 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2966 Make_Object_Declaration (Loc,
2967 Defining_Identifier => Source_Address,
2968 Object_Definition =>
2969 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2971 Make_Object_Declaration (Loc,
2972 Defining_Identifier => Local_Stub,
2973 Aliased_Present => True,
2974 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
2976 Make_Object_Declaration (Loc,
2977 Defining_Identifier => Stubbed_Result,
2978 Object_Definition =>
2979 New_Occurrence_Of (Stub_Type_Access, Loc),
2981 Make_Attribute_Reference (Loc,
2983 New_Occurrence_Of (Local_Stub, Loc),
2985 Name_Unchecked_Access)));
2987 -- Read the source Partition_ID and RPC_Receiver from incoming stream
2989 Statements := New_List (
2990 Make_Attribute_Reference (Loc,
2992 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
2993 Attribute_Name => Name_Read,
2994 Expressions => New_List (
2996 New_Occurrence_Of (Source_Partition, Loc))),
2998 Make_Attribute_Reference (Loc,
3000 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3003 Expressions => New_List (
3005 New_Occurrence_Of (Source_Receiver, Loc))),
3007 Make_Attribute_Reference (Loc,
3009 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3012 Expressions => New_List (
3014 New_Occurrence_Of (Source_Address, Loc))));
3016 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3018 Set_Etype (Stubbed_Result, Stub_Type_Access);
3020 -- If the Address is Null_Address, then return a null object
3022 Append_To (Statements,
3023 Make_Implicit_If_Statement (RACW_Type,
3026 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3027 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3028 Then_Statements => New_List (
3029 Make_Assignment_Statement (Loc,
3031 Expression => Make_Null (Loc)),
3032 Make_Return_Statement (Loc))));
3034 -- If the RACW denotes an object created on the current partition,
3035 -- Local_Statements will be executed. The real object will be used.
3037 Local_Statements := New_List (
3038 Make_Assignment_Statement (Loc,
3041 Unchecked_Convert_To (RACW_Type,
3042 OK_Convert_To (RTE (RE_Address),
3043 New_Occurrence_Of (Source_Address, Loc)))));
3045 -- If the object is located on another partition, then a stub object
3046 -- will be created with all the information needed to rebuild the
3047 -- real object at the other end.
3049 Remote_Statements := New_List (
3051 Make_Assignment_Statement (Loc,
3052 Name => Make_Selected_Component (Loc,
3053 Prefix => Stubbed_Result,
3054 Selector_Name => Name_Origin),
3056 New_Occurrence_Of (Source_Partition, Loc)),
3058 Make_Assignment_Statement (Loc,
3059 Name => Make_Selected_Component (Loc,
3060 Prefix => Stubbed_Result,
3061 Selector_Name => Name_Receiver),
3063 New_Occurrence_Of (Source_Receiver, Loc)),
3065 Make_Assignment_Statement (Loc,
3066 Name => Make_Selected_Component (Loc,
3067 Prefix => Stubbed_Result,
3068 Selector_Name => Name_Addr),
3070 New_Occurrence_Of (Source_Address, Loc)));
3072 Append_To (Remote_Statements,
3073 Make_Assignment_Statement (Loc,
3074 Name => Make_Selected_Component (Loc,
3075 Prefix => Stubbed_Result,
3076 Selector_Name => Name_Asynchronous),
3078 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3080 Append_List_To (Remote_Statements,
3081 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3082 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3083 -- set on the stub type if, and only if, the RACW type has a pragma
3084 -- Asynchronous. This is incorrect for RACWs that implement RAS
3085 -- types, because in that case the /designated subprogram/ (not the
3086 -- type) might be asynchronous, and that causes the stub to need to
3087 -- be asynchronous too. A solution is to transport a RAS as a struct
3088 -- containing a RACW and an asynchronous flag, and to properly alter
3089 -- the Asynchronous component in the stub type in the RAS's Input
3092 Append_To (Remote_Statements,
3093 Make_Assignment_Statement (Loc,
3095 Expression => Unchecked_Convert_To (RACW_Type,
3096 New_Occurrence_Of (Stubbed_Result, Loc))));
3098 -- Distinguish between the local and remote cases, and execute the
3099 -- appropriate piece of code.
3101 Append_To (Statements,
3102 Make_Implicit_If_Statement (RACW_Type,
3106 Make_Function_Call (Loc,
3107 Name => New_Occurrence_Of (
3108 RTE (RE_Get_Local_Partition_Id), Loc)),
3109 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3110 Then_Statements => Local_Statements,
3111 Else_Statements => Remote_Statements));
3113 Build_Stream_Procedure
3114 (Loc, RACW_Type, Body_Node,
3115 Make_Defining_Identifier (Loc, Procedure_Name),
3116 Statements, Outp => True);
3117 Set_Declarations (Body_Node, Decls);
3119 Proc_Decl := Make_Subprogram_Declaration (Loc,
3120 Copy_Specification (Loc, Specification (Body_Node)));
3123 Make_Attribute_Definition_Clause (Loc,
3124 Name => New_Occurrence_Of (RACW_Type, Loc),
3128 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3130 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3131 Insert_After (Proc_Decl, Attr_Decl);
3132 Append_To (Body_Decls, Body_Node);
3133 end Add_RACW_Read_Attribute;
3135 ------------------------------
3136 -- Add_RACW_Write_Attribute --
3137 ------------------------------
3139 procedure Add_RACW_Write_Attribute
3140 (RACW_Type : Entity_Id;
3141 Stub_Type : Entity_Id;
3142 Stub_Type_Access : Entity_Id;
3143 RPC_Receiver : Node_Id;
3144 Body_Decls : List_Id)
3146 Body_Node : Node_Id;
3147 Proc_Decl : Node_Id;
3148 Attr_Decl : Node_Id;
3150 Statements : List_Id;
3151 Local_Statements : List_Id;
3152 Remote_Statements : List_Id;
3153 Null_Statements : List_Id;
3155 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
3158 -- Build the code fragment corresponding to the marshalling of a
3161 Local_Statements := New_List (
3163 Pack_Entity_Into_Stream_Access (Loc,
3164 Stream => Stream_Parameter,
3165 Object => RTE (RE_Get_Local_Partition_Id)),
3167 Pack_Node_Into_Stream_Access (Loc,
3168 Stream => Stream_Parameter,
3169 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3170 Etyp => RTE (RE_Unsigned_64)),
3172 Pack_Node_Into_Stream_Access (Loc,
3173 Stream => Stream_Parameter,
3174 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3175 Make_Attribute_Reference (Loc,
3177 Make_Explicit_Dereference (Loc,
3179 Attribute_Name => Name_Address)),
3180 Etyp => RTE (RE_Unsigned_64)));
3182 -- Build the code fragment corresponding to the marshalling of
3185 Remote_Statements := New_List (
3187 Pack_Node_Into_Stream_Access (Loc,
3188 Stream => Stream_Parameter,
3190 Make_Selected_Component (Loc,
3191 Prefix => Unchecked_Convert_To (Stub_Type_Access,
3194 Make_Identifier (Loc, Name_Origin)),
3195 Etyp => RTE (RE_Partition_ID)),
3197 Pack_Node_Into_Stream_Access (Loc,
3198 Stream => Stream_Parameter,
3200 Make_Selected_Component (Loc,
3201 Prefix => Unchecked_Convert_To (Stub_Type_Access,
3204 Make_Identifier (Loc, Name_Receiver)),
3205 Etyp => RTE (RE_Unsigned_64)),
3207 Pack_Node_Into_Stream_Access (Loc,
3208 Stream => Stream_Parameter,
3210 Make_Selected_Component (Loc,
3211 Prefix => Unchecked_Convert_To (Stub_Type_Access,
3214 Make_Identifier (Loc, Name_Addr)),
3215 Etyp => RTE (RE_Unsigned_64)));
3217 -- Build code fragment corresponding to marshalling of a null object
3219 Null_Statements := New_List (
3221 Pack_Entity_Into_Stream_Access (Loc,
3222 Stream => Stream_Parameter,
3223 Object => RTE (RE_Get_Local_Partition_Id)),
3225 Pack_Node_Into_Stream_Access (Loc,
3226 Stream => Stream_Parameter,
3227 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3228 Etyp => RTE (RE_Unsigned_64)),
3230 Pack_Node_Into_Stream_Access (Loc,
3231 Stream => Stream_Parameter,
3232 Object => Make_Integer_Literal (Loc, Uint_0),
3233 Etyp => RTE (RE_Unsigned_64)));
3235 Statements := New_List (
3236 Make_Implicit_If_Statement (RACW_Type,
3239 Left_Opnd => Object,
3240 Right_Opnd => Make_Null (Loc)),
3241 Then_Statements => Null_Statements,
3242 Elsif_Parts => New_List (
3243 Make_Elsif_Part (Loc,
3247 Make_Attribute_Reference (Loc,
3249 Attribute_Name => Name_Tag),
3251 Make_Attribute_Reference (Loc,
3252 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3253 Attribute_Name => Name_Tag)),
3254 Then_Statements => Remote_Statements)),
3255 Else_Statements => Local_Statements));
3257 Build_Stream_Procedure
3258 (Loc, RACW_Type, Body_Node,
3259 Make_Defining_Identifier (Loc, Procedure_Name),
3260 Statements, Outp => False);
3262 Proc_Decl := Make_Subprogram_Declaration (Loc,
3263 Copy_Specification (Loc, Specification (Body_Node)));
3266 Make_Attribute_Definition_Clause (Loc,
3267 Name => New_Occurrence_Of (RACW_Type, Loc),
3268 Chars => Name_Write,
3271 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3273 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3274 Insert_After (Proc_Decl, Attr_Decl);
3275 Append_To (Body_Decls, Body_Node);
3276 end Add_RACW_Write_Attribute;
3278 ------------------------
3279 -- Add_RAS_Access_TSS --
3280 ------------------------
3282 procedure Add_RAS_Access_TSS (N : Node_Id) is
3283 Loc : constant Source_Ptr := Sloc (N);
3285 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3286 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3287 -- Ras_Type is the access to subprogram type while Fat_Type is the
3288 -- corresponding record type.
3290 RACW_Type : constant Entity_Id :=
3291 Underlying_RACW_Type (Ras_Type);
3292 Desig : constant Entity_Id :=
3293 Etype (Designated_Type (RACW_Type));
3295 Stub_Elements : constant Stub_Structure :=
3296 Stubs_Table.Get (Desig);
3297 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3299 Proc : constant Entity_Id :=
3300 Make_Defining_Identifier (Loc,
3301 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3303 Proc_Spec : Node_Id;
3305 -- Formal parameters
3307 Package_Name : constant Entity_Id :=
3308 Make_Defining_Identifier (Loc,
3312 Subp_Id : constant Entity_Id :=
3313 Make_Defining_Identifier (Loc,
3315 -- Target subprogram
3317 Asynch_P : constant Entity_Id :=
3318 Make_Defining_Identifier (Loc,
3319 Chars => Name_Asynchronous);
3320 -- Is the procedure to which the 'Access applies asynchronous?
3322 All_Calls_Remote : constant Entity_Id :=
3323 Make_Defining_Identifier (Loc,
3324 Chars => Name_All_Calls_Remote);
3325 -- True if an All_Calls_Remote pragma applies to the RCI unit
3326 -- that contains the subprogram.
3328 -- Common local variables
3330 Proc_Decls : List_Id;
3331 Proc_Statements : List_Id;
3333 Origin : constant Entity_Id :=
3334 Make_Defining_Identifier (Loc,
3335 Chars => New_Internal_Name ('P'));
3337 -- Additional local variables for the local case
3339 Proxy_Addr : constant Entity_Id :=
3340 Make_Defining_Identifier (Loc,
3341 Chars => New_Internal_Name ('P'));
3343 -- Additional local variables for the remote case
3345 Local_Stub : constant Entity_Id :=
3346 Make_Defining_Identifier (Loc,
3347 Chars => New_Internal_Name ('L'));
3349 Stub_Ptr : constant Entity_Id :=
3350 Make_Defining_Identifier (Loc,
3351 Chars => New_Internal_Name ('S'));
3354 (Field_Name : Name_Id;
3355 Value : Node_Id) return Node_Id;
3356 -- Construct an assignment that sets the named component in the
3364 (Field_Name : Name_Id;
3365 Value : Node_Id) return Node_Id
3369 Make_Assignment_Statement (Loc,
3371 Make_Selected_Component (Loc,
3373 Selector_Name => Field_Name),
3374 Expression => Value);
3377 -- Start of processing for Add_RAS_Access_TSS
3380 Proc_Decls := New_List (
3382 -- Common declarations
3384 Make_Object_Declaration (Loc,
3385 Defining_Identifier => Origin,
3386 Constant_Present => True,
3387 Object_Definition =>
3388 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3390 Make_Function_Call (Loc,
3392 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3393 Parameter_Associations => New_List (
3394 New_Occurrence_Of (Package_Name, Loc)))),
3396 -- Declaration use only in the local case: proxy address
3398 Make_Object_Declaration (Loc,
3399 Defining_Identifier => Proxy_Addr,
3400 Object_Definition =>
3401 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3403 -- Declarations used only in the remote case: stub object and
3406 Make_Object_Declaration (Loc,
3407 Defining_Identifier => Local_Stub,
3408 Aliased_Present => True,
3409 Object_Definition =>
3410 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3412 Make_Object_Declaration (Loc,
3413 Defining_Identifier =>
3415 Object_Definition =>
3416 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3418 Make_Attribute_Reference (Loc,
3419 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3420 Attribute_Name => Name_Unchecked_Access)));
3422 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3423 -- Build_Get_Unique_RP_Call needs this information
3425 -- Note: Here we assume that the Fat_Type is a record
3426 -- containing just a pointer to a proxy or stub object.
3428 Proc_Statements := New_List (
3432 -- Get_RAS_Info (Pkg, Subp, PA);
3433 -- if Origin = Local_Partition_Id
3434 -- and then not All_Calls_Remote
3436 -- return Fat_Type!(PA);
3439 Make_Procedure_Call_Statement (Loc,
3441 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3442 Parameter_Associations => New_List (
3443 New_Occurrence_Of (Package_Name, Loc),
3444 New_Occurrence_Of (Subp_Id, Loc),
3445 New_Occurrence_Of (Proxy_Addr, Loc))),
3447 Make_Implicit_If_Statement (N,
3453 New_Occurrence_Of (Origin, Loc),
3455 Make_Function_Call (Loc,
3457 RTE (RE_Get_Local_Partition_Id), Loc))),
3460 New_Occurrence_Of (All_Calls_Remote, Loc))),
3461 Then_Statements => New_List (
3462 Make_Return_Statement (Loc,
3463 Unchecked_Convert_To (Fat_Type,
3464 OK_Convert_To (RTE (RE_Address),
3465 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3467 Set_Field (Name_Origin,
3468 New_Occurrence_Of (Origin, Loc)),
3470 Set_Field (Name_Receiver,
3471 Make_Function_Call (Loc,
3473 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3474 Parameter_Associations => New_List (
3475 New_Occurrence_Of (Package_Name, Loc)))),
3477 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3479 -- E.4.1(9) A remote call is asynchronous if it is a call to
3480 -- a procedure, or a call through a value of an access-to-procedure
3481 -- type, to which a pragma Asynchronous applies.
3483 -- Parameter Asynch_P is true when the procedure is asynchronous;
3484 -- Expression Asynch_T is true when the type is asynchronous.
3486 Set_Field (Name_Asynchronous,
3488 New_Occurrence_Of (Asynch_P, Loc),
3489 New_Occurrence_Of (Boolean_Literals (
3490 Is_Asynchronous (Ras_Type)), Loc))));
3492 Append_List_To (Proc_Statements,
3493 Build_Get_Unique_RP_Call
3494 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3496 -- Return the newly created value
3498 Append_To (Proc_Statements,
3499 Make_Return_Statement (Loc,
3501 Unchecked_Convert_To (Fat_Type,
3502 New_Occurrence_Of (Stub_Ptr, Loc))));
3505 Make_Function_Specification (Loc,
3506 Defining_Unit_Name => Proc,
3507 Parameter_Specifications => New_List (
3508 Make_Parameter_Specification (Loc,
3509 Defining_Identifier => Package_Name,
3511 New_Occurrence_Of (Standard_String, Loc)),
3513 Make_Parameter_Specification (Loc,
3514 Defining_Identifier => Subp_Id,
3516 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3518 Make_Parameter_Specification (Loc,
3519 Defining_Identifier => Asynch_P,
3521 New_Occurrence_Of (Standard_Boolean, Loc)),
3523 Make_Parameter_Specification (Loc,
3524 Defining_Identifier => All_Calls_Remote,
3526 New_Occurrence_Of (Standard_Boolean, Loc))),
3528 Result_Definition =>
3529 New_Occurrence_Of (Fat_Type, Loc));
3531 -- Set the kind and return type of the function to prevent
3532 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3534 Set_Ekind (Proc, E_Function);
3535 Set_Etype (Proc, Fat_Type);
3538 Make_Subprogram_Body (Loc,
3539 Specification => Proc_Spec,
3540 Declarations => Proc_Decls,
3541 Handled_Statement_Sequence =>
3542 Make_Handled_Sequence_Of_Statements (Loc,
3543 Statements => Proc_Statements)));
3545 Set_TSS (Fat_Type, Proc);
3546 end Add_RAS_Access_TSS;
3548 -----------------------
3549 -- Add_RAST_Features --
3550 -----------------------
3552 procedure Add_RAST_Features
3553 (Vis_Decl : Node_Id;
3554 RAS_Type : Entity_Id)
3556 pragma Warnings (Off);
3557 pragma Unreferenced (RAS_Type);
3558 pragma Warnings (On);
3560 Add_RAS_Access_TSS (Vis_Decl);
3561 end Add_RAST_Features;
3563 -----------------------------------------
3564 -- Add_Receiving_Stubs_To_Declarations --
3565 -----------------------------------------
3567 procedure Add_Receiving_Stubs_To_Declarations
3568 (Pkg_Spec : Node_Id;
3572 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3574 Request_Parameter : Node_Id;
3576 Pkg_RPC_Receiver : constant Entity_Id :=
3577 Make_Defining_Identifier (Loc,
3578 New_Internal_Name ('H'));
3579 Pkg_RPC_Receiver_Statements : List_Id;
3580 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3581 Pkg_RPC_Receiver_Body : Node_Id;
3582 -- A Pkg_RPC_Receiver is built to decode the request
3584 Lookup_RAS_Info : constant Entity_Id :=
3585 Make_Defining_Identifier (Loc,
3586 Chars => New_Internal_Name ('R'));
3587 -- A remote subprogram is created to allow peers to look up
3588 -- RAS information using subprogram ids.
3590 Subp_Id : Entity_Id;
3591 Subp_Index : Entity_Id;
3592 -- Subprogram_Id as read from the incoming stream
3594 Current_Declaration : Node_Id;
3595 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3596 Current_Stubs : Node_Id;
3598 Subp_Info_Array : constant Entity_Id :=
3599 Make_Defining_Identifier (Loc,
3600 Chars => New_Internal_Name ('I'));
3602 Subp_Info_List : constant List_Id := New_List;
3604 Register_Pkg_Actuals : constant List_Id := New_List;
3606 All_Calls_Remote_E : Entity_Id;
3607 Proxy_Object_Addr : Entity_Id;
3609 procedure Append_Stubs_To
3610 (RPC_Receiver_Cases : List_Id;
3612 Subprogram_Number : Int);
3613 -- Add one case to the specified RPC receiver case list
3614 -- associating Subprogram_Number with the subprogram declared
3615 -- by Declaration, for which we have receiving stubs in Stubs.
3617 ---------------------
3618 -- Append_Stubs_To --
3619 ---------------------
3621 procedure Append_Stubs_To
3622 (RPC_Receiver_Cases : List_Id;
3624 Subprogram_Number : Int)
3627 Append_To (RPC_Receiver_Cases,
3628 Make_Case_Statement_Alternative (Loc,
3630 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3633 Make_Procedure_Call_Statement (Loc,
3636 Defining_Entity (Stubs), Loc),
3637 Parameter_Associations => New_List (
3638 New_Occurrence_Of (Request_Parameter, Loc))))));
3639 end Append_Stubs_To;
3641 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3644 -- Building receiving stubs consist in several operations:
3646 -- - a package RPC receiver must be built. This subprogram
3647 -- will get a Subprogram_Id from the incoming stream
3648 -- and will dispatch the call to the right subprogram
3650 -- - a receiving stub for any subprogram visible in the package
3651 -- spec. This stub will read all the parameters from the stream,
3652 -- and put the result as well as the exception occurrence in the
3655 -- - a dummy package with an empty spec and a body made of an
3656 -- elaboration part, whose job is to register the receiving
3657 -- part of this RCI package on the name server. This is done
3658 -- by calling System.Partition_Interface.Register_Receiving_Stub
3660 Build_RPC_Receiver_Body (
3661 RPC_Receiver => Pkg_RPC_Receiver,
3662 Request => Request_Parameter,
3664 Subp_Index => Subp_Index,
3665 Stmts => Pkg_RPC_Receiver_Statements,
3666 Decl => Pkg_RPC_Receiver_Body);
3667 pragma Assert (Subp_Id = Subp_Index);
3669 -- A null subp_id denotes a call through a RAS, in which case the
3670 -- next Uint_64 element in the stream is the address of the local
3671 -- proxy object, from which we can retrieve the actual subprogram id.
3673 Append_To (Pkg_RPC_Receiver_Statements,
3674 Make_Implicit_If_Statement (Pkg_Spec,
3677 New_Occurrence_Of (Subp_Id, Loc),
3678 Make_Integer_Literal (Loc, 0)),
3679 Then_Statements => New_List (
3680 Make_Assignment_Statement (Loc,
3682 New_Occurrence_Of (Subp_Id, Loc),
3684 Make_Selected_Component (Loc,
3686 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3687 OK_Convert_To (RTE (RE_Address),
3688 Make_Attribute_Reference (Loc,
3690 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3693 Expressions => New_List (
3694 Make_Selected_Component (Loc,
3695 Prefix => Request_Parameter,
3696 Selector_Name => Name_Params))))),
3698 Make_Identifier (Loc, Name_Subp_Id))))));
3700 -- Build a subprogram for RAS information lookups
3702 Current_Declaration :=
3703 Make_Subprogram_Declaration (Loc,
3705 Make_Function_Specification (Loc,
3706 Defining_Unit_Name =>
3708 Parameter_Specifications => New_List (
3709 Make_Parameter_Specification (Loc,
3710 Defining_Identifier =>
3711 Make_Defining_Identifier (Loc, Name_Subp_Id),
3715 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3716 Result_Definition =>
3717 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3718 Append_To (Decls, Current_Declaration);
3719 Analyze (Current_Declaration);
3721 Current_Stubs := Build_Subprogram_Receiving_Stubs
3722 (Vis_Decl => Current_Declaration,
3723 Asynchronous => False);
3724 Append_To (Decls, Current_Stubs);
3725 Analyze (Current_Stubs);
3727 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3730 Subprogram_Number => 1);
3732 -- For each subprogram, the receiving stub will be built and a
3733 -- case statement will be made on the Subprogram_Id to dispatch
3734 -- to the right subprogram.
3736 All_Calls_Remote_E := Boolean_Literals (
3737 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3739 Overload_Counter_Table.Reset;
3741 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3742 while Present (Current_Declaration) loop
3743 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3744 and then Comes_From_Source (Current_Declaration)
3747 Loc : constant Source_Ptr :=
3748 Sloc (Current_Declaration);
3749 -- While specifically processing Current_Declaration, use
3750 -- its Sloc as the location of all generated nodes.
3752 Subp_Def : constant Entity_Id :=
3754 (Specification (Current_Declaration));
3756 Subp_Val : String_Id;
3759 -- Build receiving stub
3762 Build_Subprogram_Receiving_Stubs
3763 (Vis_Decl => Current_Declaration,
3765 Nkind (Specification (Current_Declaration)) =
3766 N_Procedure_Specification
3767 and then Is_Asynchronous (Subp_Def));
3769 Append_To (Decls, Current_Stubs);
3770 Analyze (Current_Stubs);
3774 Add_RAS_Proxy_And_Analyze (Decls,
3776 Current_Declaration,
3777 All_Calls_Remote_E =>
3779 Proxy_Object_Addr =>
3782 -- Compute distribution identifier
3784 Assign_Subprogram_Identifier (
3786 Current_Subprogram_Number,
3789 pragma Assert (Current_Subprogram_Number =
3790 Get_Subprogram_Id (Subp_Def));
3792 -- Add subprogram descriptor (RCI_Subp_Info) to the
3793 -- subprograms table for this receiver. The aggregate
3794 -- below must be kept consistent with the declaration
3795 -- of type RCI_Subp_Info in System.Partition_Interface.
3797 Append_To (Subp_Info_List,
3798 Make_Component_Association (Loc,
3799 Choices => New_List (
3800 Make_Integer_Literal (Loc,
3801 Current_Subprogram_Number)),
3803 Make_Aggregate (Loc,
3804 Component_Associations => New_List (
3805 Make_Component_Association (Loc,
3806 Choices => New_List (
3807 Make_Identifier (Loc, Name_Addr)),
3810 Proxy_Object_Addr, Loc))))));
3812 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3815 Subprogram_Number =>
3816 Current_Subprogram_Number);
3819 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3822 Next (Current_Declaration);
3825 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3826 -- rather than raising an exception since we do not want someone
3827 -- to crash a remote partition by sending invalid subprogram ids.
3828 -- This is consistent with the other parts of the case statement
3829 -- since even in presence of incorrect parameters in the stream,
3830 -- every exception will be caught and (if the subprogram is not an
3831 -- APC) put into the result stream and sent away.
3833 Append_To (Pkg_RPC_Receiver_Cases,
3834 Make_Case_Statement_Alternative (Loc,
3836 New_List (Make_Others_Choice (Loc)),
3838 New_List (Make_Null_Statement (Loc))));
3840 Append_To (Pkg_RPC_Receiver_Statements,
3841 Make_Case_Statement (Loc,
3843 New_Occurrence_Of (Subp_Id, Loc),
3844 Alternatives => Pkg_RPC_Receiver_Cases));
3847 Make_Object_Declaration (Loc,
3848 Defining_Identifier => Subp_Info_Array,
3849 Constant_Present => True,
3850 Aliased_Present => True,
3851 Object_Definition =>
3852 Make_Subtype_Indication (Loc,
3854 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3856 Make_Index_Or_Discriminant_Constraint (Loc,
3859 Low_Bound => Make_Integer_Literal (Loc,
3860 First_RCI_Subprogram_Id),
3862 Make_Integer_Literal (Loc,
3863 First_RCI_Subprogram_Id
3864 + List_Length (Subp_Info_List) - 1))))),
3866 Make_Aggregate (Loc,
3867 Component_Associations => Subp_Info_List)));
3868 Analyze (Last (Decls));
3871 Make_Subprogram_Body (Loc,
3873 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
3876 Handled_Statement_Sequence =>
3877 Make_Handled_Sequence_Of_Statements (Loc,
3878 Statements => New_List (
3879 Make_Return_Statement (Loc,
3880 Expression => OK_Convert_To (RTE (RE_Unsigned_64),
3881 Make_Selected_Component (Loc,
3883 Make_Indexed_Component (Loc,
3885 New_Occurrence_Of (Subp_Info_Array, Loc),
3886 Expressions => New_List (
3887 Convert_To (Standard_Integer,
3888 Make_Identifier (Loc, Name_Subp_Id)))),
3890 Make_Identifier (Loc, Name_Addr))))))));
3891 Analyze (Last (Decls));
3893 Append_To (Decls, Pkg_RPC_Receiver_Body);
3894 Analyze (Last (Decls));
3896 Get_Library_Unit_Name_String (Pkg_Spec);
3897 Append_To (Register_Pkg_Actuals,
3899 Make_String_Literal (Loc,
3900 Strval => String_From_Name_Buffer));
3902 Append_To (Register_Pkg_Actuals,
3904 Make_Attribute_Reference (Loc,
3906 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
3908 Name_Unrestricted_Access));
3910 Append_To (Register_Pkg_Actuals,
3912 Make_Attribute_Reference (Loc,
3914 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
3918 Append_To (Register_Pkg_Actuals,
3920 Make_Attribute_Reference (Loc,
3922 New_Occurrence_Of (Subp_Info_Array, Loc),
3926 Append_To (Register_Pkg_Actuals,
3928 Make_Attribute_Reference (Loc,
3930 New_Occurrence_Of (Subp_Info_Array, Loc),
3935 Make_Procedure_Call_Statement (Loc,
3937 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
3938 Parameter_Associations => Register_Pkg_Actuals));
3939 Analyze (Last (Stmts));
3940 end Add_Receiving_Stubs_To_Declarations;
3942 ---------------------------------
3943 -- Build_General_Calling_Stubs --
3944 ---------------------------------
3946 procedure Build_General_Calling_Stubs
3948 Statements : List_Id;
3949 Target_Partition : Entity_Id;
3950 Target_RPC_Receiver : Node_Id;
3951 Subprogram_Id : Node_Id;
3952 Asynchronous : Node_Id := Empty;
3953 Is_Known_Asynchronous : Boolean := False;
3954 Is_Known_Non_Asynchronous : Boolean := False;
3955 Is_Function : Boolean;
3957 Stub_Type : Entity_Id := Empty;
3958 RACW_Type : Entity_Id := Empty;
3961 Loc : constant Source_Ptr := Sloc (Nod);
3963 Stream_Parameter : Node_Id;
3964 -- Name of the stream used to transmit parameters to the
3967 Result_Parameter : Node_Id;
3968 -- Name of the result parameter (in non-APC cases) which get the
3969 -- result of the remote subprogram.
3971 Exception_Return_Parameter : Node_Id;
3972 -- Name of the parameter which will hold the exception sent by the
3973 -- remote subprogram.
3975 Current_Parameter : Node_Id;
3976 -- Current parameter being handled
3978 Ordered_Parameters_List : constant List_Id :=
3979 Build_Ordered_Parameters_List (Spec);
3981 Asynchronous_Statements : List_Id := No_List;
3982 Non_Asynchronous_Statements : List_Id := No_List;
3983 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
3985 Extra_Formal_Statements : constant List_Id := New_List;
3986 -- List of statements for extra formal parameters. It will appear
3987 -- after the regular statements for writing out parameters.
3989 pragma Warnings (Off);
3990 pragma Unreferenced (RACW_Type);
3991 -- Used only for the PolyORB case
3992 pragma Warnings (On);
3995 -- The general form of a calling stub for a given subprogram is:
3997 -- procedure X (...) is P : constant Partition_ID :=
3998 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
3999 -- System.RPC.Params_Stream_Type (0); begin
4000 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4001 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4002 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4003 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4005 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4007 -- There are some variations: Do_APC is called for an asynchronous
4008 -- procedure and the part after the call is completely ommitted as
4009 -- well as the declaration of Result. For a function call, 'Input is
4010 -- always used to read the result even if it is constrained.
4013 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4016 Make_Object_Declaration (Loc,
4017 Defining_Identifier => Stream_Parameter,
4018 Aliased_Present => True,
4019 Object_Definition =>
4020 Make_Subtype_Indication (Loc,
4022 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4024 Make_Index_Or_Discriminant_Constraint (Loc,
4026 New_List (Make_Integer_Literal (Loc, 0))))));
4028 if not Is_Known_Asynchronous then
4030 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4033 Make_Object_Declaration (Loc,
4034 Defining_Identifier => Result_Parameter,
4035 Aliased_Present => True,
4036 Object_Definition =>
4037 Make_Subtype_Indication (Loc,
4039 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4041 Make_Index_Or_Discriminant_Constraint (Loc,
4043 New_List (Make_Integer_Literal (Loc, 0))))));
4045 Exception_Return_Parameter :=
4046 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4049 Make_Object_Declaration (Loc,
4050 Defining_Identifier => Exception_Return_Parameter,
4051 Object_Definition =>
4052 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4055 Result_Parameter := Empty;
4056 Exception_Return_Parameter := Empty;
4059 -- Put first the RPC receiver corresponding to the remote package
4061 Append_To (Statements,
4062 Make_Attribute_Reference (Loc,
4064 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4065 Attribute_Name => Name_Write,
4066 Expressions => New_List (
4067 Make_Attribute_Reference (Loc,
4069 New_Occurrence_Of (Stream_Parameter, Loc),
4072 Target_RPC_Receiver)));
4074 -- Then put the Subprogram_Id of the subprogram we want to call in
4077 Append_To (Statements,
4078 Make_Attribute_Reference (Loc,
4080 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4083 Expressions => New_List (
4084 Make_Attribute_Reference (Loc,
4086 New_Occurrence_Of (Stream_Parameter, Loc),
4087 Attribute_Name => Name_Access),
4090 Current_Parameter := First (Ordered_Parameters_List);
4091 while Present (Current_Parameter) loop
4093 Typ : constant Node_Id :=
4094 Parameter_Type (Current_Parameter);
4096 Constrained : Boolean;
4098 Extra_Parameter : Entity_Id;
4101 if Is_RACW_Controlling_Formal
4102 (Current_Parameter, Stub_Type)
4104 -- In the case of a controlling formal argument, we marshall
4105 -- its addr field rather than the local stub.
4107 Append_To (Statements,
4108 Pack_Node_Into_Stream (Loc,
4109 Stream => Stream_Parameter,
4111 Make_Selected_Component (Loc,
4113 Defining_Identifier (Current_Parameter),
4114 Selector_Name => Name_Addr),
4115 Etyp => RTE (RE_Unsigned_64)));
4118 Value := New_Occurrence_Of
4119 (Defining_Identifier (Current_Parameter), Loc);
4121 -- Access type parameters are transmitted as in out
4122 -- parameters. However, a dereference is needed so that
4123 -- we marshall the designated object.
4125 if Nkind (Typ) = N_Access_Definition then
4126 Value := Make_Explicit_Dereference (Loc, Value);
4127 Etyp := Etype (Subtype_Mark (Typ));
4129 Etyp := Etype (Typ);
4133 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
4135 -- Any parameter but unconstrained out parameters are
4136 -- transmitted to the peer.
4138 if In_Present (Current_Parameter)
4139 or else not Out_Present (Current_Parameter)
4140 or else not Constrained
4142 Append_To (Statements,
4143 Make_Attribute_Reference (Loc,
4145 New_Occurrence_Of (Etyp, Loc),
4147 Output_From_Constrained (Constrained),
4148 Expressions => New_List (
4149 Make_Attribute_Reference (Loc,
4151 New_Occurrence_Of (Stream_Parameter, Loc),
4152 Attribute_Name => Name_Access),
4157 -- If the current parameter has a dynamic constrained status,
4158 -- then this status is transmitted as well.
4159 -- This should be done for accessibility as well ???
4161 if Nkind (Typ) /= N_Access_Definition
4162 and then Need_Extra_Constrained (Current_Parameter)
4164 -- In this block, we do not use the extra formal that has
4165 -- been created because it does not exist at the time of
4166 -- expansion when building calling stubs for remote access
4167 -- to subprogram types. We create an extra variable of this
4168 -- type and push it in the stream after the regular
4171 Extra_Parameter := Make_Defining_Identifier
4172 (Loc, New_Internal_Name ('P'));
4175 Make_Object_Declaration (Loc,
4176 Defining_Identifier => Extra_Parameter,
4177 Constant_Present => True,
4178 Object_Definition =>
4179 New_Occurrence_Of (Standard_Boolean, Loc),
4181 Make_Attribute_Reference (Loc,
4184 Defining_Identifier (Current_Parameter), Loc),
4185 Attribute_Name => Name_Constrained)));
4187 Append_To (Extra_Formal_Statements,
4188 Make_Attribute_Reference (Loc,
4190 New_Occurrence_Of (Standard_Boolean, Loc),
4193 Expressions => New_List (
4194 Make_Attribute_Reference (Loc,
4196 New_Occurrence_Of (Stream_Parameter, Loc),
4199 New_Occurrence_Of (Extra_Parameter, Loc))));
4202 Next (Current_Parameter);
4206 -- Append the formal statements list to the statements
4208 Append_List_To (Statements, Extra_Formal_Statements);
4210 if not Is_Known_Non_Asynchronous then
4212 -- Build the call to System.RPC.Do_APC
4214 Asynchronous_Statements := New_List (
4215 Make_Procedure_Call_Statement (Loc,
4217 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4218 Parameter_Associations => New_List (
4219 New_Occurrence_Of (Target_Partition, Loc),
4220 Make_Attribute_Reference (Loc,
4222 New_Occurrence_Of (Stream_Parameter, Loc),
4226 Asynchronous_Statements := No_List;
4229 if not Is_Known_Asynchronous then
4231 -- Build the call to System.RPC.Do_RPC
4233 Non_Asynchronous_Statements := New_List (
4234 Make_Procedure_Call_Statement (Loc,
4236 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4237 Parameter_Associations => New_List (
4238 New_Occurrence_Of (Target_Partition, Loc),
4240 Make_Attribute_Reference (Loc,
4242 New_Occurrence_Of (Stream_Parameter, Loc),
4246 Make_Attribute_Reference (Loc,
4248 New_Occurrence_Of (Result_Parameter, Loc),
4252 -- Read the exception occurrence from the result stream and
4253 -- reraise it. It does no harm if this is a Null_Occurrence since
4254 -- this does nothing.
4256 Append_To (Non_Asynchronous_Statements,
4257 Make_Attribute_Reference (Loc,
4259 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4264 Expressions => New_List (
4265 Make_Attribute_Reference (Loc,
4267 New_Occurrence_Of (Result_Parameter, Loc),
4270 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4272 Append_To (Non_Asynchronous_Statements,
4273 Make_Procedure_Call_Statement (Loc,
4275 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4276 Parameter_Associations => New_List (
4277 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4281 -- If this is a function call, then read the value and return
4282 -- it. The return value is written/read using 'Output/'Input.
4284 Append_To (Non_Asynchronous_Statements,
4285 Make_Tag_Check (Loc,
4286 Make_Return_Statement (Loc,
4288 Make_Attribute_Reference (Loc,
4291 Etype (Result_Definition (Spec)), Loc),
4293 Attribute_Name => Name_Input,
4295 Expressions => New_List (
4296 Make_Attribute_Reference (Loc,
4298 New_Occurrence_Of (Result_Parameter, Loc),
4299 Attribute_Name => Name_Access))))));
4302 -- Loop around parameters and assign out (or in out)
4303 -- parameters. In the case of RACW, controlling arguments
4304 -- cannot possibly have changed since they are remote, so we do
4305 -- not read them from the stream.
4307 Current_Parameter := First (Ordered_Parameters_List);
4308 while Present (Current_Parameter) loop
4310 Typ : constant Node_Id :=
4311 Parameter_Type (Current_Parameter);
4318 (Defining_Identifier (Current_Parameter), Loc);
4320 if Nkind (Typ) = N_Access_Definition then
4321 Value := Make_Explicit_Dereference (Loc, Value);
4322 Etyp := Etype (Subtype_Mark (Typ));
4324 Etyp := Etype (Typ);
4327 if (Out_Present (Current_Parameter)
4328 or else Nkind (Typ) = N_Access_Definition)
4329 and then Etyp /= Stub_Type
4331 Append_To (Non_Asynchronous_Statements,
4332 Make_Attribute_Reference (Loc,
4334 New_Occurrence_Of (Etyp, Loc),
4336 Attribute_Name => Name_Read,
4338 Expressions => New_List (
4339 Make_Attribute_Reference (Loc,
4341 New_Occurrence_Of (Result_Parameter, Loc),
4348 Next (Current_Parameter);
4353 if Is_Known_Asynchronous then
4354 Append_List_To (Statements, Asynchronous_Statements);
4356 elsif Is_Known_Non_Asynchronous then
4357 Append_List_To (Statements, Non_Asynchronous_Statements);
4360 pragma Assert (Present (Asynchronous));
4361 Prepend_To (Asynchronous_Statements,
4362 Make_Attribute_Reference (Loc,
4363 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4364 Attribute_Name => Name_Write,
4365 Expressions => New_List (
4366 Make_Attribute_Reference (Loc,
4368 New_Occurrence_Of (Stream_Parameter, Loc),
4369 Attribute_Name => Name_Access),
4370 New_Occurrence_Of (Standard_True, Loc))));
4372 Prepend_To (Non_Asynchronous_Statements,
4373 Make_Attribute_Reference (Loc,
4374 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4375 Attribute_Name => Name_Write,
4376 Expressions => New_List (
4377 Make_Attribute_Reference (Loc,
4379 New_Occurrence_Of (Stream_Parameter, Loc),
4380 Attribute_Name => Name_Access),
4381 New_Occurrence_Of (Standard_False, Loc))));
4383 Append_To (Statements,
4384 Make_Implicit_If_Statement (Nod,
4385 Condition => Asynchronous,
4386 Then_Statements => Asynchronous_Statements,
4387 Else_Statements => Non_Asynchronous_Statements));
4389 end Build_General_Calling_Stubs;
4391 -----------------------------
4392 -- Build_RPC_Receiver_Body --
4393 -----------------------------
4395 procedure Build_RPC_Receiver_Body
4396 (RPC_Receiver : Entity_Id;
4397 Request : out Entity_Id;
4398 Subp_Id : out Entity_Id;
4399 Subp_Index : out Entity_Id;
4400 Stmts : out List_Id;
4403 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4405 RPC_Receiver_Spec : Node_Id;
4406 RPC_Receiver_Decls : List_Id;
4409 Request := Make_Defining_Identifier (Loc, Name_R);
4411 RPC_Receiver_Spec :=
4412 Build_RPC_Receiver_Specification
4413 (RPC_Receiver => RPC_Receiver,
4414 Request_Parameter => Request);
4416 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4417 Subp_Index := Subp_Id;
4419 -- Subp_Id may not be a constant, because in the case of the RPC
4420 -- receiver for an RCI package, when a call is received from a RAS
4421 -- dereference, it will be assigned during subsequent processing.
4423 RPC_Receiver_Decls := New_List (
4424 Make_Object_Declaration (Loc,
4425 Defining_Identifier => Subp_Id,
4426 Object_Definition =>
4427 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4429 Make_Attribute_Reference (Loc,
4431 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4432 Attribute_Name => Name_Input,
4433 Expressions => New_List (
4434 Make_Selected_Component (Loc,
4436 Selector_Name => Name_Params)))));
4441 Make_Subprogram_Body (Loc,
4442 Specification => RPC_Receiver_Spec,
4443 Declarations => RPC_Receiver_Decls,
4444 Handled_Statement_Sequence =>
4445 Make_Handled_Sequence_Of_Statements (Loc,
4446 Statements => Stmts));
4447 end Build_RPC_Receiver_Body;
4449 -----------------------
4450 -- Build_Stub_Target --
4451 -----------------------
4453 function Build_Stub_Target
4456 RCI_Locator : Entity_Id;
4457 Controlling_Parameter : Entity_Id) return RPC_Target
4459 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4461 Target_Info.Partition :=
4462 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4463 if Present (Controlling_Parameter) then
4465 Make_Object_Declaration (Loc,
4466 Defining_Identifier => Target_Info.Partition,
4467 Constant_Present => True,
4468 Object_Definition =>
4469 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4472 Make_Selected_Component (Loc,
4473 Prefix => Controlling_Parameter,
4474 Selector_Name => Name_Origin)));
4476 Target_Info.RPC_Receiver :=
4477 Make_Selected_Component (Loc,
4478 Prefix => Controlling_Parameter,
4479 Selector_Name => Name_Receiver);
4483 Make_Object_Declaration (Loc,
4484 Defining_Identifier => Target_Info.Partition,
4485 Constant_Present => True,
4486 Object_Definition =>
4487 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4490 Make_Function_Call (Loc,
4491 Name => Make_Selected_Component (Loc,
4493 Make_Identifier (Loc, Chars (RCI_Locator)),
4495 Make_Identifier (Loc,
4496 Name_Get_Active_Partition_ID)))));
4498 Target_Info.RPC_Receiver :=
4499 Make_Selected_Component (Loc,
4501 Make_Identifier (Loc, Chars (RCI_Locator)),
4503 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4506 end Build_Stub_Target;
4508 ---------------------
4509 -- Build_Stub_Type --
4510 ---------------------
4512 procedure Build_Stub_Type
4513 (RACW_Type : Entity_Id;
4514 Stub_Type : Entity_Id;
4515 Stub_Type_Decl : out Node_Id;
4516 RPC_Receiver_Decl : out Node_Id)
4518 Loc : constant Source_Ptr := Sloc (Stub_Type);
4519 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4523 Make_Full_Type_Declaration (Loc,
4524 Defining_Identifier => Stub_Type,
4526 Make_Record_Definition (Loc,
4527 Tagged_Present => True,
4528 Limited_Present => True,
4530 Make_Component_List (Loc,
4531 Component_Items => New_List (
4533 Make_Component_Declaration (Loc,
4534 Defining_Identifier =>
4535 Make_Defining_Identifier (Loc, Name_Origin),
4536 Component_Definition =>
4537 Make_Component_Definition (Loc,
4538 Aliased_Present => False,
4539 Subtype_Indication =>
4541 RTE (RE_Partition_ID), Loc))),
4543 Make_Component_Declaration (Loc,
4544 Defining_Identifier =>
4545 Make_Defining_Identifier (Loc, Name_Receiver),
4546 Component_Definition =>
4547 Make_Component_Definition (Loc,
4548 Aliased_Present => False,
4549 Subtype_Indication =>
4550 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4552 Make_Component_Declaration (Loc,
4553 Defining_Identifier =>
4554 Make_Defining_Identifier (Loc, Name_Addr),
4555 Component_Definition =>
4556 Make_Component_Definition (Loc,
4557 Aliased_Present => False,
4558 Subtype_Indication =>
4559 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4561 Make_Component_Declaration (Loc,
4562 Defining_Identifier =>
4563 Make_Defining_Identifier (Loc, Name_Asynchronous),
4564 Component_Definition =>
4565 Make_Component_Definition (Loc,
4566 Aliased_Present => False,
4567 Subtype_Indication =>
4569 Standard_Boolean, Loc)))))));
4572 RPC_Receiver_Decl := Empty;
4575 RPC_Receiver_Request : constant Entity_Id :=
4576 Make_Defining_Identifier (Loc, Name_R);
4578 RPC_Receiver_Decl :=
4579 Make_Subprogram_Declaration (Loc,
4580 Build_RPC_Receiver_Specification (
4581 RPC_Receiver => Make_Defining_Identifier (Loc,
4582 New_Internal_Name ('R')),
4583 Request_Parameter => RPC_Receiver_Request));
4586 end Build_Stub_Type;
4588 --------------------------------------
4589 -- Build_Subprogram_Receiving_Stubs --
4590 --------------------------------------
4592 function Build_Subprogram_Receiving_Stubs
4593 (Vis_Decl : Node_Id;
4594 Asynchronous : Boolean;
4595 Dynamically_Asynchronous : Boolean := False;
4596 Stub_Type : Entity_Id := Empty;
4597 RACW_Type : Entity_Id := Empty;
4598 Parent_Primitive : Entity_Id := Empty) return Node_Id
4600 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4602 Request_Parameter : constant Entity_Id :=
4603 Make_Defining_Identifier (Loc,
4604 New_Internal_Name ('R'));
4605 -- Formal parameter for receiving stubs: a descriptor for an incoming
4608 Decls : constant List_Id := New_List;
4609 -- All the parameters will get declared before calling the real
4610 -- subprograms. Also the out parameters will be declared.
4612 Statements : constant List_Id := New_List;
4614 Extra_Formal_Statements : constant List_Id := New_List;
4615 -- Statements concerning extra formal parameters
4617 After_Statements : constant List_Id := New_List;
4618 -- Statements to be executed after the subprogram call
4620 Inner_Decls : List_Id := No_List;
4621 -- In case of a function, the inner declarations are needed since
4622 -- the result may be unconstrained.
4624 Excep_Handlers : List_Id := No_List;
4625 Excep_Choice : Entity_Id;
4626 Excep_Code : List_Id;
4628 Parameter_List : constant List_Id := New_List;
4629 -- List of parameters to be passed to the subprogram
4631 Current_Parameter : Node_Id;
4633 Ordered_Parameters_List : constant List_Id :=
4634 Build_Ordered_Parameters_List
4635 (Specification (Vis_Decl));
4637 Subp_Spec : Node_Id;
4638 -- Subprogram specification
4640 Called_Subprogram : Node_Id;
4641 -- The subprogram to call
4643 Null_Raise_Statement : Node_Id;
4645 Dynamic_Async : Entity_Id;
4648 if Present (RACW_Type) then
4649 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4651 Called_Subprogram :=
4653 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4656 if Dynamically_Asynchronous then
4658 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4660 Dynamic_Async := Empty;
4663 if not Asynchronous or Dynamically_Asynchronous then
4665 -- The first statement after the subprogram call is a statement to
4666 -- write a Null_Occurrence into the result stream.
4668 Null_Raise_Statement :=
4669 Make_Attribute_Reference (Loc,
4671 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4672 Attribute_Name => Name_Write,
4673 Expressions => New_List (
4674 Make_Selected_Component (Loc,
4675 Prefix => Request_Parameter,
4676 Selector_Name => Name_Result),
4677 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4679 if Dynamically_Asynchronous then
4680 Null_Raise_Statement :=
4681 Make_Implicit_If_Statement (Vis_Decl,
4683 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4684 Then_Statements => New_List (Null_Raise_Statement));
4687 Append_To (After_Statements, Null_Raise_Statement);
4690 -- Loop through every parameter and get its value from the stream. If
4691 -- the parameter is unconstrained, then the parameter is read using
4692 -- 'Input at the point of declaration.
4694 Current_Parameter := First (Ordered_Parameters_List);
4695 while Present (Current_Parameter) loop
4698 Constrained : Boolean;
4700 Need_Extra_Constrained : Boolean;
4701 -- True when an Extra_Constrained actual is required
4703 Object : constant Entity_Id :=
4704 Make_Defining_Identifier (Loc,
4705 New_Internal_Name ('P'));
4707 Expr : Node_Id := Empty;
4709 Is_Controlling_Formal : constant Boolean :=
4710 Is_RACW_Controlling_Formal
4711 (Current_Parameter, Stub_Type);
4714 if Is_Controlling_Formal then
4716 -- We have a controlling formal parameter. Read its address
4717 -- rather than a real object. The address is in Unsigned_64
4720 Etyp := RTE (RE_Unsigned_64);
4722 Etyp := Etype (Parameter_Type (Current_Parameter));
4726 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
4728 if In_Present (Current_Parameter)
4729 or else not Out_Present (Current_Parameter)
4730 or else not Constrained
4731 or else Is_Controlling_Formal
4733 -- If an input parameter is constrained, then the read of
4734 -- the parameter is deferred until the beginning of the
4735 -- subprogram body. If it is unconstrained, then an
4736 -- expression is built for the object declaration and the
4737 -- variable is set using 'Input instead of 'Read. Note that
4738 -- this deferral does not change the order in which the
4739 -- actuals are read because Build_Ordered_Parameter_List
4740 -- puts them unconstrained first.
4743 Append_To (Statements,
4744 Make_Attribute_Reference (Loc,
4745 Prefix => New_Occurrence_Of (Etyp, Loc),
4746 Attribute_Name => Name_Read,
4747 Expressions => New_List (
4748 Make_Selected_Component (Loc,
4749 Prefix => Request_Parameter,
4750 Selector_Name => Name_Params),
4751 New_Occurrence_Of (Object, Loc))));
4755 -- Build and append Input_With_Tag_Check function
4758 Input_With_Tag_Check (Loc,
4760 Stream => Make_Selected_Component (Loc,
4761 Prefix => Request_Parameter,
4762 Selector_Name => Name_Params)));
4764 -- Prepare function call expression
4766 Expr := Make_Function_Call (Loc,
4767 New_Occurrence_Of (Defining_Unit_Name
4768 (Specification (Last (Decls))), Loc));
4772 Need_Extra_Constrained :=
4773 Nkind (Parameter_Type (Current_Parameter)) /=
4776 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4778 Present (Extra_Constrained
4779 (Defining_Identifier (Current_Parameter)));
4781 -- We may not associate an extra constrained actual to a
4782 -- constant object, so if one is needed, declare the actual
4783 -- as a variable even if it won't be modified.
4785 Build_Actual_Object_Declaration
4788 Variable => Need_Extra_Constrained
4789 or else Out_Present (Current_Parameter),
4793 -- An out parameter may be written back using a 'Write
4794 -- attribute instead of a 'Output because it has been
4795 -- constrained by the parameter given to the caller. Note that
4796 -- out controlling arguments in the case of a RACW are not put
4797 -- back in the stream because the pointer on them has not
4800 if Out_Present (Current_Parameter)
4802 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4804 Append_To (After_Statements,
4805 Make_Attribute_Reference (Loc,
4806 Prefix => New_Occurrence_Of (Etyp, Loc),
4807 Attribute_Name => Name_Write,
4808 Expressions => New_List (
4809 Make_Selected_Component (Loc,
4810 Prefix => Request_Parameter,
4811 Selector_Name => Name_Result),
4812 New_Occurrence_Of (Object, Loc))));
4815 -- For RACW controlling formals, the Etyp of Object is always
4816 -- an RACW, even if the parameter is not of an anonymous access
4817 -- type. In such case, we need to dereference it at call time.
4819 if Is_Controlling_Formal then
4820 if Nkind (Parameter_Type (Current_Parameter)) /=
4823 Append_To (Parameter_List,
4824 Make_Parameter_Association (Loc,
4827 Defining_Identifier (Current_Parameter), Loc),
4828 Explicit_Actual_Parameter =>
4829 Make_Explicit_Dereference (Loc,
4830 Unchecked_Convert_To (RACW_Type,
4831 OK_Convert_To (RTE (RE_Address),
4832 New_Occurrence_Of (Object, Loc))))));
4835 Append_To (Parameter_List,
4836 Make_Parameter_Association (Loc,
4839 Defining_Identifier (Current_Parameter), Loc),
4840 Explicit_Actual_Parameter =>
4841 Unchecked_Convert_To (RACW_Type,
4842 OK_Convert_To (RTE (RE_Address),
4843 New_Occurrence_Of (Object, Loc)))));
4847 Append_To (Parameter_List,
4848 Make_Parameter_Association (Loc,
4851 Defining_Identifier (Current_Parameter), Loc),
4852 Explicit_Actual_Parameter =>
4853 New_Occurrence_Of (Object, Loc)));
4856 -- If the current parameter needs an extra formal, then read it
4857 -- from the stream and set the corresponding semantic field in
4858 -- the variable. If the kind of the parameter identifier is
4859 -- E_Void, then this is a compiler generated parameter that
4860 -- doesn't need an extra constrained status.
4862 -- The case of Extra_Accessibility should also be handled ???
4864 if Need_Extra_Constrained then
4866 Extra_Parameter : constant Entity_Id :=
4868 (Defining_Identifier
4869 (Current_Parameter));
4871 Formal_Entity : constant Entity_Id :=
4872 Make_Defining_Identifier
4873 (Loc, Chars (Extra_Parameter));
4875 Formal_Type : constant Entity_Id :=
4876 Etype (Extra_Parameter);
4880 Make_Object_Declaration (Loc,
4881 Defining_Identifier => Formal_Entity,
4882 Object_Definition =>
4883 New_Occurrence_Of (Formal_Type, Loc)));
4885 Append_To (Extra_Formal_Statements,
4886 Make_Attribute_Reference (Loc,
4887 Prefix => New_Occurrence_Of (
4889 Attribute_Name => Name_Read,
4890 Expressions => New_List (
4891 Make_Selected_Component (Loc,
4892 Prefix => Request_Parameter,
4893 Selector_Name => Name_Params),
4894 New_Occurrence_Of (Formal_Entity, Loc))));
4896 -- Note: the call to Set_Extra_Constrained below relies
4897 -- on the fact that Object's Ekind has been set by
4898 -- Build_Actual_Object_Declaration.
4900 Set_Extra_Constrained (Object, Formal_Entity);
4905 Next (Current_Parameter);
4908 -- Append the formal statements list at the end of regular statements
4910 Append_List_To (Statements, Extra_Formal_Statements);
4912 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
4914 -- The remote subprogram is a function. We build an inner block to
4915 -- be able to hold a potentially unconstrained result in a
4919 Etyp : constant Entity_Id :=
4920 Etype (Result_Definition (Specification (Vis_Decl)));
4921 Result : constant Node_Id :=
4922 Make_Defining_Identifier (Loc,
4923 New_Internal_Name ('R'));
4925 Inner_Decls := New_List (
4926 Make_Object_Declaration (Loc,
4927 Defining_Identifier => Result,
4928 Constant_Present => True,
4929 Object_Definition => New_Occurrence_Of (Etyp, Loc),
4931 Make_Function_Call (Loc,
4932 Name => Called_Subprogram,
4933 Parameter_Associations => Parameter_List)));
4935 Append_To (After_Statements,
4936 Make_Attribute_Reference (Loc,
4937 Prefix => New_Occurrence_Of (Etyp, Loc),
4938 Attribute_Name => Name_Output,
4939 Expressions => New_List (
4940 Make_Selected_Component (Loc,
4941 Prefix => Request_Parameter,
4942 Selector_Name => Name_Result),
4943 New_Occurrence_Of (Result, Loc))));
4946 Append_To (Statements,
4947 Make_Block_Statement (Loc,
4948 Declarations => Inner_Decls,
4949 Handled_Statement_Sequence =>
4950 Make_Handled_Sequence_Of_Statements (Loc,
4951 Statements => After_Statements)));
4954 -- The remote subprogram is a procedure. We do not need any inner
4955 -- block in this case.
4957 if Dynamically_Asynchronous then
4959 Make_Object_Declaration (Loc,
4960 Defining_Identifier => Dynamic_Async,
4961 Object_Definition =>
4962 New_Occurrence_Of (Standard_Boolean, Loc)));
4964 Append_To (Statements,
4965 Make_Attribute_Reference (Loc,
4966 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4967 Attribute_Name => Name_Read,
4968 Expressions => New_List (
4969 Make_Selected_Component (Loc,
4970 Prefix => Request_Parameter,
4971 Selector_Name => Name_Params),
4972 New_Occurrence_Of (Dynamic_Async, Loc))));
4975 Append_To (Statements,
4976 Make_Procedure_Call_Statement (Loc,
4977 Name => Called_Subprogram,
4978 Parameter_Associations => Parameter_List));
4980 Append_List_To (Statements, After_Statements);
4983 if Asynchronous and then not Dynamically_Asynchronous then
4985 -- For an asynchronous procedure, add a null exception handler
4987 Excep_Handlers := New_List (
4988 Make_Implicit_Exception_Handler (Loc,
4989 Exception_Choices => New_List (Make_Others_Choice (Loc)),
4990 Statements => New_List (Make_Null_Statement (Loc))));
4993 -- In the other cases, if an exception is raised, then the
4994 -- exception occurrence is copied into the output stream and
4995 -- no other output parameter is written.
4998 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5000 Excep_Code := New_List (
5001 Make_Attribute_Reference (Loc,
5003 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5004 Attribute_Name => Name_Write,
5005 Expressions => New_List (
5006 Make_Selected_Component (Loc,
5007 Prefix => Request_Parameter,
5008 Selector_Name => Name_Result),
5009 New_Occurrence_Of (Excep_Choice, Loc))));
5011 if Dynamically_Asynchronous then
5012 Excep_Code := New_List (
5013 Make_Implicit_If_Statement (Vis_Decl,
5014 Condition => Make_Op_Not (Loc,
5015 New_Occurrence_Of (Dynamic_Async, Loc)),
5016 Then_Statements => Excep_Code));
5019 Excep_Handlers := New_List (
5020 Make_Implicit_Exception_Handler (Loc,
5021 Choice_Parameter => Excep_Choice,
5022 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5023 Statements => Excep_Code));
5028 Make_Procedure_Specification (Loc,
5029 Defining_Unit_Name =>
5030 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
5032 Parameter_Specifications => New_List (
5033 Make_Parameter_Specification (Loc,
5034 Defining_Identifier => Request_Parameter,
5036 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5039 Make_Subprogram_Body (Loc,
5040 Specification => Subp_Spec,
5041 Declarations => Decls,
5042 Handled_Statement_Sequence =>
5043 Make_Handled_Sequence_Of_Statements (Loc,
5044 Statements => Statements,
5045 Exception_Handlers => Excep_Handlers));
5046 end Build_Subprogram_Receiving_Stubs;
5052 function Result return Node_Id is
5054 return Make_Identifier (Loc, Name_V);
5057 ----------------------
5058 -- Stream_Parameter --
5059 ----------------------
5061 function Stream_Parameter return Node_Id is
5063 return Make_Identifier (Loc, Name_S);
5064 end Stream_Parameter;
5068 -------------------------------
5069 -- Get_And_Reset_RACW_Bodies --
5070 -------------------------------
5072 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5073 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
5074 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5076 Body_Decls : List_Id;
5077 -- Returned list of declarations
5080 if Stub_Elements = Empty_Stub_Structure then
5082 -- Stub elements may be missing as a consequence of a previously
5088 Body_Decls := Stub_Elements.Body_Decls;
5089 Stub_Elements.Body_Decls := No_List;
5090 Stubs_Table.Set (Desig, Stub_Elements);
5092 end Get_And_Reset_RACW_Bodies;
5094 -----------------------
5095 -- Get_Subprogram_Id --
5096 -----------------------
5098 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5099 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5101 pragma Assert (Result /= No_String);
5103 end Get_Subprogram_Id;
5105 -----------------------
5106 -- Get_Subprogram_Id --
5107 -----------------------
5109 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5111 return Get_Subprogram_Ids (Def).Int_Identifier;
5112 end Get_Subprogram_Id;
5114 ------------------------
5115 -- Get_Subprogram_Ids --
5116 ------------------------
5118 function Get_Subprogram_Ids
5119 (Def : Entity_Id) return Subprogram_Identifiers
5122 return Subprogram_Identifier_Table.Get (Def);
5123 end Get_Subprogram_Ids;
5129 function Hash (F : Entity_Id) return Hash_Index is
5131 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5134 function Hash (F : Name_Id) return Hash_Index is
5136 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5139 --------------------------
5140 -- Input_With_Tag_Check --
5141 --------------------------
5143 function Input_With_Tag_Check
5145 Var_Type : Entity_Id;
5146 Stream : Node_Id) return Node_Id
5150 Make_Subprogram_Body (Loc,
5151 Specification => Make_Function_Specification (Loc,
5152 Defining_Unit_Name =>
5153 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
5154 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5155 Declarations => No_List,
5156 Handled_Statement_Sequence =>
5157 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5158 Make_Tag_Check (Loc,
5159 Make_Return_Statement (Loc,
5160 Make_Attribute_Reference (Loc,
5161 Prefix => New_Occurrence_Of (Var_Type, Loc),
5162 Attribute_Name => Name_Input,
5164 New_List (Stream)))))));
5165 end Input_With_Tag_Check;
5167 --------------------------------
5168 -- Is_RACW_Controlling_Formal --
5169 --------------------------------
5171 function Is_RACW_Controlling_Formal
5172 (Parameter : Node_Id;
5173 Stub_Type : Entity_Id) return Boolean
5178 -- If the kind of the parameter is E_Void, then it is not a
5179 -- controlling formal (this can happen in the context of RAS).
5181 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5185 -- If the parameter is not a controlling formal, then it cannot
5186 -- be possibly a RACW_Controlling_Formal.
5188 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5192 Typ := Parameter_Type (Parameter);
5193 return (Nkind (Typ) = N_Access_Definition
5194 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5195 or else Etype (Typ) = Stub_Type;
5196 end Is_RACW_Controlling_Formal;
5198 -----------------------------
5199 -- Make_Selected_Component --
5200 -----------------------------
5202 function Make_Selected_Component
5205 Selector_Name : Name_Id) return Node_Id
5208 return Make_Selected_Component (Loc,
5209 Prefix => New_Occurrence_Of (Prefix, Loc),
5210 Selector_Name => Make_Identifier (Loc, Selector_Name));
5211 end Make_Selected_Component;
5213 --------------------
5214 -- Make_Tag_Check --
5215 --------------------
5217 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5218 Occ : constant Entity_Id :=
5219 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5222 return Make_Block_Statement (Loc,
5223 Handled_Statement_Sequence =>
5224 Make_Handled_Sequence_Of_Statements (Loc,
5225 Statements => New_List (N),
5227 Exception_Handlers => New_List (
5228 Make_Implicit_Exception_Handler (Loc,
5229 Choice_Parameter => Occ,
5231 Exception_Choices =>
5232 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5235 New_List (Make_Procedure_Call_Statement (Loc,
5237 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5238 New_List (New_Occurrence_Of (Occ, Loc))))))));
5241 ----------------------------
5242 -- Need_Extra_Constrained --
5243 ----------------------------
5245 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5246 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5248 return Out_Present (Parameter)
5249 and then Has_Discriminants (Etyp)
5250 and then not Is_Constrained (Etyp)
5251 and then not Is_Indefinite_Subtype (Etyp);
5252 end Need_Extra_Constrained;
5254 ------------------------------------
5255 -- Pack_Entity_Into_Stream_Access --
5256 ------------------------------------
5258 function Pack_Entity_Into_Stream_Access
5262 Etyp : Entity_Id := Empty) return Node_Id
5267 if Present (Etyp) then
5270 Typ := Etype (Object);
5274 Pack_Node_Into_Stream_Access (Loc,
5276 Object => New_Occurrence_Of (Object, Loc),
5278 end Pack_Entity_Into_Stream_Access;
5280 ---------------------------
5281 -- Pack_Node_Into_Stream --
5282 ---------------------------
5284 function Pack_Node_Into_Stream
5288 Etyp : Entity_Id) return Node_Id
5290 Write_Attribute : Name_Id := Name_Write;
5293 if not Is_Constrained (Etyp) then
5294 Write_Attribute := Name_Output;
5298 Make_Attribute_Reference (Loc,
5299 Prefix => New_Occurrence_Of (Etyp, Loc),
5300 Attribute_Name => Write_Attribute,
5301 Expressions => New_List (
5302 Make_Attribute_Reference (Loc,
5303 Prefix => New_Occurrence_Of (Stream, Loc),
5304 Attribute_Name => Name_Access),
5306 end Pack_Node_Into_Stream;
5308 ----------------------------------
5309 -- Pack_Node_Into_Stream_Access --
5310 ----------------------------------
5312 function Pack_Node_Into_Stream_Access
5316 Etyp : Entity_Id) return Node_Id
5318 Write_Attribute : Name_Id := Name_Write;
5321 if not Is_Constrained (Etyp) then
5322 Write_Attribute := Name_Output;
5326 Make_Attribute_Reference (Loc,
5327 Prefix => New_Occurrence_Of (Etyp, Loc),
5328 Attribute_Name => Write_Attribute,
5329 Expressions => New_List (
5332 end Pack_Node_Into_Stream_Access;
5334 ---------------------
5335 -- PolyORB_Support --
5336 ---------------------
5338 package body PolyORB_Support is
5340 -- Local subprograms
5342 procedure Add_RACW_Read_Attribute
5343 (RACW_Type : Entity_Id;
5344 Stub_Type : Entity_Id;
5345 Stub_Type_Access : Entity_Id;
5346 Body_Decls : List_Id);
5347 -- Add Read attribute for the RACW type. The declaration and attribute
5348 -- definition clauses are inserted right after the declaration of
5349 -- RACW_Type, while the subprogram body is appended to Body_Decls.
5351 procedure Add_RACW_Write_Attribute
5352 (RACW_Type : Entity_Id;
5353 Stub_Type : Entity_Id;
5354 Stub_Type_Access : Entity_Id;
5355 Body_Decls : List_Id);
5356 -- Same as above for the Write attribute
5358 procedure Add_RACW_From_Any
5359 (RACW_Type : Entity_Id;
5360 Stub_Type : Entity_Id;
5361 Stub_Type_Access : Entity_Id;
5362 Body_Decls : List_Id);
5363 -- Add the From_Any TSS for this RACW type
5365 procedure Add_RACW_To_Any
5366 (Designated_Type : Entity_Id;
5367 RACW_Type : Entity_Id;
5368 Stub_Type : Entity_Id;
5369 Stub_Type_Access : Entity_Id;
5370 Body_Decls : List_Id);
5371 -- Add the To_Any TSS for this RACW type
5373 procedure Add_RACW_TypeCode
5374 (Designated_Type : Entity_Id;
5375 RACW_Type : Entity_Id;
5376 Body_Decls : List_Id);
5377 -- Add the TypeCode TSS for this RACW type
5379 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5380 -- Add the From_Any TSS for this RAS type
5382 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5383 -- Add the To_Any TSS for this RAS type
5385 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5386 -- Add the TypeCode TSS for this RAS type
5388 procedure Add_RAS_Access_TSS (N : Node_Id);
5389 -- Add a subprogram body for RAS Access TSS
5391 -------------------------------------
5392 -- Add_Obj_RPC_Receiver_Completion --
5393 -------------------------------------
5395 procedure Add_Obj_RPC_Receiver_Completion
5398 RPC_Receiver : Entity_Id;
5399 Stub_Elements : Stub_Structure)
5401 Desig : constant Entity_Id :=
5402 Etype (Designated_Type (Stub_Elements.RACW_Type));
5405 Make_Procedure_Call_Statement (Loc,
5408 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5410 Parameter_Associations => New_List (
5414 Make_String_Literal (Loc,
5415 Full_Qualified_Name (Desig)),
5419 Make_Attribute_Reference (Loc,
5422 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5428 Make_Attribute_Reference (Loc,
5431 Defining_Identifier (
5432 Stub_Elements.RPC_Receiver_Decl), Loc),
5435 end Add_Obj_RPC_Receiver_Completion;
5437 -----------------------
5438 -- Add_RACW_Features --
5439 -----------------------
5441 procedure Add_RACW_Features
5442 (RACW_Type : Entity_Id;
5444 Stub_Type : Entity_Id;
5445 Stub_Type_Access : Entity_Id;
5446 RPC_Receiver_Decl : Node_Id;
5447 Body_Decls : List_Id)
5449 pragma Warnings (Off);
5450 pragma Unreferenced (RPC_Receiver_Decl);
5451 pragma Warnings (On);
5455 (RACW_Type => RACW_Type,
5456 Stub_Type => Stub_Type,
5457 Stub_Type_Access => Stub_Type_Access,
5458 Body_Decls => Body_Decls);
5461 (Designated_Type => Desig,
5462 RACW_Type => RACW_Type,
5463 Stub_Type => Stub_Type,
5464 Stub_Type_Access => Stub_Type_Access,
5465 Body_Decls => Body_Decls);
5467 -- In the PolyORB case, the RACW 'Read and 'Write attributes are
5468 -- implemented in terms of the From_Any and To_Any TSSs, so these
5469 -- TSSs must be expanded before 'Read and 'Write.
5471 Add_RACW_Write_Attribute
5472 (RACW_Type => RACW_Type,
5473 Stub_Type => Stub_Type,
5474 Stub_Type_Access => Stub_Type_Access,
5475 Body_Decls => Body_Decls);
5477 Add_RACW_Read_Attribute
5478 (RACW_Type => RACW_Type,
5479 Stub_Type => Stub_Type,
5480 Stub_Type_Access => Stub_Type_Access,
5481 Body_Decls => Body_Decls);
5484 (Designated_Type => Desig,
5485 RACW_Type => RACW_Type,
5486 Body_Decls => Body_Decls);
5487 end Add_RACW_Features;
5489 -----------------------
5490 -- Add_RACW_From_Any --
5491 -----------------------
5493 procedure Add_RACW_From_Any
5494 (RACW_Type : Entity_Id;
5495 Stub_Type : Entity_Id;
5496 Stub_Type_Access : Entity_Id;
5497 Body_Decls : List_Id)
5499 Loc : constant Source_Ptr := Sloc (RACW_Type);
5500 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5502 Fnam : constant Entity_Id :=
5503 Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
5505 Func_Spec : Node_Id;
5506 Func_Decl : Node_Id;
5507 Func_Body : Node_Id;
5510 Statements : List_Id;
5511 Stub_Statements : List_Id;
5512 Local_Statements : List_Id;
5513 -- Various parts of the subprogram
5515 Any_Parameter : constant Entity_Id :=
5516 Make_Defining_Identifier (Loc, Name_A);
5517 Reference : constant Entity_Id :=
5518 Make_Defining_Identifier
5519 (Loc, New_Internal_Name ('R'));
5520 Is_Local : constant Entity_Id :=
5521 Make_Defining_Identifier
5522 (Loc, New_Internal_Name ('L'));
5523 Addr : constant Entity_Id :=
5524 Make_Defining_Identifier
5525 (Loc, New_Internal_Name ('A'));
5526 Local_Stub : constant Entity_Id :=
5527 Make_Defining_Identifier
5528 (Loc, New_Internal_Name ('L'));
5529 Stubbed_Result : constant Entity_Id :=
5530 Make_Defining_Identifier
5531 (Loc, New_Internal_Name ('S'));
5533 Stub_Condition : Node_Id;
5534 -- An expression that determines whether we create a stub for the
5535 -- newly-unpacked RACW. Normally we create a stub only for remote
5536 -- objects, but in the case of an RACW used to implement a RAS, we
5537 -- also create a stub for local subprograms if a pragma
5538 -- All_Calls_Remote applies.
5540 Asynchronous_Flag : constant Entity_Id :=
5541 Asynchronous_Flags_Table.Get (RACW_Type);
5542 -- The flag object declared in Add_RACW_Asynchronous_Flag
5546 -- Object declarations
5549 Make_Object_Declaration (Loc,
5550 Defining_Identifier =>
5552 Object_Definition =>
5553 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5555 Make_Function_Call (Loc,
5557 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5558 Parameter_Associations => New_List (
5559 New_Occurrence_Of (Any_Parameter, Loc)))),
5561 Make_Object_Declaration (Loc,
5562 Defining_Identifier => Local_Stub,
5563 Aliased_Present => True,
5564 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
5566 Make_Object_Declaration (Loc,
5567 Defining_Identifier => Stubbed_Result,
5568 Object_Definition =>
5569 New_Occurrence_Of (Stub_Type_Access, Loc),
5571 Make_Attribute_Reference (Loc,
5573 New_Occurrence_Of (Local_Stub, Loc),
5575 Name_Unchecked_Access)),
5577 Make_Object_Declaration (Loc,
5578 Defining_Identifier => Is_Local,
5579 Object_Definition =>
5580 New_Occurrence_Of (Standard_Boolean, Loc)),
5582 Make_Object_Declaration (Loc,
5583 Defining_Identifier => Addr,
5584 Object_Definition =>
5585 New_Occurrence_Of (RTE (RE_Address), Loc)));
5587 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5589 Set_Etype (Stubbed_Result, Stub_Type_Access);
5591 -- If the ref Is_Nil, return a null pointer
5593 Statements := New_List (
5594 Make_Implicit_If_Statement (RACW_Type,
5596 Make_Function_Call (Loc,
5598 New_Occurrence_Of (RTE (RE_Is_Nil), Loc),
5599 Parameter_Associations => New_List (
5600 New_Occurrence_Of (Reference, Loc))),
5601 Then_Statements => New_List (
5602 Make_Return_Statement (Loc,
5604 Make_Null (Loc)))));
5606 Append_To (Statements,
5607 Make_Procedure_Call_Statement (Loc,
5609 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
5610 Parameter_Associations => New_List (
5611 New_Occurrence_Of (Reference, Loc),
5612 New_Occurrence_Of (Is_Local, Loc),
5613 New_Occurrence_Of (Addr, Loc))));
5615 -- If the object is located on another partition, then a stub object
5616 -- will be created with all the information needed to rebuild the
5617 -- real object at the other end. This stanza is always used in the
5618 -- case of RAS types, for which a stub is required even for local
5621 Stub_Statements := New_List (
5622 Make_Assignment_Statement (Loc,
5623 Name => Make_Selected_Component (Loc,
5624 Prefix => Stubbed_Result,
5625 Selector_Name => Name_Target),
5627 Make_Function_Call (Loc,
5629 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
5630 Parameter_Associations => New_List (
5631 New_Occurrence_Of (Reference, Loc)))),
5633 Make_Procedure_Call_Statement (Loc,
5635 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
5636 Parameter_Associations => New_List (
5637 Make_Selected_Component (Loc,
5638 Prefix => Stubbed_Result,
5639 Selector_Name => Name_Target))),
5641 Make_Assignment_Statement (Loc,
5642 Name => Make_Selected_Component (Loc,
5643 Prefix => Stubbed_Result,
5644 Selector_Name => Name_Asynchronous),
5646 New_Occurrence_Of (Asynchronous_Flag, Loc)));
5648 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5649 -- set on the stub type if, and only if, the RACW type has a pragma
5650 -- Asynchronous. This is incorrect for RACWs that implement RAS
5651 -- types, because in that case the /designated subprogram/ (not the
5652 -- type) might be asynchronous, and that causes the stub to need to
5653 -- be asynchronous too. A solution is to transport a RAS as a struct
5654 -- containing a RACW and an asynchronous flag, and to properly alter
5655 -- the Asynchronous component in the stub type in the RAS's _From_Any
5658 Append_List_To (Stub_Statements,
5659 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
5661 -- Distinguish between the local and remote cases, and execute the
5662 -- appropriate piece of code.
5664 Stub_Condition := New_Occurrence_Of (Is_Local, Loc);
5667 Stub_Condition := Make_And_Then (Loc,
5671 Make_Selected_Component (Loc,
5673 Unchecked_Convert_To (
5674 RTE (RE_RAS_Proxy_Type_Access),
5675 New_Occurrence_Of (Addr, Loc)),
5677 Make_Identifier (Loc,
5678 Name_All_Calls_Remote)));
5681 Local_Statements := New_List (
5682 Make_Return_Statement (Loc,
5684 Unchecked_Convert_To (RACW_Type,
5685 New_Occurrence_Of (Addr, Loc))));
5687 Append_To (Statements,
5688 Make_Implicit_If_Statement (RACW_Type,
5691 Then_Statements => Local_Statements,
5692 Else_Statements => Stub_Statements));
5694 Append_To (Statements,
5695 Make_Return_Statement (Loc,
5696 Expression => Unchecked_Convert_To (RACW_Type,
5697 New_Occurrence_Of (Stubbed_Result, Loc))));
5700 Make_Function_Specification (Loc,
5701 Defining_Unit_Name =>
5703 Parameter_Specifications => New_List (
5704 Make_Parameter_Specification (Loc,
5705 Defining_Identifier =>
5708 New_Occurrence_Of (RTE (RE_Any), Loc))),
5709 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5711 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5712 -- entity in the declaration spec, not those of the body spec.
5714 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5717 Make_Subprogram_Body (Loc,
5719 Copy_Specification (Loc, Func_Spec),
5720 Declarations => Decls,
5721 Handled_Statement_Sequence =>
5722 Make_Handled_Sequence_Of_Statements (Loc,
5723 Statements => Statements));
5725 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5726 Append_To (Body_Decls, Func_Body);
5728 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5729 end Add_RACW_From_Any;
5731 -----------------------------
5732 -- Add_RACW_Read_Attribute --
5733 -----------------------------
5735 procedure Add_RACW_Read_Attribute
5736 (RACW_Type : Entity_Id;
5737 Stub_Type : Entity_Id;
5738 Stub_Type_Access : Entity_Id;
5739 Body_Decls : List_Id)
5741 pragma Warnings (Off);
5742 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5743 pragma Warnings (On);
5744 Loc : constant Source_Ptr := Sloc (RACW_Type);
5746 Proc_Decl : Node_Id;
5747 Attr_Decl : Node_Id;
5749 Body_Node : Node_Id;
5752 Statements : List_Id;
5753 -- Various parts of the procedure
5755 Procedure_Name : constant Name_Id :=
5756 New_Internal_Name ('R');
5757 Source_Ref : constant Entity_Id :=
5758 Make_Defining_Identifier
5759 (Loc, New_Internal_Name ('R'));
5760 Asynchronous_Flag : constant Entity_Id :=
5761 Asynchronous_Flags_Table.Get (RACW_Type);
5762 pragma Assert (Present (Asynchronous_Flag));
5764 function Stream_Parameter return Node_Id;
5765 function Result return Node_Id;
5766 -- Functions to create occurrences of the formal parameter names
5772 function Result return Node_Id is
5774 return Make_Identifier (Loc, Name_V);
5777 ----------------------
5778 -- Stream_Parameter --
5779 ----------------------
5781 function Stream_Parameter return Node_Id is
5783 return Make_Identifier (Loc, Name_S);
5784 end Stream_Parameter;
5786 -- Start of processing for Add_RACW_Read_Attribute
5789 -- Generate object declarations
5792 Make_Object_Declaration (Loc,
5793 Defining_Identifier => Source_Ref,
5794 Object_Definition =>
5795 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5797 Statements := New_List (
5798 Make_Attribute_Reference (Loc,
5800 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5801 Attribute_Name => Name_Read,
5802 Expressions => New_List (
5804 New_Occurrence_Of (Source_Ref, Loc))),
5805 Make_Assignment_Statement (Loc,
5809 PolyORB_Support.Helpers.Build_From_Any_Call (
5811 Make_Function_Call (Loc,
5813 New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5814 Parameter_Associations => New_List (
5815 New_Occurrence_Of (Source_Ref, Loc))),
5818 Build_Stream_Procedure
5819 (Loc, RACW_Type, Body_Node,
5820 Make_Defining_Identifier (Loc, Procedure_Name),
5821 Statements, Outp => True);
5822 Set_Declarations (Body_Node, Decls);
5824 Proc_Decl := Make_Subprogram_Declaration (Loc,
5825 Copy_Specification (Loc, Specification (Body_Node)));
5828 Make_Attribute_Definition_Clause (Loc,
5829 Name => New_Occurrence_Of (RACW_Type, Loc),
5833 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5835 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5836 Insert_After (Proc_Decl, Attr_Decl);
5837 Append_To (Body_Decls, Body_Node);
5838 end Add_RACW_Read_Attribute;
5840 ---------------------
5841 -- Add_RACW_To_Any --
5842 ---------------------
5844 procedure Add_RACW_To_Any
5845 (Designated_Type : Entity_Id;
5846 RACW_Type : Entity_Id;
5847 Stub_Type : Entity_Id;
5848 Stub_Type_Access : Entity_Id;
5849 Body_Decls : List_Id)
5851 Loc : constant Source_Ptr := Sloc (RACW_Type);
5853 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5857 Stub_Elements : constant Stub_Structure :=
5858 Stubs_Table.Get (Designated_Type);
5859 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5861 Func_Spec : Node_Id;
5862 Func_Decl : Node_Id;
5863 Func_Body : Node_Id;
5866 Statements : List_Id;
5867 Null_Statements : List_Id;
5868 Local_Statements : List_Id := No_List;
5869 Stub_Statements : List_Id;
5871 -- Various parts of the subprogram
5873 RACW_Parameter : constant Entity_Id
5874 := Make_Defining_Identifier (Loc, Name_R);
5876 Reference : constant Entity_Id :=
5877 Make_Defining_Identifier
5878 (Loc, New_Internal_Name ('R'));
5879 Any : constant Entity_Id :=
5880 Make_Defining_Identifier
5881 (Loc, New_Internal_Name ('A'));
5885 -- Object declarations
5888 Make_Object_Declaration (Loc,
5889 Defining_Identifier =>
5891 Object_Definition =>
5892 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
5893 Make_Object_Declaration (Loc,
5894 Defining_Identifier =>
5896 Object_Definition =>
5897 New_Occurrence_Of (RTE (RE_Any), Loc)));
5899 -- If the object is null, nothing to do (Reference is already
5902 Null_Statements := New_List (Make_Null_Statement (Loc));
5906 -- If the object is a RAS designating a local subprogram, we
5907 -- already have a target reference.
5909 Local_Statements := New_List (
5910 Make_Procedure_Call_Statement (Loc,
5912 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
5913 Parameter_Associations => New_List (
5914 New_Occurrence_Of (Reference, Loc),
5915 Make_Selected_Component (Loc,
5917 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
5918 New_Occurrence_Of (RACW_Parameter, Loc)),
5919 Selector_Name => Make_Identifier (Loc, Name_Target)))));
5922 -- If the object is a local RACW object, use Get_Reference now to
5923 -- obtain a reference.
5925 Local_Statements := New_List (
5926 Make_Procedure_Call_Statement (Loc,
5928 New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5929 Parameter_Associations => New_List (
5930 Unchecked_Convert_To (
5932 New_Occurrence_Of (RACW_Parameter, Loc)),
5933 Make_String_Literal (Loc,
5934 Full_Qualified_Name (Designated_Type)),
5935 Make_Attribute_Reference (Loc,
5938 Defining_Identifier (
5939 Stub_Elements.RPC_Receiver_Decl), Loc),
5942 New_Occurrence_Of (Reference, Loc))));
5945 -- If the object is located on another partition, use the target from
5948 Stub_Statements := New_List (
5949 Make_Procedure_Call_Statement (Loc,
5951 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
5952 Parameter_Associations => New_List (
5953 New_Occurrence_Of (Reference, Loc),
5954 Make_Selected_Component (Loc,
5955 Prefix => Unchecked_Convert_To (Stub_Type_Access,
5956 New_Occurrence_Of (RACW_Parameter, Loc)),
5958 Make_Identifier (Loc, Name_Target)))));
5960 -- Distinguish between the null, local and remote cases, and execute
5961 -- the appropriate piece of code.
5964 Make_Implicit_If_Statement (RACW_Type,
5967 Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc),
5968 Right_Opnd => Make_Null (Loc)),
5969 Then_Statements => Null_Statements,
5970 Elsif_Parts => New_List (
5971 Make_Elsif_Part (Loc,
5975 Make_Attribute_Reference (Loc,
5977 New_Occurrence_Of (RACW_Parameter, Loc),
5978 Attribute_Name => Name_Tag),
5980 Make_Attribute_Reference (Loc,
5981 Prefix => New_Occurrence_Of (Stub_Type, Loc),
5982 Attribute_Name => Name_Tag)),
5983 Then_Statements => Local_Statements)),
5984 Else_Statements => Stub_Statements);
5986 Statements := New_List (
5988 Make_Assignment_Statement (Loc,
5990 New_Occurrence_Of (Any, Loc),
5992 Make_Function_Call (Loc,
5993 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5994 Parameter_Associations => New_List (
5995 New_Occurrence_Of (Reference, Loc)))),
5996 Make_Procedure_Call_Statement (Loc,
5998 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5999 Parameter_Associations => New_List (
6000 New_Occurrence_Of (Any, Loc),
6001 Make_Selected_Component (Loc,
6003 Defining_Identifier (
6004 Stub_Elements.RPC_Receiver_Decl),
6005 Selector_Name => Name_Obj_TypeCode))),
6006 Make_Return_Statement (Loc,
6008 New_Occurrence_Of (Any, Loc)));
6010 Fnam := Make_Defining_Identifier (
6011 Loc, New_Internal_Name ('T'));
6014 Make_Function_Specification (Loc,
6015 Defining_Unit_Name =>
6017 Parameter_Specifications => New_List (
6018 Make_Parameter_Specification (Loc,
6019 Defining_Identifier =>
6022 New_Occurrence_Of (RACW_Type, Loc))),
6023 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6025 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6026 -- entity in the declaration spec, not in the body spec.
6028 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6031 Make_Subprogram_Body (Loc,
6033 Copy_Specification (Loc, Func_Spec),
6034 Declarations => Decls,
6035 Handled_Statement_Sequence =>
6036 Make_Handled_Sequence_Of_Statements (Loc,
6037 Statements => Statements));
6039 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6040 Append_To (Body_Decls, Func_Body);
6042 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
6043 end Add_RACW_To_Any;
6045 -----------------------
6046 -- Add_RACW_TypeCode --
6047 -----------------------
6049 procedure Add_RACW_TypeCode
6050 (Designated_Type : Entity_Id;
6051 RACW_Type : Entity_Id;
6052 Body_Decls : List_Id)
6054 Loc : constant Source_Ptr := Sloc (RACW_Type);
6058 Stub_Elements : constant Stub_Structure :=
6059 Stubs_Table.Get (Designated_Type);
6060 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6062 Func_Spec : Node_Id;
6063 Func_Decl : Node_Id;
6064 Func_Body : Node_Id;
6068 Make_Defining_Identifier (Loc,
6069 Chars => New_Internal_Name ('T'));
6071 -- The spec for this subprogram has a dummy 'access RACW' argument,
6072 -- which serves only for overloading purposes.
6075 Make_Function_Specification (Loc,
6076 Defining_Unit_Name =>
6078 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6080 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6081 -- entity in the declaration spec, not those of the body spec.
6083 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6086 Make_Subprogram_Body (Loc,
6088 Copy_Specification (Loc, Func_Spec),
6089 Declarations => Empty_List,
6090 Handled_Statement_Sequence =>
6091 Make_Handled_Sequence_Of_Statements (Loc,
6092 Statements => New_List (
6093 Make_Return_Statement (Loc,
6095 Make_Selected_Component (Loc,
6097 Defining_Identifier (
6098 Stub_Elements.RPC_Receiver_Decl),
6099 Selector_Name => Name_Obj_TypeCode)))));
6101 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6102 Append_To (Body_Decls, Func_Body);
6104 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6105 end Add_RACW_TypeCode;
6107 ------------------------------
6108 -- Add_RACW_Write_Attribute --
6109 ------------------------------
6111 procedure Add_RACW_Write_Attribute
6112 (RACW_Type : Entity_Id;
6113 Stub_Type : Entity_Id;
6114 Stub_Type_Access : Entity_Id;
6115 Body_Decls : List_Id)
6117 pragma Warnings (Off);
6118 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6119 pragma Warnings (On);
6121 Loc : constant Source_Ptr := Sloc (RACW_Type);
6123 Body_Node : Node_Id;
6124 Proc_Decl : Node_Id;
6125 Attr_Decl : Node_Id;
6127 Statements : List_Id;
6128 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
6130 function Stream_Parameter return Node_Id;
6131 function Object return Node_Id;
6132 -- Functions to create occurrences of the formal parameter names
6138 function Object return Node_Id is
6139 Object_Ref : constant Node_Id :=
6140 Make_Identifier (Loc, Name_V);
6143 -- Etype must be set for Build_To_Any_Call
6145 Set_Etype (Object_Ref, RACW_Type);
6150 ----------------------
6151 -- Stream_Parameter --
6152 ----------------------
6154 function Stream_Parameter return Node_Id is
6156 return Make_Identifier (Loc, Name_S);
6157 end Stream_Parameter;
6159 -- Start of processing for Add_RACW_Write_Attribute
6162 Statements := New_List (
6163 Pack_Node_Into_Stream_Access (Loc,
6164 Stream => Stream_Parameter,
6166 Make_Function_Call (Loc,
6168 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
6169 Parameter_Associations => New_List (
6170 PolyORB_Support.Helpers.Build_To_Any_Call
6171 (Object, Body_Decls))),
6172 Etyp => RTE (RE_Object_Ref)));
6174 Build_Stream_Procedure
6175 (Loc, RACW_Type, Body_Node,
6176 Make_Defining_Identifier (Loc, Procedure_Name),
6177 Statements, Outp => False);
6180 Make_Subprogram_Declaration (Loc,
6181 Copy_Specification (Loc, Specification (Body_Node)));
6184 Make_Attribute_Definition_Clause (Loc,
6185 Name => New_Occurrence_Of (RACW_Type, Loc),
6186 Chars => Name_Write,
6189 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6191 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6192 Insert_After (Proc_Decl, Attr_Decl);
6193 Append_To (Body_Decls, Body_Node);
6194 end Add_RACW_Write_Attribute;
6196 -----------------------
6197 -- Add_RAST_Features --
6198 -----------------------
6200 procedure Add_RAST_Features
6201 (Vis_Decl : Node_Id;
6202 RAS_Type : Entity_Id)
6205 Add_RAS_Access_TSS (Vis_Decl);
6207 Add_RAS_From_Any (RAS_Type);
6208 Add_RAS_TypeCode (RAS_Type);
6210 -- To_Any uses TypeCode, and therefore needs to be generated last
6212 Add_RAS_To_Any (RAS_Type);
6213 end Add_RAST_Features;
6215 ------------------------
6216 -- Add_RAS_Access_TSS --
6217 ------------------------
6219 procedure Add_RAS_Access_TSS (N : Node_Id) is
6220 Loc : constant Source_Ptr := Sloc (N);
6222 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6223 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6224 -- Ras_Type is the access to subprogram type; Fat_Type is the
6225 -- corresponding record type.
6227 RACW_Type : constant Entity_Id :=
6228 Underlying_RACW_Type (Ras_Type);
6229 Desig : constant Entity_Id :=
6230 Etype (Designated_Type (RACW_Type));
6232 Stub_Elements : constant Stub_Structure :=
6233 Stubs_Table.Get (Desig);
6234 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6236 Proc : constant Entity_Id :=
6237 Make_Defining_Identifier (Loc,
6238 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6240 Proc_Spec : Node_Id;
6242 -- Formal parameters
6244 Package_Name : constant Entity_Id :=
6245 Make_Defining_Identifier (Loc,
6250 Subp_Id : constant Entity_Id :=
6251 Make_Defining_Identifier (Loc,
6254 -- Target subprogram
6256 Asynch_P : constant Entity_Id :=
6257 Make_Defining_Identifier (Loc,
6258 Chars => Name_Asynchronous);
6259 -- Is the procedure to which the 'Access applies asynchronous?
6261 All_Calls_Remote : constant Entity_Id :=
6262 Make_Defining_Identifier (Loc,
6263 Chars => Name_All_Calls_Remote);
6264 -- True if an All_Calls_Remote pragma applies to the RCI unit
6265 -- that contains the subprogram.
6267 -- Common local variables
6269 Proc_Decls : List_Id;
6270 Proc_Statements : List_Id;
6272 Subp_Ref : constant Entity_Id :=
6273 Make_Defining_Identifier (Loc, Name_R);
6274 -- Reference that designates the target subprogram (returned
6275 -- by Get_RAS_Info).
6277 Is_Local : constant Entity_Id :=
6278 Make_Defining_Identifier (Loc, Name_L);
6279 Local_Addr : constant Entity_Id :=
6280 Make_Defining_Identifier (Loc, Name_A);
6281 -- For the call to Get_Local_Address
6283 -- Additional local variables for the remote case
6285 Local_Stub : constant Entity_Id :=
6286 Make_Defining_Identifier (Loc,
6287 Chars => New_Internal_Name ('L'));
6289 Stub_Ptr : constant Entity_Id :=
6290 Make_Defining_Identifier (Loc,
6291 Chars => New_Internal_Name ('S'));
6294 (Field_Name : Name_Id;
6295 Value : Node_Id) return Node_Id;
6296 -- Construct an assignment that sets the named component in the
6304 (Field_Name : Name_Id;
6305 Value : Node_Id) return Node_Id
6309 Make_Assignment_Statement (Loc,
6311 Make_Selected_Component (Loc,
6313 Selector_Name => Field_Name),
6314 Expression => Value);
6317 -- Start of processing for Add_RAS_Access_TSS
6320 Proc_Decls := New_List (
6322 -- Common declarations
6324 Make_Object_Declaration (Loc,
6325 Defining_Identifier => Subp_Ref,
6326 Object_Definition =>
6327 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6329 Make_Object_Declaration (Loc,
6330 Defining_Identifier => Is_Local,
6331 Object_Definition =>
6332 New_Occurrence_Of (Standard_Boolean, Loc)),
6334 Make_Object_Declaration (Loc,
6335 Defining_Identifier => Local_Addr,
6336 Object_Definition =>
6337 New_Occurrence_Of (RTE (RE_Address), Loc)),
6339 Make_Object_Declaration (Loc,
6340 Defining_Identifier => Local_Stub,
6341 Aliased_Present => True,
6342 Object_Definition =>
6343 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6345 Make_Object_Declaration (Loc,
6346 Defining_Identifier =>
6348 Object_Definition =>
6349 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6351 Make_Attribute_Reference (Loc,
6352 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6353 Attribute_Name => Name_Unchecked_Access)));
6355 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6356 -- Build_Get_Unique_RP_Call needs this information
6358 -- Get_RAS_Info (Pkg, Subp, R);
6359 -- Obtain a reference to the target subprogram
6361 Proc_Statements := New_List (
6362 Make_Procedure_Call_Statement (Loc,
6364 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6365 Parameter_Associations => New_List (
6366 New_Occurrence_Of (Package_Name, Loc),
6367 New_Occurrence_Of (Subp_Id, Loc),
6368 New_Occurrence_Of (Subp_Ref, Loc))),
6370 -- Get_Local_Address (R, L, A);
6371 -- Determine whether the subprogram is local (L), and if so
6372 -- obtain the local address of its proxy (A).
6374 Make_Procedure_Call_Statement (Loc,
6376 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6377 Parameter_Associations => New_List (
6378 New_Occurrence_Of (Subp_Ref, Loc),
6379 New_Occurrence_Of (Is_Local, Loc),
6380 New_Occurrence_Of (Local_Addr, Loc))));
6382 -- Note: Here we assume that the Fat_Type is a record containing just
6383 -- an access to a proxy or stub object.
6385 Append_To (Proc_Statements,
6389 Make_Implicit_If_Statement (N,
6391 New_Occurrence_Of (Is_Local, Loc),
6393 Then_Statements => New_List (
6395 -- if A.Target = null then
6397 Make_Implicit_If_Statement (N,
6400 Make_Selected_Component (Loc,
6402 Unchecked_Convert_To (
6403 RTE (RE_RAS_Proxy_Type_Access),
6404 New_Occurrence_Of (Local_Addr, Loc)),
6406 Make_Identifier (Loc, Name_Target)),
6409 Then_Statements => New_List (
6411 -- A.Target := Entity_Of (Ref);
6413 Make_Assignment_Statement (Loc,
6415 Make_Selected_Component (Loc,
6417 Unchecked_Convert_To (
6418 RTE (RE_RAS_Proxy_Type_Access),
6419 New_Occurrence_Of (Local_Addr, Loc)),
6421 Make_Identifier (Loc, Name_Target)),
6423 Make_Function_Call (Loc,
6425 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6426 Parameter_Associations => New_List (
6427 New_Occurrence_Of (Subp_Ref, Loc)))),
6429 -- Inc_Usage (A.Target);
6431 Make_Procedure_Call_Statement (Loc,
6433 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6434 Parameter_Associations => New_List (
6435 Make_Selected_Component (Loc,
6437 Unchecked_Convert_To (
6438 RTE (RE_RAS_Proxy_Type_Access),
6439 New_Occurrence_Of (Local_Addr, Loc)),
6440 Selector_Name => Make_Identifier (Loc,
6444 -- if not All_Calls_Remote then
6445 -- return Fat_Type!(A);
6448 Make_Implicit_If_Statement (N,
6451 New_Occurrence_Of (All_Calls_Remote, Loc)),
6453 Then_Statements => New_List (
6454 Make_Return_Statement (Loc,
6455 Unchecked_Convert_To (Fat_Type,
6456 New_Occurrence_Of (Local_Addr, Loc))))))));
6458 Append_List_To (Proc_Statements, New_List (
6460 -- Stub.Target := Entity_Of (Ref);
6462 Set_Field (Name_Target,
6463 Make_Function_Call (Loc,
6465 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6466 Parameter_Associations => New_List (
6467 New_Occurrence_Of (Subp_Ref, Loc)))),
6469 -- Inc_Usage (Stub.Target);
6471 Make_Procedure_Call_Statement (Loc,
6473 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6474 Parameter_Associations => New_List (
6475 Make_Selected_Component (Loc,
6477 Selector_Name => Name_Target))),
6479 -- E.4.1(9) A remote call is asynchronous if it is a call to
6480 -- a procedure, or a call through a value of an access-to-procedure
6481 -- type, to which a pragma Asynchronous applies.
6483 -- Parameter Asynch_P is true when the procedure is asynchronous;
6484 -- Expression Asynch_T is true when the type is asynchronous.
6486 Set_Field (Name_Asynchronous,
6488 New_Occurrence_Of (Asynch_P, Loc),
6489 New_Occurrence_Of (Boolean_Literals (
6490 Is_Asynchronous (Ras_Type)), Loc)))));
6492 Append_List_To (Proc_Statements,
6493 Build_Get_Unique_RP_Call (Loc,
6494 Stub_Ptr, Stub_Elements.Stub_Type));
6496 Append_To (Proc_Statements,
6497 Make_Return_Statement (Loc,
6499 Unchecked_Convert_To (Fat_Type,
6500 New_Occurrence_Of (Stub_Ptr, Loc))));
6503 Make_Function_Specification (Loc,
6504 Defining_Unit_Name => Proc,
6505 Parameter_Specifications => New_List (
6506 Make_Parameter_Specification (Loc,
6507 Defining_Identifier => Package_Name,
6509 New_Occurrence_Of (Standard_String, Loc)),
6511 Make_Parameter_Specification (Loc,
6512 Defining_Identifier => Subp_Id,
6514 New_Occurrence_Of (Standard_String, Loc)),
6516 Make_Parameter_Specification (Loc,
6517 Defining_Identifier => Asynch_P,
6519 New_Occurrence_Of (Standard_Boolean, Loc)),
6521 Make_Parameter_Specification (Loc,
6522 Defining_Identifier => All_Calls_Remote,
6524 New_Occurrence_Of (Standard_Boolean, Loc))),
6526 Result_Definition =>
6527 New_Occurrence_Of (Fat_Type, Loc));
6529 -- Set the kind and return type of the function to prevent
6530 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6532 Set_Ekind (Proc, E_Function);
6533 Set_Etype (Proc, Fat_Type);
6536 Make_Subprogram_Body (Loc,
6537 Specification => Proc_Spec,
6538 Declarations => Proc_Decls,
6539 Handled_Statement_Sequence =>
6540 Make_Handled_Sequence_Of_Statements (Loc,
6541 Statements => Proc_Statements)));
6543 Set_TSS (Fat_Type, Proc);
6544 end Add_RAS_Access_TSS;
6546 ----------------------
6547 -- Add_RAS_From_Any --
6548 ----------------------
6550 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6551 Loc : constant Source_Ptr := Sloc (RAS_Type);
6553 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6554 Make_TSS_Name (RAS_Type, TSS_From_Any));
6556 Func_Spec : Node_Id;
6558 Statements : List_Id;
6560 Any_Parameter : constant Entity_Id :=
6561 Make_Defining_Identifier (Loc, Name_A);
6564 Statements := New_List (
6565 Make_Return_Statement (Loc,
6567 Make_Aggregate (Loc,
6568 Component_Associations => New_List (
6569 Make_Component_Association (Loc,
6570 Choices => New_List (
6571 Make_Identifier (Loc, Name_Ras)),
6573 PolyORB_Support.Helpers.Build_From_Any_Call (
6574 Underlying_RACW_Type (RAS_Type),
6575 New_Occurrence_Of (Any_Parameter, Loc),
6579 Make_Function_Specification (Loc,
6580 Defining_Unit_Name =>
6582 Parameter_Specifications => New_List (
6583 Make_Parameter_Specification (Loc,
6584 Defining_Identifier =>
6587 New_Occurrence_Of (RTE (RE_Any), Loc))),
6588 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6591 Make_Subprogram_Body (Loc,
6592 Specification => Func_Spec,
6593 Declarations => No_List,
6594 Handled_Statement_Sequence =>
6595 Make_Handled_Sequence_Of_Statements (Loc,
6596 Statements => Statements)));
6597 Set_TSS (RAS_Type, Fnam);
6598 end Add_RAS_From_Any;
6600 --------------------
6601 -- Add_RAS_To_Any --
6602 --------------------
6604 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6605 Loc : constant Source_Ptr := Sloc (RAS_Type);
6607 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6608 Make_TSS_Name (RAS_Type, TSS_To_Any));
6611 Statements : List_Id;
6613 Func_Spec : Node_Id;
6615 Any : constant Entity_Id :=
6616 Make_Defining_Identifier (Loc,
6617 Chars => New_Internal_Name ('A'));
6618 RAS_Parameter : constant Entity_Id :=
6619 Make_Defining_Identifier (Loc,
6620 Chars => New_Internal_Name ('R'));
6621 RACW_Parameter : constant Node_Id :=
6622 Make_Selected_Component (Loc,
6623 Prefix => RAS_Parameter,
6624 Selector_Name => Name_Ras);
6627 -- Object declarations
6629 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6631 Make_Object_Declaration (Loc,
6632 Defining_Identifier =>
6634 Object_Definition =>
6635 New_Occurrence_Of (RTE (RE_Any), Loc),
6637 PolyORB_Support.Helpers.Build_To_Any_Call
6638 (RACW_Parameter, No_List)));
6640 Statements := New_List (
6641 Make_Procedure_Call_Statement (Loc,
6643 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6644 Parameter_Associations => New_List (
6645 New_Occurrence_Of (Any, Loc),
6646 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6648 Make_Return_Statement (Loc,
6650 New_Occurrence_Of (Any, Loc)));
6653 Make_Function_Specification (Loc,
6654 Defining_Unit_Name =>
6656 Parameter_Specifications => New_List (
6657 Make_Parameter_Specification (Loc,
6658 Defining_Identifier =>
6661 New_Occurrence_Of (RAS_Type, Loc))),
6662 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6665 Make_Subprogram_Body (Loc,
6666 Specification => Func_Spec,
6667 Declarations => Decls,
6668 Handled_Statement_Sequence =>
6669 Make_Handled_Sequence_Of_Statements (Loc,
6670 Statements => Statements)));
6671 Set_TSS (RAS_Type, Fnam);
6674 ----------------------
6675 -- Add_RAS_TypeCode --
6676 ----------------------
6678 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6679 Loc : constant Source_Ptr := Sloc (RAS_Type);
6681 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6682 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6684 Func_Spec : Node_Id;
6686 Decls : constant List_Id := New_List;
6687 Name_String, Repo_Id_String : String_Id;
6691 Make_Function_Specification (Loc,
6692 Defining_Unit_Name =>
6694 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6696 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6697 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6700 Make_Subprogram_Body (Loc,
6701 Specification => Func_Spec,
6702 Declarations => Decls,
6703 Handled_Statement_Sequence =>
6704 Make_Handled_Sequence_Of_Statements (Loc,
6705 Statements => New_List (
6706 Make_Return_Statement (Loc,
6708 Make_Function_Call (Loc,
6710 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6711 Parameter_Associations => New_List (
6712 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6713 Make_Aggregate (Loc,
6716 Make_Function_Call (Loc,
6717 Name => New_Occurrence_Of (
6718 RTE (RE_TA_String), Loc),
6719 Parameter_Associations => New_List (
6720 Make_String_Literal (Loc, Name_String))),
6721 Make_Function_Call (Loc,
6722 Name => New_Occurrence_Of (
6723 RTE (RE_TA_String), Loc),
6724 Parameter_Associations => New_List (
6725 Make_String_Literal (Loc,
6726 Repo_Id_String))))))))))));
6727 Set_TSS (RAS_Type, Fnam);
6728 end Add_RAS_TypeCode;
6730 -----------------------------------------
6731 -- Add_Receiving_Stubs_To_Declarations --
6732 -----------------------------------------
6734 procedure Add_Receiving_Stubs_To_Declarations
6735 (Pkg_Spec : Node_Id;
6739 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6741 Pkg_RPC_Receiver : constant Entity_Id :=
6742 Make_Defining_Identifier (Loc,
6743 New_Internal_Name ('H'));
6744 Pkg_RPC_Receiver_Object : Node_Id;
6746 Pkg_RPC_Receiver_Body : Node_Id;
6747 Pkg_RPC_Receiver_Decls : List_Id;
6748 Pkg_RPC_Receiver_Statements : List_Id;
6749 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6750 -- A Pkg_RPC_Receiver is built to decode the request
6753 -- Request object received from neutral layer
6755 Subp_Id : Entity_Id;
6756 -- Subprogram identifier as received from the neutral
6757 -- distribution core.
6759 Subp_Index : Entity_Id;
6760 -- Internal index as determined by matching either the
6761 -- method name from the request structure, or the local
6762 -- subprogram address (in case of a RAS).
6764 Is_Local : constant Entity_Id :=
6765 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
6766 Local_Address : constant Entity_Id :=
6767 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
6768 -- Address of a local subprogram designated by a
6769 -- reference corresponding to a RAS.
6771 Dispatch_On_Address : constant List_Id := New_List;
6772 Dispatch_On_Name : constant List_Id := New_List;
6774 Current_Declaration : Node_Id;
6775 Current_Stubs : Node_Id;
6776 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6778 Subp_Info_Array : constant Entity_Id :=
6779 Make_Defining_Identifier (Loc,
6780 Chars => New_Internal_Name ('I'));
6782 Subp_Info_List : constant List_Id := New_List;
6784 Register_Pkg_Actuals : constant List_Id := New_List;
6786 All_Calls_Remote_E : Entity_Id;
6788 procedure Append_Stubs_To
6789 (RPC_Receiver_Cases : List_Id;
6790 Declaration : Node_Id;
6793 Subp_Dist_Name : Entity_Id;
6794 Subp_Proxy_Addr : Entity_Id);
6795 -- Add one case to the specified RPC receiver case list associating
6796 -- Subprogram_Number with the subprogram declared by Declaration, for
6797 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6798 -- subprogram index. Subp_Dist_Name is the string used to call the
6799 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6800 -- object, used in the context of calls through remote
6801 -- access-to-subprogram types.
6803 ---------------------
6804 -- Append_Stubs_To --
6805 ---------------------
6807 procedure Append_Stubs_To
6808 (RPC_Receiver_Cases : List_Id;
6809 Declaration : Node_Id;
6812 Subp_Dist_Name : Entity_Id;
6813 Subp_Proxy_Addr : Entity_Id)
6815 Case_Stmts : List_Id;
6817 Case_Stmts := New_List (
6818 Make_Procedure_Call_Statement (Loc,
6821 Defining_Entity (Stubs), Loc),
6822 Parameter_Associations =>
6823 New_List (New_Occurrence_Of (Request, Loc))));
6824 if Nkind (Specification (Declaration))
6825 = N_Function_Specification
6827 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6829 Append_To (Case_Stmts, Make_Return_Statement (Loc));
6832 Append_To (RPC_Receiver_Cases,
6833 Make_Case_Statement_Alternative (Loc,
6835 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6839 Append_To (Dispatch_On_Name,
6840 Make_Elsif_Part (Loc,
6842 Make_Function_Call (Loc,
6844 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6845 Parameter_Associations => New_List (
6846 New_Occurrence_Of (Subp_Id, Loc),
6847 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6848 Then_Statements => New_List (
6849 Make_Assignment_Statement (Loc,
6850 New_Occurrence_Of (Subp_Index, Loc),
6851 Make_Integer_Literal (Loc,
6854 Append_To (Dispatch_On_Address,
6855 Make_Elsif_Part (Loc,
6859 New_Occurrence_Of (Local_Address, Loc),
6861 New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6862 Then_Statements => New_List (
6863 Make_Assignment_Statement (Loc,
6864 New_Occurrence_Of (Subp_Index, Loc),
6865 Make_Integer_Literal (Loc,
6867 end Append_Stubs_To;
6869 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6872 -- Building receiving stubs consist in several operations:
6874 -- - a package RPC receiver must be built. This subprogram
6875 -- will get a Subprogram_Id from the incoming stream
6876 -- and will dispatch the call to the right subprogram
6878 -- - a receiving stub for any subprogram visible in the package
6879 -- spec. This stub will read all the parameters from the stream,
6880 -- and put the result as well as the exception occurrence in the
6883 -- - a dummy package with an empty spec and a body made of an
6884 -- elaboration part, whose job is to register the receiving
6885 -- part of this RCI package on the name server. This is done
6886 -- by calling System.Partition_Interface.Register_Receiving_Stub
6888 Build_RPC_Receiver_Body (
6889 RPC_Receiver => Pkg_RPC_Receiver,
6892 Subp_Index => Subp_Index,
6893 Stmts => Pkg_RPC_Receiver_Statements,
6894 Decl => Pkg_RPC_Receiver_Body);
6895 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6897 -- Extract local address information from the target reference:
6898 -- if non-null, that means that this is a reference that denotes
6899 -- one particular operation, and hence that the operation name
6900 -- must not be taken into account for dispatching.
6902 Append_To (Pkg_RPC_Receiver_Decls,
6903 Make_Object_Declaration (Loc,
6904 Defining_Identifier =>
6906 Object_Definition =>
6907 New_Occurrence_Of (Standard_Boolean, Loc)));
6908 Append_To (Pkg_RPC_Receiver_Decls,
6909 Make_Object_Declaration (Loc,
6910 Defining_Identifier =>
6912 Object_Definition =>
6913 New_Occurrence_Of (RTE (RE_Address), Loc)));
6914 Append_To (Pkg_RPC_Receiver_Statements,
6915 Make_Procedure_Call_Statement (Loc,
6917 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6918 Parameter_Associations => New_List (
6919 Make_Selected_Component (Loc,
6921 Selector_Name => Name_Target),
6922 New_Occurrence_Of (Is_Local, Loc),
6923 New_Occurrence_Of (Local_Address, Loc))));
6925 -- Determine whether the reference that was used to make
6926 -- the call was the base RCI reference (in which case
6927 -- Local_Address is 0, and the method identifier from the
6928 -- request must be used to determine which subprogram is
6929 -- called) or a reference identifying one particular subprogram
6930 -- (in which case Local_Address is the address of that
6931 -- subprogram, and the method name from the request is
6933 -- In each case, cascaded elsifs are used to determine the
6934 -- proper subprogram index. Using hash tables might be
6937 Append_To (Pkg_RPC_Receiver_Statements,
6938 Make_Implicit_If_Statement (Pkg_Spec,
6941 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6942 Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
6943 Then_Statements => New_List (
6944 Make_Implicit_If_Statement (Pkg_Spec,
6946 New_Occurrence_Of (Standard_False, Loc),
6947 Then_Statements => New_List (
6948 Make_Null_Statement (Loc)),
6950 Dispatch_On_Address)),
6951 Else_Statements => New_List (
6952 Make_Implicit_If_Statement (Pkg_Spec,
6954 New_Occurrence_Of (Standard_False, Loc),
6955 Then_Statements => New_List (
6956 Make_Null_Statement (Loc)),
6958 Dispatch_On_Name))));
6960 -- For each subprogram, the receiving stub will be built and a
6961 -- case statement will be made on the Subprogram_Id to dispatch
6962 -- to the right subprogram.
6964 All_Calls_Remote_E := Boolean_Literals (
6965 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6967 Overload_Counter_Table.Reset;
6968 Reserve_NamingContext_Methods;
6970 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
6971 while Present (Current_Declaration) loop
6972 if Nkind (Current_Declaration) = N_Subprogram_Declaration
6973 and then Comes_From_Source (Current_Declaration)
6976 Loc : constant Source_Ptr :=
6977 Sloc (Current_Declaration);
6978 -- While specifically processing Current_Declaration, use
6979 -- its Sloc as the location of all generated nodes.
6981 Subp_Def : constant Entity_Id :=
6983 (Specification (Current_Declaration));
6985 Subp_Val : String_Id;
6987 Subp_Dist_Name : constant Entity_Id :=
6988 Make_Defining_Identifier (Loc,
6990 Related_Id => Chars (Subp_Def),
6992 Suffix_Index => -1));
6994 Proxy_Object_Addr : Entity_Id;
6997 -- Build receiving stub
7000 Build_Subprogram_Receiving_Stubs
7001 (Vis_Decl => Current_Declaration,
7003 Nkind (Specification (Current_Declaration)) =
7004 N_Procedure_Specification
7005 and then Is_Asynchronous (Subp_Def));
7007 Append_To (Decls, Current_Stubs);
7008 Analyze (Current_Stubs);
7012 Add_RAS_Proxy_And_Analyze (Decls,
7014 Current_Declaration,
7015 All_Calls_Remote_E =>
7017 Proxy_Object_Addr =>
7020 -- Compute distribution identifier
7022 Assign_Subprogram_Identifier (
7024 Current_Subprogram_Number,
7027 pragma Assert (Current_Subprogram_Number =
7028 Get_Subprogram_Id (Subp_Def));
7031 Make_Object_Declaration (Loc,
7032 Defining_Identifier => Subp_Dist_Name,
7033 Constant_Present => True,
7034 Object_Definition => New_Occurrence_Of (
7035 Standard_String, Loc),
7037 Make_String_Literal (Loc, Subp_Val)));
7038 Analyze (Last (Decls));
7040 -- Add subprogram descriptor (RCI_Subp_Info) to the
7041 -- subprograms table for this receiver. The aggregate
7042 -- below must be kept consistent with the declaration
7043 -- of type RCI_Subp_Info in System.Partition_Interface.
7045 Append_To (Subp_Info_List,
7046 Make_Component_Association (Loc,
7047 Choices => New_List (
7048 Make_Integer_Literal (Loc,
7049 Current_Subprogram_Number)),
7051 Make_Aggregate (Loc,
7052 Expressions => New_List (
7053 Make_Attribute_Reference (Loc,
7056 Subp_Dist_Name, Loc),
7057 Attribute_Name => Name_Address),
7058 Make_Attribute_Reference (Loc,
7061 Subp_Dist_Name, Loc),
7062 Attribute_Name => Name_Length),
7063 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
7065 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
7066 Declaration => Current_Declaration,
7067 Stubs => Current_Stubs,
7068 Subp_Number => Current_Subprogram_Number,
7069 Subp_Dist_Name => Subp_Dist_Name,
7070 Subp_Proxy_Addr => Proxy_Object_Addr);
7073 Current_Subprogram_Number := Current_Subprogram_Number + 1;
7076 Next (Current_Declaration);
7079 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7080 -- rather than raising an exception since we do not want someone
7081 -- to crash a remote partition by sending invalid subprogram ids.
7082 -- This is consistent with the other parts of the case statement
7083 -- since even in presence of incorrect parameters in the stream,
7084 -- every exception will be caught and (if the subprogram is not an
7085 -- APC) put into the result stream and sent away.
7087 Append_To (Pkg_RPC_Receiver_Cases,
7088 Make_Case_Statement_Alternative (Loc,
7090 New_List (Make_Others_Choice (Loc)),
7092 New_List (Make_Null_Statement (Loc))));
7094 Append_To (Pkg_RPC_Receiver_Statements,
7095 Make_Case_Statement (Loc,
7097 New_Occurrence_Of (Subp_Index, Loc),
7098 Alternatives => Pkg_RPC_Receiver_Cases));
7101 Make_Object_Declaration (Loc,
7102 Defining_Identifier => Subp_Info_Array,
7103 Constant_Present => True,
7104 Aliased_Present => True,
7105 Object_Definition =>
7106 Make_Subtype_Indication (Loc,
7108 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
7110 Make_Index_Or_Discriminant_Constraint (Loc,
7113 Low_Bound => Make_Integer_Literal (Loc,
7114 First_RCI_Subprogram_Id),
7116 Make_Integer_Literal (Loc,
7117 First_RCI_Subprogram_Id
7118 + List_Length (Subp_Info_List) - 1))))),
7120 Make_Aggregate (Loc,
7121 Component_Associations => Subp_Info_List)));
7122 Analyze (Last (Decls));
7124 Append_To (Decls, Pkg_RPC_Receiver_Body);
7125 Analyze (Last (Decls));
7127 Pkg_RPC_Receiver_Object :=
7128 Make_Object_Declaration (Loc,
7129 Defining_Identifier =>
7130 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
7131 Aliased_Present => True,
7132 Object_Definition =>
7133 New_Occurrence_Of (RTE (RE_Servant), Loc));
7134 Append_To (Decls, Pkg_RPC_Receiver_Object);
7135 Analyze (Last (Decls));
7137 Get_Library_Unit_Name_String (Pkg_Spec);
7138 Append_To (Register_Pkg_Actuals,
7140 Make_String_Literal (Loc,
7141 Strval => String_From_Name_Buffer));
7143 Append_To (Register_Pkg_Actuals,
7145 Make_Attribute_Reference (Loc,
7148 (Defining_Entity (Pkg_Spec), Loc),
7152 Append_To (Register_Pkg_Actuals,
7154 Make_Attribute_Reference (Loc,
7156 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7157 Attribute_Name => Name_Access));
7159 Append_To (Register_Pkg_Actuals,
7161 Make_Attribute_Reference (Loc,
7164 Defining_Identifier (
7165 Pkg_RPC_Receiver_Object), Loc),
7169 Append_To (Register_Pkg_Actuals,
7171 Make_Attribute_Reference (Loc,
7173 New_Occurrence_Of (Subp_Info_Array, Loc),
7177 Append_To (Register_Pkg_Actuals,
7179 Make_Attribute_Reference (Loc,
7181 New_Occurrence_Of (Subp_Info_Array, Loc),
7185 Append_To (Register_Pkg_Actuals,
7186 -- Is_All_Calls_Remote
7187 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7190 Make_Procedure_Call_Statement (Loc,
7192 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7193 Parameter_Associations => Register_Pkg_Actuals));
7194 Analyze (Last (Stmts));
7196 end Add_Receiving_Stubs_To_Declarations;
7198 ---------------------------------
7199 -- Build_General_Calling_Stubs --
7200 ---------------------------------
7202 procedure Build_General_Calling_Stubs
7204 Statements : List_Id;
7205 Target_Object : Node_Id;
7206 Subprogram_Id : Node_Id;
7207 Asynchronous : Node_Id := Empty;
7208 Is_Known_Asynchronous : Boolean := False;
7209 Is_Known_Non_Asynchronous : Boolean := False;
7210 Is_Function : Boolean;
7212 Stub_Type : Entity_Id := Empty;
7213 RACW_Type : Entity_Id := Empty;
7216 Loc : constant Source_Ptr := Sloc (Nod);
7218 Arguments : Node_Id;
7219 -- Name of the named values list used to transmit parameters
7220 -- to the remote package
7223 -- The request object constructed by these stubs
7226 -- Name of the result named value (in non-APC cases) which get the
7227 -- result of the remote subprogram.
7229 Result_TC : Node_Id;
7230 -- Typecode expression for the result of the request (void
7231 -- typecode for procedures).
7233 Exception_Return_Parameter : Node_Id;
7234 -- Name of the parameter which will hold the exception sent by the
7235 -- remote subprogram.
7237 Current_Parameter : Node_Id;
7238 -- Current parameter being handled
7240 Ordered_Parameters_List : constant List_Id :=
7241 Build_Ordered_Parameters_List (Spec);
7243 Asynchronous_P : Node_Id;
7244 -- A Boolean expression indicating whether this call is asynchronous
7246 Asynchronous_Statements : List_Id := No_List;
7247 Non_Asynchronous_Statements : List_Id := No_List;
7248 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7250 Extra_Formal_Statements : constant List_Id := New_List;
7251 -- List of statements for extra formal parameters. It will appear
7252 -- after the regular statements for writing out parameters.
7254 After_Statements : constant List_Id := New_List;
7255 -- Statements to be executed after call returns (to assign
7256 -- in out or out parameter values).
7259 -- The type of the formal parameter being processed
7261 Is_Controlling_Formal : Boolean;
7262 Is_First_Controlling_Formal : Boolean;
7263 First_Controlling_Formal_Seen : Boolean := False;
7264 -- Controlling formal parameters of distributed object primitives
7265 -- require special handling, and the first such parameter needs even
7266 -- more special handling.
7269 -- ??? document general form of stub subprograms for the PolyORB case
7271 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7274 Make_Object_Declaration (Loc,
7275 Defining_Identifier => Request,
7276 Aliased_Present => False,
7277 Object_Definition =>
7278 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
7281 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7284 Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7285 Etype (Result_Definition (Spec)), Decls);
7287 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7291 Make_Object_Declaration (Loc,
7292 Defining_Identifier => Result,
7293 Aliased_Present => False,
7294 Object_Definition =>
7295 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7297 Make_Aggregate (Loc,
7298 Component_Associations => New_List (
7299 Make_Component_Association (Loc,
7300 Choices => New_List (
7301 Make_Identifier (Loc, Name_Name)),
7303 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7304 Make_Component_Association (Loc,
7305 Choices => New_List (
7306 Make_Identifier (Loc, Name_Argument)),
7308 Make_Function_Call (Loc,
7310 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7311 Parameter_Associations => New_List (
7313 Make_Component_Association (Loc,
7314 Choices => New_List (
7315 Make_Identifier (Loc, Name_Arg_Modes)),
7317 Make_Integer_Literal (Loc, 0))))));
7319 if not Is_Known_Asynchronous then
7320 Exception_Return_Parameter :=
7321 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7324 Make_Object_Declaration (Loc,
7325 Defining_Identifier => Exception_Return_Parameter,
7326 Object_Definition =>
7327 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7330 Exception_Return_Parameter := Empty;
7333 -- Initialize and fill in arguments list
7336 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7337 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7339 Current_Parameter := First (Ordered_Parameters_List);
7340 while Present (Current_Parameter) loop
7342 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7343 Is_Controlling_Formal := True;
7344 Is_First_Controlling_Formal :=
7345 not First_Controlling_Formal_Seen;
7346 First_Controlling_Formal_Seen := True;
7348 Is_Controlling_Formal := False;
7349 Is_First_Controlling_Formal := False;
7352 if Is_Controlling_Formal then
7354 -- In the case of a controlling formal argument, we send its
7360 Etyp := Etype (Parameter_Type (Current_Parameter));
7363 -- The first controlling formal parameter is treated specially: it
7364 -- is used to set the target object of the call.
7366 if not Is_First_Controlling_Formal then
7369 Constrained : constant Boolean :=
7370 Is_Constrained (Etyp)
7371 or else Is_Elementary_Type (Etyp);
7373 Any : constant Entity_Id :=
7374 Make_Defining_Identifier (Loc,
7375 New_Internal_Name ('A'));
7377 Actual_Parameter : Node_Id :=
7379 Defining_Identifier (
7380 Current_Parameter), Loc);
7385 if Is_Controlling_Formal then
7387 -- For a controlling formal parameter (other than the
7388 -- first one), use the corresponding RACW. If the
7389 -- parameter is not an anonymous access parameter, that
7390 -- involves taking its 'Unrestricted_Access.
7392 if Nkind (Parameter_Type (Current_Parameter))
7393 = N_Access_Definition
7395 Actual_Parameter := OK_Convert_To
7396 (Etyp, Actual_Parameter);
7398 Actual_Parameter := OK_Convert_To (Etyp,
7399 Make_Attribute_Reference (Loc,
7403 Name_Unrestricted_Access));
7408 if In_Present (Current_Parameter)
7409 or else not Out_Present (Current_Parameter)
7410 or else not Constrained
7411 or else Is_Controlling_Formal
7413 -- The parameter has an input value, is constrained at
7414 -- runtime by an input value, or is a controlling formal
7415 -- parameter (always passed as a reference) other than
7418 Expr := PolyORB_Support.Helpers.Build_To_Any_Call (
7419 Actual_Parameter, Decls);
7421 Expr := Make_Function_Call (Loc,
7423 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7424 Parameter_Associations => New_List (
7425 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7430 Make_Object_Declaration (Loc,
7431 Defining_Identifier =>
7433 Aliased_Present => False,
7434 Object_Definition =>
7435 New_Occurrence_Of (RTE (RE_Any), Loc),
7439 Append_To (Statements,
7440 Add_Parameter_To_NVList (Loc,
7441 Parameter => Current_Parameter,
7442 NVList => Arguments,
7443 Constrained => Constrained,
7446 if Out_Present (Current_Parameter)
7447 and then not Is_Controlling_Formal
7449 Append_To (After_Statements,
7450 Make_Assignment_Statement (Loc,
7453 Defining_Identifier (Current_Parameter), Loc),
7455 PolyORB_Support.Helpers.Build_From_Any_Call (
7456 Etype (Parameter_Type (Current_Parameter)),
7457 New_Occurrence_Of (Any, Loc),
7464 -- If the current parameter has a dynamic constrained status, then
7465 -- this status is transmitted as well.
7466 -- This should be done for accessibility as well ???
7468 if Nkind (Parameter_Type (Current_Parameter))
7469 /= N_Access_Definition
7470 and then Need_Extra_Constrained (Current_Parameter)
7472 -- In this block, we do not use the extra formal that has been
7473 -- created because it does not exist at the time of expansion
7474 -- when building calling stubs for remote access to subprogram
7475 -- types. We create an extra variable of this type and push it
7476 -- in the stream after the regular parameters.
7479 Extra_Any_Parameter : constant Entity_Id :=
7480 Make_Defining_Identifier
7481 (Loc, New_Internal_Name ('P'));
7483 Parameter_Exp : constant Node_Id :=
7484 Make_Attribute_Reference (Loc,
7485 Prefix => New_Occurrence_Of (
7486 Defining_Identifier (Current_Parameter), Loc),
7487 Attribute_Name => Name_Constrained);
7489 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7492 Make_Object_Declaration (Loc,
7493 Defining_Identifier =>
7494 Extra_Any_Parameter,
7495 Aliased_Present => False,
7496 Object_Definition =>
7497 New_Occurrence_Of (RTE (RE_Any), Loc),
7499 PolyORB_Support.Helpers.Build_To_Any_Call (
7503 Append_To (Extra_Formal_Statements,
7504 Add_Parameter_To_NVList (Loc,
7505 Parameter => Extra_Any_Parameter,
7506 NVList => Arguments,
7507 Constrained => True,
7508 Any => Extra_Any_Parameter));
7512 Next (Current_Parameter);
7515 -- Append the formal statements list to the statements
7517 Append_List_To (Statements, Extra_Formal_Statements);
7519 Append_To (Statements,
7520 Make_Procedure_Call_Statement (Loc,
7522 New_Occurrence_Of (RTE (RE_Request_Create), Loc),
7523 Parameter_Associations => New_List (
7526 New_Occurrence_Of (Arguments, Loc),
7527 New_Occurrence_Of (Result, Loc),
7528 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7530 Append_To (Parameter_Associations (Last (Statements)),
7531 New_Occurrence_Of (Request, Loc));
7534 not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7535 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7536 Asynchronous_P := New_Occurrence_Of (
7537 Boolean_Literals (Is_Known_Asynchronous), Loc);
7539 pragma Assert (Present (Asynchronous));
7540 Asynchronous_P := New_Copy_Tree (Asynchronous);
7541 -- The expression node Asynchronous will be used to build an 'if'
7542 -- statement at the end of Build_General_Calling_Stubs: we need to
7543 -- make a copy here.
7546 Append_To (Parameter_Associations (Last (Statements)),
7547 Make_Indexed_Component (Loc,
7550 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7551 Expressions => New_List (Asynchronous_P)));
7553 Append_To (Statements,
7554 Make_Procedure_Call_Statement (Loc,
7556 New_Occurrence_Of (RTE (RE_Request_Invoke), Loc),
7557 Parameter_Associations => New_List (
7558 New_Occurrence_Of (Request, Loc))));
7560 Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7561 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7563 if not Is_Known_Asynchronous then
7565 -- Reraise an exception occurrence from the completed request.
7566 -- If the exception occurrence is empty, this is a no-op.
7568 Append_To (Non_Asynchronous_Statements,
7569 Make_Procedure_Call_Statement (Loc,
7571 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7572 Parameter_Associations => New_List (
7573 New_Occurrence_Of (Request, Loc))));
7577 -- If this is a function call, read the value and return it
7579 Append_To (Non_Asynchronous_Statements,
7580 Make_Tag_Check (Loc,
7581 Make_Return_Statement (Loc,
7582 PolyORB_Support.Helpers.Build_From_Any_Call (
7583 Etype (Result_Definition (Spec)),
7584 Make_Selected_Component (Loc,
7586 Selector_Name => Name_Argument),
7591 Append_List_To (Non_Asynchronous_Statements,
7594 if Is_Known_Asynchronous then
7595 Append_List_To (Statements, Asynchronous_Statements);
7597 elsif Is_Known_Non_Asynchronous then
7598 Append_List_To (Statements, Non_Asynchronous_Statements);
7601 pragma Assert (Present (Asynchronous));
7602 Append_To (Statements,
7603 Make_Implicit_If_Statement (Nod,
7604 Condition => Asynchronous,
7605 Then_Statements => Asynchronous_Statements,
7606 Else_Statements => Non_Asynchronous_Statements));
7608 end Build_General_Calling_Stubs;
7610 -----------------------
7611 -- Build_Stub_Target --
7612 -----------------------
7614 function Build_Stub_Target
7617 RCI_Locator : Entity_Id;
7618 Controlling_Parameter : Entity_Id) return RPC_Target
7620 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7621 Target_Reference : constant Entity_Id :=
7622 Make_Defining_Identifier (Loc,
7623 New_Internal_Name ('T'));
7625 if Present (Controlling_Parameter) then
7627 Make_Object_Declaration (Loc,
7628 Defining_Identifier => Target_Reference,
7629 Object_Definition =>
7630 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7632 Make_Function_Call (Loc,
7634 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7635 Parameter_Associations => New_List (
7636 Make_Selected_Component (Loc,
7637 Prefix => Controlling_Parameter,
7638 Selector_Name => Name_Target)))));
7639 -- Controlling_Parameter has the same components as
7640 -- System.Partition_Interface.RACW_Stub_Type.
7642 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7645 Target_Info.Object :=
7646 Make_Selected_Component (Loc,
7648 Make_Identifier (Loc, Chars (RCI_Locator)),
7650 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7653 end Build_Stub_Target;
7655 ---------------------
7656 -- Build_Stub_Type --
7657 ---------------------
7659 procedure Build_Stub_Type
7660 (RACW_Type : Entity_Id;
7661 Stub_Type : Entity_Id;
7662 Stub_Type_Decl : out Node_Id;
7663 RPC_Receiver_Decl : out Node_Id)
7665 Loc : constant Source_Ptr := Sloc (Stub_Type);
7666 pragma Warnings (Off);
7667 pragma Unreferenced (RACW_Type);
7668 pragma Warnings (On);
7672 Make_Full_Type_Declaration (Loc,
7673 Defining_Identifier => Stub_Type,
7675 Make_Record_Definition (Loc,
7676 Tagged_Present => True,
7677 Limited_Present => True,
7679 Make_Component_List (Loc,
7680 Component_Items => New_List (
7682 Make_Component_Declaration (Loc,
7683 Defining_Identifier =>
7684 Make_Defining_Identifier (Loc, Name_Target),
7685 Component_Definition =>
7686 Make_Component_Definition (Loc,
7689 Subtype_Indication =>
7690 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7692 Make_Component_Declaration (Loc,
7693 Defining_Identifier =>
7694 Make_Defining_Identifier (Loc, Name_Asynchronous),
7695 Component_Definition =>
7696 Make_Component_Definition (Loc,
7697 Aliased_Present => False,
7698 Subtype_Indication =>
7700 Standard_Boolean, Loc)))))));
7702 RPC_Receiver_Decl :=
7703 Make_Object_Declaration (Loc,
7704 Defining_Identifier => Make_Defining_Identifier (Loc,
7705 New_Internal_Name ('R')),
7706 Aliased_Present => True,
7707 Object_Definition =>
7708 New_Occurrence_Of (RTE (RE_Servant), Loc));
7709 end Build_Stub_Type;
7711 -----------------------------
7712 -- Build_RPC_Receiver_Body --
7713 -----------------------------
7715 procedure Build_RPC_Receiver_Body
7716 (RPC_Receiver : Entity_Id;
7717 Request : out Entity_Id;
7718 Subp_Id : out Entity_Id;
7719 Subp_Index : out Entity_Id;
7720 Stmts : out List_Id;
7723 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7725 RPC_Receiver_Spec : Node_Id;
7726 RPC_Receiver_Decls : List_Id;
7729 Request := Make_Defining_Identifier (Loc, Name_R);
7731 RPC_Receiver_Spec :=
7732 Build_RPC_Receiver_Specification (
7733 RPC_Receiver => RPC_Receiver,
7734 Request_Parameter => Request);
7736 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7737 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7739 RPC_Receiver_Decls := New_List (
7740 Make_Object_Renaming_Declaration (Loc,
7741 Defining_Identifier => Subp_Id,
7742 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7744 Make_Explicit_Dereference (Loc,
7746 Make_Selected_Component (Loc,
7748 Selector_Name => Name_Operation))),
7750 Make_Object_Declaration (Loc,
7751 Defining_Identifier => Subp_Index,
7752 Object_Definition =>
7753 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7755 Make_Attribute_Reference (Loc,
7757 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7758 Attribute_Name => Name_Last)));
7763 Make_Subprogram_Body (Loc,
7764 Specification => RPC_Receiver_Spec,
7765 Declarations => RPC_Receiver_Decls,
7766 Handled_Statement_Sequence =>
7767 Make_Handled_Sequence_Of_Statements (Loc,
7768 Statements => Stmts));
7769 end Build_RPC_Receiver_Body;
7771 --------------------------------------
7772 -- Build_Subprogram_Receiving_Stubs --
7773 --------------------------------------
7775 function Build_Subprogram_Receiving_Stubs
7776 (Vis_Decl : Node_Id;
7777 Asynchronous : Boolean;
7778 Dynamically_Asynchronous : Boolean := False;
7779 Stub_Type : Entity_Id := Empty;
7780 RACW_Type : Entity_Id := Empty;
7781 Parent_Primitive : Entity_Id := Empty) return Node_Id
7783 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7785 Request_Parameter : constant Entity_Id :=
7786 Make_Defining_Identifier (Loc,
7787 New_Internal_Name ('R'));
7788 -- Formal parameter for receiving stubs: a descriptor for an incoming
7791 Outer_Decls : constant List_Id := New_List;
7792 -- At the outermost level, an NVList and Any's are declared for all
7793 -- parameters. The Dynamic_Async flag also needs to be declared there
7794 -- to be visible from the exception handling code.
7796 Outer_Statements : constant List_Id := New_List;
7797 -- Statements that occur prior to the declaration of the actual
7798 -- parameter variables.
7800 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7801 -- Statements concerning extra formal parameters, prior to the
7802 -- declaration of the actual parameter variables.
7804 Decls : constant List_Id := New_List;
7805 -- All the parameters will get declared before calling the real
7806 -- subprograms. Also the out parameters will be declared.
7807 -- At this level, parameters may be unconstrained.
7809 Statements : constant List_Id := New_List;
7811 After_Statements : constant List_Id := New_List;
7812 -- Statements to be executed after the subprogram call
7814 Inner_Decls : List_Id := No_List;
7815 -- In case of a function, the inner declarations are needed since
7816 -- the result may be unconstrained.
7818 Excep_Handlers : List_Id := No_List;
7820 Parameter_List : constant List_Id := New_List;
7821 -- List of parameters to be passed to the subprogram
7823 First_Controlling_Formal_Seen : Boolean := False;
7825 Current_Parameter : Node_Id;
7827 Ordered_Parameters_List : constant List_Id :=
7828 Build_Ordered_Parameters_List
7829 (Specification (Vis_Decl));
7831 Arguments : constant Entity_Id :=
7832 Make_Defining_Identifier (Loc,
7833 New_Internal_Name ('A'));
7834 -- Name of the named values list used to retrieve parameters
7836 Subp_Spec : Node_Id;
7837 -- Subprogram specification
7839 Called_Subprogram : Node_Id;
7840 -- The subprogram to call
7843 if Present (RACW_Type) then
7844 Called_Subprogram :=
7845 New_Occurrence_Of (Parent_Primitive, Loc);
7847 Called_Subprogram :=
7849 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7852 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7854 -- Loop through every parameter and get its value from the stream. If
7855 -- the parameter is unconstrained, then the parameter is read using
7856 -- 'Input at the point of declaration.
7858 Current_Parameter := First (Ordered_Parameters_List);
7859 while Present (Current_Parameter) loop
7862 Constrained : Boolean;
7863 Any : Entity_Id := Empty;
7864 Object : constant Entity_Id :=
7865 Make_Defining_Identifier (Loc,
7866 New_Internal_Name ('P'));
7867 Expr : Node_Id := Empty;
7869 Is_Controlling_Formal : constant Boolean
7870 := Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
7872 Is_First_Controlling_Formal : Boolean := False;
7874 Need_Extra_Constrained : Boolean;
7875 -- True when an extra constrained actual is required
7878 if Is_Controlling_Formal then
7880 -- Controlling formals in distributed object primitive
7881 -- operations are handled specially:
7882 -- - the first controlling formal is used as the
7883 -- target of the call;
7884 -- - the remaining controlling formals are transmitted
7888 Is_First_Controlling_Formal :=
7889 not First_Controlling_Formal_Seen;
7890 First_Controlling_Formal_Seen := True;
7892 Etyp := Etype (Parameter_Type (Current_Parameter));
7896 Is_Constrained (Etyp)
7897 or else Is_Elementary_Type (Etyp);
7899 if not Is_First_Controlling_Formal then
7900 Any := Make_Defining_Identifier (Loc,
7901 New_Internal_Name ('A'));
7902 Append_To (Outer_Decls,
7903 Make_Object_Declaration (Loc,
7904 Defining_Identifier =>
7906 Object_Definition =>
7907 New_Occurrence_Of (RTE (RE_Any), Loc),
7909 Make_Function_Call (Loc,
7911 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7912 Parameter_Associations => New_List (
7913 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7914 Etyp, Outer_Decls)))));
7916 Append_To (Outer_Statements,
7917 Add_Parameter_To_NVList (Loc,
7918 Parameter => Current_Parameter,
7919 NVList => Arguments,
7920 Constrained => Constrained,
7924 if Is_First_Controlling_Formal then
7926 Addr : constant Entity_Id :=
7927 Make_Defining_Identifier (Loc,
7928 New_Internal_Name ('A'));
7929 Is_Local : constant Entity_Id :=
7930 Make_Defining_Identifier (Loc,
7931 New_Internal_Name ('L'));
7934 -- Special case: obtain the first controlling formal
7935 -- from the target of the remote call, instead of the
7938 Append_To (Outer_Decls,
7939 Make_Object_Declaration (Loc,
7940 Defining_Identifier =>
7942 Object_Definition =>
7943 New_Occurrence_Of (RTE (RE_Address), Loc)));
7944 Append_To (Outer_Decls,
7945 Make_Object_Declaration (Loc,
7946 Defining_Identifier =>
7948 Object_Definition =>
7949 New_Occurrence_Of (Standard_Boolean, Loc)));
7950 Append_To (Outer_Statements,
7951 Make_Procedure_Call_Statement (Loc,
7954 RTE (RE_Get_Local_Address), Loc),
7955 Parameter_Associations => New_List (
7956 Make_Selected_Component (Loc,
7959 Request_Parameter, Loc),
7961 Make_Identifier (Loc, Name_Target)),
7962 New_Occurrence_Of (Is_Local, Loc),
7963 New_Occurrence_Of (Addr, Loc))));
7965 Expr := Unchecked_Convert_To (RACW_Type,
7966 New_Occurrence_Of (Addr, Loc));
7969 elsif In_Present (Current_Parameter)
7970 or else not Out_Present (Current_Parameter)
7971 or else not Constrained
7973 -- If an input parameter is constrained, then its reading is
7974 -- deferred until the beginning of the subprogram body. If
7975 -- it is unconstrained, then an expression is built for
7976 -- the object declaration and the variable is set using
7977 -- 'Input instead of 'Read.
7979 Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
7980 Etyp, New_Occurrence_Of (Any, Loc), Decls);
7983 Append_To (Statements,
7984 Make_Assignment_Statement (Loc,
7986 New_Occurrence_Of (Object, Loc),
7992 -- Expr will be used to initialize (and constrain) the
7993 -- parameter when it is declared.
7998 Need_Extra_Constrained :=
7999 Nkind (Parameter_Type (Current_Parameter)) /=
8002 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
8004 Present (Extra_Constrained
8005 (Defining_Identifier (Current_Parameter)));
8007 -- We may not associate an extra constrained actual to a
8008 -- constant object, so if one is needed, declare the actual
8009 -- as a variable even if it won't be modified.
8011 Build_Actual_Object_Declaration
8014 Variable => Need_Extra_Constrained
8015 or else Out_Present (Current_Parameter),
8018 Set_Etype (Object, Etyp);
8020 -- An out parameter may be written back using a 'Write
8021 -- attribute instead of a 'Output because it has been
8022 -- constrained by the parameter given to the caller. Note that
8023 -- out controlling arguments in the case of a RACW are not put
8024 -- back in the stream because the pointer on them has not
8027 if Out_Present (Current_Parameter)
8028 and then not Is_Controlling_Formal
8030 Append_To (After_Statements,
8031 Make_Procedure_Call_Statement (Loc,
8033 New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
8034 Parameter_Associations => New_List (
8035 New_Occurrence_Of (Any, Loc),
8036 PolyORB_Support.Helpers.Build_To_Any_Call (
8037 New_Occurrence_Of (Object, Loc),
8041 -- For RACW controlling formals, the Etyp of Object is always
8042 -- an RACW, even if the parameter is not of an anonymous access
8043 -- type. In such case, we need to dereference it at call time.
8045 if Is_Controlling_Formal then
8046 if Nkind (Parameter_Type (Current_Parameter)) /=
8049 Append_To (Parameter_List,
8050 Make_Parameter_Association (Loc,
8053 Defining_Identifier (Current_Parameter), Loc),
8054 Explicit_Actual_Parameter =>
8055 Make_Explicit_Dereference (Loc,
8056 Unchecked_Convert_To (RACW_Type,
8057 OK_Convert_To (RTE (RE_Address),
8058 New_Occurrence_Of (Object, Loc))))));
8061 Append_To (Parameter_List,
8062 Make_Parameter_Association (Loc,
8065 Defining_Identifier (Current_Parameter), Loc),
8066 Explicit_Actual_Parameter =>
8067 Unchecked_Convert_To (RACW_Type,
8068 OK_Convert_To (RTE (RE_Address),
8069 New_Occurrence_Of (Object, Loc)))));
8073 Append_To (Parameter_List,
8074 Make_Parameter_Association (Loc,
8077 Defining_Identifier (Current_Parameter), Loc),
8078 Explicit_Actual_Parameter =>
8079 New_Occurrence_Of (Object, Loc)));
8082 -- If the current parameter needs an extra formal, then read it
8083 -- from the stream and set the corresponding semantic field in
8084 -- the variable. If the kind of the parameter identifier is
8085 -- E_Void, then this is a compiler generated parameter that
8086 -- doesn't need an extra constrained status.
8088 -- The case of Extra_Accessibility should also be handled ???
8090 if Need_Extra_Constrained then
8092 Extra_Parameter : constant Entity_Id :=
8094 (Defining_Identifier
8095 (Current_Parameter));
8096 Extra_Any : constant Entity_Id :=
8097 Make_Defining_Identifier
8098 (Loc, New_Internal_Name ('A'));
8100 Formal_Entity : constant Entity_Id :=
8101 Make_Defining_Identifier
8102 (Loc, Chars (Extra_Parameter));
8104 Formal_Type : constant Entity_Id :=
8105 Etype (Extra_Parameter);
8107 Append_To (Outer_Decls,
8108 Make_Object_Declaration (Loc,
8109 Defining_Identifier =>
8111 Object_Definition =>
8112 New_Occurrence_Of (RTE (RE_Any), Loc),
8114 Make_Function_Call (Loc,
8116 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8117 Parameter_Associations => New_List (
8118 PolyORB_Support.Helpers.Build_TypeCode_Call
8119 (Loc, Formal_Type, Outer_Decls)))));
8121 Append_To (Outer_Extra_Formal_Statements,
8122 Add_Parameter_To_NVList (Loc,
8123 Parameter => Extra_Parameter,
8124 NVList => Arguments,
8125 Constrained => True,
8129 Make_Object_Declaration (Loc,
8130 Defining_Identifier => Formal_Entity,
8131 Object_Definition =>
8132 New_Occurrence_Of (Formal_Type, Loc)));
8134 Append_To (Statements,
8135 Make_Assignment_Statement (Loc,
8137 New_Occurrence_Of (Formal_Entity, Loc),
8139 PolyORB_Support.Helpers.Build_From_Any_Call (
8141 New_Occurrence_Of (Extra_Any, Loc),
8143 Set_Extra_Constrained (Object, Formal_Entity);
8148 Next (Current_Parameter);
8151 -- Extra Formals should go after all the other parameters
8153 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8155 Append_To (Outer_Statements,
8156 Make_Procedure_Call_Statement (Loc,
8158 New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8159 Parameter_Associations => New_List (
8160 New_Occurrence_Of (Request_Parameter, Loc),
8161 New_Occurrence_Of (Arguments, Loc))));
8163 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8165 -- The remote subprogram is a function. We build an inner block to
8166 -- be able to hold a potentially unconstrained result in a
8170 Etyp : constant Entity_Id :=
8171 Etype (Result_Definition (Specification (Vis_Decl)));
8172 Result : constant Node_Id :=
8173 Make_Defining_Identifier (Loc,
8174 New_Internal_Name ('R'));
8176 Inner_Decls := New_List (
8177 Make_Object_Declaration (Loc,
8178 Defining_Identifier => Result,
8179 Constant_Present => True,
8180 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8182 Make_Function_Call (Loc,
8183 Name => Called_Subprogram,
8184 Parameter_Associations => Parameter_List)));
8186 Set_Etype (Result, Etyp);
8187 Append_To (After_Statements,
8188 Make_Procedure_Call_Statement (Loc,
8190 New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8191 Parameter_Associations => New_List (
8192 New_Occurrence_Of (Request_Parameter, Loc),
8193 PolyORB_Support.Helpers.Build_To_Any_Call (
8194 New_Occurrence_Of (Result, Loc),
8196 -- A DSA function does not have out or inout arguments
8199 Append_To (Statements,
8200 Make_Block_Statement (Loc,
8201 Declarations => Inner_Decls,
8202 Handled_Statement_Sequence =>
8203 Make_Handled_Sequence_Of_Statements (Loc,
8204 Statements => After_Statements)));
8207 -- The remote subprogram is a procedure. We do not need any inner
8208 -- block in this case. No specific processing is required here for
8209 -- the dynamically asynchronous case: the indication of whether
8210 -- call is asynchronous or not is managed by the Sync_Scope
8211 -- attibute of the request, and is handled entirely in the
8214 Append_To (After_Statements,
8215 Make_Procedure_Call_Statement (Loc,
8217 New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8218 Parameter_Associations => New_List (
8219 New_Occurrence_Of (Request_Parameter, Loc))));
8221 Append_To (Statements,
8222 Make_Procedure_Call_Statement (Loc,
8223 Name => Called_Subprogram,
8224 Parameter_Associations => Parameter_List));
8226 Append_List_To (Statements, After_Statements);
8230 Make_Procedure_Specification (Loc,
8231 Defining_Unit_Name =>
8232 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
8234 Parameter_Specifications => New_List (
8235 Make_Parameter_Specification (Loc,
8236 Defining_Identifier => Request_Parameter,
8238 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8240 -- An exception raised during the execution of an incoming
8241 -- remote subprogram call and that needs to be sent back
8242 -- to the caller is propagated by the receiving stubs, and
8243 -- will be handled by the caller (the distribution runtime).
8245 if Asynchronous and then not Dynamically_Asynchronous then
8247 -- For an asynchronous procedure, add a null exception handler
8249 Excep_Handlers := New_List (
8250 Make_Implicit_Exception_Handler (Loc,
8251 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8252 Statements => New_List (Make_Null_Statement (Loc))));
8256 -- In the other cases, if an exception is raised, then the
8257 -- exception occurrence is propagated.
8262 Append_To (Outer_Statements,
8263 Make_Block_Statement (Loc,
8266 Handled_Statement_Sequence =>
8267 Make_Handled_Sequence_Of_Statements (Loc,
8268 Statements => Statements)));
8271 Make_Subprogram_Body (Loc,
8272 Specification => Subp_Spec,
8273 Declarations => Outer_Decls,
8274 Handled_Statement_Sequence =>
8275 Make_Handled_Sequence_Of_Statements (Loc,
8276 Statements => Outer_Statements,
8277 Exception_Handlers => Excep_Handlers));
8278 end Build_Subprogram_Receiving_Stubs;
8284 package body Helpers is
8286 -----------------------
8287 -- Local Subprograms --
8288 -----------------------
8290 function Find_Numeric_Representation
8291 (Typ : Entity_Id) return Entity_Id;
8292 -- Given a numeric type Typ, return the smallest integer or floarting
8293 -- point type from Standard, or the smallest unsigned (modular) type
8294 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8296 function Make_Stream_Procedure_Function_Name
8299 Nam : Name_Id) return Entity_Id;
8300 -- Return the name to be assigned for stream subprogram Nam of Typ.
8301 -- (copied from exp_strm.adb, should be shared???)
8303 ------------------------------------------------------------
8304 -- Common subprograms for building various tree fragments --
8305 ------------------------------------------------------------
8307 function Build_Get_Aggregate_Element
8311 Idx : Node_Id) return Node_Id;
8312 -- Build a call to Get_Aggregate_Element on Any
8313 -- for typecode TC, returning the Idx'th element.
8316 Subprogram : Entity_Id;
8317 -- Reference location for constructed nodes
8320 -- For 'Range and Etype
8323 -- For the construction of the innermost element expression
8325 with procedure Add_Process_Element
8328 Counter : Entity_Id;
8331 procedure Append_Array_Traversal
8334 Counter : Entity_Id := Empty;
8336 -- Build nested loop statements that iterate over the elements of an
8337 -- array Arry. The statement(s) built by Add_Process_Element are
8338 -- executed for each element; Indices is the list of indices to be
8339 -- used in the construction of the indexed component that denotes the
8340 -- current element. Subprogram is the entity for the subprogram for
8341 -- which this iterator is generated. The generated statements are
8342 -- appended to Stmts.
8346 -- The record entity being dealt with
8348 with procedure Add_Process_Element
8350 Container : Node_Or_Entity_Id;
8351 Counter : in out Int;
8354 -- Rec is the instance of the record type, or Empty.
8355 -- Field is either the N_Defining_Identifier for a component,
8356 -- or an N_Variant_Part.
8358 procedure Append_Record_Traversal
8361 Container : Node_Or_Entity_Id;
8362 Counter : in out Int);
8363 -- Process component list Clist. Individual fields are passed
8364 -- to Field_Processing. Each variant part is also processed.
8365 -- Container is the outer Any (for From_Any/To_Any),
8366 -- the outer typecode (for TC) to which the operation applies.
8368 -----------------------------
8369 -- Append_Record_Traversal --
8370 -----------------------------
8372 procedure Append_Record_Traversal
8375 Container : Node_Or_Entity_Id;
8376 Counter : in out Int)
8380 -- Clist's Component_Items and Variant_Part
8390 CI := Component_Items (Clist);
8391 VP := Variant_Part (Clist);
8394 while Present (Item) loop
8395 Def := Defining_Identifier (Item);
8396 if not Is_Internal_Name (Chars (Def)) then
8398 (Stmts, Container, Counter, Rec, Def);
8403 if Present (VP) then
8404 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8406 end Append_Record_Traversal;
8408 -------------------------
8409 -- Build_From_Any_Call --
8410 -------------------------
8412 function Build_From_Any_Call
8415 Decls : List_Id) return Node_Id
8417 Loc : constant Source_Ptr := Sloc (N);
8419 U_Type : Entity_Id := Underlying_Type (Typ);
8421 Fnam : Entity_Id := Empty;
8422 Lib_RE : RE_Id := RE_Null;
8426 -- First simple case where the From_Any function is present
8427 -- in the type's TSS.
8429 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8431 if Sloc (U_Type) <= Standard_Location then
8432 U_Type := Base_Type (U_Type);
8435 -- Check first for Boolean and Character. These are enumeration
8436 -- types, but we treat them specially, since they may require
8437 -- special handling in the transfer protocol. However, this
8438 -- special handling only applies if they have standard
8439 -- representation, otherwise they are treated like any other
8440 -- enumeration type.
8442 if Present (Fnam) then
8445 elsif U_Type = Standard_Boolean then
8448 elsif U_Type = Standard_Character then
8451 elsif U_Type = Standard_Wide_Character then
8454 elsif U_Type = Standard_Wide_Wide_Character then
8455 Lib_RE := RE_FA_WWC;
8457 -- Floating point types
8459 elsif U_Type = Standard_Short_Float then
8462 elsif U_Type = Standard_Float then
8465 elsif U_Type = Standard_Long_Float then
8468 elsif U_Type = Standard_Long_Long_Float then
8469 Lib_RE := RE_FA_LLF;
8473 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8474 Lib_RE := RE_FA_SSI;
8476 elsif U_Type = Etype (Standard_Short_Integer) then
8479 elsif U_Type = Etype (Standard_Integer) then
8482 elsif U_Type = Etype (Standard_Long_Integer) then
8485 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8486 Lib_RE := RE_FA_LLI;
8488 -- Unsigned integer types
8490 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8491 Lib_RE := RE_FA_SSU;
8493 elsif U_Type = RTE (RE_Short_Unsigned) then
8496 elsif U_Type = RTE (RE_Unsigned) then
8499 elsif U_Type = RTE (RE_Long_Unsigned) then
8502 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8503 Lib_RE := RE_FA_LLU;
8505 elsif U_Type = Standard_String then
8506 Lib_RE := RE_FA_String;
8508 -- Other (non-primitive) types
8514 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8515 Append_To (Decls, Decl);
8519 -- Call the function
8521 if Lib_RE /= RE_Null then
8522 pragma Assert (No (Fnam));
8523 Fnam := RTE (Lib_RE);
8527 Make_Function_Call (Loc,
8528 Name => New_Occurrence_Of (Fnam, Loc),
8529 Parameter_Associations => New_List (N));
8531 -- We must set the type of Result, so the unchecked conversion
8532 -- from the underlying type to the base type is properly done.
8534 Set_Etype (Result, U_Type);
8536 return Unchecked_Convert_To (Typ, Result);
8537 end Build_From_Any_Call;
8539 -----------------------------
8540 -- Build_From_Any_Function --
8541 -----------------------------
8543 procedure Build_From_Any_Function
8547 Fnam : out Entity_Id)
8550 Decls : constant List_Id := New_List;
8551 Stms : constant List_Id := New_List;
8552 Any_Parameter : constant Entity_Id
8553 := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
8555 if Is_Itype (Typ) then
8556 Build_From_Any_Function
8564 Fnam := Make_Stream_Procedure_Function_Name (Loc,
8565 Typ, Name_uFrom_Any);
8568 Make_Function_Specification (Loc,
8569 Defining_Unit_Name => Fnam,
8570 Parameter_Specifications => New_List (
8571 Make_Parameter_Specification (Loc,
8572 Defining_Identifier =>
8575 New_Occurrence_Of (RTE (RE_Any), Loc))),
8576 Result_Definition => New_Occurrence_Of (Typ, Loc));
8578 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8581 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8583 if Is_Derived_Type (Typ)
8584 and then not Is_Tagged_Type (Typ)
8587 Make_Return_Statement (Loc,
8591 Build_From_Any_Call (
8593 New_Occurrence_Of (Any_Parameter, Loc),
8596 elsif Is_Record_Type (Typ)
8597 and then not Is_Derived_Type (Typ)
8598 and then not Is_Tagged_Type (Typ)
8600 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8602 Make_Return_Statement (Loc,
8606 Build_From_Any_Call (
8608 New_Occurrence_Of (Any_Parameter, Loc),
8612 Disc : Entity_Id := Empty;
8613 Discriminant_Associations : List_Id;
8614 Rdef : constant Node_Id :=
8615 Type_Definition (Declaration_Node (Typ));
8616 Component_Counter : Int := 0;
8618 -- The returned object
8620 Res : constant Entity_Id :=
8621 Make_Defining_Identifier (Loc,
8622 New_Internal_Name ('R'));
8624 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8626 procedure FA_Rec_Add_Process_Element
8629 Counter : in out Int;
8633 procedure FA_Append_Record_Traversal is
8634 new Append_Record_Traversal
8636 Add_Process_Element => FA_Rec_Add_Process_Element);
8638 --------------------------------
8639 -- FA_Rec_Add_Process_Element --
8640 --------------------------------
8642 procedure FA_Rec_Add_Process_Element
8645 Counter : in out Int;
8650 if Nkind (Field) = N_Defining_Identifier then
8652 -- A regular component
8655 Make_Assignment_Statement (Loc,
8656 Name => Make_Selected_Component (Loc,
8658 New_Occurrence_Of (Rec, Loc),
8660 New_Occurrence_Of (Field, Loc)),
8662 Build_From_Any_Call (Etype (Field),
8663 Build_Get_Aggregate_Element (Loc,
8665 Tc => Build_TypeCode_Call (Loc,
8666 Etype (Field), Decls),
8667 Idx => Make_Integer_Literal (Loc,
8676 Struct_Counter : Int := 0;
8678 Block_Decls : constant List_Id := New_List;
8679 Block_Stmts : constant List_Id := New_List;
8682 Alt_List : constant List_Id := New_List;
8683 Choice_List : List_Id;
8685 Struct_Any : constant Entity_Id :=
8686 Make_Defining_Identifier (Loc,
8687 New_Internal_Name ('S'));
8691 Make_Object_Declaration (Loc,
8692 Defining_Identifier =>
8696 Object_Definition =>
8697 New_Occurrence_Of (RTE (RE_Any), Loc),
8699 Make_Function_Call (Loc,
8700 Name => New_Occurrence_Of (
8701 RTE (RE_Extract_Union_Value), Loc),
8702 Parameter_Associations => New_List (
8703 Build_Get_Aggregate_Element (Loc,
8705 Tc => Make_Function_Call (Loc,
8706 Name => New_Occurrence_Of (
8707 RTE (RE_Any_Member_Type), Loc),
8708 Parameter_Associations =>
8710 New_Occurrence_Of (Any, Loc),
8711 Make_Integer_Literal (Loc,
8713 Idx => Make_Integer_Literal (Loc,
8717 Make_Block_Statement (Loc,
8720 Handled_Statement_Sequence =>
8721 Make_Handled_Sequence_Of_Statements (Loc,
8722 Statements => Block_Stmts)));
8724 Append_To (Block_Stmts,
8725 Make_Case_Statement (Loc,
8727 Make_Selected_Component (Loc,
8730 Chars (Name (Field))),
8734 Variant := First_Non_Pragma (Variants (Field));
8736 while Present (Variant) loop
8737 Choice_List := New_Copy_List_Tree
8738 (Discrete_Choices (Variant));
8740 VP_Stmts := New_List;
8742 -- Struct_Counter should be reset before
8743 -- handling a variant part. Indeed only one
8744 -- of the case statement alternatives will be
8745 -- executed at run-time, so the counter must
8746 -- start at 0 for every case statement.
8748 Struct_Counter := 0;
8750 FA_Append_Record_Traversal (
8752 Clist => Component_List (Variant),
8753 Container => Struct_Any,
8754 Counter => Struct_Counter);
8756 Append_To (Alt_List,
8757 Make_Case_Statement_Alternative (Loc,
8758 Discrete_Choices => Choice_List,
8761 Next_Non_Pragma (Variant);
8765 Counter := Counter + 1;
8766 end FA_Rec_Add_Process_Element;
8769 -- First all discriminants
8771 if Has_Discriminants (Typ) then
8772 Disc := First_Discriminant (Typ);
8773 Discriminant_Associations := New_List;
8775 while Present (Disc) loop
8777 Disc_Var_Name : constant Entity_Id :=
8778 Make_Defining_Identifier (Loc, Chars (Disc));
8779 Disc_Type : constant Entity_Id :=
8783 Make_Object_Declaration (Loc,
8784 Defining_Identifier =>
8786 Constant_Present => True,
8787 Object_Definition =>
8788 New_Occurrence_Of (Disc_Type, Loc),
8790 Build_From_Any_Call (Disc_Type,
8791 Build_Get_Aggregate_Element (Loc,
8792 Any => Any_Parameter,
8793 Tc => Build_TypeCode_Call
8794 (Loc, Disc_Type, Decls),
8795 Idx => Make_Integer_Literal
8796 (Loc, Component_Counter)),
8798 Component_Counter := Component_Counter + 1;
8800 Append_To (Discriminant_Associations,
8801 Make_Discriminant_Association (Loc,
8802 Selector_Names => New_List (
8803 New_Occurrence_Of (Disc, Loc)),
8805 New_Occurrence_Of (Disc_Var_Name, Loc)));
8807 Next_Discriminant (Disc);
8810 Res_Definition := Make_Subtype_Indication (Loc,
8811 Subtype_Mark => Res_Definition,
8813 Make_Index_Or_Discriminant_Constraint (Loc,
8814 Discriminant_Associations));
8817 -- Now we have all the discriminants in variables, we can
8818 -- declared a constrained object. Note that we are not
8819 -- initializing (non-discriminant) components directly in
8820 -- the object declarations, because which fields to
8821 -- initialize depends (at run time) on the discriminant
8825 Make_Object_Declaration (Loc,
8826 Defining_Identifier =>
8828 Object_Definition =>
8831 -- ... then all components
8833 FA_Append_Record_Traversal (Stms,
8834 Clist => Component_List (Rdef),
8835 Container => Any_Parameter,
8836 Counter => Component_Counter);
8839 Make_Return_Statement (Loc,
8840 Expression => New_Occurrence_Of (Res, Loc)));
8844 elsif Is_Array_Type (Typ) then
8846 Constrained : constant Boolean := Is_Constrained (Typ);
8848 procedure FA_Ary_Add_Process_Element
8851 Counter : Entity_Id;
8853 -- Assign the current element (as identified by Counter) of
8854 -- Any to the variable denoted by name Datum, and advance
8855 -- Counter by 1. If Datum is not an Any, a call to From_Any
8856 -- for its type is inserted.
8858 --------------------------------
8859 -- FA_Ary_Add_Process_Element --
8860 --------------------------------
8862 procedure FA_Ary_Add_Process_Element
8865 Counter : Entity_Id;
8868 Assignment : constant Node_Id :=
8869 Make_Assignment_Statement (Loc,
8871 Expression => Empty);
8873 Element_Any : Node_Id;
8877 Element_TC : Node_Id;
8880 if Etype (Datum) = RTE (RE_Any) then
8882 -- When Datum is an Any the Etype field is not
8883 -- sufficient to determine the typecode of Datum
8884 -- (which can be a TC_SEQUENCE or TC_ARRAY
8885 -- depending on the value of Constrained).
8886 -- Therefore we retrieve the typecode which has
8887 -- been constructed in Append_Array_Traversal with
8888 -- a call to Get_Any_Type.
8891 Make_Function_Call (Loc,
8892 Name => New_Occurrence_Of (
8893 RTE (RE_Get_Any_Type), Loc),
8894 Parameter_Associations => New_List (
8895 New_Occurrence_Of (Entity (Datum), Loc)));
8897 -- For non Any Datum we simply construct a typecode
8898 -- matching the Etype of the Datum.
8900 Element_TC := Build_TypeCode_Call
8901 (Loc, Etype (Datum), Decls);
8905 Build_Get_Aggregate_Element (Loc,
8908 Idx => New_Occurrence_Of (Counter, Loc));
8911 -- Note: here we *prepend* statements to Stmts, so
8912 -- we must do it in reverse order.
8915 Make_Assignment_Statement (Loc,
8917 New_Occurrence_Of (Counter, Loc),
8921 New_Occurrence_Of (Counter, Loc),
8923 Make_Integer_Literal (Loc, 1))));
8925 if Nkind (Datum) /= N_Attribute_Reference then
8927 -- We ignore the value of the length of each
8928 -- dimension, since the target array has already
8929 -- been constrained anyway.
8931 if Etype (Datum) /= RTE (RE_Any) then
8932 Set_Expression (Assignment,
8933 Build_From_Any_Call (
8934 Component_Type (Typ),
8938 Set_Expression (Assignment, Element_Any);
8940 Prepend_To (Stmts, Assignment);
8942 end FA_Ary_Add_Process_Element;
8944 Counter : constant Entity_Id :=
8945 Make_Defining_Identifier (Loc, Name_J);
8947 Initial_Counter_Value : Int := 0;
8949 Component_TC : constant Entity_Id :=
8950 Make_Defining_Identifier (Loc, Name_T);
8952 Res : constant Entity_Id :=
8953 Make_Defining_Identifier (Loc, Name_R);
8955 procedure Append_From_Any_Array_Iterator is
8956 new Append_Array_Traversal (
8959 Indices => New_List,
8960 Add_Process_Element => FA_Ary_Add_Process_Element);
8962 Res_Subtype_Indication : Node_Id :=
8963 New_Occurrence_Of (Typ, Loc);
8966 if not Constrained then
8968 Ndim : constant Int := Number_Dimensions (Typ);
8971 Indx : Node_Id := First_Index (Typ);
8974 Ranges : constant List_Id := New_List;
8977 for J in 1 .. Ndim loop
8978 Lnam := New_External_Name ('L', J);
8979 Hnam := New_External_Name ('H', J);
8980 Indt := Etype (Indx);
8983 Make_Object_Declaration (Loc,
8984 Defining_Identifier =>
8985 Make_Defining_Identifier (Loc, Lnam),
8988 Object_Definition =>
8989 New_Occurrence_Of (Indt, Loc),
8991 Build_From_Any_Call (
8993 Build_Get_Aggregate_Element (Loc,
8994 Any => Any_Parameter,
8995 Tc => Build_TypeCode_Call (Loc,
8997 Idx => Make_Integer_Literal (Loc, J - 1)),
9001 Make_Object_Declaration (Loc,
9002 Defining_Identifier =>
9003 Make_Defining_Identifier (Loc, Hnam),
9006 Object_Definition =>
9007 New_Occurrence_Of (Indt, Loc),
9008 Expression => Make_Attribute_Reference (Loc,
9010 New_Occurrence_Of (Indt, Loc),
9011 Attribute_Name => Name_Val,
9012 Expressions => New_List (
9013 Make_Op_Subtract (Loc,
9018 Standard_Long_Integer,
9019 Make_Identifier (Loc, Lnam)),
9022 Standard_Long_Integer,
9023 Make_Function_Call (Loc,
9024 Name => New_Occurrence_Of (RTE (
9025 RE_Get_Nested_Sequence_Length
9027 Parameter_Associations =>
9030 Any_Parameter, Loc),
9031 Make_Integer_Literal (Loc,
9034 Make_Integer_Literal (Loc, 1))))));
9038 Low_Bound => Make_Identifier (Loc, Lnam),
9039 High_Bound => Make_Identifier (Loc, Hnam)));
9044 -- Now we have all the necessary bound information:
9045 -- apply the set of range constraints to the
9046 -- (unconstrained) nominal subtype of Res.
9048 Initial_Counter_Value := Ndim;
9049 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9051 Res_Subtype_Indication,
9053 Make_Index_Or_Discriminant_Constraint (Loc,
9054 Constraints => Ranges));
9059 Make_Object_Declaration (Loc,
9060 Defining_Identifier => Res,
9061 Object_Definition => Res_Subtype_Indication));
9062 Set_Etype (Res, Typ);
9065 Make_Object_Declaration (Loc,
9066 Defining_Identifier => Counter,
9067 Object_Definition =>
9068 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
9070 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9073 Make_Object_Declaration (Loc,
9074 Defining_Identifier => Component_TC,
9075 Constant_Present => True,
9076 Object_Definition =>
9077 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9079 Build_TypeCode_Call (Loc,
9080 Component_Type (Typ), Decls)));
9082 Append_From_Any_Array_Iterator (Stms,
9083 Any_Parameter, Counter);
9086 Make_Return_Statement (Loc,
9087 Expression => New_Occurrence_Of (Res, Loc)));
9090 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9092 Make_Return_Statement (Loc,
9094 Unchecked_Convert_To (
9096 Build_From_Any_Call (
9097 Find_Numeric_Representation (Typ),
9098 New_Occurrence_Of (Any_Parameter, Loc),
9102 -- Default: type is represented as an opaque sequence of bytes
9105 Strm : constant Entity_Id :=
9106 Make_Defining_Identifier (Loc,
9107 Chars => New_Internal_Name ('S'));
9108 Res : constant Entity_Id :=
9109 Make_Defining_Identifier (Loc,
9110 Chars => New_Internal_Name ('R'));
9113 -- Strm : Buffer_Stream_Type;
9116 Make_Object_Declaration (Loc,
9117 Defining_Identifier =>
9121 Object_Definition =>
9122 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9124 -- Allocate_Buffer (Strm);
9127 Make_Procedure_Call_Statement (Loc,
9129 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9130 Parameter_Associations => New_List (
9131 New_Occurrence_Of (Strm, Loc))));
9133 -- Any_To_BS (Strm, A);
9136 Make_Procedure_Call_Statement (Loc,
9138 New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
9139 Parameter_Associations => New_List (
9140 New_Occurrence_Of (Any_Parameter, Loc),
9141 New_Occurrence_Of (Strm, Loc))));
9144 -- Res : constant T := T'Input (Strm);
9146 -- Release_Buffer (Strm);
9150 Append_To (Stms, Make_Block_Statement (Loc,
9151 Declarations => New_List (
9152 Make_Object_Declaration (Loc,
9153 Defining_Identifier => Res,
9154 Constant_Present => True,
9155 Object_Definition =>
9156 New_Occurrence_Of (Typ, Loc),
9158 Make_Attribute_Reference (Loc,
9159 Prefix => New_Occurrence_Of (Typ, Loc),
9160 Attribute_Name => Name_Input,
9161 Expressions => New_List (
9162 Make_Attribute_Reference (Loc,
9163 Prefix => New_Occurrence_Of (Strm, Loc),
9164 Attribute_Name => Name_Access))))),
9166 Handled_Statement_Sequence =>
9167 Make_Handled_Sequence_Of_Statements (Loc,
9168 Statements => New_List (
9169 Make_Procedure_Call_Statement (Loc,
9171 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
9172 Parameter_Associations =>
9174 New_Occurrence_Of (Strm, Loc))),
9175 Make_Return_Statement (Loc,
9176 Expression => New_Occurrence_Of (Res, Loc))))));
9182 Make_Subprogram_Body (Loc,
9183 Specification => Spec,
9184 Declarations => Decls,
9185 Handled_Statement_Sequence =>
9186 Make_Handled_Sequence_Of_Statements (Loc,
9187 Statements => Stms));
9188 end Build_From_Any_Function;
9190 ---------------------------------
9191 -- Build_Get_Aggregate_Element --
9192 ---------------------------------
9194 function Build_Get_Aggregate_Element
9198 Idx : Node_Id) return Node_Id
9201 return Make_Function_Call (Loc,
9204 RTE (RE_Get_Aggregate_Element), Loc),
9205 Parameter_Associations => New_List (
9206 New_Occurrence_Of (Any, Loc),
9209 end Build_Get_Aggregate_Element;
9211 -------------------------
9212 -- Build_Reposiroty_Id --
9213 -------------------------
9215 procedure Build_Name_And_Repository_Id
9217 Name_Str : out String_Id;
9218 Repo_Id_Str : out String_Id)
9222 Store_String_Chars ("DSA:");
9223 Get_Library_Unit_Name_String (Scope (E));
9224 Store_String_Chars (
9225 Name_Buffer (Name_Buffer'First
9226 .. Name_Buffer'First + Name_Len - 1));
9227 Store_String_Char ('.');
9228 Get_Name_String (Chars (E));
9229 Store_String_Chars (
9230 Name_Buffer (Name_Buffer'First
9231 .. Name_Buffer'First + Name_Len - 1));
9232 Store_String_Chars (":1.0");
9233 Repo_Id_Str := End_String;
9234 Name_Str := String_From_Name_Buffer;
9235 end Build_Name_And_Repository_Id;
9237 -----------------------
9238 -- Build_To_Any_Call --
9239 -----------------------
9241 function Build_To_Any_Call
9243 Decls : List_Id) return Node_Id
9245 Loc : constant Source_Ptr := Sloc (N);
9247 Typ : Entity_Id := Etype (N);
9250 Fnam : Entity_Id := Empty;
9251 Lib_RE : RE_Id := RE_Null;
9254 -- If N is a selected component, then maybe its Etype has not been
9255 -- set yet: try to use the Etype of the selector_name in that
9258 if No (Typ) and then Nkind (N) = N_Selected_Component then
9259 Typ := Etype (Selector_Name (N));
9261 pragma Assert (Present (Typ));
9263 -- The full view, if Typ is private; the completion, if Typ is
9266 U_Type := Underlying_Type (Typ);
9268 -- First simple case where the To_Any function is present in the
9271 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9273 -- Check first for Boolean and Character. These are enumeration
9274 -- types, but we treat them specially, since they may require
9275 -- special handling in the transfer protocol. However, this
9276 -- special handling only applies if they have standard
9277 -- representation, otherwise they are treated like any other
9278 -- enumeration type.
9280 if Sloc (U_Type) <= Standard_Location then
9281 U_Type := Base_Type (U_Type);
9284 if Present (Fnam) then
9287 elsif U_Type = Standard_Boolean then
9290 elsif U_Type = Standard_Character then
9293 elsif U_Type = Standard_Wide_Character then
9296 elsif U_Type = Standard_Wide_Wide_Character then
9297 Lib_RE := RE_TA_WWC;
9299 -- Floating point types
9301 elsif U_Type = Standard_Short_Float then
9304 elsif U_Type = Standard_Float then
9307 elsif U_Type = Standard_Long_Float then
9310 elsif U_Type = Standard_Long_Long_Float then
9311 Lib_RE := RE_TA_LLF;
9315 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9316 Lib_RE := RE_TA_SSI;
9318 elsif U_Type = Etype (Standard_Short_Integer) then
9321 elsif U_Type = Etype (Standard_Integer) then
9324 elsif U_Type = Etype (Standard_Long_Integer) then
9327 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9328 Lib_RE := RE_TA_LLI;
9330 -- Unsigned integer types
9332 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9333 Lib_RE := RE_TA_SSU;
9335 elsif U_Type = RTE (RE_Short_Unsigned) then
9338 elsif U_Type = RTE (RE_Unsigned) then
9341 elsif U_Type = RTE (RE_Long_Unsigned) then
9344 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9345 Lib_RE := RE_TA_LLU;
9347 elsif U_Type = Standard_String then
9348 Lib_RE := RE_TA_String;
9350 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9353 -- Other (non-primitive) types
9359 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9360 Append_To (Decls, Decl);
9364 -- Call the function
9366 if Lib_RE /= RE_Null then
9367 pragma Assert (No (Fnam));
9368 Fnam := RTE (Lib_RE);
9372 Make_Function_Call (Loc,
9373 Name => New_Occurrence_Of (Fnam, Loc),
9374 Parameter_Associations =>
9375 New_List (Unchecked_Convert_To (U_Type, N)));
9376 end Build_To_Any_Call;
9378 ---------------------------
9379 -- Build_To_Any_Function --
9380 ---------------------------
9382 procedure Build_To_Any_Function
9386 Fnam : out Entity_Id)
9389 Decls : constant List_Id := New_List;
9390 Stms : constant List_Id := New_List;
9392 Expr_Parameter : constant Entity_Id :=
9393 Make_Defining_Identifier (Loc, Name_E);
9395 Any : constant Entity_Id :=
9396 Make_Defining_Identifier (Loc, Name_A);
9399 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9402 if Is_Itype (Typ) then
9403 Build_To_Any_Function
9411 Fnam := Make_Stream_Procedure_Function_Name (Loc,
9415 Make_Function_Specification (Loc,
9416 Defining_Unit_Name => Fnam,
9417 Parameter_Specifications => New_List (
9418 Make_Parameter_Specification (Loc,
9419 Defining_Identifier =>
9422 New_Occurrence_Of (Typ, Loc))),
9423 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9424 Set_Etype (Expr_Parameter, Typ);
9427 Make_Object_Declaration (Loc,
9428 Defining_Identifier =>
9430 Object_Definition =>
9431 New_Occurrence_Of (RTE (RE_Any), Loc));
9433 if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9435 Rt_Type : constant Entity_Id
9437 Expr : constant Node_Id
9440 New_Occurrence_Of (Expr_Parameter, Loc));
9442 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9445 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9446 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9448 Rt_Type : constant Entity_Id
9450 Expr : constant Node_Id
9453 New_Occurrence_Of (Expr_Parameter, Loc));
9456 Set_Expression (Any_Decl,
9457 Build_To_Any_Call (Expr, Decls));
9462 Disc : Entity_Id := Empty;
9463 Rdef : constant Node_Id :=
9464 Type_Definition (Declaration_Node (Typ));
9466 Elements : constant List_Id := New_List;
9468 procedure TA_Rec_Add_Process_Element
9470 Container : Node_Or_Entity_Id;
9471 Counter : in out Int;
9475 procedure TA_Append_Record_Traversal is
9476 new Append_Record_Traversal
9477 (Rec => Expr_Parameter,
9478 Add_Process_Element => TA_Rec_Add_Process_Element);
9480 --------------------------------
9481 -- TA_Rec_Add_Process_Element --
9482 --------------------------------
9484 procedure TA_Rec_Add_Process_Element
9486 Container : Node_Or_Entity_Id;
9487 Counter : in out Int;
9491 Field_Ref : Node_Id;
9494 if Nkind (Field) = N_Defining_Identifier then
9496 -- A regular component
9498 Field_Ref := Make_Selected_Component (Loc,
9499 Prefix => New_Occurrence_Of (Rec, Loc),
9500 Selector_Name => New_Occurrence_Of (Field, Loc));
9501 Set_Etype (Field_Ref, Etype (Field));
9504 Make_Procedure_Call_Statement (Loc,
9507 RTE (RE_Add_Aggregate_Element), Loc),
9508 Parameter_Associations => New_List (
9509 New_Occurrence_Of (Container, Loc),
9510 Build_To_Any_Call (Field_Ref, Decls))));
9517 Struct_Counter : Int := 0;
9519 Block_Decls : constant List_Id := New_List;
9520 Block_Stmts : constant List_Id := New_List;
9523 Alt_List : constant List_Id := New_List;
9524 Choice_List : List_Id;
9526 Union_Any : constant Entity_Id :=
9527 Make_Defining_Identifier (Loc,
9528 New_Internal_Name ('V'));
9530 Struct_Any : constant Entity_Id :=
9531 Make_Defining_Identifier (Loc,
9532 New_Internal_Name ('S'));
9534 function Make_Discriminant_Reference
9536 -- Build a selected component for the
9537 -- discriminant of this variant part.
9539 ---------------------------------
9540 -- Make_Discriminant_Reference --
9541 ---------------------------------
9543 function Make_Discriminant_Reference
9546 Nod : constant Node_Id :=
9547 Make_Selected_Component (Loc,
9550 Chars (Name (Field)));
9552 Set_Etype (Nod, Etype (Name (Field)));
9554 end Make_Discriminant_Reference;
9558 Make_Block_Statement (Loc,
9561 Handled_Statement_Sequence =>
9562 Make_Handled_Sequence_Of_Statements (Loc,
9563 Statements => Block_Stmts)));
9565 -- Declare the Variant Part aggregate
9567 -- Knowing the position of this VP in
9568 -- the variant record, we can fetch the
9569 -- VP typecode from Container.
9571 Append_To (Block_Decls,
9572 Make_Object_Declaration (Loc,
9573 Defining_Identifier => Union_Any,
9574 Object_Definition =>
9575 New_Occurrence_Of (RTE (RE_Any), Loc),
9577 Make_Function_Call (Loc,
9578 Name => New_Occurrence_Of (
9579 RTE (RE_Create_Any), Loc),
9580 Parameter_Associations => New_List (
9581 Make_Function_Call (Loc,
9584 RTE (RE_Any_Member_Type), Loc),
9585 Parameter_Associations => New_List (
9586 New_Occurrence_Of (Container, Loc),
9587 Make_Integer_Literal (Loc,
9590 -- Declare the inner struct aggregate
9591 -- (that will contain the components
9594 Append_To (Block_Decls,
9595 Make_Object_Declaration (Loc,
9596 Defining_Identifier => Struct_Any,
9597 Object_Definition =>
9598 New_Occurrence_Of (RTE (RE_Any), Loc),
9600 Make_Function_Call (Loc,
9601 Name => New_Occurrence_Of (
9602 RTE (RE_Create_Any), Loc),
9603 Parameter_Associations => New_List (
9604 Make_Function_Call (Loc,
9607 RTE (RE_Any_Member_Type), Loc),
9608 Parameter_Associations => New_List (
9609 New_Occurrence_Of (Union_Any, Loc),
9610 Make_Integer_Literal (Loc,
9613 -- Construct a case statement that will choose
9614 -- the appropriate code at runtime depending on
9615 -- the discriminant.
9617 Append_To (Block_Stmts,
9618 Make_Case_Statement (Loc,
9620 Make_Discriminant_Reference,
9624 Variant := First_Non_Pragma (Variants (Field));
9625 while Present (Variant) loop
9626 Choice_List := New_Copy_List_Tree
9627 (Discrete_Choices (Variant));
9629 VP_Stmts := New_List;
9631 -- Append discriminant value to union
9634 Append_To (VP_Stmts,
9635 Make_Procedure_Call_Statement (Loc,
9638 RTE (RE_Add_Aggregate_Element), Loc),
9639 Parameter_Associations => New_List (
9640 New_Occurrence_Of (Union_Any, Loc),
9642 Make_Discriminant_Reference,
9645 -- Populate inner struct aggregate
9647 -- Struct_Counter should be reset before
9648 -- handling a variant part. Indeed only one
9649 -- of the case statement alternatives will be
9650 -- executed at run-time, so the counter must
9651 -- start at 0 for every case statement.
9653 Struct_Counter := 0;
9655 TA_Append_Record_Traversal (
9657 Clist => Component_List (Variant),
9658 Container => Struct_Any,
9659 Counter => Struct_Counter);
9661 -- Append inner struct to union aggregate
9663 Append_To (VP_Stmts,
9664 Make_Procedure_Call_Statement (Loc,
9667 RTE (RE_Add_Aggregate_Element), Loc),
9668 Parameter_Associations => New_List (
9669 New_Occurrence_Of (Union_Any, Loc),
9670 New_Occurrence_Of (Struct_Any, Loc))));
9672 -- Append union to outer aggregate
9674 Append_To (VP_Stmts,
9675 Make_Procedure_Call_Statement (Loc,
9678 RTE (RE_Add_Aggregate_Element), Loc),
9679 Parameter_Associations => New_List (
9680 New_Occurrence_Of (Container, Loc),
9682 (Union_Any, Loc))));
9684 Append_To (Alt_List,
9685 Make_Case_Statement_Alternative (Loc,
9686 Discrete_Choices => Choice_List,
9687 Statements => VP_Stmts));
9689 Next_Non_Pragma (Variant);
9693 Counter := Counter + 1;
9694 end TA_Rec_Add_Process_Element;
9697 -- Records are encoded in a TC_STRUCT aggregate:
9698 -- -- Outer aggregate (TC_STRUCT)
9699 -- | [discriminant1]
9700 -- | [discriminant2]
9707 -- A component can be a common component or a variant
9710 -- A variant part is encoded as a TC_UNION aggregate:
9711 -- -- Variant Part Aggregate (TC_UNION)
9712 -- | [discriminant choice for this Variant Part]
9714 -- | -- Inner struct (TC_STRUCT)
9719 -- Let's start by building the outer aggregate
9720 -- First we construct an Elements array containing all
9721 -- the discriminants.
9723 if Has_Discriminants (Typ) then
9724 Disc := First_Discriminant (Typ);
9726 while Present (Disc) loop
9729 Discriminant : constant Entity_Id :=
9730 Make_Selected_Component (Loc,
9731 Prefix => Expr_Parameter,
9732 Selector_Name => Chars (Disc));
9734 Set_Etype (Discriminant, Etype (Disc));
9736 Append_To (Elements,
9737 Make_Component_Association (Loc,
9738 Choices => New_List (
9739 Make_Integer_Literal (Loc, Counter)),
9741 Build_To_Any_Call (Discriminant, Decls)));
9743 Counter := Counter + 1;
9744 Next_Discriminant (Disc);
9748 -- If there are no discriminants, we declare an empty
9752 Dummy_Any : constant Entity_Id :=
9753 Make_Defining_Identifier (Loc,
9754 Chars => New_Internal_Name ('A'));
9758 Make_Object_Declaration (Loc,
9759 Defining_Identifier => Dummy_Any,
9760 Object_Definition =>
9761 New_Occurrence_Of (RTE (RE_Any), Loc)));
9763 Append_To (Elements,
9764 Make_Component_Association (Loc,
9765 Choices => New_List (
9768 Make_Integer_Literal (Loc, 1),
9770 Make_Integer_Literal (Loc, 0))),
9772 New_Occurrence_Of (Dummy_Any, Loc)));
9776 -- We build the result aggregate with discriminants
9777 -- as the first elements.
9779 Set_Expression (Any_Decl,
9780 Make_Function_Call (Loc,
9781 Name => New_Occurrence_Of (
9782 RTE (RE_Any_Aggregate_Build), Loc),
9783 Parameter_Associations => New_List (
9785 Make_Aggregate (Loc,
9786 Component_Associations => Elements))));
9789 -- Then we append all the components to the result
9792 TA_Append_Record_Traversal (Stms,
9793 Clist => Component_List (Rdef),
9795 Counter => Counter);
9799 elsif Is_Array_Type (Typ) then
9801 Constrained : constant Boolean := Is_Constrained (Typ);
9803 procedure TA_Ary_Add_Process_Element
9806 Counter : Entity_Id;
9809 --------------------------------
9810 -- TA_Ary_Add_Process_Element --
9811 --------------------------------
9813 procedure TA_Ary_Add_Process_Element
9816 Counter : Entity_Id;
9819 pragma Warnings (Off);
9820 pragma Unreferenced (Counter);
9821 pragma Warnings (On);
9823 Element_Any : Node_Id;
9826 if Etype (Datum) = RTE (RE_Any) then
9827 Element_Any := Datum;
9829 Element_Any := Build_To_Any_Call (Datum, Decls);
9833 Make_Procedure_Call_Statement (Loc,
9834 Name => New_Occurrence_Of (
9835 RTE (RE_Add_Aggregate_Element), Loc),
9836 Parameter_Associations => New_List (
9837 New_Occurrence_Of (Any, Loc),
9839 end TA_Ary_Add_Process_Element;
9841 procedure Append_To_Any_Array_Iterator is
9842 new Append_Array_Traversal (
9844 Arry => Expr_Parameter,
9845 Indices => New_List,
9846 Add_Process_Element => TA_Ary_Add_Process_Element);
9851 Set_Expression (Any_Decl,
9852 Make_Function_Call (Loc,
9854 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9855 Parameter_Associations => New_List (Result_TC)));
9858 if not Constrained then
9859 Index := First_Index (Typ);
9860 for J in 1 .. Number_Dimensions (Typ) loop
9862 Make_Procedure_Call_Statement (Loc,
9865 RTE (RE_Add_Aggregate_Element), Loc),
9866 Parameter_Associations => New_List (
9867 New_Occurrence_Of (Any, Loc),
9869 OK_Convert_To (Etype (Index),
9870 Make_Attribute_Reference (Loc,
9872 New_Occurrence_Of (Expr_Parameter, Loc),
9873 Attribute_Name => Name_First,
9874 Expressions => New_List (
9875 Make_Integer_Literal (Loc, J)))),
9881 Append_To_Any_Array_Iterator (Stms, Any);
9884 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9885 Set_Expression (Any_Decl,
9888 Find_Numeric_Representation (Typ),
9889 New_Occurrence_Of (Expr_Parameter, Loc)),
9893 -- Default: type is represented as an opaque sequence of bytes
9896 Strm : constant Entity_Id := Make_Defining_Identifier (Loc,
9897 New_Internal_Name ('S'));
9900 -- Strm : aliased Buffer_Stream_Type;
9903 Make_Object_Declaration (Loc,
9904 Defining_Identifier =>
9908 Object_Definition =>
9909 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9911 -- Allocate_Buffer (Strm);
9914 Make_Procedure_Call_Statement (Loc,
9916 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9917 Parameter_Associations => New_List (
9918 New_Occurrence_Of (Strm, Loc))));
9920 -- T'Output (Strm'Access, E);
9923 Make_Attribute_Reference (Loc,
9924 Prefix => New_Occurrence_Of (Typ, Loc),
9925 Attribute_Name => Name_Output,
9926 Expressions => New_List (
9927 Make_Attribute_Reference (Loc,
9928 Prefix => New_Occurrence_Of (Strm, Loc),
9929 Attribute_Name => Name_Access),
9930 New_Occurrence_Of (Expr_Parameter, Loc))));
9932 -- BS_To_Any (Strm, A);
9935 Make_Procedure_Call_Statement (Loc,
9937 New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
9938 Parameter_Associations => New_List (
9939 New_Occurrence_Of (Strm, Loc),
9940 New_Occurrence_Of (Any, Loc))));
9942 -- Release_Buffer (Strm);
9945 Make_Procedure_Call_Statement (Loc,
9947 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
9948 Parameter_Associations => New_List (
9949 New_Occurrence_Of (Strm, Loc))));
9953 Append_To (Decls, Any_Decl);
9955 if Present (Result_TC) then
9957 Make_Procedure_Call_Statement (Loc,
9958 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
9959 Parameter_Associations => New_List (
9960 New_Occurrence_Of (Any, Loc),
9965 Make_Return_Statement (Loc,
9966 Expression => New_Occurrence_Of (Any, Loc)));
9969 Make_Subprogram_Body (Loc,
9970 Specification => Spec,
9971 Declarations => Decls,
9972 Handled_Statement_Sequence =>
9973 Make_Handled_Sequence_Of_Statements (Loc,
9974 Statements => Stms));
9975 end Build_To_Any_Function;
9977 -------------------------
9978 -- Build_TypeCode_Call --
9979 -------------------------
9981 function Build_TypeCode_Call
9984 Decls : List_Id) return Node_Id
9986 U_Type : Entity_Id := Underlying_Type (Typ);
9987 -- The full view, if Typ is private; the completion,
9988 -- if Typ is incomplete.
9990 Fnam : Entity_Id := Empty;
9991 Lib_RE : RE_Id := RE_Null;
9996 -- Special case System.PolyORB.Interface.Any: its primitives have
9997 -- not been set yet, so can't call Find_Inherited_TSS.
9999 if Typ = RTE (RE_Any) then
10000 Fnam := RTE (RE_TC_Any);
10003 -- First simple case where the TypeCode is present
10004 -- in the type's TSS.
10006 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10010 if Sloc (U_Type) <= Standard_Location then
10012 -- Do not try to build alias typecodes for subtypes from
10015 U_Type := Base_Type (U_Type);
10018 if U_Type = Standard_Boolean then
10021 elsif U_Type = Standard_Character then
10024 elsif U_Type = Standard_Wide_Character then
10025 Lib_RE := RE_TC_WC;
10027 elsif U_Type = Standard_Wide_Wide_Character then
10028 Lib_RE := RE_TC_WWC;
10030 -- Floating point types
10032 elsif U_Type = Standard_Short_Float then
10033 Lib_RE := RE_TC_SF;
10035 elsif U_Type = Standard_Float then
10038 elsif U_Type = Standard_Long_Float then
10039 Lib_RE := RE_TC_LF;
10041 elsif U_Type = Standard_Long_Long_Float then
10042 Lib_RE := RE_TC_LLF;
10044 -- Integer types (walk back to the base type)
10046 elsif U_Type = Etype (Standard_Short_Short_Integer) then
10047 Lib_RE := RE_TC_SSI;
10049 elsif U_Type = Etype (Standard_Short_Integer) then
10050 Lib_RE := RE_TC_SI;
10052 elsif U_Type = Etype (Standard_Integer) then
10055 elsif U_Type = Etype (Standard_Long_Integer) then
10056 Lib_RE := RE_TC_LI;
10058 elsif U_Type = Etype (Standard_Long_Long_Integer) then
10059 Lib_RE := RE_TC_LLI;
10061 -- Unsigned integer types
10063 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
10064 Lib_RE := RE_TC_SSU;
10066 elsif U_Type = RTE (RE_Short_Unsigned) then
10067 Lib_RE := RE_TC_SU;
10069 elsif U_Type = RTE (RE_Unsigned) then
10072 elsif U_Type = RTE (RE_Long_Unsigned) then
10073 Lib_RE := RE_TC_LU;
10075 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
10076 Lib_RE := RE_TC_LLU;
10078 elsif U_Type = Standard_String then
10079 Lib_RE := RE_TC_String;
10081 -- Other (non-primitive) types
10087 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10088 Append_To (Decls, Decl);
10092 if Lib_RE /= RE_Null then
10093 Fnam := RTE (Lib_RE);
10097 -- Call the function
10100 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10102 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10104 Set_Etype (Expr, RTE (RE_TypeCode));
10107 end Build_TypeCode_Call;
10109 -----------------------------
10110 -- Build_TypeCode_Function --
10111 -----------------------------
10113 procedure Build_TypeCode_Function
10116 Decl : out Node_Id;
10117 Fnam : out Entity_Id)
10120 Decls : constant List_Id := New_List;
10121 Stms : constant List_Id := New_List;
10123 TCNam : constant Entity_Id :=
10124 Make_Stream_Procedure_Function_Name (Loc,
10125 Typ, Name_uTypeCode);
10127 Parameters : List_Id;
10129 procedure Add_String_Parameter
10131 Parameter_List : List_Id);
10132 -- Add a literal for S to Parameters
10134 procedure Add_TypeCode_Parameter
10135 (TC_Node : Node_Id;
10136 Parameter_List : List_Id);
10137 -- Add the typecode for Typ to Parameters
10139 procedure Add_Long_Parameter
10140 (Expr_Node : Node_Id;
10141 Parameter_List : List_Id);
10142 -- Add a signed long integer expression to Parameters
10144 procedure Initialize_Parameter_List
10145 (Name_String : String_Id;
10146 Repo_Id_String : String_Id;
10147 Parameter_List : out List_Id);
10148 -- Return a list that contains the first two parameters
10149 -- for a parameterized typecode: name and repository id.
10151 function Make_Constructed_TypeCode
10153 Parameters : List_Id) return Node_Id;
10154 -- Call TC_Build with the given kind and parameters
10156 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10157 -- Make a return statement that calls TC_Build with the given
10158 -- typecode kind, and the constructed parameters list.
10160 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10161 -- Return a typecode that is a TC_Alias for the given typecode
10163 --------------------------
10164 -- Add_String_Parameter --
10165 --------------------------
10167 procedure Add_String_Parameter
10169 Parameter_List : List_Id)
10172 Append_To (Parameter_List,
10173 Make_Function_Call (Loc,
10175 New_Occurrence_Of (RTE (RE_TA_String), Loc),
10176 Parameter_Associations => New_List (
10177 Make_String_Literal (Loc, S))));
10178 end Add_String_Parameter;
10180 ----------------------------
10181 -- Add_TypeCode_Parameter --
10182 ----------------------------
10184 procedure Add_TypeCode_Parameter
10185 (TC_Node : Node_Id;
10186 Parameter_List : List_Id)
10189 Append_To (Parameter_List,
10190 Make_Function_Call (Loc,
10192 New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10193 Parameter_Associations => New_List (
10195 end Add_TypeCode_Parameter;
10197 ------------------------
10198 -- Add_Long_Parameter --
10199 ------------------------
10201 procedure Add_Long_Parameter
10202 (Expr_Node : Node_Id;
10203 Parameter_List : List_Id)
10206 Append_To (Parameter_List,
10207 Make_Function_Call (Loc,
10209 New_Occurrence_Of (RTE (RE_TA_LI), Loc),
10210 Parameter_Associations => New_List (Expr_Node)));
10211 end Add_Long_Parameter;
10213 -------------------------------
10214 -- Initialize_Parameter_List --
10215 -------------------------------
10217 procedure Initialize_Parameter_List
10218 (Name_String : String_Id;
10219 Repo_Id_String : String_Id;
10220 Parameter_List : out List_Id)
10223 Parameter_List := New_List;
10224 Add_String_Parameter (Name_String, Parameter_List);
10225 Add_String_Parameter (Repo_Id_String, Parameter_List);
10226 end Initialize_Parameter_List;
10228 ---------------------------
10229 -- Return_Alias_TypeCode --
10230 ---------------------------
10232 procedure Return_Alias_TypeCode
10233 (Base_TypeCode : Node_Id)
10236 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10237 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
10238 end Return_Alias_TypeCode;
10240 -------------------------------
10241 -- Make_Constructed_TypeCode --
10242 -------------------------------
10244 function Make_Constructed_TypeCode
10246 Parameters : List_Id) return Node_Id
10248 Constructed_TC : constant Node_Id :=
10249 Make_Function_Call (Loc,
10251 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
10252 Parameter_Associations => New_List (
10253 New_Occurrence_Of (Kind, Loc),
10254 Make_Aggregate (Loc,
10255 Expressions => Parameters)));
10257 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10258 return Constructed_TC;
10259 end Make_Constructed_TypeCode;
10261 ---------------------------------
10262 -- Return_Constructed_TypeCode --
10263 ---------------------------------
10265 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10268 Make_Return_Statement (Loc,
10270 Make_Constructed_TypeCode (Kind, Parameters)));
10271 end Return_Constructed_TypeCode;
10277 procedure TC_Rec_Add_Process_Element
10280 Counter : in out Int;
10284 procedure TC_Append_Record_Traversal is
10285 new Append_Record_Traversal (
10287 Add_Process_Element => TC_Rec_Add_Process_Element);
10289 --------------------------------
10290 -- TC_Rec_Add_Process_Element --
10291 --------------------------------
10293 procedure TC_Rec_Add_Process_Element
10296 Counter : in out Int;
10300 pragma Warnings (Off);
10301 pragma Unreferenced (Any, Counter, Rec);
10302 pragma Warnings (On);
10305 if Nkind (Field) = N_Defining_Identifier then
10307 -- A regular component
10309 Add_TypeCode_Parameter (
10310 Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10311 Get_Name_String (Chars (Field));
10312 Add_String_Parameter (String_From_Name_Buffer, Params);
10319 Discriminant_Type : constant Entity_Id :=
10320 Etype (Name (Field));
10322 Is_Enum : constant Boolean :=
10323 Is_Enumeration_Type (Discriminant_Type);
10325 Union_TC_Params : List_Id;
10327 U_Name : constant Name_Id :=
10328 New_External_Name (Chars (Typ), 'V', -1);
10330 Name_Str : String_Id;
10331 Struct_TC_Params : List_Id;
10335 Default : constant Node_Id :=
10336 Make_Integer_Literal (Loc, -1);
10338 Dummy_Counter : Int := 0;
10340 Choice_Index : Int := 0;
10342 procedure Add_Params_For_Variant_Components;
10343 -- Add a struct TypeCode and a corresponding member name
10344 -- to the union parameter list.
10346 -- Ordering of declarations is a complete mess in this
10347 -- area, it is supposed to be types/varibles, then
10348 -- subprogram specs, then subprogram bodies ???
10350 ---------------------------------------
10351 -- Add_Params_For_Variant_Components --
10352 ---------------------------------------
10354 procedure Add_Params_For_Variant_Components
10356 S_Name : constant Name_Id :=
10357 New_External_Name (U_Name, 'S', -1);
10360 Get_Name_String (S_Name);
10361 Name_Str := String_From_Name_Buffer;
10362 Initialize_Parameter_List
10363 (Name_Str, Name_Str, Struct_TC_Params);
10365 -- Build struct parameters
10367 TC_Append_Record_Traversal (Struct_TC_Params,
10368 Component_List (Variant),
10372 Add_TypeCode_Parameter
10373 (Make_Constructed_TypeCode
10374 (RTE (RE_TC_Struct), Struct_TC_Params),
10377 Add_String_Parameter (Name_Str, Union_TC_Params);
10378 end Add_Params_For_Variant_Components;
10381 Get_Name_String (U_Name);
10382 Name_Str := String_From_Name_Buffer;
10384 Initialize_Parameter_List
10385 (Name_Str, Name_Str, Union_TC_Params);
10387 -- Add union in enclosing parameter list
10389 Add_TypeCode_Parameter
10390 (Make_Constructed_TypeCode
10391 (RTE (RE_TC_Union), Union_TC_Params),
10394 Add_String_Parameter (Name_Str, Params);
10396 -- Build union parameters
10398 Add_TypeCode_Parameter
10399 (Build_TypeCode_Call
10400 (Loc, Discriminant_Type, Decls),
10403 Add_Long_Parameter (Default, Union_TC_Params);
10405 Variant := First_Non_Pragma (Variants (Field));
10406 while Present (Variant) loop
10407 Choice := First (Discrete_Choices (Variant));
10408 while Present (Choice) loop
10409 case Nkind (Choice) is
10412 L : constant Uint :=
10413 Expr_Value (Low_Bound (Choice));
10414 H : constant Uint :=
10415 Expr_Value (High_Bound (Choice));
10417 -- 3.8.1(8) guarantees that the bounds of
10418 -- this range are static.
10425 Expr := New_Occurrence_Of (
10426 Get_Enum_Lit_From_Pos (
10427 Discriminant_Type, J, Loc), Loc);
10430 Make_Integer_Literal (Loc, J);
10432 Append_To (Union_TC_Params,
10433 Make_Function_Call (Loc,
10434 Name => New_Occurrence_Of
10435 (RTE (RE_TA_A), Loc),
10436 Parameter_Associations =>
10441 Add_Params_For_Variant_Components;
10446 when N_Others_Choice =>
10448 -- This variant possess a default choice.
10449 -- We must therefore set the default
10450 -- parameter to the current choice index. The
10451 -- default parameter is by construction the
10452 -- fourth in the Union_TC_Params list.
10455 Default_Node : constant Node_Id :=
10456 Pick (Union_TC_Params, 4);
10458 New_Default_Node : constant Node_Id :=
10459 Make_Function_Call (Loc,
10462 (RTE (RE_TA_LI), Loc),
10463 Parameter_Associations =>
10465 Make_Integer_Literal
10466 (Loc, Choice_Index)));
10472 Remove (Default_Node);
10475 -- Add a placeholder member label
10476 -- for the default case.
10477 -- It must be of the discriminant
10481 Exp : constant Node_Id :=
10482 Make_Attribute_Reference (Loc,
10483 Prefix => New_Occurrence_Of
10484 (Discriminant_Type, Loc),
10485 Attribute_Name => Name_First);
10487 Set_Etype (Exp, Discriminant_Type);
10488 Append_To (Union_TC_Params,
10489 Make_Function_Call (Loc,
10490 Name => New_Occurrence_Of
10491 (RTE (RE_TA_A), Loc),
10492 Parameter_Associations =>
10498 Add_Params_For_Variant_Components;
10502 Exp : constant Node_Id :=
10503 New_Copy_Tree (Choice);
10505 Append_To (Union_TC_Params,
10506 Make_Function_Call (Loc,
10507 Name => New_Occurrence_Of
10508 (RTE (RE_TA_A), Loc),
10509 Parameter_Associations =>
10515 Add_Params_For_Variant_Components;
10518 Choice_Index := Choice_Index + 1;
10522 Next_Non_Pragma (Variant);
10527 end TC_Rec_Add_Process_Element;
10529 Type_Name_Str : String_Id;
10530 Type_Repo_Id_Str : String_Id;
10533 if Is_Itype (Typ) then
10534 Build_TypeCode_Function
10536 Typ => Etype (Typ),
10545 Make_Function_Specification (Loc,
10546 Defining_Unit_Name => Fnam,
10547 Parameter_Specifications => Empty_List,
10548 Result_Definition =>
10549 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10551 Build_Name_And_Repository_Id (Typ,
10552 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10553 Initialize_Parameter_List
10554 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10556 if Is_Derived_Type (Typ)
10557 and then not Is_Tagged_Type (Typ)
10559 Return_Alias_TypeCode (
10560 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10562 elsif Is_Integer_Type (Typ)
10563 or else Is_Unsigned_Type (Typ)
10565 Return_Alias_TypeCode (
10566 Build_TypeCode_Call (Loc,
10567 Find_Numeric_Representation (Typ), Decls));
10569 elsif Is_Record_Type (Typ)
10570 and then not Is_Tagged_Type (Typ)
10573 -- Record typecodes are encoded as follows:
10577 -- | [Repository Id]
10579 -- Then for each discriminant:
10581 -- | [Discriminant Type Code]
10582 -- | [Discriminant Name]
10585 -- Then for each component:
10587 -- | [Component Type Code]
10588 -- | [Component Name]
10591 -- Variants components type codes are encoded as follows:
10595 -- | [Repository Id]
10596 -- | [Discriminant Type Code]
10597 -- | [Index of Default Variant Part or -1 for no default]
10599 -- Then for each Variant Part :
10604 -- | | [Variant Part Name]
10605 -- | | [Variant Part Repository Id]
10607 -- | Then for each VP component:
10608 -- | | [VP component Typecode]
10609 -- | | [VP component Name]
10615 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10616 Return_Alias_TypeCode (
10617 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10620 Disc : Entity_Id := Empty;
10621 Rdef : constant Node_Id :=
10622 Type_Definition (Declaration_Node (Typ));
10623 Dummy_Counter : Int := 0;
10625 -- Construct the discriminants typecodes
10627 if Has_Discriminants (Typ) then
10628 Disc := First_Discriminant (Typ);
10630 while Present (Disc) loop
10631 Add_TypeCode_Parameter (
10632 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10634 Get_Name_String (Chars (Disc));
10635 Add_String_Parameter (
10636 String_From_Name_Buffer,
10638 Next_Discriminant (Disc);
10641 -- then the components typecodes
10643 TC_Append_Record_Traversal
10644 (Parameters, Component_List (Rdef),
10645 Empty, Dummy_Counter);
10646 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10650 elsif Is_Array_Type (Typ) then
10652 Ndim : constant Pos := Number_Dimensions (Typ);
10653 Inner_TypeCode : Node_Id;
10654 Constrained : constant Boolean := Is_Constrained (Typ);
10655 Indx : Node_Id := First_Index (Typ);
10658 Inner_TypeCode := Build_TypeCode_Call (Loc,
10659 Component_Type (Typ),
10662 for J in 1 .. Ndim loop
10663 if Constrained then
10664 Inner_TypeCode := Make_Constructed_TypeCode
10665 (RTE (RE_TC_Array), New_List (
10666 Build_To_Any_Call (
10667 OK_Convert_To (RTE (RE_Long_Unsigned),
10668 Make_Attribute_Reference (Loc,
10670 New_Occurrence_Of (Typ, Loc),
10673 Expressions => New_List (
10674 Make_Integer_Literal (Loc,
10677 Build_To_Any_Call (Inner_TypeCode, Decls)));
10680 -- Unconstrained case: add low bound for each
10683 Add_TypeCode_Parameter
10684 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10686 Get_Name_String (New_External_Name ('L', J));
10687 Add_String_Parameter (
10688 String_From_Name_Buffer,
10692 Inner_TypeCode := Make_Constructed_TypeCode
10693 (RTE (RE_TC_Sequence), New_List (
10694 Build_To_Any_Call (
10695 OK_Convert_To (RTE (RE_Long_Unsigned),
10696 Make_Integer_Literal (Loc, 0)),
10698 Build_To_Any_Call (Inner_TypeCode, Decls)));
10702 if Constrained then
10703 Return_Alias_TypeCode (Inner_TypeCode);
10705 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10707 Store_String_Char ('V');
10708 Add_String_Parameter (End_String, Parameters);
10709 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10714 -- Default: type is represented as an opaque sequence of bytes
10716 Return_Alias_TypeCode
10717 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10721 Make_Subprogram_Body (Loc,
10722 Specification => Spec,
10723 Declarations => Decls,
10724 Handled_Statement_Sequence =>
10725 Make_Handled_Sequence_Of_Statements (Loc,
10726 Statements => Stms));
10727 end Build_TypeCode_Function;
10729 ---------------------------------
10730 -- Find_Numeric_Representation --
10731 ---------------------------------
10733 function Find_Numeric_Representation
10734 (Typ : Entity_Id) return Entity_Id
10736 FST : constant Entity_Id := First_Subtype (Typ);
10737 P_Size : constant Uint := Esize (FST);
10740 if Is_Unsigned_Type (Typ) then
10741 if P_Size <= Standard_Short_Short_Integer_Size then
10742 return RTE (RE_Short_Short_Unsigned);
10744 elsif P_Size <= Standard_Short_Integer_Size then
10745 return RTE (RE_Short_Unsigned);
10747 elsif P_Size <= Standard_Integer_Size then
10748 return RTE (RE_Unsigned);
10750 elsif P_Size <= Standard_Long_Integer_Size then
10751 return RTE (RE_Long_Unsigned);
10754 return RTE (RE_Long_Long_Unsigned);
10757 elsif Is_Integer_Type (Typ) then
10758 if P_Size <= Standard_Short_Short_Integer_Size then
10759 return Standard_Short_Short_Integer;
10761 elsif P_Size <= Standard_Short_Integer_Size then
10762 return Standard_Short_Integer;
10764 elsif P_Size <= Standard_Integer_Size then
10765 return Standard_Integer;
10767 elsif P_Size <= Standard_Long_Integer_Size then
10768 return Standard_Long_Integer;
10771 return Standard_Long_Long_Integer;
10774 elsif Is_Floating_Point_Type (Typ) then
10775 if P_Size <= Standard_Short_Float_Size then
10776 return Standard_Short_Float;
10778 elsif P_Size <= Standard_Float_Size then
10779 return Standard_Float;
10781 elsif P_Size <= Standard_Long_Float_Size then
10782 return Standard_Long_Float;
10785 return Standard_Long_Long_Float;
10789 raise Program_Error;
10792 -- TBD: fixed point types???
10793 -- TBverified numeric types with a biased representation???
10795 end Find_Numeric_Representation;
10797 ---------------------------
10798 -- Append_Array_Traversal --
10799 ---------------------------
10801 procedure Append_Array_Traversal
10804 Counter : Entity_Id := Empty;
10807 Loc : constant Source_Ptr := Sloc (Subprogram);
10808 Typ : constant Entity_Id := Etype (Arry);
10809 Constrained : constant Boolean := Is_Constrained (Typ);
10810 Ndim : constant Pos := Number_Dimensions (Typ);
10812 Inner_Any, Inner_Counter : Entity_Id;
10814 Loop_Stm : Node_Id;
10815 Inner_Stmts : constant List_Id := New_List;
10818 if Depth > Ndim then
10820 -- Processing for one element of an array
10823 Element_Expr : constant Node_Id :=
10824 Make_Indexed_Component (Loc,
10825 New_Occurrence_Of (Arry, Loc),
10829 Set_Etype (Element_Expr, Component_Type (Typ));
10830 Add_Process_Element (Stmts,
10832 Counter => Counter,
10833 Datum => Element_Expr);
10839 Append_To (Indices,
10840 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10842 if not Constrained or else Depth > 1 then
10843 Inner_Any := Make_Defining_Identifier (Loc,
10844 New_External_Name ('A', Depth));
10845 Set_Etype (Inner_Any, RTE (RE_Any));
10847 Inner_Any := Empty;
10850 if Present (Counter) then
10851 Inner_Counter := Make_Defining_Identifier (Loc,
10852 New_External_Name ('J', Depth));
10854 Inner_Counter := Empty;
10858 Loop_Any : Node_Id := Inner_Any;
10861 -- For the first dimension of a constrained array, we add
10862 -- elements directly in the corresponding Any; there is no
10863 -- intervening inner Any.
10865 if No (Loop_Any) then
10869 Append_Array_Traversal (Inner_Stmts,
10871 Counter => Inner_Counter,
10872 Depth => Depth + 1);
10876 Make_Implicit_Loop_Statement (Subprogram,
10877 Iteration_Scheme =>
10878 Make_Iteration_Scheme (Loc,
10879 Loop_Parameter_Specification =>
10880 Make_Loop_Parameter_Specification (Loc,
10881 Defining_Identifier =>
10882 Make_Defining_Identifier (Loc,
10883 Chars => New_External_Name ('L', Depth)),
10885 Discrete_Subtype_Definition =>
10886 Make_Attribute_Reference (Loc,
10887 Prefix => New_Occurrence_Of (Arry, Loc),
10888 Attribute_Name => Name_Range,
10890 Expressions => New_List (
10891 Make_Integer_Literal (Loc, Depth))))),
10892 Statements => Inner_Stmts);
10895 Decls : constant List_Id := New_List;
10896 Dimen_Stmts : constant List_Id := New_List;
10897 Length_Node : Node_Id;
10899 Inner_Any_TypeCode : constant Entity_Id :=
10900 Make_Defining_Identifier (Loc,
10901 New_External_Name ('T', Depth));
10903 Inner_Any_TypeCode_Expr : Node_Id;
10907 if Constrained then
10908 Inner_Any_TypeCode_Expr :=
10909 Make_Function_Call (Loc,
10911 New_Occurrence_Of (RTE (RE_Get_TC), Loc),
10912 Parameter_Associations => New_List (
10913 New_Occurrence_Of (Any, Loc)));
10915 Inner_Any_TypeCode_Expr :=
10916 Make_Function_Call (Loc,
10918 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
10919 Parameter_Associations => New_List (
10920 New_Occurrence_Of (Any, Loc),
10921 Make_Integer_Literal (Loc, Ndim)));
10924 Inner_Any_TypeCode_Expr :=
10925 Make_Function_Call (Loc,
10927 New_Occurrence_Of (RTE (RE_Content_Type), Loc),
10928 Parameter_Associations => New_List (
10929 Make_Identifier (Loc,
10930 New_External_Name ('T', Depth - 1))));
10934 Make_Object_Declaration (Loc,
10935 Defining_Identifier => Inner_Any_TypeCode,
10936 Constant_Present => True,
10937 Object_Definition => New_Occurrence_Of (
10938 RTE (RE_TypeCode), Loc),
10939 Expression => Inner_Any_TypeCode_Expr));
10941 if Present (Inner_Any) then
10943 Make_Object_Declaration (Loc,
10944 Defining_Identifier => Inner_Any,
10945 Object_Definition =>
10946 New_Occurrence_Of (RTE (RE_Any), Loc),
10948 Make_Function_Call (Loc,
10950 New_Occurrence_Of (
10951 RTE (RE_Create_Any), Loc),
10952 Parameter_Associations => New_List (
10953 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
10956 if Present (Inner_Counter) then
10958 Make_Object_Declaration (Loc,
10959 Defining_Identifier => Inner_Counter,
10960 Object_Definition =>
10961 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
10963 Make_Integer_Literal (Loc, 0)));
10966 if not Constrained then
10967 Length_Node := Make_Attribute_Reference (Loc,
10968 Prefix => New_Occurrence_Of (Arry, Loc),
10969 Attribute_Name => Name_Length,
10971 New_List (Make_Integer_Literal (Loc, Depth)));
10972 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
10974 Add_Process_Element (Dimen_Stmts,
10975 Datum => Length_Node,
10977 Counter => Inner_Counter);
10980 -- Loop_Stm does appropriate processing for each element
10983 Append_To (Dimen_Stmts, Loop_Stm);
10985 -- Link outer and inner any
10987 if Present (Inner_Any) then
10988 Add_Process_Element (Dimen_Stmts,
10990 Counter => Counter,
10991 Datum => New_Occurrence_Of (Inner_Any, Loc));
10995 Make_Block_Statement (Loc,
10998 Handled_Statement_Sequence =>
10999 Make_Handled_Sequence_Of_Statements (Loc,
11000 Statements => Dimen_Stmts)));
11002 end Append_Array_Traversal;
11004 -----------------------------------------
11005 -- Make_Stream_Procedure_Function_Name --
11006 -----------------------------------------
11008 function Make_Stream_Procedure_Function_Name
11011 Nam : Name_Id) return Entity_Id
11014 -- For tagged types, we use a canonical name so that it matches
11015 -- the primitive spec. For all other cases, we use a serialized
11016 -- name so that multiple generations of the same procedure do not
11019 if Is_Tagged_Type (Typ) then
11020 return Make_Defining_Identifier (Loc, Nam);
11022 return Make_Defining_Identifier (Loc,
11024 New_External_Name (Nam, ' ', Increment_Serial_Number));
11026 end Make_Stream_Procedure_Function_Name;
11029 -----------------------------------
11030 -- Reserve_NamingContext_Methods --
11031 -----------------------------------
11033 procedure Reserve_NamingContext_Methods is
11034 Str_Resolve : constant String := "resolve";
11036 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11037 Name_Len := Str_Resolve'Length;
11038 Overload_Counter_Table.Set (Name_Find, 1);
11039 end Reserve_NamingContext_Methods;
11041 end PolyORB_Support;
11043 -------------------------------
11044 -- RACW_Type_Is_Asynchronous --
11045 -------------------------------
11047 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11048 Asynchronous_Flag : constant Entity_Id :=
11049 Asynchronous_Flags_Table.Get (RACW_Type);
11051 Replace (Expression (Parent (Asynchronous_Flag)),
11052 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11053 end RACW_Type_Is_Asynchronous;
11055 -------------------------
11056 -- RCI_Package_Locator --
11057 -------------------------
11059 function RCI_Package_Locator
11061 Package_Spec : Node_Id) return Node_Id
11064 Pkg_Name : String_Id;
11067 Get_Library_Unit_Name_String (Package_Spec);
11068 Pkg_Name := String_From_Name_Buffer;
11070 Make_Package_Instantiation (Loc,
11071 Defining_Unit_Name =>
11072 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
11074 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11075 Generic_Associations => New_List (
11076 Make_Generic_Association (Loc,
11078 Make_Identifier (Loc, Name_RCI_Name),
11079 Explicit_Generic_Actual_Parameter =>
11080 Make_String_Literal (Loc,
11081 Strval => Pkg_Name)),
11082 Make_Generic_Association (Loc,
11084 Make_Identifier (Loc, Name_Version),
11085 Explicit_Generic_Actual_Parameter =>
11086 Make_Attribute_Reference (Loc,
11088 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11092 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
11093 Defining_Unit_Name (Inst));
11095 end RCI_Package_Locator;
11097 -----------------------------------------------
11098 -- Remote_Types_Tagged_Full_View_Encountered --
11099 -----------------------------------------------
11101 procedure Remote_Types_Tagged_Full_View_Encountered
11102 (Full_View : Entity_Id)
11104 Stub_Elements : constant Stub_Structure :=
11105 Stubs_Table.Get (Full_View);
11107 if Stub_Elements /= Empty_Stub_Structure then
11108 Add_RACW_Primitive_Declarations_And_Bodies
11110 Stub_Elements.RPC_Receiver_Decl,
11111 Stub_Elements.Body_Decls);
11113 end Remote_Types_Tagged_Full_View_Encountered;
11115 -------------------
11116 -- Scope_Of_Spec --
11117 -------------------
11119 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11120 Unit_Name : Node_Id;
11123 Unit_Name := Defining_Unit_Name (Spec);
11124 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11125 Unit_Name := Defining_Identifier (Unit_Name);
11131 ----------------------
11132 -- Set_Renaming_TSS --
11133 ----------------------
11135 procedure Set_Renaming_TSS
11138 TSS_Nam : TSS_Name_Type)
11140 Loc : constant Source_Ptr := Sloc (Nam);
11141 Spec : constant Node_Id := Parent (Nam);
11143 TSS_Node : constant Node_Id :=
11144 Make_Subprogram_Renaming_Declaration (Loc,
11146 Copy_Specification (Loc,
11148 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11149 Name => New_Occurrence_Of (Nam, Loc));
11151 Snam : constant Entity_Id :=
11152 Defining_Unit_Name (Specification (TSS_Node));
11155 if Nkind (Spec) = N_Function_Specification then
11156 Set_Ekind (Snam, E_Function);
11157 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11159 Set_Ekind (Snam, E_Procedure);
11160 Set_Etype (Snam, Standard_Void_Type);
11163 Set_TSS (Typ, Snam);
11164 end Set_Renaming_TSS;
11166 ----------------------------------------------
11167 -- Specific_Add_Obj_RPC_Receiver_Completion --
11168 ----------------------------------------------
11170 procedure Specific_Add_Obj_RPC_Receiver_Completion
11173 RPC_Receiver : Entity_Id;
11174 Stub_Elements : Stub_Structure) is
11176 case Get_PCS_Name is
11177 when Name_PolyORB_DSA =>
11178 PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11179 Decls, RPC_Receiver, Stub_Elements);
11181 GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11182 Decls, RPC_Receiver, Stub_Elements);
11184 end Specific_Add_Obj_RPC_Receiver_Completion;
11186 --------------------------------
11187 -- Specific_Add_RACW_Features --
11188 --------------------------------
11190 procedure Specific_Add_RACW_Features
11191 (RACW_Type : Entity_Id;
11193 Stub_Type : Entity_Id;
11194 Stub_Type_Access : Entity_Id;
11195 RPC_Receiver_Decl : Node_Id;
11196 Body_Decls : List_Id) is
11198 case Get_PCS_Name is
11199 when Name_PolyORB_DSA =>
11200 PolyORB_Support.Add_RACW_Features (
11209 GARLIC_Support.Add_RACW_Features (
11216 end Specific_Add_RACW_Features;
11218 --------------------------------
11219 -- Specific_Add_RAST_Features --
11220 --------------------------------
11222 procedure Specific_Add_RAST_Features
11223 (Vis_Decl : Node_Id;
11224 RAS_Type : Entity_Id) is
11226 case Get_PCS_Name is
11227 when Name_PolyORB_DSA =>
11228 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11230 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11232 end Specific_Add_RAST_Features;
11234 --------------------------------------------------
11235 -- Specific_Add_Receiving_Stubs_To_Declarations --
11236 --------------------------------------------------
11238 procedure Specific_Add_Receiving_Stubs_To_Declarations
11239 (Pkg_Spec : Node_Id;
11244 case Get_PCS_Name is
11245 when Name_PolyORB_DSA =>
11246 PolyORB_Support.Add_Receiving_Stubs_To_Declarations (
11247 Pkg_Spec, Decls, Stmts);
11249 GARLIC_Support.Add_Receiving_Stubs_To_Declarations (
11250 Pkg_Spec, Decls, Stmts);
11252 end Specific_Add_Receiving_Stubs_To_Declarations;
11254 ------------------------------------------
11255 -- Specific_Build_General_Calling_Stubs --
11256 ------------------------------------------
11258 procedure Specific_Build_General_Calling_Stubs
11260 Statements : List_Id;
11261 Target : RPC_Target;
11262 Subprogram_Id : Node_Id;
11263 Asynchronous : Node_Id := Empty;
11264 Is_Known_Asynchronous : Boolean := False;
11265 Is_Known_Non_Asynchronous : Boolean := False;
11266 Is_Function : Boolean;
11268 Stub_Type : Entity_Id := Empty;
11269 RACW_Type : Entity_Id := Empty;
11273 case Get_PCS_Name is
11274 when Name_PolyORB_DSA =>
11275 PolyORB_Support.Build_General_Calling_Stubs (
11281 Is_Known_Asynchronous,
11282 Is_Known_Non_Asynchronous,
11289 GARLIC_Support.Build_General_Calling_Stubs (
11293 Target.RPC_Receiver,
11296 Is_Known_Asynchronous,
11297 Is_Known_Non_Asynchronous,
11304 end Specific_Build_General_Calling_Stubs;
11306 --------------------------------------
11307 -- Specific_Build_RPC_Receiver_Body --
11308 --------------------------------------
11310 procedure Specific_Build_RPC_Receiver_Body
11311 (RPC_Receiver : Entity_Id;
11312 Request : out Entity_Id;
11313 Subp_Id : out Entity_Id;
11314 Subp_Index : out Entity_Id;
11315 Stmts : out List_Id;
11316 Decl : out Node_Id)
11319 case Get_PCS_Name is
11320 when Name_PolyORB_DSA =>
11321 PolyORB_Support.Build_RPC_Receiver_Body
11329 GARLIC_Support.Build_RPC_Receiver_Body
11337 end Specific_Build_RPC_Receiver_Body;
11339 --------------------------------
11340 -- Specific_Build_Stub_Target --
11341 --------------------------------
11343 function Specific_Build_Stub_Target
11346 RCI_Locator : Entity_Id;
11347 Controlling_Parameter : Entity_Id) return RPC_Target
11350 case Get_PCS_Name is
11351 when Name_PolyORB_DSA =>
11352 return PolyORB_Support.Build_Stub_Target (Loc,
11353 Decls, RCI_Locator, Controlling_Parameter);
11355 return GARLIC_Support.Build_Stub_Target (Loc,
11356 Decls, RCI_Locator, Controlling_Parameter);
11358 end Specific_Build_Stub_Target;
11360 ------------------------------
11361 -- Specific_Build_Stub_Type --
11362 ------------------------------
11364 procedure Specific_Build_Stub_Type
11365 (RACW_Type : Entity_Id;
11366 Stub_Type : Entity_Id;
11367 Stub_Type_Decl : out Node_Id;
11368 RPC_Receiver_Decl : out Node_Id)
11371 case Get_PCS_Name is
11372 when Name_PolyORB_DSA =>
11373 PolyORB_Support.Build_Stub_Type (
11374 RACW_Type, Stub_Type,
11375 Stub_Type_Decl, RPC_Receiver_Decl);
11377 GARLIC_Support.Build_Stub_Type (
11378 RACW_Type, Stub_Type,
11379 Stub_Type_Decl, RPC_Receiver_Decl);
11381 end Specific_Build_Stub_Type;
11383 function Specific_Build_Subprogram_Receiving_Stubs
11384 (Vis_Decl : Node_Id;
11385 Asynchronous : Boolean;
11386 Dynamically_Asynchronous : Boolean := False;
11387 Stub_Type : Entity_Id := Empty;
11388 RACW_Type : Entity_Id := Empty;
11389 Parent_Primitive : Entity_Id := Empty) return Node_Id
11392 case Get_PCS_Name is
11393 when Name_PolyORB_DSA =>
11394 return PolyORB_Support.Build_Subprogram_Receiving_Stubs (
11397 Dynamically_Asynchronous,
11402 return GARLIC_Support.Build_Subprogram_Receiving_Stubs (
11405 Dynamically_Asynchronous,
11410 end Specific_Build_Subprogram_Receiving_Stubs;
11412 --------------------------
11413 -- Underlying_RACW_Type --
11414 --------------------------
11416 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11417 Record_Type : Entity_Id;
11420 if Ekind (RAS_Typ) = E_Record_Type then
11421 Record_Type := RAS_Typ;
11423 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11424 Record_Type := Equivalent_Type (RAS_Typ);
11428 Etype (Subtype_Indication (
11429 Component_Definition (
11430 First (Component_Items (Component_List (
11431 Type_Definition (Declaration_Node (Record_Type))))))));
11432 end Underlying_RACW_Type;