1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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_Disp; use Exp_Disp;
31 with Exp_Strm; use Exp_Strm;
32 with Exp_Tss; use Exp_Tss;
33 with Exp_Util; use Exp_Util;
35 with Nlists; use Nlists;
36 with Nmake; use Nmake;
38 with Rtsfind; use Rtsfind;
40 with Sem_Aux; use Sem_Aux;
41 with Sem_Cat; use Sem_Cat;
42 with Sem_Ch3; use Sem_Ch3;
43 with Sem_Ch8; use Sem_Ch8;
44 with Sem_Dist; use Sem_Dist;
45 with Sem_Eval; use Sem_Eval;
46 with Sem_Util; use Sem_Util;
47 with Sinfo; use Sinfo;
48 with Stand; use Stand;
49 with Stringt; use Stringt;
50 with Tbuild; use Tbuild;
51 with Ttypes; use Ttypes;
52 with Uintp; use Uintp;
54 with GNAT.HTable; use GNAT.HTable;
56 package body Exp_Dist is
58 -- The following model has been used to implement distributed objects:
59 -- given a designated type D and a RACW type R, then a record of the form:
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 as RACW_Stub_Type, it can
68 -- be 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 arrives 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 RAS
86 -- information lookup operation. (This is for the Garlic code generation,
87 -- where subprograms are identified by numbers; in the PolyORB version,
88 -- they are identified by name, with a numeric suffix for homonyms.)
90 type Hash_Index is range 0 .. 50;
92 -----------------------
93 -- Local subprograms --
94 -----------------------
96 function Hash (F : Entity_Id) return Hash_Index;
97 -- DSA expansion associates stubs to distributed object types using a hash
98 -- table on entity ids.
100 function Hash (F : Name_Id) return Hash_Index;
101 -- The generation of subprogram identifiers requires an overload counter
102 -- to be associated with each remote subprogram name. These counters are
103 -- maintained in a hash table on name ids.
105 type Subprogram_Identifiers is record
106 Str_Identifier : String_Id;
107 Int_Identifier : Int;
110 package Subprogram_Identifier_Table is
111 new Simple_HTable (Header_Num => Hash_Index,
112 Element => Subprogram_Identifiers,
113 No_Element => (No_String, 0),
117 -- Mapping between a remote subprogram and the corresponding subprogram
120 package Overload_Counter_Table is
121 new Simple_HTable (Header_Num => Hash_Index,
127 -- Mapping between a subprogram name and an integer that counts the number
128 -- of defining subprogram names with that Name_Id encountered so far in a
129 -- given context (an interface).
131 function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
132 function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
133 function Get_Subprogram_Id (Def : Entity_Id) return Int;
134 -- Given a subprogram defined in a RCI package, get its distribution
135 -- subprogram identifiers (the distribution identifiers are a unique
136 -- subprogram number, and the non-qualified subprogram name, in the
137 -- casing used for the subprogram declaration; if the name is overloaded,
138 -- a double underscore and a serial number are appended.
140 -- The integer identifier is used to perform remote calls with GARLIC;
141 -- the string identifier is used in the case of PolyORB.
143 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
144 -- when receiving a call, the calling stubs will create requests with the
145 -- exact casing of the defining unit name of the called subprogram, so as
146 -- to allow calls to subprograms on distributed nodes that do distinguish
149 -- NOTE: Another design would be to allow a representation clause on
150 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
152 pragma Warnings (Off, Get_Subprogram_Id);
153 -- One homonym only is unreferenced (specific to the GARLIC version)
155 procedure Add_RAS_Dereference_TSS (N : Node_Id);
156 -- Add a subprogram body for RAS Dereference TSS
158 procedure Add_RAS_Proxy_And_Analyze
161 All_Calls_Remote_E : Entity_Id;
162 Proxy_Object_Addr : out Entity_Id);
163 -- Add the proxy type required, on the receiving (server) side, to handle
164 -- calls to the subprogram declared by Vis_Decl through a remote access
165 -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
166 -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
167 -- is appended to Decls. Proxy_Object_Addr is a constant of type
168 -- System.Address that designates an instance of the proxy object.
170 function Build_Remote_Subprogram_Proxy_Type
172 ACR_Expression : Node_Id) return Node_Id;
173 -- Build and return a tagged record type definition for an RCI subprogram
174 -- proxy type. ACR_Expression is used as the initialization value for the
175 -- All_Calls_Remote component.
177 function Build_Get_Unique_RP_Call
180 Stub_Type : Entity_Id) return List_Id;
181 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
182 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
183 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
185 function Build_Stub_Tag
187 RACW_Type : Entity_Id) return Node_Id;
188 -- Return an expression denoting the tag of the stub type associated with
191 function Build_Subprogram_Calling_Stubs
194 Asynchronous : Boolean;
195 Dynamically_Asynchronous : Boolean := False;
196 Stub_Type : Entity_Id := Empty;
197 RACW_Type : Entity_Id := Empty;
198 Locator : Entity_Id := Empty;
199 New_Name : Name_Id := No_Name) return Node_Id;
200 -- Build the calling stub for a given subprogram with the subprogram ID
201 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
202 -- parameters of this type will be marshalled instead of the object itself.
203 -- It will then be converted into Stub_Type before performing the real
204 -- call. If Dynamically_Asynchronous is True, then it will be computed at
205 -- run time whether the call is asynchronous or not. Otherwise, the value
206 -- of the formal Asynchronous will be used. If Locator is not Empty, it
207 -- will be used instead of RCI_Cache. If New_Name is given, then it will
208 -- be used instead of the original name.
210 function Build_RPC_Receiver_Specification
211 (RPC_Receiver : Entity_Id;
212 Request_Parameter : Entity_Id) return Node_Id;
213 -- Make a subprogram specification for an RPC receiver, with the given
214 -- defining unit name and formal parameter.
216 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
217 -- Return an ordered parameter list: unconstrained parameters are put
218 -- at the beginning of the list and constrained ones are put after. If
219 -- there are no parameters, an empty list is returned. Special case:
220 -- the controlling formal of the equivalent RACW operation for a RAS
221 -- type is always left in first position.
223 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean;
224 -- True when Typ is an unconstrained type, or a null-excluding access type.
225 -- In either case, this means stubs cannot contain a default-initialized
226 -- object declaration of such type.
228 procedure Add_Calling_Stubs_To_Declarations
231 -- Add calling stubs to the declarative part
233 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
234 -- Return True if nothing prevents the program whose specification is
235 -- given to be asynchronous (i.e. no [IN] OUT parameters).
237 function Pack_Entity_Into_Stream_Access
241 Etyp : Entity_Id := Empty) return Node_Id;
242 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
243 -- then Etype (Object) will be used if present. If the type is
244 -- constrained, then 'Write will be used to output the object,
245 -- If the type is unconstrained, 'Output will be used.
247 function Pack_Node_Into_Stream
251 Etyp : Entity_Id) return Node_Id;
252 -- Similar to above, with an arbitrary node instead of an entity
254 function Pack_Node_Into_Stream_Access
258 Etyp : Entity_Id) return Node_Id;
259 -- Similar to above, with Stream instead of Stream'Access
261 function Make_Selected_Component
264 Selector_Name : Name_Id) return Node_Id;
265 -- Return a selected_component whose prefix denotes the given entity, and
266 -- with the given Selector_Name.
268 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
269 -- Return the scope represented by a given spec
271 procedure Set_Renaming_TSS
274 TSS_Nam : TSS_Name_Type);
275 -- Create a renaming declaration of subprogram Nam, and register it as a
276 -- TSS for Typ with name TSS_Nam.
278 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
279 -- Return True if the current parameter needs an extra formal to reflect
280 -- its constrained status.
282 function Is_RACW_Controlling_Formal
283 (Parameter : Node_Id;
284 Stub_Type : Entity_Id) return Boolean;
285 -- Return True if the current parameter is a controlling formal argument
286 -- of type Stub_Type or access to Stub_Type.
288 procedure Declare_Create_NVList
293 -- Append the declaration of NVList to Decls, and its
294 -- initialization to Stmts.
296 function Add_Parameter_To_NVList
299 Parameter : Entity_Id;
300 Constrained : Boolean;
301 RACW_Ctrl : Boolean := False;
302 Any : Entity_Id) return Node_Id;
303 -- Return a call to Add_Item to add the Any corresponding to the designated
304 -- formal Parameter (with the indicated Constrained status) to NVList.
305 -- RACW_Ctrl must be set to True for controlling formals of distributed
306 -- object primitive operations.
312 -- This record describes various tree fragments associated with the
313 -- generation of RACW calling stubs. One such record exists for every
314 -- distributed object type, i.e. each tagged type that is the designated
315 -- type of one or more RACW type.
317 type Stub_Structure is record
318 Stub_Type : Entity_Id;
319 -- Stub type: this type has the same primitive operations as the
320 -- designated types, but the provided bodies for these operations
321 -- a remote call to an actual target object potentially located on
322 -- another partition; each value of the stub type encapsulates a
323 -- reference to a remote object.
325 Stub_Type_Access : Entity_Id;
326 -- A local access type designating the stub type (this is not an RACW
329 RPC_Receiver_Decl : Node_Id;
330 -- Declaration for the RPC receiver entity associated with the
331 -- designated type. As an exception, for the case of an RACW that
332 -- implements a RAS, no object RPC receiver is generated. Instead,
333 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
334 -- would have been inserted.
336 Body_Decls : List_Id;
337 -- List of subprogram bodies to be included in generated code: bodies
338 -- for the RACW's stream attributes, and for the primitive operations
341 RACW_Type : Entity_Id;
342 -- One of the RACW types designating this distributed object type
343 -- (they are all interchangeable; we use any one of them in order to
344 -- avoid having to create various anonymous access types).
348 Empty_Stub_Structure : constant Stub_Structure :=
349 (Empty, Empty, Empty, No_List, Empty);
351 package Stubs_Table is
352 new Simple_HTable (Header_Num => Hash_Index,
353 Element => Stub_Structure,
354 No_Element => Empty_Stub_Structure,
358 -- Mapping between a RACW designated type and its stub type
360 package Asynchronous_Flags_Table is
361 new Simple_HTable (Header_Num => Hash_Index,
362 Element => Entity_Id,
367 -- Mapping between a RACW type and a constant having the value True
368 -- if the RACW is asynchronous and False otherwise.
370 package RCI_Locator_Table is
371 new Simple_HTable (Header_Num => Hash_Index,
372 Element => Entity_Id,
377 -- Mapping between a RCI package on which All_Calls_Remote applies and
378 -- the generic instantiation of RCI_Locator for this package.
380 package RCI_Calling_Stubs_Table is
381 new Simple_HTable (Header_Num => Hash_Index,
382 Element => Entity_Id,
387 -- Mapping between a RCI subprogram and the corresponding calling stubs
389 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure;
390 -- Return the stub information associated with the given RACW type
392 procedure Add_Stub_Type
393 (Designated_Type : Entity_Id;
394 RACW_Type : Entity_Id;
396 Stub_Type : out Entity_Id;
397 Stub_Type_Access : out Entity_Id;
398 RPC_Receiver_Decl : out Node_Id;
399 Body_Decls : out List_Id;
400 Existing : out Boolean);
401 -- Add the declaration of the stub type, the access to stub type and the
402 -- object RPC receiver at the end of Decls. If these already exist,
403 -- then nothing is added in the tree but the right values are returned
404 -- anyhow and Existing is set to True.
406 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
407 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
408 -- structure table, reset it to No_List, and return the previous value.
410 procedure Add_RACW_Asynchronous_Flag
411 (Declarations : List_Id;
412 RACW_Type : Entity_Id);
413 -- Declare a boolean constant associated with RACW_Type whose value
414 -- indicates at run time whether a pragma Asynchronous applies to it.
416 procedure Assign_Subprogram_Identifier
420 -- Determine the distribution subprogram identifier to
421 -- be used for remote subprogram Def, return it in Id and
422 -- store it in a hash table for later retrieval by
423 -- Get_Subprogram_Id. Spn is the subprogram number.
425 function RCI_Package_Locator
427 Package_Spec : Node_Id) return Node_Id;
428 -- Instantiate the generic package RCI_Locator in order to locate the
429 -- RCI package whose spec is given as argument.
431 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
432 -- Surround a node N by a tag check, as in:
436 -- when E : Ada.Tags.Tag_Error =>
437 -- Raise_Exception (Program_Error'Identity,
438 -- Exception_Message (E));
441 function Input_With_Tag_Check
443 Var_Type : Entity_Id;
444 Stream : Node_Id) return Node_Id;
445 -- Return a function with the following form:
446 -- function R return Var_Type is
448 -- return Var_Type'Input (S);
450 -- when E : Ada.Tags.Tag_Error =>
451 -- Raise_Exception (Program_Error'Identity,
452 -- Exception_Message (E));
455 procedure Build_Actual_Object_Declaration
461 -- Build the declaration of an object with the given defining identifier,
462 -- initialized with Expr if provided, to serve as actual parameter in a
463 -- server stub. If Variable is true, the declared object will be a variable
464 -- (case of an out or in out formal), else it will be a constant. Object's
465 -- Ekind is set accordingly. The declaration, as well as any other
466 -- declarations it requires, are appended to Decls.
468 --------------------------------------------
469 -- Hooks for PCS-specific code generation --
470 --------------------------------------------
472 -- Part of the code generation circuitry for distribution needs to be
473 -- tailored for each implementation of the PCS. For each routine that
474 -- needs to be specialized, a Specific_<routine> wrapper is created,
475 -- which calls the corresponding <routine> in package
476 -- <pcs_implementation>_Support.
478 procedure Specific_Add_RACW_Features
479 (RACW_Type : Entity_Id;
481 Stub_Type : Entity_Id;
482 Stub_Type_Access : Entity_Id;
483 RPC_Receiver_Decl : Node_Id;
484 Body_Decls : List_Id);
485 -- Add declaration for TSSs for a given RACW type. The declarations are
486 -- added just after the declaration of the RACW type itself. If the RACW
487 -- appears in the main unit, Body_Decls is a list of declarations to which
488 -- the bodies are appended. Else Body_Decls is No_List.
489 -- PCS-specific ancillary subprogram for Add_RACW_Features.
491 procedure Specific_Add_RAST_Features
493 RAS_Type : Entity_Id);
494 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
495 -- subprogram for Add_RAST_Features.
497 -- An RPC_Target record is used during construction of calling stubs
498 -- to pass PCS-specific tree fragments corresponding to the information
499 -- necessary to locate the target of a remote subprogram call.
501 type RPC_Target (PCS_Kind : PCS_Names) is record
503 when Name_PolyORB_DSA =>
505 -- An expression whose value is a PolyORB reference to the target
509 Partition : Entity_Id;
510 -- A variable containing the Partition_ID of the target partition
512 RPC_Receiver : Node_Id;
513 -- An expression whose value is the address of the target RPC
518 procedure Specific_Build_General_Calling_Stubs
520 Statements : List_Id;
522 Subprogram_Id : Node_Id;
523 Asynchronous : Node_Id := Empty;
524 Is_Known_Asynchronous : Boolean := False;
525 Is_Known_Non_Asynchronous : Boolean := False;
526 Is_Function : Boolean;
528 Stub_Type : Entity_Id := Empty;
529 RACW_Type : Entity_Id := Empty;
531 -- Build calling stubs for general purpose. The parameters are:
532 -- Decls : a place to put declarations
533 -- Statements : a place to put statements
534 -- Target : PCS-specific target information (see details
535 -- in RPC_Target declaration).
536 -- Subprogram_Id : a node containing the subprogram ID
537 -- Asynchronous : True if an APC must be made instead of an RPC.
538 -- The value needs not be supplied if one of the
539 -- Is_Known_... is True.
540 -- Is_Known_Async... : True if we know that this is asynchronous
541 -- Is_Known_Non_A... : True if we know that this is not asynchronous
542 -- Spec : a node with a Parameter_Specifications and
543 -- a Result_Definition if applicable
544 -- Stub_Type : in case of RACW stubs, parameters of type access
545 -- to Stub_Type will be marshalled using the
546 -- address of the object (the addr field) rather
547 -- than using the 'Write on the stub itself
548 -- Nod : used to provide sloc for generated code
550 function Specific_Build_Stub_Target
553 RCI_Locator : Entity_Id;
554 Controlling_Parameter : Entity_Id) return RPC_Target;
555 -- Build call target information nodes for use within calling stubs. In the
556 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
557 -- for an RACW, Controlling_Parameter is the entity for the controlling
558 -- formal parameter used to determine the location of the target of the
559 -- call. Decls provides a location where variable declarations can be
560 -- appended to construct the necessary values.
562 procedure Specific_Build_Stub_Type
563 (RACW_Type : Entity_Id;
564 Stub_Type_Comps : out List_Id;
565 RPC_Receiver_Decl : out Node_Id);
566 -- Build a components list for the stub type associated with an RACW type,
567 -- and build the necessary RPC receiver, if applicable. PCS-specific
568 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
569 -- is generated, then RPC_Receiver_Decl is set to Empty.
571 procedure Specific_Build_RPC_Receiver_Body
572 (RPC_Receiver : Entity_Id;
573 Request : out Entity_Id;
574 Subp_Id : out Entity_Id;
575 Subp_Index : out Entity_Id;
578 -- Make a subprogram body for an RPC receiver, with the given
579 -- defining unit name. On return:
580 -- - Subp_Id is the subprogram identifier from the PCS.
581 -- - Subp_Index is the index in the list of subprograms
582 -- used for dispatching (a variable of type Subprogram_Id).
583 -- - Stmts is the place where the request dispatching
584 -- statements can occur,
585 -- - Decl is the subprogram body declaration.
587 function Specific_Build_Subprogram_Receiving_Stubs
589 Asynchronous : Boolean;
590 Dynamically_Asynchronous : Boolean := False;
591 Stub_Type : Entity_Id := Empty;
592 RACW_Type : Entity_Id := Empty;
593 Parent_Primitive : Entity_Id := Empty) return Node_Id;
594 -- Build the receiving stub for a given subprogram. The subprogram
595 -- declaration is also built by this procedure, and the value returned
596 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
597 -- found in the specification, then its address is read from the stream
598 -- instead of the object itself and converted into an access to
599 -- class-wide type before doing the real call using any of the RACW type
600 -- pointing on the designated type.
602 procedure Specific_Add_Obj_RPC_Receiver_Completion
605 RPC_Receiver : Entity_Id;
606 Stub_Elements : Stub_Structure);
607 -- Add the necessary code to Decls after the completion of generation
608 -- of the RACW RPC receiver described by Stub_Elements.
610 procedure Specific_Add_Receiving_Stubs_To_Declarations
614 -- Add receiving stubs to the declarative part of an RCI unit
620 package GARLIC_Support is
622 -- Support for generating DSA code that uses the GARLIC PCS
624 -- The subprograms below provide the GARLIC versions of the
625 -- corresponding Specific_<subprogram> routine declared above.
627 procedure Add_RACW_Features
628 (RACW_Type : Entity_Id;
629 Stub_Type : Entity_Id;
630 Stub_Type_Access : Entity_Id;
631 RPC_Receiver_Decl : Node_Id;
632 Body_Decls : List_Id);
634 procedure Add_RAST_Features
636 RAS_Type : Entity_Id);
638 procedure Build_General_Calling_Stubs
640 Statements : List_Id;
641 Target_Partition : Entity_Id; -- From RPC_Target
642 Target_RPC_Receiver : Node_Id; -- From RPC_Target
643 Subprogram_Id : Node_Id;
644 Asynchronous : Node_Id := Empty;
645 Is_Known_Asynchronous : Boolean := False;
646 Is_Known_Non_Asynchronous : Boolean := False;
647 Is_Function : Boolean;
649 Stub_Type : Entity_Id := Empty;
650 RACW_Type : Entity_Id := Empty;
653 function Build_Stub_Target
656 RCI_Locator : Entity_Id;
657 Controlling_Parameter : Entity_Id) return RPC_Target;
659 procedure Build_Stub_Type
660 (RACW_Type : Entity_Id;
661 Stub_Type_Comps : out List_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 ---------------------
694 -- PolyORB_Support --
695 ---------------------
697 package PolyORB_Support is
699 -- Support for generating DSA code that uses the PolyORB PCS
701 -- The subprograms below provide the PolyORB versions of the
702 -- corresponding Specific_<subprogram> routine declared above.
704 procedure Add_RACW_Features
705 (RACW_Type : Entity_Id;
707 Stub_Type : Entity_Id;
708 Stub_Type_Access : Entity_Id;
709 RPC_Receiver_Decl : Node_Id;
710 Body_Decls : List_Id);
712 procedure Add_RAST_Features
714 RAS_Type : Entity_Id);
716 procedure Build_General_Calling_Stubs
718 Statements : List_Id;
719 Target_Object : Node_Id; -- From RPC_Target
720 Subprogram_Id : Node_Id;
721 Asynchronous : Node_Id := Empty;
722 Is_Known_Asynchronous : Boolean := False;
723 Is_Known_Non_Asynchronous : Boolean := False;
724 Is_Function : Boolean;
726 Stub_Type : Entity_Id := Empty;
727 RACW_Type : Entity_Id := Empty;
730 function Build_Stub_Target
733 RCI_Locator : Entity_Id;
734 Controlling_Parameter : Entity_Id) return RPC_Target;
736 procedure Build_Stub_Type
737 (RACW_Type : Entity_Id;
738 Stub_Type_Comps : out List_Id;
739 RPC_Receiver_Decl : out Node_Id);
741 function Build_Subprogram_Receiving_Stubs
743 Asynchronous : Boolean;
744 Dynamically_Asynchronous : Boolean := False;
745 Stub_Type : Entity_Id := Empty;
746 RACW_Type : Entity_Id := Empty;
747 Parent_Primitive : Entity_Id := Empty) return Node_Id;
749 procedure Add_Obj_RPC_Receiver_Completion
752 RPC_Receiver : Entity_Id;
753 Stub_Elements : Stub_Structure);
755 procedure Add_Receiving_Stubs_To_Declarations
760 procedure Build_RPC_Receiver_Body
761 (RPC_Receiver : Entity_Id;
762 Request : out Entity_Id;
763 Subp_Id : out Entity_Id;
764 Subp_Index : out Entity_Id;
768 procedure Reserve_NamingContext_Methods;
769 -- Mark the method names for interface NamingContext as already used in
770 -- the overload table, so no clashes occur with user code (with the
771 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
772 -- their methods to be accessed as objects, for the implementation of
773 -- remote access-to-subprogram types).
781 -- Routines to build distribution helper subprograms for user-defined
782 -- types. For implementation of the Distributed systems annex (DSA)
783 -- over the PolyORB generic middleware components, it is necessary to
784 -- generate several supporting subprograms for each application data
785 -- type used in inter-partition communication. These subprograms are:
787 -- A Typecode function returning a high-level description of the
790 -- Two conversion functions allowing conversion of values of the
791 -- type from and to the generic data containers used by PolyORB.
792 -- These generic containers are called 'Any' type values after the
793 -- CORBA terminology, and hence the conversion subprograms are
794 -- named To_Any and From_Any.
796 function Build_From_Any_Call
799 Decls : List_Id) return Node_Id;
800 -- Build call to From_Any attribute function of type Typ with
801 -- expression N as actual parameter. Decls is the declarations list
802 -- for an appropriate enclosing scope of the point where the call
803 -- will be inserted; if the From_Any attribute for Typ needs to be
804 -- generated at this point, its declaration is appended to Decls.
806 procedure Build_From_Any_Function
810 Fnam : out Entity_Id);
811 -- Build From_Any attribute function for Typ. Loc is the reference
812 -- location for generated nodes, Typ is the type for which the
813 -- conversion function is generated. On return, Decl and Fnam contain
814 -- the declaration and entity for the newly-created function.
816 function Build_To_Any_Call
818 Decls : List_Id) return Node_Id;
819 -- Build call to To_Any attribute function with expression as actual
820 -- parameter. Decls is the declarations list for an appropriate
821 -- enclosing scope of the point where the call will be inserted; if
822 -- the To_Any attribute for Typ needs to be generated at this point,
823 -- its declaration is appended to Decls.
825 procedure Build_To_Any_Function
829 Fnam : out Entity_Id);
830 -- Build To_Any attribute function for Typ. Loc is the reference
831 -- location for generated nodes, Typ is the type for which the
832 -- conversion function is generated. On return, Decl and Fnam contain
833 -- the declaration and entity for the newly-created function.
835 function Build_TypeCode_Call
838 Decls : List_Id) return Node_Id;
839 -- Build call to TypeCode attribute function for Typ. Decls is the
840 -- declarations list for an appropriate enclosing scope of the point
841 -- where the call will be inserted; if the To_Any attribute for Typ
842 -- needs to be generated at this point, its declaration is appended
845 procedure Build_TypeCode_Function
849 Fnam : out Entity_Id);
850 -- Build TypeCode attribute function for Typ. Loc is the reference
851 -- location for generated nodes, Typ is the type for which the
852 -- conversion function is generated. On return, Decl and Fnam contain
853 -- the declaration and entity for the newly-created function.
855 procedure Build_Name_And_Repository_Id
857 Name_Str : out String_Id;
858 Repo_Id_Str : out String_Id);
859 -- In the PolyORB distribution model, each distributed object type
860 -- and each distributed operation has a globally unique identifier,
861 -- its Repository Id. This subprogram builds and returns two strings
862 -- for entity E (a distributed object type or operation): one
863 -- containing the name of E, the second containing its repository id.
865 procedure Assign_Opaque_From_Any
871 -- For a Target object of type Typ, which has opaque representation
872 -- as a sequence of octets determined by stream attributes (which
873 -- includes all limited types), append code to Stmts performing the
875 -- Target := Typ'From_Any (N)
877 -- or, if Target is Empty:
878 -- return Typ'From_Any (N)
884 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
886 function Build_From_Any_Call
889 Decls : List_Id) return Node_Id
890 renames PolyORB_Support.Helpers.Build_From_Any_Call;
892 function Build_To_Any_Call
894 Decls : List_Id) return Node_Id
895 renames PolyORB_Support.Helpers.Build_To_Any_Call;
897 function Build_TypeCode_Call
900 Decls : List_Id) return Node_Id
901 renames PolyORB_Support.Helpers.Build_TypeCode_Call;
903 ------------------------------------
904 -- Local variables and structures --
905 ------------------------------------
908 -- Needs comments ???
910 Output_From_Constrained : constant array (Boolean) of Name_Id :=
911 (False => Name_Output,
913 -- The attribute to choose depending on the fact that the parameter
914 -- is constrained or not. There is no such thing as Input_From_Constrained
915 -- since this require separate mechanisms ('Input is a function while
916 -- 'Read is a procedure).
918 ---------------------------------------
919 -- Add_Calling_Stubs_To_Declarations --
920 ---------------------------------------
922 procedure Add_Calling_Stubs_To_Declarations
926 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
927 -- Subprogram id 0 is reserved for calls received from
928 -- remote access-to-subprogram dereferences.
930 Current_Declaration : Node_Id;
931 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
932 RCI_Instantiation : Node_Id;
933 Subp_Stubs : Node_Id;
934 Subp_Str : String_Id;
936 pragma Warnings (Off, Subp_Str);
939 -- The first thing added is an instantiation of the generic package
940 -- System.Partition_Interface.RCI_Locator with the name of this remote
941 -- package. This will act as an interface with the name server to
942 -- determine the Partition_ID and the RPC_Receiver for the receiver
945 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
946 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
948 Append_To (Decls, RCI_Instantiation);
949 Analyze (RCI_Instantiation);
951 -- For each subprogram declaration visible in the spec, we do build a
952 -- body. We also increment a counter to assign a different Subprogram_Id
953 -- to each subprograms. The receiving stubs processing do use the same
954 -- mechanism and will thus assign the same Id and do the correct
957 Overload_Counter_Table.Reset;
958 PolyORB_Support.Reserve_NamingContext_Methods;
960 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
961 while Present (Current_Declaration) loop
962 if Nkind (Current_Declaration) = N_Subprogram_Declaration
963 and then Comes_From_Source (Current_Declaration)
965 Assign_Subprogram_Identifier
966 (Defining_Unit_Name (Specification (Current_Declaration)),
967 Current_Subprogram_Number,
971 Build_Subprogram_Calling_Stubs (
972 Vis_Decl => Current_Declaration,
974 Build_Subprogram_Id (Loc,
975 Defining_Unit_Name (Specification (Current_Declaration))),
977 Nkind (Specification (Current_Declaration)) =
978 N_Procedure_Specification
980 Is_Asynchronous (Defining_Unit_Name (Specification
981 (Current_Declaration))));
983 Append_To (Decls, Subp_Stubs);
984 Analyze (Subp_Stubs);
986 Current_Subprogram_Number := Current_Subprogram_Number + 1;
989 Next (Current_Declaration);
991 end Add_Calling_Stubs_To_Declarations;
993 -----------------------------
994 -- Add_Parameter_To_NVList --
995 -----------------------------
997 function Add_Parameter_To_NVList
1000 Parameter : Entity_Id;
1001 Constrained : Boolean;
1002 RACW_Ctrl : Boolean := False;
1003 Any : Entity_Id) return Node_Id
1005 Parameter_Name_String : String_Id;
1006 Parameter_Mode : Node_Id;
1008 function Parameter_Passing_Mode
1010 Parameter : Entity_Id;
1011 Constrained : Boolean) return Node_Id;
1012 -- Return an expression that denotes the parameter passing mode to be
1013 -- used for Parameter in distribution stubs, where Constrained is
1014 -- Parameter's constrained status.
1016 ----------------------------
1017 -- Parameter_Passing_Mode --
1018 ----------------------------
1020 function Parameter_Passing_Mode
1022 Parameter : Entity_Id;
1023 Constrained : Boolean) return Node_Id
1028 if Out_Present (Parameter) then
1029 if In_Present (Parameter)
1030 or else not Constrained
1032 -- Unconstrained formals must be translated
1033 -- to 'in' or 'inout', not 'out', because
1034 -- they need to be constrained by the actual.
1036 Lib_RE := RE_Mode_Inout;
1038 Lib_RE := RE_Mode_Out;
1042 Lib_RE := RE_Mode_In;
1045 return New_Occurrence_Of (RTE (Lib_RE), Loc);
1046 end Parameter_Passing_Mode;
1048 -- Start of processing for Add_Parameter_To_NVList
1051 if Nkind (Parameter) = N_Defining_Identifier then
1052 Get_Name_String (Chars (Parameter));
1054 Get_Name_String (Chars (Defining_Identifier (Parameter)));
1057 Parameter_Name_String := String_From_Name_Buffer;
1059 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1061 -- When the parameter passed to Add_Parameter_To_NVList is an
1062 -- Extra_Constrained parameter, Parameter is an N_Defining_
1063 -- Identifier, instead of a complete N_Parameter_Specification.
1064 -- Thus, we explicitly set 'in' mode in this case.
1066 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1070 Parameter_Passing_Mode (Loc, Parameter, Constrained);
1074 Make_Procedure_Call_Statement (Loc,
1077 (RTE (RE_NVList_Add_Item), Loc),
1078 Parameter_Associations => New_List (
1079 New_Occurrence_Of (NVList, Loc),
1080 Make_Function_Call (Loc,
1083 (RTE (RE_To_PolyORB_String), Loc),
1084 Parameter_Associations => New_List (
1085 Make_String_Literal (Loc,
1086 Strval => Parameter_Name_String))),
1087 New_Occurrence_Of (Any, Loc),
1089 end Add_Parameter_To_NVList;
1091 --------------------------------
1092 -- Add_RACW_Asynchronous_Flag --
1093 --------------------------------
1095 procedure Add_RACW_Asynchronous_Flag
1096 (Declarations : List_Id;
1097 RACW_Type : Entity_Id)
1099 Loc : constant Source_Ptr := Sloc (RACW_Type);
1101 Asynchronous_Flag : constant Entity_Id :=
1102 Make_Defining_Identifier (Loc,
1103 New_External_Name (Chars (RACW_Type), 'A'));
1106 -- Declare the asynchronous flag. This flag will be changed to True
1107 -- whenever it is known that the RACW type is asynchronous.
1109 Append_To (Declarations,
1110 Make_Object_Declaration (Loc,
1111 Defining_Identifier => Asynchronous_Flag,
1112 Constant_Present => True,
1113 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1114 Expression => New_Occurrence_Of (Standard_False, Loc)));
1116 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1117 end Add_RACW_Asynchronous_Flag;
1119 -----------------------
1120 -- Add_RACW_Features --
1121 -----------------------
1123 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1124 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1125 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1129 Body_Decls : List_Id;
1131 Stub_Type : Entity_Id;
1132 Stub_Type_Access : Entity_Id;
1133 RPC_Receiver_Decl : Node_Id;
1136 -- True when appropriate stubs have already been generated (this is the
1137 -- case when another RACW with the same designated type has already been
1138 -- encountered), in which case we reuse the previous stubs rather than
1139 -- generating new ones.
1142 if not Expander_Active then
1146 -- Mark the current package declaration as containing an RACW, so that
1147 -- the bodies for the calling stubs and the RACW stream subprograms
1148 -- are attached to the tree when the corresponding body is encountered.
1150 Set_Has_RACW (Current_Scope);
1152 -- Look for place to declare the RACW stub type and RACW operations
1158 -- Case of declaring the RACW in the same package as its designated
1159 -- type: we know that the designated type is a private type, so we
1160 -- use the private declarations list.
1162 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1164 if Present (Private_Declarations (Pkg_Spec)) then
1165 Decls := Private_Declarations (Pkg_Spec);
1167 Decls := Visible_Declarations (Pkg_Spec);
1171 -- Case of declaring the RACW in another package than its designated
1172 -- type: use the private declarations list if present; otherwise
1173 -- use the visible declarations.
1175 Decls := List_Containing (Declaration_Node (RACW_Type));
1179 -- If we were unable to find the declarations, that means that the
1180 -- completion of the type was missing. We can safely return and let the
1181 -- error be caught by the semantic analysis.
1188 (Designated_Type => Desig,
1189 RACW_Type => RACW_Type,
1191 Stub_Type => Stub_Type,
1192 Stub_Type_Access => Stub_Type_Access,
1193 RPC_Receiver_Decl => RPC_Receiver_Decl,
1194 Body_Decls => Body_Decls,
1195 Existing => Existing);
1197 -- If this RACW is not in the main unit, do not generate primitive or
1200 if not Entity_Is_In_Main_Unit (RACW_Type) then
1201 Body_Decls := No_List;
1204 Add_RACW_Asynchronous_Flag
1205 (Declarations => Decls,
1206 RACW_Type => RACW_Type);
1208 Specific_Add_RACW_Features
1209 (RACW_Type => RACW_Type,
1211 Stub_Type => Stub_Type,
1212 Stub_Type_Access => Stub_Type_Access,
1213 RPC_Receiver_Decl => RPC_Receiver_Decl,
1214 Body_Decls => Body_Decls);
1216 -- If we already have stubs for this designated type, nothing to do
1222 if Is_Frozen (Desig) then
1223 Validate_RACW_Primitives (RACW_Type);
1224 Add_RACW_Primitive_Declarations_And_Bodies
1225 (Designated_Type => Desig,
1226 Insertion_Node => RPC_Receiver_Decl,
1227 Body_Decls => Body_Decls);
1230 -- Validate_RACW_Primitives requires the list of all primitives of
1231 -- the designated type, so defer processing until Desig is frozen.
1232 -- See Exp_Ch3.Freeze_Type.
1234 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1236 end Add_RACW_Features;
1238 ------------------------------------------------
1239 -- Add_RACW_Primitive_Declarations_And_Bodies --
1240 ------------------------------------------------
1242 procedure Add_RACW_Primitive_Declarations_And_Bodies
1243 (Designated_Type : Entity_Id;
1244 Insertion_Node : Node_Id;
1245 Body_Decls : List_Id)
1247 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1248 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1249 -- the declarations are recognized as belonging to the current package.
1251 Stub_Elements : constant Stub_Structure :=
1252 Stubs_Table.Get (Designated_Type);
1254 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1256 Is_RAS : constant Boolean :=
1257 not Comes_From_Source (Stub_Elements.RACW_Type);
1258 -- Case of the RACW generated to implement a remote access-to-
1261 Build_Bodies : constant Boolean :=
1262 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1263 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1264 -- only when the main unit is the unit that contains the stub type.
1266 Current_Insertion_Node : Node_Id := Insertion_Node;
1268 RPC_Receiver : Entity_Id;
1269 RPC_Receiver_Statements : List_Id;
1270 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1271 RPC_Receiver_Elsif_Parts : List_Id;
1272 RPC_Receiver_Request : Entity_Id;
1273 RPC_Receiver_Subp_Id : Entity_Id;
1274 RPC_Receiver_Subp_Index : Entity_Id;
1276 Subp_Str : String_Id;
1278 Current_Primitive_Elmt : Elmt_Id;
1279 Current_Primitive : Entity_Id;
1280 Current_Primitive_Body : Node_Id;
1281 Current_Primitive_Spec : Node_Id;
1282 Current_Primitive_Decl : Node_Id;
1283 Current_Primitive_Number : Int := 0;
1284 Current_Primitive_Alias : Node_Id;
1285 Current_Receiver : Entity_Id;
1286 Current_Receiver_Body : Node_Id;
1287 RPC_Receiver_Decl : Node_Id;
1288 Possibly_Asynchronous : Boolean;
1291 if not Expander_Active then
1296 RPC_Receiver := Make_Temporary (Loc, 'P');
1298 Specific_Build_RPC_Receiver_Body
1299 (RPC_Receiver => RPC_Receiver,
1300 Request => RPC_Receiver_Request,
1301 Subp_Id => RPC_Receiver_Subp_Id,
1302 Subp_Index => RPC_Receiver_Subp_Index,
1303 Stmts => RPC_Receiver_Statements,
1304 Decl => RPC_Receiver_Decl);
1306 if Get_PCS_Name = Name_PolyORB_DSA then
1308 -- For the case of PolyORB, we need to map a textual operation
1309 -- name into a primitive index. Currently we do so using a simple
1310 -- sequence of string comparisons.
1312 RPC_Receiver_Elsif_Parts := New_List;
1316 -- Build callers, receivers for every primitive operations and a RPC
1317 -- receiver for this type. Note that we use Direct_Primitive_Operations,
1318 -- not Primitive_Operations, because we really want just the primitives
1319 -- of the tagged type itself, and in the case of a tagged synchronized
1320 -- type we do not want to get the primitives of the corresponding
1323 if Present (Direct_Primitive_Operations (Designated_Type)) then
1324 Overload_Counter_Table.Reset;
1326 Current_Primitive_Elmt :=
1327 First_Elmt (Direct_Primitive_Operations (Designated_Type));
1328 while Current_Primitive_Elmt /= No_Elmt loop
1329 Current_Primitive := Node (Current_Primitive_Elmt);
1331 -- Copy the primitive of all the parents, except predefined ones
1332 -- that are not remotely dispatching. Also omit hidden primitives
1333 -- (occurs in the case of primitives of interface progenitors
1334 -- other than immediate ancestors of the Designated_Type).
1336 if Chars (Current_Primitive) /= Name_uSize
1337 and then Chars (Current_Primitive) /= Name_uAlignment
1339 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1340 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1341 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1342 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1343 Is_TSS (Current_Primitive, TSS_Stream_Write)
1345 Is_Predefined_Interface_Primitive (Current_Primitive))
1346 and then not Is_Hidden (Current_Primitive)
1348 -- The first thing to do is build an up-to-date copy of the
1349 -- spec with all the formals referencing Controlling_Type
1350 -- transformed into formals referencing Stub_Type. Since this
1351 -- primitive may have been inherited, go back the alias chain
1352 -- until the real primitive has been found.
1354 Current_Primitive_Alias := Ultimate_Alias (Current_Primitive);
1356 -- Copy the spec from the original declaration for the purpose
1357 -- of declaring an overriding subprogram: we need to replace
1358 -- the type of each controlling formal with Stub_Type. The
1359 -- primitive may have been declared for Controlling_Type or
1360 -- inherited from some ancestor type for which we do not have
1361 -- an easily determined Entity_Id. We have no systematic way
1362 -- of knowing which type to substitute Stub_Type for. Instead,
1363 -- Copy_Specification relies on the flag Is_Controlling_Formal
1364 -- to determine which formals to change.
1366 Current_Primitive_Spec :=
1367 Copy_Specification (Loc,
1368 Spec => Parent (Current_Primitive_Alias),
1369 Ctrl_Type => Stub_Elements.Stub_Type);
1371 Current_Primitive_Decl :=
1372 Make_Subprogram_Declaration (Loc,
1373 Specification => Current_Primitive_Spec);
1375 Insert_After_And_Analyze (Current_Insertion_Node,
1376 Current_Primitive_Decl);
1377 Current_Insertion_Node := Current_Primitive_Decl;
1379 Possibly_Asynchronous :=
1380 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1381 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1383 Assign_Subprogram_Identifier (
1384 Defining_Unit_Name (Current_Primitive_Spec),
1385 Current_Primitive_Number,
1388 if Build_Bodies then
1389 Current_Primitive_Body :=
1390 Build_Subprogram_Calling_Stubs
1391 (Vis_Decl => Current_Primitive_Decl,
1393 Build_Subprogram_Id (Loc,
1394 Defining_Unit_Name (Current_Primitive_Spec)),
1395 Asynchronous => Possibly_Asynchronous,
1396 Dynamically_Asynchronous => Possibly_Asynchronous,
1397 Stub_Type => Stub_Elements.Stub_Type,
1398 RACW_Type => Stub_Elements.RACW_Type);
1399 Append_To (Body_Decls, Current_Primitive_Body);
1401 -- Analyzing the body here would cause the Stub type to
1402 -- be frozen, thus preventing subsequent primitive
1403 -- declarations. For this reason, it will be analyzed
1404 -- later in the regular flow (and in the context of the
1405 -- appropriate unit body, see Append_RACW_Bodies).
1409 -- Build the receiver stubs
1411 if Build_Bodies and then not Is_RAS then
1412 Current_Receiver_Body :=
1413 Specific_Build_Subprogram_Receiving_Stubs
1414 (Vis_Decl => Current_Primitive_Decl,
1415 Asynchronous => Possibly_Asynchronous,
1416 Dynamically_Asynchronous => Possibly_Asynchronous,
1417 Stub_Type => Stub_Elements.Stub_Type,
1418 RACW_Type => Stub_Elements.RACW_Type,
1419 Parent_Primitive => Current_Primitive);
1422 Defining_Unit_Name (Specification (Current_Receiver_Body));
1424 Append_To (Body_Decls, Current_Receiver_Body);
1426 -- Add a case alternative to the receiver
1428 if Get_PCS_Name = Name_PolyORB_DSA then
1429 Append_To (RPC_Receiver_Elsif_Parts,
1430 Make_Elsif_Part (Loc,
1432 Make_Function_Call (Loc,
1435 RTE (RE_Caseless_String_Eq), Loc),
1436 Parameter_Associations => New_List (
1437 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1438 Make_String_Literal (Loc, Subp_Str))),
1440 Then_Statements => New_List (
1441 Make_Assignment_Statement (Loc,
1442 Name => New_Occurrence_Of (
1443 RPC_Receiver_Subp_Index, Loc),
1445 Make_Integer_Literal (Loc,
1446 Intval => Current_Primitive_Number)))));
1449 Append_To (RPC_Receiver_Case_Alternatives,
1450 Make_Case_Statement_Alternative (Loc,
1451 Discrete_Choices => New_List (
1452 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1454 Statements => New_List (
1455 Make_Procedure_Call_Statement (Loc,
1457 New_Occurrence_Of (Current_Receiver, Loc),
1458 Parameter_Associations => New_List (
1459 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1462 -- Increment the index of current primitive
1464 Current_Primitive_Number := Current_Primitive_Number + 1;
1467 Next_Elmt (Current_Primitive_Elmt);
1471 -- Build the case statement and the heart of the subprogram
1473 if Build_Bodies and then not Is_RAS then
1474 if Get_PCS_Name = Name_PolyORB_DSA
1475 and then Present (First (RPC_Receiver_Elsif_Parts))
1477 Append_To (RPC_Receiver_Statements,
1478 Make_Implicit_If_Statement (Designated_Type,
1479 Condition => New_Occurrence_Of (Standard_False, Loc),
1480 Then_Statements => New_List,
1481 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1484 Append_To (RPC_Receiver_Case_Alternatives,
1485 Make_Case_Statement_Alternative (Loc,
1486 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1487 Statements => New_List (Make_Null_Statement (Loc))));
1489 Append_To (RPC_Receiver_Statements,
1490 Make_Case_Statement (Loc,
1492 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1493 Alternatives => RPC_Receiver_Case_Alternatives));
1495 Append_To (Body_Decls, RPC_Receiver_Decl);
1496 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1497 Body_Decls, RPC_Receiver, Stub_Elements);
1499 -- Do not analyze RPC receiver body at this stage since it references
1500 -- subprograms that have not been analyzed yet. It will be analyzed in
1501 -- the regular flow (see Append_RACW_Bodies).
1504 end Add_RACW_Primitive_Declarations_And_Bodies;
1506 -----------------------------
1507 -- Add_RAS_Dereference_TSS --
1508 -----------------------------
1510 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1511 Loc : constant Source_Ptr := Sloc (N);
1513 Type_Def : constant Node_Id := Type_Definition (N);
1514 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1515 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1516 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1518 RACW_Primitive_Name : Node_Id;
1520 Proc : constant Entity_Id :=
1521 Make_Defining_Identifier (Loc,
1522 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1524 Proc_Spec : Node_Id;
1525 Param_Specs : List_Id;
1526 Param_Assoc : constant List_Id := New_List;
1527 Stmts : constant List_Id := New_List;
1529 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P');
1531 Is_Function : constant Boolean :=
1532 Nkind (Type_Def) = N_Access_Function_Definition;
1534 Is_Degenerate : Boolean;
1535 -- Set to True if the subprogram_specification for this RAS has an
1536 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1538 Spec : constant Node_Id := Type_Def;
1540 Current_Parameter : Node_Id;
1542 -- Start of processing for Add_RAS_Dereference_TSS
1545 -- The Dereference TSS for a remote access-to-subprogram type has the
1548 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1551 -- This is called whenever a value of a RAS type is dereferenced
1553 -- First construct a list of parameter specifications:
1555 -- The first formal is the RAS values
1557 Param_Specs := New_List (
1558 Make_Parameter_Specification (Loc,
1559 Defining_Identifier => RAS_Parameter,
1562 New_Occurrence_Of (Fat_Type, Loc)));
1564 -- The following formals are copied from the type declaration
1566 Is_Degenerate := False;
1567 Current_Parameter := First (Parameter_Specifications (Type_Def));
1568 Parameters : while Present (Current_Parameter) loop
1569 if Nkind (Parameter_Type (Current_Parameter)) =
1572 Is_Degenerate := True;
1575 Append_To (Param_Specs,
1576 Make_Parameter_Specification (Loc,
1577 Defining_Identifier =>
1578 Make_Defining_Identifier (Loc,
1579 Chars => Chars (Defining_Identifier (Current_Parameter))),
1580 In_Present => In_Present (Current_Parameter),
1581 Out_Present => Out_Present (Current_Parameter),
1583 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1585 New_Copy_Tree (Expression (Current_Parameter))));
1587 Append_To (Param_Assoc,
1588 Make_Identifier (Loc,
1589 Chars => Chars (Defining_Identifier (Current_Parameter))));
1591 Next (Current_Parameter);
1592 end loop Parameters;
1594 if Is_Degenerate then
1595 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1597 -- Generate a dummy body. This code will never actually be executed,
1598 -- because null is the only legal value for a degenerate RAS type.
1599 -- For legality's sake (in order to avoid generating a function that
1600 -- does not contain a return statement), we include a dummy recursive
1601 -- call on the TSS itself.
1604 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1605 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1608 -- For a normal RAS type, we cast the RAS formal to the corresponding
1609 -- tagged type, and perform a dispatching call to its Call primitive
1612 Prepend_To (Param_Assoc,
1613 Unchecked_Convert_To (RACW_Type,
1614 New_Occurrence_Of (RAS_Parameter, Loc)));
1616 RACW_Primitive_Name :=
1617 Make_Selected_Component (Loc,
1618 Prefix => Scope (RACW_Type),
1619 Selector_Name => Name_uCall);
1624 Make_Simple_Return_Statement (Loc,
1626 Make_Function_Call (Loc,
1627 Name => RACW_Primitive_Name,
1628 Parameter_Associations => Param_Assoc)));
1632 Make_Procedure_Call_Statement (Loc,
1633 Name => RACW_Primitive_Name,
1634 Parameter_Associations => Param_Assoc));
1637 -- Build the complete subprogram
1641 Make_Function_Specification (Loc,
1642 Defining_Unit_Name => Proc,
1643 Parameter_Specifications => Param_Specs,
1644 Result_Definition =>
1646 Entity (Result_Definition (Spec)), Loc));
1648 Set_Ekind (Proc, E_Function);
1650 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1654 Make_Procedure_Specification (Loc,
1655 Defining_Unit_Name => Proc,
1656 Parameter_Specifications => Param_Specs);
1658 Set_Ekind (Proc, E_Procedure);
1659 Set_Etype (Proc, Standard_Void_Type);
1663 Make_Subprogram_Body (Loc,
1664 Specification => Proc_Spec,
1665 Declarations => New_List,
1666 Handled_Statement_Sequence =>
1667 Make_Handled_Sequence_Of_Statements (Loc,
1668 Statements => Stmts)));
1670 Set_TSS (Fat_Type, Proc);
1671 end Add_RAS_Dereference_TSS;
1673 -------------------------------
1674 -- Add_RAS_Proxy_And_Analyze --
1675 -------------------------------
1677 procedure Add_RAS_Proxy_And_Analyze
1680 All_Calls_Remote_E : Entity_Id;
1681 Proxy_Object_Addr : out Entity_Id)
1683 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1685 Subp_Name : constant Entity_Id :=
1686 Defining_Unit_Name (Specification (Vis_Decl));
1688 Pkg_Name : constant Entity_Id :=
1689 Make_Defining_Identifier (Loc,
1690 Chars => New_External_Name (Chars (Subp_Name), 'P', -1));
1692 Proxy_Type : constant Entity_Id :=
1693 Make_Defining_Identifier (Loc,
1696 (Related_Id => Chars (Subp_Name),
1699 Proxy_Type_Full_View : constant Entity_Id :=
1700 Make_Defining_Identifier (Loc,
1701 Chars (Proxy_Type));
1703 Subp_Decl_Spec : constant Node_Id :=
1704 Build_RAS_Primitive_Specification
1705 (Subp_Spec => Specification (Vis_Decl),
1706 Remote_Object_Type => Proxy_Type);
1708 Subp_Body_Spec : constant Node_Id :=
1709 Build_RAS_Primitive_Specification
1710 (Subp_Spec => Specification (Vis_Decl),
1711 Remote_Object_Type => Proxy_Type);
1713 Vis_Decls : constant List_Id := New_List;
1714 Pvt_Decls : constant List_Id := New_List;
1715 Actuals : constant List_Id := New_List;
1717 Perform_Call : Node_Id;
1720 -- type subpP is tagged limited private;
1722 Append_To (Vis_Decls,
1723 Make_Private_Type_Declaration (Loc,
1724 Defining_Identifier => Proxy_Type,
1725 Tagged_Present => True,
1726 Limited_Present => True));
1728 -- [subprogram] Call
1729 -- (Self : access subpP;
1730 -- ...other-formals...)
1733 Append_To (Vis_Decls,
1734 Make_Subprogram_Declaration (Loc,
1735 Specification => Subp_Decl_Spec));
1737 -- A : constant System.Address;
1739 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1741 Append_To (Vis_Decls,
1742 Make_Object_Declaration (Loc,
1743 Defining_Identifier => Proxy_Object_Addr,
1744 Constant_Present => True,
1745 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)));
1749 -- type subpP is tagged limited record
1750 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1754 Append_To (Pvt_Decls,
1755 Make_Full_Type_Declaration (Loc,
1756 Defining_Identifier => Proxy_Type_Full_View,
1758 Build_Remote_Subprogram_Proxy_Type (Loc,
1759 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1761 -- Trick semantic analysis into swapping the public and full view when
1762 -- freezing the public view.
1764 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1767 -- (Self : access O;
1768 -- ...other-formals...) is
1770 -- P (...other-formals...);
1774 -- (Self : access O;
1775 -- ...other-formals...)
1778 -- return F (...other-formals...);
1781 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1783 Make_Procedure_Call_Statement (Loc,
1784 Name => New_Occurrence_Of (Subp_Name, Loc),
1785 Parameter_Associations => Actuals);
1788 Make_Simple_Return_Statement (Loc,
1790 Make_Function_Call (Loc,
1791 Name => New_Occurrence_Of (Subp_Name, Loc),
1792 Parameter_Associations => Actuals));
1795 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1796 pragma Assert (Present (Formal));
1799 exit when No (Formal);
1801 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1804 -- O : aliased subpP;
1806 Append_To (Pvt_Decls,
1807 Make_Object_Declaration (Loc,
1808 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
1809 Aliased_Present => True,
1810 Object_Definition => New_Occurrence_Of (Proxy_Type, Loc)));
1812 -- A : constant System.Address := O'Address;
1814 Append_To (Pvt_Decls,
1815 Make_Object_Declaration (Loc,
1816 Defining_Identifier =>
1817 Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)),
1818 Constant_Present => True,
1819 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc),
1821 Make_Attribute_Reference (Loc,
1822 Prefix => New_Occurrence_Of (
1823 Defining_Identifier (Last (Pvt_Decls)), Loc),
1824 Attribute_Name => Name_Address)));
1827 Make_Package_Declaration (Loc,
1828 Specification => Make_Package_Specification (Loc,
1829 Defining_Unit_Name => Pkg_Name,
1830 Visible_Declarations => Vis_Decls,
1831 Private_Declarations => Pvt_Decls,
1832 End_Label => Empty)));
1833 Analyze (Last (Decls));
1836 Make_Package_Body (Loc,
1837 Defining_Unit_Name =>
1838 Make_Defining_Identifier (Loc, Chars (Pkg_Name)),
1839 Declarations => New_List (
1840 Make_Subprogram_Body (Loc,
1841 Specification => Subp_Body_Spec,
1842 Declarations => New_List,
1843 Handled_Statement_Sequence =>
1844 Make_Handled_Sequence_Of_Statements (Loc,
1845 Statements => New_List (Perform_Call))))));
1846 Analyze (Last (Decls));
1847 end Add_RAS_Proxy_And_Analyze;
1849 -----------------------
1850 -- Add_RAST_Features --
1851 -----------------------
1853 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1854 RAS_Type : constant Entity_Id :=
1855 Equivalent_Type (Defining_Identifier (Vis_Decl));
1857 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1858 Add_RAS_Dereference_TSS (Vis_Decl);
1859 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1860 end Add_RAST_Features;
1866 procedure Add_Stub_Type
1867 (Designated_Type : Entity_Id;
1868 RACW_Type : Entity_Id;
1870 Stub_Type : out Entity_Id;
1871 Stub_Type_Access : out Entity_Id;
1872 RPC_Receiver_Decl : out Node_Id;
1873 Body_Decls : out List_Id;
1874 Existing : out Boolean)
1876 Loc : constant Source_Ptr := Sloc (RACW_Type);
1878 Stub_Elements : constant Stub_Structure :=
1879 Stubs_Table.Get (Designated_Type);
1880 Stub_Type_Comps : List_Id;
1881 Stub_Type_Decl : Node_Id;
1882 Stub_Type_Access_Decl : Node_Id;
1885 if Stub_Elements /= Empty_Stub_Structure then
1886 Stub_Type := Stub_Elements.Stub_Type;
1887 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1888 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1889 Body_Decls := Stub_Elements.Body_Decls;
1895 Stub_Type := Make_Temporary (Loc, 'S');
1896 Set_Ekind (Stub_Type, E_Record_Type);
1897 Set_Is_RACW_Stub_Type (Stub_Type);
1899 Make_Defining_Identifier (Loc,
1900 Chars => New_External_Name
1901 (Related_Id => Chars (Stub_Type), Suffix => 'A'));
1903 Specific_Build_Stub_Type (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
1906 Make_Full_Type_Declaration (Loc,
1907 Defining_Identifier => Stub_Type,
1909 Make_Record_Definition (Loc,
1910 Tagged_Present => True,
1911 Limited_Present => True,
1913 Make_Component_List (Loc,
1914 Component_Items => Stub_Type_Comps)));
1916 -- Does the stub type need to explicitly implement interfaces from the
1917 -- designated type???
1919 -- In particular are there issues in the case where the designated type
1920 -- is a synchronized interface???
1922 Stub_Type_Access_Decl :=
1923 Make_Full_Type_Declaration (Loc,
1924 Defining_Identifier => Stub_Type_Access,
1926 Make_Access_To_Object_Definition (Loc,
1927 All_Present => True,
1928 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1930 Append_To (Decls, Stub_Type_Decl);
1931 Analyze (Last (Decls));
1932 Append_To (Decls, Stub_Type_Access_Decl);
1933 Analyze (Last (Decls));
1935 -- We can't directly derive the stub type from the designated type,
1936 -- because we don't want any components or discriminants from the real
1937 -- type, so instead we manually fake a derivation to get an appropriate
1940 Derive_Subprograms (Parent_Type => Designated_Type,
1941 Derived_Type => Stub_Type);
1943 if Present (RPC_Receiver_Decl) then
1944 Append_To (Decls, RPC_Receiver_Decl);
1946 RPC_Receiver_Decl := Last (Decls);
1949 Body_Decls := New_List;
1951 Stubs_Table.Set (Designated_Type,
1952 (Stub_Type => Stub_Type,
1953 Stub_Type_Access => Stub_Type_Access,
1954 RPC_Receiver_Decl => RPC_Receiver_Decl,
1955 Body_Decls => Body_Decls,
1956 RACW_Type => RACW_Type));
1959 ------------------------
1960 -- Append_RACW_Bodies --
1961 ------------------------
1963 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
1967 E := First_Entity (Spec_Id);
1968 while Present (E) loop
1969 if Is_Remote_Access_To_Class_Wide_Type (E) then
1970 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
1975 end Append_RACW_Bodies;
1977 ----------------------------------
1978 -- Assign_Subprogram_Identifier --
1979 ----------------------------------
1981 procedure Assign_Subprogram_Identifier
1986 N : constant Name_Id := Chars (Def);
1988 Overload_Order : constant Int :=
1989 Overload_Counter_Table.Get (N) + 1;
1992 Overload_Counter_Table.Set (N, Overload_Order);
1994 Get_Name_String (N);
1996 -- Homonym handling: as in Exp_Dbug, but much simpler, because the only
1997 -- entities for which we have to generate names here need only to be
1998 -- disambiguated within their own scope.
2000 if Overload_Order > 1 then
2001 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
2002 Name_Len := Name_Len + 2;
2003 Add_Nat_To_Name_Buffer (Overload_Order);
2006 Id := String_From_Name_Buffer;
2007 Subprogram_Identifier_Table.Set
2009 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
2010 end Assign_Subprogram_Identifier;
2012 -------------------------------------
2013 -- Build_Actual_Object_Declaration --
2014 -------------------------------------
2016 procedure Build_Actual_Object_Declaration
2017 (Object : Entity_Id;
2023 Loc : constant Source_Ptr := Sloc (Object);
2026 -- Declare a temporary object for the actual, possibly initialized with
2027 -- a 'Input/From_Any call.
2029 -- Complication arises in the case of limited types, for which such a
2030 -- declaration is illegal in Ada 95. In that case, we first generate a
2031 -- renaming declaration of the 'Input call, and then if needed we
2032 -- generate an overlaid non-constant view.
2034 if Ada_Version <= Ada_95
2035 and then Is_Limited_Type (Etyp)
2036 and then Present (Expr)
2039 -- Object : Etyp renames <func-call>
2042 Make_Object_Renaming_Declaration (Loc,
2043 Defining_Identifier => Object,
2044 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
2049 -- The name defined by the renaming declaration denotes a
2050 -- constant view; create a non-constant object at the same address
2051 -- to be used as the actual.
2054 Constant_Object : constant Entity_Id :=
2055 Make_Temporary (Loc, 'P');
2058 Set_Defining_Identifier
2059 (Last (Decls), Constant_Object);
2061 -- We have an unconstrained Etyp: build the actual constrained
2062 -- subtype for the value we just read from the stream.
2064 -- subtype S is <actual subtype of Constant_Object>;
2067 Build_Actual_Subtype (Etyp,
2068 New_Occurrence_Of (Constant_Object, Loc)));
2073 Make_Object_Declaration (Loc,
2074 Defining_Identifier => Object,
2075 Object_Definition =>
2077 (Defining_Identifier (Last (Decls)), Loc)));
2078 Set_Ekind (Object, E_Variable);
2080 -- Suppress default initialization:
2081 -- pragma Import (Ada, Object);
2085 Chars => Name_Import,
2086 Pragma_Argument_Associations => New_List (
2087 Make_Pragma_Argument_Association (Loc,
2088 Chars => Name_Convention,
2089 Expression => Make_Identifier (Loc, Name_Ada)),
2090 Make_Pragma_Argument_Association (Loc,
2091 Chars => Name_Entity,
2092 Expression => New_Occurrence_Of (Object, Loc)))));
2094 -- for Object'Address use Constant_Object'Address;
2097 Make_Attribute_Definition_Clause (Loc,
2098 Name => New_Occurrence_Of (Object, Loc),
2099 Chars => Name_Address,
2101 Make_Attribute_Reference (Loc,
2102 Prefix => New_Occurrence_Of (Constant_Object, Loc),
2103 Attribute_Name => Name_Address)));
2108 -- General case of a regular object declaration. Object is flagged
2109 -- constant unless it has mode out or in out, to allow the backend
2110 -- to optimize where possible.
2112 -- Object : [constant] Etyp [:= <expr>];
2115 Make_Object_Declaration (Loc,
2116 Defining_Identifier => Object,
2117 Constant_Present => Present (Expr) and then not Variable,
2118 Object_Definition => New_Occurrence_Of (Etyp, Loc),
2119 Expression => Expr));
2121 if Constant_Present (Last (Decls)) then
2122 Set_Ekind (Object, E_Constant);
2124 Set_Ekind (Object, E_Variable);
2127 end Build_Actual_Object_Declaration;
2129 ------------------------------
2130 -- Build_Get_Unique_RP_Call --
2131 ------------------------------
2133 function Build_Get_Unique_RP_Call
2135 Pointer : Entity_Id;
2136 Stub_Type : Entity_Id) return List_Id
2140 Make_Procedure_Call_Statement (Loc,
2142 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2143 Parameter_Associations => New_List (
2144 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2145 New_Occurrence_Of (Pointer, Loc)))),
2147 Make_Assignment_Statement (Loc,
2149 Make_Selected_Component (Loc,
2150 Prefix => New_Occurrence_Of (Pointer, Loc),
2152 New_Occurrence_Of (First_Tag_Component
2153 (Designated_Type (Etype (Pointer))), Loc)),
2155 Make_Attribute_Reference (Loc,
2156 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2157 Attribute_Name => Name_Tag)));
2159 -- Note: The assignment to Pointer._Tag is safe here because
2160 -- we carefully ensured that Stub_Type has exactly the same layout
2161 -- as System.Partition_Interface.RACW_Stub_Type.
2163 end Build_Get_Unique_RP_Call;
2165 -----------------------------------
2166 -- Build_Ordered_Parameters_List --
2167 -----------------------------------
2169 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2170 Constrained_List : List_Id;
2171 Unconstrained_List : List_Id;
2172 Current_Parameter : Node_Id;
2175 First_Parameter : Node_Id;
2176 For_RAS : Boolean := False;
2179 if No (Parameter_Specifications (Spec)) then
2183 Constrained_List := New_List;
2184 Unconstrained_List := New_List;
2185 First_Parameter := First (Parameter_Specifications (Spec));
2187 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2188 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2193 -- Loop through the parameters and add them to the right list. Note that
2194 -- we treat a parameter of a null-excluding access type as unconstrained
2195 -- because we can't declare an object of such a type with default
2198 Current_Parameter := First_Parameter;
2199 while Present (Current_Parameter) loop
2200 Ptyp := Parameter_Type (Current_Parameter);
2202 if (Nkind (Ptyp) = N_Access_Definition
2203 or else not Transmit_As_Unconstrained (Etype (Ptyp)))
2204 and then not (For_RAS and then Current_Parameter = First_Parameter)
2206 Append_To (Constrained_List, New_Copy (Current_Parameter));
2208 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2211 Next (Current_Parameter);
2214 -- Unconstrained parameters are returned first
2216 Append_List_To (Unconstrained_List, Constrained_List);
2218 return Unconstrained_List;
2219 end Build_Ordered_Parameters_List;
2221 ----------------------------------
2222 -- Build_Passive_Partition_Stub --
2223 ----------------------------------
2225 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2227 Pkg_Name : String_Id;
2230 Loc : constant Source_Ptr := Sloc (U);
2233 -- Verify that the implementation supports distribution, by accessing
2234 -- a type defined in the proper version of system.rpc
2237 Dist_OK : Entity_Id;
2238 pragma Warnings (Off, Dist_OK);
2240 Dist_OK := RTE (RE_Params_Stream_Type);
2243 -- Use body if present, spec otherwise
2245 if Nkind (U) = N_Package_Declaration then
2246 Pkg_Spec := Specification (U);
2247 L := Visible_Declarations (Pkg_Spec);
2249 Pkg_Spec := Parent (Corresponding_Spec (U));
2250 L := Declarations (U);
2253 Get_Library_Unit_Name_String (Pkg_Spec);
2254 Pkg_Name := String_From_Name_Buffer;
2256 Make_Procedure_Call_Statement (Loc,
2258 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2259 Parameter_Associations => New_List (
2260 Make_String_Literal (Loc, Pkg_Name),
2261 Make_Attribute_Reference (Loc,
2263 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2264 Attribute_Name => Name_Version)));
2267 end Build_Passive_Partition_Stub;
2269 --------------------------------------
2270 -- Build_RPC_Receiver_Specification --
2271 --------------------------------------
2273 function Build_RPC_Receiver_Specification
2274 (RPC_Receiver : Entity_Id;
2275 Request_Parameter : Entity_Id) return Node_Id
2277 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2280 Make_Procedure_Specification (Loc,
2281 Defining_Unit_Name => RPC_Receiver,
2282 Parameter_Specifications => New_List (
2283 Make_Parameter_Specification (Loc,
2284 Defining_Identifier => Request_Parameter,
2286 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2287 end Build_RPC_Receiver_Specification;
2289 ----------------------------------------
2290 -- Build_Remote_Subprogram_Proxy_Type --
2291 ----------------------------------------
2293 function Build_Remote_Subprogram_Proxy_Type
2295 ACR_Expression : Node_Id) return Node_Id
2299 Make_Record_Definition (Loc,
2300 Tagged_Present => True,
2301 Limited_Present => True,
2303 Make_Component_List (Loc,
2305 Component_Items => New_List (
2306 Make_Component_Declaration (Loc,
2307 Defining_Identifier =>
2308 Make_Defining_Identifier (Loc,
2309 Name_All_Calls_Remote),
2310 Component_Definition =>
2311 Make_Component_Definition (Loc,
2312 Subtype_Indication =>
2313 New_Occurrence_Of (Standard_Boolean, Loc)),
2317 Make_Component_Declaration (Loc,
2318 Defining_Identifier =>
2319 Make_Defining_Identifier (Loc,
2321 Component_Definition =>
2322 Make_Component_Definition (Loc,
2323 Subtype_Indication =>
2324 New_Occurrence_Of (RTE (RE_Address), Loc)),
2326 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2328 Make_Component_Declaration (Loc,
2329 Defining_Identifier =>
2330 Make_Defining_Identifier (Loc,
2332 Component_Definition =>
2333 Make_Component_Definition (Loc,
2334 Subtype_Indication =>
2335 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2336 end Build_Remote_Subprogram_Proxy_Type;
2338 --------------------
2339 -- Build_Stub_Tag --
2340 --------------------
2342 function Build_Stub_Tag
2344 RACW_Type : Entity_Id) return Node_Id
2346 Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type);
2349 Make_Attribute_Reference (Loc,
2350 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2351 Attribute_Name => Name_Tag);
2354 ------------------------------------
2355 -- Build_Subprogram_Calling_Stubs --
2356 ------------------------------------
2358 function Build_Subprogram_Calling_Stubs
2359 (Vis_Decl : Node_Id;
2361 Asynchronous : Boolean;
2362 Dynamically_Asynchronous : Boolean := False;
2363 Stub_Type : Entity_Id := Empty;
2364 RACW_Type : Entity_Id := Empty;
2365 Locator : Entity_Id := Empty;
2366 New_Name : Name_Id := No_Name) return Node_Id
2368 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2370 Decls : constant List_Id := New_List;
2371 Statements : constant List_Id := New_List;
2373 Subp_Spec : Node_Id;
2374 -- The specification of the body
2376 Controlling_Parameter : Entity_Id := Empty;
2378 Asynchronous_Expr : Node_Id := Empty;
2380 RCI_Locator : Entity_Id;
2382 Spec_To_Use : Node_Id;
2384 procedure Insert_Partition_Check (Parameter : Node_Id);
2385 -- Check that the parameter has been elaborated on the same partition
2386 -- than the controlling parameter (E.4(19)).
2388 ----------------------------
2389 -- Insert_Partition_Check --
2390 ----------------------------
2392 procedure Insert_Partition_Check (Parameter : Node_Id) is
2393 Parameter_Entity : constant Entity_Id :=
2394 Defining_Identifier (Parameter);
2396 -- The expression that will be built is of the form:
2398 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2399 -- raise Constraint_Error;
2402 -- We do not check that Parameter is in Stub_Type since such a check
2403 -- has been inserted at the point of call already (a tag check since
2404 -- we have multiple controlling operands).
2407 Make_Raise_Constraint_Error (Loc,
2411 Make_Function_Call (Loc,
2413 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2414 Parameter_Associations =>
2416 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2417 New_Occurrence_Of (Parameter_Entity, Loc)),
2418 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2419 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2420 Reason => CE_Partition_Check_Failed));
2421 end Insert_Partition_Check;
2423 -- Start of processing for Build_Subprogram_Calling_Stubs
2427 Copy_Specification (Loc,
2428 Spec => Specification (Vis_Decl),
2429 New_Name => New_Name);
2431 if Locator = Empty then
2432 RCI_Locator := RCI_Cache;
2433 Spec_To_Use := Specification (Vis_Decl);
2435 RCI_Locator := Locator;
2436 Spec_To_Use := Subp_Spec;
2439 -- Find a controlling argument if we have a stub type. Also check
2440 -- if this subprogram can be made asynchronous.
2442 if Present (Stub_Type)
2443 and then Present (Parameter_Specifications (Spec_To_Use))
2446 Current_Parameter : Node_Id :=
2447 First (Parameter_Specifications
2450 while Present (Current_Parameter) loop
2452 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2454 if Controlling_Parameter = Empty then
2455 Controlling_Parameter :=
2456 Defining_Identifier (Current_Parameter);
2458 Insert_Partition_Check (Current_Parameter);
2462 Next (Current_Parameter);
2467 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2469 if Dynamically_Asynchronous then
2470 Asynchronous_Expr := Make_Selected_Component (Loc,
2471 Prefix => Controlling_Parameter,
2472 Selector_Name => Name_Asynchronous);
2475 Specific_Build_General_Calling_Stubs
2477 Statements => Statements,
2478 Target => Specific_Build_Stub_Target (Loc,
2479 Decls, RCI_Locator, Controlling_Parameter),
2480 Subprogram_Id => Subp_Id,
2481 Asynchronous => Asynchronous_Expr,
2482 Is_Known_Asynchronous => Asynchronous
2483 and then not Dynamically_Asynchronous,
2484 Is_Known_Non_Asynchronous
2486 and then not Dynamically_Asynchronous,
2487 Is_Function => Nkind (Spec_To_Use) =
2488 N_Function_Specification,
2489 Spec => Spec_To_Use,
2490 Stub_Type => Stub_Type,
2491 RACW_Type => RACW_Type,
2494 RCI_Calling_Stubs_Table.Set
2495 (Defining_Unit_Name (Specification (Vis_Decl)),
2496 Defining_Unit_Name (Spec_To_Use));
2499 Make_Subprogram_Body (Loc,
2500 Specification => Subp_Spec,
2501 Declarations => Decls,
2502 Handled_Statement_Sequence =>
2503 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2504 end Build_Subprogram_Calling_Stubs;
2506 -------------------------
2507 -- Build_Subprogram_Id --
2508 -------------------------
2510 function Build_Subprogram_Id
2512 E : Entity_Id) return Node_Id
2515 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2517 Current_Declaration : Node_Id;
2518 Current_Subp : Entity_Id;
2519 Current_Subp_Str : String_Id;
2520 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2522 pragma Warnings (Off, Current_Subp_Str);
2525 -- Build_Subprogram_Id is called outside of the context of
2526 -- generating calling or receiving stubs. Hence we are processing
2527 -- an 'Access attribute_reference for an RCI subprogram, for the
2528 -- purpose of obtaining a RAS value.
2531 (Is_Remote_Call_Interface (Scope (E))
2533 (Nkind (Parent (E)) = N_Procedure_Specification
2535 Nkind (Parent (E)) = N_Function_Specification));
2537 Current_Declaration :=
2538 First (Visible_Declarations
2539 (Package_Specification_Of_Scope (Scope (E))));
2540 while Present (Current_Declaration) loop
2541 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2542 and then Comes_From_Source (Current_Declaration)
2544 Current_Subp := Defining_Unit_Name (Specification (
2545 Current_Declaration));
2547 Assign_Subprogram_Identifier
2548 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2550 Current_Subp_Number := Current_Subp_Number + 1;
2553 Next (Current_Declaration);
2558 case Get_PCS_Name is
2559 when Name_PolyORB_DSA =>
2560 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2562 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2564 end Build_Subprogram_Id;
2566 ------------------------
2567 -- Copy_Specification --
2568 ------------------------
2570 function Copy_Specification
2573 Ctrl_Type : Entity_Id := Empty;
2574 New_Name : Name_Id := No_Name) return Node_Id
2576 Parameters : List_Id := No_List;
2578 Current_Parameter : Node_Id;
2579 Current_Identifier : Entity_Id;
2580 Current_Type : Node_Id;
2582 Name_For_New_Spec : Name_Id;
2584 New_Identifier : Entity_Id;
2586 -- Comments needed in body below ???
2589 if New_Name = No_Name then
2590 pragma Assert (Nkind (Spec) = N_Function_Specification
2591 or else Nkind (Spec) = N_Procedure_Specification);
2593 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2595 Name_For_New_Spec := New_Name;
2598 if Present (Parameter_Specifications (Spec)) then
2599 Parameters := New_List;
2600 Current_Parameter := First (Parameter_Specifications (Spec));
2601 while Present (Current_Parameter) loop
2602 Current_Identifier := Defining_Identifier (Current_Parameter);
2603 Current_Type := Parameter_Type (Current_Parameter);
2605 if Nkind (Current_Type) = N_Access_Definition then
2606 if Present (Ctrl_Type) then
2607 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2609 Make_Access_Definition (Loc,
2610 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2611 Null_Exclusion_Present =>
2612 Null_Exclusion_Present (Current_Type));
2616 Make_Access_Definition (Loc,
2618 New_Copy_Tree (Subtype_Mark (Current_Type)),
2619 Null_Exclusion_Present =>
2620 Null_Exclusion_Present (Current_Type));
2624 if Present (Ctrl_Type)
2625 and then Is_Controlling_Formal (Current_Identifier)
2627 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2629 Current_Type := New_Copy_Tree (Current_Type);
2633 New_Identifier := Make_Defining_Identifier (Loc,
2634 Chars (Current_Identifier));
2636 Append_To (Parameters,
2637 Make_Parameter_Specification (Loc,
2638 Defining_Identifier => New_Identifier,
2639 Parameter_Type => Current_Type,
2640 In_Present => In_Present (Current_Parameter),
2641 Out_Present => Out_Present (Current_Parameter),
2643 New_Copy_Tree (Expression (Current_Parameter))));
2645 -- For a regular formal parameter (that needs to be marshalled
2646 -- in the context of remote calls), set the Etype now, because
2647 -- marshalling processing might need it.
2649 if Is_Entity_Name (Current_Type) then
2650 Set_Etype (New_Identifier, Entity (Current_Type));
2652 -- Current_Type is an access definition, special processing
2653 -- (not requiring etype) will occur for marshalling.
2659 Next (Current_Parameter);
2663 case Nkind (Spec) is
2665 when N_Function_Specification | N_Access_Function_Definition =>
2667 Make_Function_Specification (Loc,
2668 Defining_Unit_Name =>
2669 Make_Defining_Identifier (Loc,
2670 Chars => Name_For_New_Spec),
2671 Parameter_Specifications => Parameters,
2672 Result_Definition =>
2673 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2675 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2677 Make_Procedure_Specification (Loc,
2678 Defining_Unit_Name =>
2679 Make_Defining_Identifier (Loc,
2680 Chars => Name_For_New_Spec),
2681 Parameter_Specifications => Parameters);
2684 raise Program_Error;
2686 end Copy_Specification;
2688 -----------------------------
2689 -- Corresponding_Stub_Type --
2690 -----------------------------
2692 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2693 Desig : constant Entity_Id :=
2694 Etype (Designated_Type (RACW_Type));
2695 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2697 return Stub_Elements.Stub_Type;
2698 end Corresponding_Stub_Type;
2700 ---------------------------
2701 -- Could_Be_Asynchronous --
2702 ---------------------------
2704 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2705 Current_Parameter : Node_Id;
2708 if Present (Parameter_Specifications (Spec)) then
2709 Current_Parameter := First (Parameter_Specifications (Spec));
2710 while Present (Current_Parameter) loop
2711 if Out_Present (Current_Parameter) then
2715 Next (Current_Parameter);
2720 end Could_Be_Asynchronous;
2722 ---------------------------
2723 -- Declare_Create_NVList --
2724 ---------------------------
2726 procedure Declare_Create_NVList
2734 Make_Object_Declaration (Loc,
2735 Defining_Identifier => NVList,
2736 Aliased_Present => False,
2737 Object_Definition =>
2738 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2741 Make_Procedure_Call_Statement (Loc,
2742 Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2743 Parameter_Associations => New_List (
2744 New_Occurrence_Of (NVList, Loc))));
2745 end Declare_Create_NVList;
2747 ---------------------------------------------
2748 -- Expand_All_Calls_Remote_Subprogram_Call --
2749 ---------------------------------------------
2751 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2752 Loc : constant Source_Ptr := Sloc (N);
2753 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2754 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2755 RCI_Locator_Decl : Node_Id;
2756 RCI_Locator : Entity_Id;
2757 Calling_Stubs : Node_Id;
2758 E_Calling_Stubs : Entity_Id;
2761 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2763 if E_Calling_Stubs = Empty then
2764 RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
2766 -- The RCI_Locator package and calling stub are is inserted at the
2767 -- top level in the current unit, and must appear in the proper scope
2768 -- so that it is not prematurely removed by the GCC back end.
2771 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2773 if Ekind (Scop) = E_Package_Body then
2774 Push_Scope (Spec_Entity (Scop));
2775 elsif Ekind (Scop) = E_Subprogram_Body then
2777 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2783 if RCI_Locator = Empty then
2786 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2787 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
2788 Analyze (RCI_Locator_Decl);
2789 RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
2792 RCI_Locator_Decl := Parent (RCI_Locator);
2795 Calling_Stubs := Build_Subprogram_Calling_Stubs
2796 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2798 Build_Subprogram_Id (Loc, Called_Subprogram),
2799 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2801 Is_Asynchronous (Called_Subprogram),
2802 Locator => RCI_Locator,
2803 New_Name => New_Internal_Name ('S'));
2804 Insert_After (RCI_Locator_Decl, Calling_Stubs);
2805 Analyze (Calling_Stubs);
2808 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2811 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2812 end Expand_All_Calls_Remote_Subprogram_Call;
2814 ---------------------------------
2815 -- Expand_Calling_Stubs_Bodies --
2816 ---------------------------------
2818 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2819 Spec : constant Node_Id := Specification (Unit_Node);
2820 Decls : constant List_Id := Visible_Declarations (Spec);
2822 Push_Scope (Scope_Of_Spec (Spec));
2823 Add_Calling_Stubs_To_Declarations
2824 (Specification (Unit_Node), Decls);
2826 end Expand_Calling_Stubs_Bodies;
2828 -----------------------------------
2829 -- Expand_Receiving_Stubs_Bodies --
2830 -----------------------------------
2832 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2835 Stubs_Decls : List_Id;
2836 Stubs_Stmts : List_Id;
2839 if Nkind (Unit_Node) = N_Package_Declaration then
2840 Spec := Specification (Unit_Node);
2841 Decls := Private_Declarations (Spec);
2844 Decls := Visible_Declarations (Spec);
2847 Push_Scope (Scope_Of_Spec (Spec));
2848 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2852 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2853 Decls := Declarations (Unit_Node);
2855 Push_Scope (Scope_Of_Spec (Unit_Node));
2856 Stubs_Decls := New_List;
2857 Stubs_Stmts := New_List;
2858 Specific_Add_Receiving_Stubs_To_Declarations
2859 (Spec, Stubs_Decls, Stubs_Stmts);
2861 Insert_List_Before (First (Decls), Stubs_Decls);
2864 HSS_Stmts : constant List_Id :=
2865 Statements (Handled_Statement_Sequence (Unit_Node));
2867 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2870 if No (First_HSS_Stmt) then
2871 Append_List_To (HSS_Stmts, Stubs_Stmts);
2873 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2879 end Expand_Receiving_Stubs_Bodies;
2881 --------------------
2882 -- GARLIC_Support --
2883 --------------------
2885 package body GARLIC_Support is
2887 -- Local subprograms
2889 procedure Add_RACW_Read_Attribute
2890 (RACW_Type : Entity_Id;
2891 Stub_Type : Entity_Id;
2892 Stub_Type_Access : Entity_Id;
2893 Body_Decls : List_Id);
2894 -- Add Read attribute for the RACW type. The declaration and attribute
2895 -- definition clauses are inserted right after the declaration of
2896 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2897 -- appended to it (case where the RACW declaration is in the main unit).
2899 procedure Add_RACW_Write_Attribute
2900 (RACW_Type : Entity_Id;
2901 Stub_Type : Entity_Id;
2902 Stub_Type_Access : Entity_Id;
2903 RPC_Receiver : Node_Id;
2904 Body_Decls : List_Id);
2905 -- Same as above for the Write attribute
2907 function Stream_Parameter return Node_Id;
2908 function Result return Node_Id;
2909 function Object return Node_Id renames Result;
2910 -- Functions to create occurrences of the formal parameter names of the
2911 -- 'Read and 'Write attributes.
2914 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2915 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2917 procedure Add_RAS_Access_TSS (N : Node_Id);
2918 -- Add a subprogram body for RAS Access TSS
2920 -------------------------------------
2921 -- Add_Obj_RPC_Receiver_Completion --
2922 -------------------------------------
2924 procedure Add_Obj_RPC_Receiver_Completion
2927 RPC_Receiver : Entity_Id;
2928 Stub_Elements : Stub_Structure)
2931 -- The RPC receiver body should not be the completion of the
2932 -- declaration recorded in the stub structure, because then the
2933 -- occurrences of the formal parameters within the body should refer
2934 -- to the entities from the declaration, not from the completion, to
2935 -- which we do not have easy access. Instead, the RPC receiver body
2936 -- acts as its own declaration, and the RPC receiver declaration is
2937 -- completed by a renaming-as-body.
2940 Make_Subprogram_Renaming_Declaration (Loc,
2942 Copy_Specification (Loc,
2943 Specification (Stub_Elements.RPC_Receiver_Decl)),
2944 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2945 end Add_Obj_RPC_Receiver_Completion;
2947 -----------------------
2948 -- Add_RACW_Features --
2949 -----------------------
2951 procedure Add_RACW_Features
2952 (RACW_Type : Entity_Id;
2953 Stub_Type : Entity_Id;
2954 Stub_Type_Access : Entity_Id;
2955 RPC_Receiver_Decl : Node_Id;
2956 Body_Decls : List_Id)
2958 RPC_Receiver : Node_Id;
2959 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2962 Loc := Sloc (RACW_Type);
2966 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2967 -- of the corresponding distributed object type. We retrieve its
2968 -- address from the local proxy object.
2970 RPC_Receiver := Make_Selected_Component (Loc,
2972 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2973 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2976 RPC_Receiver := Make_Attribute_Reference (Loc,
2977 Prefix => New_Occurrence_Of (
2978 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2979 Attribute_Name => Name_Address);
2982 Add_RACW_Write_Attribute
2989 Add_RACW_Read_Attribute
2994 end Add_RACW_Features;
2996 -----------------------------
2997 -- Add_RACW_Read_Attribute --
2998 -----------------------------
3000 procedure Add_RACW_Read_Attribute
3001 (RACW_Type : Entity_Id;
3002 Stub_Type : Entity_Id;
3003 Stub_Type_Access : Entity_Id;
3004 Body_Decls : List_Id)
3006 Proc_Decl : Node_Id;
3007 Attr_Decl : Node_Id;
3009 Body_Node : Node_Id;
3011 Statements : constant List_Id := New_List;
3013 Local_Statements : List_Id;
3014 Remote_Statements : List_Id;
3015 -- Various parts of the procedure
3017 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
3018 Asynchronous_Flag : constant Entity_Id :=
3019 Asynchronous_Flags_Table.Get (RACW_Type);
3020 pragma Assert (Present (Asynchronous_Flag));
3022 -- Prepare local identifiers
3024 Source_Partition : Entity_Id;
3025 Source_Receiver : Entity_Id;
3026 Source_Address : Entity_Id;
3027 Local_Stub : Entity_Id;
3028 Stubbed_Result : Entity_Id;
3030 -- Start of processing for Add_RACW_Read_Attribute
3033 Build_Stream_Procedure (Loc,
3034 RACW_Type, Body_Node, Pnam, Statements, Outp => True);
3035 Proc_Decl := Make_Subprogram_Declaration (Loc,
3036 Copy_Specification (Loc, Specification (Body_Node)));
3039 Make_Attribute_Definition_Clause (Loc,
3040 Name => New_Occurrence_Of (RACW_Type, Loc),
3044 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3046 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3047 Insert_After (Proc_Decl, Attr_Decl);
3049 if No (Body_Decls) then
3051 -- Case of processing an RACW type from another unit than the
3052 -- main one: do not generate a body.
3057 -- Prepare local identifiers
3059 Source_Partition := Make_Temporary (Loc, 'P');
3060 Source_Receiver := Make_Temporary (Loc, 'S');
3061 Source_Address := Make_Temporary (Loc, 'P');
3062 Local_Stub := Make_Temporary (Loc, 'L');
3063 Stubbed_Result := Make_Temporary (Loc, 'S');
3065 -- Generate object declarations
3068 Make_Object_Declaration (Loc,
3069 Defining_Identifier => Source_Partition,
3070 Object_Definition =>
3071 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
3073 Make_Object_Declaration (Loc,
3074 Defining_Identifier => Source_Receiver,
3075 Object_Definition =>
3076 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3078 Make_Object_Declaration (Loc,
3079 Defining_Identifier => Source_Address,
3080 Object_Definition =>
3081 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3083 Make_Object_Declaration (Loc,
3084 Defining_Identifier => Local_Stub,
3085 Aliased_Present => True,
3086 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
3088 Make_Object_Declaration (Loc,
3089 Defining_Identifier => Stubbed_Result,
3090 Object_Definition =>
3091 New_Occurrence_Of (Stub_Type_Access, Loc),
3093 Make_Attribute_Reference (Loc,
3095 New_Occurrence_Of (Local_Stub, Loc),
3097 Name_Unchecked_Access)));
3099 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3101 Append_List_To (Statements, New_List (
3102 Make_Attribute_Reference (Loc,
3104 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3105 Attribute_Name => Name_Read,
3106 Expressions => New_List (
3108 New_Occurrence_Of (Source_Partition, Loc))),
3110 Make_Attribute_Reference (Loc,
3112 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3115 Expressions => New_List (
3117 New_Occurrence_Of (Source_Receiver, Loc))),
3119 Make_Attribute_Reference (Loc,
3121 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3124 Expressions => New_List (
3126 New_Occurrence_Of (Source_Address, Loc)))));
3128 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3130 Set_Etype (Stubbed_Result, Stub_Type_Access);
3132 -- If the Address is Null_Address, then return a null object, unless
3133 -- RACW_Type is null-excluding, in which case unconditionally raise
3134 -- CONSTRAINT_ERROR instead.
3137 Zero_Statements : List_Id;
3138 -- Statements executed when a zero value is received
3141 if Can_Never_Be_Null (RACW_Type) then
3142 Zero_Statements := New_List (
3143 Make_Raise_Constraint_Error (Loc,
3144 Reason => CE_Null_Not_Allowed));
3146 Zero_Statements := New_List (
3147 Make_Assignment_Statement (Loc,
3149 Expression => Make_Null (Loc)),
3150 Make_Simple_Return_Statement (Loc));
3153 Append_To (Statements,
3154 Make_Implicit_If_Statement (RACW_Type,
3157 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3158 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3159 Then_Statements => Zero_Statements));
3162 -- If the RACW denotes an object created on the current partition,
3163 -- Local_Statements will be executed. The real object will be used.
3165 Local_Statements := New_List (
3166 Make_Assignment_Statement (Loc,
3169 Unchecked_Convert_To (RACW_Type,
3170 OK_Convert_To (RTE (RE_Address),
3171 New_Occurrence_Of (Source_Address, Loc)))));
3173 -- If the object is located on another partition, then a stub object
3174 -- will be created with all the information needed to rebuild the
3175 -- real object at the other end.
3177 Remote_Statements := New_List (
3179 Make_Assignment_Statement (Loc,
3180 Name => Make_Selected_Component (Loc,
3181 Prefix => Stubbed_Result,
3182 Selector_Name => Name_Origin),
3184 New_Occurrence_Of (Source_Partition, Loc)),
3186 Make_Assignment_Statement (Loc,
3187 Name => Make_Selected_Component (Loc,
3188 Prefix => Stubbed_Result,
3189 Selector_Name => Name_Receiver),
3191 New_Occurrence_Of (Source_Receiver, Loc)),
3193 Make_Assignment_Statement (Loc,
3194 Name => Make_Selected_Component (Loc,
3195 Prefix => Stubbed_Result,
3196 Selector_Name => Name_Addr),
3198 New_Occurrence_Of (Source_Address, Loc)));
3200 Append_To (Remote_Statements,
3201 Make_Assignment_Statement (Loc,
3202 Name => Make_Selected_Component (Loc,
3203 Prefix => Stubbed_Result,
3204 Selector_Name => Name_Asynchronous),
3206 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3208 Append_List_To (Remote_Statements,
3209 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3210 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3211 -- set on the stub type if, and only if, the RACW type has a pragma
3212 -- Asynchronous. This is incorrect for RACWs that implement RAS
3213 -- types, because in that case the /designated subprogram/ (not the
3214 -- type) might be asynchronous, and that causes the stub to need to
3215 -- be asynchronous too. A solution is to transport a RAS as a struct
3216 -- containing a RACW and an asynchronous flag, and to properly alter
3217 -- the Asynchronous component in the stub type in the RAS's Input
3220 Append_To (Remote_Statements,
3221 Make_Assignment_Statement (Loc,
3223 Expression => Unchecked_Convert_To (RACW_Type,
3224 New_Occurrence_Of (Stubbed_Result, Loc))));
3226 -- Distinguish between the local and remote cases, and execute the
3227 -- appropriate piece of code.
3229 Append_To (Statements,
3230 Make_Implicit_If_Statement (RACW_Type,
3234 Make_Function_Call (Loc,
3235 Name => New_Occurrence_Of (
3236 RTE (RE_Get_Local_Partition_Id), Loc)),
3237 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3238 Then_Statements => Local_Statements,
3239 Else_Statements => Remote_Statements));
3241 Set_Declarations (Body_Node, Decls);
3242 Append_To (Body_Decls, Body_Node);
3243 end Add_RACW_Read_Attribute;
3245 ------------------------------
3246 -- Add_RACW_Write_Attribute --
3247 ------------------------------
3249 procedure Add_RACW_Write_Attribute
3250 (RACW_Type : Entity_Id;
3251 Stub_Type : Entity_Id;
3252 Stub_Type_Access : Entity_Id;
3253 RPC_Receiver : Node_Id;
3254 Body_Decls : List_Id)
3256 Body_Node : Node_Id;
3257 Proc_Decl : Node_Id;
3258 Attr_Decl : Node_Id;
3260 Statements : constant List_Id := New_List;
3261 Local_Statements : List_Id;
3262 Remote_Statements : List_Id;
3263 Null_Statements : List_Id;
3265 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
3268 Build_Stream_Procedure
3269 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
3271 Proc_Decl := Make_Subprogram_Declaration (Loc,
3272 Copy_Specification (Loc, Specification (Body_Node)));
3275 Make_Attribute_Definition_Clause (Loc,
3276 Name => New_Occurrence_Of (RACW_Type, Loc),
3277 Chars => Name_Write,
3280 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3282 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3283 Insert_After (Proc_Decl, Attr_Decl);
3285 if No (Body_Decls) then
3289 -- Build the code fragment corresponding to the marshalling of a
3292 Local_Statements := New_List (
3294 Pack_Entity_Into_Stream_Access (Loc,
3295 Stream => Stream_Parameter,
3296 Object => RTE (RE_Get_Local_Partition_Id)),
3298 Pack_Node_Into_Stream_Access (Loc,
3299 Stream => Stream_Parameter,
3300 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3301 Etyp => RTE (RE_Unsigned_64)),
3303 Pack_Node_Into_Stream_Access (Loc,
3304 Stream => Stream_Parameter,
3305 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3306 Make_Attribute_Reference (Loc,
3308 Make_Explicit_Dereference (Loc,
3310 Attribute_Name => Name_Address)),
3311 Etyp => RTE (RE_Unsigned_64)));
3313 -- Build the code fragment corresponding to the marshalling of
3316 Remote_Statements := New_List (
3317 Pack_Node_Into_Stream_Access (Loc,
3318 Stream => Stream_Parameter,
3320 Make_Selected_Component (Loc,
3322 Unchecked_Convert_To (Stub_Type_Access, Object),
3323 Selector_Name => Make_Identifier (Loc, Name_Origin)),
3324 Etyp => RTE (RE_Partition_ID)),
3326 Pack_Node_Into_Stream_Access (Loc,
3327 Stream => Stream_Parameter,
3329 Make_Selected_Component (Loc,
3331 Unchecked_Convert_To (Stub_Type_Access, Object),
3332 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
3333 Etyp => RTE (RE_Unsigned_64)),
3335 Pack_Node_Into_Stream_Access (Loc,
3336 Stream => Stream_Parameter,
3338 Make_Selected_Component (Loc,
3340 Unchecked_Convert_To (Stub_Type_Access, Object),
3341 Selector_Name => Make_Identifier (Loc, Name_Addr)),
3342 Etyp => RTE (RE_Unsigned_64)));
3344 -- Build code fragment corresponding to marshalling of a null object
3346 Null_Statements := New_List (
3348 Pack_Entity_Into_Stream_Access (Loc,
3349 Stream => Stream_Parameter,
3350 Object => RTE (RE_Get_Local_Partition_Id)),
3352 Pack_Node_Into_Stream_Access (Loc,
3353 Stream => Stream_Parameter,
3354 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3355 Etyp => RTE (RE_Unsigned_64)),
3357 Pack_Node_Into_Stream_Access (Loc,
3358 Stream => Stream_Parameter,
3359 Object => Make_Integer_Literal (Loc, Uint_0),
3360 Etyp => RTE (RE_Unsigned_64)));
3362 Append_To (Statements,
3363 Make_Implicit_If_Statement (RACW_Type,
3366 Left_Opnd => Object,
3367 Right_Opnd => Make_Null (Loc)),
3369 Then_Statements => Null_Statements,
3371 Elsif_Parts => New_List (
3372 Make_Elsif_Part (Loc,
3376 Make_Attribute_Reference (Loc,
3378 Attribute_Name => Name_Tag),
3381 Make_Attribute_Reference (Loc,
3382 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3383 Attribute_Name => Name_Tag)),
3384 Then_Statements => Remote_Statements)),
3385 Else_Statements => Local_Statements));
3387 Append_To (Body_Decls, Body_Node);
3388 end Add_RACW_Write_Attribute;
3390 ------------------------
3391 -- Add_RAS_Access_TSS --
3392 ------------------------
3394 procedure Add_RAS_Access_TSS (N : Node_Id) is
3395 Loc : constant Source_Ptr := Sloc (N);
3397 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3398 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3399 -- Ras_Type is the access to subprogram type while Fat_Type is the
3400 -- corresponding record type.
3402 RACW_Type : constant Entity_Id :=
3403 Underlying_RACW_Type (Ras_Type);
3404 Desig : constant Entity_Id :=
3405 Etype (Designated_Type (RACW_Type));
3407 Stub_Elements : constant Stub_Structure :=
3408 Stubs_Table.Get (Desig);
3409 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3411 Proc : constant Entity_Id :=
3412 Make_Defining_Identifier (Loc,
3413 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3415 Proc_Spec : Node_Id;
3417 -- Formal parameters
3419 Package_Name : constant Entity_Id :=
3420 Make_Defining_Identifier (Loc,
3424 Subp_Id : constant Entity_Id :=
3425 Make_Defining_Identifier (Loc,
3427 -- Target subprogram
3429 Asynch_P : constant Entity_Id :=
3430 Make_Defining_Identifier (Loc,
3431 Chars => Name_Asynchronous);
3432 -- Is the procedure to which the 'Access applies asynchronous?
3434 All_Calls_Remote : constant Entity_Id :=
3435 Make_Defining_Identifier (Loc,
3436 Chars => Name_All_Calls_Remote);
3437 -- True if an All_Calls_Remote pragma applies to the RCI unit
3438 -- that contains the subprogram.
3440 -- Common local variables
3442 Proc_Decls : List_Id;
3443 Proc_Statements : List_Id;
3445 Origin : constant Entity_Id := Make_Temporary (Loc, 'P');
3447 -- Additional local variables for the local case
3449 Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P');
3451 -- Additional local variables for the remote case
3453 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
3454 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
3457 (Field_Name : Name_Id;
3458 Value : Node_Id) return Node_Id;
3459 -- Construct an assignment that sets the named component in the
3467 (Field_Name : Name_Id;
3468 Value : Node_Id) return Node_Id
3472 Make_Assignment_Statement (Loc,
3474 Make_Selected_Component (Loc,
3476 Selector_Name => Field_Name),
3477 Expression => Value);
3480 -- Start of processing for Add_RAS_Access_TSS
3483 Proc_Decls := New_List (
3485 -- Common declarations
3487 Make_Object_Declaration (Loc,
3488 Defining_Identifier => Origin,
3489 Constant_Present => True,
3490 Object_Definition =>
3491 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3493 Make_Function_Call (Loc,
3495 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3496 Parameter_Associations => New_List (
3497 New_Occurrence_Of (Package_Name, Loc)))),
3499 -- Declaration use only in the local case: proxy address
3501 Make_Object_Declaration (Loc,
3502 Defining_Identifier => Proxy_Addr,
3503 Object_Definition =>
3504 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3506 -- Declarations used only in the remote case: stub object and
3509 Make_Object_Declaration (Loc,
3510 Defining_Identifier => Local_Stub,
3511 Aliased_Present => True,
3512 Object_Definition =>
3513 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3515 Make_Object_Declaration (Loc,
3516 Defining_Identifier =>
3518 Object_Definition =>
3519 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3521 Make_Attribute_Reference (Loc,
3522 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3523 Attribute_Name => Name_Unchecked_Access)));
3525 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3527 -- Build_Get_Unique_RP_Call needs above information
3529 -- Note: Here we assume that the Fat_Type is a record
3530 -- containing just a pointer to a proxy or stub object.
3532 Proc_Statements := New_List (
3536 -- Get_RAS_Info (Pkg, Subp, PA);
3537 -- if Origin = Local_Partition_Id
3538 -- and then not All_Calls_Remote
3540 -- return Fat_Type!(PA);
3543 Make_Procedure_Call_Statement (Loc,
3544 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3545 Parameter_Associations => New_List (
3546 New_Occurrence_Of (Package_Name, Loc),
3547 New_Occurrence_Of (Subp_Id, Loc),
3548 New_Occurrence_Of (Proxy_Addr, Loc))),
3550 Make_Implicit_If_Statement (N,
3556 New_Occurrence_Of (Origin, Loc),
3558 Make_Function_Call (Loc,
3560 RTE (RE_Get_Local_Partition_Id), Loc))),
3564 New_Occurrence_Of (All_Calls_Remote, Loc))),
3566 Then_Statements => New_List (
3567 Make_Simple_Return_Statement (Loc,
3568 Unchecked_Convert_To (Fat_Type,
3569 OK_Convert_To (RTE (RE_Address),
3570 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3572 Set_Field (Name_Origin,
3573 New_Occurrence_Of (Origin, Loc)),
3575 Set_Field (Name_Receiver,
3576 Make_Function_Call (Loc,
3578 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3579 Parameter_Associations => New_List (
3580 New_Occurrence_Of (Package_Name, Loc)))),
3582 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3584 -- E.4.1(9) A remote call is asynchronous if it is a call to
3585 -- a procedure or a call through a value of an access-to-procedure
3586 -- type to which a pragma Asynchronous applies.
3588 -- Asynch_P is true when the procedure is asynchronous;
3589 -- Asynch_T is true when the type is asynchronous.
3591 Set_Field (Name_Asynchronous,
3593 New_Occurrence_Of (Asynch_P, Loc),
3594 New_Occurrence_Of (Boolean_Literals (
3595 Is_Asynchronous (Ras_Type)), Loc))));
3597 Append_List_To (Proc_Statements,
3598 Build_Get_Unique_RP_Call
3599 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3601 -- Return the newly created value
3603 Append_To (Proc_Statements,
3604 Make_Simple_Return_Statement (Loc,
3606 Unchecked_Convert_To (Fat_Type,
3607 New_Occurrence_Of (Stub_Ptr, Loc))));
3610 Make_Function_Specification (Loc,
3611 Defining_Unit_Name => Proc,
3612 Parameter_Specifications => New_List (
3613 Make_Parameter_Specification (Loc,
3614 Defining_Identifier => Package_Name,
3616 New_Occurrence_Of (Standard_String, Loc)),
3618 Make_Parameter_Specification (Loc,
3619 Defining_Identifier => Subp_Id,
3621 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3623 Make_Parameter_Specification (Loc,
3624 Defining_Identifier => Asynch_P,
3626 New_Occurrence_Of (Standard_Boolean, Loc)),
3628 Make_Parameter_Specification (Loc,
3629 Defining_Identifier => All_Calls_Remote,
3631 New_Occurrence_Of (Standard_Boolean, Loc))),
3633 Result_Definition =>
3634 New_Occurrence_Of (Fat_Type, Loc));
3636 -- Set the kind and return type of the function to prevent
3637 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3639 Set_Ekind (Proc, E_Function);
3640 Set_Etype (Proc, Fat_Type);
3643 Make_Subprogram_Body (Loc,
3644 Specification => Proc_Spec,
3645 Declarations => Proc_Decls,
3646 Handled_Statement_Sequence =>
3647 Make_Handled_Sequence_Of_Statements (Loc,
3648 Statements => Proc_Statements)));
3650 Set_TSS (Fat_Type, Proc);
3651 end Add_RAS_Access_TSS;
3653 -----------------------
3654 -- Add_RAST_Features --
3655 -----------------------
3657 procedure Add_RAST_Features
3658 (Vis_Decl : Node_Id;
3659 RAS_Type : Entity_Id)
3661 pragma Unreferenced (RAS_Type);
3663 Add_RAS_Access_TSS (Vis_Decl);
3664 end Add_RAST_Features;
3666 -----------------------------------------
3667 -- Add_Receiving_Stubs_To_Declarations --
3668 -----------------------------------------
3670 procedure Add_Receiving_Stubs_To_Declarations
3671 (Pkg_Spec : Node_Id;
3675 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3677 Request_Parameter : Node_Id;
3679 Pkg_RPC_Receiver : constant Entity_Id :=
3680 Make_Temporary (Loc, 'H');
3681 Pkg_RPC_Receiver_Statements : List_Id;
3682 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3683 Pkg_RPC_Receiver_Body : Node_Id;
3684 -- A Pkg_RPC_Receiver is built to decode the request
3686 Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R');
3687 -- A remote subprogram is created to allow peers to look up RAS
3688 -- information using subprogram ids.
3690 Subp_Id : Entity_Id;
3691 Subp_Index : Entity_Id;
3692 -- Subprogram_Id as read from the incoming stream
3694 Current_Declaration : Node_Id;
3695 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3696 Current_Stubs : Node_Id;
3698 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
3699 Subp_Info_List : constant List_Id := New_List;
3701 Register_Pkg_Actuals : constant List_Id := New_List;
3703 All_Calls_Remote_E : Entity_Id;
3704 Proxy_Object_Addr : Entity_Id;
3706 procedure Append_Stubs_To
3707 (RPC_Receiver_Cases : List_Id;
3709 Subprogram_Number : Int);
3710 -- Add one case to the specified RPC receiver case list
3711 -- associating Subprogram_Number with the subprogram declared
3712 -- by Declaration, for which we have receiving stubs in Stubs.
3714 ---------------------
3715 -- Append_Stubs_To --
3716 ---------------------
3718 procedure Append_Stubs_To
3719 (RPC_Receiver_Cases : List_Id;
3721 Subprogram_Number : Int)
3724 Append_To (RPC_Receiver_Cases,
3725 Make_Case_Statement_Alternative (Loc,
3727 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3730 Make_Procedure_Call_Statement (Loc,
3732 New_Occurrence_Of (Defining_Entity (Stubs), Loc),
3733 Parameter_Associations => New_List (
3734 New_Occurrence_Of (Request_Parameter, Loc))))));
3735 end Append_Stubs_To;
3737 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3740 -- Building receiving stubs consist in several operations:
3742 -- - a package RPC receiver must be built. This subprogram
3743 -- will get a Subprogram_Id from the incoming stream
3744 -- and will dispatch the call to the right subprogram;
3746 -- - a receiving stub for each subprogram visible in the package
3747 -- spec. This stub will read all the parameters from the stream,
3748 -- and put the result as well as the exception occurrence in the
3751 -- - a dummy package with an empty spec and a body made of an
3752 -- elaboration part, whose job is to register the receiving
3753 -- part of this RCI package on the name server. This is done
3754 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3756 Build_RPC_Receiver_Body (
3757 RPC_Receiver => Pkg_RPC_Receiver,
3758 Request => Request_Parameter,
3760 Subp_Index => Subp_Index,
3761 Stmts => Pkg_RPC_Receiver_Statements,
3762 Decl => Pkg_RPC_Receiver_Body);
3763 pragma Assert (Subp_Id = Subp_Index);
3765 -- A null subp_id denotes a call through a RAS, in which case the
3766 -- next Uint_64 element in the stream is the address of the local
3767 -- proxy object, from which we can retrieve the actual subprogram id.
3769 Append_To (Pkg_RPC_Receiver_Statements,
3770 Make_Implicit_If_Statement (Pkg_Spec,
3773 New_Occurrence_Of (Subp_Id, Loc),
3774 Make_Integer_Literal (Loc, 0)),
3776 Then_Statements => New_List (
3777 Make_Assignment_Statement (Loc,
3779 New_Occurrence_Of (Subp_Id, Loc),
3782 Make_Selected_Component (Loc,
3784 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3785 OK_Convert_To (RTE (RE_Address),
3786 Make_Attribute_Reference (Loc,
3788 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3791 Expressions => New_List (
3792 Make_Selected_Component (Loc,
3793 Prefix => Request_Parameter,
3794 Selector_Name => Name_Params))))),
3797 Make_Identifier (Loc, Name_Subp_Id))))));
3799 -- Build a subprogram for RAS information lookups
3801 Current_Declaration :=
3802 Make_Subprogram_Declaration (Loc,
3804 Make_Function_Specification (Loc,
3805 Defining_Unit_Name =>
3807 Parameter_Specifications => New_List (
3808 Make_Parameter_Specification (Loc,
3809 Defining_Identifier =>
3810 Make_Defining_Identifier (Loc, Name_Subp_Id),
3814 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3815 Result_Definition =>
3816 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3818 Append_To (Decls, Current_Declaration);
3819 Analyze (Current_Declaration);
3821 Current_Stubs := Build_Subprogram_Receiving_Stubs
3822 (Vis_Decl => Current_Declaration,
3823 Asynchronous => False);
3824 Append_To (Decls, Current_Stubs);
3825 Analyze (Current_Stubs);
3827 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3830 Subprogram_Number => 1);
3832 -- For each subprogram, the receiving stub will be built and a
3833 -- case statement will be made on the Subprogram_Id to dispatch
3834 -- to the right subprogram.
3836 All_Calls_Remote_E :=
3838 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3840 Overload_Counter_Table.Reset;
3842 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3843 while Present (Current_Declaration) loop
3844 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3845 and then Comes_From_Source (Current_Declaration)
3848 Loc : constant Source_Ptr := Sloc (Current_Declaration);
3849 -- While specifically processing Current_Declaration, use
3850 -- its Sloc as the location of all generated nodes.
3852 Subp_Def : constant Entity_Id :=
3854 (Specification (Current_Declaration));
3856 Subp_Val : String_Id;
3857 pragma Warnings (Off, Subp_Val);
3860 -- Build receiving stub
3863 Build_Subprogram_Receiving_Stubs
3864 (Vis_Decl => Current_Declaration,
3866 Nkind (Specification (Current_Declaration)) =
3867 N_Procedure_Specification
3868 and then Is_Asynchronous (Subp_Def));
3870 Append_To (Decls, Current_Stubs);
3871 Analyze (Current_Stubs);
3875 Add_RAS_Proxy_And_Analyze (Decls,
3876 Vis_Decl => Current_Declaration,
3877 All_Calls_Remote_E => All_Calls_Remote_E,
3878 Proxy_Object_Addr => Proxy_Object_Addr);
3880 -- Compute distribution identifier
3882 Assign_Subprogram_Identifier
3884 Current_Subprogram_Number,
3888 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
3890 -- Add subprogram descriptor (RCI_Subp_Info) to the
3891 -- subprograms table for this receiver. The aggregate
3892 -- below must be kept consistent with the declaration
3893 -- of type RCI_Subp_Info in System.Partition_Interface.
3895 Append_To (Subp_Info_List,
3896 Make_Component_Association (Loc,
3897 Choices => New_List (
3898 Make_Integer_Literal (Loc,
3899 Current_Subprogram_Number)),
3902 Make_Aggregate (Loc,
3903 Component_Associations => New_List (
3904 Make_Component_Association (Loc,
3905 Choices => New_List (
3906 Make_Identifier (Loc, Name_Addr)),
3909 Proxy_Object_Addr, Loc))))));
3911 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3912 Stubs => Current_Stubs,
3913 Subprogram_Number => Current_Subprogram_Number);
3916 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3919 Next (Current_Declaration);
3922 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3923 -- rather than raising an exception since we do not want someone
3924 -- to crash a remote partition by sending invalid subprogram ids.
3925 -- This is consistent with the other parts of the case statement
3926 -- since even in presence of incorrect parameters in the stream,
3927 -- every exception will be caught and (if the subprogram is not an
3928 -- APC) put into the result stream and sent away.
3930 Append_To (Pkg_RPC_Receiver_Cases,
3931 Make_Case_Statement_Alternative (Loc,
3932 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
3933 Statements => New_List (Make_Null_Statement (Loc))));
3935 Append_To (Pkg_RPC_Receiver_Statements,
3936 Make_Case_Statement (Loc,
3937 Expression => New_Occurrence_Of (Subp_Id, Loc),
3938 Alternatives => Pkg_RPC_Receiver_Cases));
3941 Make_Object_Declaration (Loc,
3942 Defining_Identifier => Subp_Info_Array,
3943 Constant_Present => True,
3944 Aliased_Present => True,
3945 Object_Definition =>
3946 Make_Subtype_Indication (Loc,
3948 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3950 Make_Index_Or_Discriminant_Constraint (Loc,
3953 Low_Bound => Make_Integer_Literal (Loc,
3954 First_RCI_Subprogram_Id),
3956 Make_Integer_Literal (Loc,
3958 First_RCI_Subprogram_Id
3959 + List_Length (Subp_Info_List) - 1)))))));
3961 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3962 -- has zero length, and the declaration is for an empty array, in
3963 -- which case no initialization aggregate must be generated.
3965 if Present (First (Subp_Info_List)) then
3966 Set_Expression (Last (Decls),
3967 Make_Aggregate (Loc,
3968 Component_Associations => Subp_Info_List));
3970 -- No initialization provided: remove CONSTANT so that the
3971 -- declaration is not an incomplete deferred constant.
3974 Set_Constant_Present (Last (Decls), False);
3977 Analyze (Last (Decls));
3980 Subp_Info_Addr : Node_Id;
3981 -- Return statement for Lookup_RAS_Info: address of the subprogram
3982 -- information record for the requested subprogram id.
3985 if Present (First (Subp_Info_List)) then
3987 Make_Selected_Component (Loc,
3989 Make_Indexed_Component (Loc,
3990 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
3991 Expressions => New_List (
3992 Convert_To (Standard_Integer,
3993 Make_Identifier (Loc, Name_Subp_Id)))),
3994 Selector_Name => Make_Identifier (Loc, Name_Addr));
3996 -- Case of no visible subprogram: just raise Constraint_Error, we
3997 -- know for sure we got junk from a remote partition.
4001 Make_Raise_Constraint_Error (Loc,
4002 Reason => CE_Range_Check_Failed);
4003 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
4007 Make_Subprogram_Body (Loc,
4009 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
4010 Declarations => No_List,
4011 Handled_Statement_Sequence =>
4012 Make_Handled_Sequence_Of_Statements (Loc,
4013 Statements => New_List (
4014 Make_Simple_Return_Statement (Loc,
4017 (RTE (RE_Unsigned_64), Subp_Info_Addr))))));
4020 Analyze (Last (Decls));
4022 Append_To (Decls, Pkg_RPC_Receiver_Body);
4023 Analyze (Last (Decls));
4025 Get_Library_Unit_Name_String (Pkg_Spec);
4029 Append_To (Register_Pkg_Actuals,
4030 Make_String_Literal (Loc,
4031 Strval => String_From_Name_Buffer));
4035 Append_To (Register_Pkg_Actuals,
4036 Make_Attribute_Reference (Loc,
4037 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
4038 Attribute_Name => Name_Unrestricted_Access));
4042 Append_To (Register_Pkg_Actuals,
4043 Make_Attribute_Reference (Loc,
4045 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
4046 Attribute_Name => Name_Version));
4050 Append_To (Register_Pkg_Actuals,
4051 Make_Attribute_Reference (Loc,
4052 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4053 Attribute_Name => Name_Address));
4057 Append_To (Register_Pkg_Actuals,
4058 Make_Attribute_Reference (Loc,
4059 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4060 Attribute_Name => Name_Length));
4062 -- Generate the call
4065 Make_Procedure_Call_Statement (Loc,
4067 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
4068 Parameter_Associations => Register_Pkg_Actuals));
4069 Analyze (Last (Stmts));
4070 end Add_Receiving_Stubs_To_Declarations;
4072 ---------------------------------
4073 -- Build_General_Calling_Stubs --
4074 ---------------------------------
4076 procedure Build_General_Calling_Stubs
4078 Statements : List_Id;
4079 Target_Partition : Entity_Id;
4080 Target_RPC_Receiver : Node_Id;
4081 Subprogram_Id : Node_Id;
4082 Asynchronous : Node_Id := Empty;
4083 Is_Known_Asynchronous : Boolean := False;
4084 Is_Known_Non_Asynchronous : Boolean := False;
4085 Is_Function : Boolean;
4087 Stub_Type : Entity_Id := Empty;
4088 RACW_Type : Entity_Id := Empty;
4091 Loc : constant Source_Ptr := Sloc (Nod);
4093 Stream_Parameter : Node_Id;
4094 -- Name of the stream used to transmit parameters to the remote
4097 Result_Parameter : Node_Id;
4098 -- Name of the result parameter (in non-APC cases) which get the
4099 -- result of the remote subprogram.
4101 Exception_Return_Parameter : Node_Id;
4102 -- Name of the parameter which will hold the exception sent by the
4103 -- remote subprogram.
4105 Current_Parameter : Node_Id;
4106 -- Current parameter being handled
4108 Ordered_Parameters_List : constant List_Id :=
4109 Build_Ordered_Parameters_List (Spec);
4111 Asynchronous_Statements : List_Id := No_List;
4112 Non_Asynchronous_Statements : List_Id := No_List;
4113 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4115 Extra_Formal_Statements : constant List_Id := New_List;
4116 -- List of statements for extra formal parameters. It will appear
4117 -- after the regular statements for writing out parameters.
4119 pragma Unreferenced (RACW_Type);
4120 -- Used only for the PolyORB case
4123 -- The general form of a calling stub for a given subprogram is:
4125 -- procedure X (...) is P : constant Partition_ID :=
4126 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4127 -- System.RPC.Params_Stream_Type (0); begin
4128 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4129 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4130 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4131 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4133 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4135 -- There are some variations: Do_APC is called for an asynchronous
4136 -- procedure and the part after the call is completely ommitted as
4137 -- well as the declaration of Result. For a function call, 'Input is
4138 -- always used to read the result even if it is constrained.
4140 Stream_Parameter := Make_Temporary (Loc, 'S');
4143 Make_Object_Declaration (Loc,
4144 Defining_Identifier => Stream_Parameter,
4145 Aliased_Present => True,
4146 Object_Definition =>
4147 Make_Subtype_Indication (Loc,
4149 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4151 Make_Index_Or_Discriminant_Constraint (Loc,
4153 New_List (Make_Integer_Literal (Loc, 0))))));
4155 if not Is_Known_Asynchronous then
4156 Result_Parameter := Make_Temporary (Loc, 'R');
4159 Make_Object_Declaration (Loc,
4160 Defining_Identifier => Result_Parameter,
4161 Aliased_Present => True,
4162 Object_Definition =>
4163 Make_Subtype_Indication (Loc,
4165 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4167 Make_Index_Or_Discriminant_Constraint (Loc,
4169 New_List (Make_Integer_Literal (Loc, 0))))));
4171 Exception_Return_Parameter := Make_Temporary (Loc, '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_Temporary (Loc, 'P');
4293 Make_Object_Declaration (Loc,
4294 Defining_Identifier => Extra_Parameter,
4295 Constant_Present => True,
4296 Object_Definition =>
4297 New_Occurrence_Of (Standard_Boolean, Loc),
4299 Make_Attribute_Reference (Loc,
4302 Defining_Identifier (Current_Parameter), Loc),
4303 Attribute_Name => Name_Constrained)));
4305 Append_To (Extra_Formal_Statements,
4306 Make_Attribute_Reference (Loc,
4308 New_Occurrence_Of (Standard_Boolean, Loc),
4309 Attribute_Name => Name_Write,
4310 Expressions => New_List (
4311 Make_Attribute_Reference (Loc,
4314 (Stream_Parameter, Loc), Attribute_Name =>
4316 New_Occurrence_Of (Extra_Parameter, Loc))));
4319 Next (Current_Parameter);
4323 -- Append the formal statements list to the statements
4325 Append_List_To (Statements, Extra_Formal_Statements);
4327 if not Is_Known_Non_Asynchronous then
4329 -- Build the call to System.RPC.Do_APC
4331 Asynchronous_Statements := New_List (
4332 Make_Procedure_Call_Statement (Loc,
4334 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4335 Parameter_Associations => New_List (
4336 New_Occurrence_Of (Target_Partition, Loc),
4337 Make_Attribute_Reference (Loc,
4339 New_Occurrence_Of (Stream_Parameter, Loc),
4340 Attribute_Name => Name_Access))));
4342 Asynchronous_Statements := No_List;
4345 if not Is_Known_Asynchronous then
4347 -- Build the call to System.RPC.Do_RPC
4349 Non_Asynchronous_Statements := New_List (
4350 Make_Procedure_Call_Statement (Loc,
4352 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4353 Parameter_Associations => New_List (
4354 New_Occurrence_Of (Target_Partition, Loc),
4356 Make_Attribute_Reference (Loc,
4358 New_Occurrence_Of (Stream_Parameter, Loc),
4359 Attribute_Name => Name_Access),
4361 Make_Attribute_Reference (Loc,
4363 New_Occurrence_Of (Result_Parameter, Loc),
4364 Attribute_Name => Name_Access))));
4366 -- Read the exception occurrence from the result stream and
4367 -- reraise it. It does no harm if this is a Null_Occurrence since
4368 -- this does nothing.
4370 Append_To (Non_Asynchronous_Statements,
4371 Make_Attribute_Reference (Loc,
4373 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4375 Attribute_Name => Name_Read,
4377 Expressions => New_List (
4378 Make_Attribute_Reference (Loc,
4380 New_Occurrence_Of (Result_Parameter, Loc),
4381 Attribute_Name => Name_Access),
4382 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4384 Append_To (Non_Asynchronous_Statements,
4385 Make_Procedure_Call_Statement (Loc,
4387 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4388 Parameter_Associations => New_List (
4389 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4393 -- If this is a function call, then read the value and return
4394 -- it. The return value is written/read using 'Output/'Input.
4396 Append_To (Non_Asynchronous_Statements,
4397 Make_Tag_Check (Loc,
4398 Make_Simple_Return_Statement (Loc,
4400 Make_Attribute_Reference (Loc,
4403 Etype (Result_Definition (Spec)), Loc),
4405 Attribute_Name => Name_Input,
4407 Expressions => New_List (
4408 Make_Attribute_Reference (Loc,
4410 New_Occurrence_Of (Result_Parameter, Loc),
4411 Attribute_Name => Name_Access))))));
4414 -- Loop around parameters and assign out (or in out)
4415 -- parameters. In the case of RACW, controlling arguments
4416 -- cannot possibly have changed since they are remote, so
4417 -- we do not read them from the stream.
4419 Current_Parameter := First (Ordered_Parameters_List);
4420 while Present (Current_Parameter) loop
4422 Typ : constant Node_Id :=
4423 Parameter_Type (Current_Parameter);
4430 (Defining_Identifier (Current_Parameter), Loc);
4432 if Nkind (Typ) = N_Access_Definition then
4433 Value := Make_Explicit_Dereference (Loc, Value);
4434 Etyp := Etype (Subtype_Mark (Typ));
4436 Etyp := Etype (Typ);
4439 if (Out_Present (Current_Parameter)
4440 or else Nkind (Typ) = N_Access_Definition)
4441 and then Etyp /= Stub_Type
4443 Append_To (Non_Asynchronous_Statements,
4444 Make_Attribute_Reference (Loc,
4446 New_Occurrence_Of (Etyp, Loc),
4448 Attribute_Name => Name_Read,
4450 Expressions => New_List (
4451 Make_Attribute_Reference (Loc,
4453 New_Occurrence_Of (Result_Parameter, Loc),
4454 Attribute_Name => Name_Access),
4459 Next (Current_Parameter);
4464 if Is_Known_Asynchronous then
4465 Append_List_To (Statements, Asynchronous_Statements);
4467 elsif Is_Known_Non_Asynchronous then
4468 Append_List_To (Statements, Non_Asynchronous_Statements);
4471 pragma Assert (Present (Asynchronous));
4472 Prepend_To (Asynchronous_Statements,
4473 Make_Attribute_Reference (Loc,
4474 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4475 Attribute_Name => Name_Write,
4476 Expressions => New_List (
4477 Make_Attribute_Reference (Loc,
4479 New_Occurrence_Of (Stream_Parameter, Loc),
4480 Attribute_Name => Name_Access),
4481 New_Occurrence_Of (Standard_True, Loc))));
4483 Prepend_To (Non_Asynchronous_Statements,
4484 Make_Attribute_Reference (Loc,
4485 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4486 Attribute_Name => Name_Write,
4487 Expressions => New_List (
4488 Make_Attribute_Reference (Loc,
4490 New_Occurrence_Of (Stream_Parameter, Loc),
4491 Attribute_Name => Name_Access),
4492 New_Occurrence_Of (Standard_False, Loc))));
4494 Append_To (Statements,
4495 Make_Implicit_If_Statement (Nod,
4496 Condition => Asynchronous,
4497 Then_Statements => Asynchronous_Statements,
4498 Else_Statements => Non_Asynchronous_Statements));
4500 end Build_General_Calling_Stubs;
4502 -----------------------------
4503 -- Build_RPC_Receiver_Body --
4504 -----------------------------
4506 procedure Build_RPC_Receiver_Body
4507 (RPC_Receiver : Entity_Id;
4508 Request : out Entity_Id;
4509 Subp_Id : out Entity_Id;
4510 Subp_Index : out Entity_Id;
4511 Stmts : out List_Id;
4514 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4516 RPC_Receiver_Spec : Node_Id;
4517 RPC_Receiver_Decls : List_Id;
4520 Request := Make_Defining_Identifier (Loc, Name_R);
4522 RPC_Receiver_Spec :=
4523 Build_RPC_Receiver_Specification
4524 (RPC_Receiver => RPC_Receiver,
4525 Request_Parameter => Request);
4527 Subp_Id := Make_Temporary (Loc, 'P');
4528 Subp_Index := Subp_Id;
4530 -- Subp_Id may not be a constant, because in the case of the RPC
4531 -- receiver for an RCI package, when a call is received from a RAS
4532 -- dereference, it will be assigned during subsequent processing.
4534 RPC_Receiver_Decls := New_List (
4535 Make_Object_Declaration (Loc,
4536 Defining_Identifier => Subp_Id,
4537 Object_Definition =>
4538 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4540 Make_Attribute_Reference (Loc,
4542 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4543 Attribute_Name => Name_Input,
4544 Expressions => New_List (
4545 Make_Selected_Component (Loc,
4547 Selector_Name => Name_Params)))));
4552 Make_Subprogram_Body (Loc,
4553 Specification => RPC_Receiver_Spec,
4554 Declarations => RPC_Receiver_Decls,
4555 Handled_Statement_Sequence =>
4556 Make_Handled_Sequence_Of_Statements (Loc,
4557 Statements => Stmts));
4558 end Build_RPC_Receiver_Body;
4560 -----------------------
4561 -- Build_Stub_Target --
4562 -----------------------
4564 function Build_Stub_Target
4567 RCI_Locator : Entity_Id;
4568 Controlling_Parameter : Entity_Id) return RPC_Target
4570 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4573 Target_Info.Partition := Make_Temporary (Loc, '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_Comps : out List_Id;
4627 RPC_Receiver_Decl : out Node_Id)
4629 Loc : constant Source_Ptr := Sloc (RACW_Type);
4630 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4633 Stub_Type_Comps := New_List (
4634 Make_Component_Declaration (Loc,
4635 Defining_Identifier =>
4636 Make_Defining_Identifier (Loc, Name_Origin),
4637 Component_Definition =>
4638 Make_Component_Definition (Loc,
4639 Aliased_Present => False,
4640 Subtype_Indication =>
4641 New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
4643 Make_Component_Declaration (Loc,
4644 Defining_Identifier =>
4645 Make_Defining_Identifier (Loc, Name_Receiver),
4646 Component_Definition =>
4647 Make_Component_Definition (Loc,
4648 Aliased_Present => False,
4649 Subtype_Indication =>
4650 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4652 Make_Component_Declaration (Loc,
4653 Defining_Identifier =>
4654 Make_Defining_Identifier (Loc, Name_Addr),
4655 Component_Definition =>
4656 Make_Component_Definition (Loc,
4657 Aliased_Present => False,
4658 Subtype_Indication =>
4659 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4661 Make_Component_Declaration (Loc,
4662 Defining_Identifier =>
4663 Make_Defining_Identifier (Loc, Name_Asynchronous),
4664 Component_Definition =>
4665 Make_Component_Definition (Loc,
4666 Aliased_Present => False,
4667 Subtype_Indication =>
4668 New_Occurrence_Of (Standard_Boolean, Loc))));
4671 RPC_Receiver_Decl := Empty;
4674 RPC_Receiver_Request : constant Entity_Id :=
4675 Make_Defining_Identifier (Loc, Name_R);
4677 RPC_Receiver_Decl :=
4678 Make_Subprogram_Declaration (Loc,
4679 Build_RPC_Receiver_Specification
4680 (RPC_Receiver => Make_Temporary (Loc, 'R'),
4681 Request_Parameter => RPC_Receiver_Request));
4684 end Build_Stub_Type;
4686 --------------------------------------
4687 -- Build_Subprogram_Receiving_Stubs --
4688 --------------------------------------
4690 function Build_Subprogram_Receiving_Stubs
4691 (Vis_Decl : Node_Id;
4692 Asynchronous : Boolean;
4693 Dynamically_Asynchronous : Boolean := False;
4694 Stub_Type : Entity_Id := Empty;
4695 RACW_Type : Entity_Id := Empty;
4696 Parent_Primitive : Entity_Id := Empty) return Node_Id
4698 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4700 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
4701 -- Formal parameter for receiving stubs: a descriptor for an incoming
4704 Decls : constant List_Id := New_List;
4705 -- All the parameters will get declared before calling the real
4706 -- subprograms. Also the out parameters will be declared.
4708 Statements : constant List_Id := New_List;
4710 Extra_Formal_Statements : constant List_Id := New_List;
4711 -- Statements concerning extra formal parameters
4713 After_Statements : constant List_Id := New_List;
4714 -- Statements to be executed after the subprogram call
4716 Inner_Decls : List_Id := No_List;
4717 -- In case of a function, the inner declarations are needed since
4718 -- the result may be unconstrained.
4720 Excep_Handlers : List_Id := No_List;
4721 Excep_Choice : Entity_Id;
4722 Excep_Code : List_Id;
4724 Parameter_List : constant List_Id := New_List;
4725 -- List of parameters to be passed to the subprogram
4727 Current_Parameter : Node_Id;
4729 Ordered_Parameters_List : constant List_Id :=
4730 Build_Ordered_Parameters_List
4731 (Specification (Vis_Decl));
4733 Subp_Spec : Node_Id;
4734 -- Subprogram specification
4736 Called_Subprogram : Node_Id;
4737 -- The subprogram to call
4739 Null_Raise_Statement : Node_Id;
4741 Dynamic_Async : Entity_Id;
4744 if Present (RACW_Type) then
4745 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4747 Called_Subprogram :=
4749 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4752 if Dynamically_Asynchronous then
4753 Dynamic_Async := Make_Temporary (Loc, 'S');
4755 Dynamic_Async := Empty;
4758 if not Asynchronous or Dynamically_Asynchronous then
4760 -- The first statement after the subprogram call is a statement to
4761 -- write a Null_Occurrence into the result stream.
4763 Null_Raise_Statement :=
4764 Make_Attribute_Reference (Loc,
4766 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4767 Attribute_Name => Name_Write,
4768 Expressions => New_List (
4769 Make_Selected_Component (Loc,
4770 Prefix => Request_Parameter,
4771 Selector_Name => Name_Result),
4772 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4774 if Dynamically_Asynchronous then
4775 Null_Raise_Statement :=
4776 Make_Implicit_If_Statement (Vis_Decl,
4778 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4779 Then_Statements => New_List (Null_Raise_Statement));
4782 Append_To (After_Statements, Null_Raise_Statement);
4785 -- Loop through every parameter and get its value from the stream. If
4786 -- the parameter is unconstrained, then the parameter is read using
4787 -- 'Input at the point of declaration.
4789 Current_Parameter := First (Ordered_Parameters_List);
4790 while Present (Current_Parameter) loop
4793 Constrained : Boolean;
4795 Need_Extra_Constrained : Boolean;
4796 -- True when an Extra_Constrained actual is required
4798 Object : constant Entity_Id := Make_Temporary (Loc, 'P');
4800 Expr : Node_Id := Empty;
4802 Is_Controlling_Formal : constant Boolean :=
4803 Is_RACW_Controlling_Formal
4804 (Current_Parameter, Stub_Type);
4807 if Is_Controlling_Formal then
4809 -- We have a controlling formal parameter. Read its address
4810 -- rather than a real object. The address is in Unsigned_64
4813 Etyp := RTE (RE_Unsigned_64);
4815 Etyp := Etype (Parameter_Type (Current_Parameter));
4818 Constrained := not Transmit_As_Unconstrained (Etyp);
4820 if In_Present (Current_Parameter)
4821 or else not Out_Present (Current_Parameter)
4822 or else not Constrained
4823 or else Is_Controlling_Formal
4825 -- If an input parameter is constrained, then the read of
4826 -- the parameter is deferred until the beginning of the
4827 -- subprogram body. If it is unconstrained, then an
4828 -- expression is built for the object declaration and the
4829 -- variable is set using 'Input instead of 'Read. Note that
4830 -- this deferral does not change the order in which the
4831 -- actuals are read because Build_Ordered_Parameter_List
4832 -- puts them unconstrained first.
4835 Append_To (Statements,
4836 Make_Attribute_Reference (Loc,
4837 Prefix => New_Occurrence_Of (Etyp, Loc),
4838 Attribute_Name => Name_Read,
4839 Expressions => New_List (
4840 Make_Selected_Component (Loc,
4841 Prefix => Request_Parameter,
4842 Selector_Name => Name_Params),
4843 New_Occurrence_Of (Object, Loc))));
4847 -- Build and append Input_With_Tag_Check function
4850 Input_With_Tag_Check (Loc,
4853 Make_Selected_Component (Loc,
4854 Prefix => Request_Parameter,
4855 Selector_Name => Name_Params)));
4857 -- Prepare function call expression
4860 Make_Function_Call (Loc,
4864 (Specification (Last (Decls))), Loc));
4868 Need_Extra_Constrained :=
4869 Nkind (Parameter_Type (Current_Parameter)) /=
4872 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4874 Present (Extra_Constrained
4875 (Defining_Identifier (Current_Parameter)));
4877 -- We may not associate an extra constrained actual to a
4878 -- constant object, so if one is needed, declare the actual
4879 -- as a variable even if it won't be modified.
4881 Build_Actual_Object_Declaration
4884 Variable => Need_Extra_Constrained
4885 or else Out_Present (Current_Parameter),
4889 -- An out parameter may be written back using a 'Write
4890 -- attribute instead of a 'Output because it has been
4891 -- constrained by the parameter given to the caller. Note that
4892 -- out controlling arguments in the case of a RACW are not put
4893 -- back in the stream because the pointer on them has not
4896 if Out_Present (Current_Parameter)
4898 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4900 Append_To (After_Statements,
4901 Make_Attribute_Reference (Loc,
4902 Prefix => New_Occurrence_Of (Etyp, Loc),
4903 Attribute_Name => Name_Write,
4904 Expressions => New_List (
4905 Make_Selected_Component (Loc,
4906 Prefix => Request_Parameter,
4907 Selector_Name => Name_Result),
4908 New_Occurrence_Of (Object, Loc))));
4911 -- For RACW controlling formals, the Etyp of Object is always
4912 -- an RACW, even if the parameter is not of an anonymous access
4913 -- type. In such case, we need to dereference it at call time.
4915 if Is_Controlling_Formal then
4916 if Nkind (Parameter_Type (Current_Parameter)) /=
4919 Append_To (Parameter_List,
4920 Make_Parameter_Association (Loc,
4923 Defining_Identifier (Current_Parameter), Loc),
4924 Explicit_Actual_Parameter =>
4925 Make_Explicit_Dereference (Loc,
4926 Unchecked_Convert_To (RACW_Type,
4927 OK_Convert_To (RTE (RE_Address),
4928 New_Occurrence_Of (Object, Loc))))));
4931 Append_To (Parameter_List,
4932 Make_Parameter_Association (Loc,
4935 Defining_Identifier (Current_Parameter), Loc),
4936 Explicit_Actual_Parameter =>
4937 Unchecked_Convert_To (RACW_Type,
4938 OK_Convert_To (RTE (RE_Address),
4939 New_Occurrence_Of (Object, Loc)))));
4943 Append_To (Parameter_List,
4944 Make_Parameter_Association (Loc,
4947 Defining_Identifier (Current_Parameter), Loc),
4948 Explicit_Actual_Parameter =>
4949 New_Occurrence_Of (Object, Loc)));
4952 -- If the current parameter needs an extra formal, then read it
4953 -- from the stream and set the corresponding semantic field in
4954 -- the variable. If the kind of the parameter identifier is
4955 -- E_Void, then this is a compiler generated parameter that
4956 -- doesn't need an extra constrained status.
4958 -- The case of Extra_Accessibility should also be handled ???
4960 if Need_Extra_Constrained then
4962 Extra_Parameter : constant Entity_Id :=
4964 (Defining_Identifier
4965 (Current_Parameter));
4967 Formal_Entity : constant Entity_Id :=
4968 Make_Defining_Identifier
4969 (Loc, Chars (Extra_Parameter));
4971 Formal_Type : constant Entity_Id :=
4972 Etype (Extra_Parameter);
4976 Make_Object_Declaration (Loc,
4977 Defining_Identifier => Formal_Entity,
4978 Object_Definition =>
4979 New_Occurrence_Of (Formal_Type, Loc)));
4981 Append_To (Extra_Formal_Statements,
4982 Make_Attribute_Reference (Loc,
4983 Prefix => New_Occurrence_Of (
4985 Attribute_Name => Name_Read,
4986 Expressions => New_List (
4987 Make_Selected_Component (Loc,
4988 Prefix => Request_Parameter,
4989 Selector_Name => Name_Params),
4990 New_Occurrence_Of (Formal_Entity, Loc))));
4992 -- Note: the call to Set_Extra_Constrained below relies
4993 -- on the fact that Object's Ekind has been set by
4994 -- Build_Actual_Object_Declaration.
4996 Set_Extra_Constrained (Object, Formal_Entity);
5001 Next (Current_Parameter);
5004 -- Append the formal statements list at the end of regular statements
5006 Append_List_To (Statements, Extra_Formal_Statements);
5008 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
5010 -- The remote subprogram is a function. We build an inner block to
5011 -- be able to hold a potentially unconstrained result in a
5015 Etyp : constant Entity_Id :=
5016 Etype (Result_Definition (Specification (Vis_Decl)));
5017 Result : constant Node_Id := Make_Temporary (Loc, 'R');
5020 Inner_Decls := New_List (
5021 Make_Object_Declaration (Loc,
5022 Defining_Identifier => Result,
5023 Constant_Present => True,
5024 Object_Definition => New_Occurrence_Of (Etyp, Loc),
5026 Make_Function_Call (Loc,
5027 Name => Called_Subprogram,
5028 Parameter_Associations => Parameter_List)));
5030 if Is_Class_Wide_Type (Etyp) then
5032 -- For a remote call to a function with a class-wide type,
5033 -- check that the returned value satisfies the requirements
5036 Append_To (Inner_Decls,
5037 Make_Transportable_Check (Loc,
5038 New_Occurrence_Of (Result, Loc)));
5042 Append_To (After_Statements,
5043 Make_Attribute_Reference (Loc,
5044 Prefix => New_Occurrence_Of (Etyp, Loc),
5045 Attribute_Name => Name_Output,
5046 Expressions => New_List (
5047 Make_Selected_Component (Loc,
5048 Prefix => Request_Parameter,
5049 Selector_Name => Name_Result),
5050 New_Occurrence_Of (Result, Loc))));
5053 Append_To (Statements,
5054 Make_Block_Statement (Loc,
5055 Declarations => Inner_Decls,
5056 Handled_Statement_Sequence =>
5057 Make_Handled_Sequence_Of_Statements (Loc,
5058 Statements => After_Statements)));
5061 -- The remote subprogram is a procedure. We do not need any inner
5062 -- block in this case.
5064 if Dynamically_Asynchronous then
5066 Make_Object_Declaration (Loc,
5067 Defining_Identifier => Dynamic_Async,
5068 Object_Definition =>
5069 New_Occurrence_Of (Standard_Boolean, Loc)));
5071 Append_To (Statements,
5072 Make_Attribute_Reference (Loc,
5073 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5074 Attribute_Name => Name_Read,
5075 Expressions => New_List (
5076 Make_Selected_Component (Loc,
5077 Prefix => Request_Parameter,
5078 Selector_Name => Name_Params),
5079 New_Occurrence_Of (Dynamic_Async, Loc))));
5082 Append_To (Statements,
5083 Make_Procedure_Call_Statement (Loc,
5084 Name => Called_Subprogram,
5085 Parameter_Associations => Parameter_List));
5087 Append_List_To (Statements, After_Statements);
5090 if Asynchronous and then not Dynamically_Asynchronous then
5092 -- For an asynchronous procedure, add a null exception handler
5094 Excep_Handlers := New_List (
5095 Make_Implicit_Exception_Handler (Loc,
5096 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5097 Statements => New_List (Make_Null_Statement (Loc))));
5100 -- In the other cases, if an exception is raised, then the
5101 -- exception occurrence is copied into the output stream and
5102 -- no other output parameter is written.
5104 Excep_Choice := Make_Temporary (Loc, 'E');
5106 Excep_Code := New_List (
5107 Make_Attribute_Reference (Loc,
5109 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5110 Attribute_Name => Name_Write,
5111 Expressions => New_List (
5112 Make_Selected_Component (Loc,
5113 Prefix => Request_Parameter,
5114 Selector_Name => Name_Result),
5115 New_Occurrence_Of (Excep_Choice, Loc))));
5117 if Dynamically_Asynchronous then
5118 Excep_Code := New_List (
5119 Make_Implicit_If_Statement (Vis_Decl,
5120 Condition => Make_Op_Not (Loc,
5121 New_Occurrence_Of (Dynamic_Async, Loc)),
5122 Then_Statements => Excep_Code));
5125 Excep_Handlers := New_List (
5126 Make_Implicit_Exception_Handler (Loc,
5127 Choice_Parameter => Excep_Choice,
5128 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5129 Statements => Excep_Code));
5134 Make_Procedure_Specification (Loc,
5135 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
5137 Parameter_Specifications => New_List (
5138 Make_Parameter_Specification (Loc,
5139 Defining_Identifier => Request_Parameter,
5141 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5144 Make_Subprogram_Body (Loc,
5145 Specification => Subp_Spec,
5146 Declarations => Decls,
5147 Handled_Statement_Sequence =>
5148 Make_Handled_Sequence_Of_Statements (Loc,
5149 Statements => Statements,
5150 Exception_Handlers => Excep_Handlers));
5151 end Build_Subprogram_Receiving_Stubs;
5157 function Result return Node_Id is
5159 return Make_Identifier (Loc, Name_V);
5162 ----------------------
5163 -- Stream_Parameter --
5164 ----------------------
5166 function Stream_Parameter return Node_Id is
5168 return Make_Identifier (Loc, Name_S);
5169 end Stream_Parameter;
5173 -------------------------------
5174 -- Get_And_Reset_RACW_Bodies --
5175 -------------------------------
5177 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5178 Desig : constant Entity_Id :=
5179 Etype (Designated_Type (RACW_Type));
5181 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5183 Body_Decls : List_Id;
5184 -- Returned list of declarations
5187 if Stub_Elements = Empty_Stub_Structure then
5189 -- Stub elements may be missing as a consequence of a previously
5195 Body_Decls := Stub_Elements.Body_Decls;
5196 Stub_Elements.Body_Decls := No_List;
5197 Stubs_Table.Set (Desig, Stub_Elements);
5199 end Get_And_Reset_RACW_Bodies;
5201 -----------------------
5202 -- Get_Stub_Elements --
5203 -----------------------
5205 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is
5206 Desig : constant Entity_Id :=
5207 Etype (Designated_Type (RACW_Type));
5208 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
5210 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5211 return Stub_Elements;
5212 end Get_Stub_Elements;
5214 -----------------------
5215 -- Get_Subprogram_Id --
5216 -----------------------
5218 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5219 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5221 pragma Assert (Result /= No_String);
5223 end Get_Subprogram_Id;
5225 -----------------------
5226 -- Get_Subprogram_Id --
5227 -----------------------
5229 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5231 return Get_Subprogram_Ids (Def).Int_Identifier;
5232 end Get_Subprogram_Id;
5234 ------------------------
5235 -- Get_Subprogram_Ids --
5236 ------------------------
5238 function Get_Subprogram_Ids
5239 (Def : Entity_Id) return Subprogram_Identifiers
5242 return Subprogram_Identifier_Table.Get (Def);
5243 end Get_Subprogram_Ids;
5249 function Hash (F : Entity_Id) return Hash_Index is
5251 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5254 function Hash (F : Name_Id) return Hash_Index is
5256 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5259 --------------------------
5260 -- Input_With_Tag_Check --
5261 --------------------------
5263 function Input_With_Tag_Check
5265 Var_Type : Entity_Id;
5266 Stream : Node_Id) return Node_Id
5270 Make_Subprogram_Body (Loc,
5272 Make_Function_Specification (Loc,
5273 Defining_Unit_Name => Make_Temporary (Loc, 'S'),
5274 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5275 Declarations => No_List,
5276 Handled_Statement_Sequence =>
5277 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5278 Make_Tag_Check (Loc,
5279 Make_Simple_Return_Statement (Loc,
5280 Make_Attribute_Reference (Loc,
5281 Prefix => New_Occurrence_Of (Var_Type, Loc),
5282 Attribute_Name => Name_Input,
5284 New_List (Stream)))))));
5285 end Input_With_Tag_Check;
5287 --------------------------------
5288 -- Is_RACW_Controlling_Formal --
5289 --------------------------------
5291 function Is_RACW_Controlling_Formal
5292 (Parameter : Node_Id;
5293 Stub_Type : Entity_Id) return Boolean
5298 -- If the kind of the parameter is E_Void, then it is not a controlling
5299 -- formal (this can happen in the context of RAS).
5301 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5305 -- If the parameter is not a controlling formal, then it cannot be
5306 -- possibly a RACW_Controlling_Formal.
5308 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5312 Typ := Parameter_Type (Parameter);
5313 return (Nkind (Typ) = N_Access_Definition
5314 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5315 or else Etype (Typ) = Stub_Type;
5316 end Is_RACW_Controlling_Formal;
5318 ------------------------------
5319 -- Make_Transportable_Check --
5320 ------------------------------
5322 function Make_Transportable_Check
5324 Expr : Node_Id) return Node_Id is
5327 Make_Raise_Program_Error (Loc,
5330 Build_Get_Transportable (Loc,
5331 Make_Selected_Component (Loc,
5333 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5334 Reason => PE_Non_Transportable_Actual);
5335 end Make_Transportable_Check;
5337 -----------------------------
5338 -- Make_Selected_Component --
5339 -----------------------------
5341 function Make_Selected_Component
5344 Selector_Name : Name_Id) return Node_Id
5347 return Make_Selected_Component (Loc,
5348 Prefix => New_Occurrence_Of (Prefix, Loc),
5349 Selector_Name => Make_Identifier (Loc, Selector_Name));
5350 end Make_Selected_Component;
5352 --------------------
5353 -- Make_Tag_Check --
5354 --------------------
5356 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5357 Occ : constant Entity_Id := Make_Temporary (Loc, 'E');
5360 return Make_Block_Statement (Loc,
5361 Handled_Statement_Sequence =>
5362 Make_Handled_Sequence_Of_Statements (Loc,
5363 Statements => New_List (N),
5365 Exception_Handlers => New_List (
5366 Make_Implicit_Exception_Handler (Loc,
5367 Choice_Parameter => Occ,
5369 Exception_Choices =>
5370 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5373 New_List (Make_Procedure_Call_Statement (Loc,
5375 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5376 New_List (New_Occurrence_Of (Occ, Loc))))))));
5379 ----------------------------
5380 -- Need_Extra_Constrained --
5381 ----------------------------
5383 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5384 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5386 return Out_Present (Parameter)
5387 and then Has_Discriminants (Etyp)
5388 and then not Is_Constrained (Etyp)
5389 and then not Is_Indefinite_Subtype (Etyp);
5390 end Need_Extra_Constrained;
5392 ------------------------------------
5393 -- Pack_Entity_Into_Stream_Access --
5394 ------------------------------------
5396 function Pack_Entity_Into_Stream_Access
5400 Etyp : Entity_Id := Empty) return Node_Id
5405 if Present (Etyp) then
5408 Typ := Etype (Object);
5412 Pack_Node_Into_Stream_Access (Loc,
5414 Object => New_Occurrence_Of (Object, Loc),
5416 end Pack_Entity_Into_Stream_Access;
5418 ---------------------------
5419 -- Pack_Node_Into_Stream --
5420 ---------------------------
5422 function Pack_Node_Into_Stream
5426 Etyp : Entity_Id) return Node_Id
5428 Write_Attribute : Name_Id := Name_Write;
5431 if not Is_Constrained (Etyp) then
5432 Write_Attribute := Name_Output;
5436 Make_Attribute_Reference (Loc,
5437 Prefix => New_Occurrence_Of (Etyp, Loc),
5438 Attribute_Name => Write_Attribute,
5439 Expressions => New_List (
5440 Make_Attribute_Reference (Loc,
5441 Prefix => New_Occurrence_Of (Stream, Loc),
5442 Attribute_Name => Name_Access),
5444 end Pack_Node_Into_Stream;
5446 ----------------------------------
5447 -- Pack_Node_Into_Stream_Access --
5448 ----------------------------------
5450 function Pack_Node_Into_Stream_Access
5454 Etyp : Entity_Id) return Node_Id
5456 Write_Attribute : Name_Id := Name_Write;
5459 if not Is_Constrained (Etyp) then
5460 Write_Attribute := Name_Output;
5464 Make_Attribute_Reference (Loc,
5465 Prefix => New_Occurrence_Of (Etyp, Loc),
5466 Attribute_Name => Write_Attribute,
5467 Expressions => New_List (
5470 end Pack_Node_Into_Stream_Access;
5472 ---------------------
5473 -- PolyORB_Support --
5474 ---------------------
5476 package body PolyORB_Support is
5478 -- Local subprograms
5480 procedure Add_RACW_Read_Attribute
5481 (RACW_Type : Entity_Id;
5482 Stub_Type : Entity_Id;
5483 Stub_Type_Access : Entity_Id;
5484 Body_Decls : List_Id);
5485 -- Add Read attribute for the RACW type. The declaration and attribute
5486 -- definition clauses are inserted right after the declaration of
5487 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5488 -- appended to it (case where the RACW declaration is in the main unit).
5490 procedure Add_RACW_Write_Attribute
5491 (RACW_Type : Entity_Id;
5492 Stub_Type : Entity_Id;
5493 Stub_Type_Access : Entity_Id;
5494 Body_Decls : List_Id);
5495 -- Same as above for the Write attribute
5497 procedure Add_RACW_From_Any
5498 (RACW_Type : Entity_Id;
5499 Body_Decls : List_Id);
5500 -- Add the From_Any TSS for this RACW type
5502 procedure Add_RACW_To_Any
5503 (RACW_Type : Entity_Id;
5504 Body_Decls : List_Id);
5505 -- Add the To_Any TSS for this RACW type
5507 procedure Add_RACW_TypeCode
5508 (Designated_Type : Entity_Id;
5509 RACW_Type : Entity_Id;
5510 Body_Decls : List_Id);
5511 -- Add the TypeCode TSS for this RACW type
5513 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5514 -- Add the From_Any TSS for this RAS type
5516 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5517 -- Add the To_Any TSS for this RAS type
5519 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5520 -- Add the TypeCode TSS for this RAS type
5522 procedure Add_RAS_Access_TSS (N : Node_Id);
5523 -- Add a subprogram body for RAS Access TSS
5525 -------------------------------------
5526 -- Add_Obj_RPC_Receiver_Completion --
5527 -------------------------------------
5529 procedure Add_Obj_RPC_Receiver_Completion
5532 RPC_Receiver : Entity_Id;
5533 Stub_Elements : Stub_Structure)
5535 Desig : constant Entity_Id :=
5536 Etype (Designated_Type (Stub_Elements.RACW_Type));
5539 Make_Procedure_Call_Statement (Loc,
5542 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5544 Parameter_Associations => New_List (
5548 Make_String_Literal (Loc,
5549 Fully_Qualified_Name_String (Desig)),
5553 Make_Attribute_Reference (Loc,
5556 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5562 Make_Attribute_Reference (Loc,
5565 Defining_Identifier (
5566 Stub_Elements.RPC_Receiver_Decl), Loc),
5569 end Add_Obj_RPC_Receiver_Completion;
5571 -----------------------
5572 -- Add_RACW_Features --
5573 -----------------------
5575 procedure Add_RACW_Features
5576 (RACW_Type : Entity_Id;
5578 Stub_Type : Entity_Id;
5579 Stub_Type_Access : Entity_Id;
5580 RPC_Receiver_Decl : Node_Id;
5581 Body_Decls : List_Id)
5583 pragma Unreferenced (RPC_Receiver_Decl);
5587 (RACW_Type => RACW_Type,
5588 Body_Decls => Body_Decls);
5591 (RACW_Type => RACW_Type,
5592 Body_Decls => Body_Decls);
5594 Add_RACW_Write_Attribute
5595 (RACW_Type => RACW_Type,
5596 Stub_Type => Stub_Type,
5597 Stub_Type_Access => Stub_Type_Access,
5598 Body_Decls => Body_Decls);
5600 Add_RACW_Read_Attribute
5601 (RACW_Type => RACW_Type,
5602 Stub_Type => Stub_Type,
5603 Stub_Type_Access => Stub_Type_Access,
5604 Body_Decls => Body_Decls);
5607 (Designated_Type => Desig,
5608 RACW_Type => RACW_Type,
5609 Body_Decls => Body_Decls);
5610 end Add_RACW_Features;
5612 -----------------------
5613 -- Add_RACW_From_Any --
5614 -----------------------
5616 procedure Add_RACW_From_Any
5617 (RACW_Type : Entity_Id;
5618 Body_Decls : List_Id)
5620 Loc : constant Source_Ptr := Sloc (RACW_Type);
5621 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5622 Fnam : constant Entity_Id :=
5623 Make_Defining_Identifier (Loc,
5624 Chars => New_External_Name (Chars (RACW_Type), 'F'));
5626 Func_Spec : Node_Id;
5627 Func_Decl : Node_Id;
5628 Func_Body : Node_Id;
5630 Statements : List_Id;
5631 -- Various parts of the subprogram
5633 Any_Parameter : constant Entity_Id :=
5634 Make_Defining_Identifier (Loc, Name_A);
5636 Asynchronous_Flag : constant Entity_Id :=
5637 Asynchronous_Flags_Table.Get (RACW_Type);
5638 -- The flag object declared in Add_RACW_Asynchronous_Flag
5642 Make_Function_Specification (Loc,
5643 Defining_Unit_Name =>
5645 Parameter_Specifications => New_List (
5646 Make_Parameter_Specification (Loc,
5647 Defining_Identifier =>
5650 New_Occurrence_Of (RTE (RE_Any), Loc))),
5651 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5653 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5654 -- entity in the declaration spec, not those of the body spec.
5656 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5657 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5658 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5660 if No (Body_Decls) then
5664 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5665 -- set on the stub type if, and only if, the RACW type has a pragma
5666 -- Asynchronous. This is incorrect for RACWs that implement RAS
5667 -- types, because in that case the /designated subprogram/ (not the
5668 -- type) might be asynchronous, and that causes the stub to need to
5669 -- be asynchronous too. A solution is to transport a RAS as a struct
5670 -- containing a RACW and an asynchronous flag, and to properly alter
5671 -- the Asynchronous component in the stub type in the RAS's _From_Any
5674 Statements := New_List (
5675 Make_Simple_Return_Statement (Loc,
5676 Expression => Unchecked_Convert_To (RACW_Type,
5677 Make_Function_Call (Loc,
5678 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5679 Parameter_Associations => New_List (
5680 Make_Function_Call (Loc,
5681 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5682 Parameter_Associations => New_List (
5683 New_Occurrence_Of (Any_Parameter, Loc))),
5684 Build_Stub_Tag (Loc, RACW_Type),
5685 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5686 New_Occurrence_Of (Asynchronous_Flag, Loc))))));
5689 Make_Subprogram_Body (Loc,
5690 Specification => Copy_Specification (Loc, Func_Spec),
5691 Declarations => No_List,
5692 Handled_Statement_Sequence =>
5693 Make_Handled_Sequence_Of_Statements (Loc,
5694 Statements => Statements));
5696 Append_To (Body_Decls, Func_Body);
5697 end Add_RACW_From_Any;
5699 -----------------------------
5700 -- Add_RACW_Read_Attribute --
5701 -----------------------------
5703 procedure Add_RACW_Read_Attribute
5704 (RACW_Type : Entity_Id;
5705 Stub_Type : Entity_Id;
5706 Stub_Type_Access : Entity_Id;
5707 Body_Decls : List_Id)
5709 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5711 Loc : constant Source_Ptr := Sloc (RACW_Type);
5713 Proc_Decl : Node_Id;
5714 Attr_Decl : Node_Id;
5716 Body_Node : Node_Id;
5718 Decls : constant List_Id := New_List;
5719 Statements : constant List_Id := New_List;
5720 Reference : constant Entity_Id :=
5721 Make_Defining_Identifier (Loc, Name_R);
5722 -- Various parts of the procedure
5724 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
5726 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5728 Asynchronous_Flag : constant Entity_Id :=
5729 Asynchronous_Flags_Table.Get (RACW_Type);
5730 pragma Assert (Present (Asynchronous_Flag));
5732 function Stream_Parameter return Node_Id;
5733 function Result return Node_Id;
5735 -- Functions to create occurrences of the formal parameter names
5741 function Result return Node_Id is
5743 return Make_Identifier (Loc, Name_V);
5746 ----------------------
5747 -- Stream_Parameter --
5748 ----------------------
5750 function Stream_Parameter return Node_Id is
5752 return Make_Identifier (Loc, Name_S);
5753 end Stream_Parameter;
5755 -- Start of processing for Add_RACW_Read_Attribute
5758 Build_Stream_Procedure
5759 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
5761 Proc_Decl := Make_Subprogram_Declaration (Loc,
5762 Copy_Specification (Loc, Specification (Body_Node)));
5765 Make_Attribute_Definition_Clause (Loc,
5766 Name => New_Occurrence_Of (RACW_Type, Loc),
5770 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5772 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5773 Insert_After (Proc_Decl, Attr_Decl);
5775 if No (Body_Decls) then
5780 Make_Object_Declaration (Loc,
5781 Defining_Identifier =>
5783 Object_Definition =>
5784 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5786 Append_List_To (Statements, New_List (
5787 Make_Attribute_Reference (Loc,
5789 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5790 Attribute_Name => Name_Read,
5791 Expressions => New_List (
5793 New_Occurrence_Of (Reference, Loc))),
5795 Make_Assignment_Statement (Loc,
5799 Unchecked_Convert_To (RACW_Type,
5800 Make_Function_Call (Loc,
5802 New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5803 Parameter_Associations => New_List (
5804 New_Occurrence_Of (Reference, Loc),
5805 Build_Stub_Tag (Loc, RACW_Type),
5806 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5807 New_Occurrence_Of (Asynchronous_Flag, Loc)))))));
5809 Set_Declarations (Body_Node, Decls);
5810 Append_To (Body_Decls, Body_Node);
5811 end Add_RACW_Read_Attribute;
5813 ---------------------
5814 -- Add_RACW_To_Any --
5815 ---------------------
5817 procedure Add_RACW_To_Any
5818 (RACW_Type : Entity_Id;
5819 Body_Decls : List_Id)
5821 Loc : constant Source_Ptr := Sloc (RACW_Type);
5823 Fnam : constant Entity_Id :=
5824 Make_Defining_Identifier (Loc,
5825 Chars => New_External_Name (Chars (RACW_Type), 'T'));
5827 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5829 Stub_Elements : constant Stub_Structure :=
5830 Get_Stub_Elements (RACW_Type);
5832 Func_Spec : Node_Id;
5833 Func_Decl : Node_Id;
5834 Func_Body : Node_Id;
5837 Statements : List_Id;
5838 -- Various parts of the subprogram
5840 RACW_Parameter : constant Entity_Id :=
5841 Make_Defining_Identifier (Loc, Name_R);
5843 Reference : constant Entity_Id := Make_Temporary (Loc, 'R');
5844 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
5848 Make_Function_Specification (Loc,
5849 Defining_Unit_Name =>
5851 Parameter_Specifications => New_List (
5852 Make_Parameter_Specification (Loc,
5853 Defining_Identifier =>
5856 New_Occurrence_Of (RACW_Type, Loc))),
5857 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5859 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5860 -- entity in the declaration spec, not in the body spec.
5862 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5864 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5865 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5867 if No (Body_Decls) then
5873 -- R : constant Object_Ref :=
5879 -- RPC_Receiver'Access);
5883 Make_Object_Declaration (Loc,
5884 Defining_Identifier => Reference,
5885 Constant_Present => True,
5886 Object_Definition =>
5887 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5889 Make_Function_Call (Loc,
5890 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5891 Parameter_Associations => New_List (
5892 Unchecked_Convert_To (RTE (RE_Address),
5893 New_Occurrence_Of (RACW_Parameter, Loc)),
5894 Make_String_Literal (Loc,
5895 Strval => Fully_Qualified_Name_String
5896 (Etype (Designated_Type (RACW_Type)))),
5897 Build_Stub_Tag (Loc, RACW_Type),
5898 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5899 Make_Attribute_Reference (Loc,
5902 (Defining_Identifier
5903 (Stub_Elements.RPC_Receiver_Decl), Loc),
5904 Attribute_Name => Name_Access)))),
5906 Make_Object_Declaration (Loc,
5907 Defining_Identifier => Any,
5908 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)));
5912 -- Any := TA_ObjRef (Reference);
5913 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5916 Statements := New_List (
5917 Make_Assignment_Statement (Loc,
5918 Name => New_Occurrence_Of (Any, Loc),
5920 Make_Function_Call (Loc,
5921 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5922 Parameter_Associations => New_List (
5923 New_Occurrence_Of (Reference, Loc)))),
5925 Make_Procedure_Call_Statement (Loc,
5926 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5927 Parameter_Associations => New_List (
5928 New_Occurrence_Of (Any, Loc),
5929 Make_Selected_Component (Loc,
5931 Defining_Identifier (
5932 Stub_Elements.RPC_Receiver_Decl),
5933 Selector_Name => Name_Obj_TypeCode))),
5935 Make_Simple_Return_Statement (Loc,
5936 Expression => New_Occurrence_Of (Any, Loc)));
5939 Make_Subprogram_Body (Loc,
5940 Specification => Copy_Specification (Loc, Func_Spec),
5941 Declarations => Decls,
5942 Handled_Statement_Sequence =>
5943 Make_Handled_Sequence_Of_Statements (Loc,
5944 Statements => Statements));
5945 Append_To (Body_Decls, Func_Body);
5946 end Add_RACW_To_Any;
5948 -----------------------
5949 -- Add_RACW_TypeCode --
5950 -----------------------
5952 procedure Add_RACW_TypeCode
5953 (Designated_Type : Entity_Id;
5954 RACW_Type : Entity_Id;
5955 Body_Decls : List_Id)
5957 Loc : constant Source_Ptr := Sloc (RACW_Type);
5959 Fnam : constant Entity_Id :=
5960 Make_Defining_Identifier (Loc,
5961 Chars => New_External_Name (Chars (RACW_Type), 'Y'));
5963 Stub_Elements : constant Stub_Structure :=
5964 Stubs_Table.Get (Designated_Type);
5965 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5967 Func_Spec : Node_Id;
5968 Func_Decl : Node_Id;
5969 Func_Body : Node_Id;
5972 -- The spec for this subprogram has a dummy 'access RACW' argument,
5973 -- which serves only for overloading purposes.
5976 Make_Function_Specification (Loc,
5977 Defining_Unit_Name => Fnam,
5978 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
5980 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5981 -- entity in the declaration spec, not those of the body spec.
5983 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5984 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5985 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
5987 if No (Body_Decls) then
5992 Make_Subprogram_Body (Loc,
5993 Specification => Copy_Specification (Loc, Func_Spec),
5994 Declarations => Empty_List,
5995 Handled_Statement_Sequence =>
5996 Make_Handled_Sequence_Of_Statements (Loc,
5997 Statements => New_List (
5998 Make_Simple_Return_Statement (Loc,
6000 Make_Selected_Component (Loc,
6003 (Stub_Elements.RPC_Receiver_Decl),
6004 Selector_Name => Name_Obj_TypeCode)))));
6006 Append_To (Body_Decls, Func_Body);
6007 end Add_RACW_TypeCode;
6009 ------------------------------
6010 -- Add_RACW_Write_Attribute --
6011 ------------------------------
6013 procedure Add_RACW_Write_Attribute
6014 (RACW_Type : Entity_Id;
6015 Stub_Type : Entity_Id;
6016 Stub_Type_Access : Entity_Id;
6017 Body_Decls : List_Id)
6019 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6021 Loc : constant Source_Ptr := Sloc (RACW_Type);
6023 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
6025 Stub_Elements : constant Stub_Structure :=
6026 Get_Stub_Elements (RACW_Type);
6028 Body_Node : Node_Id;
6029 Proc_Decl : Node_Id;
6030 Attr_Decl : Node_Id;
6032 Statements : constant List_Id := New_List;
6033 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
6035 function Stream_Parameter return Node_Id;
6036 function Object return Node_Id;
6037 -- Functions to create occurrences of the formal parameter names
6043 function Object return Node_Id is
6045 return Make_Identifier (Loc, Name_V);
6048 ----------------------
6049 -- Stream_Parameter --
6050 ----------------------
6052 function Stream_Parameter return Node_Id is
6054 return Make_Identifier (Loc, Name_S);
6055 end Stream_Parameter;
6057 -- Start of processing for Add_RACW_Write_Attribute
6060 Build_Stream_Procedure
6061 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
6064 Make_Subprogram_Declaration (Loc,
6065 Copy_Specification (Loc, Specification (Body_Node)));
6068 Make_Attribute_Definition_Clause (Loc,
6069 Name => New_Occurrence_Of (RACW_Type, Loc),
6070 Chars => Name_Write,
6073 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6075 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6076 Insert_After (Proc_Decl, Attr_Decl);
6078 if No (Body_Decls) then
6082 Append_To (Statements,
6083 Pack_Node_Into_Stream_Access (Loc,
6084 Stream => Stream_Parameter,
6086 Make_Function_Call (Loc,
6087 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6088 Parameter_Associations => New_List (
6089 Unchecked_Convert_To (RTE (RE_Address), Object),
6090 Make_String_Literal (Loc,
6091 Strval => Fully_Qualified_Name_String
6092 (Etype (Designated_Type (RACW_Type)))),
6093 Build_Stub_Tag (Loc, RACW_Type),
6094 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
6095 Make_Attribute_Reference (Loc,
6098 (Defining_Identifier
6099 (Stub_Elements.RPC_Receiver_Decl), Loc),
6100 Attribute_Name => Name_Access))),
6102 Etyp => RTE (RE_Object_Ref)));
6104 Append_To (Body_Decls, Body_Node);
6105 end Add_RACW_Write_Attribute;
6107 -----------------------
6108 -- Add_RAST_Features --
6109 -----------------------
6111 procedure Add_RAST_Features
6112 (Vis_Decl : Node_Id;
6113 RAS_Type : Entity_Id)
6116 Add_RAS_Access_TSS (Vis_Decl);
6118 Add_RAS_From_Any (RAS_Type);
6119 Add_RAS_TypeCode (RAS_Type);
6121 -- To_Any uses TypeCode, and therefore needs to be generated last
6123 Add_RAS_To_Any (RAS_Type);
6124 end Add_RAST_Features;
6126 ------------------------
6127 -- Add_RAS_Access_TSS --
6128 ------------------------
6130 procedure Add_RAS_Access_TSS (N : Node_Id) is
6131 Loc : constant Source_Ptr := Sloc (N);
6133 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6134 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6135 -- Ras_Type is the access to subprogram type; Fat_Type is the
6136 -- corresponding record type.
6138 RACW_Type : constant Entity_Id :=
6139 Underlying_RACW_Type (Ras_Type);
6141 Stub_Elements : constant Stub_Structure :=
6142 Get_Stub_Elements (RACW_Type);
6144 Proc : constant Entity_Id :=
6145 Make_Defining_Identifier (Loc,
6146 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6148 Proc_Spec : Node_Id;
6150 -- Formal parameters
6152 Package_Name : constant Entity_Id :=
6153 Make_Defining_Identifier (Loc,
6158 Subp_Id : constant Entity_Id :=
6159 Make_Defining_Identifier (Loc,
6162 -- Target subprogram
6164 Asynch_P : constant Entity_Id :=
6165 Make_Defining_Identifier (Loc,
6166 Chars => Name_Asynchronous);
6167 -- Is the procedure to which the 'Access applies asynchronous?
6169 All_Calls_Remote : constant Entity_Id :=
6170 Make_Defining_Identifier (Loc,
6171 Chars => Name_All_Calls_Remote);
6172 -- True if an All_Calls_Remote pragma applies to the RCI unit
6173 -- that contains the subprogram.
6175 -- Common local variables
6177 Proc_Decls : List_Id;
6178 Proc_Statements : List_Id;
6180 Subp_Ref : constant Entity_Id :=
6181 Make_Defining_Identifier (Loc, Name_R);
6182 -- Reference that designates the target subprogram (returned
6183 -- by Get_RAS_Info).
6185 Is_Local : constant Entity_Id :=
6186 Make_Defining_Identifier (Loc, Name_L);
6187 Local_Addr : constant Entity_Id :=
6188 Make_Defining_Identifier (Loc, Name_A);
6189 -- For the call to Get_Local_Address
6191 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
6192 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
6193 -- Additional local variables for the remote case
6196 (Field_Name : Name_Id;
6197 Value : Node_Id) return Node_Id;
6198 -- Construct an assignment that sets the named component in the
6206 (Field_Name : Name_Id;
6207 Value : Node_Id) return Node_Id
6211 Make_Assignment_Statement (Loc,
6213 Make_Selected_Component (Loc,
6215 Selector_Name => Field_Name),
6216 Expression => Value);
6219 -- Start of processing for Add_RAS_Access_TSS
6222 Proc_Decls := New_List (
6224 -- Common declarations
6226 Make_Object_Declaration (Loc,
6227 Defining_Identifier => Subp_Ref,
6228 Object_Definition =>
6229 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6231 Make_Object_Declaration (Loc,
6232 Defining_Identifier => Is_Local,
6233 Object_Definition =>
6234 New_Occurrence_Of (Standard_Boolean, Loc)),
6236 Make_Object_Declaration (Loc,
6237 Defining_Identifier => Local_Addr,
6238 Object_Definition =>
6239 New_Occurrence_Of (RTE (RE_Address), Loc)),
6241 Make_Object_Declaration (Loc,
6242 Defining_Identifier => Local_Stub,
6243 Aliased_Present => True,
6244 Object_Definition =>
6245 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6247 Make_Object_Declaration (Loc,
6248 Defining_Identifier => Stub_Ptr,
6249 Object_Definition =>
6250 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6252 Make_Attribute_Reference (Loc,
6253 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6254 Attribute_Name => Name_Unchecked_Access)));
6256 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6257 -- Build_Get_Unique_RP_Call needs this information
6259 -- Get_RAS_Info (Pkg, Subp, R);
6260 -- Obtain a reference to the target subprogram
6262 Proc_Statements := New_List (
6263 Make_Procedure_Call_Statement (Loc,
6264 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6265 Parameter_Associations => New_List (
6266 New_Occurrence_Of (Package_Name, Loc),
6267 New_Occurrence_Of (Subp_Id, Loc),
6268 New_Occurrence_Of (Subp_Ref, Loc))),
6270 -- Get_Local_Address (R, L, A);
6271 -- Determine whether the subprogram is local (L), and if so
6272 -- obtain the local address of its proxy (A).
6274 Make_Procedure_Call_Statement (Loc,
6275 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6276 Parameter_Associations => New_List (
6277 New_Occurrence_Of (Subp_Ref, Loc),
6278 New_Occurrence_Of (Is_Local, Loc),
6279 New_Occurrence_Of (Local_Addr, Loc))));
6281 -- Note: Here we assume that the Fat_Type is a record containing just
6282 -- an access to a proxy or stub object.
6284 Append_To (Proc_Statements,
6288 Make_Implicit_If_Statement (N,
6289 Condition => New_Occurrence_Of (Is_Local, Loc),
6291 Then_Statements => New_List (
6293 -- if A.Target = null then
6295 Make_Implicit_If_Statement (N,
6298 Make_Selected_Component (Loc,
6300 Unchecked_Convert_To
6301 (RTE (RE_RAS_Proxy_Type_Access),
6302 New_Occurrence_Of (Local_Addr, Loc)),
6303 Selector_Name => Make_Identifier (Loc, Name_Target)),
6306 Then_Statements => New_List (
6308 -- A.Target := Entity_Of (Ref);
6310 Make_Assignment_Statement (Loc,
6312 Make_Selected_Component (Loc,
6314 Unchecked_Convert_To
6315 (RTE (RE_RAS_Proxy_Type_Access),
6316 New_Occurrence_Of (Local_Addr, Loc)),
6317 Selector_Name => Make_Identifier (Loc, Name_Target)),
6319 Make_Function_Call (Loc,
6320 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6321 Parameter_Associations => New_List (
6322 New_Occurrence_Of (Subp_Ref, Loc)))),
6324 -- Inc_Usage (A.Target);
6327 Make_Procedure_Call_Statement (Loc,
6328 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6329 Parameter_Associations => New_List (
6330 Make_Selected_Component (Loc,
6332 Unchecked_Convert_To
6333 (RTE (RE_RAS_Proxy_Type_Access),
6334 New_Occurrence_Of (Local_Addr, Loc)),
6336 Make_Identifier (Loc, Name_Target)))))),
6338 -- if not All_Calls_Remote then
6339 -- return Fat_Type!(A);
6342 Make_Implicit_If_Statement (N,
6346 New_Occurrence_Of (All_Calls_Remote, Loc)),
6348 Then_Statements => New_List (
6349 Make_Simple_Return_Statement (Loc,
6351 Unchecked_Convert_To
6352 (Fat_Type, New_Occurrence_Of (Local_Addr, Loc))))))));
6354 Append_List_To (Proc_Statements, New_List (
6356 -- Stub.Target := Entity_Of (Ref);
6358 Set_Field (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 (Stub.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 Selector_Name => Name_Target))),
6373 -- E.4.1(9) A remote call is asynchronous if it is a call to
6374 -- a procedure, or a call through a value of an access-to-procedure
6375 -- type, to which a pragma Asynchronous applies.
6377 -- Parameter Asynch_P is true when the procedure is asynchronous;
6378 -- Expression Asynch_T is true when the type is asynchronous.
6380 Set_Field (Name_Asynchronous,
6382 Left_Opnd => New_Occurrence_Of (Asynch_P, Loc),
6385 (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc)))));
6387 Append_List_To (Proc_Statements,
6388 Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
6390 Append_To (Proc_Statements,
6391 Make_Simple_Return_Statement (Loc,
6393 Unchecked_Convert_To (Fat_Type,
6394 New_Occurrence_Of (Stub_Ptr, Loc))));
6397 Make_Function_Specification (Loc,
6398 Defining_Unit_Name => Proc,
6399 Parameter_Specifications => New_List (
6400 Make_Parameter_Specification (Loc,
6401 Defining_Identifier => Package_Name,
6403 New_Occurrence_Of (Standard_String, Loc)),
6405 Make_Parameter_Specification (Loc,
6406 Defining_Identifier => Subp_Id,
6408 New_Occurrence_Of (Standard_String, Loc)),
6410 Make_Parameter_Specification (Loc,
6411 Defining_Identifier => Asynch_P,
6413 New_Occurrence_Of (Standard_Boolean, Loc)),
6415 Make_Parameter_Specification (Loc,
6416 Defining_Identifier => All_Calls_Remote,
6418 New_Occurrence_Of (Standard_Boolean, Loc))),
6420 Result_Definition =>
6421 New_Occurrence_Of (Fat_Type, Loc));
6423 -- Set the kind and return type of the function to prevent
6424 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6426 Set_Ekind (Proc, E_Function);
6427 Set_Etype (Proc, Fat_Type);
6430 Make_Subprogram_Body (Loc,
6431 Specification => Proc_Spec,
6432 Declarations => Proc_Decls,
6433 Handled_Statement_Sequence =>
6434 Make_Handled_Sequence_Of_Statements (Loc,
6435 Statements => Proc_Statements)));
6437 Set_TSS (Fat_Type, Proc);
6438 end Add_RAS_Access_TSS;
6440 ----------------------
6441 -- Add_RAS_From_Any --
6442 ----------------------
6444 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6445 Loc : constant Source_Ptr := Sloc (RAS_Type);
6447 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6448 Make_TSS_Name (RAS_Type, TSS_From_Any));
6450 Func_Spec : Node_Id;
6452 Statements : List_Id;
6454 Any_Parameter : constant Entity_Id :=
6455 Make_Defining_Identifier (Loc, Name_A);
6458 Statements := New_List (
6459 Make_Simple_Return_Statement (Loc,
6461 Make_Aggregate (Loc,
6462 Component_Associations => New_List (
6463 Make_Component_Association (Loc,
6464 Choices => New_List (
6465 Make_Identifier (Loc, Name_Ras)),
6467 PolyORB_Support.Helpers.Build_From_Any_Call (
6468 Underlying_RACW_Type (RAS_Type),
6469 New_Occurrence_Of (Any_Parameter, Loc),
6473 Make_Function_Specification (Loc,
6474 Defining_Unit_Name => Fnam,
6475 Parameter_Specifications => New_List (
6476 Make_Parameter_Specification (Loc,
6477 Defining_Identifier => Any_Parameter,
6478 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
6479 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6482 Make_Subprogram_Body (Loc,
6483 Specification => Func_Spec,
6484 Declarations => No_List,
6485 Handled_Statement_Sequence =>
6486 Make_Handled_Sequence_Of_Statements (Loc,
6487 Statements => Statements)));
6488 Set_TSS (RAS_Type, Fnam);
6489 end Add_RAS_From_Any;
6491 --------------------
6492 -- Add_RAS_To_Any --
6493 --------------------
6495 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6496 Loc : constant Source_Ptr := Sloc (RAS_Type);
6498 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6499 Make_TSS_Name (RAS_Type, TSS_To_Any));
6502 Statements : List_Id;
6504 Func_Spec : Node_Id;
6506 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
6507 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
6508 RACW_Parameter : constant Node_Id :=
6509 Make_Selected_Component (Loc,
6510 Prefix => RAS_Parameter,
6511 Selector_Name => Name_Ras);
6514 -- Object declarations
6516 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6518 Make_Object_Declaration (Loc,
6519 Defining_Identifier => Any,
6520 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc),
6522 PolyORB_Support.Helpers.Build_To_Any_Call
6523 (RACW_Parameter, No_List)));
6525 Statements := New_List (
6526 Make_Procedure_Call_Statement (Loc,
6527 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6528 Parameter_Associations => New_List (
6529 New_Occurrence_Of (Any, Loc),
6530 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6533 Make_Simple_Return_Statement (Loc,
6534 Expression => New_Occurrence_Of (Any, Loc)));
6537 Make_Function_Specification (Loc,
6538 Defining_Unit_Name => Fnam,
6539 Parameter_Specifications => New_List (
6540 Make_Parameter_Specification (Loc,
6541 Defining_Identifier => RAS_Parameter,
6542 Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))),
6543 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6546 Make_Subprogram_Body (Loc,
6547 Specification => Func_Spec,
6548 Declarations => Decls,
6549 Handled_Statement_Sequence =>
6550 Make_Handled_Sequence_Of_Statements (Loc,
6551 Statements => Statements)));
6552 Set_TSS (RAS_Type, Fnam);
6555 ----------------------
6556 -- Add_RAS_TypeCode --
6557 ----------------------
6559 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6560 Loc : constant Source_Ptr := Sloc (RAS_Type);
6562 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6563 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6565 Func_Spec : Node_Id;
6566 Decls : constant List_Id := New_List;
6567 Name_String : String_Id;
6568 Repo_Id_String : String_Id;
6572 Make_Function_Specification (Loc,
6573 Defining_Unit_Name => Fnam,
6574 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6576 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6577 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6580 Make_Subprogram_Body (Loc,
6581 Specification => Func_Spec,
6582 Declarations => Decls,
6583 Handled_Statement_Sequence =>
6584 Make_Handled_Sequence_Of_Statements (Loc,
6585 Statements => New_List (
6586 Make_Simple_Return_Statement (Loc,
6588 Make_Function_Call (Loc,
6589 Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6590 Parameter_Associations => New_List (
6591 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6592 Make_Aggregate (Loc,
6595 Make_Function_Call (Loc,
6598 (RTE (RE_TA_Std_String), Loc),
6599 Parameter_Associations => New_List (
6600 Make_String_Literal (Loc, Name_String))),
6601 Make_Function_Call (Loc,
6604 (RTE (RE_TA_Std_String), Loc),
6605 Parameter_Associations => New_List (
6606 Make_String_Literal (Loc,
6607 Strval => Repo_Id_String))))))))))));
6608 Set_TSS (RAS_Type, Fnam);
6609 end Add_RAS_TypeCode;
6611 -----------------------------------------
6612 -- Add_Receiving_Stubs_To_Declarations --
6613 -----------------------------------------
6615 procedure Add_Receiving_Stubs_To_Declarations
6616 (Pkg_Spec : Node_Id;
6620 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6622 Pkg_RPC_Receiver : constant Entity_Id :=
6623 Make_Temporary (Loc, 'H');
6624 Pkg_RPC_Receiver_Object : Node_Id;
6625 Pkg_RPC_Receiver_Body : Node_Id;
6626 Pkg_RPC_Receiver_Decls : List_Id;
6627 Pkg_RPC_Receiver_Statements : List_Id;
6629 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6630 -- A Pkg_RPC_Receiver is built to decode the request
6633 -- Request object received from neutral layer
6635 Subp_Id : Entity_Id;
6636 -- Subprogram identifier as received from the neutral distribution
6639 Subp_Index : Entity_Id;
6640 -- Internal index as determined by matching either the method name
6641 -- from the request structure, or the local subprogram address (in
6644 Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L');
6646 Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A');
6647 -- Address of a local subprogram designated by a reference
6648 -- corresponding to a RAS.
6650 Dispatch_On_Address : constant List_Id := New_List;
6651 Dispatch_On_Name : constant List_Id := New_List;
6653 Current_Declaration : Node_Id;
6654 Current_Stubs : Node_Id;
6655 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6657 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
6659 Subp_Info_List : constant List_Id := New_List;
6661 Register_Pkg_Actuals : constant List_Id := New_List;
6663 All_Calls_Remote_E : Entity_Id;
6665 procedure Append_Stubs_To
6666 (RPC_Receiver_Cases : List_Id;
6667 Declaration : Node_Id;
6670 Subp_Dist_Name : Entity_Id;
6671 Subp_Proxy_Addr : Entity_Id);
6672 -- Add one case to the specified RPC receiver case list associating
6673 -- Subprogram_Number with the subprogram declared by Declaration, for
6674 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6675 -- subprogram index. Subp_Dist_Name is the string used to call the
6676 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6677 -- object, used in the context of calls through remote
6678 -- access-to-subprogram types.
6680 ---------------------
6681 -- Append_Stubs_To --
6682 ---------------------
6684 procedure Append_Stubs_To
6685 (RPC_Receiver_Cases : List_Id;
6686 Declaration : Node_Id;
6689 Subp_Dist_Name : Entity_Id;
6690 Subp_Proxy_Addr : Entity_Id)
6692 Case_Stmts : List_Id;
6694 Case_Stmts := New_List (
6695 Make_Procedure_Call_Statement (Loc,
6698 Defining_Entity (Stubs), Loc),
6699 Parameter_Associations =>
6700 New_List (New_Occurrence_Of (Request, Loc))));
6702 if Nkind (Specification (Declaration)) = N_Function_Specification
6704 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6706 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6709 Append_To (RPC_Receiver_Cases,
6710 Make_Case_Statement_Alternative (Loc,
6712 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6713 Statements => Case_Stmts));
6715 Append_To (Dispatch_On_Name,
6716 Make_Elsif_Part (Loc,
6718 Make_Function_Call (Loc,
6720 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6721 Parameter_Associations => New_List (
6722 New_Occurrence_Of (Subp_Id, Loc),
6723 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6725 Then_Statements => New_List (
6726 Make_Assignment_Statement (Loc,
6727 New_Occurrence_Of (Subp_Index, Loc),
6728 Make_Integer_Literal (Loc, Subp_Number)))));
6730 Append_To (Dispatch_On_Address,
6731 Make_Elsif_Part (Loc,
6734 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6735 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6737 Then_Statements => New_List (
6738 Make_Assignment_Statement (Loc,
6739 New_Occurrence_Of (Subp_Index, Loc),
6740 Make_Integer_Literal (Loc, Subp_Number)))));
6741 end Append_Stubs_To;
6743 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6746 -- Building receiving stubs consist in several operations:
6748 -- - a package RPC receiver must be built. This subprogram will get
6749 -- a Subprogram_Id from the incoming stream and will dispatch the
6750 -- call to the right subprogram;
6752 -- - a receiving stub for each subprogram visible in the package
6753 -- spec. This stub will read all the parameters from the stream,
6754 -- and put the result as well as the exception occurrence in the
6757 Build_RPC_Receiver_Body (
6758 RPC_Receiver => Pkg_RPC_Receiver,
6761 Subp_Index => Subp_Index,
6762 Stmts => Pkg_RPC_Receiver_Statements,
6763 Decl => Pkg_RPC_Receiver_Body);
6764 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6766 -- Extract local address information from the target reference:
6767 -- if non-null, that means that this is a reference that denotes
6768 -- one particular operation, and hence that the operation name
6769 -- must not be taken into account for dispatching.
6771 Append_To (Pkg_RPC_Receiver_Decls,
6772 Make_Object_Declaration (Loc,
6773 Defining_Identifier => Is_Local,
6774 Object_Definition =>
6775 New_Occurrence_Of (Standard_Boolean, Loc)));
6777 Append_To (Pkg_RPC_Receiver_Decls,
6778 Make_Object_Declaration (Loc,
6779 Defining_Identifier => Local_Address,
6780 Object_Definition =>
6781 New_Occurrence_Of (RTE (RE_Address), Loc)));
6783 Append_To (Pkg_RPC_Receiver_Statements,
6784 Make_Procedure_Call_Statement (Loc,
6785 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6786 Parameter_Associations => New_List (
6787 Make_Selected_Component (Loc,
6789 Selector_Name => Name_Target),
6790 New_Occurrence_Of (Is_Local, Loc),
6791 New_Occurrence_Of (Local_Address, Loc))));
6793 -- For each subprogram, the receiving stub will be built and a case
6794 -- statement will be made on the Subprogram_Id to dispatch to the
6795 -- right subprogram.
6797 All_Calls_Remote_E := Boolean_Literals (
6798 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6800 Overload_Counter_Table.Reset;
6801 Reserve_NamingContext_Methods;
6803 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
6804 while Present (Current_Declaration) loop
6805 if Nkind (Current_Declaration) = N_Subprogram_Declaration
6806 and then Comes_From_Source (Current_Declaration)
6809 Loc : constant Source_Ptr := Sloc (Current_Declaration);
6810 -- While specifically processing Current_Declaration, use
6811 -- its Sloc as the location of all generated nodes.
6813 Subp_Def : constant Entity_Id :=
6815 (Specification (Current_Declaration));
6817 Subp_Val : String_Id;
6819 Subp_Dist_Name : constant Entity_Id :=
6820 Make_Defining_Identifier (Loc,
6823 (Related_Id => Chars (Subp_Def),
6825 Suffix_Index => -1));
6827 Proxy_Object_Addr : Entity_Id;
6830 -- Build receiving stub
6833 Build_Subprogram_Receiving_Stubs
6834 (Vis_Decl => Current_Declaration,
6836 Nkind (Specification (Current_Declaration)) =
6837 N_Procedure_Specification
6838 and then Is_Asynchronous (Subp_Def));
6840 Append_To (Decls, Current_Stubs);
6841 Analyze (Current_Stubs);
6845 Add_RAS_Proxy_And_Analyze (Decls,
6846 Vis_Decl => Current_Declaration,
6847 All_Calls_Remote_E => All_Calls_Remote_E,
6848 Proxy_Object_Addr => Proxy_Object_Addr);
6850 -- Compute distribution identifier
6852 Assign_Subprogram_Identifier
6854 Current_Subprogram_Number,
6858 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
6861 Make_Object_Declaration (Loc,
6862 Defining_Identifier => Subp_Dist_Name,
6863 Constant_Present => True,
6864 Object_Definition =>
6865 New_Occurrence_Of (Standard_String, Loc),
6867 Make_String_Literal (Loc, Subp_Val)));
6868 Analyze (Last (Decls));
6870 -- Add subprogram descriptor (RCI_Subp_Info) to the
6871 -- subprograms table for this receiver. The aggregate
6872 -- below must be kept consistent with the declaration
6873 -- of type RCI_Subp_Info in System.Partition_Interface.
6875 Append_To (Subp_Info_List,
6876 Make_Component_Association (Loc,
6877 Choices => New_List (
6878 Make_Integer_Literal (Loc, Current_Subprogram_Number)),
6881 Make_Aggregate (Loc,
6882 Expressions => New_List (
6883 Make_Attribute_Reference (Loc,
6885 New_Occurrence_Of (Subp_Dist_Name, Loc),
6886 Attribute_Name => Name_Address),
6888 Make_Attribute_Reference (Loc,
6890 New_Occurrence_Of (Subp_Dist_Name, Loc),
6891 Attribute_Name => Name_Length),
6893 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
6895 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6896 Declaration => Current_Declaration,
6897 Stubs => Current_Stubs,
6898 Subp_Number => Current_Subprogram_Number,
6899 Subp_Dist_Name => Subp_Dist_Name,
6900 Subp_Proxy_Addr => Proxy_Object_Addr);
6903 Current_Subprogram_Number := Current_Subprogram_Number + 1;
6906 Next (Current_Declaration);
6910 Make_Object_Declaration (Loc,
6911 Defining_Identifier => Subp_Info_Array,
6912 Constant_Present => True,
6913 Aliased_Present => True,
6914 Object_Definition =>
6915 Make_Subtype_Indication (Loc,
6917 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6919 Make_Index_Or_Discriminant_Constraint (Loc,
6923 Make_Integer_Literal (Loc,
6924 Intval => First_RCI_Subprogram_Id),
6926 Make_Integer_Literal (Loc,
6928 First_RCI_Subprogram_Id
6929 + List_Length (Subp_Info_List) - 1)))))));
6931 if Present (First (Subp_Info_List)) then
6932 Set_Expression (Last (Decls),
6933 Make_Aggregate (Loc,
6934 Component_Associations => Subp_Info_List));
6936 -- Generate the dispatch statement to determine the subprogram id
6937 -- of the called subprogram.
6939 -- We first test whether the reference that was used to make the
6940 -- call was the base RCI reference (in which case Local_Address is
6941 -- zero, and the method identifier from the request must be used
6942 -- to determine which subprogram is called) or a reference
6943 -- identifying one particular subprogram (in which case
6944 -- Local_Address is the address of that subprogram, and the
6945 -- method name from the request is ignored). The latter occurs
6946 -- for the case of a call through a remote access-to-subprogram.
6948 -- In each case, cascaded elsifs are used to determine the proper
6949 -- subprogram index. Using hash tables might be more efficient.
6951 Append_To (Pkg_RPC_Receiver_Statements,
6952 Make_Implicit_If_Statement (Pkg_Spec,
6955 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6956 Right_Opnd => New_Occurrence_Of
6957 (RTE (RE_Null_Address), Loc)),
6959 Then_Statements => New_List (
6960 Make_Implicit_If_Statement (Pkg_Spec,
6961 Condition => New_Occurrence_Of (Standard_False, Loc),
6962 Then_Statements => New_List (
6963 Make_Null_Statement (Loc)),
6964 Elsif_Parts => Dispatch_On_Address)),
6966 Else_Statements => New_List (
6967 Make_Implicit_If_Statement (Pkg_Spec,
6968 Condition => New_Occurrence_Of (Standard_False, Loc),
6969 Then_Statements => New_List (Make_Null_Statement (Loc)),
6970 Elsif_Parts => Dispatch_On_Name))));
6973 -- For a degenerate RCI with no visible subprograms,
6974 -- Subp_Info_List has zero length, and the declaration is for an
6975 -- empty array, in which case no initialization aggregate must be
6976 -- generated. We do not generate a Dispatch_Statement either.
6978 -- No initialization provided: remove CONSTANT so that the
6979 -- declaration is not an incomplete deferred constant.
6981 Set_Constant_Present (Last (Decls), False);
6984 -- Analyze Subp_Info_Array declaration
6986 Analyze (Last (Decls));
6988 -- If we receive an invalid Subprogram_Id, it is best to do nothing
6989 -- rather than raising an exception since we do not want someone
6990 -- to crash a remote partition by sending invalid subprogram ids.
6991 -- This is consistent with the other parts of the case statement
6992 -- since even in presence of incorrect parameters in the stream,
6993 -- every exception will be caught and (if the subprogram is not an
6994 -- APC) put into the result stream and sent away.
6996 Append_To (Pkg_RPC_Receiver_Cases,
6997 Make_Case_Statement_Alternative (Loc,
6998 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
6999 Statements => New_List (Make_Null_Statement (Loc))));
7001 Append_To (Pkg_RPC_Receiver_Statements,
7002 Make_Case_Statement (Loc,
7003 Expression => New_Occurrence_Of (Subp_Index, Loc),
7004 Alternatives => Pkg_RPC_Receiver_Cases));
7006 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7009 Append_To (Decls, Pkg_RPC_Receiver_Body);
7010 Analyze (Last (Decls));
7012 Pkg_RPC_Receiver_Object :=
7013 Make_Object_Declaration (Loc,
7014 Defining_Identifier => Make_Temporary (Loc, 'R'),
7015 Aliased_Present => True,
7016 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
7017 Append_To (Decls, Pkg_RPC_Receiver_Object);
7018 Analyze (Last (Decls));
7020 Get_Library_Unit_Name_String (Pkg_Spec);
7024 Append_To (Register_Pkg_Actuals,
7025 Make_String_Literal (Loc,
7026 Strval => String_From_Name_Buffer));
7030 Append_To (Register_Pkg_Actuals,
7031 Make_Attribute_Reference (Loc,
7034 (Defining_Entity (Pkg_Spec), Loc),
7035 Attribute_Name => Name_Version));
7039 Append_To (Register_Pkg_Actuals,
7040 Make_Attribute_Reference (Loc,
7042 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7043 Attribute_Name => Name_Access));
7047 Append_To (Register_Pkg_Actuals,
7048 Make_Attribute_Reference (Loc,
7051 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc),
7052 Attribute_Name => Name_Access));
7056 Append_To (Register_Pkg_Actuals,
7057 Make_Attribute_Reference (Loc,
7058 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7059 Attribute_Name => Name_Address));
7063 Append_To (Register_Pkg_Actuals,
7064 Make_Attribute_Reference (Loc,
7065 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7066 Attribute_Name => Name_Length));
7068 -- Is_All_Calls_Remote
7070 Append_To (Register_Pkg_Actuals,
7071 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7073 -- Finally call Register_Pkg_Receiving_Stub with the above parameters
7076 Make_Procedure_Call_Statement (Loc,
7078 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7079 Parameter_Associations => Register_Pkg_Actuals));
7080 Analyze (Last (Stmts));
7081 end Add_Receiving_Stubs_To_Declarations;
7083 ---------------------------------
7084 -- Build_General_Calling_Stubs --
7085 ---------------------------------
7087 procedure Build_General_Calling_Stubs
7089 Statements : List_Id;
7090 Target_Object : Node_Id;
7091 Subprogram_Id : Node_Id;
7092 Asynchronous : Node_Id := Empty;
7093 Is_Known_Asynchronous : Boolean := False;
7094 Is_Known_Non_Asynchronous : Boolean := False;
7095 Is_Function : Boolean;
7097 Stub_Type : Entity_Id := Empty;
7098 RACW_Type : Entity_Id := Empty;
7101 Loc : constant Source_Ptr := Sloc (Nod);
7103 Request : constant Entity_Id := Make_Temporary (Loc, 'R');
7104 -- The request object constructed by these stubs
7105 -- Could we use Name_R instead??? (see GLADE client stubs)
7107 function Make_Request_RTE_Call
7109 Actuals : List_Id := New_List) return Node_Id;
7110 -- Generate a procedure call statement calling RE with the given
7111 -- actuals. Request'Access is appended to the list.
7113 ---------------------------
7114 -- Make_Request_RTE_Call --
7115 ---------------------------
7117 function Make_Request_RTE_Call
7119 Actuals : List_Id := New_List) return Node_Id
7123 Make_Attribute_Reference (Loc,
7124 Prefix => New_Occurrence_Of (Request, Loc),
7125 Attribute_Name => Name_Access));
7126 return Make_Procedure_Call_Statement (Loc,
7128 New_Occurrence_Of (RTE (RE), Loc),
7129 Parameter_Associations => Actuals);
7130 end Make_Request_RTE_Call;
7132 Arguments : Node_Id;
7133 -- Name of the named values list used to transmit parameters
7134 -- to the remote package
7137 -- Name of the result named value (in non-APC cases) which get the
7138 -- result of the remote subprogram.
7140 Result_TC : Node_Id;
7141 -- Typecode expression for the result of the request (void
7142 -- typecode for procedures).
7144 Exception_Return_Parameter : Node_Id;
7145 -- Name of the parameter which will hold the exception sent by the
7146 -- remote subprogram.
7148 Current_Parameter : Node_Id;
7149 -- Current parameter being handled
7151 Ordered_Parameters_List : constant List_Id :=
7152 Build_Ordered_Parameters_List (Spec);
7154 Asynchronous_P : Node_Id;
7155 -- A Boolean expression indicating whether this call is asynchronous
7157 Asynchronous_Statements : List_Id := No_List;
7158 Non_Asynchronous_Statements : List_Id := No_List;
7159 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7161 Extra_Formal_Statements : constant List_Id := New_List;
7162 -- List of statements for extra formal parameters. It will appear
7163 -- after the regular statements for writing out parameters.
7165 After_Statements : constant List_Id := New_List;
7166 -- Statements to be executed after call returns (to assign IN OUT or
7167 -- OUT parameter values).
7170 -- The type of the formal parameter being processed
7172 Is_Controlling_Formal : Boolean;
7173 Is_First_Controlling_Formal : Boolean;
7174 First_Controlling_Formal_Seen : Boolean := False;
7175 -- Controlling formal parameters of distributed object primitives
7176 -- require special handling, and the first such parameter needs even
7177 -- more special handling.
7180 -- ??? document general form of stub subprograms for the PolyORB case
7183 Make_Object_Declaration (Loc,
7184 Defining_Identifier => Request,
7185 Aliased_Present => True,
7186 Object_Definition =>
7187 New_Occurrence_Of (RTE (RE_Request), Loc)));
7189 Result := Make_Temporary (Loc, 'R');
7193 PolyORB_Support.Helpers.Build_TypeCode_Call
7194 (Loc, Etype (Result_Definition (Spec)), Decls);
7196 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7200 Make_Object_Declaration (Loc,
7201 Defining_Identifier => Result,
7202 Aliased_Present => False,
7203 Object_Definition =>
7204 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7206 Make_Aggregate (Loc,
7207 Component_Associations => New_List (
7208 Make_Component_Association (Loc,
7209 Choices => New_List (Make_Identifier (Loc, Name_Name)),
7211 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7212 Make_Component_Association (Loc,
7213 Choices => New_List (
7214 Make_Identifier (Loc, Name_Argument)),
7216 Make_Function_Call (Loc,
7217 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7218 Parameter_Associations => New_List (Result_TC))),
7219 Make_Component_Association (Loc,
7220 Choices => New_List (
7221 Make_Identifier (Loc, Name_Arg_Modes)),
7222 Expression => Make_Integer_Literal (Loc, 0))))));
7224 if not Is_Known_Asynchronous then
7225 Exception_Return_Parameter := Make_Temporary (Loc, 'E');
7228 Make_Object_Declaration (Loc,
7229 Defining_Identifier => Exception_Return_Parameter,
7230 Object_Definition =>
7231 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7234 Exception_Return_Parameter := Empty;
7237 -- Initialize and fill in arguments list
7239 Arguments := Make_Temporary (Loc, 'A');
7240 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7242 Current_Parameter := First (Ordered_Parameters_List);
7243 while Present (Current_Parameter) loop
7244 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7245 Is_Controlling_Formal := True;
7246 Is_First_Controlling_Formal :=
7247 not First_Controlling_Formal_Seen;
7248 First_Controlling_Formal_Seen := True;
7251 Is_Controlling_Formal := False;
7252 Is_First_Controlling_Formal := False;
7255 if Is_Controlling_Formal then
7257 -- For a controlling formal argument, we send its reference
7262 Etyp := Etype (Parameter_Type (Current_Parameter));
7265 -- The first controlling formal parameter is treated specially:
7266 -- it is used to set the target object of the call.
7268 if not Is_First_Controlling_Formal then
7270 Constrained : constant Boolean :=
7271 Is_Constrained (Etyp)
7272 or else Is_Elementary_Type (Etyp);
7274 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
7276 Actual_Parameter : Node_Id :=
7278 Defining_Identifier (
7279 Current_Parameter), Loc);
7284 if Is_Controlling_Formal then
7286 -- For a controlling formal parameter (other than the
7287 -- first one), use the corresponding RACW. If the
7288 -- parameter is not an anonymous access parameter, that
7289 -- involves taking its 'Unrestricted_Access.
7291 if Nkind (Parameter_Type (Current_Parameter))
7292 = N_Access_Definition
7294 Actual_Parameter := OK_Convert_To
7295 (Etyp, Actual_Parameter);
7297 Actual_Parameter := OK_Convert_To (Etyp,
7298 Make_Attribute_Reference (Loc,
7299 Prefix => Actual_Parameter,
7300 Attribute_Name => Name_Unrestricted_Access));
7305 if In_Present (Current_Parameter)
7306 or else not Out_Present (Current_Parameter)
7307 or else not Constrained
7308 or else Is_Controlling_Formal
7310 -- The parameter has an input value, is constrained at
7311 -- runtime by an input value, or is a controlling formal
7312 -- parameter (always passed as a reference) other than
7315 Expr := PolyORB_Support.Helpers.Build_To_Any_Call
7316 (Actual_Parameter, Decls);
7319 Expr := Make_Function_Call (Loc,
7320 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7321 Parameter_Associations => New_List (
7322 PolyORB_Support.Helpers.Build_TypeCode_Call
7323 (Loc, Etyp, Decls)));
7327 Make_Object_Declaration (Loc,
7328 Defining_Identifier => Any,
7329 Aliased_Present => False,
7330 Object_Definition =>
7331 New_Occurrence_Of (RTE (RE_Any), Loc),
7332 Expression => Expr));
7334 Append_To (Statements,
7335 Add_Parameter_To_NVList (Loc,
7336 Parameter => Current_Parameter,
7337 NVList => Arguments,
7338 Constrained => Constrained,
7341 if Out_Present (Current_Parameter)
7342 and then not Is_Controlling_Formal
7344 if Is_Limited_Type (Etyp) then
7345 Helpers.Assign_Opaque_From_Any (Loc,
7346 Stms => After_Statements,
7348 N => New_Occurrence_Of (Any, Loc),
7350 Defining_Identifier (Current_Parameter));
7352 Append_To (After_Statements,
7353 Make_Assignment_Statement (Loc,
7356 Defining_Identifier (Current_Parameter), Loc),
7358 PolyORB_Support.Helpers.Build_From_Any_Call
7360 New_Occurrence_Of (Any, Loc),
7367 -- If the current parameter has a dynamic constrained status, then
7368 -- this status is transmitted as well.
7369 -- This should be done for accessibility as well ???
7371 if Nkind (Parameter_Type (Current_Parameter)) /=
7373 and then Need_Extra_Constrained (Current_Parameter)
7375 -- In this block, we do not use the extra formal that has been
7376 -- created because it does not exist at the time of expansion
7377 -- when building calling stubs for remote access to subprogram
7378 -- types. We create an extra variable of this type and push it
7379 -- in the stream after the regular parameters.
7382 Extra_Any_Parameter : constant Entity_Id :=
7383 Make_Temporary (Loc, 'P');
7385 Parameter_Exp : constant Node_Id :=
7386 Make_Attribute_Reference (Loc,
7387 Prefix => New_Occurrence_Of (
7388 Defining_Identifier (Current_Parameter), Loc),
7389 Attribute_Name => Name_Constrained);
7392 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7395 Make_Object_Declaration (Loc,
7396 Defining_Identifier => Extra_Any_Parameter,
7397 Aliased_Present => False,
7398 Object_Definition =>
7399 New_Occurrence_Of (RTE (RE_Any), Loc),
7401 PolyORB_Support.Helpers.Build_To_Any_Call
7402 (Parameter_Exp, Decls)));
7404 Append_To (Extra_Formal_Statements,
7405 Add_Parameter_To_NVList (Loc,
7406 Parameter => Extra_Any_Parameter,
7407 NVList => Arguments,
7408 Constrained => True,
7409 Any => Extra_Any_Parameter));
7413 Next (Current_Parameter);
7416 -- Append the formal statements list to the statements
7418 Append_List_To (Statements, Extra_Formal_Statements);
7420 Append_To (Statements,
7421 Make_Procedure_Call_Statement (Loc,
7423 New_Occurrence_Of (RTE (RE_Request_Setup), Loc),
7424 Parameter_Associations => New_List (
7425 New_Occurrence_Of (Request, Loc),
7428 New_Occurrence_Of (Arguments, Loc),
7429 New_Occurrence_Of (Result, Loc),
7430 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7433 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7435 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7438 (Boolean_Literals (Is_Known_Asynchronous), Loc);
7441 pragma Assert (Present (Asynchronous));
7442 Asynchronous_P := New_Copy_Tree (Asynchronous);
7444 -- The expression node Asynchronous will be used to build an 'if'
7445 -- statement at the end of Build_General_Calling_Stubs: we need to
7446 -- make a copy here.
7449 Append_To (Parameter_Associations (Last (Statements)),
7450 Make_Indexed_Component (Loc,
7453 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7454 Expressions => New_List (Asynchronous_P)));
7456 Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke));
7458 -- Asynchronous case
7460 if not Is_Known_Non_Asynchronous then
7461 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7464 -- Non-asynchronous case
7466 if not Is_Known_Asynchronous then
7467 -- Reraise an exception occurrence from the completed request.
7468 -- If the exception occurrence is empty, this is a no-op.
7470 Non_Asynchronous_Statements := New_List (
7471 Make_Procedure_Call_Statement (Loc,
7473 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7474 Parameter_Associations => New_List (
7475 New_Occurrence_Of (Request, Loc))));
7478 -- If this is a function call, read the value and return it
7480 Append_To (Non_Asynchronous_Statements,
7481 Make_Tag_Check (Loc,
7482 Make_Simple_Return_Statement (Loc,
7483 PolyORB_Support.Helpers.Build_From_Any_Call
7484 (Etype (Result_Definition (Spec)),
7485 Make_Selected_Component (Loc,
7487 Selector_Name => Name_Argument),
7492 -- Case of a procedure: deal with IN OUT and OUT formals
7494 Append_List_To (Non_Asynchronous_Statements, After_Statements);
7498 if Is_Known_Asynchronous then
7499 Append_List_To (Statements, Asynchronous_Statements);
7501 elsif Is_Known_Non_Asynchronous then
7502 Append_List_To (Statements, Non_Asynchronous_Statements);
7505 pragma Assert (Present (Asynchronous));
7506 Append_To (Statements,
7507 Make_Implicit_If_Statement (Nod,
7508 Condition => Asynchronous,
7509 Then_Statements => Asynchronous_Statements,
7510 Else_Statements => Non_Asynchronous_Statements));
7512 end Build_General_Calling_Stubs;
7514 -----------------------
7515 -- Build_Stub_Target --
7516 -----------------------
7518 function Build_Stub_Target
7521 RCI_Locator : Entity_Id;
7522 Controlling_Parameter : Entity_Id) return RPC_Target
7524 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7525 Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T');
7528 if Present (Controlling_Parameter) then
7530 Make_Object_Declaration (Loc,
7531 Defining_Identifier => Target_Reference,
7533 Object_Definition =>
7534 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7537 Make_Function_Call (Loc,
7539 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7540 Parameter_Associations => New_List (
7541 Make_Selected_Component (Loc,
7542 Prefix => Controlling_Parameter,
7543 Selector_Name => Name_Target)))));
7545 -- Note: Controlling_Parameter has the same components as
7546 -- System.Partition_Interface.RACW_Stub_Type.
7548 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7551 Target_Info.Object :=
7552 Make_Selected_Component (Loc,
7553 Prefix => Make_Identifier (Loc, Chars (RCI_Locator)),
7555 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7559 end Build_Stub_Target;
7561 ---------------------
7562 -- Build_Stub_Type --
7563 ---------------------
7565 procedure Build_Stub_Type
7566 (RACW_Type : Entity_Id;
7567 Stub_Type_Comps : out List_Id;
7568 RPC_Receiver_Decl : out Node_Id)
7570 Loc : constant Source_Ptr := Sloc (RACW_Type);
7573 Stub_Type_Comps := New_List (
7574 Make_Component_Declaration (Loc,
7575 Defining_Identifier =>
7576 Make_Defining_Identifier (Loc, Name_Target),
7577 Component_Definition =>
7578 Make_Component_Definition (Loc,
7579 Aliased_Present => False,
7580 Subtype_Indication =>
7581 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7583 Make_Component_Declaration (Loc,
7584 Defining_Identifier =>
7585 Make_Defining_Identifier (Loc, Name_Asynchronous),
7587 Component_Definition =>
7588 Make_Component_Definition (Loc,
7589 Aliased_Present => False,
7590 Subtype_Indication =>
7591 New_Occurrence_Of (Standard_Boolean, Loc))));
7593 RPC_Receiver_Decl :=
7594 Make_Object_Declaration (Loc,
7595 Defining_Identifier => Make_Temporary (Loc, 'R'),
7596 Aliased_Present => True,
7597 Object_Definition =>
7598 New_Occurrence_Of (RTE (RE_Servant), Loc));
7599 end Build_Stub_Type;
7601 -----------------------------
7602 -- Build_RPC_Receiver_Body --
7603 -----------------------------
7605 procedure Build_RPC_Receiver_Body
7606 (RPC_Receiver : Entity_Id;
7607 Request : out Entity_Id;
7608 Subp_Id : out Entity_Id;
7609 Subp_Index : out Entity_Id;
7610 Stmts : out List_Id;
7613 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7615 RPC_Receiver_Spec : Node_Id;
7616 RPC_Receiver_Decls : List_Id;
7619 Request := Make_Defining_Identifier (Loc, Name_R);
7621 RPC_Receiver_Spec :=
7622 Build_RPC_Receiver_Specification
7623 (RPC_Receiver => RPC_Receiver,
7624 Request_Parameter => Request);
7626 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7627 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7629 RPC_Receiver_Decls := New_List (
7630 Make_Object_Renaming_Declaration (Loc,
7631 Defining_Identifier => Subp_Id,
7632 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7634 Make_Explicit_Dereference (Loc,
7636 Make_Selected_Component (Loc,
7638 Selector_Name => Name_Operation))),
7640 Make_Object_Declaration (Loc,
7641 Defining_Identifier => Subp_Index,
7642 Object_Definition =>
7643 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7645 Make_Attribute_Reference (Loc,
7647 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7648 Attribute_Name => Name_Last)));
7653 Make_Subprogram_Body (Loc,
7654 Specification => RPC_Receiver_Spec,
7655 Declarations => RPC_Receiver_Decls,
7656 Handled_Statement_Sequence =>
7657 Make_Handled_Sequence_Of_Statements (Loc,
7658 Statements => Stmts));
7659 end Build_RPC_Receiver_Body;
7661 --------------------------------------
7662 -- Build_Subprogram_Receiving_Stubs --
7663 --------------------------------------
7665 function Build_Subprogram_Receiving_Stubs
7666 (Vis_Decl : Node_Id;
7667 Asynchronous : Boolean;
7668 Dynamically_Asynchronous : Boolean := False;
7669 Stub_Type : Entity_Id := Empty;
7670 RACW_Type : Entity_Id := Empty;
7671 Parent_Primitive : Entity_Id := Empty) return Node_Id
7673 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7675 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
7676 -- Formal parameter for receiving stubs: a descriptor for an incoming
7679 Outer_Decls : constant List_Id := New_List;
7680 -- At the outermost level, an NVList and Any's are declared for all
7681 -- parameters. The Dynamic_Async flag also needs to be declared there
7682 -- to be visible from the exception handling code.
7684 Outer_Statements : constant List_Id := New_List;
7685 -- Statements that occur prior to the declaration of the actual
7686 -- parameter variables.
7688 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7689 -- Statements concerning extra formal parameters, prior to the
7690 -- declaration of the actual parameter variables.
7692 Decls : constant List_Id := New_List;
7693 -- All the parameters will get declared before calling the real
7694 -- subprograms. Also the out parameters will be declared. At this
7695 -- level, parameters may be unconstrained.
7697 Statements : constant List_Id := New_List;
7699 After_Statements : constant List_Id := New_List;
7700 -- Statements to be executed after the subprogram call
7702 Inner_Decls : List_Id := No_List;
7703 -- In case of a function, the inner declarations are needed since
7704 -- the result may be unconstrained.
7706 Excep_Handlers : List_Id := No_List;
7708 Parameter_List : constant List_Id := New_List;
7709 -- List of parameters to be passed to the subprogram
7711 First_Controlling_Formal_Seen : Boolean := False;
7713 Current_Parameter : Node_Id;
7715 Ordered_Parameters_List : constant List_Id :=
7716 Build_Ordered_Parameters_List
7717 (Specification (Vis_Decl));
7719 Arguments : constant Entity_Id := Make_Temporary (Loc, 'A');
7720 -- Name of the named values list used to retrieve parameters
7722 Subp_Spec : Node_Id;
7723 -- Subprogram specification
7725 Called_Subprogram : Node_Id;
7726 -- The subprogram to call
7729 if Present (RACW_Type) then
7730 Called_Subprogram :=
7731 New_Occurrence_Of (Parent_Primitive, Loc);
7733 Called_Subprogram :=
7735 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7738 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7740 -- Loop through every parameter and get its value from the stream. If
7741 -- the parameter is unconstrained, then the parameter is read using
7742 -- 'Input at the point of declaration.
7744 Current_Parameter := First (Ordered_Parameters_List);
7745 while Present (Current_Parameter) loop
7748 Constrained : Boolean;
7749 Any : Entity_Id := Empty;
7750 Object : constant Entity_Id := Make_Temporary (Loc, 'P');
7751 Expr : Node_Id := Empty;
7753 Is_Controlling_Formal : constant Boolean :=
7754 Is_RACW_Controlling_Formal
7755 (Current_Parameter, Stub_Type);
7757 Is_First_Controlling_Formal : Boolean := False;
7759 Need_Extra_Constrained : Boolean;
7760 -- True when an extra constrained actual is required
7763 if Is_Controlling_Formal then
7765 -- Controlling formals in distributed object primitive
7766 -- operations are handled specially:
7768 -- - the first controlling formal is used as the
7769 -- target of the call;
7771 -- - the remaining controlling formals are transmitted
7775 Is_First_Controlling_Formal :=
7776 not First_Controlling_Formal_Seen;
7777 First_Controlling_Formal_Seen := True;
7780 Etyp := Etype (Parameter_Type (Current_Parameter));
7784 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
7786 if not Is_First_Controlling_Formal then
7787 Any := Make_Temporary (Loc, 'A');
7789 Append_To (Outer_Decls,
7790 Make_Object_Declaration (Loc,
7791 Defining_Identifier => Any,
7792 Object_Definition =>
7793 New_Occurrence_Of (RTE (RE_Any), Loc),
7795 Make_Function_Call (Loc,
7796 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7797 Parameter_Associations => New_List (
7798 PolyORB_Support.Helpers.Build_TypeCode_Call
7799 (Loc, Etyp, Outer_Decls)))));
7801 Append_To (Outer_Statements,
7802 Add_Parameter_To_NVList (Loc,
7803 Parameter => Current_Parameter,
7804 NVList => Arguments,
7805 Constrained => Constrained,
7809 if Is_First_Controlling_Formal then
7811 Addr : constant Entity_Id := Make_Temporary (Loc, 'A');
7813 Is_Local : constant Entity_Id :=
7814 Make_Temporary (Loc, 'L');
7817 -- Special case: obtain the first controlling formal
7818 -- from the target of the remote call, instead of the
7821 Append_To (Outer_Decls,
7822 Make_Object_Declaration (Loc,
7823 Defining_Identifier => Addr,
7824 Object_Definition =>
7825 New_Occurrence_Of (RTE (RE_Address), Loc)));
7827 Append_To (Outer_Decls,
7828 Make_Object_Declaration (Loc,
7829 Defining_Identifier => Is_Local,
7830 Object_Definition =>
7831 New_Occurrence_Of (Standard_Boolean, Loc)));
7833 Append_To (Outer_Statements,
7834 Make_Procedure_Call_Statement (Loc,
7836 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7837 Parameter_Associations => New_List (
7838 Make_Selected_Component (Loc,
7841 Request_Parameter, Loc),
7843 Make_Identifier (Loc, Name_Target)),
7844 New_Occurrence_Of (Is_Local, Loc),
7845 New_Occurrence_Of (Addr, Loc))));
7847 Expr := Unchecked_Convert_To (RACW_Type,
7848 New_Occurrence_Of (Addr, Loc));
7851 elsif In_Present (Current_Parameter)
7852 or else not Out_Present (Current_Parameter)
7853 or else not Constrained
7855 -- If an input parameter is constrained, then its reading is
7856 -- deferred until the beginning of the subprogram body. If
7857 -- it is unconstrained, then an expression is built for
7858 -- the object declaration and the variable is set using
7859 -- 'Input instead of 'Read.
7861 if Constrained and then Is_Limited_Type (Etyp) then
7862 Helpers.Assign_Opaque_From_Any (Loc,
7865 N => New_Occurrence_Of (Any, Loc),
7869 Expr := Helpers.Build_From_Any_Call
7870 (Etyp, New_Occurrence_Of (Any, Loc), Decls);
7873 Append_To (Statements,
7874 Make_Assignment_Statement (Loc,
7875 Name => New_Occurrence_Of (Object, Loc),
7876 Expression => Expr));
7880 -- Expr will be used to initialize (and constrain) the
7881 -- parameter when it is declared.
7889 Need_Extra_Constrained :=
7890 Nkind (Parameter_Type (Current_Parameter)) /=
7893 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7895 Present (Extra_Constrained
7896 (Defining_Identifier (Current_Parameter)));
7898 -- We may not associate an extra constrained actual to a
7899 -- constant object, so if one is needed, declare the actual
7900 -- as a variable even if it won't be modified.
7902 Build_Actual_Object_Declaration
7905 Variable => Need_Extra_Constrained
7906 or else Out_Present (Current_Parameter),
7909 Set_Etype (Object, Etyp);
7911 -- An out parameter may be written back using a 'Write
7912 -- attribute instead of a 'Output because it has been
7913 -- constrained by the parameter given to the caller. Note that
7914 -- out controlling arguments in the case of a RACW are not put
7915 -- back in the stream because the pointer on them has not
7918 if Out_Present (Current_Parameter)
7919 and then not Is_Controlling_Formal
7921 Append_To (After_Statements,
7922 Make_Procedure_Call_Statement (Loc,
7923 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
7924 Parameter_Associations => New_List (
7925 New_Occurrence_Of (Any, Loc),
7926 PolyORB_Support.Helpers.Build_To_Any_Call
7927 (New_Occurrence_Of (Object, Loc), Decls))));
7930 -- For RACW controlling formals, the Etyp of Object is always
7931 -- an RACW, even if the parameter is not of an anonymous access
7932 -- type. In such case, we need to dereference it at call time.
7934 if Is_Controlling_Formal then
7935 if Nkind (Parameter_Type (Current_Parameter)) /=
7938 Append_To (Parameter_List,
7939 Make_Parameter_Association (Loc,
7942 (Defining_Identifier (Current_Parameter), Loc),
7943 Explicit_Actual_Parameter =>
7944 Make_Explicit_Dereference (Loc,
7945 Prefix => New_Occurrence_Of (Object, Loc))));
7948 Append_To (Parameter_List,
7949 Make_Parameter_Association (Loc,
7952 (Defining_Identifier (Current_Parameter), Loc),
7954 Explicit_Actual_Parameter =>
7955 New_Occurrence_Of (Object, Loc)));
7959 Append_To (Parameter_List,
7960 Make_Parameter_Association (Loc,
7963 Defining_Identifier (Current_Parameter), Loc),
7964 Explicit_Actual_Parameter =>
7965 New_Occurrence_Of (Object, Loc)));
7968 -- If the current parameter needs an extra formal, then read it
7969 -- from the stream and set the corresponding semantic field in
7970 -- the variable. If the kind of the parameter identifier is
7971 -- E_Void, then this is a compiler generated parameter that
7972 -- doesn't need an extra constrained status.
7974 -- The case of Extra_Accessibility should also be handled ???
7976 if Need_Extra_Constrained then
7978 Extra_Parameter : constant Entity_Id :=
7980 (Defining_Identifier
7981 (Current_Parameter));
7983 Extra_Any : constant Entity_Id :=
7984 Make_Temporary (Loc, 'A');
7986 Formal_Entity : constant Entity_Id :=
7987 Make_Defining_Identifier (Loc,
7988 Chars => Chars (Extra_Parameter));
7990 Formal_Type : constant Entity_Id :=
7991 Etype (Extra_Parameter);
7994 Append_To (Outer_Decls,
7995 Make_Object_Declaration (Loc,
7996 Defining_Identifier => Extra_Any,
7997 Object_Definition =>
7998 New_Occurrence_Of (RTE (RE_Any), Loc),
8000 Make_Function_Call (Loc,
8002 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8003 Parameter_Associations => New_List (
8004 PolyORB_Support.Helpers.Build_TypeCode_Call
8005 (Loc, Formal_Type, Outer_Decls)))));
8007 Append_To (Outer_Extra_Formal_Statements,
8008 Add_Parameter_To_NVList (Loc,
8009 Parameter => Extra_Parameter,
8010 NVList => Arguments,
8011 Constrained => True,
8015 Make_Object_Declaration (Loc,
8016 Defining_Identifier => Formal_Entity,
8017 Object_Definition =>
8018 New_Occurrence_Of (Formal_Type, Loc)));
8020 Append_To (Statements,
8021 Make_Assignment_Statement (Loc,
8022 Name => New_Occurrence_Of (Formal_Entity, Loc),
8024 PolyORB_Support.Helpers.Build_From_Any_Call
8026 New_Occurrence_Of (Extra_Any, Loc),
8028 Set_Extra_Constrained (Object, Formal_Entity);
8033 Next (Current_Parameter);
8036 -- Extra Formals should go after all the other parameters
8038 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8040 Append_To (Outer_Statements,
8041 Make_Procedure_Call_Statement (Loc,
8042 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8043 Parameter_Associations => New_List (
8044 New_Occurrence_Of (Request_Parameter, Loc),
8045 New_Occurrence_Of (Arguments, Loc))));
8047 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8049 -- The remote subprogram is a function: Build an inner block to be
8050 -- able to hold a potentially unconstrained result in a variable.
8053 Etyp : constant Entity_Id :=
8054 Etype (Result_Definition (Specification (Vis_Decl)));
8055 Result : constant Node_Id := Make_Temporary (Loc, 'R');
8058 Inner_Decls := New_List (
8059 Make_Object_Declaration (Loc,
8060 Defining_Identifier => Result,
8061 Constant_Present => True,
8062 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8064 Make_Function_Call (Loc,
8065 Name => Called_Subprogram,
8066 Parameter_Associations => Parameter_List)));
8068 if Is_Class_Wide_Type (Etyp) then
8070 -- For a remote call to a function with a class-wide type,
8071 -- check that the returned value satisfies the requirements
8074 Append_To (Inner_Decls,
8075 Make_Transportable_Check (Loc,
8076 New_Occurrence_Of (Result, Loc)));
8080 Set_Etype (Result, Etyp);
8081 Append_To (After_Statements,
8082 Make_Procedure_Call_Statement (Loc,
8083 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8084 Parameter_Associations => New_List (
8085 New_Occurrence_Of (Request_Parameter, Loc),
8086 PolyORB_Support.Helpers.Build_To_Any_Call
8087 (New_Occurrence_Of (Result, Loc), Decls))));
8089 -- A DSA function does not have out or inout arguments
8092 Append_To (Statements,
8093 Make_Block_Statement (Loc,
8094 Declarations => Inner_Decls,
8095 Handled_Statement_Sequence =>
8096 Make_Handled_Sequence_Of_Statements (Loc,
8097 Statements => After_Statements)));
8100 -- The remote subprogram is a procedure. We do not need any inner
8101 -- block in this case. No specific processing is required here for
8102 -- the dynamically asynchronous case: the indication of whether
8103 -- call is asynchronous or not is managed by the Sync_Scope
8104 -- attibute of the request, and is handled entirely in the
8107 Append_To (After_Statements,
8108 Make_Procedure_Call_Statement (Loc,
8109 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8110 Parameter_Associations => New_List (
8111 New_Occurrence_Of (Request_Parameter, Loc))));
8113 Append_To (Statements,
8114 Make_Procedure_Call_Statement (Loc,
8115 Name => Called_Subprogram,
8116 Parameter_Associations => Parameter_List));
8118 Append_List_To (Statements, After_Statements);
8122 Make_Procedure_Specification (Loc,
8123 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
8125 Parameter_Specifications => New_List (
8126 Make_Parameter_Specification (Loc,
8127 Defining_Identifier => Request_Parameter,
8129 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8131 -- An exception raised during the execution of an incoming remote
8132 -- subprogram call and that needs to be sent back to the caller is
8133 -- propagated by the receiving stubs, and will be handled by the
8134 -- caller (the distribution runtime).
8136 if Asynchronous and then not Dynamically_Asynchronous then
8138 -- For an asynchronous procedure, add a null exception handler
8140 Excep_Handlers := New_List (
8141 Make_Implicit_Exception_Handler (Loc,
8142 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8143 Statements => New_List (Make_Null_Statement (Loc))));
8146 -- In the other cases, if an exception is raised, then the
8147 -- exception occurrence is propagated.
8152 Append_To (Outer_Statements,
8153 Make_Block_Statement (Loc,
8154 Declarations => Decls,
8155 Handled_Statement_Sequence =>
8156 Make_Handled_Sequence_Of_Statements (Loc,
8157 Statements => Statements)));
8160 Make_Subprogram_Body (Loc,
8161 Specification => Subp_Spec,
8162 Declarations => Outer_Decls,
8163 Handled_Statement_Sequence =>
8164 Make_Handled_Sequence_Of_Statements (Loc,
8165 Statements => Outer_Statements,
8166 Exception_Handlers => Excep_Handlers));
8167 end Build_Subprogram_Receiving_Stubs;
8173 package body Helpers is
8175 -----------------------
8176 -- Local Subprograms --
8177 -----------------------
8179 function Find_Numeric_Representation
8180 (Typ : Entity_Id) return Entity_Id;
8181 -- Given a numeric type Typ, return the smallest integer or floating
8182 -- point type from Standard, or the smallest unsigned (modular) type
8183 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8185 function Make_Helper_Function_Name
8188 Nam : Name_Id) return Entity_Id;
8189 -- Return the name to be assigned for helper subprogram Nam of Typ
8191 ------------------------------------------------------------
8192 -- Common subprograms for building various tree fragments --
8193 ------------------------------------------------------------
8195 function Build_Get_Aggregate_Element
8199 Idx : Node_Id) return Node_Id;
8200 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8201 -- returning the Idx'th element.
8204 Subprogram : Entity_Id;
8205 -- Reference location for constructed nodes
8208 -- For 'Range and Etype
8211 -- For the construction of the innermost element expression
8213 with procedure Add_Process_Element
8216 Counter : Entity_Id;
8219 procedure Append_Array_Traversal
8222 Counter : Entity_Id := Empty;
8224 -- Build nested loop statements that iterate over the elements of an
8225 -- array Arry. The statement(s) built by Add_Process_Element are
8226 -- executed for each element; Indexes is the list of indexes to be
8227 -- used in the construction of the indexed component that denotes the
8228 -- current element. Subprogram is the entity for the subprogram for
8229 -- which this iterator is generated. The generated statements are
8230 -- appended to Stmts.
8234 -- The record entity being dealt with
8236 with procedure Add_Process_Element
8238 Container : Node_Or_Entity_Id;
8239 Counter : in out Int;
8242 -- Rec is the instance of the record type, or Empty.
8243 -- Field is either the N_Defining_Identifier for a component,
8244 -- or an N_Variant_Part.
8246 procedure Append_Record_Traversal
8249 Container : Node_Or_Entity_Id;
8250 Counter : in out Int);
8251 -- Process component list Clist. Individual fields are passed
8252 -- to Field_Processing. Each variant part is also processed.
8253 -- Container is the outer Any (for From_Any/To_Any),
8254 -- the outer typecode (for TC) to which the operation applies.
8256 -----------------------------
8257 -- Append_Record_Traversal --
8258 -----------------------------
8260 procedure Append_Record_Traversal
8263 Container : Node_Or_Entity_Id;
8264 Counter : in out Int)
8268 -- Clist's Component_Items and Variant_Part
8278 CI := Component_Items (Clist);
8279 VP := Variant_Part (Clist);
8282 while Present (Item) loop
8283 Def := Defining_Identifier (Item);
8285 if not Is_Internal_Name (Chars (Def)) then
8287 (Stmts, Container, Counter, Rec, Def);
8293 if Present (VP) then
8294 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8296 end Append_Record_Traversal;
8298 -----------------------------
8299 -- Assign_Opaque_From_Any --
8300 -----------------------------
8302 procedure Assign_Opaque_From_Any
8309 Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
8312 Read_Call_List : List_Id;
8313 -- List on which to place the 'Read attribute reference
8316 -- Strm : Buffer_Stream_Type;
8319 Make_Object_Declaration (Loc,
8320 Defining_Identifier => Strm,
8321 Aliased_Present => True,
8322 Object_Definition =>
8323 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
8325 -- Any_To_BS (Strm, A);
8328 Make_Procedure_Call_Statement (Loc,
8329 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
8330 Parameter_Associations => New_List (
8332 New_Occurrence_Of (Strm, Loc))));
8334 if Transmit_As_Unconstrained (Typ) then
8336 Make_Attribute_Reference (Loc,
8337 Prefix => New_Occurrence_Of (Typ, Loc),
8338 Attribute_Name => Name_Input,
8339 Expressions => New_List (
8340 Make_Attribute_Reference (Loc,
8341 Prefix => New_Occurrence_Of (Strm, Loc),
8342 Attribute_Name => Name_Access)));
8344 -- Target := Typ'Input (Strm'Access)
8346 if Present (Target) then
8348 Make_Assignment_Statement (Loc,
8349 Name => New_Occurrence_Of (Target, Loc),
8350 Expression => Expr));
8352 -- return Typ'Input (Strm'Access);
8356 Make_Simple_Return_Statement (Loc,
8357 Expression => Expr));
8361 if Present (Target) then
8362 Read_Call_List := Stms;
8363 Expr := New_Occurrence_Of (Target, Loc);
8367 Temp : constant Entity_Id := Make_Temporary (Loc, 'R');
8370 Read_Call_List := New_List;
8371 Expr := New_Occurrence_Of (Temp, Loc);
8373 Append_To (Stms, Make_Block_Statement (Loc,
8374 Declarations => New_List (
8375 Make_Object_Declaration (Loc,
8376 Defining_Identifier =>
8378 Object_Definition =>
8379 New_Occurrence_Of (Typ, Loc))),
8381 Handled_Statement_Sequence =>
8382 Make_Handled_Sequence_Of_Statements (Loc,
8383 Statements => Read_Call_List)));
8387 -- Typ'Read (Strm'Access, [Target|Temp])
8389 Append_To (Read_Call_List,
8390 Make_Attribute_Reference (Loc,
8391 Prefix => New_Occurrence_Of (Typ, Loc),
8392 Attribute_Name => Name_Read,
8393 Expressions => New_List (
8394 Make_Attribute_Reference (Loc,
8395 Prefix => New_Occurrence_Of (Strm, Loc),
8396 Attribute_Name => Name_Access),
8403 Append_To (Read_Call_List,
8404 Make_Simple_Return_Statement (Loc,
8405 Expression => New_Copy (Expr)));
8408 end Assign_Opaque_From_Any;
8410 -------------------------
8411 -- Build_From_Any_Call --
8412 -------------------------
8414 function Build_From_Any_Call
8417 Decls : List_Id) return Node_Id
8419 Loc : constant Source_Ptr := Sloc (N);
8421 U_Type : Entity_Id := Underlying_Type (Typ);
8423 Fnam : Entity_Id := Empty;
8424 Lib_RE : RE_Id := RE_Null;
8428 -- First simple case where the From_Any function is present
8429 -- in the type's TSS.
8431 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8433 -- For the subtype representing a generic actual type, go to the
8436 if Is_Generic_Actual_Type (U_Type) then
8437 U_Type := Underlying_Type (Base_Type (U_Type));
8440 -- For a standard subtype, go to the base type
8442 if Sloc (U_Type) <= Standard_Location then
8443 U_Type := Base_Type (U_Type);
8446 -- Check first for Boolean and Character. These are enumeration
8447 -- types, but we treat them specially, since they may require
8448 -- special handling in the transfer protocol. However, this
8449 -- special handling only applies if they have standard
8450 -- representation, otherwise they are treated like any other
8451 -- enumeration type.
8453 if Present (Fnam) then
8456 elsif U_Type = Standard_Boolean then
8459 elsif U_Type = Standard_Character then
8462 elsif U_Type = Standard_Wide_Character then
8465 elsif U_Type = Standard_Wide_Wide_Character then
8466 Lib_RE := RE_FA_WWC;
8468 -- Floating point types
8470 elsif U_Type = Standard_Short_Float then
8473 elsif U_Type = Standard_Float then
8476 elsif U_Type = Standard_Long_Float then
8479 elsif U_Type = Standard_Long_Long_Float then
8480 Lib_RE := RE_FA_LLF;
8484 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8485 Lib_RE := RE_FA_SSI;
8487 elsif U_Type = Etype (Standard_Short_Integer) then
8490 elsif U_Type = Etype (Standard_Integer) then
8493 elsif U_Type = Etype (Standard_Long_Integer) then
8496 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8497 Lib_RE := RE_FA_LLI;
8499 -- Unsigned integer types
8501 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8502 Lib_RE := RE_FA_SSU;
8504 elsif U_Type = RTE (RE_Short_Unsigned) then
8507 elsif U_Type = RTE (RE_Unsigned) then
8510 elsif U_Type = RTE (RE_Long_Unsigned) then
8513 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8514 Lib_RE := RE_FA_LLU;
8516 elsif Is_RTE (U_Type, RE_Unbounded_String) then
8517 Lib_RE := RE_FA_String;
8519 -- Special DSA types
8521 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
8524 -- Other (non-primitive) types
8531 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8532 Append_To (Decls, Decl);
8536 -- Call the function
8538 if Lib_RE /= RE_Null then
8539 pragma Assert (No (Fnam));
8540 Fnam := RTE (Lib_RE);
8544 Make_Function_Call (Loc,
8545 Name => New_Occurrence_Of (Fnam, Loc),
8546 Parameter_Associations => New_List (N));
8548 -- We must set the type of Result, so the unchecked conversion
8549 -- from the underlying type to the base type is properly done.
8551 Set_Etype (Result, U_Type);
8553 return Unchecked_Convert_To (Typ, Result);
8554 end Build_From_Any_Call;
8556 -----------------------------
8557 -- Build_From_Any_Function --
8558 -----------------------------
8560 procedure Build_From_Any_Function
8564 Fnam : out Entity_Id)
8567 Decls : constant List_Id := New_List;
8568 Stms : constant List_Id := New_List;
8570 Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A');
8572 Use_Opaque_Representation : Boolean;
8575 -- For a derived type, we can't go past the base type (to the
8576 -- parent type) here, because that would cause the attribute's
8577 -- formal parameter to have the wrong type; hence the Base_Type
8580 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
8581 Build_From_Any_Function
8589 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
8592 Make_Function_Specification (Loc,
8593 Defining_Unit_Name => Fnam,
8594 Parameter_Specifications => New_List (
8595 Make_Parameter_Specification (Loc,
8596 Defining_Identifier => Any_Parameter,
8597 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
8598 Result_Definition => New_Occurrence_Of (Typ, Loc));
8600 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8603 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8605 Use_Opaque_Representation := False;
8607 if Has_Stream_Attribute_Definition
8608 (Typ, TSS_Stream_Output, At_Any_Place => True)
8610 Has_Stream_Attribute_Definition
8611 (Typ, TSS_Stream_Write, At_Any_Place => True)
8613 -- If user-defined stream attributes are specified for this
8614 -- type, use them and transmit data as an opaque sequence of
8617 Use_Opaque_Representation := True;
8619 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
8621 Make_Simple_Return_Statement (Loc,
8626 New_Occurrence_Of (Any_Parameter, Loc),
8629 elsif Is_Record_Type (Typ)
8630 and then not Is_Derived_Type (Typ)
8631 and then not Is_Tagged_Type (Typ)
8633 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8635 Make_Simple_Return_Statement (Loc,
8639 New_Occurrence_Of (Any_Parameter, Loc),
8644 Disc : Entity_Id := Empty;
8645 Discriminant_Associations : List_Id;
8646 Rdef : constant Node_Id :=
8648 (Declaration_Node (Typ));
8649 Component_Counter : Int := 0;
8651 -- The returned object
8653 Res : constant Entity_Id := Make_Temporary (Loc, 'R');
8655 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8657 procedure FA_Rec_Add_Process_Element
8660 Counter : in out Int;
8664 procedure FA_Append_Record_Traversal is
8665 new Append_Record_Traversal
8667 Add_Process_Element => FA_Rec_Add_Process_Element);
8669 --------------------------------
8670 -- FA_Rec_Add_Process_Element --
8671 --------------------------------
8673 procedure FA_Rec_Add_Process_Element
8676 Counter : in out Int;
8682 if Nkind (Field) = N_Defining_Identifier then
8683 -- A regular component
8685 Ctyp := Etype (Field);
8688 Make_Assignment_Statement (Loc,
8689 Name => Make_Selected_Component (Loc,
8691 New_Occurrence_Of (Rec, Loc),
8693 New_Occurrence_Of (Field, Loc)),
8696 Build_From_Any_Call (Ctyp,
8697 Build_Get_Aggregate_Element (Loc,
8700 Build_TypeCode_Call (Loc, Ctyp, Decls),
8702 Make_Integer_Literal (Loc, Counter)),
8710 Struct_Counter : Int := 0;
8712 Block_Decls : constant List_Id := New_List;
8713 Block_Stmts : constant List_Id := New_List;
8716 Alt_List : constant List_Id := New_List;
8717 Choice_List : List_Id;
8719 Struct_Any : constant Entity_Id :=
8720 Make_Temporary (Loc, 'S');
8724 Make_Object_Declaration (Loc,
8725 Defining_Identifier => Struct_Any,
8726 Constant_Present => True,
8727 Object_Definition =>
8728 New_Occurrence_Of (RTE (RE_Any), Loc),
8730 Make_Function_Call (Loc,
8733 (RTE (RE_Extract_Union_Value), Loc),
8735 Parameter_Associations => New_List (
8736 Build_Get_Aggregate_Element (Loc,
8739 Make_Function_Call (Loc,
8740 Name => New_Occurrence_Of (
8741 RTE (RE_Any_Member_Type), Loc),
8742 Parameter_Associations =>
8744 New_Occurrence_Of (Any, Loc),
8745 Make_Integer_Literal (Loc,
8746 Intval => Counter))),
8748 Make_Integer_Literal (Loc,
8749 Intval => Counter))))));
8752 Make_Block_Statement (Loc,
8753 Declarations => Block_Decls,
8754 Handled_Statement_Sequence =>
8755 Make_Handled_Sequence_Of_Statements (Loc,
8756 Statements => Block_Stmts)));
8758 Append_To (Block_Stmts,
8759 Make_Case_Statement (Loc,
8761 Make_Selected_Component (Loc,
8763 Selector_Name => Chars (Name (Field))),
8764 Alternatives => Alt_List));
8766 Variant := First_Non_Pragma (Variants (Field));
8767 while Present (Variant) loop
8770 (Discrete_Choices (Variant));
8772 VP_Stmts := New_List;
8774 -- Struct_Counter should be reset before
8775 -- handling a variant part. Indeed only one
8776 -- of the case statement alternatives will be
8777 -- executed at run time, so the counter must
8778 -- start at 0 for every case statement.
8780 Struct_Counter := 0;
8782 FA_Append_Record_Traversal (
8784 Clist => Component_List (Variant),
8785 Container => Struct_Any,
8786 Counter => Struct_Counter);
8788 Append_To (Alt_List,
8789 Make_Case_Statement_Alternative (Loc,
8790 Discrete_Choices => Choice_List,
8791 Statements => VP_Stmts));
8792 Next_Non_Pragma (Variant);
8797 Counter := Counter + 1;
8798 end FA_Rec_Add_Process_Element;
8801 -- First all discriminants
8803 if Has_Discriminants (Typ) then
8804 Discriminant_Associations := New_List;
8806 Disc := First_Discriminant (Typ);
8807 while Present (Disc) loop
8809 Disc_Var_Name : constant Entity_Id :=
8810 Make_Defining_Identifier (Loc,
8811 Chars => Chars (Disc));
8812 Disc_Type : constant Entity_Id :=
8817 Make_Object_Declaration (Loc,
8818 Defining_Identifier => Disc_Var_Name,
8819 Constant_Present => True,
8820 Object_Definition =>
8821 New_Occurrence_Of (Disc_Type, Loc),
8824 Build_From_Any_Call (Disc_Type,
8825 Build_Get_Aggregate_Element (Loc,
8826 Any => Any_Parameter,
8827 TC => Build_TypeCode_Call
8828 (Loc, Disc_Type, Decls),
8829 Idx => Make_Integer_Literal (Loc,
8830 Intval => Component_Counter)),
8833 Component_Counter := Component_Counter + 1;
8835 Append_To (Discriminant_Associations,
8836 Make_Discriminant_Association (Loc,
8837 Selector_Names => New_List (
8838 New_Occurrence_Of (Disc, Loc)),
8840 New_Occurrence_Of (Disc_Var_Name, Loc)));
8842 Next_Discriminant (Disc);
8846 Make_Subtype_Indication (Loc,
8847 Subtype_Mark => Res_Definition,
8849 Make_Index_Or_Discriminant_Constraint (Loc,
8850 Discriminant_Associations));
8853 -- Now we have all the discriminants in variables, we can
8854 -- declared a constrained object. Note that we are not
8855 -- initializing (non-discriminant) components directly in
8856 -- the object declarations, because which fields to
8857 -- initialize depends (at run time) on the discriminant
8861 Make_Object_Declaration (Loc,
8862 Defining_Identifier => Res,
8863 Object_Definition => Res_Definition));
8865 -- ... then all components
8867 FA_Append_Record_Traversal (Stms,
8868 Clist => Component_List (Rdef),
8869 Container => Any_Parameter,
8870 Counter => Component_Counter);
8873 Make_Simple_Return_Statement (Loc,
8874 Expression => New_Occurrence_Of (Res, Loc)));
8878 elsif Is_Array_Type (Typ) then
8880 Constrained : constant Boolean := Is_Constrained (Typ);
8882 procedure FA_Ary_Add_Process_Element
8885 Counter : Entity_Id;
8887 -- Assign the current element (as identified by Counter) of
8888 -- Any to the variable denoted by name Datum, and advance
8889 -- Counter by 1. If Datum is not an Any, a call to From_Any
8890 -- for its type is inserted.
8892 --------------------------------
8893 -- FA_Ary_Add_Process_Element --
8894 --------------------------------
8896 procedure FA_Ary_Add_Process_Element
8899 Counter : Entity_Id;
8902 Assignment : constant Node_Id :=
8903 Make_Assignment_Statement (Loc,
8905 Expression => Empty);
8907 Element_Any : Node_Id;
8911 Element_TC : Node_Id;
8914 if Etype (Datum) = RTE (RE_Any) then
8916 -- When Datum is an Any the Etype field is not
8917 -- sufficient to determine the typecode of Datum
8918 -- (which can be a TC_SEQUENCE or TC_ARRAY
8919 -- depending on the value of Constrained).
8921 -- Therefore we retrieve the typecode which has
8922 -- been constructed in Append_Array_Traversal with
8923 -- a call to Get_Any_Type.
8926 Make_Function_Call (Loc,
8927 Name => New_Occurrence_Of (
8928 RTE (RE_Get_Any_Type), Loc),
8929 Parameter_Associations => New_List (
8930 New_Occurrence_Of (Entity (Datum), Loc)));
8932 -- For non Any Datum we simply construct a typecode
8933 -- matching the Etype of the Datum.
8935 Element_TC := Build_TypeCode_Call
8936 (Loc, Etype (Datum), Decls);
8940 Build_Get_Aggregate_Element (Loc,
8943 Idx => New_Occurrence_Of (Counter, Loc));
8946 -- Note: here we *prepend* statements to Stmts, so
8947 -- we must do it in reverse order.
8950 Make_Assignment_Statement (Loc,
8952 New_Occurrence_Of (Counter, Loc),
8955 Left_Opnd => New_Occurrence_Of (Counter, Loc),
8956 Right_Opnd => Make_Integer_Literal (Loc, 1))));
8958 if Nkind (Datum) /= N_Attribute_Reference then
8960 -- We ignore the value of the length of each
8961 -- dimension, since the target array has already
8962 -- been constrained anyway.
8964 if Etype (Datum) /= RTE (RE_Any) then
8965 Set_Expression (Assignment,
8967 (Component_Type (Typ), Element_Any, Decls));
8969 Set_Expression (Assignment, Element_Any);
8972 Prepend_To (Stmts, Assignment);
8974 end FA_Ary_Add_Process_Element;
8976 ------------------------
8977 -- Local Declarations --
8978 ------------------------
8980 Counter : constant Entity_Id :=
8981 Make_Defining_Identifier (Loc, Name_J);
8983 Initial_Counter_Value : Int := 0;
8985 Component_TC : constant Entity_Id :=
8986 Make_Defining_Identifier (Loc, Name_T);
8988 Res : constant Entity_Id :=
8989 Make_Defining_Identifier (Loc, Name_R);
8991 procedure Append_From_Any_Array_Iterator is
8992 new Append_Array_Traversal (
8995 Indexes => New_List,
8996 Add_Process_Element => FA_Ary_Add_Process_Element);
8998 Res_Subtype_Indication : Node_Id :=
8999 New_Occurrence_Of (Typ, Loc);
9002 if not Constrained then
9004 Ndim : constant Int := Number_Dimensions (Typ);
9007 Indx : Node_Id := First_Index (Typ);
9010 Ranges : constant List_Id := New_List;
9013 for J in 1 .. Ndim loop
9014 Lnam := New_External_Name ('L', J);
9015 Hnam := New_External_Name ('H', J);
9017 -- Note, for empty arrays bounds may be out of
9018 -- the range of Etype (Indx).
9020 Indt := Base_Type (Etype (Indx));
9023 Make_Object_Declaration (Loc,
9024 Defining_Identifier =>
9025 Make_Defining_Identifier (Loc, Lnam),
9026 Constant_Present => True,
9027 Object_Definition =>
9028 New_Occurrence_Of (Indt, Loc),
9032 Build_Get_Aggregate_Element (Loc,
9033 Any => Any_Parameter,
9034 TC => Build_TypeCode_Call
9037 Make_Integer_Literal (Loc, J - 1)),
9041 Make_Object_Declaration (Loc,
9042 Defining_Identifier =>
9043 Make_Defining_Identifier (Loc, Hnam),
9045 Constant_Present => True,
9047 Object_Definition =>
9048 New_Occurrence_Of (Indt, Loc),
9050 Expression => Make_Attribute_Reference (Loc,
9052 New_Occurrence_Of (Indt, Loc),
9054 Attribute_Name => Name_Val,
9056 Expressions => New_List (
9057 Make_Op_Subtract (Loc,
9062 Standard_Long_Integer,
9063 Make_Identifier (Loc, Lnam)),
9067 Standard_Long_Integer,
9068 Make_Function_Call (Loc,
9070 New_Occurrence_Of (RTE (
9071 RE_Get_Nested_Sequence_Length
9073 Parameter_Associations =>
9076 Any_Parameter, Loc),
9077 Make_Integer_Literal (Loc,
9081 Make_Integer_Literal (Loc, 1))))));
9085 Low_Bound => Make_Identifier (Loc, Lnam),
9086 High_Bound => Make_Identifier (Loc, Hnam)));
9091 -- Now we have all the necessary bound information:
9092 -- apply the set of range constraints to the
9093 -- (unconstrained) nominal subtype of Res.
9095 Initial_Counter_Value := Ndim;
9096 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9097 Subtype_Mark => Res_Subtype_Indication,
9099 Make_Index_Or_Discriminant_Constraint (Loc,
9100 Constraints => Ranges));
9105 Make_Object_Declaration (Loc,
9106 Defining_Identifier => Res,
9107 Object_Definition => Res_Subtype_Indication));
9108 Set_Etype (Res, Typ);
9111 Make_Object_Declaration (Loc,
9112 Defining_Identifier => Counter,
9113 Object_Definition =>
9114 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
9116 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9119 Make_Object_Declaration (Loc,
9120 Defining_Identifier => Component_TC,
9121 Constant_Present => True,
9122 Object_Definition =>
9123 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9125 Build_TypeCode_Call (Loc,
9126 Component_Type (Typ), Decls)));
9128 Append_From_Any_Array_Iterator
9129 (Stms, Any_Parameter, Counter);
9132 Make_Simple_Return_Statement (Loc,
9133 Expression => New_Occurrence_Of (Res, Loc)));
9136 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9138 Make_Simple_Return_Statement (Loc,
9140 Unchecked_Convert_To (Typ,
9142 (Find_Numeric_Representation (Typ),
9143 New_Occurrence_Of (Any_Parameter, Loc),
9147 Use_Opaque_Representation := True;
9150 if Use_Opaque_Representation then
9151 Assign_Opaque_From_Any (Loc,
9154 N => New_Occurrence_Of (Any_Parameter, Loc),
9159 Make_Subprogram_Body (Loc,
9160 Specification => Spec,
9161 Declarations => Decls,
9162 Handled_Statement_Sequence =>
9163 Make_Handled_Sequence_Of_Statements (Loc,
9164 Statements => Stms));
9165 end Build_From_Any_Function;
9167 ---------------------------------
9168 -- Build_Get_Aggregate_Element --
9169 ---------------------------------
9171 function Build_Get_Aggregate_Element
9175 Idx : Node_Id) return Node_Id
9178 return Make_Function_Call (Loc,
9180 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc),
9181 Parameter_Associations => New_List (
9182 New_Occurrence_Of (Any, Loc),
9185 end Build_Get_Aggregate_Element;
9187 -------------------------
9188 -- Build_Reposiroty_Id --
9189 -------------------------
9191 procedure Build_Name_And_Repository_Id
9193 Name_Str : out String_Id;
9194 Repo_Id_Str : out String_Id)
9198 Store_String_Chars ("DSA:");
9199 Get_Library_Unit_Name_String (Scope (E));
9201 (Name_Buffer (Name_Buffer'First ..
9202 Name_Buffer'First + Name_Len - 1));
9203 Store_String_Char ('.');
9204 Get_Name_String (Chars (E));
9206 (Name_Buffer (Name_Buffer'First ..
9207 Name_Buffer'First + Name_Len - 1));
9208 Store_String_Chars (":1.0");
9209 Repo_Id_Str := End_String;
9210 Name_Str := String_From_Name_Buffer;
9211 end Build_Name_And_Repository_Id;
9213 -----------------------
9214 -- Build_To_Any_Call --
9215 -----------------------
9217 function Build_To_Any_Call
9219 Decls : List_Id) return Node_Id
9221 Loc : constant Source_Ptr := Sloc (N);
9223 Typ : Entity_Id := Etype (N);
9226 Fnam : Entity_Id := Empty;
9227 Lib_RE : RE_Id := RE_Null;
9230 -- If N is a selected component, then maybe its Etype has not been
9231 -- set yet: try to use Etype of the selector_name in that case.
9233 if No (Typ) and then Nkind (N) = N_Selected_Component then
9234 Typ := Etype (Selector_Name (N));
9237 pragma Assert (Present (Typ));
9239 -- Get full view for private type, completion for incomplete type
9241 U_Type := Underlying_Type (Typ);
9243 -- First simple case where the To_Any function is present in the
9246 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9248 -- For the subtype representing a generic actual type, go to the
9251 if Is_Generic_Actual_Type (U_Type) then
9252 U_Type := Underlying_Type (Base_Type (U_Type));
9255 -- For a standard subtype, go to the base type
9257 if Sloc (U_Type) <= Standard_Location then
9258 U_Type := Base_Type (U_Type);
9261 if Present (Fnam) then
9264 -- Check first for Boolean and Character. These are enumeration
9265 -- types, but we treat them specially, since they may require
9266 -- special handling in the transfer protocol. However, this
9267 -- special handling only applies if they have standard
9268 -- representation, otherwise they are treated like any other
9269 -- enumeration type.
9271 elsif U_Type = Standard_Boolean then
9274 elsif U_Type = Standard_Character then
9277 elsif U_Type = Standard_Wide_Character then
9280 elsif U_Type = Standard_Wide_Wide_Character then
9281 Lib_RE := RE_TA_WWC;
9283 -- Floating point types
9285 elsif U_Type = Standard_Short_Float then
9288 elsif U_Type = Standard_Float then
9291 elsif U_Type = Standard_Long_Float then
9294 elsif U_Type = Standard_Long_Long_Float then
9295 Lib_RE := RE_TA_LLF;
9299 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9300 Lib_RE := RE_TA_SSI;
9302 elsif U_Type = Etype (Standard_Short_Integer) then
9305 elsif U_Type = Etype (Standard_Integer) then
9308 elsif U_Type = Etype (Standard_Long_Integer) then
9311 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9312 Lib_RE := RE_TA_LLI;
9314 -- Unsigned integer types
9316 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9317 Lib_RE := RE_TA_SSU;
9319 elsif U_Type = RTE (RE_Short_Unsigned) then
9322 elsif U_Type = RTE (RE_Unsigned) then
9325 elsif U_Type = RTE (RE_Long_Unsigned) then
9328 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9329 Lib_RE := RE_TA_LLU;
9331 elsif Is_RTE (U_Type, RE_Unbounded_String) then
9332 Lib_RE := RE_TA_String;
9334 -- Special DSA types
9336 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
9340 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9342 -- No corresponding FA_TC ???
9346 -- Other (non-primitive) types
9352 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9353 Append_To (Decls, Decl);
9357 -- Call the function
9359 if Lib_RE /= RE_Null then
9360 pragma Assert (No (Fnam));
9361 Fnam := RTE (Lib_RE);
9364 -- If Fnam is already analyzed, find the proper expected type,
9365 -- else we have a newly constructed To_Any function and we know
9366 -- that the expected type of its parameter is U_Type.
9368 if Ekind (Fnam) = E_Function
9369 and then Present (First_Formal (Fnam))
9371 C_Type := Etype (First_Formal (Fnam));
9377 Make_Function_Call (Loc,
9378 Name => New_Occurrence_Of (Fnam, Loc),
9379 Parameter_Associations =>
9380 New_List (OK_Convert_To (C_Type, N)));
9381 end Build_To_Any_Call;
9383 ---------------------------
9384 -- Build_To_Any_Function --
9385 ---------------------------
9387 procedure Build_To_Any_Function
9391 Fnam : out Entity_Id)
9394 Decls : constant List_Id := New_List;
9395 Stms : constant List_Id := New_List;
9397 Expr_Parameter : Entity_Id;
9399 Result_TC : Node_Id;
9403 Use_Opaque_Representation : Boolean;
9404 -- When True, use stream attributes and represent type as an
9405 -- opaque sequence of bytes.
9408 -- For a derived type, we can't go past the base type (to the
9409 -- parent type) here, because that would cause the attribute's
9410 -- formal parameter to have the wrong type; hence the Base_Type
9413 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
9414 Build_To_Any_Function
9422 Expr_Parameter := Make_Defining_Identifier (Loc, Name_E);
9423 Any := Make_Defining_Identifier (Loc, Name_A);
9424 Result_TC := Build_TypeCode_Call (Loc, Typ, Decls);
9426 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
9429 Make_Function_Specification (Loc,
9430 Defining_Unit_Name => Fnam,
9431 Parameter_Specifications => New_List (
9432 Make_Parameter_Specification (Loc,
9433 Defining_Identifier => Expr_Parameter,
9434 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9435 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9436 Set_Etype (Expr_Parameter, Typ);
9439 Make_Object_Declaration (Loc,
9440 Defining_Identifier => Any,
9441 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9443 Use_Opaque_Representation := False;
9445 if Has_Stream_Attribute_Definition
9446 (Typ, TSS_Stream_Output, At_Any_Place => True)
9448 Has_Stream_Attribute_Definition
9449 (Typ, TSS_Stream_Write, At_Any_Place => True)
9451 -- If user-defined stream attributes are specified for this
9452 -- type, use them and transmit data as an opaque sequence of
9455 Use_Opaque_Representation := True;
9457 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9459 -- Non-tagged derived type: convert to root type
9462 Rt_Type : constant Entity_Id := Root_Type (Typ);
9463 Expr : constant Node_Id :=
9466 New_Occurrence_Of (Expr_Parameter, Loc));
9468 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9471 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9473 -- Non-tagged record type
9475 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9477 Rt_Type : constant Entity_Id := Etype (Typ);
9478 Expr : constant Node_Id :=
9479 OK_Convert_To (Rt_Type,
9480 New_Occurrence_Of (Expr_Parameter, Loc));
9484 (Any_Decl, Build_To_Any_Call (Expr, Decls));
9487 -- Comment needed here (and label on declare block ???)
9491 Disc : Entity_Id := Empty;
9492 Rdef : constant Node_Id :=
9493 Type_Definition (Declaration_Node (Typ));
9495 Elements : constant List_Id := New_List;
9497 procedure TA_Rec_Add_Process_Element
9499 Container : Node_Or_Entity_Id;
9500 Counter : in out Int;
9503 -- Processing routine for traversal below
9505 procedure TA_Append_Record_Traversal is
9506 new Append_Record_Traversal
9507 (Rec => Expr_Parameter,
9508 Add_Process_Element => TA_Rec_Add_Process_Element);
9510 --------------------------------
9511 -- TA_Rec_Add_Process_Element --
9512 --------------------------------
9514 procedure TA_Rec_Add_Process_Element
9516 Container : Node_Or_Entity_Id;
9517 Counter : in out Int;
9521 Field_Ref : Node_Id;
9524 if Nkind (Field) = N_Defining_Identifier then
9526 -- A regular component
9528 Field_Ref := Make_Selected_Component (Loc,
9529 Prefix => New_Occurrence_Of (Rec, Loc),
9530 Selector_Name => New_Occurrence_Of (Field, Loc));
9531 Set_Etype (Field_Ref, Etype (Field));
9534 Make_Procedure_Call_Statement (Loc,
9537 RTE (RE_Add_Aggregate_Element), Loc),
9538 Parameter_Associations => New_List (
9539 New_Occurrence_Of (Container, Loc),
9540 Build_To_Any_Call (Field_Ref, Decls))));
9545 Variant_Part : declare
9547 Struct_Counter : Int := 0;
9549 Block_Decls : constant List_Id := New_List;
9550 Block_Stmts : constant List_Id := New_List;
9553 Alt_List : constant List_Id := New_List;
9554 Choice_List : List_Id;
9556 Union_Any : constant Entity_Id :=
9557 Make_Temporary (Loc, 'V');
9559 Struct_Any : constant Entity_Id :=
9560 Make_Temporary (Loc, 'S');
9562 function Make_Discriminant_Reference
9564 -- Build reference to the discriminant for this
9567 ---------------------------------
9568 -- Make_Discriminant_Reference --
9569 ---------------------------------
9571 function Make_Discriminant_Reference
9574 Nod : constant Node_Id :=
9575 Make_Selected_Component (Loc,
9578 Chars (Name (Field)));
9580 Set_Etype (Nod, Etype (Name (Field)));
9582 end Make_Discriminant_Reference;
9584 -- Start of processing for Variant_Part
9588 Make_Block_Statement (Loc,
9591 Handled_Statement_Sequence =>
9592 Make_Handled_Sequence_Of_Statements (Loc,
9593 Statements => Block_Stmts)));
9595 -- Declare variant part aggregate (Union_Any).
9596 -- Knowing the position of this VP in the
9597 -- variant record, we can fetch the VP typecode
9600 Append_To (Block_Decls,
9601 Make_Object_Declaration (Loc,
9602 Defining_Identifier => Union_Any,
9603 Object_Definition =>
9604 New_Occurrence_Of (RTE (RE_Any), Loc),
9606 Make_Function_Call (Loc,
9607 Name => New_Occurrence_Of (
9608 RTE (RE_Create_Any), Loc),
9609 Parameter_Associations => New_List (
9610 Make_Function_Call (Loc,
9613 RTE (RE_Any_Member_Type), Loc),
9614 Parameter_Associations => New_List (
9615 New_Occurrence_Of (Container, Loc),
9616 Make_Integer_Literal (Loc,
9619 -- Declare inner struct aggregate (which
9620 -- contains the components of this VP).
9622 Append_To (Block_Decls,
9623 Make_Object_Declaration (Loc,
9624 Defining_Identifier => Struct_Any,
9625 Object_Definition =>
9626 New_Occurrence_Of (RTE (RE_Any), Loc),
9628 Make_Function_Call (Loc,
9629 Name => New_Occurrence_Of (
9630 RTE (RE_Create_Any), Loc),
9631 Parameter_Associations => New_List (
9632 Make_Function_Call (Loc,
9635 RTE (RE_Any_Member_Type), Loc),
9636 Parameter_Associations => New_List (
9637 New_Occurrence_Of (Union_Any, Loc),
9638 Make_Integer_Literal (Loc,
9641 -- Build case statement
9643 Append_To (Block_Stmts,
9644 Make_Case_Statement (Loc,
9645 Expression => Make_Discriminant_Reference,
9646 Alternatives => Alt_List));
9648 Variant := First_Non_Pragma (Variants (Field));
9649 while Present (Variant) loop
9650 Choice_List := New_Copy_List_Tree
9651 (Discrete_Choices (Variant));
9653 VP_Stmts := New_List;
9655 -- Append discriminant val to union aggregate
9657 Append_To (VP_Stmts,
9658 Make_Procedure_Call_Statement (Loc,
9661 RTE (RE_Add_Aggregate_Element), Loc),
9662 Parameter_Associations => New_List (
9663 New_Occurrence_Of (Union_Any, Loc),
9665 (Make_Discriminant_Reference,
9668 -- Populate inner struct aggregate
9670 -- Struct_Counter should be reset before
9671 -- handling a variant part. Indeed only one
9672 -- of the case statement alternatives will be
9673 -- executed at run time, so the counter must
9674 -- start at 0 for every case statement.
9676 Struct_Counter := 0;
9678 TA_Append_Record_Traversal
9680 Clist => Component_List (Variant),
9681 Container => Struct_Any,
9682 Counter => Struct_Counter);
9684 -- Append inner struct to union aggregate
9686 Append_To (VP_Stmts,
9687 Make_Procedure_Call_Statement (Loc,
9690 (RTE (RE_Add_Aggregate_Element), Loc),
9691 Parameter_Associations => New_List (
9692 New_Occurrence_Of (Union_Any, Loc),
9693 New_Occurrence_Of (Struct_Any, Loc))));
9695 -- Append union to outer aggregate
9697 Append_To (VP_Stmts,
9698 Make_Procedure_Call_Statement (Loc,
9701 (RTE (RE_Add_Aggregate_Element), Loc),
9702 Parameter_Associations => New_List (
9703 New_Occurrence_Of (Container, Loc),
9705 (Union_Any, Loc))));
9707 Append_To (Alt_List,
9708 Make_Case_Statement_Alternative (Loc,
9709 Discrete_Choices => Choice_List,
9710 Statements => VP_Stmts));
9712 Next_Non_Pragma (Variant);
9717 Counter := Counter + 1;
9718 end TA_Rec_Add_Process_Element;
9721 -- Records are encoded in a TC_STRUCT aggregate:
9723 -- -- Outer aggregate (TC_STRUCT)
9724 -- | [discriminant1]
9725 -- | [discriminant2]
9732 -- A component can be a common component or variant part
9734 -- A variant part is encoded as a TC_UNION aggregate:
9736 -- -- Variant Part Aggregate (TC_UNION)
9737 -- | [discriminant choice for this Variant Part]
9739 -- | -- Inner struct (TC_STRUCT)
9744 -- Let's start by building the outer aggregate. First we
9745 -- construct Elements array containing all discriminants.
9747 if Has_Discriminants (Typ) then
9748 Disc := First_Discriminant (Typ);
9749 while Present (Disc) loop
9751 Discriminant : constant Entity_Id :=
9752 Make_Selected_Component (Loc,
9759 Set_Etype (Discriminant, Etype (Disc));
9761 Append_To (Elements,
9762 Make_Component_Association (Loc,
9763 Choices => New_List (
9764 Make_Integer_Literal (Loc, Counter)),
9766 Build_To_Any_Call (Discriminant, Decls)));
9769 Counter := Counter + 1;
9770 Next_Discriminant (Disc);
9774 -- If there are no discriminants, we declare an empty
9778 Dummy_Any : constant Entity_Id :=
9779 Make_Temporary (Loc, 'A');
9783 Make_Object_Declaration (Loc,
9784 Defining_Identifier => Dummy_Any,
9785 Object_Definition =>
9786 New_Occurrence_Of (RTE (RE_Any), Loc)));
9788 Append_To (Elements,
9789 Make_Component_Association (Loc,
9790 Choices => New_List (
9793 Make_Integer_Literal (Loc, 1),
9795 Make_Integer_Literal (Loc, 0))),
9797 New_Occurrence_Of (Dummy_Any, Loc)));
9801 -- We build the result aggregate with discriminants
9802 -- as the first elements.
9804 Set_Expression (Any_Decl,
9805 Make_Function_Call (Loc,
9806 Name => New_Occurrence_Of
9807 (RTE (RE_Any_Aggregate_Build), Loc),
9808 Parameter_Associations => New_List (
9810 Make_Aggregate (Loc,
9811 Component_Associations => Elements))));
9814 -- Then we append all the components to the result
9817 TA_Append_Record_Traversal (Stms,
9818 Clist => Component_List (Rdef),
9820 Counter => Counter);
9824 elsif Is_Array_Type (Typ) then
9826 -- Constrained and unconstrained array types
9829 Constrained : constant Boolean := Is_Constrained (Typ);
9831 procedure TA_Ary_Add_Process_Element
9834 Counter : Entity_Id;
9837 --------------------------------
9838 -- TA_Ary_Add_Process_Element --
9839 --------------------------------
9841 procedure TA_Ary_Add_Process_Element
9844 Counter : Entity_Id;
9847 pragma Unreferenced (Counter);
9849 Element_Any : Node_Id;
9852 if Etype (Datum) = RTE (RE_Any) then
9853 Element_Any := Datum;
9855 Element_Any := Build_To_Any_Call (Datum, Decls);
9859 Make_Procedure_Call_Statement (Loc,
9860 Name => New_Occurrence_Of (
9861 RTE (RE_Add_Aggregate_Element), Loc),
9862 Parameter_Associations => New_List (
9863 New_Occurrence_Of (Any, Loc),
9865 end TA_Ary_Add_Process_Element;
9867 procedure Append_To_Any_Array_Iterator is
9868 new Append_Array_Traversal (
9870 Arry => Expr_Parameter,
9871 Indexes => New_List,
9872 Add_Process_Element => TA_Ary_Add_Process_Element);
9877 Set_Expression (Any_Decl,
9878 Make_Function_Call (Loc,
9880 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9881 Parameter_Associations => New_List (Result_TC)));
9884 if not Constrained then
9885 Index := First_Index (Typ);
9886 for J in 1 .. Number_Dimensions (Typ) loop
9888 Make_Procedure_Call_Statement (Loc,
9891 RTE (RE_Add_Aggregate_Element), Loc),
9892 Parameter_Associations => New_List (
9893 New_Occurrence_Of (Any, Loc),
9895 OK_Convert_To (Etype (Index),
9896 Make_Attribute_Reference (Loc,
9898 New_Occurrence_Of (Expr_Parameter, Loc),
9899 Attribute_Name => Name_First,
9900 Expressions => New_List (
9901 Make_Integer_Literal (Loc, J)))),
9907 Append_To_Any_Array_Iterator (Stms, Any);
9910 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9914 Set_Expression (Any_Decl,
9917 Find_Numeric_Representation (Typ),
9918 New_Occurrence_Of (Expr_Parameter, Loc)),
9922 -- Default case, including tagged types: opaque representation
9924 Use_Opaque_Representation := True;
9927 if Use_Opaque_Representation then
9929 Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
9930 -- Stream used to store data representation produced by
9931 -- stream attribute.
9935 -- Strm : aliased Buffer_Stream_Type;
9938 Make_Object_Declaration (Loc,
9939 Defining_Identifier =>
9943 Object_Definition =>
9944 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9947 -- T'Output (Strm'Access, E);
9950 Make_Attribute_Reference (Loc,
9951 Prefix => New_Occurrence_Of (Typ, Loc),
9952 Attribute_Name => Name_Output,
9953 Expressions => New_List (
9954 Make_Attribute_Reference (Loc,
9955 Prefix => New_Occurrence_Of (Strm, Loc),
9956 Attribute_Name => Name_Access),
9957 New_Occurrence_Of (Expr_Parameter, Loc))));
9960 -- BS_To_Any (Strm, A);
9963 Make_Procedure_Call_Statement (Loc,
9964 Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
9965 Parameter_Associations => New_List (
9966 New_Occurrence_Of (Strm, Loc),
9967 New_Occurrence_Of (Any, Loc))));
9970 -- Release_Buffer (Strm);
9973 Make_Procedure_Call_Statement (Loc,
9974 Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
9975 Parameter_Associations => New_List (
9976 New_Occurrence_Of (Strm, Loc))));
9980 Append_To (Decls, Any_Decl);
9982 if Present (Result_TC) then
9984 Make_Procedure_Call_Statement (Loc,
9985 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
9986 Parameter_Associations => New_List (
9987 New_Occurrence_Of (Any, Loc),
9992 Make_Simple_Return_Statement (Loc,
9993 Expression => New_Occurrence_Of (Any, Loc)));
9996 Make_Subprogram_Body (Loc,
9997 Specification => Spec,
9998 Declarations => Decls,
9999 Handled_Statement_Sequence =>
10000 Make_Handled_Sequence_Of_Statements (Loc,
10001 Statements => Stms));
10002 end Build_To_Any_Function;
10004 -------------------------
10005 -- Build_TypeCode_Call --
10006 -------------------------
10008 function Build_TypeCode_Call
10011 Decls : List_Id) return Node_Id
10013 U_Type : Entity_Id := Underlying_Type (Typ);
10014 -- The full view, if Typ is private; the completion,
10015 -- if Typ is incomplete.
10017 Fnam : Entity_Id := Empty;
10018 Lib_RE : RE_Id := RE_Null;
10022 -- Special case System.PolyORB.Interface.Any: its primitives have
10023 -- not been set yet, so can't call Find_Inherited_TSS.
10025 if Typ = RTE (RE_Any) then
10026 Fnam := RTE (RE_TC_A);
10029 -- First simple case where the TypeCode is present
10030 -- in the type's TSS.
10032 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10035 -- For the subtype representing a generic actual type, go to the
10038 if Is_Generic_Actual_Type (U_Type) then
10039 U_Type := Underlying_Type (Base_Type (U_Type));
10042 -- For a standard subtype, go to the base type
10044 if Sloc (U_Type) <= Standard_Location then
10045 U_Type := Base_Type (U_Type);
10049 if U_Type = Standard_Boolean then
10052 elsif U_Type = Standard_Character then
10055 elsif U_Type = Standard_Wide_Character then
10056 Lib_RE := RE_TC_WC;
10058 elsif U_Type = Standard_Wide_Wide_Character then
10059 Lib_RE := RE_TC_WWC;
10061 -- Floating point types
10063 elsif U_Type = Standard_Short_Float then
10064 Lib_RE := RE_TC_SF;
10066 elsif U_Type = Standard_Float then
10069 elsif U_Type = Standard_Long_Float then
10070 Lib_RE := RE_TC_LF;
10072 elsif U_Type = Standard_Long_Long_Float then
10073 Lib_RE := RE_TC_LLF;
10075 -- Integer types (walk back to the base type)
10077 elsif U_Type = Etype (Standard_Short_Short_Integer) then
10078 Lib_RE := RE_TC_SSI;
10080 elsif U_Type = Etype (Standard_Short_Integer) then
10081 Lib_RE := RE_TC_SI;
10083 elsif U_Type = Etype (Standard_Integer) then
10086 elsif U_Type = Etype (Standard_Long_Integer) then
10087 Lib_RE := RE_TC_LI;
10089 elsif U_Type = Etype (Standard_Long_Long_Integer) then
10090 Lib_RE := RE_TC_LLI;
10092 -- Unsigned integer types
10094 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
10095 Lib_RE := RE_TC_SSU;
10097 elsif U_Type = RTE (RE_Short_Unsigned) then
10098 Lib_RE := RE_TC_SU;
10100 elsif U_Type = RTE (RE_Unsigned) then
10103 elsif U_Type = RTE (RE_Long_Unsigned) then
10104 Lib_RE := RE_TC_LU;
10106 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
10107 Lib_RE := RE_TC_LLU;
10109 elsif Is_RTE (U_Type, RE_Unbounded_String) then
10110 Lib_RE := RE_TC_String;
10112 -- Special DSA types
10114 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
10117 -- Other (non-primitive) types
10123 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10124 Append_To (Decls, Decl);
10128 if Lib_RE /= RE_Null then
10129 Fnam := RTE (Lib_RE);
10133 -- Call the function
10136 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10138 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10140 Set_Etype (Expr, RTE (RE_TypeCode));
10143 end Build_TypeCode_Call;
10145 -----------------------------
10146 -- Build_TypeCode_Function --
10147 -----------------------------
10149 procedure Build_TypeCode_Function
10152 Decl : out Node_Id;
10153 Fnam : out Entity_Id)
10156 Decls : constant List_Id := New_List;
10157 Stms : constant List_Id := New_List;
10159 TCNam : constant Entity_Id :=
10160 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
10162 Parameters : List_Id;
10164 procedure Add_String_Parameter
10166 Parameter_List : List_Id);
10167 -- Add a literal for S to Parameters
10169 procedure Add_TypeCode_Parameter
10170 (TC_Node : Node_Id;
10171 Parameter_List : List_Id);
10172 -- Add the typecode for Typ to Parameters
10174 procedure Add_Long_Parameter
10175 (Expr_Node : Node_Id;
10176 Parameter_List : List_Id);
10177 -- Add a signed long integer expression to Parameters
10179 procedure Initialize_Parameter_List
10180 (Name_String : String_Id;
10181 Repo_Id_String : String_Id;
10182 Parameter_List : out List_Id);
10183 -- Return a list that contains the first two parameters
10184 -- for a parameterized typecode: name and repository id.
10186 function Make_Constructed_TypeCode
10188 Parameters : List_Id) return Node_Id;
10189 -- Call TC_Build with the given kind and parameters
10191 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10192 -- Make a return statement that calls TC_Build with the given
10193 -- typecode kind, and the constructed parameters list.
10195 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10196 -- Return a typecode that is a TC_Alias for the given typecode
10198 --------------------------
10199 -- Add_String_Parameter --
10200 --------------------------
10202 procedure Add_String_Parameter
10204 Parameter_List : List_Id)
10207 Append_To (Parameter_List,
10208 Make_Function_Call (Loc,
10209 Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc),
10210 Parameter_Associations => New_List (
10211 Make_String_Literal (Loc, S))));
10212 end Add_String_Parameter;
10214 ----------------------------
10215 -- Add_TypeCode_Parameter --
10216 ----------------------------
10218 procedure Add_TypeCode_Parameter
10219 (TC_Node : Node_Id;
10220 Parameter_List : List_Id)
10223 Append_To (Parameter_List,
10224 Make_Function_Call (Loc,
10225 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10226 Parameter_Associations => New_List (TC_Node)));
10227 end Add_TypeCode_Parameter;
10229 ------------------------
10230 -- Add_Long_Parameter --
10231 ------------------------
10233 procedure Add_Long_Parameter
10234 (Expr_Node : Node_Id;
10235 Parameter_List : List_Id)
10238 Append_To (Parameter_List,
10239 Make_Function_Call (Loc,
10240 Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc),
10241 Parameter_Associations => New_List (Expr_Node)));
10242 end Add_Long_Parameter;
10244 -------------------------------
10245 -- Initialize_Parameter_List --
10246 -------------------------------
10248 procedure Initialize_Parameter_List
10249 (Name_String : String_Id;
10250 Repo_Id_String : String_Id;
10251 Parameter_List : out List_Id)
10254 Parameter_List := New_List;
10255 Add_String_Parameter (Name_String, Parameter_List);
10256 Add_String_Parameter (Repo_Id_String, Parameter_List);
10257 end Initialize_Parameter_List;
10259 ---------------------------
10260 -- Return_Alias_TypeCode --
10261 ---------------------------
10263 procedure Return_Alias_TypeCode
10264 (Base_TypeCode : Node_Id)
10267 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10268 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
10269 end Return_Alias_TypeCode;
10271 -------------------------------
10272 -- Make_Constructed_TypeCode --
10273 -------------------------------
10275 function Make_Constructed_TypeCode
10277 Parameters : List_Id) return Node_Id
10279 Constructed_TC : constant Node_Id :=
10280 Make_Function_Call (Loc,
10282 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
10283 Parameter_Associations => New_List (
10284 New_Occurrence_Of (Kind, Loc),
10285 Make_Aggregate (Loc,
10286 Expressions => Parameters)));
10288 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10289 return Constructed_TC;
10290 end Make_Constructed_TypeCode;
10292 ---------------------------------
10293 -- Return_Constructed_TypeCode --
10294 ---------------------------------
10296 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10299 Make_Simple_Return_Statement (Loc,
10301 Make_Constructed_TypeCode (Kind, Parameters)));
10302 end Return_Constructed_TypeCode;
10308 procedure TC_Rec_Add_Process_Element
10311 Counter : in out Int;
10315 procedure TC_Append_Record_Traversal is
10316 new Append_Record_Traversal (
10318 Add_Process_Element => TC_Rec_Add_Process_Element);
10320 --------------------------------
10321 -- TC_Rec_Add_Process_Element --
10322 --------------------------------
10324 procedure TC_Rec_Add_Process_Element
10327 Counter : in out Int;
10331 pragma Unreferenced (Any, Counter, Rec);
10334 if Nkind (Field) = N_Defining_Identifier then
10336 -- A regular component
10338 Add_TypeCode_Parameter
10339 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10340 Get_Name_String (Chars (Field));
10341 Add_String_Parameter (String_From_Name_Buffer, Params);
10348 Discriminant_Type : constant Entity_Id :=
10349 Etype (Name (Field));
10351 Is_Enum : constant Boolean :=
10352 Is_Enumeration_Type (Discriminant_Type);
10354 Union_TC_Params : List_Id;
10356 U_Name : constant Name_Id :=
10357 New_External_Name (Chars (Typ), 'V', -1);
10359 Name_Str : String_Id;
10360 Struct_TC_Params : List_Id;
10364 Default : constant Node_Id :=
10365 Make_Integer_Literal (Loc, -1);
10367 Dummy_Counter : Int := 0;
10369 Choice_Index : Int := 0;
10371 procedure Add_Params_For_Variant_Components;
10372 -- Add a struct TypeCode and a corresponding member name
10373 -- to the union parameter list.
10375 -- Ordering of declarations is a complete mess in this
10376 -- area, it is supposed to be types/variables, then
10377 -- subprogram specs, then subprogram bodies ???
10379 ---------------------------------------
10380 -- Add_Params_For_Variant_Components --
10381 ---------------------------------------
10383 procedure Add_Params_For_Variant_Components
10385 S_Name : constant Name_Id :=
10386 New_External_Name (U_Name, 'S', -1);
10389 Get_Name_String (S_Name);
10390 Name_Str := String_From_Name_Buffer;
10391 Initialize_Parameter_List
10392 (Name_Str, Name_Str, Struct_TC_Params);
10394 -- Build struct parameters
10396 TC_Append_Record_Traversal (Struct_TC_Params,
10397 Component_List (Variant),
10401 Add_TypeCode_Parameter
10402 (Make_Constructed_TypeCode
10403 (RTE (RE_TC_Struct), Struct_TC_Params),
10406 Add_String_Parameter (Name_Str, Union_TC_Params);
10407 end Add_Params_For_Variant_Components;
10410 Get_Name_String (U_Name);
10411 Name_Str := String_From_Name_Buffer;
10413 Initialize_Parameter_List
10414 (Name_Str, Name_Str, Union_TC_Params);
10416 -- Add union in enclosing parameter list
10418 Add_TypeCode_Parameter
10419 (Make_Constructed_TypeCode
10420 (RTE (RE_TC_Union), Union_TC_Params),
10423 Add_String_Parameter (Name_Str, Params);
10425 -- Build union parameters
10427 Add_TypeCode_Parameter
10428 (Build_TypeCode_Call
10429 (Loc, Discriminant_Type, Decls),
10432 Add_Long_Parameter (Default, Union_TC_Params);
10434 Variant := First_Non_Pragma (Variants (Field));
10435 while Present (Variant) loop
10436 Choice := First (Discrete_Choices (Variant));
10437 while Present (Choice) loop
10438 case Nkind (Choice) is
10441 L : constant Uint :=
10442 Expr_Value (Low_Bound (Choice));
10443 H : constant Uint :=
10444 Expr_Value (High_Bound (Choice));
10446 -- 3.8.1(8) guarantees that the bounds of
10447 -- this range are static.
10454 Expr := New_Occurrence_Of (
10455 Get_Enum_Lit_From_Pos (
10456 Discriminant_Type, J, Loc), Loc);
10459 Make_Integer_Literal (Loc, J);
10461 Append_To (Union_TC_Params,
10462 Build_To_Any_Call (Expr, Decls));
10464 Add_Params_For_Variant_Components;
10469 when N_Others_Choice =>
10471 -- This variant possess a default choice.
10472 -- We must therefore set the default
10473 -- parameter to the current choice index. The
10474 -- default parameter is by construction the
10475 -- fourth in the Union_TC_Params list.
10478 Default_Node : constant Node_Id :=
10479 Pick (Union_TC_Params, 4);
10481 New_Default_Node : constant Node_Id :=
10482 Make_Function_Call (Loc,
10485 (RTE (RE_TA_LI), Loc),
10486 Parameter_Associations =>
10488 Make_Integer_Literal
10489 (Loc, Choice_Index)));
10495 Remove (Default_Node);
10498 -- Add a placeholder member label
10499 -- for the default case.
10500 -- It must be of the discriminant type.
10503 Exp : constant Node_Id :=
10504 Make_Attribute_Reference (Loc,
10505 Prefix => New_Occurrence_Of
10506 (Discriminant_Type, Loc),
10507 Attribute_Name => Name_First);
10509 Set_Etype (Exp, Discriminant_Type);
10510 Append_To (Union_TC_Params,
10511 Build_To_Any_Call (Exp, Decls));
10514 Add_Params_For_Variant_Components;
10518 -- Case of an explicit choice
10521 Exp : constant Node_Id :=
10522 New_Copy_Tree (Choice);
10524 Append_To (Union_TC_Params,
10525 Build_To_Any_Call (Exp, Decls));
10528 Add_Params_For_Variant_Components;
10532 Choice_Index := Choice_Index + 1;
10535 Next_Non_Pragma (Variant);
10539 end TC_Rec_Add_Process_Element;
10541 Type_Name_Str : String_Id;
10542 Type_Repo_Id_Str : String_Id;
10544 -- Start of processing for Build_TypeCode_Function
10547 -- For a derived type, we can't go past the base type (to the
10548 -- parent type) here, because that would cause the attribute's
10549 -- formal parameter to have the wrong type; hence the Base_Type
10552 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
10553 Build_TypeCode_Function
10555 Typ => Etype (Typ),
10564 Make_Function_Specification (Loc,
10565 Defining_Unit_Name => Fnam,
10566 Parameter_Specifications => Empty_List,
10567 Result_Definition =>
10568 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10570 Build_Name_And_Repository_Id (Typ,
10571 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10573 Initialize_Parameter_List
10574 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10576 if Has_Stream_Attribute_Definition
10577 (Typ, TSS_Stream_Output, At_Any_Place => True)
10579 Has_Stream_Attribute_Definition
10580 (Typ, TSS_Stream_Write, At_Any_Place => True)
10582 -- If user-defined stream attributes are specified for this
10583 -- type, use them and transmit data as an opaque sequence of
10584 -- stream elements.
10586 Return_Alias_TypeCode
10587 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10589 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
10590 Return_Alias_TypeCode (
10591 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10593 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10594 Return_Alias_TypeCode (
10595 Build_TypeCode_Call (Loc,
10596 Find_Numeric_Representation (Typ), Decls));
10598 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
10600 -- Record typecodes are encoded as follows:
10604 -- | [Repository Id]
10606 -- Then for each discriminant:
10608 -- | [Discriminant Type Code]
10609 -- | [Discriminant Name]
10612 -- Then for each component:
10614 -- | [Component Type Code]
10615 -- | [Component Name]
10618 -- Variants components type codes are encoded as follows:
10622 -- | [Repository Id]
10623 -- | [Discriminant Type Code]
10624 -- | [Index of Default Variant Part or -1 for no default]
10626 -- Then for each Variant Part :
10631 -- | | [Variant Part Name]
10632 -- | | [Variant Part Repository Id]
10634 -- | Then for each VP component:
10635 -- | | [VP component Typecode]
10636 -- | | [VP component Name]
10642 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10643 Return_Alias_TypeCode
10644 (Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10648 Disc : Entity_Id := Empty;
10649 Rdef : constant Node_Id :=
10650 Type_Definition (Declaration_Node (Typ));
10651 Dummy_Counter : Int := 0;
10654 -- Construct the discriminants typecodes
10656 if Has_Discriminants (Typ) then
10657 Disc := First_Discriminant (Typ);
10660 while Present (Disc) loop
10661 Add_TypeCode_Parameter (
10662 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10664 Get_Name_String (Chars (Disc));
10665 Add_String_Parameter (
10666 String_From_Name_Buffer,
10668 Next_Discriminant (Disc);
10671 -- then the components typecodes
10673 TC_Append_Record_Traversal
10674 (Parameters, Component_List (Rdef),
10675 Empty, Dummy_Counter);
10676 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10680 elsif Is_Array_Type (Typ) then
10682 Ndim : constant Pos := Number_Dimensions (Typ);
10683 Inner_TypeCode : Node_Id;
10684 Constrained : constant Boolean := Is_Constrained (Typ);
10685 Indx : Node_Id := First_Index (Typ);
10689 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls);
10691 for J in 1 .. Ndim loop
10692 if Constrained then
10693 Inner_TypeCode := Make_Constructed_TypeCode
10694 (RTE (RE_TC_Array), New_List (
10695 Build_To_Any_Call (
10696 OK_Convert_To (RTE (RE_Long_Unsigned),
10697 Make_Attribute_Reference (Loc,
10698 Prefix => New_Occurrence_Of (Typ, Loc),
10699 Attribute_Name => Name_Length,
10700 Expressions => New_List (
10701 Make_Integer_Literal (Loc,
10702 Intval => Ndim - J + 1)))),
10704 Build_To_Any_Call (Inner_TypeCode, Decls)));
10707 -- Unconstrained case: add low bound for each
10710 Add_TypeCode_Parameter
10711 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10713 Get_Name_String (New_External_Name ('L', J));
10714 Add_String_Parameter (
10715 String_From_Name_Buffer,
10719 Inner_TypeCode := Make_Constructed_TypeCode
10720 (RTE (RE_TC_Sequence), New_List (
10721 Build_To_Any_Call (
10722 OK_Convert_To (RTE (RE_Long_Unsigned),
10723 Make_Integer_Literal (Loc, 0)),
10725 Build_To_Any_Call (Inner_TypeCode, Decls)));
10729 if Constrained then
10730 Return_Alias_TypeCode (Inner_TypeCode);
10732 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10734 Store_String_Char ('V');
10735 Add_String_Parameter (End_String, Parameters);
10736 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10741 -- Default: type is represented as an opaque sequence of bytes
10743 Return_Alias_TypeCode
10744 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10748 Make_Subprogram_Body (Loc,
10749 Specification => Spec,
10750 Declarations => Decls,
10751 Handled_Statement_Sequence =>
10752 Make_Handled_Sequence_Of_Statements (Loc,
10753 Statements => Stms));
10754 end Build_TypeCode_Function;
10756 ---------------------------------
10757 -- Find_Numeric_Representation --
10758 ---------------------------------
10760 function Find_Numeric_Representation
10761 (Typ : Entity_Id) return Entity_Id
10763 FST : constant Entity_Id := First_Subtype (Typ);
10764 P_Size : constant Uint := Esize (FST);
10767 if Is_Unsigned_Type (Typ) then
10768 if P_Size <= Standard_Short_Short_Integer_Size then
10769 return RTE (RE_Short_Short_Unsigned);
10771 elsif P_Size <= Standard_Short_Integer_Size then
10772 return RTE (RE_Short_Unsigned);
10774 elsif P_Size <= Standard_Integer_Size then
10775 return RTE (RE_Unsigned);
10777 elsif P_Size <= Standard_Long_Integer_Size then
10778 return RTE (RE_Long_Unsigned);
10781 return RTE (RE_Long_Long_Unsigned);
10784 elsif Is_Integer_Type (Typ) then
10785 if P_Size <= Standard_Short_Short_Integer_Size then
10786 return Standard_Short_Short_Integer;
10788 elsif P_Size <= Standard_Short_Integer_Size then
10789 return Standard_Short_Integer;
10791 elsif P_Size <= Standard_Integer_Size then
10792 return Standard_Integer;
10794 elsif P_Size <= Standard_Long_Integer_Size then
10795 return Standard_Long_Integer;
10798 return Standard_Long_Long_Integer;
10801 elsif Is_Floating_Point_Type (Typ) then
10802 if P_Size <= Standard_Short_Float_Size then
10803 return Standard_Short_Float;
10805 elsif P_Size <= Standard_Float_Size then
10806 return Standard_Float;
10808 elsif P_Size <= Standard_Long_Float_Size then
10809 return Standard_Long_Float;
10812 return Standard_Long_Long_Float;
10816 raise Program_Error;
10819 -- TBD: fixed point types???
10820 -- TBverified numeric types with a biased representation???
10822 end Find_Numeric_Representation;
10824 ---------------------------
10825 -- Append_Array_Traversal --
10826 ---------------------------
10828 procedure Append_Array_Traversal
10831 Counter : Entity_Id := Empty;
10834 Loc : constant Source_Ptr := Sloc (Subprogram);
10835 Typ : constant Entity_Id := Etype (Arry);
10836 Constrained : constant Boolean := Is_Constrained (Typ);
10837 Ndim : constant Pos := Number_Dimensions (Typ);
10839 Inner_Any, Inner_Counter : Entity_Id;
10841 Loop_Stm : Node_Id;
10842 Inner_Stmts : constant List_Id := New_List;
10845 if Depth > Ndim then
10847 -- Processing for one element of an array
10850 Element_Expr : constant Node_Id :=
10851 Make_Indexed_Component (Loc,
10852 New_Occurrence_Of (Arry, Loc),
10855 Set_Etype (Element_Expr, Component_Type (Typ));
10856 Add_Process_Element (Stmts,
10858 Counter => Counter,
10859 Datum => Element_Expr);
10865 Append_To (Indexes,
10866 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10868 if not Constrained or else Depth > 1 then
10869 Inner_Any := Make_Defining_Identifier (Loc,
10870 New_External_Name ('A', Depth));
10871 Set_Etype (Inner_Any, RTE (RE_Any));
10873 Inner_Any := Empty;
10876 if Present (Counter) then
10877 Inner_Counter := Make_Defining_Identifier (Loc,
10878 New_External_Name ('J', Depth));
10880 Inner_Counter := Empty;
10884 Loop_Any : Node_Id := Inner_Any;
10887 -- For the first dimension of a constrained array, we add
10888 -- elements directly in the corresponding Any; there is no
10889 -- intervening inner Any.
10891 if No (Loop_Any) then
10895 Append_Array_Traversal (Inner_Stmts,
10897 Counter => Inner_Counter,
10898 Depth => Depth + 1);
10902 Make_Implicit_Loop_Statement (Subprogram,
10903 Iteration_Scheme =>
10904 Make_Iteration_Scheme (Loc,
10905 Loop_Parameter_Specification =>
10906 Make_Loop_Parameter_Specification (Loc,
10907 Defining_Identifier =>
10908 Make_Defining_Identifier (Loc,
10909 Chars => New_External_Name ('L', Depth)),
10911 Discrete_Subtype_Definition =>
10912 Make_Attribute_Reference (Loc,
10913 Prefix => New_Occurrence_Of (Arry, Loc),
10914 Attribute_Name => Name_Range,
10916 Expressions => New_List (
10917 Make_Integer_Literal (Loc, Depth))))),
10918 Statements => Inner_Stmts);
10921 Decls : constant List_Id := New_List;
10922 Dimen_Stmts : constant List_Id := New_List;
10923 Length_Node : Node_Id;
10925 Inner_Any_TypeCode : constant Entity_Id :=
10926 Make_Defining_Identifier (Loc,
10927 New_External_Name ('T', Depth));
10929 Inner_Any_TypeCode_Expr : Node_Id;
10933 if Constrained then
10934 Inner_Any_TypeCode_Expr :=
10935 Make_Function_Call (Loc,
10936 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
10937 Parameter_Associations => New_List (
10938 New_Occurrence_Of (Any, Loc)));
10941 Inner_Any_TypeCode_Expr :=
10942 Make_Function_Call (Loc,
10944 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
10945 Parameter_Associations => New_List (
10946 New_Occurrence_Of (Any, Loc),
10947 Make_Integer_Literal (Loc, Ndim)));
10951 Inner_Any_TypeCode_Expr :=
10952 Make_Function_Call (Loc,
10953 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc),
10954 Parameter_Associations => New_List (
10955 Make_Identifier (Loc,
10956 Chars => New_External_Name ('T', Depth - 1))));
10960 Make_Object_Declaration (Loc,
10961 Defining_Identifier => Inner_Any_TypeCode,
10962 Constant_Present => True,
10963 Object_Definition => New_Occurrence_Of (
10964 RTE (RE_TypeCode), Loc),
10965 Expression => Inner_Any_TypeCode_Expr));
10967 if Present (Inner_Any) then
10969 Make_Object_Declaration (Loc,
10970 Defining_Identifier => Inner_Any,
10971 Object_Definition =>
10972 New_Occurrence_Of (RTE (RE_Any), Loc),
10974 Make_Function_Call (Loc,
10976 New_Occurrence_Of (
10977 RTE (RE_Create_Any), Loc),
10978 Parameter_Associations => New_List (
10979 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
10982 if Present (Inner_Counter) then
10984 Make_Object_Declaration (Loc,
10985 Defining_Identifier => Inner_Counter,
10986 Object_Definition =>
10987 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
10989 Make_Integer_Literal (Loc, 0)));
10992 if not Constrained then
10993 Length_Node := Make_Attribute_Reference (Loc,
10994 Prefix => New_Occurrence_Of (Arry, Loc),
10995 Attribute_Name => Name_Length,
10997 New_List (Make_Integer_Literal (Loc, Depth)));
10998 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
11000 Add_Process_Element (Dimen_Stmts,
11001 Datum => Length_Node,
11003 Counter => Inner_Counter);
11006 -- Loop_Stm does appropriate processing for each element
11009 Append_To (Dimen_Stmts, Loop_Stm);
11011 -- Link outer and inner any
11013 if Present (Inner_Any) then
11014 Add_Process_Element (Dimen_Stmts,
11016 Counter => Counter,
11017 Datum => New_Occurrence_Of (Inner_Any, Loc));
11021 Make_Block_Statement (Loc,
11024 Handled_Statement_Sequence =>
11025 Make_Handled_Sequence_Of_Statements (Loc,
11026 Statements => Dimen_Stmts)));
11028 end Append_Array_Traversal;
11030 -------------------------------
11031 -- Make_Helper_Function_Name --
11032 -------------------------------
11034 function Make_Helper_Function_Name
11037 Nam : Name_Id) return Entity_Id
11042 -- For tagged types that aren't frozen yet, generate the helper
11043 -- under its canonical name so that it matches the primitive
11044 -- spec. For all other cases, we use a serialized name so that
11045 -- multiple generations of the same procedure do not clash.
11048 if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then
11051 Serial := Increment_Serial_Number;
11054 -- Use prefixed underscore to avoid potential clash with user
11055 -- identifier (we use attribute names for Nam).
11058 Make_Defining_Identifier (Loc,
11061 (Related_Id => Nam,
11063 Suffix_Index => Serial,
11066 end Make_Helper_Function_Name;
11069 -----------------------------------
11070 -- Reserve_NamingContext_Methods --
11071 -----------------------------------
11073 procedure Reserve_NamingContext_Methods is
11074 Str_Resolve : constant String := "resolve";
11076 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11077 Name_Len := Str_Resolve'Length;
11078 Overload_Counter_Table.Set (Name_Find, 1);
11079 end Reserve_NamingContext_Methods;
11081 end PolyORB_Support;
11083 -------------------------------
11084 -- RACW_Type_Is_Asynchronous --
11085 -------------------------------
11087 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11088 Asynchronous_Flag : constant Entity_Id :=
11089 Asynchronous_Flags_Table.Get (RACW_Type);
11091 Replace (Expression (Parent (Asynchronous_Flag)),
11092 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11093 end RACW_Type_Is_Asynchronous;
11095 -------------------------
11096 -- RCI_Package_Locator --
11097 -------------------------
11099 function RCI_Package_Locator
11101 Package_Spec : Node_Id) return Node_Id
11104 Pkg_Name : String_Id;
11107 Get_Library_Unit_Name_String (Package_Spec);
11108 Pkg_Name := String_From_Name_Buffer;
11110 Make_Package_Instantiation (Loc,
11111 Defining_Unit_Name => Make_Temporary (Loc, 'R'),
11114 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11116 Generic_Associations => New_List (
11117 Make_Generic_Association (Loc,
11119 Make_Identifier (Loc, Name_RCI_Name),
11120 Explicit_Generic_Actual_Parameter =>
11121 Make_String_Literal (Loc,
11122 Strval => Pkg_Name)),
11124 Make_Generic_Association (Loc,
11126 Make_Identifier (Loc, Name_Version),
11127 Explicit_Generic_Actual_Parameter =>
11128 Make_Attribute_Reference (Loc,
11130 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11134 RCI_Locator_Table.Set
11135 (Defining_Unit_Name (Package_Spec),
11136 Defining_Unit_Name (Inst));
11138 end RCI_Package_Locator;
11140 -----------------------------------------------
11141 -- Remote_Types_Tagged_Full_View_Encountered --
11142 -----------------------------------------------
11144 procedure Remote_Types_Tagged_Full_View_Encountered
11145 (Full_View : Entity_Id)
11147 Stub_Elements : constant Stub_Structure :=
11148 Stubs_Table.Get (Full_View);
11151 -- For an RACW encountered before the freeze point of its designated
11152 -- type, the stub type is generated at the point of the RACW declaration
11153 -- but the primitives are generated only once the designated type is
11154 -- frozen. That freeze can occur in another scope, for example when the
11155 -- RACW is declared in a nested package. In that case we need to
11156 -- reestablish the stub type's scope prior to generating its primitive
11159 if Stub_Elements /= Empty_Stub_Structure then
11161 Saved_Scope : constant Entity_Id := Current_Scope;
11162 Stubs_Scope : constant Entity_Id :=
11163 Scope (Stub_Elements.Stub_Type);
11166 if Current_Scope /= Stubs_Scope then
11167 Push_Scope (Stubs_Scope);
11170 Add_RACW_Primitive_Declarations_And_Bodies
11172 Stub_Elements.RPC_Receiver_Decl,
11173 Stub_Elements.Body_Decls);
11175 if Current_Scope /= Saved_Scope then
11180 end Remote_Types_Tagged_Full_View_Encountered;
11182 -------------------
11183 -- Scope_Of_Spec --
11184 -------------------
11186 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11187 Unit_Name : Node_Id;
11190 Unit_Name := Defining_Unit_Name (Spec);
11191 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11192 Unit_Name := Defining_Identifier (Unit_Name);
11198 ----------------------
11199 -- Set_Renaming_TSS --
11200 ----------------------
11202 procedure Set_Renaming_TSS
11205 TSS_Nam : TSS_Name_Type)
11207 Loc : constant Source_Ptr := Sloc (Nam);
11208 Spec : constant Node_Id := Parent (Nam);
11210 TSS_Node : constant Node_Id :=
11211 Make_Subprogram_Renaming_Declaration (Loc,
11213 Copy_Specification (Loc,
11215 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11216 Name => New_Occurrence_Of (Nam, Loc));
11218 Snam : constant Entity_Id :=
11219 Defining_Unit_Name (Specification (TSS_Node));
11222 if Nkind (Spec) = N_Function_Specification then
11223 Set_Ekind (Snam, E_Function);
11224 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11226 Set_Ekind (Snam, E_Procedure);
11227 Set_Etype (Snam, Standard_Void_Type);
11230 Set_TSS (Typ, Snam);
11231 end Set_Renaming_TSS;
11233 ----------------------------------------------
11234 -- Specific_Add_Obj_RPC_Receiver_Completion --
11235 ----------------------------------------------
11237 procedure Specific_Add_Obj_RPC_Receiver_Completion
11240 RPC_Receiver : Entity_Id;
11241 Stub_Elements : Stub_Structure)
11244 case Get_PCS_Name is
11245 when Name_PolyORB_DSA =>
11246 PolyORB_Support.Add_Obj_RPC_Receiver_Completion
11247 (Loc, Decls, RPC_Receiver, Stub_Elements);
11249 GARLIC_Support.Add_Obj_RPC_Receiver_Completion
11250 (Loc, Decls, RPC_Receiver, Stub_Elements);
11252 end Specific_Add_Obj_RPC_Receiver_Completion;
11254 --------------------------------
11255 -- Specific_Add_RACW_Features --
11256 --------------------------------
11258 procedure Specific_Add_RACW_Features
11259 (RACW_Type : Entity_Id;
11261 Stub_Type : Entity_Id;
11262 Stub_Type_Access : Entity_Id;
11263 RPC_Receiver_Decl : Node_Id;
11264 Body_Decls : List_Id)
11267 case Get_PCS_Name is
11268 when Name_PolyORB_DSA =>
11269 PolyORB_Support.Add_RACW_Features
11278 GARLIC_Support.Add_RACW_Features
11285 end Specific_Add_RACW_Features;
11287 --------------------------------
11288 -- Specific_Add_RAST_Features --
11289 --------------------------------
11291 procedure Specific_Add_RAST_Features
11292 (Vis_Decl : Node_Id;
11293 RAS_Type : Entity_Id)
11296 case Get_PCS_Name is
11297 when Name_PolyORB_DSA =>
11298 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11300 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11302 end Specific_Add_RAST_Features;
11304 --------------------------------------------------
11305 -- Specific_Add_Receiving_Stubs_To_Declarations --
11306 --------------------------------------------------
11308 procedure Specific_Add_Receiving_Stubs_To_Declarations
11309 (Pkg_Spec : Node_Id;
11314 case Get_PCS_Name is
11315 when Name_PolyORB_DSA =>
11316 PolyORB_Support.Add_Receiving_Stubs_To_Declarations
11317 (Pkg_Spec, Decls, Stmts);
11319 GARLIC_Support.Add_Receiving_Stubs_To_Declarations
11320 (Pkg_Spec, Decls, Stmts);
11322 end Specific_Add_Receiving_Stubs_To_Declarations;
11324 ------------------------------------------
11325 -- Specific_Build_General_Calling_Stubs --
11326 ------------------------------------------
11328 procedure Specific_Build_General_Calling_Stubs
11330 Statements : List_Id;
11331 Target : RPC_Target;
11332 Subprogram_Id : Node_Id;
11333 Asynchronous : Node_Id := Empty;
11334 Is_Known_Asynchronous : Boolean := False;
11335 Is_Known_Non_Asynchronous : Boolean := False;
11336 Is_Function : Boolean;
11338 Stub_Type : Entity_Id := Empty;
11339 RACW_Type : Entity_Id := Empty;
11343 case Get_PCS_Name is
11344 when Name_PolyORB_DSA =>
11345 PolyORB_Support.Build_General_Calling_Stubs
11351 Is_Known_Asynchronous,
11352 Is_Known_Non_Asynchronous,
11360 GARLIC_Support.Build_General_Calling_Stubs
11364 Target.RPC_Receiver,
11367 Is_Known_Asynchronous,
11368 Is_Known_Non_Asynchronous,
11375 end Specific_Build_General_Calling_Stubs;
11377 --------------------------------------
11378 -- Specific_Build_RPC_Receiver_Body --
11379 --------------------------------------
11381 procedure Specific_Build_RPC_Receiver_Body
11382 (RPC_Receiver : Entity_Id;
11383 Request : out Entity_Id;
11384 Subp_Id : out Entity_Id;
11385 Subp_Index : out Entity_Id;
11386 Stmts : out List_Id;
11387 Decl : out Node_Id)
11390 case Get_PCS_Name is
11391 when Name_PolyORB_DSA =>
11392 PolyORB_Support.Build_RPC_Receiver_Body
11401 GARLIC_Support.Build_RPC_Receiver_Body
11409 end Specific_Build_RPC_Receiver_Body;
11411 --------------------------------
11412 -- Specific_Build_Stub_Target --
11413 --------------------------------
11415 function Specific_Build_Stub_Target
11418 RCI_Locator : Entity_Id;
11419 Controlling_Parameter : Entity_Id) return RPC_Target
11422 case Get_PCS_Name is
11423 when Name_PolyORB_DSA =>
11425 PolyORB_Support.Build_Stub_Target
11426 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11430 GARLIC_Support.Build_Stub_Target
11431 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11433 end Specific_Build_Stub_Target;
11435 ------------------------------
11436 -- Specific_Build_Stub_Type --
11437 ------------------------------
11439 procedure Specific_Build_Stub_Type
11440 (RACW_Type : Entity_Id;
11441 Stub_Type_Comps : out List_Id;
11442 RPC_Receiver_Decl : out Node_Id)
11445 case Get_PCS_Name is
11446 when Name_PolyORB_DSA =>
11447 PolyORB_Support.Build_Stub_Type
11448 (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
11451 GARLIC_Support.Build_Stub_Type
11452 (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
11454 end Specific_Build_Stub_Type;
11456 -----------------------------------------------
11457 -- Specific_Build_Subprogram_Receiving_Stubs --
11458 -----------------------------------------------
11460 function Specific_Build_Subprogram_Receiving_Stubs
11461 (Vis_Decl : Node_Id;
11462 Asynchronous : Boolean;
11463 Dynamically_Asynchronous : Boolean := False;
11464 Stub_Type : Entity_Id := Empty;
11465 RACW_Type : Entity_Id := Empty;
11466 Parent_Primitive : Entity_Id := Empty) return Node_Id
11469 case Get_PCS_Name is
11470 when Name_PolyORB_DSA =>
11472 PolyORB_Support.Build_Subprogram_Receiving_Stubs
11475 Dynamically_Asynchronous,
11482 GARLIC_Support.Build_Subprogram_Receiving_Stubs
11485 Dynamically_Asynchronous,
11490 end Specific_Build_Subprogram_Receiving_Stubs;
11492 -------------------------------
11493 -- Transmit_As_Unconstrained --
11494 -------------------------------
11496 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
11499 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
11500 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
11501 end Transmit_As_Unconstrained;
11503 --------------------------
11504 -- Underlying_RACW_Type --
11505 --------------------------
11507 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11508 Record_Type : Entity_Id;
11511 if Ekind (RAS_Typ) = E_Record_Type then
11512 Record_Type := RAS_Typ;
11514 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11515 Record_Type := Equivalent_Type (RAS_Typ);
11519 Etype (Subtype_Indication
11520 (Component_Definition
11521 (First (Component_Items
11524 (Declaration_Node (Record_Type))))))));
11525 end Underlying_RACW_Type;