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, for the case of an RACW that
332 -- implements a RAS, no object RPC receiver is generated. Instead,
333 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
334 -- would have been inserted.
336 Body_Decls : List_Id;
337 -- List of subprogram bodies to be included in generated code: bodies
338 -- for the RACW's stream attributes, and for the primitive operations
341 RACW_Type : Entity_Id;
342 -- One of the RACW types designating this distributed object type
343 -- (they are all interchangeable; we use any one of them in order to
344 -- avoid having to create various anonymous access types).
348 Empty_Stub_Structure : constant Stub_Structure :=
349 (Empty, Empty, Empty, No_List, Empty);
351 package Stubs_Table is
352 new Simple_HTable (Header_Num => Hash_Index,
353 Element => Stub_Structure,
354 No_Element => Empty_Stub_Structure,
358 -- Mapping between a RACW designated type and its stub type
360 package Asynchronous_Flags_Table is
361 new Simple_HTable (Header_Num => Hash_Index,
362 Element => Entity_Id,
367 -- Mapping between a RACW type and a constant having the value True
368 -- if the RACW is asynchronous and False otherwise.
370 package RCI_Locator_Table is
371 new Simple_HTable (Header_Num => Hash_Index,
372 Element => Entity_Id,
377 -- Mapping between a RCI package on which All_Calls_Remote applies and
378 -- the generic instantiation of RCI_Locator for this package.
380 package RCI_Calling_Stubs_Table is
381 new Simple_HTable (Header_Num => Hash_Index,
382 Element => Entity_Id,
387 -- Mapping between a RCI subprogram and the corresponding calling stubs
389 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure;
390 -- Return the stub information associated with the given RACW type
392 procedure Add_Stub_Type
393 (Designated_Type : Entity_Id;
394 RACW_Type : Entity_Id;
396 Stub_Type : out Entity_Id;
397 Stub_Type_Access : out Entity_Id;
398 RPC_Receiver_Decl : out Node_Id;
399 Body_Decls : out List_Id;
400 Existing : out Boolean);
401 -- Add the declaration of the stub type, the access to stub type and the
402 -- object RPC receiver at the end of Decls. If these already exist,
403 -- then nothing is added in the tree but the right values are returned
404 -- anyhow and Existing is set to True.
406 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
407 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
408 -- structure table, reset it to No_List, and return the previous value.
410 procedure Add_RACW_Asynchronous_Flag
411 (Declarations : List_Id;
412 RACW_Type : Entity_Id);
413 -- Declare a boolean constant associated with RACW_Type whose value
414 -- indicates at run time whether a pragma Asynchronous applies to it.
416 procedure Assign_Subprogram_Identifier
420 -- Determine the distribution subprogram identifier to
421 -- be used for remote subprogram Def, return it in Id and
422 -- store it in a hash table for later retrieval by
423 -- Get_Subprogram_Id. Spn is the subprogram number.
425 function RCI_Package_Locator
427 Package_Spec : Node_Id) return Node_Id;
428 -- Instantiate the generic package RCI_Locator in order to locate the
429 -- RCI package whose spec is given as argument.
431 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
432 -- Surround a node N by a tag check, as in:
436 -- when E : Ada.Tags.Tag_Error =>
437 -- Raise_Exception (Program_Error'Identity,
438 -- Exception_Message (E));
441 function Input_With_Tag_Check
443 Var_Type : Entity_Id;
444 Stream : Node_Id) return Node_Id;
445 -- Return a function with the following form:
446 -- function R return Var_Type is
448 -- return Var_Type'Input (S);
450 -- when E : Ada.Tags.Tag_Error =>
451 -- Raise_Exception (Program_Error'Identity,
452 -- Exception_Message (E));
455 procedure Build_Actual_Object_Declaration
461 -- Build the declaration of an object with the given defining identifier,
462 -- initialized with Expr if provided, to serve as actual parameter in a
463 -- server stub. If Variable is true, the declared object will be a variable
464 -- (case of an out or in out formal), else it will be a constant. Object's
465 -- Ekind is set accordingly. The declaration, as well as any other
466 -- declarations it requires, are appended to Decls.
468 --------------------------------------------
469 -- Hooks for PCS-specific code generation --
470 --------------------------------------------
472 -- Part of the code generation circuitry for distribution needs to be
473 -- tailored for each implementation of the PCS. For each routine that
474 -- needs to be specialized, a Specific_<routine> wrapper is created,
475 -- which calls the corresponding <routine> in package
476 -- <pcs_implementation>_Support.
478 procedure Specific_Add_RACW_Features
479 (RACW_Type : Entity_Id;
481 Stub_Type : Entity_Id;
482 Stub_Type_Access : Entity_Id;
483 RPC_Receiver_Decl : Node_Id;
484 Body_Decls : List_Id);
485 -- Add declaration for TSSs for a given RACW type. The declarations are
486 -- added just after the declaration of the RACW type itself. If the RACW
487 -- appears in the main unit, Body_Decls is a list of declarations to which
488 -- the bodies are appended. Else Body_Decls is No_List.
489 -- PCS-specific ancillary subprogram for Add_RACW_Features.
491 procedure Specific_Add_RAST_Features
493 RAS_Type : Entity_Id);
494 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
495 -- subprogram for Add_RAST_Features.
497 -- An RPC_Target record is used during construction of calling stubs
498 -- to pass PCS-specific tree fragments corresponding to the information
499 -- necessary to locate the target of a remote subprogram call.
501 type RPC_Target (PCS_Kind : PCS_Names) is record
503 when Name_PolyORB_DSA =>
505 -- An expression whose value is a PolyORB reference to the target
509 Partition : Entity_Id;
510 -- A variable containing the Partition_ID of the target partition
512 RPC_Receiver : Node_Id;
513 -- An expression whose value is the address of the target RPC
518 procedure Specific_Build_General_Calling_Stubs
520 Statements : List_Id;
522 Subprogram_Id : Node_Id;
523 Asynchronous : Node_Id := Empty;
524 Is_Known_Asynchronous : Boolean := False;
525 Is_Known_Non_Asynchronous : Boolean := False;
526 Is_Function : Boolean;
528 Stub_Type : Entity_Id := Empty;
529 RACW_Type : Entity_Id := Empty;
531 -- Build calling stubs for general purpose. The parameters are:
532 -- Decls : a place to put declarations
533 -- Statements : a place to put statements
534 -- Target : PCS-specific target information (see details
535 -- in RPC_Target declaration).
536 -- Subprogram_Id : a node containing the subprogram ID
537 -- Asynchronous : True if an APC must be made instead of an RPC.
538 -- The value needs not be supplied if one of the
539 -- Is_Known_... is True.
540 -- Is_Known_Async... : True if we know that this is asynchronous
541 -- Is_Known_Non_A... : True if we know that this is not asynchronous
542 -- Spec : a node with a Parameter_Specifications and
543 -- a Result_Definition if applicable
544 -- Stub_Type : in case of RACW stubs, parameters of type access
545 -- to Stub_Type will be marshalled using the
546 -- address of the object (the addr field) rather
547 -- than using the 'Write on the stub itself
548 -- Nod : used to provide sloc for generated code
550 function Specific_Build_Stub_Target
553 RCI_Locator : Entity_Id;
554 Controlling_Parameter : Entity_Id) return RPC_Target;
555 -- Build call target information nodes for use within calling stubs. In the
556 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
557 -- for an RACW, Controlling_Parameter is the entity for the controlling
558 -- formal parameter used to determine the location of the target of the
559 -- call. Decls provides a location where variable declarations can be
560 -- appended to construct the necessary values.
562 procedure Specific_Build_Stub_Type
563 (RACW_Type : Entity_Id;
564 Stub_Type_Comps : out List_Id;
565 RPC_Receiver_Decl : out Node_Id);
566 -- Build a components list for the stub type associated with an RACW type,
567 -- and build the necessary RPC receiver, if applicable. PCS-specific
568 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
569 -- is generated, then RPC_Receiver_Decl is set to Empty.
571 procedure Specific_Build_RPC_Receiver_Body
572 (RPC_Receiver : Entity_Id;
573 Request : out Entity_Id;
574 Subp_Id : out Entity_Id;
575 Subp_Index : out Entity_Id;
578 -- Make a subprogram body for an RPC receiver, with the given
579 -- defining unit name. On return:
580 -- - Subp_Id is the subprogram identifier from the PCS.
581 -- - Subp_Index is the index in the list of subprograms
582 -- used for dispatching (a variable of type Subprogram_Id).
583 -- - Stmts is the place where the request dispatching
584 -- statements can occur,
585 -- - Decl is the subprogram body declaration.
587 function Specific_Build_Subprogram_Receiving_Stubs
589 Asynchronous : Boolean;
590 Dynamically_Asynchronous : Boolean := False;
591 Stub_Type : Entity_Id := Empty;
592 RACW_Type : Entity_Id := Empty;
593 Parent_Primitive : Entity_Id := Empty) return Node_Id;
594 -- Build the receiving stub for a given subprogram. The subprogram
595 -- declaration is also built by this procedure, and the value returned
596 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
597 -- found in the specification, then its address is read from the stream
598 -- instead of the object itself and converted into an access to
599 -- class-wide type before doing the real call using any of the RACW type
600 -- pointing on the designated type.
602 procedure Specific_Add_Obj_RPC_Receiver_Completion
605 RPC_Receiver : Entity_Id;
606 Stub_Elements : Stub_Structure);
607 -- Add the necessary code to Decls after the completion of generation
608 -- of the RACW RPC receiver described by Stub_Elements.
610 procedure Specific_Add_Receiving_Stubs_To_Declarations
614 -- Add receiving stubs to the declarative part of an RCI unit
620 package GARLIC_Support is
622 -- Support for generating DSA code that uses the GARLIC PCS
624 -- The subprograms below provide the GARLIC versions of the
625 -- corresponding Specific_<subprogram> routine declared above.
627 procedure Add_RACW_Features
628 (RACW_Type : Entity_Id;
629 Stub_Type : Entity_Id;
630 Stub_Type_Access : Entity_Id;
631 RPC_Receiver_Decl : Node_Id;
632 Body_Decls : List_Id);
634 procedure Add_RAST_Features
636 RAS_Type : Entity_Id);
638 procedure Build_General_Calling_Stubs
640 Statements : List_Id;
641 Target_Partition : Entity_Id; -- From RPC_Target
642 Target_RPC_Receiver : Node_Id; -- From RPC_Target
643 Subprogram_Id : Node_Id;
644 Asynchronous : Node_Id := Empty;
645 Is_Known_Asynchronous : Boolean := False;
646 Is_Known_Non_Asynchronous : Boolean := False;
647 Is_Function : Boolean;
649 Stub_Type : Entity_Id := Empty;
650 RACW_Type : Entity_Id := Empty;
653 function Build_Stub_Target
656 RCI_Locator : Entity_Id;
657 Controlling_Parameter : Entity_Id) return RPC_Target;
659 procedure Build_Stub_Type
660 (RACW_Type : Entity_Id;
661 Stub_Type_Comps : out List_Id;
662 RPC_Receiver_Decl : out Node_Id);
664 function Build_Subprogram_Receiving_Stubs
666 Asynchronous : Boolean;
667 Dynamically_Asynchronous : Boolean := False;
668 Stub_Type : Entity_Id := Empty;
669 RACW_Type : Entity_Id := Empty;
670 Parent_Primitive : Entity_Id := Empty) return Node_Id;
672 procedure Add_Obj_RPC_Receiver_Completion
675 RPC_Receiver : Entity_Id;
676 Stub_Elements : Stub_Structure);
678 procedure Add_Receiving_Stubs_To_Declarations
683 procedure Build_RPC_Receiver_Body
684 (RPC_Receiver : Entity_Id;
685 Request : out Entity_Id;
686 Subp_Id : out Entity_Id;
687 Subp_Index : out Entity_Id;
693 ---------------------
694 -- PolyORB_Support --
695 ---------------------
697 package PolyORB_Support is
699 -- Support for generating DSA code that uses the PolyORB PCS
701 -- The subprograms below provide the PolyORB versions of the
702 -- corresponding Specific_<subprogram> routine declared above.
704 procedure Add_RACW_Features
705 (RACW_Type : Entity_Id;
707 Stub_Type : Entity_Id;
708 Stub_Type_Access : Entity_Id;
709 RPC_Receiver_Decl : Node_Id;
710 Body_Decls : List_Id);
712 procedure Add_RAST_Features
714 RAS_Type : Entity_Id);
716 procedure Build_General_Calling_Stubs
718 Statements : List_Id;
719 Target_Object : Node_Id; -- From RPC_Target
720 Subprogram_Id : Node_Id;
721 Asynchronous : Node_Id := Empty;
722 Is_Known_Asynchronous : Boolean := False;
723 Is_Known_Non_Asynchronous : Boolean := False;
724 Is_Function : Boolean;
726 Stub_Type : Entity_Id := Empty;
727 RACW_Type : Entity_Id := Empty;
730 function Build_Stub_Target
733 RCI_Locator : Entity_Id;
734 Controlling_Parameter : Entity_Id) return RPC_Target;
736 procedure Build_Stub_Type
737 (RACW_Type : Entity_Id;
738 Stub_Type_Comps : out List_Id;
739 RPC_Receiver_Decl : out Node_Id);
741 function Build_Subprogram_Receiving_Stubs
743 Asynchronous : Boolean;
744 Dynamically_Asynchronous : Boolean := False;
745 Stub_Type : Entity_Id := Empty;
746 RACW_Type : Entity_Id := Empty;
747 Parent_Primitive : Entity_Id := Empty) return Node_Id;
749 procedure Add_Obj_RPC_Receiver_Completion
752 RPC_Receiver : Entity_Id;
753 Stub_Elements : Stub_Structure);
755 procedure Add_Receiving_Stubs_To_Declarations
760 procedure Build_RPC_Receiver_Body
761 (RPC_Receiver : Entity_Id;
762 Request : out Entity_Id;
763 Subp_Id : out Entity_Id;
764 Subp_Index : out Entity_Id;
768 procedure Reserve_NamingContext_Methods;
769 -- Mark the method names for interface NamingContext as already used in
770 -- the overload table, so no clashes occur with user code (with the
771 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
772 -- their methods to be accessed as objects, for the implementation of
773 -- remote access-to-subprogram types).
781 -- Routines to build distribution helper subprograms for user-defined
782 -- types. For implementation of the Distributed systems annex (DSA)
783 -- over the PolyORB generic middleware components, it is necessary to
784 -- generate several supporting subprograms for each application data
785 -- type used in inter-partition communication. These subprograms are:
787 -- A Typecode function returning a high-level description of the
790 -- Two conversion functions allowing conversion of values of the
791 -- type from and to the generic data containers used by PolyORB.
792 -- These generic containers are called 'Any' type values after the
793 -- CORBA terminology, and hence the conversion subprograms are
794 -- named To_Any and From_Any.
796 function Build_From_Any_Call
799 Decls : List_Id) return Node_Id;
800 -- Build call to From_Any attribute function of type Typ with
801 -- expression N as actual parameter. Decls is the declarations list
802 -- for an appropriate enclosing scope of the point where the call
803 -- will be inserted; if the From_Any attribute for Typ needs to be
804 -- generated at this point, its declaration is appended to Decls.
806 procedure Build_From_Any_Function
810 Fnam : out Entity_Id);
811 -- Build From_Any attribute function for Typ. Loc is the reference
812 -- location for generated nodes, Typ is the type for which the
813 -- conversion function is generated. On return, Decl and Fnam contain
814 -- the declaration and entity for the newly-created function.
816 function Build_To_Any_Call
818 Decls : List_Id) return Node_Id;
819 -- Build call to To_Any attribute function with expression as actual
820 -- parameter. Decls is the declarations list for an appropriate
821 -- enclosing scope of the point where the call will be inserted; if
822 -- the To_Any attribute for Typ needs to be generated at this point,
823 -- its declaration is appended to Decls.
825 procedure Build_To_Any_Function
829 Fnam : out Entity_Id);
830 -- Build To_Any attribute function for Typ. Loc is the reference
831 -- location for generated nodes, Typ is the type for which the
832 -- conversion function is generated. On return, Decl and Fnam contain
833 -- the declaration and entity for the newly-created function.
835 function Build_TypeCode_Call
838 Decls : List_Id) return Node_Id;
839 -- Build call to TypeCode attribute function for Typ. Decls is the
840 -- declarations list for an appropriate enclosing scope of the point
841 -- where the call will be inserted; if the To_Any attribute for Typ
842 -- needs to be generated at this point, its declaration is appended
845 procedure Build_TypeCode_Function
849 Fnam : out Entity_Id);
850 -- Build TypeCode attribute function for Typ. Loc is the reference
851 -- location for generated nodes, Typ is the type for which the
852 -- conversion function is generated. On return, Decl and Fnam contain
853 -- the declaration and entity for the newly-created function.
855 procedure Build_Name_And_Repository_Id
857 Name_Str : out String_Id;
858 Repo_Id_Str : out String_Id);
859 -- In the PolyORB distribution model, each distributed object type
860 -- and each distributed operation has a globally unique identifier,
861 -- its Repository Id. This subprogram builds and returns two strings
862 -- for entity E (a distributed object type or operation): one
863 -- containing the name of E, the second containing its repository id.
865 procedure Assign_Opaque_From_Any
871 -- For a Target object of type Typ, which has opaque representation
872 -- as a sequence of octets determined by stream attributes (which
873 -- includes all limited types), append code to Stmts performing the
875 -- Target := Typ'From_Any (N)
877 -- or, if Target is Empty:
878 -- return Typ'From_Any (N)
884 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
886 function Build_From_Any_Call
889 Decls : List_Id) return Node_Id
890 renames PolyORB_Support.Helpers.Build_From_Any_Call;
892 function Build_To_Any_Call
894 Decls : List_Id) return Node_Id
895 renames PolyORB_Support.Helpers.Build_To_Any_Call;
897 function Build_TypeCode_Call
900 Decls : List_Id) return Node_Id
901 renames PolyORB_Support.Helpers.Build_TypeCode_Call;
903 ------------------------------------
904 -- Local variables and structures --
905 ------------------------------------
908 -- Needs comments ???
910 Output_From_Constrained : constant array (Boolean) of Name_Id :=
911 (False => Name_Output,
913 -- The attribute to choose depending on the fact that the parameter
914 -- is constrained or not. There is no such thing as Input_From_Constrained
915 -- since this require separate mechanisms ('Input is a function while
916 -- 'Read is a procedure).
919 with procedure Process_Subprogram_Declaration (Decl : Node_Id);
920 -- Generate calling or receiving stub for this subprogram declaration
922 procedure Build_Package_Stubs (Pkg_Spec : Node_Id);
923 -- Recursively visit the given RCI Package_Specification, calling
924 -- Process_Subprogram_Declaration for each remote subprogram.
926 -------------------------
927 -- Build_Package_Stubs --
928 -------------------------
930 procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is
931 Decls : constant List_Id := Visible_Declarations (Pkg_Spec);
934 procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id);
935 -- Recurse for the given nested package declaration
937 -----------------------
938 -- Visit_Nested_Spec --
939 -----------------------
941 procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is
942 Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl);
944 Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec));
945 Build_Package_Stubs (Nested_Pkg_Spec);
947 end Visit_Nested_Pkg;
949 -- Start of processing for Build_Package_Stubs
952 Decl := First (Decls);
953 while Present (Decl) loop
955 when N_Subprogram_Declaration =>
957 -- Note: we test Comes_From_Source on Spec, not Decl, because
958 -- in the case of a subprogram instance, only the specification
959 -- (not the declaration) is marked as coming from source.
961 if Comes_From_Source (Specification (Decl)) then
962 Process_Subprogram_Declaration (Decl);
965 when N_Package_Declaration =>
967 -- Case of a nested package or package instantiation coming
968 -- from source. Note that the anonymous wrapper package for
969 -- subprogram instances is not flagged Is_Generic_Instance at
970 -- this point, so there is a distinct circuit to handle them
971 -- (see case N_Subprogram_Instantiation below).
974 Pkg_Ent : constant Entity_Id :=
975 Defining_Unit_Name (Specification (Decl));
977 if Comes_From_Source (Decl)
979 (Is_Generic_Instance (Pkg_Ent)
980 and then Comes_From_Source
981 (Get_Package_Instantiation_Node (Pkg_Ent)))
983 Visit_Nested_Pkg (Decl);
987 when N_Subprogram_Instantiation =>
989 -- The subprogram declaration for an instance of a generic
990 -- subprogram is wrapped in a package that does not come from
991 -- source, so we need to explicitly traverse it here.
993 if Comes_From_Source (Decl) then
994 Visit_Nested_Pkg (Instance_Spec (Decl));
1002 end Build_Package_Stubs;
1004 ---------------------------------------
1005 -- Add_Calling_Stubs_To_Declarations --
1006 ---------------------------------------
1008 procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is
1009 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
1011 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
1012 -- Subprogram id 0 is reserved for calls received from
1013 -- remote access-to-subprogram dereferences.
1015 RCI_Instantiation : Node_Id;
1017 procedure Visit_Subprogram (Decl : Node_Id);
1018 -- Generate calling stub for one remote subprogram
1020 ----------------------
1021 -- Visit_Subprogram --
1022 ----------------------
1024 procedure Visit_Subprogram (Decl : Node_Id) is
1025 Loc : constant Source_Ptr := Sloc (Decl);
1026 Spec : constant Node_Id := Specification (Decl);
1027 Subp_Stubs : Node_Id;
1029 Subp_Str : String_Id;
1030 pragma Warnings (Off, Subp_Str);
1033 -- Disable expansion of stubs if serious errors have been diagnosed,
1034 -- because otherwise some illegal remote subprogram declarations
1035 -- could cause cascaded errors in stubs.
1037 if Serious_Errors_Detected /= 0 then
1041 Assign_Subprogram_Identifier
1042 (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str);
1045 Build_Subprogram_Calling_Stubs
1048 Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)),
1050 Nkind (Spec) = N_Procedure_Specification
1051 and then Is_Asynchronous (Defining_Unit_Name (Spec)));
1053 Append_To (List_Containing (Decl), Subp_Stubs);
1054 Analyze (Subp_Stubs);
1056 Current_Subprogram_Number := Current_Subprogram_Number + 1;
1057 end Visit_Subprogram;
1059 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
1061 -- Start of processing for Add_Calling_Stubs_To_Declarations
1064 Push_Scope (Scope_Of_Spec (Pkg_Spec));
1066 -- The first thing added is an instantiation of the generic package
1067 -- System.Partition_Interface.RCI_Locator with the name of this remote
1068 -- package. This will act as an interface with the name server to
1069 -- determine the Partition_ID and the RPC_Receiver for the receiver
1072 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
1073 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
1075 Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation);
1076 Analyze (RCI_Instantiation);
1078 -- For each subprogram declaration visible in the spec, we do build a
1079 -- body. We also increment a counter to assign a different Subprogram_Id
1080 -- to each subprogram. The receiving stubs processing uses the same
1081 -- mechanism and will thus assign the same Id and do the correct
1084 Overload_Counter_Table.Reset;
1085 PolyORB_Support.Reserve_NamingContext_Methods;
1087 Visit_Spec (Pkg_Spec);
1090 end Add_Calling_Stubs_To_Declarations;
1092 -----------------------------
1093 -- Add_Parameter_To_NVList --
1094 -----------------------------
1096 function Add_Parameter_To_NVList
1099 Parameter : Entity_Id;
1100 Constrained : Boolean;
1101 RACW_Ctrl : Boolean := False;
1102 Any : Entity_Id) return Node_Id
1104 Parameter_Name_String : String_Id;
1105 Parameter_Mode : Node_Id;
1107 function Parameter_Passing_Mode
1109 Parameter : Entity_Id;
1110 Constrained : Boolean) return Node_Id;
1111 -- Return an expression that denotes the parameter passing mode to be
1112 -- used for Parameter in distribution stubs, where Constrained is
1113 -- Parameter's constrained status.
1115 ----------------------------
1116 -- Parameter_Passing_Mode --
1117 ----------------------------
1119 function Parameter_Passing_Mode
1121 Parameter : Entity_Id;
1122 Constrained : Boolean) return Node_Id
1127 if Out_Present (Parameter) then
1128 if In_Present (Parameter)
1129 or else not Constrained
1131 -- Unconstrained formals must be translated
1132 -- to 'in' or 'inout', not 'out', because
1133 -- they need to be constrained by the actual.
1135 Lib_RE := RE_Mode_Inout;
1137 Lib_RE := RE_Mode_Out;
1141 Lib_RE := RE_Mode_In;
1144 return New_Occurrence_Of (RTE (Lib_RE), Loc);
1145 end Parameter_Passing_Mode;
1147 -- Start of processing for Add_Parameter_To_NVList
1150 if Nkind (Parameter) = N_Defining_Identifier then
1151 Get_Name_String (Chars (Parameter));
1153 Get_Name_String (Chars (Defining_Identifier (Parameter)));
1156 Parameter_Name_String := String_From_Name_Buffer;
1158 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1160 -- When the parameter passed to Add_Parameter_To_NVList is an
1161 -- Extra_Constrained parameter, Parameter is an N_Defining_
1162 -- Identifier, instead of a complete N_Parameter_Specification.
1163 -- Thus, we explicitly set 'in' mode in this case.
1165 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1169 Parameter_Passing_Mode (Loc, Parameter, Constrained);
1173 Make_Procedure_Call_Statement (Loc,
1176 (RTE (RE_NVList_Add_Item), Loc),
1177 Parameter_Associations => New_List (
1178 New_Occurrence_Of (NVList, Loc),
1179 Make_Function_Call (Loc,
1182 (RTE (RE_To_PolyORB_String), Loc),
1183 Parameter_Associations => New_List (
1184 Make_String_Literal (Loc,
1185 Strval => Parameter_Name_String))),
1186 New_Occurrence_Of (Any, Loc),
1188 end Add_Parameter_To_NVList;
1190 --------------------------------
1191 -- Add_RACW_Asynchronous_Flag --
1192 --------------------------------
1194 procedure Add_RACW_Asynchronous_Flag
1195 (Declarations : List_Id;
1196 RACW_Type : Entity_Id)
1198 Loc : constant Source_Ptr := Sloc (RACW_Type);
1200 Asynchronous_Flag : constant Entity_Id :=
1201 Make_Defining_Identifier (Loc,
1202 New_External_Name (Chars (RACW_Type), 'A'));
1205 -- Declare the asynchronous flag. This flag will be changed to True
1206 -- whenever it is known that the RACW type is asynchronous.
1208 Append_To (Declarations,
1209 Make_Object_Declaration (Loc,
1210 Defining_Identifier => Asynchronous_Flag,
1211 Constant_Present => True,
1212 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1213 Expression => New_Occurrence_Of (Standard_False, Loc)));
1215 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1216 end Add_RACW_Asynchronous_Flag;
1218 -----------------------
1219 -- Add_RACW_Features --
1220 -----------------------
1222 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1223 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1224 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1228 Body_Decls : List_Id;
1230 Stub_Type : Entity_Id;
1231 Stub_Type_Access : Entity_Id;
1232 RPC_Receiver_Decl : Node_Id;
1235 -- True when appropriate stubs have already been generated (this is the
1236 -- case when another RACW with the same designated type has already been
1237 -- encountered), in which case we reuse the previous stubs rather than
1238 -- generating new ones.
1241 if not Expander_Active then
1245 -- Mark the current package declaration as containing an RACW, so that
1246 -- the bodies for the calling stubs and the RACW stream subprograms
1247 -- are attached to the tree when the corresponding body is encountered.
1249 Set_Has_RACW (Current_Scope);
1251 -- Look for place to declare the RACW stub type and RACW operations
1257 -- Case of declaring the RACW in the same package as its designated
1258 -- type: we know that the designated type is a private type, so we
1259 -- use the private declarations list.
1261 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1263 if Present (Private_Declarations (Pkg_Spec)) then
1264 Decls := Private_Declarations (Pkg_Spec);
1266 Decls := Visible_Declarations (Pkg_Spec);
1270 -- Case of declaring the RACW in another package than its designated
1271 -- type: use the private declarations list if present; otherwise
1272 -- use the visible declarations.
1274 Decls := List_Containing (Declaration_Node (RACW_Type));
1278 -- If we were unable to find the declarations, that means that the
1279 -- completion of the type was missing. We can safely return and let the
1280 -- error be caught by the semantic analysis.
1287 (Designated_Type => Desig,
1288 RACW_Type => RACW_Type,
1290 Stub_Type => Stub_Type,
1291 Stub_Type_Access => Stub_Type_Access,
1292 RPC_Receiver_Decl => RPC_Receiver_Decl,
1293 Body_Decls => Body_Decls,
1294 Existing => Existing);
1296 -- If this RACW is not in the main unit, do not generate primitive or
1299 if not Entity_Is_In_Main_Unit (RACW_Type) then
1300 Body_Decls := No_List;
1303 Add_RACW_Asynchronous_Flag
1304 (Declarations => Decls,
1305 RACW_Type => RACW_Type);
1307 Specific_Add_RACW_Features
1308 (RACW_Type => RACW_Type,
1310 Stub_Type => Stub_Type,
1311 Stub_Type_Access => Stub_Type_Access,
1312 RPC_Receiver_Decl => RPC_Receiver_Decl,
1313 Body_Decls => Body_Decls);
1315 -- If we already have stubs for this designated type, nothing to do
1321 if Is_Frozen (Desig) then
1322 Validate_RACW_Primitives (RACW_Type);
1323 Add_RACW_Primitive_Declarations_And_Bodies
1324 (Designated_Type => Desig,
1325 Insertion_Node => RPC_Receiver_Decl,
1326 Body_Decls => Body_Decls);
1329 -- Validate_RACW_Primitives requires the list of all primitives of
1330 -- the designated type, so defer processing until Desig is frozen.
1331 -- See Exp_Ch3.Freeze_Type.
1333 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1335 end Add_RACW_Features;
1337 ------------------------------------------------
1338 -- Add_RACW_Primitive_Declarations_And_Bodies --
1339 ------------------------------------------------
1341 procedure Add_RACW_Primitive_Declarations_And_Bodies
1342 (Designated_Type : Entity_Id;
1343 Insertion_Node : Node_Id;
1344 Body_Decls : List_Id)
1346 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1347 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1348 -- the declarations are recognized as belonging to the current package.
1350 Stub_Elements : constant Stub_Structure :=
1351 Stubs_Table.Get (Designated_Type);
1353 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1355 Is_RAS : constant Boolean :=
1356 not Comes_From_Source (Stub_Elements.RACW_Type);
1357 -- Case of the RACW generated to implement a remote access-to-
1360 Build_Bodies : constant Boolean :=
1361 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1362 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1363 -- only when the main unit is the unit that contains the stub type.
1365 Current_Insertion_Node : Node_Id := Insertion_Node;
1367 RPC_Receiver : Entity_Id;
1368 RPC_Receiver_Statements : List_Id;
1369 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1370 RPC_Receiver_Elsif_Parts : List_Id;
1371 RPC_Receiver_Request : Entity_Id;
1372 RPC_Receiver_Subp_Id : Entity_Id;
1373 RPC_Receiver_Subp_Index : Entity_Id;
1375 Subp_Str : String_Id;
1377 Current_Primitive_Elmt : Elmt_Id;
1378 Current_Primitive : Entity_Id;
1379 Current_Primitive_Body : Node_Id;
1380 Current_Primitive_Spec : Node_Id;
1381 Current_Primitive_Decl : Node_Id;
1382 Current_Primitive_Number : Int := 0;
1383 Current_Primitive_Alias : Node_Id;
1384 Current_Receiver : Entity_Id;
1385 Current_Receiver_Body : Node_Id;
1386 RPC_Receiver_Decl : Node_Id;
1387 Possibly_Asynchronous : Boolean;
1390 if not Expander_Active then
1395 RPC_Receiver := Make_Temporary (Loc, 'P');
1397 Specific_Build_RPC_Receiver_Body
1398 (RPC_Receiver => RPC_Receiver,
1399 Request => RPC_Receiver_Request,
1400 Subp_Id => RPC_Receiver_Subp_Id,
1401 Subp_Index => RPC_Receiver_Subp_Index,
1402 Stmts => RPC_Receiver_Statements,
1403 Decl => RPC_Receiver_Decl);
1405 if Get_PCS_Name = Name_PolyORB_DSA then
1407 -- For the case of PolyORB, we need to map a textual operation
1408 -- name into a primitive index. Currently we do so using a simple
1409 -- sequence of string comparisons.
1411 RPC_Receiver_Elsif_Parts := New_List;
1415 -- Build callers, receivers for every primitive operations and a RPC
1416 -- receiver for this type. Note that we use Direct_Primitive_Operations,
1417 -- not Primitive_Operations, because we really want just the primitives
1418 -- of the tagged type itself, and in the case of a tagged synchronized
1419 -- type we do not want to get the primitives of the corresponding
1422 if Present (Direct_Primitive_Operations (Designated_Type)) then
1423 Overload_Counter_Table.Reset;
1425 Current_Primitive_Elmt :=
1426 First_Elmt (Direct_Primitive_Operations (Designated_Type));
1427 while Current_Primitive_Elmt /= No_Elmt loop
1428 Current_Primitive := Node (Current_Primitive_Elmt);
1430 -- Copy the primitive of all the parents, except predefined ones
1431 -- that are not remotely dispatching. Also omit hidden primitives
1432 -- (occurs in the case of primitives of interface progenitors
1433 -- other than immediate ancestors of the Designated_Type).
1435 if Chars (Current_Primitive) /= Name_uSize
1436 and then Chars (Current_Primitive) /= Name_uAlignment
1438 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1439 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1440 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1441 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1442 Is_TSS (Current_Primitive, TSS_Stream_Write)
1444 Is_Predefined_Interface_Primitive (Current_Primitive))
1445 and then not Is_Hidden (Current_Primitive)
1447 -- The first thing to do is build an up-to-date copy of the
1448 -- spec with all the formals referencing Controlling_Type
1449 -- transformed into formals referencing Stub_Type. Since this
1450 -- primitive may have been inherited, go back the alias chain
1451 -- until the real primitive has been found.
1453 Current_Primitive_Alias := Ultimate_Alias (Current_Primitive);
1455 -- Copy the spec from the original declaration for the purpose
1456 -- of declaring an overriding subprogram: we need to replace
1457 -- the type of each controlling formal with Stub_Type. The
1458 -- primitive may have been declared for Controlling_Type or
1459 -- inherited from some ancestor type for which we do not have
1460 -- an easily determined Entity_Id. We have no systematic way
1461 -- of knowing which type to substitute Stub_Type for. Instead,
1462 -- Copy_Specification relies on the flag Is_Controlling_Formal
1463 -- to determine which formals to change.
1465 Current_Primitive_Spec :=
1466 Copy_Specification (Loc,
1467 Spec => Parent (Current_Primitive_Alias),
1468 Ctrl_Type => Stub_Elements.Stub_Type);
1470 Current_Primitive_Decl :=
1471 Make_Subprogram_Declaration (Loc,
1472 Specification => Current_Primitive_Spec);
1474 Insert_After_And_Analyze (Current_Insertion_Node,
1475 Current_Primitive_Decl);
1476 Current_Insertion_Node := Current_Primitive_Decl;
1478 Possibly_Asynchronous :=
1479 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1480 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1482 Assign_Subprogram_Identifier (
1483 Defining_Unit_Name (Current_Primitive_Spec),
1484 Current_Primitive_Number,
1487 if Build_Bodies then
1488 Current_Primitive_Body :=
1489 Build_Subprogram_Calling_Stubs
1490 (Vis_Decl => Current_Primitive_Decl,
1492 Build_Subprogram_Id (Loc,
1493 Defining_Unit_Name (Current_Primitive_Spec)),
1494 Asynchronous => Possibly_Asynchronous,
1495 Dynamically_Asynchronous => Possibly_Asynchronous,
1496 Stub_Type => Stub_Elements.Stub_Type,
1497 RACW_Type => Stub_Elements.RACW_Type);
1498 Append_To (Body_Decls, Current_Primitive_Body);
1500 -- Analyzing the body here would cause the Stub type to
1501 -- be frozen, thus preventing subsequent primitive
1502 -- declarations. For this reason, it will be analyzed
1503 -- later in the regular flow (and in the context of the
1504 -- appropriate unit body, see Append_RACW_Bodies).
1508 -- Build the receiver stubs
1510 if Build_Bodies and then not Is_RAS then
1511 Current_Receiver_Body :=
1512 Specific_Build_Subprogram_Receiving_Stubs
1513 (Vis_Decl => Current_Primitive_Decl,
1514 Asynchronous => Possibly_Asynchronous,
1515 Dynamically_Asynchronous => Possibly_Asynchronous,
1516 Stub_Type => Stub_Elements.Stub_Type,
1517 RACW_Type => Stub_Elements.RACW_Type,
1518 Parent_Primitive => Current_Primitive);
1521 Defining_Unit_Name (Specification (Current_Receiver_Body));
1523 Append_To (Body_Decls, Current_Receiver_Body);
1525 -- Add a case alternative to the receiver
1527 if Get_PCS_Name = Name_PolyORB_DSA then
1528 Append_To (RPC_Receiver_Elsif_Parts,
1529 Make_Elsif_Part (Loc,
1531 Make_Function_Call (Loc,
1534 RTE (RE_Caseless_String_Eq), Loc),
1535 Parameter_Associations => New_List (
1536 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1537 Make_String_Literal (Loc, Subp_Str))),
1539 Then_Statements => New_List (
1540 Make_Assignment_Statement (Loc,
1541 Name => New_Occurrence_Of (
1542 RPC_Receiver_Subp_Index, Loc),
1544 Make_Integer_Literal (Loc,
1545 Intval => Current_Primitive_Number)))));
1548 Append_To (RPC_Receiver_Case_Alternatives,
1549 Make_Case_Statement_Alternative (Loc,
1550 Discrete_Choices => New_List (
1551 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1553 Statements => New_List (
1554 Make_Procedure_Call_Statement (Loc,
1556 New_Occurrence_Of (Current_Receiver, Loc),
1557 Parameter_Associations => New_List (
1558 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1561 -- Increment the index of current primitive
1563 Current_Primitive_Number := Current_Primitive_Number + 1;
1566 Next_Elmt (Current_Primitive_Elmt);
1570 -- Build the case statement and the heart of the subprogram
1572 if Build_Bodies and then not Is_RAS then
1573 if Get_PCS_Name = Name_PolyORB_DSA
1574 and then Present (First (RPC_Receiver_Elsif_Parts))
1576 Append_To (RPC_Receiver_Statements,
1577 Make_Implicit_If_Statement (Designated_Type,
1578 Condition => New_Occurrence_Of (Standard_False, Loc),
1579 Then_Statements => New_List,
1580 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1583 Append_To (RPC_Receiver_Case_Alternatives,
1584 Make_Case_Statement_Alternative (Loc,
1585 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1586 Statements => New_List (Make_Null_Statement (Loc))));
1588 Append_To (RPC_Receiver_Statements,
1589 Make_Case_Statement (Loc,
1591 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1592 Alternatives => RPC_Receiver_Case_Alternatives));
1594 Append_To (Body_Decls, RPC_Receiver_Decl);
1595 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1596 Body_Decls, RPC_Receiver, Stub_Elements);
1598 -- Do not analyze RPC receiver body at this stage since it references
1599 -- subprograms that have not been analyzed yet. It will be analyzed in
1600 -- the regular flow (see Append_RACW_Bodies).
1603 end Add_RACW_Primitive_Declarations_And_Bodies;
1605 -----------------------------
1606 -- Add_RAS_Dereference_TSS --
1607 -----------------------------
1609 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1610 Loc : constant Source_Ptr := Sloc (N);
1612 Type_Def : constant Node_Id := Type_Definition (N);
1613 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1614 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1615 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1617 RACW_Primitive_Name : Node_Id;
1619 Proc : constant Entity_Id :=
1620 Make_Defining_Identifier (Loc,
1621 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1623 Proc_Spec : Node_Id;
1624 Param_Specs : List_Id;
1625 Param_Assoc : constant List_Id := New_List;
1626 Stmts : constant List_Id := New_List;
1628 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P');
1630 Is_Function : constant Boolean :=
1631 Nkind (Type_Def) = N_Access_Function_Definition;
1633 Is_Degenerate : Boolean;
1634 -- Set to True if the subprogram_specification for this RAS has an
1635 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1637 Spec : constant Node_Id := Type_Def;
1639 Current_Parameter : Node_Id;
1641 -- Start of processing for Add_RAS_Dereference_TSS
1644 -- The Dereference TSS for a remote access-to-subprogram type has the
1647 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1650 -- This is called whenever a value of a RAS type is dereferenced
1652 -- First construct a list of parameter specifications:
1654 -- The first formal is the RAS values
1656 Param_Specs := New_List (
1657 Make_Parameter_Specification (Loc,
1658 Defining_Identifier => RAS_Parameter,
1661 New_Occurrence_Of (Fat_Type, Loc)));
1663 -- The following formals are copied from the type declaration
1665 Is_Degenerate := False;
1666 Current_Parameter := First (Parameter_Specifications (Type_Def));
1667 Parameters : while Present (Current_Parameter) loop
1668 if Nkind (Parameter_Type (Current_Parameter)) =
1671 Is_Degenerate := True;
1674 Append_To (Param_Specs,
1675 Make_Parameter_Specification (Loc,
1676 Defining_Identifier =>
1677 Make_Defining_Identifier (Loc,
1678 Chars => Chars (Defining_Identifier (Current_Parameter))),
1679 In_Present => In_Present (Current_Parameter),
1680 Out_Present => Out_Present (Current_Parameter),
1682 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1684 New_Copy_Tree (Expression (Current_Parameter))));
1686 Append_To (Param_Assoc,
1687 Make_Identifier (Loc,
1688 Chars => Chars (Defining_Identifier (Current_Parameter))));
1690 Next (Current_Parameter);
1691 end loop Parameters;
1693 if Is_Degenerate then
1694 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1696 -- Generate a dummy body. This code will never actually be executed,
1697 -- because null is the only legal value for a degenerate RAS type.
1698 -- For legality's sake (in order to avoid generating a function that
1699 -- does not contain a return statement), we include a dummy recursive
1700 -- call on the TSS itself.
1703 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1704 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1707 -- For a normal RAS type, we cast the RAS formal to the corresponding
1708 -- tagged type, and perform a dispatching call to its Call primitive
1711 Prepend_To (Param_Assoc,
1712 Unchecked_Convert_To (RACW_Type,
1713 New_Occurrence_Of (RAS_Parameter, Loc)));
1715 RACW_Primitive_Name :=
1716 Make_Selected_Component (Loc,
1717 Prefix => Scope (RACW_Type),
1718 Selector_Name => Name_uCall);
1723 Make_Simple_Return_Statement (Loc,
1725 Make_Function_Call (Loc,
1726 Name => RACW_Primitive_Name,
1727 Parameter_Associations => Param_Assoc)));
1731 Make_Procedure_Call_Statement (Loc,
1732 Name => RACW_Primitive_Name,
1733 Parameter_Associations => Param_Assoc));
1736 -- Build the complete subprogram
1740 Make_Function_Specification (Loc,
1741 Defining_Unit_Name => Proc,
1742 Parameter_Specifications => Param_Specs,
1743 Result_Definition =>
1745 Entity (Result_Definition (Spec)), Loc));
1747 Set_Ekind (Proc, E_Function);
1749 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1753 Make_Procedure_Specification (Loc,
1754 Defining_Unit_Name => Proc,
1755 Parameter_Specifications => Param_Specs);
1757 Set_Ekind (Proc, E_Procedure);
1758 Set_Etype (Proc, Standard_Void_Type);
1762 Make_Subprogram_Body (Loc,
1763 Specification => Proc_Spec,
1764 Declarations => New_List,
1765 Handled_Statement_Sequence =>
1766 Make_Handled_Sequence_Of_Statements (Loc,
1767 Statements => Stmts)));
1769 Set_TSS (Fat_Type, Proc);
1770 end Add_RAS_Dereference_TSS;
1772 -------------------------------
1773 -- Add_RAS_Proxy_And_Analyze --
1774 -------------------------------
1776 procedure Add_RAS_Proxy_And_Analyze
1779 All_Calls_Remote_E : Entity_Id;
1780 Proxy_Object_Addr : out Entity_Id)
1782 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1784 Subp_Name : constant Entity_Id :=
1785 Defining_Unit_Name (Specification (Vis_Decl));
1787 Pkg_Name : constant Entity_Id :=
1788 Make_Defining_Identifier (Loc,
1789 Chars => New_External_Name (Chars (Subp_Name), 'P', -1));
1791 Proxy_Type : constant Entity_Id :=
1792 Make_Defining_Identifier (Loc,
1795 (Related_Id => Chars (Subp_Name),
1798 Proxy_Type_Full_View : constant Entity_Id :=
1799 Make_Defining_Identifier (Loc,
1800 Chars (Proxy_Type));
1802 Subp_Decl_Spec : constant Node_Id :=
1803 Build_RAS_Primitive_Specification
1804 (Subp_Spec => Specification (Vis_Decl),
1805 Remote_Object_Type => Proxy_Type);
1807 Subp_Body_Spec : constant Node_Id :=
1808 Build_RAS_Primitive_Specification
1809 (Subp_Spec => Specification (Vis_Decl),
1810 Remote_Object_Type => Proxy_Type);
1812 Vis_Decls : constant List_Id := New_List;
1813 Pvt_Decls : constant List_Id := New_List;
1814 Actuals : constant List_Id := New_List;
1816 Perform_Call : Node_Id;
1819 -- type subpP is tagged limited private;
1821 Append_To (Vis_Decls,
1822 Make_Private_Type_Declaration (Loc,
1823 Defining_Identifier => Proxy_Type,
1824 Tagged_Present => True,
1825 Limited_Present => True));
1827 -- [subprogram] Call
1828 -- (Self : access subpP;
1829 -- ...other-formals...)
1832 Append_To (Vis_Decls,
1833 Make_Subprogram_Declaration (Loc,
1834 Specification => Subp_Decl_Spec));
1836 -- A : constant System.Address;
1838 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1840 Append_To (Vis_Decls,
1841 Make_Object_Declaration (Loc,
1842 Defining_Identifier => Proxy_Object_Addr,
1843 Constant_Present => True,
1844 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)));
1848 -- type subpP is tagged limited record
1849 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1853 Append_To (Pvt_Decls,
1854 Make_Full_Type_Declaration (Loc,
1855 Defining_Identifier => Proxy_Type_Full_View,
1857 Build_Remote_Subprogram_Proxy_Type (Loc,
1858 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1860 -- Trick semantic analysis into swapping the public and full view when
1861 -- freezing the public view.
1863 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1866 -- (Self : access O;
1867 -- ...other-formals...) is
1869 -- P (...other-formals...);
1873 -- (Self : access O;
1874 -- ...other-formals...)
1877 -- return F (...other-formals...);
1880 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1882 Make_Procedure_Call_Statement (Loc,
1883 Name => New_Occurrence_Of (Subp_Name, Loc),
1884 Parameter_Associations => Actuals);
1887 Make_Simple_Return_Statement (Loc,
1889 Make_Function_Call (Loc,
1890 Name => New_Occurrence_Of (Subp_Name, Loc),
1891 Parameter_Associations => Actuals));
1894 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1895 pragma Assert (Present (Formal));
1898 exit when No (Formal);
1900 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1903 -- O : aliased subpP;
1905 Append_To (Pvt_Decls,
1906 Make_Object_Declaration (Loc,
1907 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
1908 Aliased_Present => True,
1909 Object_Definition => New_Occurrence_Of (Proxy_Type, Loc)));
1911 -- A : constant System.Address := O'Address;
1913 Append_To (Pvt_Decls,
1914 Make_Object_Declaration (Loc,
1915 Defining_Identifier =>
1916 Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)),
1917 Constant_Present => True,
1918 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc),
1920 Make_Attribute_Reference (Loc,
1921 Prefix => New_Occurrence_Of (
1922 Defining_Identifier (Last (Pvt_Decls)), Loc),
1923 Attribute_Name => Name_Address)));
1926 Make_Package_Declaration (Loc,
1927 Specification => Make_Package_Specification (Loc,
1928 Defining_Unit_Name => Pkg_Name,
1929 Visible_Declarations => Vis_Decls,
1930 Private_Declarations => Pvt_Decls,
1931 End_Label => Empty)));
1932 Analyze (Last (Decls));
1935 Make_Package_Body (Loc,
1936 Defining_Unit_Name =>
1937 Make_Defining_Identifier (Loc, Chars (Pkg_Name)),
1938 Declarations => New_List (
1939 Make_Subprogram_Body (Loc,
1940 Specification => Subp_Body_Spec,
1941 Declarations => New_List,
1942 Handled_Statement_Sequence =>
1943 Make_Handled_Sequence_Of_Statements (Loc,
1944 Statements => New_List (Perform_Call))))));
1945 Analyze (Last (Decls));
1946 end Add_RAS_Proxy_And_Analyze;
1948 -----------------------
1949 -- Add_RAST_Features --
1950 -----------------------
1952 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1953 RAS_Type : constant Entity_Id :=
1954 Equivalent_Type (Defining_Identifier (Vis_Decl));
1956 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1957 Add_RAS_Dereference_TSS (Vis_Decl);
1958 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1959 end Add_RAST_Features;
1965 procedure Add_Stub_Type
1966 (Designated_Type : Entity_Id;
1967 RACW_Type : Entity_Id;
1969 Stub_Type : out Entity_Id;
1970 Stub_Type_Access : out Entity_Id;
1971 RPC_Receiver_Decl : out Node_Id;
1972 Body_Decls : out List_Id;
1973 Existing : out Boolean)
1975 Loc : constant Source_Ptr := Sloc (RACW_Type);
1977 Stub_Elements : constant Stub_Structure :=
1978 Stubs_Table.Get (Designated_Type);
1979 Stub_Type_Comps : List_Id;
1980 Stub_Type_Decl : Node_Id;
1981 Stub_Type_Access_Decl : Node_Id;
1984 if Stub_Elements /= Empty_Stub_Structure then
1985 Stub_Type := Stub_Elements.Stub_Type;
1986 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1987 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1988 Body_Decls := Stub_Elements.Body_Decls;
1994 Stub_Type := Make_Temporary (Loc, 'S');
1995 Set_Ekind (Stub_Type, E_Record_Type);
1996 Set_Is_RACW_Stub_Type (Stub_Type);
1998 Make_Defining_Identifier (Loc,
1999 Chars => New_External_Name
2000 (Related_Id => Chars (Stub_Type), Suffix => 'A'));
2002 Specific_Build_Stub_Type (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
2005 Make_Full_Type_Declaration (Loc,
2006 Defining_Identifier => Stub_Type,
2008 Make_Record_Definition (Loc,
2009 Tagged_Present => True,
2010 Limited_Present => True,
2012 Make_Component_List (Loc,
2013 Component_Items => Stub_Type_Comps)));
2015 -- Does the stub type need to explicitly implement interfaces from the
2016 -- designated type???
2018 -- In particular are there issues in the case where the designated type
2019 -- is a synchronized interface???
2021 Stub_Type_Access_Decl :=
2022 Make_Full_Type_Declaration (Loc,
2023 Defining_Identifier => Stub_Type_Access,
2025 Make_Access_To_Object_Definition (Loc,
2026 All_Present => True,
2027 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
2029 Append_To (Decls, Stub_Type_Decl);
2030 Analyze (Last (Decls));
2031 Append_To (Decls, Stub_Type_Access_Decl);
2032 Analyze (Last (Decls));
2034 -- We can't directly derive the stub type from the designated type,
2035 -- because we don't want any components or discriminants from the real
2036 -- type, so instead we manually fake a derivation to get an appropriate
2039 Derive_Subprograms (Parent_Type => Designated_Type,
2040 Derived_Type => Stub_Type);
2042 if Present (RPC_Receiver_Decl) then
2043 Append_To (Decls, RPC_Receiver_Decl);
2045 RPC_Receiver_Decl := Last (Decls);
2048 Body_Decls := New_List;
2050 Stubs_Table.Set (Designated_Type,
2051 (Stub_Type => Stub_Type,
2052 Stub_Type_Access => Stub_Type_Access,
2053 RPC_Receiver_Decl => RPC_Receiver_Decl,
2054 Body_Decls => Body_Decls,
2055 RACW_Type => RACW_Type));
2058 ------------------------
2059 -- Append_RACW_Bodies --
2060 ------------------------
2062 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
2066 E := First_Entity (Spec_Id);
2067 while Present (E) loop
2068 if Is_Remote_Access_To_Class_Wide_Type (E) then
2069 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
2074 end Append_RACW_Bodies;
2076 ----------------------------------
2077 -- Assign_Subprogram_Identifier --
2078 ----------------------------------
2080 procedure Assign_Subprogram_Identifier
2085 N : constant Name_Id := Chars (Def);
2087 Overload_Order : constant Int := Overload_Counter_Table.Get (N) + 1;
2090 Overload_Counter_Table.Set (N, Overload_Order);
2092 Get_Name_String (N);
2094 -- Homonym handling: as in Exp_Dbug, but much simpler, because the only
2095 -- entities for which we have to generate names here need only to be
2096 -- disambiguated within their own scope.
2098 if Overload_Order > 1 then
2099 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
2100 Name_Len := Name_Len + 2;
2101 Add_Nat_To_Name_Buffer (Overload_Order);
2104 Id := String_From_Name_Buffer;
2105 Subprogram_Identifier_Table.Set
2107 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
2108 end Assign_Subprogram_Identifier;
2110 -------------------------------------
2111 -- Build_Actual_Object_Declaration --
2112 -------------------------------------
2114 procedure Build_Actual_Object_Declaration
2115 (Object : Entity_Id;
2121 Loc : constant Source_Ptr := Sloc (Object);
2124 -- Declare a temporary object for the actual, possibly initialized with
2125 -- a 'Input/From_Any call.
2127 -- Complication arises in the case of limited types, for which such a
2128 -- declaration is illegal in Ada 95. In that case, we first generate a
2129 -- renaming declaration of the 'Input call, and then if needed we
2130 -- generate an overlaid non-constant view.
2132 if Ada_Version <= Ada_95
2133 and then Is_Limited_Type (Etyp)
2134 and then Present (Expr)
2137 -- Object : Etyp renames <func-call>
2140 Make_Object_Renaming_Declaration (Loc,
2141 Defining_Identifier => Object,
2142 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
2147 -- The name defined by the renaming declaration denotes a
2148 -- constant view; create a non-constant object at the same address
2149 -- to be used as the actual.
2152 Constant_Object : constant Entity_Id :=
2153 Make_Temporary (Loc, 'P');
2156 Set_Defining_Identifier
2157 (Last (Decls), Constant_Object);
2159 -- We have an unconstrained Etyp: build the actual constrained
2160 -- subtype for the value we just read from the stream.
2162 -- subtype S is <actual subtype of Constant_Object>;
2165 Build_Actual_Subtype (Etyp,
2166 New_Occurrence_Of (Constant_Object, Loc)));
2171 Make_Object_Declaration (Loc,
2172 Defining_Identifier => Object,
2173 Object_Definition =>
2175 (Defining_Identifier (Last (Decls)), Loc)));
2176 Set_Ekind (Object, E_Variable);
2178 -- Suppress default initialization:
2179 -- pragma Import (Ada, Object);
2183 Chars => Name_Import,
2184 Pragma_Argument_Associations => New_List (
2185 Make_Pragma_Argument_Association (Loc,
2186 Chars => Name_Convention,
2187 Expression => Make_Identifier (Loc, Name_Ada)),
2188 Make_Pragma_Argument_Association (Loc,
2189 Chars => Name_Entity,
2190 Expression => New_Occurrence_Of (Object, Loc)))));
2192 -- for Object'Address use Constant_Object'Address;
2195 Make_Attribute_Definition_Clause (Loc,
2196 Name => New_Occurrence_Of (Object, Loc),
2197 Chars => Name_Address,
2199 Make_Attribute_Reference (Loc,
2200 Prefix => New_Occurrence_Of (Constant_Object, Loc),
2201 Attribute_Name => Name_Address)));
2206 -- General case of a regular object declaration. Object is flagged
2207 -- constant unless it has mode out or in out, to allow the backend
2208 -- to optimize where possible.
2210 -- Object : [constant] Etyp [:= <expr>];
2213 Make_Object_Declaration (Loc,
2214 Defining_Identifier => Object,
2215 Constant_Present => Present (Expr) and then not Variable,
2216 Object_Definition => New_Occurrence_Of (Etyp, Loc),
2217 Expression => Expr));
2219 if Constant_Present (Last (Decls)) then
2220 Set_Ekind (Object, E_Constant);
2222 Set_Ekind (Object, E_Variable);
2225 end Build_Actual_Object_Declaration;
2227 ------------------------------
2228 -- Build_Get_Unique_RP_Call --
2229 ------------------------------
2231 function Build_Get_Unique_RP_Call
2233 Pointer : Entity_Id;
2234 Stub_Type : Entity_Id) return List_Id
2238 Make_Procedure_Call_Statement (Loc,
2240 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2241 Parameter_Associations => New_List (
2242 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2243 New_Occurrence_Of (Pointer, Loc)))),
2245 Make_Assignment_Statement (Loc,
2247 Make_Selected_Component (Loc,
2248 Prefix => New_Occurrence_Of (Pointer, Loc),
2250 New_Occurrence_Of (First_Tag_Component
2251 (Designated_Type (Etype (Pointer))), Loc)),
2253 Make_Attribute_Reference (Loc,
2254 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2255 Attribute_Name => Name_Tag)));
2257 -- Note: The assignment to Pointer._Tag is safe here because
2258 -- we carefully ensured that Stub_Type has exactly the same layout
2259 -- as System.Partition_Interface.RACW_Stub_Type.
2261 end Build_Get_Unique_RP_Call;
2263 -----------------------------------
2264 -- Build_Ordered_Parameters_List --
2265 -----------------------------------
2267 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2268 Constrained_List : List_Id;
2269 Unconstrained_List : List_Id;
2270 Current_Parameter : Node_Id;
2273 First_Parameter : Node_Id;
2274 For_RAS : Boolean := False;
2277 if No (Parameter_Specifications (Spec)) then
2281 Constrained_List := New_List;
2282 Unconstrained_List := New_List;
2283 First_Parameter := First (Parameter_Specifications (Spec));
2285 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2286 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2291 -- Loop through the parameters and add them to the right list. Note that
2292 -- we treat a parameter of a null-excluding access type as unconstrained
2293 -- because we can't declare an object of such a type with default
2296 Current_Parameter := First_Parameter;
2297 while Present (Current_Parameter) loop
2298 Ptyp := Parameter_Type (Current_Parameter);
2300 if (Nkind (Ptyp) = N_Access_Definition
2301 or else not Transmit_As_Unconstrained (Etype (Ptyp)))
2302 and then not (For_RAS and then Current_Parameter = First_Parameter)
2304 Append_To (Constrained_List, New_Copy (Current_Parameter));
2306 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2309 Next (Current_Parameter);
2312 -- Unconstrained parameters are returned first
2314 Append_List_To (Unconstrained_List, Constrained_List);
2316 return Unconstrained_List;
2317 end Build_Ordered_Parameters_List;
2319 ----------------------------------
2320 -- Build_Passive_Partition_Stub --
2321 ----------------------------------
2323 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2325 Pkg_Name : String_Id;
2328 Loc : constant Source_Ptr := Sloc (U);
2331 -- Verify that the implementation supports distribution, by accessing
2332 -- a type defined in the proper version of system.rpc
2335 Dist_OK : Entity_Id;
2336 pragma Warnings (Off, Dist_OK);
2338 Dist_OK := RTE (RE_Params_Stream_Type);
2341 -- Use body if present, spec otherwise
2343 if Nkind (U) = N_Package_Declaration then
2344 Pkg_Spec := Specification (U);
2345 L := Visible_Declarations (Pkg_Spec);
2347 Pkg_Spec := Parent (Corresponding_Spec (U));
2348 L := Declarations (U);
2351 Get_Library_Unit_Name_String (Pkg_Spec);
2352 Pkg_Name := String_From_Name_Buffer;
2354 Make_Procedure_Call_Statement (Loc,
2356 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2357 Parameter_Associations => New_List (
2358 Make_String_Literal (Loc, Pkg_Name),
2359 Make_Attribute_Reference (Loc,
2361 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2362 Attribute_Name => Name_Version)));
2365 end Build_Passive_Partition_Stub;
2367 --------------------------------------
2368 -- Build_RPC_Receiver_Specification --
2369 --------------------------------------
2371 function Build_RPC_Receiver_Specification
2372 (RPC_Receiver : Entity_Id;
2373 Request_Parameter : Entity_Id) return Node_Id
2375 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2378 Make_Procedure_Specification (Loc,
2379 Defining_Unit_Name => RPC_Receiver,
2380 Parameter_Specifications => New_List (
2381 Make_Parameter_Specification (Loc,
2382 Defining_Identifier => Request_Parameter,
2384 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2385 end Build_RPC_Receiver_Specification;
2387 ----------------------------------------
2388 -- Build_Remote_Subprogram_Proxy_Type --
2389 ----------------------------------------
2391 function Build_Remote_Subprogram_Proxy_Type
2393 ACR_Expression : Node_Id) return Node_Id
2397 Make_Record_Definition (Loc,
2398 Tagged_Present => True,
2399 Limited_Present => True,
2401 Make_Component_List (Loc,
2403 Component_Items => New_List (
2404 Make_Component_Declaration (Loc,
2405 Defining_Identifier =>
2406 Make_Defining_Identifier (Loc,
2407 Name_All_Calls_Remote),
2408 Component_Definition =>
2409 Make_Component_Definition (Loc,
2410 Subtype_Indication =>
2411 New_Occurrence_Of (Standard_Boolean, Loc)),
2415 Make_Component_Declaration (Loc,
2416 Defining_Identifier =>
2417 Make_Defining_Identifier (Loc,
2419 Component_Definition =>
2420 Make_Component_Definition (Loc,
2421 Subtype_Indication =>
2422 New_Occurrence_Of (RTE (RE_Address), Loc)),
2424 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2426 Make_Component_Declaration (Loc,
2427 Defining_Identifier =>
2428 Make_Defining_Identifier (Loc,
2430 Component_Definition =>
2431 Make_Component_Definition (Loc,
2432 Subtype_Indication =>
2433 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2434 end Build_Remote_Subprogram_Proxy_Type;
2436 --------------------
2437 -- Build_Stub_Tag --
2438 --------------------
2440 function Build_Stub_Tag
2442 RACW_Type : Entity_Id) return Node_Id
2444 Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type);
2447 Make_Attribute_Reference (Loc,
2448 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2449 Attribute_Name => Name_Tag);
2452 ------------------------------------
2453 -- Build_Subprogram_Calling_Stubs --
2454 ------------------------------------
2456 function Build_Subprogram_Calling_Stubs
2457 (Vis_Decl : Node_Id;
2459 Asynchronous : Boolean;
2460 Dynamically_Asynchronous : Boolean := False;
2461 Stub_Type : Entity_Id := Empty;
2462 RACW_Type : Entity_Id := Empty;
2463 Locator : Entity_Id := Empty;
2464 New_Name : Name_Id := No_Name) return Node_Id
2466 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2468 Decls : constant List_Id := New_List;
2469 Statements : constant List_Id := New_List;
2471 Subp_Spec : Node_Id;
2472 -- The specification of the body
2474 Controlling_Parameter : Entity_Id := Empty;
2476 Asynchronous_Expr : Node_Id := Empty;
2478 RCI_Locator : Entity_Id;
2480 Spec_To_Use : Node_Id;
2482 procedure Insert_Partition_Check (Parameter : Node_Id);
2483 -- Check that the parameter has been elaborated on the same partition
2484 -- than the controlling parameter (E.4(19)).
2486 ----------------------------
2487 -- Insert_Partition_Check --
2488 ----------------------------
2490 procedure Insert_Partition_Check (Parameter : Node_Id) is
2491 Parameter_Entity : constant Entity_Id :=
2492 Defining_Identifier (Parameter);
2494 -- The expression that will be built is of the form:
2496 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2497 -- raise Constraint_Error;
2500 -- We do not check that Parameter is in Stub_Type since such a check
2501 -- has been inserted at the point of call already (a tag check since
2502 -- we have multiple controlling operands).
2505 Make_Raise_Constraint_Error (Loc,
2509 Make_Function_Call (Loc,
2511 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2512 Parameter_Associations =>
2514 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2515 New_Occurrence_Of (Parameter_Entity, Loc)),
2516 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2517 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2518 Reason => CE_Partition_Check_Failed));
2519 end Insert_Partition_Check;
2521 -- Start of processing for Build_Subprogram_Calling_Stubs
2525 Copy_Specification (Loc,
2526 Spec => Specification (Vis_Decl),
2527 New_Name => New_Name);
2529 if Locator = Empty then
2530 RCI_Locator := RCI_Cache;
2531 Spec_To_Use := Specification (Vis_Decl);
2533 RCI_Locator := Locator;
2534 Spec_To_Use := Subp_Spec;
2537 -- Find a controlling argument if we have a stub type. Also check
2538 -- if this subprogram can be made asynchronous.
2540 if Present (Stub_Type)
2541 and then Present (Parameter_Specifications (Spec_To_Use))
2544 Current_Parameter : Node_Id :=
2545 First (Parameter_Specifications
2548 while Present (Current_Parameter) loop
2550 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2552 if Controlling_Parameter = Empty then
2553 Controlling_Parameter :=
2554 Defining_Identifier (Current_Parameter);
2556 Insert_Partition_Check (Current_Parameter);
2560 Next (Current_Parameter);
2565 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2567 if Dynamically_Asynchronous then
2568 Asynchronous_Expr := Make_Selected_Component (Loc,
2569 Prefix => Controlling_Parameter,
2570 Selector_Name => Name_Asynchronous);
2573 Specific_Build_General_Calling_Stubs
2575 Statements => Statements,
2576 Target => Specific_Build_Stub_Target (Loc,
2577 Decls, RCI_Locator, Controlling_Parameter),
2578 Subprogram_Id => Subp_Id,
2579 Asynchronous => Asynchronous_Expr,
2580 Is_Known_Asynchronous => Asynchronous
2581 and then not Dynamically_Asynchronous,
2582 Is_Known_Non_Asynchronous
2584 and then not Dynamically_Asynchronous,
2585 Is_Function => Nkind (Spec_To_Use) =
2586 N_Function_Specification,
2587 Spec => Spec_To_Use,
2588 Stub_Type => Stub_Type,
2589 RACW_Type => RACW_Type,
2592 RCI_Calling_Stubs_Table.Set
2593 (Defining_Unit_Name (Specification (Vis_Decl)),
2594 Defining_Unit_Name (Spec_To_Use));
2597 Make_Subprogram_Body (Loc,
2598 Specification => Subp_Spec,
2599 Declarations => Decls,
2600 Handled_Statement_Sequence =>
2601 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2602 end Build_Subprogram_Calling_Stubs;
2604 -------------------------
2605 -- Build_Subprogram_Id --
2606 -------------------------
2608 function Build_Subprogram_Id
2610 E : Entity_Id) return Node_Id
2613 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2615 Current_Declaration : Node_Id;
2616 Current_Subp : Entity_Id;
2617 Current_Subp_Str : String_Id;
2618 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2620 pragma Warnings (Off, Current_Subp_Str);
2623 -- Build_Subprogram_Id is called outside of the context of
2624 -- generating calling or receiving stubs. Hence we are processing
2625 -- an 'Access attribute_reference for an RCI subprogram, for the
2626 -- purpose of obtaining a RAS value.
2629 (Is_Remote_Call_Interface (Scope (E))
2631 (Nkind (Parent (E)) = N_Procedure_Specification
2633 Nkind (Parent (E)) = N_Function_Specification));
2635 Current_Declaration :=
2636 First (Visible_Declarations
2637 (Package_Specification_Of_Scope (Scope (E))));
2638 while Present (Current_Declaration) loop
2639 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2640 and then Comes_From_Source (Current_Declaration)
2642 Current_Subp := Defining_Unit_Name (Specification (
2643 Current_Declaration));
2645 Assign_Subprogram_Identifier
2646 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2648 Current_Subp_Number := Current_Subp_Number + 1;
2651 Next (Current_Declaration);
2656 case Get_PCS_Name is
2657 when Name_PolyORB_DSA =>
2658 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2660 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2662 end Build_Subprogram_Id;
2664 ------------------------
2665 -- Copy_Specification --
2666 ------------------------
2668 function Copy_Specification
2671 Ctrl_Type : Entity_Id := Empty;
2672 New_Name : Name_Id := No_Name) return Node_Id
2674 Parameters : List_Id := No_List;
2676 Current_Parameter : Node_Id;
2677 Current_Identifier : Entity_Id;
2678 Current_Type : Node_Id;
2680 Name_For_New_Spec : Name_Id;
2682 New_Identifier : Entity_Id;
2684 -- Comments needed in body below ???
2687 if New_Name = No_Name then
2688 pragma Assert (Nkind (Spec) = N_Function_Specification
2689 or else Nkind (Spec) = N_Procedure_Specification);
2691 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2693 Name_For_New_Spec := New_Name;
2696 if Present (Parameter_Specifications (Spec)) then
2697 Parameters := New_List;
2698 Current_Parameter := First (Parameter_Specifications (Spec));
2699 while Present (Current_Parameter) loop
2700 Current_Identifier := Defining_Identifier (Current_Parameter);
2701 Current_Type := Parameter_Type (Current_Parameter);
2703 if Nkind (Current_Type) = N_Access_Definition then
2704 if Present (Ctrl_Type) then
2705 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2707 Make_Access_Definition (Loc,
2708 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2709 Null_Exclusion_Present =>
2710 Null_Exclusion_Present (Current_Type));
2714 Make_Access_Definition (Loc,
2716 New_Copy_Tree (Subtype_Mark (Current_Type)),
2717 Null_Exclusion_Present =>
2718 Null_Exclusion_Present (Current_Type));
2722 if Present (Ctrl_Type)
2723 and then Is_Controlling_Formal (Current_Identifier)
2725 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2727 Current_Type := New_Copy_Tree (Current_Type);
2731 New_Identifier := Make_Defining_Identifier (Loc,
2732 Chars (Current_Identifier));
2734 Append_To (Parameters,
2735 Make_Parameter_Specification (Loc,
2736 Defining_Identifier => New_Identifier,
2737 Parameter_Type => Current_Type,
2738 In_Present => In_Present (Current_Parameter),
2739 Out_Present => Out_Present (Current_Parameter),
2741 New_Copy_Tree (Expression (Current_Parameter))));
2743 -- For a regular formal parameter (that needs to be marshalled
2744 -- in the context of remote calls), set the Etype now, because
2745 -- marshalling processing might need it.
2747 if Is_Entity_Name (Current_Type) then
2748 Set_Etype (New_Identifier, Entity (Current_Type));
2750 -- Current_Type is an access definition, special processing
2751 -- (not requiring etype) will occur for marshalling.
2757 Next (Current_Parameter);
2761 case Nkind (Spec) is
2763 when N_Function_Specification | N_Access_Function_Definition =>
2765 Make_Function_Specification (Loc,
2766 Defining_Unit_Name =>
2767 Make_Defining_Identifier (Loc,
2768 Chars => Name_For_New_Spec),
2769 Parameter_Specifications => Parameters,
2770 Result_Definition =>
2771 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2773 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2775 Make_Procedure_Specification (Loc,
2776 Defining_Unit_Name =>
2777 Make_Defining_Identifier (Loc,
2778 Chars => Name_For_New_Spec),
2779 Parameter_Specifications => Parameters);
2782 raise Program_Error;
2784 end Copy_Specification;
2786 -----------------------------
2787 -- Corresponding_Stub_Type --
2788 -----------------------------
2790 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2791 Desig : constant Entity_Id :=
2792 Etype (Designated_Type (RACW_Type));
2793 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2795 return Stub_Elements.Stub_Type;
2796 end Corresponding_Stub_Type;
2798 ---------------------------
2799 -- Could_Be_Asynchronous --
2800 ---------------------------
2802 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2803 Current_Parameter : Node_Id;
2806 if Present (Parameter_Specifications (Spec)) then
2807 Current_Parameter := First (Parameter_Specifications (Spec));
2808 while Present (Current_Parameter) loop
2809 if Out_Present (Current_Parameter) then
2813 Next (Current_Parameter);
2818 end Could_Be_Asynchronous;
2820 ---------------------------
2821 -- Declare_Create_NVList --
2822 ---------------------------
2824 procedure Declare_Create_NVList
2832 Make_Object_Declaration (Loc,
2833 Defining_Identifier => NVList,
2834 Aliased_Present => False,
2835 Object_Definition =>
2836 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2839 Make_Procedure_Call_Statement (Loc,
2840 Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2841 Parameter_Associations => New_List (
2842 New_Occurrence_Of (NVList, Loc))));
2843 end Declare_Create_NVList;
2845 ---------------------------------------------
2846 -- Expand_All_Calls_Remote_Subprogram_Call --
2847 ---------------------------------------------
2849 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2850 Loc : constant Source_Ptr := Sloc (N);
2851 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2852 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2853 RCI_Locator_Decl : Node_Id;
2854 RCI_Locator : Entity_Id;
2855 Calling_Stubs : Node_Id;
2856 E_Calling_Stubs : Entity_Id;
2859 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2861 if E_Calling_Stubs = Empty then
2862 RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
2864 -- The RCI_Locator package and calling stub are is inserted at the
2865 -- top level in the current unit, and must appear in the proper scope
2866 -- so that it is not prematurely removed by the GCC back end.
2869 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2871 if Ekind (Scop) = E_Package_Body then
2872 Push_Scope (Spec_Entity (Scop));
2873 elsif Ekind (Scop) = E_Subprogram_Body then
2875 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2881 if RCI_Locator = Empty then
2884 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2885 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
2886 Analyze (RCI_Locator_Decl);
2887 RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
2890 RCI_Locator_Decl := Parent (RCI_Locator);
2893 Calling_Stubs := Build_Subprogram_Calling_Stubs
2894 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2896 Build_Subprogram_Id (Loc, Called_Subprogram),
2897 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2899 Is_Asynchronous (Called_Subprogram),
2900 Locator => RCI_Locator,
2901 New_Name => New_Internal_Name ('S'));
2902 Insert_After (RCI_Locator_Decl, Calling_Stubs);
2903 Analyze (Calling_Stubs);
2906 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2909 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2910 end Expand_All_Calls_Remote_Subprogram_Call;
2912 ---------------------------------
2913 -- Expand_Calling_Stubs_Bodies --
2914 ---------------------------------
2916 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2917 Spec : constant Node_Id := Specification (Unit_Node);
2919 Add_Calling_Stubs_To_Declarations (Spec);
2920 end Expand_Calling_Stubs_Bodies;
2922 -----------------------------------
2923 -- Expand_Receiving_Stubs_Bodies --
2924 -----------------------------------
2926 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2929 Stubs_Decls : List_Id;
2930 Stubs_Stmts : List_Id;
2933 if Nkind (Unit_Node) = N_Package_Declaration then
2934 Spec := Specification (Unit_Node);
2935 Decls := Private_Declarations (Spec);
2938 Decls := Visible_Declarations (Spec);
2941 Push_Scope (Scope_Of_Spec (Spec));
2942 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2946 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2947 Decls := Declarations (Unit_Node);
2949 Push_Scope (Scope_Of_Spec (Unit_Node));
2950 Stubs_Decls := New_List;
2951 Stubs_Stmts := New_List;
2952 Specific_Add_Receiving_Stubs_To_Declarations
2953 (Spec, Stubs_Decls, Stubs_Stmts);
2955 Insert_List_Before (First (Decls), Stubs_Decls);
2958 HSS_Stmts : constant List_Id :=
2959 Statements (Handled_Statement_Sequence (Unit_Node));
2961 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2964 if No (First_HSS_Stmt) then
2965 Append_List_To (HSS_Stmts, Stubs_Stmts);
2967 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2973 end Expand_Receiving_Stubs_Bodies;
2975 --------------------
2976 -- GARLIC_Support --
2977 --------------------
2979 package body GARLIC_Support is
2981 -- Local subprograms
2983 procedure Add_RACW_Read_Attribute
2984 (RACW_Type : Entity_Id;
2985 Stub_Type : Entity_Id;
2986 Stub_Type_Access : Entity_Id;
2987 Body_Decls : List_Id);
2988 -- Add Read attribute for the RACW type. The declaration and attribute
2989 -- definition clauses are inserted right after the declaration of
2990 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2991 -- appended to it (case where the RACW declaration is in the main unit).
2993 procedure Add_RACW_Write_Attribute
2994 (RACW_Type : Entity_Id;
2995 Stub_Type : Entity_Id;
2996 Stub_Type_Access : Entity_Id;
2997 RPC_Receiver : Node_Id;
2998 Body_Decls : List_Id);
2999 -- Same as above for the Write attribute
3001 function Stream_Parameter return Node_Id;
3002 function Result return Node_Id;
3003 function Object return Node_Id renames Result;
3004 -- Functions to create occurrences of the formal parameter names of the
3005 -- 'Read and 'Write attributes.
3008 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
3009 -- their ancillary subroutines (set on entry by Add_RACW_Features).
3011 procedure Add_RAS_Access_TSS (N : Node_Id);
3012 -- Add a subprogram body for RAS Access TSS
3014 -------------------------------------
3015 -- Add_Obj_RPC_Receiver_Completion --
3016 -------------------------------------
3018 procedure Add_Obj_RPC_Receiver_Completion
3021 RPC_Receiver : Entity_Id;
3022 Stub_Elements : Stub_Structure)
3025 -- The RPC receiver body should not be the completion of the
3026 -- declaration recorded in the stub structure, because then the
3027 -- occurrences of the formal parameters within the body should refer
3028 -- to the entities from the declaration, not from the completion, to
3029 -- which we do not have easy access. Instead, the RPC receiver body
3030 -- acts as its own declaration, and the RPC receiver declaration is
3031 -- completed by a renaming-as-body.
3034 Make_Subprogram_Renaming_Declaration (Loc,
3036 Copy_Specification (Loc,
3037 Specification (Stub_Elements.RPC_Receiver_Decl)),
3038 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
3039 end Add_Obj_RPC_Receiver_Completion;
3041 -----------------------
3042 -- Add_RACW_Features --
3043 -----------------------
3045 procedure Add_RACW_Features
3046 (RACW_Type : Entity_Id;
3047 Stub_Type : Entity_Id;
3048 Stub_Type_Access : Entity_Id;
3049 RPC_Receiver_Decl : Node_Id;
3050 Body_Decls : List_Id)
3052 RPC_Receiver : Node_Id;
3053 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
3056 Loc := Sloc (RACW_Type);
3060 -- For a RAS, the RPC receiver is that of the RCI unit, not that
3061 -- of the corresponding distributed object type. We retrieve its
3062 -- address from the local proxy object.
3064 RPC_Receiver := Make_Selected_Component (Loc,
3066 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
3067 Selector_Name => Make_Identifier (Loc, Name_Receiver));
3070 RPC_Receiver := Make_Attribute_Reference (Loc,
3071 Prefix => New_Occurrence_Of (
3072 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
3073 Attribute_Name => Name_Address);
3076 Add_RACW_Write_Attribute
3083 Add_RACW_Read_Attribute
3088 end Add_RACW_Features;
3090 -----------------------------
3091 -- Add_RACW_Read_Attribute --
3092 -----------------------------
3094 procedure Add_RACW_Read_Attribute
3095 (RACW_Type : Entity_Id;
3096 Stub_Type : Entity_Id;
3097 Stub_Type_Access : Entity_Id;
3098 Body_Decls : List_Id)
3100 Proc_Decl : Node_Id;
3101 Attr_Decl : Node_Id;
3103 Body_Node : Node_Id;
3105 Statements : constant List_Id := New_List;
3107 Local_Statements : List_Id;
3108 Remote_Statements : List_Id;
3109 -- Various parts of the procedure
3111 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
3112 Asynchronous_Flag : constant Entity_Id :=
3113 Asynchronous_Flags_Table.Get (RACW_Type);
3114 pragma Assert (Present (Asynchronous_Flag));
3116 -- Prepare local identifiers
3118 Source_Partition : Entity_Id;
3119 Source_Receiver : Entity_Id;
3120 Source_Address : Entity_Id;
3121 Local_Stub : Entity_Id;
3122 Stubbed_Result : Entity_Id;
3124 -- Start of processing for Add_RACW_Read_Attribute
3127 Build_Stream_Procedure (Loc,
3128 RACW_Type, Body_Node, Pnam, Statements, Outp => True);
3129 Proc_Decl := Make_Subprogram_Declaration (Loc,
3130 Copy_Specification (Loc, Specification (Body_Node)));
3133 Make_Attribute_Definition_Clause (Loc,
3134 Name => New_Occurrence_Of (RACW_Type, Loc),
3138 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3140 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3141 Insert_After (Proc_Decl, Attr_Decl);
3143 if No (Body_Decls) then
3145 -- Case of processing an RACW type from another unit than the
3146 -- main one: do not generate a body.
3151 -- Prepare local identifiers
3153 Source_Partition := Make_Temporary (Loc, 'P');
3154 Source_Receiver := Make_Temporary (Loc, 'S');
3155 Source_Address := Make_Temporary (Loc, 'P');
3156 Local_Stub := Make_Temporary (Loc, 'L');
3157 Stubbed_Result := Make_Temporary (Loc, 'S');
3159 -- Generate object declarations
3162 Make_Object_Declaration (Loc,
3163 Defining_Identifier => Source_Partition,
3164 Object_Definition =>
3165 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
3167 Make_Object_Declaration (Loc,
3168 Defining_Identifier => Source_Receiver,
3169 Object_Definition =>
3170 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3172 Make_Object_Declaration (Loc,
3173 Defining_Identifier => Source_Address,
3174 Object_Definition =>
3175 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3177 Make_Object_Declaration (Loc,
3178 Defining_Identifier => Local_Stub,
3179 Aliased_Present => True,
3180 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
3182 Make_Object_Declaration (Loc,
3183 Defining_Identifier => Stubbed_Result,
3184 Object_Definition =>
3185 New_Occurrence_Of (Stub_Type_Access, Loc),
3187 Make_Attribute_Reference (Loc,
3189 New_Occurrence_Of (Local_Stub, Loc),
3191 Name_Unchecked_Access)));
3193 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3195 Append_List_To (Statements, New_List (
3196 Make_Attribute_Reference (Loc,
3198 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3199 Attribute_Name => Name_Read,
3200 Expressions => New_List (
3202 New_Occurrence_Of (Source_Partition, Loc))),
3204 Make_Attribute_Reference (Loc,
3206 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3209 Expressions => New_List (
3211 New_Occurrence_Of (Source_Receiver, Loc))),
3213 Make_Attribute_Reference (Loc,
3215 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3218 Expressions => New_List (
3220 New_Occurrence_Of (Source_Address, Loc)))));
3222 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3224 Set_Etype (Stubbed_Result, Stub_Type_Access);
3226 -- If the Address is Null_Address, then return a null object, unless
3227 -- RACW_Type is null-excluding, in which case unconditionally raise
3228 -- CONSTRAINT_ERROR instead.
3231 Zero_Statements : List_Id;
3232 -- Statements executed when a zero value is received
3235 if Can_Never_Be_Null (RACW_Type) then
3236 Zero_Statements := New_List (
3237 Make_Raise_Constraint_Error (Loc,
3238 Reason => CE_Null_Not_Allowed));
3240 Zero_Statements := New_List (
3241 Make_Assignment_Statement (Loc,
3243 Expression => Make_Null (Loc)),
3244 Make_Simple_Return_Statement (Loc));
3247 Append_To (Statements,
3248 Make_Implicit_If_Statement (RACW_Type,
3251 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3252 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3253 Then_Statements => Zero_Statements));
3256 -- If the RACW denotes an object created on the current partition,
3257 -- Local_Statements will be executed. The real object will be used.
3259 Local_Statements := New_List (
3260 Make_Assignment_Statement (Loc,
3263 Unchecked_Convert_To (RACW_Type,
3264 OK_Convert_To (RTE (RE_Address),
3265 New_Occurrence_Of (Source_Address, Loc)))));
3267 -- If the object is located on another partition, then a stub object
3268 -- will be created with all the information needed to rebuild the
3269 -- real object at the other end.
3271 Remote_Statements := New_List (
3273 Make_Assignment_Statement (Loc,
3274 Name => Make_Selected_Component (Loc,
3275 Prefix => Stubbed_Result,
3276 Selector_Name => Name_Origin),
3278 New_Occurrence_Of (Source_Partition, Loc)),
3280 Make_Assignment_Statement (Loc,
3281 Name => Make_Selected_Component (Loc,
3282 Prefix => Stubbed_Result,
3283 Selector_Name => Name_Receiver),
3285 New_Occurrence_Of (Source_Receiver, Loc)),
3287 Make_Assignment_Statement (Loc,
3288 Name => Make_Selected_Component (Loc,
3289 Prefix => Stubbed_Result,
3290 Selector_Name => Name_Addr),
3292 New_Occurrence_Of (Source_Address, Loc)));
3294 Append_To (Remote_Statements,
3295 Make_Assignment_Statement (Loc,
3296 Name => Make_Selected_Component (Loc,
3297 Prefix => Stubbed_Result,
3298 Selector_Name => Name_Asynchronous),
3300 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3302 Append_List_To (Remote_Statements,
3303 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3304 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3305 -- set on the stub type if, and only if, the RACW type has a pragma
3306 -- Asynchronous. This is incorrect for RACWs that implement RAS
3307 -- types, because in that case the /designated subprogram/ (not the
3308 -- type) might be asynchronous, and that causes the stub to need to
3309 -- be asynchronous too. A solution is to transport a RAS as a struct
3310 -- containing a RACW and an asynchronous flag, and to properly alter
3311 -- the Asynchronous component in the stub type in the RAS's Input
3314 Append_To (Remote_Statements,
3315 Make_Assignment_Statement (Loc,
3317 Expression => Unchecked_Convert_To (RACW_Type,
3318 New_Occurrence_Of (Stubbed_Result, Loc))));
3320 -- Distinguish between the local and remote cases, and execute the
3321 -- appropriate piece of code.
3323 Append_To (Statements,
3324 Make_Implicit_If_Statement (RACW_Type,
3328 Make_Function_Call (Loc,
3329 Name => New_Occurrence_Of (
3330 RTE (RE_Get_Local_Partition_Id), Loc)),
3331 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3332 Then_Statements => Local_Statements,
3333 Else_Statements => Remote_Statements));
3335 Set_Declarations (Body_Node, Decls);
3336 Append_To (Body_Decls, Body_Node);
3337 end Add_RACW_Read_Attribute;
3339 ------------------------------
3340 -- Add_RACW_Write_Attribute --
3341 ------------------------------
3343 procedure Add_RACW_Write_Attribute
3344 (RACW_Type : Entity_Id;
3345 Stub_Type : Entity_Id;
3346 Stub_Type_Access : Entity_Id;
3347 RPC_Receiver : Node_Id;
3348 Body_Decls : List_Id)
3350 Body_Node : Node_Id;
3351 Proc_Decl : Node_Id;
3352 Attr_Decl : Node_Id;
3354 Statements : constant List_Id := New_List;
3355 Local_Statements : List_Id;
3356 Remote_Statements : List_Id;
3357 Null_Statements : List_Id;
3359 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
3362 Build_Stream_Procedure
3363 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
3365 Proc_Decl := Make_Subprogram_Declaration (Loc,
3366 Copy_Specification (Loc, Specification (Body_Node)));
3369 Make_Attribute_Definition_Clause (Loc,
3370 Name => New_Occurrence_Of (RACW_Type, Loc),
3371 Chars => Name_Write,
3374 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3376 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3377 Insert_After (Proc_Decl, Attr_Decl);
3379 if No (Body_Decls) then
3383 -- Build the code fragment corresponding to the marshalling of a
3386 Local_Statements := New_List (
3388 Pack_Entity_Into_Stream_Access (Loc,
3389 Stream => Stream_Parameter,
3390 Object => RTE (RE_Get_Local_Partition_Id)),
3392 Pack_Node_Into_Stream_Access (Loc,
3393 Stream => Stream_Parameter,
3394 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3395 Etyp => RTE (RE_Unsigned_64)),
3397 Pack_Node_Into_Stream_Access (Loc,
3398 Stream => Stream_Parameter,
3399 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3400 Make_Attribute_Reference (Loc,
3402 Make_Explicit_Dereference (Loc,
3404 Attribute_Name => Name_Address)),
3405 Etyp => RTE (RE_Unsigned_64)));
3407 -- Build the code fragment corresponding to the marshalling of
3410 Remote_Statements := New_List (
3411 Pack_Node_Into_Stream_Access (Loc,
3412 Stream => Stream_Parameter,
3414 Make_Selected_Component (Loc,
3416 Unchecked_Convert_To (Stub_Type_Access, Object),
3417 Selector_Name => Make_Identifier (Loc, Name_Origin)),
3418 Etyp => RTE (RE_Partition_ID)),
3420 Pack_Node_Into_Stream_Access (Loc,
3421 Stream => Stream_Parameter,
3423 Make_Selected_Component (Loc,
3425 Unchecked_Convert_To (Stub_Type_Access, Object),
3426 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
3427 Etyp => RTE (RE_Unsigned_64)),
3429 Pack_Node_Into_Stream_Access (Loc,
3430 Stream => Stream_Parameter,
3432 Make_Selected_Component (Loc,
3434 Unchecked_Convert_To (Stub_Type_Access, Object),
3435 Selector_Name => Make_Identifier (Loc, Name_Addr)),
3436 Etyp => RTE (RE_Unsigned_64)));
3438 -- Build code fragment corresponding to marshalling of a null object
3440 Null_Statements := New_List (
3442 Pack_Entity_Into_Stream_Access (Loc,
3443 Stream => Stream_Parameter,
3444 Object => RTE (RE_Get_Local_Partition_Id)),
3446 Pack_Node_Into_Stream_Access (Loc,
3447 Stream => Stream_Parameter,
3448 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3449 Etyp => RTE (RE_Unsigned_64)),
3451 Pack_Node_Into_Stream_Access (Loc,
3452 Stream => Stream_Parameter,
3453 Object => Make_Integer_Literal (Loc, Uint_0),
3454 Etyp => RTE (RE_Unsigned_64)));
3456 Append_To (Statements,
3457 Make_Implicit_If_Statement (RACW_Type,
3460 Left_Opnd => Object,
3461 Right_Opnd => Make_Null (Loc)),
3463 Then_Statements => Null_Statements,
3465 Elsif_Parts => New_List (
3466 Make_Elsif_Part (Loc,
3470 Make_Attribute_Reference (Loc,
3472 Attribute_Name => Name_Tag),
3475 Make_Attribute_Reference (Loc,
3476 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3477 Attribute_Name => Name_Tag)),
3478 Then_Statements => Remote_Statements)),
3479 Else_Statements => Local_Statements));
3481 Append_To (Body_Decls, Body_Node);
3482 end Add_RACW_Write_Attribute;
3484 ------------------------
3485 -- Add_RAS_Access_TSS --
3486 ------------------------
3488 procedure Add_RAS_Access_TSS (N : Node_Id) is
3489 Loc : constant Source_Ptr := Sloc (N);
3491 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3492 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3493 -- Ras_Type is the access to subprogram type while Fat_Type is the
3494 -- corresponding record type.
3496 RACW_Type : constant Entity_Id :=
3497 Underlying_RACW_Type (Ras_Type);
3498 Desig : constant Entity_Id :=
3499 Etype (Designated_Type (RACW_Type));
3501 Stub_Elements : constant Stub_Structure :=
3502 Stubs_Table.Get (Desig);
3503 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3505 Proc : constant Entity_Id :=
3506 Make_Defining_Identifier (Loc,
3507 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3509 Proc_Spec : Node_Id;
3511 -- Formal parameters
3513 Package_Name : constant Entity_Id :=
3514 Make_Defining_Identifier (Loc,
3518 Subp_Id : constant Entity_Id :=
3519 Make_Defining_Identifier (Loc,
3521 -- Target subprogram
3523 Asynch_P : constant Entity_Id :=
3524 Make_Defining_Identifier (Loc,
3525 Chars => Name_Asynchronous);
3526 -- Is the procedure to which the 'Access applies asynchronous?
3528 All_Calls_Remote : constant Entity_Id :=
3529 Make_Defining_Identifier (Loc,
3530 Chars => Name_All_Calls_Remote);
3531 -- True if an All_Calls_Remote pragma applies to the RCI unit
3532 -- that contains the subprogram.
3534 -- Common local variables
3536 Proc_Decls : List_Id;
3537 Proc_Statements : List_Id;
3539 Origin : constant Entity_Id := Make_Temporary (Loc, 'P');
3541 -- Additional local variables for the local case
3543 Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P');
3545 -- Additional local variables for the remote case
3547 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
3548 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
3551 (Field_Name : Name_Id;
3552 Value : Node_Id) return Node_Id;
3553 -- Construct an assignment that sets the named component in the
3561 (Field_Name : Name_Id;
3562 Value : Node_Id) return Node_Id
3566 Make_Assignment_Statement (Loc,
3568 Make_Selected_Component (Loc,
3570 Selector_Name => Field_Name),
3571 Expression => Value);
3574 -- Start of processing for Add_RAS_Access_TSS
3577 Proc_Decls := New_List (
3579 -- Common declarations
3581 Make_Object_Declaration (Loc,
3582 Defining_Identifier => Origin,
3583 Constant_Present => True,
3584 Object_Definition =>
3585 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3587 Make_Function_Call (Loc,
3589 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3590 Parameter_Associations => New_List (
3591 New_Occurrence_Of (Package_Name, Loc)))),
3593 -- Declaration use only in the local case: proxy address
3595 Make_Object_Declaration (Loc,
3596 Defining_Identifier => Proxy_Addr,
3597 Object_Definition =>
3598 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3600 -- Declarations used only in the remote case: stub object and
3603 Make_Object_Declaration (Loc,
3604 Defining_Identifier => Local_Stub,
3605 Aliased_Present => True,
3606 Object_Definition =>
3607 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3609 Make_Object_Declaration (Loc,
3610 Defining_Identifier =>
3612 Object_Definition =>
3613 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3615 Make_Attribute_Reference (Loc,
3616 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3617 Attribute_Name => Name_Unchecked_Access)));
3619 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3621 -- Build_Get_Unique_RP_Call needs above information
3623 -- Note: Here we assume that the Fat_Type is a record
3624 -- containing just a pointer to a proxy or stub object.
3626 Proc_Statements := New_List (
3630 -- Get_RAS_Info (Pkg, Subp, PA);
3631 -- if Origin = Local_Partition_Id
3632 -- and then not All_Calls_Remote
3634 -- return Fat_Type!(PA);
3637 Make_Procedure_Call_Statement (Loc,
3638 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3639 Parameter_Associations => New_List (
3640 New_Occurrence_Of (Package_Name, Loc),
3641 New_Occurrence_Of (Subp_Id, Loc),
3642 New_Occurrence_Of (Proxy_Addr, Loc))),
3644 Make_Implicit_If_Statement (N,
3650 New_Occurrence_Of (Origin, Loc),
3652 Make_Function_Call (Loc,
3654 RTE (RE_Get_Local_Partition_Id), Loc))),
3658 New_Occurrence_Of (All_Calls_Remote, Loc))),
3660 Then_Statements => New_List (
3661 Make_Simple_Return_Statement (Loc,
3662 Unchecked_Convert_To (Fat_Type,
3663 OK_Convert_To (RTE (RE_Address),
3664 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3666 Set_Field (Name_Origin,
3667 New_Occurrence_Of (Origin, Loc)),
3669 Set_Field (Name_Receiver,
3670 Make_Function_Call (Loc,
3672 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3673 Parameter_Associations => New_List (
3674 New_Occurrence_Of (Package_Name, Loc)))),
3676 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3678 -- E.4.1(9) A remote call is asynchronous if it is a call to
3679 -- a procedure or a call through a value of an access-to-procedure
3680 -- type to which a pragma Asynchronous applies.
3682 -- Asynch_P is true when the procedure is asynchronous;
3683 -- Asynch_T is true when the type is asynchronous.
3685 Set_Field (Name_Asynchronous,
3687 New_Occurrence_Of (Asynch_P, Loc),
3688 New_Occurrence_Of (Boolean_Literals (
3689 Is_Asynchronous (Ras_Type)), Loc))));
3691 Append_List_To (Proc_Statements,
3692 Build_Get_Unique_RP_Call
3693 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3695 -- Return the newly created value
3697 Append_To (Proc_Statements,
3698 Make_Simple_Return_Statement (Loc,
3700 Unchecked_Convert_To (Fat_Type,
3701 New_Occurrence_Of (Stub_Ptr, Loc))));
3704 Make_Function_Specification (Loc,
3705 Defining_Unit_Name => Proc,
3706 Parameter_Specifications => New_List (
3707 Make_Parameter_Specification (Loc,
3708 Defining_Identifier => Package_Name,
3710 New_Occurrence_Of (Standard_String, Loc)),
3712 Make_Parameter_Specification (Loc,
3713 Defining_Identifier => Subp_Id,
3715 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3717 Make_Parameter_Specification (Loc,
3718 Defining_Identifier => Asynch_P,
3720 New_Occurrence_Of (Standard_Boolean, Loc)),
3722 Make_Parameter_Specification (Loc,
3723 Defining_Identifier => All_Calls_Remote,
3725 New_Occurrence_Of (Standard_Boolean, Loc))),
3727 Result_Definition =>
3728 New_Occurrence_Of (Fat_Type, Loc));
3730 -- Set the kind and return type of the function to prevent
3731 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3733 Set_Ekind (Proc, E_Function);
3734 Set_Etype (Proc, Fat_Type);
3737 Make_Subprogram_Body (Loc,
3738 Specification => Proc_Spec,
3739 Declarations => Proc_Decls,
3740 Handled_Statement_Sequence =>
3741 Make_Handled_Sequence_Of_Statements (Loc,
3742 Statements => Proc_Statements)));
3744 Set_TSS (Fat_Type, Proc);
3745 end Add_RAS_Access_TSS;
3747 -----------------------
3748 -- Add_RAST_Features --
3749 -----------------------
3751 procedure Add_RAST_Features
3752 (Vis_Decl : Node_Id;
3753 RAS_Type : Entity_Id)
3755 pragma Unreferenced (RAS_Type);
3757 Add_RAS_Access_TSS (Vis_Decl);
3758 end Add_RAST_Features;
3760 -----------------------------------------
3761 -- Add_Receiving_Stubs_To_Declarations --
3762 -----------------------------------------
3764 procedure Add_Receiving_Stubs_To_Declarations
3765 (Pkg_Spec : Node_Id;
3769 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3771 Request_Parameter : Node_Id;
3773 Pkg_RPC_Receiver : constant Entity_Id :=
3774 Make_Temporary (Loc, 'H');
3775 Pkg_RPC_Receiver_Statements : List_Id;
3776 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3777 Pkg_RPC_Receiver_Body : Node_Id;
3778 -- A Pkg_RPC_Receiver is built to decode the request
3780 Lookup_RAS : Node_Id;
3781 Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R');
3782 -- A remote subprogram is created to allow peers to look up RAS
3783 -- information using subprogram ids.
3785 Subp_Id : Entity_Id;
3786 Subp_Index : Entity_Id;
3787 -- Subprogram_Id as read from the incoming stream
3789 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
3790 Current_Stubs : Node_Id;
3792 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
3793 Subp_Info_List : constant List_Id := New_List;
3795 Register_Pkg_Actuals : constant List_Id := New_List;
3797 All_Calls_Remote_E : Entity_Id;
3798 Proxy_Object_Addr : Entity_Id;
3800 procedure Append_Stubs_To
3801 (RPC_Receiver_Cases : List_Id;
3803 Subprogram_Number : Int);
3804 -- Add one case to the specified RPC receiver case list
3805 -- associating Subprogram_Number with the subprogram declared
3806 -- by Declaration, for which we have receiving stubs in Stubs.
3808 procedure Visit_Subprogram (Decl : Node_Id);
3809 -- Generate receiving stub for one remote subprogram
3811 ---------------------
3812 -- Append_Stubs_To --
3813 ---------------------
3815 procedure Append_Stubs_To
3816 (RPC_Receiver_Cases : List_Id;
3818 Subprogram_Number : Int)
3821 Append_To (RPC_Receiver_Cases,
3822 Make_Case_Statement_Alternative (Loc,
3824 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3827 Make_Procedure_Call_Statement (Loc,
3829 New_Occurrence_Of (Defining_Entity (Stubs), Loc),
3830 Parameter_Associations => New_List (
3831 New_Occurrence_Of (Request_Parameter, Loc))))));
3832 end Append_Stubs_To;
3834 ----------------------
3835 -- Visit_Subprogram --
3836 ----------------------
3838 procedure Visit_Subprogram (Decl : Node_Id) is
3839 Loc : constant Source_Ptr := Sloc (Decl);
3840 Spec : constant Node_Id := Specification (Decl);
3841 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
3843 Subp_Val : String_Id;
3844 pragma Warnings (Off, Subp_Val);
3847 -- Disable expansion of stubs if serious errors have been
3848 -- diagnosed, because otherwise some illegal remote subprogram
3849 -- declarations could cause cascaded errors in stubs.
3851 if Serious_Errors_Detected /= 0 then
3855 -- Build receiving stub
3858 Build_Subprogram_Receiving_Stubs
3861 Nkind (Spec) = N_Procedure_Specification
3862 and then Is_Asynchronous (Subp_Def));
3864 Append_To (Decls, Current_Stubs);
3865 Analyze (Current_Stubs);
3869 Add_RAS_Proxy_And_Analyze (Decls,
3871 All_Calls_Remote_E => All_Calls_Remote_E,
3872 Proxy_Object_Addr => Proxy_Object_Addr);
3874 -- Compute distribution identifier
3876 Assign_Subprogram_Identifier
3877 (Subp_Def, Current_Subp_Number, Subp_Val);
3879 pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
3881 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
3882 -- table for this receiver. This aggregate must be kept consistent
3883 -- with the declaration of RCI_Subp_Info in
3884 -- System.Partition_Interface.
3886 Append_To (Subp_Info_List,
3887 Make_Component_Association (Loc,
3888 Choices => New_List (
3889 Make_Integer_Literal (Loc, Current_Subp_Number)),
3892 Make_Aggregate (Loc,
3893 Component_Associations => New_List (
3897 Make_Component_Association (Loc,
3899 New_List (Make_Identifier (Loc, Name_Addr)),
3901 New_Occurrence_Of (Proxy_Object_Addr, Loc))))));
3903 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3904 Stubs => Current_Stubs,
3905 Subprogram_Number => Current_Subp_Number);
3907 Current_Subp_Number := Current_Subp_Number + 1;
3908 end Visit_Subprogram;
3910 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
3912 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3915 -- Building receiving stubs consist in several operations:
3917 -- - a package RPC receiver must be built. This subprogram
3918 -- will get a Subprogram_Id from the incoming stream
3919 -- and will dispatch the call to the right subprogram;
3921 -- - a receiving stub for each subprogram visible in the package
3922 -- spec. This stub will read all the parameters from the stream,
3923 -- and put the result as well as the exception occurrence in the
3926 -- - a dummy package with an empty spec and a body made of an
3927 -- elaboration part, whose job is to register the receiving
3928 -- part of this RCI package on the name server. This is done
3929 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3931 Build_RPC_Receiver_Body (
3932 RPC_Receiver => Pkg_RPC_Receiver,
3933 Request => Request_Parameter,
3935 Subp_Index => Subp_Index,
3936 Stmts => Pkg_RPC_Receiver_Statements,
3937 Decl => Pkg_RPC_Receiver_Body);
3938 pragma Assert (Subp_Id = Subp_Index);
3940 -- A null subp_id denotes a call through a RAS, in which case the
3941 -- next Uint_64 element in the stream is the address of the local
3942 -- proxy object, from which we can retrieve the actual subprogram id.
3944 Append_To (Pkg_RPC_Receiver_Statements,
3945 Make_Implicit_If_Statement (Pkg_Spec,
3948 New_Occurrence_Of (Subp_Id, Loc),
3949 Make_Integer_Literal (Loc, 0)),
3951 Then_Statements => New_List (
3952 Make_Assignment_Statement (Loc,
3954 New_Occurrence_Of (Subp_Id, Loc),
3957 Make_Selected_Component (Loc,
3959 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3960 OK_Convert_To (RTE (RE_Address),
3961 Make_Attribute_Reference (Loc,
3963 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3966 Expressions => New_List (
3967 Make_Selected_Component (Loc,
3968 Prefix => Request_Parameter,
3969 Selector_Name => Name_Params))))),
3971 Selector_Name => Make_Identifier (Loc, Name_Subp_Id))))));
3973 -- Build a subprogram for RAS information lookups
3976 Make_Subprogram_Declaration (Loc,
3978 Make_Function_Specification (Loc,
3979 Defining_Unit_Name =>
3981 Parameter_Specifications => New_List (
3982 Make_Parameter_Specification (Loc,
3983 Defining_Identifier =>
3984 Make_Defining_Identifier (Loc, Name_Subp_Id),
3988 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3989 Result_Definition =>
3990 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3991 Append_To (Decls, Lookup_RAS);
3992 Analyze (Lookup_RAS);
3994 Current_Stubs := Build_Subprogram_Receiving_Stubs
3995 (Vis_Decl => Lookup_RAS,
3996 Asynchronous => False);
3997 Append_To (Decls, Current_Stubs);
3998 Analyze (Current_Stubs);
4000 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
4001 Stubs => Current_Stubs,
4002 Subprogram_Number => 1);
4004 -- For each subprogram, the receiving stub will be built and a
4005 -- case statement will be made on the Subprogram_Id to dispatch
4006 -- to the right subprogram.
4008 All_Calls_Remote_E :=
4010 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
4012 Overload_Counter_Table.Reset;
4014 Visit_Spec (Pkg_Spec);
4016 -- If we receive an invalid Subprogram_Id, it is best to do nothing
4017 -- rather than raising an exception since we do not want someone
4018 -- to crash a remote partition by sending invalid subprogram ids.
4019 -- This is consistent with the other parts of the case statement
4020 -- since even in presence of incorrect parameters in the stream,
4021 -- every exception will be caught and (if the subprogram is not an
4022 -- APC) put into the result stream and sent away.
4024 Append_To (Pkg_RPC_Receiver_Cases,
4025 Make_Case_Statement_Alternative (Loc,
4026 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4027 Statements => New_List (Make_Null_Statement (Loc))));
4029 Append_To (Pkg_RPC_Receiver_Statements,
4030 Make_Case_Statement (Loc,
4031 Expression => New_Occurrence_Of (Subp_Id, Loc),
4032 Alternatives => Pkg_RPC_Receiver_Cases));
4035 Make_Object_Declaration (Loc,
4036 Defining_Identifier => Subp_Info_Array,
4037 Constant_Present => True,
4038 Aliased_Present => True,
4039 Object_Definition =>
4040 Make_Subtype_Indication (Loc,
4042 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
4044 Make_Index_Or_Discriminant_Constraint (Loc,
4047 Low_Bound => Make_Integer_Literal (Loc,
4048 First_RCI_Subprogram_Id),
4050 Make_Integer_Literal (Loc,
4052 First_RCI_Subprogram_Id
4053 + List_Length (Subp_Info_List) - 1)))))));
4055 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
4056 -- has zero length, and the declaration is for an empty array, in
4057 -- which case no initialization aggregate must be generated.
4059 if Present (First (Subp_Info_List)) then
4060 Set_Expression (Last (Decls),
4061 Make_Aggregate (Loc,
4062 Component_Associations => Subp_Info_List));
4064 -- No initialization provided: remove CONSTANT so that the
4065 -- declaration is not an incomplete deferred constant.
4068 Set_Constant_Present (Last (Decls), False);
4071 Analyze (Last (Decls));
4074 Subp_Info_Addr : Node_Id;
4075 -- Return statement for Lookup_RAS_Info: address of the subprogram
4076 -- information record for the requested subprogram id.
4079 if Present (First (Subp_Info_List)) then
4081 Make_Selected_Component (Loc,
4083 Make_Indexed_Component (Loc,
4084 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4085 Expressions => New_List (
4086 Convert_To (Standard_Integer,
4087 Make_Identifier (Loc, Name_Subp_Id)))),
4088 Selector_Name => Make_Identifier (Loc, Name_Addr));
4090 -- Case of no visible subprogram: just raise Constraint_Error, we
4091 -- know for sure we got junk from a remote partition.
4095 Make_Raise_Constraint_Error (Loc,
4096 Reason => CE_Range_Check_Failed);
4097 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
4101 Make_Subprogram_Body (Loc,
4103 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
4104 Declarations => No_List,
4105 Handled_Statement_Sequence =>
4106 Make_Handled_Sequence_Of_Statements (Loc,
4107 Statements => New_List (
4108 Make_Simple_Return_Statement (Loc,
4111 (RTE (RE_Unsigned_64), Subp_Info_Addr))))));
4114 Analyze (Last (Decls));
4116 Append_To (Decls, Pkg_RPC_Receiver_Body);
4117 Analyze (Last (Decls));
4119 Get_Library_Unit_Name_String (Pkg_Spec);
4123 Append_To (Register_Pkg_Actuals,
4124 Make_String_Literal (Loc,
4125 Strval => String_From_Name_Buffer));
4129 Append_To (Register_Pkg_Actuals,
4130 Make_Attribute_Reference (Loc,
4131 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
4132 Attribute_Name => Name_Unrestricted_Access));
4136 Append_To (Register_Pkg_Actuals,
4137 Make_Attribute_Reference (Loc,
4139 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
4140 Attribute_Name => Name_Version));
4144 Append_To (Register_Pkg_Actuals,
4145 Make_Attribute_Reference (Loc,
4146 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4147 Attribute_Name => Name_Address));
4151 Append_To (Register_Pkg_Actuals,
4152 Make_Attribute_Reference (Loc,
4153 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4154 Attribute_Name => Name_Length));
4156 -- Generate the call
4159 Make_Procedure_Call_Statement (Loc,
4161 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
4162 Parameter_Associations => Register_Pkg_Actuals));
4163 Analyze (Last (Stmts));
4164 end Add_Receiving_Stubs_To_Declarations;
4166 ---------------------------------
4167 -- Build_General_Calling_Stubs --
4168 ---------------------------------
4170 procedure Build_General_Calling_Stubs
4172 Statements : List_Id;
4173 Target_Partition : Entity_Id;
4174 Target_RPC_Receiver : Node_Id;
4175 Subprogram_Id : Node_Id;
4176 Asynchronous : Node_Id := Empty;
4177 Is_Known_Asynchronous : Boolean := False;
4178 Is_Known_Non_Asynchronous : Boolean := False;
4179 Is_Function : Boolean;
4181 Stub_Type : Entity_Id := Empty;
4182 RACW_Type : Entity_Id := Empty;
4185 Loc : constant Source_Ptr := Sloc (Nod);
4187 Stream_Parameter : Node_Id;
4188 -- Name of the stream used to transmit parameters to the remote
4191 Result_Parameter : Node_Id;
4192 -- Name of the result parameter (in non-APC cases) which get the
4193 -- result of the remote subprogram.
4195 Exception_Return_Parameter : Node_Id;
4196 -- Name of the parameter which will hold the exception sent by the
4197 -- remote subprogram.
4199 Current_Parameter : Node_Id;
4200 -- Current parameter being handled
4202 Ordered_Parameters_List : constant List_Id :=
4203 Build_Ordered_Parameters_List (Spec);
4205 Asynchronous_Statements : List_Id := No_List;
4206 Non_Asynchronous_Statements : List_Id := No_List;
4207 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4209 Extra_Formal_Statements : constant List_Id := New_List;
4210 -- List of statements for extra formal parameters. It will appear
4211 -- after the regular statements for writing out parameters.
4213 pragma Unreferenced (RACW_Type);
4214 -- Used only for the PolyORB case
4217 -- The general form of a calling stub for a given subprogram is:
4219 -- procedure X (...) is P : constant Partition_ID :=
4220 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4221 -- System.RPC.Params_Stream_Type (0); begin
4222 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4223 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4224 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4225 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4227 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4229 -- There are some variations: Do_APC is called for an asynchronous
4230 -- procedure and the part after the call is completely ommitted as
4231 -- well as the declaration of Result. For a function call, 'Input is
4232 -- always used to read the result even if it is constrained.
4234 Stream_Parameter := Make_Temporary (Loc, 'S');
4237 Make_Object_Declaration (Loc,
4238 Defining_Identifier => Stream_Parameter,
4239 Aliased_Present => True,
4240 Object_Definition =>
4241 Make_Subtype_Indication (Loc,
4243 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4245 Make_Index_Or_Discriminant_Constraint (Loc,
4247 New_List (Make_Integer_Literal (Loc, 0))))));
4249 if not Is_Known_Asynchronous then
4250 Result_Parameter := Make_Temporary (Loc, 'R');
4253 Make_Object_Declaration (Loc,
4254 Defining_Identifier => Result_Parameter,
4255 Aliased_Present => True,
4256 Object_Definition =>
4257 Make_Subtype_Indication (Loc,
4259 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4261 Make_Index_Or_Discriminant_Constraint (Loc,
4263 New_List (Make_Integer_Literal (Loc, 0))))));
4265 Exception_Return_Parameter := Make_Temporary (Loc, 'E');
4268 Make_Object_Declaration (Loc,
4269 Defining_Identifier => Exception_Return_Parameter,
4270 Object_Definition =>
4271 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4274 Result_Parameter := Empty;
4275 Exception_Return_Parameter := Empty;
4278 -- Put first the RPC receiver corresponding to the remote package
4280 Append_To (Statements,
4281 Make_Attribute_Reference (Loc,
4283 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4284 Attribute_Name => Name_Write,
4285 Expressions => New_List (
4286 Make_Attribute_Reference (Loc,
4287 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4288 Attribute_Name => Name_Access),
4289 Target_RPC_Receiver)));
4291 -- Then put the Subprogram_Id of the subprogram we want to call in
4294 Append_To (Statements,
4295 Make_Attribute_Reference (Loc,
4296 Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4297 Attribute_Name => Name_Write,
4298 Expressions => New_List (
4299 Make_Attribute_Reference (Loc,
4300 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4301 Attribute_Name => Name_Access),
4304 Current_Parameter := First (Ordered_Parameters_List);
4305 while Present (Current_Parameter) loop
4307 Typ : constant Node_Id :=
4308 Parameter_Type (Current_Parameter);
4310 Constrained : Boolean;
4312 Extra_Parameter : Entity_Id;
4315 if Is_RACW_Controlling_Formal
4316 (Current_Parameter, Stub_Type)
4318 -- In the case of a controlling formal argument, we marshall
4319 -- its addr field rather than the local stub.
4321 Append_To (Statements,
4322 Pack_Node_Into_Stream (Loc,
4323 Stream => Stream_Parameter,
4325 Make_Selected_Component (Loc,
4327 Defining_Identifier (Current_Parameter),
4328 Selector_Name => Name_Addr),
4329 Etyp => RTE (RE_Unsigned_64)));
4334 (Defining_Identifier (Current_Parameter), Loc);
4336 -- Access type parameters are transmitted as in out
4337 -- parameters. However, a dereference is needed so that
4338 -- we marshall the designated object.
4340 if Nkind (Typ) = N_Access_Definition then
4341 Value := Make_Explicit_Dereference (Loc, Value);
4342 Etyp := Etype (Subtype_Mark (Typ));
4344 Etyp := Etype (Typ);
4347 Constrained := not Transmit_As_Unconstrained (Etyp);
4349 -- Any parameter but unconstrained out parameters are
4350 -- transmitted to the peer.
4352 if In_Present (Current_Parameter)
4353 or else not Out_Present (Current_Parameter)
4354 or else not Constrained
4356 Append_To (Statements,
4357 Make_Attribute_Reference (Loc,
4358 Prefix => New_Occurrence_Of (Etyp, Loc),
4360 Output_From_Constrained (Constrained),
4361 Expressions => New_List (
4362 Make_Attribute_Reference (Loc,
4364 New_Occurrence_Of (Stream_Parameter, Loc),
4365 Attribute_Name => Name_Access),
4370 -- If the current parameter has a dynamic constrained status,
4371 -- then this status is transmitted as well.
4372 -- This should be done for accessibility as well ???
4374 if Nkind (Typ) /= N_Access_Definition
4375 and then Need_Extra_Constrained (Current_Parameter)
4377 -- In this block, we do not use the extra formal that has
4378 -- been created because it does not exist at the time of
4379 -- expansion when building calling stubs for remote access
4380 -- to subprogram types. We create an extra variable of this
4381 -- type and push it in the stream after the regular
4384 Extra_Parameter := Make_Temporary (Loc, 'P');
4387 Make_Object_Declaration (Loc,
4388 Defining_Identifier => Extra_Parameter,
4389 Constant_Present => True,
4390 Object_Definition =>
4391 New_Occurrence_Of (Standard_Boolean, Loc),
4393 Make_Attribute_Reference (Loc,
4396 Defining_Identifier (Current_Parameter), Loc),
4397 Attribute_Name => Name_Constrained)));
4399 Append_To (Extra_Formal_Statements,
4400 Make_Attribute_Reference (Loc,
4402 New_Occurrence_Of (Standard_Boolean, Loc),
4403 Attribute_Name => Name_Write,
4404 Expressions => New_List (
4405 Make_Attribute_Reference (Loc,
4408 (Stream_Parameter, Loc), Attribute_Name =>
4410 New_Occurrence_Of (Extra_Parameter, Loc))));
4413 Next (Current_Parameter);
4417 -- Append the formal statements list to the statements
4419 Append_List_To (Statements, Extra_Formal_Statements);
4421 if not Is_Known_Non_Asynchronous then
4423 -- Build the call to System.RPC.Do_APC
4425 Asynchronous_Statements := New_List (
4426 Make_Procedure_Call_Statement (Loc,
4428 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4429 Parameter_Associations => New_List (
4430 New_Occurrence_Of (Target_Partition, Loc),
4431 Make_Attribute_Reference (Loc,
4433 New_Occurrence_Of (Stream_Parameter, Loc),
4434 Attribute_Name => Name_Access))));
4436 Asynchronous_Statements := No_List;
4439 if not Is_Known_Asynchronous then
4441 -- Build the call to System.RPC.Do_RPC
4443 Non_Asynchronous_Statements := New_List (
4444 Make_Procedure_Call_Statement (Loc,
4446 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4447 Parameter_Associations => New_List (
4448 New_Occurrence_Of (Target_Partition, Loc),
4450 Make_Attribute_Reference (Loc,
4452 New_Occurrence_Of (Stream_Parameter, Loc),
4453 Attribute_Name => Name_Access),
4455 Make_Attribute_Reference (Loc,
4457 New_Occurrence_Of (Result_Parameter, Loc),
4458 Attribute_Name => Name_Access))));
4460 -- Read the exception occurrence from the result stream and
4461 -- reraise it. It does no harm if this is a Null_Occurrence since
4462 -- this does nothing.
4464 Append_To (Non_Asynchronous_Statements,
4465 Make_Attribute_Reference (Loc,
4467 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4469 Attribute_Name => Name_Read,
4471 Expressions => New_List (
4472 Make_Attribute_Reference (Loc,
4474 New_Occurrence_Of (Result_Parameter, Loc),
4475 Attribute_Name => Name_Access),
4476 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4478 Append_To (Non_Asynchronous_Statements,
4479 Make_Procedure_Call_Statement (Loc,
4481 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4482 Parameter_Associations => New_List (
4483 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4487 -- If this is a function call, then read the value and return
4488 -- it. The return value is written/read using 'Output/'Input.
4490 Append_To (Non_Asynchronous_Statements,
4491 Make_Tag_Check (Loc,
4492 Make_Simple_Return_Statement (Loc,
4494 Make_Attribute_Reference (Loc,
4497 Etype (Result_Definition (Spec)), Loc),
4499 Attribute_Name => Name_Input,
4501 Expressions => New_List (
4502 Make_Attribute_Reference (Loc,
4504 New_Occurrence_Of (Result_Parameter, Loc),
4505 Attribute_Name => Name_Access))))));
4508 -- Loop around parameters and assign out (or in out)
4509 -- parameters. In the case of RACW, controlling arguments
4510 -- cannot possibly have changed since they are remote, so
4511 -- we do not read them from the stream.
4513 Current_Parameter := First (Ordered_Parameters_List);
4514 while Present (Current_Parameter) loop
4516 Typ : constant Node_Id :=
4517 Parameter_Type (Current_Parameter);
4524 (Defining_Identifier (Current_Parameter), Loc);
4526 if Nkind (Typ) = N_Access_Definition then
4527 Value := Make_Explicit_Dereference (Loc, Value);
4528 Etyp := Etype (Subtype_Mark (Typ));
4530 Etyp := Etype (Typ);
4533 if (Out_Present (Current_Parameter)
4534 or else Nkind (Typ) = N_Access_Definition)
4535 and then Etyp /= Stub_Type
4537 Append_To (Non_Asynchronous_Statements,
4538 Make_Attribute_Reference (Loc,
4540 New_Occurrence_Of (Etyp, Loc),
4542 Attribute_Name => Name_Read,
4544 Expressions => New_List (
4545 Make_Attribute_Reference (Loc,
4547 New_Occurrence_Of (Result_Parameter, Loc),
4548 Attribute_Name => Name_Access),
4553 Next (Current_Parameter);
4558 if Is_Known_Asynchronous then
4559 Append_List_To (Statements, Asynchronous_Statements);
4561 elsif Is_Known_Non_Asynchronous then
4562 Append_List_To (Statements, Non_Asynchronous_Statements);
4565 pragma Assert (Present (Asynchronous));
4566 Prepend_To (Asynchronous_Statements,
4567 Make_Attribute_Reference (Loc,
4568 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4569 Attribute_Name => Name_Write,
4570 Expressions => New_List (
4571 Make_Attribute_Reference (Loc,
4573 New_Occurrence_Of (Stream_Parameter, Loc),
4574 Attribute_Name => Name_Access),
4575 New_Occurrence_Of (Standard_True, Loc))));
4577 Prepend_To (Non_Asynchronous_Statements,
4578 Make_Attribute_Reference (Loc,
4579 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4580 Attribute_Name => Name_Write,
4581 Expressions => New_List (
4582 Make_Attribute_Reference (Loc,
4584 New_Occurrence_Of (Stream_Parameter, Loc),
4585 Attribute_Name => Name_Access),
4586 New_Occurrence_Of (Standard_False, Loc))));
4588 Append_To (Statements,
4589 Make_Implicit_If_Statement (Nod,
4590 Condition => Asynchronous,
4591 Then_Statements => Asynchronous_Statements,
4592 Else_Statements => Non_Asynchronous_Statements));
4594 end Build_General_Calling_Stubs;
4596 -----------------------------
4597 -- Build_RPC_Receiver_Body --
4598 -----------------------------
4600 procedure Build_RPC_Receiver_Body
4601 (RPC_Receiver : Entity_Id;
4602 Request : out Entity_Id;
4603 Subp_Id : out Entity_Id;
4604 Subp_Index : out Entity_Id;
4605 Stmts : out List_Id;
4608 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4610 RPC_Receiver_Spec : Node_Id;
4611 RPC_Receiver_Decls : List_Id;
4614 Request := Make_Defining_Identifier (Loc, Name_R);
4616 RPC_Receiver_Spec :=
4617 Build_RPC_Receiver_Specification
4618 (RPC_Receiver => RPC_Receiver,
4619 Request_Parameter => Request);
4621 Subp_Id := Make_Temporary (Loc, 'P');
4622 Subp_Index := Subp_Id;
4624 -- Subp_Id may not be a constant, because in the case of the RPC
4625 -- receiver for an RCI package, when a call is received from a RAS
4626 -- dereference, it will be assigned during subsequent processing.
4628 RPC_Receiver_Decls := New_List (
4629 Make_Object_Declaration (Loc,
4630 Defining_Identifier => Subp_Id,
4631 Object_Definition =>
4632 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4634 Make_Attribute_Reference (Loc,
4636 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4637 Attribute_Name => Name_Input,
4638 Expressions => New_List (
4639 Make_Selected_Component (Loc,
4641 Selector_Name => Name_Params)))));
4646 Make_Subprogram_Body (Loc,
4647 Specification => RPC_Receiver_Spec,
4648 Declarations => RPC_Receiver_Decls,
4649 Handled_Statement_Sequence =>
4650 Make_Handled_Sequence_Of_Statements (Loc,
4651 Statements => Stmts));
4652 end Build_RPC_Receiver_Body;
4654 -----------------------
4655 -- Build_Stub_Target --
4656 -----------------------
4658 function Build_Stub_Target
4661 RCI_Locator : Entity_Id;
4662 Controlling_Parameter : Entity_Id) return RPC_Target
4664 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4667 Target_Info.Partition := Make_Temporary (Loc, 'P');
4669 if Present (Controlling_Parameter) then
4671 Make_Object_Declaration (Loc,
4672 Defining_Identifier => Target_Info.Partition,
4673 Constant_Present => True,
4674 Object_Definition =>
4675 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4678 Make_Selected_Component (Loc,
4679 Prefix => Controlling_Parameter,
4680 Selector_Name => Name_Origin)));
4682 Target_Info.RPC_Receiver :=
4683 Make_Selected_Component (Loc,
4684 Prefix => Controlling_Parameter,
4685 Selector_Name => Name_Receiver);
4689 Make_Object_Declaration (Loc,
4690 Defining_Identifier => Target_Info.Partition,
4691 Constant_Present => True,
4692 Object_Definition =>
4693 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4696 Make_Function_Call (Loc,
4697 Name => Make_Selected_Component (Loc,
4699 Make_Identifier (Loc, Chars (RCI_Locator)),
4701 Make_Identifier (Loc,
4702 Name_Get_Active_Partition_ID)))));
4704 Target_Info.RPC_Receiver :=
4705 Make_Selected_Component (Loc,
4707 Make_Identifier (Loc, Chars (RCI_Locator)),
4709 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4712 end Build_Stub_Target;
4714 ---------------------
4715 -- Build_Stub_Type --
4716 ---------------------
4718 procedure Build_Stub_Type
4719 (RACW_Type : Entity_Id;
4720 Stub_Type_Comps : out List_Id;
4721 RPC_Receiver_Decl : out Node_Id)
4723 Loc : constant Source_Ptr := Sloc (RACW_Type);
4724 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4727 Stub_Type_Comps := New_List (
4728 Make_Component_Declaration (Loc,
4729 Defining_Identifier =>
4730 Make_Defining_Identifier (Loc, Name_Origin),
4731 Component_Definition =>
4732 Make_Component_Definition (Loc,
4733 Aliased_Present => False,
4734 Subtype_Indication =>
4735 New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
4737 Make_Component_Declaration (Loc,
4738 Defining_Identifier =>
4739 Make_Defining_Identifier (Loc, Name_Receiver),
4740 Component_Definition =>
4741 Make_Component_Definition (Loc,
4742 Aliased_Present => False,
4743 Subtype_Indication =>
4744 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4746 Make_Component_Declaration (Loc,
4747 Defining_Identifier =>
4748 Make_Defining_Identifier (Loc, Name_Addr),
4749 Component_Definition =>
4750 Make_Component_Definition (Loc,
4751 Aliased_Present => False,
4752 Subtype_Indication =>
4753 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4755 Make_Component_Declaration (Loc,
4756 Defining_Identifier =>
4757 Make_Defining_Identifier (Loc, Name_Asynchronous),
4758 Component_Definition =>
4759 Make_Component_Definition (Loc,
4760 Aliased_Present => False,
4761 Subtype_Indication =>
4762 New_Occurrence_Of (Standard_Boolean, Loc))));
4765 RPC_Receiver_Decl := Empty;
4768 RPC_Receiver_Request : constant Entity_Id :=
4769 Make_Defining_Identifier (Loc, Name_R);
4771 RPC_Receiver_Decl :=
4772 Make_Subprogram_Declaration (Loc,
4773 Build_RPC_Receiver_Specification
4774 (RPC_Receiver => Make_Temporary (Loc, 'R'),
4775 Request_Parameter => RPC_Receiver_Request));
4778 end Build_Stub_Type;
4780 --------------------------------------
4781 -- Build_Subprogram_Receiving_Stubs --
4782 --------------------------------------
4784 function Build_Subprogram_Receiving_Stubs
4785 (Vis_Decl : Node_Id;
4786 Asynchronous : Boolean;
4787 Dynamically_Asynchronous : Boolean := False;
4788 Stub_Type : Entity_Id := Empty;
4789 RACW_Type : Entity_Id := Empty;
4790 Parent_Primitive : Entity_Id := Empty) return Node_Id
4792 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4794 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
4795 -- Formal parameter for receiving stubs: a descriptor for an incoming
4798 Decls : constant List_Id := New_List;
4799 -- All the parameters will get declared before calling the real
4800 -- subprograms. Also the out parameters will be declared.
4802 Statements : constant List_Id := New_List;
4804 Extra_Formal_Statements : constant List_Id := New_List;
4805 -- Statements concerning extra formal parameters
4807 After_Statements : constant List_Id := New_List;
4808 -- Statements to be executed after the subprogram call
4810 Inner_Decls : List_Id := No_List;
4811 -- In case of a function, the inner declarations are needed since
4812 -- the result may be unconstrained.
4814 Excep_Handlers : List_Id := No_List;
4815 Excep_Choice : Entity_Id;
4816 Excep_Code : List_Id;
4818 Parameter_List : constant List_Id := New_List;
4819 -- List of parameters to be passed to the subprogram
4821 Current_Parameter : Node_Id;
4823 Ordered_Parameters_List : constant List_Id :=
4824 Build_Ordered_Parameters_List
4825 (Specification (Vis_Decl));
4827 Subp_Spec : Node_Id;
4828 -- Subprogram specification
4830 Called_Subprogram : Node_Id;
4831 -- The subprogram to call
4833 Null_Raise_Statement : Node_Id;
4835 Dynamic_Async : Entity_Id;
4838 if Present (RACW_Type) then
4839 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4841 Called_Subprogram :=
4843 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4846 if Dynamically_Asynchronous then
4847 Dynamic_Async := Make_Temporary (Loc, 'S');
4849 Dynamic_Async := Empty;
4852 if not Asynchronous or Dynamically_Asynchronous then
4854 -- The first statement after the subprogram call is a statement to
4855 -- write a Null_Occurrence into the result stream.
4857 Null_Raise_Statement :=
4858 Make_Attribute_Reference (Loc,
4860 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4861 Attribute_Name => Name_Write,
4862 Expressions => New_List (
4863 Make_Selected_Component (Loc,
4864 Prefix => Request_Parameter,
4865 Selector_Name => Name_Result),
4866 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4868 if Dynamically_Asynchronous then
4869 Null_Raise_Statement :=
4870 Make_Implicit_If_Statement (Vis_Decl,
4872 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4873 Then_Statements => New_List (Null_Raise_Statement));
4876 Append_To (After_Statements, Null_Raise_Statement);
4879 -- Loop through every parameter and get its value from the stream. If
4880 -- the parameter is unconstrained, then the parameter is read using
4881 -- 'Input at the point of declaration.
4883 Current_Parameter := First (Ordered_Parameters_List);
4884 while Present (Current_Parameter) loop
4887 Constrained : Boolean;
4889 Need_Extra_Constrained : Boolean;
4890 -- True when an Extra_Constrained actual is required
4892 Object : constant Entity_Id := Make_Temporary (Loc, 'P');
4894 Expr : Node_Id := Empty;
4896 Is_Controlling_Formal : constant Boolean :=
4897 Is_RACW_Controlling_Formal
4898 (Current_Parameter, Stub_Type);
4901 if Is_Controlling_Formal then
4903 -- We have a controlling formal parameter. Read its address
4904 -- rather than a real object. The address is in Unsigned_64
4907 Etyp := RTE (RE_Unsigned_64);
4909 Etyp := Etype (Parameter_Type (Current_Parameter));
4912 Constrained := not Transmit_As_Unconstrained (Etyp);
4914 if In_Present (Current_Parameter)
4915 or else not Out_Present (Current_Parameter)
4916 or else not Constrained
4917 or else Is_Controlling_Formal
4919 -- If an input parameter is constrained, then the read of
4920 -- the parameter is deferred until the beginning of the
4921 -- subprogram body. If it is unconstrained, then an
4922 -- expression is built for the object declaration and the
4923 -- variable is set using 'Input instead of 'Read. Note that
4924 -- this deferral does not change the order in which the
4925 -- actuals are read because Build_Ordered_Parameter_List
4926 -- puts them unconstrained first.
4929 Append_To (Statements,
4930 Make_Attribute_Reference (Loc,
4931 Prefix => New_Occurrence_Of (Etyp, Loc),
4932 Attribute_Name => Name_Read,
4933 Expressions => New_List (
4934 Make_Selected_Component (Loc,
4935 Prefix => Request_Parameter,
4936 Selector_Name => Name_Params),
4937 New_Occurrence_Of (Object, Loc))));
4941 -- Build and append Input_With_Tag_Check function
4944 Input_With_Tag_Check (Loc,
4947 Make_Selected_Component (Loc,
4948 Prefix => Request_Parameter,
4949 Selector_Name => Name_Params)));
4951 -- Prepare function call expression
4954 Make_Function_Call (Loc,
4958 (Specification (Last (Decls))), Loc));
4962 Need_Extra_Constrained :=
4963 Nkind (Parameter_Type (Current_Parameter)) /=
4966 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4968 Present (Extra_Constrained
4969 (Defining_Identifier (Current_Parameter)));
4971 -- We may not associate an extra constrained actual to a
4972 -- constant object, so if one is needed, declare the actual
4973 -- as a variable even if it won't be modified.
4975 Build_Actual_Object_Declaration
4978 Variable => Need_Extra_Constrained
4979 or else Out_Present (Current_Parameter),
4983 -- An out parameter may be written back using a 'Write
4984 -- attribute instead of a 'Output because it has been
4985 -- constrained by the parameter given to the caller. Note that
4986 -- out controlling arguments in the case of a RACW are not put
4987 -- back in the stream because the pointer on them has not
4990 if Out_Present (Current_Parameter)
4992 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4994 Append_To (After_Statements,
4995 Make_Attribute_Reference (Loc,
4996 Prefix => New_Occurrence_Of (Etyp, Loc),
4997 Attribute_Name => Name_Write,
4998 Expressions => New_List (
4999 Make_Selected_Component (Loc,
5000 Prefix => Request_Parameter,
5001 Selector_Name => Name_Result),
5002 New_Occurrence_Of (Object, Loc))));
5005 -- For RACW controlling formals, the Etyp of Object is always
5006 -- an RACW, even if the parameter is not of an anonymous access
5007 -- type. In such case, we need to dereference it at call time.
5009 if Is_Controlling_Formal then
5010 if Nkind (Parameter_Type (Current_Parameter)) /=
5013 Append_To (Parameter_List,
5014 Make_Parameter_Association (Loc,
5017 Defining_Identifier (Current_Parameter), Loc),
5018 Explicit_Actual_Parameter =>
5019 Make_Explicit_Dereference (Loc,
5020 Unchecked_Convert_To (RACW_Type,
5021 OK_Convert_To (RTE (RE_Address),
5022 New_Occurrence_Of (Object, Loc))))));
5025 Append_To (Parameter_List,
5026 Make_Parameter_Association (Loc,
5029 Defining_Identifier (Current_Parameter), Loc),
5030 Explicit_Actual_Parameter =>
5031 Unchecked_Convert_To (RACW_Type,
5032 OK_Convert_To (RTE (RE_Address),
5033 New_Occurrence_Of (Object, Loc)))));
5037 Append_To (Parameter_List,
5038 Make_Parameter_Association (Loc,
5041 Defining_Identifier (Current_Parameter), Loc),
5042 Explicit_Actual_Parameter =>
5043 New_Occurrence_Of (Object, Loc)));
5046 -- If the current parameter needs an extra formal, then read it
5047 -- from the stream and set the corresponding semantic field in
5048 -- the variable. If the kind of the parameter identifier is
5049 -- E_Void, then this is a compiler generated parameter that
5050 -- doesn't need an extra constrained status.
5052 -- The case of Extra_Accessibility should also be handled ???
5054 if Need_Extra_Constrained then
5056 Extra_Parameter : constant Entity_Id :=
5058 (Defining_Identifier
5059 (Current_Parameter));
5061 Formal_Entity : constant Entity_Id :=
5062 Make_Defining_Identifier
5063 (Loc, Chars (Extra_Parameter));
5065 Formal_Type : constant Entity_Id :=
5066 Etype (Extra_Parameter);
5070 Make_Object_Declaration (Loc,
5071 Defining_Identifier => Formal_Entity,
5072 Object_Definition =>
5073 New_Occurrence_Of (Formal_Type, Loc)));
5075 Append_To (Extra_Formal_Statements,
5076 Make_Attribute_Reference (Loc,
5077 Prefix => New_Occurrence_Of (
5079 Attribute_Name => Name_Read,
5080 Expressions => New_List (
5081 Make_Selected_Component (Loc,
5082 Prefix => Request_Parameter,
5083 Selector_Name => Name_Params),
5084 New_Occurrence_Of (Formal_Entity, Loc))));
5086 -- Note: the call to Set_Extra_Constrained below relies
5087 -- on the fact that Object's Ekind has been set by
5088 -- Build_Actual_Object_Declaration.
5090 Set_Extra_Constrained (Object, Formal_Entity);
5095 Next (Current_Parameter);
5098 -- Append the formal statements list at the end of regular statements
5100 Append_List_To (Statements, Extra_Formal_Statements);
5102 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
5104 -- The remote subprogram is a function. We build an inner block to
5105 -- be able to hold a potentially unconstrained result in a
5109 Etyp : constant Entity_Id :=
5110 Etype (Result_Definition (Specification (Vis_Decl)));
5111 Result : constant Node_Id := Make_Temporary (Loc, 'R');
5114 Inner_Decls := New_List (
5115 Make_Object_Declaration (Loc,
5116 Defining_Identifier => Result,
5117 Constant_Present => True,
5118 Object_Definition => New_Occurrence_Of (Etyp, Loc),
5120 Make_Function_Call (Loc,
5121 Name => Called_Subprogram,
5122 Parameter_Associations => Parameter_List)));
5124 if Is_Class_Wide_Type (Etyp) then
5126 -- For a remote call to a function with a class-wide type,
5127 -- check that the returned value satisfies the requirements
5130 Append_To (Inner_Decls,
5131 Make_Transportable_Check (Loc,
5132 New_Occurrence_Of (Result, Loc)));
5136 Append_To (After_Statements,
5137 Make_Attribute_Reference (Loc,
5138 Prefix => New_Occurrence_Of (Etyp, Loc),
5139 Attribute_Name => Name_Output,
5140 Expressions => New_List (
5141 Make_Selected_Component (Loc,
5142 Prefix => Request_Parameter,
5143 Selector_Name => Name_Result),
5144 New_Occurrence_Of (Result, Loc))));
5147 Append_To (Statements,
5148 Make_Block_Statement (Loc,
5149 Declarations => Inner_Decls,
5150 Handled_Statement_Sequence =>
5151 Make_Handled_Sequence_Of_Statements (Loc,
5152 Statements => After_Statements)));
5155 -- The remote subprogram is a procedure. We do not need any inner
5156 -- block in this case.
5158 if Dynamically_Asynchronous then
5160 Make_Object_Declaration (Loc,
5161 Defining_Identifier => Dynamic_Async,
5162 Object_Definition =>
5163 New_Occurrence_Of (Standard_Boolean, Loc)));
5165 Append_To (Statements,
5166 Make_Attribute_Reference (Loc,
5167 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5168 Attribute_Name => Name_Read,
5169 Expressions => New_List (
5170 Make_Selected_Component (Loc,
5171 Prefix => Request_Parameter,
5172 Selector_Name => Name_Params),
5173 New_Occurrence_Of (Dynamic_Async, Loc))));
5176 Append_To (Statements,
5177 Make_Procedure_Call_Statement (Loc,
5178 Name => Called_Subprogram,
5179 Parameter_Associations => Parameter_List));
5181 Append_List_To (Statements, After_Statements);
5184 if Asynchronous and then not Dynamically_Asynchronous then
5186 -- For an asynchronous procedure, add a null exception handler
5188 Excep_Handlers := New_List (
5189 Make_Implicit_Exception_Handler (Loc,
5190 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5191 Statements => New_List (Make_Null_Statement (Loc))));
5194 -- In the other cases, if an exception is raised, then the
5195 -- exception occurrence is copied into the output stream and
5196 -- no other output parameter is written.
5198 Excep_Choice := Make_Temporary (Loc, 'E');
5200 Excep_Code := New_List (
5201 Make_Attribute_Reference (Loc,
5203 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5204 Attribute_Name => Name_Write,
5205 Expressions => New_List (
5206 Make_Selected_Component (Loc,
5207 Prefix => Request_Parameter,
5208 Selector_Name => Name_Result),
5209 New_Occurrence_Of (Excep_Choice, Loc))));
5211 if Dynamically_Asynchronous then
5212 Excep_Code := New_List (
5213 Make_Implicit_If_Statement (Vis_Decl,
5214 Condition => Make_Op_Not (Loc,
5215 New_Occurrence_Of (Dynamic_Async, Loc)),
5216 Then_Statements => Excep_Code));
5219 Excep_Handlers := New_List (
5220 Make_Implicit_Exception_Handler (Loc,
5221 Choice_Parameter => Excep_Choice,
5222 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5223 Statements => Excep_Code));
5228 Make_Procedure_Specification (Loc,
5229 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
5231 Parameter_Specifications => New_List (
5232 Make_Parameter_Specification (Loc,
5233 Defining_Identifier => Request_Parameter,
5235 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5238 Make_Subprogram_Body (Loc,
5239 Specification => Subp_Spec,
5240 Declarations => Decls,
5241 Handled_Statement_Sequence =>
5242 Make_Handled_Sequence_Of_Statements (Loc,
5243 Statements => Statements,
5244 Exception_Handlers => Excep_Handlers));
5245 end Build_Subprogram_Receiving_Stubs;
5251 function Result return Node_Id is
5253 return Make_Identifier (Loc, Name_V);
5256 ----------------------
5257 -- Stream_Parameter --
5258 ----------------------
5260 function Stream_Parameter return Node_Id is
5262 return Make_Identifier (Loc, Name_S);
5263 end Stream_Parameter;
5267 -------------------------------
5268 -- Get_And_Reset_RACW_Bodies --
5269 -------------------------------
5271 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5272 Desig : constant Entity_Id :=
5273 Etype (Designated_Type (RACW_Type));
5275 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5277 Body_Decls : List_Id;
5278 -- Returned list of declarations
5281 if Stub_Elements = Empty_Stub_Structure then
5283 -- Stub elements may be missing as a consequence of a previously
5289 Body_Decls := Stub_Elements.Body_Decls;
5290 Stub_Elements.Body_Decls := No_List;
5291 Stubs_Table.Set (Desig, Stub_Elements);
5293 end Get_And_Reset_RACW_Bodies;
5295 -----------------------
5296 -- Get_Stub_Elements --
5297 -----------------------
5299 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is
5300 Desig : constant Entity_Id :=
5301 Etype (Designated_Type (RACW_Type));
5302 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
5304 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5305 return Stub_Elements;
5306 end Get_Stub_Elements;
5308 -----------------------
5309 -- Get_Subprogram_Id --
5310 -----------------------
5312 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5313 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5315 pragma Assert (Result /= No_String);
5317 end Get_Subprogram_Id;
5319 -----------------------
5320 -- Get_Subprogram_Id --
5321 -----------------------
5323 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5325 return Get_Subprogram_Ids (Def).Int_Identifier;
5326 end Get_Subprogram_Id;
5328 ------------------------
5329 -- Get_Subprogram_Ids --
5330 ------------------------
5332 function Get_Subprogram_Ids
5333 (Def : Entity_Id) return Subprogram_Identifiers
5336 return Subprogram_Identifier_Table.Get (Def);
5337 end Get_Subprogram_Ids;
5343 function Hash (F : Entity_Id) return Hash_Index is
5345 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5348 function Hash (F : Name_Id) return Hash_Index is
5350 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5353 --------------------------
5354 -- Input_With_Tag_Check --
5355 --------------------------
5357 function Input_With_Tag_Check
5359 Var_Type : Entity_Id;
5360 Stream : Node_Id) return Node_Id
5364 Make_Subprogram_Body (Loc,
5366 Make_Function_Specification (Loc,
5367 Defining_Unit_Name => Make_Temporary (Loc, 'S'),
5368 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5369 Declarations => No_List,
5370 Handled_Statement_Sequence =>
5371 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5372 Make_Tag_Check (Loc,
5373 Make_Simple_Return_Statement (Loc,
5374 Make_Attribute_Reference (Loc,
5375 Prefix => New_Occurrence_Of (Var_Type, Loc),
5376 Attribute_Name => Name_Input,
5378 New_List (Stream)))))));
5379 end Input_With_Tag_Check;
5381 --------------------------------
5382 -- Is_RACW_Controlling_Formal --
5383 --------------------------------
5385 function Is_RACW_Controlling_Formal
5386 (Parameter : Node_Id;
5387 Stub_Type : Entity_Id) return Boolean
5392 -- If the kind of the parameter is E_Void, then it is not a controlling
5393 -- formal (this can happen in the context of RAS).
5395 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5399 -- If the parameter is not a controlling formal, then it cannot be
5400 -- possibly a RACW_Controlling_Formal.
5402 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5406 Typ := Parameter_Type (Parameter);
5407 return (Nkind (Typ) = N_Access_Definition
5408 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5409 or else Etype (Typ) = Stub_Type;
5410 end Is_RACW_Controlling_Formal;
5412 ------------------------------
5413 -- Make_Transportable_Check --
5414 ------------------------------
5416 function Make_Transportable_Check
5418 Expr : Node_Id) return Node_Id is
5421 Make_Raise_Program_Error (Loc,
5424 Build_Get_Transportable (Loc,
5425 Make_Selected_Component (Loc,
5427 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5428 Reason => PE_Non_Transportable_Actual);
5429 end Make_Transportable_Check;
5431 -----------------------------
5432 -- Make_Selected_Component --
5433 -----------------------------
5435 function Make_Selected_Component
5438 Selector_Name : Name_Id) return Node_Id
5441 return Make_Selected_Component (Loc,
5442 Prefix => New_Occurrence_Of (Prefix, Loc),
5443 Selector_Name => Make_Identifier (Loc, Selector_Name));
5444 end Make_Selected_Component;
5446 --------------------
5447 -- Make_Tag_Check --
5448 --------------------
5450 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5451 Occ : constant Entity_Id := Make_Temporary (Loc, 'E');
5454 return Make_Block_Statement (Loc,
5455 Handled_Statement_Sequence =>
5456 Make_Handled_Sequence_Of_Statements (Loc,
5457 Statements => New_List (N),
5459 Exception_Handlers => New_List (
5460 Make_Implicit_Exception_Handler (Loc,
5461 Choice_Parameter => Occ,
5463 Exception_Choices =>
5464 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5467 New_List (Make_Procedure_Call_Statement (Loc,
5469 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5470 New_List (New_Occurrence_Of (Occ, Loc))))))));
5473 ----------------------------
5474 -- Need_Extra_Constrained --
5475 ----------------------------
5477 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5478 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5480 return Out_Present (Parameter)
5481 and then Has_Discriminants (Etyp)
5482 and then not Is_Constrained (Etyp)
5483 and then not Is_Indefinite_Subtype (Etyp);
5484 end Need_Extra_Constrained;
5486 ------------------------------------
5487 -- Pack_Entity_Into_Stream_Access --
5488 ------------------------------------
5490 function Pack_Entity_Into_Stream_Access
5494 Etyp : Entity_Id := Empty) return Node_Id
5499 if Present (Etyp) then
5502 Typ := Etype (Object);
5506 Pack_Node_Into_Stream_Access (Loc,
5508 Object => New_Occurrence_Of (Object, Loc),
5510 end Pack_Entity_Into_Stream_Access;
5512 ---------------------------
5513 -- Pack_Node_Into_Stream --
5514 ---------------------------
5516 function Pack_Node_Into_Stream
5520 Etyp : Entity_Id) return Node_Id
5522 Write_Attribute : Name_Id := Name_Write;
5525 if not Is_Constrained (Etyp) then
5526 Write_Attribute := Name_Output;
5530 Make_Attribute_Reference (Loc,
5531 Prefix => New_Occurrence_Of (Etyp, Loc),
5532 Attribute_Name => Write_Attribute,
5533 Expressions => New_List (
5534 Make_Attribute_Reference (Loc,
5535 Prefix => New_Occurrence_Of (Stream, Loc),
5536 Attribute_Name => Name_Access),
5538 end Pack_Node_Into_Stream;
5540 ----------------------------------
5541 -- Pack_Node_Into_Stream_Access --
5542 ----------------------------------
5544 function Pack_Node_Into_Stream_Access
5548 Etyp : Entity_Id) return Node_Id
5550 Write_Attribute : Name_Id := Name_Write;
5553 if not Is_Constrained (Etyp) then
5554 Write_Attribute := Name_Output;
5558 Make_Attribute_Reference (Loc,
5559 Prefix => New_Occurrence_Of (Etyp, Loc),
5560 Attribute_Name => Write_Attribute,
5561 Expressions => New_List (
5564 end Pack_Node_Into_Stream_Access;
5566 ---------------------
5567 -- PolyORB_Support --
5568 ---------------------
5570 package body PolyORB_Support is
5572 -- Local subprograms
5574 procedure Add_RACW_Read_Attribute
5575 (RACW_Type : Entity_Id;
5576 Stub_Type : Entity_Id;
5577 Stub_Type_Access : Entity_Id;
5578 Body_Decls : List_Id);
5579 -- Add Read attribute for the RACW type. The declaration and attribute
5580 -- definition clauses are inserted right after the declaration of
5581 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5582 -- appended to it (case where the RACW declaration is in the main unit).
5584 procedure Add_RACW_Write_Attribute
5585 (RACW_Type : Entity_Id;
5586 Stub_Type : Entity_Id;
5587 Stub_Type_Access : Entity_Id;
5588 Body_Decls : List_Id);
5589 -- Same as above for the Write attribute
5591 procedure Add_RACW_From_Any
5592 (RACW_Type : Entity_Id;
5593 Body_Decls : List_Id);
5594 -- Add the From_Any TSS for this RACW type
5596 procedure Add_RACW_To_Any
5597 (RACW_Type : Entity_Id;
5598 Body_Decls : List_Id);
5599 -- Add the To_Any TSS for this RACW type
5601 procedure Add_RACW_TypeCode
5602 (Designated_Type : Entity_Id;
5603 RACW_Type : Entity_Id;
5604 Body_Decls : List_Id);
5605 -- Add the TypeCode TSS for this RACW type
5607 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5608 -- Add the From_Any TSS for this RAS type
5610 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5611 -- Add the To_Any TSS for this RAS type
5613 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5614 -- Add the TypeCode TSS for this RAS type
5616 procedure Add_RAS_Access_TSS (N : Node_Id);
5617 -- Add a subprogram body for RAS Access TSS
5619 -------------------------------------
5620 -- Add_Obj_RPC_Receiver_Completion --
5621 -------------------------------------
5623 procedure Add_Obj_RPC_Receiver_Completion
5626 RPC_Receiver : Entity_Id;
5627 Stub_Elements : Stub_Structure)
5629 Desig : constant Entity_Id :=
5630 Etype (Designated_Type (Stub_Elements.RACW_Type));
5633 Make_Procedure_Call_Statement (Loc,
5636 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5638 Parameter_Associations => New_List (
5642 Make_String_Literal (Loc,
5643 Fully_Qualified_Name_String (Desig)),
5647 Make_Attribute_Reference (Loc,
5650 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5656 Make_Attribute_Reference (Loc,
5659 Defining_Identifier (
5660 Stub_Elements.RPC_Receiver_Decl), Loc),
5663 end Add_Obj_RPC_Receiver_Completion;
5665 -----------------------
5666 -- Add_RACW_Features --
5667 -----------------------
5669 procedure Add_RACW_Features
5670 (RACW_Type : Entity_Id;
5672 Stub_Type : Entity_Id;
5673 Stub_Type_Access : Entity_Id;
5674 RPC_Receiver_Decl : Node_Id;
5675 Body_Decls : List_Id)
5677 pragma Unreferenced (RPC_Receiver_Decl);
5681 (RACW_Type => RACW_Type,
5682 Body_Decls => Body_Decls);
5685 (RACW_Type => RACW_Type,
5686 Body_Decls => Body_Decls);
5688 Add_RACW_Write_Attribute
5689 (RACW_Type => RACW_Type,
5690 Stub_Type => Stub_Type,
5691 Stub_Type_Access => Stub_Type_Access,
5692 Body_Decls => Body_Decls);
5694 Add_RACW_Read_Attribute
5695 (RACW_Type => RACW_Type,
5696 Stub_Type => Stub_Type,
5697 Stub_Type_Access => Stub_Type_Access,
5698 Body_Decls => Body_Decls);
5701 (Designated_Type => Desig,
5702 RACW_Type => RACW_Type,
5703 Body_Decls => Body_Decls);
5704 end Add_RACW_Features;
5706 -----------------------
5707 -- Add_RACW_From_Any --
5708 -----------------------
5710 procedure Add_RACW_From_Any
5711 (RACW_Type : Entity_Id;
5712 Body_Decls : List_Id)
5714 Loc : constant Source_Ptr := Sloc (RACW_Type);
5715 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5716 Fnam : constant Entity_Id :=
5717 Make_Defining_Identifier (Loc,
5718 Chars => New_External_Name (Chars (RACW_Type), 'F'));
5720 Func_Spec : Node_Id;
5721 Func_Decl : Node_Id;
5722 Func_Body : Node_Id;
5724 Statements : List_Id;
5725 -- Various parts of the subprogram
5727 Any_Parameter : constant Entity_Id :=
5728 Make_Defining_Identifier (Loc, Name_A);
5730 Asynchronous_Flag : constant Entity_Id :=
5731 Asynchronous_Flags_Table.Get (RACW_Type);
5732 -- The flag object declared in Add_RACW_Asynchronous_Flag
5736 Make_Function_Specification (Loc,
5737 Defining_Unit_Name =>
5739 Parameter_Specifications => New_List (
5740 Make_Parameter_Specification (Loc,
5741 Defining_Identifier =>
5744 New_Occurrence_Of (RTE (RE_Any), Loc))),
5745 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5747 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5748 -- entity in the declaration spec, not those of the body spec.
5750 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5751 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5752 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5754 if No (Body_Decls) then
5758 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5759 -- set on the stub type if, and only if, the RACW type has a pragma
5760 -- Asynchronous. This is incorrect for RACWs that implement RAS
5761 -- types, because in that case the /designated subprogram/ (not the
5762 -- type) might be asynchronous, and that causes the stub to need to
5763 -- be asynchronous too. A solution is to transport a RAS as a struct
5764 -- containing a RACW and an asynchronous flag, and to properly alter
5765 -- the Asynchronous component in the stub type in the RAS's _From_Any
5768 Statements := New_List (
5769 Make_Simple_Return_Statement (Loc,
5770 Expression => Unchecked_Convert_To (RACW_Type,
5771 Make_Function_Call (Loc,
5772 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5773 Parameter_Associations => New_List (
5774 Make_Function_Call (Loc,
5775 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5776 Parameter_Associations => New_List (
5777 New_Occurrence_Of (Any_Parameter, Loc))),
5778 Build_Stub_Tag (Loc, RACW_Type),
5779 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5780 New_Occurrence_Of (Asynchronous_Flag, Loc))))));
5783 Make_Subprogram_Body (Loc,
5784 Specification => Copy_Specification (Loc, Func_Spec),
5785 Declarations => No_List,
5786 Handled_Statement_Sequence =>
5787 Make_Handled_Sequence_Of_Statements (Loc,
5788 Statements => Statements));
5790 Append_To (Body_Decls, Func_Body);
5791 end Add_RACW_From_Any;
5793 -----------------------------
5794 -- Add_RACW_Read_Attribute --
5795 -----------------------------
5797 procedure Add_RACW_Read_Attribute
5798 (RACW_Type : Entity_Id;
5799 Stub_Type : Entity_Id;
5800 Stub_Type_Access : Entity_Id;
5801 Body_Decls : List_Id)
5803 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5805 Loc : constant Source_Ptr := Sloc (RACW_Type);
5807 Proc_Decl : Node_Id;
5808 Attr_Decl : Node_Id;
5810 Body_Node : Node_Id;
5812 Decls : constant List_Id := New_List;
5813 Statements : constant List_Id := New_List;
5814 Reference : constant Entity_Id :=
5815 Make_Defining_Identifier (Loc, Name_R);
5816 -- Various parts of the procedure
5818 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
5820 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5822 Asynchronous_Flag : constant Entity_Id :=
5823 Asynchronous_Flags_Table.Get (RACW_Type);
5824 pragma Assert (Present (Asynchronous_Flag));
5826 function Stream_Parameter return Node_Id;
5827 function Result return Node_Id;
5829 -- Functions to create occurrences of the formal parameter names
5835 function Result return Node_Id is
5837 return Make_Identifier (Loc, Name_V);
5840 ----------------------
5841 -- Stream_Parameter --
5842 ----------------------
5844 function Stream_Parameter return Node_Id is
5846 return Make_Identifier (Loc, Name_S);
5847 end Stream_Parameter;
5849 -- Start of processing for Add_RACW_Read_Attribute
5852 Build_Stream_Procedure
5853 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
5855 Proc_Decl := Make_Subprogram_Declaration (Loc,
5856 Copy_Specification (Loc, Specification (Body_Node)));
5859 Make_Attribute_Definition_Clause (Loc,
5860 Name => New_Occurrence_Of (RACW_Type, Loc),
5864 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5866 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5867 Insert_After (Proc_Decl, Attr_Decl);
5869 if No (Body_Decls) then
5874 Make_Object_Declaration (Loc,
5875 Defining_Identifier =>
5877 Object_Definition =>
5878 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5880 Append_List_To (Statements, New_List (
5881 Make_Attribute_Reference (Loc,
5883 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5884 Attribute_Name => Name_Read,
5885 Expressions => New_List (
5887 New_Occurrence_Of (Reference, Loc))),
5889 Make_Assignment_Statement (Loc,
5893 Unchecked_Convert_To (RACW_Type,
5894 Make_Function_Call (Loc,
5896 New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5897 Parameter_Associations => New_List (
5898 New_Occurrence_Of (Reference, Loc),
5899 Build_Stub_Tag (Loc, RACW_Type),
5900 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5901 New_Occurrence_Of (Asynchronous_Flag, Loc)))))));
5903 Set_Declarations (Body_Node, Decls);
5904 Append_To (Body_Decls, Body_Node);
5905 end Add_RACW_Read_Attribute;
5907 ---------------------
5908 -- Add_RACW_To_Any --
5909 ---------------------
5911 procedure Add_RACW_To_Any
5912 (RACW_Type : Entity_Id;
5913 Body_Decls : List_Id)
5915 Loc : constant Source_Ptr := Sloc (RACW_Type);
5917 Fnam : constant Entity_Id :=
5918 Make_Defining_Identifier (Loc,
5919 Chars => New_External_Name (Chars (RACW_Type), 'T'));
5921 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5923 Stub_Elements : constant Stub_Structure :=
5924 Get_Stub_Elements (RACW_Type);
5926 Func_Spec : Node_Id;
5927 Func_Decl : Node_Id;
5928 Func_Body : Node_Id;
5931 Statements : List_Id;
5932 -- Various parts of the subprogram
5934 RACW_Parameter : constant Entity_Id :=
5935 Make_Defining_Identifier (Loc, Name_R);
5937 Reference : constant Entity_Id := Make_Temporary (Loc, 'R');
5938 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
5942 Make_Function_Specification (Loc,
5943 Defining_Unit_Name =>
5945 Parameter_Specifications => New_List (
5946 Make_Parameter_Specification (Loc,
5947 Defining_Identifier =>
5950 New_Occurrence_Of (RACW_Type, Loc))),
5951 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5953 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5954 -- entity in the declaration spec, not in the body spec.
5956 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5958 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5959 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5961 if No (Body_Decls) then
5967 -- R : constant Object_Ref :=
5973 -- RPC_Receiver'Access);
5977 Make_Object_Declaration (Loc,
5978 Defining_Identifier => Reference,
5979 Constant_Present => True,
5980 Object_Definition =>
5981 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5983 Make_Function_Call (Loc,
5984 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5985 Parameter_Associations => New_List (
5986 Unchecked_Convert_To (RTE (RE_Address),
5987 New_Occurrence_Of (RACW_Parameter, Loc)),
5988 Make_String_Literal (Loc,
5989 Strval => Fully_Qualified_Name_String
5990 (Etype (Designated_Type (RACW_Type)))),
5991 Build_Stub_Tag (Loc, RACW_Type),
5992 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5993 Make_Attribute_Reference (Loc,
5996 (Defining_Identifier
5997 (Stub_Elements.RPC_Receiver_Decl), Loc),
5998 Attribute_Name => Name_Access)))),
6000 Make_Object_Declaration (Loc,
6001 Defining_Identifier => Any,
6002 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)));
6006 -- Any := TA_ObjRef (Reference);
6007 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
6010 Statements := New_List (
6011 Make_Assignment_Statement (Loc,
6012 Name => New_Occurrence_Of (Any, Loc),
6014 Make_Function_Call (Loc,
6015 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
6016 Parameter_Associations => New_List (
6017 New_Occurrence_Of (Reference, Loc)))),
6019 Make_Procedure_Call_Statement (Loc,
6020 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6021 Parameter_Associations => New_List (
6022 New_Occurrence_Of (Any, Loc),
6023 Make_Selected_Component (Loc,
6025 Defining_Identifier (
6026 Stub_Elements.RPC_Receiver_Decl),
6027 Selector_Name => Name_Obj_TypeCode))),
6029 Make_Simple_Return_Statement (Loc,
6030 Expression => New_Occurrence_Of (Any, Loc)));
6033 Make_Subprogram_Body (Loc,
6034 Specification => Copy_Specification (Loc, Func_Spec),
6035 Declarations => Decls,
6036 Handled_Statement_Sequence =>
6037 Make_Handled_Sequence_Of_Statements (Loc,
6038 Statements => Statements));
6039 Append_To (Body_Decls, Func_Body);
6040 end Add_RACW_To_Any;
6042 -----------------------
6043 -- Add_RACW_TypeCode --
6044 -----------------------
6046 procedure Add_RACW_TypeCode
6047 (Designated_Type : Entity_Id;
6048 RACW_Type : Entity_Id;
6049 Body_Decls : List_Id)
6051 Loc : constant Source_Ptr := Sloc (RACW_Type);
6053 Fnam : constant Entity_Id :=
6054 Make_Defining_Identifier (Loc,
6055 Chars => New_External_Name (Chars (RACW_Type), 'Y'));
6057 Stub_Elements : constant Stub_Structure :=
6058 Stubs_Table.Get (Designated_Type);
6059 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6061 Func_Spec : Node_Id;
6062 Func_Decl : Node_Id;
6063 Func_Body : Node_Id;
6066 -- The spec for this subprogram has a dummy 'access RACW' argument,
6067 -- which serves only for overloading purposes.
6070 Make_Function_Specification (Loc,
6071 Defining_Unit_Name => Fnam,
6072 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6074 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6075 -- entity in the declaration spec, not those of the body spec.
6077 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6078 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6079 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6081 if No (Body_Decls) then
6086 Make_Subprogram_Body (Loc,
6087 Specification => Copy_Specification (Loc, Func_Spec),
6088 Declarations => Empty_List,
6089 Handled_Statement_Sequence =>
6090 Make_Handled_Sequence_Of_Statements (Loc,
6091 Statements => New_List (
6092 Make_Simple_Return_Statement (Loc,
6094 Make_Selected_Component (Loc,
6097 (Stub_Elements.RPC_Receiver_Decl),
6098 Selector_Name => Name_Obj_TypeCode)))));
6100 Append_To (Body_Decls, Func_Body);
6101 end Add_RACW_TypeCode;
6103 ------------------------------
6104 -- Add_RACW_Write_Attribute --
6105 ------------------------------
6107 procedure Add_RACW_Write_Attribute
6108 (RACW_Type : Entity_Id;
6109 Stub_Type : Entity_Id;
6110 Stub_Type_Access : Entity_Id;
6111 Body_Decls : List_Id)
6113 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6115 Loc : constant Source_Ptr := Sloc (RACW_Type);
6117 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
6119 Stub_Elements : constant Stub_Structure :=
6120 Get_Stub_Elements (RACW_Type);
6122 Body_Node : Node_Id;
6123 Proc_Decl : Node_Id;
6124 Attr_Decl : Node_Id;
6126 Statements : constant List_Id := New_List;
6127 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
6129 function Stream_Parameter return Node_Id;
6130 function Object return Node_Id;
6131 -- Functions to create occurrences of the formal parameter names
6137 function Object return Node_Id is
6139 return Make_Identifier (Loc, Name_V);
6142 ----------------------
6143 -- Stream_Parameter --
6144 ----------------------
6146 function Stream_Parameter return Node_Id is
6148 return Make_Identifier (Loc, Name_S);
6149 end Stream_Parameter;
6151 -- Start of processing for Add_RACW_Write_Attribute
6154 Build_Stream_Procedure
6155 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
6158 Make_Subprogram_Declaration (Loc,
6159 Copy_Specification (Loc, Specification (Body_Node)));
6162 Make_Attribute_Definition_Clause (Loc,
6163 Name => New_Occurrence_Of (RACW_Type, Loc),
6164 Chars => Name_Write,
6167 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6169 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6170 Insert_After (Proc_Decl, Attr_Decl);
6172 if No (Body_Decls) then
6176 Append_To (Statements,
6177 Pack_Node_Into_Stream_Access (Loc,
6178 Stream => Stream_Parameter,
6180 Make_Function_Call (Loc,
6181 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6182 Parameter_Associations => New_List (
6183 Unchecked_Convert_To (RTE (RE_Address), Object),
6184 Make_String_Literal (Loc,
6185 Strval => Fully_Qualified_Name_String
6186 (Etype (Designated_Type (RACW_Type)))),
6187 Build_Stub_Tag (Loc, RACW_Type),
6188 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
6189 Make_Attribute_Reference (Loc,
6192 (Defining_Identifier
6193 (Stub_Elements.RPC_Receiver_Decl), Loc),
6194 Attribute_Name => Name_Access))),
6196 Etyp => RTE (RE_Object_Ref)));
6198 Append_To (Body_Decls, Body_Node);
6199 end Add_RACW_Write_Attribute;
6201 -----------------------
6202 -- Add_RAST_Features --
6203 -----------------------
6205 procedure Add_RAST_Features
6206 (Vis_Decl : Node_Id;
6207 RAS_Type : Entity_Id)
6210 Add_RAS_Access_TSS (Vis_Decl);
6212 Add_RAS_From_Any (RAS_Type);
6213 Add_RAS_TypeCode (RAS_Type);
6215 -- To_Any uses TypeCode, and therefore needs to be generated last
6217 Add_RAS_To_Any (RAS_Type);
6218 end Add_RAST_Features;
6220 ------------------------
6221 -- Add_RAS_Access_TSS --
6222 ------------------------
6224 procedure Add_RAS_Access_TSS (N : Node_Id) is
6225 Loc : constant Source_Ptr := Sloc (N);
6227 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6228 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6229 -- Ras_Type is the access to subprogram type; Fat_Type is the
6230 -- corresponding record type.
6232 RACW_Type : constant Entity_Id :=
6233 Underlying_RACW_Type (Ras_Type);
6235 Stub_Elements : constant Stub_Structure :=
6236 Get_Stub_Elements (RACW_Type);
6238 Proc : constant Entity_Id :=
6239 Make_Defining_Identifier (Loc,
6240 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6242 Proc_Spec : Node_Id;
6244 -- Formal parameters
6246 Package_Name : constant Entity_Id :=
6247 Make_Defining_Identifier (Loc,
6252 Subp_Id : constant Entity_Id :=
6253 Make_Defining_Identifier (Loc,
6256 -- Target subprogram
6258 Asynch_P : constant Entity_Id :=
6259 Make_Defining_Identifier (Loc,
6260 Chars => Name_Asynchronous);
6261 -- Is the procedure to which the 'Access applies asynchronous?
6263 All_Calls_Remote : constant Entity_Id :=
6264 Make_Defining_Identifier (Loc,
6265 Chars => Name_All_Calls_Remote);
6266 -- True if an All_Calls_Remote pragma applies to the RCI unit
6267 -- that contains the subprogram.
6269 -- Common local variables
6271 Proc_Decls : List_Id;
6272 Proc_Statements : List_Id;
6274 Subp_Ref : constant Entity_Id :=
6275 Make_Defining_Identifier (Loc, Name_R);
6276 -- Reference that designates the target subprogram (returned
6277 -- by Get_RAS_Info).
6279 Is_Local : constant Entity_Id :=
6280 Make_Defining_Identifier (Loc, Name_L);
6281 Local_Addr : constant Entity_Id :=
6282 Make_Defining_Identifier (Loc, Name_A);
6283 -- For the call to Get_Local_Address
6285 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
6286 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
6287 -- Additional local variables for the remote case
6290 (Field_Name : Name_Id;
6291 Value : Node_Id) return Node_Id;
6292 -- Construct an assignment that sets the named component in the
6300 (Field_Name : Name_Id;
6301 Value : Node_Id) return Node_Id
6305 Make_Assignment_Statement (Loc,
6307 Make_Selected_Component (Loc,
6309 Selector_Name => Field_Name),
6310 Expression => Value);
6313 -- Start of processing for Add_RAS_Access_TSS
6316 Proc_Decls := New_List (
6318 -- Common declarations
6320 Make_Object_Declaration (Loc,
6321 Defining_Identifier => Subp_Ref,
6322 Object_Definition =>
6323 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6325 Make_Object_Declaration (Loc,
6326 Defining_Identifier => Is_Local,
6327 Object_Definition =>
6328 New_Occurrence_Of (Standard_Boolean, Loc)),
6330 Make_Object_Declaration (Loc,
6331 Defining_Identifier => Local_Addr,
6332 Object_Definition =>
6333 New_Occurrence_Of (RTE (RE_Address), Loc)),
6335 Make_Object_Declaration (Loc,
6336 Defining_Identifier => Local_Stub,
6337 Aliased_Present => True,
6338 Object_Definition =>
6339 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6341 Make_Object_Declaration (Loc,
6342 Defining_Identifier => Stub_Ptr,
6343 Object_Definition =>
6344 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6346 Make_Attribute_Reference (Loc,
6347 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6348 Attribute_Name => Name_Unchecked_Access)));
6350 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6351 -- Build_Get_Unique_RP_Call needs this information
6353 -- Get_RAS_Info (Pkg, Subp, R);
6354 -- Obtain a reference to the target subprogram
6356 Proc_Statements := New_List (
6357 Make_Procedure_Call_Statement (Loc,
6358 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6359 Parameter_Associations => New_List (
6360 New_Occurrence_Of (Package_Name, Loc),
6361 New_Occurrence_Of (Subp_Id, Loc),
6362 New_Occurrence_Of (Subp_Ref, Loc))),
6364 -- Get_Local_Address (R, L, A);
6365 -- Determine whether the subprogram is local (L), and if so
6366 -- obtain the local address of its proxy (A).
6368 Make_Procedure_Call_Statement (Loc,
6369 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6370 Parameter_Associations => New_List (
6371 New_Occurrence_Of (Subp_Ref, Loc),
6372 New_Occurrence_Of (Is_Local, Loc),
6373 New_Occurrence_Of (Local_Addr, Loc))));
6375 -- Note: Here we assume that the Fat_Type is a record containing just
6376 -- an access to a proxy or stub object.
6378 Append_To (Proc_Statements,
6382 Make_Implicit_If_Statement (N,
6383 Condition => New_Occurrence_Of (Is_Local, Loc),
6385 Then_Statements => New_List (
6387 -- if A.Target = null then
6389 Make_Implicit_If_Statement (N,
6392 Make_Selected_Component (Loc,
6394 Unchecked_Convert_To
6395 (RTE (RE_RAS_Proxy_Type_Access),
6396 New_Occurrence_Of (Local_Addr, Loc)),
6397 Selector_Name => Make_Identifier (Loc, Name_Target)),
6400 Then_Statements => New_List (
6402 -- A.Target := Entity_Of (Ref);
6404 Make_Assignment_Statement (Loc,
6406 Make_Selected_Component (Loc,
6408 Unchecked_Convert_To
6409 (RTE (RE_RAS_Proxy_Type_Access),
6410 New_Occurrence_Of (Local_Addr, Loc)),
6411 Selector_Name => Make_Identifier (Loc, Name_Target)),
6413 Make_Function_Call (Loc,
6414 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6415 Parameter_Associations => New_List (
6416 New_Occurrence_Of (Subp_Ref, Loc)))),
6418 -- Inc_Usage (A.Target);
6421 Make_Procedure_Call_Statement (Loc,
6422 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6423 Parameter_Associations => New_List (
6424 Make_Selected_Component (Loc,
6426 Unchecked_Convert_To
6427 (RTE (RE_RAS_Proxy_Type_Access),
6428 New_Occurrence_Of (Local_Addr, Loc)),
6430 Make_Identifier (Loc, Name_Target)))))),
6432 -- if not All_Calls_Remote then
6433 -- return Fat_Type!(A);
6436 Make_Implicit_If_Statement (N,
6440 New_Occurrence_Of (All_Calls_Remote, Loc)),
6442 Then_Statements => New_List (
6443 Make_Simple_Return_Statement (Loc,
6445 Unchecked_Convert_To
6446 (Fat_Type, New_Occurrence_Of (Local_Addr, Loc))))))));
6448 Append_List_To (Proc_Statements, New_List (
6450 -- Stub.Target := Entity_Of (Ref);
6452 Set_Field (Name_Target,
6453 Make_Function_Call (Loc,
6454 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6455 Parameter_Associations => New_List (
6456 New_Occurrence_Of (Subp_Ref, Loc)))),
6458 -- Inc_Usage (Stub.Target);
6460 Make_Procedure_Call_Statement (Loc,
6461 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6462 Parameter_Associations => New_List (
6463 Make_Selected_Component (Loc,
6465 Selector_Name => Name_Target))),
6467 -- E.4.1(9) A remote call is asynchronous if it is a call to
6468 -- a procedure, or a call through a value of an access-to-procedure
6469 -- type, to which a pragma Asynchronous applies.
6471 -- Parameter Asynch_P is true when the procedure is asynchronous;
6472 -- Expression Asynch_T is true when the type is asynchronous.
6474 Set_Field (Name_Asynchronous,
6476 Left_Opnd => New_Occurrence_Of (Asynch_P, Loc),
6479 (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc)))));
6481 Append_List_To (Proc_Statements,
6482 Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
6484 Append_To (Proc_Statements,
6485 Make_Simple_Return_Statement (Loc,
6487 Unchecked_Convert_To (Fat_Type,
6488 New_Occurrence_Of (Stub_Ptr, Loc))));
6491 Make_Function_Specification (Loc,
6492 Defining_Unit_Name => Proc,
6493 Parameter_Specifications => New_List (
6494 Make_Parameter_Specification (Loc,
6495 Defining_Identifier => Package_Name,
6497 New_Occurrence_Of (Standard_String, Loc)),
6499 Make_Parameter_Specification (Loc,
6500 Defining_Identifier => Subp_Id,
6502 New_Occurrence_Of (Standard_String, Loc)),
6504 Make_Parameter_Specification (Loc,
6505 Defining_Identifier => Asynch_P,
6507 New_Occurrence_Of (Standard_Boolean, Loc)),
6509 Make_Parameter_Specification (Loc,
6510 Defining_Identifier => All_Calls_Remote,
6512 New_Occurrence_Of (Standard_Boolean, Loc))),
6514 Result_Definition =>
6515 New_Occurrence_Of (Fat_Type, Loc));
6517 -- Set the kind and return type of the function to prevent
6518 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6520 Set_Ekind (Proc, E_Function);
6521 Set_Etype (Proc, Fat_Type);
6524 Make_Subprogram_Body (Loc,
6525 Specification => Proc_Spec,
6526 Declarations => Proc_Decls,
6527 Handled_Statement_Sequence =>
6528 Make_Handled_Sequence_Of_Statements (Loc,
6529 Statements => Proc_Statements)));
6531 Set_TSS (Fat_Type, Proc);
6532 end Add_RAS_Access_TSS;
6534 ----------------------
6535 -- Add_RAS_From_Any --
6536 ----------------------
6538 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6539 Loc : constant Source_Ptr := Sloc (RAS_Type);
6541 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6542 Make_TSS_Name (RAS_Type, TSS_From_Any));
6544 Func_Spec : Node_Id;
6546 Statements : List_Id;
6548 Any_Parameter : constant Entity_Id :=
6549 Make_Defining_Identifier (Loc, Name_A);
6552 Statements := New_List (
6553 Make_Simple_Return_Statement (Loc,
6555 Make_Aggregate (Loc,
6556 Component_Associations => New_List (
6557 Make_Component_Association (Loc,
6558 Choices => New_List (Make_Identifier (Loc, Name_Ras)),
6560 PolyORB_Support.Helpers.Build_From_Any_Call
6561 (Underlying_RACW_Type (RAS_Type),
6562 New_Occurrence_Of (Any_Parameter, Loc),
6566 Make_Function_Specification (Loc,
6567 Defining_Unit_Name => Fnam,
6568 Parameter_Specifications => New_List (
6569 Make_Parameter_Specification (Loc,
6570 Defining_Identifier => Any_Parameter,
6571 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
6572 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6575 Make_Subprogram_Body (Loc,
6576 Specification => Func_Spec,
6577 Declarations => No_List,
6578 Handled_Statement_Sequence =>
6579 Make_Handled_Sequence_Of_Statements (Loc,
6580 Statements => Statements)));
6581 Set_TSS (RAS_Type, Fnam);
6582 end Add_RAS_From_Any;
6584 --------------------
6585 -- Add_RAS_To_Any --
6586 --------------------
6588 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6589 Loc : constant Source_Ptr := Sloc (RAS_Type);
6591 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6592 Make_TSS_Name (RAS_Type, TSS_To_Any));
6595 Statements : List_Id;
6597 Func_Spec : Node_Id;
6599 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
6600 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
6601 RACW_Parameter : constant Node_Id :=
6602 Make_Selected_Component (Loc,
6603 Prefix => RAS_Parameter,
6604 Selector_Name => Name_Ras);
6607 -- Object declarations
6609 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6611 Make_Object_Declaration (Loc,
6612 Defining_Identifier => Any,
6613 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc),
6615 PolyORB_Support.Helpers.Build_To_Any_Call
6616 (RACW_Parameter, No_List)));
6618 Statements := New_List (
6619 Make_Procedure_Call_Statement (Loc,
6620 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6621 Parameter_Associations => New_List (
6622 New_Occurrence_Of (Any, Loc),
6623 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6626 Make_Simple_Return_Statement (Loc,
6627 Expression => New_Occurrence_Of (Any, Loc)));
6630 Make_Function_Specification (Loc,
6631 Defining_Unit_Name => Fnam,
6632 Parameter_Specifications => New_List (
6633 Make_Parameter_Specification (Loc,
6634 Defining_Identifier => RAS_Parameter,
6635 Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))),
6636 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6639 Make_Subprogram_Body (Loc,
6640 Specification => Func_Spec,
6641 Declarations => Decls,
6642 Handled_Statement_Sequence =>
6643 Make_Handled_Sequence_Of_Statements (Loc,
6644 Statements => Statements)));
6645 Set_TSS (RAS_Type, Fnam);
6648 ----------------------
6649 -- Add_RAS_TypeCode --
6650 ----------------------
6652 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6653 Loc : constant Source_Ptr := Sloc (RAS_Type);
6655 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6656 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6658 Func_Spec : Node_Id;
6659 Decls : constant List_Id := New_List;
6660 Name_String : String_Id;
6661 Repo_Id_String : String_Id;
6665 Make_Function_Specification (Loc,
6666 Defining_Unit_Name => Fnam,
6667 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6669 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6670 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6673 Make_Subprogram_Body (Loc,
6674 Specification => Func_Spec,
6675 Declarations => Decls,
6676 Handled_Statement_Sequence =>
6677 Make_Handled_Sequence_Of_Statements (Loc,
6678 Statements => New_List (
6679 Make_Simple_Return_Statement (Loc,
6681 Make_Function_Call (Loc,
6682 Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6683 Parameter_Associations => New_List (
6684 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6685 Make_Aggregate (Loc,
6688 Make_Function_Call (Loc,
6691 (RTE (RE_TA_Std_String), Loc),
6692 Parameter_Associations => New_List (
6693 Make_String_Literal (Loc, Name_String))),
6694 Make_Function_Call (Loc,
6697 (RTE (RE_TA_Std_String), Loc),
6698 Parameter_Associations => New_List (
6699 Make_String_Literal (Loc,
6700 Strval => Repo_Id_String))))))))))));
6701 Set_TSS (RAS_Type, Fnam);
6702 end Add_RAS_TypeCode;
6704 -----------------------------------------
6705 -- Add_Receiving_Stubs_To_Declarations --
6706 -----------------------------------------
6708 procedure Add_Receiving_Stubs_To_Declarations
6709 (Pkg_Spec : Node_Id;
6713 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6715 Pkg_RPC_Receiver : constant Entity_Id :=
6716 Make_Temporary (Loc, 'H');
6717 Pkg_RPC_Receiver_Object : Node_Id;
6718 Pkg_RPC_Receiver_Body : Node_Id;
6719 Pkg_RPC_Receiver_Decls : List_Id;
6720 Pkg_RPC_Receiver_Statements : List_Id;
6722 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6723 -- A Pkg_RPC_Receiver is built to decode the request
6726 -- Request object received from neutral layer
6728 Subp_Id : Entity_Id;
6729 -- Subprogram identifier as received from the neutral distribution
6732 Subp_Index : Entity_Id;
6733 -- Internal index as determined by matching either the method name
6734 -- from the request structure, or the local subprogram address (in
6737 Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L');
6739 Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A');
6740 -- Address of a local subprogram designated by a reference
6741 -- corresponding to a RAS.
6743 Dispatch_On_Address : constant List_Id := New_List;
6744 Dispatch_On_Name : constant List_Id := New_List;
6746 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
6748 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
6749 Subp_Info_List : constant List_Id := New_List;
6751 Register_Pkg_Actuals : constant List_Id := New_List;
6753 All_Calls_Remote_E : Entity_Id;
6755 procedure Append_Stubs_To
6756 (RPC_Receiver_Cases : List_Id;
6757 Declaration : Node_Id;
6760 Subp_Dist_Name : Entity_Id;
6761 Subp_Proxy_Addr : Entity_Id);
6762 -- Add one case to the specified RPC receiver case list associating
6763 -- Subprogram_Number with the subprogram declared by Declaration, for
6764 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6765 -- subprogram index. Subp_Dist_Name is the string used to call the
6766 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6767 -- object, used in the context of calls through remote
6768 -- access-to-subprogram types.
6770 procedure Visit_Subprogram (Decl : Node_Id);
6771 -- Generate receiving stub for one remote subprogram
6773 ---------------------
6774 -- Append_Stubs_To --
6775 ---------------------
6777 procedure Append_Stubs_To
6778 (RPC_Receiver_Cases : List_Id;
6779 Declaration : Node_Id;
6782 Subp_Dist_Name : Entity_Id;
6783 Subp_Proxy_Addr : Entity_Id)
6785 Case_Stmts : List_Id;
6787 Case_Stmts := New_List (
6788 Make_Procedure_Call_Statement (Loc,
6791 Defining_Entity (Stubs), Loc),
6792 Parameter_Associations =>
6793 New_List (New_Occurrence_Of (Request, Loc))));
6795 if Nkind (Specification (Declaration)) = N_Function_Specification
6797 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6799 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6802 Append_To (RPC_Receiver_Cases,
6803 Make_Case_Statement_Alternative (Loc,
6805 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6806 Statements => Case_Stmts));
6808 Append_To (Dispatch_On_Name,
6809 Make_Elsif_Part (Loc,
6811 Make_Function_Call (Loc,
6813 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6814 Parameter_Associations => New_List (
6815 New_Occurrence_Of (Subp_Id, Loc),
6816 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6818 Then_Statements => New_List (
6819 Make_Assignment_Statement (Loc,
6820 New_Occurrence_Of (Subp_Index, Loc),
6821 Make_Integer_Literal (Loc, Subp_Number)))));
6823 Append_To (Dispatch_On_Address,
6824 Make_Elsif_Part (Loc,
6827 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6828 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6830 Then_Statements => New_List (
6831 Make_Assignment_Statement (Loc,
6832 New_Occurrence_Of (Subp_Index, Loc),
6833 Make_Integer_Literal (Loc, Subp_Number)))));
6834 end Append_Stubs_To;
6836 ----------------------
6837 -- Visit_Subprogram --
6838 ----------------------
6840 procedure Visit_Subprogram (Decl : Node_Id) is
6841 Loc : constant Source_Ptr := Sloc (Decl);
6842 Spec : constant Node_Id := Specification (Decl);
6843 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
6845 Subp_Val : String_Id;
6847 Subp_Dist_Name : constant Entity_Id :=
6848 Make_Defining_Identifier (Loc,
6851 (Related_Id => Chars (Subp_Def),
6853 Suffix_Index => -1));
6855 Current_Stubs : Node_Id;
6856 Proxy_Obj_Addr : Entity_Id;
6859 -- Disable expansion of stubs if serious errors have been
6860 -- diagnosed, because otherwise some illegal remote subprogram
6861 -- declarations could cause cascaded errors in stubs.
6863 if Serious_Errors_Detected /= 0 then
6867 -- Build receiving stub
6870 Build_Subprogram_Receiving_Stubs
6872 Asynchronous => Nkind (Spec) = N_Procedure_Specification
6873 and then Is_Asynchronous (Subp_Def));
6875 Append_To (Decls, Current_Stubs);
6876 Analyze (Current_Stubs);
6880 Add_RAS_Proxy_And_Analyze (Decls,
6882 All_Calls_Remote_E => All_Calls_Remote_E,
6883 Proxy_Object_Addr => Proxy_Obj_Addr);
6885 -- Compute distribution identifier
6887 Assign_Subprogram_Identifier
6888 (Subp_Def, Current_Subp_Number, Subp_Val);
6891 (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
6894 Make_Object_Declaration (Loc,
6895 Defining_Identifier => Subp_Dist_Name,
6896 Constant_Present => True,
6897 Object_Definition =>
6898 New_Occurrence_Of (Standard_String, Loc),
6900 Make_String_Literal (Loc, Subp_Val)));
6901 Analyze (Last (Decls));
6903 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
6904 -- table for this receiver. The aggregate below must be kept
6905 -- consistent with the declaration of RCI_Subp_Info in
6906 -- System.Partition_Interface.
6908 Append_To (Subp_Info_List,
6909 Make_Component_Association (Loc,
6911 New_List (Make_Integer_Literal (Loc, Current_Subp_Number)),
6914 Make_Aggregate (Loc,
6915 Expressions => New_List (
6919 Make_Attribute_Reference (Loc,
6921 New_Occurrence_Of (Subp_Dist_Name, Loc),
6922 Attribute_Name => Name_Address),
6926 Make_Attribute_Reference (Loc,
6928 New_Occurrence_Of (Subp_Dist_Name, Loc),
6929 Attribute_Name => Name_Length),
6933 New_Occurrence_Of (Proxy_Obj_Addr, Loc)))));
6935 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6936 Declaration => Decl,
6937 Stubs => Current_Stubs,
6938 Subp_Number => Current_Subp_Number,
6939 Subp_Dist_Name => Subp_Dist_Name,
6940 Subp_Proxy_Addr => Proxy_Obj_Addr);
6942 Current_Subp_Number := Current_Subp_Number + 1;
6943 end Visit_Subprogram;
6945 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
6947 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6950 -- Building receiving stubs consist in several operations:
6952 -- - a package RPC receiver must be built. This subprogram will get
6953 -- a Subprogram_Id from the incoming stream and will dispatch the
6954 -- call to the right subprogram;
6956 -- - a receiving stub for each subprogram visible in the package
6957 -- spec. This stub will read all the parameters from the stream,
6958 -- and put the result as well as the exception occurrence in the
6961 Build_RPC_Receiver_Body (
6962 RPC_Receiver => Pkg_RPC_Receiver,
6965 Subp_Index => Subp_Index,
6966 Stmts => Pkg_RPC_Receiver_Statements,
6967 Decl => Pkg_RPC_Receiver_Body);
6968 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6970 -- Extract local address information from the target reference:
6971 -- if non-null, that means that this is a reference that denotes
6972 -- one particular operation, and hence that the operation name
6973 -- must not be taken into account for dispatching.
6975 Append_To (Pkg_RPC_Receiver_Decls,
6976 Make_Object_Declaration (Loc,
6977 Defining_Identifier => Is_Local,
6978 Object_Definition =>
6979 New_Occurrence_Of (Standard_Boolean, Loc)));
6981 Append_To (Pkg_RPC_Receiver_Decls,
6982 Make_Object_Declaration (Loc,
6983 Defining_Identifier => Local_Address,
6984 Object_Definition =>
6985 New_Occurrence_Of (RTE (RE_Address), Loc)));
6987 Append_To (Pkg_RPC_Receiver_Statements,
6988 Make_Procedure_Call_Statement (Loc,
6989 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6990 Parameter_Associations => New_List (
6991 Make_Selected_Component (Loc,
6993 Selector_Name => Name_Target),
6994 New_Occurrence_Of (Is_Local, Loc),
6995 New_Occurrence_Of (Local_Address, Loc))));
6997 -- For each subprogram, the receiving stub will be built and a case
6998 -- statement will be made on the Subprogram_Id to dispatch to the
6999 -- right subprogram.
7001 All_Calls_Remote_E := Boolean_Literals (
7002 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
7004 Overload_Counter_Table.Reset;
7005 Reserve_NamingContext_Methods;
7007 Visit_Spec (Pkg_Spec);
7010 Make_Object_Declaration (Loc,
7011 Defining_Identifier => Subp_Info_Array,
7012 Constant_Present => True,
7013 Aliased_Present => True,
7014 Object_Definition =>
7015 Make_Subtype_Indication (Loc,
7017 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
7019 Make_Index_Or_Discriminant_Constraint (Loc,
7023 Make_Integer_Literal (Loc,
7024 Intval => First_RCI_Subprogram_Id),
7026 Make_Integer_Literal (Loc,
7028 First_RCI_Subprogram_Id
7029 + List_Length (Subp_Info_List) - 1)))))));
7031 if Present (First (Subp_Info_List)) then
7032 Set_Expression (Last (Decls),
7033 Make_Aggregate (Loc,
7034 Component_Associations => Subp_Info_List));
7036 -- Generate the dispatch statement to determine the subprogram id
7037 -- of the called subprogram.
7039 -- We first test whether the reference that was used to make the
7040 -- call was the base RCI reference (in which case Local_Address is
7041 -- zero, and the method identifier from the request must be used
7042 -- to determine which subprogram is called) or a reference
7043 -- identifying one particular subprogram (in which case
7044 -- Local_Address is the address of that subprogram, and the
7045 -- method name from the request is ignored). The latter occurs
7046 -- for the case of a call through a remote access-to-subprogram.
7048 -- In each case, cascaded elsifs are used to determine the proper
7049 -- subprogram index. Using hash tables might be more efficient.
7051 Append_To (Pkg_RPC_Receiver_Statements,
7052 Make_Implicit_If_Statement (Pkg_Spec,
7055 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
7056 Right_Opnd => New_Occurrence_Of
7057 (RTE (RE_Null_Address), Loc)),
7059 Then_Statements => New_List (
7060 Make_Implicit_If_Statement (Pkg_Spec,
7061 Condition => New_Occurrence_Of (Standard_False, Loc),
7062 Then_Statements => New_List (
7063 Make_Null_Statement (Loc)),
7064 Elsif_Parts => Dispatch_On_Address)),
7066 Else_Statements => New_List (
7067 Make_Implicit_If_Statement (Pkg_Spec,
7068 Condition => New_Occurrence_Of (Standard_False, Loc),
7069 Then_Statements => New_List (Make_Null_Statement (Loc)),
7070 Elsif_Parts => Dispatch_On_Name))));
7073 -- For a degenerate RCI with no visible subprograms,
7074 -- Subp_Info_List has zero length, and the declaration is for an
7075 -- empty array, in which case no initialization aggregate must be
7076 -- generated. We do not generate a Dispatch_Statement either.
7078 -- No initialization provided: remove CONSTANT so that the
7079 -- declaration is not an incomplete deferred constant.
7081 Set_Constant_Present (Last (Decls), False);
7084 -- Analyze Subp_Info_Array declaration
7086 Analyze (Last (Decls));
7088 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7089 -- rather than raising an exception since we do not want someone
7090 -- to crash a remote partition by sending invalid subprogram ids.
7091 -- This is consistent with the other parts of the case statement
7092 -- since even in presence of incorrect parameters in the stream,
7093 -- every exception will be caught and (if the subprogram is not an
7094 -- APC) put into the result stream and sent away.
7096 Append_To (Pkg_RPC_Receiver_Cases,
7097 Make_Case_Statement_Alternative (Loc,
7098 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
7099 Statements => New_List (Make_Null_Statement (Loc))));
7101 Append_To (Pkg_RPC_Receiver_Statements,
7102 Make_Case_Statement (Loc,
7103 Expression => New_Occurrence_Of (Subp_Index, Loc),
7104 Alternatives => Pkg_RPC_Receiver_Cases));
7106 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7109 Append_To (Decls, Pkg_RPC_Receiver_Body);
7110 Analyze (Last (Decls));
7112 Pkg_RPC_Receiver_Object :=
7113 Make_Object_Declaration (Loc,
7114 Defining_Identifier => Make_Temporary (Loc, 'R'),
7115 Aliased_Present => True,
7116 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
7117 Append_To (Decls, Pkg_RPC_Receiver_Object);
7118 Analyze (Last (Decls));
7120 Get_Library_Unit_Name_String (Pkg_Spec);
7124 Append_To (Register_Pkg_Actuals,
7125 Make_String_Literal (Loc,
7126 Strval => String_From_Name_Buffer));
7130 Append_To (Register_Pkg_Actuals,
7131 Make_Attribute_Reference (Loc,
7134 (Defining_Entity (Pkg_Spec), Loc),
7135 Attribute_Name => Name_Version));
7139 Append_To (Register_Pkg_Actuals,
7140 Make_Attribute_Reference (Loc,
7142 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7143 Attribute_Name => Name_Access));
7147 Append_To (Register_Pkg_Actuals,
7148 Make_Attribute_Reference (Loc,
7151 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc),
7152 Attribute_Name => Name_Access));
7156 Append_To (Register_Pkg_Actuals,
7157 Make_Attribute_Reference (Loc,
7158 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7159 Attribute_Name => Name_Address));
7163 Append_To (Register_Pkg_Actuals,
7164 Make_Attribute_Reference (Loc,
7165 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7166 Attribute_Name => Name_Length));
7168 -- Is_All_Calls_Remote
7170 Append_To (Register_Pkg_Actuals,
7171 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7173 -- Finally call Register_Pkg_Receiving_Stub with the above parameters
7176 Make_Procedure_Call_Statement (Loc,
7178 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7179 Parameter_Associations => Register_Pkg_Actuals));
7180 Analyze (Last (Stmts));
7181 end Add_Receiving_Stubs_To_Declarations;
7183 ---------------------------------
7184 -- Build_General_Calling_Stubs --
7185 ---------------------------------
7187 procedure Build_General_Calling_Stubs
7189 Statements : List_Id;
7190 Target_Object : Node_Id;
7191 Subprogram_Id : Node_Id;
7192 Asynchronous : Node_Id := Empty;
7193 Is_Known_Asynchronous : Boolean := False;
7194 Is_Known_Non_Asynchronous : Boolean := False;
7195 Is_Function : Boolean;
7197 Stub_Type : Entity_Id := Empty;
7198 RACW_Type : Entity_Id := Empty;
7201 Loc : constant Source_Ptr := Sloc (Nod);
7203 Request : constant Entity_Id := Make_Temporary (Loc, 'R');
7204 -- The request object constructed by these stubs
7205 -- Could we use Name_R instead??? (see GLADE client stubs)
7207 function Make_Request_RTE_Call
7209 Actuals : List_Id := New_List) return Node_Id;
7210 -- Generate a procedure call statement calling RE with the given
7211 -- actuals. Request'Access is appended to the list.
7213 ---------------------------
7214 -- Make_Request_RTE_Call --
7215 ---------------------------
7217 function Make_Request_RTE_Call
7219 Actuals : List_Id := New_List) return Node_Id
7223 Make_Attribute_Reference (Loc,
7224 Prefix => New_Occurrence_Of (Request, Loc),
7225 Attribute_Name => Name_Access));
7226 return Make_Procedure_Call_Statement (Loc,
7228 New_Occurrence_Of (RTE (RE), Loc),
7229 Parameter_Associations => Actuals);
7230 end Make_Request_RTE_Call;
7232 Arguments : Node_Id;
7233 -- Name of the named values list used to transmit parameters
7234 -- to the remote package
7237 -- Name of the result named value (in non-APC cases) which get the
7238 -- result of the remote subprogram.
7240 Result_TC : Node_Id;
7241 -- Typecode expression for the result of the request (void
7242 -- typecode for procedures).
7244 Exception_Return_Parameter : Node_Id;
7245 -- Name of the parameter which will hold the exception sent by the
7246 -- remote subprogram.
7248 Current_Parameter : Node_Id;
7249 -- Current parameter being handled
7251 Ordered_Parameters_List : constant List_Id :=
7252 Build_Ordered_Parameters_List (Spec);
7254 Asynchronous_P : Node_Id;
7255 -- A Boolean expression indicating whether this call is asynchronous
7257 Asynchronous_Statements : List_Id := No_List;
7258 Non_Asynchronous_Statements : List_Id := No_List;
7259 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7261 Extra_Formal_Statements : constant List_Id := New_List;
7262 -- List of statements for extra formal parameters. It will appear
7263 -- after the regular statements for writing out parameters.
7265 After_Statements : constant List_Id := New_List;
7266 -- Statements to be executed after call returns (to assign IN OUT or
7267 -- OUT parameter values).
7270 -- The type of the formal parameter being processed
7272 Is_Controlling_Formal : Boolean;
7273 Is_First_Controlling_Formal : Boolean;
7274 First_Controlling_Formal_Seen : Boolean := False;
7275 -- Controlling formal parameters of distributed object primitives
7276 -- require special handling, and the first such parameter needs even
7277 -- more special handling.
7280 -- ??? document general form of stub subprograms for the PolyORB case
7283 Make_Object_Declaration (Loc,
7284 Defining_Identifier => Request,
7285 Aliased_Present => True,
7286 Object_Definition =>
7287 New_Occurrence_Of (RTE (RE_Request), Loc)));
7289 Result := Make_Temporary (Loc, 'R');
7293 PolyORB_Support.Helpers.Build_TypeCode_Call
7294 (Loc, Etype (Result_Definition (Spec)), Decls);
7296 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7300 Make_Object_Declaration (Loc,
7301 Defining_Identifier => Result,
7302 Aliased_Present => False,
7303 Object_Definition =>
7304 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7306 Make_Aggregate (Loc,
7307 Component_Associations => New_List (
7308 Make_Component_Association (Loc,
7309 Choices => New_List (Make_Identifier (Loc, Name_Name)),
7311 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7312 Make_Component_Association (Loc,
7313 Choices => New_List (
7314 Make_Identifier (Loc, Name_Argument)),
7316 Make_Function_Call (Loc,
7317 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7318 Parameter_Associations => New_List (Result_TC))),
7319 Make_Component_Association (Loc,
7320 Choices => New_List (
7321 Make_Identifier (Loc, Name_Arg_Modes)),
7322 Expression => Make_Integer_Literal (Loc, 0))))));
7324 if not Is_Known_Asynchronous then
7325 Exception_Return_Parameter := Make_Temporary (Loc, 'E');
7328 Make_Object_Declaration (Loc,
7329 Defining_Identifier => Exception_Return_Parameter,
7330 Object_Definition =>
7331 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7334 Exception_Return_Parameter := Empty;
7337 -- Initialize and fill in arguments list
7339 Arguments := Make_Temporary (Loc, 'A');
7340 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7342 Current_Parameter := First (Ordered_Parameters_List);
7343 while Present (Current_Parameter) loop
7344 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7345 Is_Controlling_Formal := True;
7346 Is_First_Controlling_Formal :=
7347 not First_Controlling_Formal_Seen;
7348 First_Controlling_Formal_Seen := True;
7351 Is_Controlling_Formal := False;
7352 Is_First_Controlling_Formal := False;
7355 if Is_Controlling_Formal then
7357 -- For a controlling formal argument, we send its reference
7362 Etyp := Etype (Parameter_Type (Current_Parameter));
7365 -- The first controlling formal parameter is treated specially:
7366 -- it is used to set the target object of the call.
7368 if not Is_First_Controlling_Formal then
7370 Constrained : constant Boolean :=
7371 Is_Constrained (Etyp)
7372 or else Is_Elementary_Type (Etyp);
7374 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
7376 Actual_Parameter : Node_Id :=
7378 Defining_Identifier (
7379 Current_Parameter), Loc);
7384 if Is_Controlling_Formal then
7386 -- For a controlling formal parameter (other than the
7387 -- first one), use the corresponding RACW. If the
7388 -- parameter is not an anonymous access parameter, that
7389 -- involves taking its 'Unrestricted_Access.
7391 if Nkind (Parameter_Type (Current_Parameter))
7392 = N_Access_Definition
7394 Actual_Parameter := OK_Convert_To
7395 (Etyp, Actual_Parameter);
7397 Actual_Parameter := OK_Convert_To (Etyp,
7398 Make_Attribute_Reference (Loc,
7399 Prefix => Actual_Parameter,
7400 Attribute_Name => Name_Unrestricted_Access));
7405 if In_Present (Current_Parameter)
7406 or else not Out_Present (Current_Parameter)
7407 or else not Constrained
7408 or else Is_Controlling_Formal
7410 -- The parameter has an input value, is constrained at
7411 -- runtime by an input value, or is a controlling formal
7412 -- parameter (always passed as a reference) other than
7415 Expr := PolyORB_Support.Helpers.Build_To_Any_Call
7416 (Actual_Parameter, Decls);
7419 Expr := Make_Function_Call (Loc,
7420 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7421 Parameter_Associations => New_List (
7422 PolyORB_Support.Helpers.Build_TypeCode_Call
7423 (Loc, Etyp, Decls)));
7427 Make_Object_Declaration (Loc,
7428 Defining_Identifier => Any,
7429 Aliased_Present => False,
7430 Object_Definition =>
7431 New_Occurrence_Of (RTE (RE_Any), Loc),
7432 Expression => Expr));
7434 Append_To (Statements,
7435 Add_Parameter_To_NVList (Loc,
7436 Parameter => Current_Parameter,
7437 NVList => Arguments,
7438 Constrained => Constrained,
7441 if Out_Present (Current_Parameter)
7442 and then not Is_Controlling_Formal
7444 if Is_Limited_Type (Etyp) then
7445 Helpers.Assign_Opaque_From_Any (Loc,
7446 Stms => After_Statements,
7448 N => New_Occurrence_Of (Any, Loc),
7450 Defining_Identifier (Current_Parameter));
7452 Append_To (After_Statements,
7453 Make_Assignment_Statement (Loc,
7456 Defining_Identifier (Current_Parameter), Loc),
7458 PolyORB_Support.Helpers.Build_From_Any_Call
7460 New_Occurrence_Of (Any, Loc),
7467 -- If the current parameter has a dynamic constrained status, then
7468 -- this status is transmitted as well.
7469 -- This should be done for accessibility as well ???
7471 if Nkind (Parameter_Type (Current_Parameter)) /=
7473 and then Need_Extra_Constrained (Current_Parameter)
7475 -- In this block, we do not use the extra formal that has been
7476 -- created because it does not exist at the time of expansion
7477 -- when building calling stubs for remote access to subprogram
7478 -- types. We create an extra variable of this type and push it
7479 -- in the stream after the regular parameters.
7482 Extra_Any_Parameter : constant Entity_Id :=
7483 Make_Temporary (Loc, 'P');
7485 Parameter_Exp : constant Node_Id :=
7486 Make_Attribute_Reference (Loc,
7487 Prefix => New_Occurrence_Of (
7488 Defining_Identifier (Current_Parameter), Loc),
7489 Attribute_Name => Name_Constrained);
7492 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7495 Make_Object_Declaration (Loc,
7496 Defining_Identifier => Extra_Any_Parameter,
7497 Aliased_Present => False,
7498 Object_Definition =>
7499 New_Occurrence_Of (RTE (RE_Any), Loc),
7501 PolyORB_Support.Helpers.Build_To_Any_Call
7502 (Parameter_Exp, Decls)));
7504 Append_To (Extra_Formal_Statements,
7505 Add_Parameter_To_NVList (Loc,
7506 Parameter => Extra_Any_Parameter,
7507 NVList => Arguments,
7508 Constrained => True,
7509 Any => Extra_Any_Parameter));
7513 Next (Current_Parameter);
7516 -- Append the formal statements list to the statements
7518 Append_List_To (Statements, Extra_Formal_Statements);
7520 Append_To (Statements,
7521 Make_Procedure_Call_Statement (Loc,
7523 New_Occurrence_Of (RTE (RE_Request_Setup), Loc),
7524 Parameter_Associations => New_List (
7525 New_Occurrence_Of (Request, Loc),
7528 New_Occurrence_Of (Arguments, Loc),
7529 New_Occurrence_Of (Result, Loc),
7530 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7533 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7535 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7538 (Boolean_Literals (Is_Known_Asynchronous), Loc);
7541 pragma Assert (Present (Asynchronous));
7542 Asynchronous_P := New_Copy_Tree (Asynchronous);
7544 -- The expression node Asynchronous will be used to build an 'if'
7545 -- statement at the end of Build_General_Calling_Stubs: we need to
7546 -- make a copy here.
7549 Append_To (Parameter_Associations (Last (Statements)),
7550 Make_Indexed_Component (Loc,
7553 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7554 Expressions => New_List (Asynchronous_P)));
7556 Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke));
7558 -- Asynchronous case
7560 if not Is_Known_Non_Asynchronous then
7561 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7564 -- Non-asynchronous case
7566 if not Is_Known_Asynchronous then
7567 -- Reraise an exception occurrence from the completed request.
7568 -- If the exception occurrence is empty, this is a no-op.
7570 Non_Asynchronous_Statements := New_List (
7571 Make_Procedure_Call_Statement (Loc,
7573 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7574 Parameter_Associations => New_List (
7575 New_Occurrence_Of (Request, Loc))));
7578 -- If this is a function call, read the value and return it
7580 Append_To (Non_Asynchronous_Statements,
7581 Make_Tag_Check (Loc,
7582 Make_Simple_Return_Statement (Loc,
7583 PolyORB_Support.Helpers.Build_From_Any_Call
7584 (Etype (Result_Definition (Spec)),
7585 Make_Selected_Component (Loc,
7587 Selector_Name => Name_Argument),
7592 -- Case of a procedure: deal with IN OUT and OUT formals
7594 Append_List_To (Non_Asynchronous_Statements, After_Statements);
7598 if Is_Known_Asynchronous then
7599 Append_List_To (Statements, Asynchronous_Statements);
7601 elsif Is_Known_Non_Asynchronous then
7602 Append_List_To (Statements, Non_Asynchronous_Statements);
7605 pragma Assert (Present (Asynchronous));
7606 Append_To (Statements,
7607 Make_Implicit_If_Statement (Nod,
7608 Condition => Asynchronous,
7609 Then_Statements => Asynchronous_Statements,
7610 Else_Statements => Non_Asynchronous_Statements));
7612 end Build_General_Calling_Stubs;
7614 -----------------------
7615 -- Build_Stub_Target --
7616 -----------------------
7618 function Build_Stub_Target
7621 RCI_Locator : Entity_Id;
7622 Controlling_Parameter : Entity_Id) return RPC_Target
7624 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7625 Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T');
7628 if Present (Controlling_Parameter) then
7630 Make_Object_Declaration (Loc,
7631 Defining_Identifier => Target_Reference,
7633 Object_Definition =>
7634 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7637 Make_Function_Call (Loc,
7639 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7640 Parameter_Associations => New_List (
7641 Make_Selected_Component (Loc,
7642 Prefix => Controlling_Parameter,
7643 Selector_Name => Name_Target)))));
7645 -- Note: Controlling_Parameter has the same components as
7646 -- System.Partition_Interface.RACW_Stub_Type.
7648 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7651 Target_Info.Object :=
7652 Make_Selected_Component (Loc,
7654 Make_Identifier (Loc, Chars (RCI_Locator)),
7656 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7660 end Build_Stub_Target;
7662 ---------------------
7663 -- Build_Stub_Type --
7664 ---------------------
7666 procedure Build_Stub_Type
7667 (RACW_Type : Entity_Id;
7668 Stub_Type_Comps : out List_Id;
7669 RPC_Receiver_Decl : out Node_Id)
7671 Loc : constant Source_Ptr := Sloc (RACW_Type);
7674 Stub_Type_Comps := New_List (
7675 Make_Component_Declaration (Loc,
7676 Defining_Identifier =>
7677 Make_Defining_Identifier (Loc, Name_Target),
7678 Component_Definition =>
7679 Make_Component_Definition (Loc,
7680 Aliased_Present => False,
7681 Subtype_Indication =>
7682 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7684 Make_Component_Declaration (Loc,
7685 Defining_Identifier =>
7686 Make_Defining_Identifier (Loc, Name_Asynchronous),
7688 Component_Definition =>
7689 Make_Component_Definition (Loc,
7690 Aliased_Present => False,
7691 Subtype_Indication =>
7692 New_Occurrence_Of (Standard_Boolean, Loc))));
7694 RPC_Receiver_Decl :=
7695 Make_Object_Declaration (Loc,
7696 Defining_Identifier => Make_Temporary (Loc, 'R'),
7697 Aliased_Present => True,
7698 Object_Definition =>
7699 New_Occurrence_Of (RTE (RE_Servant), Loc));
7700 end Build_Stub_Type;
7702 -----------------------------
7703 -- Build_RPC_Receiver_Body --
7704 -----------------------------
7706 procedure Build_RPC_Receiver_Body
7707 (RPC_Receiver : Entity_Id;
7708 Request : out Entity_Id;
7709 Subp_Id : out Entity_Id;
7710 Subp_Index : out Entity_Id;
7711 Stmts : out List_Id;
7714 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7716 RPC_Receiver_Spec : Node_Id;
7717 RPC_Receiver_Decls : List_Id;
7720 Request := Make_Defining_Identifier (Loc, Name_R);
7722 RPC_Receiver_Spec :=
7723 Build_RPC_Receiver_Specification
7724 (RPC_Receiver => RPC_Receiver,
7725 Request_Parameter => Request);
7727 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7728 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7730 RPC_Receiver_Decls := New_List (
7731 Make_Object_Renaming_Declaration (Loc,
7732 Defining_Identifier => Subp_Id,
7733 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7735 Make_Explicit_Dereference (Loc,
7737 Make_Selected_Component (Loc,
7739 Selector_Name => Name_Operation))),
7741 Make_Object_Declaration (Loc,
7742 Defining_Identifier => Subp_Index,
7743 Object_Definition =>
7744 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7746 Make_Attribute_Reference (Loc,
7748 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7749 Attribute_Name => Name_Last)));
7754 Make_Subprogram_Body (Loc,
7755 Specification => RPC_Receiver_Spec,
7756 Declarations => RPC_Receiver_Decls,
7757 Handled_Statement_Sequence =>
7758 Make_Handled_Sequence_Of_Statements (Loc,
7759 Statements => Stmts));
7760 end Build_RPC_Receiver_Body;
7762 --------------------------------------
7763 -- Build_Subprogram_Receiving_Stubs --
7764 --------------------------------------
7766 function Build_Subprogram_Receiving_Stubs
7767 (Vis_Decl : Node_Id;
7768 Asynchronous : Boolean;
7769 Dynamically_Asynchronous : Boolean := False;
7770 Stub_Type : Entity_Id := Empty;
7771 RACW_Type : Entity_Id := Empty;
7772 Parent_Primitive : Entity_Id := Empty) return Node_Id
7774 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7776 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
7777 -- Formal parameter for receiving stubs: a descriptor for an incoming
7780 Outer_Decls : constant List_Id := New_List;
7781 -- At the outermost level, an NVList and Any's are declared for all
7782 -- parameters. The Dynamic_Async flag also needs to be declared there
7783 -- to be visible from the exception handling code.
7785 Outer_Statements : constant List_Id := New_List;
7786 -- Statements that occur prior to the declaration of the actual
7787 -- parameter variables.
7789 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7790 -- Statements concerning extra formal parameters, prior to the
7791 -- declaration of the actual parameter variables.
7793 Decls : constant List_Id := New_List;
7794 -- All the parameters will get declared before calling the real
7795 -- subprograms. Also the out parameters will be declared. At this
7796 -- level, parameters may be unconstrained.
7798 Statements : constant List_Id := New_List;
7800 After_Statements : constant List_Id := New_List;
7801 -- Statements to be executed after the subprogram call
7803 Inner_Decls : List_Id := No_List;
7804 -- In case of a function, the inner declarations are needed since
7805 -- the result may be unconstrained.
7807 Excep_Handlers : List_Id := No_List;
7809 Parameter_List : constant List_Id := New_List;
7810 -- List of parameters to be passed to the subprogram
7812 First_Controlling_Formal_Seen : Boolean := False;
7814 Current_Parameter : Node_Id;
7816 Ordered_Parameters_List : constant List_Id :=
7817 Build_Ordered_Parameters_List
7818 (Specification (Vis_Decl));
7820 Arguments : constant Entity_Id := Make_Temporary (Loc, 'A');
7821 -- Name of the named values list used to retrieve parameters
7823 Subp_Spec : Node_Id;
7824 -- Subprogram specification
7826 Called_Subprogram : Node_Id;
7827 -- The subprogram to call
7830 if Present (RACW_Type) then
7831 Called_Subprogram :=
7832 New_Occurrence_Of (Parent_Primitive, Loc);
7834 Called_Subprogram :=
7836 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7839 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7841 -- Loop through every parameter and get its value from the stream. If
7842 -- the parameter is unconstrained, then the parameter is read using
7843 -- 'Input at the point of declaration.
7845 Current_Parameter := First (Ordered_Parameters_List);
7846 while Present (Current_Parameter) loop
7849 Constrained : Boolean;
7850 Any : Entity_Id := Empty;
7851 Object : constant Entity_Id := Make_Temporary (Loc, 'P');
7852 Expr : Node_Id := Empty;
7854 Is_Controlling_Formal : constant Boolean :=
7855 Is_RACW_Controlling_Formal
7856 (Current_Parameter, Stub_Type);
7858 Is_First_Controlling_Formal : Boolean := False;
7860 Need_Extra_Constrained : Boolean;
7861 -- True when an extra constrained actual is required
7864 if Is_Controlling_Formal then
7866 -- Controlling formals in distributed object primitive
7867 -- operations are handled specially:
7869 -- - the first controlling formal is used as the
7870 -- target of the call;
7872 -- - the remaining controlling formals are transmitted
7876 Is_First_Controlling_Formal :=
7877 not First_Controlling_Formal_Seen;
7878 First_Controlling_Formal_Seen := True;
7881 Etyp := Etype (Parameter_Type (Current_Parameter));
7885 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
7887 if not Is_First_Controlling_Formal then
7888 Any := Make_Temporary (Loc, 'A');
7890 Append_To (Outer_Decls,
7891 Make_Object_Declaration (Loc,
7892 Defining_Identifier => Any,
7893 Object_Definition =>
7894 New_Occurrence_Of (RTE (RE_Any), Loc),
7896 Make_Function_Call (Loc,
7897 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7898 Parameter_Associations => New_List (
7899 PolyORB_Support.Helpers.Build_TypeCode_Call
7900 (Loc, Etyp, Outer_Decls)))));
7902 Append_To (Outer_Statements,
7903 Add_Parameter_To_NVList (Loc,
7904 Parameter => Current_Parameter,
7905 NVList => Arguments,
7906 Constrained => Constrained,
7910 if Is_First_Controlling_Formal then
7912 Addr : constant Entity_Id := Make_Temporary (Loc, 'A');
7914 Is_Local : constant Entity_Id :=
7915 Make_Temporary (Loc, 'L');
7918 -- Special case: obtain the first controlling formal
7919 -- from the target of the remote call, instead of the
7922 Append_To (Outer_Decls,
7923 Make_Object_Declaration (Loc,
7924 Defining_Identifier => Addr,
7925 Object_Definition =>
7926 New_Occurrence_Of (RTE (RE_Address), Loc)));
7928 Append_To (Outer_Decls,
7929 Make_Object_Declaration (Loc,
7930 Defining_Identifier => Is_Local,
7931 Object_Definition =>
7932 New_Occurrence_Of (Standard_Boolean, Loc)));
7934 Append_To (Outer_Statements,
7935 Make_Procedure_Call_Statement (Loc,
7937 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7938 Parameter_Associations => New_List (
7939 Make_Selected_Component (Loc,
7942 Request_Parameter, Loc),
7944 Make_Identifier (Loc, Name_Target)),
7945 New_Occurrence_Of (Is_Local, Loc),
7946 New_Occurrence_Of (Addr, Loc))));
7948 Expr := Unchecked_Convert_To (RACW_Type,
7949 New_Occurrence_Of (Addr, Loc));
7952 elsif In_Present (Current_Parameter)
7953 or else not Out_Present (Current_Parameter)
7954 or else not Constrained
7956 -- If an input parameter is constrained, then its reading is
7957 -- deferred until the beginning of the subprogram body. If
7958 -- it is unconstrained, then an expression is built for
7959 -- the object declaration and the variable is set using
7960 -- 'Input instead of 'Read.
7962 if Constrained and then Is_Limited_Type (Etyp) then
7963 Helpers.Assign_Opaque_From_Any (Loc,
7966 N => New_Occurrence_Of (Any, Loc),
7970 Expr := Helpers.Build_From_Any_Call
7971 (Etyp, New_Occurrence_Of (Any, Loc), Decls);
7974 Append_To (Statements,
7975 Make_Assignment_Statement (Loc,
7976 Name => New_Occurrence_Of (Object, Loc),
7977 Expression => Expr));
7981 -- Expr will be used to initialize (and constrain) the
7982 -- parameter when it is declared.
7990 Need_Extra_Constrained :=
7991 Nkind (Parameter_Type (Current_Parameter)) /=
7994 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7996 Present (Extra_Constrained
7997 (Defining_Identifier (Current_Parameter)));
7999 -- We may not associate an extra constrained actual to a
8000 -- constant object, so if one is needed, declare the actual
8001 -- as a variable even if it won't be modified.
8003 Build_Actual_Object_Declaration
8006 Variable => Need_Extra_Constrained
8007 or else Out_Present (Current_Parameter),
8010 Set_Etype (Object, Etyp);
8012 -- An out parameter may be written back using a 'Write
8013 -- attribute instead of a 'Output because it has been
8014 -- constrained by the parameter given to the caller. Note that
8015 -- out controlling arguments in the case of a RACW are not put
8016 -- back in the stream because the pointer on them has not
8019 if Out_Present (Current_Parameter)
8020 and then not Is_Controlling_Formal
8022 Append_To (After_Statements,
8023 Make_Procedure_Call_Statement (Loc,
8024 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
8025 Parameter_Associations => New_List (
8026 New_Occurrence_Of (Any, Loc),
8027 PolyORB_Support.Helpers.Build_To_Any_Call
8028 (New_Occurrence_Of (Object, Loc), Decls))));
8031 -- For RACW controlling formals, the Etyp of Object is always
8032 -- an RACW, even if the parameter is not of an anonymous access
8033 -- type. In such case, we need to dereference it at call time.
8035 if Is_Controlling_Formal then
8036 if Nkind (Parameter_Type (Current_Parameter)) /=
8039 Append_To (Parameter_List,
8040 Make_Parameter_Association (Loc,
8043 (Defining_Identifier (Current_Parameter), Loc),
8044 Explicit_Actual_Parameter =>
8045 Make_Explicit_Dereference (Loc,
8046 Prefix => New_Occurrence_Of (Object, Loc))));
8049 Append_To (Parameter_List,
8050 Make_Parameter_Association (Loc,
8053 (Defining_Identifier (Current_Parameter), Loc),
8055 Explicit_Actual_Parameter =>
8056 New_Occurrence_Of (Object, Loc)));
8060 Append_To (Parameter_List,
8061 Make_Parameter_Association (Loc,
8064 Defining_Identifier (Current_Parameter), Loc),
8065 Explicit_Actual_Parameter =>
8066 New_Occurrence_Of (Object, Loc)));
8069 -- If the current parameter needs an extra formal, then read it
8070 -- from the stream and set the corresponding semantic field in
8071 -- the variable. If the kind of the parameter identifier is
8072 -- E_Void, then this is a compiler generated parameter that
8073 -- doesn't need an extra constrained status.
8075 -- The case of Extra_Accessibility should also be handled ???
8077 if Need_Extra_Constrained then
8079 Extra_Parameter : constant Entity_Id :=
8081 (Defining_Identifier
8082 (Current_Parameter));
8084 Extra_Any : constant Entity_Id :=
8085 Make_Temporary (Loc, 'A');
8087 Formal_Entity : constant Entity_Id :=
8088 Make_Defining_Identifier (Loc,
8089 Chars => Chars (Extra_Parameter));
8091 Formal_Type : constant Entity_Id :=
8092 Etype (Extra_Parameter);
8095 Append_To (Outer_Decls,
8096 Make_Object_Declaration (Loc,
8097 Defining_Identifier => Extra_Any,
8098 Object_Definition =>
8099 New_Occurrence_Of (RTE (RE_Any), Loc),
8101 Make_Function_Call (Loc,
8103 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8104 Parameter_Associations => New_List (
8105 PolyORB_Support.Helpers.Build_TypeCode_Call
8106 (Loc, Formal_Type, Outer_Decls)))));
8108 Append_To (Outer_Extra_Formal_Statements,
8109 Add_Parameter_To_NVList (Loc,
8110 Parameter => Extra_Parameter,
8111 NVList => Arguments,
8112 Constrained => True,
8116 Make_Object_Declaration (Loc,
8117 Defining_Identifier => Formal_Entity,
8118 Object_Definition =>
8119 New_Occurrence_Of (Formal_Type, Loc)));
8121 Append_To (Statements,
8122 Make_Assignment_Statement (Loc,
8123 Name => New_Occurrence_Of (Formal_Entity, Loc),
8125 PolyORB_Support.Helpers.Build_From_Any_Call
8127 New_Occurrence_Of (Extra_Any, Loc),
8129 Set_Extra_Constrained (Object, Formal_Entity);
8134 Next (Current_Parameter);
8137 -- Extra Formals should go after all the other parameters
8139 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8141 Append_To (Outer_Statements,
8142 Make_Procedure_Call_Statement (Loc,
8143 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8144 Parameter_Associations => New_List (
8145 New_Occurrence_Of (Request_Parameter, Loc),
8146 New_Occurrence_Of (Arguments, Loc))));
8148 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8150 -- The remote subprogram is a function: Build an inner block to be
8151 -- able to hold a potentially unconstrained result in a variable.
8154 Etyp : constant Entity_Id :=
8155 Etype (Result_Definition (Specification (Vis_Decl)));
8156 Result : constant Node_Id := Make_Temporary (Loc, 'R');
8159 Inner_Decls := New_List (
8160 Make_Object_Declaration (Loc,
8161 Defining_Identifier => Result,
8162 Constant_Present => True,
8163 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8165 Make_Function_Call (Loc,
8166 Name => Called_Subprogram,
8167 Parameter_Associations => Parameter_List)));
8169 if Is_Class_Wide_Type (Etyp) then
8171 -- For a remote call to a function with a class-wide type,
8172 -- check that the returned value satisfies the requirements
8175 Append_To (Inner_Decls,
8176 Make_Transportable_Check (Loc,
8177 New_Occurrence_Of (Result, Loc)));
8181 Set_Etype (Result, Etyp);
8182 Append_To (After_Statements,
8183 Make_Procedure_Call_Statement (Loc,
8184 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8185 Parameter_Associations => New_List (
8186 New_Occurrence_Of (Request_Parameter, Loc),
8187 PolyORB_Support.Helpers.Build_To_Any_Call
8188 (New_Occurrence_Of (Result, Loc), Decls))));
8190 -- A DSA function does not have out or inout arguments
8193 Append_To (Statements,
8194 Make_Block_Statement (Loc,
8195 Declarations => Inner_Decls,
8196 Handled_Statement_Sequence =>
8197 Make_Handled_Sequence_Of_Statements (Loc,
8198 Statements => After_Statements)));
8201 -- The remote subprogram is a procedure. We do not need any inner
8202 -- block in this case. No specific processing is required here for
8203 -- the dynamically asynchronous case: the indication of whether
8204 -- call is asynchronous or not is managed by the Sync_Scope
8205 -- attibute of the request, and is handled entirely in the
8208 Append_To (After_Statements,
8209 Make_Procedure_Call_Statement (Loc,
8210 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8211 Parameter_Associations => New_List (
8212 New_Occurrence_Of (Request_Parameter, Loc))));
8214 Append_To (Statements,
8215 Make_Procedure_Call_Statement (Loc,
8216 Name => Called_Subprogram,
8217 Parameter_Associations => Parameter_List));
8219 Append_List_To (Statements, After_Statements);
8223 Make_Procedure_Specification (Loc,
8224 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
8226 Parameter_Specifications => New_List (
8227 Make_Parameter_Specification (Loc,
8228 Defining_Identifier => Request_Parameter,
8230 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8232 -- An exception raised during the execution of an incoming remote
8233 -- subprogram call and that needs to be sent back to the caller is
8234 -- propagated by the receiving stubs, and will be handled by the
8235 -- caller (the distribution runtime).
8237 if Asynchronous and then not Dynamically_Asynchronous then
8239 -- For an asynchronous procedure, add a null exception handler
8241 Excep_Handlers := New_List (
8242 Make_Implicit_Exception_Handler (Loc,
8243 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8244 Statements => New_List (Make_Null_Statement (Loc))));
8247 -- In the other cases, if an exception is raised, then the
8248 -- exception occurrence is propagated.
8253 Append_To (Outer_Statements,
8254 Make_Block_Statement (Loc,
8255 Declarations => Decls,
8256 Handled_Statement_Sequence =>
8257 Make_Handled_Sequence_Of_Statements (Loc,
8258 Statements => Statements)));
8261 Make_Subprogram_Body (Loc,
8262 Specification => Subp_Spec,
8263 Declarations => Outer_Decls,
8264 Handled_Statement_Sequence =>
8265 Make_Handled_Sequence_Of_Statements (Loc,
8266 Statements => Outer_Statements,
8267 Exception_Handlers => Excep_Handlers));
8268 end Build_Subprogram_Receiving_Stubs;
8274 package body Helpers is
8276 -----------------------
8277 -- Local Subprograms --
8278 -----------------------
8280 function Find_Numeric_Representation
8281 (Typ : Entity_Id) return Entity_Id;
8282 -- Given a numeric type Typ, return the smallest integer or modular
8283 -- type from Interfaces, or the smallest floating point type from
8284 -- Standard whose range encompasses that of Typ.
8286 function Make_Helper_Function_Name
8289 Nam : Name_Id) return Entity_Id;
8290 -- Return the name to be assigned for helper subprogram Nam of Typ
8292 ------------------------------------------------------------
8293 -- Common subprograms for building various tree fragments --
8294 ------------------------------------------------------------
8296 function Build_Get_Aggregate_Element
8300 Idx : Node_Id) return Node_Id;
8301 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8302 -- returning the Idx'th element.
8305 Subprogram : Entity_Id;
8306 -- Reference location for constructed nodes
8309 -- For 'Range and Etype
8312 -- For the construction of the innermost element expression
8314 with procedure Add_Process_Element
8317 Counter : Entity_Id;
8320 procedure Append_Array_Traversal
8323 Counter : Entity_Id := Empty;
8325 -- Build nested loop statements that iterate over the elements of an
8326 -- array Arry. The statement(s) built by Add_Process_Element are
8327 -- executed for each element; Indexes is the list of indexes to be
8328 -- used in the construction of the indexed component that denotes the
8329 -- current element. Subprogram is the entity for the subprogram for
8330 -- which this iterator is generated. The generated statements are
8331 -- appended to Stmts.
8335 -- The record entity being dealt with
8337 with procedure Add_Process_Element
8339 Container : Node_Or_Entity_Id;
8340 Counter : in out Int;
8343 -- Rec is the instance of the record type, or Empty.
8344 -- Field is either the N_Defining_Identifier for a component,
8345 -- or an N_Variant_Part.
8347 procedure Append_Record_Traversal
8350 Container : Node_Or_Entity_Id;
8351 Counter : in out Int);
8352 -- Process component list Clist. Individual fields are passed
8353 -- to Field_Processing. Each variant part is also processed.
8354 -- Container is the outer Any (for From_Any/To_Any),
8355 -- the outer typecode (for TC) to which the operation applies.
8357 -----------------------------
8358 -- Append_Record_Traversal --
8359 -----------------------------
8361 procedure Append_Record_Traversal
8364 Container : Node_Or_Entity_Id;
8365 Counter : in out Int)
8369 -- Clist's Component_Items and Variant_Part
8379 CI := Component_Items (Clist);
8380 VP := Variant_Part (Clist);
8383 while Present (Item) loop
8384 Def := Defining_Identifier (Item);
8386 if not Is_Internal_Name (Chars (Def)) then
8388 (Stmts, Container, Counter, Rec, Def);
8394 if Present (VP) then
8395 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8397 end Append_Record_Traversal;
8399 -----------------------------
8400 -- Assign_Opaque_From_Any --
8401 -----------------------------
8403 procedure Assign_Opaque_From_Any
8410 Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
8413 Read_Call_List : List_Id;
8414 -- List on which to place the 'Read attribute reference
8417 -- Strm : Buffer_Stream_Type;
8420 Make_Object_Declaration (Loc,
8421 Defining_Identifier => Strm,
8422 Aliased_Present => True,
8423 Object_Definition =>
8424 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
8426 -- Any_To_BS (Strm, A);
8429 Make_Procedure_Call_Statement (Loc,
8430 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
8431 Parameter_Associations => New_List (
8433 New_Occurrence_Of (Strm, Loc))));
8435 if Transmit_As_Unconstrained (Typ) then
8437 Make_Attribute_Reference (Loc,
8438 Prefix => New_Occurrence_Of (Typ, Loc),
8439 Attribute_Name => Name_Input,
8440 Expressions => New_List (
8441 Make_Attribute_Reference (Loc,
8442 Prefix => New_Occurrence_Of (Strm, Loc),
8443 Attribute_Name => Name_Access)));
8445 -- Target := Typ'Input (Strm'Access)
8447 if Present (Target) then
8449 Make_Assignment_Statement (Loc,
8450 Name => New_Occurrence_Of (Target, Loc),
8451 Expression => Expr));
8453 -- return Typ'Input (Strm'Access);
8457 Make_Simple_Return_Statement (Loc,
8458 Expression => Expr));
8462 if Present (Target) then
8463 Read_Call_List := Stms;
8464 Expr := New_Occurrence_Of (Target, Loc);
8468 Temp : constant Entity_Id := Make_Temporary (Loc, 'R');
8471 Read_Call_List := New_List;
8472 Expr := New_Occurrence_Of (Temp, Loc);
8474 Append_To (Stms, Make_Block_Statement (Loc,
8475 Declarations => New_List (
8476 Make_Object_Declaration (Loc,
8477 Defining_Identifier =>
8479 Object_Definition =>
8480 New_Occurrence_Of (Typ, Loc))),
8482 Handled_Statement_Sequence =>
8483 Make_Handled_Sequence_Of_Statements (Loc,
8484 Statements => Read_Call_List)));
8488 -- Typ'Read (Strm'Access, [Target|Temp])
8490 Append_To (Read_Call_List,
8491 Make_Attribute_Reference (Loc,
8492 Prefix => New_Occurrence_Of (Typ, Loc),
8493 Attribute_Name => Name_Read,
8494 Expressions => New_List (
8495 Make_Attribute_Reference (Loc,
8496 Prefix => New_Occurrence_Of (Strm, Loc),
8497 Attribute_Name => Name_Access),
8504 Append_To (Read_Call_List,
8505 Make_Simple_Return_Statement (Loc,
8506 Expression => New_Copy (Expr)));
8509 end Assign_Opaque_From_Any;
8511 -------------------------
8512 -- Build_From_Any_Call --
8513 -------------------------
8515 function Build_From_Any_Call
8518 Decls : List_Id) return Node_Id
8520 Loc : constant Source_Ptr := Sloc (N);
8522 U_Type : Entity_Id := Underlying_Type (Typ);
8524 Fnam : Entity_Id := Empty;
8525 Lib_RE : RE_Id := RE_Null;
8529 -- First simple case where the From_Any function is present
8530 -- in the type's TSS.
8532 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8534 -- For the subtype representing a generic actual type, go to the
8537 if Is_Generic_Actual_Type (U_Type) then
8538 U_Type := Underlying_Type (Base_Type (U_Type));
8541 -- For a standard subtype, go to the base type
8543 if Sloc (U_Type) <= Standard_Location then
8544 U_Type := Base_Type (U_Type);
8547 -- Check first for Boolean and Character. These are enumeration
8548 -- types, but we treat them specially, since they may require
8549 -- special handling in the transfer protocol. However, this
8550 -- special handling only applies if they have standard
8551 -- representation, otherwise they are treated like any other
8552 -- enumeration type.
8554 if Present (Fnam) then
8557 elsif U_Type = Standard_Boolean then
8560 elsif U_Type = Standard_Character then
8563 elsif U_Type = Standard_Wide_Character then
8566 elsif U_Type = Standard_Wide_Wide_Character then
8567 Lib_RE := RE_FA_WWC;
8569 -- Floating point types
8571 elsif U_Type = Standard_Short_Float then
8574 elsif U_Type = Standard_Float then
8577 elsif U_Type = Standard_Long_Float then
8580 elsif U_Type = Standard_Long_Long_Float then
8581 Lib_RE := RE_FA_LLF;
8585 elsif U_Type = RTE (RE_Integer_8) then
8588 elsif U_Type = RTE (RE_Integer_16) then
8589 Lib_RE := RE_FA_I16;
8591 elsif U_Type = RTE (RE_Integer_32) then
8592 Lib_RE := RE_FA_I32;
8594 elsif U_Type = RTE (RE_Integer_64) then
8595 Lib_RE := RE_FA_I64;
8597 -- Unsigned integer types
8599 elsif U_Type = RTE (RE_Unsigned_8) then
8602 elsif U_Type = RTE (RE_Unsigned_16) then
8603 Lib_RE := RE_FA_U16;
8605 elsif U_Type = RTE (RE_Unsigned_32) then
8606 Lib_RE := RE_FA_U32;
8608 elsif U_Type = RTE (RE_Unsigned_64) then
8609 Lib_RE := RE_FA_U64;
8611 elsif Is_RTE (U_Type, RE_Unbounded_String) then
8612 Lib_RE := RE_FA_String;
8614 -- Special DSA types
8616 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
8619 -- Other (non-primitive) types
8626 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8627 Append_To (Decls, Decl);
8631 -- Call the function
8633 if Lib_RE /= RE_Null then
8634 pragma Assert (No (Fnam));
8635 Fnam := RTE (Lib_RE);
8639 Make_Function_Call (Loc,
8640 Name => New_Occurrence_Of (Fnam, Loc),
8641 Parameter_Associations => New_List (N));
8643 -- We must set the type of Result, so the unchecked conversion
8644 -- from the underlying type to the base type is properly done.
8646 Set_Etype (Result, U_Type);
8648 return Unchecked_Convert_To (Typ, Result);
8649 end Build_From_Any_Call;
8651 -----------------------------
8652 -- Build_From_Any_Function --
8653 -----------------------------
8655 procedure Build_From_Any_Function
8659 Fnam : out Entity_Id)
8662 Decls : constant List_Id := New_List;
8663 Stms : constant List_Id := New_List;
8665 Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A');
8667 Use_Opaque_Representation : Boolean;
8670 -- For a derived type, we can't go past the base type (to the
8671 -- parent type) here, because that would cause the attribute's
8672 -- formal parameter to have the wrong type; hence the Base_Type
8675 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
8676 Build_From_Any_Function
8684 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
8687 Make_Function_Specification (Loc,
8688 Defining_Unit_Name => Fnam,
8689 Parameter_Specifications => New_List (
8690 Make_Parameter_Specification (Loc,
8691 Defining_Identifier => Any_Parameter,
8692 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
8693 Result_Definition => New_Occurrence_Of (Typ, Loc));
8695 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8698 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8700 Use_Opaque_Representation := False;
8702 if Has_Stream_Attribute_Definition
8703 (Typ, TSS_Stream_Output, At_Any_Place => True)
8705 Has_Stream_Attribute_Definition
8706 (Typ, TSS_Stream_Write, At_Any_Place => True)
8708 -- If user-defined stream attributes are specified for this
8709 -- type, use them and transmit data as an opaque sequence of
8712 Use_Opaque_Representation := True;
8714 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
8716 Make_Simple_Return_Statement (Loc,
8721 New_Occurrence_Of (Any_Parameter, Loc),
8724 elsif Is_Record_Type (Typ)
8725 and then not Is_Derived_Type (Typ)
8726 and then not Is_Tagged_Type (Typ)
8728 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8730 Make_Simple_Return_Statement (Loc,
8734 New_Occurrence_Of (Any_Parameter, Loc),
8739 Disc : Entity_Id := Empty;
8740 Discriminant_Associations : List_Id;
8741 Rdef : constant Node_Id :=
8743 (Declaration_Node (Typ));
8744 Component_Counter : Int := 0;
8746 -- The returned object
8748 Res : constant Entity_Id := Make_Temporary (Loc, 'R');
8750 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8752 procedure FA_Rec_Add_Process_Element
8755 Counter : in out Int;
8759 procedure FA_Append_Record_Traversal is
8760 new Append_Record_Traversal
8762 Add_Process_Element => FA_Rec_Add_Process_Element);
8764 --------------------------------
8765 -- FA_Rec_Add_Process_Element --
8766 --------------------------------
8768 procedure FA_Rec_Add_Process_Element
8771 Counter : in out Int;
8777 if Nkind (Field) = N_Defining_Identifier then
8778 -- A regular component
8780 Ctyp := Etype (Field);
8783 Make_Assignment_Statement (Loc,
8784 Name => Make_Selected_Component (Loc,
8786 New_Occurrence_Of (Rec, Loc),
8788 New_Occurrence_Of (Field, Loc)),
8791 Build_From_Any_Call (Ctyp,
8792 Build_Get_Aggregate_Element (Loc,
8795 Build_TypeCode_Call (Loc, Ctyp, Decls),
8797 Make_Integer_Literal (Loc, Counter)),
8805 Struct_Counter : Int := 0;
8807 Block_Decls : constant List_Id := New_List;
8808 Block_Stmts : constant List_Id := New_List;
8811 Alt_List : constant List_Id := New_List;
8812 Choice_List : List_Id;
8814 Struct_Any : constant Entity_Id :=
8815 Make_Temporary (Loc, 'S');
8819 Make_Object_Declaration (Loc,
8820 Defining_Identifier => Struct_Any,
8821 Constant_Present => True,
8822 Object_Definition =>
8823 New_Occurrence_Of (RTE (RE_Any), Loc),
8825 Make_Function_Call (Loc,
8828 (RTE (RE_Extract_Union_Value), Loc),
8830 Parameter_Associations => New_List (
8831 Build_Get_Aggregate_Element (Loc,
8834 Make_Function_Call (Loc,
8835 Name => New_Occurrence_Of (
8836 RTE (RE_Any_Member_Type), Loc),
8837 Parameter_Associations =>
8839 New_Occurrence_Of (Any, Loc),
8840 Make_Integer_Literal (Loc,
8841 Intval => Counter))),
8843 Make_Integer_Literal (Loc,
8844 Intval => Counter))))));
8847 Make_Block_Statement (Loc,
8848 Declarations => Block_Decls,
8849 Handled_Statement_Sequence =>
8850 Make_Handled_Sequence_Of_Statements (Loc,
8851 Statements => Block_Stmts)));
8853 Append_To (Block_Stmts,
8854 Make_Case_Statement (Loc,
8856 Make_Selected_Component (Loc,
8858 Selector_Name => Chars (Name (Field))),
8859 Alternatives => Alt_List));
8861 Variant := First_Non_Pragma (Variants (Field));
8862 while Present (Variant) loop
8865 (Discrete_Choices (Variant));
8867 VP_Stmts := New_List;
8869 -- Struct_Counter should be reset before
8870 -- handling a variant part. Indeed only one
8871 -- of the case statement alternatives will be
8872 -- executed at run time, so the counter must
8873 -- start at 0 for every case statement.
8875 Struct_Counter := 0;
8877 FA_Append_Record_Traversal (
8879 Clist => Component_List (Variant),
8880 Container => Struct_Any,
8881 Counter => Struct_Counter);
8883 Append_To (Alt_List,
8884 Make_Case_Statement_Alternative (Loc,
8885 Discrete_Choices => Choice_List,
8886 Statements => VP_Stmts));
8887 Next_Non_Pragma (Variant);
8892 Counter := Counter + 1;
8893 end FA_Rec_Add_Process_Element;
8896 -- First all discriminants
8898 if Has_Discriminants (Typ) then
8899 Discriminant_Associations := New_List;
8901 Disc := First_Discriminant (Typ);
8902 while Present (Disc) loop
8904 Disc_Var_Name : constant Entity_Id :=
8905 Make_Defining_Identifier (Loc,
8906 Chars => Chars (Disc));
8907 Disc_Type : constant Entity_Id :=
8912 Make_Object_Declaration (Loc,
8913 Defining_Identifier => Disc_Var_Name,
8914 Constant_Present => True,
8915 Object_Definition =>
8916 New_Occurrence_Of (Disc_Type, Loc),
8919 Build_From_Any_Call (Disc_Type,
8920 Build_Get_Aggregate_Element (Loc,
8921 Any => Any_Parameter,
8922 TC => Build_TypeCode_Call
8923 (Loc, Disc_Type, Decls),
8924 Idx => Make_Integer_Literal (Loc,
8925 Intval => Component_Counter)),
8928 Component_Counter := Component_Counter + 1;
8930 Append_To (Discriminant_Associations,
8931 Make_Discriminant_Association (Loc,
8932 Selector_Names => New_List (
8933 New_Occurrence_Of (Disc, Loc)),
8935 New_Occurrence_Of (Disc_Var_Name, Loc)));
8937 Next_Discriminant (Disc);
8941 Make_Subtype_Indication (Loc,
8942 Subtype_Mark => Res_Definition,
8944 Make_Index_Or_Discriminant_Constraint (Loc,
8945 Discriminant_Associations));
8948 -- Now we have all the discriminants in variables, we can
8949 -- declared a constrained object. Note that we are not
8950 -- initializing (non-discriminant) components directly in
8951 -- the object declarations, because which fields to
8952 -- initialize depends (at run time) on the discriminant
8956 Make_Object_Declaration (Loc,
8957 Defining_Identifier => Res,
8958 Object_Definition => Res_Definition));
8960 -- ... then all components
8962 FA_Append_Record_Traversal (Stms,
8963 Clist => Component_List (Rdef),
8964 Container => Any_Parameter,
8965 Counter => Component_Counter);
8968 Make_Simple_Return_Statement (Loc,
8969 Expression => New_Occurrence_Of (Res, Loc)));
8973 elsif Is_Array_Type (Typ) then
8975 Constrained : constant Boolean := Is_Constrained (Typ);
8977 procedure FA_Ary_Add_Process_Element
8980 Counter : Entity_Id;
8982 -- Assign the current element (as identified by Counter) of
8983 -- Any to the variable denoted by name Datum, and advance
8984 -- Counter by 1. If Datum is not an Any, a call to From_Any
8985 -- for its type is inserted.
8987 --------------------------------
8988 -- FA_Ary_Add_Process_Element --
8989 --------------------------------
8991 procedure FA_Ary_Add_Process_Element
8994 Counter : Entity_Id;
8997 Assignment : constant Node_Id :=
8998 Make_Assignment_Statement (Loc,
9000 Expression => Empty);
9002 Element_Any : Node_Id;
9006 Element_TC : Node_Id;
9009 if Etype (Datum) = RTE (RE_Any) then
9011 -- When Datum is an Any the Etype field is not
9012 -- sufficient to determine the typecode of Datum
9013 -- (which can be a TC_SEQUENCE or TC_ARRAY
9014 -- depending on the value of Constrained).
9016 -- Therefore we retrieve the typecode which has
9017 -- been constructed in Append_Array_Traversal with
9018 -- a call to Get_Any_Type.
9021 Make_Function_Call (Loc,
9022 Name => New_Occurrence_Of (
9023 RTE (RE_Get_Any_Type), Loc),
9024 Parameter_Associations => New_List (
9025 New_Occurrence_Of (Entity (Datum), Loc)));
9027 -- For non Any Datum we simply construct a typecode
9028 -- matching the Etype of the Datum.
9030 Element_TC := Build_TypeCode_Call
9031 (Loc, Etype (Datum), Decls);
9035 Build_Get_Aggregate_Element (Loc,
9038 Idx => New_Occurrence_Of (Counter, Loc));
9041 -- Note: here we *prepend* statements to Stmts, so
9042 -- we must do it in reverse order.
9045 Make_Assignment_Statement (Loc,
9047 New_Occurrence_Of (Counter, Loc),
9050 Left_Opnd => New_Occurrence_Of (Counter, Loc),
9051 Right_Opnd => Make_Integer_Literal (Loc, 1))));
9053 if Nkind (Datum) /= N_Attribute_Reference then
9055 -- We ignore the value of the length of each
9056 -- dimension, since the target array has already been
9057 -- constrained anyway.
9059 if Etype (Datum) /= RTE (RE_Any) then
9060 Set_Expression (Assignment,
9062 (Component_Type (Typ), Element_Any, Decls));
9064 Set_Expression (Assignment, Element_Any);
9067 Prepend_To (Stmts, Assignment);
9069 end FA_Ary_Add_Process_Element;
9071 ------------------------
9072 -- Local Declarations --
9073 ------------------------
9075 Counter : constant Entity_Id :=
9076 Make_Defining_Identifier (Loc, Name_J);
9078 Initial_Counter_Value : Int := 0;
9080 Component_TC : constant Entity_Id :=
9081 Make_Defining_Identifier (Loc, Name_T);
9083 Res : constant Entity_Id :=
9084 Make_Defining_Identifier (Loc, Name_R);
9086 procedure Append_From_Any_Array_Iterator is
9087 new Append_Array_Traversal (
9090 Indexes => New_List,
9091 Add_Process_Element => FA_Ary_Add_Process_Element);
9093 Res_Subtype_Indication : Node_Id :=
9094 New_Occurrence_Of (Typ, Loc);
9097 if not Constrained then
9099 Ndim : constant Int := Number_Dimensions (Typ);
9102 Indx : Node_Id := First_Index (Typ);
9105 Ranges : constant List_Id := New_List;
9108 for J in 1 .. Ndim loop
9109 Lnam := New_External_Name ('L', J);
9110 Hnam := New_External_Name ('H', J);
9112 -- Note, for empty arrays bounds may be out of
9113 -- the range of Etype (Indx).
9115 Indt := Base_Type (Etype (Indx));
9118 Make_Object_Declaration (Loc,
9119 Defining_Identifier =>
9120 Make_Defining_Identifier (Loc, Lnam),
9121 Constant_Present => True,
9122 Object_Definition =>
9123 New_Occurrence_Of (Indt, Loc),
9127 Build_Get_Aggregate_Element (Loc,
9128 Any => Any_Parameter,
9129 TC => Build_TypeCode_Call
9132 Make_Integer_Literal (Loc, J - 1)),
9136 Make_Object_Declaration (Loc,
9137 Defining_Identifier =>
9138 Make_Defining_Identifier (Loc, Hnam),
9140 Constant_Present => True,
9142 Object_Definition =>
9143 New_Occurrence_Of (Indt, Loc),
9145 Expression => Make_Attribute_Reference (Loc,
9147 New_Occurrence_Of (Indt, Loc),
9149 Attribute_Name => Name_Val,
9151 Expressions => New_List (
9152 Make_Op_Subtract (Loc,
9157 (Standard_Long_Integer,
9158 Make_Identifier (Loc, Lnam)),
9162 (Standard_Long_Integer,
9163 Make_Function_Call (Loc,
9165 New_Occurrence_Of (RTE (
9166 RE_Get_Nested_Sequence_Length
9168 Parameter_Associations =>
9171 Any_Parameter, Loc),
9172 Make_Integer_Literal (Loc,
9176 Make_Integer_Literal (Loc, 1))))));
9180 Low_Bound => Make_Identifier (Loc, Lnam),
9181 High_Bound => Make_Identifier (Loc, Hnam)));
9186 -- Now we have all the necessary bound information:
9187 -- apply the set of range constraints to the
9188 -- (unconstrained) nominal subtype of Res.
9190 Initial_Counter_Value := Ndim;
9191 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9192 Subtype_Mark => Res_Subtype_Indication,
9194 Make_Index_Or_Discriminant_Constraint (Loc,
9195 Constraints => Ranges));
9200 Make_Object_Declaration (Loc,
9201 Defining_Identifier => Res,
9202 Object_Definition => Res_Subtype_Indication));
9203 Set_Etype (Res, Typ);
9206 Make_Object_Declaration (Loc,
9207 Defining_Identifier => Counter,
9208 Object_Definition =>
9209 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc),
9211 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9214 Make_Object_Declaration (Loc,
9215 Defining_Identifier => Component_TC,
9216 Constant_Present => True,
9217 Object_Definition =>
9218 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9220 Build_TypeCode_Call (Loc,
9221 Component_Type (Typ), Decls)));
9223 Append_From_Any_Array_Iterator
9224 (Stms, Any_Parameter, Counter);
9227 Make_Simple_Return_Statement (Loc,
9228 Expression => New_Occurrence_Of (Res, Loc)));
9231 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9233 Make_Simple_Return_Statement (Loc,
9235 Unchecked_Convert_To (Typ,
9237 (Find_Numeric_Representation (Typ),
9238 New_Occurrence_Of (Any_Parameter, Loc),
9242 Use_Opaque_Representation := True;
9245 if Use_Opaque_Representation then
9246 Assign_Opaque_From_Any (Loc,
9249 N => New_Occurrence_Of (Any_Parameter, Loc),
9254 Make_Subprogram_Body (Loc,
9255 Specification => Spec,
9256 Declarations => Decls,
9257 Handled_Statement_Sequence =>
9258 Make_Handled_Sequence_Of_Statements (Loc,
9259 Statements => Stms));
9260 end Build_From_Any_Function;
9262 ---------------------------------
9263 -- Build_Get_Aggregate_Element --
9264 ---------------------------------
9266 function Build_Get_Aggregate_Element
9270 Idx : Node_Id) return Node_Id
9273 return Make_Function_Call (Loc,
9275 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc),
9276 Parameter_Associations => New_List (
9277 New_Occurrence_Of (Any, Loc),
9280 end Build_Get_Aggregate_Element;
9282 -------------------------
9283 -- Build_Reposiroty_Id --
9284 -------------------------
9286 procedure Build_Name_And_Repository_Id
9288 Name_Str : out String_Id;
9289 Repo_Id_Str : out String_Id)
9293 Store_String_Chars ("DSA:");
9294 Get_Library_Unit_Name_String (Scope (E));
9296 (Name_Buffer (Name_Buffer'First ..
9297 Name_Buffer'First + Name_Len - 1));
9298 Store_String_Char ('.');
9299 Get_Name_String (Chars (E));
9301 (Name_Buffer (Name_Buffer'First ..
9302 Name_Buffer'First + Name_Len - 1));
9303 Store_String_Chars (":1.0");
9304 Repo_Id_Str := End_String;
9305 Name_Str := String_From_Name_Buffer;
9306 end Build_Name_And_Repository_Id;
9308 -----------------------
9309 -- Build_To_Any_Call --
9310 -----------------------
9312 function Build_To_Any_Call
9314 Decls : List_Id) return Node_Id
9316 Loc : constant Source_Ptr := Sloc (N);
9318 Typ : Entity_Id := Etype (N);
9321 Fnam : Entity_Id := Empty;
9322 Lib_RE : RE_Id := RE_Null;
9325 -- If N is a selected component, then maybe its Etype has not been
9326 -- set yet: try to use Etype of the selector_name in that case.
9328 if No (Typ) and then Nkind (N) = N_Selected_Component then
9329 Typ := Etype (Selector_Name (N));
9332 pragma Assert (Present (Typ));
9334 -- Get full view for private type, completion for incomplete type
9336 U_Type := Underlying_Type (Typ);
9338 -- First simple case where the To_Any function is present in the
9341 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9343 -- For the subtype representing a generic actual type, go to the
9346 if Is_Generic_Actual_Type (U_Type) then
9347 U_Type := Underlying_Type (Base_Type (U_Type));
9350 -- For a standard subtype, go to the base type
9352 if Sloc (U_Type) <= Standard_Location then
9353 U_Type := Base_Type (U_Type);
9356 if Present (Fnam) then
9359 -- Check first for Boolean and Character. These are enumeration
9360 -- types, but we treat them specially, since they may require
9361 -- special handling in the transfer protocol. However, this
9362 -- special handling only applies if they have standard
9363 -- representation, otherwise they are treated like any other
9364 -- enumeration type.
9366 elsif U_Type = Standard_Boolean then
9369 elsif U_Type = Standard_Character then
9372 elsif U_Type = Standard_Wide_Character then
9375 elsif U_Type = Standard_Wide_Wide_Character then
9376 Lib_RE := RE_TA_WWC;
9378 -- Floating point types
9380 elsif U_Type = Standard_Short_Float then
9383 elsif U_Type = Standard_Float then
9386 elsif U_Type = Standard_Long_Float then
9389 elsif U_Type = Standard_Long_Long_Float then
9390 Lib_RE := RE_TA_LLF;
9394 elsif U_Type = RTE (RE_Integer_8) then
9397 elsif U_Type = RTE (RE_Integer_16) then
9398 Lib_RE := RE_TA_I16;
9400 elsif U_Type = RTE (RE_Integer_32) then
9401 Lib_RE := RE_TA_I32;
9403 elsif U_Type = RTE (RE_Integer_64) then
9404 Lib_RE := RE_TA_I64;
9406 -- Unsigned integer types
9408 elsif U_Type = RTE (RE_Unsigned_8) then
9411 elsif U_Type = RTE (RE_Unsigned_16) then
9412 Lib_RE := RE_TA_U16;
9414 elsif U_Type = RTE (RE_Unsigned_32) then
9415 Lib_RE := RE_TA_U32;
9417 elsif U_Type = RTE (RE_Unsigned_64) then
9418 Lib_RE := RE_TA_U64;
9420 elsif Is_RTE (U_Type, RE_Unbounded_String) then
9421 Lib_RE := RE_TA_String;
9423 -- Special DSA types
9425 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
9429 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9431 -- No corresponding FA_TC ???
9435 -- Other (non-primitive) types
9441 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9442 Append_To (Decls, Decl);
9446 -- Call the function
9448 if Lib_RE /= RE_Null then
9449 pragma Assert (No (Fnam));
9450 Fnam := RTE (Lib_RE);
9453 -- If Fnam is already analyzed, find the proper expected type,
9454 -- else we have a newly constructed To_Any function and we know
9455 -- that the expected type of its parameter is U_Type.
9457 if Ekind (Fnam) = E_Function
9458 and then Present (First_Formal (Fnam))
9460 C_Type := Etype (First_Formal (Fnam));
9466 Make_Function_Call (Loc,
9467 Name => New_Occurrence_Of (Fnam, Loc),
9468 Parameter_Associations =>
9469 New_List (OK_Convert_To (C_Type, N)));
9470 end Build_To_Any_Call;
9472 ---------------------------
9473 -- Build_To_Any_Function --
9474 ---------------------------
9476 procedure Build_To_Any_Function
9480 Fnam : out Entity_Id)
9483 Decls : constant List_Id := New_List;
9484 Stms : constant List_Id := New_List;
9486 Expr_Parameter : Entity_Id;
9488 Result_TC : Node_Id;
9492 Use_Opaque_Representation : Boolean;
9493 -- When True, use stream attributes and represent type as an
9494 -- opaque sequence of bytes.
9497 -- For a derived type, we can't go past the base type (to the
9498 -- parent type) here, because that would cause the attribute's
9499 -- formal parameter to have the wrong type; hence the Base_Type
9502 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
9503 Build_To_Any_Function
9511 Expr_Parameter := Make_Defining_Identifier (Loc, Name_E);
9512 Any := Make_Defining_Identifier (Loc, Name_A);
9513 Result_TC := Build_TypeCode_Call (Loc, Typ, Decls);
9515 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
9518 Make_Function_Specification (Loc,
9519 Defining_Unit_Name => Fnam,
9520 Parameter_Specifications => New_List (
9521 Make_Parameter_Specification (Loc,
9522 Defining_Identifier => Expr_Parameter,
9523 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9524 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9525 Set_Etype (Expr_Parameter, Typ);
9528 Make_Object_Declaration (Loc,
9529 Defining_Identifier => Any,
9530 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9532 Use_Opaque_Representation := False;
9534 if Has_Stream_Attribute_Definition
9535 (Typ, TSS_Stream_Output, At_Any_Place => True)
9537 Has_Stream_Attribute_Definition
9538 (Typ, TSS_Stream_Write, At_Any_Place => True)
9540 -- If user-defined stream attributes are specified for this
9541 -- type, use them and transmit data as an opaque sequence of
9544 Use_Opaque_Representation := True;
9546 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9548 -- Non-tagged derived type: convert to root type
9551 Rt_Type : constant Entity_Id := Root_Type (Typ);
9552 Expr : constant Node_Id :=
9555 New_Occurrence_Of (Expr_Parameter, Loc));
9557 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9560 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9562 -- Non-tagged record type
9564 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9566 Rt_Type : constant Entity_Id := Etype (Typ);
9567 Expr : constant Node_Id :=
9568 OK_Convert_To (Rt_Type,
9569 New_Occurrence_Of (Expr_Parameter, Loc));
9573 (Any_Decl, Build_To_Any_Call (Expr, Decls));
9576 -- Comment needed here (and label on declare block ???)
9580 Disc : Entity_Id := Empty;
9581 Rdef : constant Node_Id :=
9582 Type_Definition (Declaration_Node (Typ));
9584 Elements : constant List_Id := New_List;
9586 procedure TA_Rec_Add_Process_Element
9588 Container : Node_Or_Entity_Id;
9589 Counter : in out Int;
9592 -- Processing routine for traversal below
9594 procedure TA_Append_Record_Traversal is
9595 new Append_Record_Traversal
9596 (Rec => Expr_Parameter,
9597 Add_Process_Element => TA_Rec_Add_Process_Element);
9599 --------------------------------
9600 -- TA_Rec_Add_Process_Element --
9601 --------------------------------
9603 procedure TA_Rec_Add_Process_Element
9605 Container : Node_Or_Entity_Id;
9606 Counter : in out Int;
9610 Field_Ref : Node_Id;
9613 if Nkind (Field) = N_Defining_Identifier then
9615 -- A regular component
9617 Field_Ref := Make_Selected_Component (Loc,
9618 Prefix => New_Occurrence_Of (Rec, Loc),
9619 Selector_Name => New_Occurrence_Of (Field, Loc));
9620 Set_Etype (Field_Ref, Etype (Field));
9623 Make_Procedure_Call_Statement (Loc,
9626 RTE (RE_Add_Aggregate_Element), Loc),
9627 Parameter_Associations => New_List (
9628 New_Occurrence_Of (Container, Loc),
9629 Build_To_Any_Call (Field_Ref, Decls))));
9634 Variant_Part : declare
9636 Struct_Counter : Int := 0;
9638 Block_Decls : constant List_Id := New_List;
9639 Block_Stmts : constant List_Id := New_List;
9642 Alt_List : constant List_Id := New_List;
9643 Choice_List : List_Id;
9645 Union_Any : constant Entity_Id :=
9646 Make_Temporary (Loc, 'V');
9648 Struct_Any : constant Entity_Id :=
9649 Make_Temporary (Loc, 'S');
9651 function Make_Discriminant_Reference
9653 -- Build reference to the discriminant for this
9656 ---------------------------------
9657 -- Make_Discriminant_Reference --
9658 ---------------------------------
9660 function Make_Discriminant_Reference
9663 Nod : constant Node_Id :=
9664 Make_Selected_Component (Loc,
9667 Chars (Name (Field)));
9669 Set_Etype (Nod, Etype (Name (Field)));
9671 end Make_Discriminant_Reference;
9673 -- Start of processing for Variant_Part
9677 Make_Block_Statement (Loc,
9680 Handled_Statement_Sequence =>
9681 Make_Handled_Sequence_Of_Statements (Loc,
9682 Statements => Block_Stmts)));
9684 -- Declare variant part aggregate (Union_Any).
9685 -- Knowing the position of this VP in the
9686 -- variant record, we can fetch the VP typecode
9689 Append_To (Block_Decls,
9690 Make_Object_Declaration (Loc,
9691 Defining_Identifier => Union_Any,
9692 Object_Definition =>
9693 New_Occurrence_Of (RTE (RE_Any), Loc),
9695 Make_Function_Call (Loc,
9696 Name => New_Occurrence_Of (
9697 RTE (RE_Create_Any), Loc),
9698 Parameter_Associations => New_List (
9699 Make_Function_Call (Loc,
9702 RTE (RE_Any_Member_Type), Loc),
9703 Parameter_Associations => New_List (
9704 New_Occurrence_Of (Container, Loc),
9705 Make_Integer_Literal (Loc,
9708 -- Declare inner struct aggregate (which
9709 -- contains the components of this VP).
9711 Append_To (Block_Decls,
9712 Make_Object_Declaration (Loc,
9713 Defining_Identifier => Struct_Any,
9714 Object_Definition =>
9715 New_Occurrence_Of (RTE (RE_Any), Loc),
9717 Make_Function_Call (Loc,
9718 Name => New_Occurrence_Of (
9719 RTE (RE_Create_Any), Loc),
9720 Parameter_Associations => New_List (
9721 Make_Function_Call (Loc,
9724 RTE (RE_Any_Member_Type), Loc),
9725 Parameter_Associations => New_List (
9726 New_Occurrence_Of (Union_Any, Loc),
9727 Make_Integer_Literal (Loc,
9730 -- Build case statement
9732 Append_To (Block_Stmts,
9733 Make_Case_Statement (Loc,
9734 Expression => Make_Discriminant_Reference,
9735 Alternatives => Alt_List));
9737 Variant := First_Non_Pragma (Variants (Field));
9738 while Present (Variant) loop
9739 Choice_List := New_Copy_List_Tree
9740 (Discrete_Choices (Variant));
9742 VP_Stmts := New_List;
9744 -- Append discriminant val to union aggregate
9746 Append_To (VP_Stmts,
9747 Make_Procedure_Call_Statement (Loc,
9750 RTE (RE_Add_Aggregate_Element), Loc),
9751 Parameter_Associations => New_List (
9752 New_Occurrence_Of (Union_Any, Loc),
9754 (Make_Discriminant_Reference,
9757 -- Populate inner struct aggregate
9759 -- Struct_Counter should be reset before
9760 -- handling a variant part. Indeed only one
9761 -- of the case statement alternatives will be
9762 -- executed at run time, so the counter must
9763 -- start at 0 for every case statement.
9765 Struct_Counter := 0;
9767 TA_Append_Record_Traversal
9769 Clist => Component_List (Variant),
9770 Container => Struct_Any,
9771 Counter => Struct_Counter);
9773 -- Append inner struct to union aggregate
9775 Append_To (VP_Stmts,
9776 Make_Procedure_Call_Statement (Loc,
9779 (RTE (RE_Add_Aggregate_Element), Loc),
9780 Parameter_Associations => New_List (
9781 New_Occurrence_Of (Union_Any, Loc),
9782 New_Occurrence_Of (Struct_Any, Loc))));
9784 -- Append union to outer aggregate
9786 Append_To (VP_Stmts,
9787 Make_Procedure_Call_Statement (Loc,
9790 (RTE (RE_Add_Aggregate_Element), Loc),
9791 Parameter_Associations => New_List (
9792 New_Occurrence_Of (Container, Loc),
9794 (Union_Any, Loc))));
9796 Append_To (Alt_List,
9797 Make_Case_Statement_Alternative (Loc,
9798 Discrete_Choices => Choice_List,
9799 Statements => VP_Stmts));
9801 Next_Non_Pragma (Variant);
9806 Counter := Counter + 1;
9807 end TA_Rec_Add_Process_Element;
9810 -- Records are encoded in a TC_STRUCT aggregate:
9812 -- -- Outer aggregate (TC_STRUCT)
9813 -- | [discriminant1]
9814 -- | [discriminant2]
9821 -- A component can be a common component or variant part
9823 -- A variant part is encoded as a TC_UNION aggregate:
9825 -- -- Variant Part Aggregate (TC_UNION)
9826 -- | [discriminant choice for this Variant Part]
9828 -- | -- Inner struct (TC_STRUCT)
9833 -- Let's start by building the outer aggregate. First we
9834 -- construct Elements array containing all discriminants.
9836 if Has_Discriminants (Typ) then
9837 Disc := First_Discriminant (Typ);
9838 while Present (Disc) loop
9840 Discriminant : constant Entity_Id :=
9841 Make_Selected_Component (Loc,
9848 Set_Etype (Discriminant, Etype (Disc));
9850 Append_To (Elements,
9851 Make_Component_Association (Loc,
9852 Choices => New_List (
9853 Make_Integer_Literal (Loc, Counter)),
9855 Build_To_Any_Call (Discriminant, Decls)));
9858 Counter := Counter + 1;
9859 Next_Discriminant (Disc);
9863 -- If there are no discriminants, we declare an empty
9867 Dummy_Any : constant Entity_Id :=
9868 Make_Temporary (Loc, 'A');
9872 Make_Object_Declaration (Loc,
9873 Defining_Identifier => Dummy_Any,
9874 Object_Definition =>
9875 New_Occurrence_Of (RTE (RE_Any), Loc)));
9877 Append_To (Elements,
9878 Make_Component_Association (Loc,
9879 Choices => New_List (
9882 Make_Integer_Literal (Loc, 1),
9884 Make_Integer_Literal (Loc, 0))),
9886 New_Occurrence_Of (Dummy_Any, Loc)));
9890 -- We build the result aggregate with discriminants
9891 -- as the first elements.
9893 Set_Expression (Any_Decl,
9894 Make_Function_Call (Loc,
9895 Name => New_Occurrence_Of
9896 (RTE (RE_Any_Aggregate_Build), Loc),
9897 Parameter_Associations => New_List (
9899 Make_Aggregate (Loc,
9900 Component_Associations => Elements))));
9903 -- Then we append all the components to the result
9906 TA_Append_Record_Traversal (Stms,
9907 Clist => Component_List (Rdef),
9909 Counter => Counter);
9913 elsif Is_Array_Type (Typ) then
9915 -- Constrained and unconstrained array types
9918 Constrained : constant Boolean := Is_Constrained (Typ);
9920 procedure TA_Ary_Add_Process_Element
9923 Counter : Entity_Id;
9926 --------------------------------
9927 -- TA_Ary_Add_Process_Element --
9928 --------------------------------
9930 procedure TA_Ary_Add_Process_Element
9933 Counter : Entity_Id;
9936 pragma Unreferenced (Counter);
9938 Element_Any : Node_Id;
9941 if Etype (Datum) = RTE (RE_Any) then
9942 Element_Any := Datum;
9944 Element_Any := Build_To_Any_Call (Datum, Decls);
9948 Make_Procedure_Call_Statement (Loc,
9949 Name => New_Occurrence_Of (
9950 RTE (RE_Add_Aggregate_Element), Loc),
9951 Parameter_Associations => New_List (
9952 New_Occurrence_Of (Any, Loc),
9954 end TA_Ary_Add_Process_Element;
9956 procedure Append_To_Any_Array_Iterator is
9957 new Append_Array_Traversal (
9959 Arry => Expr_Parameter,
9960 Indexes => New_List,
9961 Add_Process_Element => TA_Ary_Add_Process_Element);
9966 Set_Expression (Any_Decl,
9967 Make_Function_Call (Loc,
9969 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9970 Parameter_Associations => New_List (Result_TC)));
9973 if not Constrained then
9974 Index := First_Index (Typ);
9975 for J in 1 .. Number_Dimensions (Typ) loop
9977 Make_Procedure_Call_Statement (Loc,
9980 RTE (RE_Add_Aggregate_Element), Loc),
9981 Parameter_Associations => New_List (
9982 New_Occurrence_Of (Any, Loc),
9984 OK_Convert_To (Etype (Index),
9985 Make_Attribute_Reference (Loc,
9987 New_Occurrence_Of (Expr_Parameter, Loc),
9988 Attribute_Name => Name_First,
9989 Expressions => New_List (
9990 Make_Integer_Literal (Loc, J)))),
9996 Append_To_Any_Array_Iterator (Stms, Any);
9999 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10003 Set_Expression (Any_Decl,
10004 Build_To_Any_Call (
10006 Find_Numeric_Representation (Typ),
10007 New_Occurrence_Of (Expr_Parameter, Loc)),
10011 -- Default case, including tagged types: opaque representation
10013 Use_Opaque_Representation := True;
10016 if Use_Opaque_Representation then
10018 Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
10019 -- Stream used to store data representation produced by
10020 -- stream attribute.
10024 -- Strm : aliased Buffer_Stream_Type;
10027 Make_Object_Declaration (Loc,
10028 Defining_Identifier =>
10032 Object_Definition =>
10033 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
10036 -- T'Output (Strm'Access, E);
10039 Make_Attribute_Reference (Loc,
10040 Prefix => New_Occurrence_Of (Typ, Loc),
10041 Attribute_Name => Name_Output,
10042 Expressions => New_List (
10043 Make_Attribute_Reference (Loc,
10044 Prefix => New_Occurrence_Of (Strm, Loc),
10045 Attribute_Name => Name_Access),
10046 New_Occurrence_Of (Expr_Parameter, Loc))));
10049 -- BS_To_Any (Strm, A);
10052 Make_Procedure_Call_Statement (Loc,
10053 Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
10054 Parameter_Associations => New_List (
10055 New_Occurrence_Of (Strm, Loc),
10056 New_Occurrence_Of (Any, Loc))));
10059 -- Release_Buffer (Strm);
10062 Make_Procedure_Call_Statement (Loc,
10063 Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
10064 Parameter_Associations => New_List (
10065 New_Occurrence_Of (Strm, Loc))));
10069 Append_To (Decls, Any_Decl);
10071 if Present (Result_TC) then
10073 Make_Procedure_Call_Statement (Loc,
10074 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
10075 Parameter_Associations => New_List (
10076 New_Occurrence_Of (Any, Loc),
10081 Make_Simple_Return_Statement (Loc,
10082 Expression => New_Occurrence_Of (Any, Loc)));
10085 Make_Subprogram_Body (Loc,
10086 Specification => Spec,
10087 Declarations => Decls,
10088 Handled_Statement_Sequence =>
10089 Make_Handled_Sequence_Of_Statements (Loc,
10090 Statements => Stms));
10091 end Build_To_Any_Function;
10093 -------------------------
10094 -- Build_TypeCode_Call --
10095 -------------------------
10097 function Build_TypeCode_Call
10100 Decls : List_Id) return Node_Id
10102 U_Type : Entity_Id := Underlying_Type (Typ);
10103 -- The full view, if Typ is private; the completion,
10104 -- if Typ is incomplete.
10106 Fnam : Entity_Id := Empty;
10107 Lib_RE : RE_Id := RE_Null;
10111 -- Special case System.PolyORB.Interface.Any: its primitives have
10112 -- not been set yet, so can't call Find_Inherited_TSS.
10114 if Typ = RTE (RE_Any) then
10115 Fnam := RTE (RE_TC_A);
10118 -- First simple case where the TypeCode is present
10119 -- in the type's TSS.
10121 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10124 -- For the subtype representing a generic actual type, go to the
10127 if Is_Generic_Actual_Type (U_Type) then
10128 U_Type := Underlying_Type (Base_Type (U_Type));
10131 -- For a standard subtype, go to the base type
10133 if Sloc (U_Type) <= Standard_Location then
10134 U_Type := Base_Type (U_Type);
10138 if U_Type = Standard_Boolean then
10141 elsif U_Type = Standard_Character then
10144 elsif U_Type = Standard_Wide_Character then
10145 Lib_RE := RE_TC_WC;
10147 elsif U_Type = Standard_Wide_Wide_Character then
10148 Lib_RE := RE_TC_WWC;
10150 -- Floating point types
10152 elsif U_Type = Standard_Short_Float then
10153 Lib_RE := RE_TC_SF;
10155 elsif U_Type = Standard_Float then
10158 elsif U_Type = Standard_Long_Float then
10159 Lib_RE := RE_TC_LF;
10161 elsif U_Type = Standard_Long_Long_Float then
10162 Lib_RE := RE_TC_LLF;
10164 -- Integer types (walk back to the base type)
10166 elsif U_Type = RTE (RE_Integer_8) then
10167 Lib_RE := RE_TC_I8;
10169 elsif U_Type = RTE (RE_Integer_16) then
10170 Lib_RE := RE_TC_I16;
10172 elsif U_Type = RTE (RE_Integer_32) then
10173 Lib_RE := RE_TC_I32;
10175 elsif U_Type = RTE (RE_Integer_64) then
10176 Lib_RE := RE_TC_I64;
10178 -- Unsigned integer types
10180 elsif U_Type = RTE (RE_Unsigned_8) then
10181 Lib_RE := RE_TC_U8;
10183 elsif U_Type = RTE (RE_Unsigned_16) then
10184 Lib_RE := RE_TC_U16;
10186 elsif U_Type = RTE (RE_Unsigned_32) then
10187 Lib_RE := RE_TC_U32;
10189 elsif U_Type = RTE (RE_Unsigned_64) then
10190 Lib_RE := RE_TC_U64;
10192 elsif Is_RTE (U_Type, RE_Unbounded_String) then
10193 Lib_RE := RE_TC_String;
10195 -- Special DSA types
10197 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
10200 -- Other (non-primitive) types
10206 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10207 Append_To (Decls, Decl);
10211 if Lib_RE /= RE_Null then
10212 Fnam := RTE (Lib_RE);
10216 -- Call the function
10219 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10221 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10223 Set_Etype (Expr, RTE (RE_TypeCode));
10226 end Build_TypeCode_Call;
10228 -----------------------------
10229 -- Build_TypeCode_Function --
10230 -----------------------------
10232 procedure Build_TypeCode_Function
10235 Decl : out Node_Id;
10236 Fnam : out Entity_Id)
10239 Decls : constant List_Id := New_List;
10240 Stms : constant List_Id := New_List;
10242 TCNam : constant Entity_Id :=
10243 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
10245 Parameters : List_Id;
10247 procedure Add_String_Parameter
10249 Parameter_List : List_Id);
10250 -- Add a literal for S to Parameters
10252 procedure Add_TypeCode_Parameter
10253 (TC_Node : Node_Id;
10254 Parameter_List : List_Id);
10255 -- Add the typecode for Typ to Parameters
10257 procedure Add_Long_Parameter
10258 (Expr_Node : Node_Id;
10259 Parameter_List : List_Id);
10260 -- Add a signed long integer expression to Parameters
10262 procedure Initialize_Parameter_List
10263 (Name_String : String_Id;
10264 Repo_Id_String : String_Id;
10265 Parameter_List : out List_Id);
10266 -- Return a list that contains the first two parameters
10267 -- for a parameterized typecode: name and repository id.
10269 function Make_Constructed_TypeCode
10271 Parameters : List_Id) return Node_Id;
10272 -- Call TC_Build with the given kind and parameters
10274 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10275 -- Make a return statement that calls TC_Build with the given
10276 -- typecode kind, and the constructed parameters list.
10278 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10279 -- Return a typecode that is a TC_Alias for the given typecode
10281 --------------------------
10282 -- Add_String_Parameter --
10283 --------------------------
10285 procedure Add_String_Parameter
10287 Parameter_List : List_Id)
10290 Append_To (Parameter_List,
10291 Make_Function_Call (Loc,
10292 Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc),
10293 Parameter_Associations => New_List (
10294 Make_String_Literal (Loc, S))));
10295 end Add_String_Parameter;
10297 ----------------------------
10298 -- Add_TypeCode_Parameter --
10299 ----------------------------
10301 procedure Add_TypeCode_Parameter
10302 (TC_Node : Node_Id;
10303 Parameter_List : List_Id)
10306 Append_To (Parameter_List,
10307 Make_Function_Call (Loc,
10308 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10309 Parameter_Associations => New_List (TC_Node)));
10310 end Add_TypeCode_Parameter;
10312 ------------------------
10313 -- Add_Long_Parameter --
10314 ------------------------
10316 procedure Add_Long_Parameter
10317 (Expr_Node : Node_Id;
10318 Parameter_List : List_Id)
10321 Append_To (Parameter_List,
10322 Make_Function_Call (Loc,
10324 New_Occurrence_Of (RTE (RE_TA_I32), Loc),
10325 Parameter_Associations => New_List (Expr_Node)));
10326 end Add_Long_Parameter;
10328 -------------------------------
10329 -- Initialize_Parameter_List --
10330 -------------------------------
10332 procedure Initialize_Parameter_List
10333 (Name_String : String_Id;
10334 Repo_Id_String : String_Id;
10335 Parameter_List : out List_Id)
10338 Parameter_List := New_List;
10339 Add_String_Parameter (Name_String, Parameter_List);
10340 Add_String_Parameter (Repo_Id_String, Parameter_List);
10341 end Initialize_Parameter_List;
10343 ---------------------------
10344 -- Return_Alias_TypeCode --
10345 ---------------------------
10347 procedure Return_Alias_TypeCode
10348 (Base_TypeCode : Node_Id)
10351 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10352 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
10353 end Return_Alias_TypeCode;
10355 -------------------------------
10356 -- Make_Constructed_TypeCode --
10357 -------------------------------
10359 function Make_Constructed_TypeCode
10361 Parameters : List_Id) return Node_Id
10363 Constructed_TC : constant Node_Id :=
10364 Make_Function_Call (Loc,
10366 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
10367 Parameter_Associations => New_List (
10368 New_Occurrence_Of (Kind, Loc),
10369 Make_Aggregate (Loc,
10370 Expressions => Parameters)));
10372 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10373 return Constructed_TC;
10374 end Make_Constructed_TypeCode;
10376 ---------------------------------
10377 -- Return_Constructed_TypeCode --
10378 ---------------------------------
10380 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10383 Make_Simple_Return_Statement (Loc,
10385 Make_Constructed_TypeCode (Kind, Parameters)));
10386 end Return_Constructed_TypeCode;
10392 procedure TC_Rec_Add_Process_Element
10395 Counter : in out Int;
10399 procedure TC_Append_Record_Traversal is
10400 new Append_Record_Traversal (
10402 Add_Process_Element => TC_Rec_Add_Process_Element);
10404 --------------------------------
10405 -- TC_Rec_Add_Process_Element --
10406 --------------------------------
10408 procedure TC_Rec_Add_Process_Element
10411 Counter : in out Int;
10415 pragma Unreferenced (Any, Counter, Rec);
10418 if Nkind (Field) = N_Defining_Identifier then
10420 -- A regular component
10422 Add_TypeCode_Parameter
10423 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10424 Get_Name_String (Chars (Field));
10425 Add_String_Parameter (String_From_Name_Buffer, Params);
10431 Variant_Part : declare
10432 Disc_Type : constant Entity_Id := Etype (Name (Field));
10434 Is_Enum : constant Boolean :=
10435 Is_Enumeration_Type (Disc_Type);
10437 Union_TC_Params : List_Id;
10439 U_Name : constant Name_Id :=
10440 New_External_Name (Chars (Typ), 'V', -1);
10442 Name_Str : String_Id;
10443 Struct_TC_Params : List_Id;
10447 Default : constant Node_Id :=
10448 Make_Integer_Literal (Loc, -1);
10450 Dummy_Counter : Int := 0;
10452 Choice_Index : Int := 0;
10453 -- Index of current choice in TypeCode, used to identify
10454 -- it as the default choice if it is a "when others".
10456 procedure Add_Params_For_Variant_Components;
10457 -- Add a struct TypeCode and a corresponding member name
10458 -- to the union parameter list.
10460 -- Ordering of declarations is a complete mess in this
10461 -- area, it is supposed to be types/variables, then
10462 -- subprogram specs, then subprogram bodies ???
10464 ---------------------------------------
10465 -- Add_Params_For_Variant_Components --
10466 ---------------------------------------
10468 procedure Add_Params_For_Variant_Components is
10469 S_Name : constant Name_Id :=
10470 New_External_Name (U_Name, 'S', -1);
10473 Get_Name_String (S_Name);
10474 Name_Str := String_From_Name_Buffer;
10475 Initialize_Parameter_List
10476 (Name_Str, Name_Str, Struct_TC_Params);
10478 -- Build struct parameters
10480 TC_Append_Record_Traversal (Struct_TC_Params,
10481 Component_List (Variant),
10485 Add_TypeCode_Parameter
10486 (Make_Constructed_TypeCode
10487 (RTE (RE_TC_Struct), Struct_TC_Params),
10490 Add_String_Parameter (Name_Str, Union_TC_Params);
10491 end Add_Params_For_Variant_Components;
10493 -- Start of processing for Variant_Part
10496 Get_Name_String (U_Name);
10497 Name_Str := String_From_Name_Buffer;
10499 Initialize_Parameter_List
10500 (Name_Str, Name_Str, Union_TC_Params);
10502 -- Add union in enclosing parameter list
10504 Add_TypeCode_Parameter
10505 (Make_Constructed_TypeCode
10506 (RTE (RE_TC_Union), Union_TC_Params),
10509 Add_String_Parameter (Name_Str, Params);
10511 -- Build union parameters
10513 Add_TypeCode_Parameter
10514 (Build_TypeCode_Call (Loc, Disc_Type, Decls),
10517 Add_Long_Parameter (Default, Union_TC_Params);
10519 Variant := First_Non_Pragma (Variants (Field));
10520 while Present (Variant) loop
10521 Choice := First (Discrete_Choices (Variant));
10522 while Present (Choice) loop
10523 case Nkind (Choice) is
10526 L : constant Uint :=
10527 Expr_Value (Low_Bound (Choice));
10528 H : constant Uint :=
10529 Expr_Value (High_Bound (Choice));
10531 -- 3.8.1(8) guarantees that the bounds of
10532 -- this range are static.
10539 Expr := Get_Enum_Lit_From_Pos
10540 (Disc_Type, J, Loc);
10543 Make_Integer_Literal (Loc, J);
10546 Set_Etype (Expr, Disc_Type);
10547 Append_To (Union_TC_Params,
10548 Build_To_Any_Call (Expr, Decls));
10550 Add_Params_For_Variant_Components;
10555 Choice_Index + UI_To_Int (H - L) + 1;
10558 when N_Others_Choice =>
10560 -- This variant has a default choice. We must
10561 -- therefore set the default parameter to the
10562 -- current choice index. This parameter is by
10563 -- construction the 4th in Union_TC_Params.
10566 (Pick (Union_TC_Params, 4),
10567 Make_Function_Call (Loc,
10570 (RTE (RE_TA_I32), Loc),
10571 Parameter_Associations =>
10573 Make_Integer_Literal (Loc,
10574 Intval => Choice_Index))));
10576 -- Add a placeholder member label for the
10577 -- default case, which must have the
10578 -- discriminant type.
10581 Exp : constant Node_Id :=
10582 Make_Attribute_Reference (Loc,
10583 Prefix => New_Occurrence_Of
10585 Attribute_Name => Name_First);
10587 Set_Etype (Exp, Disc_Type);
10588 Append_To (Union_TC_Params,
10589 Build_To_Any_Call (Exp, Decls));
10592 Add_Params_For_Variant_Components;
10593 Choice_Index := Choice_Index + 1;
10595 -- Case of an explicit choice
10599 Exp : constant Node_Id :=
10600 New_Copy_Tree (Choice);
10602 Append_To (Union_TC_Params,
10603 Build_To_Any_Call (Exp, Decls));
10606 Add_Params_For_Variant_Components;
10607 Choice_Index := Choice_Index + 1;
10613 Next_Non_Pragma (Variant);
10617 end TC_Rec_Add_Process_Element;
10619 Type_Name_Str : String_Id;
10620 Type_Repo_Id_Str : String_Id;
10622 -- Start of processing for Build_TypeCode_Function
10625 -- For a derived type, we can't go past the base type (to the
10626 -- parent type) here, because that would cause the attribute's
10627 -- formal parameter to have the wrong type; hence the Base_Type
10630 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
10631 Build_TypeCode_Function
10633 Typ => Etype (Typ),
10642 Make_Function_Specification (Loc,
10643 Defining_Unit_Name => Fnam,
10644 Parameter_Specifications => Empty_List,
10645 Result_Definition =>
10646 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10648 Build_Name_And_Repository_Id (Typ,
10649 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10651 Initialize_Parameter_List
10652 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10654 if Has_Stream_Attribute_Definition
10655 (Typ, TSS_Stream_Output, At_Any_Place => True)
10657 Has_Stream_Attribute_Definition
10658 (Typ, TSS_Stream_Write, At_Any_Place => True)
10660 -- If user-defined stream attributes are specified for this
10661 -- type, use them and transmit data as an opaque sequence of
10662 -- stream elements.
10664 Return_Alias_TypeCode
10665 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10667 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
10668 Return_Alias_TypeCode (
10669 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10671 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10672 Return_Alias_TypeCode (
10673 Build_TypeCode_Call (Loc,
10674 Find_Numeric_Representation (Typ), Decls));
10676 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
10678 -- Record typecodes are encoded as follows:
10682 -- | [Repository Id]
10684 -- Then for each discriminant:
10686 -- | [Discriminant Type Code]
10687 -- | [Discriminant Name]
10690 -- Then for each component:
10692 -- | [Component Type Code]
10693 -- | [Component Name]
10696 -- Variants components type codes are encoded as follows:
10700 -- | [Repository Id]
10701 -- | [Discriminant Type Code]
10702 -- | [Index of Default Variant Part or -1 for no default]
10704 -- Then for each Variant Part :
10709 -- | | [Variant Part Name]
10710 -- | | [Variant Part Repository Id]
10712 -- | Then for each VP component:
10713 -- | | [VP component Typecode]
10714 -- | | [VP component Name]
10720 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10721 Return_Alias_TypeCode
10722 (Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10726 Disc : Entity_Id := Empty;
10727 Rdef : constant Node_Id :=
10728 Type_Definition (Declaration_Node (Typ));
10729 Dummy_Counter : Int := 0;
10732 -- Construct the discriminants typecodes
10734 if Has_Discriminants (Typ) then
10735 Disc := First_Discriminant (Typ);
10738 while Present (Disc) loop
10739 Add_TypeCode_Parameter (
10740 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10742 Get_Name_String (Chars (Disc));
10743 Add_String_Parameter (
10744 String_From_Name_Buffer,
10746 Next_Discriminant (Disc);
10749 -- then the components typecodes
10751 TC_Append_Record_Traversal
10752 (Parameters, Component_List (Rdef),
10753 Empty, Dummy_Counter);
10754 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10758 elsif Is_Array_Type (Typ) then
10760 Ndim : constant Pos := Number_Dimensions (Typ);
10761 Inner_TypeCode : Node_Id;
10762 Constrained : constant Boolean := Is_Constrained (Typ);
10763 Indx : Node_Id := First_Index (Typ);
10767 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls);
10769 for J in 1 .. Ndim loop
10770 if Constrained then
10771 Inner_TypeCode := Make_Constructed_TypeCode
10772 (RTE (RE_TC_Array), New_List (
10773 Build_To_Any_Call (
10774 OK_Convert_To (RTE (RE_Unsigned_32),
10775 Make_Attribute_Reference (Loc,
10776 Prefix => New_Occurrence_Of (Typ, Loc),
10777 Attribute_Name => Name_Length,
10778 Expressions => New_List (
10779 Make_Integer_Literal (Loc,
10780 Intval => Ndim - J + 1)))),
10782 Build_To_Any_Call (Inner_TypeCode, Decls)));
10785 -- Unconstrained case: add low bound for each
10788 Add_TypeCode_Parameter
10789 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10791 Get_Name_String (New_External_Name ('L', J));
10792 Add_String_Parameter (
10793 String_From_Name_Buffer,
10797 Inner_TypeCode := Make_Constructed_TypeCode
10798 (RTE (RE_TC_Sequence), New_List (
10799 Build_To_Any_Call (
10800 OK_Convert_To (RTE (RE_Unsigned_32),
10801 Make_Integer_Literal (Loc, 0)),
10803 Build_To_Any_Call (Inner_TypeCode, Decls)));
10807 if Constrained then
10808 Return_Alias_TypeCode (Inner_TypeCode);
10810 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10812 Store_String_Char ('V');
10813 Add_String_Parameter (End_String, Parameters);
10814 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10819 -- Default: type is represented as an opaque sequence of bytes
10821 Return_Alias_TypeCode
10822 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10826 Make_Subprogram_Body (Loc,
10827 Specification => Spec,
10828 Declarations => Decls,
10829 Handled_Statement_Sequence =>
10830 Make_Handled_Sequence_Of_Statements (Loc,
10831 Statements => Stms));
10832 end Build_TypeCode_Function;
10834 ---------------------------------
10835 -- Find_Numeric_Representation --
10836 ---------------------------------
10838 function Find_Numeric_Representation
10839 (Typ : Entity_Id) return Entity_Id
10841 FST : constant Entity_Id := First_Subtype (Typ);
10842 P_Size : constant Uint := Esize (FST);
10845 -- Special case: for Stream_Element_Offset and Storage_Offset,
10846 -- always force transmission as a 64-bit value.
10848 if Is_RTE (FST, RE_Stream_Element_Offset)
10850 Is_RTE (FST, RE_Storage_Offset)
10852 return RTE (RE_Unsigned_64);
10855 if Is_Unsigned_Type (Typ) then
10856 if P_Size <= 8 then
10857 return RTE (RE_Unsigned_8);
10859 elsif P_Size <= 16 then
10860 return RTE (RE_Unsigned_16);
10862 elsif P_Size <= 32 then
10863 return RTE (RE_Unsigned_32);
10866 return RTE (RE_Unsigned_64);
10869 elsif Is_Integer_Type (Typ) then
10870 if P_Size <= 8 then
10871 return RTE (RE_Integer_8);
10873 elsif P_Size <= Standard_Short_Integer_Size then
10874 return RTE (RE_Integer_16);
10876 elsif P_Size <= Standard_Integer_Size then
10877 return RTE (RE_Integer_32);
10880 return RTE (RE_Integer_64);
10883 elsif Is_Floating_Point_Type (Typ) then
10884 if P_Size <= Standard_Short_Float_Size then
10885 return Standard_Short_Float;
10887 elsif P_Size <= Standard_Float_Size then
10888 return Standard_Float;
10890 elsif P_Size <= Standard_Long_Float_Size then
10891 return Standard_Long_Float;
10894 return Standard_Long_Long_Float;
10898 raise Program_Error;
10901 -- TBD: fixed point types???
10902 -- TBverified numeric types with a biased representation???
10904 end Find_Numeric_Representation;
10906 ---------------------------
10907 -- Append_Array_Traversal --
10908 ---------------------------
10910 procedure Append_Array_Traversal
10913 Counter : Entity_Id := Empty;
10916 Loc : constant Source_Ptr := Sloc (Subprogram);
10917 Typ : constant Entity_Id := Etype (Arry);
10918 Constrained : constant Boolean := Is_Constrained (Typ);
10919 Ndim : constant Pos := Number_Dimensions (Typ);
10921 Inner_Any, Inner_Counter : Entity_Id;
10923 Loop_Stm : Node_Id;
10924 Inner_Stmts : constant List_Id := New_List;
10927 if Depth > Ndim then
10929 -- Processing for one element of an array
10932 Element_Expr : constant Node_Id :=
10933 Make_Indexed_Component (Loc,
10934 New_Occurrence_Of (Arry, Loc),
10937 Set_Etype (Element_Expr, Component_Type (Typ));
10938 Add_Process_Element (Stmts,
10940 Counter => Counter,
10941 Datum => Element_Expr);
10947 Append_To (Indexes,
10948 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10950 if not Constrained or else Depth > 1 then
10951 Inner_Any := Make_Defining_Identifier (Loc,
10952 New_External_Name ('A', Depth));
10953 Set_Etype (Inner_Any, RTE (RE_Any));
10955 Inner_Any := Empty;
10958 if Present (Counter) then
10959 Inner_Counter := Make_Defining_Identifier (Loc,
10960 New_External_Name ('J', Depth));
10962 Inner_Counter := Empty;
10966 Loop_Any : Node_Id := Inner_Any;
10969 -- For the first dimension of a constrained array, we add
10970 -- elements directly in the corresponding Any; there is no
10971 -- intervening inner Any.
10973 if No (Loop_Any) then
10977 Append_Array_Traversal (Inner_Stmts,
10979 Counter => Inner_Counter,
10980 Depth => Depth + 1);
10984 Make_Implicit_Loop_Statement (Subprogram,
10985 Iteration_Scheme =>
10986 Make_Iteration_Scheme (Loc,
10987 Loop_Parameter_Specification =>
10988 Make_Loop_Parameter_Specification (Loc,
10989 Defining_Identifier =>
10990 Make_Defining_Identifier (Loc,
10991 Chars => New_External_Name ('L', Depth)),
10993 Discrete_Subtype_Definition =>
10994 Make_Attribute_Reference (Loc,
10995 Prefix => New_Occurrence_Of (Arry, Loc),
10996 Attribute_Name => Name_Range,
10998 Expressions => New_List (
10999 Make_Integer_Literal (Loc, Depth))))),
11000 Statements => Inner_Stmts);
11003 Decls : constant List_Id := New_List;
11004 Dimen_Stmts : constant List_Id := New_List;
11005 Length_Node : Node_Id;
11007 Inner_Any_TypeCode : constant Entity_Id :=
11008 Make_Defining_Identifier (Loc,
11009 New_External_Name ('T', Depth));
11011 Inner_Any_TypeCode_Expr : Node_Id;
11015 if Constrained then
11016 Inner_Any_TypeCode_Expr :=
11017 Make_Function_Call (Loc,
11018 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
11019 Parameter_Associations => New_List (
11020 New_Occurrence_Of (Any, Loc)));
11023 Inner_Any_TypeCode_Expr :=
11024 Make_Function_Call (Loc,
11026 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
11027 Parameter_Associations => New_List (
11028 New_Occurrence_Of (Any, Loc),
11029 Make_Integer_Literal (Loc, Ndim)));
11033 Inner_Any_TypeCode_Expr :=
11034 Make_Function_Call (Loc,
11035 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc),
11036 Parameter_Associations => New_List (
11037 Make_Identifier (Loc,
11038 Chars => New_External_Name ('T', Depth - 1))));
11042 Make_Object_Declaration (Loc,
11043 Defining_Identifier => Inner_Any_TypeCode,
11044 Constant_Present => True,
11045 Object_Definition => New_Occurrence_Of (
11046 RTE (RE_TypeCode), Loc),
11047 Expression => Inner_Any_TypeCode_Expr));
11049 if Present (Inner_Any) then
11051 Make_Object_Declaration (Loc,
11052 Defining_Identifier => Inner_Any,
11053 Object_Definition =>
11054 New_Occurrence_Of (RTE (RE_Any), Loc),
11056 Make_Function_Call (Loc,
11058 New_Occurrence_Of (
11059 RTE (RE_Create_Any), Loc),
11060 Parameter_Associations => New_List (
11061 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
11064 if Present (Inner_Counter) then
11066 Make_Object_Declaration (Loc,
11067 Defining_Identifier => Inner_Counter,
11068 Object_Definition =>
11069 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc),
11071 Make_Integer_Literal (Loc, 0)));
11074 if not Constrained then
11075 Length_Node := Make_Attribute_Reference (Loc,
11076 Prefix => New_Occurrence_Of (Arry, Loc),
11077 Attribute_Name => Name_Length,
11079 New_List (Make_Integer_Literal (Loc, Depth)));
11080 Set_Etype (Length_Node, RTE (RE_Unsigned_32));
11082 Add_Process_Element (Dimen_Stmts,
11083 Datum => Length_Node,
11085 Counter => Inner_Counter);
11088 -- Loop_Stm does appropriate processing for each element
11091 Append_To (Dimen_Stmts, Loop_Stm);
11093 -- Link outer and inner any
11095 if Present (Inner_Any) then
11096 Add_Process_Element (Dimen_Stmts,
11098 Counter => Counter,
11099 Datum => New_Occurrence_Of (Inner_Any, Loc));
11103 Make_Block_Statement (Loc,
11106 Handled_Statement_Sequence =>
11107 Make_Handled_Sequence_Of_Statements (Loc,
11108 Statements => Dimen_Stmts)));
11110 end Append_Array_Traversal;
11112 -------------------------------
11113 -- Make_Helper_Function_Name --
11114 -------------------------------
11116 function Make_Helper_Function_Name
11119 Nam : Name_Id) return Entity_Id
11124 -- For tagged types that aren't frozen yet, generate the helper
11125 -- under its canonical name so that it matches the primitive
11126 -- spec. For all other cases, we use a serialized name so that
11127 -- multiple generations of the same procedure do not clash.
11130 if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then
11133 Serial := Increment_Serial_Number;
11136 -- Use prefixed underscore to avoid potential clash with user
11137 -- identifier (we use attribute names for Nam).
11140 Make_Defining_Identifier (Loc,
11143 (Related_Id => Nam,
11145 Suffix_Index => Serial,
11148 end Make_Helper_Function_Name;
11151 -----------------------------------
11152 -- Reserve_NamingContext_Methods --
11153 -----------------------------------
11155 procedure Reserve_NamingContext_Methods is
11156 Str_Resolve : constant String := "resolve";
11158 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11159 Name_Len := Str_Resolve'Length;
11160 Overload_Counter_Table.Set (Name_Find, 1);
11161 end Reserve_NamingContext_Methods;
11163 end PolyORB_Support;
11165 -------------------------------
11166 -- RACW_Type_Is_Asynchronous --
11167 -------------------------------
11169 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11170 Asynchronous_Flag : constant Entity_Id :=
11171 Asynchronous_Flags_Table.Get (RACW_Type);
11173 Replace (Expression (Parent (Asynchronous_Flag)),
11174 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11175 end RACW_Type_Is_Asynchronous;
11177 -------------------------
11178 -- RCI_Package_Locator --
11179 -------------------------
11181 function RCI_Package_Locator
11183 Package_Spec : Node_Id) return Node_Id
11186 Pkg_Name : String_Id;
11189 Get_Library_Unit_Name_String (Package_Spec);
11190 Pkg_Name := String_From_Name_Buffer;
11192 Make_Package_Instantiation (Loc,
11193 Defining_Unit_Name => Make_Temporary (Loc, 'R'),
11196 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11198 Generic_Associations => New_List (
11199 Make_Generic_Association (Loc,
11201 Make_Identifier (Loc, Name_RCI_Name),
11202 Explicit_Generic_Actual_Parameter =>
11203 Make_String_Literal (Loc,
11204 Strval => Pkg_Name)),
11206 Make_Generic_Association (Loc,
11208 Make_Identifier (Loc, Name_Version),
11209 Explicit_Generic_Actual_Parameter =>
11210 Make_Attribute_Reference (Loc,
11212 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11216 RCI_Locator_Table.Set
11217 (Defining_Unit_Name (Package_Spec),
11218 Defining_Unit_Name (Inst));
11220 end RCI_Package_Locator;
11222 -----------------------------------------------
11223 -- Remote_Types_Tagged_Full_View_Encountered --
11224 -----------------------------------------------
11226 procedure Remote_Types_Tagged_Full_View_Encountered
11227 (Full_View : Entity_Id)
11229 Stub_Elements : constant Stub_Structure :=
11230 Stubs_Table.Get (Full_View);
11233 -- For an RACW encountered before the freeze point of its designated
11234 -- type, the stub type is generated at the point of the RACW declaration
11235 -- but the primitives are generated only once the designated type is
11236 -- frozen. That freeze can occur in another scope, for example when the
11237 -- RACW is declared in a nested package. In that case we need to
11238 -- reestablish the stub type's scope prior to generating its primitive
11241 if Stub_Elements /= Empty_Stub_Structure then
11243 Saved_Scope : constant Entity_Id := Current_Scope;
11244 Stubs_Scope : constant Entity_Id :=
11245 Scope (Stub_Elements.Stub_Type);
11248 if Current_Scope /= Stubs_Scope then
11249 Push_Scope (Stubs_Scope);
11252 Add_RACW_Primitive_Declarations_And_Bodies
11254 Stub_Elements.RPC_Receiver_Decl,
11255 Stub_Elements.Body_Decls);
11257 if Current_Scope /= Saved_Scope then
11262 end Remote_Types_Tagged_Full_View_Encountered;
11264 -------------------
11265 -- Scope_Of_Spec --
11266 -------------------
11268 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11269 Unit_Name : Node_Id;
11272 Unit_Name := Defining_Unit_Name (Spec);
11273 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11274 Unit_Name := Defining_Identifier (Unit_Name);
11280 ----------------------
11281 -- Set_Renaming_TSS --
11282 ----------------------
11284 procedure Set_Renaming_TSS
11287 TSS_Nam : TSS_Name_Type)
11289 Loc : constant Source_Ptr := Sloc (Nam);
11290 Spec : constant Node_Id := Parent (Nam);
11292 TSS_Node : constant Node_Id :=
11293 Make_Subprogram_Renaming_Declaration (Loc,
11295 Copy_Specification (Loc,
11297 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11298 Name => New_Occurrence_Of (Nam, Loc));
11300 Snam : constant Entity_Id :=
11301 Defining_Unit_Name (Specification (TSS_Node));
11304 if Nkind (Spec) = N_Function_Specification then
11305 Set_Ekind (Snam, E_Function);
11306 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11308 Set_Ekind (Snam, E_Procedure);
11309 Set_Etype (Snam, Standard_Void_Type);
11312 Set_TSS (Typ, Snam);
11313 end Set_Renaming_TSS;
11315 ----------------------------------------------
11316 -- Specific_Add_Obj_RPC_Receiver_Completion --
11317 ----------------------------------------------
11319 procedure Specific_Add_Obj_RPC_Receiver_Completion
11322 RPC_Receiver : Entity_Id;
11323 Stub_Elements : Stub_Structure)
11326 case Get_PCS_Name is
11327 when Name_PolyORB_DSA =>
11328 PolyORB_Support.Add_Obj_RPC_Receiver_Completion
11329 (Loc, Decls, RPC_Receiver, Stub_Elements);
11331 GARLIC_Support.Add_Obj_RPC_Receiver_Completion
11332 (Loc, Decls, RPC_Receiver, Stub_Elements);
11334 end Specific_Add_Obj_RPC_Receiver_Completion;
11336 --------------------------------
11337 -- Specific_Add_RACW_Features --
11338 --------------------------------
11340 procedure Specific_Add_RACW_Features
11341 (RACW_Type : Entity_Id;
11343 Stub_Type : Entity_Id;
11344 Stub_Type_Access : Entity_Id;
11345 RPC_Receiver_Decl : Node_Id;
11346 Body_Decls : List_Id)
11349 case Get_PCS_Name is
11350 when Name_PolyORB_DSA =>
11351 PolyORB_Support.Add_RACW_Features
11360 GARLIC_Support.Add_RACW_Features
11367 end Specific_Add_RACW_Features;
11369 --------------------------------
11370 -- Specific_Add_RAST_Features --
11371 --------------------------------
11373 procedure Specific_Add_RAST_Features
11374 (Vis_Decl : Node_Id;
11375 RAS_Type : Entity_Id)
11378 case Get_PCS_Name is
11379 when Name_PolyORB_DSA =>
11380 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11382 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11384 end Specific_Add_RAST_Features;
11386 --------------------------------------------------
11387 -- Specific_Add_Receiving_Stubs_To_Declarations --
11388 --------------------------------------------------
11390 procedure Specific_Add_Receiving_Stubs_To_Declarations
11391 (Pkg_Spec : Node_Id;
11396 case Get_PCS_Name is
11397 when Name_PolyORB_DSA =>
11398 PolyORB_Support.Add_Receiving_Stubs_To_Declarations
11399 (Pkg_Spec, Decls, Stmts);
11401 GARLIC_Support.Add_Receiving_Stubs_To_Declarations
11402 (Pkg_Spec, Decls, Stmts);
11404 end Specific_Add_Receiving_Stubs_To_Declarations;
11406 ------------------------------------------
11407 -- Specific_Build_General_Calling_Stubs --
11408 ------------------------------------------
11410 procedure Specific_Build_General_Calling_Stubs
11412 Statements : List_Id;
11413 Target : RPC_Target;
11414 Subprogram_Id : Node_Id;
11415 Asynchronous : Node_Id := Empty;
11416 Is_Known_Asynchronous : Boolean := False;
11417 Is_Known_Non_Asynchronous : Boolean := False;
11418 Is_Function : Boolean;
11420 Stub_Type : Entity_Id := Empty;
11421 RACW_Type : Entity_Id := Empty;
11425 case Get_PCS_Name is
11426 when Name_PolyORB_DSA =>
11427 PolyORB_Support.Build_General_Calling_Stubs
11433 Is_Known_Asynchronous,
11434 Is_Known_Non_Asynchronous,
11442 GARLIC_Support.Build_General_Calling_Stubs
11446 Target.RPC_Receiver,
11449 Is_Known_Asynchronous,
11450 Is_Known_Non_Asynchronous,
11457 end Specific_Build_General_Calling_Stubs;
11459 --------------------------------------
11460 -- Specific_Build_RPC_Receiver_Body --
11461 --------------------------------------
11463 procedure Specific_Build_RPC_Receiver_Body
11464 (RPC_Receiver : Entity_Id;
11465 Request : out Entity_Id;
11466 Subp_Id : out Entity_Id;
11467 Subp_Index : out Entity_Id;
11468 Stmts : out List_Id;
11469 Decl : out Node_Id)
11472 case Get_PCS_Name is
11473 when Name_PolyORB_DSA =>
11474 PolyORB_Support.Build_RPC_Receiver_Body
11483 GARLIC_Support.Build_RPC_Receiver_Body
11491 end Specific_Build_RPC_Receiver_Body;
11493 --------------------------------
11494 -- Specific_Build_Stub_Target --
11495 --------------------------------
11497 function Specific_Build_Stub_Target
11500 RCI_Locator : Entity_Id;
11501 Controlling_Parameter : Entity_Id) return RPC_Target
11504 case Get_PCS_Name is
11505 when Name_PolyORB_DSA =>
11507 PolyORB_Support.Build_Stub_Target
11508 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11512 GARLIC_Support.Build_Stub_Target
11513 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11515 end Specific_Build_Stub_Target;
11517 ------------------------------
11518 -- Specific_Build_Stub_Type --
11519 ------------------------------
11521 procedure Specific_Build_Stub_Type
11522 (RACW_Type : Entity_Id;
11523 Stub_Type_Comps : out List_Id;
11524 RPC_Receiver_Decl : out Node_Id)
11527 case Get_PCS_Name is
11528 when Name_PolyORB_DSA =>
11529 PolyORB_Support.Build_Stub_Type
11530 (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
11533 GARLIC_Support.Build_Stub_Type
11534 (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl);
11536 end Specific_Build_Stub_Type;
11538 -----------------------------------------------
11539 -- Specific_Build_Subprogram_Receiving_Stubs --
11540 -----------------------------------------------
11542 function Specific_Build_Subprogram_Receiving_Stubs
11543 (Vis_Decl : Node_Id;
11544 Asynchronous : Boolean;
11545 Dynamically_Asynchronous : Boolean := False;
11546 Stub_Type : Entity_Id := Empty;
11547 RACW_Type : Entity_Id := Empty;
11548 Parent_Primitive : Entity_Id := Empty) return Node_Id
11551 case Get_PCS_Name is
11552 when Name_PolyORB_DSA =>
11554 PolyORB_Support.Build_Subprogram_Receiving_Stubs
11557 Dynamically_Asynchronous,
11564 GARLIC_Support.Build_Subprogram_Receiving_Stubs
11567 Dynamically_Asynchronous,
11572 end Specific_Build_Subprogram_Receiving_Stubs;
11574 -------------------------------
11575 -- Transmit_As_Unconstrained --
11576 -------------------------------
11578 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
11581 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
11582 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
11583 end Transmit_As_Unconstrained;
11585 --------------------------
11586 -- Underlying_RACW_Type --
11587 --------------------------
11589 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11590 Record_Type : Entity_Id;
11593 if Ekind (RAS_Typ) = E_Record_Type then
11594 Record_Type := RAS_Typ;
11596 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11597 Record_Type := Equivalent_Type (RAS_Typ);
11601 Etype (Subtype_Indication
11602 (Component_Definition
11603 (First (Component_Items
11606 (Declaration_Node (Record_Type))))))));
11607 end Underlying_RACW_Type;