1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Elists; use Elists;
29 with Exp_Atag; use Exp_Atag;
30 with Exp_Strm; use Exp_Strm;
31 with Exp_Tss; use Exp_Tss;
32 with Exp_Util; use Exp_Util;
34 with Nlists; use Nlists;
35 with Nmake; use Nmake;
37 with Rtsfind; use Rtsfind;
39 with Sem_Cat; use Sem_Cat;
40 with Sem_Ch3; use Sem_Ch3;
41 with Sem_Ch8; use Sem_Ch8;
42 with Sem_Dist; use Sem_Dist;
43 with Sem_Eval; use Sem_Eval;
44 with Sem_Util; use Sem_Util;
45 with Sinfo; use Sinfo;
46 with Snames; use Snames;
47 with Stand; use Stand;
48 with Stringt; use Stringt;
49 with Tbuild; use Tbuild;
50 with Ttypes; use Ttypes;
51 with Uintp; use Uintp;
53 with GNAT.HTable; use GNAT.HTable;
55 package body Exp_Dist is
57 -- The following model has been used to implement distributed objects:
58 -- given a designated type D and a RACW type R, then a record of the
61 -- type Stub is tagged record
62 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
65 -- is built. This type has two properties:
67 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
68 -- converted to and from this type to make it suitable for
69 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
70 -- to avoid memory leaks when the same remote object arrive on the
71 -- same partition through several paths;
73 -- 2) It also has the same dispatching table as the designated type D,
74 -- and thus can be used as an object designated by a value of type
75 -- R on any partition other than the one on which the object has
76 -- been created, since only dispatching calls will be performed and
77 -- the fields themselves will not be used. We call Derive_Subprograms
78 -- to fake half a derivation to ensure that the subprograms do have
79 -- the same dispatching table.
81 First_RCI_Subprogram_Id : constant := 2;
82 -- RCI subprograms are numbered starting at 2. The RCI receiver for
83 -- an RCI package can thus identify calls received through remote
84 -- access-to-subprogram dereferences by the fact that they have a
85 -- (primitive) subprogram id of 0, and 1 is used for the internal
86 -- RAS information lookup operation. (This is for the Garlic code
87 -- generation, where subprograms are identified by numbers; in the
88 -- PolyORB version, they are identified by name, with a numeric suffix
91 type Hash_Index is range 0 .. 50;
93 -----------------------
94 -- Local subprograms --
95 -----------------------
97 function Hash (F : Entity_Id) return Hash_Index;
98 -- DSA expansion associates stubs to distributed object types using
99 -- a hash table on entity ids.
101 function Hash (F : Name_Id) return Hash_Index;
102 -- The generation of subprogram identifiers requires an overload counter
103 -- to be associated with each remote subprogram names. These counters
104 -- are maintained in a hash table on name ids.
106 type Subprogram_Identifiers is record
107 Str_Identifier : String_Id;
108 Int_Identifier : Int;
111 package Subprogram_Identifier_Table is
112 new Simple_HTable (Header_Num => Hash_Index,
113 Element => Subprogram_Identifiers,
114 No_Element => (No_String, 0),
118 -- Mapping between a remote subprogram and the corresponding
119 -- subprogram identifiers.
121 package Overload_Counter_Table is
122 new Simple_HTable (Header_Num => Hash_Index,
128 -- Mapping between a subprogram name and an integer that
129 -- counts the number of defining subprogram names with that
130 -- Name_Id encountered so far in a given context (an interface).
132 function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
133 function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
134 function Get_Subprogram_Id (Def : Entity_Id) return Int;
135 -- Given a subprogram defined in a RCI package, get its distribution
136 -- subprogram identifiers (the distribution identifiers are a unique
137 -- subprogram number, and the non-qualified subprogram name, in the
138 -- casing used for the subprogram declaration; if the name is overloaded,
139 -- a double underscore and a serial number are appended.
141 -- The integer identifier is used to perform remote calls with GARLIC;
142 -- the string identifier is used in the case of PolyORB.
144 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
145 -- when receiving a call, the calling stubs will create requests with the
146 -- exact casing of the defining unit name of the called subprogram, so as
147 -- to allow calls to subprograms on distributed nodes that do distinguish
150 -- NOTE: Another design would be to allow a representation clause on
151 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
153 pragma Warnings (Off, Get_Subprogram_Id);
154 -- One homonym only is unreferenced (specific to the GARLIC version)
156 procedure Add_RAS_Dereference_TSS (N : Node_Id);
157 -- Add a subprogram body for RAS Dereference TSS
159 procedure Add_RAS_Proxy_And_Analyze
162 All_Calls_Remote_E : Entity_Id;
163 Proxy_Object_Addr : out Entity_Id);
164 -- Add the proxy type required, on the receiving (server) side, to handle
165 -- calls to the subprogram declared by Vis_Decl through a remote access
166 -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
167 -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
168 -- is appended to Decls. Proxy_Object_Addr is a constant of type
169 -- System.Address that designates an instance of the proxy object.
171 function Build_Remote_Subprogram_Proxy_Type
173 ACR_Expression : Node_Id) return Node_Id;
174 -- Build and return a tagged record type definition for an RCI
175 -- subprogram proxy type.
176 -- ACR_Expression is use as the initialization value for
177 -- the All_Calls_Remote component.
179 function Build_Get_Unique_RP_Call
182 Stub_Type : Entity_Id) return List_Id;
183 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
184 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
185 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
187 function Build_Subprogram_Calling_Stubs
190 Asynchronous : Boolean;
191 Dynamically_Asynchronous : Boolean := False;
192 Stub_Type : Entity_Id := Empty;
193 RACW_Type : Entity_Id := Empty;
194 Locator : Entity_Id := Empty;
195 New_Name : Name_Id := No_Name) return Node_Id;
196 -- Build the calling stub for a given subprogram with the subprogram ID
197 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
198 -- parameters of this type will be marshalled instead of the object
199 -- itself. It will then be converted into Stub_Type before performing
200 -- the real call. If Dynamically_Asynchronous is True, then it will be
201 -- computed at run time whether the call is asynchronous or not.
202 -- Otherwise, the value of the formal Asynchronous will be used.
203 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
204 -- New_Name is given, then it will be used instead of the original name.
206 function Build_RPC_Receiver_Specification
207 (RPC_Receiver : Entity_Id;
208 Request_Parameter : Entity_Id) return Node_Id;
209 -- Make a subprogram specification for an RPC receiver, with the given
210 -- defining unit name and formal parameter.
212 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
213 -- Return an ordered parameter list: unconstrained parameters are put
214 -- at the beginning of the list and constrained ones are put after. If
215 -- there are no parameters, an empty list is returned. Special case:
216 -- the controlling formal of the equivalent RACW operation for a RAS
217 -- type is always left in first position.
219 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean;
220 -- True when Typ is an unconstrained type, or a null-excluding access type.
221 -- In either case, this means stubs cannot contain a default-initialized
222 -- object declaration of such type.
224 procedure Add_Calling_Stubs_To_Declarations
227 -- Add calling stubs to the declarative part
229 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
230 -- Return True if nothing prevents the program whose specification is
231 -- given to be asynchronous (i.e. no out parameter).
233 function Pack_Entity_Into_Stream_Access
237 Etyp : Entity_Id := Empty) return Node_Id;
238 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
239 -- then Etype (Object) will be used if present. If the type is
240 -- constrained, then 'Write will be used to output the object,
241 -- If the type is unconstrained, 'Output will be used.
243 function Pack_Node_Into_Stream
247 Etyp : Entity_Id) return Node_Id;
248 -- Similar to above, with an arbitrary node instead of an entity
250 function Pack_Node_Into_Stream_Access
254 Etyp : Entity_Id) return Node_Id;
255 -- Similar to above, with Stream instead of Stream'Access
257 function Make_Selected_Component
260 Selector_Name : Name_Id) return Node_Id;
261 -- Return a selected_component whose prefix denotes the given entity,
262 -- and with the given Selector_Name.
264 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
265 -- Return the scope represented by a given spec
267 procedure Set_Renaming_TSS
270 TSS_Nam : TSS_Name_Type);
271 -- Create a renaming declaration of subprogram Nam,
272 -- and register it as a TSS for Typ with name TSS_Nam.
274 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
275 -- Return True if the current parameter needs an extra formal to reflect
276 -- its constrained status.
278 function Is_RACW_Controlling_Formal
279 (Parameter : Node_Id;
280 Stub_Type : Entity_Id) return Boolean;
281 -- Return True if the current parameter is a controlling formal argument
282 -- of type Stub_Type or access to Stub_Type.
284 procedure Declare_Create_NVList
289 -- Append the declaration of NVList to Decls, and its
290 -- initialization to Stmts.
292 function Add_Parameter_To_NVList
295 Parameter : Entity_Id;
296 Constrained : Boolean;
297 RACW_Ctrl : Boolean := False;
298 Any : Entity_Id) return Node_Id;
299 -- Return a call to Add_Item to add the Any corresponding to the designated
300 -- formal Parameter (with the indicated Constrained status) to NVList.
301 -- RACW_Ctrl must be set to True for controlling formals of distributed
302 -- object primitive operations.
308 -- This record describes various tree fragments associated with the
309 -- generation of RACW calling stubs. One such record exists for every
310 -- distributed object type, i.e. each tagged type that is the designated
311 -- type of one or more RACW type.
313 type Stub_Structure is record
314 Stub_Type : Entity_Id;
315 -- Stub type: this type has the same primitive operations as the
316 -- designated types, but the provided bodies for these operations
317 -- a remote call to an actual target object potentially located on
318 -- another partition; each value of the stub type encapsulates a
319 -- reference to a remote object.
321 Stub_Type_Access : Entity_Id;
322 -- A local access type designating the stub type (this is not an RACW
325 RPC_Receiver_Decl : Node_Id;
326 -- Declaration for the RPC receiver entity associated with the
327 -- designated type. As an exception, for the case of an RACW that
328 -- implements a RAS, no object RPC receiver is generated. Instead,
329 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
330 -- would have been inserted.
332 Body_Decls : List_Id;
333 -- List of subprogram bodies to be included in generated code: bodies
334 -- for the RACW's stream attributes, and for the primitive operations
337 RACW_Type : Entity_Id;
338 -- One of the RACW types designating this distributed object type
339 -- (they are all interchangeable; we use any one of them in order to
340 -- avoid having to create various anonymous access types).
344 Empty_Stub_Structure : constant Stub_Structure :=
345 (Empty, Empty, Empty, No_List, Empty);
347 package Stubs_Table is
348 new Simple_HTable (Header_Num => Hash_Index,
349 Element => Stub_Structure,
350 No_Element => Empty_Stub_Structure,
354 -- Mapping between a RACW designated type and its stub type
356 package Asynchronous_Flags_Table is
357 new Simple_HTable (Header_Num => Hash_Index,
358 Element => Entity_Id,
363 -- Mapping between a RACW type and a constant having the value True
364 -- if the RACW is asynchronous and False otherwise.
366 package RCI_Locator_Table is
367 new Simple_HTable (Header_Num => Hash_Index,
368 Element => Entity_Id,
373 -- Mapping between a RCI package on which All_Calls_Remote applies and
374 -- the generic instantiation of RCI_Locator for this package.
376 package RCI_Calling_Stubs_Table is
377 new Simple_HTable (Header_Num => Hash_Index,
378 Element => Entity_Id,
383 -- Mapping between a RCI subprogram and the corresponding calling stubs
385 procedure Add_Stub_Type
386 (Designated_Type : Entity_Id;
387 RACW_Type : Entity_Id;
389 Stub_Type : out Entity_Id;
390 Stub_Type_Access : out Entity_Id;
391 RPC_Receiver_Decl : out Node_Id;
392 Body_Decls : out List_Id;
393 Existing : out Boolean);
394 -- Add the declaration of the stub type, the access to stub type and the
395 -- object RPC receiver at the end of Decls. If these already exist,
396 -- then nothing is added in the tree but the right values are returned
397 -- anyhow and Existing is set to True.
399 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
400 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
401 -- structure table, reset it to No_List, and return the previous value.
403 procedure Add_RACW_Asynchronous_Flag
404 (Declarations : List_Id;
405 RACW_Type : Entity_Id);
406 -- Declare a boolean constant associated with RACW_Type whose value
407 -- indicates at run time whether a pragma Asynchronous applies to it.
409 procedure Assign_Subprogram_Identifier
413 -- Determine the distribution subprogram identifier to
414 -- be used for remote subprogram Def, return it in Id and
415 -- store it in a hash table for later retrieval by
416 -- Get_Subprogram_Id. Spn is the subprogram number.
418 function RCI_Package_Locator
420 Package_Spec : Node_Id) return Node_Id;
421 -- Instantiate the generic package RCI_Locator in order to locate the
422 -- RCI package whose spec is given as argument.
424 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
425 -- Surround a node N by a tag check, as in:
429 -- when E : Ada.Tags.Tag_Error =>
430 -- Raise_Exception (Program_Error'Identity,
431 -- Exception_Message (E));
434 function Input_With_Tag_Check
436 Var_Type : Entity_Id;
437 Stream : Node_Id) return Node_Id;
438 -- Return a function with the following form:
439 -- function R return Var_Type is
441 -- return Var_Type'Input (S);
443 -- when E : Ada.Tags.Tag_Error =>
444 -- Raise_Exception (Program_Error'Identity,
445 -- Exception_Message (E));
448 procedure Build_Actual_Object_Declaration
454 -- Build the declaration of an object with the given defining identifier,
455 -- initialized with Expr if provided, to serve as actual parameter in a
456 -- server stub. If Variable is true, the declared object will be a variable
457 -- (case of an out or in out formal), else it will be a constant. Object's
458 -- Ekind is set accordingly. The declaration, as well as any other
459 -- declarations it requires, are appended to Decls.
461 --------------------------------------------
462 -- Hooks for PCS-specific code generation --
463 --------------------------------------------
465 -- Part of the code generation circuitry for distribution needs to be
466 -- tailored for each implementation of the PCS. For each routine that
467 -- needs to be specialized, a Specific_<routine> wrapper is created,
468 -- which calls the corresponding <routine> in package
469 -- <pcs_implementation>_Support.
471 procedure Specific_Add_RACW_Features
472 (RACW_Type : Entity_Id;
474 Stub_Type : Entity_Id;
475 Stub_Type_Access : Entity_Id;
476 RPC_Receiver_Decl : Node_Id;
477 Body_Decls : List_Id);
478 -- Add declaration for TSSs for a given RACW type. The declarations are
479 -- added just after the declaration of the RACW type itself. If the RACW
480 -- appears in the main unit, Body_Decls is a list of declarations to which
481 -- the bodies are appended. Else Body_Decls is No_List.
482 -- PCS-specific ancillary subprogram for Add_RACW_Features.
484 procedure Specific_Add_RAST_Features
486 RAS_Type : Entity_Id);
487 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
488 -- subprogram for Add_RAST_Features.
490 -- An RPC_Target record is used during construction of calling stubs
491 -- to pass PCS-specific tree fragments corresponding to the information
492 -- necessary to locate the target of a remote subprogram call.
494 type RPC_Target (PCS_Kind : PCS_Names) is record
496 when Name_PolyORB_DSA =>
498 -- An expression whose value is a PolyORB reference to the target
502 Partition : Entity_Id;
503 -- A variable containing the Partition_ID of the target partition
505 RPC_Receiver : Node_Id;
506 -- An expression whose value is the address of the target RPC
511 procedure Specific_Build_General_Calling_Stubs
513 Statements : List_Id;
515 Subprogram_Id : Node_Id;
516 Asynchronous : Node_Id := Empty;
517 Is_Known_Asynchronous : Boolean := False;
518 Is_Known_Non_Asynchronous : Boolean := False;
519 Is_Function : Boolean;
521 Stub_Type : Entity_Id := Empty;
522 RACW_Type : Entity_Id := Empty;
524 -- Build calling stubs for general purpose. The parameters are:
525 -- Decls : a place to put declarations
526 -- Statements : a place to put statements
527 -- Target : PCS-specific target information (see details
528 -- in RPC_Target declaration).
529 -- Subprogram_Id : a node containing the subprogram ID
530 -- Asynchronous : True if an APC must be made instead of an RPC.
531 -- The value needs not be supplied if one of the
532 -- Is_Known_... is True.
533 -- Is_Known_Async... : True if we know that this is asynchronous
534 -- Is_Known_Non_A... : True if we know that this is not asynchronous
535 -- Spec : a node with a Parameter_Specifications and
536 -- a Result_Definition if applicable
537 -- Stub_Type : in case of RACW stubs, parameters of type access
538 -- to Stub_Type will be marshalled using the
539 -- address of the object (the addr field) rather
540 -- than using the 'Write on the stub itself
541 -- Nod : used to provide sloc for generated code
543 function Specific_Build_Stub_Target
546 RCI_Locator : Entity_Id;
547 Controlling_Parameter : Entity_Id) return RPC_Target;
548 -- Build call target information nodes for use within calling stubs. In the
549 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
550 -- for an RACW, Controlling_Parameter is the entity for the controlling
551 -- formal parameter used to determine the location of the target of the
552 -- call. Decls provides a location where variable declarations can be
553 -- appended to construct the necessary values.
555 procedure Specific_Build_Stub_Type
556 (RACW_Type : Entity_Id;
557 Stub_Type : Entity_Id;
558 Stub_Type_Decl : out Node_Id;
559 RPC_Receiver_Decl : out Node_Id);
560 -- Build a type declaration for the stub type associated with an RACW
561 -- type, and the necessary RPC receiver, if applicable. PCS-specific
562 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
563 -- is generated, then RPC_Receiver_Decl is set to Empty.
565 procedure Specific_Build_RPC_Receiver_Body
566 (RPC_Receiver : Entity_Id;
567 Request : out Entity_Id;
568 Subp_Id : out Entity_Id;
569 Subp_Index : out Entity_Id;
572 -- Make a subprogram body for an RPC receiver, with the given
573 -- defining unit name. On return:
574 -- - Subp_Id is the subprogram identifier from the PCS.
575 -- - Subp_Index is the index in the list of subprograms
576 -- used for dispatching (a variable of type Subprogram_Id).
577 -- - Stmts is the place where the request dispatching
578 -- statements can occur,
579 -- - Decl is the subprogram body declaration.
581 function Specific_Build_Subprogram_Receiving_Stubs
583 Asynchronous : Boolean;
584 Dynamically_Asynchronous : Boolean := False;
585 Stub_Type : Entity_Id := Empty;
586 RACW_Type : Entity_Id := Empty;
587 Parent_Primitive : Entity_Id := Empty) return Node_Id;
588 -- Build the receiving stub for a given subprogram. The subprogram
589 -- declaration is also built by this procedure, and the value returned
590 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
591 -- found in the specification, then its address is read from the stream
592 -- instead of the object itself and converted into an access to
593 -- class-wide type before doing the real call using any of the RACW type
594 -- pointing on the designated type.
596 procedure Specific_Add_Obj_RPC_Receiver_Completion
599 RPC_Receiver : Entity_Id;
600 Stub_Elements : Stub_Structure);
601 -- Add the necessary code to Decls after the completion of generation
602 -- of the RACW RPC receiver described by Stub_Elements.
604 procedure Specific_Add_Receiving_Stubs_To_Declarations
608 -- Add receiving stubs to the declarative part of an RCI unit
610 package GARLIC_Support is
612 -- Support for generating DSA code that uses the GARLIC PCS
614 -- The subprograms below provide the GARLIC versions of the
615 -- corresponding Specific_<subprogram> routine declared above.
617 procedure Add_RACW_Features
618 (RACW_Type : Entity_Id;
619 Stub_Type : Entity_Id;
620 Stub_Type_Access : Entity_Id;
621 RPC_Receiver_Decl : Node_Id;
622 Body_Decls : List_Id);
624 procedure Add_RAST_Features
626 RAS_Type : Entity_Id);
628 procedure Build_General_Calling_Stubs
630 Statements : List_Id;
631 Target_Partition : Entity_Id; -- From RPC_Target
632 Target_RPC_Receiver : Node_Id; -- From RPC_Target
633 Subprogram_Id : Node_Id;
634 Asynchronous : Node_Id := Empty;
635 Is_Known_Asynchronous : Boolean := False;
636 Is_Known_Non_Asynchronous : Boolean := False;
637 Is_Function : Boolean;
639 Stub_Type : Entity_Id := Empty;
640 RACW_Type : Entity_Id := Empty;
643 function Build_Stub_Target
646 RCI_Locator : Entity_Id;
647 Controlling_Parameter : Entity_Id) return RPC_Target;
649 procedure Build_Stub_Type
650 (RACW_Type : Entity_Id;
651 Stub_Type : Entity_Id;
652 Stub_Type_Decl : out Node_Id;
653 RPC_Receiver_Decl : out Node_Id);
655 function Build_Subprogram_Receiving_Stubs
657 Asynchronous : Boolean;
658 Dynamically_Asynchronous : Boolean := False;
659 Stub_Type : Entity_Id := Empty;
660 RACW_Type : Entity_Id := Empty;
661 Parent_Primitive : Entity_Id := Empty) return Node_Id;
663 procedure Add_Obj_RPC_Receiver_Completion
666 RPC_Receiver : Entity_Id;
667 Stub_Elements : Stub_Structure);
669 procedure Add_Receiving_Stubs_To_Declarations
674 procedure Build_RPC_Receiver_Body
675 (RPC_Receiver : Entity_Id;
676 Request : out Entity_Id;
677 Subp_Id : out Entity_Id;
678 Subp_Index : out Entity_Id;
684 package PolyORB_Support is
686 -- Support for generating DSA code that uses the PolyORB PCS
688 -- The subprograms below provide the PolyORB versions of the
689 -- corresponding Specific_<subprogram> routine declared above.
691 procedure Add_RACW_Features
692 (RACW_Type : Entity_Id;
694 Stub_Type : Entity_Id;
695 Stub_Type_Access : Entity_Id;
696 RPC_Receiver_Decl : Node_Id;
697 Body_Decls : List_Id);
699 procedure Add_RAST_Features
701 RAS_Type : Entity_Id);
703 procedure Build_General_Calling_Stubs
705 Statements : List_Id;
706 Target_Object : Node_Id; -- From RPC_Target
707 Subprogram_Id : Node_Id;
708 Asynchronous : Node_Id := Empty;
709 Is_Known_Asynchronous : Boolean := False;
710 Is_Known_Non_Asynchronous : Boolean := False;
711 Is_Function : Boolean;
713 Stub_Type : Entity_Id := Empty;
714 RACW_Type : Entity_Id := Empty;
717 function Build_Stub_Target
720 RCI_Locator : Entity_Id;
721 Controlling_Parameter : Entity_Id) return RPC_Target;
723 procedure Build_Stub_Type
724 (RACW_Type : Entity_Id;
725 Stub_Type : Entity_Id;
726 Stub_Type_Decl : out Node_Id;
727 RPC_Receiver_Decl : out Node_Id);
729 function Build_Subprogram_Receiving_Stubs
731 Asynchronous : Boolean;
732 Dynamically_Asynchronous : Boolean := False;
733 Stub_Type : Entity_Id := Empty;
734 RACW_Type : Entity_Id := Empty;
735 Parent_Primitive : Entity_Id := Empty) return Node_Id;
737 procedure Add_Obj_RPC_Receiver_Completion
740 RPC_Receiver : Entity_Id;
741 Stub_Elements : Stub_Structure);
743 procedure Add_Receiving_Stubs_To_Declarations
748 procedure Build_RPC_Receiver_Body
749 (RPC_Receiver : Entity_Id;
750 Request : out Entity_Id;
751 Subp_Id : out Entity_Id;
752 Subp_Index : out Entity_Id;
756 procedure Reserve_NamingContext_Methods;
757 -- Mark the method names for interface NamingContext as already used in
758 -- the overload table, so no clashes occur with user code (with the
759 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
760 -- their methods to be accessed as objects, for the implementation of
761 -- remote access-to-subprogram types).
765 -- Routines to build distribution helper subprograms for user-defined
766 -- types. For implementation of the Distributed systems annex (DSA)
767 -- over the PolyORB generic middleware components, it is necessary to
768 -- generate several supporting subprograms for each application data
769 -- type used in inter-partition communication. These subprograms are:
771 -- A Typecode function returning a high-level description of the
774 -- Two conversion functions allowing conversion of values of the
775 -- type from and to the generic data containers used by PolyORB.
776 -- These generic containers are called 'Any' type values after the
777 -- CORBA terminology, and hence the conversion subprograms are
778 -- named To_Any and From_Any.
780 function Build_From_Any_Call
783 Decls : List_Id) return Node_Id;
784 -- Build call to From_Any attribute function of type Typ with
785 -- expression N as actual parameter. Decls is the declarations list
786 -- for an appropriate enclosing scope of the point where the call
787 -- will be inserted; if the From_Any attribute for Typ needs to be
788 -- generated at this point, its declaration is appended to Decls.
790 procedure Build_From_Any_Function
794 Fnam : out Entity_Id);
795 -- Build From_Any attribute function for Typ. Loc is the reference
796 -- location for generated nodes, Typ is the type for which the
797 -- conversion function is generated. On return, Decl and Fnam contain
798 -- the declaration and entity for the newly-created function.
800 function Build_To_Any_Call
802 Decls : List_Id) return Node_Id;
803 -- Build call to To_Any attribute function with expression as actual
804 -- parameter. Decls is the declarations list for an appropriate
805 -- enclosing scope of the point where the call will be inserted; if
806 -- the To_Any attribute for Typ needs to be generated at this point,
807 -- its declaration is appended to Decls.
809 procedure Build_To_Any_Function
813 Fnam : out Entity_Id);
814 -- Build To_Any attribute function for Typ. Loc is the reference
815 -- location for generated nodes, Typ is the type for which the
816 -- conversion function is generated. On return, Decl and Fnam contain
817 -- the declaration and entity for the newly-created function.
819 function Build_TypeCode_Call
822 Decls : List_Id) return Node_Id;
823 -- Build call to TypeCode attribute function for Typ. Decls is the
824 -- declarations list for an appropriate enclosing scope of the point
825 -- where the call will be inserted; if the To_Any attribute for Typ
826 -- needs to be generated at this point, its declaration is appended
829 procedure Build_TypeCode_Function
833 Fnam : out Entity_Id);
834 -- Build TypeCode attribute function for Typ. Loc is the reference
835 -- location for generated nodes, Typ is the type for which the
836 -- conversion function is generated. On return, Decl and Fnam contain
837 -- the declaration and entity for the newly-created function.
839 procedure Build_Name_And_Repository_Id
841 Name_Str : out String_Id;
842 Repo_Id_Str : out String_Id);
843 -- In the PolyORB distribution model, each distributed object type
844 -- and each distributed operation has a globally unique identifier,
845 -- its Repository Id. This subprogram builds and returns two strings
846 -- for entity E (a distributed object type or operation): one
847 -- containing the name of E, the second containing its repository id.
853 ------------------------------------
854 -- Local variables and structures --
855 ------------------------------------
858 -- Needs comments ???
860 Output_From_Constrained : constant array (Boolean) of Name_Id :=
861 (False => Name_Output,
863 -- The attribute to choose depending on the fact that the parameter
864 -- is constrained or not. There is no such thing as Input_From_Constrained
865 -- since this require separate mechanisms ('Input is a function while
866 -- 'Read is a procedure).
868 ---------------------------------------
869 -- Add_Calling_Stubs_To_Declarations --
870 ---------------------------------------
872 procedure Add_Calling_Stubs_To_Declarations
876 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
877 -- Subprogram id 0 is reserved for calls received from
878 -- remote access-to-subprogram dereferences.
880 Current_Declaration : Node_Id;
881 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
882 RCI_Instantiation : Node_Id;
883 Subp_Stubs : Node_Id;
884 Subp_Str : String_Id;
886 pragma Warnings (Off, Subp_Str);
889 -- The first thing added is an instantiation of the generic package
890 -- System.Partition_Interface.RCI_Locator with the name of this remote
891 -- package. This will act as an interface with the name server to
892 -- determine the Partition_ID and the RPC_Receiver for the receiver
895 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
896 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
898 Append_To (Decls, RCI_Instantiation);
899 Analyze (RCI_Instantiation);
901 -- For each subprogram declaration visible in the spec, we do build a
902 -- body. We also increment a counter to assign a different Subprogram_Id
903 -- to each subprograms. The receiving stubs processing do use the same
904 -- mechanism and will thus assign the same Id and do the correct
907 Overload_Counter_Table.Reset;
908 PolyORB_Support.Reserve_NamingContext_Methods;
910 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
911 while Present (Current_Declaration) loop
912 if Nkind (Current_Declaration) = N_Subprogram_Declaration
913 and then Comes_From_Source (Current_Declaration)
915 Assign_Subprogram_Identifier
916 (Defining_Unit_Name (Specification (Current_Declaration)),
917 Current_Subprogram_Number,
921 Build_Subprogram_Calling_Stubs (
922 Vis_Decl => Current_Declaration,
924 Build_Subprogram_Id (Loc,
925 Defining_Unit_Name (Specification (Current_Declaration))),
927 Nkind (Specification (Current_Declaration)) =
928 N_Procedure_Specification
930 Is_Asynchronous (Defining_Unit_Name (Specification
931 (Current_Declaration))));
933 Append_To (Decls, Subp_Stubs);
934 Analyze (Subp_Stubs);
936 Current_Subprogram_Number := Current_Subprogram_Number + 1;
939 Next (Current_Declaration);
941 end Add_Calling_Stubs_To_Declarations;
943 -----------------------------
944 -- Add_Parameter_To_NVList --
945 -----------------------------
947 function Add_Parameter_To_NVList
950 Parameter : Entity_Id;
951 Constrained : Boolean;
952 RACW_Ctrl : Boolean := False;
953 Any : Entity_Id) return Node_Id
955 Parameter_Name_String : String_Id;
956 Parameter_Mode : Node_Id;
958 function Parameter_Passing_Mode
960 Parameter : Entity_Id;
961 Constrained : Boolean) return Node_Id;
962 -- Return an expression that denotes the parameter passing mode to be
963 -- used for Parameter in distribution stubs, where Constrained is
964 -- Parameter's constrained status.
966 ----------------------------
967 -- Parameter_Passing_Mode --
968 ----------------------------
970 function Parameter_Passing_Mode
972 Parameter : Entity_Id;
973 Constrained : Boolean) return Node_Id
978 if Out_Present (Parameter) then
979 if In_Present (Parameter)
980 or else not Constrained
982 -- Unconstrained formals must be translated
983 -- to 'in' or 'inout', not 'out', because
984 -- they need to be constrained by the actual.
986 Lib_RE := RE_Mode_Inout;
988 Lib_RE := RE_Mode_Out;
992 Lib_RE := RE_Mode_In;
995 return New_Occurrence_Of (RTE (Lib_RE), Loc);
996 end Parameter_Passing_Mode;
998 -- Start of processing for Add_Parameter_To_NVList
1001 if Nkind (Parameter) = N_Defining_Identifier then
1002 Get_Name_String (Chars (Parameter));
1004 Get_Name_String (Chars (Defining_Identifier (Parameter)));
1007 Parameter_Name_String := String_From_Name_Buffer;
1009 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1011 -- When the parameter passed to Add_Parameter_To_NVList is an
1012 -- Extra_Constrained parameter, Parameter is an N_Defining_
1013 -- Identifier, instead of a complete N_Parameter_Specification.
1014 -- Thus, we explicitly set 'in' mode in this case.
1016 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1020 Parameter_Passing_Mode (Loc, Parameter, Constrained);
1024 Make_Procedure_Call_Statement (Loc,
1027 (RTE (RE_NVList_Add_Item), Loc),
1028 Parameter_Associations => New_List (
1029 New_Occurrence_Of (NVList, Loc),
1030 Make_Function_Call (Loc,
1033 (RTE (RE_To_PolyORB_String), Loc),
1034 Parameter_Associations => New_List (
1035 Make_String_Literal (Loc,
1036 Strval => Parameter_Name_String))),
1037 New_Occurrence_Of (Any, Loc),
1039 end Add_Parameter_To_NVList;
1041 --------------------------------
1042 -- Add_RACW_Asynchronous_Flag --
1043 --------------------------------
1045 procedure Add_RACW_Asynchronous_Flag
1046 (Declarations : List_Id;
1047 RACW_Type : Entity_Id)
1049 Loc : constant Source_Ptr := Sloc (RACW_Type);
1051 Asynchronous_Flag : constant Entity_Id :=
1052 Make_Defining_Identifier (Loc,
1053 New_External_Name (Chars (RACW_Type), 'A'));
1056 -- Declare the asynchronous flag. This flag will be changed to True
1057 -- whenever it is known that the RACW type is asynchronous.
1059 Append_To (Declarations,
1060 Make_Object_Declaration (Loc,
1061 Defining_Identifier => Asynchronous_Flag,
1062 Constant_Present => True,
1063 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1064 Expression => New_Occurrence_Of (Standard_False, Loc)));
1066 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1067 end Add_RACW_Asynchronous_Flag;
1069 -----------------------
1070 -- Add_RACW_Features --
1071 -----------------------
1073 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1074 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1075 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1079 Body_Decls : List_Id;
1081 Stub_Type : Entity_Id;
1082 Stub_Type_Access : Entity_Id;
1083 RPC_Receiver_Decl : Node_Id;
1086 -- True when appropriate stubs have already been generated (this is the
1087 -- case when another RACW with the same designated type has already been
1088 -- encountered), in which case we reuse the previous stubs rather than
1089 -- generating new ones.
1092 if not Expander_Active then
1096 -- Mark the current package declaration as containing an RACW, so that
1097 -- the bodies for the calling stubs and the RACW stream subprograms
1098 -- are attached to the tree when the corresponding body is encountered.
1100 Set_Has_RACW (Current_Scope);
1102 -- Look for place to declare the RACW stub type and RACW operations
1108 -- Case of declaring the RACW in the same package as its designated
1109 -- type: we know that the designated type is a private type, so we
1110 -- use the private declarations list.
1112 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1114 if Present (Private_Declarations (Pkg_Spec)) then
1115 Decls := Private_Declarations (Pkg_Spec);
1117 Decls := Visible_Declarations (Pkg_Spec);
1122 -- Case of declaring the RACW in another package than its designated
1123 -- type: use the private declarations list if present; otherwise
1124 -- use the visible declarations.
1126 Decls := List_Containing (Declaration_Node (RACW_Type));
1130 -- If we were unable to find the declarations, that means that the
1131 -- completion of the type was missing. We can safely return and let the
1132 -- error be caught by the semantic analysis.
1139 (Designated_Type => Desig,
1140 RACW_Type => RACW_Type,
1142 Stub_Type => Stub_Type,
1143 Stub_Type_Access => Stub_Type_Access,
1144 RPC_Receiver_Decl => RPC_Receiver_Decl,
1145 Body_Decls => Body_Decls,
1146 Existing => Existing);
1148 -- If this RACW is not in the main unit, do not generate primitive or
1151 if not Entity_Is_In_Main_Unit (RACW_Type) then
1152 Body_Decls := No_List;
1155 Add_RACW_Asynchronous_Flag
1156 (Declarations => Decls,
1157 RACW_Type => RACW_Type);
1159 Specific_Add_RACW_Features
1160 (RACW_Type => RACW_Type,
1162 Stub_Type => Stub_Type,
1163 Stub_Type_Access => Stub_Type_Access,
1164 RPC_Receiver_Decl => RPC_Receiver_Decl,
1165 Body_Decls => Body_Decls);
1167 -- If we already have stubs for this designated type, nothing to do
1173 if Is_Frozen (Desig) then
1174 Validate_RACW_Primitives (RACW_Type);
1175 Add_RACW_Primitive_Declarations_And_Bodies
1176 (Designated_Type => Desig,
1177 Insertion_Node => RPC_Receiver_Decl,
1178 Body_Decls => Body_Decls);
1181 -- Validate_RACW_Primitives requires the list of all primitives of
1182 -- the designated type, so defer processing until Desig is frozen.
1183 -- See Exp_Ch3.Freeze_Type.
1185 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1187 end Add_RACW_Features;
1189 ------------------------------------------------
1190 -- Add_RACW_Primitive_Declarations_And_Bodies --
1191 ------------------------------------------------
1193 procedure Add_RACW_Primitive_Declarations_And_Bodies
1194 (Designated_Type : Entity_Id;
1195 Insertion_Node : Node_Id;
1196 Body_Decls : List_Id)
1198 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1199 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1200 -- the declarations are recognized as belonging to the current package.
1202 Stub_Elements : constant Stub_Structure :=
1203 Stubs_Table.Get (Designated_Type);
1205 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1207 Is_RAS : constant Boolean :=
1208 not Comes_From_Source (Stub_Elements.RACW_Type);
1209 -- Case of the RACW generated to implement a remote access-to-
1212 Build_Bodies : constant Boolean :=
1213 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1214 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1215 -- only when the main unit is the unit that contains the stub type.
1217 Current_Insertion_Node : Node_Id := Insertion_Node;
1219 RPC_Receiver : Entity_Id;
1220 RPC_Receiver_Statements : List_Id;
1221 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1222 RPC_Receiver_Elsif_Parts : List_Id;
1223 RPC_Receiver_Request : Entity_Id;
1224 RPC_Receiver_Subp_Id : Entity_Id;
1225 RPC_Receiver_Subp_Index : Entity_Id;
1227 Subp_Str : String_Id;
1229 Current_Primitive_Elmt : Elmt_Id;
1230 Current_Primitive : Entity_Id;
1231 Current_Primitive_Body : Node_Id;
1232 Current_Primitive_Spec : Node_Id;
1233 Current_Primitive_Decl : Node_Id;
1234 Current_Primitive_Number : Int := 0;
1235 Current_Primitive_Alias : Node_Id;
1236 Current_Receiver : Entity_Id;
1237 Current_Receiver_Body : Node_Id;
1238 RPC_Receiver_Decl : Node_Id;
1239 Possibly_Asynchronous : Boolean;
1242 if not Expander_Active then
1248 Make_Defining_Identifier (Loc,
1249 Chars => New_Internal_Name ('P'));
1250 Specific_Build_RPC_Receiver_Body
1251 (RPC_Receiver => RPC_Receiver,
1252 Request => RPC_Receiver_Request,
1253 Subp_Id => RPC_Receiver_Subp_Id,
1254 Subp_Index => RPC_Receiver_Subp_Index,
1255 Stmts => RPC_Receiver_Statements,
1256 Decl => RPC_Receiver_Decl);
1258 if Get_PCS_Name = Name_PolyORB_DSA then
1260 -- For the case of PolyORB, we need to map a textual operation
1261 -- name into a primitive index. Currently we do so using a simple
1262 -- sequence of string comparisons.
1264 RPC_Receiver_Elsif_Parts := New_List;
1268 -- Build callers, receivers for every primitive operations and a RPC
1269 -- receiver for this type.
1271 if Present (Primitive_Operations (Designated_Type)) then
1272 Overload_Counter_Table.Reset;
1274 Current_Primitive_Elmt :=
1275 First_Elmt (Primitive_Operations (Designated_Type));
1276 while Current_Primitive_Elmt /= No_Elmt loop
1277 Current_Primitive := Node (Current_Primitive_Elmt);
1279 -- Copy the primitive of all the parents, except predefined ones
1280 -- that are not remotely dispatching. Also omit hidden primitives
1281 -- (occurs in the case of primitives of interface progenitors
1282 -- other than immediate ancestors of the Designated_Type).
1284 if Chars (Current_Primitive) /= Name_uSize
1285 and then Chars (Current_Primitive) /= Name_uAlignment
1287 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1288 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1289 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1290 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1291 Is_TSS (Current_Primitive, TSS_Stream_Write))
1292 and then not Is_Hidden (Current_Primitive)
1294 -- The first thing to do is build an up-to-date copy of the
1295 -- spec with all the formals referencing Designated_Type
1296 -- transformed into formals referencing Stub_Type. Since this
1297 -- primitive may have been inherited, go back the alias chain
1298 -- until the real primitive has been found.
1300 Current_Primitive_Alias := Current_Primitive;
1301 while Present (Alias (Current_Primitive_Alias)) loop
1303 (Current_Primitive_Alias
1304 /= Alias (Current_Primitive_Alias));
1305 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
1308 -- Copy the spec from the original declaration for the purpose
1309 -- of declaring an overriding subprogram: we need to replace
1310 -- the type of each controlling formal with Stub_Type. The
1311 -- primitive may have been declared for Designated_Type or
1312 -- inherited from some ancestor type for which we do not have
1313 -- an easily determined Entity_Id. We have no systematic way
1314 -- of knowing which type to substitute Stub_Type for. Instead,
1315 -- Copy_Specification relies on the flag Is_Controlling_Formal
1316 -- to determine which formals to change.
1318 Current_Primitive_Spec :=
1319 Copy_Specification (Loc,
1320 Spec => Parent (Current_Primitive_Alias),
1321 Ctrl_Type => Stub_Elements.Stub_Type);
1323 Current_Primitive_Decl :=
1324 Make_Subprogram_Declaration (Loc,
1325 Specification => Current_Primitive_Spec);
1327 Insert_After_And_Analyze (Current_Insertion_Node,
1328 Current_Primitive_Decl);
1329 Current_Insertion_Node := Current_Primitive_Decl;
1331 Possibly_Asynchronous :=
1332 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1333 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1335 Assign_Subprogram_Identifier (
1336 Defining_Unit_Name (Current_Primitive_Spec),
1337 Current_Primitive_Number,
1340 if Build_Bodies then
1341 Current_Primitive_Body :=
1342 Build_Subprogram_Calling_Stubs
1343 (Vis_Decl => Current_Primitive_Decl,
1345 Build_Subprogram_Id (Loc,
1346 Defining_Unit_Name (Current_Primitive_Spec)),
1347 Asynchronous => Possibly_Asynchronous,
1348 Dynamically_Asynchronous => Possibly_Asynchronous,
1349 Stub_Type => Stub_Elements.Stub_Type,
1350 RACW_Type => Stub_Elements.RACW_Type);
1351 Append_To (Body_Decls, Current_Primitive_Body);
1353 -- Analyzing the body here would cause the Stub type to
1354 -- be frozen, thus preventing subsequent primitive
1355 -- declarations. For this reason, it will be analyzed
1356 -- later in the regular flow (and in the context of the
1357 -- appropriate unit body, see Append_RACW_Bodies).
1361 -- Build the receiver stubs
1363 if Build_Bodies and then not Is_RAS then
1364 Current_Receiver_Body :=
1365 Specific_Build_Subprogram_Receiving_Stubs
1366 (Vis_Decl => Current_Primitive_Decl,
1367 Asynchronous => Possibly_Asynchronous,
1368 Dynamically_Asynchronous => Possibly_Asynchronous,
1369 Stub_Type => Stub_Elements.Stub_Type,
1370 RACW_Type => Stub_Elements.RACW_Type,
1371 Parent_Primitive => Current_Primitive);
1373 Current_Receiver := Defining_Unit_Name (
1374 Specification (Current_Receiver_Body));
1376 Append_To (Body_Decls, Current_Receiver_Body);
1378 -- Add a case alternative to the receiver
1380 if Get_PCS_Name = Name_PolyORB_DSA then
1381 Append_To (RPC_Receiver_Elsif_Parts,
1382 Make_Elsif_Part (Loc,
1384 Make_Function_Call (Loc,
1387 RTE (RE_Caseless_String_Eq), Loc),
1388 Parameter_Associations => New_List (
1389 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1390 Make_String_Literal (Loc, Subp_Str))),
1391 Then_Statements => New_List (
1392 Make_Assignment_Statement (Loc,
1393 Name => New_Occurrence_Of (
1394 RPC_Receiver_Subp_Index, Loc),
1396 Make_Integer_Literal (Loc,
1397 Current_Primitive_Number)))));
1400 Append_To (RPC_Receiver_Case_Alternatives,
1401 Make_Case_Statement_Alternative (Loc,
1402 Discrete_Choices => New_List (
1403 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1405 Statements => New_List (
1406 Make_Procedure_Call_Statement (Loc,
1408 New_Occurrence_Of (Current_Receiver, Loc),
1409 Parameter_Associations => New_List (
1410 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1413 -- Increment the index of current primitive
1415 Current_Primitive_Number := Current_Primitive_Number + 1;
1418 Next_Elmt (Current_Primitive_Elmt);
1422 -- Build the case statement and the heart of the subprogram
1424 if Build_Bodies and then not Is_RAS then
1425 if Get_PCS_Name = Name_PolyORB_DSA
1426 and then Present (First (RPC_Receiver_Elsif_Parts))
1428 Append_To (RPC_Receiver_Statements,
1429 Make_Implicit_If_Statement (Designated_Type,
1430 Condition => New_Occurrence_Of (Standard_False, Loc),
1431 Then_Statements => New_List,
1432 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1435 Append_To (RPC_Receiver_Case_Alternatives,
1436 Make_Case_Statement_Alternative (Loc,
1437 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1438 Statements => New_List (Make_Null_Statement (Loc))));
1440 Append_To (RPC_Receiver_Statements,
1441 Make_Case_Statement (Loc,
1443 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1444 Alternatives => RPC_Receiver_Case_Alternatives));
1446 Append_To (Body_Decls, RPC_Receiver_Decl);
1447 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1448 Body_Decls, RPC_Receiver, Stub_Elements);
1450 -- Do not analyze RPC receiver body at this stage since it references
1451 -- subprograms that have not been analyzed yet. It will be analyzed in
1452 -- the regular flow (see Append_RACW_Bodies).
1455 end Add_RACW_Primitive_Declarations_And_Bodies;
1457 -----------------------------
1458 -- Add_RAS_Dereference_TSS --
1459 -----------------------------
1461 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1462 Loc : constant Source_Ptr := Sloc (N);
1464 Type_Def : constant Node_Id := Type_Definition (N);
1465 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1466 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1467 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1468 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1470 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
1471 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1473 RACW_Primitive_Name : Node_Id;
1475 Proc : constant Entity_Id :=
1476 Make_Defining_Identifier (Loc,
1477 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1479 Proc_Spec : Node_Id;
1480 Param_Specs : List_Id;
1481 Param_Assoc : constant List_Id := New_List;
1482 Stmts : constant List_Id := New_List;
1484 RAS_Parameter : constant Entity_Id :=
1485 Make_Defining_Identifier (Loc,
1486 Chars => New_Internal_Name ('P'));
1488 Is_Function : constant Boolean :=
1489 Nkind (Type_Def) = N_Access_Function_Definition;
1491 Is_Degenerate : Boolean;
1492 -- Set to True if the subprogram_specification for this RAS has an
1493 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1495 Spec : constant Node_Id := Type_Def;
1497 Current_Parameter : Node_Id;
1499 -- Start of processing for Add_RAS_Dereference_TSS
1502 -- The Dereference TSS for a remote access-to-subprogram type has the
1505 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1508 -- This is called whenever a value of a RAS type is dereferenced
1510 -- First construct a list of parameter specifications:
1512 -- The first formal is the RAS values
1514 Param_Specs := New_List (
1515 Make_Parameter_Specification (Loc,
1516 Defining_Identifier => RAS_Parameter,
1519 New_Occurrence_Of (Fat_Type, Loc)));
1521 -- The following formals are copied from the type declaration
1523 Is_Degenerate := False;
1524 Current_Parameter := First (Parameter_Specifications (Type_Def));
1525 Parameters : while Present (Current_Parameter) loop
1526 if Nkind (Parameter_Type (Current_Parameter)) =
1529 Is_Degenerate := True;
1532 Append_To (Param_Specs,
1533 Make_Parameter_Specification (Loc,
1534 Defining_Identifier =>
1535 Make_Defining_Identifier (Loc,
1536 Chars => Chars (Defining_Identifier (Current_Parameter))),
1537 In_Present => In_Present (Current_Parameter),
1538 Out_Present => Out_Present (Current_Parameter),
1540 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1542 New_Copy_Tree (Expression (Current_Parameter))));
1544 Append_To (Param_Assoc,
1545 Make_Identifier (Loc,
1546 Chars => Chars (Defining_Identifier (Current_Parameter))));
1548 Next (Current_Parameter);
1549 end loop Parameters;
1551 if Is_Degenerate then
1552 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1554 -- Generate a dummy body. This code will never actually be executed,
1555 -- because null is the only legal value for a degenerate RAS type.
1556 -- For legality's sake (in order to avoid generating a function that
1557 -- does not contain a return statement), we include a dummy recursive
1558 -- call on the TSS itself.
1561 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1562 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1565 -- For a normal RAS type, we cast the RAS formal to the corresponding
1566 -- tagged type, and perform a dispatching call to its Call primitive
1569 Prepend_To (Param_Assoc,
1570 Unchecked_Convert_To (RACW_Type,
1571 New_Occurrence_Of (RAS_Parameter, Loc)));
1573 RACW_Primitive_Name :=
1574 Make_Selected_Component (Loc,
1575 Prefix => Scope (RACW_Type),
1576 Selector_Name => Name_uCall);
1581 Make_Simple_Return_Statement (Loc,
1583 Make_Function_Call (Loc,
1584 Name => RACW_Primitive_Name,
1585 Parameter_Associations => Param_Assoc)));
1589 Make_Procedure_Call_Statement (Loc,
1590 Name => RACW_Primitive_Name,
1591 Parameter_Associations => Param_Assoc));
1594 -- Build the complete subprogram
1598 Make_Function_Specification (Loc,
1599 Defining_Unit_Name => Proc,
1600 Parameter_Specifications => Param_Specs,
1601 Result_Definition =>
1603 Entity (Result_Definition (Spec)), Loc));
1605 Set_Ekind (Proc, E_Function);
1607 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1611 Make_Procedure_Specification (Loc,
1612 Defining_Unit_Name => Proc,
1613 Parameter_Specifications => Param_Specs);
1615 Set_Ekind (Proc, E_Procedure);
1616 Set_Etype (Proc, Standard_Void_Type);
1620 Make_Subprogram_Body (Loc,
1621 Specification => Proc_Spec,
1622 Declarations => New_List,
1623 Handled_Statement_Sequence =>
1624 Make_Handled_Sequence_Of_Statements (Loc,
1625 Statements => Stmts)));
1627 Set_TSS (Fat_Type, Proc);
1628 end Add_RAS_Dereference_TSS;
1630 -------------------------------
1631 -- Add_RAS_Proxy_And_Analyze --
1632 -------------------------------
1634 procedure Add_RAS_Proxy_And_Analyze
1637 All_Calls_Remote_E : Entity_Id;
1638 Proxy_Object_Addr : out Entity_Id)
1640 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1642 Subp_Name : constant Entity_Id :=
1643 Defining_Unit_Name (Specification (Vis_Decl));
1645 Pkg_Name : constant Entity_Id :=
1646 Make_Defining_Identifier (Loc,
1648 New_External_Name (Chars (Subp_Name), 'P', -1));
1650 Proxy_Type : constant Entity_Id :=
1651 Make_Defining_Identifier (Loc,
1654 Related_Id => Chars (Subp_Name),
1657 Proxy_Type_Full_View : constant Entity_Id :=
1658 Make_Defining_Identifier (Loc,
1659 Chars (Proxy_Type));
1661 Subp_Decl_Spec : constant Node_Id :=
1662 Build_RAS_Primitive_Specification
1663 (Subp_Spec => Specification (Vis_Decl),
1664 Remote_Object_Type => Proxy_Type);
1666 Subp_Body_Spec : constant Node_Id :=
1667 Build_RAS_Primitive_Specification
1668 (Subp_Spec => Specification (Vis_Decl),
1669 Remote_Object_Type => Proxy_Type);
1671 Vis_Decls : constant List_Id := New_List;
1672 Pvt_Decls : constant List_Id := New_List;
1673 Actuals : constant List_Id := New_List;
1675 Perform_Call : Node_Id;
1678 -- type subpP is tagged limited private;
1680 Append_To (Vis_Decls,
1681 Make_Private_Type_Declaration (Loc,
1682 Defining_Identifier => Proxy_Type,
1683 Tagged_Present => True,
1684 Limited_Present => True));
1686 -- [subprogram] Call
1687 -- (Self : access subpP;
1688 -- ...other-formals...)
1691 Append_To (Vis_Decls,
1692 Make_Subprogram_Declaration (Loc,
1693 Specification => Subp_Decl_Spec));
1695 -- A : constant System.Address;
1697 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1699 Append_To (Vis_Decls,
1700 Make_Object_Declaration (Loc,
1701 Defining_Identifier =>
1705 Object_Definition =>
1706 New_Occurrence_Of (RTE (RE_Address), Loc)));
1710 -- type subpP is tagged limited record
1711 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1715 Append_To (Pvt_Decls,
1716 Make_Full_Type_Declaration (Loc,
1717 Defining_Identifier =>
1718 Proxy_Type_Full_View,
1720 Build_Remote_Subprogram_Proxy_Type (Loc,
1721 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1723 -- Trick semantic analysis into swapping the public and full view when
1724 -- freezing the public view.
1726 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1729 -- (Self : access O;
1730 -- ...other-formals...) is
1732 -- P (...other-formals...);
1736 -- (Self : access O;
1737 -- ...other-formals...)
1740 -- return F (...other-formals...);
1743 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1745 Make_Procedure_Call_Statement (Loc,
1747 New_Occurrence_Of (Subp_Name, Loc),
1748 Parameter_Associations =>
1752 Make_Simple_Return_Statement (Loc,
1754 Make_Function_Call (Loc,
1756 New_Occurrence_Of (Subp_Name, Loc),
1757 Parameter_Associations =>
1761 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1762 pragma Assert (Present (Formal));
1765 exit when No (Formal);
1767 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1770 -- O : aliased subpP;
1772 Append_To (Pvt_Decls,
1773 Make_Object_Declaration (Loc,
1774 Defining_Identifier =>
1775 Make_Defining_Identifier (Loc,
1779 Object_Definition =>
1780 New_Occurrence_Of (Proxy_Type, Loc)));
1782 -- A : constant System.Address := O'Address;
1784 Append_To (Pvt_Decls,
1785 Make_Object_Declaration (Loc,
1786 Defining_Identifier =>
1787 Make_Defining_Identifier (Loc,
1788 Chars (Proxy_Object_Addr)),
1791 Object_Definition =>
1792 New_Occurrence_Of (RTE (RE_Address), Loc),
1794 Make_Attribute_Reference (Loc,
1795 Prefix => New_Occurrence_Of (
1796 Defining_Identifier (Last (Pvt_Decls)), Loc),
1801 Make_Package_Declaration (Loc,
1802 Specification => Make_Package_Specification (Loc,
1803 Defining_Unit_Name => Pkg_Name,
1804 Visible_Declarations => Vis_Decls,
1805 Private_Declarations => Pvt_Decls,
1806 End_Label => Empty)));
1807 Analyze (Last (Decls));
1810 Make_Package_Body (Loc,
1811 Defining_Unit_Name =>
1812 Make_Defining_Identifier (Loc,
1814 Declarations => New_List (
1815 Make_Subprogram_Body (Loc,
1818 Declarations => New_List,
1819 Handled_Statement_Sequence =>
1820 Make_Handled_Sequence_Of_Statements (Loc,
1821 Statements => New_List (Perform_Call))))));
1822 Analyze (Last (Decls));
1823 end Add_RAS_Proxy_And_Analyze;
1825 -----------------------
1826 -- Add_RAST_Features --
1827 -----------------------
1829 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1830 RAS_Type : constant Entity_Id :=
1831 Equivalent_Type (Defining_Identifier (Vis_Decl));
1833 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1834 Add_RAS_Dereference_TSS (Vis_Decl);
1835 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1836 end Add_RAST_Features;
1842 procedure Add_Stub_Type
1843 (Designated_Type : Entity_Id;
1844 RACW_Type : Entity_Id;
1846 Stub_Type : out Entity_Id;
1847 Stub_Type_Access : out Entity_Id;
1848 RPC_Receiver_Decl : out Node_Id;
1849 Body_Decls : out List_Id;
1850 Existing : out Boolean)
1852 Loc : constant Source_Ptr := Sloc (RACW_Type);
1854 Stub_Elements : constant Stub_Structure :=
1855 Stubs_Table.Get (Designated_Type);
1856 Stub_Type_Decl : Node_Id;
1857 Stub_Type_Access_Decl : Node_Id;
1860 if Stub_Elements /= Empty_Stub_Structure then
1861 Stub_Type := Stub_Elements.Stub_Type;
1862 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1863 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1864 Body_Decls := Stub_Elements.Body_Decls;
1871 Make_Defining_Identifier (Loc,
1872 Chars => New_Internal_Name ('S'));
1873 Set_Ekind (Stub_Type, E_Record_Type);
1874 Set_Is_RACW_Stub_Type (Stub_Type);
1876 Make_Defining_Identifier (Loc,
1877 Chars => New_External_Name
1878 (Related_Id => Chars (Stub_Type), Suffix => 'A'));
1880 Specific_Build_Stub_Type
1881 (RACW_Type, Stub_Type,
1882 Stub_Type_Decl, RPC_Receiver_Decl);
1884 Stub_Type_Access_Decl :=
1885 Make_Full_Type_Declaration (Loc,
1886 Defining_Identifier => Stub_Type_Access,
1888 Make_Access_To_Object_Definition (Loc,
1889 All_Present => True,
1890 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1892 Append_To (Decls, Stub_Type_Decl);
1893 Analyze (Last (Decls));
1894 Append_To (Decls, Stub_Type_Access_Decl);
1895 Analyze (Last (Decls));
1897 -- This is in no way a type derivation, but we fake it to make sure that
1898 -- the dispatching table gets built with the corresponding primitive
1899 -- operations at the right place.
1901 Derive_Subprograms (Parent_Type => Designated_Type,
1902 Derived_Type => Stub_Type);
1904 if Present (RPC_Receiver_Decl) then
1905 Append_To (Decls, RPC_Receiver_Decl);
1907 RPC_Receiver_Decl := Last (Decls);
1910 Body_Decls := New_List;
1912 Stubs_Table.Set (Designated_Type,
1913 (Stub_Type => Stub_Type,
1914 Stub_Type_Access => Stub_Type_Access,
1915 RPC_Receiver_Decl => RPC_Receiver_Decl,
1916 Body_Decls => Body_Decls,
1917 RACW_Type => RACW_Type));
1920 ------------------------
1921 -- Append_RACW_Bodies --
1922 ------------------------
1924 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
1927 E := First_Entity (Spec_Id);
1928 while Present (E) loop
1929 if Is_Remote_Access_To_Class_Wide_Type (E) then
1930 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
1935 end Append_RACW_Bodies;
1937 ----------------------------------
1938 -- Assign_Subprogram_Identifier --
1939 ----------------------------------
1941 procedure Assign_Subprogram_Identifier
1946 N : constant Name_Id := Chars (Def);
1948 Overload_Order : constant Int :=
1949 Overload_Counter_Table.Get (N) + 1;
1952 Overload_Counter_Table.Set (N, Overload_Order);
1954 Get_Name_String (N);
1956 -- Homonym handling: as in Exp_Dbug, but much simpler,
1957 -- because the only entities for which we have to generate
1958 -- names here need only to be disambiguated within their
1961 if Overload_Order > 1 then
1962 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
1963 Name_Len := Name_Len + 2;
1964 Add_Nat_To_Name_Buffer (Overload_Order);
1967 Id := String_From_Name_Buffer;
1968 Subprogram_Identifier_Table.Set (Def,
1969 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
1970 end Assign_Subprogram_Identifier;
1972 -------------------------------------
1973 -- Build_Actual_Object_Declaration --
1974 -------------------------------------
1976 procedure Build_Actual_Object_Declaration
1977 (Object : Entity_Id;
1983 Loc : constant Source_Ptr := Sloc (Object);
1985 -- Declare a temporary object for the actual, possibly initialized with
1986 -- a 'Input/From_Any call.
1988 -- Complication arises in the case of limited types, for which such a
1989 -- declaration is illegal in Ada 95. In that case, we first generate a
1990 -- renaming declaration of the 'Input call, and then if needed we
1991 -- generate an overlaid non-constant view.
1993 if Ada_Version <= Ada_95
1994 and then Is_Limited_Type (Etyp)
1995 and then Present (Expr)
1998 -- Object : Etyp renames <func-call>
2001 Make_Object_Renaming_Declaration (Loc,
2002 Defining_Identifier => Object,
2003 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
2008 -- The name defined by the renaming declaration denotes a
2009 -- constant view; create a non-constant object at the same address
2010 -- to be used as the actual.
2013 Constant_Object : constant Entity_Id :=
2014 Make_Defining_Identifier (Loc,
2015 New_Internal_Name ('P'));
2017 Set_Defining_Identifier
2018 (Last (Decls), Constant_Object);
2020 -- We have an unconstrained Etyp: build the actual constrained
2021 -- subtype for the value we just read from the stream.
2023 -- subtype S is <actual subtype of Constant_Object>;
2026 Build_Actual_Subtype (Etyp,
2027 New_Occurrence_Of (Constant_Object, Loc)));
2032 Make_Object_Declaration (Loc,
2033 Defining_Identifier => Object,
2034 Object_Definition =>
2036 (Defining_Identifier (Last (Decls)), Loc)));
2037 Set_Ekind (Object, E_Variable);
2039 -- Suppress default initialization:
2040 -- pragma Import (Ada, Object);
2044 Chars => Name_Import,
2045 Pragma_Argument_Associations => New_List (
2046 Make_Pragma_Argument_Association (Loc,
2047 Chars => Name_Convention,
2048 Expression => Make_Identifier (Loc, Name_Ada)),
2049 Make_Pragma_Argument_Association (Loc,
2050 Chars => Name_Entity,
2051 Expression => New_Occurrence_Of (Object, Loc)))));
2053 -- for Object'Address use Constant_Object'Address;
2056 Make_Attribute_Definition_Clause (Loc,
2057 Name => New_Occurrence_Of (Object, Loc),
2058 Chars => Name_Address,
2060 Make_Attribute_Reference (Loc,
2062 New_Occurrence_Of (Constant_Object, Loc),
2070 -- General case of a regular object declaration. Object is flagged
2071 -- constant unless it has mode out or in out, to allow the backend
2072 -- to optimize where possible.
2074 -- Object : [constant] Etyp [:= <expr>];
2077 Make_Object_Declaration (Loc,
2078 Defining_Identifier => Object,
2079 Constant_Present => Present (Expr) and then not Variable,
2080 Object_Definition =>
2081 New_Occurrence_Of (Etyp, Loc),
2082 Expression => Expr));
2084 if Constant_Present (Last (Decls)) then
2085 Set_Ekind (Object, E_Constant);
2087 Set_Ekind (Object, E_Variable);
2090 end Build_Actual_Object_Declaration;
2092 ------------------------------
2093 -- Build_Get_Unique_RP_Call --
2094 ------------------------------
2096 function Build_Get_Unique_RP_Call
2098 Pointer : Entity_Id;
2099 Stub_Type : Entity_Id) return List_Id
2103 Make_Procedure_Call_Statement (Loc,
2105 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2106 Parameter_Associations => New_List (
2107 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2108 New_Occurrence_Of (Pointer, Loc)))),
2110 Make_Assignment_Statement (Loc,
2112 Make_Selected_Component (Loc,
2114 New_Occurrence_Of (Pointer, Loc),
2116 New_Occurrence_Of (First_Tag_Component
2117 (Designated_Type (Etype (Pointer))), Loc)),
2119 Make_Attribute_Reference (Loc,
2121 New_Occurrence_Of (Stub_Type, Loc),
2125 -- Note: The assignment to Pointer._Tag is safe here because
2126 -- we carefully ensured that Stub_Type has exactly the same layout
2127 -- as System.Partition_Interface.RACW_Stub_Type.
2129 end Build_Get_Unique_RP_Call;
2131 -----------------------------------
2132 -- Build_Ordered_Parameters_List --
2133 -----------------------------------
2135 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2136 Constrained_List : List_Id;
2137 Unconstrained_List : List_Id;
2138 Current_Parameter : Node_Id;
2141 First_Parameter : Node_Id;
2142 For_RAS : Boolean := False;
2145 if No (Parameter_Specifications (Spec)) then
2149 Constrained_List := New_List;
2150 Unconstrained_List := New_List;
2151 First_Parameter := First (Parameter_Specifications (Spec));
2153 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2154 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2159 -- Loop through the parameters and add them to the right list. Note that
2160 -- we treat a parameter of a null-excluding access type as unconstrained
2161 -- because we can't declare an object of such a type with default
2164 Current_Parameter := First_Parameter;
2165 while Present (Current_Parameter) loop
2166 Ptyp := Parameter_Type (Current_Parameter);
2168 if (Nkind (Ptyp) = N_Access_Definition
2169 or else not Transmit_As_Unconstrained (Etype (Ptyp)))
2170 and then not (For_RAS and then Current_Parameter = First_Parameter)
2172 Append_To (Constrained_List, New_Copy (Current_Parameter));
2174 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2177 Next (Current_Parameter);
2180 -- Unconstrained parameters are returned first
2182 Append_List_To (Unconstrained_List, Constrained_List);
2184 return Unconstrained_List;
2185 end Build_Ordered_Parameters_List;
2187 ----------------------------------
2188 -- Build_Passive_Partition_Stub --
2189 ----------------------------------
2191 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2193 Pkg_Name : String_Id;
2196 Loc : constant Source_Ptr := Sloc (U);
2199 -- Verify that the implementation supports distribution, by accessing
2200 -- a type defined in the proper version of system.rpc
2203 Dist_OK : Entity_Id;
2204 pragma Warnings (Off, Dist_OK);
2206 Dist_OK := RTE (RE_Params_Stream_Type);
2209 -- Use body if present, spec otherwise
2211 if Nkind (U) = N_Package_Declaration then
2212 Pkg_Spec := Specification (U);
2213 L := Visible_Declarations (Pkg_Spec);
2215 Pkg_Spec := Parent (Corresponding_Spec (U));
2216 L := Declarations (U);
2219 Get_Library_Unit_Name_String (Pkg_Spec);
2220 Pkg_Name := String_From_Name_Buffer;
2222 Make_Procedure_Call_Statement (Loc,
2224 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2225 Parameter_Associations => New_List (
2226 Make_String_Literal (Loc, Pkg_Name),
2227 Make_Attribute_Reference (Loc,
2229 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2234 end Build_Passive_Partition_Stub;
2236 --------------------------------------
2237 -- Build_RPC_Receiver_Specification --
2238 --------------------------------------
2240 function Build_RPC_Receiver_Specification
2241 (RPC_Receiver : Entity_Id;
2242 Request_Parameter : Entity_Id) return Node_Id
2244 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2247 Make_Procedure_Specification (Loc,
2248 Defining_Unit_Name => RPC_Receiver,
2249 Parameter_Specifications => New_List (
2250 Make_Parameter_Specification (Loc,
2251 Defining_Identifier => Request_Parameter,
2253 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2254 end Build_RPC_Receiver_Specification;
2256 ----------------------------------------
2257 -- Build_Remote_Subprogram_Proxy_Type --
2258 ----------------------------------------
2260 function Build_Remote_Subprogram_Proxy_Type
2262 ACR_Expression : Node_Id) return Node_Id
2266 Make_Record_Definition (Loc,
2267 Tagged_Present => True,
2268 Limited_Present => True,
2270 Make_Component_List (Loc,
2272 Component_Items => New_List (
2273 Make_Component_Declaration (Loc,
2274 Defining_Identifier =>
2275 Make_Defining_Identifier (Loc,
2276 Name_All_Calls_Remote),
2277 Component_Definition =>
2278 Make_Component_Definition (Loc,
2279 Subtype_Indication =>
2280 New_Occurrence_Of (Standard_Boolean, Loc)),
2284 Make_Component_Declaration (Loc,
2285 Defining_Identifier =>
2286 Make_Defining_Identifier (Loc,
2288 Component_Definition =>
2289 Make_Component_Definition (Loc,
2290 Subtype_Indication =>
2291 New_Occurrence_Of (RTE (RE_Address), Loc)),
2293 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2295 Make_Component_Declaration (Loc,
2296 Defining_Identifier =>
2297 Make_Defining_Identifier (Loc,
2299 Component_Definition =>
2300 Make_Component_Definition (Loc,
2301 Subtype_Indication =>
2302 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2303 end Build_Remote_Subprogram_Proxy_Type;
2305 ------------------------------------
2306 -- Build_Subprogram_Calling_Stubs --
2307 ------------------------------------
2309 function Build_Subprogram_Calling_Stubs
2310 (Vis_Decl : Node_Id;
2312 Asynchronous : Boolean;
2313 Dynamically_Asynchronous : Boolean := False;
2314 Stub_Type : Entity_Id := Empty;
2315 RACW_Type : Entity_Id := Empty;
2316 Locator : Entity_Id := Empty;
2317 New_Name : Name_Id := No_Name) return Node_Id
2319 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2321 Decls : constant List_Id := New_List;
2322 Statements : constant List_Id := New_List;
2324 Subp_Spec : Node_Id;
2325 -- The specification of the body
2327 Controlling_Parameter : Entity_Id := Empty;
2329 Asynchronous_Expr : Node_Id := Empty;
2331 RCI_Locator : Entity_Id;
2333 Spec_To_Use : Node_Id;
2335 procedure Insert_Partition_Check (Parameter : Node_Id);
2336 -- Check that the parameter has been elaborated on the same partition
2337 -- than the controlling parameter (E.4(19)).
2339 ----------------------------
2340 -- Insert_Partition_Check --
2341 ----------------------------
2343 procedure Insert_Partition_Check (Parameter : Node_Id) is
2344 Parameter_Entity : constant Entity_Id :=
2345 Defining_Identifier (Parameter);
2347 -- The expression that will be built is of the form:
2349 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2350 -- raise Constraint_Error;
2353 -- We do not check that Parameter is in Stub_Type since such a check
2354 -- has been inserted at the point of call already (a tag check since
2355 -- we have multiple controlling operands).
2358 Make_Raise_Constraint_Error (Loc,
2362 Make_Function_Call (Loc,
2364 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2365 Parameter_Associations =>
2367 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2368 New_Occurrence_Of (Parameter_Entity, Loc)),
2369 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2370 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2371 Reason => CE_Partition_Check_Failed));
2372 end Insert_Partition_Check;
2374 -- Start of processing for Build_Subprogram_Calling_Stubs
2377 Subp_Spec := Copy_Specification (Loc,
2378 Spec => Specification (Vis_Decl),
2379 New_Name => New_Name);
2381 if Locator = Empty then
2382 RCI_Locator := RCI_Cache;
2383 Spec_To_Use := Specification (Vis_Decl);
2385 RCI_Locator := Locator;
2386 Spec_To_Use := Subp_Spec;
2389 -- Find a controlling argument if we have a stub type. Also check
2390 -- if this subprogram can be made asynchronous.
2392 if Present (Stub_Type)
2393 and then Present (Parameter_Specifications (Spec_To_Use))
2396 Current_Parameter : Node_Id :=
2397 First (Parameter_Specifications
2400 while Present (Current_Parameter) loop
2402 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2404 if Controlling_Parameter = Empty then
2405 Controlling_Parameter :=
2406 Defining_Identifier (Current_Parameter);
2408 Insert_Partition_Check (Current_Parameter);
2412 Next (Current_Parameter);
2417 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2419 if Dynamically_Asynchronous then
2420 Asynchronous_Expr := Make_Selected_Component (Loc,
2421 Prefix => Controlling_Parameter,
2422 Selector_Name => Name_Asynchronous);
2425 Specific_Build_General_Calling_Stubs
2427 Statements => Statements,
2428 Target => Specific_Build_Stub_Target (Loc,
2429 Decls, RCI_Locator, Controlling_Parameter),
2430 Subprogram_Id => Subp_Id,
2431 Asynchronous => Asynchronous_Expr,
2432 Is_Known_Asynchronous => Asynchronous
2433 and then not Dynamically_Asynchronous,
2434 Is_Known_Non_Asynchronous
2436 and then not Dynamically_Asynchronous,
2437 Is_Function => Nkind (Spec_To_Use) =
2438 N_Function_Specification,
2439 Spec => Spec_To_Use,
2440 Stub_Type => Stub_Type,
2441 RACW_Type => RACW_Type,
2444 RCI_Calling_Stubs_Table.Set
2445 (Defining_Unit_Name (Specification (Vis_Decl)),
2446 Defining_Unit_Name (Spec_To_Use));
2449 Make_Subprogram_Body (Loc,
2450 Specification => Subp_Spec,
2451 Declarations => Decls,
2452 Handled_Statement_Sequence =>
2453 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2454 end Build_Subprogram_Calling_Stubs;
2456 -------------------------
2457 -- Build_Subprogram_Id --
2458 -------------------------
2460 function Build_Subprogram_Id
2462 E : Entity_Id) return Node_Id
2465 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2467 Current_Declaration : Node_Id;
2468 Current_Subp : Entity_Id;
2469 Current_Subp_Str : String_Id;
2470 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2472 pragma Warnings (Off, Current_Subp_Str);
2475 -- Build_Subprogram_Id is called outside of the context of
2476 -- generating calling or receiving stubs. Hence we are processing
2477 -- an 'Access attribute_reference for an RCI subprogram, for the
2478 -- purpose of obtaining a RAS value.
2481 (Is_Remote_Call_Interface (Scope (E))
2483 (Nkind (Parent (E)) = N_Procedure_Specification
2485 Nkind (Parent (E)) = N_Function_Specification));
2487 Current_Declaration :=
2488 First (Visible_Declarations
2489 (Package_Specification_Of_Scope (Scope (E))));
2490 while Present (Current_Declaration) loop
2491 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2492 and then Comes_From_Source (Current_Declaration)
2494 Current_Subp := Defining_Unit_Name (Specification (
2495 Current_Declaration));
2497 Assign_Subprogram_Identifier
2498 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2500 Current_Subp_Number := Current_Subp_Number + 1;
2503 Next (Current_Declaration);
2508 case Get_PCS_Name is
2509 when Name_PolyORB_DSA =>
2510 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2512 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2514 end Build_Subprogram_Id;
2516 ------------------------
2517 -- Copy_Specification --
2518 ------------------------
2520 function Copy_Specification
2523 Ctrl_Type : Entity_Id := Empty;
2524 New_Name : Name_Id := No_Name) return Node_Id
2526 Parameters : List_Id := No_List;
2528 Current_Parameter : Node_Id;
2529 Current_Identifier : Entity_Id;
2530 Current_Type : Node_Id;
2532 Name_For_New_Spec : Name_Id;
2534 New_Identifier : Entity_Id;
2536 -- Comments needed in body below ???
2539 if New_Name = No_Name then
2540 pragma Assert (Nkind (Spec) = N_Function_Specification
2541 or else Nkind (Spec) = N_Procedure_Specification);
2543 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2545 Name_For_New_Spec := New_Name;
2548 if Present (Parameter_Specifications (Spec)) then
2549 Parameters := New_List;
2550 Current_Parameter := First (Parameter_Specifications (Spec));
2551 while Present (Current_Parameter) loop
2552 Current_Identifier := Defining_Identifier (Current_Parameter);
2553 Current_Type := Parameter_Type (Current_Parameter);
2555 if Nkind (Current_Type) = N_Access_Definition then
2556 if Present (Ctrl_Type) then
2557 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2559 Make_Access_Definition (Loc,
2560 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2561 Null_Exclusion_Present =>
2562 Null_Exclusion_Present (Current_Type));
2566 Make_Access_Definition (Loc,
2568 New_Copy_Tree (Subtype_Mark (Current_Type)),
2569 Null_Exclusion_Present =>
2570 Null_Exclusion_Present (Current_Type));
2574 if Present (Ctrl_Type)
2575 and then Is_Controlling_Formal (Current_Identifier)
2577 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2579 Current_Type := New_Copy_Tree (Current_Type);
2583 New_Identifier := Make_Defining_Identifier (Loc,
2584 Chars (Current_Identifier));
2586 Append_To (Parameters,
2587 Make_Parameter_Specification (Loc,
2588 Defining_Identifier => New_Identifier,
2589 Parameter_Type => Current_Type,
2590 In_Present => In_Present (Current_Parameter),
2591 Out_Present => Out_Present (Current_Parameter),
2593 New_Copy_Tree (Expression (Current_Parameter))));
2595 -- For a regular formal parameter (that needs to be marshalled
2596 -- in the context of remote calls), set the Etype now, because
2597 -- marshalling processing might need it.
2599 if Is_Entity_Name (Current_Type) then
2600 Set_Etype (New_Identifier, Entity (Current_Type));
2602 -- Current_Type is an access definition, special processing
2603 -- (not requiring etype) will occur for marshalling.
2609 Next (Current_Parameter);
2613 case Nkind (Spec) is
2615 when N_Function_Specification | N_Access_Function_Definition =>
2617 Make_Function_Specification (Loc,
2618 Defining_Unit_Name =>
2619 Make_Defining_Identifier (Loc,
2620 Chars => Name_For_New_Spec),
2621 Parameter_Specifications => Parameters,
2622 Result_Definition =>
2623 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2625 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2627 Make_Procedure_Specification (Loc,
2628 Defining_Unit_Name =>
2629 Make_Defining_Identifier (Loc,
2630 Chars => Name_For_New_Spec),
2631 Parameter_Specifications => Parameters);
2634 raise Program_Error;
2636 end Copy_Specification;
2638 -----------------------------
2639 -- Corresponding_Stub_Type --
2640 -----------------------------
2642 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2643 Desig : constant Entity_Id :=
2644 Etype (Designated_Type (RACW_Type));
2645 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2647 return Stub_Elements.Stub_Type;
2648 end Corresponding_Stub_Type;
2650 ---------------------------
2651 -- Could_Be_Asynchronous --
2652 ---------------------------
2654 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2655 Current_Parameter : Node_Id;
2658 if Present (Parameter_Specifications (Spec)) then
2659 Current_Parameter := First (Parameter_Specifications (Spec));
2660 while Present (Current_Parameter) loop
2661 if Out_Present (Current_Parameter) then
2665 Next (Current_Parameter);
2670 end Could_Be_Asynchronous;
2672 ---------------------------
2673 -- Declare_Create_NVList --
2674 ---------------------------
2676 procedure Declare_Create_NVList
2684 Make_Object_Declaration (Loc,
2685 Defining_Identifier => NVList,
2686 Aliased_Present => False,
2687 Object_Definition =>
2688 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2691 Make_Procedure_Call_Statement (Loc,
2693 New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2694 Parameter_Associations => New_List (
2695 New_Occurrence_Of (NVList, Loc))));
2696 end Declare_Create_NVList;
2698 ---------------------------------------------
2699 -- Expand_All_Calls_Remote_Subprogram_Call --
2700 ---------------------------------------------
2702 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2703 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2704 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2705 Loc : constant Source_Ptr := Sloc (N);
2706 RCI_Locator : Node_Id;
2707 RCI_Cache : Entity_Id;
2708 Calling_Stubs : Node_Id;
2709 E_Calling_Stubs : Entity_Id;
2712 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2714 if E_Calling_Stubs = Empty then
2715 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2717 if RCI_Cache = Empty then
2720 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2721 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2723 -- The RCI_Locator package is inserted at the top level in the
2724 -- current unit, and must appear in the proper scope, so that it
2725 -- is not prematurely removed by the GCC back-end.
2728 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2731 if Ekind (Scop) = E_Package_Body then
2732 Push_Scope (Spec_Entity (Scop));
2734 elsif Ekind (Scop) = E_Subprogram_Body then
2736 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2742 Analyze (RCI_Locator);
2746 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2749 RCI_Locator := Parent (RCI_Cache);
2752 Calling_Stubs := Build_Subprogram_Calling_Stubs
2753 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2755 Build_Subprogram_Id (Loc, Called_Subprogram),
2756 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2758 Is_Asynchronous (Called_Subprogram),
2759 Locator => RCI_Cache,
2760 New_Name => New_Internal_Name ('S'));
2761 Insert_After (RCI_Locator, Calling_Stubs);
2762 Analyze (Calling_Stubs);
2763 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2766 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2767 end Expand_All_Calls_Remote_Subprogram_Call;
2769 ---------------------------------
2770 -- Expand_Calling_Stubs_Bodies --
2771 ---------------------------------
2773 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2774 Spec : constant Node_Id := Specification (Unit_Node);
2775 Decls : constant List_Id := Visible_Declarations (Spec);
2777 Push_Scope (Scope_Of_Spec (Spec));
2778 Add_Calling_Stubs_To_Declarations
2779 (Specification (Unit_Node), Decls);
2781 end Expand_Calling_Stubs_Bodies;
2783 -----------------------------------
2784 -- Expand_Receiving_Stubs_Bodies --
2785 -----------------------------------
2787 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2790 Stubs_Decls : List_Id;
2791 Stubs_Stmts : List_Id;
2794 if Nkind (Unit_Node) = N_Package_Declaration then
2795 Spec := Specification (Unit_Node);
2796 Decls := Private_Declarations (Spec);
2799 Decls := Visible_Declarations (Spec);
2802 Push_Scope (Scope_Of_Spec (Spec));
2803 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2807 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2808 Decls := Declarations (Unit_Node);
2810 Push_Scope (Scope_Of_Spec (Unit_Node));
2811 Stubs_Decls := New_List;
2812 Stubs_Stmts := New_List;
2813 Specific_Add_Receiving_Stubs_To_Declarations
2814 (Spec, Stubs_Decls, Stubs_Stmts);
2816 Insert_List_Before (First (Decls), Stubs_Decls);
2819 HSS_Stmts : constant List_Id :=
2820 Statements (Handled_Statement_Sequence (Unit_Node));
2821 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2823 if No (First_HSS_Stmt) then
2824 Append_List_To (HSS_Stmts, Stubs_Stmts);
2826 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2832 end Expand_Receiving_Stubs_Bodies;
2834 --------------------
2835 -- GARLIC_Support --
2836 --------------------
2838 package body GARLIC_Support is
2840 -- Local subprograms
2842 procedure Add_RACW_Read_Attribute
2843 (RACW_Type : Entity_Id;
2844 Stub_Type : Entity_Id;
2845 Stub_Type_Access : Entity_Id;
2846 Body_Decls : List_Id);
2847 -- Add Read attribute for the RACW type. The declaration and attribute
2848 -- definition clauses are inserted right after the declaration of
2849 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2850 -- appended to it (case where the RACW declaration is in the main unit).
2852 procedure Add_RACW_Write_Attribute
2853 (RACW_Type : Entity_Id;
2854 Stub_Type : Entity_Id;
2855 Stub_Type_Access : Entity_Id;
2856 RPC_Receiver : Node_Id;
2857 Body_Decls : List_Id);
2858 -- Same as above for the Write attribute
2860 function Stream_Parameter return Node_Id;
2861 function Result return Node_Id;
2862 function Object return Node_Id renames Result;
2863 -- Functions to create occurrences of the formal parameter names of the
2864 -- 'Read and 'Write attributes.
2867 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2868 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2870 procedure Add_RAS_Access_TSS (N : Node_Id);
2871 -- Add a subprogram body for RAS Access TSS
2873 -------------------------------------
2874 -- Add_Obj_RPC_Receiver_Completion --
2875 -------------------------------------
2877 procedure Add_Obj_RPC_Receiver_Completion
2880 RPC_Receiver : Entity_Id;
2881 Stub_Elements : Stub_Structure) is
2883 -- The RPC receiver body should not be the completion of the
2884 -- declaration recorded in the stub structure, because then the
2885 -- occurrences of the formal parameters within the body should refer
2886 -- to the entities from the declaration, not from the completion, to
2887 -- which we do not have easy access. Instead, the RPC receiver body
2888 -- acts as its own declaration, and the RPC receiver declaration is
2889 -- completed by a renaming-as-body.
2892 Make_Subprogram_Renaming_Declaration (Loc,
2894 Copy_Specification (Loc,
2895 Specification (Stub_Elements.RPC_Receiver_Decl)),
2896 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2897 end Add_Obj_RPC_Receiver_Completion;
2899 -----------------------
2900 -- Add_RACW_Features --
2901 -----------------------
2903 procedure Add_RACW_Features
2904 (RACW_Type : Entity_Id;
2905 Stub_Type : Entity_Id;
2906 Stub_Type_Access : Entity_Id;
2907 RPC_Receiver_Decl : Node_Id;
2908 Body_Decls : List_Id)
2910 RPC_Receiver : Node_Id;
2911 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2914 Loc := Sloc (RACW_Type);
2918 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2919 -- of the corresponding distributed object type. We retrieve its
2920 -- address from the local proxy object.
2922 RPC_Receiver := Make_Selected_Component (Loc,
2924 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2925 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2928 RPC_Receiver := Make_Attribute_Reference (Loc,
2929 Prefix => New_Occurrence_Of (
2930 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2931 Attribute_Name => Name_Address);
2934 Add_RACW_Write_Attribute (
2941 Add_RACW_Read_Attribute (
2946 end Add_RACW_Features;
2948 -----------------------------
2949 -- Add_RACW_Read_Attribute --
2950 -----------------------------
2952 procedure Add_RACW_Read_Attribute
2953 (RACW_Type : Entity_Id;
2954 Stub_Type : Entity_Id;
2955 Stub_Type_Access : Entity_Id;
2956 Body_Decls : List_Id)
2958 Proc_Decl : Node_Id;
2959 Attr_Decl : Node_Id;
2961 Body_Node : Node_Id;
2963 Statements : constant List_Id := New_List;
2965 Local_Statements : List_Id;
2966 Remote_Statements : List_Id;
2967 -- Various parts of the procedure
2969 Pnam : constant Entity_Id :=
2970 Make_Defining_Identifier
2971 (Loc, New_Internal_Name ('R'));
2972 Asynchronous_Flag : constant Entity_Id :=
2973 Asynchronous_Flags_Table.Get (RACW_Type);
2974 pragma Assert (Present (Asynchronous_Flag));
2976 -- Prepare local identifiers
2978 Source_Partition : Entity_Id;
2979 Source_Receiver : Entity_Id;
2980 Source_Address : Entity_Id;
2981 Local_Stub : Entity_Id;
2982 Stubbed_Result : Entity_Id;
2984 -- Start of processing for Add_RACW_Read_Attribute
2987 Build_Stream_Procedure (Loc,
2988 RACW_Type, Body_Node, Pnam, Statements, Outp => True);
2989 Proc_Decl := Make_Subprogram_Declaration (Loc,
2990 Copy_Specification (Loc, Specification (Body_Node)));
2993 Make_Attribute_Definition_Clause (Loc,
2994 Name => New_Occurrence_Of (RACW_Type, Loc),
2998 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3000 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3001 Insert_After (Proc_Decl, Attr_Decl);
3003 if No (Body_Decls) then
3004 -- Case of processing an RACW type from another unit than the
3005 -- main one: do not generate a body.
3010 -- Prepare local identifiers
3013 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3015 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3017 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3019 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
3021 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3023 -- Generate object declarations
3026 Make_Object_Declaration (Loc,
3027 Defining_Identifier => Source_Partition,
3028 Object_Definition =>
3029 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
3031 Make_Object_Declaration (Loc,
3032 Defining_Identifier => Source_Receiver,
3033 Object_Definition =>
3034 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3036 Make_Object_Declaration (Loc,
3037 Defining_Identifier => Source_Address,
3038 Object_Definition =>
3039 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3041 Make_Object_Declaration (Loc,
3042 Defining_Identifier => Local_Stub,
3043 Aliased_Present => True,
3044 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
3046 Make_Object_Declaration (Loc,
3047 Defining_Identifier => Stubbed_Result,
3048 Object_Definition =>
3049 New_Occurrence_Of (Stub_Type_Access, Loc),
3051 Make_Attribute_Reference (Loc,
3053 New_Occurrence_Of (Local_Stub, Loc),
3055 Name_Unchecked_Access)));
3057 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3059 Append_List_To (Statements, New_List (
3060 Make_Attribute_Reference (Loc,
3062 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3063 Attribute_Name => Name_Read,
3064 Expressions => New_List (
3066 New_Occurrence_Of (Source_Partition, Loc))),
3068 Make_Attribute_Reference (Loc,
3070 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3073 Expressions => New_List (
3075 New_Occurrence_Of (Source_Receiver, Loc))),
3077 Make_Attribute_Reference (Loc,
3079 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3082 Expressions => New_List (
3084 New_Occurrence_Of (Source_Address, Loc)))));
3086 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3088 Set_Etype (Stubbed_Result, Stub_Type_Access);
3090 -- If the Address is Null_Address, then return a null object, unless
3091 -- RACW_Type is null-excluding, in which case inconditionally raise
3092 -- CONSTRAINT_ERROR instead.
3095 Zero_Statements : List_Id;
3096 -- Statements executed when a zero value is received
3098 if Can_Never_Be_Null (RACW_Type) then
3099 Zero_Statements := New_List (
3100 Make_Raise_Constraint_Error (Loc,
3101 Reason => CE_Null_Not_Allowed));
3103 Zero_Statements := New_List (
3104 Make_Assignment_Statement (Loc,
3106 Expression => Make_Null (Loc)),
3107 Make_Simple_Return_Statement (Loc));
3110 Append_To (Statements,
3111 Make_Implicit_If_Statement (RACW_Type,
3114 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3115 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3116 Then_Statements => Zero_Statements));
3119 -- If the RACW denotes an object created on the current partition,
3120 -- Local_Statements will be executed. The real object will be used.
3122 Local_Statements := New_List (
3123 Make_Assignment_Statement (Loc,
3126 Unchecked_Convert_To (RACW_Type,
3127 OK_Convert_To (RTE (RE_Address),
3128 New_Occurrence_Of (Source_Address, Loc)))));
3130 -- If the object is located on another partition, then a stub object
3131 -- will be created with all the information needed to rebuild the
3132 -- real object at the other end.
3134 Remote_Statements := New_List (
3136 Make_Assignment_Statement (Loc,
3137 Name => Make_Selected_Component (Loc,
3138 Prefix => Stubbed_Result,
3139 Selector_Name => Name_Origin),
3141 New_Occurrence_Of (Source_Partition, Loc)),
3143 Make_Assignment_Statement (Loc,
3144 Name => Make_Selected_Component (Loc,
3145 Prefix => Stubbed_Result,
3146 Selector_Name => Name_Receiver),
3148 New_Occurrence_Of (Source_Receiver, Loc)),
3150 Make_Assignment_Statement (Loc,
3151 Name => Make_Selected_Component (Loc,
3152 Prefix => Stubbed_Result,
3153 Selector_Name => Name_Addr),
3155 New_Occurrence_Of (Source_Address, Loc)));
3157 Append_To (Remote_Statements,
3158 Make_Assignment_Statement (Loc,
3159 Name => Make_Selected_Component (Loc,
3160 Prefix => Stubbed_Result,
3161 Selector_Name => Name_Asynchronous),
3163 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3165 Append_List_To (Remote_Statements,
3166 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3167 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3168 -- set on the stub type if, and only if, the RACW type has a pragma
3169 -- Asynchronous. This is incorrect for RACWs that implement RAS
3170 -- types, because in that case the /designated subprogram/ (not the
3171 -- type) might be asynchronous, and that causes the stub to need to
3172 -- be asynchronous too. A solution is to transport a RAS as a struct
3173 -- containing a RACW and an asynchronous flag, and to properly alter
3174 -- the Asynchronous component in the stub type in the RAS's Input
3177 Append_To (Remote_Statements,
3178 Make_Assignment_Statement (Loc,
3180 Expression => Unchecked_Convert_To (RACW_Type,
3181 New_Occurrence_Of (Stubbed_Result, Loc))));
3183 -- Distinguish between the local and remote cases, and execute the
3184 -- appropriate piece of code.
3186 Append_To (Statements,
3187 Make_Implicit_If_Statement (RACW_Type,
3191 Make_Function_Call (Loc,
3192 Name => New_Occurrence_Of (
3193 RTE (RE_Get_Local_Partition_Id), Loc)),
3194 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3195 Then_Statements => Local_Statements,
3196 Else_Statements => Remote_Statements));
3198 Set_Declarations (Body_Node, Decls);
3199 Append_To (Body_Decls, Body_Node);
3200 end Add_RACW_Read_Attribute;
3202 ------------------------------
3203 -- Add_RACW_Write_Attribute --
3204 ------------------------------
3206 procedure Add_RACW_Write_Attribute
3207 (RACW_Type : Entity_Id;
3208 Stub_Type : Entity_Id;
3209 Stub_Type_Access : Entity_Id;
3210 RPC_Receiver : Node_Id;
3211 Body_Decls : List_Id)
3213 Body_Node : Node_Id;
3214 Proc_Decl : Node_Id;
3215 Attr_Decl : Node_Id;
3217 Statements : constant List_Id := New_List;
3218 Local_Statements : List_Id;
3219 Remote_Statements : List_Id;
3220 Null_Statements : List_Id;
3222 Pnam : constant Entity_Id :=
3223 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3226 Build_Stream_Procedure
3227 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
3229 Proc_Decl := Make_Subprogram_Declaration (Loc,
3230 Copy_Specification (Loc, Specification (Body_Node)));
3233 Make_Attribute_Definition_Clause (Loc,
3234 Name => New_Occurrence_Of (RACW_Type, Loc),
3235 Chars => Name_Write,
3238 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3240 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3241 Insert_After (Proc_Decl, Attr_Decl);
3243 if No (Body_Decls) then
3247 -- Build the code fragment corresponding to the marshalling of a
3250 Local_Statements := New_List (
3252 Pack_Entity_Into_Stream_Access (Loc,
3253 Stream => Stream_Parameter,
3254 Object => RTE (RE_Get_Local_Partition_Id)),
3256 Pack_Node_Into_Stream_Access (Loc,
3257 Stream => Stream_Parameter,
3258 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3259 Etyp => RTE (RE_Unsigned_64)),
3261 Pack_Node_Into_Stream_Access (Loc,
3262 Stream => Stream_Parameter,
3263 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3264 Make_Attribute_Reference (Loc,
3266 Make_Explicit_Dereference (Loc,
3268 Attribute_Name => Name_Address)),
3269 Etyp => RTE (RE_Unsigned_64)));
3271 -- Build the code fragment corresponding to the marshalling of
3274 Remote_Statements := New_List (
3276 Pack_Node_Into_Stream_Access (Loc,
3277 Stream => Stream_Parameter,
3279 Make_Selected_Component (Loc,
3280 Prefix => Unchecked_Convert_To (Stub_Type_Access,
3283 Make_Identifier (Loc, Name_Origin)),
3284 Etyp => RTE (RE_Partition_ID)),
3286 Pack_Node_Into_Stream_Access (Loc,
3287 Stream => Stream_Parameter,
3289 Make_Selected_Component (Loc,
3290 Prefix => Unchecked_Convert_To (Stub_Type_Access,
3293 Make_Identifier (Loc, Name_Receiver)),
3294 Etyp => RTE (RE_Unsigned_64)),
3296 Pack_Node_Into_Stream_Access (Loc,
3297 Stream => Stream_Parameter,
3299 Make_Selected_Component (Loc,
3300 Prefix => Unchecked_Convert_To (Stub_Type_Access,
3303 Make_Identifier (Loc, Name_Addr)),
3304 Etyp => RTE (RE_Unsigned_64)));
3306 -- Build code fragment corresponding to marshalling of a null object
3308 Null_Statements := New_List (
3310 Pack_Entity_Into_Stream_Access (Loc,
3311 Stream => Stream_Parameter,
3312 Object => RTE (RE_Get_Local_Partition_Id)),
3314 Pack_Node_Into_Stream_Access (Loc,
3315 Stream => Stream_Parameter,
3316 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3317 Etyp => RTE (RE_Unsigned_64)),
3319 Pack_Node_Into_Stream_Access (Loc,
3320 Stream => Stream_Parameter,
3321 Object => Make_Integer_Literal (Loc, Uint_0),
3322 Etyp => RTE (RE_Unsigned_64)));
3324 Append_To (Statements,
3325 Make_Implicit_If_Statement (RACW_Type,
3328 Left_Opnd => Object,
3329 Right_Opnd => Make_Null (Loc)),
3330 Then_Statements => Null_Statements,
3331 Elsif_Parts => New_List (
3332 Make_Elsif_Part (Loc,
3336 Make_Attribute_Reference (Loc,
3338 Attribute_Name => Name_Tag),
3340 Make_Attribute_Reference (Loc,
3341 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3342 Attribute_Name => Name_Tag)),
3343 Then_Statements => Remote_Statements)),
3344 Else_Statements => Local_Statements));
3346 Append_To (Body_Decls, Body_Node);
3347 end Add_RACW_Write_Attribute;
3349 ------------------------
3350 -- Add_RAS_Access_TSS --
3351 ------------------------
3353 procedure Add_RAS_Access_TSS (N : Node_Id) is
3354 Loc : constant Source_Ptr := Sloc (N);
3356 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3357 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3358 -- Ras_Type is the access to subprogram type while Fat_Type is the
3359 -- corresponding record type.
3361 RACW_Type : constant Entity_Id :=
3362 Underlying_RACW_Type (Ras_Type);
3363 Desig : constant Entity_Id :=
3364 Etype (Designated_Type (RACW_Type));
3366 Stub_Elements : constant Stub_Structure :=
3367 Stubs_Table.Get (Desig);
3368 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3370 Proc : constant Entity_Id :=
3371 Make_Defining_Identifier (Loc,
3372 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3374 Proc_Spec : Node_Id;
3376 -- Formal parameters
3378 Package_Name : constant Entity_Id :=
3379 Make_Defining_Identifier (Loc,
3383 Subp_Id : constant Entity_Id :=
3384 Make_Defining_Identifier (Loc,
3386 -- Target subprogram
3388 Asynch_P : constant Entity_Id :=
3389 Make_Defining_Identifier (Loc,
3390 Chars => Name_Asynchronous);
3391 -- Is the procedure to which the 'Access applies asynchronous?
3393 All_Calls_Remote : constant Entity_Id :=
3394 Make_Defining_Identifier (Loc,
3395 Chars => Name_All_Calls_Remote);
3396 -- True if an All_Calls_Remote pragma applies to the RCI unit
3397 -- that contains the subprogram.
3399 -- Common local variables
3401 Proc_Decls : List_Id;
3402 Proc_Statements : List_Id;
3404 Origin : constant Entity_Id :=
3405 Make_Defining_Identifier (Loc,
3406 Chars => New_Internal_Name ('P'));
3408 -- Additional local variables for the local case
3410 Proxy_Addr : constant Entity_Id :=
3411 Make_Defining_Identifier (Loc,
3412 Chars => New_Internal_Name ('P'));
3414 -- Additional local variables for the remote case
3416 Local_Stub : constant Entity_Id :=
3417 Make_Defining_Identifier (Loc,
3418 Chars => New_Internal_Name ('L'));
3420 Stub_Ptr : constant Entity_Id :=
3421 Make_Defining_Identifier (Loc,
3422 Chars => New_Internal_Name ('S'));
3425 (Field_Name : Name_Id;
3426 Value : Node_Id) return Node_Id;
3427 -- Construct an assignment that sets the named component in the
3435 (Field_Name : Name_Id;
3436 Value : Node_Id) return Node_Id
3440 Make_Assignment_Statement (Loc,
3442 Make_Selected_Component (Loc,
3444 Selector_Name => Field_Name),
3445 Expression => Value);
3448 -- Start of processing for Add_RAS_Access_TSS
3451 Proc_Decls := New_List (
3453 -- Common declarations
3455 Make_Object_Declaration (Loc,
3456 Defining_Identifier => Origin,
3457 Constant_Present => True,
3458 Object_Definition =>
3459 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3461 Make_Function_Call (Loc,
3463 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3464 Parameter_Associations => New_List (
3465 New_Occurrence_Of (Package_Name, Loc)))),
3467 -- Declaration use only in the local case: proxy address
3469 Make_Object_Declaration (Loc,
3470 Defining_Identifier => Proxy_Addr,
3471 Object_Definition =>
3472 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3474 -- Declarations used only in the remote case: stub object and
3477 Make_Object_Declaration (Loc,
3478 Defining_Identifier => Local_Stub,
3479 Aliased_Present => True,
3480 Object_Definition =>
3481 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3483 Make_Object_Declaration (Loc,
3484 Defining_Identifier =>
3486 Object_Definition =>
3487 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3489 Make_Attribute_Reference (Loc,
3490 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3491 Attribute_Name => Name_Unchecked_Access)));
3493 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3494 -- Build_Get_Unique_RP_Call needs this information
3496 -- Note: Here we assume that the Fat_Type is a record
3497 -- containing just a pointer to a proxy or stub object.
3499 Proc_Statements := New_List (
3503 -- Get_RAS_Info (Pkg, Subp, PA);
3504 -- if Origin = Local_Partition_Id
3505 -- and then not All_Calls_Remote
3507 -- return Fat_Type!(PA);
3510 Make_Procedure_Call_Statement (Loc,
3512 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3513 Parameter_Associations => New_List (
3514 New_Occurrence_Of (Package_Name, Loc),
3515 New_Occurrence_Of (Subp_Id, Loc),
3516 New_Occurrence_Of (Proxy_Addr, Loc))),
3518 Make_Implicit_If_Statement (N,
3524 New_Occurrence_Of (Origin, Loc),
3526 Make_Function_Call (Loc,
3528 RTE (RE_Get_Local_Partition_Id), Loc))),
3531 New_Occurrence_Of (All_Calls_Remote, Loc))),
3532 Then_Statements => New_List (
3533 Make_Simple_Return_Statement (Loc,
3534 Unchecked_Convert_To (Fat_Type,
3535 OK_Convert_To (RTE (RE_Address),
3536 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3538 Set_Field (Name_Origin,
3539 New_Occurrence_Of (Origin, Loc)),
3541 Set_Field (Name_Receiver,
3542 Make_Function_Call (Loc,
3544 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3545 Parameter_Associations => New_List (
3546 New_Occurrence_Of (Package_Name, Loc)))),
3548 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3550 -- E.4.1(9) A remote call is asynchronous if it is a call to
3551 -- a procedure, or a call through a value of an access-to-procedure
3552 -- type, to which a pragma Asynchronous applies.
3554 -- Parameter Asynch_P is true when the procedure is asynchronous;
3555 -- Expression Asynch_T is true when the type is asynchronous.
3557 Set_Field (Name_Asynchronous,
3559 New_Occurrence_Of (Asynch_P, Loc),
3560 New_Occurrence_Of (Boolean_Literals (
3561 Is_Asynchronous (Ras_Type)), Loc))));
3563 Append_List_To (Proc_Statements,
3564 Build_Get_Unique_RP_Call
3565 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3567 -- Return the newly created value
3569 Append_To (Proc_Statements,
3570 Make_Simple_Return_Statement (Loc,
3572 Unchecked_Convert_To (Fat_Type,
3573 New_Occurrence_Of (Stub_Ptr, Loc))));
3576 Make_Function_Specification (Loc,
3577 Defining_Unit_Name => Proc,
3578 Parameter_Specifications => New_List (
3579 Make_Parameter_Specification (Loc,
3580 Defining_Identifier => Package_Name,
3582 New_Occurrence_Of (Standard_String, Loc)),
3584 Make_Parameter_Specification (Loc,
3585 Defining_Identifier => Subp_Id,
3587 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3589 Make_Parameter_Specification (Loc,
3590 Defining_Identifier => Asynch_P,
3592 New_Occurrence_Of (Standard_Boolean, Loc)),
3594 Make_Parameter_Specification (Loc,
3595 Defining_Identifier => All_Calls_Remote,
3597 New_Occurrence_Of (Standard_Boolean, Loc))),
3599 Result_Definition =>
3600 New_Occurrence_Of (Fat_Type, Loc));
3602 -- Set the kind and return type of the function to prevent
3603 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3605 Set_Ekind (Proc, E_Function);
3606 Set_Etype (Proc, Fat_Type);
3609 Make_Subprogram_Body (Loc,
3610 Specification => Proc_Spec,
3611 Declarations => Proc_Decls,
3612 Handled_Statement_Sequence =>
3613 Make_Handled_Sequence_Of_Statements (Loc,
3614 Statements => Proc_Statements)));
3616 Set_TSS (Fat_Type, Proc);
3617 end Add_RAS_Access_TSS;
3619 -----------------------
3620 -- Add_RAST_Features --
3621 -----------------------
3623 procedure Add_RAST_Features
3624 (Vis_Decl : Node_Id;
3625 RAS_Type : Entity_Id)
3627 pragma Warnings (Off);
3628 pragma Unreferenced (RAS_Type);
3629 pragma Warnings (On);
3631 Add_RAS_Access_TSS (Vis_Decl);
3632 end Add_RAST_Features;
3634 -----------------------------------------
3635 -- Add_Receiving_Stubs_To_Declarations --
3636 -----------------------------------------
3638 procedure Add_Receiving_Stubs_To_Declarations
3639 (Pkg_Spec : Node_Id;
3643 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3645 Request_Parameter : Node_Id;
3647 Pkg_RPC_Receiver : constant Entity_Id :=
3648 Make_Defining_Identifier (Loc,
3649 New_Internal_Name ('H'));
3650 Pkg_RPC_Receiver_Statements : List_Id;
3651 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3652 Pkg_RPC_Receiver_Body : Node_Id;
3653 -- A Pkg_RPC_Receiver is built to decode the request
3655 Lookup_RAS_Info : constant Entity_Id :=
3656 Make_Defining_Identifier (Loc,
3657 Chars => New_Internal_Name ('R'));
3658 -- A remote subprogram is created to allow peers to look up
3659 -- RAS information using subprogram ids.
3661 Subp_Id : Entity_Id;
3662 Subp_Index : Entity_Id;
3663 -- Subprogram_Id as read from the incoming stream
3665 Current_Declaration : Node_Id;
3666 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3667 Current_Stubs : Node_Id;
3669 Subp_Info_Array : constant Entity_Id :=
3670 Make_Defining_Identifier (Loc,
3671 Chars => New_Internal_Name ('I'));
3673 Subp_Info_List : constant List_Id := New_List;
3675 Register_Pkg_Actuals : constant List_Id := New_List;
3677 All_Calls_Remote_E : Entity_Id;
3678 Proxy_Object_Addr : Entity_Id;
3680 procedure Append_Stubs_To
3681 (RPC_Receiver_Cases : List_Id;
3683 Subprogram_Number : Int);
3684 -- Add one case to the specified RPC receiver case list
3685 -- associating Subprogram_Number with the subprogram declared
3686 -- by Declaration, for which we have receiving stubs in Stubs.
3688 ---------------------
3689 -- Append_Stubs_To --
3690 ---------------------
3692 procedure Append_Stubs_To
3693 (RPC_Receiver_Cases : List_Id;
3695 Subprogram_Number : Int)
3698 Append_To (RPC_Receiver_Cases,
3699 Make_Case_Statement_Alternative (Loc,
3701 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3704 Make_Procedure_Call_Statement (Loc,
3707 Defining_Entity (Stubs), Loc),
3708 Parameter_Associations => New_List (
3709 New_Occurrence_Of (Request_Parameter, Loc))))));
3710 end Append_Stubs_To;
3712 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3715 -- Building receiving stubs consist in several operations:
3717 -- - a package RPC receiver must be built. This subprogram
3718 -- will get a Subprogram_Id from the incoming stream
3719 -- and will dispatch the call to the right subprogram;
3721 -- - a receiving stub for each subprogram visible in the package
3722 -- spec. This stub will read all the parameters from the stream,
3723 -- and put the result as well as the exception occurrence in the
3726 -- - a dummy package with an empty spec and a body made of an
3727 -- elaboration part, whose job is to register the receiving
3728 -- part of this RCI package on the name server. This is done
3729 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3731 Build_RPC_Receiver_Body (
3732 RPC_Receiver => Pkg_RPC_Receiver,
3733 Request => Request_Parameter,
3735 Subp_Index => Subp_Index,
3736 Stmts => Pkg_RPC_Receiver_Statements,
3737 Decl => Pkg_RPC_Receiver_Body);
3738 pragma Assert (Subp_Id = Subp_Index);
3740 -- A null subp_id denotes a call through a RAS, in which case the
3741 -- next Uint_64 element in the stream is the address of the local
3742 -- proxy object, from which we can retrieve the actual subprogram id.
3744 Append_To (Pkg_RPC_Receiver_Statements,
3745 Make_Implicit_If_Statement (Pkg_Spec,
3748 New_Occurrence_Of (Subp_Id, Loc),
3749 Make_Integer_Literal (Loc, 0)),
3750 Then_Statements => New_List (
3751 Make_Assignment_Statement (Loc,
3753 New_Occurrence_Of (Subp_Id, Loc),
3755 Make_Selected_Component (Loc,
3757 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3758 OK_Convert_To (RTE (RE_Address),
3759 Make_Attribute_Reference (Loc,
3761 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3764 Expressions => New_List (
3765 Make_Selected_Component (Loc,
3766 Prefix => Request_Parameter,
3767 Selector_Name => Name_Params))))),
3769 Make_Identifier (Loc, Name_Subp_Id))))));
3771 -- Build a subprogram for RAS information lookups
3773 Current_Declaration :=
3774 Make_Subprogram_Declaration (Loc,
3776 Make_Function_Specification (Loc,
3777 Defining_Unit_Name =>
3779 Parameter_Specifications => New_List (
3780 Make_Parameter_Specification (Loc,
3781 Defining_Identifier =>
3782 Make_Defining_Identifier (Loc, Name_Subp_Id),
3786 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3787 Result_Definition =>
3788 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3789 Append_To (Decls, Current_Declaration);
3790 Analyze (Current_Declaration);
3792 Current_Stubs := Build_Subprogram_Receiving_Stubs
3793 (Vis_Decl => Current_Declaration,
3794 Asynchronous => False);
3795 Append_To (Decls, Current_Stubs);
3796 Analyze (Current_Stubs);
3798 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3801 Subprogram_Number => 1);
3803 -- For each subprogram, the receiving stub will be built and a
3804 -- case statement will be made on the Subprogram_Id to dispatch
3805 -- to the right subprogram.
3807 All_Calls_Remote_E :=
3809 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3811 Overload_Counter_Table.Reset;
3813 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3814 while Present (Current_Declaration) loop
3815 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3816 and then Comes_From_Source (Current_Declaration)
3819 Loc : constant Source_Ptr := Sloc (Current_Declaration);
3820 -- While specifically processing Current_Declaration, use
3821 -- its Sloc as the location of all generated nodes.
3823 Subp_Def : constant Entity_Id :=
3825 (Specification (Current_Declaration));
3827 Subp_Val : String_Id;
3828 pragma Warnings (Off, Subp_Val);
3831 -- Build receiving stub
3834 Build_Subprogram_Receiving_Stubs
3835 (Vis_Decl => Current_Declaration,
3837 Nkind (Specification (Current_Declaration)) =
3838 N_Procedure_Specification
3839 and then Is_Asynchronous (Subp_Def));
3841 Append_To (Decls, Current_Stubs);
3842 Analyze (Current_Stubs);
3846 Add_RAS_Proxy_And_Analyze (Decls,
3847 Vis_Decl => Current_Declaration,
3848 All_Calls_Remote_E => All_Calls_Remote_E,
3849 Proxy_Object_Addr => Proxy_Object_Addr);
3851 -- Compute distribution identifier
3853 Assign_Subprogram_Identifier
3855 Current_Subprogram_Number,
3859 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
3861 -- Add subprogram descriptor (RCI_Subp_Info) to the
3862 -- subprograms table for this receiver. The aggregate
3863 -- below must be kept consistent with the declaration
3864 -- of type RCI_Subp_Info in System.Partition_Interface.
3866 Append_To (Subp_Info_List,
3867 Make_Component_Association (Loc,
3868 Choices => New_List (
3869 Make_Integer_Literal (Loc,
3870 Current_Subprogram_Number)),
3872 Make_Aggregate (Loc,
3873 Component_Associations => New_List (
3874 Make_Component_Association (Loc,
3875 Choices => New_List (
3876 Make_Identifier (Loc, Name_Addr)),
3879 Proxy_Object_Addr, Loc))))));
3881 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3884 Subprogram_Number =>
3885 Current_Subprogram_Number);
3888 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3891 Next (Current_Declaration);
3894 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3895 -- rather than raising an exception since we do not want someone
3896 -- to crash a remote partition by sending invalid subprogram ids.
3897 -- This is consistent with the other parts of the case statement
3898 -- since even in presence of incorrect parameters in the stream,
3899 -- every exception will be caught and (if the subprogram is not an
3900 -- APC) put into the result stream and sent away.
3902 Append_To (Pkg_RPC_Receiver_Cases,
3903 Make_Case_Statement_Alternative (Loc,
3905 New_List (Make_Others_Choice (Loc)),
3907 New_List (Make_Null_Statement (Loc))));
3909 Append_To (Pkg_RPC_Receiver_Statements,
3910 Make_Case_Statement (Loc,
3912 New_Occurrence_Of (Subp_Id, Loc),
3913 Alternatives => Pkg_RPC_Receiver_Cases));
3916 Make_Object_Declaration (Loc,
3917 Defining_Identifier => Subp_Info_Array,
3918 Constant_Present => True,
3919 Aliased_Present => True,
3920 Object_Definition =>
3921 Make_Subtype_Indication (Loc,
3923 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3925 Make_Index_Or_Discriminant_Constraint (Loc,
3928 Low_Bound => Make_Integer_Literal (Loc,
3929 First_RCI_Subprogram_Id),
3931 Make_Integer_Literal (Loc,
3932 First_RCI_Subprogram_Id
3933 + List_Length (Subp_Info_List) - 1)))))));
3935 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3936 -- has zero length, and the declaration is for an empty array, in
3937 -- which case no initialization aggregate must be generated.
3939 if Present (First (Subp_Info_List)) then
3940 Set_Expression (Last (Decls),
3941 Make_Aggregate (Loc,
3942 Component_Associations => Subp_Info_List));
3944 -- No initialization provided: remove CONSTANT so that the
3945 -- declaration is not an incomplete deferred constant.
3948 Set_Constant_Present (Last (Decls), False);
3951 Analyze (Last (Decls));
3954 Subp_Info_Addr : Node_Id;
3955 -- Return statement for Lookup_RAS_Info: address of the subprogram
3956 -- information record for the requested subprogram id.
3959 if Present (First (Subp_Info_List)) then
3961 Make_Selected_Component (Loc,
3963 Make_Indexed_Component (Loc,
3965 New_Occurrence_Of (Subp_Info_Array, Loc),
3966 Expressions => New_List (
3967 Convert_To (Standard_Integer,
3968 Make_Identifier (Loc, Name_Subp_Id)))),
3970 Make_Identifier (Loc, Name_Addr));
3972 -- Case of no visible subprogram: just raise Constraint_Error, we
3973 -- know for sure we got junk from a remote partition.
3977 Make_Raise_Constraint_Error (Loc,
3978 Reason => CE_Range_Check_Failed);
3979 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
3983 Make_Subprogram_Body (Loc,
3985 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
3988 Handled_Statement_Sequence =>
3989 Make_Handled_Sequence_Of_Statements (Loc,
3990 Statements => New_List (
3991 Make_Simple_Return_Statement (Loc,
3993 OK_Convert_To (RTE (RE_Unsigned_64),
3994 Subp_Info_Addr))))));
3997 Analyze (Last (Decls));
3999 Append_To (Decls, Pkg_RPC_Receiver_Body);
4000 Analyze (Last (Decls));
4002 Get_Library_Unit_Name_String (Pkg_Spec);
4006 Append_To (Register_Pkg_Actuals,
4007 Make_String_Literal (Loc,
4008 Strval => String_From_Name_Buffer));
4012 Append_To (Register_Pkg_Actuals,
4013 Make_Attribute_Reference (Loc,
4015 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
4017 Name_Unrestricted_Access));
4021 Append_To (Register_Pkg_Actuals,
4022 Make_Attribute_Reference (Loc,
4024 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
4030 Append_To (Register_Pkg_Actuals,
4031 Make_Attribute_Reference (Loc,
4033 New_Occurrence_Of (Subp_Info_Array, Loc),
4039 Append_To (Register_Pkg_Actuals,
4040 Make_Attribute_Reference (Loc,
4042 New_Occurrence_Of (Subp_Info_Array, Loc),
4046 -- Generate the call
4049 Make_Procedure_Call_Statement (Loc,
4051 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
4052 Parameter_Associations => Register_Pkg_Actuals));
4053 Analyze (Last (Stmts));
4054 end Add_Receiving_Stubs_To_Declarations;
4056 ---------------------------------
4057 -- Build_General_Calling_Stubs --
4058 ---------------------------------
4060 procedure Build_General_Calling_Stubs
4062 Statements : List_Id;
4063 Target_Partition : Entity_Id;
4064 Target_RPC_Receiver : Node_Id;
4065 Subprogram_Id : Node_Id;
4066 Asynchronous : Node_Id := Empty;
4067 Is_Known_Asynchronous : Boolean := False;
4068 Is_Known_Non_Asynchronous : Boolean := False;
4069 Is_Function : Boolean;
4071 Stub_Type : Entity_Id := Empty;
4072 RACW_Type : Entity_Id := Empty;
4075 Loc : constant Source_Ptr := Sloc (Nod);
4077 Stream_Parameter : Node_Id;
4078 -- Name of the stream used to transmit parameters to the
4081 Result_Parameter : Node_Id;
4082 -- Name of the result parameter (in non-APC cases) which get the
4083 -- result of the remote subprogram.
4085 Exception_Return_Parameter : Node_Id;
4086 -- Name of the parameter which will hold the exception sent by the
4087 -- remote subprogram.
4089 Current_Parameter : Node_Id;
4090 -- Current parameter being handled
4092 Ordered_Parameters_List : constant List_Id :=
4093 Build_Ordered_Parameters_List (Spec);
4095 Asynchronous_Statements : List_Id := No_List;
4096 Non_Asynchronous_Statements : List_Id := No_List;
4097 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4099 Extra_Formal_Statements : constant List_Id := New_List;
4100 -- List of statements for extra formal parameters. It will appear
4101 -- after the regular statements for writing out parameters.
4103 pragma Warnings (Off);
4104 pragma Unreferenced (RACW_Type);
4105 -- Used only for the PolyORB case
4106 pragma Warnings (On);
4109 -- The general form of a calling stub for a given subprogram is:
4111 -- procedure X (...) is P : constant Partition_ID :=
4112 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4113 -- System.RPC.Params_Stream_Type (0); begin
4114 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4115 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4116 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4117 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4119 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4121 -- There are some variations: Do_APC is called for an asynchronous
4122 -- procedure and the part after the call is completely ommitted as
4123 -- well as the declaration of Result. For a function call, 'Input is
4124 -- always used to read the result even if it is constrained.
4127 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4130 Make_Object_Declaration (Loc,
4131 Defining_Identifier => Stream_Parameter,
4132 Aliased_Present => True,
4133 Object_Definition =>
4134 Make_Subtype_Indication (Loc,
4136 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4138 Make_Index_Or_Discriminant_Constraint (Loc,
4140 New_List (Make_Integer_Literal (Loc, 0))))));
4142 if not Is_Known_Asynchronous then
4144 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4147 Make_Object_Declaration (Loc,
4148 Defining_Identifier => Result_Parameter,
4149 Aliased_Present => True,
4150 Object_Definition =>
4151 Make_Subtype_Indication (Loc,
4153 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4155 Make_Index_Or_Discriminant_Constraint (Loc,
4157 New_List (Make_Integer_Literal (Loc, 0))))));
4159 Exception_Return_Parameter :=
4160 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4163 Make_Object_Declaration (Loc,
4164 Defining_Identifier => Exception_Return_Parameter,
4165 Object_Definition =>
4166 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4169 Result_Parameter := Empty;
4170 Exception_Return_Parameter := Empty;
4173 -- Put first the RPC receiver corresponding to the remote package
4175 Append_To (Statements,
4176 Make_Attribute_Reference (Loc,
4178 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4179 Attribute_Name => Name_Write,
4180 Expressions => New_List (
4181 Make_Attribute_Reference (Loc,
4183 New_Occurrence_Of (Stream_Parameter, Loc),
4186 Target_RPC_Receiver)));
4188 -- Then put the Subprogram_Id of the subprogram we want to call in
4191 Append_To (Statements,
4192 Make_Attribute_Reference (Loc,
4194 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4197 Expressions => New_List (
4198 Make_Attribute_Reference (Loc,
4200 New_Occurrence_Of (Stream_Parameter, Loc),
4201 Attribute_Name => Name_Access),
4204 Current_Parameter := First (Ordered_Parameters_List);
4205 while Present (Current_Parameter) loop
4207 Typ : constant Node_Id :=
4208 Parameter_Type (Current_Parameter);
4210 Constrained : Boolean;
4212 Extra_Parameter : Entity_Id;
4215 if Is_RACW_Controlling_Formal
4216 (Current_Parameter, Stub_Type)
4218 -- In the case of a controlling formal argument, we marshall
4219 -- its addr field rather than the local stub.
4221 Append_To (Statements,
4222 Pack_Node_Into_Stream (Loc,
4223 Stream => Stream_Parameter,
4225 Make_Selected_Component (Loc,
4227 Defining_Identifier (Current_Parameter),
4228 Selector_Name => Name_Addr),
4229 Etyp => RTE (RE_Unsigned_64)));
4232 Value := New_Occurrence_Of
4233 (Defining_Identifier (Current_Parameter), Loc);
4235 -- Access type parameters are transmitted as in out
4236 -- parameters. However, a dereference is needed so that
4237 -- we marshall the designated object.
4239 if Nkind (Typ) = N_Access_Definition then
4240 Value := Make_Explicit_Dereference (Loc, Value);
4241 Etyp := Etype (Subtype_Mark (Typ));
4243 Etyp := Etype (Typ);
4246 Constrained := not Transmit_As_Unconstrained (Etyp);
4248 -- Any parameter but unconstrained out parameters are
4249 -- transmitted to the peer.
4251 if In_Present (Current_Parameter)
4252 or else not Out_Present (Current_Parameter)
4253 or else not Constrained
4255 Append_To (Statements,
4256 Make_Attribute_Reference (Loc,
4258 New_Occurrence_Of (Etyp, Loc),
4260 Output_From_Constrained (Constrained),
4261 Expressions => New_List (
4262 Make_Attribute_Reference (Loc,
4264 New_Occurrence_Of (Stream_Parameter, Loc),
4265 Attribute_Name => Name_Access),
4270 -- If the current parameter has a dynamic constrained status,
4271 -- then this status is transmitted as well.
4272 -- This should be done for accessibility as well ???
4274 if Nkind (Typ) /= N_Access_Definition
4275 and then Need_Extra_Constrained (Current_Parameter)
4277 -- In this block, we do not use the extra formal that has
4278 -- been created because it does not exist at the time of
4279 -- expansion when building calling stubs for remote access
4280 -- to subprogram types. We create an extra variable of this
4281 -- type and push it in the stream after the regular
4284 Extra_Parameter := Make_Defining_Identifier
4285 (Loc, New_Internal_Name ('P'));
4288 Make_Object_Declaration (Loc,
4289 Defining_Identifier => Extra_Parameter,
4290 Constant_Present => True,
4291 Object_Definition =>
4292 New_Occurrence_Of (Standard_Boolean, Loc),
4294 Make_Attribute_Reference (Loc,
4297 Defining_Identifier (Current_Parameter), Loc),
4298 Attribute_Name => Name_Constrained)));
4300 Append_To (Extra_Formal_Statements,
4301 Make_Attribute_Reference (Loc,
4303 New_Occurrence_Of (Standard_Boolean, Loc),
4306 Expressions => New_List (
4307 Make_Attribute_Reference (Loc,
4309 New_Occurrence_Of (Stream_Parameter, Loc),
4312 New_Occurrence_Of (Extra_Parameter, Loc))));
4315 Next (Current_Parameter);
4319 -- Append the formal statements list to the statements
4321 Append_List_To (Statements, Extra_Formal_Statements);
4323 if not Is_Known_Non_Asynchronous then
4325 -- Build the call to System.RPC.Do_APC
4327 Asynchronous_Statements := New_List (
4328 Make_Procedure_Call_Statement (Loc,
4330 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4331 Parameter_Associations => New_List (
4332 New_Occurrence_Of (Target_Partition, Loc),
4333 Make_Attribute_Reference (Loc,
4335 New_Occurrence_Of (Stream_Parameter, Loc),
4339 Asynchronous_Statements := No_List;
4342 if not Is_Known_Asynchronous then
4344 -- Build the call to System.RPC.Do_RPC
4346 Non_Asynchronous_Statements := New_List (
4347 Make_Procedure_Call_Statement (Loc,
4349 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4350 Parameter_Associations => New_List (
4351 New_Occurrence_Of (Target_Partition, Loc),
4353 Make_Attribute_Reference (Loc,
4355 New_Occurrence_Of (Stream_Parameter, Loc),
4359 Make_Attribute_Reference (Loc,
4361 New_Occurrence_Of (Result_Parameter, Loc),
4365 -- Read the exception occurrence from the result stream and
4366 -- reraise it. It does no harm if this is a Null_Occurrence since
4367 -- this does nothing.
4369 Append_To (Non_Asynchronous_Statements,
4370 Make_Attribute_Reference (Loc,
4372 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4377 Expressions => New_List (
4378 Make_Attribute_Reference (Loc,
4380 New_Occurrence_Of (Result_Parameter, Loc),
4383 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4385 Append_To (Non_Asynchronous_Statements,
4386 Make_Procedure_Call_Statement (Loc,
4388 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4389 Parameter_Associations => New_List (
4390 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4394 -- If this is a function call, then read the value and return
4395 -- it. The return value is written/read using 'Output/'Input.
4397 Append_To (Non_Asynchronous_Statements,
4398 Make_Tag_Check (Loc,
4399 Make_Simple_Return_Statement (Loc,
4401 Make_Attribute_Reference (Loc,
4404 Etype (Result_Definition (Spec)), Loc),
4406 Attribute_Name => Name_Input,
4408 Expressions => New_List (
4409 Make_Attribute_Reference (Loc,
4411 New_Occurrence_Of (Result_Parameter, Loc),
4412 Attribute_Name => Name_Access))))));
4415 -- Loop around parameters and assign out (or in out)
4416 -- parameters. In the case of RACW, controlling arguments
4417 -- cannot possibly have changed since they are remote, so we do
4418 -- not read them from the stream.
4420 Current_Parameter := First (Ordered_Parameters_List);
4421 while Present (Current_Parameter) loop
4423 Typ : constant Node_Id :=
4424 Parameter_Type (Current_Parameter);
4431 (Defining_Identifier (Current_Parameter), Loc);
4433 if Nkind (Typ) = N_Access_Definition then
4434 Value := Make_Explicit_Dereference (Loc, Value);
4435 Etyp := Etype (Subtype_Mark (Typ));
4437 Etyp := Etype (Typ);
4440 if (Out_Present (Current_Parameter)
4441 or else Nkind (Typ) = N_Access_Definition)
4442 and then Etyp /= Stub_Type
4444 Append_To (Non_Asynchronous_Statements,
4445 Make_Attribute_Reference (Loc,
4447 New_Occurrence_Of (Etyp, Loc),
4449 Attribute_Name => Name_Read,
4451 Expressions => New_List (
4452 Make_Attribute_Reference (Loc,
4454 New_Occurrence_Of (Result_Parameter, Loc),
4461 Next (Current_Parameter);
4466 if Is_Known_Asynchronous then
4467 Append_List_To (Statements, Asynchronous_Statements);
4469 elsif Is_Known_Non_Asynchronous then
4470 Append_List_To (Statements, Non_Asynchronous_Statements);
4473 pragma Assert (Present (Asynchronous));
4474 Prepend_To (Asynchronous_Statements,
4475 Make_Attribute_Reference (Loc,
4476 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4477 Attribute_Name => Name_Write,
4478 Expressions => New_List (
4479 Make_Attribute_Reference (Loc,
4481 New_Occurrence_Of (Stream_Parameter, Loc),
4482 Attribute_Name => Name_Access),
4483 New_Occurrence_Of (Standard_True, Loc))));
4485 Prepend_To (Non_Asynchronous_Statements,
4486 Make_Attribute_Reference (Loc,
4487 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4488 Attribute_Name => Name_Write,
4489 Expressions => New_List (
4490 Make_Attribute_Reference (Loc,
4492 New_Occurrence_Of (Stream_Parameter, Loc),
4493 Attribute_Name => Name_Access),
4494 New_Occurrence_Of (Standard_False, Loc))));
4496 Append_To (Statements,
4497 Make_Implicit_If_Statement (Nod,
4498 Condition => Asynchronous,
4499 Then_Statements => Asynchronous_Statements,
4500 Else_Statements => Non_Asynchronous_Statements));
4502 end Build_General_Calling_Stubs;
4504 -----------------------------
4505 -- Build_RPC_Receiver_Body --
4506 -----------------------------
4508 procedure Build_RPC_Receiver_Body
4509 (RPC_Receiver : Entity_Id;
4510 Request : out Entity_Id;
4511 Subp_Id : out Entity_Id;
4512 Subp_Index : out Entity_Id;
4513 Stmts : out List_Id;
4516 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4518 RPC_Receiver_Spec : Node_Id;
4519 RPC_Receiver_Decls : List_Id;
4522 Request := Make_Defining_Identifier (Loc, Name_R);
4524 RPC_Receiver_Spec :=
4525 Build_RPC_Receiver_Specification
4526 (RPC_Receiver => RPC_Receiver,
4527 Request_Parameter => Request);
4529 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4530 Subp_Index := Subp_Id;
4532 -- Subp_Id may not be a constant, because in the case of the RPC
4533 -- receiver for an RCI package, when a call is received from a RAS
4534 -- dereference, it will be assigned during subsequent processing.
4536 RPC_Receiver_Decls := New_List (
4537 Make_Object_Declaration (Loc,
4538 Defining_Identifier => Subp_Id,
4539 Object_Definition =>
4540 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4542 Make_Attribute_Reference (Loc,
4544 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4545 Attribute_Name => Name_Input,
4546 Expressions => New_List (
4547 Make_Selected_Component (Loc,
4549 Selector_Name => Name_Params)))));
4554 Make_Subprogram_Body (Loc,
4555 Specification => RPC_Receiver_Spec,
4556 Declarations => RPC_Receiver_Decls,
4557 Handled_Statement_Sequence =>
4558 Make_Handled_Sequence_Of_Statements (Loc,
4559 Statements => Stmts));
4560 end Build_RPC_Receiver_Body;
4562 -----------------------
4563 -- Build_Stub_Target --
4564 -----------------------
4566 function Build_Stub_Target
4569 RCI_Locator : Entity_Id;
4570 Controlling_Parameter : Entity_Id) return RPC_Target
4572 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4574 Target_Info.Partition :=
4575 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4576 if Present (Controlling_Parameter) then
4578 Make_Object_Declaration (Loc,
4579 Defining_Identifier => Target_Info.Partition,
4580 Constant_Present => True,
4581 Object_Definition =>
4582 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4585 Make_Selected_Component (Loc,
4586 Prefix => Controlling_Parameter,
4587 Selector_Name => Name_Origin)));
4589 Target_Info.RPC_Receiver :=
4590 Make_Selected_Component (Loc,
4591 Prefix => Controlling_Parameter,
4592 Selector_Name => Name_Receiver);
4596 Make_Object_Declaration (Loc,
4597 Defining_Identifier => Target_Info.Partition,
4598 Constant_Present => True,
4599 Object_Definition =>
4600 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4603 Make_Function_Call (Loc,
4604 Name => Make_Selected_Component (Loc,
4606 Make_Identifier (Loc, Chars (RCI_Locator)),
4608 Make_Identifier (Loc,
4609 Name_Get_Active_Partition_ID)))));
4611 Target_Info.RPC_Receiver :=
4612 Make_Selected_Component (Loc,
4614 Make_Identifier (Loc, Chars (RCI_Locator)),
4616 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4619 end Build_Stub_Target;
4621 ---------------------
4622 -- Build_Stub_Type --
4623 ---------------------
4625 procedure Build_Stub_Type
4626 (RACW_Type : Entity_Id;
4627 Stub_Type : Entity_Id;
4628 Stub_Type_Decl : out Node_Id;
4629 RPC_Receiver_Decl : out Node_Id)
4631 Loc : constant Source_Ptr := Sloc (Stub_Type);
4632 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4636 Make_Full_Type_Declaration (Loc,
4637 Defining_Identifier => Stub_Type,
4639 Make_Record_Definition (Loc,
4640 Tagged_Present => True,
4641 Limited_Present => True,
4643 Make_Component_List (Loc,
4644 Component_Items => New_List (
4646 Make_Component_Declaration (Loc,
4647 Defining_Identifier =>
4648 Make_Defining_Identifier (Loc, Name_Origin),
4649 Component_Definition =>
4650 Make_Component_Definition (Loc,
4651 Aliased_Present => False,
4652 Subtype_Indication =>
4654 RTE (RE_Partition_ID), Loc))),
4656 Make_Component_Declaration (Loc,
4657 Defining_Identifier =>
4658 Make_Defining_Identifier (Loc, Name_Receiver),
4659 Component_Definition =>
4660 Make_Component_Definition (Loc,
4661 Aliased_Present => False,
4662 Subtype_Indication =>
4663 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4665 Make_Component_Declaration (Loc,
4666 Defining_Identifier =>
4667 Make_Defining_Identifier (Loc, Name_Addr),
4668 Component_Definition =>
4669 Make_Component_Definition (Loc,
4670 Aliased_Present => False,
4671 Subtype_Indication =>
4672 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4674 Make_Component_Declaration (Loc,
4675 Defining_Identifier =>
4676 Make_Defining_Identifier (Loc, Name_Asynchronous),
4677 Component_Definition =>
4678 Make_Component_Definition (Loc,
4679 Aliased_Present => False,
4680 Subtype_Indication =>
4682 Standard_Boolean, Loc)))))));
4685 RPC_Receiver_Decl := Empty;
4688 RPC_Receiver_Request : constant Entity_Id :=
4689 Make_Defining_Identifier (Loc, Name_R);
4691 RPC_Receiver_Decl :=
4692 Make_Subprogram_Declaration (Loc,
4693 Build_RPC_Receiver_Specification (
4694 RPC_Receiver => Make_Defining_Identifier (Loc,
4695 New_Internal_Name ('R')),
4696 Request_Parameter => RPC_Receiver_Request));
4699 end Build_Stub_Type;
4701 --------------------------------------
4702 -- Build_Subprogram_Receiving_Stubs --
4703 --------------------------------------
4705 function Build_Subprogram_Receiving_Stubs
4706 (Vis_Decl : Node_Id;
4707 Asynchronous : Boolean;
4708 Dynamically_Asynchronous : Boolean := False;
4709 Stub_Type : Entity_Id := Empty;
4710 RACW_Type : Entity_Id := Empty;
4711 Parent_Primitive : Entity_Id := Empty) return Node_Id
4713 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4715 Request_Parameter : constant Entity_Id :=
4716 Make_Defining_Identifier (Loc,
4717 New_Internal_Name ('R'));
4718 -- Formal parameter for receiving stubs: a descriptor for an incoming
4721 Decls : constant List_Id := New_List;
4722 -- All the parameters will get declared before calling the real
4723 -- subprograms. Also the out parameters will be declared.
4725 Statements : constant List_Id := New_List;
4727 Extra_Formal_Statements : constant List_Id := New_List;
4728 -- Statements concerning extra formal parameters
4730 After_Statements : constant List_Id := New_List;
4731 -- Statements to be executed after the subprogram call
4733 Inner_Decls : List_Id := No_List;
4734 -- In case of a function, the inner declarations are needed since
4735 -- the result may be unconstrained.
4737 Excep_Handlers : List_Id := No_List;
4738 Excep_Choice : Entity_Id;
4739 Excep_Code : List_Id;
4741 Parameter_List : constant List_Id := New_List;
4742 -- List of parameters to be passed to the subprogram
4744 Current_Parameter : Node_Id;
4746 Ordered_Parameters_List : constant List_Id :=
4747 Build_Ordered_Parameters_List
4748 (Specification (Vis_Decl));
4750 Subp_Spec : Node_Id;
4751 -- Subprogram specification
4753 Called_Subprogram : Node_Id;
4754 -- The subprogram to call
4756 Null_Raise_Statement : Node_Id;
4758 Dynamic_Async : Entity_Id;
4761 if Present (RACW_Type) then
4762 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4764 Called_Subprogram :=
4766 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4769 if Dynamically_Asynchronous then
4771 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4773 Dynamic_Async := Empty;
4776 if not Asynchronous or Dynamically_Asynchronous then
4778 -- The first statement after the subprogram call is a statement to
4779 -- write a Null_Occurrence into the result stream.
4781 Null_Raise_Statement :=
4782 Make_Attribute_Reference (Loc,
4784 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4785 Attribute_Name => Name_Write,
4786 Expressions => New_List (
4787 Make_Selected_Component (Loc,
4788 Prefix => Request_Parameter,
4789 Selector_Name => Name_Result),
4790 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4792 if Dynamically_Asynchronous then
4793 Null_Raise_Statement :=
4794 Make_Implicit_If_Statement (Vis_Decl,
4796 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4797 Then_Statements => New_List (Null_Raise_Statement));
4800 Append_To (After_Statements, Null_Raise_Statement);
4803 -- Loop through every parameter and get its value from the stream. If
4804 -- the parameter is unconstrained, then the parameter is read using
4805 -- 'Input at the point of declaration.
4807 Current_Parameter := First (Ordered_Parameters_List);
4808 while Present (Current_Parameter) loop
4811 Constrained : Boolean;
4813 Need_Extra_Constrained : Boolean;
4814 -- True when an Extra_Constrained actual is required
4816 Object : constant Entity_Id :=
4817 Make_Defining_Identifier (Loc,
4818 New_Internal_Name ('P'));
4820 Expr : Node_Id := Empty;
4822 Is_Controlling_Formal : constant Boolean :=
4823 Is_RACW_Controlling_Formal
4824 (Current_Parameter, Stub_Type);
4827 if Is_Controlling_Formal then
4829 -- We have a controlling formal parameter. Read its address
4830 -- rather than a real object. The address is in Unsigned_64
4833 Etyp := RTE (RE_Unsigned_64);
4835 Etyp := Etype (Parameter_Type (Current_Parameter));
4838 Constrained := not Transmit_As_Unconstrained (Etyp);
4840 if In_Present (Current_Parameter)
4841 or else not Out_Present (Current_Parameter)
4842 or else not Constrained
4843 or else Is_Controlling_Formal
4845 -- If an input parameter is constrained, then the read of
4846 -- the parameter is deferred until the beginning of the
4847 -- subprogram body. If it is unconstrained, then an
4848 -- expression is built for the object declaration and the
4849 -- variable is set using 'Input instead of 'Read. Note that
4850 -- this deferral does not change the order in which the
4851 -- actuals are read because Build_Ordered_Parameter_List
4852 -- puts them unconstrained first.
4855 Append_To (Statements,
4856 Make_Attribute_Reference (Loc,
4857 Prefix => New_Occurrence_Of (Etyp, Loc),
4858 Attribute_Name => Name_Read,
4859 Expressions => New_List (
4860 Make_Selected_Component (Loc,
4861 Prefix => Request_Parameter,
4862 Selector_Name => Name_Params),
4863 New_Occurrence_Of (Object, Loc))));
4867 -- Build and append Input_With_Tag_Check function
4870 Input_With_Tag_Check (Loc,
4872 Stream => Make_Selected_Component (Loc,
4873 Prefix => Request_Parameter,
4874 Selector_Name => Name_Params)));
4876 -- Prepare function call expression
4878 Expr := Make_Function_Call (Loc,
4879 New_Occurrence_Of (Defining_Unit_Name
4880 (Specification (Last (Decls))), Loc));
4884 Need_Extra_Constrained :=
4885 Nkind (Parameter_Type (Current_Parameter)) /=
4888 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4890 Present (Extra_Constrained
4891 (Defining_Identifier (Current_Parameter)));
4893 -- We may not associate an extra constrained actual to a
4894 -- constant object, so if one is needed, declare the actual
4895 -- as a variable even if it won't be modified.
4897 Build_Actual_Object_Declaration
4900 Variable => Need_Extra_Constrained
4901 or else Out_Present (Current_Parameter),
4905 -- An out parameter may be written back using a 'Write
4906 -- attribute instead of a 'Output because it has been
4907 -- constrained by the parameter given to the caller. Note that
4908 -- out controlling arguments in the case of a RACW are not put
4909 -- back in the stream because the pointer on them has not
4912 if Out_Present (Current_Parameter)
4914 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4916 Append_To (After_Statements,
4917 Make_Attribute_Reference (Loc,
4918 Prefix => New_Occurrence_Of (Etyp, Loc),
4919 Attribute_Name => Name_Write,
4920 Expressions => New_List (
4921 Make_Selected_Component (Loc,
4922 Prefix => Request_Parameter,
4923 Selector_Name => Name_Result),
4924 New_Occurrence_Of (Object, Loc))));
4927 -- For RACW controlling formals, the Etyp of Object is always
4928 -- an RACW, even if the parameter is not of an anonymous access
4929 -- type. In such case, we need to dereference it at call time.
4931 if Is_Controlling_Formal then
4932 if Nkind (Parameter_Type (Current_Parameter)) /=
4935 Append_To (Parameter_List,
4936 Make_Parameter_Association (Loc,
4939 Defining_Identifier (Current_Parameter), Loc),
4940 Explicit_Actual_Parameter =>
4941 Make_Explicit_Dereference (Loc,
4942 Unchecked_Convert_To (RACW_Type,
4943 OK_Convert_To (RTE (RE_Address),
4944 New_Occurrence_Of (Object, Loc))))));
4947 Append_To (Parameter_List,
4948 Make_Parameter_Association (Loc,
4951 Defining_Identifier (Current_Parameter), Loc),
4952 Explicit_Actual_Parameter =>
4953 Unchecked_Convert_To (RACW_Type,
4954 OK_Convert_To (RTE (RE_Address),
4955 New_Occurrence_Of (Object, Loc)))));
4959 Append_To (Parameter_List,
4960 Make_Parameter_Association (Loc,
4963 Defining_Identifier (Current_Parameter), Loc),
4964 Explicit_Actual_Parameter =>
4965 New_Occurrence_Of (Object, Loc)));
4968 -- If the current parameter needs an extra formal, then read it
4969 -- from the stream and set the corresponding semantic field in
4970 -- the variable. If the kind of the parameter identifier is
4971 -- E_Void, then this is a compiler generated parameter that
4972 -- doesn't need an extra constrained status.
4974 -- The case of Extra_Accessibility should also be handled ???
4976 if Need_Extra_Constrained then
4978 Extra_Parameter : constant Entity_Id :=
4980 (Defining_Identifier
4981 (Current_Parameter));
4983 Formal_Entity : constant Entity_Id :=
4984 Make_Defining_Identifier
4985 (Loc, Chars (Extra_Parameter));
4987 Formal_Type : constant Entity_Id :=
4988 Etype (Extra_Parameter);
4992 Make_Object_Declaration (Loc,
4993 Defining_Identifier => Formal_Entity,
4994 Object_Definition =>
4995 New_Occurrence_Of (Formal_Type, Loc)));
4997 Append_To (Extra_Formal_Statements,
4998 Make_Attribute_Reference (Loc,
4999 Prefix => New_Occurrence_Of (
5001 Attribute_Name => Name_Read,
5002 Expressions => New_List (
5003 Make_Selected_Component (Loc,
5004 Prefix => Request_Parameter,
5005 Selector_Name => Name_Params),
5006 New_Occurrence_Of (Formal_Entity, Loc))));
5008 -- Note: the call to Set_Extra_Constrained below relies
5009 -- on the fact that Object's Ekind has been set by
5010 -- Build_Actual_Object_Declaration.
5012 Set_Extra_Constrained (Object, Formal_Entity);
5017 Next (Current_Parameter);
5020 -- Append the formal statements list at the end of regular statements
5022 Append_List_To (Statements, Extra_Formal_Statements);
5024 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
5026 -- The remote subprogram is a function. We build an inner block to
5027 -- be able to hold a potentially unconstrained result in a
5031 Etyp : constant Entity_Id :=
5032 Etype (Result_Definition (Specification (Vis_Decl)));
5033 Result : constant Node_Id :=
5034 Make_Defining_Identifier (Loc,
5035 New_Internal_Name ('R'));
5037 Inner_Decls := New_List (
5038 Make_Object_Declaration (Loc,
5039 Defining_Identifier => Result,
5040 Constant_Present => True,
5041 Object_Definition => New_Occurrence_Of (Etyp, Loc),
5043 Make_Function_Call (Loc,
5044 Name => Called_Subprogram,
5045 Parameter_Associations => Parameter_List)));
5047 if Is_Class_Wide_Type (Etyp) then
5049 -- For a remote call to a function with a class-wide type,
5050 -- check that the returned value satisfies the requirements
5053 Append_To (Inner_Decls,
5054 Make_Transportable_Check (Loc,
5055 New_Occurrence_Of (Result, Loc)));
5059 Append_To (After_Statements,
5060 Make_Attribute_Reference (Loc,
5061 Prefix => New_Occurrence_Of (Etyp, Loc),
5062 Attribute_Name => Name_Output,
5063 Expressions => New_List (
5064 Make_Selected_Component (Loc,
5065 Prefix => Request_Parameter,
5066 Selector_Name => Name_Result),
5067 New_Occurrence_Of (Result, Loc))));
5070 Append_To (Statements,
5071 Make_Block_Statement (Loc,
5072 Declarations => Inner_Decls,
5073 Handled_Statement_Sequence =>
5074 Make_Handled_Sequence_Of_Statements (Loc,
5075 Statements => After_Statements)));
5078 -- The remote subprogram is a procedure. We do not need any inner
5079 -- block in this case.
5081 if Dynamically_Asynchronous then
5083 Make_Object_Declaration (Loc,
5084 Defining_Identifier => Dynamic_Async,
5085 Object_Definition =>
5086 New_Occurrence_Of (Standard_Boolean, Loc)));
5088 Append_To (Statements,
5089 Make_Attribute_Reference (Loc,
5090 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5091 Attribute_Name => Name_Read,
5092 Expressions => New_List (
5093 Make_Selected_Component (Loc,
5094 Prefix => Request_Parameter,
5095 Selector_Name => Name_Params),
5096 New_Occurrence_Of (Dynamic_Async, Loc))));
5099 Append_To (Statements,
5100 Make_Procedure_Call_Statement (Loc,
5101 Name => Called_Subprogram,
5102 Parameter_Associations => Parameter_List));
5104 Append_List_To (Statements, After_Statements);
5107 if Asynchronous and then not Dynamically_Asynchronous then
5109 -- For an asynchronous procedure, add a null exception handler
5111 Excep_Handlers := New_List (
5112 Make_Implicit_Exception_Handler (Loc,
5113 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5114 Statements => New_List (Make_Null_Statement (Loc))));
5117 -- In the other cases, if an exception is raised, then the
5118 -- exception occurrence is copied into the output stream and
5119 -- no other output parameter is written.
5122 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5124 Excep_Code := New_List (
5125 Make_Attribute_Reference (Loc,
5127 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5128 Attribute_Name => Name_Write,
5129 Expressions => New_List (
5130 Make_Selected_Component (Loc,
5131 Prefix => Request_Parameter,
5132 Selector_Name => Name_Result),
5133 New_Occurrence_Of (Excep_Choice, Loc))));
5135 if Dynamically_Asynchronous then
5136 Excep_Code := New_List (
5137 Make_Implicit_If_Statement (Vis_Decl,
5138 Condition => Make_Op_Not (Loc,
5139 New_Occurrence_Of (Dynamic_Async, Loc)),
5140 Then_Statements => Excep_Code));
5143 Excep_Handlers := New_List (
5144 Make_Implicit_Exception_Handler (Loc,
5145 Choice_Parameter => Excep_Choice,
5146 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5147 Statements => Excep_Code));
5152 Make_Procedure_Specification (Loc,
5153 Defining_Unit_Name =>
5154 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
5156 Parameter_Specifications => New_List (
5157 Make_Parameter_Specification (Loc,
5158 Defining_Identifier => Request_Parameter,
5160 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5163 Make_Subprogram_Body (Loc,
5164 Specification => Subp_Spec,
5165 Declarations => Decls,
5166 Handled_Statement_Sequence =>
5167 Make_Handled_Sequence_Of_Statements (Loc,
5168 Statements => Statements,
5169 Exception_Handlers => Excep_Handlers));
5170 end Build_Subprogram_Receiving_Stubs;
5176 function Result return Node_Id is
5178 return Make_Identifier (Loc, Name_V);
5181 ----------------------
5182 -- Stream_Parameter --
5183 ----------------------
5185 function Stream_Parameter return Node_Id is
5187 return Make_Identifier (Loc, Name_S);
5188 end Stream_Parameter;
5192 -------------------------------
5193 -- Get_And_Reset_RACW_Bodies --
5194 -------------------------------
5196 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5197 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
5198 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5200 Body_Decls : List_Id;
5201 -- Returned list of declarations
5204 if Stub_Elements = Empty_Stub_Structure then
5206 -- Stub elements may be missing as a consequence of a previously
5212 Body_Decls := Stub_Elements.Body_Decls;
5213 Stub_Elements.Body_Decls := No_List;
5214 Stubs_Table.Set (Desig, Stub_Elements);
5216 end Get_And_Reset_RACW_Bodies;
5218 -----------------------
5219 -- Get_Subprogram_Id --
5220 -----------------------
5222 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5223 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5225 pragma Assert (Result /= No_String);
5227 end Get_Subprogram_Id;
5229 -----------------------
5230 -- Get_Subprogram_Id --
5231 -----------------------
5233 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5235 return Get_Subprogram_Ids (Def).Int_Identifier;
5236 end Get_Subprogram_Id;
5238 ------------------------
5239 -- Get_Subprogram_Ids --
5240 ------------------------
5242 function Get_Subprogram_Ids
5243 (Def : Entity_Id) return Subprogram_Identifiers
5246 return Subprogram_Identifier_Table.Get (Def);
5247 end Get_Subprogram_Ids;
5253 function Hash (F : Entity_Id) return Hash_Index is
5255 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5258 function Hash (F : Name_Id) return Hash_Index is
5260 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5263 --------------------------
5264 -- Input_With_Tag_Check --
5265 --------------------------
5267 function Input_With_Tag_Check
5269 Var_Type : Entity_Id;
5270 Stream : Node_Id) return Node_Id
5274 Make_Subprogram_Body (Loc,
5275 Specification => Make_Function_Specification (Loc,
5276 Defining_Unit_Name =>
5277 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
5278 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5279 Declarations => No_List,
5280 Handled_Statement_Sequence =>
5281 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5282 Make_Tag_Check (Loc,
5283 Make_Simple_Return_Statement (Loc,
5284 Make_Attribute_Reference (Loc,
5285 Prefix => New_Occurrence_Of (Var_Type, Loc),
5286 Attribute_Name => Name_Input,
5288 New_List (Stream)))))));
5289 end Input_With_Tag_Check;
5291 --------------------------------
5292 -- Is_RACW_Controlling_Formal --
5293 --------------------------------
5295 function Is_RACW_Controlling_Formal
5296 (Parameter : Node_Id;
5297 Stub_Type : Entity_Id) return Boolean
5302 -- If the kind of the parameter is E_Void, then it is not a
5303 -- controlling formal (this can happen in the context of RAS).
5305 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5309 -- If the parameter is not a controlling formal, then it cannot
5310 -- be possibly a RACW_Controlling_Formal.
5312 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5316 Typ := Parameter_Type (Parameter);
5317 return (Nkind (Typ) = N_Access_Definition
5318 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5319 or else Etype (Typ) = Stub_Type;
5320 end Is_RACW_Controlling_Formal;
5322 ------------------------------
5323 -- Make_Transportable_Check --
5324 ------------------------------
5326 function Make_Transportable_Check
5328 Expr : Node_Id) return Node_Id is
5331 Make_Raise_Program_Error (Loc,
5334 Build_Get_Transportable (Loc,
5335 Make_Selected_Component (Loc,
5337 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5338 Reason => PE_Non_Transportable_Actual);
5339 end Make_Transportable_Check;
5341 -----------------------------
5342 -- Make_Selected_Component --
5343 -----------------------------
5345 function Make_Selected_Component
5348 Selector_Name : Name_Id) return Node_Id
5351 return Make_Selected_Component (Loc,
5352 Prefix => New_Occurrence_Of (Prefix, Loc),
5353 Selector_Name => Make_Identifier (Loc, Selector_Name));
5354 end Make_Selected_Component;
5356 --------------------
5357 -- Make_Tag_Check --
5358 --------------------
5360 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5361 Occ : constant Entity_Id :=
5362 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5365 return Make_Block_Statement (Loc,
5366 Handled_Statement_Sequence =>
5367 Make_Handled_Sequence_Of_Statements (Loc,
5368 Statements => New_List (N),
5370 Exception_Handlers => New_List (
5371 Make_Implicit_Exception_Handler (Loc,
5372 Choice_Parameter => Occ,
5374 Exception_Choices =>
5375 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5378 New_List (Make_Procedure_Call_Statement (Loc,
5380 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5381 New_List (New_Occurrence_Of (Occ, Loc))))))));
5384 ----------------------------
5385 -- Need_Extra_Constrained --
5386 ----------------------------
5388 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5389 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5391 return Out_Present (Parameter)
5392 and then Has_Discriminants (Etyp)
5393 and then not Is_Constrained (Etyp)
5394 and then not Is_Indefinite_Subtype (Etyp);
5395 end Need_Extra_Constrained;
5397 ------------------------------------
5398 -- Pack_Entity_Into_Stream_Access --
5399 ------------------------------------
5401 function Pack_Entity_Into_Stream_Access
5405 Etyp : Entity_Id := Empty) return Node_Id
5410 if Present (Etyp) then
5413 Typ := Etype (Object);
5417 Pack_Node_Into_Stream_Access (Loc,
5419 Object => New_Occurrence_Of (Object, Loc),
5421 end Pack_Entity_Into_Stream_Access;
5423 ---------------------------
5424 -- Pack_Node_Into_Stream --
5425 ---------------------------
5427 function Pack_Node_Into_Stream
5431 Etyp : Entity_Id) return Node_Id
5433 Write_Attribute : Name_Id := Name_Write;
5436 if not Is_Constrained (Etyp) then
5437 Write_Attribute := Name_Output;
5441 Make_Attribute_Reference (Loc,
5442 Prefix => New_Occurrence_Of (Etyp, Loc),
5443 Attribute_Name => Write_Attribute,
5444 Expressions => New_List (
5445 Make_Attribute_Reference (Loc,
5446 Prefix => New_Occurrence_Of (Stream, Loc),
5447 Attribute_Name => Name_Access),
5449 end Pack_Node_Into_Stream;
5451 ----------------------------------
5452 -- Pack_Node_Into_Stream_Access --
5453 ----------------------------------
5455 function Pack_Node_Into_Stream_Access
5459 Etyp : Entity_Id) return Node_Id
5461 Write_Attribute : Name_Id := Name_Write;
5464 if not Is_Constrained (Etyp) then
5465 Write_Attribute := Name_Output;
5469 Make_Attribute_Reference (Loc,
5470 Prefix => New_Occurrence_Of (Etyp, Loc),
5471 Attribute_Name => Write_Attribute,
5472 Expressions => New_List (
5475 end Pack_Node_Into_Stream_Access;
5477 ---------------------
5478 -- PolyORB_Support --
5479 ---------------------
5481 package body PolyORB_Support is
5483 -- Local subprograms
5485 procedure Add_RACW_Read_Attribute
5486 (RACW_Type : Entity_Id;
5487 Stub_Type : Entity_Id;
5488 Stub_Type_Access : Entity_Id;
5489 Body_Decls : List_Id);
5490 -- Add Read attribute for the RACW type. The declaration and attribute
5491 -- definition clauses are inserted right after the declaration of
5492 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5493 -- appended to it (case where the RACW declaration is in the main unit).
5495 procedure Add_RACW_Write_Attribute
5496 (RACW_Type : Entity_Id;
5497 Stub_Type : Entity_Id;
5498 Stub_Type_Access : Entity_Id;
5499 Body_Decls : List_Id);
5500 -- Same as above for the Write attribute
5502 procedure Add_RACW_From_Any
5503 (RACW_Type : Entity_Id;
5504 Stub_Type : Entity_Id;
5505 Stub_Type_Access : Entity_Id;
5506 Body_Decls : List_Id);
5507 -- Add the From_Any TSS for this RACW type
5509 procedure Add_RACW_To_Any
5510 (Designated_Type : Entity_Id;
5511 RACW_Type : Entity_Id;
5512 Stub_Type : Entity_Id;
5513 Stub_Type_Access : Entity_Id;
5514 Body_Decls : List_Id);
5515 -- Add the To_Any TSS for this RACW type
5517 procedure Add_RACW_TypeCode
5518 (Designated_Type : Entity_Id;
5519 RACW_Type : Entity_Id;
5520 Body_Decls : List_Id);
5521 -- Add the TypeCode TSS for this RACW type
5523 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5524 -- Add the From_Any TSS for this RAS type
5526 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5527 -- Add the To_Any TSS for this RAS type
5529 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5530 -- Add the TypeCode TSS for this RAS type
5532 procedure Add_RAS_Access_TSS (N : Node_Id);
5533 -- Add a subprogram body for RAS Access TSS
5535 -------------------------------------
5536 -- Add_Obj_RPC_Receiver_Completion --
5537 -------------------------------------
5539 procedure Add_Obj_RPC_Receiver_Completion
5542 RPC_Receiver : Entity_Id;
5543 Stub_Elements : Stub_Structure)
5545 Desig : constant Entity_Id :=
5546 Etype (Designated_Type (Stub_Elements.RACW_Type));
5549 Make_Procedure_Call_Statement (Loc,
5552 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5554 Parameter_Associations => New_List (
5558 Make_String_Literal (Loc,
5559 Full_Qualified_Name (Desig)),
5563 Make_Attribute_Reference (Loc,
5566 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5572 Make_Attribute_Reference (Loc,
5575 Defining_Identifier (
5576 Stub_Elements.RPC_Receiver_Decl), Loc),
5579 end Add_Obj_RPC_Receiver_Completion;
5581 -----------------------
5582 -- Add_RACW_Features --
5583 -----------------------
5585 procedure Add_RACW_Features
5586 (RACW_Type : Entity_Id;
5588 Stub_Type : Entity_Id;
5589 Stub_Type_Access : Entity_Id;
5590 RPC_Receiver_Decl : Node_Id;
5591 Body_Decls : List_Id)
5593 pragma Warnings (Off);
5594 pragma Unreferenced (RPC_Receiver_Decl);
5595 pragma Warnings (On);
5599 (RACW_Type => RACW_Type,
5600 Stub_Type => Stub_Type,
5601 Stub_Type_Access => Stub_Type_Access,
5602 Body_Decls => Body_Decls);
5605 (Designated_Type => Desig,
5606 RACW_Type => RACW_Type,
5607 Stub_Type => Stub_Type,
5608 Stub_Type_Access => Stub_Type_Access,
5609 Body_Decls => Body_Decls);
5611 -- In the PolyORB case, the RACW 'Read and 'Write attributes are
5612 -- implemented in terms of the From_Any and To_Any TSSs, so these
5613 -- TSSs must be expanded before 'Read and 'Write.
5615 Add_RACW_Write_Attribute
5616 (RACW_Type => RACW_Type,
5617 Stub_Type => Stub_Type,
5618 Stub_Type_Access => Stub_Type_Access,
5619 Body_Decls => Body_Decls);
5621 Add_RACW_Read_Attribute
5622 (RACW_Type => RACW_Type,
5623 Stub_Type => Stub_Type,
5624 Stub_Type_Access => Stub_Type_Access,
5625 Body_Decls => Body_Decls);
5628 (Designated_Type => Desig,
5629 RACW_Type => RACW_Type,
5630 Body_Decls => Body_Decls);
5631 end Add_RACW_Features;
5633 -----------------------
5634 -- Add_RACW_From_Any --
5635 -----------------------
5637 procedure Add_RACW_From_Any
5638 (RACW_Type : Entity_Id;
5639 Stub_Type : Entity_Id;
5640 Stub_Type_Access : Entity_Id;
5641 Body_Decls : List_Id)
5643 Loc : constant Source_Ptr := Sloc (RACW_Type);
5644 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5646 Fnam : constant Entity_Id :=
5647 Make_Defining_Identifier (Loc,
5648 Chars => New_External_Name (Chars (RACW_Type), 'F'));
5650 Func_Spec : Node_Id;
5651 Func_Decl : Node_Id;
5652 Func_Body : Node_Id;
5655 Statements : List_Id;
5656 Stub_Statements : List_Id;
5657 Local_Statements : List_Id;
5658 -- Various parts of the subprogram
5660 Any_Parameter : constant Entity_Id :=
5661 Make_Defining_Identifier (Loc, Name_A);
5663 Reference : Entity_Id;
5664 Is_Local : Entity_Id;
5666 Local_Stub : Entity_Id;
5667 Stubbed_Result : Entity_Id;
5669 Stub_Condition : Node_Id;
5670 -- An expression that determines whether we create a stub for the
5671 -- newly-unpacked RACW. Normally we create a stub only for remote
5672 -- objects, but in the case of an RACW used to implement a RAS, we
5673 -- also create a stub for local subprograms if a pragma
5674 -- All_Calls_Remote applies.
5676 Asynchronous_Flag : constant Entity_Id :=
5677 Asynchronous_Flags_Table.Get (RACW_Type);
5678 -- The flag object declared in Add_RACW_Asynchronous_Flag
5682 Make_Function_Specification (Loc,
5683 Defining_Unit_Name =>
5685 Parameter_Specifications => New_List (
5686 Make_Parameter_Specification (Loc,
5687 Defining_Identifier =>
5690 New_Occurrence_Of (RTE (RE_Any), Loc))),
5691 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5693 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5694 -- entity in the declaration spec, not those of the body spec.
5696 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5697 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5698 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5700 if No (Body_Decls) then
5704 -- Object declarations
5707 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
5709 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
5711 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
5713 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
5715 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
5718 Make_Object_Declaration (Loc,
5719 Defining_Identifier =>
5721 Object_Definition =>
5722 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5724 Make_Function_Call (Loc,
5726 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5727 Parameter_Associations => New_List (
5728 New_Occurrence_Of (Any_Parameter, Loc)))),
5730 Make_Object_Declaration (Loc,
5731 Defining_Identifier => Local_Stub,
5732 Aliased_Present => True,
5733 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
5735 Make_Object_Declaration (Loc,
5736 Defining_Identifier => Stubbed_Result,
5737 Object_Definition =>
5738 New_Occurrence_Of (Stub_Type_Access, Loc),
5740 Make_Attribute_Reference (Loc,
5742 New_Occurrence_Of (Local_Stub, Loc),
5744 Name_Unchecked_Access)),
5746 Make_Object_Declaration (Loc,
5747 Defining_Identifier => Is_Local,
5748 Object_Definition =>
5749 New_Occurrence_Of (Standard_Boolean, Loc)),
5751 Make_Object_Declaration (Loc,
5752 Defining_Identifier => Addr,
5753 Object_Definition =>
5754 New_Occurrence_Of (RTE (RE_Address), Loc)));
5756 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5758 Set_Etype (Stubbed_Result, Stub_Type_Access);
5760 -- If the ref Is_Nil, return a null pointer
5762 Statements := New_List (
5763 Make_Implicit_If_Statement (RACW_Type,
5765 Make_Function_Call (Loc,
5767 New_Occurrence_Of (RTE (RE_Is_Nil), Loc),
5768 Parameter_Associations => New_List (
5769 New_Occurrence_Of (Reference, Loc))),
5770 Then_Statements => New_List (
5771 Make_Simple_Return_Statement (Loc,
5773 Make_Null (Loc)))));
5775 Append_To (Statements,
5776 Make_Procedure_Call_Statement (Loc,
5778 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
5779 Parameter_Associations => New_List (
5780 New_Occurrence_Of (Reference, Loc),
5781 New_Occurrence_Of (Is_Local, Loc),
5782 New_Occurrence_Of (Addr, Loc))));
5784 -- If the object is located on another partition, then a stub object
5785 -- will be created with all the information needed to rebuild the
5786 -- real object at the other end. This stanza is always used in the
5787 -- case of RAS types, for which a stub is required even for local
5790 Stub_Statements := New_List (
5791 Make_Assignment_Statement (Loc,
5792 Name => Make_Selected_Component (Loc,
5793 Prefix => Stubbed_Result,
5794 Selector_Name => Name_Target),
5796 Make_Function_Call (Loc,
5798 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
5799 Parameter_Associations => New_List (
5800 New_Occurrence_Of (Reference, Loc)))),
5802 Make_Procedure_Call_Statement (Loc,
5804 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
5805 Parameter_Associations => New_List (
5806 Make_Selected_Component (Loc,
5807 Prefix => Stubbed_Result,
5808 Selector_Name => Name_Target))),
5810 Make_Assignment_Statement (Loc,
5811 Name => Make_Selected_Component (Loc,
5812 Prefix => Stubbed_Result,
5813 Selector_Name => Name_Asynchronous),
5815 New_Occurrence_Of (Asynchronous_Flag, Loc)));
5817 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5818 -- set on the stub type if, and only if, the RACW type has a pragma
5819 -- Asynchronous. This is incorrect for RACWs that implement RAS
5820 -- types, because in that case the /designated subprogram/ (not the
5821 -- type) might be asynchronous, and that causes the stub to need to
5822 -- be asynchronous too. A solution is to transport a RAS as a struct
5823 -- containing a RACW and an asynchronous flag, and to properly alter
5824 -- the Asynchronous component in the stub type in the RAS's _From_Any
5827 Append_List_To (Stub_Statements,
5828 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
5830 -- Distinguish between the local and remote cases, and execute the
5831 -- appropriate piece of code.
5833 Stub_Condition := New_Occurrence_Of (Is_Local, Loc);
5836 Stub_Condition := Make_And_Then (Loc,
5840 Make_Selected_Component (Loc,
5842 Unchecked_Convert_To (
5843 RTE (RE_RAS_Proxy_Type_Access),
5844 New_Occurrence_Of (Addr, Loc)),
5846 Make_Identifier (Loc,
5847 Name_All_Calls_Remote)));
5850 Local_Statements := New_List (
5851 Make_Simple_Return_Statement (Loc,
5853 Unchecked_Convert_To (RACW_Type,
5854 New_Occurrence_Of (Addr, Loc))));
5856 Append_To (Statements,
5857 Make_Implicit_If_Statement (RACW_Type,
5860 Then_Statements => Local_Statements,
5861 Else_Statements => Stub_Statements));
5863 Append_To (Statements,
5864 Make_Simple_Return_Statement (Loc,
5865 Expression => Unchecked_Convert_To (RACW_Type,
5866 New_Occurrence_Of (Stubbed_Result, Loc))));
5869 Make_Subprogram_Body (Loc,
5871 Copy_Specification (Loc, Func_Spec),
5872 Declarations => Decls,
5873 Handled_Statement_Sequence =>
5874 Make_Handled_Sequence_Of_Statements (Loc,
5875 Statements => Statements));
5877 Append_To (Body_Decls, Func_Body);
5878 end Add_RACW_From_Any;
5880 -----------------------------
5881 -- Add_RACW_Read_Attribute --
5882 -----------------------------
5884 procedure Add_RACW_Read_Attribute
5885 (RACW_Type : Entity_Id;
5886 Stub_Type : Entity_Id;
5887 Stub_Type_Access : Entity_Id;
5888 Body_Decls : List_Id)
5890 pragma Warnings (Off);
5891 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5892 pragma Warnings (On);
5893 Loc : constant Source_Ptr := Sloc (RACW_Type);
5895 Proc_Decl : Node_Id;
5896 Attr_Decl : Node_Id;
5898 Body_Node : Node_Id;
5901 Statements : constant List_Id := New_List;
5902 -- Various parts of the procedure
5904 Pnam : constant Entity_Id :=
5905 Make_Defining_Identifier (Loc,
5906 New_Internal_Name ('R'));
5908 Source_Ref : Entity_Id;
5909 Asynchronous_Flag : constant Entity_Id :=
5910 Asynchronous_Flags_Table.Get (RACW_Type);
5911 pragma Assert (Present (Asynchronous_Flag));
5913 function Stream_Parameter return Node_Id;
5914 function Result return Node_Id;
5915 -- Functions to create occurrences of the formal parameter names
5921 function Result return Node_Id is
5923 return Make_Identifier (Loc, Name_V);
5926 ----------------------
5927 -- Stream_Parameter --
5928 ----------------------
5930 function Stream_Parameter return Node_Id is
5932 return Make_Identifier (Loc, Name_S);
5933 end Stream_Parameter;
5935 -- Start of processing for Add_RACW_Read_Attribute
5938 Build_Stream_Procedure
5939 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
5941 Proc_Decl := Make_Subprogram_Declaration (Loc,
5942 Copy_Specification (Loc, Specification (Body_Node)));
5945 Make_Attribute_Definition_Clause (Loc,
5946 Name => New_Occurrence_Of (RACW_Type, Loc),
5950 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5952 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5953 Insert_After (Proc_Decl, Attr_Decl);
5955 if No (Body_Decls) then
5959 Source_Ref := Make_Defining_Identifier
5960 (Loc, New_Internal_Name ('R'));
5962 -- Generate object declarations
5965 Make_Object_Declaration (Loc,
5966 Defining_Identifier => Source_Ref,
5967 Object_Definition =>
5968 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5970 Append_List_To (Statements, New_List (
5971 Make_Attribute_Reference (Loc,
5973 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5974 Attribute_Name => Name_Read,
5975 Expressions => New_List (
5977 New_Occurrence_Of (Source_Ref, Loc))),
5978 Make_Assignment_Statement (Loc,
5982 PolyORB_Support.Helpers.Build_From_Any_Call (
5984 Make_Function_Call (Loc,
5986 New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5987 Parameter_Associations => New_List (
5988 New_Occurrence_Of (Source_Ref, Loc))),
5991 Set_Declarations (Body_Node, Decls);
5992 Append_To (Body_Decls, Body_Node);
5993 end Add_RACW_Read_Attribute;
5995 ---------------------
5996 -- Add_RACW_To_Any --
5997 ---------------------
5999 procedure Add_RACW_To_Any
6000 (Designated_Type : Entity_Id;
6001 RACW_Type : Entity_Id;
6002 Stub_Type : Entity_Id;
6003 Stub_Type_Access : Entity_Id;
6004 Body_Decls : List_Id)
6006 Loc : constant Source_Ptr := Sloc (RACW_Type);
6008 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
6010 Fnam : constant Entity_Id :=
6011 Make_Defining_Identifier (Loc,
6012 Chars => New_External_Name (Chars (RACW_Type), 'T'));
6014 Stub_Elements : constant Stub_Structure :=
6015 Stubs_Table.Get (Designated_Type);
6016 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6018 Func_Spec : Node_Id;
6019 Func_Decl : Node_Id;
6020 Func_Body : Node_Id;
6023 Statements : List_Id;
6024 Null_Statements : List_Id;
6025 Local_Statements : List_Id := No_List;
6026 Stub_Statements : List_Id;
6028 -- Various parts of the subprogram
6030 RACW_Parameter : constant Entity_Id :=
6031 Make_Defining_Identifier (Loc, Name_R);
6033 Reference : constant Entity_Id :=
6034 Make_Defining_Identifier
6035 (Loc, New_Internal_Name ('R'));
6036 Any : constant Entity_Id :=
6037 Make_Defining_Identifier
6038 (Loc, New_Internal_Name ('A'));
6042 Make_Function_Specification (Loc,
6043 Defining_Unit_Name =>
6045 Parameter_Specifications => New_List (
6046 Make_Parameter_Specification (Loc,
6047 Defining_Identifier =>
6050 New_Occurrence_Of (RACW_Type, Loc))),
6051 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6053 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6054 -- entity in the declaration spec, not in the body spec.
6056 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6058 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6059 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
6061 if No (Body_Decls) then
6065 -- Object declarations
6068 Make_Object_Declaration (Loc,
6069 Defining_Identifier =>
6071 Object_Definition =>
6072 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6073 Make_Object_Declaration (Loc,
6074 Defining_Identifier =>
6076 Object_Definition =>
6077 New_Occurrence_Of (RTE (RE_Any), Loc)));
6079 -- If the object is null, nothing to do (Reference is already
6082 Null_Statements := New_List (Make_Null_Statement (Loc));
6086 -- If the object is a RAS designating a local subprogram, we
6087 -- already have a target reference.
6089 Local_Statements := New_List (
6090 Make_Procedure_Call_Statement (Loc,
6092 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
6093 Parameter_Associations => New_List (
6094 New_Occurrence_Of (Reference, Loc),
6095 Make_Selected_Component (Loc,
6097 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
6098 New_Occurrence_Of (RACW_Parameter, Loc)),
6099 Selector_Name => Make_Identifier (Loc, Name_Target)))));
6102 -- If the object is a local RACW object, use Get_Reference now to
6103 -- obtain a reference.
6105 Local_Statements := New_List (
6106 Make_Procedure_Call_Statement (Loc,
6108 New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6109 Parameter_Associations => New_List (
6110 Unchecked_Convert_To (
6112 New_Occurrence_Of (RACW_Parameter, Loc)),
6113 Make_String_Literal (Loc,
6114 Full_Qualified_Name (Designated_Type)),
6115 Make_Attribute_Reference (Loc,
6118 Defining_Identifier (
6119 Stub_Elements.RPC_Receiver_Decl), Loc),
6122 New_Occurrence_Of (Reference, Loc))));
6125 -- If the object is located on another partition, use the target from
6128 Stub_Statements := New_List (
6129 Make_Procedure_Call_Statement (Loc,
6131 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
6132 Parameter_Associations => New_List (
6133 New_Occurrence_Of (Reference, Loc),
6134 Make_Selected_Component (Loc,
6135 Prefix => Unchecked_Convert_To (Stub_Type_Access,
6136 New_Occurrence_Of (RACW_Parameter, Loc)),
6138 Make_Identifier (Loc, Name_Target)))));
6140 -- Distinguish between the null, local and remote cases, and execute
6141 -- the appropriate piece of code.
6144 Make_Implicit_If_Statement (RACW_Type,
6147 Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc),
6148 Right_Opnd => Make_Null (Loc)),
6149 Then_Statements => Null_Statements,
6150 Elsif_Parts => New_List (
6151 Make_Elsif_Part (Loc,
6155 Make_Attribute_Reference (Loc,
6157 New_Occurrence_Of (RACW_Parameter, Loc),
6158 Attribute_Name => Name_Tag),
6160 Make_Attribute_Reference (Loc,
6161 Prefix => New_Occurrence_Of (Stub_Type, Loc),
6162 Attribute_Name => Name_Tag)),
6163 Then_Statements => Local_Statements)),
6164 Else_Statements => Stub_Statements);
6166 Statements := New_List (
6168 Make_Assignment_Statement (Loc,
6170 New_Occurrence_Of (Any, Loc),
6172 Make_Function_Call (Loc,
6173 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
6174 Parameter_Associations => New_List (
6175 New_Occurrence_Of (Reference, Loc)))),
6176 Make_Procedure_Call_Statement (Loc,
6178 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6179 Parameter_Associations => New_List (
6180 New_Occurrence_Of (Any, Loc),
6181 Make_Selected_Component (Loc,
6183 Defining_Identifier (
6184 Stub_Elements.RPC_Receiver_Decl),
6185 Selector_Name => Name_Obj_TypeCode))),
6186 Make_Simple_Return_Statement (Loc,
6188 New_Occurrence_Of (Any, Loc)));
6191 Make_Subprogram_Body (Loc,
6193 Copy_Specification (Loc, Func_Spec),
6194 Declarations => Decls,
6195 Handled_Statement_Sequence =>
6196 Make_Handled_Sequence_Of_Statements (Loc,
6197 Statements => Statements));
6198 Append_To (Body_Decls, Func_Body);
6199 end Add_RACW_To_Any;
6201 -----------------------
6202 -- Add_RACW_TypeCode --
6203 -----------------------
6205 procedure Add_RACW_TypeCode
6206 (Designated_Type : Entity_Id;
6207 RACW_Type : Entity_Id;
6208 Body_Decls : List_Id)
6210 Loc : constant Source_Ptr := Sloc (RACW_Type);
6212 Fnam : constant Entity_Id :=
6213 Make_Defining_Identifier (Loc,
6214 Chars => New_External_Name (Chars (RACW_Type), 'Y'));
6216 Stub_Elements : constant Stub_Structure :=
6217 Stubs_Table.Get (Designated_Type);
6218 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6220 Func_Spec : Node_Id;
6221 Func_Decl : Node_Id;
6222 Func_Body : Node_Id;
6226 -- The spec for this subprogram has a dummy 'access RACW' argument,
6227 -- which serves only for overloading purposes.
6230 Make_Function_Specification (Loc,
6231 Defining_Unit_Name =>
6233 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6235 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6236 -- entity in the declaration spec, not those of the body spec.
6238 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6239 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6240 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6242 if No (Body_Decls) then
6247 Make_Subprogram_Body (Loc,
6249 Copy_Specification (Loc, Func_Spec),
6250 Declarations => Empty_List,
6251 Handled_Statement_Sequence =>
6252 Make_Handled_Sequence_Of_Statements (Loc,
6253 Statements => New_List (
6254 Make_Simple_Return_Statement (Loc,
6256 Make_Selected_Component (Loc,
6258 Defining_Identifier (
6259 Stub_Elements.RPC_Receiver_Decl),
6260 Selector_Name => Name_Obj_TypeCode)))));
6262 Append_To (Body_Decls, Func_Body);
6263 end Add_RACW_TypeCode;
6265 ------------------------------
6266 -- Add_RACW_Write_Attribute --
6267 ------------------------------
6269 procedure Add_RACW_Write_Attribute
6270 (RACW_Type : Entity_Id;
6271 Stub_Type : Entity_Id;
6272 Stub_Type_Access : Entity_Id;
6273 Body_Decls : List_Id)
6275 pragma Warnings (Off);
6276 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6277 pragma Warnings (On);
6279 Loc : constant Source_Ptr := Sloc (RACW_Type);
6281 Body_Node : Node_Id;
6282 Proc_Decl : Node_Id;
6283 Attr_Decl : Node_Id;
6285 Statements : constant List_Id := New_List;
6286 Pnam : constant Entity_Id :=
6287 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
6289 function Stream_Parameter return Node_Id;
6290 function Object return Node_Id;
6291 -- Functions to create occurrences of the formal parameter names
6297 function Object return Node_Id is
6298 Object_Ref : constant Node_Id :=
6299 Make_Identifier (Loc, Name_V);
6302 -- Etype must be set for Build_To_Any_Call
6304 Set_Etype (Object_Ref, RACW_Type);
6309 ----------------------
6310 -- Stream_Parameter --
6311 ----------------------
6313 function Stream_Parameter return Node_Id is
6315 return Make_Identifier (Loc, Name_S);
6316 end Stream_Parameter;
6318 -- Start of processing for Add_RACW_Write_Attribute
6321 Build_Stream_Procedure
6322 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
6325 Make_Subprogram_Declaration (Loc,
6326 Copy_Specification (Loc, Specification (Body_Node)));
6329 Make_Attribute_Definition_Clause (Loc,
6330 Name => New_Occurrence_Of (RACW_Type, Loc),
6331 Chars => Name_Write,
6334 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6336 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6337 Insert_After (Proc_Decl, Attr_Decl);
6339 if No (Body_Decls) then
6343 Append_To (Statements,
6344 Pack_Node_Into_Stream_Access (Loc,
6345 Stream => Stream_Parameter,
6347 Make_Function_Call (Loc,
6349 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
6350 Parameter_Associations => New_List (
6351 PolyORB_Support.Helpers.Build_To_Any_Call
6352 (Object, Body_Decls))),
6353 Etyp => RTE (RE_Object_Ref)));
6355 Append_To (Body_Decls, Body_Node);
6356 end Add_RACW_Write_Attribute;
6358 -----------------------
6359 -- Add_RAST_Features --
6360 -----------------------
6362 procedure Add_RAST_Features
6363 (Vis_Decl : Node_Id;
6364 RAS_Type : Entity_Id)
6367 Add_RAS_Access_TSS (Vis_Decl);
6369 Add_RAS_From_Any (RAS_Type);
6370 Add_RAS_TypeCode (RAS_Type);
6372 -- To_Any uses TypeCode, and therefore needs to be generated last
6374 Add_RAS_To_Any (RAS_Type);
6375 end Add_RAST_Features;
6377 ------------------------
6378 -- Add_RAS_Access_TSS --
6379 ------------------------
6381 procedure Add_RAS_Access_TSS (N : Node_Id) is
6382 Loc : constant Source_Ptr := Sloc (N);
6384 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6385 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6386 -- Ras_Type is the access to subprogram type; Fat_Type is the
6387 -- corresponding record type.
6389 RACW_Type : constant Entity_Id :=
6390 Underlying_RACW_Type (Ras_Type);
6391 Desig : constant Entity_Id :=
6392 Etype (Designated_Type (RACW_Type));
6394 Stub_Elements : constant Stub_Structure :=
6395 Stubs_Table.Get (Desig);
6396 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6398 Proc : constant Entity_Id :=
6399 Make_Defining_Identifier (Loc,
6400 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6402 Proc_Spec : Node_Id;
6404 -- Formal parameters
6406 Package_Name : constant Entity_Id :=
6407 Make_Defining_Identifier (Loc,
6412 Subp_Id : constant Entity_Id :=
6413 Make_Defining_Identifier (Loc,
6416 -- Target subprogram
6418 Asynch_P : constant Entity_Id :=
6419 Make_Defining_Identifier (Loc,
6420 Chars => Name_Asynchronous);
6421 -- Is the procedure to which the 'Access applies asynchronous?
6423 All_Calls_Remote : constant Entity_Id :=
6424 Make_Defining_Identifier (Loc,
6425 Chars => Name_All_Calls_Remote);
6426 -- True if an All_Calls_Remote pragma applies to the RCI unit
6427 -- that contains the subprogram.
6429 -- Common local variables
6431 Proc_Decls : List_Id;
6432 Proc_Statements : List_Id;
6434 Subp_Ref : constant Entity_Id :=
6435 Make_Defining_Identifier (Loc, Name_R);
6436 -- Reference that designates the target subprogram (returned
6437 -- by Get_RAS_Info).
6439 Is_Local : constant Entity_Id :=
6440 Make_Defining_Identifier (Loc, Name_L);
6441 Local_Addr : constant Entity_Id :=
6442 Make_Defining_Identifier (Loc, Name_A);
6443 -- For the call to Get_Local_Address
6445 -- Additional local variables for the remote case
6447 Local_Stub : constant Entity_Id :=
6448 Make_Defining_Identifier (Loc,
6449 Chars => New_Internal_Name ('L'));
6451 Stub_Ptr : constant Entity_Id :=
6452 Make_Defining_Identifier (Loc,
6453 Chars => New_Internal_Name ('S'));
6456 (Field_Name : Name_Id;
6457 Value : Node_Id) return Node_Id;
6458 -- Construct an assignment that sets the named component in the
6466 (Field_Name : Name_Id;
6467 Value : Node_Id) return Node_Id
6471 Make_Assignment_Statement (Loc,
6473 Make_Selected_Component (Loc,
6475 Selector_Name => Field_Name),
6476 Expression => Value);
6479 -- Start of processing for Add_RAS_Access_TSS
6482 Proc_Decls := New_List (
6484 -- Common declarations
6486 Make_Object_Declaration (Loc,
6487 Defining_Identifier => Subp_Ref,
6488 Object_Definition =>
6489 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6491 Make_Object_Declaration (Loc,
6492 Defining_Identifier => Is_Local,
6493 Object_Definition =>
6494 New_Occurrence_Of (Standard_Boolean, Loc)),
6496 Make_Object_Declaration (Loc,
6497 Defining_Identifier => Local_Addr,
6498 Object_Definition =>
6499 New_Occurrence_Of (RTE (RE_Address), Loc)),
6501 Make_Object_Declaration (Loc,
6502 Defining_Identifier => Local_Stub,
6503 Aliased_Present => True,
6504 Object_Definition =>
6505 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6507 Make_Object_Declaration (Loc,
6508 Defining_Identifier =>
6510 Object_Definition =>
6511 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6513 Make_Attribute_Reference (Loc,
6514 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6515 Attribute_Name => Name_Unchecked_Access)));
6517 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6518 -- Build_Get_Unique_RP_Call needs this information
6520 -- Get_RAS_Info (Pkg, Subp, R);
6521 -- Obtain a reference to the target subprogram
6523 Proc_Statements := New_List (
6524 Make_Procedure_Call_Statement (Loc,
6526 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6527 Parameter_Associations => New_List (
6528 New_Occurrence_Of (Package_Name, Loc),
6529 New_Occurrence_Of (Subp_Id, Loc),
6530 New_Occurrence_Of (Subp_Ref, Loc))),
6532 -- Get_Local_Address (R, L, A);
6533 -- Determine whether the subprogram is local (L), and if so
6534 -- obtain the local address of its proxy (A).
6536 Make_Procedure_Call_Statement (Loc,
6538 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6539 Parameter_Associations => New_List (
6540 New_Occurrence_Of (Subp_Ref, Loc),
6541 New_Occurrence_Of (Is_Local, Loc),
6542 New_Occurrence_Of (Local_Addr, Loc))));
6544 -- Note: Here we assume that the Fat_Type is a record containing just
6545 -- an access to a proxy or stub object.
6547 Append_To (Proc_Statements,
6551 Make_Implicit_If_Statement (N,
6553 New_Occurrence_Of (Is_Local, Loc),
6555 Then_Statements => New_List (
6557 -- if A.Target = null then
6559 Make_Implicit_If_Statement (N,
6562 Make_Selected_Component (Loc,
6564 Unchecked_Convert_To (
6565 RTE (RE_RAS_Proxy_Type_Access),
6566 New_Occurrence_Of (Local_Addr, Loc)),
6568 Make_Identifier (Loc, Name_Target)),
6571 Then_Statements => New_List (
6573 -- A.Target := Entity_Of (Ref);
6575 Make_Assignment_Statement (Loc,
6577 Make_Selected_Component (Loc,
6579 Unchecked_Convert_To (
6580 RTE (RE_RAS_Proxy_Type_Access),
6581 New_Occurrence_Of (Local_Addr, Loc)),
6583 Make_Identifier (Loc, Name_Target)),
6585 Make_Function_Call (Loc,
6587 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6588 Parameter_Associations => New_List (
6589 New_Occurrence_Of (Subp_Ref, Loc)))),
6591 -- Inc_Usage (A.Target);
6593 Make_Procedure_Call_Statement (Loc,
6595 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6596 Parameter_Associations => New_List (
6597 Make_Selected_Component (Loc,
6599 Unchecked_Convert_To (
6600 RTE (RE_RAS_Proxy_Type_Access),
6601 New_Occurrence_Of (Local_Addr, Loc)),
6602 Selector_Name => Make_Identifier (Loc,
6606 -- if not All_Calls_Remote then
6607 -- return Fat_Type!(A);
6610 Make_Implicit_If_Statement (N,
6613 New_Occurrence_Of (All_Calls_Remote, Loc)),
6615 Then_Statements => New_List (
6616 Make_Simple_Return_Statement (Loc,
6617 Unchecked_Convert_To (Fat_Type,
6618 New_Occurrence_Of (Local_Addr, Loc))))))));
6620 Append_List_To (Proc_Statements, New_List (
6622 -- Stub.Target := Entity_Of (Ref);
6624 Set_Field (Name_Target,
6625 Make_Function_Call (Loc,
6627 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6628 Parameter_Associations => New_List (
6629 New_Occurrence_Of (Subp_Ref, Loc)))),
6631 -- Inc_Usage (Stub.Target);
6633 Make_Procedure_Call_Statement (Loc,
6635 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6636 Parameter_Associations => New_List (
6637 Make_Selected_Component (Loc,
6639 Selector_Name => Name_Target))),
6641 -- E.4.1(9) A remote call is asynchronous if it is a call to
6642 -- a procedure, or a call through a value of an access-to-procedure
6643 -- type, to which a pragma Asynchronous applies.
6645 -- Parameter Asynch_P is true when the procedure is asynchronous;
6646 -- Expression Asynch_T is true when the type is asynchronous.
6648 Set_Field (Name_Asynchronous,
6650 New_Occurrence_Of (Asynch_P, Loc),
6651 New_Occurrence_Of (Boolean_Literals (
6652 Is_Asynchronous (Ras_Type)), Loc)))));
6654 Append_List_To (Proc_Statements,
6655 Build_Get_Unique_RP_Call (Loc,
6656 Stub_Ptr, Stub_Elements.Stub_Type));
6658 Append_To (Proc_Statements,
6659 Make_Simple_Return_Statement (Loc,
6661 Unchecked_Convert_To (Fat_Type,
6662 New_Occurrence_Of (Stub_Ptr, Loc))));
6665 Make_Function_Specification (Loc,
6666 Defining_Unit_Name => Proc,
6667 Parameter_Specifications => New_List (
6668 Make_Parameter_Specification (Loc,
6669 Defining_Identifier => Package_Name,
6671 New_Occurrence_Of (Standard_String, Loc)),
6673 Make_Parameter_Specification (Loc,
6674 Defining_Identifier => Subp_Id,
6676 New_Occurrence_Of (Standard_String, Loc)),
6678 Make_Parameter_Specification (Loc,
6679 Defining_Identifier => Asynch_P,
6681 New_Occurrence_Of (Standard_Boolean, Loc)),
6683 Make_Parameter_Specification (Loc,
6684 Defining_Identifier => All_Calls_Remote,
6686 New_Occurrence_Of (Standard_Boolean, Loc))),
6688 Result_Definition =>
6689 New_Occurrence_Of (Fat_Type, Loc));
6691 -- Set the kind and return type of the function to prevent
6692 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6694 Set_Ekind (Proc, E_Function);
6695 Set_Etype (Proc, Fat_Type);
6698 Make_Subprogram_Body (Loc,
6699 Specification => Proc_Spec,
6700 Declarations => Proc_Decls,
6701 Handled_Statement_Sequence =>
6702 Make_Handled_Sequence_Of_Statements (Loc,
6703 Statements => Proc_Statements)));
6705 Set_TSS (Fat_Type, Proc);
6706 end Add_RAS_Access_TSS;
6708 ----------------------
6709 -- Add_RAS_From_Any --
6710 ----------------------
6712 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6713 Loc : constant Source_Ptr := Sloc (RAS_Type);
6715 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6716 Make_TSS_Name (RAS_Type, TSS_From_Any));
6718 Func_Spec : Node_Id;
6720 Statements : List_Id;
6722 Any_Parameter : constant Entity_Id :=
6723 Make_Defining_Identifier (Loc, Name_A);
6726 Statements := New_List (
6727 Make_Simple_Return_Statement (Loc,
6729 Make_Aggregate (Loc,
6730 Component_Associations => New_List (
6731 Make_Component_Association (Loc,
6732 Choices => New_List (
6733 Make_Identifier (Loc, Name_Ras)),
6735 PolyORB_Support.Helpers.Build_From_Any_Call (
6736 Underlying_RACW_Type (RAS_Type),
6737 New_Occurrence_Of (Any_Parameter, Loc),
6741 Make_Function_Specification (Loc,
6742 Defining_Unit_Name =>
6744 Parameter_Specifications => New_List (
6745 Make_Parameter_Specification (Loc,
6746 Defining_Identifier =>
6749 New_Occurrence_Of (RTE (RE_Any), Loc))),
6750 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6753 Make_Subprogram_Body (Loc,
6754 Specification => Func_Spec,
6755 Declarations => No_List,
6756 Handled_Statement_Sequence =>
6757 Make_Handled_Sequence_Of_Statements (Loc,
6758 Statements => Statements)));
6759 Set_TSS (RAS_Type, Fnam);
6760 end Add_RAS_From_Any;
6762 --------------------
6763 -- Add_RAS_To_Any --
6764 --------------------
6766 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6767 Loc : constant Source_Ptr := Sloc (RAS_Type);
6769 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6770 Make_TSS_Name (RAS_Type, TSS_To_Any));
6773 Statements : List_Id;
6775 Func_Spec : Node_Id;
6777 Any : constant Entity_Id :=
6778 Make_Defining_Identifier (Loc,
6779 Chars => New_Internal_Name ('A'));
6780 RAS_Parameter : constant Entity_Id :=
6781 Make_Defining_Identifier (Loc,
6782 Chars => New_Internal_Name ('R'));
6783 RACW_Parameter : constant Node_Id :=
6784 Make_Selected_Component (Loc,
6785 Prefix => RAS_Parameter,
6786 Selector_Name => Name_Ras);
6789 -- Object declarations
6791 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6793 Make_Object_Declaration (Loc,
6794 Defining_Identifier =>
6796 Object_Definition =>
6797 New_Occurrence_Of (RTE (RE_Any), Loc),
6799 PolyORB_Support.Helpers.Build_To_Any_Call
6800 (RACW_Parameter, No_List)));
6802 Statements := New_List (
6803 Make_Procedure_Call_Statement (Loc,
6805 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6806 Parameter_Associations => New_List (
6807 New_Occurrence_Of (Any, Loc),
6808 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6810 Make_Simple_Return_Statement (Loc,
6812 New_Occurrence_Of (Any, Loc)));
6815 Make_Function_Specification (Loc,
6816 Defining_Unit_Name =>
6818 Parameter_Specifications => New_List (
6819 Make_Parameter_Specification (Loc,
6820 Defining_Identifier =>
6823 New_Occurrence_Of (RAS_Type, Loc))),
6824 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6827 Make_Subprogram_Body (Loc,
6828 Specification => Func_Spec,
6829 Declarations => Decls,
6830 Handled_Statement_Sequence =>
6831 Make_Handled_Sequence_Of_Statements (Loc,
6832 Statements => Statements)));
6833 Set_TSS (RAS_Type, Fnam);
6836 ----------------------
6837 -- Add_RAS_TypeCode --
6838 ----------------------
6840 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6841 Loc : constant Source_Ptr := Sloc (RAS_Type);
6843 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6844 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6846 Func_Spec : Node_Id;
6848 Decls : constant List_Id := New_List;
6849 Name_String, Repo_Id_String : String_Id;
6853 Make_Function_Specification (Loc,
6854 Defining_Unit_Name =>
6856 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6858 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6859 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6862 Make_Subprogram_Body (Loc,
6863 Specification => Func_Spec,
6864 Declarations => Decls,
6865 Handled_Statement_Sequence =>
6866 Make_Handled_Sequence_Of_Statements (Loc,
6867 Statements => New_List (
6868 Make_Simple_Return_Statement (Loc,
6870 Make_Function_Call (Loc,
6872 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6873 Parameter_Associations => New_List (
6874 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6875 Make_Aggregate (Loc,
6878 Make_Function_Call (Loc,
6879 Name => New_Occurrence_Of (
6880 RTE (RE_TA_String), Loc),
6881 Parameter_Associations => New_List (
6882 Make_String_Literal (Loc, Name_String))),
6883 Make_Function_Call (Loc,
6884 Name => New_Occurrence_Of (
6885 RTE (RE_TA_String), Loc),
6886 Parameter_Associations => New_List (
6887 Make_String_Literal (Loc,
6888 Repo_Id_String))))))))))));
6889 Set_TSS (RAS_Type, Fnam);
6890 end Add_RAS_TypeCode;
6892 -----------------------------------------
6893 -- Add_Receiving_Stubs_To_Declarations --
6894 -----------------------------------------
6896 procedure Add_Receiving_Stubs_To_Declarations
6897 (Pkg_Spec : Node_Id;
6901 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6903 Pkg_RPC_Receiver : constant Entity_Id :=
6904 Make_Defining_Identifier (Loc,
6905 New_Internal_Name ('H'));
6906 Pkg_RPC_Receiver_Object : Node_Id;
6908 Pkg_RPC_Receiver_Body : Node_Id;
6909 Pkg_RPC_Receiver_Decls : List_Id;
6910 Pkg_RPC_Receiver_Statements : List_Id;
6911 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6912 -- A Pkg_RPC_Receiver is built to decode the request
6915 -- Request object received from neutral layer
6917 Subp_Id : Entity_Id;
6918 -- Subprogram identifier as received from the neutral
6919 -- distribution core.
6921 Subp_Index : Entity_Id;
6922 -- Internal index as determined by matching either the
6923 -- method name from the request structure, or the local
6924 -- subprogram address (in case of a RAS).
6926 Is_Local : constant Entity_Id :=
6927 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
6928 Local_Address : constant Entity_Id :=
6929 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
6930 -- Address of a local subprogram designated by a
6931 -- reference corresponding to a RAS.
6933 Dispatch_On_Address : constant List_Id := New_List;
6934 Dispatch_On_Name : constant List_Id := New_List;
6936 Current_Declaration : Node_Id;
6937 Current_Stubs : Node_Id;
6938 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6940 Subp_Info_Array : constant Entity_Id :=
6941 Make_Defining_Identifier (Loc,
6942 Chars => New_Internal_Name ('I'));
6944 Subp_Info_List : constant List_Id := New_List;
6946 Register_Pkg_Actuals : constant List_Id := New_List;
6948 All_Calls_Remote_E : Entity_Id;
6950 procedure Append_Stubs_To
6951 (RPC_Receiver_Cases : List_Id;
6952 Declaration : Node_Id;
6955 Subp_Dist_Name : Entity_Id;
6956 Subp_Proxy_Addr : Entity_Id);
6957 -- Add one case to the specified RPC receiver case list associating
6958 -- Subprogram_Number with the subprogram declared by Declaration, for
6959 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6960 -- subprogram index. Subp_Dist_Name is the string used to call the
6961 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6962 -- object, used in the context of calls through remote
6963 -- access-to-subprogram types.
6965 ---------------------
6966 -- Append_Stubs_To --
6967 ---------------------
6969 procedure Append_Stubs_To
6970 (RPC_Receiver_Cases : List_Id;
6971 Declaration : Node_Id;
6974 Subp_Dist_Name : Entity_Id;
6975 Subp_Proxy_Addr : Entity_Id)
6977 Case_Stmts : List_Id;
6979 Case_Stmts := New_List (
6980 Make_Procedure_Call_Statement (Loc,
6983 Defining_Entity (Stubs), Loc),
6984 Parameter_Associations =>
6985 New_List (New_Occurrence_Of (Request, Loc))));
6986 if Nkind (Specification (Declaration))
6987 = N_Function_Specification
6989 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6991 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6994 Append_To (RPC_Receiver_Cases,
6995 Make_Case_Statement_Alternative (Loc,
6997 New_List (Make_Integer_Literal (Loc, Subp_Number)),
7001 Append_To (Dispatch_On_Name,
7002 Make_Elsif_Part (Loc,
7004 Make_Function_Call (Loc,
7006 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
7007 Parameter_Associations => New_List (
7008 New_Occurrence_Of (Subp_Id, Loc),
7009 New_Occurrence_Of (Subp_Dist_Name, Loc))),
7010 Then_Statements => New_List (
7011 Make_Assignment_Statement (Loc,
7012 New_Occurrence_Of (Subp_Index, Loc),
7013 Make_Integer_Literal (Loc,
7016 Append_To (Dispatch_On_Address,
7017 Make_Elsif_Part (Loc,
7021 New_Occurrence_Of (Local_Address, Loc),
7023 New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
7024 Then_Statements => New_List (
7025 Make_Assignment_Statement (Loc,
7026 New_Occurrence_Of (Subp_Index, Loc),
7027 Make_Integer_Literal (Loc,
7029 end Append_Stubs_To;
7031 -- Start of processing for Add_Receiving_Stubs_To_Declarations
7034 -- Building receiving stubs consist in several operations:
7036 -- - a package RPC receiver must be built. This subprogram
7037 -- will get a Subprogram_Id from the incoming stream
7038 -- and will dispatch the call to the right subprogram;
7040 -- - a receiving stub for each subprogram visible in the package
7041 -- spec. This stub will read all the parameters from the stream,
7042 -- and put the result as well as the exception occurrence in the
7045 -- - a dummy package with an empty spec and a body made of an
7046 -- elaboration part, whose job is to register the receiving
7047 -- part of this RCI package on the name server. This is done
7048 -- by calling System.Partition_Interface.Register_Receiving_Stub.
7050 Build_RPC_Receiver_Body (
7051 RPC_Receiver => Pkg_RPC_Receiver,
7054 Subp_Index => Subp_Index,
7055 Stmts => Pkg_RPC_Receiver_Statements,
7056 Decl => Pkg_RPC_Receiver_Body);
7057 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
7059 -- Extract local address information from the target reference:
7060 -- if non-null, that means that this is a reference that denotes
7061 -- one particular operation, and hence that the operation name
7062 -- must not be taken into account for dispatching.
7064 Append_To (Pkg_RPC_Receiver_Decls,
7065 Make_Object_Declaration (Loc,
7066 Defining_Identifier =>
7068 Object_Definition =>
7069 New_Occurrence_Of (Standard_Boolean, Loc)));
7070 Append_To (Pkg_RPC_Receiver_Decls,
7071 Make_Object_Declaration (Loc,
7072 Defining_Identifier =>
7074 Object_Definition =>
7075 New_Occurrence_Of (RTE (RE_Address), Loc)));
7076 Append_To (Pkg_RPC_Receiver_Statements,
7077 Make_Procedure_Call_Statement (Loc,
7079 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7080 Parameter_Associations => New_List (
7081 Make_Selected_Component (Loc,
7083 Selector_Name => Name_Target),
7084 New_Occurrence_Of (Is_Local, Loc),
7085 New_Occurrence_Of (Local_Address, Loc))));
7087 -- For each subprogram, the receiving stub will be built and a
7088 -- case statement will be made on the Subprogram_Id to dispatch
7089 -- to the right subprogram.
7091 All_Calls_Remote_E := Boolean_Literals (
7092 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
7094 Overload_Counter_Table.Reset;
7095 Reserve_NamingContext_Methods;
7097 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
7098 while Present (Current_Declaration) loop
7099 if Nkind (Current_Declaration) = N_Subprogram_Declaration
7100 and then Comes_From_Source (Current_Declaration)
7103 Loc : constant Source_Ptr := Sloc (Current_Declaration);
7104 -- While specifically processing Current_Declaration, use
7105 -- its Sloc as the location of all generated nodes.
7107 Subp_Def : constant Entity_Id :=
7109 (Specification (Current_Declaration));
7111 Subp_Val : String_Id;
7113 Subp_Dist_Name : constant Entity_Id :=
7114 Make_Defining_Identifier (Loc,
7116 Related_Id => Chars (Subp_Def),
7118 Suffix_Index => -1));
7120 Proxy_Object_Addr : Entity_Id;
7123 -- Build receiving stub
7126 Build_Subprogram_Receiving_Stubs
7127 (Vis_Decl => Current_Declaration,
7129 Nkind (Specification (Current_Declaration)) =
7130 N_Procedure_Specification
7131 and then Is_Asynchronous (Subp_Def));
7133 Append_To (Decls, Current_Stubs);
7134 Analyze (Current_Stubs);
7138 Add_RAS_Proxy_And_Analyze (Decls,
7140 Current_Declaration,
7141 All_Calls_Remote_E =>
7143 Proxy_Object_Addr =>
7146 -- Compute distribution identifier
7148 Assign_Subprogram_Identifier (
7150 Current_Subprogram_Number,
7153 pragma Assert (Current_Subprogram_Number =
7154 Get_Subprogram_Id (Subp_Def));
7157 Make_Object_Declaration (Loc,
7158 Defining_Identifier => Subp_Dist_Name,
7159 Constant_Present => True,
7160 Object_Definition => New_Occurrence_Of (
7161 Standard_String, Loc),
7163 Make_String_Literal (Loc, Subp_Val)));
7164 Analyze (Last (Decls));
7166 -- Add subprogram descriptor (RCI_Subp_Info) to the
7167 -- subprograms table for this receiver. The aggregate
7168 -- below must be kept consistent with the declaration
7169 -- of type RCI_Subp_Info in System.Partition_Interface.
7171 Append_To (Subp_Info_List,
7172 Make_Component_Association (Loc,
7173 Choices => New_List (
7174 Make_Integer_Literal (Loc,
7175 Current_Subprogram_Number)),
7177 Make_Aggregate (Loc,
7178 Expressions => New_List (
7179 Make_Attribute_Reference (Loc,
7182 Subp_Dist_Name, Loc),
7183 Attribute_Name => Name_Address),
7184 Make_Attribute_Reference (Loc,
7187 Subp_Dist_Name, Loc),
7188 Attribute_Name => Name_Length),
7189 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
7191 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
7192 Declaration => Current_Declaration,
7193 Stubs => Current_Stubs,
7194 Subp_Number => Current_Subprogram_Number,
7195 Subp_Dist_Name => Subp_Dist_Name,
7196 Subp_Proxy_Addr => Proxy_Object_Addr);
7199 Current_Subprogram_Number := Current_Subprogram_Number + 1;
7202 Next (Current_Declaration);
7206 Make_Object_Declaration (Loc,
7207 Defining_Identifier => Subp_Info_Array,
7208 Constant_Present => True,
7209 Aliased_Present => True,
7210 Object_Definition =>
7211 Make_Subtype_Indication (Loc,
7213 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
7215 Make_Index_Or_Discriminant_Constraint (Loc,
7218 Low_Bound => Make_Integer_Literal (Loc,
7219 First_RCI_Subprogram_Id),
7221 Make_Integer_Literal (Loc,
7222 First_RCI_Subprogram_Id
7223 + List_Length (Subp_Info_List) - 1)))))));
7225 if Present (First (Subp_Info_List)) then
7226 Set_Expression (Last (Decls),
7227 Make_Aggregate (Loc,
7228 Component_Associations => Subp_Info_List));
7230 -- Generate the dispatch statement to determine the subprogram id
7231 -- of the called subprogram.
7233 -- We first test whether the reference that was used to make the
7234 -- call was the base RCI reference (in which case Local_Address is
7235 -- zero, and the method identifier from the request must be used
7236 -- to determine which subprogram is called) or a reference
7237 -- identifying one particular subprogram (in which case
7238 -- Local_Address is the address of that subprogram, and the
7239 -- method name from the request is ignored). The latter occurs
7240 -- for the case of a call through a remote access-to-subprogram.
7242 -- In each case, cascaded elsifs are used to determine the proper
7243 -- subprogram index. Using hash tables might be more efficient.
7245 Append_To (Pkg_RPC_Receiver_Statements,
7246 Make_Implicit_If_Statement (Pkg_Spec,
7249 Left_Opnd => New_Occurrence_Of
7250 (Local_Address, Loc),
7251 Right_Opnd => New_Occurrence_Of
7252 (RTE (RE_Null_Address), Loc)),
7253 Then_Statements => New_List (
7254 Make_Implicit_If_Statement (Pkg_Spec,
7256 New_Occurrence_Of (Standard_False, Loc),
7257 Then_Statements => New_List (
7258 Make_Null_Statement (Loc)),
7260 Dispatch_On_Address)),
7262 Else_Statements => New_List (
7263 Make_Implicit_If_Statement (Pkg_Spec,
7265 New_Occurrence_Of (Standard_False, Loc),
7266 Then_Statements => New_List (
7267 Make_Null_Statement (Loc)),
7269 Dispatch_On_Name))));
7272 -- For a degenerate RCI with no visible subprograms,
7273 -- Subp_Info_List has zero length, and the declaration is for an
7274 -- empty array, in which case no initialization aggregate must be
7275 -- generated. We do not generate a Dispatch_Statement either.
7277 -- No initialization provided: remove CONSTANT so that the
7278 -- declaration is not an incomplete deferred constant.
7280 Set_Constant_Present (Last (Decls), False);
7283 -- Analyze Subp_Info_Array declaration
7285 Analyze (Last (Decls));
7287 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7288 -- rather than raising an exception since we do not want someone
7289 -- to crash a remote partition by sending invalid subprogram ids.
7290 -- This is consistent with the other parts of the case statement
7291 -- since even in presence of incorrect parameters in the stream,
7292 -- every exception will be caught and (if the subprogram is not an
7293 -- APC) put into the result stream and sent away.
7295 Append_To (Pkg_RPC_Receiver_Cases,
7296 Make_Case_Statement_Alternative (Loc,
7298 New_List (Make_Others_Choice (Loc)),
7300 New_List (Make_Null_Statement (Loc))));
7302 Append_To (Pkg_RPC_Receiver_Statements,
7303 Make_Case_Statement (Loc,
7305 New_Occurrence_Of (Subp_Index, Loc),
7306 Alternatives => Pkg_RPC_Receiver_Cases));
7308 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7311 Append_To (Decls, Pkg_RPC_Receiver_Body);
7312 Analyze (Last (Decls));
7314 Pkg_RPC_Receiver_Object :=
7315 Make_Object_Declaration (Loc,
7316 Defining_Identifier =>
7317 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
7318 Aliased_Present => True,
7319 Object_Definition =>
7320 New_Occurrence_Of (RTE (RE_Servant), Loc));
7321 Append_To (Decls, Pkg_RPC_Receiver_Object);
7322 Analyze (Last (Decls));
7324 Get_Library_Unit_Name_String (Pkg_Spec);
7325 Append_To (Register_Pkg_Actuals,
7327 Make_String_Literal (Loc,
7328 Strval => String_From_Name_Buffer));
7330 Append_To (Register_Pkg_Actuals,
7332 Make_Attribute_Reference (Loc,
7335 (Defining_Entity (Pkg_Spec), Loc),
7339 Append_To (Register_Pkg_Actuals,
7341 Make_Attribute_Reference (Loc,
7343 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7344 Attribute_Name => Name_Access));
7346 Append_To (Register_Pkg_Actuals,
7348 Make_Attribute_Reference (Loc,
7351 Defining_Identifier (
7352 Pkg_RPC_Receiver_Object), Loc),
7356 Append_To (Register_Pkg_Actuals,
7358 Make_Attribute_Reference (Loc,
7360 New_Occurrence_Of (Subp_Info_Array, Loc),
7364 Append_To (Register_Pkg_Actuals,
7366 Make_Attribute_Reference (Loc,
7368 New_Occurrence_Of (Subp_Info_Array, Loc),
7372 Append_To (Register_Pkg_Actuals,
7373 -- Is_All_Calls_Remote
7374 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7377 Make_Procedure_Call_Statement (Loc,
7379 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7380 Parameter_Associations => Register_Pkg_Actuals));
7381 Analyze (Last (Stmts));
7383 end Add_Receiving_Stubs_To_Declarations;
7385 ---------------------------------
7386 -- Build_General_Calling_Stubs --
7387 ---------------------------------
7389 procedure Build_General_Calling_Stubs
7391 Statements : List_Id;
7392 Target_Object : Node_Id;
7393 Subprogram_Id : Node_Id;
7394 Asynchronous : Node_Id := Empty;
7395 Is_Known_Asynchronous : Boolean := False;
7396 Is_Known_Non_Asynchronous : Boolean := False;
7397 Is_Function : Boolean;
7399 Stub_Type : Entity_Id := Empty;
7400 RACW_Type : Entity_Id := Empty;
7403 Loc : constant Source_Ptr := Sloc (Nod);
7405 Arguments : Node_Id;
7406 -- Name of the named values list used to transmit parameters
7407 -- to the remote package
7410 -- The request object constructed by these stubs
7413 -- Name of the result named value (in non-APC cases) which get the
7414 -- result of the remote subprogram.
7416 Result_TC : Node_Id;
7417 -- Typecode expression for the result of the request (void
7418 -- typecode for procedures).
7420 Exception_Return_Parameter : Node_Id;
7421 -- Name of the parameter which will hold the exception sent by the
7422 -- remote subprogram.
7424 Current_Parameter : Node_Id;
7425 -- Current parameter being handled
7427 Ordered_Parameters_List : constant List_Id :=
7428 Build_Ordered_Parameters_List (Spec);
7430 Asynchronous_P : Node_Id;
7431 -- A Boolean expression indicating whether this call is asynchronous
7433 Asynchronous_Statements : List_Id := No_List;
7434 Non_Asynchronous_Statements : List_Id := No_List;
7435 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7437 Extra_Formal_Statements : constant List_Id := New_List;
7438 -- List of statements for extra formal parameters. It will appear
7439 -- after the regular statements for writing out parameters.
7441 After_Statements : constant List_Id := New_List;
7442 -- Statements to be executed after call returns (to assign
7443 -- in out or out parameter values).
7446 -- The type of the formal parameter being processed
7448 Is_Controlling_Formal : Boolean;
7449 Is_First_Controlling_Formal : Boolean;
7450 First_Controlling_Formal_Seen : Boolean := False;
7451 -- Controlling formal parameters of distributed object primitives
7452 -- require special handling, and the first such parameter needs even
7453 -- more special handling.
7456 -- ??? document general form of stub subprograms for the PolyORB case
7458 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7461 Make_Object_Declaration (Loc,
7462 Defining_Identifier => Request,
7463 Aliased_Present => False,
7464 Object_Definition =>
7465 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
7468 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7471 Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7472 Etype (Result_Definition (Spec)), Decls);
7474 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7478 Make_Object_Declaration (Loc,
7479 Defining_Identifier => Result,
7480 Aliased_Present => False,
7481 Object_Definition =>
7482 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7484 Make_Aggregate (Loc,
7485 Component_Associations => New_List (
7486 Make_Component_Association (Loc,
7487 Choices => New_List (
7488 Make_Identifier (Loc, Name_Name)),
7490 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7491 Make_Component_Association (Loc,
7492 Choices => New_List (
7493 Make_Identifier (Loc, Name_Argument)),
7495 Make_Function_Call (Loc,
7497 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7498 Parameter_Associations => New_List (
7500 Make_Component_Association (Loc,
7501 Choices => New_List (
7502 Make_Identifier (Loc, Name_Arg_Modes)),
7504 Make_Integer_Literal (Loc, 0))))));
7506 if not Is_Known_Asynchronous then
7507 Exception_Return_Parameter :=
7508 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7511 Make_Object_Declaration (Loc,
7512 Defining_Identifier => Exception_Return_Parameter,
7513 Object_Definition =>
7514 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7517 Exception_Return_Parameter := Empty;
7520 -- Initialize and fill in arguments list
7523 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7524 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7526 Current_Parameter := First (Ordered_Parameters_List);
7527 while Present (Current_Parameter) loop
7528 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7529 Is_Controlling_Formal := True;
7530 Is_First_Controlling_Formal :=
7531 not First_Controlling_Formal_Seen;
7532 First_Controlling_Formal_Seen := True;
7534 Is_Controlling_Formal := False;
7535 Is_First_Controlling_Formal := False;
7538 if Is_Controlling_Formal then
7540 -- In the case of a controlling formal argument, we send its
7546 Etyp := Etype (Parameter_Type (Current_Parameter));
7549 -- The first controlling formal parameter is treated specially: it
7550 -- is used to set the target object of the call.
7552 if not Is_First_Controlling_Formal then
7555 Constrained : constant Boolean :=
7556 Is_Constrained (Etyp)
7557 or else Is_Elementary_Type (Etyp);
7559 Any : constant Entity_Id :=
7560 Make_Defining_Identifier (Loc,
7561 New_Internal_Name ('A'));
7563 Actual_Parameter : Node_Id :=
7565 Defining_Identifier (
7566 Current_Parameter), Loc);
7571 if Is_Controlling_Formal then
7573 -- For a controlling formal parameter (other than the
7574 -- first one), use the corresponding RACW. If the
7575 -- parameter is not an anonymous access parameter, that
7576 -- involves taking its 'Unrestricted_Access.
7578 if Nkind (Parameter_Type (Current_Parameter))
7579 = N_Access_Definition
7581 Actual_Parameter := OK_Convert_To
7582 (Etyp, Actual_Parameter);
7584 Actual_Parameter := OK_Convert_To (Etyp,
7585 Make_Attribute_Reference (Loc,
7589 Name_Unrestricted_Access));
7594 if In_Present (Current_Parameter)
7595 or else not Out_Present (Current_Parameter)
7596 or else not Constrained
7597 or else Is_Controlling_Formal
7599 -- The parameter has an input value, is constrained at
7600 -- runtime by an input value, or is a controlling formal
7601 -- parameter (always passed as a reference) other than
7604 Expr := PolyORB_Support.Helpers.Build_To_Any_Call (
7605 Actual_Parameter, Decls);
7607 Expr := Make_Function_Call (Loc,
7609 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7610 Parameter_Associations => New_List (
7611 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7616 Make_Object_Declaration (Loc,
7617 Defining_Identifier =>
7619 Aliased_Present => False,
7620 Object_Definition =>
7621 New_Occurrence_Of (RTE (RE_Any), Loc),
7625 Append_To (Statements,
7626 Add_Parameter_To_NVList (Loc,
7627 Parameter => Current_Parameter,
7628 NVList => Arguments,
7629 Constrained => Constrained,
7632 if Out_Present (Current_Parameter)
7633 and then not Is_Controlling_Formal
7635 Append_To (After_Statements,
7636 Make_Assignment_Statement (Loc,
7639 Defining_Identifier (Current_Parameter), Loc),
7641 PolyORB_Support.Helpers.Build_From_Any_Call (
7642 Etype (Parameter_Type (Current_Parameter)),
7643 New_Occurrence_Of (Any, Loc),
7650 -- If the current parameter has a dynamic constrained status, then
7651 -- this status is transmitted as well.
7652 -- This should be done for accessibility as well ???
7654 if Nkind (Parameter_Type (Current_Parameter))
7655 /= N_Access_Definition
7656 and then Need_Extra_Constrained (Current_Parameter)
7658 -- In this block, we do not use the extra formal that has been
7659 -- created because it does not exist at the time of expansion
7660 -- when building calling stubs for remote access to subprogram
7661 -- types. We create an extra variable of this type and push it
7662 -- in the stream after the regular parameters.
7665 Extra_Any_Parameter : constant Entity_Id :=
7666 Make_Defining_Identifier
7667 (Loc, New_Internal_Name ('P'));
7669 Parameter_Exp : constant Node_Id :=
7670 Make_Attribute_Reference (Loc,
7671 Prefix => New_Occurrence_Of (
7672 Defining_Identifier (Current_Parameter), Loc),
7673 Attribute_Name => Name_Constrained);
7675 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7678 Make_Object_Declaration (Loc,
7679 Defining_Identifier =>
7680 Extra_Any_Parameter,
7681 Aliased_Present => False,
7682 Object_Definition =>
7683 New_Occurrence_Of (RTE (RE_Any), Loc),
7685 PolyORB_Support.Helpers.Build_To_Any_Call (
7689 Append_To (Extra_Formal_Statements,
7690 Add_Parameter_To_NVList (Loc,
7691 Parameter => Extra_Any_Parameter,
7692 NVList => Arguments,
7693 Constrained => True,
7694 Any => Extra_Any_Parameter));
7698 Next (Current_Parameter);
7701 -- Append the formal statements list to the statements
7703 Append_List_To (Statements, Extra_Formal_Statements);
7705 Append_To (Statements,
7706 Make_Procedure_Call_Statement (Loc,
7708 New_Occurrence_Of (RTE (RE_Request_Create), Loc),
7709 Parameter_Associations => New_List (
7712 New_Occurrence_Of (Arguments, Loc),
7713 New_Occurrence_Of (Result, Loc),
7714 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7716 Append_To (Parameter_Associations (Last (Statements)),
7717 New_Occurrence_Of (Request, Loc));
7720 not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7721 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7722 Asynchronous_P := New_Occurrence_Of (
7723 Boolean_Literals (Is_Known_Asynchronous), Loc);
7725 pragma Assert (Present (Asynchronous));
7726 Asynchronous_P := New_Copy_Tree (Asynchronous);
7727 -- The expression node Asynchronous will be used to build an 'if'
7728 -- statement at the end of Build_General_Calling_Stubs: we need to
7729 -- make a copy here.
7732 Append_To (Parameter_Associations (Last (Statements)),
7733 Make_Indexed_Component (Loc,
7736 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7737 Expressions => New_List (Asynchronous_P)));
7739 Append_To (Statements,
7740 Make_Procedure_Call_Statement (Loc,
7742 New_Occurrence_Of (RTE (RE_Request_Invoke), Loc),
7743 Parameter_Associations => New_List (
7744 New_Occurrence_Of (Request, Loc))));
7746 Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7747 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7749 if not Is_Known_Asynchronous then
7751 -- Reraise an exception occurrence from the completed request.
7752 -- If the exception occurrence is empty, this is a no-op.
7754 Append_To (Non_Asynchronous_Statements,
7755 Make_Procedure_Call_Statement (Loc,
7757 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7758 Parameter_Associations => New_List (
7759 New_Occurrence_Of (Request, Loc))));
7763 -- If this is a function call, read the value and return it
7765 Append_To (Non_Asynchronous_Statements,
7766 Make_Tag_Check (Loc,
7767 Make_Simple_Return_Statement (Loc,
7768 PolyORB_Support.Helpers.Build_From_Any_Call (
7769 Etype (Result_Definition (Spec)),
7770 Make_Selected_Component (Loc,
7772 Selector_Name => Name_Argument),
7777 Append_List_To (Non_Asynchronous_Statements,
7780 if Is_Known_Asynchronous then
7781 Append_List_To (Statements, Asynchronous_Statements);
7783 elsif Is_Known_Non_Asynchronous then
7784 Append_List_To (Statements, Non_Asynchronous_Statements);
7787 pragma Assert (Present (Asynchronous));
7788 Append_To (Statements,
7789 Make_Implicit_If_Statement (Nod,
7790 Condition => Asynchronous,
7791 Then_Statements => Asynchronous_Statements,
7792 Else_Statements => Non_Asynchronous_Statements));
7794 end Build_General_Calling_Stubs;
7796 -----------------------
7797 -- Build_Stub_Target --
7798 -----------------------
7800 function Build_Stub_Target
7803 RCI_Locator : Entity_Id;
7804 Controlling_Parameter : Entity_Id) return RPC_Target
7806 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7807 Target_Reference : constant Entity_Id :=
7808 Make_Defining_Identifier (Loc,
7809 New_Internal_Name ('T'));
7811 if Present (Controlling_Parameter) then
7813 Make_Object_Declaration (Loc,
7814 Defining_Identifier => Target_Reference,
7815 Object_Definition =>
7816 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7818 Make_Function_Call (Loc,
7820 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7821 Parameter_Associations => New_List (
7822 Make_Selected_Component (Loc,
7823 Prefix => Controlling_Parameter,
7824 Selector_Name => Name_Target)))));
7825 -- Controlling_Parameter has the same components as
7826 -- System.Partition_Interface.RACW_Stub_Type.
7828 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7831 Target_Info.Object :=
7832 Make_Selected_Component (Loc,
7834 Make_Identifier (Loc, Chars (RCI_Locator)),
7836 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7839 end Build_Stub_Target;
7841 ---------------------
7842 -- Build_Stub_Type --
7843 ---------------------
7845 procedure Build_Stub_Type
7846 (RACW_Type : Entity_Id;
7847 Stub_Type : Entity_Id;
7848 Stub_Type_Decl : out Node_Id;
7849 RPC_Receiver_Decl : out Node_Id)
7851 Loc : constant Source_Ptr := Sloc (Stub_Type);
7852 pragma Warnings (Off);
7853 pragma Unreferenced (RACW_Type);
7854 pragma Warnings (On);
7858 Make_Full_Type_Declaration (Loc,
7859 Defining_Identifier => Stub_Type,
7861 Make_Record_Definition (Loc,
7862 Tagged_Present => True,
7863 Limited_Present => True,
7865 Make_Component_List (Loc,
7866 Component_Items => New_List (
7868 Make_Component_Declaration (Loc,
7869 Defining_Identifier =>
7870 Make_Defining_Identifier (Loc, Name_Target),
7871 Component_Definition =>
7872 Make_Component_Definition (Loc,
7875 Subtype_Indication =>
7876 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7878 Make_Component_Declaration (Loc,
7879 Defining_Identifier =>
7880 Make_Defining_Identifier (Loc, Name_Asynchronous),
7881 Component_Definition =>
7882 Make_Component_Definition (Loc,
7883 Aliased_Present => False,
7884 Subtype_Indication =>
7886 Standard_Boolean, Loc)))))));
7888 RPC_Receiver_Decl :=
7889 Make_Object_Declaration (Loc,
7890 Defining_Identifier => Make_Defining_Identifier (Loc,
7891 New_Internal_Name ('R')),
7892 Aliased_Present => True,
7893 Object_Definition =>
7894 New_Occurrence_Of (RTE (RE_Servant), Loc));
7895 end Build_Stub_Type;
7897 -----------------------------
7898 -- Build_RPC_Receiver_Body --
7899 -----------------------------
7901 procedure Build_RPC_Receiver_Body
7902 (RPC_Receiver : Entity_Id;
7903 Request : out Entity_Id;
7904 Subp_Id : out Entity_Id;
7905 Subp_Index : out Entity_Id;
7906 Stmts : out List_Id;
7909 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7911 RPC_Receiver_Spec : Node_Id;
7912 RPC_Receiver_Decls : List_Id;
7915 Request := Make_Defining_Identifier (Loc, Name_R);
7917 RPC_Receiver_Spec :=
7918 Build_RPC_Receiver_Specification (
7919 RPC_Receiver => RPC_Receiver,
7920 Request_Parameter => Request);
7922 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7923 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7925 RPC_Receiver_Decls := New_List (
7926 Make_Object_Renaming_Declaration (Loc,
7927 Defining_Identifier => Subp_Id,
7928 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7930 Make_Explicit_Dereference (Loc,
7932 Make_Selected_Component (Loc,
7934 Selector_Name => Name_Operation))),
7936 Make_Object_Declaration (Loc,
7937 Defining_Identifier => Subp_Index,
7938 Object_Definition =>
7939 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7941 Make_Attribute_Reference (Loc,
7943 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7944 Attribute_Name => Name_Last)));
7949 Make_Subprogram_Body (Loc,
7950 Specification => RPC_Receiver_Spec,
7951 Declarations => RPC_Receiver_Decls,
7952 Handled_Statement_Sequence =>
7953 Make_Handled_Sequence_Of_Statements (Loc,
7954 Statements => Stmts));
7955 end Build_RPC_Receiver_Body;
7957 --------------------------------------
7958 -- Build_Subprogram_Receiving_Stubs --
7959 --------------------------------------
7961 function Build_Subprogram_Receiving_Stubs
7962 (Vis_Decl : Node_Id;
7963 Asynchronous : Boolean;
7964 Dynamically_Asynchronous : Boolean := False;
7965 Stub_Type : Entity_Id := Empty;
7966 RACW_Type : Entity_Id := Empty;
7967 Parent_Primitive : Entity_Id := Empty) return Node_Id
7969 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7971 Request_Parameter : constant Entity_Id :=
7972 Make_Defining_Identifier (Loc,
7973 New_Internal_Name ('R'));
7974 -- Formal parameter for receiving stubs: a descriptor for an incoming
7977 Outer_Decls : constant List_Id := New_List;
7978 -- At the outermost level, an NVList and Any's are declared for all
7979 -- parameters. The Dynamic_Async flag also needs to be declared there
7980 -- to be visible from the exception handling code.
7982 Outer_Statements : constant List_Id := New_List;
7983 -- Statements that occur prior to the declaration of the actual
7984 -- parameter variables.
7986 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7987 -- Statements concerning extra formal parameters, prior to the
7988 -- declaration of the actual parameter variables.
7990 Decls : constant List_Id := New_List;
7991 -- All the parameters will get declared before calling the real
7992 -- subprograms. Also the out parameters will be declared.
7993 -- At this level, parameters may be unconstrained.
7995 Statements : constant List_Id := New_List;
7997 After_Statements : constant List_Id := New_List;
7998 -- Statements to be executed after the subprogram call
8000 Inner_Decls : List_Id := No_List;
8001 -- In case of a function, the inner declarations are needed since
8002 -- the result may be unconstrained.
8004 Excep_Handlers : List_Id := No_List;
8006 Parameter_List : constant List_Id := New_List;
8007 -- List of parameters to be passed to the subprogram
8009 First_Controlling_Formal_Seen : Boolean := False;
8011 Current_Parameter : Node_Id;
8013 Ordered_Parameters_List : constant List_Id :=
8014 Build_Ordered_Parameters_List
8015 (Specification (Vis_Decl));
8017 Arguments : constant Entity_Id :=
8018 Make_Defining_Identifier (Loc,
8019 New_Internal_Name ('A'));
8020 -- Name of the named values list used to retrieve parameters
8022 Subp_Spec : Node_Id;
8023 -- Subprogram specification
8025 Called_Subprogram : Node_Id;
8026 -- The subprogram to call
8029 if Present (RACW_Type) then
8030 Called_Subprogram :=
8031 New_Occurrence_Of (Parent_Primitive, Loc);
8033 Called_Subprogram :=
8035 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
8038 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
8040 -- Loop through every parameter and get its value from the stream. If
8041 -- the parameter is unconstrained, then the parameter is read using
8042 -- 'Input at the point of declaration.
8044 Current_Parameter := First (Ordered_Parameters_List);
8045 while Present (Current_Parameter) loop
8048 Constrained : Boolean;
8049 Any : Entity_Id := Empty;
8050 Object : constant Entity_Id :=
8051 Make_Defining_Identifier (Loc,
8052 New_Internal_Name ('P'));
8053 Expr : Node_Id := Empty;
8055 Is_Controlling_Formal : constant Boolean
8056 := Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
8058 Is_First_Controlling_Formal : Boolean := False;
8060 Need_Extra_Constrained : Boolean;
8061 -- True when an extra constrained actual is required
8064 if Is_Controlling_Formal then
8066 -- Controlling formals in distributed object primitive
8067 -- operations are handled specially:
8068 -- - the first controlling formal is used as the
8069 -- target of the call;
8070 -- - the remaining controlling formals are transmitted
8074 Is_First_Controlling_Formal :=
8075 not First_Controlling_Formal_Seen;
8076 First_Controlling_Formal_Seen := True;
8078 Etyp := Etype (Parameter_Type (Current_Parameter));
8082 Is_Constrained (Etyp)
8083 or else Is_Elementary_Type (Etyp);
8085 if not Is_First_Controlling_Formal then
8086 Any := Make_Defining_Identifier (Loc,
8087 New_Internal_Name ('A'));
8088 Append_To (Outer_Decls,
8089 Make_Object_Declaration (Loc,
8090 Defining_Identifier =>
8092 Object_Definition =>
8093 New_Occurrence_Of (RTE (RE_Any), Loc),
8095 Make_Function_Call (Loc,
8097 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8098 Parameter_Associations => New_List (
8099 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
8100 Etyp, Outer_Decls)))));
8102 Append_To (Outer_Statements,
8103 Add_Parameter_To_NVList (Loc,
8104 Parameter => Current_Parameter,
8105 NVList => Arguments,
8106 Constrained => Constrained,
8110 if Is_First_Controlling_Formal then
8112 Addr : constant Entity_Id :=
8113 Make_Defining_Identifier (Loc,
8114 New_Internal_Name ('A'));
8115 Is_Local : constant Entity_Id :=
8116 Make_Defining_Identifier (Loc,
8117 New_Internal_Name ('L'));
8120 -- Special case: obtain the first controlling formal
8121 -- from the target of the remote call, instead of the
8124 Append_To (Outer_Decls,
8125 Make_Object_Declaration (Loc,
8126 Defining_Identifier =>
8128 Object_Definition =>
8129 New_Occurrence_Of (RTE (RE_Address), Loc)));
8130 Append_To (Outer_Decls,
8131 Make_Object_Declaration (Loc,
8132 Defining_Identifier =>
8134 Object_Definition =>
8135 New_Occurrence_Of (Standard_Boolean, Loc)));
8136 Append_To (Outer_Statements,
8137 Make_Procedure_Call_Statement (Loc,
8140 RTE (RE_Get_Local_Address), Loc),
8141 Parameter_Associations => New_List (
8142 Make_Selected_Component (Loc,
8145 Request_Parameter, Loc),
8147 Make_Identifier (Loc, Name_Target)),
8148 New_Occurrence_Of (Is_Local, Loc),
8149 New_Occurrence_Of (Addr, Loc))));
8151 Expr := Unchecked_Convert_To (RACW_Type,
8152 New_Occurrence_Of (Addr, Loc));
8155 elsif In_Present (Current_Parameter)
8156 or else not Out_Present (Current_Parameter)
8157 or else not Constrained
8159 -- If an input parameter is constrained, then its reading is
8160 -- deferred until the beginning of the subprogram body. If
8161 -- it is unconstrained, then an expression is built for
8162 -- the object declaration and the variable is set using
8163 -- 'Input instead of 'Read.
8165 Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
8166 Etyp, New_Occurrence_Of (Any, Loc), Decls);
8169 Append_To (Statements,
8170 Make_Assignment_Statement (Loc,
8172 New_Occurrence_Of (Object, Loc),
8178 -- Expr will be used to initialize (and constrain) the
8179 -- parameter when it is declared.
8184 Need_Extra_Constrained :=
8185 Nkind (Parameter_Type (Current_Parameter)) /=
8188 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
8190 Present (Extra_Constrained
8191 (Defining_Identifier (Current_Parameter)));
8193 -- We may not associate an extra constrained actual to a
8194 -- constant object, so if one is needed, declare the actual
8195 -- as a variable even if it won't be modified.
8197 Build_Actual_Object_Declaration
8200 Variable => Need_Extra_Constrained
8201 or else Out_Present (Current_Parameter),
8204 Set_Etype (Object, Etyp);
8206 -- An out parameter may be written back using a 'Write
8207 -- attribute instead of a 'Output because it has been
8208 -- constrained by the parameter given to the caller. Note that
8209 -- out controlling arguments in the case of a RACW are not put
8210 -- back in the stream because the pointer on them has not
8213 if Out_Present (Current_Parameter)
8214 and then not Is_Controlling_Formal
8216 Append_To (After_Statements,
8217 Make_Procedure_Call_Statement (Loc,
8219 New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
8220 Parameter_Associations => New_List (
8221 New_Occurrence_Of (Any, Loc),
8222 PolyORB_Support.Helpers.Build_To_Any_Call (
8223 New_Occurrence_Of (Object, Loc),
8227 -- For RACW controlling formals, the Etyp of Object is always
8228 -- an RACW, even if the parameter is not of an anonymous access
8229 -- type. In such case, we need to dereference it at call time.
8231 if Is_Controlling_Formal then
8232 if Nkind (Parameter_Type (Current_Parameter)) /=
8235 Append_To (Parameter_List,
8236 Make_Parameter_Association (Loc,
8239 Defining_Identifier (Current_Parameter), Loc),
8240 Explicit_Actual_Parameter =>
8241 Make_Explicit_Dereference (Loc,
8242 Unchecked_Convert_To (RACW_Type,
8243 OK_Convert_To (RTE (RE_Address),
8244 New_Occurrence_Of (Object, Loc))))));
8247 Append_To (Parameter_List,
8248 Make_Parameter_Association (Loc,
8251 Defining_Identifier (Current_Parameter), Loc),
8252 Explicit_Actual_Parameter =>
8253 Unchecked_Convert_To (RACW_Type,
8254 OK_Convert_To (RTE (RE_Address),
8255 New_Occurrence_Of (Object, Loc)))));
8259 Append_To (Parameter_List,
8260 Make_Parameter_Association (Loc,
8263 Defining_Identifier (Current_Parameter), Loc),
8264 Explicit_Actual_Parameter =>
8265 New_Occurrence_Of (Object, Loc)));
8268 -- If the current parameter needs an extra formal, then read it
8269 -- from the stream and set the corresponding semantic field in
8270 -- the variable. If the kind of the parameter identifier is
8271 -- E_Void, then this is a compiler generated parameter that
8272 -- doesn't need an extra constrained status.
8274 -- The case of Extra_Accessibility should also be handled ???
8276 if Need_Extra_Constrained then
8278 Extra_Parameter : constant Entity_Id :=
8280 (Defining_Identifier
8281 (Current_Parameter));
8282 Extra_Any : constant Entity_Id :=
8283 Make_Defining_Identifier
8284 (Loc, New_Internal_Name ('A'));
8286 Formal_Entity : constant Entity_Id :=
8287 Make_Defining_Identifier
8288 (Loc, Chars (Extra_Parameter));
8290 Formal_Type : constant Entity_Id :=
8291 Etype (Extra_Parameter);
8293 Append_To (Outer_Decls,
8294 Make_Object_Declaration (Loc,
8295 Defining_Identifier =>
8297 Object_Definition =>
8298 New_Occurrence_Of (RTE (RE_Any), Loc),
8300 Make_Function_Call (Loc,
8302 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8303 Parameter_Associations => New_List (
8304 PolyORB_Support.Helpers.Build_TypeCode_Call
8305 (Loc, Formal_Type, Outer_Decls)))));
8307 Append_To (Outer_Extra_Formal_Statements,
8308 Add_Parameter_To_NVList (Loc,
8309 Parameter => Extra_Parameter,
8310 NVList => Arguments,
8311 Constrained => True,
8315 Make_Object_Declaration (Loc,
8316 Defining_Identifier => Formal_Entity,
8317 Object_Definition =>
8318 New_Occurrence_Of (Formal_Type, Loc)));
8320 Append_To (Statements,
8321 Make_Assignment_Statement (Loc,
8323 New_Occurrence_Of (Formal_Entity, Loc),
8325 PolyORB_Support.Helpers.Build_From_Any_Call (
8327 New_Occurrence_Of (Extra_Any, Loc),
8329 Set_Extra_Constrained (Object, Formal_Entity);
8334 Next (Current_Parameter);
8337 -- Extra Formals should go after all the other parameters
8339 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8341 Append_To (Outer_Statements,
8342 Make_Procedure_Call_Statement (Loc,
8344 New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8345 Parameter_Associations => New_List (
8346 New_Occurrence_Of (Request_Parameter, Loc),
8347 New_Occurrence_Of (Arguments, Loc))));
8349 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8351 -- The remote subprogram is a function. We build an inner block to
8352 -- be able to hold a potentially unconstrained result in a
8356 Etyp : constant Entity_Id :=
8357 Etype (Result_Definition (Specification (Vis_Decl)));
8358 Result : constant Node_Id :=
8359 Make_Defining_Identifier (Loc,
8360 New_Internal_Name ('R'));
8362 Inner_Decls := New_List (
8363 Make_Object_Declaration (Loc,
8364 Defining_Identifier => Result,
8365 Constant_Present => True,
8366 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8368 Make_Function_Call (Loc,
8369 Name => Called_Subprogram,
8370 Parameter_Associations => Parameter_List)));
8372 if Is_Class_Wide_Type (Etyp) then
8374 -- For a remote call to a function with a class-wide type,
8375 -- check that the returned value satisfies the requirements
8378 Append_To (Inner_Decls,
8379 Make_Transportable_Check (Loc,
8380 New_Occurrence_Of (Result, Loc)));
8384 Set_Etype (Result, Etyp);
8385 Append_To (After_Statements,
8386 Make_Procedure_Call_Statement (Loc,
8388 New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8389 Parameter_Associations => New_List (
8390 New_Occurrence_Of (Request_Parameter, Loc),
8391 PolyORB_Support.Helpers.Build_To_Any_Call (
8392 New_Occurrence_Of (Result, Loc),
8394 -- A DSA function does not have out or inout arguments
8397 Append_To (Statements,
8398 Make_Block_Statement (Loc,
8399 Declarations => Inner_Decls,
8400 Handled_Statement_Sequence =>
8401 Make_Handled_Sequence_Of_Statements (Loc,
8402 Statements => After_Statements)));
8405 -- The remote subprogram is a procedure. We do not need any inner
8406 -- block in this case. No specific processing is required here for
8407 -- the dynamically asynchronous case: the indication of whether
8408 -- call is asynchronous or not is managed by the Sync_Scope
8409 -- attibute of the request, and is handled entirely in the
8412 Append_To (After_Statements,
8413 Make_Procedure_Call_Statement (Loc,
8415 New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8416 Parameter_Associations => New_List (
8417 New_Occurrence_Of (Request_Parameter, Loc))));
8419 Append_To (Statements,
8420 Make_Procedure_Call_Statement (Loc,
8421 Name => Called_Subprogram,
8422 Parameter_Associations => Parameter_List));
8424 Append_List_To (Statements, After_Statements);
8428 Make_Procedure_Specification (Loc,
8429 Defining_Unit_Name =>
8430 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
8432 Parameter_Specifications => New_List (
8433 Make_Parameter_Specification (Loc,
8434 Defining_Identifier => Request_Parameter,
8436 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8438 -- An exception raised during the execution of an incoming
8439 -- remote subprogram call and that needs to be sent back
8440 -- to the caller is propagated by the receiving stubs, and
8441 -- will be handled by the caller (the distribution runtime).
8443 if Asynchronous and then not Dynamically_Asynchronous then
8445 -- For an asynchronous procedure, add a null exception handler
8447 Excep_Handlers := New_List (
8448 Make_Implicit_Exception_Handler (Loc,
8449 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8450 Statements => New_List (Make_Null_Statement (Loc))));
8454 -- In the other cases, if an exception is raised, then the
8455 -- exception occurrence is propagated.
8460 Append_To (Outer_Statements,
8461 Make_Block_Statement (Loc,
8464 Handled_Statement_Sequence =>
8465 Make_Handled_Sequence_Of_Statements (Loc,
8466 Statements => Statements)));
8469 Make_Subprogram_Body (Loc,
8470 Specification => Subp_Spec,
8471 Declarations => Outer_Decls,
8472 Handled_Statement_Sequence =>
8473 Make_Handled_Sequence_Of_Statements (Loc,
8474 Statements => Outer_Statements,
8475 Exception_Handlers => Excep_Handlers));
8476 end Build_Subprogram_Receiving_Stubs;
8482 package body Helpers is
8484 -----------------------
8485 -- Local Subprograms --
8486 -----------------------
8488 function Find_Numeric_Representation
8489 (Typ : Entity_Id) return Entity_Id;
8490 -- Given a numeric type Typ, return the smallest integer or floating
8491 -- point type from Standard, or the smallest unsigned (modular) type
8492 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8494 function Make_Stream_Procedure_Function_Name
8497 Nam : Name_Id) return Entity_Id;
8498 -- Return the name to be assigned for stream subprogram Nam of Typ.
8499 -- (copied from exp_strm.adb, should be shared???)
8501 ------------------------------------------------------------
8502 -- Common subprograms for building various tree fragments --
8503 ------------------------------------------------------------
8505 function Build_Get_Aggregate_Element
8509 Idx : Node_Id) return Node_Id;
8510 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8511 -- returning the Idx'th element.
8514 Subprogram : Entity_Id;
8515 -- Reference location for constructed nodes
8518 -- For 'Range and Etype
8521 -- For the construction of the innermost element expression
8523 with procedure Add_Process_Element
8526 Counter : Entity_Id;
8529 procedure Append_Array_Traversal
8532 Counter : Entity_Id := Empty;
8534 -- Build nested loop statements that iterate over the elements of an
8535 -- array Arry. The statement(s) built by Add_Process_Element are
8536 -- executed for each element; Indices is the list of indices to be
8537 -- used in the construction of the indexed component that denotes the
8538 -- current element. Subprogram is the entity for the subprogram for
8539 -- which this iterator is generated. The generated statements are
8540 -- appended to Stmts.
8544 -- The record entity being dealt with
8546 with procedure Add_Process_Element
8548 Container : Node_Or_Entity_Id;
8549 Counter : in out Int;
8552 -- Rec is the instance of the record type, or Empty.
8553 -- Field is either the N_Defining_Identifier for a component,
8554 -- or an N_Variant_Part.
8556 procedure Append_Record_Traversal
8559 Container : Node_Or_Entity_Id;
8560 Counter : in out Int);
8561 -- Process component list Clist. Individual fields are passed
8562 -- to Field_Processing. Each variant part is also processed.
8563 -- Container is the outer Any (for From_Any/To_Any),
8564 -- the outer typecode (for TC) to which the operation applies.
8566 -----------------------------
8567 -- Append_Record_Traversal --
8568 -----------------------------
8570 procedure Append_Record_Traversal
8573 Container : Node_Or_Entity_Id;
8574 Counter : in out Int)
8578 -- Clist's Component_Items and Variant_Part
8588 CI := Component_Items (Clist);
8589 VP := Variant_Part (Clist);
8592 while Present (Item) loop
8593 Def := Defining_Identifier (Item);
8595 if not Is_Internal_Name (Chars (Def)) then
8597 (Stmts, Container, Counter, Rec, Def);
8603 if Present (VP) then
8604 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8606 end Append_Record_Traversal;
8608 -------------------------
8609 -- Build_From_Any_Call --
8610 -------------------------
8612 function Build_From_Any_Call
8615 Decls : List_Id) return Node_Id
8617 Loc : constant Source_Ptr := Sloc (N);
8619 U_Type : Entity_Id := Underlying_Type (Typ);
8621 Fnam : Entity_Id := Empty;
8622 Lib_RE : RE_Id := RE_Null;
8626 -- First simple case where the From_Any function is present
8627 -- in the type's TSS.
8629 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8631 if Sloc (U_Type) <= Standard_Location then
8632 U_Type := Base_Type (U_Type);
8635 -- Check first for Boolean and Character. These are enumeration
8636 -- types, but we treat them specially, since they may require
8637 -- special handling in the transfer protocol. However, this
8638 -- special handling only applies if they have standard
8639 -- representation, otherwise they are treated like any other
8640 -- enumeration type.
8642 if Present (Fnam) then
8645 elsif U_Type = Standard_Boolean then
8648 elsif U_Type = Standard_Character then
8651 elsif U_Type = Standard_Wide_Character then
8654 elsif U_Type = Standard_Wide_Wide_Character then
8655 Lib_RE := RE_FA_WWC;
8657 -- Floating point types
8659 elsif U_Type = Standard_Short_Float then
8662 elsif U_Type = Standard_Float then
8665 elsif U_Type = Standard_Long_Float then
8668 elsif U_Type = Standard_Long_Long_Float then
8669 Lib_RE := RE_FA_LLF;
8673 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8674 Lib_RE := RE_FA_SSI;
8676 elsif U_Type = Etype (Standard_Short_Integer) then
8679 elsif U_Type = Etype (Standard_Integer) then
8682 elsif U_Type = Etype (Standard_Long_Integer) then
8685 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8686 Lib_RE := RE_FA_LLI;
8688 -- Unsigned integer types
8690 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8691 Lib_RE := RE_FA_SSU;
8693 elsif U_Type = RTE (RE_Short_Unsigned) then
8696 elsif U_Type = RTE (RE_Unsigned) then
8699 elsif U_Type = RTE (RE_Long_Unsigned) then
8702 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8703 Lib_RE := RE_FA_LLU;
8705 elsif U_Type = Standard_String then
8706 Lib_RE := RE_FA_String;
8708 -- Other (non-primitive) types
8714 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8715 Append_To (Decls, Decl);
8719 -- Call the function
8721 if Lib_RE /= RE_Null then
8722 pragma Assert (No (Fnam));
8723 Fnam := RTE (Lib_RE);
8727 Make_Function_Call (Loc,
8728 Name => New_Occurrence_Of (Fnam, Loc),
8729 Parameter_Associations => New_List (N));
8731 -- We must set the type of Result, so the unchecked conversion
8732 -- from the underlying type to the base type is properly done.
8734 Set_Etype (Result, U_Type);
8736 return Unchecked_Convert_To (Typ, Result);
8737 end Build_From_Any_Call;
8739 -----------------------------
8740 -- Build_From_Any_Function --
8741 -----------------------------
8743 procedure Build_From_Any_Function
8747 Fnam : out Entity_Id)
8750 Decls : constant List_Id := New_List;
8751 Stms : constant List_Id := New_List;
8753 Any_Parameter : constant Entity_Id :=
8754 Make_Defining_Identifier (Loc,
8755 New_Internal_Name ('A'));
8757 Use_Opaque_Representation : Boolean;
8760 if Is_Itype (Typ) then
8761 Build_From_Any_Function
8769 Fnam := Make_Stream_Procedure_Function_Name (Loc,
8770 Typ, Name_uFrom_Any);
8773 Make_Function_Specification (Loc,
8774 Defining_Unit_Name => Fnam,
8775 Parameter_Specifications => New_List (
8776 Make_Parameter_Specification (Loc,
8777 Defining_Identifier =>
8780 New_Occurrence_Of (RTE (RE_Any), Loc))),
8781 Result_Definition => New_Occurrence_Of (Typ, Loc));
8783 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8786 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8788 Use_Opaque_Representation := False;
8790 if Has_Stream_Attribute_Definition
8791 (Typ, TSS_Stream_Output, At_Any_Place => True)
8793 Has_Stream_Attribute_Definition
8794 (Typ, TSS_Stream_Write, At_Any_Place => True)
8796 -- If user-defined stream attributes are specified for this
8797 -- type, use them and transmit data as an opaque sequence of
8800 Use_Opaque_Representation := True;
8802 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
8804 Make_Simple_Return_Statement (Loc,
8808 Build_From_Any_Call (
8810 New_Occurrence_Of (Any_Parameter, Loc),
8813 elsif Is_Record_Type (Typ)
8814 and then not Is_Derived_Type (Typ)
8815 and then not Is_Tagged_Type (Typ)
8817 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8819 Make_Simple_Return_Statement (Loc,
8823 Build_From_Any_Call (
8825 New_Occurrence_Of (Any_Parameter, Loc),
8829 Disc : Entity_Id := Empty;
8830 Discriminant_Associations : List_Id;
8831 Rdef : constant Node_Id :=
8832 Type_Definition (Declaration_Node (Typ));
8833 Component_Counter : Int := 0;
8835 -- The returned object
8837 Res : constant Entity_Id :=
8838 Make_Defining_Identifier (Loc,
8839 New_Internal_Name ('R'));
8841 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8843 procedure FA_Rec_Add_Process_Element
8846 Counter : in out Int;
8850 procedure FA_Append_Record_Traversal is
8851 new Append_Record_Traversal
8853 Add_Process_Element => FA_Rec_Add_Process_Element);
8855 --------------------------------
8856 -- FA_Rec_Add_Process_Element --
8857 --------------------------------
8859 procedure FA_Rec_Add_Process_Element
8862 Counter : in out Int;
8867 if Nkind (Field) = N_Defining_Identifier then
8869 -- A regular component
8872 Make_Assignment_Statement (Loc,
8873 Name => Make_Selected_Component (Loc,
8875 New_Occurrence_Of (Rec, Loc),
8877 New_Occurrence_Of (Field, Loc)),
8879 Build_From_Any_Call (Etype (Field),
8880 Build_Get_Aggregate_Element (Loc,
8882 TC => Build_TypeCode_Call (Loc,
8883 Etype (Field), Decls),
8884 Idx => Make_Integer_Literal (Loc,
8893 Struct_Counter : Int := 0;
8895 Block_Decls : constant List_Id := New_List;
8896 Block_Stmts : constant List_Id := New_List;
8899 Alt_List : constant List_Id := New_List;
8900 Choice_List : List_Id;
8902 Struct_Any : constant Entity_Id :=
8903 Make_Defining_Identifier (Loc,
8904 New_Internal_Name ('S'));
8908 Make_Object_Declaration (Loc,
8909 Defining_Identifier =>
8913 Object_Definition =>
8914 New_Occurrence_Of (RTE (RE_Any), Loc),
8916 Make_Function_Call (Loc,
8917 Name => New_Occurrence_Of (
8918 RTE (RE_Extract_Union_Value), Loc),
8919 Parameter_Associations => New_List (
8920 Build_Get_Aggregate_Element (Loc,
8923 Make_Function_Call (Loc,
8924 Name => New_Occurrence_Of (
8925 RTE (RE_Any_Member_Type), Loc),
8926 Parameter_Associations =>
8928 New_Occurrence_Of (Any, Loc),
8929 Make_Integer_Literal (Loc,
8930 Intval => Counter))),
8932 Make_Integer_Literal (Loc,
8933 Intval => Counter))))));
8936 Make_Block_Statement (Loc,
8939 Handled_Statement_Sequence =>
8940 Make_Handled_Sequence_Of_Statements (Loc,
8941 Statements => Block_Stmts)));
8943 Append_To (Block_Stmts,
8944 Make_Case_Statement (Loc,
8946 Make_Selected_Component (Loc,
8949 Chars (Name (Field))),
8953 Variant := First_Non_Pragma (Variants (Field));
8954 while Present (Variant) loop
8955 Choice_List := New_Copy_List_Tree
8956 (Discrete_Choices (Variant));
8958 VP_Stmts := New_List;
8960 -- Struct_Counter should be reset before
8961 -- handling a variant part. Indeed only one
8962 -- of the case statement alternatives will be
8963 -- executed at run-time, so the counter must
8964 -- start at 0 for every case statement.
8966 Struct_Counter := 0;
8968 FA_Append_Record_Traversal (
8970 Clist => Component_List (Variant),
8971 Container => Struct_Any,
8972 Counter => Struct_Counter);
8974 Append_To (Alt_List,
8975 Make_Case_Statement_Alternative (Loc,
8976 Discrete_Choices => Choice_List,
8979 Next_Non_Pragma (Variant);
8983 Counter := Counter + 1;
8984 end FA_Rec_Add_Process_Element;
8987 -- First all discriminants
8989 if Has_Discriminants (Typ) then
8990 Discriminant_Associations := New_List;
8992 Disc := First_Discriminant (Typ);
8993 while Present (Disc) loop
8995 Disc_Var_Name : constant Entity_Id :=
8996 Make_Defining_Identifier (Loc,
8997 Chars => Chars (Disc));
8998 Disc_Type : constant Entity_Id :=
9003 Make_Object_Declaration (Loc,
9004 Defining_Identifier =>
9006 Constant_Present => True,
9007 Object_Definition =>
9008 New_Occurrence_Of (Disc_Type, Loc),
9010 Build_From_Any_Call (Disc_Type,
9011 Build_Get_Aggregate_Element (Loc,
9012 Any => Any_Parameter,
9013 TC => Build_TypeCode_Call
9014 (Loc, Disc_Type, Decls),
9015 Idx => Make_Integer_Literal (Loc,
9016 Intval => Component_Counter)),
9018 Component_Counter := Component_Counter + 1;
9020 Append_To (Discriminant_Associations,
9021 Make_Discriminant_Association (Loc,
9022 Selector_Names => New_List (
9023 New_Occurrence_Of (Disc, Loc)),
9025 New_Occurrence_Of (Disc_Var_Name, Loc)));
9027 Next_Discriminant (Disc);
9031 Make_Subtype_Indication (Loc,
9032 Subtype_Mark => Res_Definition,
9034 Make_Index_Or_Discriminant_Constraint (Loc,
9035 Discriminant_Associations));
9038 -- Now we have all the discriminants in variables, we can
9039 -- declared a constrained object. Note that we are not
9040 -- initializing (non-discriminant) components directly in
9041 -- the object declarations, because which fields to
9042 -- initialize depends (at run time) on the discriminant
9046 Make_Object_Declaration (Loc,
9047 Defining_Identifier =>
9049 Object_Definition =>
9052 -- ... then all components
9054 FA_Append_Record_Traversal (Stms,
9055 Clist => Component_List (Rdef),
9056 Container => Any_Parameter,
9057 Counter => Component_Counter);
9060 Make_Simple_Return_Statement (Loc,
9061 Expression => New_Occurrence_Of (Res, Loc)));
9065 elsif Is_Array_Type (Typ) then
9067 Constrained : constant Boolean := Is_Constrained (Typ);
9069 procedure FA_Ary_Add_Process_Element
9072 Counter : Entity_Id;
9074 -- Assign the current element (as identified by Counter) of
9075 -- Any to the variable denoted by name Datum, and advance
9076 -- Counter by 1. If Datum is not an Any, a call to From_Any
9077 -- for its type is inserted.
9079 --------------------------------
9080 -- FA_Ary_Add_Process_Element --
9081 --------------------------------
9083 procedure FA_Ary_Add_Process_Element
9086 Counter : Entity_Id;
9089 Assignment : constant Node_Id :=
9090 Make_Assignment_Statement (Loc,
9092 Expression => Empty);
9094 Element_Any : Node_Id;
9098 Element_TC : Node_Id;
9101 if Etype (Datum) = RTE (RE_Any) then
9103 -- When Datum is an Any the Etype field is not
9104 -- sufficient to determine the typecode of Datum
9105 -- (which can be a TC_SEQUENCE or TC_ARRAY
9106 -- depending on the value of Constrained).
9107 -- Therefore we retrieve the typecode which has
9108 -- been constructed in Append_Array_Traversal with
9109 -- a call to Get_Any_Type.
9112 Make_Function_Call (Loc,
9113 Name => New_Occurrence_Of (
9114 RTE (RE_Get_Any_Type), Loc),
9115 Parameter_Associations => New_List (
9116 New_Occurrence_Of (Entity (Datum), Loc)));
9118 -- For non Any Datum we simply construct a typecode
9119 -- matching the Etype of the Datum.
9121 Element_TC := Build_TypeCode_Call
9122 (Loc, Etype (Datum), Decls);
9126 Build_Get_Aggregate_Element (Loc,
9129 Idx => New_Occurrence_Of (Counter, Loc));
9132 -- Note: here we *prepend* statements to Stmts, so
9133 -- we must do it in reverse order.
9136 Make_Assignment_Statement (Loc,
9138 New_Occurrence_Of (Counter, Loc),
9142 New_Occurrence_Of (Counter, Loc),
9144 Make_Integer_Literal (Loc, 1))));
9146 if Nkind (Datum) /= N_Attribute_Reference then
9148 -- We ignore the value of the length of each
9149 -- dimension, since the target array has already
9150 -- been constrained anyway.
9152 if Etype (Datum) /= RTE (RE_Any) then
9153 Set_Expression (Assignment,
9154 Build_From_Any_Call (
9155 Component_Type (Typ),
9159 Set_Expression (Assignment, Element_Any);
9162 Prepend_To (Stmts, Assignment);
9164 end FA_Ary_Add_Process_Element;
9166 ------------------------
9167 -- Local Declarations --
9168 ------------------------
9170 Counter : constant Entity_Id :=
9171 Make_Defining_Identifier (Loc, Name_J);
9173 Initial_Counter_Value : Int := 0;
9175 Component_TC : constant Entity_Id :=
9176 Make_Defining_Identifier (Loc, Name_T);
9178 Res : constant Entity_Id :=
9179 Make_Defining_Identifier (Loc, Name_R);
9181 procedure Append_From_Any_Array_Iterator is
9182 new Append_Array_Traversal (
9185 Indices => New_List,
9186 Add_Process_Element => FA_Ary_Add_Process_Element);
9188 Res_Subtype_Indication : Node_Id :=
9189 New_Occurrence_Of (Typ, Loc);
9192 if not Constrained then
9194 Ndim : constant Int := Number_Dimensions (Typ);
9197 Indx : Node_Id := First_Index (Typ);
9200 Ranges : constant List_Id := New_List;
9203 for J in 1 .. Ndim loop
9204 Lnam := New_External_Name ('L', J);
9205 Hnam := New_External_Name ('H', J);
9206 Indt := Etype (Indx);
9209 Make_Object_Declaration (Loc,
9210 Defining_Identifier =>
9211 Make_Defining_Identifier (Loc, Lnam),
9214 Object_Definition =>
9215 New_Occurrence_Of (Indt, Loc),
9217 Build_From_Any_Call (
9219 Build_Get_Aggregate_Element (Loc,
9220 Any => Any_Parameter,
9221 TC => Build_TypeCode_Call (Loc,
9223 Idx => Make_Integer_Literal (Loc, J - 1)),
9227 Make_Object_Declaration (Loc,
9228 Defining_Identifier =>
9229 Make_Defining_Identifier (Loc, Hnam),
9232 Object_Definition =>
9233 New_Occurrence_Of (Indt, Loc),
9234 Expression => Make_Attribute_Reference (Loc,
9236 New_Occurrence_Of (Indt, Loc),
9237 Attribute_Name => Name_Val,
9238 Expressions => New_List (
9239 Make_Op_Subtract (Loc,
9244 Standard_Long_Integer,
9245 Make_Identifier (Loc, Lnam)),
9248 Standard_Long_Integer,
9249 Make_Function_Call (Loc,
9251 New_Occurrence_Of (RTE (
9252 RE_Get_Nested_Sequence_Length
9254 Parameter_Associations =>
9257 Any_Parameter, Loc),
9258 Make_Integer_Literal (Loc,
9261 Make_Integer_Literal (Loc, 1))))));
9265 Low_Bound => Make_Identifier (Loc, Lnam),
9266 High_Bound => Make_Identifier (Loc, Hnam)));
9271 -- Now we have all the necessary bound information:
9272 -- apply the set of range constraints to the
9273 -- (unconstrained) nominal subtype of Res.
9275 Initial_Counter_Value := Ndim;
9276 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9278 Res_Subtype_Indication,
9280 Make_Index_Or_Discriminant_Constraint (Loc,
9281 Constraints => Ranges));
9286 Make_Object_Declaration (Loc,
9287 Defining_Identifier => Res,
9288 Object_Definition => Res_Subtype_Indication));
9289 Set_Etype (Res, Typ);
9292 Make_Object_Declaration (Loc,
9293 Defining_Identifier => Counter,
9294 Object_Definition =>
9295 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
9297 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9300 Make_Object_Declaration (Loc,
9301 Defining_Identifier => Component_TC,
9302 Constant_Present => True,
9303 Object_Definition =>
9304 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9306 Build_TypeCode_Call (Loc,
9307 Component_Type (Typ), Decls)));
9309 Append_From_Any_Array_Iterator (Stms,
9310 Any_Parameter, Counter);
9313 Make_Simple_Return_Statement (Loc,
9314 Expression => New_Occurrence_Of (Res, Loc)));
9317 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9319 Make_Simple_Return_Statement (Loc,
9321 Unchecked_Convert_To (
9323 Build_From_Any_Call (
9324 Find_Numeric_Representation (Typ),
9325 New_Occurrence_Of (Any_Parameter, Loc),
9329 Use_Opaque_Representation := True;
9332 if Use_Opaque_Representation then
9334 -- Default: type is represented as an opaque sequence of bytes
9337 Strm : constant Entity_Id :=
9338 Make_Defining_Identifier (Loc,
9339 Chars => New_Internal_Name ('S'));
9340 Res : constant Entity_Id :=
9341 Make_Defining_Identifier (Loc,
9342 Chars => New_Internal_Name ('R'));
9345 -- Strm : Buffer_Stream_Type;
9348 Make_Object_Declaration (Loc,
9349 Defining_Identifier =>
9353 Object_Definition =>
9354 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9356 -- Allocate_Buffer (Strm);
9359 Make_Procedure_Call_Statement (Loc,
9361 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9362 Parameter_Associations => New_List (
9363 New_Occurrence_Of (Strm, Loc))));
9365 -- Any_To_BS (Strm, A);
9368 Make_Procedure_Call_Statement (Loc,
9370 New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
9371 Parameter_Associations => New_List (
9372 New_Occurrence_Of (Any_Parameter, Loc),
9373 New_Occurrence_Of (Strm, Loc))));
9376 -- Res : constant T := T'Input (Strm);
9378 -- Release_Buffer (Strm);
9382 Append_To (Stms, Make_Block_Statement (Loc,
9383 Declarations => New_List (
9384 Make_Object_Declaration (Loc,
9385 Defining_Identifier => Res,
9386 Constant_Present => True,
9387 Object_Definition =>
9388 New_Occurrence_Of (Typ, Loc),
9390 Make_Attribute_Reference (Loc,
9391 Prefix => New_Occurrence_Of (Typ, Loc),
9392 Attribute_Name => Name_Input,
9393 Expressions => New_List (
9394 Make_Attribute_Reference (Loc,
9395 Prefix => New_Occurrence_Of (Strm, Loc),
9396 Attribute_Name => Name_Access))))),
9398 Handled_Statement_Sequence =>
9399 Make_Handled_Sequence_Of_Statements (Loc,
9400 Statements => New_List (
9401 Make_Procedure_Call_Statement (Loc,
9403 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
9404 Parameter_Associations =>
9406 New_Occurrence_Of (Strm, Loc))),
9407 Make_Simple_Return_Statement (Loc,
9408 Expression => New_Occurrence_Of (Res, Loc))))));
9414 Make_Subprogram_Body (Loc,
9415 Specification => Spec,
9416 Declarations => Decls,
9417 Handled_Statement_Sequence =>
9418 Make_Handled_Sequence_Of_Statements (Loc,
9419 Statements => Stms));
9420 end Build_From_Any_Function;
9422 ---------------------------------
9423 -- Build_Get_Aggregate_Element --
9424 ---------------------------------
9426 function Build_Get_Aggregate_Element
9430 Idx : Node_Id) return Node_Id
9433 return Make_Function_Call (Loc,
9436 RTE (RE_Get_Aggregate_Element), Loc),
9437 Parameter_Associations => New_List (
9438 New_Occurrence_Of (Any, Loc),
9441 end Build_Get_Aggregate_Element;
9443 -------------------------
9444 -- Build_Reposiroty_Id --
9445 -------------------------
9447 procedure Build_Name_And_Repository_Id
9449 Name_Str : out String_Id;
9450 Repo_Id_Str : out String_Id)
9454 Store_String_Chars ("DSA:");
9455 Get_Library_Unit_Name_String (Scope (E));
9457 (Name_Buffer (Name_Buffer'First ..
9458 Name_Buffer'First + Name_Len - 1));
9459 Store_String_Char ('.');
9460 Get_Name_String (Chars (E));
9462 (Name_Buffer (Name_Buffer'First ..
9463 Name_Buffer'First + Name_Len - 1));
9464 Store_String_Chars (":1.0");
9465 Repo_Id_Str := End_String;
9466 Name_Str := String_From_Name_Buffer;
9467 end Build_Name_And_Repository_Id;
9469 -----------------------
9470 -- Build_To_Any_Call --
9471 -----------------------
9473 function Build_To_Any_Call
9475 Decls : List_Id) return Node_Id
9477 Loc : constant Source_Ptr := Sloc (N);
9479 Typ : Entity_Id := Etype (N);
9481 Fnam : Entity_Id := Empty;
9482 Lib_RE : RE_Id := RE_Null;
9485 -- If N is a selected component, then maybe its Etype has not been
9486 -- set yet: try to use Etype of the selector_name in that case.
9488 if No (Typ) and then Nkind (N) = N_Selected_Component then
9489 Typ := Etype (Selector_Name (N));
9491 pragma Assert (Present (Typ));
9493 -- Get full view for private type, completion for incomplete type
9495 U_Type := Underlying_Type (Typ);
9497 -- First simple case where the To_Any function is present in the
9500 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9502 -- Check first for Boolean and Character. These are enumeration
9503 -- types, but we treat them specially, since they may require
9504 -- special handling in the transfer protocol. However, this
9505 -- special handling only applies if they have standard
9506 -- representation, otherwise they are treated like any other
9507 -- enumeration type.
9509 if Sloc (U_Type) <= Standard_Location then
9510 U_Type := Base_Type (U_Type);
9513 if Present (Fnam) then
9516 elsif U_Type = Standard_Boolean then
9519 elsif U_Type = Standard_Character then
9522 elsif U_Type = Standard_Wide_Character then
9525 elsif U_Type = Standard_Wide_Wide_Character then
9526 Lib_RE := RE_TA_WWC;
9528 -- Floating point types
9530 elsif U_Type = Standard_Short_Float then
9533 elsif U_Type = Standard_Float then
9536 elsif U_Type = Standard_Long_Float then
9539 elsif U_Type = Standard_Long_Long_Float then
9540 Lib_RE := RE_TA_LLF;
9544 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9545 Lib_RE := RE_TA_SSI;
9547 elsif U_Type = Etype (Standard_Short_Integer) then
9550 elsif U_Type = Etype (Standard_Integer) then
9553 elsif U_Type = Etype (Standard_Long_Integer) then
9556 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9557 Lib_RE := RE_TA_LLI;
9559 -- Unsigned integer types
9561 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9562 Lib_RE := RE_TA_SSU;
9564 elsif U_Type = RTE (RE_Short_Unsigned) then
9567 elsif U_Type = RTE (RE_Unsigned) then
9570 elsif U_Type = RTE (RE_Long_Unsigned) then
9573 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9574 Lib_RE := RE_TA_LLU;
9576 elsif U_Type = Standard_String then
9577 Lib_RE := RE_TA_String;
9579 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9582 -- Other (non-primitive) types
9588 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9589 Append_To (Decls, Decl);
9593 -- Call the function
9595 if Lib_RE /= RE_Null then
9596 pragma Assert (No (Fnam));
9597 Fnam := RTE (Lib_RE);
9601 Make_Function_Call (Loc,
9602 Name => New_Occurrence_Of (Fnam, Loc),
9603 Parameter_Associations =>
9604 New_List (Unchecked_Convert_To (U_Type, N)));
9605 end Build_To_Any_Call;
9607 ---------------------------
9608 -- Build_To_Any_Function --
9609 ---------------------------
9611 procedure Build_To_Any_Function
9615 Fnam : out Entity_Id)
9618 Decls : constant List_Id := New_List;
9619 Stms : constant List_Id := New_List;
9621 Expr_Parameter : constant Entity_Id :=
9622 Make_Defining_Identifier (Loc, Name_E);
9624 Any : constant Entity_Id :=
9625 Make_Defining_Identifier (Loc, Name_A);
9628 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9630 Use_Opaque_Representation : Boolean;
9631 -- When True, use stream attributes and represent type as an
9632 -- opaque sequence of bytes.
9635 if Is_Itype (Typ) then
9636 Build_To_Any_Function
9645 Make_Stream_Procedure_Function_Name (Loc, Typ, Name_uTo_Any);
9648 Make_Function_Specification (Loc,
9649 Defining_Unit_Name => Fnam,
9650 Parameter_Specifications => New_List (
9651 Make_Parameter_Specification (Loc,
9652 Defining_Identifier =>
9655 New_Occurrence_Of (Typ, Loc))),
9656 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9657 Set_Etype (Expr_Parameter, Typ);
9660 Make_Object_Declaration (Loc,
9661 Defining_Identifier =>
9663 Object_Definition =>
9664 New_Occurrence_Of (RTE (RE_Any), Loc));
9666 Use_Opaque_Representation := False;
9668 if Has_Stream_Attribute_Definition
9669 (Typ, TSS_Stream_Output, At_Any_Place => True)
9671 Has_Stream_Attribute_Definition
9672 (Typ, TSS_Stream_Write, At_Any_Place => True)
9674 -- If user-defined stream attributes are specified for this
9675 -- type, use them and transmit data as an opaque sequence of
9678 Use_Opaque_Representation := True;
9680 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9682 -- Non-tagged derived type: convert to root type
9685 Rt_Type : constant Entity_Id := Root_Type (Typ);
9686 Expr : constant Node_Id :=
9689 New_Occurrence_Of (Expr_Parameter, Loc));
9691 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9694 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9696 -- Non-tagged record type
9698 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9700 Rt_Type : constant Entity_Id := Etype (Typ);
9701 Expr : constant Node_Id :=
9702 OK_Convert_To (Rt_Type,
9703 New_Occurrence_Of (Expr_Parameter, Loc));
9706 Set_Expression (Any_Decl,
9707 Build_To_Any_Call (Expr, Decls));
9710 -- Comment needed here (and label on declare block ???)
9714 Disc : Entity_Id := Empty;
9715 Rdef : constant Node_Id :=
9716 Type_Definition (Declaration_Node (Typ));
9718 Elements : constant List_Id := New_List;
9720 procedure TA_Rec_Add_Process_Element
9722 Container : Node_Or_Entity_Id;
9723 Counter : in out Int;
9726 -- Processing routine for traversal below
9728 procedure TA_Append_Record_Traversal is
9729 new Append_Record_Traversal
9730 (Rec => Expr_Parameter,
9731 Add_Process_Element => TA_Rec_Add_Process_Element);
9733 --------------------------------
9734 -- TA_Rec_Add_Process_Element --
9735 --------------------------------
9737 procedure TA_Rec_Add_Process_Element
9739 Container : Node_Or_Entity_Id;
9740 Counter : in out Int;
9744 Field_Ref : Node_Id;
9747 if Nkind (Field) = N_Defining_Identifier then
9749 -- A regular component
9751 Field_Ref := Make_Selected_Component (Loc,
9752 Prefix => New_Occurrence_Of (Rec, Loc),
9753 Selector_Name => New_Occurrence_Of (Field, Loc));
9754 Set_Etype (Field_Ref, Etype (Field));
9757 Make_Procedure_Call_Statement (Loc,
9760 RTE (RE_Add_Aggregate_Element), Loc),
9761 Parameter_Associations => New_List (
9762 New_Occurrence_Of (Container, Loc),
9763 Build_To_Any_Call (Field_Ref, Decls))));
9768 Variant_Part : declare
9770 Struct_Counter : Int := 0;
9772 Block_Decls : constant List_Id := New_List;
9773 Block_Stmts : constant List_Id := New_List;
9776 Alt_List : constant List_Id := New_List;
9777 Choice_List : List_Id;
9779 Union_Any : constant Entity_Id :=
9780 Make_Defining_Identifier (Loc,
9781 New_Internal_Name ('V'));
9783 Struct_Any : constant Entity_Id :=
9784 Make_Defining_Identifier (Loc,
9785 New_Internal_Name ('S'));
9787 function Make_Discriminant_Reference
9789 -- Build reference to the discriminant for this
9792 ---------------------------------
9793 -- Make_Discriminant_Reference --
9794 ---------------------------------
9796 function Make_Discriminant_Reference
9799 Nod : constant Node_Id :=
9800 Make_Selected_Component (Loc,
9803 Chars (Name (Field)));
9805 Set_Etype (Nod, Etype (Name (Field)));
9807 end Make_Discriminant_Reference;
9809 -- Start processing for Variant_Part
9813 Make_Block_Statement (Loc,
9816 Handled_Statement_Sequence =>
9817 Make_Handled_Sequence_Of_Statements (Loc,
9818 Statements => Block_Stmts)));
9820 -- Declare variant part aggregate (Union_Any).
9821 -- Knowing the position of this VP in the
9822 -- variant record, we can fetch the VP typecode
9825 Append_To (Block_Decls,
9826 Make_Object_Declaration (Loc,
9827 Defining_Identifier => Union_Any,
9828 Object_Definition =>
9829 New_Occurrence_Of (RTE (RE_Any), Loc),
9831 Make_Function_Call (Loc,
9832 Name => New_Occurrence_Of (
9833 RTE (RE_Create_Any), Loc),
9834 Parameter_Associations => New_List (
9835 Make_Function_Call (Loc,
9838 RTE (RE_Any_Member_Type), Loc),
9839 Parameter_Associations => New_List (
9840 New_Occurrence_Of (Container, Loc),
9841 Make_Integer_Literal (Loc,
9844 -- Declare inner struct aggregate (which
9845 -- contains the components of this VP).
9847 Append_To (Block_Decls,
9848 Make_Object_Declaration (Loc,
9849 Defining_Identifier => Struct_Any,
9850 Object_Definition =>
9851 New_Occurrence_Of (RTE (RE_Any), Loc),
9853 Make_Function_Call (Loc,
9854 Name => New_Occurrence_Of (
9855 RTE (RE_Create_Any), Loc),
9856 Parameter_Associations => New_List (
9857 Make_Function_Call (Loc,
9860 RTE (RE_Any_Member_Type), Loc),
9861 Parameter_Associations => New_List (
9862 New_Occurrence_Of (Union_Any, Loc),
9863 Make_Integer_Literal (Loc,
9866 -- Build case statement
9868 Append_To (Block_Stmts,
9869 Make_Case_Statement (Loc,
9871 Make_Discriminant_Reference,
9875 Variant := First_Non_Pragma (Variants (Field));
9876 while Present (Variant) loop
9877 Choice_List := New_Copy_List_Tree
9878 (Discrete_Choices (Variant));
9880 VP_Stmts := New_List;
9882 -- Append discriminant val to union aggregate
9884 Append_To (VP_Stmts,
9885 Make_Procedure_Call_Statement (Loc,
9888 RTE (RE_Add_Aggregate_Element), Loc),
9889 Parameter_Associations => New_List (
9890 New_Occurrence_Of (Union_Any, Loc),
9892 Make_Discriminant_Reference,
9895 -- Populate inner struct aggregate
9897 -- Struct_Counter should be reset before
9898 -- handling a variant part. Indeed only one
9899 -- of the case statement alternatives will be
9900 -- executed at run-time, so the counter must
9901 -- start at 0 for every case statement.
9903 Struct_Counter := 0;
9905 TA_Append_Record_Traversal (
9907 Clist => Component_List (Variant),
9908 Container => Struct_Any,
9909 Counter => Struct_Counter);
9911 -- Append inner struct to union aggregate
9913 Append_To (VP_Stmts,
9914 Make_Procedure_Call_Statement (Loc,
9917 RTE (RE_Add_Aggregate_Element), Loc),
9918 Parameter_Associations => New_List (
9919 New_Occurrence_Of (Union_Any, Loc),
9920 New_Occurrence_Of (Struct_Any, Loc))));
9922 -- Append union to outer aggregate
9924 Append_To (VP_Stmts,
9925 Make_Procedure_Call_Statement (Loc,
9928 RTE (RE_Add_Aggregate_Element), Loc),
9929 Parameter_Associations => New_List (
9930 New_Occurrence_Of (Container, Loc),
9932 (Union_Any, Loc))));
9934 Append_To (Alt_List,
9935 Make_Case_Statement_Alternative (Loc,
9936 Discrete_Choices => Choice_List,
9937 Statements => VP_Stmts));
9939 Next_Non_Pragma (Variant);
9944 Counter := Counter + 1;
9945 end TA_Rec_Add_Process_Element;
9948 -- Records are encoded in a TC_STRUCT aggregate:
9950 -- -- Outer aggregate (TC_STRUCT)
9951 -- | [discriminant1]
9952 -- | [discriminant2]
9959 -- A component can be a common component or variant part
9961 -- A variant part is encoded as a TC_UNION aggregate:
9963 -- -- Variant Part Aggregate (TC_UNION)
9964 -- | [discriminant choice for this Variant Part]
9966 -- | -- Inner struct (TC_STRUCT)
9971 -- Let's start by building the outer aggregate. First we
9972 -- construct Elements array containing all discriminants.
9974 if Has_Discriminants (Typ) then
9975 Disc := First_Discriminant (Typ);
9976 while Present (Disc) loop
9978 Discriminant : constant Entity_Id :=
9979 Make_Selected_Component (Loc,
9986 Set_Etype (Discriminant, Etype (Disc));
9988 Append_To (Elements,
9989 Make_Component_Association (Loc,
9990 Choices => New_List (
9991 Make_Integer_Literal (Loc, Counter)),
9993 Build_To_Any_Call (Discriminant, Decls)));
9996 Counter := Counter + 1;
9997 Next_Discriminant (Disc);
10001 -- If there are no discriminants, we declare an empty
10005 Dummy_Any : constant Entity_Id :=
10006 Make_Defining_Identifier (Loc,
10007 Chars => New_Internal_Name ('A'));
10011 Make_Object_Declaration (Loc,
10012 Defining_Identifier => Dummy_Any,
10013 Object_Definition =>
10014 New_Occurrence_Of (RTE (RE_Any), Loc)));
10016 Append_To (Elements,
10017 Make_Component_Association (Loc,
10018 Choices => New_List (
10021 Make_Integer_Literal (Loc, 1),
10023 Make_Integer_Literal (Loc, 0))),
10025 New_Occurrence_Of (Dummy_Any, Loc)));
10029 -- We build the result aggregate with discriminants
10030 -- as the first elements.
10032 Set_Expression (Any_Decl,
10033 Make_Function_Call (Loc,
10034 Name => New_Occurrence_Of (
10035 RTE (RE_Any_Aggregate_Build), Loc),
10036 Parameter_Associations => New_List (
10038 Make_Aggregate (Loc,
10039 Component_Associations => Elements))));
10040 Result_TC := Empty;
10042 -- Then we append all the components to the result
10045 TA_Append_Record_Traversal (Stms,
10046 Clist => Component_List (Rdef),
10048 Counter => Counter);
10052 elsif Is_Array_Type (Typ) then
10054 -- Constrained and unconstrained array types
10057 Constrained : constant Boolean := Is_Constrained (Typ);
10059 procedure TA_Ary_Add_Process_Element
10062 Counter : Entity_Id;
10065 --------------------------------
10066 -- TA_Ary_Add_Process_Element --
10067 --------------------------------
10069 procedure TA_Ary_Add_Process_Element
10072 Counter : Entity_Id;
10075 pragma Warnings (Off);
10076 pragma Unreferenced (Counter);
10077 pragma Warnings (On);
10079 Element_Any : Node_Id;
10082 if Etype (Datum) = RTE (RE_Any) then
10083 Element_Any := Datum;
10085 Element_Any := Build_To_Any_Call (Datum, Decls);
10089 Make_Procedure_Call_Statement (Loc,
10090 Name => New_Occurrence_Of (
10091 RTE (RE_Add_Aggregate_Element), Loc),
10092 Parameter_Associations => New_List (
10093 New_Occurrence_Of (Any, Loc),
10095 end TA_Ary_Add_Process_Element;
10097 procedure Append_To_Any_Array_Iterator is
10098 new Append_Array_Traversal (
10099 Subprogram => Fnam,
10100 Arry => Expr_Parameter,
10101 Indices => New_List,
10102 Add_Process_Element => TA_Ary_Add_Process_Element);
10107 Set_Expression (Any_Decl,
10108 Make_Function_Call (Loc,
10110 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
10111 Parameter_Associations => New_List (Result_TC)));
10112 Result_TC := Empty;
10114 if not Constrained then
10115 Index := First_Index (Typ);
10116 for J in 1 .. Number_Dimensions (Typ) loop
10118 Make_Procedure_Call_Statement (Loc,
10120 New_Occurrence_Of (
10121 RTE (RE_Add_Aggregate_Element), Loc),
10122 Parameter_Associations => New_List (
10123 New_Occurrence_Of (Any, Loc),
10124 Build_To_Any_Call (
10125 OK_Convert_To (Etype (Index),
10126 Make_Attribute_Reference (Loc,
10128 New_Occurrence_Of (Expr_Parameter, Loc),
10129 Attribute_Name => Name_First,
10130 Expressions => New_List (
10131 Make_Integer_Literal (Loc, J)))),
10133 Next_Index (Index);
10137 Append_To_Any_Array_Iterator (Stms, Any);
10140 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10144 Set_Expression (Any_Decl,
10145 Build_To_Any_Call (
10147 Find_Numeric_Representation (Typ),
10148 New_Occurrence_Of (Expr_Parameter, Loc)),
10152 -- Default case, including tagged types: opaque representation
10154 Use_Opaque_Representation := True;
10157 if Use_Opaque_Representation then
10159 Strm : constant Entity_Id :=
10160 Make_Defining_Identifier (Loc,
10161 Chars => New_Internal_Name ('S'));
10162 -- Stream used to store data representation produced by
10163 -- stream attribute.
10167 -- Strm : aliased Buffer_Stream_Type;
10170 Make_Object_Declaration (Loc,
10171 Defining_Identifier =>
10175 Object_Definition =>
10176 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
10179 -- Allocate_Buffer (Strm);
10182 Make_Procedure_Call_Statement (Loc,
10184 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
10185 Parameter_Associations => New_List (
10186 New_Occurrence_Of (Strm, Loc))));
10189 -- T'Output (Strm'Access, E);
10192 Make_Attribute_Reference (Loc,
10193 Prefix => New_Occurrence_Of (Typ, Loc),
10194 Attribute_Name => Name_Output,
10195 Expressions => New_List (
10196 Make_Attribute_Reference (Loc,
10197 Prefix => New_Occurrence_Of (Strm, Loc),
10198 Attribute_Name => Name_Access),
10199 New_Occurrence_Of (Expr_Parameter, Loc))));
10202 -- BS_To_Any (Strm, A);
10205 Make_Procedure_Call_Statement (Loc,
10207 New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
10208 Parameter_Associations => New_List (
10209 New_Occurrence_Of (Strm, Loc),
10210 New_Occurrence_Of (Any, Loc))));
10213 -- Release_Buffer (Strm);
10216 Make_Procedure_Call_Statement (Loc,
10218 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
10219 Parameter_Associations => New_List (
10220 New_Occurrence_Of (Strm, Loc))));
10224 Append_To (Decls, Any_Decl);
10226 if Present (Result_TC) then
10228 Make_Procedure_Call_Statement (Loc,
10229 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
10230 Parameter_Associations => New_List (
10231 New_Occurrence_Of (Any, Loc),
10236 Make_Simple_Return_Statement (Loc,
10237 Expression => New_Occurrence_Of (Any, Loc)));
10240 Make_Subprogram_Body (Loc,
10241 Specification => Spec,
10242 Declarations => Decls,
10243 Handled_Statement_Sequence =>
10244 Make_Handled_Sequence_Of_Statements (Loc,
10245 Statements => Stms));
10246 end Build_To_Any_Function;
10248 -------------------------
10249 -- Build_TypeCode_Call --
10250 -------------------------
10252 function Build_TypeCode_Call
10255 Decls : List_Id) return Node_Id
10257 U_Type : Entity_Id := Underlying_Type (Typ);
10258 -- The full view, if Typ is private; the completion,
10259 -- if Typ is incomplete.
10261 Fnam : Entity_Id := Empty;
10262 Lib_RE : RE_Id := RE_Null;
10266 -- Special case System.PolyORB.Interface.Any: its primitives have
10267 -- not been set yet, so can't call Find_Inherited_TSS.
10269 if Typ = RTE (RE_Any) then
10270 Fnam := RTE (RE_TC_Any);
10273 -- First simple case where the TypeCode is present
10274 -- in the type's TSS.
10276 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10280 if Sloc (U_Type) <= Standard_Location then
10282 -- Do not try to build alias typecodes for subtypes from
10285 U_Type := Base_Type (U_Type);
10288 if U_Type = Standard_Boolean then
10291 elsif U_Type = Standard_Character then
10294 elsif U_Type = Standard_Wide_Character then
10295 Lib_RE := RE_TC_WC;
10297 elsif U_Type = Standard_Wide_Wide_Character then
10298 Lib_RE := RE_TC_WWC;
10300 -- Floating point types
10302 elsif U_Type = Standard_Short_Float then
10303 Lib_RE := RE_TC_SF;
10305 elsif U_Type = Standard_Float then
10308 elsif U_Type = Standard_Long_Float then
10309 Lib_RE := RE_TC_LF;
10311 elsif U_Type = Standard_Long_Long_Float then
10312 Lib_RE := RE_TC_LLF;
10314 -- Integer types (walk back to the base type)
10316 elsif U_Type = Etype (Standard_Short_Short_Integer) then
10317 Lib_RE := RE_TC_SSI;
10319 elsif U_Type = Etype (Standard_Short_Integer) then
10320 Lib_RE := RE_TC_SI;
10322 elsif U_Type = Etype (Standard_Integer) then
10325 elsif U_Type = Etype (Standard_Long_Integer) then
10326 Lib_RE := RE_TC_LI;
10328 elsif U_Type = Etype (Standard_Long_Long_Integer) then
10329 Lib_RE := RE_TC_LLI;
10331 -- Unsigned integer types
10333 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
10334 Lib_RE := RE_TC_SSU;
10336 elsif U_Type = RTE (RE_Short_Unsigned) then
10337 Lib_RE := RE_TC_SU;
10339 elsif U_Type = RTE (RE_Unsigned) then
10342 elsif U_Type = RTE (RE_Long_Unsigned) then
10343 Lib_RE := RE_TC_LU;
10345 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
10346 Lib_RE := RE_TC_LLU;
10348 elsif U_Type = Standard_String then
10349 Lib_RE := RE_TC_String;
10351 -- Other (non-primitive) types
10357 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10358 Append_To (Decls, Decl);
10362 if Lib_RE /= RE_Null then
10363 Fnam := RTE (Lib_RE);
10367 -- Call the function
10370 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10372 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10374 Set_Etype (Expr, RTE (RE_TypeCode));
10377 end Build_TypeCode_Call;
10379 -----------------------------
10380 -- Build_TypeCode_Function --
10381 -----------------------------
10383 procedure Build_TypeCode_Function
10386 Decl : out Node_Id;
10387 Fnam : out Entity_Id)
10390 Decls : constant List_Id := New_List;
10391 Stms : constant List_Id := New_List;
10393 TCNam : constant Entity_Id :=
10394 Make_Stream_Procedure_Function_Name (Loc,
10395 Typ, Name_uTypeCode);
10397 Parameters : List_Id;
10399 procedure Add_String_Parameter
10401 Parameter_List : List_Id);
10402 -- Add a literal for S to Parameters
10404 procedure Add_TypeCode_Parameter
10405 (TC_Node : Node_Id;
10406 Parameter_List : List_Id);
10407 -- Add the typecode for Typ to Parameters
10409 procedure Add_Long_Parameter
10410 (Expr_Node : Node_Id;
10411 Parameter_List : List_Id);
10412 -- Add a signed long integer expression to Parameters
10414 procedure Initialize_Parameter_List
10415 (Name_String : String_Id;
10416 Repo_Id_String : String_Id;
10417 Parameter_List : out List_Id);
10418 -- Return a list that contains the first two parameters
10419 -- for a parameterized typecode: name and repository id.
10421 function Make_Constructed_TypeCode
10423 Parameters : List_Id) return Node_Id;
10424 -- Call TC_Build with the given kind and parameters
10426 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10427 -- Make a return statement that calls TC_Build with the given
10428 -- typecode kind, and the constructed parameters list.
10430 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10431 -- Return a typecode that is a TC_Alias for the given typecode
10433 --------------------------
10434 -- Add_String_Parameter --
10435 --------------------------
10437 procedure Add_String_Parameter
10439 Parameter_List : List_Id)
10442 Append_To (Parameter_List,
10443 Make_Function_Call (Loc,
10445 New_Occurrence_Of (RTE (RE_TA_String), Loc),
10446 Parameter_Associations => New_List (
10447 Make_String_Literal (Loc, S))));
10448 end Add_String_Parameter;
10450 ----------------------------
10451 -- Add_TypeCode_Parameter --
10452 ----------------------------
10454 procedure Add_TypeCode_Parameter
10455 (TC_Node : Node_Id;
10456 Parameter_List : List_Id)
10459 Append_To (Parameter_List,
10460 Make_Function_Call (Loc,
10462 New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10463 Parameter_Associations => New_List (
10465 end Add_TypeCode_Parameter;
10467 ------------------------
10468 -- Add_Long_Parameter --
10469 ------------------------
10471 procedure Add_Long_Parameter
10472 (Expr_Node : Node_Id;
10473 Parameter_List : List_Id)
10476 Append_To (Parameter_List,
10477 Make_Function_Call (Loc,
10479 New_Occurrence_Of (RTE (RE_TA_LI), Loc),
10480 Parameter_Associations => New_List (Expr_Node)));
10481 end Add_Long_Parameter;
10483 -------------------------------
10484 -- Initialize_Parameter_List --
10485 -------------------------------
10487 procedure Initialize_Parameter_List
10488 (Name_String : String_Id;
10489 Repo_Id_String : String_Id;
10490 Parameter_List : out List_Id)
10493 Parameter_List := New_List;
10494 Add_String_Parameter (Name_String, Parameter_List);
10495 Add_String_Parameter (Repo_Id_String, Parameter_List);
10496 end Initialize_Parameter_List;
10498 ---------------------------
10499 -- Return_Alias_TypeCode --
10500 ---------------------------
10502 procedure Return_Alias_TypeCode
10503 (Base_TypeCode : Node_Id)
10506 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10507 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
10508 end Return_Alias_TypeCode;
10510 -------------------------------
10511 -- Make_Constructed_TypeCode --
10512 -------------------------------
10514 function Make_Constructed_TypeCode
10516 Parameters : List_Id) return Node_Id
10518 Constructed_TC : constant Node_Id :=
10519 Make_Function_Call (Loc,
10521 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
10522 Parameter_Associations => New_List (
10523 New_Occurrence_Of (Kind, Loc),
10524 Make_Aggregate (Loc,
10525 Expressions => Parameters)));
10527 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10528 return Constructed_TC;
10529 end Make_Constructed_TypeCode;
10531 ---------------------------------
10532 -- Return_Constructed_TypeCode --
10533 ---------------------------------
10535 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10538 Make_Simple_Return_Statement (Loc,
10540 Make_Constructed_TypeCode (Kind, Parameters)));
10541 end Return_Constructed_TypeCode;
10547 procedure TC_Rec_Add_Process_Element
10550 Counter : in out Int;
10554 procedure TC_Append_Record_Traversal is
10555 new Append_Record_Traversal (
10557 Add_Process_Element => TC_Rec_Add_Process_Element);
10559 --------------------------------
10560 -- TC_Rec_Add_Process_Element --
10561 --------------------------------
10563 procedure TC_Rec_Add_Process_Element
10566 Counter : in out Int;
10570 pragma Warnings (Off);
10571 pragma Unreferenced (Any, Counter, Rec);
10572 pragma Warnings (On);
10575 if Nkind (Field) = N_Defining_Identifier then
10577 -- A regular component
10579 Add_TypeCode_Parameter (
10580 Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10581 Get_Name_String (Chars (Field));
10582 Add_String_Parameter (String_From_Name_Buffer, Params);
10589 Discriminant_Type : constant Entity_Id :=
10590 Etype (Name (Field));
10592 Is_Enum : constant Boolean :=
10593 Is_Enumeration_Type (Discriminant_Type);
10595 Union_TC_Params : List_Id;
10597 U_Name : constant Name_Id :=
10598 New_External_Name (Chars (Typ), 'V', -1);
10600 Name_Str : String_Id;
10601 Struct_TC_Params : List_Id;
10605 Default : constant Node_Id :=
10606 Make_Integer_Literal (Loc, -1);
10608 Dummy_Counter : Int := 0;
10610 Choice_Index : Int := 0;
10612 procedure Add_Params_For_Variant_Components;
10613 -- Add a struct TypeCode and a corresponding member name
10614 -- to the union parameter list.
10616 -- Ordering of declarations is a complete mess in this
10617 -- area, it is supposed to be types/varibles, then
10618 -- subprogram specs, then subprogram bodies ???
10620 ---------------------------------------
10621 -- Add_Params_For_Variant_Components --
10622 ---------------------------------------
10624 procedure Add_Params_For_Variant_Components
10626 S_Name : constant Name_Id :=
10627 New_External_Name (U_Name, 'S', -1);
10630 Get_Name_String (S_Name);
10631 Name_Str := String_From_Name_Buffer;
10632 Initialize_Parameter_List
10633 (Name_Str, Name_Str, Struct_TC_Params);
10635 -- Build struct parameters
10637 TC_Append_Record_Traversal (Struct_TC_Params,
10638 Component_List (Variant),
10642 Add_TypeCode_Parameter
10643 (Make_Constructed_TypeCode
10644 (RTE (RE_TC_Struct), Struct_TC_Params),
10647 Add_String_Parameter (Name_Str, Union_TC_Params);
10648 end Add_Params_For_Variant_Components;
10651 Get_Name_String (U_Name);
10652 Name_Str := String_From_Name_Buffer;
10654 Initialize_Parameter_List
10655 (Name_Str, Name_Str, Union_TC_Params);
10657 -- Add union in enclosing parameter list
10659 Add_TypeCode_Parameter
10660 (Make_Constructed_TypeCode
10661 (RTE (RE_TC_Union), Union_TC_Params),
10664 Add_String_Parameter (Name_Str, Params);
10666 -- Build union parameters
10668 Add_TypeCode_Parameter
10669 (Build_TypeCode_Call
10670 (Loc, Discriminant_Type, Decls),
10673 Add_Long_Parameter (Default, Union_TC_Params);
10675 Variant := First_Non_Pragma (Variants (Field));
10676 while Present (Variant) loop
10677 Choice := First (Discrete_Choices (Variant));
10678 while Present (Choice) loop
10679 case Nkind (Choice) is
10682 L : constant Uint :=
10683 Expr_Value (Low_Bound (Choice));
10684 H : constant Uint :=
10685 Expr_Value (High_Bound (Choice));
10687 -- 3.8.1(8) guarantees that the bounds of
10688 -- this range are static.
10695 Expr := New_Occurrence_Of (
10696 Get_Enum_Lit_From_Pos (
10697 Discriminant_Type, J, Loc), Loc);
10700 Make_Integer_Literal (Loc, J);
10702 Append_To (Union_TC_Params,
10703 Build_To_Any_Call (Expr, Decls));
10705 Add_Params_For_Variant_Components;
10710 when N_Others_Choice =>
10712 -- This variant possess a default choice.
10713 -- We must therefore set the default
10714 -- parameter to the current choice index. The
10715 -- default parameter is by construction the
10716 -- fourth in the Union_TC_Params list.
10719 Default_Node : constant Node_Id :=
10720 Pick (Union_TC_Params, 4);
10722 New_Default_Node : constant Node_Id :=
10723 Make_Function_Call (Loc,
10726 (RTE (RE_TA_LI), Loc),
10727 Parameter_Associations =>
10729 Make_Integer_Literal
10730 (Loc, Choice_Index)));
10736 Remove (Default_Node);
10739 -- Add a placeholder member label
10740 -- for the default case.
10741 -- It must be of the discriminant type.
10744 Exp : constant Node_Id :=
10745 Make_Attribute_Reference (Loc,
10746 Prefix => New_Occurrence_Of
10747 (Discriminant_Type, Loc),
10748 Attribute_Name => Name_First);
10750 Set_Etype (Exp, Discriminant_Type);
10751 Append_To (Union_TC_Params,
10752 Build_To_Any_Call (Exp, Decls));
10755 Add_Params_For_Variant_Components;
10759 -- Case of an explicit choice
10762 Exp : constant Node_Id :=
10763 New_Copy_Tree (Choice);
10765 Append_To (Union_TC_Params,
10766 Build_To_Any_Call (Exp, Decls));
10769 Add_Params_For_Variant_Components;
10772 Choice_Index := Choice_Index + 1;
10776 Next_Non_Pragma (Variant);
10781 end TC_Rec_Add_Process_Element;
10783 Type_Name_Str : String_Id;
10784 Type_Repo_Id_Str : String_Id;
10787 if Is_Itype (Typ) then
10788 Build_TypeCode_Function
10790 Typ => Etype (Typ),
10799 Make_Function_Specification (Loc,
10800 Defining_Unit_Name => Fnam,
10801 Parameter_Specifications => Empty_List,
10802 Result_Definition =>
10803 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10805 Build_Name_And_Repository_Id (Typ,
10806 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10807 Initialize_Parameter_List
10808 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10810 if Has_Stream_Attribute_Definition
10811 (Typ, TSS_Stream_Output, At_Any_Place => True)
10813 Has_Stream_Attribute_Definition
10814 (Typ, TSS_Stream_Write, At_Any_Place => True)
10816 -- If user-defined stream attributes are specified for this
10817 -- type, use them and transmit data as an opaque sequence of
10818 -- stream elements.
10820 Return_Alias_TypeCode
10821 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10823 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
10824 Return_Alias_TypeCode (
10825 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10827 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10828 Return_Alias_TypeCode (
10829 Build_TypeCode_Call (Loc,
10830 Find_Numeric_Representation (Typ), Decls));
10832 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
10834 -- Record typecodes are encoded as follows:
10838 -- | [Repository Id]
10840 -- Then for each discriminant:
10842 -- | [Discriminant Type Code]
10843 -- | [Discriminant Name]
10846 -- Then for each component:
10848 -- | [Component Type Code]
10849 -- | [Component Name]
10852 -- Variants components type codes are encoded as follows:
10856 -- | [Repository Id]
10857 -- | [Discriminant Type Code]
10858 -- | [Index of Default Variant Part or -1 for no default]
10860 -- Then for each Variant Part :
10865 -- | | [Variant Part Name]
10866 -- | | [Variant Part Repository Id]
10868 -- | Then for each VP component:
10869 -- | | [VP component Typecode]
10870 -- | | [VP component Name]
10876 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10877 Return_Alias_TypeCode (
10878 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10881 Disc : Entity_Id := Empty;
10882 Rdef : constant Node_Id :=
10883 Type_Definition (Declaration_Node (Typ));
10884 Dummy_Counter : Int := 0;
10886 -- Construct the discriminants typecodes
10888 if Has_Discriminants (Typ) then
10889 Disc := First_Discriminant (Typ);
10891 while Present (Disc) loop
10892 Add_TypeCode_Parameter (
10893 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10895 Get_Name_String (Chars (Disc));
10896 Add_String_Parameter (
10897 String_From_Name_Buffer,
10899 Next_Discriminant (Disc);
10902 -- then the components typecodes
10904 TC_Append_Record_Traversal
10905 (Parameters, Component_List (Rdef),
10906 Empty, Dummy_Counter);
10907 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10911 elsif Is_Array_Type (Typ) then
10913 Ndim : constant Pos := Number_Dimensions (Typ);
10914 Inner_TypeCode : Node_Id;
10915 Constrained : constant Boolean := Is_Constrained (Typ);
10916 Indx : Node_Id := First_Index (Typ);
10919 Inner_TypeCode := Build_TypeCode_Call (Loc,
10920 Component_Type (Typ),
10923 for J in 1 .. Ndim loop
10924 if Constrained then
10925 Inner_TypeCode := Make_Constructed_TypeCode
10926 (RTE (RE_TC_Array), New_List (
10927 Build_To_Any_Call (
10928 OK_Convert_To (RTE (RE_Long_Unsigned),
10929 Make_Attribute_Reference (Loc,
10931 New_Occurrence_Of (Typ, Loc),
10934 Expressions => New_List (
10935 Make_Integer_Literal (Loc,
10938 Build_To_Any_Call (Inner_TypeCode, Decls)));
10941 -- Unconstrained case: add low bound for each
10944 Add_TypeCode_Parameter
10945 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10947 Get_Name_String (New_External_Name ('L', J));
10948 Add_String_Parameter (
10949 String_From_Name_Buffer,
10953 Inner_TypeCode := Make_Constructed_TypeCode
10954 (RTE (RE_TC_Sequence), New_List (
10955 Build_To_Any_Call (
10956 OK_Convert_To (RTE (RE_Long_Unsigned),
10957 Make_Integer_Literal (Loc, 0)),
10959 Build_To_Any_Call (Inner_TypeCode, Decls)));
10963 if Constrained then
10964 Return_Alias_TypeCode (Inner_TypeCode);
10966 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10968 Store_String_Char ('V');
10969 Add_String_Parameter (End_String, Parameters);
10970 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10975 -- Default: type is represented as an opaque sequence of bytes
10977 Return_Alias_TypeCode
10978 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10982 Make_Subprogram_Body (Loc,
10983 Specification => Spec,
10984 Declarations => Decls,
10985 Handled_Statement_Sequence =>
10986 Make_Handled_Sequence_Of_Statements (Loc,
10987 Statements => Stms));
10988 end Build_TypeCode_Function;
10990 ---------------------------------
10991 -- Find_Numeric_Representation --
10992 ---------------------------------
10994 function Find_Numeric_Representation
10995 (Typ : Entity_Id) return Entity_Id
10997 FST : constant Entity_Id := First_Subtype (Typ);
10998 P_Size : constant Uint := Esize (FST);
11001 if Is_Unsigned_Type (Typ) then
11002 if P_Size <= Standard_Short_Short_Integer_Size then
11003 return RTE (RE_Short_Short_Unsigned);
11005 elsif P_Size <= Standard_Short_Integer_Size then
11006 return RTE (RE_Short_Unsigned);
11008 elsif P_Size <= Standard_Integer_Size then
11009 return RTE (RE_Unsigned);
11011 elsif P_Size <= Standard_Long_Integer_Size then
11012 return RTE (RE_Long_Unsigned);
11015 return RTE (RE_Long_Long_Unsigned);
11018 elsif Is_Integer_Type (Typ) then
11019 if P_Size <= Standard_Short_Short_Integer_Size then
11020 return Standard_Short_Short_Integer;
11022 elsif P_Size <= Standard_Short_Integer_Size then
11023 return Standard_Short_Integer;
11025 elsif P_Size <= Standard_Integer_Size then
11026 return Standard_Integer;
11028 elsif P_Size <= Standard_Long_Integer_Size then
11029 return Standard_Long_Integer;
11032 return Standard_Long_Long_Integer;
11035 elsif Is_Floating_Point_Type (Typ) then
11036 if P_Size <= Standard_Short_Float_Size then
11037 return Standard_Short_Float;
11039 elsif P_Size <= Standard_Float_Size then
11040 return Standard_Float;
11042 elsif P_Size <= Standard_Long_Float_Size then
11043 return Standard_Long_Float;
11046 return Standard_Long_Long_Float;
11050 raise Program_Error;
11053 -- TBD: fixed point types???
11054 -- TBverified numeric types with a biased representation???
11056 end Find_Numeric_Representation;
11058 ---------------------------
11059 -- Append_Array_Traversal --
11060 ---------------------------
11062 procedure Append_Array_Traversal
11065 Counter : Entity_Id := Empty;
11068 Loc : constant Source_Ptr := Sloc (Subprogram);
11069 Typ : constant Entity_Id := Etype (Arry);
11070 Constrained : constant Boolean := Is_Constrained (Typ);
11071 Ndim : constant Pos := Number_Dimensions (Typ);
11073 Inner_Any, Inner_Counter : Entity_Id;
11075 Loop_Stm : Node_Id;
11076 Inner_Stmts : constant List_Id := New_List;
11079 if Depth > Ndim then
11081 -- Processing for one element of an array
11084 Element_Expr : constant Node_Id :=
11085 Make_Indexed_Component (Loc,
11086 New_Occurrence_Of (Arry, Loc),
11090 Set_Etype (Element_Expr, Component_Type (Typ));
11091 Add_Process_Element (Stmts,
11093 Counter => Counter,
11094 Datum => Element_Expr);
11100 Append_To (Indices,
11101 Make_Identifier (Loc, New_External_Name ('L', Depth)));
11103 if not Constrained or else Depth > 1 then
11104 Inner_Any := Make_Defining_Identifier (Loc,
11105 New_External_Name ('A', Depth));
11106 Set_Etype (Inner_Any, RTE (RE_Any));
11108 Inner_Any := Empty;
11111 if Present (Counter) then
11112 Inner_Counter := Make_Defining_Identifier (Loc,
11113 New_External_Name ('J', Depth));
11115 Inner_Counter := Empty;
11119 Loop_Any : Node_Id := Inner_Any;
11122 -- For the first dimension of a constrained array, we add
11123 -- elements directly in the corresponding Any; there is no
11124 -- intervening inner Any.
11126 if No (Loop_Any) then
11130 Append_Array_Traversal (Inner_Stmts,
11132 Counter => Inner_Counter,
11133 Depth => Depth + 1);
11137 Make_Implicit_Loop_Statement (Subprogram,
11138 Iteration_Scheme =>
11139 Make_Iteration_Scheme (Loc,
11140 Loop_Parameter_Specification =>
11141 Make_Loop_Parameter_Specification (Loc,
11142 Defining_Identifier =>
11143 Make_Defining_Identifier (Loc,
11144 Chars => New_External_Name ('L', Depth)),
11146 Discrete_Subtype_Definition =>
11147 Make_Attribute_Reference (Loc,
11148 Prefix => New_Occurrence_Of (Arry, Loc),
11149 Attribute_Name => Name_Range,
11151 Expressions => New_List (
11152 Make_Integer_Literal (Loc, Depth))))),
11153 Statements => Inner_Stmts);
11156 Decls : constant List_Id := New_List;
11157 Dimen_Stmts : constant List_Id := New_List;
11158 Length_Node : Node_Id;
11160 Inner_Any_TypeCode : constant Entity_Id :=
11161 Make_Defining_Identifier (Loc,
11162 New_External_Name ('T', Depth));
11164 Inner_Any_TypeCode_Expr : Node_Id;
11168 if Constrained then
11169 Inner_Any_TypeCode_Expr :=
11170 Make_Function_Call (Loc,
11172 New_Occurrence_Of (RTE (RE_Get_TC), Loc),
11173 Parameter_Associations => New_List (
11174 New_Occurrence_Of (Any, Loc)));
11176 Inner_Any_TypeCode_Expr :=
11177 Make_Function_Call (Loc,
11179 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
11180 Parameter_Associations => New_List (
11181 New_Occurrence_Of (Any, Loc),
11182 Make_Integer_Literal (Loc, Ndim)));
11185 Inner_Any_TypeCode_Expr :=
11186 Make_Function_Call (Loc,
11188 New_Occurrence_Of (RTE (RE_Content_Type), Loc),
11189 Parameter_Associations => New_List (
11190 Make_Identifier (Loc,
11191 New_External_Name ('T', Depth - 1))));
11195 Make_Object_Declaration (Loc,
11196 Defining_Identifier => Inner_Any_TypeCode,
11197 Constant_Present => True,
11198 Object_Definition => New_Occurrence_Of (
11199 RTE (RE_TypeCode), Loc),
11200 Expression => Inner_Any_TypeCode_Expr));
11202 if Present (Inner_Any) then
11204 Make_Object_Declaration (Loc,
11205 Defining_Identifier => Inner_Any,
11206 Object_Definition =>
11207 New_Occurrence_Of (RTE (RE_Any), Loc),
11209 Make_Function_Call (Loc,
11211 New_Occurrence_Of (
11212 RTE (RE_Create_Any), Loc),
11213 Parameter_Associations => New_List (
11214 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
11217 if Present (Inner_Counter) then
11219 Make_Object_Declaration (Loc,
11220 Defining_Identifier => Inner_Counter,
11221 Object_Definition =>
11222 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
11224 Make_Integer_Literal (Loc, 0)));
11227 if not Constrained then
11228 Length_Node := Make_Attribute_Reference (Loc,
11229 Prefix => New_Occurrence_Of (Arry, Loc),
11230 Attribute_Name => Name_Length,
11232 New_List (Make_Integer_Literal (Loc, Depth)));
11233 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
11235 Add_Process_Element (Dimen_Stmts,
11236 Datum => Length_Node,
11238 Counter => Inner_Counter);
11241 -- Loop_Stm does appropriate processing for each element
11244 Append_To (Dimen_Stmts, Loop_Stm);
11246 -- Link outer and inner any
11248 if Present (Inner_Any) then
11249 Add_Process_Element (Dimen_Stmts,
11251 Counter => Counter,
11252 Datum => New_Occurrence_Of (Inner_Any, Loc));
11256 Make_Block_Statement (Loc,
11259 Handled_Statement_Sequence =>
11260 Make_Handled_Sequence_Of_Statements (Loc,
11261 Statements => Dimen_Stmts)));
11263 end Append_Array_Traversal;
11265 -----------------------------------------
11266 -- Make_Stream_Procedure_Function_Name --
11267 -----------------------------------------
11269 function Make_Stream_Procedure_Function_Name
11272 Nam : Name_Id) return Entity_Id
11275 -- For tagged types, we use a canonical name so that it matches
11276 -- the primitive spec. For all other cases, we use a serialized
11277 -- name so that multiple generations of the same procedure do not
11280 if Is_Tagged_Type (Typ) then
11281 return Make_Defining_Identifier (Loc, Nam);
11283 return Make_Defining_Identifier (Loc,
11285 New_External_Name (Nam, ' ', Increment_Serial_Number));
11287 end Make_Stream_Procedure_Function_Name;
11290 -----------------------------------
11291 -- Reserve_NamingContext_Methods --
11292 -----------------------------------
11294 procedure Reserve_NamingContext_Methods is
11295 Str_Resolve : constant String := "resolve";
11297 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11298 Name_Len := Str_Resolve'Length;
11299 Overload_Counter_Table.Set (Name_Find, 1);
11300 end Reserve_NamingContext_Methods;
11302 end PolyORB_Support;
11304 -------------------------------
11305 -- RACW_Type_Is_Asynchronous --
11306 -------------------------------
11308 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11309 Asynchronous_Flag : constant Entity_Id :=
11310 Asynchronous_Flags_Table.Get (RACW_Type);
11312 Replace (Expression (Parent (Asynchronous_Flag)),
11313 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11314 end RACW_Type_Is_Asynchronous;
11316 -------------------------
11317 -- RCI_Package_Locator --
11318 -------------------------
11320 function RCI_Package_Locator
11322 Package_Spec : Node_Id) return Node_Id
11325 Pkg_Name : String_Id;
11328 Get_Library_Unit_Name_String (Package_Spec);
11329 Pkg_Name := String_From_Name_Buffer;
11331 Make_Package_Instantiation (Loc,
11332 Defining_Unit_Name =>
11333 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
11335 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11336 Generic_Associations => New_List (
11337 Make_Generic_Association (Loc,
11339 Make_Identifier (Loc, Name_RCI_Name),
11340 Explicit_Generic_Actual_Parameter =>
11341 Make_String_Literal (Loc,
11342 Strval => Pkg_Name)),
11343 Make_Generic_Association (Loc,
11345 Make_Identifier (Loc, Name_Version),
11346 Explicit_Generic_Actual_Parameter =>
11347 Make_Attribute_Reference (Loc,
11349 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11353 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
11354 Defining_Unit_Name (Inst));
11356 end RCI_Package_Locator;
11358 -----------------------------------------------
11359 -- Remote_Types_Tagged_Full_View_Encountered --
11360 -----------------------------------------------
11362 procedure Remote_Types_Tagged_Full_View_Encountered
11363 (Full_View : Entity_Id)
11365 Stub_Elements : constant Stub_Structure :=
11366 Stubs_Table.Get (Full_View);
11368 -- For an RACW encountered before the freeze point of its designated
11369 -- type, the stub type is generated at the point of the RACW declaration
11370 -- but the primitives are generated only once the designated type is
11371 -- frozen. That freeze can occur in another scope, for example when the
11372 -- RACW is declared in a nested package. In that case we need to
11373 -- reestablish the stub type's scope prior to generating its primitive
11376 if Stub_Elements /= Empty_Stub_Structure then
11378 Saved_Scope : constant Entity_Id := Current_Scope;
11379 Stubs_Scope : constant Entity_Id :=
11380 Scope (Stub_Elements.Stub_Type);
11382 if Current_Scope /= Stubs_Scope then
11383 Push_Scope (Stubs_Scope);
11386 Add_RACW_Primitive_Declarations_And_Bodies
11388 Stub_Elements.RPC_Receiver_Decl,
11389 Stub_Elements.Body_Decls);
11391 if Current_Scope /= Saved_Scope then
11396 end Remote_Types_Tagged_Full_View_Encountered;
11398 -------------------
11399 -- Scope_Of_Spec --
11400 -------------------
11402 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11403 Unit_Name : Node_Id;
11406 Unit_Name := Defining_Unit_Name (Spec);
11407 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11408 Unit_Name := Defining_Identifier (Unit_Name);
11414 ----------------------
11415 -- Set_Renaming_TSS --
11416 ----------------------
11418 procedure Set_Renaming_TSS
11421 TSS_Nam : TSS_Name_Type)
11423 Loc : constant Source_Ptr := Sloc (Nam);
11424 Spec : constant Node_Id := Parent (Nam);
11426 TSS_Node : constant Node_Id :=
11427 Make_Subprogram_Renaming_Declaration (Loc,
11429 Copy_Specification (Loc,
11431 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11432 Name => New_Occurrence_Of (Nam, Loc));
11434 Snam : constant Entity_Id :=
11435 Defining_Unit_Name (Specification (TSS_Node));
11438 if Nkind (Spec) = N_Function_Specification then
11439 Set_Ekind (Snam, E_Function);
11440 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11442 Set_Ekind (Snam, E_Procedure);
11443 Set_Etype (Snam, Standard_Void_Type);
11446 Set_TSS (Typ, Snam);
11447 end Set_Renaming_TSS;
11449 ----------------------------------------------
11450 -- Specific_Add_Obj_RPC_Receiver_Completion --
11451 ----------------------------------------------
11453 procedure Specific_Add_Obj_RPC_Receiver_Completion
11456 RPC_Receiver : Entity_Id;
11457 Stub_Elements : Stub_Structure) is
11459 case Get_PCS_Name is
11460 when Name_PolyORB_DSA =>
11461 PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11462 Decls, RPC_Receiver, Stub_Elements);
11464 GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11465 Decls, RPC_Receiver, Stub_Elements);
11467 end Specific_Add_Obj_RPC_Receiver_Completion;
11469 --------------------------------
11470 -- Specific_Add_RACW_Features --
11471 --------------------------------
11473 procedure Specific_Add_RACW_Features
11474 (RACW_Type : Entity_Id;
11476 Stub_Type : Entity_Id;
11477 Stub_Type_Access : Entity_Id;
11478 RPC_Receiver_Decl : Node_Id;
11479 Body_Decls : List_Id) is
11481 case Get_PCS_Name is
11482 when Name_PolyORB_DSA =>
11483 PolyORB_Support.Add_RACW_Features (
11492 GARLIC_Support.Add_RACW_Features (
11499 end Specific_Add_RACW_Features;
11501 --------------------------------
11502 -- Specific_Add_RAST_Features --
11503 --------------------------------
11505 procedure Specific_Add_RAST_Features
11506 (Vis_Decl : Node_Id;
11507 RAS_Type : Entity_Id) is
11509 case Get_PCS_Name is
11510 when Name_PolyORB_DSA =>
11511 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11513 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11515 end Specific_Add_RAST_Features;
11517 --------------------------------------------------
11518 -- Specific_Add_Receiving_Stubs_To_Declarations --
11519 --------------------------------------------------
11521 procedure Specific_Add_Receiving_Stubs_To_Declarations
11522 (Pkg_Spec : Node_Id;
11527 case Get_PCS_Name is
11528 when Name_PolyORB_DSA =>
11529 PolyORB_Support.Add_Receiving_Stubs_To_Declarations (
11530 Pkg_Spec, Decls, Stmts);
11532 GARLIC_Support.Add_Receiving_Stubs_To_Declarations (
11533 Pkg_Spec, Decls, Stmts);
11535 end Specific_Add_Receiving_Stubs_To_Declarations;
11537 ------------------------------------------
11538 -- Specific_Build_General_Calling_Stubs --
11539 ------------------------------------------
11541 procedure Specific_Build_General_Calling_Stubs
11543 Statements : List_Id;
11544 Target : RPC_Target;
11545 Subprogram_Id : Node_Id;
11546 Asynchronous : Node_Id := Empty;
11547 Is_Known_Asynchronous : Boolean := False;
11548 Is_Known_Non_Asynchronous : Boolean := False;
11549 Is_Function : Boolean;
11551 Stub_Type : Entity_Id := Empty;
11552 RACW_Type : Entity_Id := Empty;
11556 case Get_PCS_Name is
11557 when Name_PolyORB_DSA =>
11558 PolyORB_Support.Build_General_Calling_Stubs (
11564 Is_Known_Asynchronous,
11565 Is_Known_Non_Asynchronous,
11572 GARLIC_Support.Build_General_Calling_Stubs (
11576 Target.RPC_Receiver,
11579 Is_Known_Asynchronous,
11580 Is_Known_Non_Asynchronous,
11587 end Specific_Build_General_Calling_Stubs;
11589 --------------------------------------
11590 -- Specific_Build_RPC_Receiver_Body --
11591 --------------------------------------
11593 procedure Specific_Build_RPC_Receiver_Body
11594 (RPC_Receiver : Entity_Id;
11595 Request : out Entity_Id;
11596 Subp_Id : out Entity_Id;
11597 Subp_Index : out Entity_Id;
11598 Stmts : out List_Id;
11599 Decl : out Node_Id)
11602 case Get_PCS_Name is
11603 when Name_PolyORB_DSA =>
11604 PolyORB_Support.Build_RPC_Receiver_Body
11612 GARLIC_Support.Build_RPC_Receiver_Body
11620 end Specific_Build_RPC_Receiver_Body;
11622 --------------------------------
11623 -- Specific_Build_Stub_Target --
11624 --------------------------------
11626 function Specific_Build_Stub_Target
11629 RCI_Locator : Entity_Id;
11630 Controlling_Parameter : Entity_Id) return RPC_Target
11633 case Get_PCS_Name is
11634 when Name_PolyORB_DSA =>
11635 return PolyORB_Support.Build_Stub_Target (Loc,
11636 Decls, RCI_Locator, Controlling_Parameter);
11638 return GARLIC_Support.Build_Stub_Target (Loc,
11639 Decls, RCI_Locator, Controlling_Parameter);
11641 end Specific_Build_Stub_Target;
11643 ------------------------------
11644 -- Specific_Build_Stub_Type --
11645 ------------------------------
11647 procedure Specific_Build_Stub_Type
11648 (RACW_Type : Entity_Id;
11649 Stub_Type : Entity_Id;
11650 Stub_Type_Decl : out Node_Id;
11651 RPC_Receiver_Decl : out Node_Id)
11654 case Get_PCS_Name is
11655 when Name_PolyORB_DSA =>
11656 PolyORB_Support.Build_Stub_Type (
11657 RACW_Type, Stub_Type,
11658 Stub_Type_Decl, RPC_Receiver_Decl);
11660 GARLIC_Support.Build_Stub_Type (
11661 RACW_Type, Stub_Type,
11662 Stub_Type_Decl, RPC_Receiver_Decl);
11664 end Specific_Build_Stub_Type;
11666 function Specific_Build_Subprogram_Receiving_Stubs
11667 (Vis_Decl : Node_Id;
11668 Asynchronous : Boolean;
11669 Dynamically_Asynchronous : Boolean := False;
11670 Stub_Type : Entity_Id := Empty;
11671 RACW_Type : Entity_Id := Empty;
11672 Parent_Primitive : Entity_Id := Empty) return Node_Id
11675 case Get_PCS_Name is
11676 when Name_PolyORB_DSA =>
11677 return PolyORB_Support.Build_Subprogram_Receiving_Stubs (
11680 Dynamically_Asynchronous,
11685 return GARLIC_Support.Build_Subprogram_Receiving_Stubs (
11688 Dynamically_Asynchronous,
11693 end Specific_Build_Subprogram_Receiving_Stubs;
11695 -------------------------------
11696 -- Transmit_As_Unconstrained --
11697 -------------------------------
11699 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
11702 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
11703 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
11704 end Transmit_As_Unconstrained;
11706 --------------------------
11707 -- Underlying_RACW_Type --
11708 --------------------------
11710 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11711 Record_Type : Entity_Id;
11714 if Ekind (RAS_Typ) = E_Record_Type then
11715 Record_Type := RAS_Typ;
11717 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11718 Record_Type := Equivalent_Type (RAS_Typ);
11722 Etype (Subtype_Indication (
11723 Component_Definition (
11724 First (Component_Items (Component_List (
11725 Type_Definition (Declaration_Node (Record_Type))))))));
11726 end Underlying_RACW_Type;