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_Aux; use Sem_Aux;
40 with Sem_Cat; use Sem_Cat;
41 with Sem_Ch3; use Sem_Ch3;
42 with Sem_Ch8; use Sem_Ch8;
43 with Sem_Dist; use Sem_Dist;
44 with Sem_Eval; use Sem_Eval;
45 with Sem_Util; use Sem_Util;
46 with Sinfo; use Sinfo;
47 with 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_Stub_Tag
189 RACW_Type : Entity_Id) return Node_Id;
190 -- Return an expression denoting the tag of the stub type associated with
193 function Build_Subprogram_Calling_Stubs
196 Asynchronous : Boolean;
197 Dynamically_Asynchronous : Boolean := False;
198 Stub_Type : Entity_Id := Empty;
199 RACW_Type : Entity_Id := Empty;
200 Locator : Entity_Id := Empty;
201 New_Name : Name_Id := No_Name) return Node_Id;
202 -- Build the calling stub for a given subprogram with the subprogram ID
203 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
204 -- parameters of this type will be marshalled instead of the object
205 -- itself. It will then be converted into Stub_Type before performing
206 -- the real call. If Dynamically_Asynchronous is True, then it will be
207 -- computed at run time whether the call is asynchronous or not.
208 -- Otherwise, the value of the formal Asynchronous will be used.
209 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
210 -- New_Name is given, then it will be used instead of the original name.
212 function Build_RPC_Receiver_Specification
213 (RPC_Receiver : Entity_Id;
214 Request_Parameter : Entity_Id) return Node_Id;
215 -- Make a subprogram specification for an RPC receiver, with the given
216 -- defining unit name and formal parameter.
218 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
219 -- Return an ordered parameter list: unconstrained parameters are put
220 -- at the beginning of the list and constrained ones are put after. If
221 -- there are no parameters, an empty list is returned. Special case:
222 -- the controlling formal of the equivalent RACW operation for a RAS
223 -- type is always left in first position.
225 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean;
226 -- True when Typ is an unconstrained type, or a null-excluding access type.
227 -- In either case, this means stubs cannot contain a default-initialized
228 -- object declaration of such type.
230 procedure Add_Calling_Stubs_To_Declarations
233 -- Add calling stubs to the declarative part
235 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
236 -- Return True if nothing prevents the program whose specification is
237 -- given to be asynchronous (i.e. no out parameter).
239 function Pack_Entity_Into_Stream_Access
243 Etyp : Entity_Id := Empty) return Node_Id;
244 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
245 -- then Etype (Object) will be used if present. If the type is
246 -- constrained, then 'Write will be used to output the object,
247 -- If the type is unconstrained, 'Output will be used.
249 function Pack_Node_Into_Stream
253 Etyp : Entity_Id) return Node_Id;
254 -- Similar to above, with an arbitrary node instead of an entity
256 function Pack_Node_Into_Stream_Access
260 Etyp : Entity_Id) return Node_Id;
261 -- Similar to above, with Stream instead of Stream'Access
263 function Make_Selected_Component
266 Selector_Name : Name_Id) return Node_Id;
267 -- Return a selected_component whose prefix denotes the given entity,
268 -- and with the given Selector_Name.
270 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
271 -- Return the scope represented by a given spec
273 procedure Set_Renaming_TSS
276 TSS_Nam : TSS_Name_Type);
277 -- Create a renaming declaration of subprogram Nam,
278 -- and register it as a TSS for Typ with name TSS_Nam.
280 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
281 -- Return True if the current parameter needs an extra formal to reflect
282 -- its constrained status.
284 function Is_RACW_Controlling_Formal
285 (Parameter : Node_Id;
286 Stub_Type : Entity_Id) return Boolean;
287 -- Return True if the current parameter is a controlling formal argument
288 -- of type Stub_Type or access to Stub_Type.
290 procedure Declare_Create_NVList
295 -- Append the declaration of NVList to Decls, and its
296 -- initialization to Stmts.
298 function Add_Parameter_To_NVList
301 Parameter : Entity_Id;
302 Constrained : Boolean;
303 RACW_Ctrl : Boolean := False;
304 Any : Entity_Id) return Node_Id;
305 -- Return a call to Add_Item to add the Any corresponding to the designated
306 -- formal Parameter (with the indicated Constrained status) to NVList.
307 -- RACW_Ctrl must be set to True for controlling formals of distributed
308 -- object primitive operations.
314 -- This record describes various tree fragments associated with the
315 -- generation of RACW calling stubs. One such record exists for every
316 -- distributed object type, i.e. each tagged type that is the designated
317 -- type of one or more RACW type.
319 type Stub_Structure is record
320 Stub_Type : Entity_Id;
321 -- Stub type: this type has the same primitive operations as the
322 -- designated types, but the provided bodies for these operations
323 -- a remote call to an actual target object potentially located on
324 -- another partition; each value of the stub type encapsulates a
325 -- reference to a remote object.
327 Stub_Type_Access : Entity_Id;
328 -- A local access type designating the stub type (this is not an RACW
331 RPC_Receiver_Decl : Node_Id;
332 -- Declaration for the RPC receiver entity associated with the
333 -- designated type. As an exception, for the case of an RACW that
334 -- implements a RAS, no object RPC receiver is generated. Instead,
335 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
336 -- would have been inserted.
338 Body_Decls : List_Id;
339 -- List of subprogram bodies to be included in generated code: bodies
340 -- for the RACW's stream attributes, and for the primitive operations
343 RACW_Type : Entity_Id;
344 -- One of the RACW types designating this distributed object type
345 -- (they are all interchangeable; we use any one of them in order to
346 -- avoid having to create various anonymous access types).
350 Empty_Stub_Structure : constant Stub_Structure :=
351 (Empty, Empty, Empty, No_List, Empty);
353 package Stubs_Table is
354 new Simple_HTable (Header_Num => Hash_Index,
355 Element => Stub_Structure,
356 No_Element => Empty_Stub_Structure,
360 -- Mapping between a RACW designated type and its stub type
362 package Asynchronous_Flags_Table is
363 new Simple_HTable (Header_Num => Hash_Index,
364 Element => Entity_Id,
369 -- Mapping between a RACW type and a constant having the value True
370 -- if the RACW is asynchronous and False otherwise.
372 package RCI_Locator_Table is
373 new Simple_HTable (Header_Num => Hash_Index,
374 Element => Entity_Id,
379 -- Mapping between a RCI package on which All_Calls_Remote applies and
380 -- the generic instantiation of RCI_Locator for this package.
382 package RCI_Calling_Stubs_Table is
383 new Simple_HTable (Header_Num => Hash_Index,
384 Element => Entity_Id,
389 -- Mapping between a RCI subprogram and the corresponding calling stubs
391 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure;
392 -- Return the stub information associated with the given RACW type
394 procedure Add_Stub_Type
395 (Designated_Type : Entity_Id;
396 RACW_Type : Entity_Id;
398 Stub_Type : out Entity_Id;
399 Stub_Type_Access : out Entity_Id;
400 RPC_Receiver_Decl : out Node_Id;
401 Body_Decls : out List_Id;
402 Existing : out Boolean);
403 -- Add the declaration of the stub type, the access to stub type and the
404 -- object RPC receiver at the end of Decls. If these already exist,
405 -- then nothing is added in the tree but the right values are returned
406 -- anyhow and Existing is set to True.
408 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
409 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
410 -- structure table, reset it to No_List, and return the previous value.
412 procedure Add_RACW_Asynchronous_Flag
413 (Declarations : List_Id;
414 RACW_Type : Entity_Id);
415 -- Declare a boolean constant associated with RACW_Type whose value
416 -- indicates at run time whether a pragma Asynchronous applies to it.
418 procedure Assign_Subprogram_Identifier
422 -- Determine the distribution subprogram identifier to
423 -- be used for remote subprogram Def, return it in Id and
424 -- store it in a hash table for later retrieval by
425 -- Get_Subprogram_Id. Spn is the subprogram number.
427 function RCI_Package_Locator
429 Package_Spec : Node_Id) return Node_Id;
430 -- Instantiate the generic package RCI_Locator in order to locate the
431 -- RCI package whose spec is given as argument.
433 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
434 -- Surround a node N by a tag check, as in:
438 -- when E : Ada.Tags.Tag_Error =>
439 -- Raise_Exception (Program_Error'Identity,
440 -- Exception_Message (E));
443 function Input_With_Tag_Check
445 Var_Type : Entity_Id;
446 Stream : Node_Id) return Node_Id;
447 -- Return a function with the following form:
448 -- function R return Var_Type is
450 -- return Var_Type'Input (S);
452 -- when E : Ada.Tags.Tag_Error =>
453 -- Raise_Exception (Program_Error'Identity,
454 -- Exception_Message (E));
457 procedure Build_Actual_Object_Declaration
463 -- Build the declaration of an object with the given defining identifier,
464 -- initialized with Expr if provided, to serve as actual parameter in a
465 -- server stub. If Variable is true, the declared object will be a variable
466 -- (case of an out or in out formal), else it will be a constant. Object's
467 -- Ekind is set accordingly. The declaration, as well as any other
468 -- declarations it requires, are appended to Decls.
470 --------------------------------------------
471 -- Hooks for PCS-specific code generation --
472 --------------------------------------------
474 -- Part of the code generation circuitry for distribution needs to be
475 -- tailored for each implementation of the PCS. For each routine that
476 -- needs to be specialized, a Specific_<routine> wrapper is created,
477 -- which calls the corresponding <routine> in package
478 -- <pcs_implementation>_Support.
480 procedure Specific_Add_RACW_Features
481 (RACW_Type : Entity_Id;
483 Stub_Type : Entity_Id;
484 Stub_Type_Access : Entity_Id;
485 RPC_Receiver_Decl : Node_Id;
486 Body_Decls : List_Id);
487 -- Add declaration for TSSs for a given RACW type. The declarations are
488 -- added just after the declaration of the RACW type itself. If the RACW
489 -- appears in the main unit, Body_Decls is a list of declarations to which
490 -- the bodies are appended. Else Body_Decls is No_List.
491 -- PCS-specific ancillary subprogram for Add_RACW_Features.
493 procedure Specific_Add_RAST_Features
495 RAS_Type : Entity_Id);
496 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
497 -- subprogram for Add_RAST_Features.
499 -- An RPC_Target record is used during construction of calling stubs
500 -- to pass PCS-specific tree fragments corresponding to the information
501 -- necessary to locate the target of a remote subprogram call.
503 type RPC_Target (PCS_Kind : PCS_Names) is record
505 when Name_PolyORB_DSA =>
507 -- An expression whose value is a PolyORB reference to the target
511 Partition : Entity_Id;
512 -- A variable containing the Partition_ID of the target partition
514 RPC_Receiver : Node_Id;
515 -- An expression whose value is the address of the target RPC
520 procedure Specific_Build_General_Calling_Stubs
522 Statements : List_Id;
524 Subprogram_Id : Node_Id;
525 Asynchronous : Node_Id := Empty;
526 Is_Known_Asynchronous : Boolean := False;
527 Is_Known_Non_Asynchronous : Boolean := False;
528 Is_Function : Boolean;
530 Stub_Type : Entity_Id := Empty;
531 RACW_Type : Entity_Id := Empty;
533 -- Build calling stubs for general purpose. The parameters are:
534 -- Decls : a place to put declarations
535 -- Statements : a place to put statements
536 -- Target : PCS-specific target information (see details
537 -- in RPC_Target declaration).
538 -- Subprogram_Id : a node containing the subprogram ID
539 -- Asynchronous : True if an APC must be made instead of an RPC.
540 -- The value needs not be supplied if one of the
541 -- Is_Known_... is True.
542 -- Is_Known_Async... : True if we know that this is asynchronous
543 -- Is_Known_Non_A... : True if we know that this is not asynchronous
544 -- Spec : a node with a Parameter_Specifications and
545 -- a Result_Definition if applicable
546 -- Stub_Type : in case of RACW stubs, parameters of type access
547 -- to Stub_Type will be marshalled using the
548 -- address of the object (the addr field) rather
549 -- than using the 'Write on the stub itself
550 -- Nod : used to provide sloc for generated code
552 function Specific_Build_Stub_Target
555 RCI_Locator : Entity_Id;
556 Controlling_Parameter : Entity_Id) return RPC_Target;
557 -- Build call target information nodes for use within calling stubs. In the
558 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
559 -- for an RACW, Controlling_Parameter is the entity for the controlling
560 -- formal parameter used to determine the location of the target of the
561 -- call. Decls provides a location where variable declarations can be
562 -- appended to construct the necessary values.
564 procedure Specific_Build_Stub_Type
565 (RACW_Type : Entity_Id;
566 Stub_Type : Entity_Id;
567 Stub_Type_Decl : out Node_Id;
568 RPC_Receiver_Decl : out Node_Id);
569 -- Build a type declaration for the stub type associated with an RACW
570 -- type, and the necessary RPC receiver, if applicable. PCS-specific
571 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
572 -- is generated, then RPC_Receiver_Decl is set to Empty.
574 procedure Specific_Build_RPC_Receiver_Body
575 (RPC_Receiver : Entity_Id;
576 Request : out Entity_Id;
577 Subp_Id : out Entity_Id;
578 Subp_Index : out Entity_Id;
581 -- Make a subprogram body for an RPC receiver, with the given
582 -- defining unit name. On return:
583 -- - Subp_Id is the subprogram identifier from the PCS.
584 -- - Subp_Index is the index in the list of subprograms
585 -- used for dispatching (a variable of type Subprogram_Id).
586 -- - Stmts is the place where the request dispatching
587 -- statements can occur,
588 -- - Decl is the subprogram body declaration.
590 function Specific_Build_Subprogram_Receiving_Stubs
592 Asynchronous : Boolean;
593 Dynamically_Asynchronous : Boolean := False;
594 Stub_Type : Entity_Id := Empty;
595 RACW_Type : Entity_Id := Empty;
596 Parent_Primitive : Entity_Id := Empty) return Node_Id;
597 -- Build the receiving stub for a given subprogram. The subprogram
598 -- declaration is also built by this procedure, and the value returned
599 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
600 -- found in the specification, then its address is read from the stream
601 -- instead of the object itself and converted into an access to
602 -- class-wide type before doing the real call using any of the RACW type
603 -- pointing on the designated type.
605 procedure Specific_Add_Obj_RPC_Receiver_Completion
608 RPC_Receiver : Entity_Id;
609 Stub_Elements : Stub_Structure);
610 -- Add the necessary code to Decls after the completion of generation
611 -- of the RACW RPC receiver described by Stub_Elements.
613 procedure Specific_Add_Receiving_Stubs_To_Declarations
617 -- Add receiving stubs to the declarative part of an RCI unit
619 package GARLIC_Support is
621 -- Support for generating DSA code that uses the GARLIC PCS
623 -- The subprograms below provide the GARLIC versions of the
624 -- corresponding Specific_<subprogram> routine declared above.
626 procedure Add_RACW_Features
627 (RACW_Type : Entity_Id;
628 Stub_Type : Entity_Id;
629 Stub_Type_Access : Entity_Id;
630 RPC_Receiver_Decl : Node_Id;
631 Body_Decls : List_Id);
633 procedure Add_RAST_Features
635 RAS_Type : Entity_Id);
637 procedure Build_General_Calling_Stubs
639 Statements : List_Id;
640 Target_Partition : Entity_Id; -- From RPC_Target
641 Target_RPC_Receiver : Node_Id; -- From RPC_Target
642 Subprogram_Id : Node_Id;
643 Asynchronous : Node_Id := Empty;
644 Is_Known_Asynchronous : Boolean := False;
645 Is_Known_Non_Asynchronous : Boolean := False;
646 Is_Function : Boolean;
648 Stub_Type : Entity_Id := Empty;
649 RACW_Type : Entity_Id := Empty;
652 function Build_Stub_Target
655 RCI_Locator : Entity_Id;
656 Controlling_Parameter : Entity_Id) return RPC_Target;
658 procedure Build_Stub_Type
659 (RACW_Type : Entity_Id;
660 Stub_Type : Entity_Id;
661 Stub_Type_Decl : out Node_Id;
662 RPC_Receiver_Decl : out Node_Id);
664 function Build_Subprogram_Receiving_Stubs
666 Asynchronous : Boolean;
667 Dynamically_Asynchronous : Boolean := False;
668 Stub_Type : Entity_Id := Empty;
669 RACW_Type : Entity_Id := Empty;
670 Parent_Primitive : Entity_Id := Empty) return Node_Id;
672 procedure Add_Obj_RPC_Receiver_Completion
675 RPC_Receiver : Entity_Id;
676 Stub_Elements : Stub_Structure);
678 procedure Add_Receiving_Stubs_To_Declarations
683 procedure Build_RPC_Receiver_Body
684 (RPC_Receiver : Entity_Id;
685 Request : out Entity_Id;
686 Subp_Id : out Entity_Id;
687 Subp_Index : out Entity_Id;
693 package PolyORB_Support is
695 -- Support for generating DSA code that uses the PolyORB PCS
697 -- The subprograms below provide the PolyORB versions of the
698 -- corresponding Specific_<subprogram> routine declared above.
700 procedure Add_RACW_Features
701 (RACW_Type : Entity_Id;
703 Stub_Type : Entity_Id;
704 Stub_Type_Access : Entity_Id;
705 RPC_Receiver_Decl : Node_Id;
706 Body_Decls : List_Id);
708 procedure Add_RAST_Features
710 RAS_Type : Entity_Id);
712 procedure Build_General_Calling_Stubs
714 Statements : List_Id;
715 Target_Object : Node_Id; -- From RPC_Target
716 Subprogram_Id : Node_Id;
717 Asynchronous : Node_Id := Empty;
718 Is_Known_Asynchronous : Boolean := False;
719 Is_Known_Non_Asynchronous : Boolean := False;
720 Is_Function : Boolean;
722 Stub_Type : Entity_Id := Empty;
723 RACW_Type : Entity_Id := Empty;
726 function Build_Stub_Target
729 RCI_Locator : Entity_Id;
730 Controlling_Parameter : Entity_Id) return RPC_Target;
732 procedure Build_Stub_Type
733 (RACW_Type : Entity_Id;
734 Stub_Type : Entity_Id;
735 Stub_Type_Decl : out Node_Id;
736 RPC_Receiver_Decl : out Node_Id);
738 function Build_Subprogram_Receiving_Stubs
740 Asynchronous : Boolean;
741 Dynamically_Asynchronous : Boolean := False;
742 Stub_Type : Entity_Id := Empty;
743 RACW_Type : Entity_Id := Empty;
744 Parent_Primitive : Entity_Id := Empty) return Node_Id;
746 procedure Add_Obj_RPC_Receiver_Completion
749 RPC_Receiver : Entity_Id;
750 Stub_Elements : Stub_Structure);
752 procedure Add_Receiving_Stubs_To_Declarations
757 procedure Build_RPC_Receiver_Body
758 (RPC_Receiver : Entity_Id;
759 Request : out Entity_Id;
760 Subp_Id : out Entity_Id;
761 Subp_Index : out Entity_Id;
765 procedure Reserve_NamingContext_Methods;
766 -- Mark the method names for interface NamingContext as already used in
767 -- the overload table, so no clashes occur with user code (with the
768 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
769 -- their methods to be accessed as objects, for the implementation of
770 -- remote access-to-subprogram types).
774 -- Routines to build distribution helper subprograms for user-defined
775 -- types. For implementation of the Distributed systems annex (DSA)
776 -- over the PolyORB generic middleware components, it is necessary to
777 -- generate several supporting subprograms for each application data
778 -- type used in inter-partition communication. These subprograms are:
780 -- A Typecode function returning a high-level description of the
783 -- Two conversion functions allowing conversion of values of the
784 -- type from and to the generic data containers used by PolyORB.
785 -- These generic containers are called 'Any' type values after the
786 -- CORBA terminology, and hence the conversion subprograms are
787 -- named To_Any and From_Any.
789 function Build_From_Any_Call
792 Decls : List_Id) return Node_Id;
793 -- Build call to From_Any attribute function of type Typ with
794 -- expression N as actual parameter. Decls is the declarations list
795 -- for an appropriate enclosing scope of the point where the call
796 -- will be inserted; if the From_Any attribute for Typ needs to be
797 -- generated at this point, its declaration is appended to Decls.
799 procedure Build_From_Any_Function
803 Fnam : out Entity_Id);
804 -- Build From_Any attribute function for Typ. Loc is the reference
805 -- location for generated nodes, Typ is the type for which the
806 -- conversion function is generated. On return, Decl and Fnam contain
807 -- the declaration and entity for the newly-created function.
809 function Build_To_Any_Call
811 Decls : List_Id) return Node_Id;
812 -- Build call to To_Any attribute function with expression as actual
813 -- parameter. Decls is the declarations list for an appropriate
814 -- enclosing scope of the point where the call will be inserted; if
815 -- the To_Any attribute for Typ needs to be generated at this point,
816 -- its declaration is appended to Decls.
818 procedure Build_To_Any_Function
822 Fnam : out Entity_Id);
823 -- Build To_Any attribute function for Typ. Loc is the reference
824 -- location for generated nodes, Typ is the type for which the
825 -- conversion function is generated. On return, Decl and Fnam contain
826 -- the declaration and entity for the newly-created function.
828 function Build_TypeCode_Call
831 Decls : List_Id) return Node_Id;
832 -- Build call to TypeCode attribute function for Typ. Decls is the
833 -- declarations list for an appropriate enclosing scope of the point
834 -- where the call will be inserted; if the To_Any attribute for Typ
835 -- needs to be generated at this point, its declaration is appended
838 procedure Build_TypeCode_Function
842 Fnam : out Entity_Id);
843 -- Build TypeCode attribute function for Typ. Loc is the reference
844 -- location for generated nodes, Typ is the type for which the
845 -- conversion function is generated. On return, Decl and Fnam contain
846 -- the declaration and entity for the newly-created function.
848 procedure Build_Name_And_Repository_Id
850 Name_Str : out String_Id;
851 Repo_Id_Str : out String_Id);
852 -- In the PolyORB distribution model, each distributed object type
853 -- and each distributed operation has a globally unique identifier,
854 -- its Repository Id. This subprogram builds and returns two strings
855 -- for entity E (a distributed object type or operation): one
856 -- containing the name of E, the second containing its repository id.
862 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
864 function Build_From_Any_Call
867 Decls : List_Id) return Node_Id
868 renames PolyORB_Support.Helpers.Build_From_Any_Call;
870 function Build_To_Any_Call
872 Decls : List_Id) return Node_Id
873 renames PolyORB_Support.Helpers.Build_To_Any_Call;
875 function Build_TypeCode_Call
878 Decls : List_Id) return Node_Id
879 renames PolyORB_Support.Helpers.Build_TypeCode_Call;
881 ------------------------------------
882 -- Local variables and structures --
883 ------------------------------------
886 -- Needs comments ???
888 Output_From_Constrained : constant array (Boolean) of Name_Id :=
889 (False => Name_Output,
891 -- The attribute to choose depending on the fact that the parameter
892 -- is constrained or not. There is no such thing as Input_From_Constrained
893 -- since this require separate mechanisms ('Input is a function while
894 -- 'Read is a procedure).
896 ---------------------------------------
897 -- Add_Calling_Stubs_To_Declarations --
898 ---------------------------------------
900 procedure Add_Calling_Stubs_To_Declarations
904 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
905 -- Subprogram id 0 is reserved for calls received from
906 -- remote access-to-subprogram dereferences.
908 Current_Declaration : Node_Id;
909 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
910 RCI_Instantiation : Node_Id;
911 Subp_Stubs : Node_Id;
912 Subp_Str : String_Id;
914 pragma Warnings (Off, Subp_Str);
917 -- The first thing added is an instantiation of the generic package
918 -- System.Partition_Interface.RCI_Locator with the name of this remote
919 -- package. This will act as an interface with the name server to
920 -- determine the Partition_ID and the RPC_Receiver for the receiver
923 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
924 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
926 Append_To (Decls, RCI_Instantiation);
927 Analyze (RCI_Instantiation);
929 -- For each subprogram declaration visible in the spec, we do build a
930 -- body. We also increment a counter to assign a different Subprogram_Id
931 -- to each subprograms. The receiving stubs processing do use the same
932 -- mechanism and will thus assign the same Id and do the correct
935 Overload_Counter_Table.Reset;
936 PolyORB_Support.Reserve_NamingContext_Methods;
938 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
939 while Present (Current_Declaration) loop
940 if Nkind (Current_Declaration) = N_Subprogram_Declaration
941 and then Comes_From_Source (Current_Declaration)
943 Assign_Subprogram_Identifier
944 (Defining_Unit_Name (Specification (Current_Declaration)),
945 Current_Subprogram_Number,
949 Build_Subprogram_Calling_Stubs (
950 Vis_Decl => Current_Declaration,
952 Build_Subprogram_Id (Loc,
953 Defining_Unit_Name (Specification (Current_Declaration))),
955 Nkind (Specification (Current_Declaration)) =
956 N_Procedure_Specification
958 Is_Asynchronous (Defining_Unit_Name (Specification
959 (Current_Declaration))));
961 Append_To (Decls, Subp_Stubs);
962 Analyze (Subp_Stubs);
964 Current_Subprogram_Number := Current_Subprogram_Number + 1;
967 Next (Current_Declaration);
969 end Add_Calling_Stubs_To_Declarations;
971 -----------------------------
972 -- Add_Parameter_To_NVList --
973 -----------------------------
975 function Add_Parameter_To_NVList
978 Parameter : Entity_Id;
979 Constrained : Boolean;
980 RACW_Ctrl : Boolean := False;
981 Any : Entity_Id) return Node_Id
983 Parameter_Name_String : String_Id;
984 Parameter_Mode : Node_Id;
986 function Parameter_Passing_Mode
988 Parameter : Entity_Id;
989 Constrained : Boolean) return Node_Id;
990 -- Return an expression that denotes the parameter passing mode to be
991 -- used for Parameter in distribution stubs, where Constrained is
992 -- Parameter's constrained status.
994 ----------------------------
995 -- Parameter_Passing_Mode --
996 ----------------------------
998 function Parameter_Passing_Mode
1000 Parameter : Entity_Id;
1001 Constrained : Boolean) return Node_Id
1006 if Out_Present (Parameter) then
1007 if In_Present (Parameter)
1008 or else not Constrained
1010 -- Unconstrained formals must be translated
1011 -- to 'in' or 'inout', not 'out', because
1012 -- they need to be constrained by the actual.
1014 Lib_RE := RE_Mode_Inout;
1016 Lib_RE := RE_Mode_Out;
1020 Lib_RE := RE_Mode_In;
1023 return New_Occurrence_Of (RTE (Lib_RE), Loc);
1024 end Parameter_Passing_Mode;
1026 -- Start of processing for Add_Parameter_To_NVList
1029 if Nkind (Parameter) = N_Defining_Identifier then
1030 Get_Name_String (Chars (Parameter));
1032 Get_Name_String (Chars (Defining_Identifier (Parameter)));
1035 Parameter_Name_String := String_From_Name_Buffer;
1037 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1039 -- When the parameter passed to Add_Parameter_To_NVList is an
1040 -- Extra_Constrained parameter, Parameter is an N_Defining_
1041 -- Identifier, instead of a complete N_Parameter_Specification.
1042 -- Thus, we explicitly set 'in' mode in this case.
1044 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1048 Parameter_Passing_Mode (Loc, Parameter, Constrained);
1052 Make_Procedure_Call_Statement (Loc,
1055 (RTE (RE_NVList_Add_Item), Loc),
1056 Parameter_Associations => New_List (
1057 New_Occurrence_Of (NVList, Loc),
1058 Make_Function_Call (Loc,
1061 (RTE (RE_To_PolyORB_String), Loc),
1062 Parameter_Associations => New_List (
1063 Make_String_Literal (Loc,
1064 Strval => Parameter_Name_String))),
1065 New_Occurrence_Of (Any, Loc),
1067 end Add_Parameter_To_NVList;
1069 --------------------------------
1070 -- Add_RACW_Asynchronous_Flag --
1071 --------------------------------
1073 procedure Add_RACW_Asynchronous_Flag
1074 (Declarations : List_Id;
1075 RACW_Type : Entity_Id)
1077 Loc : constant Source_Ptr := Sloc (RACW_Type);
1079 Asynchronous_Flag : constant Entity_Id :=
1080 Make_Defining_Identifier (Loc,
1081 New_External_Name (Chars (RACW_Type), 'A'));
1084 -- Declare the asynchronous flag. This flag will be changed to True
1085 -- whenever it is known that the RACW type is asynchronous.
1087 Append_To (Declarations,
1088 Make_Object_Declaration (Loc,
1089 Defining_Identifier => Asynchronous_Flag,
1090 Constant_Present => True,
1091 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1092 Expression => New_Occurrence_Of (Standard_False, Loc)));
1094 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1095 end Add_RACW_Asynchronous_Flag;
1097 -----------------------
1098 -- Add_RACW_Features --
1099 -----------------------
1101 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1102 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1103 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1107 Body_Decls : List_Id;
1109 Stub_Type : Entity_Id;
1110 Stub_Type_Access : Entity_Id;
1111 RPC_Receiver_Decl : Node_Id;
1114 -- True when appropriate stubs have already been generated (this is the
1115 -- case when another RACW with the same designated type has already been
1116 -- encountered), in which case we reuse the previous stubs rather than
1117 -- generating new ones.
1120 if not Expander_Active then
1124 -- Mark the current package declaration as containing an RACW, so that
1125 -- the bodies for the calling stubs and the RACW stream subprograms
1126 -- are attached to the tree when the corresponding body is encountered.
1128 Set_Has_RACW (Current_Scope);
1130 -- Look for place to declare the RACW stub type and RACW operations
1136 -- Case of declaring the RACW in the same package as its designated
1137 -- type: we know that the designated type is a private type, so we
1138 -- use the private declarations list.
1140 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1142 if Present (Private_Declarations (Pkg_Spec)) then
1143 Decls := Private_Declarations (Pkg_Spec);
1145 Decls := Visible_Declarations (Pkg_Spec);
1150 -- Case of declaring the RACW in another package than its designated
1151 -- type: use the private declarations list if present; otherwise
1152 -- use the visible declarations.
1154 Decls := List_Containing (Declaration_Node (RACW_Type));
1158 -- If we were unable to find the declarations, that means that the
1159 -- completion of the type was missing. We can safely return and let the
1160 -- error be caught by the semantic analysis.
1167 (Designated_Type => Desig,
1168 RACW_Type => RACW_Type,
1170 Stub_Type => Stub_Type,
1171 Stub_Type_Access => Stub_Type_Access,
1172 RPC_Receiver_Decl => RPC_Receiver_Decl,
1173 Body_Decls => Body_Decls,
1174 Existing => Existing);
1176 -- If this RACW is not in the main unit, do not generate primitive or
1179 if not Entity_Is_In_Main_Unit (RACW_Type) then
1180 Body_Decls := No_List;
1183 Add_RACW_Asynchronous_Flag
1184 (Declarations => Decls,
1185 RACW_Type => RACW_Type);
1187 Specific_Add_RACW_Features
1188 (RACW_Type => RACW_Type,
1190 Stub_Type => Stub_Type,
1191 Stub_Type_Access => Stub_Type_Access,
1192 RPC_Receiver_Decl => RPC_Receiver_Decl,
1193 Body_Decls => Body_Decls);
1195 -- If we already have stubs for this designated type, nothing to do
1201 if Is_Frozen (Desig) then
1202 Validate_RACW_Primitives (RACW_Type);
1203 Add_RACW_Primitive_Declarations_And_Bodies
1204 (Designated_Type => Desig,
1205 Insertion_Node => RPC_Receiver_Decl,
1206 Body_Decls => Body_Decls);
1209 -- Validate_RACW_Primitives requires the list of all primitives of
1210 -- the designated type, so defer processing until Desig is frozen.
1211 -- See Exp_Ch3.Freeze_Type.
1213 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1215 end Add_RACW_Features;
1217 ------------------------------------------------
1218 -- Add_RACW_Primitive_Declarations_And_Bodies --
1219 ------------------------------------------------
1221 procedure Add_RACW_Primitive_Declarations_And_Bodies
1222 (Designated_Type : Entity_Id;
1223 Insertion_Node : Node_Id;
1224 Body_Decls : List_Id)
1226 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1227 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1228 -- the declarations are recognized as belonging to the current package.
1230 Stub_Elements : constant Stub_Structure :=
1231 Stubs_Table.Get (Designated_Type);
1233 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1235 Is_RAS : constant Boolean :=
1236 not Comes_From_Source (Stub_Elements.RACW_Type);
1237 -- Case of the RACW generated to implement a remote access-to-
1240 Build_Bodies : constant Boolean :=
1241 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1242 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1243 -- only when the main unit is the unit that contains the stub type.
1245 Current_Insertion_Node : Node_Id := Insertion_Node;
1247 RPC_Receiver : Entity_Id;
1248 RPC_Receiver_Statements : List_Id;
1249 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1250 RPC_Receiver_Elsif_Parts : List_Id;
1251 RPC_Receiver_Request : Entity_Id;
1252 RPC_Receiver_Subp_Id : Entity_Id;
1253 RPC_Receiver_Subp_Index : Entity_Id;
1255 Subp_Str : String_Id;
1257 Current_Primitive_Elmt : Elmt_Id;
1258 Current_Primitive : Entity_Id;
1259 Current_Primitive_Body : Node_Id;
1260 Current_Primitive_Spec : Node_Id;
1261 Current_Primitive_Decl : Node_Id;
1262 Current_Primitive_Number : Int := 0;
1263 Current_Primitive_Alias : Node_Id;
1264 Current_Receiver : Entity_Id;
1265 Current_Receiver_Body : Node_Id;
1266 RPC_Receiver_Decl : Node_Id;
1267 Possibly_Asynchronous : Boolean;
1270 if not Expander_Active then
1276 Make_Defining_Identifier (Loc,
1277 Chars => New_Internal_Name ('P'));
1279 Specific_Build_RPC_Receiver_Body
1280 (RPC_Receiver => RPC_Receiver,
1281 Request => RPC_Receiver_Request,
1282 Subp_Id => RPC_Receiver_Subp_Id,
1283 Subp_Index => RPC_Receiver_Subp_Index,
1284 Stmts => RPC_Receiver_Statements,
1285 Decl => RPC_Receiver_Decl);
1287 if Get_PCS_Name = Name_PolyORB_DSA then
1289 -- For the case of PolyORB, we need to map a textual operation
1290 -- name into a primitive index. Currently we do so using a simple
1291 -- sequence of string comparisons.
1293 RPC_Receiver_Elsif_Parts := New_List;
1297 -- Build callers, receivers for every primitive operations and a RPC
1298 -- receiver for this type.
1300 if Present (Primitive_Operations (Designated_Type)) then
1301 Overload_Counter_Table.Reset;
1303 Current_Primitive_Elmt :=
1304 First_Elmt (Primitive_Operations (Designated_Type));
1305 while Current_Primitive_Elmt /= No_Elmt loop
1306 Current_Primitive := Node (Current_Primitive_Elmt);
1308 -- Copy the primitive of all the parents, except predefined ones
1309 -- that are not remotely dispatching. Also omit hidden primitives
1310 -- (occurs in the case of primitives of interface progenitors
1311 -- other than immediate ancestors of the Designated_Type).
1313 if Chars (Current_Primitive) /= Name_uSize
1314 and then Chars (Current_Primitive) /= Name_uAlignment
1316 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1317 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1318 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1319 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1320 Is_TSS (Current_Primitive, TSS_Stream_Write))
1321 and then not Is_Hidden (Current_Primitive)
1323 -- The first thing to do is build an up-to-date copy of the
1324 -- spec with all the formals referencing Designated_Type
1325 -- transformed into formals referencing Stub_Type. Since this
1326 -- primitive may have been inherited, go back the alias chain
1327 -- until the real primitive has been found.
1329 Current_Primitive_Alias := Current_Primitive;
1330 while Present (Alias (Current_Primitive_Alias)) loop
1332 (Current_Primitive_Alias
1333 /= Alias (Current_Primitive_Alias));
1334 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
1337 -- Copy the spec from the original declaration for the purpose
1338 -- of declaring an overriding subprogram: we need to replace
1339 -- the type of each controlling formal with Stub_Type. The
1340 -- primitive may have been declared for Designated_Type or
1341 -- inherited from some ancestor type for which we do not have
1342 -- an easily determined Entity_Id. We have no systematic way
1343 -- of knowing which type to substitute Stub_Type for. Instead,
1344 -- Copy_Specification relies on the flag Is_Controlling_Formal
1345 -- to determine which formals to change.
1347 Current_Primitive_Spec :=
1348 Copy_Specification (Loc,
1349 Spec => Parent (Current_Primitive_Alias),
1350 Ctrl_Type => Stub_Elements.Stub_Type);
1352 Current_Primitive_Decl :=
1353 Make_Subprogram_Declaration (Loc,
1354 Specification => Current_Primitive_Spec);
1356 Insert_After_And_Analyze (Current_Insertion_Node,
1357 Current_Primitive_Decl);
1358 Current_Insertion_Node := Current_Primitive_Decl;
1360 Possibly_Asynchronous :=
1361 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1362 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1364 Assign_Subprogram_Identifier (
1365 Defining_Unit_Name (Current_Primitive_Spec),
1366 Current_Primitive_Number,
1369 if Build_Bodies then
1370 Current_Primitive_Body :=
1371 Build_Subprogram_Calling_Stubs
1372 (Vis_Decl => Current_Primitive_Decl,
1374 Build_Subprogram_Id (Loc,
1375 Defining_Unit_Name (Current_Primitive_Spec)),
1376 Asynchronous => Possibly_Asynchronous,
1377 Dynamically_Asynchronous => Possibly_Asynchronous,
1378 Stub_Type => Stub_Elements.Stub_Type,
1379 RACW_Type => Stub_Elements.RACW_Type);
1380 Append_To (Body_Decls, Current_Primitive_Body);
1382 -- Analyzing the body here would cause the Stub type to
1383 -- be frozen, thus preventing subsequent primitive
1384 -- declarations. For this reason, it will be analyzed
1385 -- later in the regular flow (and in the context of the
1386 -- appropriate unit body, see Append_RACW_Bodies).
1390 -- Build the receiver stubs
1392 if Build_Bodies and then not Is_RAS then
1393 Current_Receiver_Body :=
1394 Specific_Build_Subprogram_Receiving_Stubs
1395 (Vis_Decl => Current_Primitive_Decl,
1396 Asynchronous => Possibly_Asynchronous,
1397 Dynamically_Asynchronous => Possibly_Asynchronous,
1398 Stub_Type => Stub_Elements.Stub_Type,
1399 RACW_Type => Stub_Elements.RACW_Type,
1400 Parent_Primitive => Current_Primitive);
1402 Current_Receiver := Defining_Unit_Name (
1403 Specification (Current_Receiver_Body));
1405 Append_To (Body_Decls, Current_Receiver_Body);
1407 -- Add a case alternative to the receiver
1409 if Get_PCS_Name = Name_PolyORB_DSA then
1410 Append_To (RPC_Receiver_Elsif_Parts,
1411 Make_Elsif_Part (Loc,
1413 Make_Function_Call (Loc,
1416 RTE (RE_Caseless_String_Eq), Loc),
1417 Parameter_Associations => New_List (
1418 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1419 Make_String_Literal (Loc, Subp_Str))),
1421 Then_Statements => New_List (
1422 Make_Assignment_Statement (Loc,
1423 Name => New_Occurrence_Of (
1424 RPC_Receiver_Subp_Index, Loc),
1426 Make_Integer_Literal (Loc,
1427 Intval => Current_Primitive_Number)))));
1430 Append_To (RPC_Receiver_Case_Alternatives,
1431 Make_Case_Statement_Alternative (Loc,
1432 Discrete_Choices => New_List (
1433 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1435 Statements => New_List (
1436 Make_Procedure_Call_Statement (Loc,
1438 New_Occurrence_Of (Current_Receiver, Loc),
1439 Parameter_Associations => New_List (
1440 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1443 -- Increment the index of current primitive
1445 Current_Primitive_Number := Current_Primitive_Number + 1;
1448 Next_Elmt (Current_Primitive_Elmt);
1452 -- Build the case statement and the heart of the subprogram
1454 if Build_Bodies and then not Is_RAS then
1455 if Get_PCS_Name = Name_PolyORB_DSA
1456 and then Present (First (RPC_Receiver_Elsif_Parts))
1458 Append_To (RPC_Receiver_Statements,
1459 Make_Implicit_If_Statement (Designated_Type,
1460 Condition => New_Occurrence_Of (Standard_False, Loc),
1461 Then_Statements => New_List,
1462 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1465 Append_To (RPC_Receiver_Case_Alternatives,
1466 Make_Case_Statement_Alternative (Loc,
1467 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1468 Statements => New_List (Make_Null_Statement (Loc))));
1470 Append_To (RPC_Receiver_Statements,
1471 Make_Case_Statement (Loc,
1473 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1474 Alternatives => RPC_Receiver_Case_Alternatives));
1476 Append_To (Body_Decls, RPC_Receiver_Decl);
1477 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1478 Body_Decls, RPC_Receiver, Stub_Elements);
1480 -- Do not analyze RPC receiver body at this stage since it references
1481 -- subprograms that have not been analyzed yet. It will be analyzed in
1482 -- the regular flow (see Append_RACW_Bodies).
1485 end Add_RACW_Primitive_Declarations_And_Bodies;
1487 -----------------------------
1488 -- Add_RAS_Dereference_TSS --
1489 -----------------------------
1491 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1492 Loc : constant Source_Ptr := Sloc (N);
1494 Type_Def : constant Node_Id := Type_Definition (N);
1495 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1496 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1497 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1499 RACW_Primitive_Name : Node_Id;
1501 Proc : constant Entity_Id :=
1502 Make_Defining_Identifier (Loc,
1503 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1505 Proc_Spec : Node_Id;
1506 Param_Specs : List_Id;
1507 Param_Assoc : constant List_Id := New_List;
1508 Stmts : constant List_Id := New_List;
1510 RAS_Parameter : constant Entity_Id :=
1511 Make_Defining_Identifier (Loc,
1512 Chars => New_Internal_Name ('P'));
1514 Is_Function : constant Boolean :=
1515 Nkind (Type_Def) = N_Access_Function_Definition;
1517 Is_Degenerate : Boolean;
1518 -- Set to True if the subprogram_specification for this RAS has an
1519 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1521 Spec : constant Node_Id := Type_Def;
1523 Current_Parameter : Node_Id;
1525 -- Start of processing for Add_RAS_Dereference_TSS
1528 -- The Dereference TSS for a remote access-to-subprogram type has the
1531 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1534 -- This is called whenever a value of a RAS type is dereferenced
1536 -- First construct a list of parameter specifications:
1538 -- The first formal is the RAS values
1540 Param_Specs := New_List (
1541 Make_Parameter_Specification (Loc,
1542 Defining_Identifier => RAS_Parameter,
1545 New_Occurrence_Of (Fat_Type, Loc)));
1547 -- The following formals are copied from the type declaration
1549 Is_Degenerate := False;
1550 Current_Parameter := First (Parameter_Specifications (Type_Def));
1551 Parameters : while Present (Current_Parameter) loop
1552 if Nkind (Parameter_Type (Current_Parameter)) =
1555 Is_Degenerate := True;
1558 Append_To (Param_Specs,
1559 Make_Parameter_Specification (Loc,
1560 Defining_Identifier =>
1561 Make_Defining_Identifier (Loc,
1562 Chars => Chars (Defining_Identifier (Current_Parameter))),
1563 In_Present => In_Present (Current_Parameter),
1564 Out_Present => Out_Present (Current_Parameter),
1566 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1568 New_Copy_Tree (Expression (Current_Parameter))));
1570 Append_To (Param_Assoc,
1571 Make_Identifier (Loc,
1572 Chars => Chars (Defining_Identifier (Current_Parameter))));
1574 Next (Current_Parameter);
1575 end loop Parameters;
1577 if Is_Degenerate then
1578 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1580 -- Generate a dummy body. This code will never actually be executed,
1581 -- because null is the only legal value for a degenerate RAS type.
1582 -- For legality's sake (in order to avoid generating a function that
1583 -- does not contain a return statement), we include a dummy recursive
1584 -- call on the TSS itself.
1587 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1588 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1591 -- For a normal RAS type, we cast the RAS formal to the corresponding
1592 -- tagged type, and perform a dispatching call to its Call primitive
1595 Prepend_To (Param_Assoc,
1596 Unchecked_Convert_To (RACW_Type,
1597 New_Occurrence_Of (RAS_Parameter, Loc)));
1599 RACW_Primitive_Name :=
1600 Make_Selected_Component (Loc,
1601 Prefix => Scope (RACW_Type),
1602 Selector_Name => Name_uCall);
1607 Make_Simple_Return_Statement (Loc,
1609 Make_Function_Call (Loc,
1610 Name => RACW_Primitive_Name,
1611 Parameter_Associations => Param_Assoc)));
1615 Make_Procedure_Call_Statement (Loc,
1616 Name => RACW_Primitive_Name,
1617 Parameter_Associations => Param_Assoc));
1620 -- Build the complete subprogram
1624 Make_Function_Specification (Loc,
1625 Defining_Unit_Name => Proc,
1626 Parameter_Specifications => Param_Specs,
1627 Result_Definition =>
1629 Entity (Result_Definition (Spec)), Loc));
1631 Set_Ekind (Proc, E_Function);
1633 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1637 Make_Procedure_Specification (Loc,
1638 Defining_Unit_Name => Proc,
1639 Parameter_Specifications => Param_Specs);
1641 Set_Ekind (Proc, E_Procedure);
1642 Set_Etype (Proc, Standard_Void_Type);
1646 Make_Subprogram_Body (Loc,
1647 Specification => Proc_Spec,
1648 Declarations => New_List,
1649 Handled_Statement_Sequence =>
1650 Make_Handled_Sequence_Of_Statements (Loc,
1651 Statements => Stmts)));
1653 Set_TSS (Fat_Type, Proc);
1654 end Add_RAS_Dereference_TSS;
1656 -------------------------------
1657 -- Add_RAS_Proxy_And_Analyze --
1658 -------------------------------
1660 procedure Add_RAS_Proxy_And_Analyze
1663 All_Calls_Remote_E : Entity_Id;
1664 Proxy_Object_Addr : out Entity_Id)
1666 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1668 Subp_Name : constant Entity_Id :=
1669 Defining_Unit_Name (Specification (Vis_Decl));
1671 Pkg_Name : constant Entity_Id :=
1672 Make_Defining_Identifier (Loc,
1673 Chars => New_External_Name (Chars (Subp_Name), 'P', -1));
1675 Proxy_Type : constant Entity_Id :=
1676 Make_Defining_Identifier (Loc,
1679 (Related_Id => Chars (Subp_Name),
1682 Proxy_Type_Full_View : constant Entity_Id :=
1683 Make_Defining_Identifier (Loc,
1684 Chars (Proxy_Type));
1686 Subp_Decl_Spec : constant Node_Id :=
1687 Build_RAS_Primitive_Specification
1688 (Subp_Spec => Specification (Vis_Decl),
1689 Remote_Object_Type => Proxy_Type);
1691 Subp_Body_Spec : constant Node_Id :=
1692 Build_RAS_Primitive_Specification
1693 (Subp_Spec => Specification (Vis_Decl),
1694 Remote_Object_Type => Proxy_Type);
1696 Vis_Decls : constant List_Id := New_List;
1697 Pvt_Decls : constant List_Id := New_List;
1698 Actuals : constant List_Id := New_List;
1700 Perform_Call : Node_Id;
1703 -- type subpP is tagged limited private;
1705 Append_To (Vis_Decls,
1706 Make_Private_Type_Declaration (Loc,
1707 Defining_Identifier => Proxy_Type,
1708 Tagged_Present => True,
1709 Limited_Present => True));
1711 -- [subprogram] Call
1712 -- (Self : access subpP;
1713 -- ...other-formals...)
1716 Append_To (Vis_Decls,
1717 Make_Subprogram_Declaration (Loc,
1718 Specification => Subp_Decl_Spec));
1720 -- A : constant System.Address;
1722 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1724 Append_To (Vis_Decls,
1725 Make_Object_Declaration (Loc,
1726 Defining_Identifier => Proxy_Object_Addr,
1727 Constant_Present => True,
1728 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)));
1732 -- type subpP is tagged limited record
1733 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1737 Append_To (Pvt_Decls,
1738 Make_Full_Type_Declaration (Loc,
1739 Defining_Identifier => Proxy_Type_Full_View,
1741 Build_Remote_Subprogram_Proxy_Type (Loc,
1742 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1744 -- Trick semantic analysis into swapping the public and full view when
1745 -- freezing the public view.
1747 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1750 -- (Self : access O;
1751 -- ...other-formals...) is
1753 -- P (...other-formals...);
1757 -- (Self : access O;
1758 -- ...other-formals...)
1761 -- return F (...other-formals...);
1764 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1766 Make_Procedure_Call_Statement (Loc,
1767 Name => New_Occurrence_Of (Subp_Name, Loc),
1768 Parameter_Associations => Actuals);
1771 Make_Simple_Return_Statement (Loc,
1773 Make_Function_Call (Loc,
1774 Name => New_Occurrence_Of (Subp_Name, Loc),
1775 Parameter_Associations => Actuals));
1778 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1779 pragma Assert (Present (Formal));
1782 exit when No (Formal);
1784 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1787 -- O : aliased subpP;
1789 Append_To (Pvt_Decls,
1790 Make_Object_Declaration (Loc,
1791 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
1792 Aliased_Present => True,
1793 Object_Definition => New_Occurrence_Of (Proxy_Type, Loc)));
1795 -- A : constant System.Address := O'Address;
1797 Append_To (Pvt_Decls,
1798 Make_Object_Declaration (Loc,
1799 Defining_Identifier =>
1800 Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)),
1801 Constant_Present => True,
1802 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc),
1804 Make_Attribute_Reference (Loc,
1805 Prefix => New_Occurrence_Of (
1806 Defining_Identifier (Last (Pvt_Decls)), Loc),
1807 Attribute_Name => Name_Address)));
1810 Make_Package_Declaration (Loc,
1811 Specification => Make_Package_Specification (Loc,
1812 Defining_Unit_Name => Pkg_Name,
1813 Visible_Declarations => Vis_Decls,
1814 Private_Declarations => Pvt_Decls,
1815 End_Label => Empty)));
1816 Analyze (Last (Decls));
1819 Make_Package_Body (Loc,
1820 Defining_Unit_Name =>
1821 Make_Defining_Identifier (Loc, Chars (Pkg_Name)),
1822 Declarations => New_List (
1823 Make_Subprogram_Body (Loc,
1824 Specification => Subp_Body_Spec,
1825 Declarations => New_List,
1826 Handled_Statement_Sequence =>
1827 Make_Handled_Sequence_Of_Statements (Loc,
1828 Statements => New_List (Perform_Call))))));
1829 Analyze (Last (Decls));
1830 end Add_RAS_Proxy_And_Analyze;
1832 -----------------------
1833 -- Add_RAST_Features --
1834 -----------------------
1836 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1837 RAS_Type : constant Entity_Id :=
1838 Equivalent_Type (Defining_Identifier (Vis_Decl));
1840 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1841 Add_RAS_Dereference_TSS (Vis_Decl);
1842 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1843 end Add_RAST_Features;
1849 procedure Add_Stub_Type
1850 (Designated_Type : Entity_Id;
1851 RACW_Type : Entity_Id;
1853 Stub_Type : out Entity_Id;
1854 Stub_Type_Access : out Entity_Id;
1855 RPC_Receiver_Decl : out Node_Id;
1856 Body_Decls : out List_Id;
1857 Existing : out Boolean)
1859 Loc : constant Source_Ptr := Sloc (RACW_Type);
1861 Stub_Elements : constant Stub_Structure :=
1862 Stubs_Table.Get (Designated_Type);
1863 Stub_Type_Decl : Node_Id;
1864 Stub_Type_Access_Decl : Node_Id;
1867 if Stub_Elements /= Empty_Stub_Structure then
1868 Stub_Type := Stub_Elements.Stub_Type;
1869 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1870 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1871 Body_Decls := Stub_Elements.Body_Decls;
1878 Make_Defining_Identifier (Loc,
1879 Chars => New_Internal_Name ('S'));
1880 Set_Ekind (Stub_Type, E_Record_Type);
1881 Set_Is_RACW_Stub_Type (Stub_Type);
1883 Make_Defining_Identifier (Loc,
1884 Chars => New_External_Name
1885 (Related_Id => Chars (Stub_Type), Suffix => 'A'));
1887 Specific_Build_Stub_Type
1888 (RACW_Type, Stub_Type,
1889 Stub_Type_Decl, RPC_Receiver_Decl);
1891 Stub_Type_Access_Decl :=
1892 Make_Full_Type_Declaration (Loc,
1893 Defining_Identifier => Stub_Type_Access,
1895 Make_Access_To_Object_Definition (Loc,
1896 All_Present => True,
1897 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1899 Append_To (Decls, Stub_Type_Decl);
1900 Analyze (Last (Decls));
1901 Append_To (Decls, Stub_Type_Access_Decl);
1902 Analyze (Last (Decls));
1904 -- This is in no way a type derivation, but we fake it to make sure that
1905 -- the dispatching table gets built with the corresponding primitive
1906 -- operations at the right place.
1908 Derive_Subprograms (Parent_Type => Designated_Type,
1909 Derived_Type => Stub_Type);
1911 if Present (RPC_Receiver_Decl) then
1912 Append_To (Decls, RPC_Receiver_Decl);
1914 RPC_Receiver_Decl := Last (Decls);
1917 Body_Decls := New_List;
1919 Stubs_Table.Set (Designated_Type,
1920 (Stub_Type => Stub_Type,
1921 Stub_Type_Access => Stub_Type_Access,
1922 RPC_Receiver_Decl => RPC_Receiver_Decl,
1923 Body_Decls => Body_Decls,
1924 RACW_Type => RACW_Type));
1927 ------------------------
1928 -- Append_RACW_Bodies --
1929 ------------------------
1931 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
1934 E := First_Entity (Spec_Id);
1935 while Present (E) loop
1936 if Is_Remote_Access_To_Class_Wide_Type (E) then
1937 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
1942 end Append_RACW_Bodies;
1944 ----------------------------------
1945 -- Assign_Subprogram_Identifier --
1946 ----------------------------------
1948 procedure Assign_Subprogram_Identifier
1953 N : constant Name_Id := Chars (Def);
1955 Overload_Order : constant Int :=
1956 Overload_Counter_Table.Get (N) + 1;
1959 Overload_Counter_Table.Set (N, Overload_Order);
1961 Get_Name_String (N);
1963 -- Homonym handling: as in Exp_Dbug, but much simpler,
1964 -- because the only entities for which we have to generate
1965 -- names here need only to be disambiguated within their
1968 if Overload_Order > 1 then
1969 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
1970 Name_Len := Name_Len + 2;
1971 Add_Nat_To_Name_Buffer (Overload_Order);
1974 Id := String_From_Name_Buffer;
1975 Subprogram_Identifier_Table.Set (Def,
1976 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
1977 end Assign_Subprogram_Identifier;
1979 -------------------------------------
1980 -- Build_Actual_Object_Declaration --
1981 -------------------------------------
1983 procedure Build_Actual_Object_Declaration
1984 (Object : Entity_Id;
1990 Loc : constant Source_Ptr := Sloc (Object);
1992 -- Declare a temporary object for the actual, possibly initialized with
1993 -- a 'Input/From_Any call.
1995 -- Complication arises in the case of limited types, for which such a
1996 -- declaration is illegal in Ada 95. In that case, we first generate a
1997 -- renaming declaration of the 'Input call, and then if needed we
1998 -- generate an overlaid non-constant view.
2000 if Ada_Version <= Ada_95
2001 and then Is_Limited_Type (Etyp)
2002 and then Present (Expr)
2005 -- Object : Etyp renames <func-call>
2008 Make_Object_Renaming_Declaration (Loc,
2009 Defining_Identifier => Object,
2010 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
2015 -- The name defined by the renaming declaration denotes a
2016 -- constant view; create a non-constant object at the same address
2017 -- to be used as the actual.
2020 Constant_Object : constant Entity_Id :=
2021 Make_Defining_Identifier (Loc,
2022 New_Internal_Name ('P'));
2024 Set_Defining_Identifier
2025 (Last (Decls), Constant_Object);
2027 -- We have an unconstrained Etyp: build the actual constrained
2028 -- subtype for the value we just read from the stream.
2030 -- subtype S is <actual subtype of Constant_Object>;
2033 Build_Actual_Subtype (Etyp,
2034 New_Occurrence_Of (Constant_Object, Loc)));
2039 Make_Object_Declaration (Loc,
2040 Defining_Identifier => Object,
2041 Object_Definition =>
2043 (Defining_Identifier (Last (Decls)), Loc)));
2044 Set_Ekind (Object, E_Variable);
2046 -- Suppress default initialization:
2047 -- pragma Import (Ada, Object);
2051 Chars => Name_Import,
2052 Pragma_Argument_Associations => New_List (
2053 Make_Pragma_Argument_Association (Loc,
2054 Chars => Name_Convention,
2055 Expression => Make_Identifier (Loc, Name_Ada)),
2056 Make_Pragma_Argument_Association (Loc,
2057 Chars => Name_Entity,
2058 Expression => New_Occurrence_Of (Object, Loc)))));
2060 -- for Object'Address use Constant_Object'Address;
2063 Make_Attribute_Definition_Clause (Loc,
2064 Name => New_Occurrence_Of (Object, Loc),
2065 Chars => Name_Address,
2067 Make_Attribute_Reference (Loc,
2068 Prefix => New_Occurrence_Of (Constant_Object, Loc),
2069 Attribute_Name => Name_Address)));
2075 -- General case of a regular object declaration. Object is flagged
2076 -- constant unless it has mode out or in out, to allow the backend
2077 -- to optimize where possible.
2079 -- Object : [constant] Etyp [:= <expr>];
2082 Make_Object_Declaration (Loc,
2083 Defining_Identifier => Object,
2084 Constant_Present => Present (Expr) and then not Variable,
2085 Object_Definition => New_Occurrence_Of (Etyp, Loc),
2086 Expression => Expr));
2088 if Constant_Present (Last (Decls)) then
2089 Set_Ekind (Object, E_Constant);
2091 Set_Ekind (Object, E_Variable);
2094 end Build_Actual_Object_Declaration;
2096 ------------------------------
2097 -- Build_Get_Unique_RP_Call --
2098 ------------------------------
2100 function Build_Get_Unique_RP_Call
2102 Pointer : Entity_Id;
2103 Stub_Type : Entity_Id) return List_Id
2107 Make_Procedure_Call_Statement (Loc,
2109 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2110 Parameter_Associations => New_List (
2111 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2112 New_Occurrence_Of (Pointer, Loc)))),
2114 Make_Assignment_Statement (Loc,
2116 Make_Selected_Component (Loc,
2117 Prefix => New_Occurrence_Of (Pointer, Loc),
2119 New_Occurrence_Of (First_Tag_Component
2120 (Designated_Type (Etype (Pointer))), Loc)),
2122 Make_Attribute_Reference (Loc,
2123 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2124 Attribute_Name => Name_Tag)));
2126 -- Note: The assignment to Pointer._Tag is safe here because
2127 -- we carefully ensured that Stub_Type has exactly the same layout
2128 -- as System.Partition_Interface.RACW_Stub_Type.
2130 end Build_Get_Unique_RP_Call;
2132 -----------------------------------
2133 -- Build_Ordered_Parameters_List --
2134 -----------------------------------
2136 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2137 Constrained_List : List_Id;
2138 Unconstrained_List : List_Id;
2139 Current_Parameter : Node_Id;
2142 First_Parameter : Node_Id;
2143 For_RAS : Boolean := False;
2146 if No (Parameter_Specifications (Spec)) then
2150 Constrained_List := New_List;
2151 Unconstrained_List := New_List;
2152 First_Parameter := First (Parameter_Specifications (Spec));
2154 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2155 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2160 -- Loop through the parameters and add them to the right list. Note that
2161 -- we treat a parameter of a null-excluding access type as unconstrained
2162 -- because we can't declare an object of such a type with default
2165 Current_Parameter := First_Parameter;
2166 while Present (Current_Parameter) loop
2167 Ptyp := Parameter_Type (Current_Parameter);
2169 if (Nkind (Ptyp) = N_Access_Definition
2170 or else not Transmit_As_Unconstrained (Etype (Ptyp)))
2171 and then not (For_RAS and then Current_Parameter = First_Parameter)
2173 Append_To (Constrained_List, New_Copy (Current_Parameter));
2175 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2178 Next (Current_Parameter);
2181 -- Unconstrained parameters are returned first
2183 Append_List_To (Unconstrained_List, Constrained_List);
2185 return Unconstrained_List;
2186 end Build_Ordered_Parameters_List;
2188 ----------------------------------
2189 -- Build_Passive_Partition_Stub --
2190 ----------------------------------
2192 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2194 Pkg_Name : String_Id;
2197 Loc : constant Source_Ptr := Sloc (U);
2200 -- Verify that the implementation supports distribution, by accessing
2201 -- a type defined in the proper version of system.rpc
2204 Dist_OK : Entity_Id;
2205 pragma Warnings (Off, Dist_OK);
2207 Dist_OK := RTE (RE_Params_Stream_Type);
2210 -- Use body if present, spec otherwise
2212 if Nkind (U) = N_Package_Declaration then
2213 Pkg_Spec := Specification (U);
2214 L := Visible_Declarations (Pkg_Spec);
2216 Pkg_Spec := Parent (Corresponding_Spec (U));
2217 L := Declarations (U);
2220 Get_Library_Unit_Name_String (Pkg_Spec);
2221 Pkg_Name := String_From_Name_Buffer;
2223 Make_Procedure_Call_Statement (Loc,
2225 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2226 Parameter_Associations => New_List (
2227 Make_String_Literal (Loc, Pkg_Name),
2228 Make_Attribute_Reference (Loc,
2230 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2231 Attribute_Name => Name_Version)));
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_Stub_Tag --
2307 --------------------
2309 function Build_Stub_Tag
2311 RACW_Type : Entity_Id) return Node_Id
2313 Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type);
2316 Make_Attribute_Reference (Loc,
2317 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2318 Attribute_Name => Name_Tag);
2321 ------------------------------------
2322 -- Build_Subprogram_Calling_Stubs --
2323 ------------------------------------
2325 function Build_Subprogram_Calling_Stubs
2326 (Vis_Decl : Node_Id;
2328 Asynchronous : Boolean;
2329 Dynamically_Asynchronous : Boolean := False;
2330 Stub_Type : Entity_Id := Empty;
2331 RACW_Type : Entity_Id := Empty;
2332 Locator : Entity_Id := Empty;
2333 New_Name : Name_Id := No_Name) return Node_Id
2335 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2337 Decls : constant List_Id := New_List;
2338 Statements : constant List_Id := New_List;
2340 Subp_Spec : Node_Id;
2341 -- The specification of the body
2343 Controlling_Parameter : Entity_Id := Empty;
2345 Asynchronous_Expr : Node_Id := Empty;
2347 RCI_Locator : Entity_Id;
2349 Spec_To_Use : Node_Id;
2351 procedure Insert_Partition_Check (Parameter : Node_Id);
2352 -- Check that the parameter has been elaborated on the same partition
2353 -- than the controlling parameter (E.4(19)).
2355 ----------------------------
2356 -- Insert_Partition_Check --
2357 ----------------------------
2359 procedure Insert_Partition_Check (Parameter : Node_Id) is
2360 Parameter_Entity : constant Entity_Id :=
2361 Defining_Identifier (Parameter);
2363 -- The expression that will be built is of the form:
2365 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2366 -- raise Constraint_Error;
2369 -- We do not check that Parameter is in Stub_Type since such a check
2370 -- has been inserted at the point of call already (a tag check since
2371 -- we have multiple controlling operands).
2374 Make_Raise_Constraint_Error (Loc,
2378 Make_Function_Call (Loc,
2380 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2381 Parameter_Associations =>
2383 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2384 New_Occurrence_Of (Parameter_Entity, Loc)),
2385 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2386 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2387 Reason => CE_Partition_Check_Failed));
2388 end Insert_Partition_Check;
2390 -- Start of processing for Build_Subprogram_Calling_Stubs
2393 Subp_Spec := Copy_Specification (Loc,
2394 Spec => Specification (Vis_Decl),
2395 New_Name => New_Name);
2397 if Locator = Empty then
2398 RCI_Locator := RCI_Cache;
2399 Spec_To_Use := Specification (Vis_Decl);
2401 RCI_Locator := Locator;
2402 Spec_To_Use := Subp_Spec;
2405 -- Find a controlling argument if we have a stub type. Also check
2406 -- if this subprogram can be made asynchronous.
2408 if Present (Stub_Type)
2409 and then Present (Parameter_Specifications (Spec_To_Use))
2412 Current_Parameter : Node_Id :=
2413 First (Parameter_Specifications
2416 while Present (Current_Parameter) loop
2418 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2420 if Controlling_Parameter = Empty then
2421 Controlling_Parameter :=
2422 Defining_Identifier (Current_Parameter);
2424 Insert_Partition_Check (Current_Parameter);
2428 Next (Current_Parameter);
2433 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2435 if Dynamically_Asynchronous then
2436 Asynchronous_Expr := Make_Selected_Component (Loc,
2437 Prefix => Controlling_Parameter,
2438 Selector_Name => Name_Asynchronous);
2441 Specific_Build_General_Calling_Stubs
2443 Statements => Statements,
2444 Target => Specific_Build_Stub_Target (Loc,
2445 Decls, RCI_Locator, Controlling_Parameter),
2446 Subprogram_Id => Subp_Id,
2447 Asynchronous => Asynchronous_Expr,
2448 Is_Known_Asynchronous => Asynchronous
2449 and then not Dynamically_Asynchronous,
2450 Is_Known_Non_Asynchronous
2452 and then not Dynamically_Asynchronous,
2453 Is_Function => Nkind (Spec_To_Use) =
2454 N_Function_Specification,
2455 Spec => Spec_To_Use,
2456 Stub_Type => Stub_Type,
2457 RACW_Type => RACW_Type,
2460 RCI_Calling_Stubs_Table.Set
2461 (Defining_Unit_Name (Specification (Vis_Decl)),
2462 Defining_Unit_Name (Spec_To_Use));
2465 Make_Subprogram_Body (Loc,
2466 Specification => Subp_Spec,
2467 Declarations => Decls,
2468 Handled_Statement_Sequence =>
2469 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2470 end Build_Subprogram_Calling_Stubs;
2472 -------------------------
2473 -- Build_Subprogram_Id --
2474 -------------------------
2476 function Build_Subprogram_Id
2478 E : Entity_Id) return Node_Id
2481 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2483 Current_Declaration : Node_Id;
2484 Current_Subp : Entity_Id;
2485 Current_Subp_Str : String_Id;
2486 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2488 pragma Warnings (Off, Current_Subp_Str);
2491 -- Build_Subprogram_Id is called outside of the context of
2492 -- generating calling or receiving stubs. Hence we are processing
2493 -- an 'Access attribute_reference for an RCI subprogram, for the
2494 -- purpose of obtaining a RAS value.
2497 (Is_Remote_Call_Interface (Scope (E))
2499 (Nkind (Parent (E)) = N_Procedure_Specification
2501 Nkind (Parent (E)) = N_Function_Specification));
2503 Current_Declaration :=
2504 First (Visible_Declarations
2505 (Package_Specification_Of_Scope (Scope (E))));
2506 while Present (Current_Declaration) loop
2507 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2508 and then Comes_From_Source (Current_Declaration)
2510 Current_Subp := Defining_Unit_Name (Specification (
2511 Current_Declaration));
2513 Assign_Subprogram_Identifier
2514 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2516 Current_Subp_Number := Current_Subp_Number + 1;
2519 Next (Current_Declaration);
2524 case Get_PCS_Name is
2525 when Name_PolyORB_DSA =>
2526 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2528 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2530 end Build_Subprogram_Id;
2532 ------------------------
2533 -- Copy_Specification --
2534 ------------------------
2536 function Copy_Specification
2539 Ctrl_Type : Entity_Id := Empty;
2540 New_Name : Name_Id := No_Name) return Node_Id
2542 Parameters : List_Id := No_List;
2544 Current_Parameter : Node_Id;
2545 Current_Identifier : Entity_Id;
2546 Current_Type : Node_Id;
2548 Name_For_New_Spec : Name_Id;
2550 New_Identifier : Entity_Id;
2552 -- Comments needed in body below ???
2555 if New_Name = No_Name then
2556 pragma Assert (Nkind (Spec) = N_Function_Specification
2557 or else Nkind (Spec) = N_Procedure_Specification);
2559 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2561 Name_For_New_Spec := New_Name;
2564 if Present (Parameter_Specifications (Spec)) then
2565 Parameters := New_List;
2566 Current_Parameter := First (Parameter_Specifications (Spec));
2567 while Present (Current_Parameter) loop
2568 Current_Identifier := Defining_Identifier (Current_Parameter);
2569 Current_Type := Parameter_Type (Current_Parameter);
2571 if Nkind (Current_Type) = N_Access_Definition then
2572 if Present (Ctrl_Type) then
2573 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2575 Make_Access_Definition (Loc,
2576 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2577 Null_Exclusion_Present =>
2578 Null_Exclusion_Present (Current_Type));
2582 Make_Access_Definition (Loc,
2584 New_Copy_Tree (Subtype_Mark (Current_Type)),
2585 Null_Exclusion_Present =>
2586 Null_Exclusion_Present (Current_Type));
2590 if Present (Ctrl_Type)
2591 and then Is_Controlling_Formal (Current_Identifier)
2593 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2595 Current_Type := New_Copy_Tree (Current_Type);
2599 New_Identifier := Make_Defining_Identifier (Loc,
2600 Chars (Current_Identifier));
2602 Append_To (Parameters,
2603 Make_Parameter_Specification (Loc,
2604 Defining_Identifier => New_Identifier,
2605 Parameter_Type => Current_Type,
2606 In_Present => In_Present (Current_Parameter),
2607 Out_Present => Out_Present (Current_Parameter),
2609 New_Copy_Tree (Expression (Current_Parameter))));
2611 -- For a regular formal parameter (that needs to be marshalled
2612 -- in the context of remote calls), set the Etype now, because
2613 -- marshalling processing might need it.
2615 if Is_Entity_Name (Current_Type) then
2616 Set_Etype (New_Identifier, Entity (Current_Type));
2618 -- Current_Type is an access definition, special processing
2619 -- (not requiring etype) will occur for marshalling.
2625 Next (Current_Parameter);
2629 case Nkind (Spec) is
2631 when N_Function_Specification | N_Access_Function_Definition =>
2633 Make_Function_Specification (Loc,
2634 Defining_Unit_Name =>
2635 Make_Defining_Identifier (Loc,
2636 Chars => Name_For_New_Spec),
2637 Parameter_Specifications => Parameters,
2638 Result_Definition =>
2639 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2641 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2643 Make_Procedure_Specification (Loc,
2644 Defining_Unit_Name =>
2645 Make_Defining_Identifier (Loc,
2646 Chars => Name_For_New_Spec),
2647 Parameter_Specifications => Parameters);
2650 raise Program_Error;
2652 end Copy_Specification;
2654 -----------------------------
2655 -- Corresponding_Stub_Type --
2656 -----------------------------
2658 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2659 Desig : constant Entity_Id :=
2660 Etype (Designated_Type (RACW_Type));
2661 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2663 return Stub_Elements.Stub_Type;
2664 end Corresponding_Stub_Type;
2666 ---------------------------
2667 -- Could_Be_Asynchronous --
2668 ---------------------------
2670 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2671 Current_Parameter : Node_Id;
2674 if Present (Parameter_Specifications (Spec)) then
2675 Current_Parameter := First (Parameter_Specifications (Spec));
2676 while Present (Current_Parameter) loop
2677 if Out_Present (Current_Parameter) then
2681 Next (Current_Parameter);
2686 end Could_Be_Asynchronous;
2688 ---------------------------
2689 -- Declare_Create_NVList --
2690 ---------------------------
2692 procedure Declare_Create_NVList
2700 Make_Object_Declaration (Loc,
2701 Defining_Identifier => NVList,
2702 Aliased_Present => False,
2703 Object_Definition =>
2704 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2707 Make_Procedure_Call_Statement (Loc,
2708 Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2709 Parameter_Associations => New_List (
2710 New_Occurrence_Of (NVList, Loc))));
2711 end Declare_Create_NVList;
2713 ---------------------------------------------
2714 -- Expand_All_Calls_Remote_Subprogram_Call --
2715 ---------------------------------------------
2717 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2718 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2719 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2720 Loc : constant Source_Ptr := Sloc (N);
2721 RCI_Locator : Node_Id;
2722 RCI_Cache : Entity_Id;
2723 Calling_Stubs : Node_Id;
2724 E_Calling_Stubs : Entity_Id;
2727 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2729 if E_Calling_Stubs = Empty then
2730 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2732 if RCI_Cache = Empty then
2735 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2736 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2738 -- The RCI_Locator package is inserted at the top level in the
2739 -- current unit, and must appear in the proper scope, so that it
2740 -- is not prematurely removed by the GCC back-end.
2743 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2746 if Ekind (Scop) = E_Package_Body then
2747 Push_Scope (Spec_Entity (Scop));
2749 elsif Ekind (Scop) = E_Subprogram_Body then
2751 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2757 Analyze (RCI_Locator);
2761 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2764 RCI_Locator := Parent (RCI_Cache);
2767 Calling_Stubs := Build_Subprogram_Calling_Stubs
2768 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2770 Build_Subprogram_Id (Loc, Called_Subprogram),
2771 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2773 Is_Asynchronous (Called_Subprogram),
2774 Locator => RCI_Cache,
2775 New_Name => New_Internal_Name ('S'));
2776 Insert_After (RCI_Locator, Calling_Stubs);
2777 Analyze (Calling_Stubs);
2778 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2781 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2782 end Expand_All_Calls_Remote_Subprogram_Call;
2784 ---------------------------------
2785 -- Expand_Calling_Stubs_Bodies --
2786 ---------------------------------
2788 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2789 Spec : constant Node_Id := Specification (Unit_Node);
2790 Decls : constant List_Id := Visible_Declarations (Spec);
2792 Push_Scope (Scope_Of_Spec (Spec));
2793 Add_Calling_Stubs_To_Declarations
2794 (Specification (Unit_Node), Decls);
2796 end Expand_Calling_Stubs_Bodies;
2798 -----------------------------------
2799 -- Expand_Receiving_Stubs_Bodies --
2800 -----------------------------------
2802 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2805 Stubs_Decls : List_Id;
2806 Stubs_Stmts : List_Id;
2809 if Nkind (Unit_Node) = N_Package_Declaration then
2810 Spec := Specification (Unit_Node);
2811 Decls := Private_Declarations (Spec);
2814 Decls := Visible_Declarations (Spec);
2817 Push_Scope (Scope_Of_Spec (Spec));
2818 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2822 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2823 Decls := Declarations (Unit_Node);
2825 Push_Scope (Scope_Of_Spec (Unit_Node));
2826 Stubs_Decls := New_List;
2827 Stubs_Stmts := New_List;
2828 Specific_Add_Receiving_Stubs_To_Declarations
2829 (Spec, Stubs_Decls, Stubs_Stmts);
2831 Insert_List_Before (First (Decls), Stubs_Decls);
2834 HSS_Stmts : constant List_Id :=
2835 Statements (Handled_Statement_Sequence (Unit_Node));
2837 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2840 if No (First_HSS_Stmt) then
2841 Append_List_To (HSS_Stmts, Stubs_Stmts);
2843 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2849 end Expand_Receiving_Stubs_Bodies;
2851 --------------------
2852 -- GARLIC_Support --
2853 --------------------
2855 package body GARLIC_Support is
2857 -- Local subprograms
2859 procedure Add_RACW_Read_Attribute
2860 (RACW_Type : Entity_Id;
2861 Stub_Type : Entity_Id;
2862 Stub_Type_Access : Entity_Id;
2863 Body_Decls : List_Id);
2864 -- Add Read attribute for the RACW type. The declaration and attribute
2865 -- definition clauses are inserted right after the declaration of
2866 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2867 -- appended to it (case where the RACW declaration is in the main unit).
2869 procedure Add_RACW_Write_Attribute
2870 (RACW_Type : Entity_Id;
2871 Stub_Type : Entity_Id;
2872 Stub_Type_Access : Entity_Id;
2873 RPC_Receiver : Node_Id;
2874 Body_Decls : List_Id);
2875 -- Same as above for the Write attribute
2877 function Stream_Parameter return Node_Id;
2878 function Result return Node_Id;
2879 function Object return Node_Id renames Result;
2880 -- Functions to create occurrences of the formal parameter names of the
2881 -- 'Read and 'Write attributes.
2884 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2885 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2887 procedure Add_RAS_Access_TSS (N : Node_Id);
2888 -- Add a subprogram body for RAS Access TSS
2890 -------------------------------------
2891 -- Add_Obj_RPC_Receiver_Completion --
2892 -------------------------------------
2894 procedure Add_Obj_RPC_Receiver_Completion
2897 RPC_Receiver : Entity_Id;
2898 Stub_Elements : Stub_Structure)
2901 -- The RPC receiver body should not be the completion of the
2902 -- declaration recorded in the stub structure, because then the
2903 -- occurrences of the formal parameters within the body should refer
2904 -- to the entities from the declaration, not from the completion, to
2905 -- which we do not have easy access. Instead, the RPC receiver body
2906 -- acts as its own declaration, and the RPC receiver declaration is
2907 -- completed by a renaming-as-body.
2910 Make_Subprogram_Renaming_Declaration (Loc,
2912 Copy_Specification (Loc,
2913 Specification (Stub_Elements.RPC_Receiver_Decl)),
2914 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2915 end Add_Obj_RPC_Receiver_Completion;
2917 -----------------------
2918 -- Add_RACW_Features --
2919 -----------------------
2921 procedure Add_RACW_Features
2922 (RACW_Type : Entity_Id;
2923 Stub_Type : Entity_Id;
2924 Stub_Type_Access : Entity_Id;
2925 RPC_Receiver_Decl : Node_Id;
2926 Body_Decls : List_Id)
2928 RPC_Receiver : Node_Id;
2929 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2932 Loc := Sloc (RACW_Type);
2936 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2937 -- of the corresponding distributed object type. We retrieve its
2938 -- address from the local proxy object.
2940 RPC_Receiver := Make_Selected_Component (Loc,
2942 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2943 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2946 RPC_Receiver := Make_Attribute_Reference (Loc,
2947 Prefix => New_Occurrence_Of (
2948 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2949 Attribute_Name => Name_Address);
2952 Add_RACW_Write_Attribute
2959 Add_RACW_Read_Attribute
2964 end Add_RACW_Features;
2966 -----------------------------
2967 -- Add_RACW_Read_Attribute --
2968 -----------------------------
2970 procedure Add_RACW_Read_Attribute
2971 (RACW_Type : Entity_Id;
2972 Stub_Type : Entity_Id;
2973 Stub_Type_Access : Entity_Id;
2974 Body_Decls : List_Id)
2976 Proc_Decl : Node_Id;
2977 Attr_Decl : Node_Id;
2979 Body_Node : Node_Id;
2981 Statements : constant List_Id := New_List;
2983 Local_Statements : List_Id;
2984 Remote_Statements : List_Id;
2985 -- Various parts of the procedure
2987 Pnam : constant Entity_Id :=
2988 Make_Defining_Identifier
2989 (Loc, New_Internal_Name ('R'));
2990 Asynchronous_Flag : constant Entity_Id :=
2991 Asynchronous_Flags_Table.Get (RACW_Type);
2992 pragma Assert (Present (Asynchronous_Flag));
2994 -- Prepare local identifiers
2996 Source_Partition : Entity_Id;
2997 Source_Receiver : Entity_Id;
2998 Source_Address : Entity_Id;
2999 Local_Stub : Entity_Id;
3000 Stubbed_Result : Entity_Id;
3002 -- Start of processing for Add_RACW_Read_Attribute
3005 Build_Stream_Procedure (Loc,
3006 RACW_Type, Body_Node, Pnam, Statements, Outp => True);
3007 Proc_Decl := Make_Subprogram_Declaration (Loc,
3008 Copy_Specification (Loc, Specification (Body_Node)));
3011 Make_Attribute_Definition_Clause (Loc,
3012 Name => New_Occurrence_Of (RACW_Type, Loc),
3016 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3018 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3019 Insert_After (Proc_Decl, Attr_Decl);
3021 if No (Body_Decls) then
3023 -- Case of processing an RACW type from another unit than the
3024 -- main one: do not generate a body.
3029 -- Prepare local identifiers
3032 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3034 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3036 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3038 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
3040 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3042 -- Generate object declarations
3045 Make_Object_Declaration (Loc,
3046 Defining_Identifier => Source_Partition,
3047 Object_Definition =>
3048 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
3050 Make_Object_Declaration (Loc,
3051 Defining_Identifier => Source_Receiver,
3052 Object_Definition =>
3053 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3055 Make_Object_Declaration (Loc,
3056 Defining_Identifier => Source_Address,
3057 Object_Definition =>
3058 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3060 Make_Object_Declaration (Loc,
3061 Defining_Identifier => Local_Stub,
3062 Aliased_Present => True,
3063 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
3065 Make_Object_Declaration (Loc,
3066 Defining_Identifier => Stubbed_Result,
3067 Object_Definition =>
3068 New_Occurrence_Of (Stub_Type_Access, Loc),
3070 Make_Attribute_Reference (Loc,
3072 New_Occurrence_Of (Local_Stub, Loc),
3074 Name_Unchecked_Access)));
3076 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3078 Append_List_To (Statements, New_List (
3079 Make_Attribute_Reference (Loc,
3081 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3082 Attribute_Name => Name_Read,
3083 Expressions => New_List (
3085 New_Occurrence_Of (Source_Partition, Loc))),
3087 Make_Attribute_Reference (Loc,
3089 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3092 Expressions => New_List (
3094 New_Occurrence_Of (Source_Receiver, Loc))),
3096 Make_Attribute_Reference (Loc,
3098 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3101 Expressions => New_List (
3103 New_Occurrence_Of (Source_Address, Loc)))));
3105 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3107 Set_Etype (Stubbed_Result, Stub_Type_Access);
3109 -- If the Address is Null_Address, then return a null object, unless
3110 -- RACW_Type is null-excluding, in which case unconditionally raise
3111 -- CONSTRAINT_ERROR instead.
3114 Zero_Statements : List_Id;
3115 -- Statements executed when a zero value is received
3118 if Can_Never_Be_Null (RACW_Type) then
3119 Zero_Statements := New_List (
3120 Make_Raise_Constraint_Error (Loc,
3121 Reason => CE_Null_Not_Allowed));
3123 Zero_Statements := New_List (
3124 Make_Assignment_Statement (Loc,
3126 Expression => Make_Null (Loc)),
3127 Make_Simple_Return_Statement (Loc));
3130 Append_To (Statements,
3131 Make_Implicit_If_Statement (RACW_Type,
3134 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3135 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3136 Then_Statements => Zero_Statements));
3139 -- If the RACW denotes an object created on the current partition,
3140 -- Local_Statements will be executed. The real object will be used.
3142 Local_Statements := New_List (
3143 Make_Assignment_Statement (Loc,
3146 Unchecked_Convert_To (RACW_Type,
3147 OK_Convert_To (RTE (RE_Address),
3148 New_Occurrence_Of (Source_Address, Loc)))));
3150 -- If the object is located on another partition, then a stub object
3151 -- will be created with all the information needed to rebuild the
3152 -- real object at the other end.
3154 Remote_Statements := New_List (
3156 Make_Assignment_Statement (Loc,
3157 Name => Make_Selected_Component (Loc,
3158 Prefix => Stubbed_Result,
3159 Selector_Name => Name_Origin),
3161 New_Occurrence_Of (Source_Partition, Loc)),
3163 Make_Assignment_Statement (Loc,
3164 Name => Make_Selected_Component (Loc,
3165 Prefix => Stubbed_Result,
3166 Selector_Name => Name_Receiver),
3168 New_Occurrence_Of (Source_Receiver, Loc)),
3170 Make_Assignment_Statement (Loc,
3171 Name => Make_Selected_Component (Loc,
3172 Prefix => Stubbed_Result,
3173 Selector_Name => Name_Addr),
3175 New_Occurrence_Of (Source_Address, Loc)));
3177 Append_To (Remote_Statements,
3178 Make_Assignment_Statement (Loc,
3179 Name => Make_Selected_Component (Loc,
3180 Prefix => Stubbed_Result,
3181 Selector_Name => Name_Asynchronous),
3183 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3185 Append_List_To (Remote_Statements,
3186 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3187 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3188 -- set on the stub type if, and only if, the RACW type has a pragma
3189 -- Asynchronous. This is incorrect for RACWs that implement RAS
3190 -- types, because in that case the /designated subprogram/ (not the
3191 -- type) might be asynchronous, and that causes the stub to need to
3192 -- be asynchronous too. A solution is to transport a RAS as a struct
3193 -- containing a RACW and an asynchronous flag, and to properly alter
3194 -- the Asynchronous component in the stub type in the RAS's Input
3197 Append_To (Remote_Statements,
3198 Make_Assignment_Statement (Loc,
3200 Expression => Unchecked_Convert_To (RACW_Type,
3201 New_Occurrence_Of (Stubbed_Result, Loc))));
3203 -- Distinguish between the local and remote cases, and execute the
3204 -- appropriate piece of code.
3206 Append_To (Statements,
3207 Make_Implicit_If_Statement (RACW_Type,
3211 Make_Function_Call (Loc,
3212 Name => New_Occurrence_Of (
3213 RTE (RE_Get_Local_Partition_Id), Loc)),
3214 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3215 Then_Statements => Local_Statements,
3216 Else_Statements => Remote_Statements));
3218 Set_Declarations (Body_Node, Decls);
3219 Append_To (Body_Decls, Body_Node);
3220 end Add_RACW_Read_Attribute;
3222 ------------------------------
3223 -- Add_RACW_Write_Attribute --
3224 ------------------------------
3226 procedure Add_RACW_Write_Attribute
3227 (RACW_Type : Entity_Id;
3228 Stub_Type : Entity_Id;
3229 Stub_Type_Access : Entity_Id;
3230 RPC_Receiver : Node_Id;
3231 Body_Decls : List_Id)
3233 Body_Node : Node_Id;
3234 Proc_Decl : Node_Id;
3235 Attr_Decl : Node_Id;
3237 Statements : constant List_Id := New_List;
3238 Local_Statements : List_Id;
3239 Remote_Statements : List_Id;
3240 Null_Statements : List_Id;
3242 Pnam : constant Entity_Id :=
3243 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3246 Build_Stream_Procedure
3247 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
3249 Proc_Decl := Make_Subprogram_Declaration (Loc,
3250 Copy_Specification (Loc, Specification (Body_Node)));
3253 Make_Attribute_Definition_Clause (Loc,
3254 Name => New_Occurrence_Of (RACW_Type, Loc),
3255 Chars => Name_Write,
3258 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3260 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3261 Insert_After (Proc_Decl, Attr_Decl);
3263 if No (Body_Decls) then
3267 -- Build the code fragment corresponding to the marshalling of a
3270 Local_Statements := New_List (
3272 Pack_Entity_Into_Stream_Access (Loc,
3273 Stream => Stream_Parameter,
3274 Object => RTE (RE_Get_Local_Partition_Id)),
3276 Pack_Node_Into_Stream_Access (Loc,
3277 Stream => Stream_Parameter,
3278 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3279 Etyp => RTE (RE_Unsigned_64)),
3281 Pack_Node_Into_Stream_Access (Loc,
3282 Stream => Stream_Parameter,
3283 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3284 Make_Attribute_Reference (Loc,
3286 Make_Explicit_Dereference (Loc,
3288 Attribute_Name => Name_Address)),
3289 Etyp => RTE (RE_Unsigned_64)));
3291 -- Build the code fragment corresponding to the marshalling of
3294 Remote_Statements := New_List (
3295 Pack_Node_Into_Stream_Access (Loc,
3296 Stream => Stream_Parameter,
3298 Make_Selected_Component (Loc,
3300 Unchecked_Convert_To (Stub_Type_Access, Object),
3301 Selector_Name => Make_Identifier (Loc, Name_Origin)),
3302 Etyp => RTE (RE_Partition_ID)),
3304 Pack_Node_Into_Stream_Access (Loc,
3305 Stream => Stream_Parameter,
3307 Make_Selected_Component (Loc,
3309 Unchecked_Convert_To (Stub_Type_Access, Object),
3310 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
3311 Etyp => RTE (RE_Unsigned_64)),
3313 Pack_Node_Into_Stream_Access (Loc,
3314 Stream => Stream_Parameter,
3316 Make_Selected_Component (Loc,
3318 Unchecked_Convert_To (Stub_Type_Access, Object),
3319 Selector_Name => Make_Identifier (Loc, Name_Addr)),
3320 Etyp => RTE (RE_Unsigned_64)));
3322 -- Build code fragment corresponding to marshalling of a null object
3324 Null_Statements := New_List (
3326 Pack_Entity_Into_Stream_Access (Loc,
3327 Stream => Stream_Parameter,
3328 Object => RTE (RE_Get_Local_Partition_Id)),
3330 Pack_Node_Into_Stream_Access (Loc,
3331 Stream => Stream_Parameter,
3332 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3333 Etyp => RTE (RE_Unsigned_64)),
3335 Pack_Node_Into_Stream_Access (Loc,
3336 Stream => Stream_Parameter,
3337 Object => Make_Integer_Literal (Loc, Uint_0),
3338 Etyp => RTE (RE_Unsigned_64)));
3340 Append_To (Statements,
3341 Make_Implicit_If_Statement (RACW_Type,
3344 Left_Opnd => Object,
3345 Right_Opnd => Make_Null (Loc)),
3347 Then_Statements => Null_Statements,
3349 Elsif_Parts => New_List (
3350 Make_Elsif_Part (Loc,
3354 Make_Attribute_Reference (Loc,
3356 Attribute_Name => Name_Tag),
3359 Make_Attribute_Reference (Loc,
3360 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3361 Attribute_Name => Name_Tag)),
3362 Then_Statements => Remote_Statements)),
3363 Else_Statements => Local_Statements));
3365 Append_To (Body_Decls, Body_Node);
3366 end Add_RACW_Write_Attribute;
3368 ------------------------
3369 -- Add_RAS_Access_TSS --
3370 ------------------------
3372 procedure Add_RAS_Access_TSS (N : Node_Id) is
3373 Loc : constant Source_Ptr := Sloc (N);
3375 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3376 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3377 -- Ras_Type is the access to subprogram type while Fat_Type is the
3378 -- corresponding record type.
3380 RACW_Type : constant Entity_Id :=
3381 Underlying_RACW_Type (Ras_Type);
3382 Desig : constant Entity_Id :=
3383 Etype (Designated_Type (RACW_Type));
3385 Stub_Elements : constant Stub_Structure :=
3386 Stubs_Table.Get (Desig);
3387 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3389 Proc : constant Entity_Id :=
3390 Make_Defining_Identifier (Loc,
3391 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3393 Proc_Spec : Node_Id;
3395 -- Formal parameters
3397 Package_Name : constant Entity_Id :=
3398 Make_Defining_Identifier (Loc,
3402 Subp_Id : constant Entity_Id :=
3403 Make_Defining_Identifier (Loc,
3405 -- Target subprogram
3407 Asynch_P : constant Entity_Id :=
3408 Make_Defining_Identifier (Loc,
3409 Chars => Name_Asynchronous);
3410 -- Is the procedure to which the 'Access applies asynchronous?
3412 All_Calls_Remote : constant Entity_Id :=
3413 Make_Defining_Identifier (Loc,
3414 Chars => Name_All_Calls_Remote);
3415 -- True if an All_Calls_Remote pragma applies to the RCI unit
3416 -- that contains the subprogram.
3418 -- Common local variables
3420 Proc_Decls : List_Id;
3421 Proc_Statements : List_Id;
3423 Origin : constant Entity_Id :=
3424 Make_Defining_Identifier (Loc,
3425 Chars => New_Internal_Name ('P'));
3427 -- Additional local variables for the local case
3429 Proxy_Addr : constant Entity_Id :=
3430 Make_Defining_Identifier (Loc,
3431 Chars => New_Internal_Name ('P'));
3433 -- Additional local variables for the remote case
3435 Local_Stub : constant Entity_Id :=
3436 Make_Defining_Identifier (Loc,
3437 Chars => New_Internal_Name ('L'));
3439 Stub_Ptr : constant Entity_Id :=
3440 Make_Defining_Identifier (Loc,
3441 Chars => New_Internal_Name ('S'));
3444 (Field_Name : Name_Id;
3445 Value : Node_Id) return Node_Id;
3446 -- Construct an assignment that sets the named component in the
3454 (Field_Name : Name_Id;
3455 Value : Node_Id) return Node_Id
3459 Make_Assignment_Statement (Loc,
3461 Make_Selected_Component (Loc,
3463 Selector_Name => Field_Name),
3464 Expression => Value);
3467 -- Start of processing for Add_RAS_Access_TSS
3470 Proc_Decls := New_List (
3472 -- Common declarations
3474 Make_Object_Declaration (Loc,
3475 Defining_Identifier => Origin,
3476 Constant_Present => True,
3477 Object_Definition =>
3478 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3480 Make_Function_Call (Loc,
3482 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3483 Parameter_Associations => New_List (
3484 New_Occurrence_Of (Package_Name, Loc)))),
3486 -- Declaration use only in the local case: proxy address
3488 Make_Object_Declaration (Loc,
3489 Defining_Identifier => Proxy_Addr,
3490 Object_Definition =>
3491 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3493 -- Declarations used only in the remote case: stub object and
3496 Make_Object_Declaration (Loc,
3497 Defining_Identifier => Local_Stub,
3498 Aliased_Present => True,
3499 Object_Definition =>
3500 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3502 Make_Object_Declaration (Loc,
3503 Defining_Identifier =>
3505 Object_Definition =>
3506 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3508 Make_Attribute_Reference (Loc,
3509 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3510 Attribute_Name => Name_Unchecked_Access)));
3512 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3514 -- Build_Get_Unique_RP_Call needs above information
3516 -- Note: Here we assume that the Fat_Type is a record
3517 -- containing just a pointer to a proxy or stub object.
3519 Proc_Statements := New_List (
3523 -- Get_RAS_Info (Pkg, Subp, PA);
3524 -- if Origin = Local_Partition_Id
3525 -- and then not All_Calls_Remote
3527 -- return Fat_Type!(PA);
3530 Make_Procedure_Call_Statement (Loc,
3531 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3532 Parameter_Associations => New_List (
3533 New_Occurrence_Of (Package_Name, Loc),
3534 New_Occurrence_Of (Subp_Id, Loc),
3535 New_Occurrence_Of (Proxy_Addr, Loc))),
3537 Make_Implicit_If_Statement (N,
3543 New_Occurrence_Of (Origin, Loc),
3545 Make_Function_Call (Loc,
3547 RTE (RE_Get_Local_Partition_Id), Loc))),
3551 New_Occurrence_Of (All_Calls_Remote, Loc))),
3553 Then_Statements => New_List (
3554 Make_Simple_Return_Statement (Loc,
3555 Unchecked_Convert_To (Fat_Type,
3556 OK_Convert_To (RTE (RE_Address),
3557 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3559 Set_Field (Name_Origin,
3560 New_Occurrence_Of (Origin, Loc)),
3562 Set_Field (Name_Receiver,
3563 Make_Function_Call (Loc,
3565 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3566 Parameter_Associations => New_List (
3567 New_Occurrence_Of (Package_Name, Loc)))),
3569 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3571 -- E.4.1(9) A remote call is asynchronous if it is a call to
3572 -- a procedure or a call through a value of an access-to-procedure
3573 -- type to which a pragma Asynchronous applies.
3575 -- Asynch_P is true when the procedure is asynchronous;
3576 -- Asynch_T is true when the type is asynchronous.
3578 Set_Field (Name_Asynchronous,
3580 New_Occurrence_Of (Asynch_P, Loc),
3581 New_Occurrence_Of (Boolean_Literals (
3582 Is_Asynchronous (Ras_Type)), Loc))));
3584 Append_List_To (Proc_Statements,
3585 Build_Get_Unique_RP_Call
3586 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3588 -- Return the newly created value
3590 Append_To (Proc_Statements,
3591 Make_Simple_Return_Statement (Loc,
3593 Unchecked_Convert_To (Fat_Type,
3594 New_Occurrence_Of (Stub_Ptr, Loc))));
3597 Make_Function_Specification (Loc,
3598 Defining_Unit_Name => Proc,
3599 Parameter_Specifications => New_List (
3600 Make_Parameter_Specification (Loc,
3601 Defining_Identifier => Package_Name,
3603 New_Occurrence_Of (Standard_String, Loc)),
3605 Make_Parameter_Specification (Loc,
3606 Defining_Identifier => Subp_Id,
3608 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3610 Make_Parameter_Specification (Loc,
3611 Defining_Identifier => Asynch_P,
3613 New_Occurrence_Of (Standard_Boolean, Loc)),
3615 Make_Parameter_Specification (Loc,
3616 Defining_Identifier => All_Calls_Remote,
3618 New_Occurrence_Of (Standard_Boolean, Loc))),
3620 Result_Definition =>
3621 New_Occurrence_Of (Fat_Type, Loc));
3623 -- Set the kind and return type of the function to prevent
3624 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3626 Set_Ekind (Proc, E_Function);
3627 Set_Etype (Proc, Fat_Type);
3630 Make_Subprogram_Body (Loc,
3631 Specification => Proc_Spec,
3632 Declarations => Proc_Decls,
3633 Handled_Statement_Sequence =>
3634 Make_Handled_Sequence_Of_Statements (Loc,
3635 Statements => Proc_Statements)));
3637 Set_TSS (Fat_Type, Proc);
3638 end Add_RAS_Access_TSS;
3640 -----------------------
3641 -- Add_RAST_Features --
3642 -----------------------
3644 procedure Add_RAST_Features
3645 (Vis_Decl : Node_Id;
3646 RAS_Type : Entity_Id)
3648 pragma Warnings (Off);
3649 pragma Unreferenced (RAS_Type);
3650 pragma Warnings (On);
3652 Add_RAS_Access_TSS (Vis_Decl);
3653 end Add_RAST_Features;
3655 -----------------------------------------
3656 -- Add_Receiving_Stubs_To_Declarations --
3657 -----------------------------------------
3659 procedure Add_Receiving_Stubs_To_Declarations
3660 (Pkg_Spec : Node_Id;
3664 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3666 Request_Parameter : Node_Id;
3668 Pkg_RPC_Receiver : constant Entity_Id :=
3669 Make_Defining_Identifier (Loc,
3670 New_Internal_Name ('H'));
3671 Pkg_RPC_Receiver_Statements : List_Id;
3672 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3673 Pkg_RPC_Receiver_Body : Node_Id;
3674 -- A Pkg_RPC_Receiver is built to decode the request
3676 Lookup_RAS_Info : constant Entity_Id :=
3677 Make_Defining_Identifier (Loc,
3678 Chars => New_Internal_Name ('R'));
3679 -- A remote subprogram is created to allow peers to look up
3680 -- RAS information using subprogram ids.
3682 Subp_Id : Entity_Id;
3683 Subp_Index : Entity_Id;
3684 -- Subprogram_Id as read from the incoming stream
3686 Current_Declaration : Node_Id;
3687 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3688 Current_Stubs : Node_Id;
3690 Subp_Info_Array : constant Entity_Id :=
3691 Make_Defining_Identifier (Loc,
3692 Chars => New_Internal_Name ('I'));
3694 Subp_Info_List : constant List_Id := New_List;
3696 Register_Pkg_Actuals : constant List_Id := New_List;
3698 All_Calls_Remote_E : Entity_Id;
3699 Proxy_Object_Addr : Entity_Id;
3701 procedure Append_Stubs_To
3702 (RPC_Receiver_Cases : List_Id;
3704 Subprogram_Number : Int);
3705 -- Add one case to the specified RPC receiver case list
3706 -- associating Subprogram_Number with the subprogram declared
3707 -- by Declaration, for which we have receiving stubs in Stubs.
3709 ---------------------
3710 -- Append_Stubs_To --
3711 ---------------------
3713 procedure Append_Stubs_To
3714 (RPC_Receiver_Cases : List_Id;
3716 Subprogram_Number : Int)
3719 Append_To (RPC_Receiver_Cases,
3720 Make_Case_Statement_Alternative (Loc,
3722 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3725 Make_Procedure_Call_Statement (Loc,
3727 New_Occurrence_Of (Defining_Entity (Stubs), Loc),
3728 Parameter_Associations => New_List (
3729 New_Occurrence_Of (Request_Parameter, Loc))))));
3730 end Append_Stubs_To;
3732 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3735 -- Building receiving stubs consist in several operations:
3737 -- - a package RPC receiver must be built. This subprogram
3738 -- will get a Subprogram_Id from the incoming stream
3739 -- and will dispatch the call to the right subprogram;
3741 -- - a receiving stub for each subprogram visible in the package
3742 -- spec. This stub will read all the parameters from the stream,
3743 -- and put the result as well as the exception occurrence in the
3746 -- - a dummy package with an empty spec and a body made of an
3747 -- elaboration part, whose job is to register the receiving
3748 -- part of this RCI package on the name server. This is done
3749 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3751 Build_RPC_Receiver_Body (
3752 RPC_Receiver => Pkg_RPC_Receiver,
3753 Request => Request_Parameter,
3755 Subp_Index => Subp_Index,
3756 Stmts => Pkg_RPC_Receiver_Statements,
3757 Decl => Pkg_RPC_Receiver_Body);
3758 pragma Assert (Subp_Id = Subp_Index);
3760 -- A null subp_id denotes a call through a RAS, in which case the
3761 -- next Uint_64 element in the stream is the address of the local
3762 -- proxy object, from which we can retrieve the actual subprogram id.
3764 Append_To (Pkg_RPC_Receiver_Statements,
3765 Make_Implicit_If_Statement (Pkg_Spec,
3768 New_Occurrence_Of (Subp_Id, Loc),
3769 Make_Integer_Literal (Loc, 0)),
3771 Then_Statements => New_List (
3772 Make_Assignment_Statement (Loc,
3774 New_Occurrence_Of (Subp_Id, Loc),
3777 Make_Selected_Component (Loc,
3779 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3780 OK_Convert_To (RTE (RE_Address),
3781 Make_Attribute_Reference (Loc,
3783 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3786 Expressions => New_List (
3787 Make_Selected_Component (Loc,
3788 Prefix => Request_Parameter,
3789 Selector_Name => Name_Params))))),
3792 Make_Identifier (Loc, Name_Subp_Id))))));
3794 -- Build a subprogram for RAS information lookups
3796 Current_Declaration :=
3797 Make_Subprogram_Declaration (Loc,
3799 Make_Function_Specification (Loc,
3800 Defining_Unit_Name =>
3802 Parameter_Specifications => New_List (
3803 Make_Parameter_Specification (Loc,
3804 Defining_Identifier =>
3805 Make_Defining_Identifier (Loc, Name_Subp_Id),
3809 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3810 Result_Definition =>
3811 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3813 Append_To (Decls, Current_Declaration);
3814 Analyze (Current_Declaration);
3816 Current_Stubs := Build_Subprogram_Receiving_Stubs
3817 (Vis_Decl => Current_Declaration,
3818 Asynchronous => False);
3819 Append_To (Decls, Current_Stubs);
3820 Analyze (Current_Stubs);
3822 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3825 Subprogram_Number => 1);
3827 -- For each subprogram, the receiving stub will be built and a
3828 -- case statement will be made on the Subprogram_Id to dispatch
3829 -- to the right subprogram.
3831 All_Calls_Remote_E :=
3833 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3835 Overload_Counter_Table.Reset;
3837 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3838 while Present (Current_Declaration) loop
3839 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3840 and then Comes_From_Source (Current_Declaration)
3843 Loc : constant Source_Ptr := Sloc (Current_Declaration);
3844 -- While specifically processing Current_Declaration, use
3845 -- its Sloc as the location of all generated nodes.
3847 Subp_Def : constant Entity_Id :=
3849 (Specification (Current_Declaration));
3851 Subp_Val : String_Id;
3852 pragma Warnings (Off, Subp_Val);
3855 -- Build receiving stub
3858 Build_Subprogram_Receiving_Stubs
3859 (Vis_Decl => Current_Declaration,
3861 Nkind (Specification (Current_Declaration)) =
3862 N_Procedure_Specification
3863 and then Is_Asynchronous (Subp_Def));
3865 Append_To (Decls, Current_Stubs);
3866 Analyze (Current_Stubs);
3870 Add_RAS_Proxy_And_Analyze (Decls,
3871 Vis_Decl => Current_Declaration,
3872 All_Calls_Remote_E => All_Calls_Remote_E,
3873 Proxy_Object_Addr => Proxy_Object_Addr);
3875 -- Compute distribution identifier
3877 Assign_Subprogram_Identifier
3879 Current_Subprogram_Number,
3883 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
3885 -- Add subprogram descriptor (RCI_Subp_Info) to the
3886 -- subprograms table for this receiver. The aggregate
3887 -- below must be kept consistent with the declaration
3888 -- of type RCI_Subp_Info in System.Partition_Interface.
3890 Append_To (Subp_Info_List,
3891 Make_Component_Association (Loc,
3892 Choices => New_List (
3893 Make_Integer_Literal (Loc,
3894 Current_Subprogram_Number)),
3897 Make_Aggregate (Loc,
3898 Component_Associations => New_List (
3899 Make_Component_Association (Loc,
3900 Choices => New_List (
3901 Make_Identifier (Loc, Name_Addr)),
3904 Proxy_Object_Addr, Loc))))));
3906 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3907 Stubs => Current_Stubs,
3908 Subprogram_Number => Current_Subprogram_Number);
3911 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3914 Next (Current_Declaration);
3917 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3918 -- rather than raising an exception since we do not want someone
3919 -- to crash a remote partition by sending invalid subprogram ids.
3920 -- This is consistent with the other parts of the case statement
3921 -- since even in presence of incorrect parameters in the stream,
3922 -- every exception will be caught and (if the subprogram is not an
3923 -- APC) put into the result stream and sent away.
3925 Append_To (Pkg_RPC_Receiver_Cases,
3926 Make_Case_Statement_Alternative (Loc,
3927 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
3928 Statements => New_List (Make_Null_Statement (Loc))));
3930 Append_To (Pkg_RPC_Receiver_Statements,
3931 Make_Case_Statement (Loc,
3932 Expression => New_Occurrence_Of (Subp_Id, Loc),
3933 Alternatives => Pkg_RPC_Receiver_Cases));
3936 Make_Object_Declaration (Loc,
3937 Defining_Identifier => Subp_Info_Array,
3938 Constant_Present => True,
3939 Aliased_Present => True,
3940 Object_Definition =>
3941 Make_Subtype_Indication (Loc,
3943 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3945 Make_Index_Or_Discriminant_Constraint (Loc,
3948 Low_Bound => Make_Integer_Literal (Loc,
3949 First_RCI_Subprogram_Id),
3951 Make_Integer_Literal (Loc,
3953 First_RCI_Subprogram_Id
3954 + List_Length (Subp_Info_List) - 1)))))));
3956 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3957 -- has zero length, and the declaration is for an empty array, in
3958 -- which case no initialization aggregate must be generated.
3960 if Present (First (Subp_Info_List)) then
3961 Set_Expression (Last (Decls),
3962 Make_Aggregate (Loc,
3963 Component_Associations => Subp_Info_List));
3965 -- No initialization provided: remove CONSTANT so that the
3966 -- declaration is not an incomplete deferred constant.
3969 Set_Constant_Present (Last (Decls), False);
3972 Analyze (Last (Decls));
3975 Subp_Info_Addr : Node_Id;
3976 -- Return statement for Lookup_RAS_Info: address of the subprogram
3977 -- information record for the requested subprogram id.
3980 if Present (First (Subp_Info_List)) then
3982 Make_Selected_Component (Loc,
3984 Make_Indexed_Component (Loc,
3985 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
3986 Expressions => New_List (
3987 Convert_To (Standard_Integer,
3988 Make_Identifier (Loc, Name_Subp_Id)))),
3989 Selector_Name => Make_Identifier (Loc, Name_Addr));
3991 -- Case of no visible subprogram: just raise Constraint_Error, we
3992 -- know for sure we got junk from a remote partition.
3996 Make_Raise_Constraint_Error (Loc,
3997 Reason => CE_Range_Check_Failed);
3998 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
4002 Make_Subprogram_Body (Loc,
4004 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
4005 Declarations => No_List,
4006 Handled_Statement_Sequence =>
4007 Make_Handled_Sequence_Of_Statements (Loc,
4008 Statements => New_List (
4009 Make_Simple_Return_Statement (Loc,
4012 (RTE (RE_Unsigned_64), Subp_Info_Addr))))));
4015 Analyze (Last (Decls));
4017 Append_To (Decls, Pkg_RPC_Receiver_Body);
4018 Analyze (Last (Decls));
4020 Get_Library_Unit_Name_String (Pkg_Spec);
4024 Append_To (Register_Pkg_Actuals,
4025 Make_String_Literal (Loc,
4026 Strval => String_From_Name_Buffer));
4030 Append_To (Register_Pkg_Actuals,
4031 Make_Attribute_Reference (Loc,
4032 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
4033 Attribute_Name => Name_Unrestricted_Access));
4037 Append_To (Register_Pkg_Actuals,
4038 Make_Attribute_Reference (Loc,
4040 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
4041 Attribute_Name => Name_Version));
4045 Append_To (Register_Pkg_Actuals,
4046 Make_Attribute_Reference (Loc,
4047 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4048 Attribute_Name => Name_Address));
4052 Append_To (Register_Pkg_Actuals,
4053 Make_Attribute_Reference (Loc,
4054 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4055 Attribute_Name => Name_Length));
4057 -- Generate the call
4060 Make_Procedure_Call_Statement (Loc,
4062 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
4063 Parameter_Associations => Register_Pkg_Actuals));
4064 Analyze (Last (Stmts));
4065 end Add_Receiving_Stubs_To_Declarations;
4067 ---------------------------------
4068 -- Build_General_Calling_Stubs --
4069 ---------------------------------
4071 procedure Build_General_Calling_Stubs
4073 Statements : List_Id;
4074 Target_Partition : Entity_Id;
4075 Target_RPC_Receiver : Node_Id;
4076 Subprogram_Id : Node_Id;
4077 Asynchronous : Node_Id := Empty;
4078 Is_Known_Asynchronous : Boolean := False;
4079 Is_Known_Non_Asynchronous : Boolean := False;
4080 Is_Function : Boolean;
4082 Stub_Type : Entity_Id := Empty;
4083 RACW_Type : Entity_Id := Empty;
4086 Loc : constant Source_Ptr := Sloc (Nod);
4088 Stream_Parameter : Node_Id;
4089 -- Name of the stream used to transmit parameters to the
4092 Result_Parameter : Node_Id;
4093 -- Name of the result parameter (in non-APC cases) which get the
4094 -- result of the remote subprogram.
4096 Exception_Return_Parameter : Node_Id;
4097 -- Name of the parameter which will hold the exception sent by the
4098 -- remote subprogram.
4100 Current_Parameter : Node_Id;
4101 -- Current parameter being handled
4103 Ordered_Parameters_List : constant List_Id :=
4104 Build_Ordered_Parameters_List (Spec);
4106 Asynchronous_Statements : List_Id := No_List;
4107 Non_Asynchronous_Statements : List_Id := No_List;
4108 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4110 Extra_Formal_Statements : constant List_Id := New_List;
4111 -- List of statements for extra formal parameters. It will appear
4112 -- after the regular statements for writing out parameters.
4114 pragma Warnings (Off);
4115 pragma Unreferenced (RACW_Type);
4116 -- Used only for the PolyORB case
4117 pragma Warnings (On);
4120 -- The general form of a calling stub for a given subprogram is:
4122 -- procedure X (...) is P : constant Partition_ID :=
4123 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4124 -- System.RPC.Params_Stream_Type (0); begin
4125 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4126 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4127 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4128 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4130 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4132 -- There are some variations: Do_APC is called for an asynchronous
4133 -- procedure and the part after the call is completely ommitted as
4134 -- well as the declaration of Result. For a function call, 'Input is
4135 -- always used to read the result even if it is constrained.
4138 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4141 Make_Object_Declaration (Loc,
4142 Defining_Identifier => Stream_Parameter,
4143 Aliased_Present => True,
4144 Object_Definition =>
4145 Make_Subtype_Indication (Loc,
4147 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4149 Make_Index_Or_Discriminant_Constraint (Loc,
4151 New_List (Make_Integer_Literal (Loc, 0))))));
4153 if not Is_Known_Asynchronous then
4155 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4158 Make_Object_Declaration (Loc,
4159 Defining_Identifier => Result_Parameter,
4160 Aliased_Present => True,
4161 Object_Definition =>
4162 Make_Subtype_Indication (Loc,
4164 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4166 Make_Index_Or_Discriminant_Constraint (Loc,
4168 New_List (Make_Integer_Literal (Loc, 0))))));
4170 Exception_Return_Parameter :=
4171 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4174 Make_Object_Declaration (Loc,
4175 Defining_Identifier => Exception_Return_Parameter,
4176 Object_Definition =>
4177 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4180 Result_Parameter := Empty;
4181 Exception_Return_Parameter := Empty;
4184 -- Put first the RPC receiver corresponding to the remote package
4186 Append_To (Statements,
4187 Make_Attribute_Reference (Loc,
4189 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4190 Attribute_Name => Name_Write,
4191 Expressions => New_List (
4192 Make_Attribute_Reference (Loc,
4193 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4194 Attribute_Name => Name_Access),
4195 Target_RPC_Receiver)));
4197 -- Then put the Subprogram_Id of the subprogram we want to call in
4200 Append_To (Statements,
4201 Make_Attribute_Reference (Loc,
4202 Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4203 Attribute_Name => Name_Write,
4204 Expressions => New_List (
4205 Make_Attribute_Reference (Loc,
4206 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4207 Attribute_Name => Name_Access),
4210 Current_Parameter := First (Ordered_Parameters_List);
4211 while Present (Current_Parameter) loop
4213 Typ : constant Node_Id :=
4214 Parameter_Type (Current_Parameter);
4216 Constrained : Boolean;
4218 Extra_Parameter : Entity_Id;
4221 if Is_RACW_Controlling_Formal
4222 (Current_Parameter, Stub_Type)
4224 -- In the case of a controlling formal argument, we marshall
4225 -- its addr field rather than the local stub.
4227 Append_To (Statements,
4228 Pack_Node_Into_Stream (Loc,
4229 Stream => Stream_Parameter,
4231 Make_Selected_Component (Loc,
4233 Defining_Identifier (Current_Parameter),
4234 Selector_Name => Name_Addr),
4235 Etyp => RTE (RE_Unsigned_64)));
4240 (Defining_Identifier (Current_Parameter), Loc);
4242 -- Access type parameters are transmitted as in out
4243 -- parameters. However, a dereference is needed so that
4244 -- we marshall the designated object.
4246 if Nkind (Typ) = N_Access_Definition then
4247 Value := Make_Explicit_Dereference (Loc, Value);
4248 Etyp := Etype (Subtype_Mark (Typ));
4250 Etyp := Etype (Typ);
4253 Constrained := not Transmit_As_Unconstrained (Etyp);
4255 -- Any parameter but unconstrained out parameters are
4256 -- transmitted to the peer.
4258 if In_Present (Current_Parameter)
4259 or else not Out_Present (Current_Parameter)
4260 or else not Constrained
4262 Append_To (Statements,
4263 Make_Attribute_Reference (Loc,
4264 Prefix => New_Occurrence_Of (Etyp, Loc),
4266 Output_From_Constrained (Constrained),
4267 Expressions => New_List (
4268 Make_Attribute_Reference (Loc,
4270 New_Occurrence_Of (Stream_Parameter, Loc),
4271 Attribute_Name => Name_Access),
4276 -- If the current parameter has a dynamic constrained status,
4277 -- then this status is transmitted as well.
4278 -- This should be done for accessibility as well ???
4280 if Nkind (Typ) /= N_Access_Definition
4281 and then Need_Extra_Constrained (Current_Parameter)
4283 -- In this block, we do not use the extra formal that has
4284 -- been created because it does not exist at the time of
4285 -- expansion when building calling stubs for remote access
4286 -- to subprogram types. We create an extra variable of this
4287 -- type and push it in the stream after the regular
4290 Extra_Parameter := Make_Defining_Identifier
4291 (Loc, New_Internal_Name ('P'));
4294 Make_Object_Declaration (Loc,
4295 Defining_Identifier => Extra_Parameter,
4296 Constant_Present => True,
4297 Object_Definition =>
4298 New_Occurrence_Of (Standard_Boolean, Loc),
4300 Make_Attribute_Reference (Loc,
4303 Defining_Identifier (Current_Parameter), Loc),
4304 Attribute_Name => Name_Constrained)));
4306 Append_To (Extra_Formal_Statements,
4307 Make_Attribute_Reference (Loc,
4309 New_Occurrence_Of (Standard_Boolean, Loc),
4310 Attribute_Name => Name_Write,
4311 Expressions => New_List (
4312 Make_Attribute_Reference (Loc,
4315 (Stream_Parameter, Loc), Attribute_Name =>
4317 New_Occurrence_Of (Extra_Parameter, Loc))));
4320 Next (Current_Parameter);
4324 -- Append the formal statements list to the statements
4326 Append_List_To (Statements, Extra_Formal_Statements);
4328 if not Is_Known_Non_Asynchronous then
4330 -- Build the call to System.RPC.Do_APC
4332 Asynchronous_Statements := New_List (
4333 Make_Procedure_Call_Statement (Loc,
4335 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4336 Parameter_Associations => New_List (
4337 New_Occurrence_Of (Target_Partition, Loc),
4338 Make_Attribute_Reference (Loc,
4340 New_Occurrence_Of (Stream_Parameter, Loc),
4341 Attribute_Name => Name_Access))));
4343 Asynchronous_Statements := No_List;
4346 if not Is_Known_Asynchronous then
4348 -- Build the call to System.RPC.Do_RPC
4350 Non_Asynchronous_Statements := New_List (
4351 Make_Procedure_Call_Statement (Loc,
4353 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4354 Parameter_Associations => New_List (
4355 New_Occurrence_Of (Target_Partition, Loc),
4357 Make_Attribute_Reference (Loc,
4359 New_Occurrence_Of (Stream_Parameter, Loc),
4360 Attribute_Name => Name_Access),
4362 Make_Attribute_Reference (Loc,
4364 New_Occurrence_Of (Result_Parameter, Loc),
4365 Attribute_Name => Name_Access))));
4367 -- Read the exception occurrence from the result stream and
4368 -- reraise it. It does no harm if this is a Null_Occurrence since
4369 -- this does nothing.
4371 Append_To (Non_Asynchronous_Statements,
4372 Make_Attribute_Reference (Loc,
4374 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4376 Attribute_Name => Name_Read,
4378 Expressions => New_List (
4379 Make_Attribute_Reference (Loc,
4381 New_Occurrence_Of (Result_Parameter, Loc),
4382 Attribute_Name => Name_Access),
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),
4455 Attribute_Name => Name_Access),
4460 Next (Current_Parameter);
4465 if Is_Known_Asynchronous then
4466 Append_List_To (Statements, Asynchronous_Statements);
4468 elsif Is_Known_Non_Asynchronous then
4469 Append_List_To (Statements, Non_Asynchronous_Statements);
4472 pragma Assert (Present (Asynchronous));
4473 Prepend_To (Asynchronous_Statements,
4474 Make_Attribute_Reference (Loc,
4475 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4476 Attribute_Name => Name_Write,
4477 Expressions => New_List (
4478 Make_Attribute_Reference (Loc,
4480 New_Occurrence_Of (Stream_Parameter, Loc),
4481 Attribute_Name => Name_Access),
4482 New_Occurrence_Of (Standard_True, Loc))));
4484 Prepend_To (Non_Asynchronous_Statements,
4485 Make_Attribute_Reference (Loc,
4486 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4487 Attribute_Name => Name_Write,
4488 Expressions => New_List (
4489 Make_Attribute_Reference (Loc,
4491 New_Occurrence_Of (Stream_Parameter, Loc),
4492 Attribute_Name => Name_Access),
4493 New_Occurrence_Of (Standard_False, Loc))));
4495 Append_To (Statements,
4496 Make_Implicit_If_Statement (Nod,
4497 Condition => Asynchronous,
4498 Then_Statements => Asynchronous_Statements,
4499 Else_Statements => Non_Asynchronous_Statements));
4501 end Build_General_Calling_Stubs;
4503 -----------------------------
4504 -- Build_RPC_Receiver_Body --
4505 -----------------------------
4507 procedure Build_RPC_Receiver_Body
4508 (RPC_Receiver : Entity_Id;
4509 Request : out Entity_Id;
4510 Subp_Id : out Entity_Id;
4511 Subp_Index : out Entity_Id;
4512 Stmts : out List_Id;
4515 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4517 RPC_Receiver_Spec : Node_Id;
4518 RPC_Receiver_Decls : List_Id;
4521 Request := Make_Defining_Identifier (Loc, Name_R);
4523 RPC_Receiver_Spec :=
4524 Build_RPC_Receiver_Specification
4525 (RPC_Receiver => RPC_Receiver,
4526 Request_Parameter => Request);
4528 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4529 Subp_Index := Subp_Id;
4531 -- Subp_Id may not be a constant, because in the case of the RPC
4532 -- receiver for an RCI package, when a call is received from a RAS
4533 -- dereference, it will be assigned during subsequent processing.
4535 RPC_Receiver_Decls := New_List (
4536 Make_Object_Declaration (Loc,
4537 Defining_Identifier => Subp_Id,
4538 Object_Definition =>
4539 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4541 Make_Attribute_Reference (Loc,
4543 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4544 Attribute_Name => Name_Input,
4545 Expressions => New_List (
4546 Make_Selected_Component (Loc,
4548 Selector_Name => Name_Params)))));
4553 Make_Subprogram_Body (Loc,
4554 Specification => RPC_Receiver_Spec,
4555 Declarations => RPC_Receiver_Decls,
4556 Handled_Statement_Sequence =>
4557 Make_Handled_Sequence_Of_Statements (Loc,
4558 Statements => Stmts));
4559 end Build_RPC_Receiver_Body;
4561 -----------------------
4562 -- Build_Stub_Target --
4563 -----------------------
4565 function Build_Stub_Target
4568 RCI_Locator : Entity_Id;
4569 Controlling_Parameter : Entity_Id) return RPC_Target
4571 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4573 Target_Info.Partition :=
4574 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4575 if Present (Controlling_Parameter) then
4577 Make_Object_Declaration (Loc,
4578 Defining_Identifier => Target_Info.Partition,
4579 Constant_Present => True,
4580 Object_Definition =>
4581 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4584 Make_Selected_Component (Loc,
4585 Prefix => Controlling_Parameter,
4586 Selector_Name => Name_Origin)));
4588 Target_Info.RPC_Receiver :=
4589 Make_Selected_Component (Loc,
4590 Prefix => Controlling_Parameter,
4591 Selector_Name => Name_Receiver);
4595 Make_Object_Declaration (Loc,
4596 Defining_Identifier => Target_Info.Partition,
4597 Constant_Present => True,
4598 Object_Definition =>
4599 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4602 Make_Function_Call (Loc,
4603 Name => Make_Selected_Component (Loc,
4605 Make_Identifier (Loc, Chars (RCI_Locator)),
4607 Make_Identifier (Loc,
4608 Name_Get_Active_Partition_ID)))));
4610 Target_Info.RPC_Receiver :=
4611 Make_Selected_Component (Loc,
4613 Make_Identifier (Loc, Chars (RCI_Locator)),
4615 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4618 end Build_Stub_Target;
4620 ---------------------
4621 -- Build_Stub_Type --
4622 ---------------------
4624 procedure Build_Stub_Type
4625 (RACW_Type : Entity_Id;
4626 Stub_Type : Entity_Id;
4627 Stub_Type_Decl : out Node_Id;
4628 RPC_Receiver_Decl : out Node_Id)
4630 Loc : constant Source_Ptr := Sloc (Stub_Type);
4631 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4635 Make_Full_Type_Declaration (Loc,
4636 Defining_Identifier => Stub_Type,
4638 Make_Record_Definition (Loc,
4639 Tagged_Present => True,
4640 Limited_Present => True,
4642 Make_Component_List (Loc,
4643 Component_Items => New_List (
4645 Make_Component_Declaration (Loc,
4646 Defining_Identifier =>
4647 Make_Defining_Identifier (Loc, Name_Origin),
4648 Component_Definition =>
4649 Make_Component_Definition (Loc,
4650 Aliased_Present => False,
4651 Subtype_Indication =>
4653 RTE (RE_Partition_ID), Loc))),
4655 Make_Component_Declaration (Loc,
4656 Defining_Identifier =>
4657 Make_Defining_Identifier (Loc, Name_Receiver),
4658 Component_Definition =>
4659 Make_Component_Definition (Loc,
4660 Aliased_Present => False,
4661 Subtype_Indication =>
4662 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4664 Make_Component_Declaration (Loc,
4665 Defining_Identifier =>
4666 Make_Defining_Identifier (Loc, Name_Addr),
4667 Component_Definition =>
4668 Make_Component_Definition (Loc,
4669 Aliased_Present => False,
4670 Subtype_Indication =>
4671 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4673 Make_Component_Declaration (Loc,
4674 Defining_Identifier =>
4675 Make_Defining_Identifier (Loc, Name_Asynchronous),
4676 Component_Definition =>
4677 Make_Component_Definition (Loc,
4678 Aliased_Present => False,
4679 Subtype_Indication =>
4681 Standard_Boolean, Loc)))))));
4684 RPC_Receiver_Decl := Empty;
4687 RPC_Receiver_Request : constant Entity_Id :=
4688 Make_Defining_Identifier (Loc, Name_R);
4690 RPC_Receiver_Decl :=
4691 Make_Subprogram_Declaration (Loc,
4692 Build_RPC_Receiver_Specification (
4693 RPC_Receiver => Make_Defining_Identifier (Loc,
4694 New_Internal_Name ('R')),
4695 Request_Parameter => RPC_Receiver_Request));
4698 end Build_Stub_Type;
4700 --------------------------------------
4701 -- Build_Subprogram_Receiving_Stubs --
4702 --------------------------------------
4704 function Build_Subprogram_Receiving_Stubs
4705 (Vis_Decl : Node_Id;
4706 Asynchronous : Boolean;
4707 Dynamically_Asynchronous : Boolean := False;
4708 Stub_Type : Entity_Id := Empty;
4709 RACW_Type : Entity_Id := Empty;
4710 Parent_Primitive : Entity_Id := Empty) return Node_Id
4712 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4714 Request_Parameter : constant Entity_Id :=
4715 Make_Defining_Identifier (Loc,
4716 New_Internal_Name ('R'));
4717 -- Formal parameter for receiving stubs: a descriptor for an incoming
4720 Decls : constant List_Id := New_List;
4721 -- All the parameters will get declared before calling the real
4722 -- subprograms. Also the out parameters will be declared.
4724 Statements : constant List_Id := New_List;
4726 Extra_Formal_Statements : constant List_Id := New_List;
4727 -- Statements concerning extra formal parameters
4729 After_Statements : constant List_Id := New_List;
4730 -- Statements to be executed after the subprogram call
4732 Inner_Decls : List_Id := No_List;
4733 -- In case of a function, the inner declarations are needed since
4734 -- the result may be unconstrained.
4736 Excep_Handlers : List_Id := No_List;
4737 Excep_Choice : Entity_Id;
4738 Excep_Code : List_Id;
4740 Parameter_List : constant List_Id := New_List;
4741 -- List of parameters to be passed to the subprogram
4743 Current_Parameter : Node_Id;
4745 Ordered_Parameters_List : constant List_Id :=
4746 Build_Ordered_Parameters_List
4747 (Specification (Vis_Decl));
4749 Subp_Spec : Node_Id;
4750 -- Subprogram specification
4752 Called_Subprogram : Node_Id;
4753 -- The subprogram to call
4755 Null_Raise_Statement : Node_Id;
4757 Dynamic_Async : Entity_Id;
4760 if Present (RACW_Type) then
4761 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4763 Called_Subprogram :=
4765 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4768 if Dynamically_Asynchronous then
4770 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4772 Dynamic_Async := Empty;
4775 if not Asynchronous or Dynamically_Asynchronous then
4777 -- The first statement after the subprogram call is a statement to
4778 -- write a Null_Occurrence into the result stream.
4780 Null_Raise_Statement :=
4781 Make_Attribute_Reference (Loc,
4783 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4784 Attribute_Name => Name_Write,
4785 Expressions => New_List (
4786 Make_Selected_Component (Loc,
4787 Prefix => Request_Parameter,
4788 Selector_Name => Name_Result),
4789 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4791 if Dynamically_Asynchronous then
4792 Null_Raise_Statement :=
4793 Make_Implicit_If_Statement (Vis_Decl,
4795 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4796 Then_Statements => New_List (Null_Raise_Statement));
4799 Append_To (After_Statements, Null_Raise_Statement);
4802 -- Loop through every parameter and get its value from the stream. If
4803 -- the parameter is unconstrained, then the parameter is read using
4804 -- 'Input at the point of declaration.
4806 Current_Parameter := First (Ordered_Parameters_List);
4807 while Present (Current_Parameter) loop
4810 Constrained : Boolean;
4812 Need_Extra_Constrained : Boolean;
4813 -- True when an Extra_Constrained actual is required
4815 Object : constant Entity_Id :=
4816 Make_Defining_Identifier (Loc,
4817 New_Internal_Name ('P'));
4819 Expr : Node_Id := Empty;
4821 Is_Controlling_Formal : constant Boolean :=
4822 Is_RACW_Controlling_Formal
4823 (Current_Parameter, Stub_Type);
4826 if Is_Controlling_Formal then
4828 -- We have a controlling formal parameter. Read its address
4829 -- rather than a real object. The address is in Unsigned_64
4832 Etyp := RTE (RE_Unsigned_64);
4834 Etyp := Etype (Parameter_Type (Current_Parameter));
4837 Constrained := not Transmit_As_Unconstrained (Etyp);
4839 if In_Present (Current_Parameter)
4840 or else not Out_Present (Current_Parameter)
4841 or else not Constrained
4842 or else Is_Controlling_Formal
4844 -- If an input parameter is constrained, then the read of
4845 -- the parameter is deferred until the beginning of the
4846 -- subprogram body. If it is unconstrained, then an
4847 -- expression is built for the object declaration and the
4848 -- variable is set using 'Input instead of 'Read. Note that
4849 -- this deferral does not change the order in which the
4850 -- actuals are read because Build_Ordered_Parameter_List
4851 -- puts them unconstrained first.
4854 Append_To (Statements,
4855 Make_Attribute_Reference (Loc,
4856 Prefix => New_Occurrence_Of (Etyp, Loc),
4857 Attribute_Name => Name_Read,
4858 Expressions => New_List (
4859 Make_Selected_Component (Loc,
4860 Prefix => Request_Parameter,
4861 Selector_Name => Name_Params),
4862 New_Occurrence_Of (Object, Loc))));
4866 -- Build and append Input_With_Tag_Check function
4869 Input_With_Tag_Check (Loc,
4872 Make_Selected_Component (Loc,
4873 Prefix => Request_Parameter,
4874 Selector_Name => Name_Params)));
4876 -- Prepare function call expression
4879 Make_Function_Call (Loc,
4883 (Specification (Last (Decls))), Loc));
4887 Need_Extra_Constrained :=
4888 Nkind (Parameter_Type (Current_Parameter)) /=
4891 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4893 Present (Extra_Constrained
4894 (Defining_Identifier (Current_Parameter)));
4896 -- We may not associate an extra constrained actual to a
4897 -- constant object, so if one is needed, declare the actual
4898 -- as a variable even if it won't be modified.
4900 Build_Actual_Object_Declaration
4903 Variable => Need_Extra_Constrained
4904 or else Out_Present (Current_Parameter),
4908 -- An out parameter may be written back using a 'Write
4909 -- attribute instead of a 'Output because it has been
4910 -- constrained by the parameter given to the caller. Note that
4911 -- out controlling arguments in the case of a RACW are not put
4912 -- back in the stream because the pointer on them has not
4915 if Out_Present (Current_Parameter)
4917 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4919 Append_To (After_Statements,
4920 Make_Attribute_Reference (Loc,
4921 Prefix => New_Occurrence_Of (Etyp, Loc),
4922 Attribute_Name => Name_Write,
4923 Expressions => New_List (
4924 Make_Selected_Component (Loc,
4925 Prefix => Request_Parameter,
4926 Selector_Name => Name_Result),
4927 New_Occurrence_Of (Object, Loc))));
4930 -- For RACW controlling formals, the Etyp of Object is always
4931 -- an RACW, even if the parameter is not of an anonymous access
4932 -- type. In such case, we need to dereference it at call time.
4934 if Is_Controlling_Formal then
4935 if Nkind (Parameter_Type (Current_Parameter)) /=
4938 Append_To (Parameter_List,
4939 Make_Parameter_Association (Loc,
4942 Defining_Identifier (Current_Parameter), Loc),
4943 Explicit_Actual_Parameter =>
4944 Make_Explicit_Dereference (Loc,
4945 Unchecked_Convert_To (RACW_Type,
4946 OK_Convert_To (RTE (RE_Address),
4947 New_Occurrence_Of (Object, Loc))))));
4950 Append_To (Parameter_List,
4951 Make_Parameter_Association (Loc,
4954 Defining_Identifier (Current_Parameter), Loc),
4955 Explicit_Actual_Parameter =>
4956 Unchecked_Convert_To (RACW_Type,
4957 OK_Convert_To (RTE (RE_Address),
4958 New_Occurrence_Of (Object, Loc)))));
4962 Append_To (Parameter_List,
4963 Make_Parameter_Association (Loc,
4966 Defining_Identifier (Current_Parameter), Loc),
4967 Explicit_Actual_Parameter =>
4968 New_Occurrence_Of (Object, Loc)));
4971 -- If the current parameter needs an extra formal, then read it
4972 -- from the stream and set the corresponding semantic field in
4973 -- the variable. If the kind of the parameter identifier is
4974 -- E_Void, then this is a compiler generated parameter that
4975 -- doesn't need an extra constrained status.
4977 -- The case of Extra_Accessibility should also be handled ???
4979 if Need_Extra_Constrained then
4981 Extra_Parameter : constant Entity_Id :=
4983 (Defining_Identifier
4984 (Current_Parameter));
4986 Formal_Entity : constant Entity_Id :=
4987 Make_Defining_Identifier
4988 (Loc, Chars (Extra_Parameter));
4990 Formal_Type : constant Entity_Id :=
4991 Etype (Extra_Parameter);
4995 Make_Object_Declaration (Loc,
4996 Defining_Identifier => Formal_Entity,
4997 Object_Definition =>
4998 New_Occurrence_Of (Formal_Type, Loc)));
5000 Append_To (Extra_Formal_Statements,
5001 Make_Attribute_Reference (Loc,
5002 Prefix => New_Occurrence_Of (
5004 Attribute_Name => Name_Read,
5005 Expressions => New_List (
5006 Make_Selected_Component (Loc,
5007 Prefix => Request_Parameter,
5008 Selector_Name => Name_Params),
5009 New_Occurrence_Of (Formal_Entity, Loc))));
5011 -- Note: the call to Set_Extra_Constrained below relies
5012 -- on the fact that Object's Ekind has been set by
5013 -- Build_Actual_Object_Declaration.
5015 Set_Extra_Constrained (Object, Formal_Entity);
5020 Next (Current_Parameter);
5023 -- Append the formal statements list at the end of regular statements
5025 Append_List_To (Statements, Extra_Formal_Statements);
5027 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
5029 -- The remote subprogram is a function. We build an inner block to
5030 -- be able to hold a potentially unconstrained result in a
5034 Etyp : constant Entity_Id :=
5035 Etype (Result_Definition (Specification (Vis_Decl)));
5036 Result : constant Node_Id :=
5037 Make_Defining_Identifier (Loc,
5038 New_Internal_Name ('R'));
5040 Inner_Decls := New_List (
5041 Make_Object_Declaration (Loc,
5042 Defining_Identifier => Result,
5043 Constant_Present => True,
5044 Object_Definition => New_Occurrence_Of (Etyp, Loc),
5046 Make_Function_Call (Loc,
5047 Name => Called_Subprogram,
5048 Parameter_Associations => Parameter_List)));
5050 if Is_Class_Wide_Type (Etyp) then
5052 -- For a remote call to a function with a class-wide type,
5053 -- check that the returned value satisfies the requirements
5056 Append_To (Inner_Decls,
5057 Make_Transportable_Check (Loc,
5058 New_Occurrence_Of (Result, Loc)));
5062 Append_To (After_Statements,
5063 Make_Attribute_Reference (Loc,
5064 Prefix => New_Occurrence_Of (Etyp, Loc),
5065 Attribute_Name => Name_Output,
5066 Expressions => New_List (
5067 Make_Selected_Component (Loc,
5068 Prefix => Request_Parameter,
5069 Selector_Name => Name_Result),
5070 New_Occurrence_Of (Result, Loc))));
5073 Append_To (Statements,
5074 Make_Block_Statement (Loc,
5075 Declarations => Inner_Decls,
5076 Handled_Statement_Sequence =>
5077 Make_Handled_Sequence_Of_Statements (Loc,
5078 Statements => After_Statements)));
5081 -- The remote subprogram is a procedure. We do not need any inner
5082 -- block in this case.
5084 if Dynamically_Asynchronous then
5086 Make_Object_Declaration (Loc,
5087 Defining_Identifier => Dynamic_Async,
5088 Object_Definition =>
5089 New_Occurrence_Of (Standard_Boolean, Loc)));
5091 Append_To (Statements,
5092 Make_Attribute_Reference (Loc,
5093 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5094 Attribute_Name => Name_Read,
5095 Expressions => New_List (
5096 Make_Selected_Component (Loc,
5097 Prefix => Request_Parameter,
5098 Selector_Name => Name_Params),
5099 New_Occurrence_Of (Dynamic_Async, Loc))));
5102 Append_To (Statements,
5103 Make_Procedure_Call_Statement (Loc,
5104 Name => Called_Subprogram,
5105 Parameter_Associations => Parameter_List));
5107 Append_List_To (Statements, After_Statements);
5110 if Asynchronous and then not Dynamically_Asynchronous then
5112 -- For an asynchronous procedure, add a null exception handler
5114 Excep_Handlers := New_List (
5115 Make_Implicit_Exception_Handler (Loc,
5116 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5117 Statements => New_List (Make_Null_Statement (Loc))));
5120 -- In the other cases, if an exception is raised, then the
5121 -- exception occurrence is copied into the output stream and
5122 -- no other output parameter is written.
5125 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5127 Excep_Code := New_List (
5128 Make_Attribute_Reference (Loc,
5130 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5131 Attribute_Name => Name_Write,
5132 Expressions => New_List (
5133 Make_Selected_Component (Loc,
5134 Prefix => Request_Parameter,
5135 Selector_Name => Name_Result),
5136 New_Occurrence_Of (Excep_Choice, Loc))));
5138 if Dynamically_Asynchronous then
5139 Excep_Code := New_List (
5140 Make_Implicit_If_Statement (Vis_Decl,
5141 Condition => Make_Op_Not (Loc,
5142 New_Occurrence_Of (Dynamic_Async, Loc)),
5143 Then_Statements => Excep_Code));
5146 Excep_Handlers := New_List (
5147 Make_Implicit_Exception_Handler (Loc,
5148 Choice_Parameter => Excep_Choice,
5149 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5150 Statements => Excep_Code));
5155 Make_Procedure_Specification (Loc,
5156 Defining_Unit_Name =>
5157 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
5159 Parameter_Specifications => New_List (
5160 Make_Parameter_Specification (Loc,
5161 Defining_Identifier => Request_Parameter,
5163 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5166 Make_Subprogram_Body (Loc,
5167 Specification => Subp_Spec,
5168 Declarations => Decls,
5169 Handled_Statement_Sequence =>
5170 Make_Handled_Sequence_Of_Statements (Loc,
5171 Statements => Statements,
5172 Exception_Handlers => Excep_Handlers));
5173 end Build_Subprogram_Receiving_Stubs;
5179 function Result return Node_Id is
5181 return Make_Identifier (Loc, Name_V);
5184 ----------------------
5185 -- Stream_Parameter --
5186 ----------------------
5188 function Stream_Parameter return Node_Id is
5190 return Make_Identifier (Loc, Name_S);
5191 end Stream_Parameter;
5195 -------------------------------
5196 -- Get_And_Reset_RACW_Bodies --
5197 -------------------------------
5199 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5200 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
5201 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5203 Body_Decls : List_Id;
5204 -- Returned list of declarations
5207 if Stub_Elements = Empty_Stub_Structure then
5209 -- Stub elements may be missing as a consequence of a previously
5215 Body_Decls := Stub_Elements.Body_Decls;
5216 Stub_Elements.Body_Decls := No_List;
5217 Stubs_Table.Set (Desig, Stub_Elements);
5219 end Get_And_Reset_RACW_Bodies;
5221 -----------------------
5222 -- Get_Stub_Elements --
5223 -----------------------
5225 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is
5226 Desig : constant Entity_Id :=
5227 Etype (Designated_Type (RACW_Type));
5228 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
5230 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5231 return Stub_Elements;
5232 end Get_Stub_Elements;
5234 -----------------------
5235 -- Get_Subprogram_Id --
5236 -----------------------
5238 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5239 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5241 pragma Assert (Result /= No_String);
5243 end Get_Subprogram_Id;
5245 -----------------------
5246 -- Get_Subprogram_Id --
5247 -----------------------
5249 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5251 return Get_Subprogram_Ids (Def).Int_Identifier;
5252 end Get_Subprogram_Id;
5254 ------------------------
5255 -- Get_Subprogram_Ids --
5256 ------------------------
5258 function Get_Subprogram_Ids
5259 (Def : Entity_Id) return Subprogram_Identifiers
5262 return Subprogram_Identifier_Table.Get (Def);
5263 end Get_Subprogram_Ids;
5269 function Hash (F : Entity_Id) return Hash_Index is
5271 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5274 function Hash (F : Name_Id) return Hash_Index is
5276 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5279 --------------------------
5280 -- Input_With_Tag_Check --
5281 --------------------------
5283 function Input_With_Tag_Check
5285 Var_Type : Entity_Id;
5286 Stream : Node_Id) return Node_Id
5290 Make_Subprogram_Body (Loc,
5291 Specification => Make_Function_Specification (Loc,
5292 Defining_Unit_Name =>
5293 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
5294 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5295 Declarations => No_List,
5296 Handled_Statement_Sequence =>
5297 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5298 Make_Tag_Check (Loc,
5299 Make_Simple_Return_Statement (Loc,
5300 Make_Attribute_Reference (Loc,
5301 Prefix => New_Occurrence_Of (Var_Type, Loc),
5302 Attribute_Name => Name_Input,
5304 New_List (Stream)))))));
5305 end Input_With_Tag_Check;
5307 --------------------------------
5308 -- Is_RACW_Controlling_Formal --
5309 --------------------------------
5311 function Is_RACW_Controlling_Formal
5312 (Parameter : Node_Id;
5313 Stub_Type : Entity_Id) return Boolean
5318 -- If the kind of the parameter is E_Void, then it is not a
5319 -- controlling formal (this can happen in the context of RAS).
5321 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5325 -- If the parameter is not a controlling formal, then it cannot
5326 -- be possibly a RACW_Controlling_Formal.
5328 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5332 Typ := Parameter_Type (Parameter);
5333 return (Nkind (Typ) = N_Access_Definition
5334 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5335 or else Etype (Typ) = Stub_Type;
5336 end Is_RACW_Controlling_Formal;
5338 ------------------------------
5339 -- Make_Transportable_Check --
5340 ------------------------------
5342 function Make_Transportable_Check
5344 Expr : Node_Id) return Node_Id is
5347 Make_Raise_Program_Error (Loc,
5350 Build_Get_Transportable (Loc,
5351 Make_Selected_Component (Loc,
5353 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5354 Reason => PE_Non_Transportable_Actual);
5355 end Make_Transportable_Check;
5357 -----------------------------
5358 -- Make_Selected_Component --
5359 -----------------------------
5361 function Make_Selected_Component
5364 Selector_Name : Name_Id) return Node_Id
5367 return Make_Selected_Component (Loc,
5368 Prefix => New_Occurrence_Of (Prefix, Loc),
5369 Selector_Name => Make_Identifier (Loc, Selector_Name));
5370 end Make_Selected_Component;
5372 --------------------
5373 -- Make_Tag_Check --
5374 --------------------
5376 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5377 Occ : constant Entity_Id :=
5378 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5381 return Make_Block_Statement (Loc,
5382 Handled_Statement_Sequence =>
5383 Make_Handled_Sequence_Of_Statements (Loc,
5384 Statements => New_List (N),
5386 Exception_Handlers => New_List (
5387 Make_Implicit_Exception_Handler (Loc,
5388 Choice_Parameter => Occ,
5390 Exception_Choices =>
5391 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5394 New_List (Make_Procedure_Call_Statement (Loc,
5396 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5397 New_List (New_Occurrence_Of (Occ, Loc))))))));
5400 ----------------------------
5401 -- Need_Extra_Constrained --
5402 ----------------------------
5404 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5405 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5407 return Out_Present (Parameter)
5408 and then Has_Discriminants (Etyp)
5409 and then not Is_Constrained (Etyp)
5410 and then not Is_Indefinite_Subtype (Etyp);
5411 end Need_Extra_Constrained;
5413 ------------------------------------
5414 -- Pack_Entity_Into_Stream_Access --
5415 ------------------------------------
5417 function Pack_Entity_Into_Stream_Access
5421 Etyp : Entity_Id := Empty) return Node_Id
5426 if Present (Etyp) then
5429 Typ := Etype (Object);
5433 Pack_Node_Into_Stream_Access (Loc,
5435 Object => New_Occurrence_Of (Object, Loc),
5437 end Pack_Entity_Into_Stream_Access;
5439 ---------------------------
5440 -- Pack_Node_Into_Stream --
5441 ---------------------------
5443 function Pack_Node_Into_Stream
5447 Etyp : Entity_Id) return Node_Id
5449 Write_Attribute : Name_Id := Name_Write;
5452 if not Is_Constrained (Etyp) then
5453 Write_Attribute := Name_Output;
5457 Make_Attribute_Reference (Loc,
5458 Prefix => New_Occurrence_Of (Etyp, Loc),
5459 Attribute_Name => Write_Attribute,
5460 Expressions => New_List (
5461 Make_Attribute_Reference (Loc,
5462 Prefix => New_Occurrence_Of (Stream, Loc),
5463 Attribute_Name => Name_Access),
5465 end Pack_Node_Into_Stream;
5467 ----------------------------------
5468 -- Pack_Node_Into_Stream_Access --
5469 ----------------------------------
5471 function Pack_Node_Into_Stream_Access
5475 Etyp : Entity_Id) return Node_Id
5477 Write_Attribute : Name_Id := Name_Write;
5480 if not Is_Constrained (Etyp) then
5481 Write_Attribute := Name_Output;
5485 Make_Attribute_Reference (Loc,
5486 Prefix => New_Occurrence_Of (Etyp, Loc),
5487 Attribute_Name => Write_Attribute,
5488 Expressions => New_List (
5491 end Pack_Node_Into_Stream_Access;
5493 ---------------------
5494 -- PolyORB_Support --
5495 ---------------------
5497 package body PolyORB_Support is
5499 -- Local subprograms
5501 procedure Add_RACW_Read_Attribute
5502 (RACW_Type : Entity_Id;
5503 Stub_Type : Entity_Id;
5504 Stub_Type_Access : Entity_Id;
5505 Body_Decls : List_Id);
5506 -- Add Read attribute for the RACW type. The declaration and attribute
5507 -- definition clauses are inserted right after the declaration of
5508 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5509 -- appended to it (case where the RACW declaration is in the main unit).
5511 procedure Add_RACW_Write_Attribute
5512 (RACW_Type : Entity_Id;
5513 Stub_Type : Entity_Id;
5514 Stub_Type_Access : Entity_Id;
5515 Body_Decls : List_Id);
5516 -- Same as above for the Write attribute
5518 procedure Add_RACW_From_Any
5519 (RACW_Type : Entity_Id;
5520 Body_Decls : List_Id);
5521 -- Add the From_Any TSS for this RACW type
5523 procedure Add_RACW_To_Any
5524 (RACW_Type : Entity_Id;
5525 Body_Decls : List_Id);
5526 -- Add the To_Any TSS for this RACW type
5528 procedure Add_RACW_TypeCode
5529 (Designated_Type : Entity_Id;
5530 RACW_Type : Entity_Id;
5531 Body_Decls : List_Id);
5532 -- Add the TypeCode TSS for this RACW type
5534 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5535 -- Add the From_Any TSS for this RAS type
5537 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5538 -- Add the To_Any TSS for this RAS type
5540 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5541 -- Add the TypeCode TSS for this RAS type
5543 procedure Add_RAS_Access_TSS (N : Node_Id);
5544 -- Add a subprogram body for RAS Access TSS
5546 -------------------------------------
5547 -- Add_Obj_RPC_Receiver_Completion --
5548 -------------------------------------
5550 procedure Add_Obj_RPC_Receiver_Completion
5553 RPC_Receiver : Entity_Id;
5554 Stub_Elements : Stub_Structure)
5556 Desig : constant Entity_Id :=
5557 Etype (Designated_Type (Stub_Elements.RACW_Type));
5560 Make_Procedure_Call_Statement (Loc,
5563 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5565 Parameter_Associations => New_List (
5569 Make_String_Literal (Loc,
5570 Full_Qualified_Name (Desig)),
5574 Make_Attribute_Reference (Loc,
5577 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5583 Make_Attribute_Reference (Loc,
5586 Defining_Identifier (
5587 Stub_Elements.RPC_Receiver_Decl), Loc),
5590 end Add_Obj_RPC_Receiver_Completion;
5592 -----------------------
5593 -- Add_RACW_Features --
5594 -----------------------
5596 procedure Add_RACW_Features
5597 (RACW_Type : Entity_Id;
5599 Stub_Type : Entity_Id;
5600 Stub_Type_Access : Entity_Id;
5601 RPC_Receiver_Decl : Node_Id;
5602 Body_Decls : List_Id)
5604 pragma Warnings (Off);
5605 pragma Unreferenced (RPC_Receiver_Decl);
5606 pragma Warnings (On);
5610 (RACW_Type => RACW_Type,
5611 Body_Decls => Body_Decls);
5614 (RACW_Type => RACW_Type,
5615 Body_Decls => Body_Decls);
5617 Add_RACW_Write_Attribute
5618 (RACW_Type => RACW_Type,
5619 Stub_Type => Stub_Type,
5620 Stub_Type_Access => Stub_Type_Access,
5621 Body_Decls => Body_Decls);
5623 Add_RACW_Read_Attribute
5624 (RACW_Type => RACW_Type,
5625 Stub_Type => Stub_Type,
5626 Stub_Type_Access => Stub_Type_Access,
5627 Body_Decls => Body_Decls);
5630 (Designated_Type => Desig,
5631 RACW_Type => RACW_Type,
5632 Body_Decls => Body_Decls);
5633 end Add_RACW_Features;
5635 -----------------------
5636 -- Add_RACW_From_Any --
5637 -----------------------
5639 procedure Add_RACW_From_Any
5640 (RACW_Type : 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;
5654 Statements : List_Id;
5655 -- Various parts of the subprogram
5657 Any_Parameter : constant Entity_Id :=
5658 Make_Defining_Identifier (Loc, Name_A);
5660 Asynchronous_Flag : constant Entity_Id :=
5661 Asynchronous_Flags_Table.Get (RACW_Type);
5662 -- The flag object declared in Add_RACW_Asynchronous_Flag
5666 Make_Function_Specification (Loc,
5667 Defining_Unit_Name =>
5669 Parameter_Specifications => New_List (
5670 Make_Parameter_Specification (Loc,
5671 Defining_Identifier =>
5674 New_Occurrence_Of (RTE (RE_Any), Loc))),
5675 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5677 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5678 -- entity in the declaration spec, not those of the body spec.
5680 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5681 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5682 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5684 if No (Body_Decls) then
5688 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5689 -- set on the stub type if, and only if, the RACW type has a pragma
5690 -- Asynchronous. This is incorrect for RACWs that implement RAS
5691 -- types, because in that case the /designated subprogram/ (not the
5692 -- type) might be asynchronous, and that causes the stub to need to
5693 -- be asynchronous too. A solution is to transport a RAS as a struct
5694 -- containing a RACW and an asynchronous flag, and to properly alter
5695 -- the Asynchronous component in the stub type in the RAS's _From_Any
5698 Statements := New_List (
5699 Make_Simple_Return_Statement (Loc,
5700 Expression => Unchecked_Convert_To (RACW_Type,
5701 Make_Function_Call (Loc,
5702 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5703 Parameter_Associations => New_List (
5704 Make_Function_Call (Loc,
5705 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5706 Parameter_Associations => New_List (
5707 New_Occurrence_Of (Any_Parameter, Loc))),
5708 Build_Stub_Tag (Loc, RACW_Type),
5709 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5710 New_Occurrence_Of (Asynchronous_Flag, Loc))))));
5713 Make_Subprogram_Body (Loc,
5714 Specification => Copy_Specification (Loc, Func_Spec),
5715 Declarations => No_List,
5716 Handled_Statement_Sequence =>
5717 Make_Handled_Sequence_Of_Statements (Loc,
5718 Statements => Statements));
5720 Append_To (Body_Decls, Func_Body);
5721 end Add_RACW_From_Any;
5723 -----------------------------
5724 -- Add_RACW_Read_Attribute --
5725 -----------------------------
5727 procedure Add_RACW_Read_Attribute
5728 (RACW_Type : Entity_Id;
5729 Stub_Type : Entity_Id;
5730 Stub_Type_Access : Entity_Id;
5731 Body_Decls : List_Id)
5733 pragma Warnings (Off);
5734 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5735 pragma Warnings (On);
5736 Loc : constant Source_Ptr := Sloc (RACW_Type);
5738 Proc_Decl : Node_Id;
5739 Attr_Decl : Node_Id;
5741 Body_Node : Node_Id;
5743 Decls : constant List_Id := New_List;
5744 Statements : constant List_Id := New_List;
5745 Reference : constant Entity_Id :=
5746 Make_Defining_Identifier (Loc, Name_R);
5747 -- Various parts of the procedure
5749 Pnam : constant Entity_Id := Make_Defining_Identifier (Loc,
5750 New_Internal_Name ('R'));
5752 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5754 Asynchronous_Flag : constant Entity_Id :=
5755 Asynchronous_Flags_Table.Get (RACW_Type);
5756 pragma Assert (Present (Asynchronous_Flag));
5758 function Stream_Parameter return Node_Id;
5759 function Result return Node_Id;
5761 -- Functions to create occurrences of the formal parameter names
5767 function Result return Node_Id is
5769 return Make_Identifier (Loc, Name_V);
5772 ----------------------
5773 -- Stream_Parameter --
5774 ----------------------
5776 function Stream_Parameter return Node_Id is
5778 return Make_Identifier (Loc, Name_S);
5779 end Stream_Parameter;
5781 -- Start of processing for Add_RACW_Read_Attribute
5784 Build_Stream_Procedure
5785 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
5787 Proc_Decl := Make_Subprogram_Declaration (Loc,
5788 Copy_Specification (Loc, Specification (Body_Node)));
5791 Make_Attribute_Definition_Clause (Loc,
5792 Name => New_Occurrence_Of (RACW_Type, Loc),
5796 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5798 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5799 Insert_After (Proc_Decl, Attr_Decl);
5801 if No (Body_Decls) then
5806 Make_Object_Declaration (Loc,
5807 Defining_Identifier =>
5809 Object_Definition =>
5810 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5812 Append_List_To (Statements, New_List (
5813 Make_Attribute_Reference (Loc,
5815 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5816 Attribute_Name => Name_Read,
5817 Expressions => New_List (
5819 New_Occurrence_Of (Reference, Loc))),
5821 Make_Assignment_Statement (Loc,
5825 Unchecked_Convert_To (RACW_Type,
5826 Make_Function_Call (Loc,
5828 New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5829 Parameter_Associations => New_List (
5830 New_Occurrence_Of (Reference, Loc),
5831 Build_Stub_Tag (Loc, RACW_Type),
5832 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5833 New_Occurrence_Of (Asynchronous_Flag, Loc)))))));
5835 Set_Declarations (Body_Node, Decls);
5836 Append_To (Body_Decls, Body_Node);
5837 end Add_RACW_Read_Attribute;
5839 ---------------------
5840 -- Add_RACW_To_Any --
5841 ---------------------
5843 procedure Add_RACW_To_Any
5844 (RACW_Type : Entity_Id;
5845 Body_Decls : List_Id)
5847 Loc : constant Source_Ptr := Sloc (RACW_Type);
5849 Fnam : constant Entity_Id :=
5850 Make_Defining_Identifier (Loc,
5851 Chars => New_External_Name (Chars (RACW_Type), 'T'));
5853 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5855 Stub_Elements : constant Stub_Structure :=
5856 Get_Stub_Elements (RACW_Type);
5858 Func_Spec : Node_Id;
5859 Func_Decl : Node_Id;
5860 Func_Body : Node_Id;
5863 Statements : List_Id;
5864 -- Various parts of the subprogram
5866 RACW_Parameter : constant Entity_Id :=
5867 Make_Defining_Identifier (Loc, Name_R);
5869 Reference : constant Entity_Id :=
5870 Make_Defining_Identifier
5871 (Loc, New_Internal_Name ('R'));
5872 Any : constant Entity_Id :=
5873 Make_Defining_Identifier
5874 (Loc, New_Internal_Name ('A'));
5878 Make_Function_Specification (Loc,
5879 Defining_Unit_Name =>
5881 Parameter_Specifications => New_List (
5882 Make_Parameter_Specification (Loc,
5883 Defining_Identifier =>
5886 New_Occurrence_Of (RACW_Type, Loc))),
5887 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5889 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5890 -- entity in the declaration spec, not in the body spec.
5892 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5894 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5895 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5897 if No (Body_Decls) then
5903 -- R : constant Object_Ref :=
5909 -- RPC_Receiver'Access);
5913 Make_Object_Declaration (Loc,
5914 Defining_Identifier => Reference,
5915 Constant_Present => True,
5916 Object_Definition =>
5917 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5919 Make_Function_Call (Loc,
5920 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5921 Parameter_Associations => New_List (
5922 Unchecked_Convert_To (RTE (RE_Address),
5923 New_Occurrence_Of (RACW_Parameter, Loc)),
5924 Make_String_Literal (Loc,
5925 Strval => Full_Qualified_Name
5926 (Etype (Designated_Type (RACW_Type)))),
5927 Build_Stub_Tag (Loc, RACW_Type),
5928 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5929 Make_Attribute_Reference (Loc,
5932 (Defining_Identifier
5933 (Stub_Elements.RPC_Receiver_Decl), Loc),
5934 Attribute_Name => Name_Access)))),
5936 Make_Object_Declaration (Loc,
5937 Defining_Identifier => Any,
5938 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)));
5942 -- Any := TA_ObjRef (Reference);
5943 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5946 Statements := New_List (
5947 Make_Assignment_Statement (Loc,
5948 Name => New_Occurrence_Of (Any, Loc),
5950 Make_Function_Call (Loc,
5951 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5952 Parameter_Associations => New_List (
5953 New_Occurrence_Of (Reference, Loc)))),
5955 Make_Procedure_Call_Statement (Loc,
5956 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5957 Parameter_Associations => New_List (
5958 New_Occurrence_Of (Any, Loc),
5959 Make_Selected_Component (Loc,
5961 Defining_Identifier (
5962 Stub_Elements.RPC_Receiver_Decl),
5963 Selector_Name => Name_Obj_TypeCode))),
5965 Make_Simple_Return_Statement (Loc,
5966 Expression => New_Occurrence_Of (Any, Loc)));
5969 Make_Subprogram_Body (Loc,
5970 Specification => Copy_Specification (Loc, Func_Spec),
5971 Declarations => Decls,
5972 Handled_Statement_Sequence =>
5973 Make_Handled_Sequence_Of_Statements (Loc,
5974 Statements => Statements));
5975 Append_To (Body_Decls, Func_Body);
5976 end Add_RACW_To_Any;
5978 -----------------------
5979 -- Add_RACW_TypeCode --
5980 -----------------------
5982 procedure Add_RACW_TypeCode
5983 (Designated_Type : Entity_Id;
5984 RACW_Type : Entity_Id;
5985 Body_Decls : List_Id)
5987 Loc : constant Source_Ptr := Sloc (RACW_Type);
5989 Fnam : constant Entity_Id :=
5990 Make_Defining_Identifier (Loc,
5991 Chars => New_External_Name (Chars (RACW_Type), 'Y'));
5993 Stub_Elements : constant Stub_Structure :=
5994 Stubs_Table.Get (Designated_Type);
5995 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5997 Func_Spec : Node_Id;
5998 Func_Decl : Node_Id;
5999 Func_Body : Node_Id;
6003 -- The spec for this subprogram has a dummy 'access RACW' argument,
6004 -- which serves only for overloading purposes.
6007 Make_Function_Specification (Loc,
6008 Defining_Unit_Name => Fnam,
6009 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6011 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6012 -- entity in the declaration spec, not those of the body spec.
6014 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6015 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6016 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6018 if No (Body_Decls) then
6023 Make_Subprogram_Body (Loc,
6024 Specification => Copy_Specification (Loc, Func_Spec),
6025 Declarations => Empty_List,
6026 Handled_Statement_Sequence =>
6027 Make_Handled_Sequence_Of_Statements (Loc,
6028 Statements => New_List (
6029 Make_Simple_Return_Statement (Loc,
6031 Make_Selected_Component (Loc,
6034 (Stub_Elements.RPC_Receiver_Decl),
6035 Selector_Name => Name_Obj_TypeCode)))));
6037 Append_To (Body_Decls, Func_Body);
6038 end Add_RACW_TypeCode;
6040 ------------------------------
6041 -- Add_RACW_Write_Attribute --
6042 ------------------------------
6044 procedure Add_RACW_Write_Attribute
6045 (RACW_Type : Entity_Id;
6046 Stub_Type : Entity_Id;
6047 Stub_Type_Access : Entity_Id;
6048 Body_Decls : List_Id)
6050 pragma Warnings (Off);
6051 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6052 pragma Warnings (On);
6054 Loc : constant Source_Ptr := Sloc (RACW_Type);
6056 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
6058 Stub_Elements : constant Stub_Structure :=
6059 Get_Stub_Elements (RACW_Type);
6061 Body_Node : Node_Id;
6062 Proc_Decl : Node_Id;
6063 Attr_Decl : Node_Id;
6065 Statements : constant List_Id := New_List;
6066 Pnam : constant Entity_Id :=
6067 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
6069 function Stream_Parameter return Node_Id;
6070 function Object return Node_Id;
6071 -- Functions to create occurrences of the formal parameter names
6077 function Object return Node_Id is
6079 return Make_Identifier (Loc, Name_V);
6082 ----------------------
6083 -- Stream_Parameter --
6084 ----------------------
6086 function Stream_Parameter return Node_Id is
6088 return Make_Identifier (Loc, Name_S);
6089 end Stream_Parameter;
6091 -- Start of processing for Add_RACW_Write_Attribute
6094 Build_Stream_Procedure
6095 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
6098 Make_Subprogram_Declaration (Loc,
6099 Copy_Specification (Loc, Specification (Body_Node)));
6102 Make_Attribute_Definition_Clause (Loc,
6103 Name => New_Occurrence_Of (RACW_Type, Loc),
6104 Chars => Name_Write,
6107 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6109 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6110 Insert_After (Proc_Decl, Attr_Decl);
6112 if No (Body_Decls) then
6116 Append_To (Statements,
6117 Pack_Node_Into_Stream_Access (Loc,
6118 Stream => Stream_Parameter,
6120 Make_Function_Call (Loc,
6121 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6122 Parameter_Associations => New_List (
6123 Unchecked_Convert_To (RTE (RE_Address), Object),
6124 Make_String_Literal (Loc,
6125 Strval => Full_Qualified_Name
6126 (Etype (Designated_Type (RACW_Type)))),
6127 Build_Stub_Tag (Loc, RACW_Type),
6128 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
6129 Make_Attribute_Reference (Loc,
6132 (Defining_Identifier
6133 (Stub_Elements.RPC_Receiver_Decl), Loc),
6134 Attribute_Name => Name_Access))),
6136 Etyp => RTE (RE_Object_Ref)));
6138 Append_To (Body_Decls, Body_Node);
6139 end Add_RACW_Write_Attribute;
6141 -----------------------
6142 -- Add_RAST_Features --
6143 -----------------------
6145 procedure Add_RAST_Features
6146 (Vis_Decl : Node_Id;
6147 RAS_Type : Entity_Id)
6150 Add_RAS_Access_TSS (Vis_Decl);
6152 Add_RAS_From_Any (RAS_Type);
6153 Add_RAS_TypeCode (RAS_Type);
6155 -- To_Any uses TypeCode, and therefore needs to be generated last
6157 Add_RAS_To_Any (RAS_Type);
6158 end Add_RAST_Features;
6160 ------------------------
6161 -- Add_RAS_Access_TSS --
6162 ------------------------
6164 procedure Add_RAS_Access_TSS (N : Node_Id) is
6165 Loc : constant Source_Ptr := Sloc (N);
6167 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6168 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6169 -- Ras_Type is the access to subprogram type; Fat_Type is the
6170 -- corresponding record type.
6172 RACW_Type : constant Entity_Id :=
6173 Underlying_RACW_Type (Ras_Type);
6175 Stub_Elements : constant Stub_Structure :=
6176 Get_Stub_Elements (RACW_Type);
6178 Proc : constant Entity_Id :=
6179 Make_Defining_Identifier (Loc,
6180 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6182 Proc_Spec : Node_Id;
6184 -- Formal parameters
6186 Package_Name : constant Entity_Id :=
6187 Make_Defining_Identifier (Loc,
6192 Subp_Id : constant Entity_Id :=
6193 Make_Defining_Identifier (Loc,
6196 -- Target subprogram
6198 Asynch_P : constant Entity_Id :=
6199 Make_Defining_Identifier (Loc,
6200 Chars => Name_Asynchronous);
6201 -- Is the procedure to which the 'Access applies asynchronous?
6203 All_Calls_Remote : constant Entity_Id :=
6204 Make_Defining_Identifier (Loc,
6205 Chars => Name_All_Calls_Remote);
6206 -- True if an All_Calls_Remote pragma applies to the RCI unit
6207 -- that contains the subprogram.
6209 -- Common local variables
6211 Proc_Decls : List_Id;
6212 Proc_Statements : List_Id;
6214 Subp_Ref : constant Entity_Id :=
6215 Make_Defining_Identifier (Loc, Name_R);
6216 -- Reference that designates the target subprogram (returned
6217 -- by Get_RAS_Info).
6219 Is_Local : constant Entity_Id :=
6220 Make_Defining_Identifier (Loc, Name_L);
6221 Local_Addr : constant Entity_Id :=
6222 Make_Defining_Identifier (Loc, Name_A);
6223 -- For the call to Get_Local_Address
6225 -- Additional local variables for the remote case
6227 Local_Stub : constant Entity_Id :=
6228 Make_Defining_Identifier (Loc,
6229 Chars => New_Internal_Name ('L'));
6231 Stub_Ptr : constant Entity_Id :=
6232 Make_Defining_Identifier (Loc,
6233 Chars => New_Internal_Name ('S'));
6236 (Field_Name : Name_Id;
6237 Value : Node_Id) return Node_Id;
6238 -- Construct an assignment that sets the named component in the
6246 (Field_Name : Name_Id;
6247 Value : Node_Id) return Node_Id
6251 Make_Assignment_Statement (Loc,
6253 Make_Selected_Component (Loc,
6255 Selector_Name => Field_Name),
6256 Expression => Value);
6259 -- Start of processing for Add_RAS_Access_TSS
6262 Proc_Decls := New_List (
6264 -- Common declarations
6266 Make_Object_Declaration (Loc,
6267 Defining_Identifier => Subp_Ref,
6268 Object_Definition =>
6269 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6271 Make_Object_Declaration (Loc,
6272 Defining_Identifier => Is_Local,
6273 Object_Definition =>
6274 New_Occurrence_Of (Standard_Boolean, Loc)),
6276 Make_Object_Declaration (Loc,
6277 Defining_Identifier => Local_Addr,
6278 Object_Definition =>
6279 New_Occurrence_Of (RTE (RE_Address), Loc)),
6281 Make_Object_Declaration (Loc,
6282 Defining_Identifier => Local_Stub,
6283 Aliased_Present => True,
6284 Object_Definition =>
6285 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6287 Make_Object_Declaration (Loc,
6288 Defining_Identifier => Stub_Ptr,
6289 Object_Definition =>
6290 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6292 Make_Attribute_Reference (Loc,
6293 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6294 Attribute_Name => Name_Unchecked_Access)));
6296 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6297 -- Build_Get_Unique_RP_Call needs this information
6299 -- Get_RAS_Info (Pkg, Subp, R);
6300 -- Obtain a reference to the target subprogram
6302 Proc_Statements := New_List (
6303 Make_Procedure_Call_Statement (Loc,
6304 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6305 Parameter_Associations => New_List (
6306 New_Occurrence_Of (Package_Name, Loc),
6307 New_Occurrence_Of (Subp_Id, Loc),
6308 New_Occurrence_Of (Subp_Ref, Loc))),
6310 -- Get_Local_Address (R, L, A);
6311 -- Determine whether the subprogram is local (L), and if so
6312 -- obtain the local address of its proxy (A).
6314 Make_Procedure_Call_Statement (Loc,
6315 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6316 Parameter_Associations => New_List (
6317 New_Occurrence_Of (Subp_Ref, Loc),
6318 New_Occurrence_Of (Is_Local, Loc),
6319 New_Occurrence_Of (Local_Addr, Loc))));
6321 -- Note: Here we assume that the Fat_Type is a record containing just
6322 -- an access to a proxy or stub object.
6324 Append_To (Proc_Statements,
6328 Make_Implicit_If_Statement (N,
6329 Condition => New_Occurrence_Of (Is_Local, Loc),
6331 Then_Statements => New_List (
6333 -- if A.Target = null then
6335 Make_Implicit_If_Statement (N,
6338 Make_Selected_Component (Loc,
6340 Unchecked_Convert_To
6341 (RTE (RE_RAS_Proxy_Type_Access),
6342 New_Occurrence_Of (Local_Addr, Loc)),
6343 Selector_Name => Make_Identifier (Loc, Name_Target)),
6346 Then_Statements => New_List (
6348 -- A.Target := Entity_Of (Ref);
6350 Make_Assignment_Statement (Loc,
6352 Make_Selected_Component (Loc,
6354 Unchecked_Convert_To
6355 (RTE (RE_RAS_Proxy_Type_Access),
6356 New_Occurrence_Of (Local_Addr, Loc)),
6357 Selector_Name => Make_Identifier (Loc, Name_Target)),
6359 Make_Function_Call (Loc,
6360 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6361 Parameter_Associations => New_List (
6362 New_Occurrence_Of (Subp_Ref, Loc)))),
6364 -- Inc_Usage (A.Target);
6366 Make_Procedure_Call_Statement (Loc,
6367 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6368 Parameter_Associations => New_List (
6369 Make_Selected_Component (Loc,
6371 Unchecked_Convert_To
6372 (RTE (RE_RAS_Proxy_Type_Access),
6373 New_Occurrence_Of (Local_Addr, Loc)),
6375 Make_Identifier (Loc, Name_Target)))))),
6378 -- if not All_Calls_Remote then
6379 -- return Fat_Type!(A);
6382 Make_Implicit_If_Statement (N,
6386 New_Occurrence_Of (All_Calls_Remote, Loc)),
6388 Then_Statements => New_List (
6389 Make_Simple_Return_Statement (Loc,
6391 Unchecked_Convert_To
6392 (Fat_Type, New_Occurrence_Of (Local_Addr, Loc))))))));
6394 Append_List_To (Proc_Statements, New_List (
6396 -- Stub.Target := Entity_Of (Ref);
6398 Set_Field (Name_Target,
6399 Make_Function_Call (Loc,
6400 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6401 Parameter_Associations => New_List (
6402 New_Occurrence_Of (Subp_Ref, Loc)))),
6404 -- Inc_Usage (Stub.Target);
6406 Make_Procedure_Call_Statement (Loc,
6407 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6408 Parameter_Associations => New_List (
6409 Make_Selected_Component (Loc,
6411 Selector_Name => Name_Target))),
6413 -- E.4.1(9) A remote call is asynchronous if it is a call to
6414 -- a procedure, or a call through a value of an access-to-procedure
6415 -- type, to which a pragma Asynchronous applies.
6417 -- Parameter Asynch_P is true when the procedure is asynchronous;
6418 -- Expression Asynch_T is true when the type is asynchronous.
6420 Set_Field (Name_Asynchronous,
6422 Left_Opnd => New_Occurrence_Of (Asynch_P, Loc),
6425 (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc)))));
6427 Append_List_To (Proc_Statements,
6428 Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
6430 Append_To (Proc_Statements,
6431 Make_Simple_Return_Statement (Loc,
6433 Unchecked_Convert_To (Fat_Type,
6434 New_Occurrence_Of (Stub_Ptr, Loc))));
6437 Make_Function_Specification (Loc,
6438 Defining_Unit_Name => Proc,
6439 Parameter_Specifications => New_List (
6440 Make_Parameter_Specification (Loc,
6441 Defining_Identifier => Package_Name,
6443 New_Occurrence_Of (Standard_String, Loc)),
6445 Make_Parameter_Specification (Loc,
6446 Defining_Identifier => Subp_Id,
6448 New_Occurrence_Of (Standard_String, Loc)),
6450 Make_Parameter_Specification (Loc,
6451 Defining_Identifier => Asynch_P,
6453 New_Occurrence_Of (Standard_Boolean, Loc)),
6455 Make_Parameter_Specification (Loc,
6456 Defining_Identifier => All_Calls_Remote,
6458 New_Occurrence_Of (Standard_Boolean, Loc))),
6460 Result_Definition =>
6461 New_Occurrence_Of (Fat_Type, Loc));
6463 -- Set the kind and return type of the function to prevent
6464 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6466 Set_Ekind (Proc, E_Function);
6467 Set_Etype (Proc, Fat_Type);
6470 Make_Subprogram_Body (Loc,
6471 Specification => Proc_Spec,
6472 Declarations => Proc_Decls,
6473 Handled_Statement_Sequence =>
6474 Make_Handled_Sequence_Of_Statements (Loc,
6475 Statements => Proc_Statements)));
6477 Set_TSS (Fat_Type, Proc);
6478 end Add_RAS_Access_TSS;
6480 ----------------------
6481 -- Add_RAS_From_Any --
6482 ----------------------
6484 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6485 Loc : constant Source_Ptr := Sloc (RAS_Type);
6487 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6488 Make_TSS_Name (RAS_Type, TSS_From_Any));
6490 Func_Spec : Node_Id;
6492 Statements : List_Id;
6494 Any_Parameter : constant Entity_Id :=
6495 Make_Defining_Identifier (Loc, Name_A);
6498 Statements := New_List (
6499 Make_Simple_Return_Statement (Loc,
6501 Make_Aggregate (Loc,
6502 Component_Associations => New_List (
6503 Make_Component_Association (Loc,
6504 Choices => New_List (
6505 Make_Identifier (Loc, Name_Ras)),
6507 PolyORB_Support.Helpers.Build_From_Any_Call (
6508 Underlying_RACW_Type (RAS_Type),
6509 New_Occurrence_Of (Any_Parameter, Loc),
6513 Make_Function_Specification (Loc,
6514 Defining_Unit_Name => Fnam,
6515 Parameter_Specifications => New_List (
6516 Make_Parameter_Specification (Loc,
6517 Defining_Identifier => Any_Parameter,
6518 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
6519 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6522 Make_Subprogram_Body (Loc,
6523 Specification => Func_Spec,
6524 Declarations => No_List,
6525 Handled_Statement_Sequence =>
6526 Make_Handled_Sequence_Of_Statements (Loc,
6527 Statements => Statements)));
6528 Set_TSS (RAS_Type, Fnam);
6529 end Add_RAS_From_Any;
6531 --------------------
6532 -- Add_RAS_To_Any --
6533 --------------------
6535 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6536 Loc : constant Source_Ptr := Sloc (RAS_Type);
6538 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6539 Make_TSS_Name (RAS_Type, TSS_To_Any));
6542 Statements : List_Id;
6544 Func_Spec : Node_Id;
6546 Any : constant Entity_Id :=
6547 Make_Defining_Identifier (Loc,
6548 Chars => New_Internal_Name ('A'));
6549 RAS_Parameter : constant Entity_Id :=
6550 Make_Defining_Identifier (Loc,
6551 Chars => New_Internal_Name ('R'));
6552 RACW_Parameter : constant Node_Id :=
6553 Make_Selected_Component (Loc,
6554 Prefix => RAS_Parameter,
6555 Selector_Name => Name_Ras);
6558 -- Object declarations
6560 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6562 Make_Object_Declaration (Loc,
6563 Defining_Identifier => Any,
6564 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc),
6566 PolyORB_Support.Helpers.Build_To_Any_Call
6567 (RACW_Parameter, No_List)));
6569 Statements := New_List (
6570 Make_Procedure_Call_Statement (Loc,
6571 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6572 Parameter_Associations => New_List (
6573 New_Occurrence_Of (Any, Loc),
6574 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6577 Make_Simple_Return_Statement (Loc,
6578 Expression => New_Occurrence_Of (Any, Loc)));
6581 Make_Function_Specification (Loc,
6582 Defining_Unit_Name => Fnam,
6583 Parameter_Specifications => New_List (
6584 Make_Parameter_Specification (Loc,
6585 Defining_Identifier => RAS_Parameter,
6586 Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))),
6587 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6590 Make_Subprogram_Body (Loc,
6591 Specification => Func_Spec,
6592 Declarations => Decls,
6593 Handled_Statement_Sequence =>
6594 Make_Handled_Sequence_Of_Statements (Loc,
6595 Statements => Statements)));
6596 Set_TSS (RAS_Type, Fnam);
6599 ----------------------
6600 -- Add_RAS_TypeCode --
6601 ----------------------
6603 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6604 Loc : constant Source_Ptr := Sloc (RAS_Type);
6606 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6607 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6609 Func_Spec : Node_Id;
6610 Decls : constant List_Id := New_List;
6611 Name_String : String_Id;
6612 Repo_Id_String : String_Id;
6616 Make_Function_Specification (Loc,
6617 Defining_Unit_Name => Fnam,
6618 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6620 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6621 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6624 Make_Subprogram_Body (Loc,
6625 Specification => Func_Spec,
6626 Declarations => Decls,
6627 Handled_Statement_Sequence =>
6628 Make_Handled_Sequence_Of_Statements (Loc,
6629 Statements => New_List (
6630 Make_Simple_Return_Statement (Loc,
6632 Make_Function_Call (Loc,
6633 Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6634 Parameter_Associations => New_List (
6635 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6636 Make_Aggregate (Loc,
6639 Make_Function_Call (Loc,
6642 (RTE (RE_TA_String), Loc),
6643 Parameter_Associations => New_List (
6644 Make_String_Literal (Loc, Name_String))),
6645 Make_Function_Call (Loc,
6648 (RTE (RE_TA_String), Loc),
6649 Parameter_Associations => New_List (
6650 Make_String_Literal (Loc,
6651 Strval => Repo_Id_String))))))))))));
6652 Set_TSS (RAS_Type, Fnam);
6653 end Add_RAS_TypeCode;
6655 -----------------------------------------
6656 -- Add_Receiving_Stubs_To_Declarations --
6657 -----------------------------------------
6659 procedure Add_Receiving_Stubs_To_Declarations
6660 (Pkg_Spec : Node_Id;
6664 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6666 Pkg_RPC_Receiver : constant Entity_Id :=
6667 Make_Defining_Identifier (Loc,
6668 New_Internal_Name ('H'));
6669 Pkg_RPC_Receiver_Object : Node_Id;
6670 Pkg_RPC_Receiver_Body : Node_Id;
6671 Pkg_RPC_Receiver_Decls : List_Id;
6672 Pkg_RPC_Receiver_Statements : List_Id;
6674 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6675 -- A Pkg_RPC_Receiver is built to decode the request
6678 -- Request object received from neutral layer
6680 Subp_Id : Entity_Id;
6681 -- Subprogram identifier as received from the neutral
6682 -- distribution core.
6684 Subp_Index : Entity_Id;
6685 -- Internal index as determined by matching either the method name
6686 -- from the request structure, or the local subprogram address (in
6689 Is_Local : constant Entity_Id :=
6690 Make_Defining_Identifier (Loc,
6691 Chars => New_Internal_Name ('L'));
6693 Local_Address : constant Entity_Id :=
6694 Make_Defining_Identifier (Loc,
6695 Chars => New_Internal_Name ('A'));
6696 -- Address of a local subprogram designated by a reference
6697 -- corresponding to a RAS.
6699 Dispatch_On_Address : constant List_Id := New_List;
6700 Dispatch_On_Name : constant List_Id := New_List;
6702 Current_Declaration : Node_Id;
6703 Current_Stubs : Node_Id;
6704 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6706 Subp_Info_Array : constant Entity_Id :=
6707 Make_Defining_Identifier (Loc,
6708 Chars => New_Internal_Name ('I'));
6710 Subp_Info_List : constant List_Id := New_List;
6712 Register_Pkg_Actuals : constant List_Id := New_List;
6714 All_Calls_Remote_E : Entity_Id;
6716 procedure Append_Stubs_To
6717 (RPC_Receiver_Cases : List_Id;
6718 Declaration : Node_Id;
6721 Subp_Dist_Name : Entity_Id;
6722 Subp_Proxy_Addr : Entity_Id);
6723 -- Add one case to the specified RPC receiver case list associating
6724 -- Subprogram_Number with the subprogram declared by Declaration, for
6725 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6726 -- subprogram index. Subp_Dist_Name is the string used to call the
6727 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6728 -- object, used in the context of calls through remote
6729 -- access-to-subprogram types.
6731 ---------------------
6732 -- Append_Stubs_To --
6733 ---------------------
6735 procedure Append_Stubs_To
6736 (RPC_Receiver_Cases : List_Id;
6737 Declaration : Node_Id;
6740 Subp_Dist_Name : Entity_Id;
6741 Subp_Proxy_Addr : Entity_Id)
6743 Case_Stmts : List_Id;
6745 Case_Stmts := New_List (
6746 Make_Procedure_Call_Statement (Loc,
6749 Defining_Entity (Stubs), Loc),
6750 Parameter_Associations =>
6751 New_List (New_Occurrence_Of (Request, Loc))));
6753 if Nkind (Specification (Declaration)) = N_Function_Specification
6755 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6757 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6760 Append_To (RPC_Receiver_Cases,
6761 Make_Case_Statement_Alternative (Loc,
6763 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6764 Statements => Case_Stmts));
6766 Append_To (Dispatch_On_Name,
6767 Make_Elsif_Part (Loc,
6769 Make_Function_Call (Loc,
6771 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6772 Parameter_Associations => New_List (
6773 New_Occurrence_Of (Subp_Id, Loc),
6774 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6776 Then_Statements => New_List (
6777 Make_Assignment_Statement (Loc,
6778 New_Occurrence_Of (Subp_Index, Loc),
6779 Make_Integer_Literal (Loc, Subp_Number)))));
6781 Append_To (Dispatch_On_Address,
6782 Make_Elsif_Part (Loc,
6785 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6786 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6788 Then_Statements => New_List (
6789 Make_Assignment_Statement (Loc,
6790 New_Occurrence_Of (Subp_Index, Loc),
6791 Make_Integer_Literal (Loc, Subp_Number)))));
6792 end Append_Stubs_To;
6794 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6797 -- Building receiving stubs consist in several operations:
6799 -- - a package RPC receiver must be built. This subprogram
6800 -- will get a Subprogram_Id from the incoming stream
6801 -- and will dispatch the call to the right subprogram;
6803 -- - a receiving stub for each subprogram visible in the package
6804 -- spec. This stub will read all the parameters from the stream,
6805 -- and put the result as well as the exception occurrence in the
6808 -- - a dummy package with an empty spec and a body made of an
6809 -- elaboration part, whose job is to register the receiving
6810 -- part of this RCI package on the name server. This is done
6811 -- by calling System.Partition_Interface.Register_Receiving_Stub.
6813 Build_RPC_Receiver_Body (
6814 RPC_Receiver => Pkg_RPC_Receiver,
6817 Subp_Index => Subp_Index,
6818 Stmts => Pkg_RPC_Receiver_Statements,
6819 Decl => Pkg_RPC_Receiver_Body);
6820 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6822 -- Extract local address information from the target reference:
6823 -- if non-null, that means that this is a reference that denotes
6824 -- one particular operation, and hence that the operation name
6825 -- must not be taken into account for dispatching.
6827 Append_To (Pkg_RPC_Receiver_Decls,
6828 Make_Object_Declaration (Loc,
6829 Defining_Identifier => Is_Local,
6830 Object_Definition =>
6831 New_Occurrence_Of (Standard_Boolean, Loc)));
6833 Append_To (Pkg_RPC_Receiver_Decls,
6834 Make_Object_Declaration (Loc,
6835 Defining_Identifier => Local_Address,
6836 Object_Definition =>
6837 New_Occurrence_Of (RTE (RE_Address), Loc)));
6839 Append_To (Pkg_RPC_Receiver_Statements,
6840 Make_Procedure_Call_Statement (Loc,
6841 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6842 Parameter_Associations => New_List (
6843 Make_Selected_Component (Loc,
6845 Selector_Name => Name_Target),
6846 New_Occurrence_Of (Is_Local, Loc),
6847 New_Occurrence_Of (Local_Address, Loc))));
6849 -- For each subprogram, the receiving stub will be built and a
6850 -- case statement will be made on the Subprogram_Id to dispatch
6851 -- to the right subprogram.
6853 All_Calls_Remote_E := Boolean_Literals (
6854 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6856 Overload_Counter_Table.Reset;
6857 Reserve_NamingContext_Methods;
6859 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
6860 while Present (Current_Declaration) loop
6861 if Nkind (Current_Declaration) = N_Subprogram_Declaration
6862 and then Comes_From_Source (Current_Declaration)
6865 Loc : constant Source_Ptr := Sloc (Current_Declaration);
6866 -- While specifically processing Current_Declaration, use
6867 -- its Sloc as the location of all generated nodes.
6869 Subp_Def : constant Entity_Id :=
6871 (Specification (Current_Declaration));
6873 Subp_Val : String_Id;
6875 Subp_Dist_Name : constant Entity_Id :=
6876 Make_Defining_Identifier (Loc,
6879 (Related_Id => Chars (Subp_Def),
6881 Suffix_Index => -1));
6883 Proxy_Object_Addr : Entity_Id;
6886 -- Build receiving stub
6889 Build_Subprogram_Receiving_Stubs
6890 (Vis_Decl => Current_Declaration,
6892 Nkind (Specification (Current_Declaration)) =
6893 N_Procedure_Specification
6894 and then Is_Asynchronous (Subp_Def));
6896 Append_To (Decls, Current_Stubs);
6897 Analyze (Current_Stubs);
6901 Add_RAS_Proxy_And_Analyze (Decls,
6902 Vis_Decl => Current_Declaration,
6903 All_Calls_Remote_E => All_Calls_Remote_E,
6904 Proxy_Object_Addr => Proxy_Object_Addr);
6906 -- Compute distribution identifier
6908 Assign_Subprogram_Identifier
6910 Current_Subprogram_Number,
6914 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
6917 Make_Object_Declaration (Loc,
6918 Defining_Identifier => Subp_Dist_Name,
6919 Constant_Present => True,
6920 Object_Definition =>
6921 New_Occurrence_Of (Standard_String, Loc),
6923 Make_String_Literal (Loc, Subp_Val)));
6924 Analyze (Last (Decls));
6926 -- Add subprogram descriptor (RCI_Subp_Info) to the
6927 -- subprograms table for this receiver. The aggregate
6928 -- below must be kept consistent with the declaration
6929 -- of type RCI_Subp_Info in System.Partition_Interface.
6931 Append_To (Subp_Info_List,
6932 Make_Component_Association (Loc,
6933 Choices => New_List (
6934 Make_Integer_Literal (Loc, Current_Subprogram_Number)),
6937 Make_Aggregate (Loc,
6938 Expressions => New_List (
6939 Make_Attribute_Reference (Loc,
6941 New_Occurrence_Of (Subp_Dist_Name, Loc),
6942 Attribute_Name => Name_Address),
6944 Make_Attribute_Reference (Loc,
6946 New_Occurrence_Of (Subp_Dist_Name, Loc),
6947 Attribute_Name => Name_Length),
6949 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
6951 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6952 Declaration => Current_Declaration,
6953 Stubs => Current_Stubs,
6954 Subp_Number => Current_Subprogram_Number,
6955 Subp_Dist_Name => Subp_Dist_Name,
6956 Subp_Proxy_Addr => Proxy_Object_Addr);
6959 Current_Subprogram_Number := Current_Subprogram_Number + 1;
6962 Next (Current_Declaration);
6966 Make_Object_Declaration (Loc,
6967 Defining_Identifier => Subp_Info_Array,
6968 Constant_Present => True,
6969 Aliased_Present => True,
6970 Object_Definition =>
6971 Make_Subtype_Indication (Loc,
6973 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6975 Make_Index_Or_Discriminant_Constraint (Loc,
6979 Make_Integer_Literal (Loc,
6980 Intval => First_RCI_Subprogram_Id),
6982 Make_Integer_Literal (Loc,
6984 First_RCI_Subprogram_Id
6985 + List_Length (Subp_Info_List) - 1)))))));
6987 if Present (First (Subp_Info_List)) then
6988 Set_Expression (Last (Decls),
6989 Make_Aggregate (Loc,
6990 Component_Associations => Subp_Info_List));
6992 -- Generate the dispatch statement to determine the subprogram id
6993 -- of the called subprogram.
6995 -- We first test whether the reference that was used to make the
6996 -- call was the base RCI reference (in which case Local_Address is
6997 -- zero, and the method identifier from the request must be used
6998 -- to determine which subprogram is called) or a reference
6999 -- identifying one particular subprogram (in which case
7000 -- Local_Address is the address of that subprogram, and the
7001 -- method name from the request is ignored). The latter occurs
7002 -- for the case of a call through a remote access-to-subprogram.
7004 -- In each case, cascaded elsifs are used to determine the proper
7005 -- subprogram index. Using hash tables might be more efficient.
7007 Append_To (Pkg_RPC_Receiver_Statements,
7008 Make_Implicit_If_Statement (Pkg_Spec,
7011 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
7012 Right_Opnd => New_Occurrence_Of
7013 (RTE (RE_Null_Address), Loc)),
7015 Then_Statements => New_List (
7016 Make_Implicit_If_Statement (Pkg_Spec,
7017 Condition => New_Occurrence_Of (Standard_False, Loc),
7018 Then_Statements => New_List (
7019 Make_Null_Statement (Loc)),
7020 Elsif_Parts => Dispatch_On_Address)),
7022 Else_Statements => New_List (
7023 Make_Implicit_If_Statement (Pkg_Spec,
7024 Condition => New_Occurrence_Of (Standard_False, Loc),
7025 Then_Statements => New_List (Make_Null_Statement (Loc)),
7026 Elsif_Parts => Dispatch_On_Name))));
7029 -- For a degenerate RCI with no visible subprograms,
7030 -- Subp_Info_List has zero length, and the declaration is for an
7031 -- empty array, in which case no initialization aggregate must be
7032 -- generated. We do not generate a Dispatch_Statement either.
7034 -- No initialization provided: remove CONSTANT so that the
7035 -- declaration is not an incomplete deferred constant.
7037 Set_Constant_Present (Last (Decls), False);
7040 -- Analyze Subp_Info_Array declaration
7042 Analyze (Last (Decls));
7044 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7045 -- rather than raising an exception since we do not want someone
7046 -- to crash a remote partition by sending invalid subprogram ids.
7047 -- This is consistent with the other parts of the case statement
7048 -- since even in presence of incorrect parameters in the stream,
7049 -- every exception will be caught and (if the subprogram is not an
7050 -- APC) put into the result stream and sent away.
7052 Append_To (Pkg_RPC_Receiver_Cases,
7053 Make_Case_Statement_Alternative (Loc,
7054 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
7055 Statements => New_List (Make_Null_Statement (Loc))));
7057 Append_To (Pkg_RPC_Receiver_Statements,
7058 Make_Case_Statement (Loc,
7059 Expression => New_Occurrence_Of (Subp_Index, Loc),
7060 Alternatives => Pkg_RPC_Receiver_Cases));
7062 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7065 Append_To (Decls, Pkg_RPC_Receiver_Body);
7066 Analyze (Last (Decls));
7068 Pkg_RPC_Receiver_Object :=
7069 Make_Object_Declaration (Loc,
7070 Defining_Identifier =>
7071 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
7072 Aliased_Present => True,
7073 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
7074 Append_To (Decls, Pkg_RPC_Receiver_Object);
7075 Analyze (Last (Decls));
7077 Get_Library_Unit_Name_String (Pkg_Spec);
7081 Append_To (Register_Pkg_Actuals,
7082 Make_String_Literal (Loc,
7083 Strval => String_From_Name_Buffer));
7087 Append_To (Register_Pkg_Actuals,
7088 Make_Attribute_Reference (Loc,
7091 (Defining_Entity (Pkg_Spec), Loc),
7092 Attribute_Name => Name_Version));
7096 Append_To (Register_Pkg_Actuals,
7097 Make_Attribute_Reference (Loc,
7099 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7100 Attribute_Name => Name_Access));
7104 Append_To (Register_Pkg_Actuals,
7105 Make_Attribute_Reference (Loc,
7108 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc),
7109 Attribute_Name => Name_Access));
7113 Append_To (Register_Pkg_Actuals,
7114 Make_Attribute_Reference (Loc,
7115 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7116 Attribute_Name => Name_Address));
7120 Append_To (Register_Pkg_Actuals,
7121 Make_Attribute_Reference (Loc,
7122 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7123 Attribute_Name => Name_Length));
7125 -- Is_All_Calls_Remote
7127 Append_To (Register_Pkg_Actuals,
7128 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7133 Make_Procedure_Call_Statement (Loc,
7135 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7136 Parameter_Associations => Register_Pkg_Actuals));
7137 Analyze (Last (Stmts));
7138 end Add_Receiving_Stubs_To_Declarations;
7140 ---------------------------------
7141 -- Build_General_Calling_Stubs --
7142 ---------------------------------
7144 procedure Build_General_Calling_Stubs
7146 Statements : List_Id;
7147 Target_Object : Node_Id;
7148 Subprogram_Id : Node_Id;
7149 Asynchronous : Node_Id := Empty;
7150 Is_Known_Asynchronous : Boolean := False;
7151 Is_Known_Non_Asynchronous : Boolean := False;
7152 Is_Function : Boolean;
7154 Stub_Type : Entity_Id := Empty;
7155 RACW_Type : Entity_Id := Empty;
7158 Loc : constant Source_Ptr := Sloc (Nod);
7160 Arguments : Node_Id;
7161 -- Name of the named values list used to transmit parameters
7162 -- to the remote package
7165 -- The request object constructed by these stubs
7168 -- Name of the result named value (in non-APC cases) which get the
7169 -- result of the remote subprogram.
7171 Result_TC : Node_Id;
7172 -- Typecode expression for the result of the request (void
7173 -- typecode for procedures).
7175 Exception_Return_Parameter : Node_Id;
7176 -- Name of the parameter which will hold the exception sent by the
7177 -- remote subprogram.
7179 Current_Parameter : Node_Id;
7180 -- Current parameter being handled
7182 Ordered_Parameters_List : constant List_Id :=
7183 Build_Ordered_Parameters_List (Spec);
7185 Asynchronous_P : Node_Id;
7186 -- A Boolean expression indicating whether this call is asynchronous
7188 Asynchronous_Statements : List_Id := No_List;
7189 Non_Asynchronous_Statements : List_Id := No_List;
7190 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7192 Extra_Formal_Statements : constant List_Id := New_List;
7193 -- List of statements for extra formal parameters. It will appear
7194 -- after the regular statements for writing out parameters.
7196 After_Statements : constant List_Id := New_List;
7197 -- Statements to be executed after call returns (to assign
7198 -- in out or out parameter values).
7201 -- The type of the formal parameter being processed
7203 Is_Controlling_Formal : Boolean;
7204 Is_First_Controlling_Formal : Boolean;
7205 First_Controlling_Formal_Seen : Boolean := False;
7206 -- Controlling formal parameters of distributed object primitives
7207 -- require special handling, and the first such parameter needs even
7208 -- more special handling.
7211 -- ??? document general form of stub subprograms for the PolyORB case
7212 Request := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7215 Make_Object_Declaration (Loc,
7216 Defining_Identifier => Request,
7217 Aliased_Present => False,
7218 Object_Definition =>
7219 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
7222 Make_Defining_Identifier (Loc,
7223 Chars => New_Internal_Name ('R'));
7227 PolyORB_Support.Helpers.Build_TypeCode_Call
7228 (Loc, Etype (Result_Definition (Spec)), Decls);
7230 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7234 Make_Object_Declaration (Loc,
7235 Defining_Identifier => Result,
7236 Aliased_Present => False,
7237 Object_Definition =>
7238 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7240 Make_Aggregate (Loc,
7241 Component_Associations => New_List (
7242 Make_Component_Association (Loc,
7243 Choices => New_List (Make_Identifier (Loc, Name_Name)),
7245 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7246 Make_Component_Association (Loc,
7247 Choices => New_List (
7248 Make_Identifier (Loc, Name_Argument)),
7250 Make_Function_Call (Loc,
7251 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7252 Parameter_Associations => New_List (Result_TC))),
7253 Make_Component_Association (Loc,
7254 Choices => New_List (
7255 Make_Identifier (Loc, Name_Arg_Modes)),
7256 Expression => Make_Integer_Literal (Loc, 0))))));
7258 if not Is_Known_Asynchronous then
7259 Exception_Return_Parameter :=
7260 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7263 Make_Object_Declaration (Loc,
7264 Defining_Identifier => Exception_Return_Parameter,
7265 Object_Definition =>
7266 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7269 Exception_Return_Parameter := Empty;
7272 -- Initialize and fill in arguments list
7275 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7276 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7278 Current_Parameter := First (Ordered_Parameters_List);
7279 while Present (Current_Parameter) loop
7280 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7281 Is_Controlling_Formal := True;
7282 Is_First_Controlling_Formal :=
7283 not First_Controlling_Formal_Seen;
7284 First_Controlling_Formal_Seen := True;
7287 Is_Controlling_Formal := False;
7288 Is_First_Controlling_Formal := False;
7291 if Is_Controlling_Formal then
7293 -- For a controlling formal argument, we send its reference
7298 Etyp := Etype (Parameter_Type (Current_Parameter));
7301 -- The first controlling formal parameter is treated specially:
7302 -- it is used to set the target object of the call.
7304 if not Is_First_Controlling_Formal then
7306 Constrained : constant Boolean :=
7307 Is_Constrained (Etyp)
7308 or else Is_Elementary_Type (Etyp);
7310 Any : constant Entity_Id :=
7311 Make_Defining_Identifier (Loc,
7312 New_Internal_Name ('A'));
7314 Actual_Parameter : Node_Id :=
7316 Defining_Identifier (
7317 Current_Parameter), Loc);
7322 if Is_Controlling_Formal then
7324 -- For a controlling formal parameter (other than the
7325 -- first one), use the corresponding RACW. If the
7326 -- parameter is not an anonymous access parameter, that
7327 -- involves taking its 'Unrestricted_Access.
7329 if Nkind (Parameter_Type (Current_Parameter))
7330 = N_Access_Definition
7332 Actual_Parameter := OK_Convert_To
7333 (Etyp, Actual_Parameter);
7335 Actual_Parameter := OK_Convert_To (Etyp,
7336 Make_Attribute_Reference (Loc,
7337 Prefix => Actual_Parameter,
7338 Attribute_Name => Name_Unrestricted_Access));
7343 if In_Present (Current_Parameter)
7344 or else not Out_Present (Current_Parameter)
7345 or else not Constrained
7346 or else Is_Controlling_Formal
7348 -- The parameter has an input value, is constrained at
7349 -- runtime by an input value, or is a controlling formal
7350 -- parameter (always passed as a reference) other than
7353 Expr := PolyORB_Support.Helpers.Build_To_Any_Call
7354 (Actual_Parameter, Decls);
7357 Expr := Make_Function_Call (Loc,
7358 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7359 Parameter_Associations => New_List (
7360 PolyORB_Support.Helpers.Build_TypeCode_Call
7361 (Loc, Etyp, Decls)));
7365 Make_Object_Declaration (Loc,
7366 Defining_Identifier => Any,
7367 Aliased_Present => False,
7368 Object_Definition =>
7369 New_Occurrence_Of (RTE (RE_Any), Loc),
7370 Expression => Expr));
7372 Append_To (Statements,
7373 Add_Parameter_To_NVList (Loc,
7374 Parameter => Current_Parameter,
7375 NVList => Arguments,
7376 Constrained => Constrained,
7379 if Out_Present (Current_Parameter)
7380 and then not Is_Controlling_Formal
7382 Append_To (After_Statements,
7383 Make_Assignment_Statement (Loc,
7386 Defining_Identifier (Current_Parameter), Loc),
7388 PolyORB_Support.Helpers.Build_From_Any_Call
7389 (Etype (Parameter_Type (Current_Parameter)),
7390 New_Occurrence_Of (Any, Loc),
7397 -- If the current parameter has a dynamic constrained status, then
7398 -- this status is transmitted as well.
7399 -- This should be done for accessibility as well ???
7401 if Nkind (Parameter_Type (Current_Parameter)) /=
7403 and then Need_Extra_Constrained (Current_Parameter)
7405 -- In this block, we do not use the extra formal that has been
7406 -- created because it does not exist at the time of expansion
7407 -- when building calling stubs for remote access to subprogram
7408 -- types. We create an extra variable of this type and push it
7409 -- in the stream after the regular parameters.
7412 Extra_Any_Parameter : constant Entity_Id :=
7413 Make_Defining_Identifier
7414 (Loc, New_Internal_Name ('P'));
7416 Parameter_Exp : constant Node_Id :=
7417 Make_Attribute_Reference (Loc,
7418 Prefix => New_Occurrence_Of (
7419 Defining_Identifier (Current_Parameter), Loc),
7420 Attribute_Name => Name_Constrained);
7423 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7426 Make_Object_Declaration (Loc,
7427 Defining_Identifier => Extra_Any_Parameter,
7428 Aliased_Present => False,
7429 Object_Definition =>
7430 New_Occurrence_Of (RTE (RE_Any), Loc),
7432 PolyORB_Support.Helpers.Build_To_Any_Call
7433 (Parameter_Exp, Decls)));
7435 Append_To (Extra_Formal_Statements,
7436 Add_Parameter_To_NVList (Loc,
7437 Parameter => Extra_Any_Parameter,
7438 NVList => Arguments,
7439 Constrained => True,
7440 Any => Extra_Any_Parameter));
7444 Next (Current_Parameter);
7447 -- Append the formal statements list to the statements
7449 Append_List_To (Statements, Extra_Formal_Statements);
7451 Append_To (Statements,
7452 Make_Procedure_Call_Statement (Loc,
7454 New_Occurrence_Of (RTE (RE_Request_Create), Loc),
7456 Parameter_Associations => New_List (
7459 New_Occurrence_Of (Arguments, Loc),
7460 New_Occurrence_Of (Result, Loc),
7461 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7463 Append_To (Parameter_Associations (Last (Statements)),
7464 New_Occurrence_Of (Request, Loc));
7467 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7469 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7472 (Boolean_Literals (Is_Known_Asynchronous), Loc);
7475 pragma Assert (Present (Asynchronous));
7476 Asynchronous_P := New_Copy_Tree (Asynchronous);
7478 -- The expression node Asynchronous will be used to build an 'if'
7479 -- statement at the end of Build_General_Calling_Stubs: we need to
7480 -- make a copy here.
7483 Append_To (Parameter_Associations (Last (Statements)),
7484 Make_Indexed_Component (Loc,
7487 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7488 Expressions => New_List (Asynchronous_P)));
7490 Append_To (Statements,
7491 Make_Procedure_Call_Statement (Loc,
7493 New_Occurrence_Of (RTE (RE_Request_Invoke), Loc),
7494 Parameter_Associations => New_List (
7495 New_Occurrence_Of (Request, Loc))));
7497 Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7498 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7500 if not Is_Known_Asynchronous then
7502 -- Reraise an exception occurrence from the completed request.
7503 -- If the exception occurrence is empty, this is a no-op.
7505 Append_To (Non_Asynchronous_Statements,
7506 Make_Procedure_Call_Statement (Loc,
7508 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7509 Parameter_Associations => New_List (
7510 New_Occurrence_Of (Request, Loc))));
7514 -- If this is a function call, read the value and return it
7516 Append_To (Non_Asynchronous_Statements,
7517 Make_Tag_Check (Loc,
7518 Make_Simple_Return_Statement (Loc,
7519 PolyORB_Support.Helpers.Build_From_Any_Call
7520 (Etype (Result_Definition (Spec)),
7521 Make_Selected_Component (Loc,
7523 Selector_Name => Name_Argument),
7528 Append_List_To (Non_Asynchronous_Statements, After_Statements);
7530 if Is_Known_Asynchronous then
7531 Append_List_To (Statements, Asynchronous_Statements);
7533 elsif Is_Known_Non_Asynchronous then
7534 Append_List_To (Statements, Non_Asynchronous_Statements);
7537 pragma Assert (Present (Asynchronous));
7538 Append_To (Statements,
7539 Make_Implicit_If_Statement (Nod,
7540 Condition => Asynchronous,
7541 Then_Statements => Asynchronous_Statements,
7542 Else_Statements => Non_Asynchronous_Statements));
7544 end Build_General_Calling_Stubs;
7546 -----------------------
7547 -- Build_Stub_Target --
7548 -----------------------
7550 function Build_Stub_Target
7553 RCI_Locator : Entity_Id;
7554 Controlling_Parameter : Entity_Id) return RPC_Target
7556 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7557 Target_Reference : constant Entity_Id :=
7558 Make_Defining_Identifier (Loc,
7559 New_Internal_Name ('T'));
7561 if Present (Controlling_Parameter) then
7563 Make_Object_Declaration (Loc,
7564 Defining_Identifier => Target_Reference,
7566 Object_Definition =>
7567 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7570 Make_Function_Call (Loc,
7572 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7573 Parameter_Associations => New_List (
7574 Make_Selected_Component (Loc,
7575 Prefix => Controlling_Parameter,
7576 Selector_Name => Name_Target)))));
7578 -- Note: Controlling_Parameter has the same components as
7579 -- System.Partition_Interface.RACW_Stub_Type.
7581 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7584 Target_Info.Object :=
7585 Make_Selected_Component (Loc,
7586 Prefix => Make_Identifier (Loc, Chars (RCI_Locator)),
7588 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7592 end Build_Stub_Target;
7594 ---------------------
7595 -- Build_Stub_Type --
7596 ---------------------
7598 procedure Build_Stub_Type
7599 (RACW_Type : Entity_Id;
7600 Stub_Type : Entity_Id;
7601 Stub_Type_Decl : out Node_Id;
7602 RPC_Receiver_Decl : out Node_Id)
7604 Loc : constant Source_Ptr := Sloc (Stub_Type);
7605 pragma Warnings (Off);
7606 pragma Unreferenced (RACW_Type);
7607 pragma Warnings (On);
7611 Make_Full_Type_Declaration (Loc,
7612 Defining_Identifier => Stub_Type,
7614 Make_Record_Definition (Loc,
7615 Tagged_Present => True,
7616 Limited_Present => True,
7618 Make_Component_List (Loc,
7619 Component_Items => New_List (
7621 Make_Component_Declaration (Loc,
7622 Defining_Identifier =>
7623 Make_Defining_Identifier (Loc, Name_Target),
7624 Component_Definition =>
7625 Make_Component_Definition (Loc,
7626 Aliased_Present => False,
7627 Subtype_Indication =>
7628 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7630 Make_Component_Declaration (Loc,
7631 Defining_Identifier =>
7632 Make_Defining_Identifier (Loc, Name_Asynchronous),
7634 Component_Definition =>
7635 Make_Component_Definition (Loc,
7636 Aliased_Present => False,
7637 Subtype_Indication =>
7638 New_Occurrence_Of (Standard_Boolean, Loc)))))));
7640 RPC_Receiver_Decl :=
7641 Make_Object_Declaration (Loc,
7642 Defining_Identifier => Make_Defining_Identifier (Loc,
7643 New_Internal_Name ('R')),
7644 Aliased_Present => True,
7645 Object_Definition =>
7646 New_Occurrence_Of (RTE (RE_Servant), Loc));
7647 end Build_Stub_Type;
7649 -----------------------------
7650 -- Build_RPC_Receiver_Body --
7651 -----------------------------
7653 procedure Build_RPC_Receiver_Body
7654 (RPC_Receiver : Entity_Id;
7655 Request : out Entity_Id;
7656 Subp_Id : out Entity_Id;
7657 Subp_Index : out Entity_Id;
7658 Stmts : out List_Id;
7661 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7663 RPC_Receiver_Spec : Node_Id;
7664 RPC_Receiver_Decls : List_Id;
7667 Request := Make_Defining_Identifier (Loc, Name_R);
7669 RPC_Receiver_Spec :=
7670 Build_RPC_Receiver_Specification (
7671 RPC_Receiver => RPC_Receiver,
7672 Request_Parameter => Request);
7674 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7675 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7677 RPC_Receiver_Decls := New_List (
7678 Make_Object_Renaming_Declaration (Loc,
7679 Defining_Identifier => Subp_Id,
7680 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7682 Make_Explicit_Dereference (Loc,
7684 Make_Selected_Component (Loc,
7686 Selector_Name => Name_Operation))),
7688 Make_Object_Declaration (Loc,
7689 Defining_Identifier => Subp_Index,
7690 Object_Definition =>
7691 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7693 Make_Attribute_Reference (Loc,
7695 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7696 Attribute_Name => Name_Last)));
7701 Make_Subprogram_Body (Loc,
7702 Specification => RPC_Receiver_Spec,
7703 Declarations => RPC_Receiver_Decls,
7704 Handled_Statement_Sequence =>
7705 Make_Handled_Sequence_Of_Statements (Loc,
7706 Statements => Stmts));
7707 end Build_RPC_Receiver_Body;
7709 --------------------------------------
7710 -- Build_Subprogram_Receiving_Stubs --
7711 --------------------------------------
7713 function Build_Subprogram_Receiving_Stubs
7714 (Vis_Decl : Node_Id;
7715 Asynchronous : Boolean;
7716 Dynamically_Asynchronous : Boolean := False;
7717 Stub_Type : Entity_Id := Empty;
7718 RACW_Type : Entity_Id := Empty;
7719 Parent_Primitive : Entity_Id := Empty) return Node_Id
7721 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7723 Request_Parameter : constant Entity_Id :=
7724 Make_Defining_Identifier (Loc,
7725 New_Internal_Name ('R'));
7726 -- Formal parameter for receiving stubs: a descriptor for an incoming
7729 Outer_Decls : constant List_Id := New_List;
7730 -- At the outermost level, an NVList and Any's are declared for all
7731 -- parameters. The Dynamic_Async flag also needs to be declared there
7732 -- to be visible from the exception handling code.
7734 Outer_Statements : constant List_Id := New_List;
7735 -- Statements that occur prior to the declaration of the actual
7736 -- parameter variables.
7738 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7739 -- Statements concerning extra formal parameters, prior to the
7740 -- declaration of the actual parameter variables.
7742 Decls : constant List_Id := New_List;
7743 -- All the parameters will get declared before calling the real
7744 -- subprograms. Also the out parameters will be declared.
7745 -- At this level, parameters may be unconstrained.
7747 Statements : constant List_Id := New_List;
7749 After_Statements : constant List_Id := New_List;
7750 -- Statements to be executed after the subprogram call
7752 Inner_Decls : List_Id := No_List;
7753 -- In case of a function, the inner declarations are needed since
7754 -- the result may be unconstrained.
7756 Excep_Handlers : List_Id := No_List;
7758 Parameter_List : constant List_Id := New_List;
7759 -- List of parameters to be passed to the subprogram
7761 First_Controlling_Formal_Seen : Boolean := False;
7763 Current_Parameter : Node_Id;
7765 Ordered_Parameters_List : constant List_Id :=
7766 Build_Ordered_Parameters_List
7767 (Specification (Vis_Decl));
7769 Arguments : constant Entity_Id :=
7770 Make_Defining_Identifier (Loc,
7771 New_Internal_Name ('A'));
7772 -- Name of the named values list used to retrieve parameters
7774 Subp_Spec : Node_Id;
7775 -- Subprogram specification
7777 Called_Subprogram : Node_Id;
7778 -- The subprogram to call
7781 if Present (RACW_Type) then
7782 Called_Subprogram :=
7783 New_Occurrence_Of (Parent_Primitive, Loc);
7785 Called_Subprogram :=
7787 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7790 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7792 -- Loop through every parameter and get its value from the stream. If
7793 -- the parameter is unconstrained, then the parameter is read using
7794 -- 'Input at the point of declaration.
7796 Current_Parameter := First (Ordered_Parameters_List);
7797 while Present (Current_Parameter) loop
7800 Constrained : Boolean;
7801 Any : Entity_Id := Empty;
7802 Object : constant Entity_Id :=
7803 Make_Defining_Identifier (Loc,
7804 Chars => New_Internal_Name ('P'));
7805 Expr : Node_Id := Empty;
7807 Is_Controlling_Formal : constant Boolean :=
7808 Is_RACW_Controlling_Formal
7809 (Current_Parameter, Stub_Type);
7811 Is_First_Controlling_Formal : Boolean := False;
7813 Need_Extra_Constrained : Boolean;
7814 -- True when an extra constrained actual is required
7817 if Is_Controlling_Formal then
7819 -- Controlling formals in distributed object primitive
7820 -- operations are handled specially:
7821 -- - the first controlling formal is used as the
7822 -- target of the call;
7823 -- - the remaining controlling formals are transmitted
7827 Is_First_Controlling_Formal :=
7828 not First_Controlling_Formal_Seen;
7829 First_Controlling_Formal_Seen := True;
7832 Etyp := Etype (Parameter_Type (Current_Parameter));
7836 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
7838 if not Is_First_Controlling_Formal then
7840 Make_Defining_Identifier (Loc,
7841 Chars => New_Internal_Name ('A'));
7843 Append_To (Outer_Decls,
7844 Make_Object_Declaration (Loc,
7845 Defining_Identifier => Any,
7846 Object_Definition =>
7847 New_Occurrence_Of (RTE (RE_Any), Loc),
7849 Make_Function_Call (Loc,
7850 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7851 Parameter_Associations => New_List (
7852 PolyORB_Support.Helpers.Build_TypeCode_Call
7853 (Loc, Etyp, Outer_Decls)))));
7855 Append_To (Outer_Statements,
7856 Add_Parameter_To_NVList (Loc,
7857 Parameter => Current_Parameter,
7858 NVList => Arguments,
7859 Constrained => Constrained,
7863 if Is_First_Controlling_Formal then
7865 Addr : constant Entity_Id :=
7866 Make_Defining_Identifier (Loc,
7867 Chars => New_Internal_Name ('A'));
7869 Is_Local : constant Entity_Id :=
7870 Make_Defining_Identifier (Loc,
7871 Chars => New_Internal_Name ('L'));
7874 -- Special case: obtain the first controlling formal
7875 -- from the target of the remote call, instead of the
7878 Append_To (Outer_Decls,
7879 Make_Object_Declaration (Loc,
7880 Defining_Identifier => Addr,
7881 Object_Definition =>
7882 New_Occurrence_Of (RTE (RE_Address), Loc)));
7884 Append_To (Outer_Decls,
7885 Make_Object_Declaration (Loc,
7886 Defining_Identifier => Is_Local,
7887 Object_Definition =>
7888 New_Occurrence_Of (Standard_Boolean, Loc)));
7890 Append_To (Outer_Statements,
7891 Make_Procedure_Call_Statement (Loc,
7893 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7894 Parameter_Associations => New_List (
7895 Make_Selected_Component (Loc,
7898 Request_Parameter, Loc),
7900 Make_Identifier (Loc, Name_Target)),
7901 New_Occurrence_Of (Is_Local, Loc),
7902 New_Occurrence_Of (Addr, Loc))));
7904 Expr := Unchecked_Convert_To (RACW_Type,
7905 New_Occurrence_Of (Addr, Loc));
7908 elsif In_Present (Current_Parameter)
7909 or else not Out_Present (Current_Parameter)
7910 or else not Constrained
7912 -- If an input parameter is constrained, then its reading is
7913 -- deferred until the beginning of the subprogram body. If
7914 -- it is unconstrained, then an expression is built for
7915 -- the object declaration and the variable is set using
7916 -- 'Input instead of 'Read.
7918 Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
7919 Etyp, New_Occurrence_Of (Any, Loc), Decls);
7922 Append_To (Statements,
7923 Make_Assignment_Statement (Loc,
7924 Name => New_Occurrence_Of (Object, Loc),
7925 Expression => Expr));
7930 -- Expr will be used to initialize (and constrain) the
7931 -- parameter when it is declared.
7936 Need_Extra_Constrained :=
7937 Nkind (Parameter_Type (Current_Parameter)) /=
7940 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7942 Present (Extra_Constrained
7943 (Defining_Identifier (Current_Parameter)));
7945 -- We may not associate an extra constrained actual to a
7946 -- constant object, so if one is needed, declare the actual
7947 -- as a variable even if it won't be modified.
7949 Build_Actual_Object_Declaration
7952 Variable => Need_Extra_Constrained
7953 or else Out_Present (Current_Parameter),
7956 Set_Etype (Object, Etyp);
7958 -- An out parameter may be written back using a 'Write
7959 -- attribute instead of a 'Output because it has been
7960 -- constrained by the parameter given to the caller. Note that
7961 -- out controlling arguments in the case of a RACW are not put
7962 -- back in the stream because the pointer on them has not
7965 if Out_Present (Current_Parameter)
7966 and then not Is_Controlling_Formal
7968 Append_To (After_Statements,
7969 Make_Procedure_Call_Statement (Loc,
7970 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
7971 Parameter_Associations => New_List (
7972 New_Occurrence_Of (Any, Loc),
7973 PolyORB_Support.Helpers.Build_To_Any_Call
7974 (New_Occurrence_Of (Object, Loc), Decls))));
7977 -- For RACW controlling formals, the Etyp of Object is always
7978 -- an RACW, even if the parameter is not of an anonymous access
7979 -- type. In such case, we need to dereference it at call time.
7981 if Is_Controlling_Formal then
7982 if Nkind (Parameter_Type (Current_Parameter)) /=
7985 Append_To (Parameter_List,
7986 Make_Parameter_Association (Loc,
7989 (Defining_Identifier (Current_Parameter), Loc),
7990 Explicit_Actual_Parameter =>
7991 Make_Explicit_Dereference (Loc,
7993 Unchecked_Convert_To (RACW_Type,
7994 OK_Convert_To (RTE (RE_Address),
7995 New_Occurrence_Of (Object, Loc))))));
7998 Append_To (Parameter_List,
7999 Make_Parameter_Association (Loc,
8002 (Defining_Identifier (Current_Parameter), Loc),
8004 Explicit_Actual_Parameter =>
8005 Unchecked_Convert_To (RACW_Type,
8006 OK_Convert_To (RTE (RE_Address),
8007 New_Occurrence_Of (Object, Loc)))));
8011 Append_To (Parameter_List,
8012 Make_Parameter_Association (Loc,
8015 Defining_Identifier (Current_Parameter), Loc),
8016 Explicit_Actual_Parameter =>
8017 New_Occurrence_Of (Object, Loc)));
8020 -- If the current parameter needs an extra formal, then read it
8021 -- from the stream and set the corresponding semantic field in
8022 -- the variable. If the kind of the parameter identifier is
8023 -- E_Void, then this is a compiler generated parameter that
8024 -- doesn't need an extra constrained status.
8026 -- The case of Extra_Accessibility should also be handled ???
8028 if Need_Extra_Constrained then
8030 Extra_Parameter : constant Entity_Id :=
8032 (Defining_Identifier
8033 (Current_Parameter));
8035 Extra_Any : constant Entity_Id :=
8036 Make_Defining_Identifier (Loc,
8037 Chars => New_Internal_Name ('A'));
8039 Formal_Entity : constant Entity_Id :=
8040 Make_Defining_Identifier (Loc,
8041 Chars => Chars (Extra_Parameter));
8043 Formal_Type : constant Entity_Id :=
8044 Etype (Extra_Parameter);
8047 Append_To (Outer_Decls,
8048 Make_Object_Declaration (Loc,
8049 Defining_Identifier => Extra_Any,
8050 Object_Definition =>
8051 New_Occurrence_Of (RTE (RE_Any), Loc),
8053 Make_Function_Call (Loc,
8055 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8056 Parameter_Associations => New_List (
8057 PolyORB_Support.Helpers.Build_TypeCode_Call
8058 (Loc, Formal_Type, Outer_Decls)))));
8060 Append_To (Outer_Extra_Formal_Statements,
8061 Add_Parameter_To_NVList (Loc,
8062 Parameter => Extra_Parameter,
8063 NVList => Arguments,
8064 Constrained => True,
8068 Make_Object_Declaration (Loc,
8069 Defining_Identifier => Formal_Entity,
8070 Object_Definition =>
8071 New_Occurrence_Of (Formal_Type, Loc)));
8073 Append_To (Statements,
8074 Make_Assignment_Statement (Loc,
8075 Name => New_Occurrence_Of (Formal_Entity, Loc),
8077 PolyORB_Support.Helpers.Build_From_Any_Call
8079 New_Occurrence_Of (Extra_Any, Loc),
8081 Set_Extra_Constrained (Object, Formal_Entity);
8086 Next (Current_Parameter);
8089 -- Extra Formals should go after all the other parameters
8091 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8093 Append_To (Outer_Statements,
8094 Make_Procedure_Call_Statement (Loc,
8095 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8096 Parameter_Associations => New_List (
8097 New_Occurrence_Of (Request_Parameter, Loc),
8098 New_Occurrence_Of (Arguments, Loc))));
8100 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8102 -- The remote subprogram is a function: Build an inner block to be
8103 -- able to hold a potentially unconstrained result in a variable.
8106 Etyp : constant Entity_Id :=
8107 Etype (Result_Definition (Specification (Vis_Decl)));
8108 Result : constant Node_Id :=
8109 Make_Defining_Identifier (Loc,
8110 Chars => New_Internal_Name ('R'));
8113 Inner_Decls := New_List (
8114 Make_Object_Declaration (Loc,
8115 Defining_Identifier => Result,
8116 Constant_Present => True,
8117 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8119 Make_Function_Call (Loc,
8120 Name => Called_Subprogram,
8121 Parameter_Associations => Parameter_List)));
8123 if Is_Class_Wide_Type (Etyp) then
8125 -- For a remote call to a function with a class-wide type,
8126 -- check that the returned value satisfies the requirements
8129 Append_To (Inner_Decls,
8130 Make_Transportable_Check (Loc,
8131 New_Occurrence_Of (Result, Loc)));
8135 Set_Etype (Result, Etyp);
8136 Append_To (After_Statements,
8137 Make_Procedure_Call_Statement (Loc,
8138 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8139 Parameter_Associations => New_List (
8140 New_Occurrence_Of (Request_Parameter, Loc),
8141 PolyORB_Support.Helpers.Build_To_Any_Call
8142 (New_Occurrence_Of (Result, Loc), Decls))));
8144 -- A DSA function does not have out or inout arguments
8147 Append_To (Statements,
8148 Make_Block_Statement (Loc,
8149 Declarations => Inner_Decls,
8150 Handled_Statement_Sequence =>
8151 Make_Handled_Sequence_Of_Statements (Loc,
8152 Statements => After_Statements)));
8155 -- The remote subprogram is a procedure. We do not need any inner
8156 -- block in this case. No specific processing is required here for
8157 -- the dynamically asynchronous case: the indication of whether
8158 -- call is asynchronous or not is managed by the Sync_Scope
8159 -- attibute of the request, and is handled entirely in the
8162 Append_To (After_Statements,
8163 Make_Procedure_Call_Statement (Loc,
8164 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8165 Parameter_Associations => New_List (
8166 New_Occurrence_Of (Request_Parameter, Loc))));
8168 Append_To (Statements,
8169 Make_Procedure_Call_Statement (Loc,
8170 Name => Called_Subprogram,
8171 Parameter_Associations => Parameter_List));
8173 Append_List_To (Statements, After_Statements);
8177 Make_Procedure_Specification (Loc,
8178 Defining_Unit_Name =>
8179 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
8181 Parameter_Specifications => New_List (
8182 Make_Parameter_Specification (Loc,
8183 Defining_Identifier => Request_Parameter,
8185 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8187 -- An exception raised during the execution of an incoming
8188 -- remote subprogram call and that needs to be sent back
8189 -- to the caller is propagated by the receiving stubs, and
8190 -- will be handled by the caller (the distribution runtime).
8192 if Asynchronous and then not Dynamically_Asynchronous then
8194 -- For an asynchronous procedure, add a null exception handler
8196 Excep_Handlers := New_List (
8197 Make_Implicit_Exception_Handler (Loc,
8198 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8199 Statements => New_List (Make_Null_Statement (Loc))));
8202 -- In the other cases, if an exception is raised, then the
8203 -- exception occurrence is propagated.
8208 Append_To (Outer_Statements,
8209 Make_Block_Statement (Loc,
8210 Declarations => Decls,
8211 Handled_Statement_Sequence =>
8212 Make_Handled_Sequence_Of_Statements (Loc,
8213 Statements => Statements)));
8216 Make_Subprogram_Body (Loc,
8217 Specification => Subp_Spec,
8218 Declarations => Outer_Decls,
8219 Handled_Statement_Sequence =>
8220 Make_Handled_Sequence_Of_Statements (Loc,
8221 Statements => Outer_Statements,
8222 Exception_Handlers => Excep_Handlers));
8223 end Build_Subprogram_Receiving_Stubs;
8229 package body Helpers is
8231 -----------------------
8232 -- Local Subprograms --
8233 -----------------------
8235 function Find_Numeric_Representation
8236 (Typ : Entity_Id) return Entity_Id;
8237 -- Given a numeric type Typ, return the smallest integer or floating
8238 -- point type from Standard, or the smallest unsigned (modular) type
8239 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8241 function Make_Helper_Function_Name
8244 Nam : Name_Id) return Entity_Id;
8245 -- Return the name to be assigned for helper subprogram Nam of Typ
8247 ------------------------------------------------------------
8248 -- Common subprograms for building various tree fragments --
8249 ------------------------------------------------------------
8251 function Build_Get_Aggregate_Element
8255 Idx : Node_Id) return Node_Id;
8256 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8257 -- returning the Idx'th element.
8260 Subprogram : Entity_Id;
8261 -- Reference location for constructed nodes
8264 -- For 'Range and Etype
8267 -- For the construction of the innermost element expression
8269 with procedure Add_Process_Element
8272 Counter : Entity_Id;
8275 procedure Append_Array_Traversal
8278 Counter : Entity_Id := Empty;
8280 -- Build nested loop statements that iterate over the elements of an
8281 -- array Arry. The statement(s) built by Add_Process_Element are
8282 -- executed for each element; Indices is the list of indices to be
8283 -- used in the construction of the indexed component that denotes the
8284 -- current element. Subprogram is the entity for the subprogram for
8285 -- which this iterator is generated. The generated statements are
8286 -- appended to Stmts.
8290 -- The record entity being dealt with
8292 with procedure Add_Process_Element
8294 Container : Node_Or_Entity_Id;
8295 Counter : in out Int;
8298 -- Rec is the instance of the record type, or Empty.
8299 -- Field is either the N_Defining_Identifier for a component,
8300 -- or an N_Variant_Part.
8302 procedure Append_Record_Traversal
8305 Container : Node_Or_Entity_Id;
8306 Counter : in out Int);
8307 -- Process component list Clist. Individual fields are passed
8308 -- to Field_Processing. Each variant part is also processed.
8309 -- Container is the outer Any (for From_Any/To_Any),
8310 -- the outer typecode (for TC) to which the operation applies.
8312 -----------------------------
8313 -- Append_Record_Traversal --
8314 -----------------------------
8316 procedure Append_Record_Traversal
8319 Container : Node_Or_Entity_Id;
8320 Counter : in out Int)
8324 -- Clist's Component_Items and Variant_Part
8334 CI := Component_Items (Clist);
8335 VP := Variant_Part (Clist);
8338 while Present (Item) loop
8339 Def := Defining_Identifier (Item);
8341 if not Is_Internal_Name (Chars (Def)) then
8343 (Stmts, Container, Counter, Rec, Def);
8349 if Present (VP) then
8350 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8352 end Append_Record_Traversal;
8354 -------------------------
8355 -- Build_From_Any_Call --
8356 -------------------------
8358 function Build_From_Any_Call
8361 Decls : List_Id) return Node_Id
8363 Loc : constant Source_Ptr := Sloc (N);
8365 U_Type : Entity_Id := Underlying_Type (Typ);
8367 Fnam : Entity_Id := Empty;
8368 Lib_RE : RE_Id := RE_Null;
8372 -- First simple case where the From_Any function is present
8373 -- in the type's TSS.
8375 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8377 if Sloc (U_Type) <= Standard_Location then
8378 U_Type := Base_Type (U_Type);
8381 -- Check first for Boolean and Character. These are enumeration
8382 -- types, but we treat them specially, since they may require
8383 -- special handling in the transfer protocol. However, this
8384 -- special handling only applies if they have standard
8385 -- representation, otherwise they are treated like any other
8386 -- enumeration type.
8388 if Present (Fnam) then
8391 elsif U_Type = Standard_Boolean then
8394 elsif U_Type = Standard_Character then
8397 elsif U_Type = Standard_Wide_Character then
8400 elsif U_Type = Standard_Wide_Wide_Character then
8401 Lib_RE := RE_FA_WWC;
8403 -- Floating point types
8405 elsif U_Type = Standard_Short_Float then
8408 elsif U_Type = Standard_Float then
8411 elsif U_Type = Standard_Long_Float then
8414 elsif U_Type = Standard_Long_Long_Float then
8415 Lib_RE := RE_FA_LLF;
8419 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8420 Lib_RE := RE_FA_SSI;
8422 elsif U_Type = Etype (Standard_Short_Integer) then
8425 elsif U_Type = Etype (Standard_Integer) then
8428 elsif U_Type = Etype (Standard_Long_Integer) then
8431 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8432 Lib_RE := RE_FA_LLI;
8434 -- Unsigned integer types
8436 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8437 Lib_RE := RE_FA_SSU;
8439 elsif U_Type = RTE (RE_Short_Unsigned) then
8442 elsif U_Type = RTE (RE_Unsigned) then
8445 elsif U_Type = RTE (RE_Long_Unsigned) then
8448 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8449 Lib_RE := RE_FA_LLU;
8451 elsif U_Type = Standard_String then
8452 Lib_RE := RE_FA_String;
8454 -- Special DSA types
8456 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
8459 -- Other (non-primitive) types
8465 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8466 Append_To (Decls, Decl);
8470 -- Call the function
8472 if Lib_RE /= RE_Null then
8473 pragma Assert (No (Fnam));
8474 Fnam := RTE (Lib_RE);
8478 Make_Function_Call (Loc,
8479 Name => New_Occurrence_Of (Fnam, Loc),
8480 Parameter_Associations => New_List (N));
8482 -- We must set the type of Result, so the unchecked conversion
8483 -- from the underlying type to the base type is properly done.
8485 Set_Etype (Result, U_Type);
8487 return Unchecked_Convert_To (Typ, Result);
8488 end Build_From_Any_Call;
8490 -----------------------------
8491 -- Build_From_Any_Function --
8492 -----------------------------
8494 procedure Build_From_Any_Function
8498 Fnam : out Entity_Id)
8501 Decls : constant List_Id := New_List;
8502 Stms : constant List_Id := New_List;
8504 Any_Parameter : constant Entity_Id :=
8505 Make_Defining_Identifier (Loc,
8506 New_Internal_Name ('A'));
8508 Use_Opaque_Representation : Boolean;
8511 if Is_Itype (Typ) then
8512 Build_From_Any_Function
8520 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
8523 Make_Function_Specification (Loc,
8524 Defining_Unit_Name => Fnam,
8525 Parameter_Specifications => New_List (
8526 Make_Parameter_Specification (Loc,
8527 Defining_Identifier => Any_Parameter,
8528 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
8529 Result_Definition => New_Occurrence_Of (Typ, Loc));
8531 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8534 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8536 Use_Opaque_Representation := False;
8538 if Has_Stream_Attribute_Definition
8539 (Typ, TSS_Stream_Output, At_Any_Place => True)
8541 Has_Stream_Attribute_Definition
8542 (Typ, TSS_Stream_Write, At_Any_Place => True)
8544 -- If user-defined stream attributes are specified for this
8545 -- type, use them and transmit data as an opaque sequence of
8548 Use_Opaque_Representation := True;
8550 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
8552 Make_Simple_Return_Statement (Loc,
8557 New_Occurrence_Of (Any_Parameter, Loc),
8560 elsif Is_Record_Type (Typ)
8561 and then not Is_Derived_Type (Typ)
8562 and then not Is_Tagged_Type (Typ)
8564 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8566 Make_Simple_Return_Statement (Loc,
8571 New_Occurrence_Of (Any_Parameter, Loc),
8576 Disc : Entity_Id := Empty;
8577 Discriminant_Associations : List_Id;
8578 Rdef : constant Node_Id :=
8580 (Declaration_Node (Typ));
8581 Component_Counter : Int := 0;
8583 -- The returned object
8585 Res : constant Entity_Id :=
8586 Make_Defining_Identifier (Loc,
8587 New_Internal_Name ('R'));
8589 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8591 procedure FA_Rec_Add_Process_Element
8594 Counter : in out Int;
8598 procedure FA_Append_Record_Traversal is
8599 new Append_Record_Traversal
8601 Add_Process_Element => FA_Rec_Add_Process_Element);
8603 --------------------------------
8604 -- FA_Rec_Add_Process_Element --
8605 --------------------------------
8607 procedure FA_Rec_Add_Process_Element
8610 Counter : in out Int;
8615 if Nkind (Field) = N_Defining_Identifier then
8617 -- A regular component
8620 Make_Assignment_Statement (Loc,
8621 Name => Make_Selected_Component (Loc,
8623 New_Occurrence_Of (Rec, Loc),
8625 New_Occurrence_Of (Field, Loc)),
8627 Build_From_Any_Call (Etype (Field),
8628 Build_Get_Aggregate_Element (Loc,
8630 TC => Build_TypeCode_Call (Loc,
8631 Etype (Field), Decls),
8632 Idx => Make_Integer_Literal (Loc,
8641 Struct_Counter : Int := 0;
8643 Block_Decls : constant List_Id := New_List;
8644 Block_Stmts : constant List_Id := New_List;
8647 Alt_List : constant List_Id := New_List;
8648 Choice_List : List_Id;
8650 Struct_Any : constant Entity_Id :=
8651 Make_Defining_Identifier (Loc,
8652 New_Internal_Name ('S'));
8656 Make_Object_Declaration (Loc,
8657 Defining_Identifier => Struct_Any,
8658 Constant_Present => True,
8659 Object_Definition =>
8660 New_Occurrence_Of (RTE (RE_Any), Loc),
8662 Make_Function_Call (Loc,
8665 (RTE (RE_Extract_Union_Value), Loc),
8667 Parameter_Associations => New_List (
8668 Build_Get_Aggregate_Element (Loc,
8671 Make_Function_Call (Loc,
8672 Name => New_Occurrence_Of (
8673 RTE (RE_Any_Member_Type), Loc),
8674 Parameter_Associations =>
8676 New_Occurrence_Of (Any, Loc),
8677 Make_Integer_Literal (Loc,
8678 Intval => Counter))),
8680 Make_Integer_Literal (Loc,
8681 Intval => Counter))))));
8684 Make_Block_Statement (Loc,
8685 Declarations => Block_Decls,
8686 Handled_Statement_Sequence =>
8687 Make_Handled_Sequence_Of_Statements (Loc,
8688 Statements => Block_Stmts)));
8690 Append_To (Block_Stmts,
8691 Make_Case_Statement (Loc,
8693 Make_Selected_Component (Loc,
8695 Selector_Name => Chars (Name (Field))),
8696 Alternatives => Alt_List));
8698 Variant := First_Non_Pragma (Variants (Field));
8699 while Present (Variant) loop
8702 (Discrete_Choices (Variant));
8704 VP_Stmts := New_List;
8706 -- Struct_Counter should be reset before
8707 -- handling a variant part. Indeed only one
8708 -- of the case statement alternatives will be
8709 -- executed at run-time, so the counter must
8710 -- start at 0 for every case statement.
8712 Struct_Counter := 0;
8714 FA_Append_Record_Traversal (
8716 Clist => Component_List (Variant),
8717 Container => Struct_Any,
8718 Counter => Struct_Counter);
8720 Append_To (Alt_List,
8721 Make_Case_Statement_Alternative (Loc,
8722 Discrete_Choices => Choice_List,
8723 Statements => VP_Stmts));
8724 Next_Non_Pragma (Variant);
8729 Counter := Counter + 1;
8730 end FA_Rec_Add_Process_Element;
8733 -- First all discriminants
8735 if Has_Discriminants (Typ) then
8736 Discriminant_Associations := New_List;
8738 Disc := First_Discriminant (Typ);
8739 while Present (Disc) loop
8741 Disc_Var_Name : constant Entity_Id :=
8742 Make_Defining_Identifier (Loc,
8743 Chars => Chars (Disc));
8744 Disc_Type : constant Entity_Id :=
8749 Make_Object_Declaration (Loc,
8750 Defining_Identifier => Disc_Var_Name,
8751 Constant_Present => True,
8752 Object_Definition =>
8753 New_Occurrence_Of (Disc_Type, Loc),
8756 Build_From_Any_Call (Disc_Type,
8757 Build_Get_Aggregate_Element (Loc,
8758 Any => Any_Parameter,
8759 TC => Build_TypeCode_Call
8760 (Loc, Disc_Type, Decls),
8761 Idx => Make_Integer_Literal (Loc,
8762 Intval => Component_Counter)),
8765 Component_Counter := Component_Counter + 1;
8767 Append_To (Discriminant_Associations,
8768 Make_Discriminant_Association (Loc,
8769 Selector_Names => New_List (
8770 New_Occurrence_Of (Disc, Loc)),
8772 New_Occurrence_Of (Disc_Var_Name, Loc)));
8774 Next_Discriminant (Disc);
8778 Make_Subtype_Indication (Loc,
8779 Subtype_Mark => Res_Definition,
8781 Make_Index_Or_Discriminant_Constraint (Loc,
8782 Discriminant_Associations));
8785 -- Now we have all the discriminants in variables, we can
8786 -- declared a constrained object. Note that we are not
8787 -- initializing (non-discriminant) components directly in
8788 -- the object declarations, because which fields to
8789 -- initialize depends (at run time) on the discriminant
8793 Make_Object_Declaration (Loc,
8794 Defining_Identifier => Res,
8795 Object_Definition => Res_Definition));
8797 -- ... then all components
8799 FA_Append_Record_Traversal (Stms,
8800 Clist => Component_List (Rdef),
8801 Container => Any_Parameter,
8802 Counter => Component_Counter);
8805 Make_Simple_Return_Statement (Loc,
8806 Expression => New_Occurrence_Of (Res, Loc)));
8810 elsif Is_Array_Type (Typ) then
8812 Constrained : constant Boolean := Is_Constrained (Typ);
8814 procedure FA_Ary_Add_Process_Element
8817 Counter : Entity_Id;
8819 -- Assign the current element (as identified by Counter) of
8820 -- Any to the variable denoted by name Datum, and advance
8821 -- Counter by 1. If Datum is not an Any, a call to From_Any
8822 -- for its type is inserted.
8824 --------------------------------
8825 -- FA_Ary_Add_Process_Element --
8826 --------------------------------
8828 procedure FA_Ary_Add_Process_Element
8831 Counter : Entity_Id;
8834 Assignment : constant Node_Id :=
8835 Make_Assignment_Statement (Loc,
8837 Expression => Empty);
8839 Element_Any : Node_Id;
8843 Element_TC : Node_Id;
8846 if Etype (Datum) = RTE (RE_Any) then
8848 -- When Datum is an Any the Etype field is not
8849 -- sufficient to determine the typecode of Datum
8850 -- (which can be a TC_SEQUENCE or TC_ARRAY
8851 -- depending on the value of Constrained).
8853 -- Therefore we retrieve the typecode which has
8854 -- been constructed in Append_Array_Traversal with
8855 -- a call to Get_Any_Type.
8858 Make_Function_Call (Loc,
8859 Name => New_Occurrence_Of (
8860 RTE (RE_Get_Any_Type), Loc),
8861 Parameter_Associations => New_List (
8862 New_Occurrence_Of (Entity (Datum), Loc)));
8864 -- For non Any Datum we simply construct a typecode
8865 -- matching the Etype of the Datum.
8867 Element_TC := Build_TypeCode_Call
8868 (Loc, Etype (Datum), Decls);
8872 Build_Get_Aggregate_Element (Loc,
8875 Idx => New_Occurrence_Of (Counter, Loc));
8878 -- Note: here we *prepend* statements to Stmts, so
8879 -- we must do it in reverse order.
8882 Make_Assignment_Statement (Loc,
8884 New_Occurrence_Of (Counter, Loc),
8887 Left_Opnd => New_Occurrence_Of (Counter, Loc),
8888 Right_Opnd => Make_Integer_Literal (Loc, 1))));
8890 if Nkind (Datum) /= N_Attribute_Reference then
8892 -- We ignore the value of the length of each
8893 -- dimension, since the target array has already
8894 -- been constrained anyway.
8896 if Etype (Datum) /= RTE (RE_Any) then
8897 Set_Expression (Assignment,
8899 (Component_Type (Typ), Element_Any, Decls));
8901 Set_Expression (Assignment, Element_Any);
8904 Prepend_To (Stmts, Assignment);
8906 end FA_Ary_Add_Process_Element;
8908 ------------------------
8909 -- Local Declarations --
8910 ------------------------
8912 Counter : constant Entity_Id :=
8913 Make_Defining_Identifier (Loc, Name_J);
8915 Initial_Counter_Value : Int := 0;
8917 Component_TC : constant Entity_Id :=
8918 Make_Defining_Identifier (Loc, Name_T);
8920 Res : constant Entity_Id :=
8921 Make_Defining_Identifier (Loc, Name_R);
8923 procedure Append_From_Any_Array_Iterator is
8924 new Append_Array_Traversal (
8927 Indices => New_List,
8928 Add_Process_Element => FA_Ary_Add_Process_Element);
8930 Res_Subtype_Indication : Node_Id :=
8931 New_Occurrence_Of (Typ, Loc);
8934 if not Constrained then
8936 Ndim : constant Int := Number_Dimensions (Typ);
8939 Indx : Node_Id := First_Index (Typ);
8942 Ranges : constant List_Id := New_List;
8945 for J in 1 .. Ndim loop
8946 Lnam := New_External_Name ('L', J);
8947 Hnam := New_External_Name ('H', J);
8948 Indt := Etype (Indx);
8951 Make_Object_Declaration (Loc,
8952 Defining_Identifier =>
8953 Make_Defining_Identifier (Loc, Lnam),
8954 Constant_Present => True,
8955 Object_Definition =>
8956 New_Occurrence_Of (Indt, Loc),
8960 Build_Get_Aggregate_Element (Loc,
8961 Any => Any_Parameter,
8962 TC => Build_TypeCode_Call
8965 Make_Integer_Literal (Loc, J - 1)),
8969 Make_Object_Declaration (Loc,
8970 Defining_Identifier =>
8971 Make_Defining_Identifier (Loc, Hnam),
8973 Constant_Present => True,
8975 Object_Definition =>
8976 New_Occurrence_Of (Indt, Loc),
8978 Expression => Make_Attribute_Reference (Loc,
8980 New_Occurrence_Of (Indt, Loc),
8982 Attribute_Name => Name_Val,
8984 Expressions => New_List (
8985 Make_Op_Subtract (Loc,
8990 Standard_Long_Integer,
8991 Make_Identifier (Loc, Lnam)),
8995 Standard_Long_Integer,
8996 Make_Function_Call (Loc,
8998 New_Occurrence_Of (RTE (
8999 RE_Get_Nested_Sequence_Length
9001 Parameter_Associations =>
9004 Any_Parameter, Loc),
9005 Make_Integer_Literal (Loc,
9009 Make_Integer_Literal (Loc, 1))))));
9013 Low_Bound => Make_Identifier (Loc, Lnam),
9014 High_Bound => Make_Identifier (Loc, Hnam)));
9019 -- Now we have all the necessary bound information:
9020 -- apply the set of range constraints to the
9021 -- (unconstrained) nominal subtype of Res.
9023 Initial_Counter_Value := Ndim;
9024 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9025 Subtype_Mark => Res_Subtype_Indication,
9027 Make_Index_Or_Discriminant_Constraint (Loc,
9028 Constraints => Ranges));
9033 Make_Object_Declaration (Loc,
9034 Defining_Identifier => Res,
9035 Object_Definition => Res_Subtype_Indication));
9036 Set_Etype (Res, Typ);
9039 Make_Object_Declaration (Loc,
9040 Defining_Identifier => Counter,
9041 Object_Definition =>
9042 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
9044 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9047 Make_Object_Declaration (Loc,
9048 Defining_Identifier => Component_TC,
9049 Constant_Present => True,
9050 Object_Definition =>
9051 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9053 Build_TypeCode_Call (Loc,
9054 Component_Type (Typ), Decls)));
9056 Append_From_Any_Array_Iterator
9057 (Stms, Any_Parameter, Counter);
9060 Make_Simple_Return_Statement (Loc,
9061 Expression => New_Occurrence_Of (Res, Loc)));
9064 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9066 Make_Simple_Return_Statement (Loc,
9068 Unchecked_Convert_To (Typ,
9070 (Find_Numeric_Representation (Typ),
9071 New_Occurrence_Of (Any_Parameter, Loc),
9075 Use_Opaque_Representation := True;
9078 if Use_Opaque_Representation then
9080 -- Default: type is represented as an opaque sequence of bytes
9083 Strm : constant Entity_Id :=
9084 Make_Defining_Identifier (Loc,
9085 Chars => New_Internal_Name ('S'));
9086 Res : constant Entity_Id :=
9087 Make_Defining_Identifier (Loc,
9088 Chars => New_Internal_Name ('R'));
9091 -- Strm : Buffer_Stream_Type;
9094 Make_Object_Declaration (Loc,
9095 Defining_Identifier => Strm,
9096 Aliased_Present => True,
9097 Object_Definition =>
9098 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9100 -- Allocate_Buffer (Strm);
9103 Make_Procedure_Call_Statement (Loc,
9105 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9106 Parameter_Associations => New_List (
9107 New_Occurrence_Of (Strm, Loc))));
9109 -- Any_To_BS (Strm, A);
9112 Make_Procedure_Call_Statement (Loc,
9113 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
9114 Parameter_Associations => New_List (
9115 New_Occurrence_Of (Any_Parameter, Loc),
9116 New_Occurrence_Of (Strm, Loc))));
9118 if Transmit_As_Unconstrained (Typ) then
9121 -- Res : constant T := T'Input (Strm);
9123 -- Release_Buffer (Strm);
9127 Append_To (Stms, Make_Block_Statement (Loc,
9128 Declarations => New_List (
9129 Make_Object_Declaration (Loc,
9130 Defining_Identifier => Res,
9131 Constant_Present => True,
9132 Object_Definition => New_Occurrence_Of (Typ, Loc),
9134 Make_Attribute_Reference (Loc,
9135 Prefix => New_Occurrence_Of (Typ, Loc),
9136 Attribute_Name => Name_Input,
9137 Expressions => New_List (
9138 Make_Attribute_Reference (Loc,
9140 New_Occurrence_Of (Strm, Loc),
9141 Attribute_Name => Name_Access))))),
9143 Handled_Statement_Sequence =>
9144 Make_Handled_Sequence_Of_Statements (Loc,
9145 Statements => New_List (
9146 Make_Procedure_Call_Statement (Loc,
9149 (RTE (RE_Release_Buffer), Loc),
9150 Parameter_Associations =>
9151 New_List (New_Occurrence_Of (Strm, Loc))),
9153 Make_Simple_Return_Statement (Loc,
9154 Expression => New_Occurrence_Of (Res, Loc))))));
9160 -- T'Read (Strm, Res);
9161 -- Release_Buffer (Strm);
9165 Append_To (Stms, Make_Block_Statement (Loc,
9166 Declarations => New_List (
9167 Make_Object_Declaration (Loc,
9168 Defining_Identifier => Res,
9169 Constant_Present => False,
9170 Object_Definition =>
9171 New_Occurrence_Of (Typ, Loc))),
9173 Handled_Statement_Sequence =>
9174 Make_Handled_Sequence_Of_Statements (Loc,
9175 Statements => New_List (
9176 Make_Attribute_Reference (Loc,
9177 Prefix => New_Occurrence_Of (Typ, Loc),
9178 Attribute_Name => Name_Read,
9179 Expressions => New_List (
9180 Make_Attribute_Reference (Loc,
9182 New_Occurrence_Of (Strm, Loc),
9183 Attribute_Name => Name_Access),
9184 New_Occurrence_Of (Res, Loc))),
9186 Make_Procedure_Call_Statement (Loc,
9189 (RTE (RE_Release_Buffer), Loc),
9190 Parameter_Associations =>
9191 New_List (New_Occurrence_Of (Strm, Loc))),
9193 Make_Simple_Return_Statement (Loc,
9194 Expression => New_Occurrence_Of (Res, Loc))))));
9200 Make_Subprogram_Body (Loc,
9201 Specification => Spec,
9202 Declarations => Decls,
9203 Handled_Statement_Sequence =>
9204 Make_Handled_Sequence_Of_Statements (Loc,
9205 Statements => Stms));
9206 end Build_From_Any_Function;
9208 ---------------------------------
9209 -- Build_Get_Aggregate_Element --
9210 ---------------------------------
9212 function Build_Get_Aggregate_Element
9216 Idx : Node_Id) return Node_Id
9219 return Make_Function_Call (Loc,
9221 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc),
9222 Parameter_Associations => New_List (
9223 New_Occurrence_Of (Any, Loc),
9226 end Build_Get_Aggregate_Element;
9228 -------------------------
9229 -- Build_Reposiroty_Id --
9230 -------------------------
9232 procedure Build_Name_And_Repository_Id
9234 Name_Str : out String_Id;
9235 Repo_Id_Str : out String_Id)
9239 Store_String_Chars ("DSA:");
9240 Get_Library_Unit_Name_String (Scope (E));
9242 (Name_Buffer (Name_Buffer'First ..
9243 Name_Buffer'First + Name_Len - 1));
9244 Store_String_Char ('.');
9245 Get_Name_String (Chars (E));
9247 (Name_Buffer (Name_Buffer'First ..
9248 Name_Buffer'First + Name_Len - 1));
9249 Store_String_Chars (":1.0");
9250 Repo_Id_Str := End_String;
9251 Name_Str := String_From_Name_Buffer;
9252 end Build_Name_And_Repository_Id;
9254 -----------------------
9255 -- Build_To_Any_Call --
9256 -----------------------
9258 function Build_To_Any_Call
9260 Decls : List_Id) return Node_Id
9262 Loc : constant Source_Ptr := Sloc (N);
9264 Typ : Entity_Id := Etype (N);
9266 Fnam : Entity_Id := Empty;
9267 Lib_RE : RE_Id := RE_Null;
9270 -- If N is a selected component, then maybe its Etype has not been
9271 -- set yet: try to use Etype of the selector_name in that case.
9273 if No (Typ) and then Nkind (N) = N_Selected_Component then
9274 Typ := Etype (Selector_Name (N));
9276 pragma Assert (Present (Typ));
9278 -- Get full view for private type, completion for incomplete type
9280 U_Type := Underlying_Type (Typ);
9282 -- First simple case where the To_Any function is present in the
9285 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9287 -- Check first for Boolean and Character. These are enumeration
9288 -- types, but we treat them specially, since they may require
9289 -- special handling in the transfer protocol. However, this
9290 -- special handling only applies if they have standard
9291 -- representation, otherwise they are treated like any other
9292 -- enumeration type.
9294 if Sloc (U_Type) <= Standard_Location then
9295 U_Type := Base_Type (U_Type);
9298 if Present (Fnam) then
9301 elsif U_Type = Standard_Boolean then
9304 elsif U_Type = Standard_Character then
9307 elsif U_Type = Standard_Wide_Character then
9310 elsif U_Type = Standard_Wide_Wide_Character then
9311 Lib_RE := RE_TA_WWC;
9313 -- Floating point types
9315 elsif U_Type = Standard_Short_Float then
9318 elsif U_Type = Standard_Float then
9321 elsif U_Type = Standard_Long_Float then
9324 elsif U_Type = Standard_Long_Long_Float then
9325 Lib_RE := RE_TA_LLF;
9329 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9330 Lib_RE := RE_TA_SSI;
9332 elsif U_Type = Etype (Standard_Short_Integer) then
9335 elsif U_Type = Etype (Standard_Integer) then
9338 elsif U_Type = Etype (Standard_Long_Integer) then
9341 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9342 Lib_RE := RE_TA_LLI;
9344 -- Unsigned integer types
9346 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9347 Lib_RE := RE_TA_SSU;
9349 elsif U_Type = RTE (RE_Short_Unsigned) then
9352 elsif U_Type = RTE (RE_Unsigned) then
9355 elsif U_Type = RTE (RE_Long_Unsigned) then
9358 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9359 Lib_RE := RE_TA_LLU;
9361 elsif U_Type = Standard_String then
9362 Lib_RE := RE_TA_String;
9364 -- Special DSA types
9366 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
9370 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9372 -- No corresponding FA_TC ???
9376 -- Other (non-primitive) types
9382 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9383 Append_To (Decls, Decl);
9387 -- Call the function
9389 if Lib_RE /= RE_Null then
9390 pragma Assert (No (Fnam));
9391 Fnam := RTE (Lib_RE);
9395 Make_Function_Call (Loc,
9396 Name => New_Occurrence_Of (Fnam, Loc),
9397 Parameter_Associations =>
9398 New_List (Unchecked_Convert_To (U_Type, N)));
9399 end Build_To_Any_Call;
9401 ---------------------------
9402 -- Build_To_Any_Function --
9403 ---------------------------
9405 procedure Build_To_Any_Function
9409 Fnam : out Entity_Id)
9412 Decls : constant List_Id := New_List;
9413 Stms : constant List_Id := New_List;
9415 Expr_Parameter : constant Entity_Id :=
9416 Make_Defining_Identifier (Loc, Name_E);
9418 Any : constant Entity_Id :=
9419 Make_Defining_Identifier (Loc, Name_A);
9422 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9424 Use_Opaque_Representation : Boolean;
9425 -- When True, use stream attributes and represent type as an
9426 -- opaque sequence of bytes.
9429 if Is_Itype (Typ) then
9430 Build_To_Any_Function
9438 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
9441 Make_Function_Specification (Loc,
9442 Defining_Unit_Name => Fnam,
9443 Parameter_Specifications => New_List (
9444 Make_Parameter_Specification (Loc,
9445 Defining_Identifier => Expr_Parameter,
9446 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9447 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9448 Set_Etype (Expr_Parameter, Typ);
9451 Make_Object_Declaration (Loc,
9452 Defining_Identifier => Any,
9453 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9455 Use_Opaque_Representation := False;
9457 if Has_Stream_Attribute_Definition
9458 (Typ, TSS_Stream_Output, At_Any_Place => True)
9460 Has_Stream_Attribute_Definition
9461 (Typ, TSS_Stream_Write, At_Any_Place => True)
9463 -- If user-defined stream attributes are specified for this
9464 -- type, use them and transmit data as an opaque sequence of
9467 Use_Opaque_Representation := True;
9469 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9471 -- Non-tagged derived type: convert to root type
9474 Rt_Type : constant Entity_Id := Root_Type (Typ);
9475 Expr : constant Node_Id :=
9478 New_Occurrence_Of (Expr_Parameter, Loc));
9480 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9483 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9485 -- Non-tagged record type
9487 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9489 Rt_Type : constant Entity_Id := Etype (Typ);
9490 Expr : constant Node_Id :=
9491 OK_Convert_To (Rt_Type,
9492 New_Occurrence_Of (Expr_Parameter, Loc));
9496 (Any_Decl, Build_To_Any_Call (Expr, Decls));
9499 -- Comment needed here (and label on declare block ???)
9503 Disc : Entity_Id := Empty;
9504 Rdef : constant Node_Id :=
9505 Type_Definition (Declaration_Node (Typ));
9507 Elements : constant List_Id := New_List;
9509 procedure TA_Rec_Add_Process_Element
9511 Container : Node_Or_Entity_Id;
9512 Counter : in out Int;
9515 -- Processing routine for traversal below
9517 procedure TA_Append_Record_Traversal is
9518 new Append_Record_Traversal
9519 (Rec => Expr_Parameter,
9520 Add_Process_Element => TA_Rec_Add_Process_Element);
9522 --------------------------------
9523 -- TA_Rec_Add_Process_Element --
9524 --------------------------------
9526 procedure TA_Rec_Add_Process_Element
9528 Container : Node_Or_Entity_Id;
9529 Counter : in out Int;
9533 Field_Ref : Node_Id;
9536 if Nkind (Field) = N_Defining_Identifier then
9538 -- A regular component
9540 Field_Ref := Make_Selected_Component (Loc,
9541 Prefix => New_Occurrence_Of (Rec, Loc),
9542 Selector_Name => New_Occurrence_Of (Field, Loc));
9543 Set_Etype (Field_Ref, Etype (Field));
9546 Make_Procedure_Call_Statement (Loc,
9549 RTE (RE_Add_Aggregate_Element), Loc),
9550 Parameter_Associations => New_List (
9551 New_Occurrence_Of (Container, Loc),
9552 Build_To_Any_Call (Field_Ref, Decls))));
9557 Variant_Part : declare
9559 Struct_Counter : Int := 0;
9561 Block_Decls : constant List_Id := New_List;
9562 Block_Stmts : constant List_Id := New_List;
9565 Alt_List : constant List_Id := New_List;
9566 Choice_List : List_Id;
9568 Union_Any : constant Entity_Id :=
9569 Make_Defining_Identifier (Loc,
9570 New_Internal_Name ('V'));
9572 Struct_Any : constant Entity_Id :=
9573 Make_Defining_Identifier (Loc,
9574 New_Internal_Name ('S'));
9576 function Make_Discriminant_Reference
9578 -- Build reference to the discriminant for this
9581 ---------------------------------
9582 -- Make_Discriminant_Reference --
9583 ---------------------------------
9585 function Make_Discriminant_Reference
9588 Nod : constant Node_Id :=
9589 Make_Selected_Component (Loc,
9592 Chars (Name (Field)));
9594 Set_Etype (Nod, Etype (Name (Field)));
9596 end Make_Discriminant_Reference;
9598 -- Start processing for Variant_Part
9602 Make_Block_Statement (Loc,
9605 Handled_Statement_Sequence =>
9606 Make_Handled_Sequence_Of_Statements (Loc,
9607 Statements => Block_Stmts)));
9609 -- Declare variant part aggregate (Union_Any).
9610 -- Knowing the position of this VP in the
9611 -- variant record, we can fetch the VP typecode
9614 Append_To (Block_Decls,
9615 Make_Object_Declaration (Loc,
9616 Defining_Identifier => Union_Any,
9617 Object_Definition =>
9618 New_Occurrence_Of (RTE (RE_Any), Loc),
9620 Make_Function_Call (Loc,
9621 Name => New_Occurrence_Of (
9622 RTE (RE_Create_Any), Loc),
9623 Parameter_Associations => New_List (
9624 Make_Function_Call (Loc,
9627 RTE (RE_Any_Member_Type), Loc),
9628 Parameter_Associations => New_List (
9629 New_Occurrence_Of (Container, Loc),
9630 Make_Integer_Literal (Loc,
9633 -- Declare inner struct aggregate (which
9634 -- contains the components of this VP).
9636 Append_To (Block_Decls,
9637 Make_Object_Declaration (Loc,
9638 Defining_Identifier => Struct_Any,
9639 Object_Definition =>
9640 New_Occurrence_Of (RTE (RE_Any), Loc),
9642 Make_Function_Call (Loc,
9643 Name => New_Occurrence_Of (
9644 RTE (RE_Create_Any), Loc),
9645 Parameter_Associations => New_List (
9646 Make_Function_Call (Loc,
9649 RTE (RE_Any_Member_Type), Loc),
9650 Parameter_Associations => New_List (
9651 New_Occurrence_Of (Union_Any, Loc),
9652 Make_Integer_Literal (Loc,
9655 -- Build case statement
9657 Append_To (Block_Stmts,
9658 Make_Case_Statement (Loc,
9659 Expression => Make_Discriminant_Reference,
9660 Alternatives => Alt_List));
9662 Variant := First_Non_Pragma (Variants (Field));
9663 while Present (Variant) loop
9664 Choice_List := New_Copy_List_Tree
9665 (Discrete_Choices (Variant));
9667 VP_Stmts := New_List;
9669 -- Append discriminant val to union aggregate
9671 Append_To (VP_Stmts,
9672 Make_Procedure_Call_Statement (Loc,
9675 RTE (RE_Add_Aggregate_Element), Loc),
9676 Parameter_Associations => New_List (
9677 New_Occurrence_Of (Union_Any, Loc),
9679 (Make_Discriminant_Reference,
9682 -- Populate inner struct aggregate
9684 -- Struct_Counter should be reset before
9685 -- handling a variant part. Indeed only one
9686 -- of the case statement alternatives will be
9687 -- executed at run-time, so the counter must
9688 -- start at 0 for every case statement.
9690 Struct_Counter := 0;
9692 TA_Append_Record_Traversal (
9694 Clist => Component_List (Variant),
9695 Container => Struct_Any,
9696 Counter => Struct_Counter);
9698 -- Append inner struct to union aggregate
9700 Append_To (VP_Stmts,
9701 Make_Procedure_Call_Statement (Loc,
9704 RTE (RE_Add_Aggregate_Element), Loc),
9705 Parameter_Associations => New_List (
9706 New_Occurrence_Of (Union_Any, Loc),
9707 New_Occurrence_Of (Struct_Any, Loc))));
9709 -- Append union to outer aggregate
9711 Append_To (VP_Stmts,
9712 Make_Procedure_Call_Statement (Loc,
9715 RTE (RE_Add_Aggregate_Element), Loc),
9716 Parameter_Associations => New_List (
9717 New_Occurrence_Of (Container, Loc),
9719 (Union_Any, Loc))));
9721 Append_To (Alt_List,
9722 Make_Case_Statement_Alternative (Loc,
9723 Discrete_Choices => Choice_List,
9724 Statements => VP_Stmts));
9726 Next_Non_Pragma (Variant);
9731 Counter := Counter + 1;
9732 end TA_Rec_Add_Process_Element;
9735 -- Records are encoded in a TC_STRUCT aggregate:
9737 -- -- Outer aggregate (TC_STRUCT)
9738 -- | [discriminant1]
9739 -- | [discriminant2]
9746 -- A component can be a common component or variant part
9748 -- A variant part is encoded as a TC_UNION aggregate:
9750 -- -- Variant Part Aggregate (TC_UNION)
9751 -- | [discriminant choice for this Variant Part]
9753 -- | -- Inner struct (TC_STRUCT)
9758 -- Let's start by building the outer aggregate. First we
9759 -- construct Elements array containing all discriminants.
9761 if Has_Discriminants (Typ) then
9762 Disc := First_Discriminant (Typ);
9763 while Present (Disc) loop
9765 Discriminant : constant Entity_Id :=
9766 Make_Selected_Component (Loc,
9773 Set_Etype (Discriminant, Etype (Disc));
9775 Append_To (Elements,
9776 Make_Component_Association (Loc,
9777 Choices => New_List (
9778 Make_Integer_Literal (Loc, Counter)),
9780 Build_To_Any_Call (Discriminant, Decls)));
9783 Counter := Counter + 1;
9784 Next_Discriminant (Disc);
9788 -- If there are no discriminants, we declare an empty
9792 Dummy_Any : constant Entity_Id :=
9793 Make_Defining_Identifier (Loc,
9794 Chars => New_Internal_Name ('A'));
9798 Make_Object_Declaration (Loc,
9799 Defining_Identifier => Dummy_Any,
9800 Object_Definition =>
9801 New_Occurrence_Of (RTE (RE_Any), Loc)));
9803 Append_To (Elements,
9804 Make_Component_Association (Loc,
9805 Choices => New_List (
9808 Make_Integer_Literal (Loc, 1),
9810 Make_Integer_Literal (Loc, 0))),
9812 New_Occurrence_Of (Dummy_Any, Loc)));
9816 -- We build the result aggregate with discriminants
9817 -- as the first elements.
9819 Set_Expression (Any_Decl,
9820 Make_Function_Call (Loc,
9821 Name => New_Occurrence_Of (
9822 RTE (RE_Any_Aggregate_Build), Loc),
9823 Parameter_Associations => New_List (
9825 Make_Aggregate (Loc,
9826 Component_Associations => Elements))));
9829 -- Then we append all the components to the result
9832 TA_Append_Record_Traversal (Stms,
9833 Clist => Component_List (Rdef),
9835 Counter => Counter);
9839 elsif Is_Array_Type (Typ) then
9841 -- Constrained and unconstrained array types
9844 Constrained : constant Boolean := Is_Constrained (Typ);
9846 procedure TA_Ary_Add_Process_Element
9849 Counter : Entity_Id;
9852 --------------------------------
9853 -- TA_Ary_Add_Process_Element --
9854 --------------------------------
9856 procedure TA_Ary_Add_Process_Element
9859 Counter : Entity_Id;
9862 pragma Warnings (Off);
9863 pragma Unreferenced (Counter);
9864 pragma Warnings (On);
9866 Element_Any : Node_Id;
9869 if Etype (Datum) = RTE (RE_Any) then
9870 Element_Any := Datum;
9872 Element_Any := Build_To_Any_Call (Datum, Decls);
9876 Make_Procedure_Call_Statement (Loc,
9877 Name => New_Occurrence_Of (
9878 RTE (RE_Add_Aggregate_Element), Loc),
9879 Parameter_Associations => New_List (
9880 New_Occurrence_Of (Any, Loc),
9882 end TA_Ary_Add_Process_Element;
9884 procedure Append_To_Any_Array_Iterator is
9885 new Append_Array_Traversal (
9887 Arry => Expr_Parameter,
9888 Indices => New_List,
9889 Add_Process_Element => TA_Ary_Add_Process_Element);
9894 Set_Expression (Any_Decl,
9895 Make_Function_Call (Loc,
9897 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9898 Parameter_Associations => New_List (Result_TC)));
9901 if not Constrained then
9902 Index := First_Index (Typ);
9903 for J in 1 .. Number_Dimensions (Typ) loop
9905 Make_Procedure_Call_Statement (Loc,
9908 RTE (RE_Add_Aggregate_Element), Loc),
9909 Parameter_Associations => New_List (
9910 New_Occurrence_Of (Any, Loc),
9912 OK_Convert_To (Etype (Index),
9913 Make_Attribute_Reference (Loc,
9915 New_Occurrence_Of (Expr_Parameter, Loc),
9916 Attribute_Name => Name_First,
9917 Expressions => New_List (
9918 Make_Integer_Literal (Loc, J)))),
9924 Append_To_Any_Array_Iterator (Stms, Any);
9927 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9931 Set_Expression (Any_Decl,
9934 Find_Numeric_Representation (Typ),
9935 New_Occurrence_Of (Expr_Parameter, Loc)),
9939 -- Default case, including tagged types: opaque representation
9941 Use_Opaque_Representation := True;
9944 if Use_Opaque_Representation then
9946 Strm : constant Entity_Id :=
9947 Make_Defining_Identifier (Loc,
9948 Chars => New_Internal_Name ('S'));
9949 -- Stream used to store data representation produced by
9950 -- stream attribute.
9954 -- Strm : aliased Buffer_Stream_Type;
9957 Make_Object_Declaration (Loc,
9958 Defining_Identifier =>
9962 Object_Definition =>
9963 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9966 -- Allocate_Buffer (Strm);
9969 Make_Procedure_Call_Statement (Loc,
9971 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9972 Parameter_Associations => New_List (
9973 New_Occurrence_Of (Strm, Loc))));
9976 -- T'Output (Strm'Access, E);
9979 Make_Attribute_Reference (Loc,
9980 Prefix => New_Occurrence_Of (Typ, Loc),
9981 Attribute_Name => Name_Output,
9982 Expressions => New_List (
9983 Make_Attribute_Reference (Loc,
9984 Prefix => New_Occurrence_Of (Strm, Loc),
9985 Attribute_Name => Name_Access),
9986 New_Occurrence_Of (Expr_Parameter, Loc))));
9989 -- BS_To_Any (Strm, A);
9992 Make_Procedure_Call_Statement (Loc,
9993 Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
9994 Parameter_Associations => New_List (
9995 New_Occurrence_Of (Strm, Loc),
9996 New_Occurrence_Of (Any, Loc))));
9999 -- Release_Buffer (Strm);
10002 Make_Procedure_Call_Statement (Loc,
10003 Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
10004 Parameter_Associations => New_List (
10005 New_Occurrence_Of (Strm, Loc))));
10009 Append_To (Decls, Any_Decl);
10011 if Present (Result_TC) then
10013 Make_Procedure_Call_Statement (Loc,
10014 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
10015 Parameter_Associations => New_List (
10016 New_Occurrence_Of (Any, Loc),
10021 Make_Simple_Return_Statement (Loc,
10022 Expression => New_Occurrence_Of (Any, Loc)));
10025 Make_Subprogram_Body (Loc,
10026 Specification => Spec,
10027 Declarations => Decls,
10028 Handled_Statement_Sequence =>
10029 Make_Handled_Sequence_Of_Statements (Loc,
10030 Statements => Stms));
10031 end Build_To_Any_Function;
10033 -------------------------
10034 -- Build_TypeCode_Call --
10035 -------------------------
10037 function Build_TypeCode_Call
10040 Decls : List_Id) return Node_Id
10042 U_Type : Entity_Id := Underlying_Type (Typ);
10043 -- The full view, if Typ is private; the completion,
10044 -- if Typ is incomplete.
10046 Fnam : Entity_Id := Empty;
10047 Lib_RE : RE_Id := RE_Null;
10051 -- Special case System.PolyORB.Interface.Any: its primitives have
10052 -- not been set yet, so can't call Find_Inherited_TSS.
10054 if Typ = RTE (RE_Any) then
10055 Fnam := RTE (RE_TC_A);
10058 -- First simple case where the TypeCode is present
10059 -- in the type's TSS.
10061 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10065 if Sloc (U_Type) <= Standard_Location then
10067 -- Do not try to build alias typecodes for subtypes from
10070 U_Type := Base_Type (U_Type);
10073 if U_Type = Standard_Boolean then
10076 elsif U_Type = Standard_Character then
10079 elsif U_Type = Standard_Wide_Character then
10080 Lib_RE := RE_TC_WC;
10082 elsif U_Type = Standard_Wide_Wide_Character then
10083 Lib_RE := RE_TC_WWC;
10085 -- Floating point types
10087 elsif U_Type = Standard_Short_Float then
10088 Lib_RE := RE_TC_SF;
10090 elsif U_Type = Standard_Float then
10093 elsif U_Type = Standard_Long_Float then
10094 Lib_RE := RE_TC_LF;
10096 elsif U_Type = Standard_Long_Long_Float then
10097 Lib_RE := RE_TC_LLF;
10099 -- Integer types (walk back to the base type)
10101 elsif U_Type = Etype (Standard_Short_Short_Integer) then
10102 Lib_RE := RE_TC_SSI;
10104 elsif U_Type = Etype (Standard_Short_Integer) then
10105 Lib_RE := RE_TC_SI;
10107 elsif U_Type = Etype (Standard_Integer) then
10110 elsif U_Type = Etype (Standard_Long_Integer) then
10111 Lib_RE := RE_TC_LI;
10113 elsif U_Type = Etype (Standard_Long_Long_Integer) then
10114 Lib_RE := RE_TC_LLI;
10116 -- Unsigned integer types
10118 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
10119 Lib_RE := RE_TC_SSU;
10121 elsif U_Type = RTE (RE_Short_Unsigned) then
10122 Lib_RE := RE_TC_SU;
10124 elsif U_Type = RTE (RE_Unsigned) then
10127 elsif U_Type = RTE (RE_Long_Unsigned) then
10128 Lib_RE := RE_TC_LU;
10130 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
10131 Lib_RE := RE_TC_LLU;
10133 elsif U_Type = Standard_String then
10134 Lib_RE := RE_TC_String;
10136 -- Special DSA types
10138 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
10141 -- Other (non-primitive) types
10147 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10148 Append_To (Decls, Decl);
10152 if Lib_RE /= RE_Null then
10153 Fnam := RTE (Lib_RE);
10157 -- Call the function
10160 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10162 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10164 Set_Etype (Expr, RTE (RE_TypeCode));
10167 end Build_TypeCode_Call;
10169 -----------------------------
10170 -- Build_TypeCode_Function --
10171 -----------------------------
10173 procedure Build_TypeCode_Function
10176 Decl : out Node_Id;
10177 Fnam : out Entity_Id)
10180 Decls : constant List_Id := New_List;
10181 Stms : constant List_Id := New_List;
10183 TCNam : constant Entity_Id :=
10184 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
10186 Parameters : List_Id;
10188 procedure Add_String_Parameter
10190 Parameter_List : List_Id);
10191 -- Add a literal for S to Parameters
10193 procedure Add_TypeCode_Parameter
10194 (TC_Node : Node_Id;
10195 Parameter_List : List_Id);
10196 -- Add the typecode for Typ to Parameters
10198 procedure Add_Long_Parameter
10199 (Expr_Node : Node_Id;
10200 Parameter_List : List_Id);
10201 -- Add a signed long integer expression to Parameters
10203 procedure Initialize_Parameter_List
10204 (Name_String : String_Id;
10205 Repo_Id_String : String_Id;
10206 Parameter_List : out List_Id);
10207 -- Return a list that contains the first two parameters
10208 -- for a parameterized typecode: name and repository id.
10210 function Make_Constructed_TypeCode
10212 Parameters : List_Id) return Node_Id;
10213 -- Call TC_Build with the given kind and parameters
10215 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10216 -- Make a return statement that calls TC_Build with the given
10217 -- typecode kind, and the constructed parameters list.
10219 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10220 -- Return a typecode that is a TC_Alias for the given typecode
10222 --------------------------
10223 -- Add_String_Parameter --
10224 --------------------------
10226 procedure Add_String_Parameter
10228 Parameter_List : List_Id)
10231 Append_To (Parameter_List,
10232 Make_Function_Call (Loc,
10233 Name => New_Occurrence_Of (RTE (RE_TA_String), Loc),
10234 Parameter_Associations => New_List (
10235 Make_String_Literal (Loc, S))));
10236 end Add_String_Parameter;
10238 ----------------------------
10239 -- Add_TypeCode_Parameter --
10240 ----------------------------
10242 procedure Add_TypeCode_Parameter
10243 (TC_Node : Node_Id;
10244 Parameter_List : List_Id)
10247 Append_To (Parameter_List,
10248 Make_Function_Call (Loc,
10249 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10250 Parameter_Associations => New_List (TC_Node)));
10251 end Add_TypeCode_Parameter;
10253 ------------------------
10254 -- Add_Long_Parameter --
10255 ------------------------
10257 procedure Add_Long_Parameter
10258 (Expr_Node : Node_Id;
10259 Parameter_List : List_Id)
10262 Append_To (Parameter_List,
10263 Make_Function_Call (Loc,
10264 Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc),
10265 Parameter_Associations => New_List (Expr_Node)));
10266 end Add_Long_Parameter;
10268 -------------------------------
10269 -- Initialize_Parameter_List --
10270 -------------------------------
10272 procedure Initialize_Parameter_List
10273 (Name_String : String_Id;
10274 Repo_Id_String : String_Id;
10275 Parameter_List : out List_Id)
10278 Parameter_List := New_List;
10279 Add_String_Parameter (Name_String, Parameter_List);
10280 Add_String_Parameter (Repo_Id_String, Parameter_List);
10281 end Initialize_Parameter_List;
10283 ---------------------------
10284 -- Return_Alias_TypeCode --
10285 ---------------------------
10287 procedure Return_Alias_TypeCode
10288 (Base_TypeCode : Node_Id)
10291 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10292 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
10293 end Return_Alias_TypeCode;
10295 -------------------------------
10296 -- Make_Constructed_TypeCode --
10297 -------------------------------
10299 function Make_Constructed_TypeCode
10301 Parameters : List_Id) return Node_Id
10303 Constructed_TC : constant Node_Id :=
10304 Make_Function_Call (Loc,
10306 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
10307 Parameter_Associations => New_List (
10308 New_Occurrence_Of (Kind, Loc),
10309 Make_Aggregate (Loc,
10310 Expressions => Parameters)));
10312 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10313 return Constructed_TC;
10314 end Make_Constructed_TypeCode;
10316 ---------------------------------
10317 -- Return_Constructed_TypeCode --
10318 ---------------------------------
10320 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10323 Make_Simple_Return_Statement (Loc,
10325 Make_Constructed_TypeCode (Kind, Parameters)));
10326 end Return_Constructed_TypeCode;
10332 procedure TC_Rec_Add_Process_Element
10335 Counter : in out Int;
10339 procedure TC_Append_Record_Traversal is
10340 new Append_Record_Traversal (
10342 Add_Process_Element => TC_Rec_Add_Process_Element);
10344 --------------------------------
10345 -- TC_Rec_Add_Process_Element --
10346 --------------------------------
10348 procedure TC_Rec_Add_Process_Element
10351 Counter : in out Int;
10355 pragma Warnings (Off);
10356 pragma Unreferenced (Any, Counter, Rec);
10357 pragma Warnings (On);
10360 if Nkind (Field) = N_Defining_Identifier then
10362 -- A regular component
10364 Add_TypeCode_Parameter
10365 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10366 Get_Name_String (Chars (Field));
10367 Add_String_Parameter (String_From_Name_Buffer, Params);
10374 Discriminant_Type : constant Entity_Id :=
10375 Etype (Name (Field));
10377 Is_Enum : constant Boolean :=
10378 Is_Enumeration_Type (Discriminant_Type);
10380 Union_TC_Params : List_Id;
10382 U_Name : constant Name_Id :=
10383 New_External_Name (Chars (Typ), 'V', -1);
10385 Name_Str : String_Id;
10386 Struct_TC_Params : List_Id;
10390 Default : constant Node_Id :=
10391 Make_Integer_Literal (Loc, -1);
10393 Dummy_Counter : Int := 0;
10395 Choice_Index : Int := 0;
10397 procedure Add_Params_For_Variant_Components;
10398 -- Add a struct TypeCode and a corresponding member name
10399 -- to the union parameter list.
10401 -- Ordering of declarations is a complete mess in this
10402 -- area, it is supposed to be types/variables, then
10403 -- subprogram specs, then subprogram bodies ???
10405 ---------------------------------------
10406 -- Add_Params_For_Variant_Components --
10407 ---------------------------------------
10409 procedure Add_Params_For_Variant_Components
10411 S_Name : constant Name_Id :=
10412 New_External_Name (U_Name, 'S', -1);
10415 Get_Name_String (S_Name);
10416 Name_Str := String_From_Name_Buffer;
10417 Initialize_Parameter_List
10418 (Name_Str, Name_Str, Struct_TC_Params);
10420 -- Build struct parameters
10422 TC_Append_Record_Traversal (Struct_TC_Params,
10423 Component_List (Variant),
10427 Add_TypeCode_Parameter
10428 (Make_Constructed_TypeCode
10429 (RTE (RE_TC_Struct), Struct_TC_Params),
10432 Add_String_Parameter (Name_Str, Union_TC_Params);
10433 end Add_Params_For_Variant_Components;
10436 Get_Name_String (U_Name);
10437 Name_Str := String_From_Name_Buffer;
10439 Initialize_Parameter_List
10440 (Name_Str, Name_Str, Union_TC_Params);
10442 -- Add union in enclosing parameter list
10444 Add_TypeCode_Parameter
10445 (Make_Constructed_TypeCode
10446 (RTE (RE_TC_Union), Union_TC_Params),
10449 Add_String_Parameter (Name_Str, Params);
10451 -- Build union parameters
10453 Add_TypeCode_Parameter
10454 (Build_TypeCode_Call
10455 (Loc, Discriminant_Type, Decls),
10458 Add_Long_Parameter (Default, Union_TC_Params);
10460 Variant := First_Non_Pragma (Variants (Field));
10461 while Present (Variant) loop
10462 Choice := First (Discrete_Choices (Variant));
10463 while Present (Choice) loop
10464 case Nkind (Choice) is
10467 L : constant Uint :=
10468 Expr_Value (Low_Bound (Choice));
10469 H : constant Uint :=
10470 Expr_Value (High_Bound (Choice));
10472 -- 3.8.1(8) guarantees that the bounds of
10473 -- this range are static.
10480 Expr := New_Occurrence_Of (
10481 Get_Enum_Lit_From_Pos (
10482 Discriminant_Type, J, Loc), Loc);
10485 Make_Integer_Literal (Loc, J);
10487 Append_To (Union_TC_Params,
10488 Build_To_Any_Call (Expr, Decls));
10490 Add_Params_For_Variant_Components;
10495 when N_Others_Choice =>
10497 -- This variant possess a default choice.
10498 -- We must therefore set the default
10499 -- parameter to the current choice index. The
10500 -- default parameter is by construction the
10501 -- fourth in the Union_TC_Params list.
10504 Default_Node : constant Node_Id :=
10505 Pick (Union_TC_Params, 4);
10507 New_Default_Node : constant Node_Id :=
10508 Make_Function_Call (Loc,
10511 (RTE (RE_TA_LI), Loc),
10512 Parameter_Associations =>
10514 Make_Integer_Literal
10515 (Loc, Choice_Index)));
10521 Remove (Default_Node);
10524 -- Add a placeholder member label
10525 -- for the default case.
10526 -- It must be of the discriminant type.
10529 Exp : constant Node_Id :=
10530 Make_Attribute_Reference (Loc,
10531 Prefix => New_Occurrence_Of
10532 (Discriminant_Type, Loc),
10533 Attribute_Name => Name_First);
10535 Set_Etype (Exp, Discriminant_Type);
10536 Append_To (Union_TC_Params,
10537 Build_To_Any_Call (Exp, Decls));
10540 Add_Params_For_Variant_Components;
10544 -- Case of an explicit choice
10547 Exp : constant Node_Id :=
10548 New_Copy_Tree (Choice);
10550 Append_To (Union_TC_Params,
10551 Build_To_Any_Call (Exp, Decls));
10554 Add_Params_For_Variant_Components;
10558 Choice_Index := Choice_Index + 1;
10561 Next_Non_Pragma (Variant);
10565 end TC_Rec_Add_Process_Element;
10567 Type_Name_Str : String_Id;
10568 Type_Repo_Id_Str : String_Id;
10571 if Is_Itype (Typ) then
10572 Build_TypeCode_Function
10574 Typ => Etype (Typ),
10583 Make_Function_Specification (Loc,
10584 Defining_Unit_Name => Fnam,
10585 Parameter_Specifications => Empty_List,
10586 Result_Definition =>
10587 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10589 Build_Name_And_Repository_Id (Typ,
10590 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10592 Initialize_Parameter_List
10593 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10595 if Has_Stream_Attribute_Definition
10596 (Typ, TSS_Stream_Output, At_Any_Place => True)
10598 Has_Stream_Attribute_Definition
10599 (Typ, TSS_Stream_Write, At_Any_Place => True)
10601 -- If user-defined stream attributes are specified for this
10602 -- type, use them and transmit data as an opaque sequence of
10603 -- stream elements.
10605 Return_Alias_TypeCode
10606 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10608 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
10609 Return_Alias_TypeCode (
10610 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10612 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10613 Return_Alias_TypeCode (
10614 Build_TypeCode_Call (Loc,
10615 Find_Numeric_Representation (Typ), Decls));
10617 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
10619 -- Record typecodes are encoded as follows:
10623 -- | [Repository Id]
10625 -- Then for each discriminant:
10627 -- | [Discriminant Type Code]
10628 -- | [Discriminant Name]
10631 -- Then for each component:
10633 -- | [Component Type Code]
10634 -- | [Component Name]
10637 -- Variants components type codes are encoded as follows:
10641 -- | [Repository Id]
10642 -- | [Discriminant Type Code]
10643 -- | [Index of Default Variant Part or -1 for no default]
10645 -- Then for each Variant Part :
10650 -- | | [Variant Part Name]
10651 -- | | [Variant Part Repository Id]
10653 -- | Then for each VP component:
10654 -- | | [VP component Typecode]
10655 -- | | [VP component Name]
10661 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10662 Return_Alias_TypeCode
10663 (Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10667 Disc : Entity_Id := Empty;
10668 Rdef : constant Node_Id :=
10669 Type_Definition (Declaration_Node (Typ));
10670 Dummy_Counter : Int := 0;
10673 -- Construct the discriminants typecodes
10675 if Has_Discriminants (Typ) then
10676 Disc := First_Discriminant (Typ);
10679 while Present (Disc) loop
10680 Add_TypeCode_Parameter (
10681 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10683 Get_Name_String (Chars (Disc));
10684 Add_String_Parameter (
10685 String_From_Name_Buffer,
10687 Next_Discriminant (Disc);
10690 -- then the components typecodes
10692 TC_Append_Record_Traversal
10693 (Parameters, Component_List (Rdef),
10694 Empty, Dummy_Counter);
10695 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10699 elsif Is_Array_Type (Typ) then
10701 Ndim : constant Pos := Number_Dimensions (Typ);
10702 Inner_TypeCode : Node_Id;
10703 Constrained : constant Boolean := Is_Constrained (Typ);
10704 Indx : Node_Id := First_Index (Typ);
10708 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls);
10710 for J in 1 .. Ndim loop
10711 if Constrained then
10712 Inner_TypeCode := Make_Constructed_TypeCode
10713 (RTE (RE_TC_Array), New_List (
10714 Build_To_Any_Call (
10715 OK_Convert_To (RTE (RE_Long_Unsigned),
10716 Make_Attribute_Reference (Loc,
10717 Prefix => New_Occurrence_Of (Typ, Loc),
10718 Attribute_Name => Name_Length,
10719 Expressions => New_List (
10720 Make_Integer_Literal (Loc,
10721 Intval => Ndim - J + 1)))),
10723 Build_To_Any_Call (Inner_TypeCode, Decls)));
10726 -- Unconstrained case: add low bound for each
10729 Add_TypeCode_Parameter
10730 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10732 Get_Name_String (New_External_Name ('L', J));
10733 Add_String_Parameter (
10734 String_From_Name_Buffer,
10738 Inner_TypeCode := Make_Constructed_TypeCode
10739 (RTE (RE_TC_Sequence), New_List (
10740 Build_To_Any_Call (
10741 OK_Convert_To (RTE (RE_Long_Unsigned),
10742 Make_Integer_Literal (Loc, 0)),
10744 Build_To_Any_Call (Inner_TypeCode, Decls)));
10748 if Constrained then
10749 Return_Alias_TypeCode (Inner_TypeCode);
10751 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10753 Store_String_Char ('V');
10754 Add_String_Parameter (End_String, Parameters);
10755 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10760 -- Default: type is represented as an opaque sequence of bytes
10762 Return_Alias_TypeCode
10763 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10767 Make_Subprogram_Body (Loc,
10768 Specification => Spec,
10769 Declarations => Decls,
10770 Handled_Statement_Sequence =>
10771 Make_Handled_Sequence_Of_Statements (Loc,
10772 Statements => Stms));
10773 end Build_TypeCode_Function;
10775 ---------------------------------
10776 -- Find_Numeric_Representation --
10777 ---------------------------------
10779 function Find_Numeric_Representation
10780 (Typ : Entity_Id) return Entity_Id
10782 FST : constant Entity_Id := First_Subtype (Typ);
10783 P_Size : constant Uint := Esize (FST);
10786 if Is_Unsigned_Type (Typ) then
10787 if P_Size <= Standard_Short_Short_Integer_Size then
10788 return RTE (RE_Short_Short_Unsigned);
10790 elsif P_Size <= Standard_Short_Integer_Size then
10791 return RTE (RE_Short_Unsigned);
10793 elsif P_Size <= Standard_Integer_Size then
10794 return RTE (RE_Unsigned);
10796 elsif P_Size <= Standard_Long_Integer_Size then
10797 return RTE (RE_Long_Unsigned);
10800 return RTE (RE_Long_Long_Unsigned);
10803 elsif Is_Integer_Type (Typ) then
10804 if P_Size <= Standard_Short_Short_Integer_Size then
10805 return Standard_Short_Short_Integer;
10807 elsif P_Size <= Standard_Short_Integer_Size then
10808 return Standard_Short_Integer;
10810 elsif P_Size <= Standard_Integer_Size then
10811 return Standard_Integer;
10813 elsif P_Size <= Standard_Long_Integer_Size then
10814 return Standard_Long_Integer;
10817 return Standard_Long_Long_Integer;
10820 elsif Is_Floating_Point_Type (Typ) then
10821 if P_Size <= Standard_Short_Float_Size then
10822 return Standard_Short_Float;
10824 elsif P_Size <= Standard_Float_Size then
10825 return Standard_Float;
10827 elsif P_Size <= Standard_Long_Float_Size then
10828 return Standard_Long_Float;
10831 return Standard_Long_Long_Float;
10835 raise Program_Error;
10838 -- TBD: fixed point types???
10839 -- TBverified numeric types with a biased representation???
10841 end Find_Numeric_Representation;
10843 ---------------------------
10844 -- Append_Array_Traversal --
10845 ---------------------------
10847 procedure Append_Array_Traversal
10850 Counter : Entity_Id := Empty;
10853 Loc : constant Source_Ptr := Sloc (Subprogram);
10854 Typ : constant Entity_Id := Etype (Arry);
10855 Constrained : constant Boolean := Is_Constrained (Typ);
10856 Ndim : constant Pos := Number_Dimensions (Typ);
10858 Inner_Any, Inner_Counter : Entity_Id;
10860 Loop_Stm : Node_Id;
10861 Inner_Stmts : constant List_Id := New_List;
10864 if Depth > Ndim then
10866 -- Processing for one element of an array
10869 Element_Expr : constant Node_Id :=
10870 Make_Indexed_Component (Loc,
10871 New_Occurrence_Of (Arry, Loc),
10874 Set_Etype (Element_Expr, Component_Type (Typ));
10875 Add_Process_Element (Stmts,
10877 Counter => Counter,
10878 Datum => Element_Expr);
10884 Append_To (Indices,
10885 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10887 if not Constrained or else Depth > 1 then
10888 Inner_Any := Make_Defining_Identifier (Loc,
10889 New_External_Name ('A', Depth));
10890 Set_Etype (Inner_Any, RTE (RE_Any));
10892 Inner_Any := Empty;
10895 if Present (Counter) then
10896 Inner_Counter := Make_Defining_Identifier (Loc,
10897 New_External_Name ('J', Depth));
10899 Inner_Counter := Empty;
10903 Loop_Any : Node_Id := Inner_Any;
10906 -- For the first dimension of a constrained array, we add
10907 -- elements directly in the corresponding Any; there is no
10908 -- intervening inner Any.
10910 if No (Loop_Any) then
10914 Append_Array_Traversal (Inner_Stmts,
10916 Counter => Inner_Counter,
10917 Depth => Depth + 1);
10921 Make_Implicit_Loop_Statement (Subprogram,
10922 Iteration_Scheme =>
10923 Make_Iteration_Scheme (Loc,
10924 Loop_Parameter_Specification =>
10925 Make_Loop_Parameter_Specification (Loc,
10926 Defining_Identifier =>
10927 Make_Defining_Identifier (Loc,
10928 Chars => New_External_Name ('L', Depth)),
10930 Discrete_Subtype_Definition =>
10931 Make_Attribute_Reference (Loc,
10932 Prefix => New_Occurrence_Of (Arry, Loc),
10933 Attribute_Name => Name_Range,
10935 Expressions => New_List (
10936 Make_Integer_Literal (Loc, Depth))))),
10937 Statements => Inner_Stmts);
10940 Decls : constant List_Id := New_List;
10941 Dimen_Stmts : constant List_Id := New_List;
10942 Length_Node : Node_Id;
10944 Inner_Any_TypeCode : constant Entity_Id :=
10945 Make_Defining_Identifier (Loc,
10946 New_External_Name ('T', Depth));
10948 Inner_Any_TypeCode_Expr : Node_Id;
10952 if Constrained then
10953 Inner_Any_TypeCode_Expr :=
10954 Make_Function_Call (Loc,
10955 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
10956 Parameter_Associations => New_List (
10957 New_Occurrence_Of (Any, Loc)));
10959 Inner_Any_TypeCode_Expr :=
10960 Make_Function_Call (Loc,
10962 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
10963 Parameter_Associations => New_List (
10964 New_Occurrence_Of (Any, Loc),
10965 Make_Integer_Literal (Loc, Ndim)));
10968 Inner_Any_TypeCode_Expr :=
10969 Make_Function_Call (Loc,
10970 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc),
10971 Parameter_Associations => New_List (
10972 Make_Identifier (Loc,
10973 Chars => New_External_Name ('T', Depth - 1))));
10977 Make_Object_Declaration (Loc,
10978 Defining_Identifier => Inner_Any_TypeCode,
10979 Constant_Present => True,
10980 Object_Definition => New_Occurrence_Of (
10981 RTE (RE_TypeCode), Loc),
10982 Expression => Inner_Any_TypeCode_Expr));
10984 if Present (Inner_Any) then
10986 Make_Object_Declaration (Loc,
10987 Defining_Identifier => Inner_Any,
10988 Object_Definition =>
10989 New_Occurrence_Of (RTE (RE_Any), Loc),
10991 Make_Function_Call (Loc,
10993 New_Occurrence_Of (
10994 RTE (RE_Create_Any), Loc),
10995 Parameter_Associations => New_List (
10996 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
10999 if Present (Inner_Counter) then
11001 Make_Object_Declaration (Loc,
11002 Defining_Identifier => Inner_Counter,
11003 Object_Definition =>
11004 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
11006 Make_Integer_Literal (Loc, 0)));
11009 if not Constrained then
11010 Length_Node := Make_Attribute_Reference (Loc,
11011 Prefix => New_Occurrence_Of (Arry, Loc),
11012 Attribute_Name => Name_Length,
11014 New_List (Make_Integer_Literal (Loc, Depth)));
11015 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
11017 Add_Process_Element (Dimen_Stmts,
11018 Datum => Length_Node,
11020 Counter => Inner_Counter);
11023 -- Loop_Stm does appropriate processing for each element
11026 Append_To (Dimen_Stmts, Loop_Stm);
11028 -- Link outer and inner any
11030 if Present (Inner_Any) then
11031 Add_Process_Element (Dimen_Stmts,
11033 Counter => Counter,
11034 Datum => New_Occurrence_Of (Inner_Any, Loc));
11038 Make_Block_Statement (Loc,
11041 Handled_Statement_Sequence =>
11042 Make_Handled_Sequence_Of_Statements (Loc,
11043 Statements => Dimen_Stmts)));
11045 end Append_Array_Traversal;
11047 -------------------------------
11048 -- Make_Helper_Function_Name --
11049 -------------------------------
11051 function Make_Helper_Function_Name
11054 Nam : Name_Id) return Entity_Id
11059 -- For tagged types, we use a canonical name so that it matches
11060 -- the primitive spec. For all other cases, we use a serialized
11061 -- name so that multiple generations of the same procedure do
11065 if not Is_Tagged_Type (Typ) then
11066 Serial := Increment_Serial_Number;
11069 -- Use prefixed underscore to avoid potential clash with used
11070 -- identifier (we use attribute names for Nam).
11073 Make_Defining_Identifier (Loc,
11076 (Related_Id => Nam,
11077 Suffix => ' ', Suffix_Index => Serial,
11080 end Make_Helper_Function_Name;
11083 -----------------------------------
11084 -- Reserve_NamingContext_Methods --
11085 -----------------------------------
11087 procedure Reserve_NamingContext_Methods is
11088 Str_Resolve : constant String := "resolve";
11090 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11091 Name_Len := Str_Resolve'Length;
11092 Overload_Counter_Table.Set (Name_Find, 1);
11093 end Reserve_NamingContext_Methods;
11095 end PolyORB_Support;
11097 -------------------------------
11098 -- RACW_Type_Is_Asynchronous --
11099 -------------------------------
11101 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11102 Asynchronous_Flag : constant Entity_Id :=
11103 Asynchronous_Flags_Table.Get (RACW_Type);
11105 Replace (Expression (Parent (Asynchronous_Flag)),
11106 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11107 end RACW_Type_Is_Asynchronous;
11109 -------------------------
11110 -- RCI_Package_Locator --
11111 -------------------------
11113 function RCI_Package_Locator
11115 Package_Spec : Node_Id) return Node_Id
11118 Pkg_Name : String_Id;
11121 Get_Library_Unit_Name_String (Package_Spec);
11122 Pkg_Name := String_From_Name_Buffer;
11124 Make_Package_Instantiation (Loc,
11125 Defining_Unit_Name =>
11126 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
11128 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11129 Generic_Associations => New_List (
11130 Make_Generic_Association (Loc,
11132 Make_Identifier (Loc, Name_RCI_Name),
11133 Explicit_Generic_Actual_Parameter =>
11134 Make_String_Literal (Loc,
11135 Strval => Pkg_Name)),
11136 Make_Generic_Association (Loc,
11138 Make_Identifier (Loc, Name_Version),
11139 Explicit_Generic_Actual_Parameter =>
11140 Make_Attribute_Reference (Loc,
11142 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11146 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
11147 Defining_Unit_Name (Inst));
11149 end RCI_Package_Locator;
11151 -----------------------------------------------
11152 -- Remote_Types_Tagged_Full_View_Encountered --
11153 -----------------------------------------------
11155 procedure Remote_Types_Tagged_Full_View_Encountered
11156 (Full_View : Entity_Id)
11158 Stub_Elements : constant Stub_Structure :=
11159 Stubs_Table.Get (Full_View);
11162 -- For an RACW encountered before the freeze point of its designated
11163 -- type, the stub type is generated at the point of the RACW declaration
11164 -- but the primitives are generated only once the designated type is
11165 -- frozen. That freeze can occur in another scope, for example when the
11166 -- RACW is declared in a nested package. In that case we need to
11167 -- reestablish the stub type's scope prior to generating its primitive
11170 if Stub_Elements /= Empty_Stub_Structure then
11172 Saved_Scope : constant Entity_Id := Current_Scope;
11173 Stubs_Scope : constant Entity_Id :=
11174 Scope (Stub_Elements.Stub_Type);
11177 if Current_Scope /= Stubs_Scope then
11178 Push_Scope (Stubs_Scope);
11181 Add_RACW_Primitive_Declarations_And_Bodies
11183 Stub_Elements.RPC_Receiver_Decl,
11184 Stub_Elements.Body_Decls);
11186 if Current_Scope /= Saved_Scope then
11191 end Remote_Types_Tagged_Full_View_Encountered;
11193 -------------------
11194 -- Scope_Of_Spec --
11195 -------------------
11197 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11198 Unit_Name : Node_Id;
11201 Unit_Name := Defining_Unit_Name (Spec);
11202 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11203 Unit_Name := Defining_Identifier (Unit_Name);
11209 ----------------------
11210 -- Set_Renaming_TSS --
11211 ----------------------
11213 procedure Set_Renaming_TSS
11216 TSS_Nam : TSS_Name_Type)
11218 Loc : constant Source_Ptr := Sloc (Nam);
11219 Spec : constant Node_Id := Parent (Nam);
11221 TSS_Node : constant Node_Id :=
11222 Make_Subprogram_Renaming_Declaration (Loc,
11224 Copy_Specification (Loc,
11226 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11227 Name => New_Occurrence_Of (Nam, Loc));
11229 Snam : constant Entity_Id :=
11230 Defining_Unit_Name (Specification (TSS_Node));
11233 if Nkind (Spec) = N_Function_Specification then
11234 Set_Ekind (Snam, E_Function);
11235 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11237 Set_Ekind (Snam, E_Procedure);
11238 Set_Etype (Snam, Standard_Void_Type);
11241 Set_TSS (Typ, Snam);
11242 end Set_Renaming_TSS;
11244 ----------------------------------------------
11245 -- Specific_Add_Obj_RPC_Receiver_Completion --
11246 ----------------------------------------------
11248 procedure Specific_Add_Obj_RPC_Receiver_Completion
11251 RPC_Receiver : Entity_Id;
11252 Stub_Elements : Stub_Structure)
11255 case Get_PCS_Name is
11256 when Name_PolyORB_DSA =>
11257 PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11258 Decls, RPC_Receiver, Stub_Elements);
11260 GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11261 Decls, RPC_Receiver, Stub_Elements);
11263 end Specific_Add_Obj_RPC_Receiver_Completion;
11265 --------------------------------
11266 -- Specific_Add_RACW_Features --
11267 --------------------------------
11269 procedure Specific_Add_RACW_Features
11270 (RACW_Type : Entity_Id;
11272 Stub_Type : Entity_Id;
11273 Stub_Type_Access : Entity_Id;
11274 RPC_Receiver_Decl : Node_Id;
11275 Body_Decls : List_Id)
11278 case Get_PCS_Name is
11279 when Name_PolyORB_DSA =>
11280 PolyORB_Support.Add_RACW_Features
11289 GARLIC_Support.Add_RACW_Features
11296 end Specific_Add_RACW_Features;
11298 --------------------------------
11299 -- Specific_Add_RAST_Features --
11300 --------------------------------
11302 procedure Specific_Add_RAST_Features
11303 (Vis_Decl : Node_Id;
11304 RAS_Type : Entity_Id)
11307 case Get_PCS_Name is
11308 when Name_PolyORB_DSA =>
11309 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11311 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11313 end Specific_Add_RAST_Features;
11315 --------------------------------------------------
11316 -- Specific_Add_Receiving_Stubs_To_Declarations --
11317 --------------------------------------------------
11319 procedure Specific_Add_Receiving_Stubs_To_Declarations
11320 (Pkg_Spec : Node_Id;
11325 case Get_PCS_Name is
11326 when Name_PolyORB_DSA =>
11327 PolyORB_Support.Add_Receiving_Stubs_To_Declarations
11328 (Pkg_Spec, Decls, Stmts);
11330 GARLIC_Support.Add_Receiving_Stubs_To_Declarations
11331 (Pkg_Spec, Decls, Stmts);
11333 end Specific_Add_Receiving_Stubs_To_Declarations;
11335 ------------------------------------------
11336 -- Specific_Build_General_Calling_Stubs --
11337 ------------------------------------------
11339 procedure Specific_Build_General_Calling_Stubs
11341 Statements : List_Id;
11342 Target : RPC_Target;
11343 Subprogram_Id : Node_Id;
11344 Asynchronous : Node_Id := Empty;
11345 Is_Known_Asynchronous : Boolean := False;
11346 Is_Known_Non_Asynchronous : Boolean := False;
11347 Is_Function : Boolean;
11349 Stub_Type : Entity_Id := Empty;
11350 RACW_Type : Entity_Id := Empty;
11354 case Get_PCS_Name is
11355 when Name_PolyORB_DSA =>
11356 PolyORB_Support.Build_General_Calling_Stubs
11362 Is_Known_Asynchronous,
11363 Is_Known_Non_Asynchronous,
11371 GARLIC_Support.Build_General_Calling_Stubs
11375 Target.RPC_Receiver,
11378 Is_Known_Asynchronous,
11379 Is_Known_Non_Asynchronous,
11386 end Specific_Build_General_Calling_Stubs;
11388 --------------------------------------
11389 -- Specific_Build_RPC_Receiver_Body --
11390 --------------------------------------
11392 procedure Specific_Build_RPC_Receiver_Body
11393 (RPC_Receiver : Entity_Id;
11394 Request : out Entity_Id;
11395 Subp_Id : out Entity_Id;
11396 Subp_Index : out Entity_Id;
11397 Stmts : out List_Id;
11398 Decl : out Node_Id)
11401 case Get_PCS_Name is
11402 when Name_PolyORB_DSA =>
11403 PolyORB_Support.Build_RPC_Receiver_Body
11412 GARLIC_Support.Build_RPC_Receiver_Body
11420 end Specific_Build_RPC_Receiver_Body;
11422 --------------------------------
11423 -- Specific_Build_Stub_Target --
11424 --------------------------------
11426 function Specific_Build_Stub_Target
11429 RCI_Locator : Entity_Id;
11430 Controlling_Parameter : Entity_Id) return RPC_Target
11433 case Get_PCS_Name is
11434 when Name_PolyORB_DSA =>
11435 return PolyORB_Support.Build_Stub_Target (Loc,
11436 Decls, RCI_Locator, Controlling_Parameter);
11439 return GARLIC_Support.Build_Stub_Target (Loc,
11440 Decls, RCI_Locator, Controlling_Parameter);
11442 end Specific_Build_Stub_Target;
11444 ------------------------------
11445 -- Specific_Build_Stub_Type --
11446 ------------------------------
11448 procedure Specific_Build_Stub_Type
11449 (RACW_Type : Entity_Id;
11450 Stub_Type : Entity_Id;
11451 Stub_Type_Decl : out Node_Id;
11452 RPC_Receiver_Decl : out Node_Id)
11455 case Get_PCS_Name is
11456 when Name_PolyORB_DSA =>
11457 PolyORB_Support.Build_Stub_Type (
11458 RACW_Type, Stub_Type,
11459 Stub_Type_Decl, RPC_Receiver_Decl);
11462 GARLIC_Support.Build_Stub_Type (
11463 RACW_Type, Stub_Type,
11464 Stub_Type_Decl, RPC_Receiver_Decl);
11466 end Specific_Build_Stub_Type;
11468 function Specific_Build_Subprogram_Receiving_Stubs
11469 (Vis_Decl : Node_Id;
11470 Asynchronous : Boolean;
11471 Dynamically_Asynchronous : Boolean := False;
11472 Stub_Type : Entity_Id := Empty;
11473 RACW_Type : Entity_Id := Empty;
11474 Parent_Primitive : Entity_Id := Empty) return Node_Id
11477 case Get_PCS_Name is
11478 when Name_PolyORB_DSA =>
11479 return PolyORB_Support.Build_Subprogram_Receiving_Stubs
11482 Dynamically_Asynchronous,
11488 return GARLIC_Support.Build_Subprogram_Receiving_Stubs
11491 Dynamically_Asynchronous,
11496 end Specific_Build_Subprogram_Receiving_Stubs;
11498 -------------------------------
11499 -- Transmit_As_Unconstrained --
11500 -------------------------------
11502 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
11505 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
11506 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
11507 end Transmit_As_Unconstrained;
11509 --------------------------
11510 -- Underlying_RACW_Type --
11511 --------------------------
11513 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11514 Record_Type : Entity_Id;
11517 if Ekind (RAS_Typ) = E_Record_Type then
11518 Record_Type := RAS_Typ;
11520 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11521 Record_Type := Equivalent_Type (RAS_Typ);
11525 Etype (Subtype_Indication
11526 (Component_Definition
11527 (First (Component_Items
11530 (Declaration_Node (Record_Type))))))));
11531 end Underlying_RACW_Type;