1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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 Errout; use Errout;
30 with Exp_Atag; use Exp_Atag;
31 with Exp_Disp; use Exp_Disp;
32 with Exp_Strm; use Exp_Strm;
33 with Exp_Tss; use Exp_Tss;
34 with Exp_Util; use Exp_Util;
36 with Nlists; use Nlists;
37 with Nmake; use Nmake;
39 with Rtsfind; use Rtsfind;
41 with Sem_Aux; use Sem_Aux;
42 with Sem_Cat; use Sem_Cat;
43 with Sem_Ch3; use Sem_Ch3;
44 with Sem_Ch8; use Sem_Ch8;
45 with Sem_Ch12; use Sem_Ch12;
46 with Sem_Dist; use Sem_Dist;
47 with Sem_Eval; use Sem_Eval;
48 with Sem_Util; use Sem_Util;
49 with Sinfo; use Sinfo;
50 with Stand; use Stand;
51 with Stringt; use Stringt;
52 with Tbuild; use Tbuild;
53 with Ttypes; use Ttypes;
54 with Uintp; use Uintp;
56 with GNAT.HTable; use GNAT.HTable;
58 package body Exp_Dist is
60 -- The following model has been used to implement distributed objects:
61 -- given a designated type D and a RACW type R, then a record of the form:
63 -- type Stub is tagged record
64 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
67 -- is built. This type has two properties:
69 -- 1) Since it has the same structure as RACW_Stub_Type, it can
70 -- be converted to and from this type to make it suitable for
71 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
72 -- to avoid memory leaks when the same remote object arrives on the
73 -- same partition through several paths;
75 -- 2) It also has the same dispatching table as the designated type D,
76 -- and thus can be used as an object designated by a value of type
77 -- R on any partition other than the one on which the object has
78 -- been created, since only dispatching calls will be performed and
79 -- the fields themselves will not be used. We call Derive_Subprograms
80 -- to fake half a derivation to ensure that the subprograms do have
81 -- the same dispatching table.
83 First_RCI_Subprogram_Id : constant := 2;
84 -- RCI subprograms are numbered starting at 2. The RCI receiver for
85 -- an RCI package can thus identify calls received through remote
86 -- access-to-subprogram dereferences by the fact that they have a
87 -- (primitive) subprogram id of 0, and 1 is used for the internal RAS
88 -- information lookup operation. (This is for the Garlic code generation,
89 -- where subprograms are identified by numbers; in the PolyORB version,
90 -- they are identified by name, with a numeric suffix for homonyms.)
92 type Hash_Index is range 0 .. 50;
94 -----------------------
95 -- Local subprograms --
96 -----------------------
98 function Hash (F : Entity_Id) return Hash_Index;
99 -- DSA expansion associates stubs to distributed object types using a hash
100 -- table on entity ids.
102 function Hash (F : Name_Id) return Hash_Index;
103 -- The generation of subprogram identifiers requires an overload counter
104 -- to be associated with each remote subprogram name. These counters are
105 -- maintained in a hash table on name ids.
107 type Subprogram_Identifiers is record
108 Str_Identifier : String_Id;
109 Int_Identifier : Int;
112 package Subprogram_Identifier_Table is
113 new Simple_HTable (Header_Num => Hash_Index,
114 Element => Subprogram_Identifiers,
115 No_Element => (No_String, 0),
119 -- Mapping between a remote subprogram and the corresponding subprogram
122 package Overload_Counter_Table is
123 new Simple_HTable (Header_Num => Hash_Index,
129 -- Mapping between a subprogram name and an integer that counts the number
130 -- of defining subprogram names with that Name_Id encountered so far in a
131 -- given context (an interface).
133 function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
134 function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
135 function Get_Subprogram_Id (Def : Entity_Id) return Int;
136 -- Given a subprogram defined in a RCI package, get its distribution
137 -- subprogram identifiers (the distribution identifiers are a unique
138 -- subprogram number, and the non-qualified subprogram name, in the
139 -- casing used for the subprogram declaration; if the name is overloaded,
140 -- a double underscore and a serial number are appended.
142 -- The integer identifier is used to perform remote calls with GARLIC;
143 -- the string identifier is used in the case of PolyORB.
145 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
146 -- when receiving a call, the calling stubs will create requests with the
147 -- exact casing of the defining unit name of the called subprogram, so as
148 -- to allow calls to subprograms on distributed nodes that do distinguish
151 -- NOTE: Another design would be to allow a representation clause on
152 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
154 pragma Warnings (Off, Get_Subprogram_Id);
155 -- One homonym only is unreferenced (specific to the GARLIC version)
157 procedure Add_RAS_Dereference_TSS (N : Node_Id);
158 -- Add a subprogram body for RAS Dereference TSS
160 procedure Add_RAS_Proxy_And_Analyze
163 All_Calls_Remote_E : Entity_Id;
164 Proxy_Object_Addr : out Entity_Id);
165 -- Add the proxy type required, on the receiving (server) side, to handle
166 -- calls to the subprogram declared by Vis_Decl through a remote access
167 -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
168 -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
169 -- is appended to Decls. Proxy_Object_Addr is a constant of type
170 -- System.Address that designates an instance of the proxy object.
172 function Build_Remote_Subprogram_Proxy_Type
174 ACR_Expression : Node_Id) return Node_Id;
175 -- Build and return a tagged record type definition for an RCI subprogram
176 -- proxy type. ACR_Expression is used as the initialization value for the
177 -- All_Calls_Remote component.
179 function Build_Get_Unique_RP_Call
182 Stub_Type : Entity_Id) return List_Id;
183 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
184 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
185 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
187 function Build_Stub_Tag
189 RACW_Type : Entity_Id) return Node_Id;
190 -- Return an expression denoting the tag of the stub type associated with
193 function Build_Subprogram_Calling_Stubs
196 Asynchronous : Boolean;
197 Dynamically_Asynchronous : Boolean := False;
198 Stub_Type : Entity_Id := Empty;
199 RACW_Type : Entity_Id := Empty;
200 Locator : Entity_Id := Empty;
201 New_Name : Name_Id := No_Name) return Node_Id;
202 -- Build the calling stub for a given subprogram with the subprogram ID
203 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
204 -- parameters of this type will be marshalled instead of the object itself.
205 -- It will then be converted into Stub_Type before performing the real
206 -- call. If Dynamically_Asynchronous is True, then it will be computed at
207 -- run time whether the call is asynchronous or not. Otherwise, the value
208 -- of the formal Asynchronous will be used. If Locator is not Empty, it
209 -- will be used instead of RCI_Cache. If New_Name is given, then it will
210 -- be used instead of the original name.
212 function Build_RPC_Receiver_Specification
213 (RPC_Receiver : Entity_Id;
214 Request_Parameter : Entity_Id) return Node_Id;
215 -- Make a subprogram specification for an RPC receiver, with the given
216 -- defining unit name and formal parameter.
218 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
219 -- Return an ordered parameter list: unconstrained parameters are put
220 -- at the beginning of the list and constrained ones are put after. If
221 -- there are no parameters, an empty list is returned. Special case:
222 -- the controlling formal of the equivalent RACW operation for a RAS
223 -- type is always left in first position.
225 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean;
226 -- True when Typ is an unconstrained type, or a null-excluding access type.
227 -- In either case, this means stubs cannot contain a default-initialized
228 -- object declaration of such type.
230 procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id);
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, in the case of GARLIC, for an RACW
332 -- that 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 function Specific_RPC_Receiver_Decl
563 (RACW_Type : Entity_Id) return Node_Id;
564 -- Build the RPC receiver, for RACW, if applicable, else return Empty
566 procedure Specific_Build_RPC_Receiver_Body
567 (RPC_Receiver : Entity_Id;
568 Request : out Entity_Id;
569 Subp_Id : out Entity_Id;
570 Subp_Index : out Entity_Id;
573 -- Make a subprogram body for an RPC receiver, with the given
574 -- defining unit name. On return:
575 -- - Subp_Id is the subprogram identifier from the PCS.
576 -- - Subp_Index is the index in the list of subprograms
577 -- used for dispatching (a variable of type Subprogram_Id).
578 -- - Stmts is the place where the request dispatching
579 -- statements can occur,
580 -- - Decl is the subprogram body declaration.
582 function Specific_Build_Subprogram_Receiving_Stubs
584 Asynchronous : Boolean;
585 Dynamically_Asynchronous : Boolean := False;
586 Stub_Type : Entity_Id := Empty;
587 RACW_Type : Entity_Id := Empty;
588 Parent_Primitive : Entity_Id := Empty) return Node_Id;
589 -- Build the receiving stub for a given subprogram. The subprogram
590 -- declaration is also built by this procedure, and the value returned
591 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
592 -- found in the specification, then its address is read from the stream
593 -- instead of the object itself and converted into an access to
594 -- class-wide type before doing the real call using any of the RACW type
595 -- pointing on the designated type.
597 procedure Specific_Add_Obj_RPC_Receiver_Completion
600 RPC_Receiver : Entity_Id;
601 Stub_Elements : Stub_Structure);
602 -- Add the necessary code to Decls after the completion of generation
603 -- of the RACW RPC receiver described by Stub_Elements.
605 procedure Specific_Add_Receiving_Stubs_To_Declarations
609 -- Add receiving stubs to the declarative part of an RCI unit
615 package GARLIC_Support is
617 -- Support for generating DSA code that uses the GARLIC PCS
619 -- The subprograms below provide the GARLIC versions of the
620 -- corresponding Specific_<subprogram> routine declared above.
622 procedure Add_RACW_Features
623 (RACW_Type : Entity_Id;
624 Stub_Type : Entity_Id;
625 Stub_Type_Access : Entity_Id;
626 RPC_Receiver_Decl : Node_Id;
627 Body_Decls : List_Id);
629 procedure Add_RAST_Features
631 RAS_Type : Entity_Id);
633 procedure Build_General_Calling_Stubs
635 Statements : List_Id;
636 Target_Partition : Entity_Id; -- From RPC_Target
637 Target_RPC_Receiver : Node_Id; -- From RPC_Target
638 Subprogram_Id : Node_Id;
639 Asynchronous : Node_Id := Empty;
640 Is_Known_Asynchronous : Boolean := False;
641 Is_Known_Non_Asynchronous : Boolean := False;
642 Is_Function : Boolean;
644 Stub_Type : Entity_Id := Empty;
645 RACW_Type : Entity_Id := Empty;
648 function Build_Stub_Target
651 RCI_Locator : Entity_Id;
652 Controlling_Parameter : Entity_Id) return RPC_Target;
654 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id;
656 function Build_Subprogram_Receiving_Stubs
658 Asynchronous : Boolean;
659 Dynamically_Asynchronous : Boolean := False;
660 Stub_Type : Entity_Id := Empty;
661 RACW_Type : Entity_Id := Empty;
662 Parent_Primitive : Entity_Id := Empty) return Node_Id;
664 procedure Add_Obj_RPC_Receiver_Completion
667 RPC_Receiver : Entity_Id;
668 Stub_Elements : Stub_Structure);
670 procedure Add_Receiving_Stubs_To_Declarations
675 procedure Build_RPC_Receiver_Body
676 (RPC_Receiver : Entity_Id;
677 Request : out Entity_Id;
678 Subp_Id : out Entity_Id;
679 Subp_Index : out Entity_Id;
685 ---------------------
686 -- PolyORB_Support --
687 ---------------------
689 package PolyORB_Support is
691 -- Support for generating DSA code that uses the PolyORB PCS
693 -- The subprograms below provide the PolyORB versions of the
694 -- corresponding Specific_<subprogram> routine declared above.
696 procedure Add_RACW_Features
697 (RACW_Type : Entity_Id;
699 Stub_Type : Entity_Id;
700 Stub_Type_Access : Entity_Id;
701 RPC_Receiver_Decl : Node_Id;
702 Body_Decls : List_Id);
704 procedure Add_RAST_Features
706 RAS_Type : Entity_Id);
708 procedure Build_General_Calling_Stubs
710 Statements : List_Id;
711 Target_Object : Node_Id; -- From RPC_Target
712 Subprogram_Id : Node_Id;
713 Asynchronous : Node_Id := Empty;
714 Is_Known_Asynchronous : Boolean := False;
715 Is_Known_Non_Asynchronous : Boolean := False;
716 Is_Function : Boolean;
718 Stub_Type : Entity_Id := Empty;
719 RACW_Type : Entity_Id := Empty;
722 function Build_Stub_Target
725 RCI_Locator : Entity_Id;
726 Controlling_Parameter : Entity_Id) return RPC_Target;
728 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id;
730 function Build_Subprogram_Receiving_Stubs
732 Asynchronous : Boolean;
733 Dynamically_Asynchronous : Boolean := False;
734 Stub_Type : Entity_Id := Empty;
735 RACW_Type : Entity_Id := Empty;
736 Parent_Primitive : Entity_Id := Empty) return Node_Id;
738 procedure Add_Obj_RPC_Receiver_Completion
741 RPC_Receiver : Entity_Id;
742 Stub_Elements : Stub_Structure);
744 procedure Add_Receiving_Stubs_To_Declarations
749 procedure Build_RPC_Receiver_Body
750 (RPC_Receiver : Entity_Id;
751 Request : out Entity_Id;
752 Subp_Id : out Entity_Id;
753 Subp_Index : out Entity_Id;
757 procedure Reserve_NamingContext_Methods;
758 -- Mark the method names for interface NamingContext as already used in
759 -- the overload table, so no clashes occur with user code (with the
760 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
761 -- their methods to be accessed as objects, for the implementation of
762 -- remote access-to-subprogram types).
770 -- Routines to build distribution helper subprograms for user-defined
771 -- types. For implementation of the Distributed systems annex (DSA)
772 -- over the PolyORB generic middleware components, it is necessary to
773 -- generate several supporting subprograms for each application data
774 -- type used in inter-partition communication. These subprograms are:
776 -- A Typecode function returning a high-level description of the
779 -- Two conversion functions allowing conversion of values of the
780 -- type from and to the generic data containers used by PolyORB.
781 -- These generic containers are called 'Any' type values after the
782 -- CORBA terminology, and hence the conversion subprograms are
783 -- named To_Any and From_Any.
785 function Build_From_Any_Call
788 Decls : List_Id) return Node_Id;
789 -- Build call to From_Any attribute function of type Typ with
790 -- expression N as actual parameter. Decls is the declarations list
791 -- for an appropriate enclosing scope of the point where the call
792 -- will be inserted; if the From_Any attribute for Typ needs to be
793 -- generated at this point, its declaration is appended to Decls.
795 procedure Build_From_Any_Function
799 Fnam : out Entity_Id);
800 -- Build From_Any attribute function for Typ. Loc is the reference
801 -- location for generated nodes, Typ is the type for which the
802 -- conversion function is generated. On return, Decl and Fnam contain
803 -- the declaration and entity for the newly-created function.
805 function Build_To_Any_Call
807 Decls : List_Id) return Node_Id;
808 -- Build call to To_Any attribute function with expression as actual
809 -- parameter. Decls is the declarations list for an appropriate
810 -- enclosing scope of the point where the call will be inserted; if
811 -- the To_Any attribute for Typ needs to be generated at this point,
812 -- its declaration is appended to Decls.
814 procedure Build_To_Any_Function
818 Fnam : out Entity_Id);
819 -- Build To_Any attribute function for Typ. Loc is the reference
820 -- location for generated nodes, Typ is the type for which the
821 -- conversion function is generated. On return, Decl and Fnam contain
822 -- the declaration and entity for the newly-created function.
824 function Build_TypeCode_Call
827 Decls : List_Id) return Node_Id;
828 -- Build call to TypeCode attribute function for Typ. Decls is the
829 -- declarations list for an appropriate enclosing scope of the point
830 -- where the call will be inserted; if the To_Any attribute for Typ
831 -- needs to be generated at this point, its declaration is appended
834 procedure Build_TypeCode_Function
838 Fnam : out Entity_Id);
839 -- Build TypeCode attribute function for Typ. Loc is the reference
840 -- location for generated nodes, Typ is the type for which the
841 -- conversion function is generated. On return, Decl and Fnam contain
842 -- the declaration and entity for the newly-created function.
844 procedure Build_Name_And_Repository_Id
846 Name_Str : out String_Id;
847 Repo_Id_Str : out String_Id);
848 -- In the PolyORB distribution model, each distributed object type
849 -- and each distributed operation has a globally unique identifier,
850 -- its Repository Id. This subprogram builds and returns two strings
851 -- for entity E (a distributed object type or operation): one
852 -- containing the name of E, the second containing its repository id.
854 procedure Assign_Opaque_From_Any
860 -- For a Target object of type Typ, which has opaque representation
861 -- as a sequence of octets determined by stream attributes (which
862 -- includes all limited types), append code to Stmts performing the
864 -- Target := Typ'From_Any (N)
866 -- or, if Target is Empty:
867 -- return Typ'From_Any (N)
873 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
875 function Build_From_Any_Call
878 Decls : List_Id) return Node_Id
879 renames PolyORB_Support.Helpers.Build_From_Any_Call;
881 function Build_To_Any_Call
883 Decls : List_Id) return Node_Id
884 renames PolyORB_Support.Helpers.Build_To_Any_Call;
886 function Build_TypeCode_Call
889 Decls : List_Id) return Node_Id
890 renames PolyORB_Support.Helpers.Build_TypeCode_Call;
892 ------------------------------------
893 -- Local variables and structures --
894 ------------------------------------
897 -- Needs comments ???
899 Output_From_Constrained : constant array (Boolean) of Name_Id :=
900 (False => Name_Output,
902 -- The attribute to choose depending on the fact that the parameter
903 -- is constrained or not. There is no such thing as Input_From_Constrained
904 -- since this require separate mechanisms ('Input is a function while
905 -- 'Read is a procedure).
908 with procedure Process_Subprogram_Declaration (Decl : Node_Id);
909 -- Generate calling or receiving stub for this subprogram declaration
911 procedure Build_Package_Stubs (Pkg_Spec : Node_Id);
912 -- Recursively visit the given RCI Package_Specification, calling
913 -- Process_Subprogram_Declaration for each remote subprogram.
915 -------------------------
916 -- Build_Package_Stubs --
917 -------------------------
919 procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is
920 Decls : constant List_Id := Visible_Declarations (Pkg_Spec);
923 procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id);
924 -- Recurse for the given nested package declaration
926 -----------------------
927 -- Visit_Nested_Spec --
928 -----------------------
930 procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is
931 Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl);
933 Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec));
934 Build_Package_Stubs (Nested_Pkg_Spec);
936 end Visit_Nested_Pkg;
938 -- Start of processing for Build_Package_Stubs
941 Decl := First (Decls);
942 while Present (Decl) loop
944 when N_Subprogram_Declaration =>
946 -- Note: we test Comes_From_Source on Spec, not Decl, because
947 -- in the case of a subprogram instance, only the specification
948 -- (not the declaration) is marked as coming from source.
950 if Comes_From_Source (Specification (Decl)) then
951 Process_Subprogram_Declaration (Decl);
954 when N_Package_Declaration =>
956 -- Case of a nested package or package instantiation coming
957 -- from source. Note that the anonymous wrapper package for
958 -- subprogram instances is not flagged Is_Generic_Instance at
959 -- this point, so there is a distinct circuit to handle them
960 -- (see case N_Subprogram_Instantiation below).
963 Pkg_Ent : constant Entity_Id :=
964 Defining_Unit_Name (Specification (Decl));
966 if Comes_From_Source (Decl)
968 (Is_Generic_Instance (Pkg_Ent)
969 and then Comes_From_Source
970 (Get_Package_Instantiation_Node (Pkg_Ent)))
972 Visit_Nested_Pkg (Decl);
976 when N_Subprogram_Instantiation =>
978 -- The subprogram declaration for an instance of a generic
979 -- subprogram is wrapped in a package that does not come from
980 -- source, so we need to explicitly traverse it here.
982 if Comes_From_Source (Decl) then
983 Visit_Nested_Pkg (Instance_Spec (Decl));
991 end Build_Package_Stubs;
993 ---------------------------------------
994 -- Add_Calling_Stubs_To_Declarations --
995 ---------------------------------------
997 procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is
998 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
1000 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
1001 -- Subprogram id 0 is reserved for calls received from
1002 -- remote access-to-subprogram dereferences.
1004 RCI_Instantiation : Node_Id;
1006 procedure Visit_Subprogram (Decl : Node_Id);
1007 -- Generate calling stub for one remote subprogram
1009 ----------------------
1010 -- Visit_Subprogram --
1011 ----------------------
1013 procedure Visit_Subprogram (Decl : Node_Id) is
1014 Loc : constant Source_Ptr := Sloc (Decl);
1015 Spec : constant Node_Id := Specification (Decl);
1016 Subp_Stubs : Node_Id;
1018 Subp_Str : String_Id;
1019 pragma Warnings (Off, Subp_Str);
1022 -- Disable expansion of stubs if serious errors have been diagnosed,
1023 -- because otherwise some illegal remote subprogram declarations
1024 -- could cause cascaded errors in stubs.
1026 if Serious_Errors_Detected /= 0 then
1030 Assign_Subprogram_Identifier
1031 (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str);
1034 Build_Subprogram_Calling_Stubs
1037 Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)),
1039 Nkind (Spec) = N_Procedure_Specification
1040 and then Is_Asynchronous (Defining_Unit_Name (Spec)));
1042 Append_To (List_Containing (Decl), Subp_Stubs);
1043 Analyze (Subp_Stubs);
1045 Current_Subprogram_Number := Current_Subprogram_Number + 1;
1046 end Visit_Subprogram;
1048 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
1050 -- Start of processing for Add_Calling_Stubs_To_Declarations
1053 Push_Scope (Scope_Of_Spec (Pkg_Spec));
1055 -- The first thing added is an instantiation of the generic package
1056 -- System.Partition_Interface.RCI_Locator with the name of this remote
1057 -- package. This will act as an interface with the name server to
1058 -- determine the Partition_ID and the RPC_Receiver for the receiver
1061 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
1062 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
1064 Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation);
1065 Analyze (RCI_Instantiation);
1067 -- For each subprogram declaration visible in the spec, we do build a
1068 -- body. We also increment a counter to assign a different Subprogram_Id
1069 -- to each subprogram. The receiving stubs processing uses the same
1070 -- mechanism and will thus assign the same Id and do the correct
1073 Overload_Counter_Table.Reset;
1074 PolyORB_Support.Reserve_NamingContext_Methods;
1076 Visit_Spec (Pkg_Spec);
1079 end Add_Calling_Stubs_To_Declarations;
1081 -----------------------------
1082 -- Add_Parameter_To_NVList --
1083 -----------------------------
1085 function Add_Parameter_To_NVList
1088 Parameter : Entity_Id;
1089 Constrained : Boolean;
1090 RACW_Ctrl : Boolean := False;
1091 Any : Entity_Id) return Node_Id
1093 Parameter_Name_String : String_Id;
1094 Parameter_Mode : Node_Id;
1096 function Parameter_Passing_Mode
1098 Parameter : Entity_Id;
1099 Constrained : Boolean) return Node_Id;
1100 -- Return an expression that denotes the parameter passing mode to be
1101 -- used for Parameter in distribution stubs, where Constrained is
1102 -- Parameter's constrained status.
1104 ----------------------------
1105 -- Parameter_Passing_Mode --
1106 ----------------------------
1108 function Parameter_Passing_Mode
1110 Parameter : Entity_Id;
1111 Constrained : Boolean) return Node_Id
1116 if Out_Present (Parameter) then
1117 if In_Present (Parameter)
1118 or else not Constrained
1120 -- Unconstrained formals must be translated
1121 -- to 'in' or 'inout', not 'out', because
1122 -- they need to be constrained by the actual.
1124 Lib_RE := RE_Mode_Inout;
1126 Lib_RE := RE_Mode_Out;
1130 Lib_RE := RE_Mode_In;
1133 return New_Occurrence_Of (RTE (Lib_RE), Loc);
1134 end Parameter_Passing_Mode;
1136 -- Start of processing for Add_Parameter_To_NVList
1139 if Nkind (Parameter) = N_Defining_Identifier then
1140 Get_Name_String (Chars (Parameter));
1142 Get_Name_String (Chars (Defining_Identifier (Parameter)));
1145 Parameter_Name_String := String_From_Name_Buffer;
1147 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1149 -- When the parameter passed to Add_Parameter_To_NVList is an
1150 -- Extra_Constrained parameter, Parameter is an N_Defining_
1151 -- Identifier, instead of a complete N_Parameter_Specification.
1152 -- Thus, we explicitly set 'in' mode in this case.
1154 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1158 Parameter_Passing_Mode (Loc, Parameter, Constrained);
1162 Make_Procedure_Call_Statement (Loc,
1165 (RTE (RE_NVList_Add_Item), Loc),
1166 Parameter_Associations => New_List (
1167 New_Occurrence_Of (NVList, Loc),
1168 Make_Function_Call (Loc,
1171 (RTE (RE_To_PolyORB_String), Loc),
1172 Parameter_Associations => New_List (
1173 Make_String_Literal (Loc,
1174 Strval => Parameter_Name_String))),
1175 New_Occurrence_Of (Any, Loc),
1177 end Add_Parameter_To_NVList;
1179 --------------------------------
1180 -- Add_RACW_Asynchronous_Flag --
1181 --------------------------------
1183 procedure Add_RACW_Asynchronous_Flag
1184 (Declarations : List_Id;
1185 RACW_Type : Entity_Id)
1187 Loc : constant Source_Ptr := Sloc (RACW_Type);
1189 Asynchronous_Flag : constant Entity_Id :=
1190 Make_Defining_Identifier (Loc,
1191 New_External_Name (Chars (RACW_Type), 'A'));
1194 -- Declare the asynchronous flag. This flag will be changed to True
1195 -- whenever it is known that the RACW type is asynchronous.
1197 Append_To (Declarations,
1198 Make_Object_Declaration (Loc,
1199 Defining_Identifier => Asynchronous_Flag,
1200 Constant_Present => True,
1201 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1202 Expression => New_Occurrence_Of (Standard_False, Loc)));
1204 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1205 end Add_RACW_Asynchronous_Flag;
1207 -----------------------
1208 -- Add_RACW_Features --
1209 -----------------------
1211 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1212 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1213 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1217 Body_Decls : List_Id;
1219 Stub_Type : Entity_Id;
1220 Stub_Type_Access : Entity_Id;
1221 RPC_Receiver_Decl : Node_Id;
1224 -- True when appropriate stubs have already been generated (this is the
1225 -- case when another RACW with the same designated type has already been
1226 -- encountered), in which case we reuse the previous stubs rather than
1227 -- generating new ones.
1230 if not Expander_Active then
1234 -- Mark the current package declaration as containing an RACW, so that
1235 -- the bodies for the calling stubs and the RACW stream subprograms
1236 -- are attached to the tree when the corresponding body is encountered.
1238 Set_Has_RACW (Current_Scope);
1240 -- Look for place to declare the RACW stub type and RACW operations
1246 -- Case of declaring the RACW in the same package as its designated
1247 -- type: we know that the designated type is a private type, so we
1248 -- use the private declarations list.
1250 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1252 if Present (Private_Declarations (Pkg_Spec)) then
1253 Decls := Private_Declarations (Pkg_Spec);
1255 Decls := Visible_Declarations (Pkg_Spec);
1259 -- Case of declaring the RACW in another package than its designated
1260 -- type: use the private declarations list if present; otherwise
1261 -- use the visible declarations.
1263 Decls := List_Containing (Declaration_Node (RACW_Type));
1267 -- If we were unable to find the declarations, that means that the
1268 -- completion of the type was missing. We can safely return and let the
1269 -- error be caught by the semantic analysis.
1276 (Designated_Type => Desig,
1277 RACW_Type => RACW_Type,
1279 Stub_Type => Stub_Type,
1280 Stub_Type_Access => Stub_Type_Access,
1281 RPC_Receiver_Decl => RPC_Receiver_Decl,
1282 Body_Decls => Body_Decls,
1283 Existing => Existing);
1285 -- If this RACW is not in the main unit, do not generate primitive or
1288 if not Entity_Is_In_Main_Unit (RACW_Type) then
1289 Body_Decls := No_List;
1292 Add_RACW_Asynchronous_Flag
1293 (Declarations => Decls,
1294 RACW_Type => RACW_Type);
1296 Specific_Add_RACW_Features
1297 (RACW_Type => RACW_Type,
1299 Stub_Type => Stub_Type,
1300 Stub_Type_Access => Stub_Type_Access,
1301 RPC_Receiver_Decl => RPC_Receiver_Decl,
1302 Body_Decls => Body_Decls);
1304 -- If we already have stubs for this designated type, nothing to do
1310 if Is_Frozen (Desig) then
1311 Validate_RACW_Primitives (RACW_Type);
1312 Add_RACW_Primitive_Declarations_And_Bodies
1313 (Designated_Type => Desig,
1314 Insertion_Node => RPC_Receiver_Decl,
1315 Body_Decls => Body_Decls);
1318 -- Validate_RACW_Primitives requires the list of all primitives of
1319 -- the designated type, so defer processing until Desig is frozen.
1320 -- See Exp_Ch3.Freeze_Type.
1322 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1324 end Add_RACW_Features;
1326 ------------------------------------------------
1327 -- Add_RACW_Primitive_Declarations_And_Bodies --
1328 ------------------------------------------------
1330 procedure Add_RACW_Primitive_Declarations_And_Bodies
1331 (Designated_Type : Entity_Id;
1332 Insertion_Node : Node_Id;
1333 Body_Decls : List_Id)
1335 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1336 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1337 -- the declarations are recognized as belonging to the current package.
1339 Stub_Elements : constant Stub_Structure :=
1340 Stubs_Table.Get (Designated_Type);
1342 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1344 Is_RAS : constant Boolean :=
1345 not Comes_From_Source (Stub_Elements.RACW_Type);
1346 -- Case of the RACW generated to implement a remote access-to-
1349 Build_Bodies : constant Boolean :=
1350 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1351 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1352 -- only when the main unit is the unit that contains the stub type.
1354 Current_Insertion_Node : Node_Id := Insertion_Node;
1356 RPC_Receiver : Entity_Id;
1357 RPC_Receiver_Statements : List_Id;
1358 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1359 RPC_Receiver_Elsif_Parts : List_Id;
1360 RPC_Receiver_Request : Entity_Id;
1361 RPC_Receiver_Subp_Id : Entity_Id;
1362 RPC_Receiver_Subp_Index : Entity_Id;
1364 Subp_Str : String_Id;
1366 Current_Primitive_Elmt : Elmt_Id;
1367 Current_Primitive : Entity_Id;
1368 Current_Primitive_Body : Node_Id;
1369 Current_Primitive_Spec : Node_Id;
1370 Current_Primitive_Decl : Node_Id;
1371 Current_Primitive_Number : Int := 0;
1372 Current_Primitive_Alias : Node_Id;
1373 Current_Receiver : Entity_Id;
1374 Current_Receiver_Body : Node_Id;
1375 RPC_Receiver_Decl : Node_Id;
1376 Possibly_Asynchronous : Boolean;
1379 if not Expander_Active then
1384 RPC_Receiver := Make_Temporary (Loc, 'P');
1386 Specific_Build_RPC_Receiver_Body
1387 (RPC_Receiver => RPC_Receiver,
1388 Request => RPC_Receiver_Request,
1389 Subp_Id => RPC_Receiver_Subp_Id,
1390 Subp_Index => RPC_Receiver_Subp_Index,
1391 Stmts => RPC_Receiver_Statements,
1392 Decl => RPC_Receiver_Decl);
1394 if Get_PCS_Name = Name_PolyORB_DSA then
1396 -- For the case of PolyORB, we need to map a textual operation
1397 -- name into a primitive index. Currently we do so using a simple
1398 -- sequence of string comparisons.
1400 RPC_Receiver_Elsif_Parts := New_List;
1404 -- Build callers, receivers for every primitive operations and a RPC
1405 -- receiver for this type. Note that we use Direct_Primitive_Operations,
1406 -- not Primitive_Operations, because we really want just the primitives
1407 -- of the tagged type itself, and in the case of a tagged synchronized
1408 -- type we do not want to get the primitives of the corresponding
1411 if Present (Direct_Primitive_Operations (Designated_Type)) then
1412 Overload_Counter_Table.Reset;
1414 Current_Primitive_Elmt :=
1415 First_Elmt (Direct_Primitive_Operations (Designated_Type));
1416 while Current_Primitive_Elmt /= No_Elmt loop
1417 Current_Primitive := Node (Current_Primitive_Elmt);
1419 -- Copy the primitive of all the parents, except predefined ones
1420 -- that are not remotely dispatching. Also omit hidden primitives
1421 -- (occurs in the case of primitives of interface progenitors
1422 -- other than immediate ancestors of the Designated_Type).
1424 if Chars (Current_Primitive) /= Name_uSize
1425 and then Chars (Current_Primitive) /= Name_uAlignment
1427 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1428 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1429 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1430 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1431 Is_TSS (Current_Primitive, TSS_Stream_Write)
1433 Is_Predefined_Interface_Primitive (Current_Primitive))
1434 and then not Is_Hidden (Current_Primitive)
1436 -- The first thing to do is build an up-to-date copy of the
1437 -- spec with all the formals referencing Controlling_Type
1438 -- transformed into formals referencing Stub_Type. Since this
1439 -- primitive may have been inherited, go back the alias chain
1440 -- until the real primitive has been found.
1442 Current_Primitive_Alias := Ultimate_Alias (Current_Primitive);
1444 -- Copy the spec from the original declaration for the purpose
1445 -- of declaring an overriding subprogram: we need to replace
1446 -- the type of each controlling formal with Stub_Type. The
1447 -- primitive may have been declared for Controlling_Type or
1448 -- inherited from some ancestor type for which we do not have
1449 -- an easily determined Entity_Id. We have no systematic way
1450 -- of knowing which type to substitute Stub_Type for. Instead,
1451 -- Copy_Specification relies on the flag Is_Controlling_Formal
1452 -- to determine which formals to change.
1454 Current_Primitive_Spec :=
1455 Copy_Specification (Loc,
1456 Spec => Parent (Current_Primitive_Alias),
1457 Ctrl_Type => Stub_Elements.Stub_Type);
1459 Current_Primitive_Decl :=
1460 Make_Subprogram_Declaration (Loc,
1461 Specification => Current_Primitive_Spec);
1463 Insert_After_And_Analyze (Current_Insertion_Node,
1464 Current_Primitive_Decl);
1465 Current_Insertion_Node := Current_Primitive_Decl;
1467 Possibly_Asynchronous :=
1468 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1469 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1471 Assign_Subprogram_Identifier (
1472 Defining_Unit_Name (Current_Primitive_Spec),
1473 Current_Primitive_Number,
1476 if Build_Bodies then
1477 Current_Primitive_Body :=
1478 Build_Subprogram_Calling_Stubs
1479 (Vis_Decl => Current_Primitive_Decl,
1481 Build_Subprogram_Id (Loc,
1482 Defining_Unit_Name (Current_Primitive_Spec)),
1483 Asynchronous => Possibly_Asynchronous,
1484 Dynamically_Asynchronous => Possibly_Asynchronous,
1485 Stub_Type => Stub_Elements.Stub_Type,
1486 RACW_Type => Stub_Elements.RACW_Type);
1487 Append_To (Body_Decls, Current_Primitive_Body);
1489 -- Analyzing the body here would cause the Stub type to
1490 -- be frozen, thus preventing subsequent primitive
1491 -- declarations. For this reason, it will be analyzed
1492 -- later in the regular flow (and in the context of the
1493 -- appropriate unit body, see Append_RACW_Bodies).
1497 -- Build the receiver stubs
1499 if Build_Bodies and then not Is_RAS then
1500 Current_Receiver_Body :=
1501 Specific_Build_Subprogram_Receiving_Stubs
1502 (Vis_Decl => Current_Primitive_Decl,
1503 Asynchronous => Possibly_Asynchronous,
1504 Dynamically_Asynchronous => Possibly_Asynchronous,
1505 Stub_Type => Stub_Elements.Stub_Type,
1506 RACW_Type => Stub_Elements.RACW_Type,
1507 Parent_Primitive => Current_Primitive);
1510 Defining_Unit_Name (Specification (Current_Receiver_Body));
1512 Append_To (Body_Decls, Current_Receiver_Body);
1514 -- Add a case alternative to the receiver
1516 if Get_PCS_Name = Name_PolyORB_DSA then
1517 Append_To (RPC_Receiver_Elsif_Parts,
1518 Make_Elsif_Part (Loc,
1520 Make_Function_Call (Loc,
1523 RTE (RE_Caseless_String_Eq), Loc),
1524 Parameter_Associations => New_List (
1525 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1526 Make_String_Literal (Loc, Subp_Str))),
1528 Then_Statements => New_List (
1529 Make_Assignment_Statement (Loc,
1530 Name => New_Occurrence_Of (
1531 RPC_Receiver_Subp_Index, Loc),
1533 Make_Integer_Literal (Loc,
1534 Intval => Current_Primitive_Number)))));
1537 Append_To (RPC_Receiver_Case_Alternatives,
1538 Make_Case_Statement_Alternative (Loc,
1539 Discrete_Choices => New_List (
1540 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1542 Statements => New_List (
1543 Make_Procedure_Call_Statement (Loc,
1545 New_Occurrence_Of (Current_Receiver, Loc),
1546 Parameter_Associations => New_List (
1547 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1550 -- Increment the index of current primitive
1552 Current_Primitive_Number := Current_Primitive_Number + 1;
1555 Next_Elmt (Current_Primitive_Elmt);
1559 -- Build the case statement and the heart of the subprogram
1561 if Build_Bodies and then not Is_RAS then
1562 if Get_PCS_Name = Name_PolyORB_DSA
1563 and then Present (First (RPC_Receiver_Elsif_Parts))
1565 Append_To (RPC_Receiver_Statements,
1566 Make_Implicit_If_Statement (Designated_Type,
1567 Condition => New_Occurrence_Of (Standard_False, Loc),
1568 Then_Statements => New_List,
1569 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1572 Append_To (RPC_Receiver_Case_Alternatives,
1573 Make_Case_Statement_Alternative (Loc,
1574 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1575 Statements => New_List (Make_Null_Statement (Loc))));
1577 Append_To (RPC_Receiver_Statements,
1578 Make_Case_Statement (Loc,
1580 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1581 Alternatives => RPC_Receiver_Case_Alternatives));
1583 Append_To (Body_Decls, RPC_Receiver_Decl);
1584 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1585 Body_Decls, RPC_Receiver, Stub_Elements);
1587 -- Do not analyze RPC receiver body at this stage since it references
1588 -- subprograms that have not been analyzed yet. It will be analyzed in
1589 -- the regular flow (see Append_RACW_Bodies).
1592 end Add_RACW_Primitive_Declarations_And_Bodies;
1594 -----------------------------
1595 -- Add_RAS_Dereference_TSS --
1596 -----------------------------
1598 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1599 Loc : constant Source_Ptr := Sloc (N);
1601 Type_Def : constant Node_Id := Type_Definition (N);
1602 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1603 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1604 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1606 RACW_Primitive_Name : Node_Id;
1608 Proc : constant Entity_Id :=
1609 Make_Defining_Identifier (Loc,
1610 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1612 Proc_Spec : Node_Id;
1613 Param_Specs : List_Id;
1614 Param_Assoc : constant List_Id := New_List;
1615 Stmts : constant List_Id := New_List;
1617 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P');
1619 Is_Function : constant Boolean :=
1620 Nkind (Type_Def) = N_Access_Function_Definition;
1622 Is_Degenerate : Boolean;
1623 -- Set to True if the subprogram_specification for this RAS has an
1624 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1626 Spec : constant Node_Id := Type_Def;
1628 Current_Parameter : Node_Id;
1630 -- Start of processing for Add_RAS_Dereference_TSS
1633 -- The Dereference TSS for a remote access-to-subprogram type has the
1636 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1639 -- This is called whenever a value of a RAS type is dereferenced
1641 -- First construct a list of parameter specifications:
1643 -- The first formal is the RAS values
1645 Param_Specs := New_List (
1646 Make_Parameter_Specification (Loc,
1647 Defining_Identifier => RAS_Parameter,
1650 New_Occurrence_Of (Fat_Type, Loc)));
1652 -- The following formals are copied from the type declaration
1654 Is_Degenerate := False;
1655 Current_Parameter := First (Parameter_Specifications (Type_Def));
1656 Parameters : while Present (Current_Parameter) loop
1657 if Nkind (Parameter_Type (Current_Parameter)) =
1660 Is_Degenerate := True;
1663 Append_To (Param_Specs,
1664 Make_Parameter_Specification (Loc,
1665 Defining_Identifier =>
1666 Make_Defining_Identifier (Loc,
1667 Chars => Chars (Defining_Identifier (Current_Parameter))),
1668 In_Present => In_Present (Current_Parameter),
1669 Out_Present => Out_Present (Current_Parameter),
1671 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1673 New_Copy_Tree (Expression (Current_Parameter))));
1675 Append_To (Param_Assoc,
1676 Make_Identifier (Loc,
1677 Chars => Chars (Defining_Identifier (Current_Parameter))));
1679 Next (Current_Parameter);
1680 end loop Parameters;
1682 if Is_Degenerate then
1683 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1685 -- Generate a dummy body. This code will never actually be executed,
1686 -- because null is the only legal value for a degenerate RAS type.
1687 -- For legality's sake (in order to avoid generating a function that
1688 -- does not contain a return statement), we include a dummy recursive
1689 -- call on the TSS itself.
1692 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1693 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1696 -- For a normal RAS type, we cast the RAS formal to the corresponding
1697 -- tagged type, and perform a dispatching call to its Call primitive
1700 Prepend_To (Param_Assoc,
1701 Unchecked_Convert_To (RACW_Type,
1702 New_Occurrence_Of (RAS_Parameter, Loc)));
1704 RACW_Primitive_Name :=
1705 Make_Selected_Component (Loc,
1706 Prefix => Scope (RACW_Type),
1707 Selector_Name => Name_uCall);
1712 Make_Simple_Return_Statement (Loc,
1714 Make_Function_Call (Loc,
1715 Name => RACW_Primitive_Name,
1716 Parameter_Associations => Param_Assoc)));
1720 Make_Procedure_Call_Statement (Loc,
1721 Name => RACW_Primitive_Name,
1722 Parameter_Associations => Param_Assoc));
1725 -- Build the complete subprogram
1729 Make_Function_Specification (Loc,
1730 Defining_Unit_Name => Proc,
1731 Parameter_Specifications => Param_Specs,
1732 Result_Definition =>
1734 Entity (Result_Definition (Spec)), Loc));
1736 Set_Ekind (Proc, E_Function);
1738 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1742 Make_Procedure_Specification (Loc,
1743 Defining_Unit_Name => Proc,
1744 Parameter_Specifications => Param_Specs);
1746 Set_Ekind (Proc, E_Procedure);
1747 Set_Etype (Proc, Standard_Void_Type);
1751 Make_Subprogram_Body (Loc,
1752 Specification => Proc_Spec,
1753 Declarations => New_List,
1754 Handled_Statement_Sequence =>
1755 Make_Handled_Sequence_Of_Statements (Loc,
1756 Statements => Stmts)));
1758 Set_TSS (Fat_Type, Proc);
1759 end Add_RAS_Dereference_TSS;
1761 -------------------------------
1762 -- Add_RAS_Proxy_And_Analyze --
1763 -------------------------------
1765 procedure Add_RAS_Proxy_And_Analyze
1768 All_Calls_Remote_E : Entity_Id;
1769 Proxy_Object_Addr : out Entity_Id)
1771 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1773 Subp_Name : constant Entity_Id :=
1774 Defining_Unit_Name (Specification (Vis_Decl));
1776 Pkg_Name : constant Entity_Id :=
1777 Make_Defining_Identifier (Loc,
1778 Chars => New_External_Name (Chars (Subp_Name), 'P', -1));
1780 Proxy_Type : constant Entity_Id :=
1781 Make_Defining_Identifier (Loc,
1784 (Related_Id => Chars (Subp_Name),
1787 Proxy_Type_Full_View : constant Entity_Id :=
1788 Make_Defining_Identifier (Loc,
1789 Chars (Proxy_Type));
1791 Subp_Decl_Spec : constant Node_Id :=
1792 Build_RAS_Primitive_Specification
1793 (Subp_Spec => Specification (Vis_Decl),
1794 Remote_Object_Type => Proxy_Type);
1796 Subp_Body_Spec : constant Node_Id :=
1797 Build_RAS_Primitive_Specification
1798 (Subp_Spec => Specification (Vis_Decl),
1799 Remote_Object_Type => Proxy_Type);
1801 Vis_Decls : constant List_Id := New_List;
1802 Pvt_Decls : constant List_Id := New_List;
1803 Actuals : constant List_Id := New_List;
1805 Perform_Call : Node_Id;
1808 -- type subpP is tagged limited private;
1810 Append_To (Vis_Decls,
1811 Make_Private_Type_Declaration (Loc,
1812 Defining_Identifier => Proxy_Type,
1813 Tagged_Present => True,
1814 Limited_Present => True));
1816 -- [subprogram] Call
1817 -- (Self : access subpP;
1818 -- ...other-formals...)
1821 Append_To (Vis_Decls,
1822 Make_Subprogram_Declaration (Loc,
1823 Specification => Subp_Decl_Spec));
1825 -- A : constant System.Address;
1827 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1829 Append_To (Vis_Decls,
1830 Make_Object_Declaration (Loc,
1831 Defining_Identifier => Proxy_Object_Addr,
1832 Constant_Present => True,
1833 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)));
1837 -- type subpP is tagged limited record
1838 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1842 Append_To (Pvt_Decls,
1843 Make_Full_Type_Declaration (Loc,
1844 Defining_Identifier => Proxy_Type_Full_View,
1846 Build_Remote_Subprogram_Proxy_Type (Loc,
1847 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1849 -- Trick semantic analysis into swapping the public and full view when
1850 -- freezing the public view.
1852 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1855 -- (Self : access O;
1856 -- ...other-formals...) is
1858 -- P (...other-formals...);
1862 -- (Self : access O;
1863 -- ...other-formals...)
1866 -- return F (...other-formals...);
1869 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1871 Make_Procedure_Call_Statement (Loc,
1872 Name => New_Occurrence_Of (Subp_Name, Loc),
1873 Parameter_Associations => Actuals);
1876 Make_Simple_Return_Statement (Loc,
1878 Make_Function_Call (Loc,
1879 Name => New_Occurrence_Of (Subp_Name, Loc),
1880 Parameter_Associations => Actuals));
1883 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1884 pragma Assert (Present (Formal));
1887 exit when No (Formal);
1889 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1892 -- O : aliased subpP;
1894 Append_To (Pvt_Decls,
1895 Make_Object_Declaration (Loc,
1896 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
1897 Aliased_Present => True,
1898 Object_Definition => New_Occurrence_Of (Proxy_Type, Loc)));
1900 -- A : constant System.Address := O'Address;
1902 Append_To (Pvt_Decls,
1903 Make_Object_Declaration (Loc,
1904 Defining_Identifier =>
1905 Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)),
1906 Constant_Present => True,
1907 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc),
1909 Make_Attribute_Reference (Loc,
1910 Prefix => New_Occurrence_Of (
1911 Defining_Identifier (Last (Pvt_Decls)), Loc),
1912 Attribute_Name => Name_Address)));
1915 Make_Package_Declaration (Loc,
1916 Specification => Make_Package_Specification (Loc,
1917 Defining_Unit_Name => Pkg_Name,
1918 Visible_Declarations => Vis_Decls,
1919 Private_Declarations => Pvt_Decls,
1920 End_Label => Empty)));
1921 Analyze (Last (Decls));
1924 Make_Package_Body (Loc,
1925 Defining_Unit_Name =>
1926 Make_Defining_Identifier (Loc, Chars (Pkg_Name)),
1927 Declarations => New_List (
1928 Make_Subprogram_Body (Loc,
1929 Specification => Subp_Body_Spec,
1930 Declarations => New_List,
1931 Handled_Statement_Sequence =>
1932 Make_Handled_Sequence_Of_Statements (Loc,
1933 Statements => New_List (Perform_Call))))));
1934 Analyze (Last (Decls));
1935 end Add_RAS_Proxy_And_Analyze;
1937 -----------------------
1938 -- Add_RAST_Features --
1939 -----------------------
1941 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1942 RAS_Type : constant Entity_Id :=
1943 Equivalent_Type (Defining_Identifier (Vis_Decl));
1945 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1946 Add_RAS_Dereference_TSS (Vis_Decl);
1947 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1948 end Add_RAST_Features;
1954 procedure Add_Stub_Type
1955 (Designated_Type : Entity_Id;
1956 RACW_Type : Entity_Id;
1958 Stub_Type : out Entity_Id;
1959 Stub_Type_Access : out Entity_Id;
1960 RPC_Receiver_Decl : out Node_Id;
1961 Body_Decls : out List_Id;
1962 Existing : out Boolean)
1964 Loc : constant Source_Ptr := Sloc (RACW_Type);
1966 Stub_Elements : constant Stub_Structure :=
1967 Stubs_Table.Get (Designated_Type);
1968 Stub_Type_Decl : Node_Id;
1969 Stub_Type_Access_Decl : Node_Id;
1972 if Stub_Elements /= Empty_Stub_Structure then
1973 Stub_Type := Stub_Elements.Stub_Type;
1974 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1975 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1976 Body_Decls := Stub_Elements.Body_Decls;
1982 Stub_Type := Make_Temporary (Loc, 'S');
1983 Set_Ekind (Stub_Type, E_Record_Type);
1984 Set_Is_RACW_Stub_Type (Stub_Type);
1986 Make_Defining_Identifier (Loc,
1987 Chars => New_External_Name
1988 (Related_Id => Chars (Stub_Type), Suffix => 'A'));
1990 RPC_Receiver_Decl := Specific_RPC_Receiver_Decl (RACW_Type);
1992 -- Create new stub type, copying components from generic RACW_Stub_Type
1995 Make_Full_Type_Declaration (Loc,
1996 Defining_Identifier => Stub_Type,
1998 Make_Record_Definition (Loc,
1999 Tagged_Present => True,
2000 Limited_Present => True,
2002 Make_Component_List (Loc,
2004 Copy_Component_List (RTE (RE_RACW_Stub_Type), Loc))));
2006 -- Does the stub type need to explicitly implement interfaces from the
2007 -- designated type???
2009 -- In particular are there issues in the case where the designated type
2010 -- is a synchronized interface???
2012 Stub_Type_Access_Decl :=
2013 Make_Full_Type_Declaration (Loc,
2014 Defining_Identifier => Stub_Type_Access,
2016 Make_Access_To_Object_Definition (Loc,
2017 All_Present => True,
2018 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
2020 Append_To (Decls, Stub_Type_Decl);
2021 Analyze (Last (Decls));
2022 Append_To (Decls, Stub_Type_Access_Decl);
2023 Analyze (Last (Decls));
2025 -- We can't directly derive the stub type from the designated type,
2026 -- because we don't want any components or discriminants from the real
2027 -- type, so instead we manually fake a derivation to get an appropriate
2030 Derive_Subprograms (Parent_Type => Designated_Type,
2031 Derived_Type => Stub_Type);
2033 if Present (RPC_Receiver_Decl) then
2034 Append_To (Decls, RPC_Receiver_Decl);
2037 -- Kludge, requires comment???
2039 RPC_Receiver_Decl := Last (Decls);
2042 Body_Decls := New_List;
2044 Stubs_Table.Set (Designated_Type,
2045 (Stub_Type => Stub_Type,
2046 Stub_Type_Access => Stub_Type_Access,
2047 RPC_Receiver_Decl => RPC_Receiver_Decl,
2048 Body_Decls => Body_Decls,
2049 RACW_Type => RACW_Type));
2052 ------------------------
2053 -- Append_RACW_Bodies --
2054 ------------------------
2056 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
2060 E := First_Entity (Spec_Id);
2061 while Present (E) loop
2062 if Is_Remote_Access_To_Class_Wide_Type (E) then
2063 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
2068 end Append_RACW_Bodies;
2070 ----------------------------------
2071 -- Assign_Subprogram_Identifier --
2072 ----------------------------------
2074 procedure Assign_Subprogram_Identifier
2079 N : constant Name_Id := Chars (Def);
2081 Overload_Order : constant Int := Overload_Counter_Table.Get (N) + 1;
2084 Overload_Counter_Table.Set (N, Overload_Order);
2086 Get_Name_String (N);
2088 -- Homonym handling: as in Exp_Dbug, but much simpler, because the only
2089 -- entities for which we have to generate names here need only to be
2090 -- disambiguated within their own scope.
2092 if Overload_Order > 1 then
2093 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
2094 Name_Len := Name_Len + 2;
2095 Add_Nat_To_Name_Buffer (Overload_Order);
2098 Id := String_From_Name_Buffer;
2099 Subprogram_Identifier_Table.Set
2101 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
2102 end Assign_Subprogram_Identifier;
2104 -------------------------------------
2105 -- Build_Actual_Object_Declaration --
2106 -------------------------------------
2108 procedure Build_Actual_Object_Declaration
2109 (Object : Entity_Id;
2115 Loc : constant Source_Ptr := Sloc (Object);
2118 -- Declare a temporary object for the actual, possibly initialized with
2119 -- a 'Input/From_Any call.
2121 -- Complication arises in the case of limited types, for which such a
2122 -- declaration is illegal in Ada 95. In that case, we first generate a
2123 -- renaming declaration of the 'Input call, and then if needed we
2124 -- generate an overlaid non-constant view.
2126 if Ada_Version <= Ada_95
2127 and then Is_Limited_Type (Etyp)
2128 and then Present (Expr)
2131 -- Object : Etyp renames <func-call>
2134 Make_Object_Renaming_Declaration (Loc,
2135 Defining_Identifier => Object,
2136 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
2141 -- The name defined by the renaming declaration denotes a
2142 -- constant view; create a non-constant object at the same address
2143 -- to be used as the actual.
2146 Constant_Object : constant Entity_Id :=
2147 Make_Temporary (Loc, 'P');
2150 Set_Defining_Identifier
2151 (Last (Decls), Constant_Object);
2153 -- We have an unconstrained Etyp: build the actual constrained
2154 -- subtype for the value we just read from the stream.
2156 -- subtype S is <actual subtype of Constant_Object>;
2159 Build_Actual_Subtype (Etyp,
2160 New_Occurrence_Of (Constant_Object, Loc)));
2165 Make_Object_Declaration (Loc,
2166 Defining_Identifier => Object,
2167 Object_Definition =>
2169 (Defining_Identifier (Last (Decls)), Loc)));
2170 Set_Ekind (Object, E_Variable);
2172 -- Suppress default initialization:
2173 -- pragma Import (Ada, Object);
2177 Chars => Name_Import,
2178 Pragma_Argument_Associations => New_List (
2179 Make_Pragma_Argument_Association (Loc,
2180 Chars => Name_Convention,
2181 Expression => Make_Identifier (Loc, Name_Ada)),
2182 Make_Pragma_Argument_Association (Loc,
2183 Chars => Name_Entity,
2184 Expression => New_Occurrence_Of (Object, Loc)))));
2186 -- for Object'Address use Constant_Object'Address;
2189 Make_Attribute_Definition_Clause (Loc,
2190 Name => New_Occurrence_Of (Object, Loc),
2191 Chars => Name_Address,
2193 Make_Attribute_Reference (Loc,
2194 Prefix => New_Occurrence_Of (Constant_Object, Loc),
2195 Attribute_Name => Name_Address)));
2200 -- General case of a regular object declaration. Object is flagged
2201 -- constant unless it has mode out or in out, to allow the backend
2202 -- to optimize where possible.
2204 -- Object : [constant] Etyp [:= <expr>];
2207 Make_Object_Declaration (Loc,
2208 Defining_Identifier => Object,
2209 Constant_Present => Present (Expr) and then not Variable,
2210 Object_Definition => New_Occurrence_Of (Etyp, Loc),
2211 Expression => Expr));
2213 if Constant_Present (Last (Decls)) then
2214 Set_Ekind (Object, E_Constant);
2216 Set_Ekind (Object, E_Variable);
2219 end Build_Actual_Object_Declaration;
2221 ------------------------------
2222 -- Build_Get_Unique_RP_Call --
2223 ------------------------------
2225 function Build_Get_Unique_RP_Call
2227 Pointer : Entity_Id;
2228 Stub_Type : Entity_Id) return List_Id
2232 Make_Procedure_Call_Statement (Loc,
2234 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2235 Parameter_Associations => New_List (
2236 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2237 New_Occurrence_Of (Pointer, Loc)))),
2239 Make_Assignment_Statement (Loc,
2241 Make_Selected_Component (Loc,
2242 Prefix => New_Occurrence_Of (Pointer, Loc),
2244 New_Occurrence_Of (First_Tag_Component
2245 (Designated_Type (Etype (Pointer))), Loc)),
2247 Make_Attribute_Reference (Loc,
2248 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2249 Attribute_Name => Name_Tag)));
2251 -- Note: The assignment to Pointer._Tag is safe here because
2252 -- we carefully ensured that Stub_Type has exactly the same layout
2253 -- as System.Partition_Interface.RACW_Stub_Type.
2255 end Build_Get_Unique_RP_Call;
2257 -----------------------------------
2258 -- Build_Ordered_Parameters_List --
2259 -----------------------------------
2261 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2262 Constrained_List : List_Id;
2263 Unconstrained_List : List_Id;
2264 Current_Parameter : Node_Id;
2267 First_Parameter : Node_Id;
2268 For_RAS : Boolean := False;
2271 if No (Parameter_Specifications (Spec)) then
2275 Constrained_List := New_List;
2276 Unconstrained_List := New_List;
2277 First_Parameter := First (Parameter_Specifications (Spec));
2279 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2280 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2285 -- Loop through the parameters and add them to the right list. Note that
2286 -- we treat a parameter of a null-excluding access type as unconstrained
2287 -- because we can't declare an object of such a type with default
2290 Current_Parameter := First_Parameter;
2291 while Present (Current_Parameter) loop
2292 Ptyp := Parameter_Type (Current_Parameter);
2294 if (Nkind (Ptyp) = N_Access_Definition
2295 or else not Transmit_As_Unconstrained (Etype (Ptyp)))
2296 and then not (For_RAS and then Current_Parameter = First_Parameter)
2298 Append_To (Constrained_List, New_Copy (Current_Parameter));
2300 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2303 Next (Current_Parameter);
2306 -- Unconstrained parameters are returned first
2308 Append_List_To (Unconstrained_List, Constrained_List);
2310 return Unconstrained_List;
2311 end Build_Ordered_Parameters_List;
2313 ----------------------------------
2314 -- Build_Passive_Partition_Stub --
2315 ----------------------------------
2317 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2319 Pkg_Name : String_Id;
2322 Loc : constant Source_Ptr := Sloc (U);
2325 -- Verify that the implementation supports distribution, by accessing
2326 -- a type defined in the proper version of system.rpc
2329 Dist_OK : Entity_Id;
2330 pragma Warnings (Off, Dist_OK);
2332 Dist_OK := RTE (RE_Params_Stream_Type);
2335 -- Use body if present, spec otherwise
2337 if Nkind (U) = N_Package_Declaration then
2338 Pkg_Spec := Specification (U);
2339 L := Visible_Declarations (Pkg_Spec);
2341 Pkg_Spec := Parent (Corresponding_Spec (U));
2342 L := Declarations (U);
2345 Get_Library_Unit_Name_String (Pkg_Spec);
2346 Pkg_Name := String_From_Name_Buffer;
2348 Make_Procedure_Call_Statement (Loc,
2350 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2351 Parameter_Associations => New_List (
2352 Make_String_Literal (Loc, Pkg_Name),
2353 Make_Attribute_Reference (Loc,
2355 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2356 Attribute_Name => Name_Version)));
2359 end Build_Passive_Partition_Stub;
2361 --------------------------------------
2362 -- Build_RPC_Receiver_Specification --
2363 --------------------------------------
2365 function Build_RPC_Receiver_Specification
2366 (RPC_Receiver : Entity_Id;
2367 Request_Parameter : Entity_Id) return Node_Id
2369 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2372 Make_Procedure_Specification (Loc,
2373 Defining_Unit_Name => RPC_Receiver,
2374 Parameter_Specifications => New_List (
2375 Make_Parameter_Specification (Loc,
2376 Defining_Identifier => Request_Parameter,
2378 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2379 end Build_RPC_Receiver_Specification;
2381 ----------------------------------------
2382 -- Build_Remote_Subprogram_Proxy_Type --
2383 ----------------------------------------
2385 function Build_Remote_Subprogram_Proxy_Type
2387 ACR_Expression : Node_Id) return Node_Id
2391 Make_Record_Definition (Loc,
2392 Tagged_Present => True,
2393 Limited_Present => True,
2395 Make_Component_List (Loc,
2396 Component_Items => New_List (
2397 Make_Component_Declaration (Loc,
2398 Defining_Identifier =>
2399 Make_Defining_Identifier (Loc,
2400 Name_All_Calls_Remote),
2401 Component_Definition =>
2402 Make_Component_Definition (Loc,
2403 Subtype_Indication =>
2404 New_Occurrence_Of (Standard_Boolean, Loc)),
2408 Make_Component_Declaration (Loc,
2409 Defining_Identifier =>
2410 Make_Defining_Identifier (Loc,
2412 Component_Definition =>
2413 Make_Component_Definition (Loc,
2414 Subtype_Indication =>
2415 New_Occurrence_Of (RTE (RE_Address), Loc)),
2417 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2419 Make_Component_Declaration (Loc,
2420 Defining_Identifier =>
2421 Make_Defining_Identifier (Loc,
2423 Component_Definition =>
2424 Make_Component_Definition (Loc,
2425 Subtype_Indication =>
2426 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2427 end Build_Remote_Subprogram_Proxy_Type;
2429 --------------------
2430 -- Build_Stub_Tag --
2431 --------------------
2433 function Build_Stub_Tag
2435 RACW_Type : Entity_Id) return Node_Id
2437 Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type);
2440 Make_Attribute_Reference (Loc,
2441 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2442 Attribute_Name => Name_Tag);
2445 ------------------------------------
2446 -- Build_Subprogram_Calling_Stubs --
2447 ------------------------------------
2449 function Build_Subprogram_Calling_Stubs
2450 (Vis_Decl : Node_Id;
2452 Asynchronous : Boolean;
2453 Dynamically_Asynchronous : Boolean := False;
2454 Stub_Type : Entity_Id := Empty;
2455 RACW_Type : Entity_Id := Empty;
2456 Locator : Entity_Id := Empty;
2457 New_Name : Name_Id := No_Name) return Node_Id
2459 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2461 Decls : constant List_Id := New_List;
2462 Statements : constant List_Id := New_List;
2464 Subp_Spec : Node_Id;
2465 -- The specification of the body
2467 Controlling_Parameter : Entity_Id := Empty;
2469 Asynchronous_Expr : Node_Id := Empty;
2471 RCI_Locator : Entity_Id;
2473 Spec_To_Use : Node_Id;
2475 procedure Insert_Partition_Check (Parameter : Node_Id);
2476 -- Check that the parameter has been elaborated on the same partition
2477 -- than the controlling parameter (E.4(19)).
2479 ----------------------------
2480 -- Insert_Partition_Check --
2481 ----------------------------
2483 procedure Insert_Partition_Check (Parameter : Node_Id) is
2484 Parameter_Entity : constant Entity_Id :=
2485 Defining_Identifier (Parameter);
2487 -- The expression that will be built is of the form:
2489 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2490 -- raise Constraint_Error;
2493 -- We do not check that Parameter is in Stub_Type since such a check
2494 -- has been inserted at the point of call already (a tag check since
2495 -- we have multiple controlling operands).
2498 Make_Raise_Constraint_Error (Loc,
2502 Make_Function_Call (Loc,
2504 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2505 Parameter_Associations =>
2507 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2508 New_Occurrence_Of (Parameter_Entity, Loc)),
2509 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2510 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2511 Reason => CE_Partition_Check_Failed));
2512 end Insert_Partition_Check;
2514 -- Start of processing for Build_Subprogram_Calling_Stubs
2518 Copy_Specification (Loc,
2519 Spec => Specification (Vis_Decl),
2520 New_Name => New_Name);
2522 if Locator = Empty then
2523 RCI_Locator := RCI_Cache;
2524 Spec_To_Use := Specification (Vis_Decl);
2526 RCI_Locator := Locator;
2527 Spec_To_Use := Subp_Spec;
2530 -- Find a controlling argument if we have a stub type. Also check
2531 -- if this subprogram can be made asynchronous.
2533 if Present (Stub_Type)
2534 and then Present (Parameter_Specifications (Spec_To_Use))
2537 Current_Parameter : Node_Id :=
2538 First (Parameter_Specifications
2541 while Present (Current_Parameter) loop
2543 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2545 if Controlling_Parameter = Empty then
2546 Controlling_Parameter :=
2547 Defining_Identifier (Current_Parameter);
2549 Insert_Partition_Check (Current_Parameter);
2553 Next (Current_Parameter);
2558 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2560 if Dynamically_Asynchronous then
2561 Asynchronous_Expr := Make_Selected_Component (Loc,
2562 Prefix => Controlling_Parameter,
2563 Selector_Name => Name_Asynchronous);
2566 Specific_Build_General_Calling_Stubs
2568 Statements => Statements,
2569 Target => Specific_Build_Stub_Target (Loc,
2570 Decls, RCI_Locator, Controlling_Parameter),
2571 Subprogram_Id => Subp_Id,
2572 Asynchronous => Asynchronous_Expr,
2573 Is_Known_Asynchronous => Asynchronous
2574 and then not Dynamically_Asynchronous,
2575 Is_Known_Non_Asynchronous
2577 and then not Dynamically_Asynchronous,
2578 Is_Function => Nkind (Spec_To_Use) =
2579 N_Function_Specification,
2580 Spec => Spec_To_Use,
2581 Stub_Type => Stub_Type,
2582 RACW_Type => RACW_Type,
2585 RCI_Calling_Stubs_Table.Set
2586 (Defining_Unit_Name (Specification (Vis_Decl)),
2587 Defining_Unit_Name (Spec_To_Use));
2590 Make_Subprogram_Body (Loc,
2591 Specification => Subp_Spec,
2592 Declarations => Decls,
2593 Handled_Statement_Sequence =>
2594 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2595 end Build_Subprogram_Calling_Stubs;
2597 -------------------------
2598 -- Build_Subprogram_Id --
2599 -------------------------
2601 function Build_Subprogram_Id
2603 E : Entity_Id) return Node_Id
2606 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2608 Current_Declaration : Node_Id;
2609 Current_Subp : Entity_Id;
2610 Current_Subp_Str : String_Id;
2611 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2613 pragma Warnings (Off, Current_Subp_Str);
2616 -- Build_Subprogram_Id is called outside of the context of
2617 -- generating calling or receiving stubs. Hence we are processing
2618 -- an 'Access attribute_reference for an RCI subprogram, for the
2619 -- purpose of obtaining a RAS value.
2622 (Is_Remote_Call_Interface (Scope (E))
2624 (Nkind (Parent (E)) = N_Procedure_Specification
2626 Nkind (Parent (E)) = N_Function_Specification));
2628 Current_Declaration :=
2629 First (Visible_Declarations
2630 (Package_Specification_Of_Scope (Scope (E))));
2631 while Present (Current_Declaration) loop
2632 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2633 and then Comes_From_Source (Current_Declaration)
2635 Current_Subp := Defining_Unit_Name (Specification (
2636 Current_Declaration));
2638 Assign_Subprogram_Identifier
2639 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2641 Current_Subp_Number := Current_Subp_Number + 1;
2644 Next (Current_Declaration);
2649 case Get_PCS_Name is
2650 when Name_PolyORB_DSA =>
2651 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2653 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2655 end Build_Subprogram_Id;
2657 ------------------------
2658 -- Copy_Specification --
2659 ------------------------
2661 function Copy_Specification
2664 Ctrl_Type : Entity_Id := Empty;
2665 New_Name : Name_Id := No_Name) return Node_Id
2667 Parameters : List_Id := No_List;
2669 Current_Parameter : Node_Id;
2670 Current_Identifier : Entity_Id;
2671 Current_Type : Node_Id;
2673 Name_For_New_Spec : Name_Id;
2675 New_Identifier : Entity_Id;
2677 -- Comments needed in body below ???
2680 if New_Name = No_Name then
2681 pragma Assert (Nkind (Spec) = N_Function_Specification
2682 or else Nkind (Spec) = N_Procedure_Specification);
2684 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2686 Name_For_New_Spec := New_Name;
2689 if Present (Parameter_Specifications (Spec)) then
2690 Parameters := New_List;
2691 Current_Parameter := First (Parameter_Specifications (Spec));
2692 while Present (Current_Parameter) loop
2693 Current_Identifier := Defining_Identifier (Current_Parameter);
2694 Current_Type := Parameter_Type (Current_Parameter);
2696 if Nkind (Current_Type) = N_Access_Definition then
2697 if Present (Ctrl_Type) then
2698 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2700 Make_Access_Definition (Loc,
2701 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2702 Null_Exclusion_Present =>
2703 Null_Exclusion_Present (Current_Type));
2707 Make_Access_Definition (Loc,
2709 New_Copy_Tree (Subtype_Mark (Current_Type)),
2710 Null_Exclusion_Present =>
2711 Null_Exclusion_Present (Current_Type));
2715 if Present (Ctrl_Type)
2716 and then Is_Controlling_Formal (Current_Identifier)
2718 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2720 Current_Type := New_Copy_Tree (Current_Type);
2724 New_Identifier := Make_Defining_Identifier (Loc,
2725 Chars (Current_Identifier));
2727 Append_To (Parameters,
2728 Make_Parameter_Specification (Loc,
2729 Defining_Identifier => New_Identifier,
2730 Parameter_Type => Current_Type,
2731 In_Present => In_Present (Current_Parameter),
2732 Out_Present => Out_Present (Current_Parameter),
2734 New_Copy_Tree (Expression (Current_Parameter))));
2736 -- For a regular formal parameter (that needs to be marshalled
2737 -- in the context of remote calls), set the Etype now, because
2738 -- marshalling processing might need it.
2740 if Is_Entity_Name (Current_Type) then
2741 Set_Etype (New_Identifier, Entity (Current_Type));
2743 -- Current_Type is an access definition, special processing
2744 -- (not requiring etype) will occur for marshalling.
2750 Next (Current_Parameter);
2754 case Nkind (Spec) is
2756 when N_Function_Specification | N_Access_Function_Definition =>
2758 Make_Function_Specification (Loc,
2759 Defining_Unit_Name =>
2760 Make_Defining_Identifier (Loc,
2761 Chars => Name_For_New_Spec),
2762 Parameter_Specifications => Parameters,
2763 Result_Definition =>
2764 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2766 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2768 Make_Procedure_Specification (Loc,
2769 Defining_Unit_Name =>
2770 Make_Defining_Identifier (Loc,
2771 Chars => Name_For_New_Spec),
2772 Parameter_Specifications => Parameters);
2775 raise Program_Error;
2777 end Copy_Specification;
2779 -----------------------------
2780 -- Corresponding_Stub_Type --
2781 -----------------------------
2783 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2784 Desig : constant Entity_Id :=
2785 Etype (Designated_Type (RACW_Type));
2786 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2788 return Stub_Elements.Stub_Type;
2789 end Corresponding_Stub_Type;
2791 ---------------------------
2792 -- Could_Be_Asynchronous --
2793 ---------------------------
2795 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2796 Current_Parameter : Node_Id;
2799 if Present (Parameter_Specifications (Spec)) then
2800 Current_Parameter := First (Parameter_Specifications (Spec));
2801 while Present (Current_Parameter) loop
2802 if Out_Present (Current_Parameter) then
2806 Next (Current_Parameter);
2811 end Could_Be_Asynchronous;
2813 ---------------------------
2814 -- Declare_Create_NVList --
2815 ---------------------------
2817 procedure Declare_Create_NVList
2825 Make_Object_Declaration (Loc,
2826 Defining_Identifier => NVList,
2827 Aliased_Present => False,
2828 Object_Definition =>
2829 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2832 Make_Procedure_Call_Statement (Loc,
2833 Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2834 Parameter_Associations => New_List (
2835 New_Occurrence_Of (NVList, Loc))));
2836 end Declare_Create_NVList;
2838 ---------------------------------------------
2839 -- Expand_All_Calls_Remote_Subprogram_Call --
2840 ---------------------------------------------
2842 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2843 Loc : constant Source_Ptr := Sloc (N);
2844 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2845 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2846 RCI_Locator_Decl : Node_Id;
2847 RCI_Locator : Entity_Id;
2848 Calling_Stubs : Node_Id;
2849 E_Calling_Stubs : Entity_Id;
2852 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2854 if E_Calling_Stubs = Empty then
2855 RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
2857 -- The RCI_Locator package and calling stub are is inserted at the
2858 -- top level in the current unit, and must appear in the proper scope
2859 -- so that it is not prematurely removed by the GCC back end.
2862 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2864 if Ekind (Scop) = E_Package_Body then
2865 Push_Scope (Spec_Entity (Scop));
2866 elsif Ekind (Scop) = E_Subprogram_Body then
2868 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2874 if RCI_Locator = Empty then
2877 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2878 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
2879 Analyze (RCI_Locator_Decl);
2880 RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
2883 RCI_Locator_Decl := Parent (RCI_Locator);
2886 Calling_Stubs := Build_Subprogram_Calling_Stubs
2887 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2889 Build_Subprogram_Id (Loc, Called_Subprogram),
2890 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2892 Is_Asynchronous (Called_Subprogram),
2893 Locator => RCI_Locator,
2894 New_Name => New_Internal_Name ('S'));
2895 Insert_After (RCI_Locator_Decl, Calling_Stubs);
2896 Analyze (Calling_Stubs);
2899 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2902 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2903 end Expand_All_Calls_Remote_Subprogram_Call;
2905 ---------------------------------
2906 -- Expand_Calling_Stubs_Bodies --
2907 ---------------------------------
2909 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2910 Spec : constant Node_Id := Specification (Unit_Node);
2912 Add_Calling_Stubs_To_Declarations (Spec);
2913 end Expand_Calling_Stubs_Bodies;
2915 -----------------------------------
2916 -- Expand_Receiving_Stubs_Bodies --
2917 -----------------------------------
2919 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2922 Stubs_Decls : List_Id;
2923 Stubs_Stmts : List_Id;
2926 if Nkind (Unit_Node) = N_Package_Declaration then
2927 Spec := Specification (Unit_Node);
2928 Decls := Private_Declarations (Spec);
2931 Decls := Visible_Declarations (Spec);
2934 Push_Scope (Scope_Of_Spec (Spec));
2935 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2939 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2940 Decls := Declarations (Unit_Node);
2942 Push_Scope (Scope_Of_Spec (Unit_Node));
2943 Stubs_Decls := New_List;
2944 Stubs_Stmts := New_List;
2945 Specific_Add_Receiving_Stubs_To_Declarations
2946 (Spec, Stubs_Decls, Stubs_Stmts);
2948 Insert_List_Before (First (Decls), Stubs_Decls);
2951 HSS_Stmts : constant List_Id :=
2952 Statements (Handled_Statement_Sequence (Unit_Node));
2954 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2957 if No (First_HSS_Stmt) then
2958 Append_List_To (HSS_Stmts, Stubs_Stmts);
2960 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2966 end Expand_Receiving_Stubs_Bodies;
2968 --------------------
2969 -- GARLIC_Support --
2970 --------------------
2972 package body GARLIC_Support is
2974 -- Local subprograms
2976 procedure Add_RACW_Read_Attribute
2977 (RACW_Type : Entity_Id;
2978 Stub_Type : Entity_Id;
2979 Stub_Type_Access : Entity_Id;
2980 Body_Decls : List_Id);
2981 -- Add Read attribute for the RACW type. The declaration and attribute
2982 -- definition clauses are inserted right after the declaration of
2983 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2984 -- appended to it (case where the RACW declaration is in the main unit).
2986 procedure Add_RACW_Write_Attribute
2987 (RACW_Type : Entity_Id;
2988 Stub_Type : Entity_Id;
2989 Stub_Type_Access : Entity_Id;
2990 RPC_Receiver : Node_Id;
2991 Body_Decls : List_Id);
2992 -- Same as above for the Write attribute
2994 function Stream_Parameter return Node_Id;
2995 function Result return Node_Id;
2996 function Object return Node_Id renames Result;
2997 -- Functions to create occurrences of the formal parameter names of the
2998 -- 'Read and 'Write attributes.
3001 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
3002 -- their ancillary subroutines (set on entry by Add_RACW_Features).
3004 procedure Add_RAS_Access_TSS (N : Node_Id);
3005 -- Add a subprogram body for RAS Access TSS
3007 -------------------------------------
3008 -- Add_Obj_RPC_Receiver_Completion --
3009 -------------------------------------
3011 procedure Add_Obj_RPC_Receiver_Completion
3014 RPC_Receiver : Entity_Id;
3015 Stub_Elements : Stub_Structure)
3018 -- The RPC receiver body should not be the completion of the
3019 -- declaration recorded in the stub structure, because then the
3020 -- occurrences of the formal parameters within the body should refer
3021 -- to the entities from the declaration, not from the completion, to
3022 -- which we do not have easy access. Instead, the RPC receiver body
3023 -- acts as its own declaration, and the RPC receiver declaration is
3024 -- completed by a renaming-as-body.
3027 Make_Subprogram_Renaming_Declaration (Loc,
3029 Copy_Specification (Loc,
3030 Specification (Stub_Elements.RPC_Receiver_Decl)),
3031 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
3032 end Add_Obj_RPC_Receiver_Completion;
3034 -----------------------
3035 -- Add_RACW_Features --
3036 -----------------------
3038 procedure Add_RACW_Features
3039 (RACW_Type : Entity_Id;
3040 Stub_Type : Entity_Id;
3041 Stub_Type_Access : Entity_Id;
3042 RPC_Receiver_Decl : Node_Id;
3043 Body_Decls : List_Id)
3045 RPC_Receiver : Node_Id;
3046 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
3049 Loc := Sloc (RACW_Type);
3053 -- For a RAS, the RPC receiver is that of the RCI unit, not that
3054 -- of the corresponding distributed object type. We retrieve its
3055 -- address from the local proxy object.
3057 RPC_Receiver := Make_Selected_Component (Loc,
3059 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
3060 Selector_Name => Make_Identifier (Loc, Name_Receiver));
3063 RPC_Receiver := Make_Attribute_Reference (Loc,
3064 Prefix => New_Occurrence_Of (
3065 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
3066 Attribute_Name => Name_Address);
3069 Add_RACW_Write_Attribute
3076 Add_RACW_Read_Attribute
3081 end Add_RACW_Features;
3083 -----------------------------
3084 -- Add_RACW_Read_Attribute --
3085 -----------------------------
3087 procedure Add_RACW_Read_Attribute
3088 (RACW_Type : Entity_Id;
3089 Stub_Type : Entity_Id;
3090 Stub_Type_Access : Entity_Id;
3091 Body_Decls : List_Id)
3093 Proc_Decl : Node_Id;
3094 Attr_Decl : Node_Id;
3096 Body_Node : Node_Id;
3098 Statements : constant List_Id := New_List;
3100 Local_Statements : List_Id;
3101 Remote_Statements : List_Id;
3102 -- Various parts of the procedure
3104 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
3105 Asynchronous_Flag : constant Entity_Id :=
3106 Asynchronous_Flags_Table.Get (RACW_Type);
3107 pragma Assert (Present (Asynchronous_Flag));
3109 -- Prepare local identifiers
3111 Source_Partition : Entity_Id;
3112 Source_Receiver : Entity_Id;
3113 Source_Address : Entity_Id;
3114 Local_Stub : Entity_Id;
3115 Stubbed_Result : Entity_Id;
3117 -- Start of processing for Add_RACW_Read_Attribute
3120 Build_Stream_Procedure (Loc,
3121 RACW_Type, Body_Node, Pnam, Statements, Outp => True);
3122 Proc_Decl := Make_Subprogram_Declaration (Loc,
3123 Copy_Specification (Loc, Specification (Body_Node)));
3126 Make_Attribute_Definition_Clause (Loc,
3127 Name => New_Occurrence_Of (RACW_Type, Loc),
3131 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3133 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3134 Insert_After (Proc_Decl, Attr_Decl);
3136 if No (Body_Decls) then
3138 -- Case of processing an RACW type from another unit than the
3139 -- main one: do not generate a body.
3144 -- Prepare local identifiers
3146 Source_Partition := Make_Temporary (Loc, 'P');
3147 Source_Receiver := Make_Temporary (Loc, 'S');
3148 Source_Address := Make_Temporary (Loc, 'P');
3149 Local_Stub := Make_Temporary (Loc, 'L');
3150 Stubbed_Result := Make_Temporary (Loc, 'S');
3152 -- Generate object declarations
3155 Make_Object_Declaration (Loc,
3156 Defining_Identifier => Source_Partition,
3157 Object_Definition =>
3158 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
3160 Make_Object_Declaration (Loc,
3161 Defining_Identifier => Source_Receiver,
3162 Object_Definition =>
3163 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3165 Make_Object_Declaration (Loc,
3166 Defining_Identifier => Source_Address,
3167 Object_Definition =>
3168 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3170 Make_Object_Declaration (Loc,
3171 Defining_Identifier => Local_Stub,
3172 Aliased_Present => True,
3173 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
3175 Make_Object_Declaration (Loc,
3176 Defining_Identifier => Stubbed_Result,
3177 Object_Definition =>
3178 New_Occurrence_Of (Stub_Type_Access, Loc),
3180 Make_Attribute_Reference (Loc,
3182 New_Occurrence_Of (Local_Stub, Loc),
3184 Name_Unchecked_Access)));
3186 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3188 Append_List_To (Statements, New_List (
3189 Make_Attribute_Reference (Loc,
3191 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3192 Attribute_Name => Name_Read,
3193 Expressions => New_List (
3195 New_Occurrence_Of (Source_Partition, Loc))),
3197 Make_Attribute_Reference (Loc,
3199 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3202 Expressions => New_List (
3204 New_Occurrence_Of (Source_Receiver, Loc))),
3206 Make_Attribute_Reference (Loc,
3208 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3211 Expressions => New_List (
3213 New_Occurrence_Of (Source_Address, Loc)))));
3215 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3217 Set_Etype (Stubbed_Result, Stub_Type_Access);
3219 -- If the Address is Null_Address, then return a null object, unless
3220 -- RACW_Type is null-excluding, in which case unconditionally raise
3221 -- CONSTRAINT_ERROR instead.
3224 Zero_Statements : List_Id;
3225 -- Statements executed when a zero value is received
3228 if Can_Never_Be_Null (RACW_Type) then
3229 Zero_Statements := New_List (
3230 Make_Raise_Constraint_Error (Loc,
3231 Reason => CE_Null_Not_Allowed));
3233 Zero_Statements := New_List (
3234 Make_Assignment_Statement (Loc,
3236 Expression => Make_Null (Loc)),
3237 Make_Simple_Return_Statement (Loc));
3240 Append_To (Statements,
3241 Make_Implicit_If_Statement (RACW_Type,
3244 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3245 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3246 Then_Statements => Zero_Statements));
3249 -- If the RACW denotes an object created on the current partition,
3250 -- Local_Statements will be executed. The real object will be used.
3252 Local_Statements := New_List (
3253 Make_Assignment_Statement (Loc,
3256 Unchecked_Convert_To (RACW_Type,
3257 OK_Convert_To (RTE (RE_Address),
3258 New_Occurrence_Of (Source_Address, Loc)))));
3260 -- If the object is located on another partition, then a stub object
3261 -- will be created with all the information needed to rebuild the
3262 -- real object at the other end.
3264 Remote_Statements := New_List (
3266 Make_Assignment_Statement (Loc,
3267 Name => Make_Selected_Component (Loc,
3268 Prefix => Stubbed_Result,
3269 Selector_Name => Name_Origin),
3271 New_Occurrence_Of (Source_Partition, Loc)),
3273 Make_Assignment_Statement (Loc,
3274 Name => Make_Selected_Component (Loc,
3275 Prefix => Stubbed_Result,
3276 Selector_Name => Name_Receiver),
3278 New_Occurrence_Of (Source_Receiver, Loc)),
3280 Make_Assignment_Statement (Loc,
3281 Name => Make_Selected_Component (Loc,
3282 Prefix => Stubbed_Result,
3283 Selector_Name => Name_Addr),
3285 New_Occurrence_Of (Source_Address, Loc)));
3287 Append_To (Remote_Statements,
3288 Make_Assignment_Statement (Loc,
3289 Name => Make_Selected_Component (Loc,
3290 Prefix => Stubbed_Result,
3291 Selector_Name => Name_Asynchronous),
3293 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3295 Append_List_To (Remote_Statements,
3296 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3297 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3298 -- set on the stub type if, and only if, the RACW type has a pragma
3299 -- Asynchronous. This is incorrect for RACWs that implement RAS
3300 -- types, because in that case the /designated subprogram/ (not the
3301 -- type) might be asynchronous, and that causes the stub to need to
3302 -- be asynchronous too. A solution is to transport a RAS as a struct
3303 -- containing a RACW and an asynchronous flag, and to properly alter
3304 -- the Asynchronous component in the stub type in the RAS's Input
3307 Append_To (Remote_Statements,
3308 Make_Assignment_Statement (Loc,
3310 Expression => Unchecked_Convert_To (RACW_Type,
3311 New_Occurrence_Of (Stubbed_Result, Loc))));
3313 -- Distinguish between the local and remote cases, and execute the
3314 -- appropriate piece of code.
3316 Append_To (Statements,
3317 Make_Implicit_If_Statement (RACW_Type,
3321 Make_Function_Call (Loc,
3322 Name => New_Occurrence_Of (
3323 RTE (RE_Get_Local_Partition_Id), Loc)),
3324 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3325 Then_Statements => Local_Statements,
3326 Else_Statements => Remote_Statements));
3328 Set_Declarations (Body_Node, Decls);
3329 Append_To (Body_Decls, Body_Node);
3330 end Add_RACW_Read_Attribute;
3332 ------------------------------
3333 -- Add_RACW_Write_Attribute --
3334 ------------------------------
3336 procedure Add_RACW_Write_Attribute
3337 (RACW_Type : Entity_Id;
3338 Stub_Type : Entity_Id;
3339 Stub_Type_Access : Entity_Id;
3340 RPC_Receiver : Node_Id;
3341 Body_Decls : List_Id)
3343 Body_Node : Node_Id;
3344 Proc_Decl : Node_Id;
3345 Attr_Decl : Node_Id;
3347 Statements : constant List_Id := New_List;
3348 Local_Statements : List_Id;
3349 Remote_Statements : List_Id;
3350 Null_Statements : List_Id;
3352 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
3355 Build_Stream_Procedure
3356 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
3358 Proc_Decl := Make_Subprogram_Declaration (Loc,
3359 Copy_Specification (Loc, Specification (Body_Node)));
3362 Make_Attribute_Definition_Clause (Loc,
3363 Name => New_Occurrence_Of (RACW_Type, Loc),
3364 Chars => Name_Write,
3367 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3369 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3370 Insert_After (Proc_Decl, Attr_Decl);
3372 if No (Body_Decls) then
3376 -- Build the code fragment corresponding to the marshalling of a
3379 Local_Statements := New_List (
3381 Pack_Entity_Into_Stream_Access (Loc,
3382 Stream => Stream_Parameter,
3383 Object => RTE (RE_Get_Local_Partition_Id)),
3385 Pack_Node_Into_Stream_Access (Loc,
3386 Stream => Stream_Parameter,
3387 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3388 Etyp => RTE (RE_Unsigned_64)),
3390 Pack_Node_Into_Stream_Access (Loc,
3391 Stream => Stream_Parameter,
3392 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3393 Make_Attribute_Reference (Loc,
3395 Make_Explicit_Dereference (Loc,
3397 Attribute_Name => Name_Address)),
3398 Etyp => RTE (RE_Unsigned_64)));
3400 -- Build the code fragment corresponding to the marshalling of
3403 Remote_Statements := New_List (
3404 Pack_Node_Into_Stream_Access (Loc,
3405 Stream => Stream_Parameter,
3407 Make_Selected_Component (Loc,
3409 Unchecked_Convert_To (Stub_Type_Access, Object),
3410 Selector_Name => Make_Identifier (Loc, Name_Origin)),
3411 Etyp => RTE (RE_Partition_ID)),
3413 Pack_Node_Into_Stream_Access (Loc,
3414 Stream => Stream_Parameter,
3416 Make_Selected_Component (Loc,
3418 Unchecked_Convert_To (Stub_Type_Access, Object),
3419 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
3420 Etyp => RTE (RE_Unsigned_64)),
3422 Pack_Node_Into_Stream_Access (Loc,
3423 Stream => Stream_Parameter,
3425 Make_Selected_Component (Loc,
3427 Unchecked_Convert_To (Stub_Type_Access, Object),
3428 Selector_Name => Make_Identifier (Loc, Name_Addr)),
3429 Etyp => RTE (RE_Unsigned_64)));
3431 -- Build code fragment corresponding to marshalling of a null object
3433 Null_Statements := New_List (
3435 Pack_Entity_Into_Stream_Access (Loc,
3436 Stream => Stream_Parameter,
3437 Object => RTE (RE_Get_Local_Partition_Id)),
3439 Pack_Node_Into_Stream_Access (Loc,
3440 Stream => Stream_Parameter,
3441 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3442 Etyp => RTE (RE_Unsigned_64)),
3444 Pack_Node_Into_Stream_Access (Loc,
3445 Stream => Stream_Parameter,
3446 Object => Make_Integer_Literal (Loc, Uint_0),
3447 Etyp => RTE (RE_Unsigned_64)));
3449 Append_To (Statements,
3450 Make_Implicit_If_Statement (RACW_Type,
3453 Left_Opnd => Object,
3454 Right_Opnd => Make_Null (Loc)),
3456 Then_Statements => Null_Statements,
3458 Elsif_Parts => New_List (
3459 Make_Elsif_Part (Loc,
3463 Make_Attribute_Reference (Loc,
3465 Attribute_Name => Name_Tag),
3468 Make_Attribute_Reference (Loc,
3469 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3470 Attribute_Name => Name_Tag)),
3471 Then_Statements => Remote_Statements)),
3472 Else_Statements => Local_Statements));
3474 Append_To (Body_Decls, Body_Node);
3475 end Add_RACW_Write_Attribute;
3477 ------------------------
3478 -- Add_RAS_Access_TSS --
3479 ------------------------
3481 procedure Add_RAS_Access_TSS (N : Node_Id) is
3482 Loc : constant Source_Ptr := Sloc (N);
3484 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3485 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3486 -- Ras_Type is the access to subprogram type while Fat_Type is the
3487 -- corresponding record type.
3489 RACW_Type : constant Entity_Id :=
3490 Underlying_RACW_Type (Ras_Type);
3491 Desig : constant Entity_Id :=
3492 Etype (Designated_Type (RACW_Type));
3494 Stub_Elements : constant Stub_Structure :=
3495 Stubs_Table.Get (Desig);
3496 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3498 Proc : constant Entity_Id :=
3499 Make_Defining_Identifier (Loc,
3500 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3502 Proc_Spec : Node_Id;
3504 -- Formal parameters
3506 Package_Name : constant Entity_Id :=
3507 Make_Defining_Identifier (Loc,
3511 Subp_Id : constant Entity_Id :=
3512 Make_Defining_Identifier (Loc,
3514 -- Target subprogram
3516 Asynch_P : constant Entity_Id :=
3517 Make_Defining_Identifier (Loc,
3518 Chars => Name_Asynchronous);
3519 -- Is the procedure to which the 'Access applies asynchronous?
3521 All_Calls_Remote : constant Entity_Id :=
3522 Make_Defining_Identifier (Loc,
3523 Chars => Name_All_Calls_Remote);
3524 -- True if an All_Calls_Remote pragma applies to the RCI unit
3525 -- that contains the subprogram.
3527 -- Common local variables
3529 Proc_Decls : List_Id;
3530 Proc_Statements : List_Id;
3532 Origin : constant Entity_Id := Make_Temporary (Loc, 'P');
3534 -- Additional local variables for the local case
3536 Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P');
3538 -- Additional local variables for the remote case
3540 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
3541 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
3544 (Field_Name : Name_Id;
3545 Value : Node_Id) return Node_Id;
3546 -- Construct an assignment that sets the named component in the
3554 (Field_Name : Name_Id;
3555 Value : Node_Id) return Node_Id
3559 Make_Assignment_Statement (Loc,
3561 Make_Selected_Component (Loc,
3563 Selector_Name => Field_Name),
3564 Expression => Value);
3567 -- Start of processing for Add_RAS_Access_TSS
3570 Proc_Decls := New_List (
3572 -- Common declarations
3574 Make_Object_Declaration (Loc,
3575 Defining_Identifier => Origin,
3576 Constant_Present => True,
3577 Object_Definition =>
3578 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3580 Make_Function_Call (Loc,
3582 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3583 Parameter_Associations => New_List (
3584 New_Occurrence_Of (Package_Name, Loc)))),
3586 -- Declaration use only in the local case: proxy address
3588 Make_Object_Declaration (Loc,
3589 Defining_Identifier => Proxy_Addr,
3590 Object_Definition =>
3591 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3593 -- Declarations used only in the remote case: stub object and
3596 Make_Object_Declaration (Loc,
3597 Defining_Identifier => Local_Stub,
3598 Aliased_Present => True,
3599 Object_Definition =>
3600 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3602 Make_Object_Declaration (Loc,
3603 Defining_Identifier =>
3605 Object_Definition =>
3606 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3608 Make_Attribute_Reference (Loc,
3609 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3610 Attribute_Name => Name_Unchecked_Access)));
3612 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3614 -- Build_Get_Unique_RP_Call needs above information
3616 -- Note: Here we assume that the Fat_Type is a record
3617 -- containing just a pointer to a proxy or stub object.
3619 Proc_Statements := New_List (
3623 -- Get_RAS_Info (Pkg, Subp, PA);
3624 -- if Origin = Local_Partition_Id
3625 -- and then not All_Calls_Remote
3627 -- return Fat_Type!(PA);
3630 Make_Procedure_Call_Statement (Loc,
3631 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3632 Parameter_Associations => New_List (
3633 New_Occurrence_Of (Package_Name, Loc),
3634 New_Occurrence_Of (Subp_Id, Loc),
3635 New_Occurrence_Of (Proxy_Addr, Loc))),
3637 Make_Implicit_If_Statement (N,
3643 New_Occurrence_Of (Origin, Loc),
3645 Make_Function_Call (Loc,
3647 RTE (RE_Get_Local_Partition_Id), Loc))),
3651 New_Occurrence_Of (All_Calls_Remote, Loc))),
3653 Then_Statements => New_List (
3654 Make_Simple_Return_Statement (Loc,
3655 Unchecked_Convert_To (Fat_Type,
3656 OK_Convert_To (RTE (RE_Address),
3657 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3659 Set_Field (Name_Origin,
3660 New_Occurrence_Of (Origin, Loc)),
3662 Set_Field (Name_Receiver,
3663 Make_Function_Call (Loc,
3665 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3666 Parameter_Associations => New_List (
3667 New_Occurrence_Of (Package_Name, Loc)))),
3669 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3671 -- E.4.1(9) A remote call is asynchronous if it is a call to
3672 -- a procedure or a call through a value of an access-to-procedure
3673 -- type to which a pragma Asynchronous applies.
3675 -- Asynch_P is true when the procedure is asynchronous;
3676 -- Asynch_T is true when the type is asynchronous.
3678 Set_Field (Name_Asynchronous,
3680 New_Occurrence_Of (Asynch_P, Loc),
3681 New_Occurrence_Of (Boolean_Literals (
3682 Is_Asynchronous (Ras_Type)), Loc))));
3684 Append_List_To (Proc_Statements,
3685 Build_Get_Unique_RP_Call
3686 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3688 -- Return the newly created value
3690 Append_To (Proc_Statements,
3691 Make_Simple_Return_Statement (Loc,
3693 Unchecked_Convert_To (Fat_Type,
3694 New_Occurrence_Of (Stub_Ptr, Loc))));
3697 Make_Function_Specification (Loc,
3698 Defining_Unit_Name => Proc,
3699 Parameter_Specifications => New_List (
3700 Make_Parameter_Specification (Loc,
3701 Defining_Identifier => Package_Name,
3703 New_Occurrence_Of (Standard_String, Loc)),
3705 Make_Parameter_Specification (Loc,
3706 Defining_Identifier => Subp_Id,
3708 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3710 Make_Parameter_Specification (Loc,
3711 Defining_Identifier => Asynch_P,
3713 New_Occurrence_Of (Standard_Boolean, Loc)),
3715 Make_Parameter_Specification (Loc,
3716 Defining_Identifier => All_Calls_Remote,
3718 New_Occurrence_Of (Standard_Boolean, Loc))),
3720 Result_Definition =>
3721 New_Occurrence_Of (Fat_Type, Loc));
3723 -- Set the kind and return type of the function to prevent
3724 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3726 Set_Ekind (Proc, E_Function);
3727 Set_Etype (Proc, Fat_Type);
3730 Make_Subprogram_Body (Loc,
3731 Specification => Proc_Spec,
3732 Declarations => Proc_Decls,
3733 Handled_Statement_Sequence =>
3734 Make_Handled_Sequence_Of_Statements (Loc,
3735 Statements => Proc_Statements)));
3737 Set_TSS (Fat_Type, Proc);
3738 end Add_RAS_Access_TSS;
3740 -----------------------
3741 -- Add_RAST_Features --
3742 -----------------------
3744 procedure Add_RAST_Features
3745 (Vis_Decl : Node_Id;
3746 RAS_Type : Entity_Id)
3748 pragma Unreferenced (RAS_Type);
3750 Add_RAS_Access_TSS (Vis_Decl);
3751 end Add_RAST_Features;
3753 -----------------------------------------
3754 -- Add_Receiving_Stubs_To_Declarations --
3755 -----------------------------------------
3757 procedure Add_Receiving_Stubs_To_Declarations
3758 (Pkg_Spec : Node_Id;
3762 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3764 Request_Parameter : Node_Id;
3766 Pkg_RPC_Receiver : constant Entity_Id :=
3767 Make_Temporary (Loc, 'H');
3768 Pkg_RPC_Receiver_Statements : List_Id;
3769 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3770 Pkg_RPC_Receiver_Body : Node_Id;
3771 -- A Pkg_RPC_Receiver is built to decode the request
3773 Lookup_RAS : Node_Id;
3774 Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R');
3775 -- A remote subprogram is created to allow peers to look up RAS
3776 -- information using subprogram ids.
3778 Subp_Id : Entity_Id;
3779 Subp_Index : Entity_Id;
3780 -- Subprogram_Id as read from the incoming stream
3782 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
3783 Current_Stubs : Node_Id;
3785 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
3786 Subp_Info_List : constant List_Id := New_List;
3788 Register_Pkg_Actuals : constant List_Id := New_List;
3790 All_Calls_Remote_E : Entity_Id;
3791 Proxy_Object_Addr : Entity_Id;
3793 procedure Append_Stubs_To
3794 (RPC_Receiver_Cases : List_Id;
3796 Subprogram_Number : Int);
3797 -- Add one case to the specified RPC receiver case list
3798 -- associating Subprogram_Number with the subprogram declared
3799 -- by Declaration, for which we have receiving stubs in Stubs.
3801 procedure Visit_Subprogram (Decl : Node_Id);
3802 -- Generate receiving stub for one remote subprogram
3804 ---------------------
3805 -- Append_Stubs_To --
3806 ---------------------
3808 procedure Append_Stubs_To
3809 (RPC_Receiver_Cases : List_Id;
3811 Subprogram_Number : Int)
3814 Append_To (RPC_Receiver_Cases,
3815 Make_Case_Statement_Alternative (Loc,
3817 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3820 Make_Procedure_Call_Statement (Loc,
3822 New_Occurrence_Of (Defining_Entity (Stubs), Loc),
3823 Parameter_Associations => New_List (
3824 New_Occurrence_Of (Request_Parameter, Loc))))));
3825 end Append_Stubs_To;
3827 ----------------------
3828 -- Visit_Subprogram --
3829 ----------------------
3831 procedure Visit_Subprogram (Decl : Node_Id) is
3832 Loc : constant Source_Ptr := Sloc (Decl);
3833 Spec : constant Node_Id := Specification (Decl);
3834 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
3836 Subp_Val : String_Id;
3837 pragma Warnings (Off, Subp_Val);
3840 -- Disable expansion of stubs if serious errors have been
3841 -- diagnosed, because otherwise some illegal remote subprogram
3842 -- declarations could cause cascaded errors in stubs.
3844 if Serious_Errors_Detected /= 0 then
3848 -- Build receiving stub
3851 Build_Subprogram_Receiving_Stubs
3854 Nkind (Spec) = N_Procedure_Specification
3855 and then Is_Asynchronous (Subp_Def));
3857 Append_To (Decls, Current_Stubs);
3858 Analyze (Current_Stubs);
3862 Add_RAS_Proxy_And_Analyze (Decls,
3864 All_Calls_Remote_E => All_Calls_Remote_E,
3865 Proxy_Object_Addr => Proxy_Object_Addr);
3867 -- Compute distribution identifier
3869 Assign_Subprogram_Identifier
3870 (Subp_Def, Current_Subp_Number, Subp_Val);
3872 pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
3874 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
3875 -- table for this receiver. This aggregate must be kept consistent
3876 -- with the declaration of RCI_Subp_Info in
3877 -- System.Partition_Interface.
3879 Append_To (Subp_Info_List,
3880 Make_Component_Association (Loc,
3881 Choices => New_List (
3882 Make_Integer_Literal (Loc, Current_Subp_Number)),
3885 Make_Aggregate (Loc,
3886 Component_Associations => New_List (
3890 Make_Component_Association (Loc,
3892 New_List (Make_Identifier (Loc, Name_Addr)),
3894 New_Occurrence_Of (Proxy_Object_Addr, Loc))))));
3896 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3897 Stubs => Current_Stubs,
3898 Subprogram_Number => Current_Subp_Number);
3900 Current_Subp_Number := Current_Subp_Number + 1;
3901 end Visit_Subprogram;
3903 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
3905 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3908 -- Building receiving stubs consist in several operations:
3910 -- - a package RPC receiver must be built. This subprogram
3911 -- will get a Subprogram_Id from the incoming stream
3912 -- and will dispatch the call to the right subprogram;
3914 -- - a receiving stub for each subprogram visible in the package
3915 -- spec. This stub will read all the parameters from the stream,
3916 -- and put the result as well as the exception occurrence in the
3919 -- - a dummy package with an empty spec and a body made of an
3920 -- elaboration part, whose job is to register the receiving
3921 -- part of this RCI package on the name server. This is done
3922 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3924 Build_RPC_Receiver_Body (
3925 RPC_Receiver => Pkg_RPC_Receiver,
3926 Request => Request_Parameter,
3928 Subp_Index => Subp_Index,
3929 Stmts => Pkg_RPC_Receiver_Statements,
3930 Decl => Pkg_RPC_Receiver_Body);
3931 pragma Assert (Subp_Id = Subp_Index);
3933 -- A null subp_id denotes a call through a RAS, in which case the
3934 -- next Uint_64 element in the stream is the address of the local
3935 -- proxy object, from which we can retrieve the actual subprogram id.
3937 Append_To (Pkg_RPC_Receiver_Statements,
3938 Make_Implicit_If_Statement (Pkg_Spec,
3941 New_Occurrence_Of (Subp_Id, Loc),
3942 Make_Integer_Literal (Loc, 0)),
3944 Then_Statements => New_List (
3945 Make_Assignment_Statement (Loc,
3947 New_Occurrence_Of (Subp_Id, Loc),
3950 Make_Selected_Component (Loc,
3952 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3953 OK_Convert_To (RTE (RE_Address),
3954 Make_Attribute_Reference (Loc,
3956 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3959 Expressions => New_List (
3960 Make_Selected_Component (Loc,
3961 Prefix => Request_Parameter,
3962 Selector_Name => Name_Params))))),
3964 Selector_Name => Make_Identifier (Loc, Name_Subp_Id))))));
3966 -- Build a subprogram for RAS information lookups
3969 Make_Subprogram_Declaration (Loc,
3971 Make_Function_Specification (Loc,
3972 Defining_Unit_Name =>
3974 Parameter_Specifications => New_List (
3975 Make_Parameter_Specification (Loc,
3976 Defining_Identifier =>
3977 Make_Defining_Identifier (Loc, Name_Subp_Id),
3981 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3982 Result_Definition =>
3983 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3984 Append_To (Decls, Lookup_RAS);
3985 Analyze (Lookup_RAS);
3987 Current_Stubs := Build_Subprogram_Receiving_Stubs
3988 (Vis_Decl => Lookup_RAS,
3989 Asynchronous => False);
3990 Append_To (Decls, Current_Stubs);
3991 Analyze (Current_Stubs);
3993 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3994 Stubs => Current_Stubs,
3995 Subprogram_Number => 1);
3997 -- For each subprogram, the receiving stub will be built and a
3998 -- case statement will be made on the Subprogram_Id to dispatch
3999 -- to the right subprogram.
4001 All_Calls_Remote_E :=
4003 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
4005 Overload_Counter_Table.Reset;
4007 Visit_Spec (Pkg_Spec);
4009 -- If we receive an invalid Subprogram_Id, it is best to do nothing
4010 -- rather than raising an exception since we do not want someone
4011 -- to crash a remote partition by sending invalid subprogram ids.
4012 -- This is consistent with the other parts of the case statement
4013 -- since even in presence of incorrect parameters in the stream,
4014 -- every exception will be caught and (if the subprogram is not an
4015 -- APC) put into the result stream and sent away.
4017 Append_To (Pkg_RPC_Receiver_Cases,
4018 Make_Case_Statement_Alternative (Loc,
4019 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4020 Statements => New_List (Make_Null_Statement (Loc))));
4022 Append_To (Pkg_RPC_Receiver_Statements,
4023 Make_Case_Statement (Loc,
4024 Expression => New_Occurrence_Of (Subp_Id, Loc),
4025 Alternatives => Pkg_RPC_Receiver_Cases));
4028 Make_Object_Declaration (Loc,
4029 Defining_Identifier => Subp_Info_Array,
4030 Constant_Present => True,
4031 Aliased_Present => True,
4032 Object_Definition =>
4033 Make_Subtype_Indication (Loc,
4035 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
4037 Make_Index_Or_Discriminant_Constraint (Loc,
4040 Low_Bound => Make_Integer_Literal (Loc,
4041 First_RCI_Subprogram_Id),
4043 Make_Integer_Literal (Loc,
4045 First_RCI_Subprogram_Id
4046 + List_Length (Subp_Info_List) - 1)))))));
4048 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
4049 -- has zero length, and the declaration is for an empty array, in
4050 -- which case no initialization aggregate must be generated.
4052 if Present (First (Subp_Info_List)) then
4053 Set_Expression (Last (Decls),
4054 Make_Aggregate (Loc,
4055 Component_Associations => Subp_Info_List));
4057 -- No initialization provided: remove CONSTANT so that the
4058 -- declaration is not an incomplete deferred constant.
4061 Set_Constant_Present (Last (Decls), False);
4064 Analyze (Last (Decls));
4067 Subp_Info_Addr : Node_Id;
4068 -- Return statement for Lookup_RAS_Info: address of the subprogram
4069 -- information record for the requested subprogram id.
4072 if Present (First (Subp_Info_List)) then
4074 Make_Selected_Component (Loc,
4076 Make_Indexed_Component (Loc,
4077 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4078 Expressions => New_List (
4079 Convert_To (Standard_Integer,
4080 Make_Identifier (Loc, Name_Subp_Id)))),
4081 Selector_Name => Make_Identifier (Loc, Name_Addr));
4083 -- Case of no visible subprogram: just raise Constraint_Error, we
4084 -- know for sure we got junk from a remote partition.
4088 Make_Raise_Constraint_Error (Loc,
4089 Reason => CE_Range_Check_Failed);
4090 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
4094 Make_Subprogram_Body (Loc,
4096 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
4097 Declarations => No_List,
4098 Handled_Statement_Sequence =>
4099 Make_Handled_Sequence_Of_Statements (Loc,
4100 Statements => New_List (
4101 Make_Simple_Return_Statement (Loc,
4104 (RTE (RE_Unsigned_64), Subp_Info_Addr))))));
4107 Analyze (Last (Decls));
4109 Append_To (Decls, Pkg_RPC_Receiver_Body);
4110 Analyze (Last (Decls));
4112 Get_Library_Unit_Name_String (Pkg_Spec);
4116 Append_To (Register_Pkg_Actuals,
4117 Make_String_Literal (Loc,
4118 Strval => String_From_Name_Buffer));
4122 Append_To (Register_Pkg_Actuals,
4123 Make_Attribute_Reference (Loc,
4124 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
4125 Attribute_Name => Name_Unrestricted_Access));
4129 Append_To (Register_Pkg_Actuals,
4130 Make_Attribute_Reference (Loc,
4132 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
4133 Attribute_Name => Name_Version));
4137 Append_To (Register_Pkg_Actuals,
4138 Make_Attribute_Reference (Loc,
4139 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4140 Attribute_Name => Name_Address));
4144 Append_To (Register_Pkg_Actuals,
4145 Make_Attribute_Reference (Loc,
4146 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4147 Attribute_Name => Name_Length));
4149 -- Generate the call
4152 Make_Procedure_Call_Statement (Loc,
4154 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
4155 Parameter_Associations => Register_Pkg_Actuals));
4156 Analyze (Last (Stmts));
4157 end Add_Receiving_Stubs_To_Declarations;
4159 ---------------------------------
4160 -- Build_General_Calling_Stubs --
4161 ---------------------------------
4163 procedure Build_General_Calling_Stubs
4165 Statements : List_Id;
4166 Target_Partition : Entity_Id;
4167 Target_RPC_Receiver : Node_Id;
4168 Subprogram_Id : Node_Id;
4169 Asynchronous : Node_Id := Empty;
4170 Is_Known_Asynchronous : Boolean := False;
4171 Is_Known_Non_Asynchronous : Boolean := False;
4172 Is_Function : Boolean;
4174 Stub_Type : Entity_Id := Empty;
4175 RACW_Type : Entity_Id := Empty;
4178 Loc : constant Source_Ptr := Sloc (Nod);
4180 Stream_Parameter : Node_Id;
4181 -- Name of the stream used to transmit parameters to the remote
4184 Result_Parameter : Node_Id;
4185 -- Name of the result parameter (in non-APC cases) which get the
4186 -- result of the remote subprogram.
4188 Exception_Return_Parameter : Node_Id;
4189 -- Name of the parameter which will hold the exception sent by the
4190 -- remote subprogram.
4192 Current_Parameter : Node_Id;
4193 -- Current parameter being handled
4195 Ordered_Parameters_List : constant List_Id :=
4196 Build_Ordered_Parameters_List (Spec);
4198 Asynchronous_Statements : List_Id := No_List;
4199 Non_Asynchronous_Statements : List_Id := No_List;
4200 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4202 Extra_Formal_Statements : constant List_Id := New_List;
4203 -- List of statements for extra formal parameters. It will appear
4204 -- after the regular statements for writing out parameters.
4206 pragma Unreferenced (RACW_Type);
4207 -- Used only for the PolyORB case
4210 -- The general form of a calling stub for a given subprogram is:
4212 -- procedure X (...) is P : constant Partition_ID :=
4213 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4214 -- System.RPC.Params_Stream_Type (0); begin
4215 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4216 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4217 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4218 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4220 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4222 -- There are some variations: Do_APC is called for an asynchronous
4223 -- procedure and the part after the call is completely ommitted as
4224 -- well as the declaration of Result. For a function call, 'Input is
4225 -- always used to read the result even if it is constrained.
4227 Stream_Parameter := Make_Temporary (Loc, 'S');
4230 Make_Object_Declaration (Loc,
4231 Defining_Identifier => Stream_Parameter,
4232 Aliased_Present => True,
4233 Object_Definition =>
4234 Make_Subtype_Indication (Loc,
4236 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4238 Make_Index_Or_Discriminant_Constraint (Loc,
4240 New_List (Make_Integer_Literal (Loc, 0))))));
4242 if not Is_Known_Asynchronous then
4243 Result_Parameter := Make_Temporary (Loc, 'R');
4246 Make_Object_Declaration (Loc,
4247 Defining_Identifier => Result_Parameter,
4248 Aliased_Present => True,
4249 Object_Definition =>
4250 Make_Subtype_Indication (Loc,
4252 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4254 Make_Index_Or_Discriminant_Constraint (Loc,
4256 New_List (Make_Integer_Literal (Loc, 0))))));
4258 Exception_Return_Parameter := Make_Temporary (Loc, 'E');
4261 Make_Object_Declaration (Loc,
4262 Defining_Identifier => Exception_Return_Parameter,
4263 Object_Definition =>
4264 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4267 Result_Parameter := Empty;
4268 Exception_Return_Parameter := Empty;
4271 -- Put first the RPC receiver corresponding to the remote package
4273 Append_To (Statements,
4274 Make_Attribute_Reference (Loc,
4276 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4277 Attribute_Name => Name_Write,
4278 Expressions => New_List (
4279 Make_Attribute_Reference (Loc,
4280 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4281 Attribute_Name => Name_Access),
4282 Target_RPC_Receiver)));
4284 -- Then put the Subprogram_Id of the subprogram we want to call in
4287 Append_To (Statements,
4288 Make_Attribute_Reference (Loc,
4289 Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4290 Attribute_Name => Name_Write,
4291 Expressions => New_List (
4292 Make_Attribute_Reference (Loc,
4293 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4294 Attribute_Name => Name_Access),
4297 Current_Parameter := First (Ordered_Parameters_List);
4298 while Present (Current_Parameter) loop
4300 Typ : constant Node_Id :=
4301 Parameter_Type (Current_Parameter);
4303 Constrained : Boolean;
4305 Extra_Parameter : Entity_Id;
4308 if Is_RACW_Controlling_Formal
4309 (Current_Parameter, Stub_Type)
4311 -- In the case of a controlling formal argument, we marshall
4312 -- its addr field rather than the local stub.
4314 Append_To (Statements,
4315 Pack_Node_Into_Stream (Loc,
4316 Stream => Stream_Parameter,
4318 Make_Selected_Component (Loc,
4320 Defining_Identifier (Current_Parameter),
4321 Selector_Name => Name_Addr),
4322 Etyp => RTE (RE_Unsigned_64)));
4327 (Defining_Identifier (Current_Parameter), Loc);
4329 -- Access type parameters are transmitted as in out
4330 -- parameters. However, a dereference is needed so that
4331 -- we marshall the designated object.
4333 if Nkind (Typ) = N_Access_Definition then
4334 Value := Make_Explicit_Dereference (Loc, Value);
4335 Etyp := Etype (Subtype_Mark (Typ));
4337 Etyp := Etype (Typ);
4340 Constrained := not Transmit_As_Unconstrained (Etyp);
4342 -- Any parameter but unconstrained out parameters are
4343 -- transmitted to the peer.
4345 if In_Present (Current_Parameter)
4346 or else not Out_Present (Current_Parameter)
4347 or else not Constrained
4349 Append_To (Statements,
4350 Make_Attribute_Reference (Loc,
4351 Prefix => New_Occurrence_Of (Etyp, Loc),
4353 Output_From_Constrained (Constrained),
4354 Expressions => New_List (
4355 Make_Attribute_Reference (Loc,
4357 New_Occurrence_Of (Stream_Parameter, Loc),
4358 Attribute_Name => Name_Access),
4363 -- If the current parameter has a dynamic constrained status,
4364 -- then this status is transmitted as well.
4365 -- This should be done for accessibility as well ???
4367 if Nkind (Typ) /= N_Access_Definition
4368 and then Need_Extra_Constrained (Current_Parameter)
4370 -- In this block, we do not use the extra formal that has
4371 -- been created because it does not exist at the time of
4372 -- expansion when building calling stubs for remote access
4373 -- to subprogram types. We create an extra variable of this
4374 -- type and push it in the stream after the regular
4377 Extra_Parameter := Make_Temporary (Loc, 'P');
4380 Make_Object_Declaration (Loc,
4381 Defining_Identifier => Extra_Parameter,
4382 Constant_Present => True,
4383 Object_Definition =>
4384 New_Occurrence_Of (Standard_Boolean, Loc),
4386 Make_Attribute_Reference (Loc,
4389 Defining_Identifier (Current_Parameter), Loc),
4390 Attribute_Name => Name_Constrained)));
4392 Append_To (Extra_Formal_Statements,
4393 Make_Attribute_Reference (Loc,
4395 New_Occurrence_Of (Standard_Boolean, Loc),
4396 Attribute_Name => Name_Write,
4397 Expressions => New_List (
4398 Make_Attribute_Reference (Loc,
4401 (Stream_Parameter, Loc), Attribute_Name =>
4403 New_Occurrence_Of (Extra_Parameter, Loc))));
4406 Next (Current_Parameter);
4410 -- Append the formal statements list to the statements
4412 Append_List_To (Statements, Extra_Formal_Statements);
4414 if not Is_Known_Non_Asynchronous then
4416 -- Build the call to System.RPC.Do_APC
4418 Asynchronous_Statements := New_List (
4419 Make_Procedure_Call_Statement (Loc,
4421 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4422 Parameter_Associations => New_List (
4423 New_Occurrence_Of (Target_Partition, Loc),
4424 Make_Attribute_Reference (Loc,
4426 New_Occurrence_Of (Stream_Parameter, Loc),
4427 Attribute_Name => Name_Access))));
4429 Asynchronous_Statements := No_List;
4432 if not Is_Known_Asynchronous then
4434 -- Build the call to System.RPC.Do_RPC
4436 Non_Asynchronous_Statements := New_List (
4437 Make_Procedure_Call_Statement (Loc,
4439 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4440 Parameter_Associations => New_List (
4441 New_Occurrence_Of (Target_Partition, Loc),
4443 Make_Attribute_Reference (Loc,
4445 New_Occurrence_Of (Stream_Parameter, Loc),
4446 Attribute_Name => Name_Access),
4448 Make_Attribute_Reference (Loc,
4450 New_Occurrence_Of (Result_Parameter, Loc),
4451 Attribute_Name => Name_Access))));
4453 -- Read the exception occurrence from the result stream and
4454 -- reraise it. It does no harm if this is a Null_Occurrence since
4455 -- this does nothing.
4457 Append_To (Non_Asynchronous_Statements,
4458 Make_Attribute_Reference (Loc,
4460 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4462 Attribute_Name => Name_Read,
4464 Expressions => New_List (
4465 Make_Attribute_Reference (Loc,
4467 New_Occurrence_Of (Result_Parameter, Loc),
4468 Attribute_Name => Name_Access),
4469 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4471 Append_To (Non_Asynchronous_Statements,
4472 Make_Procedure_Call_Statement (Loc,
4474 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4475 Parameter_Associations => New_List (
4476 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4480 -- If this is a function call, then read the value and return
4481 -- it. The return value is written/read using 'Output/'Input.
4483 Append_To (Non_Asynchronous_Statements,
4484 Make_Tag_Check (Loc,
4485 Make_Simple_Return_Statement (Loc,
4487 Make_Attribute_Reference (Loc,
4490 Etype (Result_Definition (Spec)), Loc),
4492 Attribute_Name => Name_Input,
4494 Expressions => New_List (
4495 Make_Attribute_Reference (Loc,
4497 New_Occurrence_Of (Result_Parameter, Loc),
4498 Attribute_Name => Name_Access))))));
4501 -- Loop around parameters and assign out (or in out)
4502 -- parameters. In the case of RACW, controlling arguments
4503 -- cannot possibly have changed since they are remote, so
4504 -- we do not read them from the stream.
4506 Current_Parameter := First (Ordered_Parameters_List);
4507 while Present (Current_Parameter) loop
4509 Typ : constant Node_Id :=
4510 Parameter_Type (Current_Parameter);
4517 (Defining_Identifier (Current_Parameter), Loc);
4519 if Nkind (Typ) = N_Access_Definition then
4520 Value := Make_Explicit_Dereference (Loc, Value);
4521 Etyp := Etype (Subtype_Mark (Typ));
4523 Etyp := Etype (Typ);
4526 if (Out_Present (Current_Parameter)
4527 or else Nkind (Typ) = N_Access_Definition)
4528 and then Etyp /= Stub_Type
4530 Append_To (Non_Asynchronous_Statements,
4531 Make_Attribute_Reference (Loc,
4533 New_Occurrence_Of (Etyp, Loc),
4535 Attribute_Name => Name_Read,
4537 Expressions => New_List (
4538 Make_Attribute_Reference (Loc,
4540 New_Occurrence_Of (Result_Parameter, Loc),
4541 Attribute_Name => Name_Access),
4546 Next (Current_Parameter);
4551 if Is_Known_Asynchronous then
4552 Append_List_To (Statements, Asynchronous_Statements);
4554 elsif Is_Known_Non_Asynchronous then
4555 Append_List_To (Statements, Non_Asynchronous_Statements);
4558 pragma Assert (Present (Asynchronous));
4559 Prepend_To (Asynchronous_Statements,
4560 Make_Attribute_Reference (Loc,
4561 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4562 Attribute_Name => Name_Write,
4563 Expressions => New_List (
4564 Make_Attribute_Reference (Loc,
4566 New_Occurrence_Of (Stream_Parameter, Loc),
4567 Attribute_Name => Name_Access),
4568 New_Occurrence_Of (Standard_True, Loc))));
4570 Prepend_To (Non_Asynchronous_Statements,
4571 Make_Attribute_Reference (Loc,
4572 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4573 Attribute_Name => Name_Write,
4574 Expressions => New_List (
4575 Make_Attribute_Reference (Loc,
4577 New_Occurrence_Of (Stream_Parameter, Loc),
4578 Attribute_Name => Name_Access),
4579 New_Occurrence_Of (Standard_False, Loc))));
4581 Append_To (Statements,
4582 Make_Implicit_If_Statement (Nod,
4583 Condition => Asynchronous,
4584 Then_Statements => Asynchronous_Statements,
4585 Else_Statements => Non_Asynchronous_Statements));
4587 end Build_General_Calling_Stubs;
4589 -----------------------------
4590 -- Build_RPC_Receiver_Body --
4591 -----------------------------
4593 procedure Build_RPC_Receiver_Body
4594 (RPC_Receiver : Entity_Id;
4595 Request : out Entity_Id;
4596 Subp_Id : out Entity_Id;
4597 Subp_Index : out Entity_Id;
4598 Stmts : out List_Id;
4601 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4603 RPC_Receiver_Spec : Node_Id;
4604 RPC_Receiver_Decls : List_Id;
4607 Request := Make_Defining_Identifier (Loc, Name_R);
4609 RPC_Receiver_Spec :=
4610 Build_RPC_Receiver_Specification
4611 (RPC_Receiver => RPC_Receiver,
4612 Request_Parameter => Request);
4614 Subp_Id := Make_Temporary (Loc, 'P');
4615 Subp_Index := Subp_Id;
4617 -- Subp_Id may not be a constant, because in the case of the RPC
4618 -- receiver for an RCI package, when a call is received from a RAS
4619 -- dereference, it will be assigned during subsequent processing.
4621 RPC_Receiver_Decls := New_List (
4622 Make_Object_Declaration (Loc,
4623 Defining_Identifier => Subp_Id,
4624 Object_Definition =>
4625 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4627 Make_Attribute_Reference (Loc,
4629 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4630 Attribute_Name => Name_Input,
4631 Expressions => New_List (
4632 Make_Selected_Component (Loc,
4634 Selector_Name => Name_Params)))));
4639 Make_Subprogram_Body (Loc,
4640 Specification => RPC_Receiver_Spec,
4641 Declarations => RPC_Receiver_Decls,
4642 Handled_Statement_Sequence =>
4643 Make_Handled_Sequence_Of_Statements (Loc,
4644 Statements => Stmts));
4645 end Build_RPC_Receiver_Body;
4647 -----------------------
4648 -- Build_Stub_Target --
4649 -----------------------
4651 function Build_Stub_Target
4654 RCI_Locator : Entity_Id;
4655 Controlling_Parameter : Entity_Id) return RPC_Target
4657 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4660 Target_Info.Partition := Make_Temporary (Loc, 'P');
4662 if Present (Controlling_Parameter) then
4664 Make_Object_Declaration (Loc,
4665 Defining_Identifier => Target_Info.Partition,
4666 Constant_Present => True,
4667 Object_Definition =>
4668 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4671 Make_Selected_Component (Loc,
4672 Prefix => Controlling_Parameter,
4673 Selector_Name => Name_Origin)));
4675 Target_Info.RPC_Receiver :=
4676 Make_Selected_Component (Loc,
4677 Prefix => Controlling_Parameter,
4678 Selector_Name => Name_Receiver);
4682 Make_Object_Declaration (Loc,
4683 Defining_Identifier => Target_Info.Partition,
4684 Constant_Present => True,
4685 Object_Definition =>
4686 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4689 Make_Function_Call (Loc,
4690 Name => Make_Selected_Component (Loc,
4692 Make_Identifier (Loc, Chars (RCI_Locator)),
4694 Make_Identifier (Loc,
4695 Name_Get_Active_Partition_ID)))));
4697 Target_Info.RPC_Receiver :=
4698 Make_Selected_Component (Loc,
4700 Make_Identifier (Loc, Chars (RCI_Locator)),
4702 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4705 end Build_Stub_Target;
4707 --------------------------------------
4708 -- Build_Subprogram_Receiving_Stubs --
4709 --------------------------------------
4711 function Build_Subprogram_Receiving_Stubs
4712 (Vis_Decl : Node_Id;
4713 Asynchronous : Boolean;
4714 Dynamically_Asynchronous : Boolean := False;
4715 Stub_Type : Entity_Id := Empty;
4716 RACW_Type : Entity_Id := Empty;
4717 Parent_Primitive : Entity_Id := Empty) return Node_Id
4719 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4721 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
4722 -- Formal parameter for receiving stubs: a descriptor for an incoming
4725 Decls : constant List_Id := New_List;
4726 -- All the parameters will get declared before calling the real
4727 -- subprograms. Also the out parameters will be declared.
4729 Statements : constant List_Id := New_List;
4731 Extra_Formal_Statements : constant List_Id := New_List;
4732 -- Statements concerning extra formal parameters
4734 After_Statements : constant List_Id := New_List;
4735 -- Statements to be executed after the subprogram call
4737 Inner_Decls : List_Id := No_List;
4738 -- In case of a function, the inner declarations are needed since
4739 -- the result may be unconstrained.
4741 Excep_Handlers : List_Id := No_List;
4742 Excep_Choice : Entity_Id;
4743 Excep_Code : List_Id;
4745 Parameter_List : constant List_Id := New_List;
4746 -- List of parameters to be passed to the subprogram
4748 Current_Parameter : Node_Id;
4750 Ordered_Parameters_List : constant List_Id :=
4751 Build_Ordered_Parameters_List
4752 (Specification (Vis_Decl));
4754 Subp_Spec : Node_Id;
4755 -- Subprogram specification
4757 Called_Subprogram : Node_Id;
4758 -- The subprogram to call
4760 Null_Raise_Statement : Node_Id;
4762 Dynamic_Async : Entity_Id;
4765 if Present (RACW_Type) then
4766 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4768 Called_Subprogram :=
4770 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4773 if Dynamically_Asynchronous then
4774 Dynamic_Async := Make_Temporary (Loc, 'S');
4776 Dynamic_Async := Empty;
4779 if not Asynchronous or Dynamically_Asynchronous then
4781 -- The first statement after the subprogram call is a statement to
4782 -- write a Null_Occurrence into the result stream.
4784 Null_Raise_Statement :=
4785 Make_Attribute_Reference (Loc,
4787 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4788 Attribute_Name => Name_Write,
4789 Expressions => New_List (
4790 Make_Selected_Component (Loc,
4791 Prefix => Request_Parameter,
4792 Selector_Name => Name_Result),
4793 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4795 if Dynamically_Asynchronous then
4796 Null_Raise_Statement :=
4797 Make_Implicit_If_Statement (Vis_Decl,
4799 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4800 Then_Statements => New_List (Null_Raise_Statement));
4803 Append_To (After_Statements, Null_Raise_Statement);
4806 -- Loop through every parameter and get its value from the stream. If
4807 -- the parameter is unconstrained, then the parameter is read using
4808 -- 'Input at the point of declaration.
4810 Current_Parameter := First (Ordered_Parameters_List);
4811 while Present (Current_Parameter) loop
4814 Constrained : Boolean;
4816 Need_Extra_Constrained : Boolean;
4817 -- True when an Extra_Constrained actual is required
4819 Object : constant Entity_Id := Make_Temporary (Loc, 'P');
4821 Expr : Node_Id := Empty;
4823 Is_Controlling_Formal : constant Boolean :=
4824 Is_RACW_Controlling_Formal
4825 (Current_Parameter, Stub_Type);
4828 if Is_Controlling_Formal then
4830 -- We have a controlling formal parameter. Read its address
4831 -- rather than a real object. The address is in Unsigned_64
4834 Etyp := RTE (RE_Unsigned_64);
4836 Etyp := Etype (Parameter_Type (Current_Parameter));
4839 Constrained := not Transmit_As_Unconstrained (Etyp);
4841 if In_Present (Current_Parameter)
4842 or else not Out_Present (Current_Parameter)
4843 or else not Constrained
4844 or else Is_Controlling_Formal
4846 -- If an input parameter is constrained, then the read of
4847 -- the parameter is deferred until the beginning of the
4848 -- subprogram body. If it is unconstrained, then an
4849 -- expression is built for the object declaration and the
4850 -- variable is set using 'Input instead of 'Read. Note that
4851 -- this deferral does not change the order in which the
4852 -- actuals are read because Build_Ordered_Parameter_List
4853 -- puts them unconstrained first.
4856 Append_To (Statements,
4857 Make_Attribute_Reference (Loc,
4858 Prefix => New_Occurrence_Of (Etyp, Loc),
4859 Attribute_Name => Name_Read,
4860 Expressions => New_List (
4861 Make_Selected_Component (Loc,
4862 Prefix => Request_Parameter,
4863 Selector_Name => Name_Params),
4864 New_Occurrence_Of (Object, Loc))));
4868 -- Build and append Input_With_Tag_Check function
4871 Input_With_Tag_Check (Loc,
4874 Make_Selected_Component (Loc,
4875 Prefix => Request_Parameter,
4876 Selector_Name => Name_Params)));
4878 -- Prepare function call expression
4881 Make_Function_Call (Loc,
4885 (Specification (Last (Decls))), Loc));
4889 Need_Extra_Constrained :=
4890 Nkind (Parameter_Type (Current_Parameter)) /=
4893 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4895 Present (Extra_Constrained
4896 (Defining_Identifier (Current_Parameter)));
4898 -- We may not associate an extra constrained actual to a
4899 -- constant object, so if one is needed, declare the actual
4900 -- as a variable even if it won't be modified.
4902 Build_Actual_Object_Declaration
4905 Variable => Need_Extra_Constrained
4906 or else Out_Present (Current_Parameter),
4910 -- An out parameter may be written back using a 'Write
4911 -- attribute instead of a 'Output because it has been
4912 -- constrained by the parameter given to the caller. Note that
4913 -- out controlling arguments in the case of a RACW are not put
4914 -- back in the stream because the pointer on them has not
4917 if Out_Present (Current_Parameter)
4919 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4921 Append_To (After_Statements,
4922 Make_Attribute_Reference (Loc,
4923 Prefix => New_Occurrence_Of (Etyp, Loc),
4924 Attribute_Name => Name_Write,
4925 Expressions => New_List (
4926 Make_Selected_Component (Loc,
4927 Prefix => Request_Parameter,
4928 Selector_Name => Name_Result),
4929 New_Occurrence_Of (Object, Loc))));
4932 -- For RACW controlling formals, the Etyp of Object is always
4933 -- an RACW, even if the parameter is not of an anonymous access
4934 -- type. In such case, we need to dereference it at call time.
4936 if Is_Controlling_Formal then
4937 if Nkind (Parameter_Type (Current_Parameter)) /=
4940 Append_To (Parameter_List,
4941 Make_Parameter_Association (Loc,
4944 Defining_Identifier (Current_Parameter), Loc),
4945 Explicit_Actual_Parameter =>
4946 Make_Explicit_Dereference (Loc,
4947 Unchecked_Convert_To (RACW_Type,
4948 OK_Convert_To (RTE (RE_Address),
4949 New_Occurrence_Of (Object, Loc))))));
4952 Append_To (Parameter_List,
4953 Make_Parameter_Association (Loc,
4956 Defining_Identifier (Current_Parameter), Loc),
4957 Explicit_Actual_Parameter =>
4958 Unchecked_Convert_To (RACW_Type,
4959 OK_Convert_To (RTE (RE_Address),
4960 New_Occurrence_Of (Object, Loc)))));
4964 Append_To (Parameter_List,
4965 Make_Parameter_Association (Loc,
4968 Defining_Identifier (Current_Parameter), Loc),
4969 Explicit_Actual_Parameter =>
4970 New_Occurrence_Of (Object, Loc)));
4973 -- If the current parameter needs an extra formal, then read it
4974 -- from the stream and set the corresponding semantic field in
4975 -- the variable. If the kind of the parameter identifier is
4976 -- E_Void, then this is a compiler generated parameter that
4977 -- doesn't need an extra constrained status.
4979 -- The case of Extra_Accessibility should also be handled ???
4981 if Need_Extra_Constrained then
4983 Extra_Parameter : constant Entity_Id :=
4985 (Defining_Identifier
4986 (Current_Parameter));
4988 Formal_Entity : constant Entity_Id :=
4989 Make_Defining_Identifier
4990 (Loc, Chars (Extra_Parameter));
4992 Formal_Type : constant Entity_Id :=
4993 Etype (Extra_Parameter);
4997 Make_Object_Declaration (Loc,
4998 Defining_Identifier => Formal_Entity,
4999 Object_Definition =>
5000 New_Occurrence_Of (Formal_Type, Loc)));
5002 Append_To (Extra_Formal_Statements,
5003 Make_Attribute_Reference (Loc,
5004 Prefix => New_Occurrence_Of (
5006 Attribute_Name => Name_Read,
5007 Expressions => New_List (
5008 Make_Selected_Component (Loc,
5009 Prefix => Request_Parameter,
5010 Selector_Name => Name_Params),
5011 New_Occurrence_Of (Formal_Entity, Loc))));
5013 -- Note: the call to Set_Extra_Constrained below relies
5014 -- on the fact that Object's Ekind has been set by
5015 -- Build_Actual_Object_Declaration.
5017 Set_Extra_Constrained (Object, Formal_Entity);
5022 Next (Current_Parameter);
5025 -- Append the formal statements list at the end of regular statements
5027 Append_List_To (Statements, Extra_Formal_Statements);
5029 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
5031 -- The remote subprogram is a function. We build an inner block to
5032 -- be able to hold a potentially unconstrained result in a
5036 Etyp : constant Entity_Id :=
5037 Etype (Result_Definition (Specification (Vis_Decl)));
5038 Result : constant Node_Id := Make_Temporary (Loc, 'R');
5041 Inner_Decls := New_List (
5042 Make_Object_Declaration (Loc,
5043 Defining_Identifier => Result,
5044 Constant_Present => True,
5045 Object_Definition => New_Occurrence_Of (Etyp, Loc),
5047 Make_Function_Call (Loc,
5048 Name => Called_Subprogram,
5049 Parameter_Associations => Parameter_List)));
5051 if Is_Class_Wide_Type (Etyp) then
5053 -- For a remote call to a function with a class-wide type,
5054 -- check that the returned value satisfies the requirements
5057 Append_To (Inner_Decls,
5058 Make_Transportable_Check (Loc,
5059 New_Occurrence_Of (Result, Loc)));
5063 Append_To (After_Statements,
5064 Make_Attribute_Reference (Loc,
5065 Prefix => New_Occurrence_Of (Etyp, Loc),
5066 Attribute_Name => Name_Output,
5067 Expressions => New_List (
5068 Make_Selected_Component (Loc,
5069 Prefix => Request_Parameter,
5070 Selector_Name => Name_Result),
5071 New_Occurrence_Of (Result, Loc))));
5074 Append_To (Statements,
5075 Make_Block_Statement (Loc,
5076 Declarations => Inner_Decls,
5077 Handled_Statement_Sequence =>
5078 Make_Handled_Sequence_Of_Statements (Loc,
5079 Statements => After_Statements)));
5082 -- The remote subprogram is a procedure. We do not need any inner
5083 -- block in this case.
5085 if Dynamically_Asynchronous then
5087 Make_Object_Declaration (Loc,
5088 Defining_Identifier => Dynamic_Async,
5089 Object_Definition =>
5090 New_Occurrence_Of (Standard_Boolean, Loc)));
5092 Append_To (Statements,
5093 Make_Attribute_Reference (Loc,
5094 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5095 Attribute_Name => Name_Read,
5096 Expressions => New_List (
5097 Make_Selected_Component (Loc,
5098 Prefix => Request_Parameter,
5099 Selector_Name => Name_Params),
5100 New_Occurrence_Of (Dynamic_Async, Loc))));
5103 Append_To (Statements,
5104 Make_Procedure_Call_Statement (Loc,
5105 Name => Called_Subprogram,
5106 Parameter_Associations => Parameter_List));
5108 Append_List_To (Statements, After_Statements);
5111 if Asynchronous and then not Dynamically_Asynchronous then
5113 -- For an asynchronous procedure, add a null exception handler
5115 Excep_Handlers := New_List (
5116 Make_Implicit_Exception_Handler (Loc,
5117 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5118 Statements => New_List (Make_Null_Statement (Loc))));
5121 -- In the other cases, if an exception is raised, then the
5122 -- exception occurrence is copied into the output stream and
5123 -- no other output parameter is written.
5125 Excep_Choice := Make_Temporary (Loc, 'E');
5127 Excep_Code := New_List (
5128 Make_Attribute_Reference (Loc,
5130 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5131 Attribute_Name => Name_Write,
5132 Expressions => New_List (
5133 Make_Selected_Component (Loc,
5134 Prefix => Request_Parameter,
5135 Selector_Name => Name_Result),
5136 New_Occurrence_Of (Excep_Choice, Loc))));
5138 if Dynamically_Asynchronous then
5139 Excep_Code := New_List (
5140 Make_Implicit_If_Statement (Vis_Decl,
5141 Condition => Make_Op_Not (Loc,
5142 New_Occurrence_Of (Dynamic_Async, Loc)),
5143 Then_Statements => Excep_Code));
5146 Excep_Handlers := New_List (
5147 Make_Implicit_Exception_Handler (Loc,
5148 Choice_Parameter => Excep_Choice,
5149 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5150 Statements => Excep_Code));
5155 Make_Procedure_Specification (Loc,
5156 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
5158 Parameter_Specifications => New_List (
5159 Make_Parameter_Specification (Loc,
5160 Defining_Identifier => Request_Parameter,
5162 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5165 Make_Subprogram_Body (Loc,
5166 Specification => Subp_Spec,
5167 Declarations => Decls,
5168 Handled_Statement_Sequence =>
5169 Make_Handled_Sequence_Of_Statements (Loc,
5170 Statements => Statements,
5171 Exception_Handlers => Excep_Handlers));
5172 end Build_Subprogram_Receiving_Stubs;
5178 function Result return Node_Id is
5180 return Make_Identifier (Loc, Name_V);
5183 -----------------------
5184 -- RPC_Receiver_Decl --
5185 -----------------------
5187 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is
5188 Loc : constant Source_Ptr := Sloc (RACW_Type);
5189 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5192 -- No RPC receiver for remote access-to-subprogram
5199 Make_Subprogram_Declaration (Loc,
5200 Build_RPC_Receiver_Specification
5201 (RPC_Receiver => Make_Temporary (Loc, 'R'),
5202 Request_Parameter => Make_Defining_Identifier (Loc, Name_R)));
5203 end RPC_Receiver_Decl;
5205 ----------------------
5206 -- Stream_Parameter --
5207 ----------------------
5209 function Stream_Parameter return Node_Id is
5211 return Make_Identifier (Loc, Name_S);
5212 end Stream_Parameter;
5216 -------------------------------
5217 -- Get_And_Reset_RACW_Bodies --
5218 -------------------------------
5220 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5221 Desig : constant Entity_Id :=
5222 Etype (Designated_Type (RACW_Type));
5224 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5226 Body_Decls : List_Id;
5227 -- Returned list of declarations
5230 if Stub_Elements = Empty_Stub_Structure then
5232 -- Stub elements may be missing as a consequence of a previously
5238 Body_Decls := Stub_Elements.Body_Decls;
5239 Stub_Elements.Body_Decls := No_List;
5240 Stubs_Table.Set (Desig, Stub_Elements);
5242 end Get_And_Reset_RACW_Bodies;
5244 -----------------------
5245 -- Get_Stub_Elements --
5246 -----------------------
5248 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is
5249 Desig : constant Entity_Id :=
5250 Etype (Designated_Type (RACW_Type));
5251 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
5253 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5254 return Stub_Elements;
5255 end Get_Stub_Elements;
5257 -----------------------
5258 -- Get_Subprogram_Id --
5259 -----------------------
5261 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5262 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5264 pragma Assert (Result /= No_String);
5266 end Get_Subprogram_Id;
5268 -----------------------
5269 -- Get_Subprogram_Id --
5270 -----------------------
5272 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5274 return Get_Subprogram_Ids (Def).Int_Identifier;
5275 end Get_Subprogram_Id;
5277 ------------------------
5278 -- Get_Subprogram_Ids --
5279 ------------------------
5281 function Get_Subprogram_Ids
5282 (Def : Entity_Id) return Subprogram_Identifiers
5285 return Subprogram_Identifier_Table.Get (Def);
5286 end Get_Subprogram_Ids;
5292 function Hash (F : Entity_Id) return Hash_Index is
5294 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5297 function Hash (F : Name_Id) return Hash_Index is
5299 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5302 --------------------------
5303 -- Input_With_Tag_Check --
5304 --------------------------
5306 function Input_With_Tag_Check
5308 Var_Type : Entity_Id;
5309 Stream : Node_Id) return Node_Id
5313 Make_Subprogram_Body (Loc,
5315 Make_Function_Specification (Loc,
5316 Defining_Unit_Name => Make_Temporary (Loc, 'S'),
5317 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5318 Declarations => No_List,
5319 Handled_Statement_Sequence =>
5320 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5321 Make_Tag_Check (Loc,
5322 Make_Simple_Return_Statement (Loc,
5323 Make_Attribute_Reference (Loc,
5324 Prefix => New_Occurrence_Of (Var_Type, Loc),
5325 Attribute_Name => Name_Input,
5327 New_List (Stream)))))));
5328 end Input_With_Tag_Check;
5330 --------------------------------
5331 -- Is_RACW_Controlling_Formal --
5332 --------------------------------
5334 function Is_RACW_Controlling_Formal
5335 (Parameter : Node_Id;
5336 Stub_Type : Entity_Id) return Boolean
5341 -- If the kind of the parameter is E_Void, then it is not a controlling
5342 -- formal (this can happen in the context of RAS).
5344 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5348 -- If the parameter is not a controlling formal, then it cannot be
5349 -- possibly a RACW_Controlling_Formal.
5351 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5355 Typ := Parameter_Type (Parameter);
5356 return (Nkind (Typ) = N_Access_Definition
5357 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5358 or else Etype (Typ) = Stub_Type;
5359 end Is_RACW_Controlling_Formal;
5361 ------------------------------
5362 -- Make_Transportable_Check --
5363 ------------------------------
5365 function Make_Transportable_Check
5367 Expr : Node_Id) return Node_Id is
5370 Make_Raise_Program_Error (Loc,
5373 Build_Get_Transportable (Loc,
5374 Make_Selected_Component (Loc,
5376 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5377 Reason => PE_Non_Transportable_Actual);
5378 end Make_Transportable_Check;
5380 -----------------------------
5381 -- Make_Selected_Component --
5382 -----------------------------
5384 function Make_Selected_Component
5387 Selector_Name : Name_Id) return Node_Id
5390 return Make_Selected_Component (Loc,
5391 Prefix => New_Occurrence_Of (Prefix, Loc),
5392 Selector_Name => Make_Identifier (Loc, Selector_Name));
5393 end Make_Selected_Component;
5395 --------------------
5396 -- Make_Tag_Check --
5397 --------------------
5399 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5400 Occ : constant Entity_Id := Make_Temporary (Loc, 'E');
5403 return Make_Block_Statement (Loc,
5404 Handled_Statement_Sequence =>
5405 Make_Handled_Sequence_Of_Statements (Loc,
5406 Statements => New_List (N),
5408 Exception_Handlers => New_List (
5409 Make_Implicit_Exception_Handler (Loc,
5410 Choice_Parameter => Occ,
5412 Exception_Choices =>
5413 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5416 New_List (Make_Procedure_Call_Statement (Loc,
5418 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5419 New_List (New_Occurrence_Of (Occ, Loc))))))));
5422 ----------------------------
5423 -- Need_Extra_Constrained --
5424 ----------------------------
5426 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5427 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5429 return Out_Present (Parameter)
5430 and then Has_Discriminants (Etyp)
5431 and then not Is_Constrained (Etyp)
5432 and then not Is_Indefinite_Subtype (Etyp);
5433 end Need_Extra_Constrained;
5435 ------------------------------------
5436 -- Pack_Entity_Into_Stream_Access --
5437 ------------------------------------
5439 function Pack_Entity_Into_Stream_Access
5443 Etyp : Entity_Id := Empty) return Node_Id
5448 if Present (Etyp) then
5451 Typ := Etype (Object);
5455 Pack_Node_Into_Stream_Access (Loc,
5457 Object => New_Occurrence_Of (Object, Loc),
5459 end Pack_Entity_Into_Stream_Access;
5461 ---------------------------
5462 -- Pack_Node_Into_Stream --
5463 ---------------------------
5465 function Pack_Node_Into_Stream
5469 Etyp : Entity_Id) return Node_Id
5471 Write_Attribute : Name_Id := Name_Write;
5474 if not Is_Constrained (Etyp) then
5475 Write_Attribute := Name_Output;
5479 Make_Attribute_Reference (Loc,
5480 Prefix => New_Occurrence_Of (Etyp, Loc),
5481 Attribute_Name => Write_Attribute,
5482 Expressions => New_List (
5483 Make_Attribute_Reference (Loc,
5484 Prefix => New_Occurrence_Of (Stream, Loc),
5485 Attribute_Name => Name_Access),
5487 end Pack_Node_Into_Stream;
5489 ----------------------------------
5490 -- Pack_Node_Into_Stream_Access --
5491 ----------------------------------
5493 function Pack_Node_Into_Stream_Access
5497 Etyp : Entity_Id) return Node_Id
5499 Write_Attribute : Name_Id := Name_Write;
5502 if not Is_Constrained (Etyp) then
5503 Write_Attribute := Name_Output;
5507 Make_Attribute_Reference (Loc,
5508 Prefix => New_Occurrence_Of (Etyp, Loc),
5509 Attribute_Name => Write_Attribute,
5510 Expressions => New_List (
5513 end Pack_Node_Into_Stream_Access;
5515 ---------------------
5516 -- PolyORB_Support --
5517 ---------------------
5519 package body PolyORB_Support is
5521 -- Local subprograms
5523 procedure Add_RACW_Read_Attribute
5524 (RACW_Type : Entity_Id;
5525 Stub_Type : Entity_Id;
5526 Stub_Type_Access : Entity_Id;
5527 Body_Decls : List_Id);
5528 -- Add Read attribute for the RACW type. The declaration and attribute
5529 -- definition clauses are inserted right after the declaration of
5530 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5531 -- appended to it (case where the RACW declaration is in the main unit).
5533 procedure Add_RACW_Write_Attribute
5534 (RACW_Type : Entity_Id;
5535 Stub_Type : Entity_Id;
5536 Stub_Type_Access : Entity_Id;
5537 Body_Decls : List_Id);
5538 -- Same as above for the Write attribute
5540 procedure Add_RACW_From_Any
5541 (RACW_Type : Entity_Id;
5542 Body_Decls : List_Id);
5543 -- Add the From_Any TSS for this RACW type
5545 procedure Add_RACW_To_Any
5546 (RACW_Type : Entity_Id;
5547 Body_Decls : List_Id);
5548 -- Add the To_Any TSS for this RACW type
5550 procedure Add_RACW_TypeCode
5551 (Designated_Type : Entity_Id;
5552 RACW_Type : Entity_Id;
5553 Body_Decls : List_Id);
5554 -- Add the TypeCode TSS for this RACW type
5556 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5557 -- Add the From_Any TSS for this RAS type
5559 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5560 -- Add the To_Any TSS for this RAS type
5562 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5563 -- Add the TypeCode TSS for this RAS type
5565 procedure Add_RAS_Access_TSS (N : Node_Id);
5566 -- Add a subprogram body for RAS Access TSS
5568 -------------------------------------
5569 -- Add_Obj_RPC_Receiver_Completion --
5570 -------------------------------------
5572 procedure Add_Obj_RPC_Receiver_Completion
5575 RPC_Receiver : Entity_Id;
5576 Stub_Elements : Stub_Structure)
5578 Desig : constant Entity_Id :=
5579 Etype (Designated_Type (Stub_Elements.RACW_Type));
5582 Make_Procedure_Call_Statement (Loc,
5585 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5587 Parameter_Associations => New_List (
5591 Make_String_Literal (Loc,
5592 Fully_Qualified_Name_String (Desig)),
5596 Make_Attribute_Reference (Loc,
5599 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5605 Make_Attribute_Reference (Loc,
5608 Defining_Identifier (
5609 Stub_Elements.RPC_Receiver_Decl), Loc),
5612 end Add_Obj_RPC_Receiver_Completion;
5614 -----------------------
5615 -- Add_RACW_Features --
5616 -----------------------
5618 procedure Add_RACW_Features
5619 (RACW_Type : Entity_Id;
5621 Stub_Type : Entity_Id;
5622 Stub_Type_Access : Entity_Id;
5623 RPC_Receiver_Decl : Node_Id;
5624 Body_Decls : List_Id)
5626 pragma Unreferenced (RPC_Receiver_Decl);
5630 (RACW_Type => RACW_Type,
5631 Body_Decls => Body_Decls);
5634 (RACW_Type => RACW_Type,
5635 Body_Decls => Body_Decls);
5637 Add_RACW_Write_Attribute
5638 (RACW_Type => RACW_Type,
5639 Stub_Type => Stub_Type,
5640 Stub_Type_Access => Stub_Type_Access,
5641 Body_Decls => Body_Decls);
5643 Add_RACW_Read_Attribute
5644 (RACW_Type => RACW_Type,
5645 Stub_Type => Stub_Type,
5646 Stub_Type_Access => Stub_Type_Access,
5647 Body_Decls => Body_Decls);
5650 (Designated_Type => Desig,
5651 RACW_Type => RACW_Type,
5652 Body_Decls => Body_Decls);
5653 end Add_RACW_Features;
5655 -----------------------
5656 -- Add_RACW_From_Any --
5657 -----------------------
5659 procedure Add_RACW_From_Any
5660 (RACW_Type : Entity_Id;
5661 Body_Decls : List_Id)
5663 Loc : constant Source_Ptr := Sloc (RACW_Type);
5664 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5665 Fnam : constant Entity_Id :=
5666 Make_Defining_Identifier (Loc,
5667 Chars => New_External_Name (Chars (RACW_Type), 'F'));
5669 Func_Spec : Node_Id;
5670 Func_Decl : Node_Id;
5671 Func_Body : Node_Id;
5673 Statements : List_Id;
5674 -- Various parts of the subprogram
5676 Any_Parameter : constant Entity_Id :=
5677 Make_Defining_Identifier (Loc, Name_A);
5679 Asynchronous_Flag : constant Entity_Id :=
5680 Asynchronous_Flags_Table.Get (RACW_Type);
5681 -- The flag object declared in Add_RACW_Asynchronous_Flag
5685 Make_Function_Specification (Loc,
5686 Defining_Unit_Name =>
5688 Parameter_Specifications => New_List (
5689 Make_Parameter_Specification (Loc,
5690 Defining_Identifier =>
5693 New_Occurrence_Of (RTE (RE_Any), Loc))),
5694 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5696 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5697 -- entity in the declaration spec, not those of the body spec.
5699 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5700 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5701 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5703 if No (Body_Decls) then
5707 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5708 -- set on the stub type if, and only if, the RACW type has a pragma
5709 -- Asynchronous. This is incorrect for RACWs that implement RAS
5710 -- types, because in that case the /designated subprogram/ (not the
5711 -- type) might be asynchronous, and that causes the stub to need to
5712 -- be asynchronous too. A solution is to transport a RAS as a struct
5713 -- containing a RACW and an asynchronous flag, and to properly alter
5714 -- the Asynchronous component in the stub type in the RAS's _From_Any
5717 Statements := New_List (
5718 Make_Simple_Return_Statement (Loc,
5719 Expression => Unchecked_Convert_To (RACW_Type,
5720 Make_Function_Call (Loc,
5721 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5722 Parameter_Associations => New_List (
5723 Make_Function_Call (Loc,
5724 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5725 Parameter_Associations => New_List (
5726 New_Occurrence_Of (Any_Parameter, Loc))),
5727 Build_Stub_Tag (Loc, RACW_Type),
5728 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5729 New_Occurrence_Of (Asynchronous_Flag, Loc))))));
5732 Make_Subprogram_Body (Loc,
5733 Specification => Copy_Specification (Loc, Func_Spec),
5734 Declarations => No_List,
5735 Handled_Statement_Sequence =>
5736 Make_Handled_Sequence_Of_Statements (Loc,
5737 Statements => Statements));
5739 Append_To (Body_Decls, Func_Body);
5740 end Add_RACW_From_Any;
5742 -----------------------------
5743 -- Add_RACW_Read_Attribute --
5744 -----------------------------
5746 procedure Add_RACW_Read_Attribute
5747 (RACW_Type : Entity_Id;
5748 Stub_Type : Entity_Id;
5749 Stub_Type_Access : Entity_Id;
5750 Body_Decls : List_Id)
5752 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5754 Loc : constant Source_Ptr := Sloc (RACW_Type);
5756 Proc_Decl : Node_Id;
5757 Attr_Decl : Node_Id;
5759 Body_Node : Node_Id;
5761 Decls : constant List_Id := New_List;
5762 Statements : constant List_Id := New_List;
5763 Reference : constant Entity_Id :=
5764 Make_Defining_Identifier (Loc, Name_R);
5765 -- Various parts of the procedure
5767 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
5769 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5771 Asynchronous_Flag : constant Entity_Id :=
5772 Asynchronous_Flags_Table.Get (RACW_Type);
5773 pragma Assert (Present (Asynchronous_Flag));
5775 function Stream_Parameter return Node_Id;
5776 function Result return Node_Id;
5778 -- Functions to create occurrences of the formal parameter names
5784 function Result return Node_Id is
5786 return Make_Identifier (Loc, Name_V);
5789 ----------------------
5790 -- Stream_Parameter --
5791 ----------------------
5793 function Stream_Parameter return Node_Id is
5795 return Make_Identifier (Loc, Name_S);
5796 end Stream_Parameter;
5798 -- Start of processing for Add_RACW_Read_Attribute
5801 Build_Stream_Procedure
5802 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
5804 Proc_Decl := Make_Subprogram_Declaration (Loc,
5805 Copy_Specification (Loc, Specification (Body_Node)));
5808 Make_Attribute_Definition_Clause (Loc,
5809 Name => New_Occurrence_Of (RACW_Type, Loc),
5813 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5815 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5816 Insert_After (Proc_Decl, Attr_Decl);
5818 if No (Body_Decls) then
5823 Make_Object_Declaration (Loc,
5824 Defining_Identifier =>
5826 Object_Definition =>
5827 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5829 Append_List_To (Statements, New_List (
5830 Make_Attribute_Reference (Loc,
5832 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5833 Attribute_Name => Name_Read,
5834 Expressions => New_List (
5836 New_Occurrence_Of (Reference, Loc))),
5838 Make_Assignment_Statement (Loc,
5842 Unchecked_Convert_To (RACW_Type,
5843 Make_Function_Call (Loc,
5845 New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5846 Parameter_Associations => New_List (
5847 New_Occurrence_Of (Reference, Loc),
5848 Build_Stub_Tag (Loc, RACW_Type),
5849 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5850 New_Occurrence_Of (Asynchronous_Flag, Loc)))))));
5852 Set_Declarations (Body_Node, Decls);
5853 Append_To (Body_Decls, Body_Node);
5854 end Add_RACW_Read_Attribute;
5856 ---------------------
5857 -- Add_RACW_To_Any --
5858 ---------------------
5860 procedure Add_RACW_To_Any
5861 (RACW_Type : Entity_Id;
5862 Body_Decls : List_Id)
5864 Loc : constant Source_Ptr := Sloc (RACW_Type);
5866 Fnam : constant Entity_Id :=
5867 Make_Defining_Identifier (Loc,
5868 Chars => New_External_Name (Chars (RACW_Type), 'T'));
5870 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5872 Stub_Elements : constant Stub_Structure :=
5873 Get_Stub_Elements (RACW_Type);
5875 Func_Spec : Node_Id;
5876 Func_Decl : Node_Id;
5877 Func_Body : Node_Id;
5880 Statements : List_Id;
5881 -- Various parts of the subprogram
5883 RACW_Parameter : constant Entity_Id :=
5884 Make_Defining_Identifier (Loc, Name_R);
5886 Reference : constant Entity_Id := Make_Temporary (Loc, 'R');
5887 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
5891 Make_Function_Specification (Loc,
5892 Defining_Unit_Name =>
5894 Parameter_Specifications => New_List (
5895 Make_Parameter_Specification (Loc,
5896 Defining_Identifier =>
5899 New_Occurrence_Of (RACW_Type, Loc))),
5900 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5902 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5903 -- entity in the declaration spec, not in the body spec.
5905 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5907 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5908 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5910 if No (Body_Decls) then
5916 -- R : constant Object_Ref :=
5922 -- RPC_Receiver'Access);
5926 Make_Object_Declaration (Loc,
5927 Defining_Identifier => Reference,
5928 Constant_Present => True,
5929 Object_Definition =>
5930 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5932 Make_Function_Call (Loc,
5933 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5934 Parameter_Associations => New_List (
5935 Unchecked_Convert_To (RTE (RE_Address),
5936 New_Occurrence_Of (RACW_Parameter, Loc)),
5937 Make_String_Literal (Loc,
5938 Strval => Fully_Qualified_Name_String
5939 (Etype (Designated_Type (RACW_Type)))),
5940 Build_Stub_Tag (Loc, RACW_Type),
5941 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5942 Make_Attribute_Reference (Loc,
5945 (Defining_Identifier
5946 (Stub_Elements.RPC_Receiver_Decl), Loc),
5947 Attribute_Name => Name_Access)))),
5949 Make_Object_Declaration (Loc,
5950 Defining_Identifier => Any,
5951 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)));
5955 -- Any := TA_ObjRef (Reference);
5956 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5959 Statements := New_List (
5960 Make_Assignment_Statement (Loc,
5961 Name => New_Occurrence_Of (Any, Loc),
5963 Make_Function_Call (Loc,
5964 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5965 Parameter_Associations => New_List (
5966 New_Occurrence_Of (Reference, Loc)))),
5968 Make_Procedure_Call_Statement (Loc,
5969 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5970 Parameter_Associations => New_List (
5971 New_Occurrence_Of (Any, Loc),
5972 Make_Selected_Component (Loc,
5974 Defining_Identifier (
5975 Stub_Elements.RPC_Receiver_Decl),
5976 Selector_Name => Name_Obj_TypeCode))),
5978 Make_Simple_Return_Statement (Loc,
5979 Expression => New_Occurrence_Of (Any, Loc)));
5982 Make_Subprogram_Body (Loc,
5983 Specification => Copy_Specification (Loc, Func_Spec),
5984 Declarations => Decls,
5985 Handled_Statement_Sequence =>
5986 Make_Handled_Sequence_Of_Statements (Loc,
5987 Statements => Statements));
5988 Append_To (Body_Decls, Func_Body);
5989 end Add_RACW_To_Any;
5991 -----------------------
5992 -- Add_RACW_TypeCode --
5993 -----------------------
5995 procedure Add_RACW_TypeCode
5996 (Designated_Type : Entity_Id;
5997 RACW_Type : Entity_Id;
5998 Body_Decls : List_Id)
6000 Loc : constant Source_Ptr := Sloc (RACW_Type);
6002 Fnam : constant Entity_Id :=
6003 Make_Defining_Identifier (Loc,
6004 Chars => New_External_Name (Chars (RACW_Type), 'Y'));
6006 Stub_Elements : constant Stub_Structure :=
6007 Stubs_Table.Get (Designated_Type);
6008 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6010 Func_Spec : Node_Id;
6011 Func_Decl : Node_Id;
6012 Func_Body : Node_Id;
6015 -- The spec for this subprogram has a dummy 'access RACW' argument,
6016 -- which serves only for overloading purposes.
6019 Make_Function_Specification (Loc,
6020 Defining_Unit_Name => Fnam,
6021 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6023 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6024 -- entity in the declaration spec, not those of the body spec.
6026 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6027 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6028 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6030 if No (Body_Decls) then
6035 Make_Subprogram_Body (Loc,
6036 Specification => Copy_Specification (Loc, Func_Spec),
6037 Declarations => Empty_List,
6038 Handled_Statement_Sequence =>
6039 Make_Handled_Sequence_Of_Statements (Loc,
6040 Statements => New_List (
6041 Make_Simple_Return_Statement (Loc,
6043 Make_Selected_Component (Loc,
6046 (Stub_Elements.RPC_Receiver_Decl),
6047 Selector_Name => Name_Obj_TypeCode)))));
6049 Append_To (Body_Decls, Func_Body);
6050 end Add_RACW_TypeCode;
6052 ------------------------------
6053 -- Add_RACW_Write_Attribute --
6054 ------------------------------
6056 procedure Add_RACW_Write_Attribute
6057 (RACW_Type : Entity_Id;
6058 Stub_Type : Entity_Id;
6059 Stub_Type_Access : Entity_Id;
6060 Body_Decls : List_Id)
6062 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6064 Loc : constant Source_Ptr := Sloc (RACW_Type);
6066 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
6068 Stub_Elements : constant Stub_Structure :=
6069 Get_Stub_Elements (RACW_Type);
6071 Body_Node : Node_Id;
6072 Proc_Decl : Node_Id;
6073 Attr_Decl : Node_Id;
6075 Statements : constant List_Id := New_List;
6076 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
6078 function Stream_Parameter return Node_Id;
6079 function Object return Node_Id;
6080 -- Functions to create occurrences of the formal parameter names
6086 function Object return Node_Id is
6088 return Make_Identifier (Loc, Name_V);
6091 ----------------------
6092 -- Stream_Parameter --
6093 ----------------------
6095 function Stream_Parameter return Node_Id is
6097 return Make_Identifier (Loc, Name_S);
6098 end Stream_Parameter;
6100 -- Start of processing for Add_RACW_Write_Attribute
6103 Build_Stream_Procedure
6104 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
6107 Make_Subprogram_Declaration (Loc,
6108 Copy_Specification (Loc, Specification (Body_Node)));
6111 Make_Attribute_Definition_Clause (Loc,
6112 Name => New_Occurrence_Of (RACW_Type, Loc),
6113 Chars => Name_Write,
6116 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6118 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6119 Insert_After (Proc_Decl, Attr_Decl);
6121 if No (Body_Decls) then
6125 Append_To (Statements,
6126 Pack_Node_Into_Stream_Access (Loc,
6127 Stream => Stream_Parameter,
6129 Make_Function_Call (Loc,
6130 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6131 Parameter_Associations => New_List (
6132 Unchecked_Convert_To (RTE (RE_Address), Object),
6133 Make_String_Literal (Loc,
6134 Strval => Fully_Qualified_Name_String
6135 (Etype (Designated_Type (RACW_Type)))),
6136 Build_Stub_Tag (Loc, RACW_Type),
6137 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
6138 Make_Attribute_Reference (Loc,
6141 (Defining_Identifier
6142 (Stub_Elements.RPC_Receiver_Decl), Loc),
6143 Attribute_Name => Name_Access))),
6145 Etyp => RTE (RE_Object_Ref)));
6147 Append_To (Body_Decls, Body_Node);
6148 end Add_RACW_Write_Attribute;
6150 -----------------------
6151 -- Add_RAST_Features --
6152 -----------------------
6154 procedure Add_RAST_Features
6155 (Vis_Decl : Node_Id;
6156 RAS_Type : Entity_Id)
6159 Add_RAS_Access_TSS (Vis_Decl);
6161 Add_RAS_From_Any (RAS_Type);
6162 Add_RAS_TypeCode (RAS_Type);
6164 -- To_Any uses TypeCode, and therefore needs to be generated last
6166 Add_RAS_To_Any (RAS_Type);
6167 end Add_RAST_Features;
6169 ------------------------
6170 -- Add_RAS_Access_TSS --
6171 ------------------------
6173 procedure Add_RAS_Access_TSS (N : Node_Id) is
6174 Loc : constant Source_Ptr := Sloc (N);
6176 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6177 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6178 -- Ras_Type is the access to subprogram type; Fat_Type is the
6179 -- corresponding record type.
6181 RACW_Type : constant Entity_Id :=
6182 Underlying_RACW_Type (Ras_Type);
6184 Stub_Elements : constant Stub_Structure :=
6185 Get_Stub_Elements (RACW_Type);
6187 Proc : constant Entity_Id :=
6188 Make_Defining_Identifier (Loc,
6189 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6191 Proc_Spec : Node_Id;
6193 -- Formal parameters
6195 Package_Name : constant Entity_Id :=
6196 Make_Defining_Identifier (Loc,
6201 Subp_Id : constant Entity_Id :=
6202 Make_Defining_Identifier (Loc,
6205 -- Target subprogram
6207 Asynch_P : constant Entity_Id :=
6208 Make_Defining_Identifier (Loc,
6209 Chars => Name_Asynchronous);
6210 -- Is the procedure to which the 'Access applies asynchronous?
6212 All_Calls_Remote : constant Entity_Id :=
6213 Make_Defining_Identifier (Loc,
6214 Chars => Name_All_Calls_Remote);
6215 -- True if an All_Calls_Remote pragma applies to the RCI unit
6216 -- that contains the subprogram.
6218 -- Common local variables
6220 Proc_Decls : List_Id;
6221 Proc_Statements : List_Id;
6223 Subp_Ref : constant Entity_Id :=
6224 Make_Defining_Identifier (Loc, Name_R);
6225 -- Reference that designates the target subprogram (returned
6226 -- by Get_RAS_Info).
6228 Is_Local : constant Entity_Id :=
6229 Make_Defining_Identifier (Loc, Name_L);
6230 Local_Addr : constant Entity_Id :=
6231 Make_Defining_Identifier (Loc, Name_A);
6232 -- For the call to Get_Local_Address
6234 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
6235 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
6236 -- Additional local variables for the remote case
6239 (Field_Name : Name_Id;
6240 Value : Node_Id) return Node_Id;
6241 -- Construct an assignment that sets the named component in the
6249 (Field_Name : Name_Id;
6250 Value : Node_Id) return Node_Id
6254 Make_Assignment_Statement (Loc,
6256 Make_Selected_Component (Loc,
6258 Selector_Name => Field_Name),
6259 Expression => Value);
6262 -- Start of processing for Add_RAS_Access_TSS
6265 Proc_Decls := New_List (
6267 -- Common declarations
6269 Make_Object_Declaration (Loc,
6270 Defining_Identifier => Subp_Ref,
6271 Object_Definition =>
6272 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6274 Make_Object_Declaration (Loc,
6275 Defining_Identifier => Is_Local,
6276 Object_Definition =>
6277 New_Occurrence_Of (Standard_Boolean, Loc)),
6279 Make_Object_Declaration (Loc,
6280 Defining_Identifier => Local_Addr,
6281 Object_Definition =>
6282 New_Occurrence_Of (RTE (RE_Address), Loc)),
6284 Make_Object_Declaration (Loc,
6285 Defining_Identifier => Local_Stub,
6286 Aliased_Present => True,
6287 Object_Definition =>
6288 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6290 Make_Object_Declaration (Loc,
6291 Defining_Identifier => Stub_Ptr,
6292 Object_Definition =>
6293 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6295 Make_Attribute_Reference (Loc,
6296 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6297 Attribute_Name => Name_Unchecked_Access)));
6299 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6300 -- Build_Get_Unique_RP_Call needs this information
6302 -- Get_RAS_Info (Pkg, Subp, R);
6303 -- Obtain a reference to the target subprogram
6305 Proc_Statements := New_List (
6306 Make_Procedure_Call_Statement (Loc,
6307 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6308 Parameter_Associations => New_List (
6309 New_Occurrence_Of (Package_Name, Loc),
6310 New_Occurrence_Of (Subp_Id, Loc),
6311 New_Occurrence_Of (Subp_Ref, Loc))),
6313 -- Get_Local_Address (R, L, A);
6314 -- Determine whether the subprogram is local (L), and if so
6315 -- obtain the local address of its proxy (A).
6317 Make_Procedure_Call_Statement (Loc,
6318 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6319 Parameter_Associations => New_List (
6320 New_Occurrence_Of (Subp_Ref, Loc),
6321 New_Occurrence_Of (Is_Local, Loc),
6322 New_Occurrence_Of (Local_Addr, Loc))));
6324 -- Note: Here we assume that the Fat_Type is a record containing just
6325 -- an access to a proxy or stub object.
6327 Append_To (Proc_Statements,
6331 Make_Implicit_If_Statement (N,
6332 Condition => New_Occurrence_Of (Is_Local, Loc),
6334 Then_Statements => New_List (
6336 -- if A.Target = null then
6338 Make_Implicit_If_Statement (N,
6341 Make_Selected_Component (Loc,
6343 Unchecked_Convert_To
6344 (RTE (RE_RAS_Proxy_Type_Access),
6345 New_Occurrence_Of (Local_Addr, Loc)),
6346 Selector_Name => Make_Identifier (Loc, Name_Target)),
6349 Then_Statements => New_List (
6351 -- A.Target := Entity_Of (Ref);
6353 Make_Assignment_Statement (Loc,
6355 Make_Selected_Component (Loc,
6357 Unchecked_Convert_To
6358 (RTE (RE_RAS_Proxy_Type_Access),
6359 New_Occurrence_Of (Local_Addr, Loc)),
6360 Selector_Name => Make_Identifier (Loc, Name_Target)),
6362 Make_Function_Call (Loc,
6363 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6364 Parameter_Associations => New_List (
6365 New_Occurrence_Of (Subp_Ref, Loc)))),
6367 -- Inc_Usage (A.Target);
6370 Make_Procedure_Call_Statement (Loc,
6371 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6372 Parameter_Associations => New_List (
6373 Make_Selected_Component (Loc,
6375 Unchecked_Convert_To
6376 (RTE (RE_RAS_Proxy_Type_Access),
6377 New_Occurrence_Of (Local_Addr, Loc)),
6379 Make_Identifier (Loc, Name_Target)))))),
6381 -- if not All_Calls_Remote then
6382 -- return Fat_Type!(A);
6385 Make_Implicit_If_Statement (N,
6389 New_Occurrence_Of (All_Calls_Remote, Loc)),
6391 Then_Statements => New_List (
6392 Make_Simple_Return_Statement (Loc,
6394 Unchecked_Convert_To
6395 (Fat_Type, New_Occurrence_Of (Local_Addr, Loc))))))));
6397 Append_List_To (Proc_Statements, New_List (
6399 -- Stub.Target := Entity_Of (Ref);
6401 Set_Field (Name_Target,
6402 Make_Function_Call (Loc,
6403 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6404 Parameter_Associations => New_List (
6405 New_Occurrence_Of (Subp_Ref, Loc)))),
6407 -- Inc_Usage (Stub.Target);
6409 Make_Procedure_Call_Statement (Loc,
6410 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6411 Parameter_Associations => New_List (
6412 Make_Selected_Component (Loc,
6414 Selector_Name => Name_Target))),
6416 -- E.4.1(9) A remote call is asynchronous if it is a call to
6417 -- a procedure, or a call through a value of an access-to-procedure
6418 -- type, to which a pragma Asynchronous applies.
6420 -- Parameter Asynch_P is true when the procedure is asynchronous;
6421 -- Expression Asynch_T is true when the type is asynchronous.
6423 Set_Field (Name_Asynchronous,
6425 Left_Opnd => New_Occurrence_Of (Asynch_P, Loc),
6428 (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc)))));
6430 Append_List_To (Proc_Statements,
6431 Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
6433 Append_To (Proc_Statements,
6434 Make_Simple_Return_Statement (Loc,
6436 Unchecked_Convert_To (Fat_Type,
6437 New_Occurrence_Of (Stub_Ptr, Loc))));
6440 Make_Function_Specification (Loc,
6441 Defining_Unit_Name => Proc,
6442 Parameter_Specifications => New_List (
6443 Make_Parameter_Specification (Loc,
6444 Defining_Identifier => Package_Name,
6446 New_Occurrence_Of (Standard_String, Loc)),
6448 Make_Parameter_Specification (Loc,
6449 Defining_Identifier => Subp_Id,
6451 New_Occurrence_Of (Standard_String, Loc)),
6453 Make_Parameter_Specification (Loc,
6454 Defining_Identifier => Asynch_P,
6456 New_Occurrence_Of (Standard_Boolean, Loc)),
6458 Make_Parameter_Specification (Loc,
6459 Defining_Identifier => All_Calls_Remote,
6461 New_Occurrence_Of (Standard_Boolean, Loc))),
6463 Result_Definition =>
6464 New_Occurrence_Of (Fat_Type, Loc));
6466 -- Set the kind and return type of the function to prevent
6467 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6469 Set_Ekind (Proc, E_Function);
6470 Set_Etype (Proc, Fat_Type);
6473 Make_Subprogram_Body (Loc,
6474 Specification => Proc_Spec,
6475 Declarations => Proc_Decls,
6476 Handled_Statement_Sequence =>
6477 Make_Handled_Sequence_Of_Statements (Loc,
6478 Statements => Proc_Statements)));
6480 Set_TSS (Fat_Type, Proc);
6481 end Add_RAS_Access_TSS;
6483 ----------------------
6484 -- Add_RAS_From_Any --
6485 ----------------------
6487 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6488 Loc : constant Source_Ptr := Sloc (RAS_Type);
6490 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6491 Make_TSS_Name (RAS_Type, TSS_From_Any));
6493 Func_Spec : Node_Id;
6495 Statements : List_Id;
6497 Any_Parameter : constant Entity_Id :=
6498 Make_Defining_Identifier (Loc, Name_A);
6501 Statements := New_List (
6502 Make_Simple_Return_Statement (Loc,
6504 Make_Aggregate (Loc,
6505 Component_Associations => New_List (
6506 Make_Component_Association (Loc,
6507 Choices => New_List (Make_Identifier (Loc, Name_Ras)),
6509 PolyORB_Support.Helpers.Build_From_Any_Call
6510 (Underlying_RACW_Type (RAS_Type),
6511 New_Occurrence_Of (Any_Parameter, Loc),
6515 Make_Function_Specification (Loc,
6516 Defining_Unit_Name => Fnam,
6517 Parameter_Specifications => New_List (
6518 Make_Parameter_Specification (Loc,
6519 Defining_Identifier => Any_Parameter,
6520 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
6521 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6524 Make_Subprogram_Body (Loc,
6525 Specification => Func_Spec,
6526 Declarations => No_List,
6527 Handled_Statement_Sequence =>
6528 Make_Handled_Sequence_Of_Statements (Loc,
6529 Statements => Statements)));
6530 Set_TSS (RAS_Type, Fnam);
6531 end Add_RAS_From_Any;
6533 --------------------
6534 -- Add_RAS_To_Any --
6535 --------------------
6537 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6538 Loc : constant Source_Ptr := Sloc (RAS_Type);
6540 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6541 Make_TSS_Name (RAS_Type, TSS_To_Any));
6544 Statements : List_Id;
6546 Func_Spec : Node_Id;
6548 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
6549 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
6550 RACW_Parameter : constant Node_Id :=
6551 Make_Selected_Component (Loc,
6552 Prefix => RAS_Parameter,
6553 Selector_Name => Name_Ras);
6556 -- Object declarations
6558 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6560 Make_Object_Declaration (Loc,
6561 Defining_Identifier => Any,
6562 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc),
6564 PolyORB_Support.Helpers.Build_To_Any_Call
6565 (RACW_Parameter, No_List)));
6567 Statements := New_List (
6568 Make_Procedure_Call_Statement (Loc,
6569 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6570 Parameter_Associations => New_List (
6571 New_Occurrence_Of (Any, Loc),
6572 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6575 Make_Simple_Return_Statement (Loc,
6576 Expression => New_Occurrence_Of (Any, Loc)));
6579 Make_Function_Specification (Loc,
6580 Defining_Unit_Name => Fnam,
6581 Parameter_Specifications => New_List (
6582 Make_Parameter_Specification (Loc,
6583 Defining_Identifier => RAS_Parameter,
6584 Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))),
6585 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6588 Make_Subprogram_Body (Loc,
6589 Specification => Func_Spec,
6590 Declarations => Decls,
6591 Handled_Statement_Sequence =>
6592 Make_Handled_Sequence_Of_Statements (Loc,
6593 Statements => Statements)));
6594 Set_TSS (RAS_Type, Fnam);
6597 ----------------------
6598 -- Add_RAS_TypeCode --
6599 ----------------------
6601 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6602 Loc : constant Source_Ptr := Sloc (RAS_Type);
6604 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6605 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6607 Func_Spec : Node_Id;
6608 Decls : constant List_Id := New_List;
6609 Name_String : String_Id;
6610 Repo_Id_String : String_Id;
6614 Make_Function_Specification (Loc,
6615 Defining_Unit_Name => Fnam,
6616 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6618 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6619 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6622 Make_Subprogram_Body (Loc,
6623 Specification => Func_Spec,
6624 Declarations => Decls,
6625 Handled_Statement_Sequence =>
6626 Make_Handled_Sequence_Of_Statements (Loc,
6627 Statements => New_List (
6628 Make_Simple_Return_Statement (Loc,
6630 Make_Function_Call (Loc,
6631 Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6632 Parameter_Associations => New_List (
6633 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6634 Make_Aggregate (Loc,
6637 Make_Function_Call (Loc,
6640 (RTE (RE_TA_Std_String), Loc),
6641 Parameter_Associations => New_List (
6642 Make_String_Literal (Loc, Name_String))),
6643 Make_Function_Call (Loc,
6646 (RTE (RE_TA_Std_String), Loc),
6647 Parameter_Associations => New_List (
6648 Make_String_Literal (Loc,
6649 Strval => Repo_Id_String))))))))))));
6650 Set_TSS (RAS_Type, Fnam);
6651 end Add_RAS_TypeCode;
6653 -----------------------------------------
6654 -- Add_Receiving_Stubs_To_Declarations --
6655 -----------------------------------------
6657 procedure Add_Receiving_Stubs_To_Declarations
6658 (Pkg_Spec : Node_Id;
6662 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6664 Pkg_RPC_Receiver : constant Entity_Id :=
6665 Make_Temporary (Loc, 'H');
6666 Pkg_RPC_Receiver_Object : Node_Id;
6667 Pkg_RPC_Receiver_Body : Node_Id;
6668 Pkg_RPC_Receiver_Decls : List_Id;
6669 Pkg_RPC_Receiver_Statements : List_Id;
6671 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6672 -- A Pkg_RPC_Receiver is built to decode the request
6675 -- Request object received from neutral layer
6677 Subp_Id : Entity_Id;
6678 -- Subprogram identifier as received from the neutral distribution
6681 Subp_Index : Entity_Id;
6682 -- Internal index as determined by matching either the method name
6683 -- from the request structure, or the local subprogram address (in
6686 Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L');
6688 Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A');
6689 -- Address of a local subprogram designated by a reference
6690 -- corresponding to a RAS.
6692 Dispatch_On_Address : constant List_Id := New_List;
6693 Dispatch_On_Name : constant List_Id := New_List;
6695 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
6697 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
6698 Subp_Info_List : constant List_Id := New_List;
6700 Register_Pkg_Actuals : constant List_Id := New_List;
6702 All_Calls_Remote_E : Entity_Id;
6704 procedure Append_Stubs_To
6705 (RPC_Receiver_Cases : List_Id;
6706 Declaration : Node_Id;
6709 Subp_Dist_Name : Entity_Id;
6710 Subp_Proxy_Addr : Entity_Id);
6711 -- Add one case to the specified RPC receiver case list associating
6712 -- Subprogram_Number with the subprogram declared by Declaration, for
6713 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6714 -- subprogram index. Subp_Dist_Name is the string used to call the
6715 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6716 -- object, used in the context of calls through remote
6717 -- access-to-subprogram types.
6719 procedure Visit_Subprogram (Decl : Node_Id);
6720 -- Generate receiving stub for one remote subprogram
6722 ---------------------
6723 -- Append_Stubs_To --
6724 ---------------------
6726 procedure Append_Stubs_To
6727 (RPC_Receiver_Cases : List_Id;
6728 Declaration : Node_Id;
6731 Subp_Dist_Name : Entity_Id;
6732 Subp_Proxy_Addr : Entity_Id)
6734 Case_Stmts : List_Id;
6736 Case_Stmts := New_List (
6737 Make_Procedure_Call_Statement (Loc,
6740 Defining_Entity (Stubs), Loc),
6741 Parameter_Associations =>
6742 New_List (New_Occurrence_Of (Request, Loc))));
6744 if Nkind (Specification (Declaration)) = N_Function_Specification
6746 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6748 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6751 Append_To (RPC_Receiver_Cases,
6752 Make_Case_Statement_Alternative (Loc,
6754 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6755 Statements => Case_Stmts));
6757 Append_To (Dispatch_On_Name,
6758 Make_Elsif_Part (Loc,
6760 Make_Function_Call (Loc,
6762 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6763 Parameter_Associations => New_List (
6764 New_Occurrence_Of (Subp_Id, Loc),
6765 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6767 Then_Statements => New_List (
6768 Make_Assignment_Statement (Loc,
6769 New_Occurrence_Of (Subp_Index, Loc),
6770 Make_Integer_Literal (Loc, Subp_Number)))));
6772 Append_To (Dispatch_On_Address,
6773 Make_Elsif_Part (Loc,
6776 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6777 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6779 Then_Statements => New_List (
6780 Make_Assignment_Statement (Loc,
6781 New_Occurrence_Of (Subp_Index, Loc),
6782 Make_Integer_Literal (Loc, Subp_Number)))));
6783 end Append_Stubs_To;
6785 ----------------------
6786 -- Visit_Subprogram --
6787 ----------------------
6789 procedure Visit_Subprogram (Decl : Node_Id) is
6790 Loc : constant Source_Ptr := Sloc (Decl);
6791 Spec : constant Node_Id := Specification (Decl);
6792 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
6794 Subp_Val : String_Id;
6796 Subp_Dist_Name : constant Entity_Id :=
6797 Make_Defining_Identifier (Loc,
6800 (Related_Id => Chars (Subp_Def),
6802 Suffix_Index => -1));
6804 Current_Stubs : Node_Id;
6805 Proxy_Obj_Addr : Entity_Id;
6808 -- Disable expansion of stubs if serious errors have been
6809 -- diagnosed, because otherwise some illegal remote subprogram
6810 -- declarations could cause cascaded errors in stubs.
6812 if Serious_Errors_Detected /= 0 then
6816 -- Build receiving stub
6819 Build_Subprogram_Receiving_Stubs
6821 Asynchronous => Nkind (Spec) = N_Procedure_Specification
6822 and then Is_Asynchronous (Subp_Def));
6824 Append_To (Decls, Current_Stubs);
6825 Analyze (Current_Stubs);
6829 Add_RAS_Proxy_And_Analyze (Decls,
6831 All_Calls_Remote_E => All_Calls_Remote_E,
6832 Proxy_Object_Addr => Proxy_Obj_Addr);
6834 -- Compute distribution identifier
6836 Assign_Subprogram_Identifier
6837 (Subp_Def, Current_Subp_Number, Subp_Val);
6840 (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
6843 Make_Object_Declaration (Loc,
6844 Defining_Identifier => Subp_Dist_Name,
6845 Constant_Present => True,
6846 Object_Definition =>
6847 New_Occurrence_Of (Standard_String, Loc),
6849 Make_String_Literal (Loc, Subp_Val)));
6850 Analyze (Last (Decls));
6852 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
6853 -- table for this receiver. The aggregate below must be kept
6854 -- consistent with the declaration of RCI_Subp_Info in
6855 -- System.Partition_Interface.
6857 Append_To (Subp_Info_List,
6858 Make_Component_Association (Loc,
6860 New_List (Make_Integer_Literal (Loc, Current_Subp_Number)),
6863 Make_Aggregate (Loc,
6864 Expressions => New_List (
6868 Make_Attribute_Reference (Loc,
6870 New_Occurrence_Of (Subp_Dist_Name, Loc),
6871 Attribute_Name => Name_Address),
6875 Make_Attribute_Reference (Loc,
6877 New_Occurrence_Of (Subp_Dist_Name, Loc),
6878 Attribute_Name => Name_Length),
6882 New_Occurrence_Of (Proxy_Obj_Addr, Loc)))));
6884 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6885 Declaration => Decl,
6886 Stubs => Current_Stubs,
6887 Subp_Number => Current_Subp_Number,
6888 Subp_Dist_Name => Subp_Dist_Name,
6889 Subp_Proxy_Addr => Proxy_Obj_Addr);
6891 Current_Subp_Number := Current_Subp_Number + 1;
6892 end Visit_Subprogram;
6894 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
6896 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6899 -- Building receiving stubs consist in several operations:
6901 -- - a package RPC receiver must be built. This subprogram will get
6902 -- a Subprogram_Id from the incoming stream and will dispatch the
6903 -- call to the right subprogram;
6905 -- - a receiving stub for each subprogram visible in the package
6906 -- spec. This stub will read all the parameters from the stream,
6907 -- and put the result as well as the exception occurrence in the
6910 Build_RPC_Receiver_Body (
6911 RPC_Receiver => Pkg_RPC_Receiver,
6914 Subp_Index => Subp_Index,
6915 Stmts => Pkg_RPC_Receiver_Statements,
6916 Decl => Pkg_RPC_Receiver_Body);
6917 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6919 -- Extract local address information from the target reference:
6920 -- if non-null, that means that this is a reference that denotes
6921 -- one particular operation, and hence that the operation name
6922 -- must not be taken into account for dispatching.
6924 Append_To (Pkg_RPC_Receiver_Decls,
6925 Make_Object_Declaration (Loc,
6926 Defining_Identifier => Is_Local,
6927 Object_Definition =>
6928 New_Occurrence_Of (Standard_Boolean, Loc)));
6930 Append_To (Pkg_RPC_Receiver_Decls,
6931 Make_Object_Declaration (Loc,
6932 Defining_Identifier => Local_Address,
6933 Object_Definition =>
6934 New_Occurrence_Of (RTE (RE_Address), Loc)));
6936 Append_To (Pkg_RPC_Receiver_Statements,
6937 Make_Procedure_Call_Statement (Loc,
6938 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6939 Parameter_Associations => New_List (
6940 Make_Selected_Component (Loc,
6942 Selector_Name => Name_Target),
6943 New_Occurrence_Of (Is_Local, Loc),
6944 New_Occurrence_Of (Local_Address, Loc))));
6946 -- For each subprogram, the receiving stub will be built and a case
6947 -- statement will be made on the Subprogram_Id to dispatch to the
6948 -- right subprogram.
6950 All_Calls_Remote_E := Boolean_Literals (
6951 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6953 Overload_Counter_Table.Reset;
6954 Reserve_NamingContext_Methods;
6956 Visit_Spec (Pkg_Spec);
6959 Make_Object_Declaration (Loc,
6960 Defining_Identifier => Subp_Info_Array,
6961 Constant_Present => True,
6962 Aliased_Present => True,
6963 Object_Definition =>
6964 Make_Subtype_Indication (Loc,
6966 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6968 Make_Index_Or_Discriminant_Constraint (Loc,
6972 Make_Integer_Literal (Loc,
6973 Intval => First_RCI_Subprogram_Id),
6975 Make_Integer_Literal (Loc,
6977 First_RCI_Subprogram_Id
6978 + List_Length (Subp_Info_List) - 1)))))));
6980 if Present (First (Subp_Info_List)) then
6981 Set_Expression (Last (Decls),
6982 Make_Aggregate (Loc,
6983 Component_Associations => Subp_Info_List));
6985 -- Generate the dispatch statement to determine the subprogram id
6986 -- of the called subprogram.
6988 -- We first test whether the reference that was used to make the
6989 -- call was the base RCI reference (in which case Local_Address is
6990 -- zero, and the method identifier from the request must be used
6991 -- to determine which subprogram is called) or a reference
6992 -- identifying one particular subprogram (in which case
6993 -- Local_Address is the address of that subprogram, and the
6994 -- method name from the request is ignored). The latter occurs
6995 -- for the case of a call through a remote access-to-subprogram.
6997 -- In each case, cascaded elsifs are used to determine the proper
6998 -- subprogram index. Using hash tables might be more efficient.
7000 Append_To (Pkg_RPC_Receiver_Statements,
7001 Make_Implicit_If_Statement (Pkg_Spec,
7004 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
7005 Right_Opnd => New_Occurrence_Of
7006 (RTE (RE_Null_Address), Loc)),
7008 Then_Statements => New_List (
7009 Make_Implicit_If_Statement (Pkg_Spec,
7010 Condition => New_Occurrence_Of (Standard_False, Loc),
7011 Then_Statements => New_List (
7012 Make_Null_Statement (Loc)),
7013 Elsif_Parts => Dispatch_On_Address)),
7015 Else_Statements => New_List (
7016 Make_Implicit_If_Statement (Pkg_Spec,
7017 Condition => New_Occurrence_Of (Standard_False, Loc),
7018 Then_Statements => New_List (Make_Null_Statement (Loc)),
7019 Elsif_Parts => Dispatch_On_Name))));
7022 -- For a degenerate RCI with no visible subprograms,
7023 -- Subp_Info_List has zero length, and the declaration is for an
7024 -- empty array, in which case no initialization aggregate must be
7025 -- generated. We do not generate a Dispatch_Statement either.
7027 -- No initialization provided: remove CONSTANT so that the
7028 -- declaration is not an incomplete deferred constant.
7030 Set_Constant_Present (Last (Decls), False);
7033 -- Analyze Subp_Info_Array declaration
7035 Analyze (Last (Decls));
7037 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7038 -- rather than raising an exception since we do not want someone
7039 -- to crash a remote partition by sending invalid subprogram ids.
7040 -- This is consistent with the other parts of the case statement
7041 -- since even in presence of incorrect parameters in the stream,
7042 -- every exception will be caught and (if the subprogram is not an
7043 -- APC) put into the result stream and sent away.
7045 Append_To (Pkg_RPC_Receiver_Cases,
7046 Make_Case_Statement_Alternative (Loc,
7047 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
7048 Statements => New_List (Make_Null_Statement (Loc))));
7050 Append_To (Pkg_RPC_Receiver_Statements,
7051 Make_Case_Statement (Loc,
7052 Expression => New_Occurrence_Of (Subp_Index, Loc),
7053 Alternatives => Pkg_RPC_Receiver_Cases));
7055 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7058 Append_To (Decls, Pkg_RPC_Receiver_Body);
7059 Analyze (Last (Decls));
7061 Pkg_RPC_Receiver_Object :=
7062 Make_Object_Declaration (Loc,
7063 Defining_Identifier => Make_Temporary (Loc, 'R'),
7064 Aliased_Present => True,
7065 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
7066 Append_To (Decls, Pkg_RPC_Receiver_Object);
7067 Analyze (Last (Decls));
7069 Get_Library_Unit_Name_String (Pkg_Spec);
7073 Append_To (Register_Pkg_Actuals,
7074 Make_String_Literal (Loc,
7075 Strval => String_From_Name_Buffer));
7079 Append_To (Register_Pkg_Actuals,
7080 Make_Attribute_Reference (Loc,
7083 (Defining_Entity (Pkg_Spec), Loc),
7084 Attribute_Name => Name_Version));
7088 Append_To (Register_Pkg_Actuals,
7089 Make_Attribute_Reference (Loc,
7091 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7092 Attribute_Name => Name_Access));
7096 Append_To (Register_Pkg_Actuals,
7097 Make_Attribute_Reference (Loc,
7100 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc),
7101 Attribute_Name => Name_Access));
7105 Append_To (Register_Pkg_Actuals,
7106 Make_Attribute_Reference (Loc,
7107 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7108 Attribute_Name => Name_Address));
7112 Append_To (Register_Pkg_Actuals,
7113 Make_Attribute_Reference (Loc,
7114 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7115 Attribute_Name => Name_Length));
7117 -- Is_All_Calls_Remote
7119 Append_To (Register_Pkg_Actuals,
7120 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7122 -- Finally call Register_Pkg_Receiving_Stub with the above parameters
7125 Make_Procedure_Call_Statement (Loc,
7127 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7128 Parameter_Associations => Register_Pkg_Actuals));
7129 Analyze (Last (Stmts));
7130 end Add_Receiving_Stubs_To_Declarations;
7132 ---------------------------------
7133 -- Build_General_Calling_Stubs --
7134 ---------------------------------
7136 procedure Build_General_Calling_Stubs
7138 Statements : List_Id;
7139 Target_Object : Node_Id;
7140 Subprogram_Id : Node_Id;
7141 Asynchronous : Node_Id := Empty;
7142 Is_Known_Asynchronous : Boolean := False;
7143 Is_Known_Non_Asynchronous : Boolean := False;
7144 Is_Function : Boolean;
7146 Stub_Type : Entity_Id := Empty;
7147 RACW_Type : Entity_Id := Empty;
7150 Loc : constant Source_Ptr := Sloc (Nod);
7152 Request : constant Entity_Id := Make_Temporary (Loc, 'R');
7153 -- The request object constructed by these stubs
7154 -- Could we use Name_R instead??? (see GLADE client stubs)
7156 function Make_Request_RTE_Call
7158 Actuals : List_Id := New_List) return Node_Id;
7159 -- Generate a procedure call statement calling RE with the given
7160 -- actuals. Request'Access is appended to the list.
7162 ---------------------------
7163 -- Make_Request_RTE_Call --
7164 ---------------------------
7166 function Make_Request_RTE_Call
7168 Actuals : List_Id := New_List) return Node_Id
7172 Make_Attribute_Reference (Loc,
7173 Prefix => New_Occurrence_Of (Request, Loc),
7174 Attribute_Name => Name_Access));
7175 return Make_Procedure_Call_Statement (Loc,
7177 New_Occurrence_Of (RTE (RE), Loc),
7178 Parameter_Associations => Actuals);
7179 end Make_Request_RTE_Call;
7181 Arguments : Node_Id;
7182 -- Name of the named values list used to transmit parameters
7183 -- to the remote package
7186 -- Name of the result named value (in non-APC cases) which get the
7187 -- result of the remote subprogram.
7189 Result_TC : Node_Id;
7190 -- Typecode expression for the result of the request (void
7191 -- typecode for procedures).
7193 Exception_Return_Parameter : Node_Id;
7194 -- Name of the parameter which will hold the exception sent by the
7195 -- remote subprogram.
7197 Current_Parameter : Node_Id;
7198 -- Current parameter being handled
7200 Ordered_Parameters_List : constant List_Id :=
7201 Build_Ordered_Parameters_List (Spec);
7203 Asynchronous_P : Node_Id;
7204 -- A Boolean expression indicating whether this call is asynchronous
7206 Asynchronous_Statements : List_Id := No_List;
7207 Non_Asynchronous_Statements : List_Id := No_List;
7208 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7210 Extra_Formal_Statements : constant List_Id := New_List;
7211 -- List of statements for extra formal parameters. It will appear
7212 -- after the regular statements for writing out parameters.
7214 After_Statements : constant List_Id := New_List;
7215 -- Statements to be executed after call returns (to assign IN OUT or
7216 -- OUT parameter values).
7219 -- The type of the formal parameter being processed
7221 Is_Controlling_Formal : Boolean;
7222 Is_First_Controlling_Formal : Boolean;
7223 First_Controlling_Formal_Seen : Boolean := False;
7224 -- Controlling formal parameters of distributed object primitives
7225 -- require special handling, and the first such parameter needs even
7226 -- more special handling.
7229 -- ??? document general form of stub subprograms for the PolyORB case
7232 Make_Object_Declaration (Loc,
7233 Defining_Identifier => Request,
7234 Aliased_Present => True,
7235 Object_Definition =>
7236 New_Occurrence_Of (RTE (RE_Request), Loc)));
7238 Result := Make_Temporary (Loc, 'R');
7242 PolyORB_Support.Helpers.Build_TypeCode_Call
7243 (Loc, Etype (Result_Definition (Spec)), Decls);
7245 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7249 Make_Object_Declaration (Loc,
7250 Defining_Identifier => Result,
7251 Aliased_Present => False,
7252 Object_Definition =>
7253 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7255 Make_Aggregate (Loc,
7256 Component_Associations => New_List (
7257 Make_Component_Association (Loc,
7258 Choices => New_List (Make_Identifier (Loc, Name_Name)),
7260 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7261 Make_Component_Association (Loc,
7262 Choices => New_List (
7263 Make_Identifier (Loc, Name_Argument)),
7265 Make_Function_Call (Loc,
7266 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7267 Parameter_Associations => New_List (Result_TC))),
7268 Make_Component_Association (Loc,
7269 Choices => New_List (
7270 Make_Identifier (Loc, Name_Arg_Modes)),
7271 Expression => Make_Integer_Literal (Loc, 0))))));
7273 if not Is_Known_Asynchronous then
7274 Exception_Return_Parameter := Make_Temporary (Loc, 'E');
7277 Make_Object_Declaration (Loc,
7278 Defining_Identifier => Exception_Return_Parameter,
7279 Object_Definition =>
7280 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7283 Exception_Return_Parameter := Empty;
7286 -- Initialize and fill in arguments list
7288 Arguments := Make_Temporary (Loc, 'A');
7289 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7291 Current_Parameter := First (Ordered_Parameters_List);
7292 while Present (Current_Parameter) loop
7293 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7294 Is_Controlling_Formal := True;
7295 Is_First_Controlling_Formal :=
7296 not First_Controlling_Formal_Seen;
7297 First_Controlling_Formal_Seen := True;
7300 Is_Controlling_Formal := False;
7301 Is_First_Controlling_Formal := False;
7304 if Is_Controlling_Formal then
7306 -- For a controlling formal argument, we send its reference
7311 Etyp := Etype (Parameter_Type (Current_Parameter));
7314 -- The first controlling formal parameter is treated specially:
7315 -- it is used to set the target object of the call.
7317 if not Is_First_Controlling_Formal then
7319 Constrained : constant Boolean :=
7320 Is_Constrained (Etyp)
7321 or else Is_Elementary_Type (Etyp);
7323 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
7325 Actual_Parameter : Node_Id :=
7327 Defining_Identifier (
7328 Current_Parameter), Loc);
7333 if Is_Controlling_Formal then
7335 -- For a controlling formal parameter (other than the
7336 -- first one), use the corresponding RACW. If the
7337 -- parameter is not an anonymous access parameter, that
7338 -- involves taking its 'Unrestricted_Access.
7340 if Nkind (Parameter_Type (Current_Parameter))
7341 = N_Access_Definition
7343 Actual_Parameter := OK_Convert_To
7344 (Etyp, Actual_Parameter);
7346 Actual_Parameter := OK_Convert_To (Etyp,
7347 Make_Attribute_Reference (Loc,
7348 Prefix => Actual_Parameter,
7349 Attribute_Name => Name_Unrestricted_Access));
7354 if In_Present (Current_Parameter)
7355 or else not Out_Present (Current_Parameter)
7356 or else not Constrained
7357 or else Is_Controlling_Formal
7359 -- The parameter has an input value, is constrained at
7360 -- runtime by an input value, or is a controlling formal
7361 -- parameter (always passed as a reference) other than
7364 Expr := PolyORB_Support.Helpers.Build_To_Any_Call
7365 (Actual_Parameter, Decls);
7368 Expr := Make_Function_Call (Loc,
7369 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7370 Parameter_Associations => New_List (
7371 PolyORB_Support.Helpers.Build_TypeCode_Call
7372 (Loc, Etyp, Decls)));
7376 Make_Object_Declaration (Loc,
7377 Defining_Identifier => Any,
7378 Aliased_Present => False,
7379 Object_Definition =>
7380 New_Occurrence_Of (RTE (RE_Any), Loc),
7381 Expression => Expr));
7383 Append_To (Statements,
7384 Add_Parameter_To_NVList (Loc,
7385 Parameter => Current_Parameter,
7386 NVList => Arguments,
7387 Constrained => Constrained,
7390 if Out_Present (Current_Parameter)
7391 and then not Is_Controlling_Formal
7393 if Is_Limited_Type (Etyp) then
7394 Helpers.Assign_Opaque_From_Any (Loc,
7395 Stms => After_Statements,
7397 N => New_Occurrence_Of (Any, Loc),
7399 Defining_Identifier (Current_Parameter));
7401 Append_To (After_Statements,
7402 Make_Assignment_Statement (Loc,
7405 Defining_Identifier (Current_Parameter), Loc),
7407 PolyORB_Support.Helpers.Build_From_Any_Call
7409 New_Occurrence_Of (Any, Loc),
7416 -- If the current parameter has a dynamic constrained status, then
7417 -- this status is transmitted as well.
7418 -- This should be done for accessibility as well ???
7420 if Nkind (Parameter_Type (Current_Parameter)) /=
7422 and then Need_Extra_Constrained (Current_Parameter)
7424 -- In this block, we do not use the extra formal that has been
7425 -- created because it does not exist at the time of expansion
7426 -- when building calling stubs for remote access to subprogram
7427 -- types. We create an extra variable of this type and push it
7428 -- in the stream after the regular parameters.
7431 Extra_Any_Parameter : constant Entity_Id :=
7432 Make_Temporary (Loc, 'P');
7434 Parameter_Exp : constant Node_Id :=
7435 Make_Attribute_Reference (Loc,
7436 Prefix => New_Occurrence_Of (
7437 Defining_Identifier (Current_Parameter), Loc),
7438 Attribute_Name => Name_Constrained);
7441 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7444 Make_Object_Declaration (Loc,
7445 Defining_Identifier => Extra_Any_Parameter,
7446 Aliased_Present => False,
7447 Object_Definition =>
7448 New_Occurrence_Of (RTE (RE_Any), Loc),
7450 PolyORB_Support.Helpers.Build_To_Any_Call
7451 (Parameter_Exp, Decls)));
7453 Append_To (Extra_Formal_Statements,
7454 Add_Parameter_To_NVList (Loc,
7455 Parameter => Extra_Any_Parameter,
7456 NVList => Arguments,
7457 Constrained => True,
7458 Any => Extra_Any_Parameter));
7462 Next (Current_Parameter);
7465 -- Append the formal statements list to the statements
7467 Append_List_To (Statements, Extra_Formal_Statements);
7469 Append_To (Statements,
7470 Make_Procedure_Call_Statement (Loc,
7472 New_Occurrence_Of (RTE (RE_Request_Setup), Loc),
7473 Parameter_Associations => New_List (
7474 New_Occurrence_Of (Request, Loc),
7477 New_Occurrence_Of (Arguments, Loc),
7478 New_Occurrence_Of (Result, Loc),
7479 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7482 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7484 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7487 (Boolean_Literals (Is_Known_Asynchronous), Loc);
7490 pragma Assert (Present (Asynchronous));
7491 Asynchronous_P := New_Copy_Tree (Asynchronous);
7493 -- The expression node Asynchronous will be used to build an 'if'
7494 -- statement at the end of Build_General_Calling_Stubs: we need to
7495 -- make a copy here.
7498 Append_To (Parameter_Associations (Last (Statements)),
7499 Make_Indexed_Component (Loc,
7502 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7503 Expressions => New_List (Asynchronous_P)));
7505 Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke));
7507 -- Asynchronous case
7509 if not Is_Known_Non_Asynchronous then
7510 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7513 -- Non-asynchronous case
7515 if not Is_Known_Asynchronous then
7516 -- Reraise an exception occurrence from the completed request.
7517 -- If the exception occurrence is empty, this is a no-op.
7519 Non_Asynchronous_Statements := New_List (
7520 Make_Procedure_Call_Statement (Loc,
7522 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7523 Parameter_Associations => New_List (
7524 New_Occurrence_Of (Request, Loc))));
7527 -- If this is a function call, read the value and return it
7529 Append_To (Non_Asynchronous_Statements,
7530 Make_Tag_Check (Loc,
7531 Make_Simple_Return_Statement (Loc,
7532 PolyORB_Support.Helpers.Build_From_Any_Call
7533 (Etype (Result_Definition (Spec)),
7534 Make_Selected_Component (Loc,
7536 Selector_Name => Name_Argument),
7541 -- Case of a procedure: deal with IN OUT and OUT formals
7543 Append_List_To (Non_Asynchronous_Statements, After_Statements);
7547 if Is_Known_Asynchronous then
7548 Append_List_To (Statements, Asynchronous_Statements);
7550 elsif Is_Known_Non_Asynchronous then
7551 Append_List_To (Statements, Non_Asynchronous_Statements);
7554 pragma Assert (Present (Asynchronous));
7555 Append_To (Statements,
7556 Make_Implicit_If_Statement (Nod,
7557 Condition => Asynchronous,
7558 Then_Statements => Asynchronous_Statements,
7559 Else_Statements => Non_Asynchronous_Statements));
7561 end Build_General_Calling_Stubs;
7563 -----------------------
7564 -- Build_Stub_Target --
7565 -----------------------
7567 function Build_Stub_Target
7570 RCI_Locator : Entity_Id;
7571 Controlling_Parameter : Entity_Id) return RPC_Target
7573 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7574 Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T');
7577 if Present (Controlling_Parameter) then
7579 Make_Object_Declaration (Loc,
7580 Defining_Identifier => Target_Reference,
7582 Object_Definition =>
7583 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7586 Make_Function_Call (Loc,
7588 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7589 Parameter_Associations => New_List (
7590 Make_Selected_Component (Loc,
7591 Prefix => Controlling_Parameter,
7592 Selector_Name => Name_Target)))));
7594 -- Note: Controlling_Parameter has the same components as
7595 -- System.Partition_Interface.RACW_Stub_Type.
7597 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7600 Target_Info.Object :=
7601 Make_Selected_Component (Loc,
7603 Make_Identifier (Loc, Chars (RCI_Locator)),
7605 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7609 end Build_Stub_Target;
7611 -----------------------------
7612 -- Build_RPC_Receiver_Body --
7613 -----------------------------
7615 procedure Build_RPC_Receiver_Body
7616 (RPC_Receiver : Entity_Id;
7617 Request : out Entity_Id;
7618 Subp_Id : out Entity_Id;
7619 Subp_Index : out Entity_Id;
7620 Stmts : out List_Id;
7623 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7625 RPC_Receiver_Spec : Node_Id;
7626 RPC_Receiver_Decls : List_Id;
7629 Request := Make_Defining_Identifier (Loc, Name_R);
7631 RPC_Receiver_Spec :=
7632 Build_RPC_Receiver_Specification
7633 (RPC_Receiver => RPC_Receiver,
7634 Request_Parameter => Request);
7636 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7637 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7639 RPC_Receiver_Decls := New_List (
7640 Make_Object_Renaming_Declaration (Loc,
7641 Defining_Identifier => Subp_Id,
7642 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7644 Make_Explicit_Dereference (Loc,
7646 Make_Selected_Component (Loc,
7648 Selector_Name => Name_Operation))),
7650 Make_Object_Declaration (Loc,
7651 Defining_Identifier => Subp_Index,
7652 Object_Definition =>
7653 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7655 Make_Attribute_Reference (Loc,
7657 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7658 Attribute_Name => Name_Last)));
7663 Make_Subprogram_Body (Loc,
7664 Specification => RPC_Receiver_Spec,
7665 Declarations => RPC_Receiver_Decls,
7666 Handled_Statement_Sequence =>
7667 Make_Handled_Sequence_Of_Statements (Loc,
7668 Statements => Stmts));
7669 end Build_RPC_Receiver_Body;
7671 --------------------------------------
7672 -- Build_Subprogram_Receiving_Stubs --
7673 --------------------------------------
7675 function Build_Subprogram_Receiving_Stubs
7676 (Vis_Decl : Node_Id;
7677 Asynchronous : Boolean;
7678 Dynamically_Asynchronous : Boolean := False;
7679 Stub_Type : Entity_Id := Empty;
7680 RACW_Type : Entity_Id := Empty;
7681 Parent_Primitive : Entity_Id := Empty) return Node_Id
7683 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7685 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
7686 -- Formal parameter for receiving stubs: a descriptor for an incoming
7689 Outer_Decls : constant List_Id := New_List;
7690 -- At the outermost level, an NVList and Any's are declared for all
7691 -- parameters. The Dynamic_Async flag also needs to be declared there
7692 -- to be visible from the exception handling code.
7694 Outer_Statements : constant List_Id := New_List;
7695 -- Statements that occur prior to the declaration of the actual
7696 -- parameter variables.
7698 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7699 -- Statements concerning extra formal parameters, prior to the
7700 -- declaration of the actual parameter variables.
7702 Decls : constant List_Id := New_List;
7703 -- All the parameters will get declared before calling the real
7704 -- subprograms. Also the out parameters will be declared. At this
7705 -- level, parameters may be unconstrained.
7707 Statements : constant List_Id := New_List;
7709 After_Statements : constant List_Id := New_List;
7710 -- Statements to be executed after the subprogram call
7712 Inner_Decls : List_Id := No_List;
7713 -- In case of a function, the inner declarations are needed since
7714 -- the result may be unconstrained.
7716 Excep_Handlers : List_Id := No_List;
7718 Parameter_List : constant List_Id := New_List;
7719 -- List of parameters to be passed to the subprogram
7721 First_Controlling_Formal_Seen : Boolean := False;
7723 Current_Parameter : Node_Id;
7725 Ordered_Parameters_List : constant List_Id :=
7726 Build_Ordered_Parameters_List
7727 (Specification (Vis_Decl));
7729 Arguments : constant Entity_Id := Make_Temporary (Loc, 'A');
7730 -- Name of the named values list used to retrieve parameters
7732 Subp_Spec : Node_Id;
7733 -- Subprogram specification
7735 Called_Subprogram : Node_Id;
7736 -- The subprogram to call
7739 if Present (RACW_Type) then
7740 Called_Subprogram :=
7741 New_Occurrence_Of (Parent_Primitive, Loc);
7743 Called_Subprogram :=
7745 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7748 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7750 -- Loop through every parameter and get its value from the stream. If
7751 -- the parameter is unconstrained, then the parameter is read using
7752 -- 'Input at the point of declaration.
7754 Current_Parameter := First (Ordered_Parameters_List);
7755 while Present (Current_Parameter) loop
7758 Constrained : Boolean;
7759 Any : Entity_Id := Empty;
7760 Object : constant Entity_Id := Make_Temporary (Loc, 'P');
7761 Expr : Node_Id := Empty;
7763 Is_Controlling_Formal : constant Boolean :=
7764 Is_RACW_Controlling_Formal
7765 (Current_Parameter, Stub_Type);
7767 Is_First_Controlling_Formal : Boolean := False;
7769 Need_Extra_Constrained : Boolean;
7770 -- True when an extra constrained actual is required
7773 if Is_Controlling_Formal then
7775 -- Controlling formals in distributed object primitive
7776 -- operations are handled specially:
7778 -- - the first controlling formal is used as the
7779 -- target of the call;
7781 -- - the remaining controlling formals are transmitted
7785 Is_First_Controlling_Formal :=
7786 not First_Controlling_Formal_Seen;
7787 First_Controlling_Formal_Seen := True;
7790 Etyp := Etype (Parameter_Type (Current_Parameter));
7794 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
7796 if not Is_First_Controlling_Formal then
7797 Any := Make_Temporary (Loc, 'A');
7799 Append_To (Outer_Decls,
7800 Make_Object_Declaration (Loc,
7801 Defining_Identifier => Any,
7802 Object_Definition =>
7803 New_Occurrence_Of (RTE (RE_Any), Loc),
7805 Make_Function_Call (Loc,
7806 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7807 Parameter_Associations => New_List (
7808 PolyORB_Support.Helpers.Build_TypeCode_Call
7809 (Loc, Etyp, Outer_Decls)))));
7811 Append_To (Outer_Statements,
7812 Add_Parameter_To_NVList (Loc,
7813 Parameter => Current_Parameter,
7814 NVList => Arguments,
7815 Constrained => Constrained,
7819 if Is_First_Controlling_Formal then
7821 Addr : constant Entity_Id := Make_Temporary (Loc, 'A');
7823 Is_Local : constant Entity_Id :=
7824 Make_Temporary (Loc, 'L');
7827 -- Special case: obtain the first controlling formal
7828 -- from the target of the remote call, instead of the
7831 Append_To (Outer_Decls,
7832 Make_Object_Declaration (Loc,
7833 Defining_Identifier => Addr,
7834 Object_Definition =>
7835 New_Occurrence_Of (RTE (RE_Address), Loc)));
7837 Append_To (Outer_Decls,
7838 Make_Object_Declaration (Loc,
7839 Defining_Identifier => Is_Local,
7840 Object_Definition =>
7841 New_Occurrence_Of (Standard_Boolean, Loc)));
7843 Append_To (Outer_Statements,
7844 Make_Procedure_Call_Statement (Loc,
7846 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7847 Parameter_Associations => New_List (
7848 Make_Selected_Component (Loc,
7851 Request_Parameter, Loc),
7853 Make_Identifier (Loc, Name_Target)),
7854 New_Occurrence_Of (Is_Local, Loc),
7855 New_Occurrence_Of (Addr, Loc))));
7857 Expr := Unchecked_Convert_To (RACW_Type,
7858 New_Occurrence_Of (Addr, Loc));
7861 elsif In_Present (Current_Parameter)
7862 or else not Out_Present (Current_Parameter)
7863 or else not Constrained
7865 -- If an input parameter is constrained, then its reading is
7866 -- deferred until the beginning of the subprogram body. If
7867 -- it is unconstrained, then an expression is built for
7868 -- the object declaration and the variable is set using
7869 -- 'Input instead of 'Read.
7871 if Constrained and then Is_Limited_Type (Etyp) then
7872 Helpers.Assign_Opaque_From_Any (Loc,
7875 N => New_Occurrence_Of (Any, Loc),
7879 Expr := Helpers.Build_From_Any_Call
7880 (Etyp, New_Occurrence_Of (Any, Loc), Decls);
7883 Append_To (Statements,
7884 Make_Assignment_Statement (Loc,
7885 Name => New_Occurrence_Of (Object, Loc),
7886 Expression => Expr));
7890 -- Expr will be used to initialize (and constrain) the
7891 -- parameter when it is declared.
7899 Need_Extra_Constrained :=
7900 Nkind (Parameter_Type (Current_Parameter)) /=
7903 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7905 Present (Extra_Constrained
7906 (Defining_Identifier (Current_Parameter)));
7908 -- We may not associate an extra constrained actual to a
7909 -- constant object, so if one is needed, declare the actual
7910 -- as a variable even if it won't be modified.
7912 Build_Actual_Object_Declaration
7915 Variable => Need_Extra_Constrained
7916 or else Out_Present (Current_Parameter),
7919 Set_Etype (Object, Etyp);
7921 -- An out parameter may be written back using a 'Write
7922 -- attribute instead of a 'Output because it has been
7923 -- constrained by the parameter given to the caller. Note that
7924 -- out controlling arguments in the case of a RACW are not put
7925 -- back in the stream because the pointer on them has not
7928 if Out_Present (Current_Parameter)
7929 and then not Is_Controlling_Formal
7931 Append_To (After_Statements,
7932 Make_Procedure_Call_Statement (Loc,
7933 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
7934 Parameter_Associations => New_List (
7935 New_Occurrence_Of (Any, Loc),
7936 PolyORB_Support.Helpers.Build_To_Any_Call
7937 (New_Occurrence_Of (Object, Loc), Decls))));
7940 -- For RACW controlling formals, the Etyp of Object is always
7941 -- an RACW, even if the parameter is not of an anonymous access
7942 -- type. In such case, we need to dereference it at call time.
7944 if Is_Controlling_Formal then
7945 if Nkind (Parameter_Type (Current_Parameter)) /=
7948 Append_To (Parameter_List,
7949 Make_Parameter_Association (Loc,
7952 (Defining_Identifier (Current_Parameter), Loc),
7953 Explicit_Actual_Parameter =>
7954 Make_Explicit_Dereference (Loc,
7955 Prefix => New_Occurrence_Of (Object, Loc))));
7958 Append_To (Parameter_List,
7959 Make_Parameter_Association (Loc,
7962 (Defining_Identifier (Current_Parameter), Loc),
7964 Explicit_Actual_Parameter =>
7965 New_Occurrence_Of (Object, Loc)));
7969 Append_To (Parameter_List,
7970 Make_Parameter_Association (Loc,
7973 Defining_Identifier (Current_Parameter), Loc),
7974 Explicit_Actual_Parameter =>
7975 New_Occurrence_Of (Object, Loc)));
7978 -- If the current parameter needs an extra formal, then read it
7979 -- from the stream and set the corresponding semantic field in
7980 -- the variable. If the kind of the parameter identifier is
7981 -- E_Void, then this is a compiler generated parameter that
7982 -- doesn't need an extra constrained status.
7984 -- The case of Extra_Accessibility should also be handled ???
7986 if Need_Extra_Constrained then
7988 Extra_Parameter : constant Entity_Id :=
7990 (Defining_Identifier
7991 (Current_Parameter));
7993 Extra_Any : constant Entity_Id :=
7994 Make_Temporary (Loc, 'A');
7996 Formal_Entity : constant Entity_Id :=
7997 Make_Defining_Identifier (Loc,
7998 Chars => Chars (Extra_Parameter));
8000 Formal_Type : constant Entity_Id :=
8001 Etype (Extra_Parameter);
8004 Append_To (Outer_Decls,
8005 Make_Object_Declaration (Loc,
8006 Defining_Identifier => Extra_Any,
8007 Object_Definition =>
8008 New_Occurrence_Of (RTE (RE_Any), Loc),
8010 Make_Function_Call (Loc,
8012 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8013 Parameter_Associations => New_List (
8014 PolyORB_Support.Helpers.Build_TypeCode_Call
8015 (Loc, Formal_Type, Outer_Decls)))));
8017 Append_To (Outer_Extra_Formal_Statements,
8018 Add_Parameter_To_NVList (Loc,
8019 Parameter => Extra_Parameter,
8020 NVList => Arguments,
8021 Constrained => True,
8025 Make_Object_Declaration (Loc,
8026 Defining_Identifier => Formal_Entity,
8027 Object_Definition =>
8028 New_Occurrence_Of (Formal_Type, Loc)));
8030 Append_To (Statements,
8031 Make_Assignment_Statement (Loc,
8032 Name => New_Occurrence_Of (Formal_Entity, Loc),
8034 PolyORB_Support.Helpers.Build_From_Any_Call
8036 New_Occurrence_Of (Extra_Any, Loc),
8038 Set_Extra_Constrained (Object, Formal_Entity);
8043 Next (Current_Parameter);
8046 -- Extra Formals should go after all the other parameters
8048 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8050 Append_To (Outer_Statements,
8051 Make_Procedure_Call_Statement (Loc,
8052 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8053 Parameter_Associations => New_List (
8054 New_Occurrence_Of (Request_Parameter, Loc),
8055 New_Occurrence_Of (Arguments, Loc))));
8057 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8059 -- The remote subprogram is a function: Build an inner block to be
8060 -- able to hold a potentially unconstrained result in a variable.
8063 Etyp : constant Entity_Id :=
8064 Etype (Result_Definition (Specification (Vis_Decl)));
8065 Result : constant Node_Id := Make_Temporary (Loc, 'R');
8068 Inner_Decls := New_List (
8069 Make_Object_Declaration (Loc,
8070 Defining_Identifier => Result,
8071 Constant_Present => True,
8072 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8074 Make_Function_Call (Loc,
8075 Name => Called_Subprogram,
8076 Parameter_Associations => Parameter_List)));
8078 if Is_Class_Wide_Type (Etyp) then
8080 -- For a remote call to a function with a class-wide type,
8081 -- check that the returned value satisfies the requirements
8084 Append_To (Inner_Decls,
8085 Make_Transportable_Check (Loc,
8086 New_Occurrence_Of (Result, Loc)));
8090 Set_Etype (Result, Etyp);
8091 Append_To (After_Statements,
8092 Make_Procedure_Call_Statement (Loc,
8093 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8094 Parameter_Associations => New_List (
8095 New_Occurrence_Of (Request_Parameter, Loc),
8096 PolyORB_Support.Helpers.Build_To_Any_Call
8097 (New_Occurrence_Of (Result, Loc), Decls))));
8099 -- A DSA function does not have out or inout arguments
8102 Append_To (Statements,
8103 Make_Block_Statement (Loc,
8104 Declarations => Inner_Decls,
8105 Handled_Statement_Sequence =>
8106 Make_Handled_Sequence_Of_Statements (Loc,
8107 Statements => After_Statements)));
8110 -- The remote subprogram is a procedure. We do not need any inner
8111 -- block in this case. No specific processing is required here for
8112 -- the dynamically asynchronous case: the indication of whether
8113 -- call is asynchronous or not is managed by the Sync_Scope
8114 -- attibute of the request, and is handled entirely in the
8117 Append_To (After_Statements,
8118 Make_Procedure_Call_Statement (Loc,
8119 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8120 Parameter_Associations => New_List (
8121 New_Occurrence_Of (Request_Parameter, Loc))));
8123 Append_To (Statements,
8124 Make_Procedure_Call_Statement (Loc,
8125 Name => Called_Subprogram,
8126 Parameter_Associations => Parameter_List));
8128 Append_List_To (Statements, After_Statements);
8132 Make_Procedure_Specification (Loc,
8133 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
8135 Parameter_Specifications => New_List (
8136 Make_Parameter_Specification (Loc,
8137 Defining_Identifier => Request_Parameter,
8139 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8141 -- An exception raised during the execution of an incoming remote
8142 -- subprogram call and that needs to be sent back to the caller is
8143 -- propagated by the receiving stubs, and will be handled by the
8144 -- caller (the distribution runtime).
8146 if Asynchronous and then not Dynamically_Asynchronous then
8148 -- For an asynchronous procedure, add a null exception handler
8150 Excep_Handlers := New_List (
8151 Make_Implicit_Exception_Handler (Loc,
8152 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8153 Statements => New_List (Make_Null_Statement (Loc))));
8156 -- In the other cases, if an exception is raised, then the
8157 -- exception occurrence is propagated.
8162 Append_To (Outer_Statements,
8163 Make_Block_Statement (Loc,
8164 Declarations => Decls,
8165 Handled_Statement_Sequence =>
8166 Make_Handled_Sequence_Of_Statements (Loc,
8167 Statements => Statements)));
8170 Make_Subprogram_Body (Loc,
8171 Specification => Subp_Spec,
8172 Declarations => Outer_Decls,
8173 Handled_Statement_Sequence =>
8174 Make_Handled_Sequence_Of_Statements (Loc,
8175 Statements => Outer_Statements,
8176 Exception_Handlers => Excep_Handlers));
8177 end Build_Subprogram_Receiving_Stubs;
8183 package body Helpers is
8185 -----------------------
8186 -- Local Subprograms --
8187 -----------------------
8189 function Find_Numeric_Representation
8190 (Typ : Entity_Id) return Entity_Id;
8191 -- Given a numeric type Typ, return the smallest integer or modular
8192 -- type from Interfaces, or the smallest floating point type from
8193 -- Standard whose range encompasses that of Typ.
8195 function Make_Helper_Function_Name
8198 Nam : Name_Id) return Entity_Id;
8199 -- Return the name to be assigned for helper subprogram Nam of Typ
8201 ------------------------------------------------------------
8202 -- Common subprograms for building various tree fragments --
8203 ------------------------------------------------------------
8205 function Build_Get_Aggregate_Element
8209 Idx : Node_Id) return Node_Id;
8210 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8211 -- returning the Idx'th element.
8214 Subprogram : Entity_Id;
8215 -- Reference location for constructed nodes
8218 -- For 'Range and Etype
8221 -- For the construction of the innermost element expression
8223 with procedure Add_Process_Element
8226 Counter : Entity_Id;
8229 procedure Append_Array_Traversal
8232 Counter : Entity_Id := Empty;
8234 -- Build nested loop statements that iterate over the elements of an
8235 -- array Arry. The statement(s) built by Add_Process_Element are
8236 -- executed for each element; Indexes is the list of indexes to be
8237 -- used in the construction of the indexed component that denotes the
8238 -- current element. Subprogram is the entity for the subprogram for
8239 -- which this iterator is generated. The generated statements are
8240 -- appended to Stmts.
8244 -- The record entity being dealt with
8246 with procedure Add_Process_Element
8248 Container : Node_Or_Entity_Id;
8249 Counter : in out Int;
8252 -- Rec is the instance of the record type, or Empty.
8253 -- Field is either the N_Defining_Identifier for a component,
8254 -- or an N_Variant_Part.
8256 procedure Append_Record_Traversal
8259 Container : Node_Or_Entity_Id;
8260 Counter : in out Int);
8261 -- Process component list Clist. Individual fields are passed
8262 -- to Field_Processing. Each variant part is also processed.
8263 -- Container is the outer Any (for From_Any/To_Any),
8264 -- the outer typecode (for TC) to which the operation applies.
8266 -----------------------------
8267 -- Append_Record_Traversal --
8268 -----------------------------
8270 procedure Append_Record_Traversal
8273 Container : Node_Or_Entity_Id;
8274 Counter : in out Int)
8278 -- Clist's Component_Items and Variant_Part
8288 CI := Component_Items (Clist);
8289 VP := Variant_Part (Clist);
8292 while Present (Item) loop
8293 Def := Defining_Identifier (Item);
8295 if not Is_Internal_Name (Chars (Def)) then
8297 (Stmts, Container, Counter, Rec, Def);
8303 if Present (VP) then
8304 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8306 end Append_Record_Traversal;
8308 -----------------------------
8309 -- Assign_Opaque_From_Any --
8310 -----------------------------
8312 procedure Assign_Opaque_From_Any
8319 Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
8322 Read_Call_List : List_Id;
8323 -- List on which to place the 'Read attribute reference
8326 -- Strm : Buffer_Stream_Type;
8329 Make_Object_Declaration (Loc,
8330 Defining_Identifier => Strm,
8331 Aliased_Present => True,
8332 Object_Definition =>
8333 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
8335 -- Any_To_BS (Strm, A);
8338 Make_Procedure_Call_Statement (Loc,
8339 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
8340 Parameter_Associations => New_List (
8342 New_Occurrence_Of (Strm, Loc))));
8344 if Transmit_As_Unconstrained (Typ) then
8346 Make_Attribute_Reference (Loc,
8347 Prefix => New_Occurrence_Of (Typ, Loc),
8348 Attribute_Name => Name_Input,
8349 Expressions => New_List (
8350 Make_Attribute_Reference (Loc,
8351 Prefix => New_Occurrence_Of (Strm, Loc),
8352 Attribute_Name => Name_Access)));
8354 -- Target := Typ'Input (Strm'Access)
8356 if Present (Target) then
8358 Make_Assignment_Statement (Loc,
8359 Name => New_Occurrence_Of (Target, Loc),
8360 Expression => Expr));
8362 -- return Typ'Input (Strm'Access);
8366 Make_Simple_Return_Statement (Loc,
8367 Expression => Expr));
8371 if Present (Target) then
8372 Read_Call_List := Stms;
8373 Expr := New_Occurrence_Of (Target, Loc);
8377 Temp : constant Entity_Id := Make_Temporary (Loc, 'R');
8380 Read_Call_List := New_List;
8381 Expr := New_Occurrence_Of (Temp, Loc);
8383 Append_To (Stms, Make_Block_Statement (Loc,
8384 Declarations => New_List (
8385 Make_Object_Declaration (Loc,
8386 Defining_Identifier =>
8388 Object_Definition =>
8389 New_Occurrence_Of (Typ, Loc))),
8391 Handled_Statement_Sequence =>
8392 Make_Handled_Sequence_Of_Statements (Loc,
8393 Statements => Read_Call_List)));
8397 -- Typ'Read (Strm'Access, [Target|Temp])
8399 Append_To (Read_Call_List,
8400 Make_Attribute_Reference (Loc,
8401 Prefix => New_Occurrence_Of (Typ, Loc),
8402 Attribute_Name => Name_Read,
8403 Expressions => New_List (
8404 Make_Attribute_Reference (Loc,
8405 Prefix => New_Occurrence_Of (Strm, Loc),
8406 Attribute_Name => Name_Access),
8413 Append_To (Read_Call_List,
8414 Make_Simple_Return_Statement (Loc,
8415 Expression => New_Copy (Expr)));
8418 end Assign_Opaque_From_Any;
8420 -------------------------
8421 -- Build_From_Any_Call --
8422 -------------------------
8424 function Build_From_Any_Call
8427 Decls : List_Id) return Node_Id
8429 Loc : constant Source_Ptr := Sloc (N);
8431 U_Type : Entity_Id := Underlying_Type (Typ);
8433 Fnam : Entity_Id := Empty;
8434 Lib_RE : RE_Id := RE_Null;
8438 -- First simple case where the From_Any function is present
8439 -- in the type's TSS.
8441 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8443 -- For the subtype representing a generic actual type, go to the
8446 if Is_Generic_Actual_Type (U_Type) then
8447 U_Type := Underlying_Type (Base_Type (U_Type));
8450 -- For a standard subtype, go to the base type
8452 if Sloc (U_Type) <= Standard_Location then
8453 U_Type := Base_Type (U_Type);
8456 -- Check first for Boolean and Character. These are enumeration
8457 -- types, but we treat them specially, since they may require
8458 -- special handling in the transfer protocol. However, this
8459 -- special handling only applies if they have standard
8460 -- representation, otherwise they are treated like any other
8461 -- enumeration type.
8463 if Present (Fnam) then
8466 elsif U_Type = Standard_Boolean then
8469 elsif U_Type = Standard_Character then
8472 elsif U_Type = Standard_Wide_Character then
8475 elsif U_Type = Standard_Wide_Wide_Character then
8476 Lib_RE := RE_FA_WWC;
8478 -- Floating point types
8480 elsif U_Type = Standard_Short_Float then
8483 elsif U_Type = Standard_Float then
8486 elsif U_Type = Standard_Long_Float then
8489 elsif U_Type = Standard_Long_Long_Float then
8490 Lib_RE := RE_FA_LLF;
8494 elsif U_Type = RTE (RE_Integer_8) then
8497 elsif U_Type = RTE (RE_Integer_16) then
8498 Lib_RE := RE_FA_I16;
8500 elsif U_Type = RTE (RE_Integer_32) then
8501 Lib_RE := RE_FA_I32;
8503 elsif U_Type = RTE (RE_Integer_64) then
8504 Lib_RE := RE_FA_I64;
8506 -- Unsigned integer types
8508 elsif U_Type = RTE (RE_Unsigned_8) then
8511 elsif U_Type = RTE (RE_Unsigned_16) then
8512 Lib_RE := RE_FA_U16;
8514 elsif U_Type = RTE (RE_Unsigned_32) then
8515 Lib_RE := RE_FA_U32;
8517 elsif U_Type = RTE (RE_Unsigned_64) then
8518 Lib_RE := RE_FA_U64;
8520 elsif Is_RTE (U_Type, RE_Unbounded_String) then
8521 Lib_RE := RE_FA_String;
8523 -- Special DSA types
8525 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
8528 -- Other (non-primitive) types
8535 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8536 Append_To (Decls, Decl);
8540 -- Call the function
8542 if Lib_RE /= RE_Null then
8543 pragma Assert (No (Fnam));
8544 Fnam := RTE (Lib_RE);
8548 Make_Function_Call (Loc,
8549 Name => New_Occurrence_Of (Fnam, Loc),
8550 Parameter_Associations => New_List (N));
8552 -- We must set the type of Result, so the unchecked conversion
8553 -- from the underlying type to the base type is properly done.
8555 Set_Etype (Result, U_Type);
8557 return Unchecked_Convert_To (Typ, Result);
8558 end Build_From_Any_Call;
8560 -----------------------------
8561 -- Build_From_Any_Function --
8562 -----------------------------
8564 procedure Build_From_Any_Function
8568 Fnam : out Entity_Id)
8571 Decls : constant List_Id := New_List;
8572 Stms : constant List_Id := New_List;
8574 Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A');
8576 Use_Opaque_Representation : Boolean;
8579 -- For a derived type, we can't go past the base type (to the
8580 -- parent type) here, because that would cause the attribute's
8581 -- formal parameter to have the wrong type; hence the Base_Type
8584 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
8585 Build_From_Any_Function
8593 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
8596 Make_Function_Specification (Loc,
8597 Defining_Unit_Name => Fnam,
8598 Parameter_Specifications => New_List (
8599 Make_Parameter_Specification (Loc,
8600 Defining_Identifier => Any_Parameter,
8601 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
8602 Result_Definition => New_Occurrence_Of (Typ, Loc));
8604 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8607 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8609 Use_Opaque_Representation := False;
8611 if Has_Stream_Attribute_Definition
8612 (Typ, TSS_Stream_Output, At_Any_Place => True)
8614 Has_Stream_Attribute_Definition
8615 (Typ, TSS_Stream_Write, At_Any_Place => True)
8617 -- If user-defined stream attributes are specified for this
8618 -- type, use them and transmit data as an opaque sequence of
8621 Use_Opaque_Representation := True;
8623 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
8625 Make_Simple_Return_Statement (Loc,
8630 New_Occurrence_Of (Any_Parameter, Loc),
8633 elsif Is_Record_Type (Typ)
8634 and then not Is_Derived_Type (Typ)
8635 and then not Is_Tagged_Type (Typ)
8637 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8639 Make_Simple_Return_Statement (Loc,
8643 New_Occurrence_Of (Any_Parameter, Loc),
8648 Disc : Entity_Id := Empty;
8649 Discriminant_Associations : List_Id;
8650 Rdef : constant Node_Id :=
8652 (Declaration_Node (Typ));
8653 Component_Counter : Int := 0;
8655 -- The returned object
8657 Res : constant Entity_Id := Make_Temporary (Loc, 'R');
8659 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8661 procedure FA_Rec_Add_Process_Element
8664 Counter : in out Int;
8668 procedure FA_Append_Record_Traversal is
8669 new Append_Record_Traversal
8671 Add_Process_Element => FA_Rec_Add_Process_Element);
8673 --------------------------------
8674 -- FA_Rec_Add_Process_Element --
8675 --------------------------------
8677 procedure FA_Rec_Add_Process_Element
8680 Counter : in out Int;
8686 if Nkind (Field) = N_Defining_Identifier then
8687 -- A regular component
8689 Ctyp := Etype (Field);
8692 Make_Assignment_Statement (Loc,
8693 Name => Make_Selected_Component (Loc,
8695 New_Occurrence_Of (Rec, Loc),
8697 New_Occurrence_Of (Field, Loc)),
8700 Build_From_Any_Call (Ctyp,
8701 Build_Get_Aggregate_Element (Loc,
8704 Build_TypeCode_Call (Loc, Ctyp, Decls),
8706 Make_Integer_Literal (Loc, Counter)),
8714 Struct_Counter : Int := 0;
8716 Block_Decls : constant List_Id := New_List;
8717 Block_Stmts : constant List_Id := New_List;
8720 Alt_List : constant List_Id := New_List;
8721 Choice_List : List_Id;
8723 Struct_Any : constant Entity_Id :=
8724 Make_Temporary (Loc, 'S');
8728 Make_Object_Declaration (Loc,
8729 Defining_Identifier => Struct_Any,
8730 Constant_Present => True,
8731 Object_Definition =>
8732 New_Occurrence_Of (RTE (RE_Any), Loc),
8734 Make_Function_Call (Loc,
8737 (RTE (RE_Extract_Union_Value), Loc),
8739 Parameter_Associations => New_List (
8740 Build_Get_Aggregate_Element (Loc,
8743 Make_Function_Call (Loc,
8744 Name => New_Occurrence_Of (
8745 RTE (RE_Any_Member_Type), Loc),
8746 Parameter_Associations =>
8748 New_Occurrence_Of (Any, Loc),
8749 Make_Integer_Literal (Loc,
8750 Intval => Counter))),
8752 Make_Integer_Literal (Loc,
8753 Intval => Counter))))));
8756 Make_Block_Statement (Loc,
8757 Declarations => Block_Decls,
8758 Handled_Statement_Sequence =>
8759 Make_Handled_Sequence_Of_Statements (Loc,
8760 Statements => Block_Stmts)));
8762 Append_To (Block_Stmts,
8763 Make_Case_Statement (Loc,
8765 Make_Selected_Component (Loc,
8767 Selector_Name => Chars (Name (Field))),
8768 Alternatives => Alt_List));
8770 Variant := First_Non_Pragma (Variants (Field));
8771 while Present (Variant) loop
8774 (Discrete_Choices (Variant));
8776 VP_Stmts := New_List;
8778 -- Struct_Counter should be reset before
8779 -- handling a variant part. Indeed only one
8780 -- of the case statement alternatives will be
8781 -- executed at run time, so the counter must
8782 -- start at 0 for every case statement.
8784 Struct_Counter := 0;
8786 FA_Append_Record_Traversal (
8788 Clist => Component_List (Variant),
8789 Container => Struct_Any,
8790 Counter => Struct_Counter);
8792 Append_To (Alt_List,
8793 Make_Case_Statement_Alternative (Loc,
8794 Discrete_Choices => Choice_List,
8795 Statements => VP_Stmts));
8796 Next_Non_Pragma (Variant);
8801 Counter := Counter + 1;
8802 end FA_Rec_Add_Process_Element;
8805 -- First all discriminants
8807 if Has_Discriminants (Typ) then
8808 Discriminant_Associations := New_List;
8810 Disc := First_Discriminant (Typ);
8811 while Present (Disc) loop
8813 Disc_Var_Name : constant Entity_Id :=
8814 Make_Defining_Identifier (Loc,
8815 Chars => Chars (Disc));
8816 Disc_Type : constant Entity_Id :=
8821 Make_Object_Declaration (Loc,
8822 Defining_Identifier => Disc_Var_Name,
8823 Constant_Present => True,
8824 Object_Definition =>
8825 New_Occurrence_Of (Disc_Type, Loc),
8828 Build_From_Any_Call (Disc_Type,
8829 Build_Get_Aggregate_Element (Loc,
8830 Any => Any_Parameter,
8831 TC => Build_TypeCode_Call
8832 (Loc, Disc_Type, Decls),
8833 Idx => Make_Integer_Literal (Loc,
8834 Intval => Component_Counter)),
8837 Component_Counter := Component_Counter + 1;
8839 Append_To (Discriminant_Associations,
8840 Make_Discriminant_Association (Loc,
8841 Selector_Names => New_List (
8842 New_Occurrence_Of (Disc, Loc)),
8844 New_Occurrence_Of (Disc_Var_Name, Loc)));
8846 Next_Discriminant (Disc);
8850 Make_Subtype_Indication (Loc,
8851 Subtype_Mark => Res_Definition,
8853 Make_Index_Or_Discriminant_Constraint (Loc,
8854 Discriminant_Associations));
8857 -- Now we have all the discriminants in variables, we can
8858 -- declared a constrained object. Note that we are not
8859 -- initializing (non-discriminant) components directly in
8860 -- the object declarations, because which fields to
8861 -- initialize depends (at run time) on the discriminant
8865 Make_Object_Declaration (Loc,
8866 Defining_Identifier => Res,
8867 Object_Definition => Res_Definition));
8869 -- ... then all components
8871 FA_Append_Record_Traversal (Stms,
8872 Clist => Component_List (Rdef),
8873 Container => Any_Parameter,
8874 Counter => Component_Counter);
8877 Make_Simple_Return_Statement (Loc,
8878 Expression => New_Occurrence_Of (Res, Loc)));
8882 elsif Is_Array_Type (Typ) then
8884 Constrained : constant Boolean := Is_Constrained (Typ);
8886 procedure FA_Ary_Add_Process_Element
8889 Counter : Entity_Id;
8891 -- Assign the current element (as identified by Counter) of
8892 -- Any to the variable denoted by name Datum, and advance
8893 -- Counter by 1. If Datum is not an Any, a call to From_Any
8894 -- for its type is inserted.
8896 --------------------------------
8897 -- FA_Ary_Add_Process_Element --
8898 --------------------------------
8900 procedure FA_Ary_Add_Process_Element
8903 Counter : Entity_Id;
8906 Assignment : constant Node_Id :=
8907 Make_Assignment_Statement (Loc,
8909 Expression => Empty);
8911 Element_Any : Node_Id;
8915 Element_TC : Node_Id;
8918 if Etype (Datum) = RTE (RE_Any) then
8920 -- When Datum is an Any the Etype field is not
8921 -- sufficient to determine the typecode of Datum
8922 -- (which can be a TC_SEQUENCE or TC_ARRAY
8923 -- depending on the value of Constrained).
8925 -- Therefore we retrieve the typecode which has
8926 -- been constructed in Append_Array_Traversal with
8927 -- a call to Get_Any_Type.
8930 Make_Function_Call (Loc,
8931 Name => New_Occurrence_Of (
8932 RTE (RE_Get_Any_Type), Loc),
8933 Parameter_Associations => New_List (
8934 New_Occurrence_Of (Entity (Datum), Loc)));
8936 -- For non Any Datum we simply construct a typecode
8937 -- matching the Etype of the Datum.
8939 Element_TC := Build_TypeCode_Call
8940 (Loc, Etype (Datum), Decls);
8944 Build_Get_Aggregate_Element (Loc,
8947 Idx => New_Occurrence_Of (Counter, Loc));
8950 -- Note: here we *prepend* statements to Stmts, so
8951 -- we must do it in reverse order.
8954 Make_Assignment_Statement (Loc,
8956 New_Occurrence_Of (Counter, Loc),
8959 Left_Opnd => New_Occurrence_Of (Counter, Loc),
8960 Right_Opnd => Make_Integer_Literal (Loc, 1))));
8962 if Nkind (Datum) /= N_Attribute_Reference then
8964 -- We ignore the value of the length of each
8965 -- dimension, since the target array has already been
8966 -- constrained anyway.
8968 if Etype (Datum) /= RTE (RE_Any) then
8969 Set_Expression (Assignment,
8971 (Component_Type (Typ), Element_Any, Decls));
8973 Set_Expression (Assignment, Element_Any);
8976 Prepend_To (Stmts, Assignment);
8978 end FA_Ary_Add_Process_Element;
8980 ------------------------
8981 -- Local Declarations --
8982 ------------------------
8984 Counter : constant Entity_Id :=
8985 Make_Defining_Identifier (Loc, Name_J);
8987 Initial_Counter_Value : Int := 0;
8989 Component_TC : constant Entity_Id :=
8990 Make_Defining_Identifier (Loc, Name_T);
8992 Res : constant Entity_Id :=
8993 Make_Defining_Identifier (Loc, Name_R);
8995 procedure Append_From_Any_Array_Iterator is
8996 new Append_Array_Traversal (
8999 Indexes => New_List,
9000 Add_Process_Element => FA_Ary_Add_Process_Element);
9002 Res_Subtype_Indication : Node_Id :=
9003 New_Occurrence_Of (Typ, Loc);
9006 if not Constrained then
9008 Ndim : constant Int := Number_Dimensions (Typ);
9011 Indx : Node_Id := First_Index (Typ);
9014 Ranges : constant List_Id := New_List;
9017 for J in 1 .. Ndim loop
9018 Lnam := New_External_Name ('L', J);
9019 Hnam := New_External_Name ('H', J);
9021 -- Note, for empty arrays bounds may be out of
9022 -- the range of Etype (Indx).
9024 Indt := Base_Type (Etype (Indx));
9027 Make_Object_Declaration (Loc,
9028 Defining_Identifier =>
9029 Make_Defining_Identifier (Loc, Lnam),
9030 Constant_Present => True,
9031 Object_Definition =>
9032 New_Occurrence_Of (Indt, Loc),
9036 Build_Get_Aggregate_Element (Loc,
9037 Any => Any_Parameter,
9038 TC => Build_TypeCode_Call
9041 Make_Integer_Literal (Loc, J - 1)),
9045 Make_Object_Declaration (Loc,
9046 Defining_Identifier =>
9047 Make_Defining_Identifier (Loc, Hnam),
9049 Constant_Present => True,
9051 Object_Definition =>
9052 New_Occurrence_Of (Indt, Loc),
9054 Expression => Make_Attribute_Reference (Loc,
9056 New_Occurrence_Of (Indt, Loc),
9058 Attribute_Name => Name_Val,
9060 Expressions => New_List (
9061 Make_Op_Subtract (Loc,
9066 (Standard_Long_Integer,
9067 Make_Identifier (Loc, Lnam)),
9071 (Standard_Long_Integer,
9072 Make_Function_Call (Loc,
9074 New_Occurrence_Of (RTE (
9075 RE_Get_Nested_Sequence_Length
9077 Parameter_Associations =>
9080 Any_Parameter, Loc),
9081 Make_Integer_Literal (Loc,
9085 Make_Integer_Literal (Loc, 1))))));
9089 Low_Bound => Make_Identifier (Loc, Lnam),
9090 High_Bound => Make_Identifier (Loc, Hnam)));
9095 -- Now we have all the necessary bound information:
9096 -- apply the set of range constraints to the
9097 -- (unconstrained) nominal subtype of Res.
9099 Initial_Counter_Value := Ndim;
9100 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9101 Subtype_Mark => Res_Subtype_Indication,
9103 Make_Index_Or_Discriminant_Constraint (Loc,
9104 Constraints => Ranges));
9109 Make_Object_Declaration (Loc,
9110 Defining_Identifier => Res,
9111 Object_Definition => Res_Subtype_Indication));
9112 Set_Etype (Res, Typ);
9115 Make_Object_Declaration (Loc,
9116 Defining_Identifier => Counter,
9117 Object_Definition =>
9118 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc),
9120 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9123 Make_Object_Declaration (Loc,
9124 Defining_Identifier => Component_TC,
9125 Constant_Present => True,
9126 Object_Definition =>
9127 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9129 Build_TypeCode_Call (Loc,
9130 Component_Type (Typ), Decls)));
9132 Append_From_Any_Array_Iterator
9133 (Stms, Any_Parameter, Counter);
9136 Make_Simple_Return_Statement (Loc,
9137 Expression => New_Occurrence_Of (Res, Loc)));
9140 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9142 Make_Simple_Return_Statement (Loc,
9144 Unchecked_Convert_To (Typ,
9146 (Find_Numeric_Representation (Typ),
9147 New_Occurrence_Of (Any_Parameter, Loc),
9151 Use_Opaque_Representation := True;
9154 if Use_Opaque_Representation then
9155 Assign_Opaque_From_Any (Loc,
9158 N => New_Occurrence_Of (Any_Parameter, Loc),
9163 Make_Subprogram_Body (Loc,
9164 Specification => Spec,
9165 Declarations => Decls,
9166 Handled_Statement_Sequence =>
9167 Make_Handled_Sequence_Of_Statements (Loc,
9168 Statements => Stms));
9169 end Build_From_Any_Function;
9171 ---------------------------------
9172 -- Build_Get_Aggregate_Element --
9173 ---------------------------------
9175 function Build_Get_Aggregate_Element
9179 Idx : Node_Id) return Node_Id
9182 return Make_Function_Call (Loc,
9184 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc),
9185 Parameter_Associations => New_List (
9186 New_Occurrence_Of (Any, Loc),
9189 end Build_Get_Aggregate_Element;
9191 -------------------------
9192 -- Build_Reposiroty_Id --
9193 -------------------------
9195 procedure Build_Name_And_Repository_Id
9197 Name_Str : out String_Id;
9198 Repo_Id_Str : out String_Id)
9202 Store_String_Chars ("DSA:");
9203 Get_Library_Unit_Name_String (Scope (E));
9205 (Name_Buffer (Name_Buffer'First ..
9206 Name_Buffer'First + Name_Len - 1));
9207 Store_String_Char ('.');
9208 Get_Name_String (Chars (E));
9210 (Name_Buffer (Name_Buffer'First ..
9211 Name_Buffer'First + Name_Len - 1));
9212 Store_String_Chars (":1.0");
9213 Repo_Id_Str := End_String;
9214 Name_Str := String_From_Name_Buffer;
9215 end Build_Name_And_Repository_Id;
9217 -----------------------
9218 -- Build_To_Any_Call --
9219 -----------------------
9221 function Build_To_Any_Call
9223 Decls : List_Id) return Node_Id
9225 Loc : constant Source_Ptr := Sloc (N);
9227 Typ : Entity_Id := Etype (N);
9230 Fnam : Entity_Id := Empty;
9231 Lib_RE : RE_Id := RE_Null;
9234 -- If N is a selected component, then maybe its Etype has not been
9235 -- set yet: try to use Etype of the selector_name in that case.
9237 if No (Typ) and then Nkind (N) = N_Selected_Component then
9238 Typ := Etype (Selector_Name (N));
9241 pragma Assert (Present (Typ));
9243 -- Get full view for private type, completion for incomplete type
9245 U_Type := Underlying_Type (Typ);
9247 -- First simple case where the To_Any function is present in the
9250 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9252 -- For the subtype representing a generic actual type, go to the
9255 if Is_Generic_Actual_Type (U_Type) then
9256 U_Type := Underlying_Type (Base_Type (U_Type));
9259 -- For a standard subtype, go to the base type
9261 if Sloc (U_Type) <= Standard_Location then
9262 U_Type := Base_Type (U_Type);
9265 if Present (Fnam) then
9268 -- Check first for Boolean and Character. These are enumeration
9269 -- types, but we treat them specially, since they may require
9270 -- special handling in the transfer protocol. However, this
9271 -- special handling only applies if they have standard
9272 -- representation, otherwise they are treated like any other
9273 -- enumeration type.
9275 elsif U_Type = Standard_Boolean then
9278 elsif U_Type = Standard_Character then
9281 elsif U_Type = Standard_Wide_Character then
9284 elsif U_Type = Standard_Wide_Wide_Character then
9285 Lib_RE := RE_TA_WWC;
9287 -- Floating point types
9289 elsif U_Type = Standard_Short_Float then
9292 elsif U_Type = Standard_Float then
9295 elsif U_Type = Standard_Long_Float then
9298 elsif U_Type = Standard_Long_Long_Float then
9299 Lib_RE := RE_TA_LLF;
9303 elsif U_Type = RTE (RE_Integer_8) then
9306 elsif U_Type = RTE (RE_Integer_16) then
9307 Lib_RE := RE_TA_I16;
9309 elsif U_Type = RTE (RE_Integer_32) then
9310 Lib_RE := RE_TA_I32;
9312 elsif U_Type = RTE (RE_Integer_64) then
9313 Lib_RE := RE_TA_I64;
9315 -- Unsigned integer types
9317 elsif U_Type = RTE (RE_Unsigned_8) then
9320 elsif U_Type = RTE (RE_Unsigned_16) then
9321 Lib_RE := RE_TA_U16;
9323 elsif U_Type = RTE (RE_Unsigned_32) then
9324 Lib_RE := RE_TA_U32;
9326 elsif U_Type = RTE (RE_Unsigned_64) then
9327 Lib_RE := RE_TA_U64;
9329 elsif Is_RTE (U_Type, RE_Unbounded_String) then
9330 Lib_RE := RE_TA_String;
9332 -- Special DSA types
9334 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
9338 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9340 -- No corresponding FA_TC ???
9344 -- Other (non-primitive) types
9350 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9351 Append_To (Decls, Decl);
9355 -- Call the function
9357 if Lib_RE /= RE_Null then
9358 pragma Assert (No (Fnam));
9359 Fnam := RTE (Lib_RE);
9362 -- If Fnam is already analyzed, find the proper expected type,
9363 -- else we have a newly constructed To_Any function and we know
9364 -- that the expected type of its parameter is U_Type.
9366 if Ekind (Fnam) = E_Function
9367 and then Present (First_Formal (Fnam))
9369 C_Type := Etype (First_Formal (Fnam));
9375 Make_Function_Call (Loc,
9376 Name => New_Occurrence_Of (Fnam, Loc),
9377 Parameter_Associations =>
9378 New_List (OK_Convert_To (C_Type, N)));
9379 end Build_To_Any_Call;
9381 ---------------------------
9382 -- Build_To_Any_Function --
9383 ---------------------------
9385 procedure Build_To_Any_Function
9389 Fnam : out Entity_Id)
9392 Decls : constant List_Id := New_List;
9393 Stms : constant List_Id := New_List;
9395 Expr_Parameter : Entity_Id;
9397 Result_TC : Node_Id;
9401 Use_Opaque_Representation : Boolean;
9402 -- When True, use stream attributes and represent type as an
9403 -- opaque sequence of bytes.
9406 -- For a derived type, we can't go past the base type (to the
9407 -- parent type) here, because that would cause the attribute's
9408 -- formal parameter to have the wrong type; hence the Base_Type
9411 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
9412 Build_To_Any_Function
9420 Expr_Parameter := Make_Defining_Identifier (Loc, Name_E);
9421 Any := Make_Defining_Identifier (Loc, Name_A);
9422 Result_TC := Build_TypeCode_Call (Loc, Typ, Decls);
9424 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
9427 Make_Function_Specification (Loc,
9428 Defining_Unit_Name => Fnam,
9429 Parameter_Specifications => New_List (
9430 Make_Parameter_Specification (Loc,
9431 Defining_Identifier => Expr_Parameter,
9432 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9433 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9434 Set_Etype (Expr_Parameter, Typ);
9437 Make_Object_Declaration (Loc,
9438 Defining_Identifier => Any,
9439 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9441 Use_Opaque_Representation := False;
9443 if Has_Stream_Attribute_Definition
9444 (Typ, TSS_Stream_Output, At_Any_Place => True)
9446 Has_Stream_Attribute_Definition
9447 (Typ, TSS_Stream_Write, At_Any_Place => True)
9449 -- If user-defined stream attributes are specified for this
9450 -- type, use them and transmit data as an opaque sequence of
9453 Use_Opaque_Representation := True;
9455 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9457 -- Non-tagged derived type: convert to root type
9460 Rt_Type : constant Entity_Id := Root_Type (Typ);
9461 Expr : constant Node_Id :=
9464 New_Occurrence_Of (Expr_Parameter, Loc));
9466 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9469 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9471 -- Non-tagged record type
9473 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9475 Rt_Type : constant Entity_Id := Etype (Typ);
9476 Expr : constant Node_Id :=
9477 OK_Convert_To (Rt_Type,
9478 New_Occurrence_Of (Expr_Parameter, Loc));
9482 (Any_Decl, Build_To_Any_Call (Expr, Decls));
9485 -- Comment needed here (and label on declare block ???)
9489 Disc : Entity_Id := Empty;
9490 Rdef : constant Node_Id :=
9491 Type_Definition (Declaration_Node (Typ));
9493 Elements : constant List_Id := New_List;
9495 procedure TA_Rec_Add_Process_Element
9497 Container : Node_Or_Entity_Id;
9498 Counter : in out Int;
9501 -- Processing routine for traversal below
9503 procedure TA_Append_Record_Traversal is
9504 new Append_Record_Traversal
9505 (Rec => Expr_Parameter,
9506 Add_Process_Element => TA_Rec_Add_Process_Element);
9508 --------------------------------
9509 -- TA_Rec_Add_Process_Element --
9510 --------------------------------
9512 procedure TA_Rec_Add_Process_Element
9514 Container : Node_Or_Entity_Id;
9515 Counter : in out Int;
9519 Field_Ref : Node_Id;
9522 if Nkind (Field) = N_Defining_Identifier then
9524 -- A regular component
9526 Field_Ref := Make_Selected_Component (Loc,
9527 Prefix => New_Occurrence_Of (Rec, Loc),
9528 Selector_Name => New_Occurrence_Of (Field, Loc));
9529 Set_Etype (Field_Ref, Etype (Field));
9532 Make_Procedure_Call_Statement (Loc,
9535 RTE (RE_Add_Aggregate_Element), Loc),
9536 Parameter_Associations => New_List (
9537 New_Occurrence_Of (Container, Loc),
9538 Build_To_Any_Call (Field_Ref, Decls))));
9543 Variant_Part : declare
9545 Struct_Counter : Int := 0;
9547 Block_Decls : constant List_Id := New_List;
9548 Block_Stmts : constant List_Id := New_List;
9551 Alt_List : constant List_Id := New_List;
9552 Choice_List : List_Id;
9554 Union_Any : constant Entity_Id :=
9555 Make_Temporary (Loc, 'V');
9557 Struct_Any : constant Entity_Id :=
9558 Make_Temporary (Loc, 'S');
9560 function Make_Discriminant_Reference
9562 -- Build reference to the discriminant for this
9565 ---------------------------------
9566 -- Make_Discriminant_Reference --
9567 ---------------------------------
9569 function Make_Discriminant_Reference
9572 Nod : constant Node_Id :=
9573 Make_Selected_Component (Loc,
9576 Chars (Name (Field)));
9578 Set_Etype (Nod, Etype (Name (Field)));
9580 end Make_Discriminant_Reference;
9582 -- Start of processing for Variant_Part
9586 Make_Block_Statement (Loc,
9589 Handled_Statement_Sequence =>
9590 Make_Handled_Sequence_Of_Statements (Loc,
9591 Statements => Block_Stmts)));
9593 -- Declare variant part aggregate (Union_Any).
9594 -- Knowing the position of this VP in the
9595 -- variant record, we can fetch the VP typecode
9598 Append_To (Block_Decls,
9599 Make_Object_Declaration (Loc,
9600 Defining_Identifier => Union_Any,
9601 Object_Definition =>
9602 New_Occurrence_Of (RTE (RE_Any), Loc),
9604 Make_Function_Call (Loc,
9605 Name => New_Occurrence_Of (
9606 RTE (RE_Create_Any), Loc),
9607 Parameter_Associations => New_List (
9608 Make_Function_Call (Loc,
9611 RTE (RE_Any_Member_Type), Loc),
9612 Parameter_Associations => New_List (
9613 New_Occurrence_Of (Container, Loc),
9614 Make_Integer_Literal (Loc,
9617 -- Declare inner struct aggregate (which
9618 -- contains the components of this VP).
9620 Append_To (Block_Decls,
9621 Make_Object_Declaration (Loc,
9622 Defining_Identifier => Struct_Any,
9623 Object_Definition =>
9624 New_Occurrence_Of (RTE (RE_Any), Loc),
9626 Make_Function_Call (Loc,
9627 Name => New_Occurrence_Of (
9628 RTE (RE_Create_Any), Loc),
9629 Parameter_Associations => New_List (
9630 Make_Function_Call (Loc,
9633 RTE (RE_Any_Member_Type), Loc),
9634 Parameter_Associations => New_List (
9635 New_Occurrence_Of (Union_Any, Loc),
9636 Make_Integer_Literal (Loc,
9639 -- Build case statement
9641 Append_To (Block_Stmts,
9642 Make_Case_Statement (Loc,
9643 Expression => Make_Discriminant_Reference,
9644 Alternatives => Alt_List));
9646 Variant := First_Non_Pragma (Variants (Field));
9647 while Present (Variant) loop
9648 Choice_List := New_Copy_List_Tree
9649 (Discrete_Choices (Variant));
9651 VP_Stmts := New_List;
9653 -- Append discriminant val to union aggregate
9655 Append_To (VP_Stmts,
9656 Make_Procedure_Call_Statement (Loc,
9659 RTE (RE_Add_Aggregate_Element), Loc),
9660 Parameter_Associations => New_List (
9661 New_Occurrence_Of (Union_Any, Loc),
9663 (Make_Discriminant_Reference,
9666 -- Populate inner struct aggregate
9668 -- Struct_Counter should be reset before
9669 -- handling a variant part. Indeed only one
9670 -- of the case statement alternatives will be
9671 -- executed at run time, so the counter must
9672 -- start at 0 for every case statement.
9674 Struct_Counter := 0;
9676 TA_Append_Record_Traversal
9678 Clist => Component_List (Variant),
9679 Container => Struct_Any,
9680 Counter => Struct_Counter);
9682 -- Append inner struct to union aggregate
9684 Append_To (VP_Stmts,
9685 Make_Procedure_Call_Statement (Loc,
9688 (RTE (RE_Add_Aggregate_Element), Loc),
9689 Parameter_Associations => New_List (
9690 New_Occurrence_Of (Union_Any, Loc),
9691 New_Occurrence_Of (Struct_Any, Loc))));
9693 -- Append union to outer aggregate
9695 Append_To (VP_Stmts,
9696 Make_Procedure_Call_Statement (Loc,
9699 (RTE (RE_Add_Aggregate_Element), Loc),
9700 Parameter_Associations => New_List (
9701 New_Occurrence_Of (Container, Loc),
9703 (Union_Any, Loc))));
9705 Append_To (Alt_List,
9706 Make_Case_Statement_Alternative (Loc,
9707 Discrete_Choices => Choice_List,
9708 Statements => VP_Stmts));
9710 Next_Non_Pragma (Variant);
9715 Counter := Counter + 1;
9716 end TA_Rec_Add_Process_Element;
9719 -- Records are encoded in a TC_STRUCT aggregate:
9721 -- -- Outer aggregate (TC_STRUCT)
9722 -- | [discriminant1]
9723 -- | [discriminant2]
9730 -- A component can be a common component or variant part
9732 -- A variant part is encoded as a TC_UNION aggregate:
9734 -- -- Variant Part Aggregate (TC_UNION)
9735 -- | [discriminant choice for this Variant Part]
9737 -- | -- Inner struct (TC_STRUCT)
9742 -- Let's start by building the outer aggregate. First we
9743 -- construct Elements array containing all discriminants.
9745 if Has_Discriminants (Typ) then
9746 Disc := First_Discriminant (Typ);
9747 while Present (Disc) loop
9749 Discriminant : constant Entity_Id :=
9750 Make_Selected_Component (Loc,
9757 Set_Etype (Discriminant, Etype (Disc));
9759 Append_To (Elements,
9760 Make_Component_Association (Loc,
9761 Choices => New_List (
9762 Make_Integer_Literal (Loc, Counter)),
9764 Build_To_Any_Call (Discriminant, Decls)));
9767 Counter := Counter + 1;
9768 Next_Discriminant (Disc);
9772 -- If there are no discriminants, we declare an empty
9776 Dummy_Any : constant Entity_Id :=
9777 Make_Temporary (Loc, 'A');
9781 Make_Object_Declaration (Loc,
9782 Defining_Identifier => Dummy_Any,
9783 Object_Definition =>
9784 New_Occurrence_Of (RTE (RE_Any), Loc)));
9786 Append_To (Elements,
9787 Make_Component_Association (Loc,
9788 Choices => New_List (
9791 Make_Integer_Literal (Loc, 1),
9793 Make_Integer_Literal (Loc, 0))),
9795 New_Occurrence_Of (Dummy_Any, Loc)));
9799 -- We build the result aggregate with discriminants
9800 -- as the first elements.
9802 Set_Expression (Any_Decl,
9803 Make_Function_Call (Loc,
9804 Name => New_Occurrence_Of
9805 (RTE (RE_Any_Aggregate_Build), Loc),
9806 Parameter_Associations => New_List (
9808 Make_Aggregate (Loc,
9809 Component_Associations => Elements))));
9812 -- Then we append all the components to the result
9815 TA_Append_Record_Traversal (Stms,
9816 Clist => Component_List (Rdef),
9818 Counter => Counter);
9822 elsif Is_Array_Type (Typ) then
9824 -- Constrained and unconstrained array types
9827 Constrained : constant Boolean := Is_Constrained (Typ);
9829 procedure TA_Ary_Add_Process_Element
9832 Counter : Entity_Id;
9835 --------------------------------
9836 -- TA_Ary_Add_Process_Element --
9837 --------------------------------
9839 procedure TA_Ary_Add_Process_Element
9842 Counter : Entity_Id;
9845 pragma Unreferenced (Counter);
9847 Element_Any : Node_Id;
9850 if Etype (Datum) = RTE (RE_Any) then
9851 Element_Any := Datum;
9853 Element_Any := Build_To_Any_Call (Datum, Decls);
9857 Make_Procedure_Call_Statement (Loc,
9858 Name => New_Occurrence_Of (
9859 RTE (RE_Add_Aggregate_Element), Loc),
9860 Parameter_Associations => New_List (
9861 New_Occurrence_Of (Any, Loc),
9863 end TA_Ary_Add_Process_Element;
9865 procedure Append_To_Any_Array_Iterator is
9866 new Append_Array_Traversal (
9868 Arry => Expr_Parameter,
9869 Indexes => New_List,
9870 Add_Process_Element => TA_Ary_Add_Process_Element);
9875 Set_Expression (Any_Decl,
9876 Make_Function_Call (Loc,
9878 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9879 Parameter_Associations => New_List (Result_TC)));
9882 if not Constrained then
9883 Index := First_Index (Typ);
9884 for J in 1 .. Number_Dimensions (Typ) loop
9886 Make_Procedure_Call_Statement (Loc,
9889 RTE (RE_Add_Aggregate_Element), Loc),
9890 Parameter_Associations => New_List (
9891 New_Occurrence_Of (Any, Loc),
9893 OK_Convert_To (Etype (Index),
9894 Make_Attribute_Reference (Loc,
9896 New_Occurrence_Of (Expr_Parameter, Loc),
9897 Attribute_Name => Name_First,
9898 Expressions => New_List (
9899 Make_Integer_Literal (Loc, J)))),
9905 Append_To_Any_Array_Iterator (Stms, Any);
9908 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9912 Set_Expression (Any_Decl,
9915 Find_Numeric_Representation (Typ),
9916 New_Occurrence_Of (Expr_Parameter, Loc)),
9920 -- Default case, including tagged types: opaque representation
9922 Use_Opaque_Representation := True;
9925 if Use_Opaque_Representation then
9927 Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
9928 -- Stream used to store data representation produced by
9929 -- stream attribute.
9933 -- Strm : aliased Buffer_Stream_Type;
9936 Make_Object_Declaration (Loc,
9937 Defining_Identifier =>
9941 Object_Definition =>
9942 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9945 -- T'Output (Strm'Access, E);
9948 Make_Attribute_Reference (Loc,
9949 Prefix => New_Occurrence_Of (Typ, Loc),
9950 Attribute_Name => Name_Output,
9951 Expressions => New_List (
9952 Make_Attribute_Reference (Loc,
9953 Prefix => New_Occurrence_Of (Strm, Loc),
9954 Attribute_Name => Name_Access),
9955 New_Occurrence_Of (Expr_Parameter, Loc))));
9958 -- BS_To_Any (Strm, A);
9961 Make_Procedure_Call_Statement (Loc,
9962 Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
9963 Parameter_Associations => New_List (
9964 New_Occurrence_Of (Strm, Loc),
9965 New_Occurrence_Of (Any, Loc))));
9968 -- Release_Buffer (Strm);
9971 Make_Procedure_Call_Statement (Loc,
9972 Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
9973 Parameter_Associations => New_List (
9974 New_Occurrence_Of (Strm, Loc))));
9978 Append_To (Decls, Any_Decl);
9980 if Present (Result_TC) then
9982 Make_Procedure_Call_Statement (Loc,
9983 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
9984 Parameter_Associations => New_List (
9985 New_Occurrence_Of (Any, Loc),
9990 Make_Simple_Return_Statement (Loc,
9991 Expression => New_Occurrence_Of (Any, Loc)));
9994 Make_Subprogram_Body (Loc,
9995 Specification => Spec,
9996 Declarations => Decls,
9997 Handled_Statement_Sequence =>
9998 Make_Handled_Sequence_Of_Statements (Loc,
9999 Statements => Stms));
10000 end Build_To_Any_Function;
10002 -------------------------
10003 -- Build_TypeCode_Call --
10004 -------------------------
10006 function Build_TypeCode_Call
10009 Decls : List_Id) return Node_Id
10011 U_Type : Entity_Id := Underlying_Type (Typ);
10012 -- The full view, if Typ is private; the completion,
10013 -- if Typ is incomplete.
10015 Fnam : Entity_Id := Empty;
10016 Lib_RE : RE_Id := RE_Null;
10020 -- Special case System.PolyORB.Interface.Any: its primitives have
10021 -- not been set yet, so can't call Find_Inherited_TSS.
10023 if Typ = RTE (RE_Any) then
10024 Fnam := RTE (RE_TC_A);
10027 -- First simple case where the TypeCode is present
10028 -- in the type's TSS.
10030 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10033 -- For the subtype representing a generic actual type, go to the
10036 if Is_Generic_Actual_Type (U_Type) then
10037 U_Type := Underlying_Type (Base_Type (U_Type));
10040 -- For a standard subtype, go to the base type
10042 if Sloc (U_Type) <= Standard_Location then
10043 U_Type := Base_Type (U_Type);
10047 if U_Type = Standard_Boolean then
10050 elsif U_Type = Standard_Character then
10053 elsif U_Type = Standard_Wide_Character then
10054 Lib_RE := RE_TC_WC;
10056 elsif U_Type = Standard_Wide_Wide_Character then
10057 Lib_RE := RE_TC_WWC;
10059 -- Floating point types
10061 elsif U_Type = Standard_Short_Float then
10062 Lib_RE := RE_TC_SF;
10064 elsif U_Type = Standard_Float then
10067 elsif U_Type = Standard_Long_Float then
10068 Lib_RE := RE_TC_LF;
10070 elsif U_Type = Standard_Long_Long_Float then
10071 Lib_RE := RE_TC_LLF;
10073 -- Integer types (walk back to the base type)
10075 elsif U_Type = RTE (RE_Integer_8) then
10076 Lib_RE := RE_TC_I8;
10078 elsif U_Type = RTE (RE_Integer_16) then
10079 Lib_RE := RE_TC_I16;
10081 elsif U_Type = RTE (RE_Integer_32) then
10082 Lib_RE := RE_TC_I32;
10084 elsif U_Type = RTE (RE_Integer_64) then
10085 Lib_RE := RE_TC_I64;
10087 -- Unsigned integer types
10089 elsif U_Type = RTE (RE_Unsigned_8) then
10090 Lib_RE := RE_TC_U8;
10092 elsif U_Type = RTE (RE_Unsigned_16) then
10093 Lib_RE := RE_TC_U16;
10095 elsif U_Type = RTE (RE_Unsigned_32) then
10096 Lib_RE := RE_TC_U32;
10098 elsif U_Type = RTE (RE_Unsigned_64) then
10099 Lib_RE := RE_TC_U64;
10101 elsif Is_RTE (U_Type, RE_Unbounded_String) then
10102 Lib_RE := RE_TC_String;
10104 -- Special DSA types
10106 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
10109 -- Other (non-primitive) types
10115 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10116 Append_To (Decls, Decl);
10120 if Lib_RE /= RE_Null then
10121 Fnam := RTE (Lib_RE);
10125 -- Call the function
10128 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10130 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10132 Set_Etype (Expr, RTE (RE_TypeCode));
10135 end Build_TypeCode_Call;
10137 -----------------------------
10138 -- Build_TypeCode_Function --
10139 -----------------------------
10141 procedure Build_TypeCode_Function
10144 Decl : out Node_Id;
10145 Fnam : out Entity_Id)
10148 Decls : constant List_Id := New_List;
10149 Stms : constant List_Id := New_List;
10151 TCNam : constant Entity_Id :=
10152 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
10154 Parameters : List_Id;
10156 procedure Add_String_Parameter
10158 Parameter_List : List_Id);
10159 -- Add a literal for S to Parameters
10161 procedure Add_TypeCode_Parameter
10162 (TC_Node : Node_Id;
10163 Parameter_List : List_Id);
10164 -- Add the typecode for Typ to Parameters
10166 procedure Add_Long_Parameter
10167 (Expr_Node : Node_Id;
10168 Parameter_List : List_Id);
10169 -- Add a signed long integer expression to Parameters
10171 procedure Initialize_Parameter_List
10172 (Name_String : String_Id;
10173 Repo_Id_String : String_Id;
10174 Parameter_List : out List_Id);
10175 -- Return a list that contains the first two parameters
10176 -- for a parameterized typecode: name and repository id.
10178 function Make_Constructed_TypeCode
10180 Parameters : List_Id) return Node_Id;
10181 -- Call TC_Build with the given kind and parameters
10183 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10184 -- Make a return statement that calls TC_Build with the given
10185 -- typecode kind, and the constructed parameters list.
10187 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10188 -- Return a typecode that is a TC_Alias for the given typecode
10190 --------------------------
10191 -- Add_String_Parameter --
10192 --------------------------
10194 procedure Add_String_Parameter
10196 Parameter_List : List_Id)
10199 Append_To (Parameter_List,
10200 Make_Function_Call (Loc,
10201 Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc),
10202 Parameter_Associations => New_List (
10203 Make_String_Literal (Loc, S))));
10204 end Add_String_Parameter;
10206 ----------------------------
10207 -- Add_TypeCode_Parameter --
10208 ----------------------------
10210 procedure Add_TypeCode_Parameter
10211 (TC_Node : Node_Id;
10212 Parameter_List : List_Id)
10215 Append_To (Parameter_List,
10216 Make_Function_Call (Loc,
10217 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10218 Parameter_Associations => New_List (TC_Node)));
10219 end Add_TypeCode_Parameter;
10221 ------------------------
10222 -- Add_Long_Parameter --
10223 ------------------------
10225 procedure Add_Long_Parameter
10226 (Expr_Node : Node_Id;
10227 Parameter_List : List_Id)
10230 Append_To (Parameter_List,
10231 Make_Function_Call (Loc,
10233 New_Occurrence_Of (RTE (RE_TA_I32), Loc),
10234 Parameter_Associations => New_List (Expr_Node)));
10235 end Add_Long_Parameter;
10237 -------------------------------
10238 -- Initialize_Parameter_List --
10239 -------------------------------
10241 procedure Initialize_Parameter_List
10242 (Name_String : String_Id;
10243 Repo_Id_String : String_Id;
10244 Parameter_List : out List_Id)
10247 Parameter_List := New_List;
10248 Add_String_Parameter (Name_String, Parameter_List);
10249 Add_String_Parameter (Repo_Id_String, Parameter_List);
10250 end Initialize_Parameter_List;
10252 ---------------------------
10253 -- Return_Alias_TypeCode --
10254 ---------------------------
10256 procedure Return_Alias_TypeCode
10257 (Base_TypeCode : Node_Id)
10260 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10261 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
10262 end Return_Alias_TypeCode;
10264 -------------------------------
10265 -- Make_Constructed_TypeCode --
10266 -------------------------------
10268 function Make_Constructed_TypeCode
10270 Parameters : List_Id) return Node_Id
10272 Constructed_TC : constant Node_Id :=
10273 Make_Function_Call (Loc,
10275 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
10276 Parameter_Associations => New_List (
10277 New_Occurrence_Of (Kind, Loc),
10278 Make_Aggregate (Loc,
10279 Expressions => Parameters)));
10281 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10282 return Constructed_TC;
10283 end Make_Constructed_TypeCode;
10285 ---------------------------------
10286 -- Return_Constructed_TypeCode --
10287 ---------------------------------
10289 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10292 Make_Simple_Return_Statement (Loc,
10294 Make_Constructed_TypeCode (Kind, Parameters)));
10295 end Return_Constructed_TypeCode;
10301 procedure TC_Rec_Add_Process_Element
10304 Counter : in out Int;
10308 procedure TC_Append_Record_Traversal is
10309 new Append_Record_Traversal (
10311 Add_Process_Element => TC_Rec_Add_Process_Element);
10313 --------------------------------
10314 -- TC_Rec_Add_Process_Element --
10315 --------------------------------
10317 procedure TC_Rec_Add_Process_Element
10320 Counter : in out Int;
10324 pragma Unreferenced (Any, Counter, Rec);
10327 if Nkind (Field) = N_Defining_Identifier then
10329 -- A regular component
10331 Add_TypeCode_Parameter
10332 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10333 Get_Name_String (Chars (Field));
10334 Add_String_Parameter (String_From_Name_Buffer, Params);
10340 Variant_Part : declare
10341 Disc_Type : constant Entity_Id := Etype (Name (Field));
10343 Is_Enum : constant Boolean :=
10344 Is_Enumeration_Type (Disc_Type);
10346 Union_TC_Params : List_Id;
10348 U_Name : constant Name_Id :=
10349 New_External_Name (Chars (Typ), 'V', -1);
10351 Name_Str : String_Id;
10352 Struct_TC_Params : List_Id;
10356 Default : constant Node_Id :=
10357 Make_Integer_Literal (Loc, -1);
10359 Dummy_Counter : Int := 0;
10361 Choice_Index : Int := 0;
10362 -- Index of current choice in TypeCode, used to identify
10363 -- it as the default choice if it is a "when others".
10365 procedure Add_Params_For_Variant_Components;
10366 -- Add a struct TypeCode and a corresponding member name
10367 -- to the union parameter list.
10369 -- Ordering of declarations is a complete mess in this
10370 -- area, it is supposed to be types/variables, then
10371 -- subprogram specs, then subprogram bodies ???
10373 ---------------------------------------
10374 -- Add_Params_For_Variant_Components --
10375 ---------------------------------------
10377 procedure Add_Params_For_Variant_Components is
10378 S_Name : constant Name_Id :=
10379 New_External_Name (U_Name, 'S', -1);
10382 Get_Name_String (S_Name);
10383 Name_Str := String_From_Name_Buffer;
10384 Initialize_Parameter_List
10385 (Name_Str, Name_Str, Struct_TC_Params);
10387 -- Build struct parameters
10389 TC_Append_Record_Traversal (Struct_TC_Params,
10390 Component_List (Variant),
10394 Add_TypeCode_Parameter
10395 (Make_Constructed_TypeCode
10396 (RTE (RE_TC_Struct), Struct_TC_Params),
10399 Add_String_Parameter (Name_Str, Union_TC_Params);
10400 end Add_Params_For_Variant_Components;
10402 -- Start of processing for Variant_Part
10405 Get_Name_String (U_Name);
10406 Name_Str := String_From_Name_Buffer;
10408 Initialize_Parameter_List
10409 (Name_Str, Name_Str, Union_TC_Params);
10411 -- Add union in enclosing parameter list
10413 Add_TypeCode_Parameter
10414 (Make_Constructed_TypeCode
10415 (RTE (RE_TC_Union), Union_TC_Params),
10418 Add_String_Parameter (Name_Str, Params);
10420 -- Build union parameters
10422 Add_TypeCode_Parameter
10423 (Build_TypeCode_Call (Loc, Disc_Type, Decls),
10426 Add_Long_Parameter (Default, Union_TC_Params);
10428 Variant := First_Non_Pragma (Variants (Field));
10429 while Present (Variant) loop
10430 Choice := First (Discrete_Choices (Variant));
10431 while Present (Choice) loop
10432 case Nkind (Choice) is
10435 L : constant Uint :=
10436 Expr_Value (Low_Bound (Choice));
10437 H : constant Uint :=
10438 Expr_Value (High_Bound (Choice));
10440 -- 3.8.1(8) guarantees that the bounds of
10441 -- this range are static.
10448 Expr := Get_Enum_Lit_From_Pos
10449 (Disc_Type, J, Loc);
10452 Make_Integer_Literal (Loc, J);
10455 Set_Etype (Expr, Disc_Type);
10456 Append_To (Union_TC_Params,
10457 Build_To_Any_Call (Expr, Decls));
10459 Add_Params_For_Variant_Components;
10464 Choice_Index + UI_To_Int (H - L) + 1;
10467 when N_Others_Choice =>
10469 -- This variant has a default choice. We must
10470 -- therefore set the default parameter to the
10471 -- current choice index. This parameter is by
10472 -- construction the 4th in Union_TC_Params.
10475 (Pick (Union_TC_Params, 4),
10476 Make_Function_Call (Loc,
10479 (RTE (RE_TA_I32), Loc),
10480 Parameter_Associations =>
10482 Make_Integer_Literal (Loc,
10483 Intval => Choice_Index))));
10485 -- Add a placeholder member label for the
10486 -- default case, which must have the
10487 -- discriminant type.
10490 Exp : constant Node_Id :=
10491 Make_Attribute_Reference (Loc,
10492 Prefix => New_Occurrence_Of
10494 Attribute_Name => Name_First);
10496 Set_Etype (Exp, Disc_Type);
10497 Append_To (Union_TC_Params,
10498 Build_To_Any_Call (Exp, Decls));
10501 Add_Params_For_Variant_Components;
10502 Choice_Index := Choice_Index + 1;
10504 -- Case of an explicit choice
10508 Exp : constant Node_Id :=
10509 New_Copy_Tree (Choice);
10511 Append_To (Union_TC_Params,
10512 Build_To_Any_Call (Exp, Decls));
10515 Add_Params_For_Variant_Components;
10516 Choice_Index := Choice_Index + 1;
10522 Next_Non_Pragma (Variant);
10526 end TC_Rec_Add_Process_Element;
10528 Type_Name_Str : String_Id;
10529 Type_Repo_Id_Str : String_Id;
10531 -- Start of processing for Build_TypeCode_Function
10534 -- For a derived type, we can't go past the base type (to the
10535 -- parent type) here, because that would cause the attribute's
10536 -- formal parameter to have the wrong type; hence the Base_Type
10539 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
10540 Build_TypeCode_Function
10542 Typ => Etype (Typ),
10551 Make_Function_Specification (Loc,
10552 Defining_Unit_Name => Fnam,
10553 Parameter_Specifications => Empty_List,
10554 Result_Definition =>
10555 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10557 Build_Name_And_Repository_Id (Typ,
10558 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10560 Initialize_Parameter_List
10561 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10563 if Has_Stream_Attribute_Definition
10564 (Typ, TSS_Stream_Output, At_Any_Place => True)
10566 Has_Stream_Attribute_Definition
10567 (Typ, TSS_Stream_Write, At_Any_Place => True)
10569 -- If user-defined stream attributes are specified for this
10570 -- type, use them and transmit data as an opaque sequence of
10571 -- stream elements.
10573 Return_Alias_TypeCode
10574 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10576 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
10577 Return_Alias_TypeCode (
10578 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10580 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10581 Return_Alias_TypeCode (
10582 Build_TypeCode_Call (Loc,
10583 Find_Numeric_Representation (Typ), Decls));
10585 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
10587 -- Record typecodes are encoded as follows:
10591 -- | [Repository Id]
10593 -- Then for each discriminant:
10595 -- | [Discriminant Type Code]
10596 -- | [Discriminant Name]
10599 -- Then for each component:
10601 -- | [Component Type Code]
10602 -- | [Component Name]
10605 -- Variants components type codes are encoded as follows:
10609 -- | [Repository Id]
10610 -- | [Discriminant Type Code]
10611 -- | [Index of Default Variant Part or -1 for no default]
10613 -- Then for each Variant Part :
10618 -- | | [Variant Part Name]
10619 -- | | [Variant Part Repository Id]
10621 -- | Then for each VP component:
10622 -- | | [VP component Typecode]
10623 -- | | [VP component Name]
10629 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10630 Return_Alias_TypeCode
10631 (Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10635 Disc : Entity_Id := Empty;
10636 Rdef : constant Node_Id :=
10637 Type_Definition (Declaration_Node (Typ));
10638 Dummy_Counter : Int := 0;
10641 -- Construct the discriminants typecodes
10643 if Has_Discriminants (Typ) then
10644 Disc := First_Discriminant (Typ);
10647 while Present (Disc) loop
10648 Add_TypeCode_Parameter (
10649 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10651 Get_Name_String (Chars (Disc));
10652 Add_String_Parameter (
10653 String_From_Name_Buffer,
10655 Next_Discriminant (Disc);
10658 -- then the components typecodes
10660 TC_Append_Record_Traversal
10661 (Parameters, Component_List (Rdef),
10662 Empty, Dummy_Counter);
10663 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10667 elsif Is_Array_Type (Typ) then
10669 Ndim : constant Pos := Number_Dimensions (Typ);
10670 Inner_TypeCode : Node_Id;
10671 Constrained : constant Boolean := Is_Constrained (Typ);
10672 Indx : Node_Id := First_Index (Typ);
10676 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls);
10678 for J in 1 .. Ndim loop
10679 if Constrained then
10680 Inner_TypeCode := Make_Constructed_TypeCode
10681 (RTE (RE_TC_Array), New_List (
10682 Build_To_Any_Call (
10683 OK_Convert_To (RTE (RE_Unsigned_32),
10684 Make_Attribute_Reference (Loc,
10685 Prefix => New_Occurrence_Of (Typ, Loc),
10686 Attribute_Name => Name_Length,
10687 Expressions => New_List (
10688 Make_Integer_Literal (Loc,
10689 Intval => Ndim - J + 1)))),
10691 Build_To_Any_Call (Inner_TypeCode, Decls)));
10694 -- Unconstrained case: add low bound for each
10697 Add_TypeCode_Parameter
10698 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10700 Get_Name_String (New_External_Name ('L', J));
10701 Add_String_Parameter (
10702 String_From_Name_Buffer,
10706 Inner_TypeCode := Make_Constructed_TypeCode
10707 (RTE (RE_TC_Sequence), New_List (
10708 Build_To_Any_Call (
10709 OK_Convert_To (RTE (RE_Unsigned_32),
10710 Make_Integer_Literal (Loc, 0)),
10712 Build_To_Any_Call (Inner_TypeCode, Decls)));
10716 if Constrained then
10717 Return_Alias_TypeCode (Inner_TypeCode);
10719 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10721 Store_String_Char ('V');
10722 Add_String_Parameter (End_String, Parameters);
10723 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10728 -- Default: type is represented as an opaque sequence of bytes
10730 Return_Alias_TypeCode
10731 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10735 Make_Subprogram_Body (Loc,
10736 Specification => Spec,
10737 Declarations => Decls,
10738 Handled_Statement_Sequence =>
10739 Make_Handled_Sequence_Of_Statements (Loc,
10740 Statements => Stms));
10741 end Build_TypeCode_Function;
10743 ---------------------------------
10744 -- Find_Numeric_Representation --
10745 ---------------------------------
10747 function Find_Numeric_Representation
10748 (Typ : Entity_Id) return Entity_Id
10750 FST : constant Entity_Id := First_Subtype (Typ);
10751 P_Size : constant Uint := Esize (FST);
10754 -- Special case: for Stream_Element_Offset and Storage_Offset,
10755 -- always force transmission as a 64-bit value.
10757 if Is_RTE (FST, RE_Stream_Element_Offset)
10759 Is_RTE (FST, RE_Storage_Offset)
10761 return RTE (RE_Unsigned_64);
10764 if Is_Unsigned_Type (Typ) then
10765 if P_Size <= 8 then
10766 return RTE (RE_Unsigned_8);
10768 elsif P_Size <= 16 then
10769 return RTE (RE_Unsigned_16);
10771 elsif P_Size <= 32 then
10772 return RTE (RE_Unsigned_32);
10775 return RTE (RE_Unsigned_64);
10778 elsif Is_Integer_Type (Typ) then
10779 if P_Size <= 8 then
10780 return RTE (RE_Integer_8);
10782 elsif P_Size <= Standard_Short_Integer_Size then
10783 return RTE (RE_Integer_16);
10785 elsif P_Size <= Standard_Integer_Size then
10786 return RTE (RE_Integer_32);
10789 return RTE (RE_Integer_64);
10792 elsif Is_Floating_Point_Type (Typ) then
10793 if P_Size <= Standard_Short_Float_Size then
10794 return Standard_Short_Float;
10796 elsif P_Size <= Standard_Float_Size then
10797 return Standard_Float;
10799 elsif P_Size <= Standard_Long_Float_Size then
10800 return Standard_Long_Float;
10803 return Standard_Long_Long_Float;
10807 raise Program_Error;
10810 -- TBD: fixed point types???
10811 -- TBverified numeric types with a biased representation???
10813 end Find_Numeric_Representation;
10815 ---------------------------
10816 -- Append_Array_Traversal --
10817 ---------------------------
10819 procedure Append_Array_Traversal
10822 Counter : Entity_Id := Empty;
10825 Loc : constant Source_Ptr := Sloc (Subprogram);
10826 Typ : constant Entity_Id := Etype (Arry);
10827 Constrained : constant Boolean := Is_Constrained (Typ);
10828 Ndim : constant Pos := Number_Dimensions (Typ);
10830 Inner_Any, Inner_Counter : Entity_Id;
10832 Loop_Stm : Node_Id;
10833 Inner_Stmts : constant List_Id := New_List;
10836 if Depth > Ndim then
10838 -- Processing for one element of an array
10841 Element_Expr : constant Node_Id :=
10842 Make_Indexed_Component (Loc,
10843 New_Occurrence_Of (Arry, Loc),
10846 Set_Etype (Element_Expr, Component_Type (Typ));
10847 Add_Process_Element (Stmts,
10849 Counter => Counter,
10850 Datum => Element_Expr);
10856 Append_To (Indexes,
10857 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10859 if not Constrained or else Depth > 1 then
10860 Inner_Any := Make_Defining_Identifier (Loc,
10861 New_External_Name ('A', Depth));
10862 Set_Etype (Inner_Any, RTE (RE_Any));
10864 Inner_Any := Empty;
10867 if Present (Counter) then
10868 Inner_Counter := Make_Defining_Identifier (Loc,
10869 New_External_Name ('J', Depth));
10871 Inner_Counter := Empty;
10875 Loop_Any : Node_Id := Inner_Any;
10878 -- For the first dimension of a constrained array, we add
10879 -- elements directly in the corresponding Any; there is no
10880 -- intervening inner Any.
10882 if No (Loop_Any) then
10886 Append_Array_Traversal (Inner_Stmts,
10888 Counter => Inner_Counter,
10889 Depth => Depth + 1);
10893 Make_Implicit_Loop_Statement (Subprogram,
10894 Iteration_Scheme =>
10895 Make_Iteration_Scheme (Loc,
10896 Loop_Parameter_Specification =>
10897 Make_Loop_Parameter_Specification (Loc,
10898 Defining_Identifier =>
10899 Make_Defining_Identifier (Loc,
10900 Chars => New_External_Name ('L', Depth)),
10902 Discrete_Subtype_Definition =>
10903 Make_Attribute_Reference (Loc,
10904 Prefix => New_Occurrence_Of (Arry, Loc),
10905 Attribute_Name => Name_Range,
10907 Expressions => New_List (
10908 Make_Integer_Literal (Loc, Depth))))),
10909 Statements => Inner_Stmts);
10912 Decls : constant List_Id := New_List;
10913 Dimen_Stmts : constant List_Id := New_List;
10914 Length_Node : Node_Id;
10916 Inner_Any_TypeCode : constant Entity_Id :=
10917 Make_Defining_Identifier (Loc,
10918 New_External_Name ('T', Depth));
10920 Inner_Any_TypeCode_Expr : Node_Id;
10924 if Constrained then
10925 Inner_Any_TypeCode_Expr :=
10926 Make_Function_Call (Loc,
10927 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
10928 Parameter_Associations => New_List (
10929 New_Occurrence_Of (Any, Loc)));
10932 Inner_Any_TypeCode_Expr :=
10933 Make_Function_Call (Loc,
10935 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
10936 Parameter_Associations => New_List (
10937 New_Occurrence_Of (Any, Loc),
10938 Make_Integer_Literal (Loc, Ndim)));
10942 Inner_Any_TypeCode_Expr :=
10943 Make_Function_Call (Loc,
10944 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc),
10945 Parameter_Associations => New_List (
10946 Make_Identifier (Loc,
10947 Chars => New_External_Name ('T', Depth - 1))));
10951 Make_Object_Declaration (Loc,
10952 Defining_Identifier => Inner_Any_TypeCode,
10953 Constant_Present => True,
10954 Object_Definition => New_Occurrence_Of (
10955 RTE (RE_TypeCode), Loc),
10956 Expression => Inner_Any_TypeCode_Expr));
10958 if Present (Inner_Any) then
10960 Make_Object_Declaration (Loc,
10961 Defining_Identifier => Inner_Any,
10962 Object_Definition =>
10963 New_Occurrence_Of (RTE (RE_Any), Loc),
10965 Make_Function_Call (Loc,
10967 New_Occurrence_Of (
10968 RTE (RE_Create_Any), Loc),
10969 Parameter_Associations => New_List (
10970 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
10973 if Present (Inner_Counter) then
10975 Make_Object_Declaration (Loc,
10976 Defining_Identifier => Inner_Counter,
10977 Object_Definition =>
10978 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc),
10980 Make_Integer_Literal (Loc, 0)));
10983 if not Constrained then
10984 Length_Node := Make_Attribute_Reference (Loc,
10985 Prefix => New_Occurrence_Of (Arry, Loc),
10986 Attribute_Name => Name_Length,
10988 New_List (Make_Integer_Literal (Loc, Depth)));
10989 Set_Etype (Length_Node, RTE (RE_Unsigned_32));
10991 Add_Process_Element (Dimen_Stmts,
10992 Datum => Length_Node,
10994 Counter => Inner_Counter);
10997 -- Loop_Stm does appropriate processing for each element
11000 Append_To (Dimen_Stmts, Loop_Stm);
11002 -- Link outer and inner any
11004 if Present (Inner_Any) then
11005 Add_Process_Element (Dimen_Stmts,
11007 Counter => Counter,
11008 Datum => New_Occurrence_Of (Inner_Any, Loc));
11012 Make_Block_Statement (Loc,
11015 Handled_Statement_Sequence =>
11016 Make_Handled_Sequence_Of_Statements (Loc,
11017 Statements => Dimen_Stmts)));
11019 end Append_Array_Traversal;
11021 -------------------------------
11022 -- Make_Helper_Function_Name --
11023 -------------------------------
11025 function Make_Helper_Function_Name
11028 Nam : Name_Id) return Entity_Id
11033 -- For tagged types that aren't frozen yet, generate the helper
11034 -- under its canonical name so that it matches the primitive
11035 -- spec. For all other cases, we use a serialized name so that
11036 -- multiple generations of the same procedure do not clash.
11039 if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then
11042 Serial := Increment_Serial_Number;
11045 -- Use prefixed underscore to avoid potential clash with user
11046 -- identifier (we use attribute names for Nam).
11049 Make_Defining_Identifier (Loc,
11052 (Related_Id => Nam,
11054 Suffix_Index => Serial,
11057 end Make_Helper_Function_Name;
11060 -----------------------------------
11061 -- Reserve_NamingContext_Methods --
11062 -----------------------------------
11064 procedure Reserve_NamingContext_Methods is
11065 Str_Resolve : constant String := "resolve";
11067 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11068 Name_Len := Str_Resolve'Length;
11069 Overload_Counter_Table.Set (Name_Find, 1);
11070 end Reserve_NamingContext_Methods;
11072 -----------------------
11073 -- RPC_Receiver_Decl --
11074 -----------------------
11076 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is
11077 Loc : constant Source_Ptr := Sloc (RACW_Type);
11081 Make_Object_Declaration (Loc,
11082 Defining_Identifier => Make_Temporary (Loc, 'R'),
11083 Aliased_Present => True,
11084 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
11085 end RPC_Receiver_Decl;
11087 end PolyORB_Support;
11089 -------------------------------
11090 -- RACW_Type_Is_Asynchronous --
11091 -------------------------------
11093 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11094 Asynchronous_Flag : constant Entity_Id :=
11095 Asynchronous_Flags_Table.Get (RACW_Type);
11097 Replace (Expression (Parent (Asynchronous_Flag)),
11098 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11099 end RACW_Type_Is_Asynchronous;
11101 -------------------------
11102 -- RCI_Package_Locator --
11103 -------------------------
11105 function RCI_Package_Locator
11107 Package_Spec : Node_Id) return Node_Id
11110 Pkg_Name : String_Id;
11113 Get_Library_Unit_Name_String (Package_Spec);
11114 Pkg_Name := String_From_Name_Buffer;
11116 Make_Package_Instantiation (Loc,
11117 Defining_Unit_Name => Make_Temporary (Loc, 'R'),
11120 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11122 Generic_Associations => New_List (
11123 Make_Generic_Association (Loc,
11125 Make_Identifier (Loc, Name_RCI_Name),
11126 Explicit_Generic_Actual_Parameter =>
11127 Make_String_Literal (Loc,
11128 Strval => Pkg_Name)),
11130 Make_Generic_Association (Loc,
11132 Make_Identifier (Loc, Name_Version),
11133 Explicit_Generic_Actual_Parameter =>
11134 Make_Attribute_Reference (Loc,
11136 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11140 RCI_Locator_Table.Set
11141 (Defining_Unit_Name (Package_Spec),
11142 Defining_Unit_Name (Inst));
11144 end RCI_Package_Locator;
11146 -----------------------------------------------
11147 -- Remote_Types_Tagged_Full_View_Encountered --
11148 -----------------------------------------------
11150 procedure Remote_Types_Tagged_Full_View_Encountered
11151 (Full_View : Entity_Id)
11153 Stub_Elements : constant Stub_Structure :=
11154 Stubs_Table.Get (Full_View);
11157 -- For an RACW encountered before the freeze point of its designated
11158 -- type, the stub type is generated at the point of the RACW declaration
11159 -- but the primitives are generated only once the designated type is
11160 -- frozen. That freeze can occur in another scope, for example when the
11161 -- RACW is declared in a nested package. In that case we need to
11162 -- reestablish the stub type's scope prior to generating its primitive
11165 if Stub_Elements /= Empty_Stub_Structure then
11167 Saved_Scope : constant Entity_Id := Current_Scope;
11168 Stubs_Scope : constant Entity_Id :=
11169 Scope (Stub_Elements.Stub_Type);
11172 if Current_Scope /= Stubs_Scope then
11173 Push_Scope (Stubs_Scope);
11176 Add_RACW_Primitive_Declarations_And_Bodies
11178 Stub_Elements.RPC_Receiver_Decl,
11179 Stub_Elements.Body_Decls);
11181 if Current_Scope /= Saved_Scope then
11186 end Remote_Types_Tagged_Full_View_Encountered;
11188 -------------------
11189 -- Scope_Of_Spec --
11190 -------------------
11192 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11193 Unit_Name : Node_Id;
11196 Unit_Name := Defining_Unit_Name (Spec);
11197 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11198 Unit_Name := Defining_Identifier (Unit_Name);
11204 ----------------------
11205 -- Set_Renaming_TSS --
11206 ----------------------
11208 procedure Set_Renaming_TSS
11211 TSS_Nam : TSS_Name_Type)
11213 Loc : constant Source_Ptr := Sloc (Nam);
11214 Spec : constant Node_Id := Parent (Nam);
11216 TSS_Node : constant Node_Id :=
11217 Make_Subprogram_Renaming_Declaration (Loc,
11219 Copy_Specification (Loc,
11221 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11222 Name => New_Occurrence_Of (Nam, Loc));
11224 Snam : constant Entity_Id :=
11225 Defining_Unit_Name (Specification (TSS_Node));
11228 if Nkind (Spec) = N_Function_Specification then
11229 Set_Ekind (Snam, E_Function);
11230 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11232 Set_Ekind (Snam, E_Procedure);
11233 Set_Etype (Snam, Standard_Void_Type);
11236 Set_TSS (Typ, Snam);
11237 end Set_Renaming_TSS;
11239 ----------------------------------------------
11240 -- Specific_Add_Obj_RPC_Receiver_Completion --
11241 ----------------------------------------------
11243 procedure Specific_Add_Obj_RPC_Receiver_Completion
11246 RPC_Receiver : Entity_Id;
11247 Stub_Elements : Stub_Structure)
11250 case Get_PCS_Name is
11251 when Name_PolyORB_DSA =>
11252 PolyORB_Support.Add_Obj_RPC_Receiver_Completion
11253 (Loc, Decls, RPC_Receiver, Stub_Elements);
11255 GARLIC_Support.Add_Obj_RPC_Receiver_Completion
11256 (Loc, Decls, RPC_Receiver, Stub_Elements);
11258 end Specific_Add_Obj_RPC_Receiver_Completion;
11260 --------------------------------
11261 -- Specific_Add_RACW_Features --
11262 --------------------------------
11264 procedure Specific_Add_RACW_Features
11265 (RACW_Type : Entity_Id;
11267 Stub_Type : Entity_Id;
11268 Stub_Type_Access : Entity_Id;
11269 RPC_Receiver_Decl : Node_Id;
11270 Body_Decls : List_Id)
11273 case Get_PCS_Name is
11274 when Name_PolyORB_DSA =>
11275 PolyORB_Support.Add_RACW_Features
11284 GARLIC_Support.Add_RACW_Features
11291 end Specific_Add_RACW_Features;
11293 --------------------------------
11294 -- Specific_Add_RAST_Features --
11295 --------------------------------
11297 procedure Specific_Add_RAST_Features
11298 (Vis_Decl : Node_Id;
11299 RAS_Type : Entity_Id)
11302 case Get_PCS_Name is
11303 when Name_PolyORB_DSA =>
11304 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11306 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11308 end Specific_Add_RAST_Features;
11310 --------------------------------------------------
11311 -- Specific_Add_Receiving_Stubs_To_Declarations --
11312 --------------------------------------------------
11314 procedure Specific_Add_Receiving_Stubs_To_Declarations
11315 (Pkg_Spec : Node_Id;
11320 case Get_PCS_Name is
11321 when Name_PolyORB_DSA =>
11322 PolyORB_Support.Add_Receiving_Stubs_To_Declarations
11323 (Pkg_Spec, Decls, Stmts);
11325 GARLIC_Support.Add_Receiving_Stubs_To_Declarations
11326 (Pkg_Spec, Decls, Stmts);
11328 end Specific_Add_Receiving_Stubs_To_Declarations;
11330 ------------------------------------------
11331 -- Specific_Build_General_Calling_Stubs --
11332 ------------------------------------------
11334 procedure Specific_Build_General_Calling_Stubs
11336 Statements : List_Id;
11337 Target : RPC_Target;
11338 Subprogram_Id : Node_Id;
11339 Asynchronous : Node_Id := Empty;
11340 Is_Known_Asynchronous : Boolean := False;
11341 Is_Known_Non_Asynchronous : Boolean := False;
11342 Is_Function : Boolean;
11344 Stub_Type : Entity_Id := Empty;
11345 RACW_Type : Entity_Id := Empty;
11349 case Get_PCS_Name is
11350 when Name_PolyORB_DSA =>
11351 PolyORB_Support.Build_General_Calling_Stubs
11357 Is_Known_Asynchronous,
11358 Is_Known_Non_Asynchronous,
11366 GARLIC_Support.Build_General_Calling_Stubs
11370 Target.RPC_Receiver,
11373 Is_Known_Asynchronous,
11374 Is_Known_Non_Asynchronous,
11381 end Specific_Build_General_Calling_Stubs;
11383 --------------------------------------
11384 -- Specific_Build_RPC_Receiver_Body --
11385 --------------------------------------
11387 procedure Specific_Build_RPC_Receiver_Body
11388 (RPC_Receiver : Entity_Id;
11389 Request : out Entity_Id;
11390 Subp_Id : out Entity_Id;
11391 Subp_Index : out Entity_Id;
11392 Stmts : out List_Id;
11393 Decl : out Node_Id)
11396 case Get_PCS_Name is
11397 when Name_PolyORB_DSA =>
11398 PolyORB_Support.Build_RPC_Receiver_Body
11407 GARLIC_Support.Build_RPC_Receiver_Body
11415 end Specific_Build_RPC_Receiver_Body;
11417 --------------------------------
11418 -- Specific_Build_Stub_Target --
11419 --------------------------------
11421 function Specific_Build_Stub_Target
11424 RCI_Locator : Entity_Id;
11425 Controlling_Parameter : Entity_Id) return RPC_Target
11428 case Get_PCS_Name is
11429 when Name_PolyORB_DSA =>
11431 PolyORB_Support.Build_Stub_Target
11432 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11436 GARLIC_Support.Build_Stub_Target
11437 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11439 end Specific_Build_Stub_Target;
11441 --------------------------------
11442 -- Specific_RPC_Receiver_Decl --
11443 --------------------------------
11445 function Specific_RPC_Receiver_Decl
11446 (RACW_Type : Entity_Id) return Node_Id
11449 case Get_PCS_Name is
11450 when Name_PolyORB_DSA =>
11451 return PolyORB_Support.RPC_Receiver_Decl (RACW_Type);
11454 return GARLIC_Support.RPC_Receiver_Decl (RACW_Type);
11456 end Specific_RPC_Receiver_Decl;
11458 -----------------------------------------------
11459 -- Specific_Build_Subprogram_Receiving_Stubs --
11460 -----------------------------------------------
11462 function Specific_Build_Subprogram_Receiving_Stubs
11463 (Vis_Decl : Node_Id;
11464 Asynchronous : Boolean;
11465 Dynamically_Asynchronous : Boolean := False;
11466 Stub_Type : Entity_Id := Empty;
11467 RACW_Type : Entity_Id := Empty;
11468 Parent_Primitive : Entity_Id := Empty) return Node_Id
11471 case Get_PCS_Name is
11472 when Name_PolyORB_DSA =>
11474 PolyORB_Support.Build_Subprogram_Receiving_Stubs
11477 Dynamically_Asynchronous,
11484 GARLIC_Support.Build_Subprogram_Receiving_Stubs
11487 Dynamically_Asynchronous,
11492 end Specific_Build_Subprogram_Receiving_Stubs;
11494 -------------------------------
11495 -- Transmit_As_Unconstrained --
11496 -------------------------------
11498 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
11501 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
11502 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
11503 end Transmit_As_Unconstrained;
11505 --------------------------
11506 -- Underlying_RACW_Type --
11507 --------------------------
11509 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11510 Record_Type : Entity_Id;
11513 if Ekind (RAS_Typ) = E_Record_Type then
11514 Record_Type := RAS_Typ;
11516 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11517 Record_Type := Equivalent_Type (RAS_Typ);
11521 Etype (Subtype_Indication
11522 (Component_Definition
11523 (First (Component_Items
11526 (Declaration_Node (Record_Type))))))));
11527 end Underlying_RACW_Type;