1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Elists; use Elists;
29 with Exp_Atag; use Exp_Atag;
30 with Exp_Strm; use Exp_Strm;
31 with Exp_Tss; use Exp_Tss;
32 with Exp_Util; use Exp_Util;
34 with Nlists; use Nlists;
35 with Nmake; use Nmake;
37 with Rtsfind; use Rtsfind;
39 with Sem_Cat; use Sem_Cat;
40 with Sem_Ch3; use Sem_Ch3;
41 with Sem_Ch8; use Sem_Ch8;
42 with Sem_Dist; use Sem_Dist;
43 with Sem_Eval; use Sem_Eval;
44 with Sem_Util; use Sem_Util;
45 with Sinfo; use Sinfo;
46 with Stand; use Stand;
47 with Stringt; use Stringt;
48 with Tbuild; use Tbuild;
49 with Ttypes; use Ttypes;
50 with Uintp; use Uintp;
52 with GNAT.HTable; use GNAT.HTable;
54 package body Exp_Dist is
56 -- The following model has been used to implement distributed objects:
57 -- given a designated type D and a RACW type R, then a record of the
60 -- type Stub is tagged record
61 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
64 -- is built. This type has two properties:
66 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
67 -- converted to and from this type to make it suitable for
68 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
69 -- to avoid memory leaks when the same remote object arrive on the
70 -- same partition through several paths;
72 -- 2) It also has the same dispatching table as the designated type D,
73 -- and thus can be used as an object designated by a value of type
74 -- R on any partition other than the one on which the object has
75 -- been created, since only dispatching calls will be performed and
76 -- the fields themselves will not be used. We call Derive_Subprograms
77 -- to fake half a derivation to ensure that the subprograms do have
78 -- the same dispatching table.
80 First_RCI_Subprogram_Id : constant := 2;
81 -- RCI subprograms are numbered starting at 2. The RCI receiver for
82 -- an RCI package can thus identify calls received through remote
83 -- access-to-subprogram dereferences by the fact that they have a
84 -- (primitive) subprogram id of 0, and 1 is used for the internal
85 -- RAS information lookup operation. (This is for the Garlic code
86 -- generation, where subprograms are identified by numbers; in the
87 -- PolyORB version, they are identified by name, with a numeric suffix
90 type Hash_Index is range 0 .. 50;
92 -----------------------
93 -- Local subprograms --
94 -----------------------
96 function Hash (F : Entity_Id) return Hash_Index;
97 -- DSA expansion associates stubs to distributed object types using
98 -- a hash table on entity ids.
100 function Hash (F : Name_Id) return Hash_Index;
101 -- The generation of subprogram identifiers requires an overload counter
102 -- to be associated with each remote subprogram names. These counters
103 -- are maintained in a hash table on name ids.
105 type Subprogram_Identifiers is record
106 Str_Identifier : String_Id;
107 Int_Identifier : Int;
110 package Subprogram_Identifier_Table is
111 new Simple_HTable (Header_Num => Hash_Index,
112 Element => Subprogram_Identifiers,
113 No_Element => (No_String, 0),
117 -- Mapping between a remote subprogram and the corresponding
118 -- subprogram identifiers.
120 package Overload_Counter_Table is
121 new Simple_HTable (Header_Num => Hash_Index,
127 -- Mapping between a subprogram name and an integer that
128 -- counts the number of defining subprogram names with that
129 -- Name_Id encountered so far in a given context (an interface).
131 function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
132 function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
133 function Get_Subprogram_Id (Def : Entity_Id) return Int;
134 -- Given a subprogram defined in a RCI package, get its distribution
135 -- subprogram identifiers (the distribution identifiers are a unique
136 -- subprogram number, and the non-qualified subprogram name, in the
137 -- casing used for the subprogram declaration; if the name is overloaded,
138 -- a double underscore and a serial number are appended.
140 -- The integer identifier is used to perform remote calls with GARLIC;
141 -- the string identifier is used in the case of PolyORB.
143 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
144 -- when receiving a call, the calling stubs will create requests with the
145 -- exact casing of the defining unit name of the called subprogram, so as
146 -- to allow calls to subprograms on distributed nodes that do distinguish
149 -- NOTE: Another design would be to allow a representation clause on
150 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
152 pragma Warnings (Off, Get_Subprogram_Id);
153 -- One homonym only is unreferenced (specific to the GARLIC version)
155 procedure Add_RAS_Dereference_TSS (N : Node_Id);
156 -- Add a subprogram body for RAS Dereference TSS
158 procedure Add_RAS_Proxy_And_Analyze
161 All_Calls_Remote_E : Entity_Id;
162 Proxy_Object_Addr : out Entity_Id);
163 -- Add the proxy type required, on the receiving (server) side, to handle
164 -- calls to the subprogram declared by Vis_Decl through a remote access
165 -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
166 -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
167 -- is appended to Decls. Proxy_Object_Addr is a constant of type
168 -- System.Address that designates an instance of the proxy object.
170 function Build_Remote_Subprogram_Proxy_Type
172 ACR_Expression : Node_Id) return Node_Id;
173 -- Build and return a tagged record type definition for an RCI
174 -- subprogram proxy type.
175 -- ACR_Expression is use as the initialization value for
176 -- the All_Calls_Remote component.
178 function Build_Get_Unique_RP_Call
181 Stub_Type : Entity_Id) return List_Id;
182 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
183 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
184 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
186 function Build_Stub_Tag
188 RACW_Type : Entity_Id) return Node_Id;
189 -- Return an expression denoting the tag of the stub type associated with
192 function Build_Subprogram_Calling_Stubs
195 Asynchronous : Boolean;
196 Dynamically_Asynchronous : Boolean := False;
197 Stub_Type : Entity_Id := Empty;
198 RACW_Type : Entity_Id := Empty;
199 Locator : Entity_Id := Empty;
200 New_Name : Name_Id := No_Name) return Node_Id;
201 -- Build the calling stub for a given subprogram with the subprogram ID
202 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
203 -- parameters of this type will be marshalled instead of the object
204 -- itself. It will then be converted into Stub_Type before performing
205 -- the real call. If Dynamically_Asynchronous is True, then it will be
206 -- computed at run time whether the call is asynchronous or not.
207 -- Otherwise, the value of the formal Asynchronous will be used.
208 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
209 -- New_Name is given, then it will be used instead of the original name.
211 function Build_RPC_Receiver_Specification
212 (RPC_Receiver : Entity_Id;
213 Request_Parameter : Entity_Id) return Node_Id;
214 -- Make a subprogram specification for an RPC receiver, with the given
215 -- defining unit name and formal parameter.
217 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
218 -- Return an ordered parameter list: unconstrained parameters are put
219 -- at the beginning of the list and constrained ones are put after. If
220 -- there are no parameters, an empty list is returned. Special case:
221 -- the controlling formal of the equivalent RACW operation for a RAS
222 -- type is always left in first position.
224 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean;
225 -- True when Typ is an unconstrained type, or a null-excluding access type.
226 -- In either case, this means stubs cannot contain a default-initialized
227 -- object declaration of such type.
229 procedure Add_Calling_Stubs_To_Declarations
232 -- Add calling stubs to the declarative part
234 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
235 -- Return True if nothing prevents the program whose specification is
236 -- given to be asynchronous (i.e. no out parameter).
238 function Pack_Entity_Into_Stream_Access
242 Etyp : Entity_Id := Empty) return Node_Id;
243 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
244 -- then Etype (Object) will be used if present. If the type is
245 -- constrained, then 'Write will be used to output the object,
246 -- If the type is unconstrained, 'Output will be used.
248 function Pack_Node_Into_Stream
252 Etyp : Entity_Id) return Node_Id;
253 -- Similar to above, with an arbitrary node instead of an entity
255 function Pack_Node_Into_Stream_Access
259 Etyp : Entity_Id) return Node_Id;
260 -- Similar to above, with Stream instead of Stream'Access
262 function Make_Selected_Component
265 Selector_Name : Name_Id) return Node_Id;
266 -- Return a selected_component whose prefix denotes the given entity,
267 -- and with the given Selector_Name.
269 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
270 -- Return the scope represented by a given spec
272 procedure Set_Renaming_TSS
275 TSS_Nam : TSS_Name_Type);
276 -- Create a renaming declaration of subprogram Nam,
277 -- and register it as a TSS for Typ with name TSS_Nam.
279 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
280 -- Return True if the current parameter needs an extra formal to reflect
281 -- its constrained status.
283 function Is_RACW_Controlling_Formal
284 (Parameter : Node_Id;
285 Stub_Type : Entity_Id) return Boolean;
286 -- Return True if the current parameter is a controlling formal argument
287 -- of type Stub_Type or access to Stub_Type.
289 procedure Declare_Create_NVList
294 -- Append the declaration of NVList to Decls, and its
295 -- initialization to Stmts.
297 function Add_Parameter_To_NVList
300 Parameter : Entity_Id;
301 Constrained : Boolean;
302 RACW_Ctrl : Boolean := False;
303 Any : Entity_Id) return Node_Id;
304 -- Return a call to Add_Item to add the Any corresponding to the designated
305 -- formal Parameter (with the indicated Constrained status) to NVList.
306 -- RACW_Ctrl must be set to True for controlling formals of distributed
307 -- object primitive operations.
313 -- This record describes various tree fragments associated with the
314 -- generation of RACW calling stubs. One such record exists for every
315 -- distributed object type, i.e. each tagged type that is the designated
316 -- type of one or more RACW type.
318 type Stub_Structure is record
319 Stub_Type : Entity_Id;
320 -- Stub type: this type has the same primitive operations as the
321 -- designated types, but the provided bodies for these operations
322 -- a remote call to an actual target object potentially located on
323 -- another partition; each value of the stub type encapsulates a
324 -- reference to a remote object.
326 Stub_Type_Access : Entity_Id;
327 -- A local access type designating the stub type (this is not an RACW
330 RPC_Receiver_Decl : Node_Id;
331 -- Declaration for the RPC receiver entity associated with the
332 -- designated type. As an exception, for the case of an RACW that
333 -- implements a RAS, no object RPC receiver is generated. Instead,
334 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
335 -- would have been inserted.
337 Body_Decls : List_Id;
338 -- List of subprogram bodies to be included in generated code: bodies
339 -- for the RACW's stream attributes, and for the primitive operations
342 RACW_Type : Entity_Id;
343 -- One of the RACW types designating this distributed object type
344 -- (they are all interchangeable; we use any one of them in order to
345 -- avoid having to create various anonymous access types).
349 Empty_Stub_Structure : constant Stub_Structure :=
350 (Empty, Empty, Empty, No_List, Empty);
352 package Stubs_Table is
353 new Simple_HTable (Header_Num => Hash_Index,
354 Element => Stub_Structure,
355 No_Element => Empty_Stub_Structure,
359 -- Mapping between a RACW designated type and its stub type
361 package Asynchronous_Flags_Table is
362 new Simple_HTable (Header_Num => Hash_Index,
363 Element => Entity_Id,
368 -- Mapping between a RACW type and a constant having the value True
369 -- if the RACW is asynchronous and False otherwise.
371 package RCI_Locator_Table is
372 new Simple_HTable (Header_Num => Hash_Index,
373 Element => Entity_Id,
378 -- Mapping between a RCI package on which All_Calls_Remote applies and
379 -- the generic instantiation of RCI_Locator for this package.
381 package RCI_Calling_Stubs_Table is
382 new Simple_HTable (Header_Num => Hash_Index,
383 Element => Entity_Id,
388 -- Mapping between a RCI subprogram and the corresponding calling stubs
390 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure;
391 -- Return the stub information associated with the given RACW type
393 procedure Add_Stub_Type
394 (Designated_Type : Entity_Id;
395 RACW_Type : Entity_Id;
397 Stub_Type : out Entity_Id;
398 Stub_Type_Access : out Entity_Id;
399 RPC_Receiver_Decl : out Node_Id;
400 Body_Decls : out List_Id;
401 Existing : out Boolean);
402 -- Add the declaration of the stub type, the access to stub type and the
403 -- object RPC receiver at the end of Decls. If these already exist,
404 -- then nothing is added in the tree but the right values are returned
405 -- anyhow and Existing is set to True.
407 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
408 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
409 -- structure table, reset it to No_List, and return the previous value.
411 procedure Add_RACW_Asynchronous_Flag
412 (Declarations : List_Id;
413 RACW_Type : Entity_Id);
414 -- Declare a boolean constant associated with RACW_Type whose value
415 -- indicates at run time whether a pragma Asynchronous applies to it.
417 procedure Assign_Subprogram_Identifier
421 -- Determine the distribution subprogram identifier to
422 -- be used for remote subprogram Def, return it in Id and
423 -- store it in a hash table for later retrieval by
424 -- Get_Subprogram_Id. Spn is the subprogram number.
426 function RCI_Package_Locator
428 Package_Spec : Node_Id) return Node_Id;
429 -- Instantiate the generic package RCI_Locator in order to locate the
430 -- RCI package whose spec is given as argument.
432 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
433 -- Surround a node N by a tag check, as in:
437 -- when E : Ada.Tags.Tag_Error =>
438 -- Raise_Exception (Program_Error'Identity,
439 -- Exception_Message (E));
442 function Input_With_Tag_Check
444 Var_Type : Entity_Id;
445 Stream : Node_Id) return Node_Id;
446 -- Return a function with the following form:
447 -- function R return Var_Type is
449 -- return Var_Type'Input (S);
451 -- when E : Ada.Tags.Tag_Error =>
452 -- Raise_Exception (Program_Error'Identity,
453 -- Exception_Message (E));
456 procedure Build_Actual_Object_Declaration
462 -- Build the declaration of an object with the given defining identifier,
463 -- initialized with Expr if provided, to serve as actual parameter in a
464 -- server stub. If Variable is true, the declared object will be a variable
465 -- (case of an out or in out formal), else it will be a constant. Object's
466 -- Ekind is set accordingly. The declaration, as well as any other
467 -- declarations it requires, are appended to Decls.
469 --------------------------------------------
470 -- Hooks for PCS-specific code generation --
471 --------------------------------------------
473 -- Part of the code generation circuitry for distribution needs to be
474 -- tailored for each implementation of the PCS. For each routine that
475 -- needs to be specialized, a Specific_<routine> wrapper is created,
476 -- which calls the corresponding <routine> in package
477 -- <pcs_implementation>_Support.
479 procedure Specific_Add_RACW_Features
480 (RACW_Type : Entity_Id;
482 Stub_Type : Entity_Id;
483 Stub_Type_Access : Entity_Id;
484 RPC_Receiver_Decl : Node_Id;
485 Body_Decls : List_Id);
486 -- Add declaration for TSSs for a given RACW type. The declarations are
487 -- added just after the declaration of the RACW type itself. If the RACW
488 -- appears in the main unit, Body_Decls is a list of declarations to which
489 -- the bodies are appended. Else Body_Decls is No_List.
490 -- PCS-specific ancillary subprogram for Add_RACW_Features.
492 procedure Specific_Add_RAST_Features
494 RAS_Type : Entity_Id);
495 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
496 -- subprogram for Add_RAST_Features.
498 -- An RPC_Target record is used during construction of calling stubs
499 -- to pass PCS-specific tree fragments corresponding to the information
500 -- necessary to locate the target of a remote subprogram call.
502 type RPC_Target (PCS_Kind : PCS_Names) is record
504 when Name_PolyORB_DSA =>
506 -- An expression whose value is a PolyORB reference to the target
510 Partition : Entity_Id;
511 -- A variable containing the Partition_ID of the target partition
513 RPC_Receiver : Node_Id;
514 -- An expression whose value is the address of the target RPC
519 procedure Specific_Build_General_Calling_Stubs
521 Statements : List_Id;
523 Subprogram_Id : Node_Id;
524 Asynchronous : Node_Id := Empty;
525 Is_Known_Asynchronous : Boolean := False;
526 Is_Known_Non_Asynchronous : Boolean := False;
527 Is_Function : Boolean;
529 Stub_Type : Entity_Id := Empty;
530 RACW_Type : Entity_Id := Empty;
532 -- Build calling stubs for general purpose. The parameters are:
533 -- Decls : a place to put declarations
534 -- Statements : a place to put statements
535 -- Target : PCS-specific target information (see details
536 -- in RPC_Target declaration).
537 -- Subprogram_Id : a node containing the subprogram ID
538 -- Asynchronous : True if an APC must be made instead of an RPC.
539 -- The value needs not be supplied if one of the
540 -- Is_Known_... is True.
541 -- Is_Known_Async... : True if we know that this is asynchronous
542 -- Is_Known_Non_A... : True if we know that this is not asynchronous
543 -- Spec : a node with a Parameter_Specifications and
544 -- a Result_Definition if applicable
545 -- Stub_Type : in case of RACW stubs, parameters of type access
546 -- to Stub_Type will be marshalled using the
547 -- address of the object (the addr field) rather
548 -- than using the 'Write on the stub itself
549 -- Nod : used to provide sloc for generated code
551 function Specific_Build_Stub_Target
554 RCI_Locator : Entity_Id;
555 Controlling_Parameter : Entity_Id) return RPC_Target;
556 -- Build call target information nodes for use within calling stubs. In the
557 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
558 -- for an RACW, Controlling_Parameter is the entity for the controlling
559 -- formal parameter used to determine the location of the target of the
560 -- call. Decls provides a location where variable declarations can be
561 -- appended to construct the necessary values.
563 procedure Specific_Build_Stub_Type
564 (RACW_Type : Entity_Id;
565 Stub_Type : Entity_Id;
566 Stub_Type_Decl : out Node_Id;
567 RPC_Receiver_Decl : out Node_Id);
568 -- Build a type declaration for the stub type associated with an RACW
569 -- type, and the necessary RPC receiver, if applicable. PCS-specific
570 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
571 -- is generated, then RPC_Receiver_Decl is set to Empty.
573 procedure Specific_Build_RPC_Receiver_Body
574 (RPC_Receiver : Entity_Id;
575 Request : out Entity_Id;
576 Subp_Id : out Entity_Id;
577 Subp_Index : out Entity_Id;
580 -- Make a subprogram body for an RPC receiver, with the given
581 -- defining unit name. On return:
582 -- - Subp_Id is the subprogram identifier from the PCS.
583 -- - Subp_Index is the index in the list of subprograms
584 -- used for dispatching (a variable of type Subprogram_Id).
585 -- - Stmts is the place where the request dispatching
586 -- statements can occur,
587 -- - Decl is the subprogram body declaration.
589 function Specific_Build_Subprogram_Receiving_Stubs
591 Asynchronous : Boolean;
592 Dynamically_Asynchronous : Boolean := False;
593 Stub_Type : Entity_Id := Empty;
594 RACW_Type : Entity_Id := Empty;
595 Parent_Primitive : Entity_Id := Empty) return Node_Id;
596 -- Build the receiving stub for a given subprogram. The subprogram
597 -- declaration is also built by this procedure, and the value returned
598 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
599 -- found in the specification, then its address is read from the stream
600 -- instead of the object itself and converted into an access to
601 -- class-wide type before doing the real call using any of the RACW type
602 -- pointing on the designated type.
604 procedure Specific_Add_Obj_RPC_Receiver_Completion
607 RPC_Receiver : Entity_Id;
608 Stub_Elements : Stub_Structure);
609 -- Add the necessary code to Decls after the completion of generation
610 -- of the RACW RPC receiver described by Stub_Elements.
612 procedure Specific_Add_Receiving_Stubs_To_Declarations
616 -- Add receiving stubs to the declarative part of an RCI unit
618 package GARLIC_Support is
620 -- Support for generating DSA code that uses the GARLIC PCS
622 -- The subprograms below provide the GARLIC versions of the
623 -- corresponding Specific_<subprogram> routine declared above.
625 procedure Add_RACW_Features
626 (RACW_Type : Entity_Id;
627 Stub_Type : Entity_Id;
628 Stub_Type_Access : Entity_Id;
629 RPC_Receiver_Decl : Node_Id;
630 Body_Decls : List_Id);
632 procedure Add_RAST_Features
634 RAS_Type : Entity_Id);
636 procedure Build_General_Calling_Stubs
638 Statements : List_Id;
639 Target_Partition : Entity_Id; -- From RPC_Target
640 Target_RPC_Receiver : Node_Id; -- From RPC_Target
641 Subprogram_Id : Node_Id;
642 Asynchronous : Node_Id := Empty;
643 Is_Known_Asynchronous : Boolean := False;
644 Is_Known_Non_Asynchronous : Boolean := False;
645 Is_Function : Boolean;
647 Stub_Type : Entity_Id := Empty;
648 RACW_Type : Entity_Id := Empty;
651 function Build_Stub_Target
654 RCI_Locator : Entity_Id;
655 Controlling_Parameter : Entity_Id) return RPC_Target;
657 procedure Build_Stub_Type
658 (RACW_Type : Entity_Id;
659 Stub_Type : Entity_Id;
660 Stub_Type_Decl : out Node_Id;
661 RPC_Receiver_Decl : out Node_Id);
663 function Build_Subprogram_Receiving_Stubs
665 Asynchronous : Boolean;
666 Dynamically_Asynchronous : Boolean := False;
667 Stub_Type : Entity_Id := Empty;
668 RACW_Type : Entity_Id := Empty;
669 Parent_Primitive : Entity_Id := Empty) return Node_Id;
671 procedure Add_Obj_RPC_Receiver_Completion
674 RPC_Receiver : Entity_Id;
675 Stub_Elements : Stub_Structure);
677 procedure Add_Receiving_Stubs_To_Declarations
682 procedure Build_RPC_Receiver_Body
683 (RPC_Receiver : Entity_Id;
684 Request : out Entity_Id;
685 Subp_Id : out Entity_Id;
686 Subp_Index : out Entity_Id;
692 package PolyORB_Support is
694 -- Support for generating DSA code that uses the PolyORB PCS
696 -- The subprograms below provide the PolyORB versions of the
697 -- corresponding Specific_<subprogram> routine declared above.
699 procedure Add_RACW_Features
700 (RACW_Type : Entity_Id;
702 Stub_Type : Entity_Id;
703 Stub_Type_Access : Entity_Id;
704 RPC_Receiver_Decl : Node_Id;
705 Body_Decls : List_Id);
707 procedure Add_RAST_Features
709 RAS_Type : Entity_Id);
711 procedure Build_General_Calling_Stubs
713 Statements : List_Id;
714 Target_Object : Node_Id; -- From RPC_Target
715 Subprogram_Id : Node_Id;
716 Asynchronous : Node_Id := Empty;
717 Is_Known_Asynchronous : Boolean := False;
718 Is_Known_Non_Asynchronous : Boolean := False;
719 Is_Function : Boolean;
721 Stub_Type : Entity_Id := Empty;
722 RACW_Type : Entity_Id := Empty;
725 function Build_Stub_Target
728 RCI_Locator : Entity_Id;
729 Controlling_Parameter : Entity_Id) return RPC_Target;
731 procedure Build_Stub_Type
732 (RACW_Type : Entity_Id;
733 Stub_Type : Entity_Id;
734 Stub_Type_Decl : out Node_Id;
735 RPC_Receiver_Decl : out Node_Id);
737 function Build_Subprogram_Receiving_Stubs
739 Asynchronous : Boolean;
740 Dynamically_Asynchronous : Boolean := False;
741 Stub_Type : Entity_Id := Empty;
742 RACW_Type : Entity_Id := Empty;
743 Parent_Primitive : Entity_Id := Empty) return Node_Id;
745 procedure Add_Obj_RPC_Receiver_Completion
748 RPC_Receiver : Entity_Id;
749 Stub_Elements : Stub_Structure);
751 procedure Add_Receiving_Stubs_To_Declarations
756 procedure Build_RPC_Receiver_Body
757 (RPC_Receiver : Entity_Id;
758 Request : out Entity_Id;
759 Subp_Id : out Entity_Id;
760 Subp_Index : out Entity_Id;
764 procedure Reserve_NamingContext_Methods;
765 -- Mark the method names for interface NamingContext as already used in
766 -- the overload table, so no clashes occur with user code (with the
767 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
768 -- their methods to be accessed as objects, for the implementation of
769 -- remote access-to-subprogram types).
773 -- Routines to build distribution helper subprograms for user-defined
774 -- types. For implementation of the Distributed systems annex (DSA)
775 -- over the PolyORB generic middleware components, it is necessary to
776 -- generate several supporting subprograms for each application data
777 -- type used in inter-partition communication. These subprograms are:
779 -- A Typecode function returning a high-level description of the
782 -- Two conversion functions allowing conversion of values of the
783 -- type from and to the generic data containers used by PolyORB.
784 -- These generic containers are called 'Any' type values after the
785 -- CORBA terminology, and hence the conversion subprograms are
786 -- named To_Any and From_Any.
788 function Build_From_Any_Call
791 Decls : List_Id) return Node_Id;
792 -- Build call to From_Any attribute function of type Typ with
793 -- expression N as actual parameter. Decls is the declarations list
794 -- for an appropriate enclosing scope of the point where the call
795 -- will be inserted; if the From_Any attribute for Typ needs to be
796 -- generated at this point, its declaration is appended to Decls.
798 procedure Build_From_Any_Function
802 Fnam : out Entity_Id);
803 -- Build From_Any attribute function for Typ. Loc is the reference
804 -- location for generated nodes, Typ is the type for which the
805 -- conversion function is generated. On return, Decl and Fnam contain
806 -- the declaration and entity for the newly-created function.
808 function Build_To_Any_Call
810 Decls : List_Id) return Node_Id;
811 -- Build call to To_Any attribute function with expression as actual
812 -- parameter. Decls is the declarations list for an appropriate
813 -- enclosing scope of the point where the call will be inserted; if
814 -- the To_Any attribute for Typ needs to be generated at this point,
815 -- its declaration is appended to Decls.
817 procedure Build_To_Any_Function
821 Fnam : out Entity_Id);
822 -- Build To_Any attribute function for Typ. Loc is the reference
823 -- location for generated nodes, Typ is the type for which the
824 -- conversion function is generated. On return, Decl and Fnam contain
825 -- the declaration and entity for the newly-created function.
827 function Build_TypeCode_Call
830 Decls : List_Id) return Node_Id;
831 -- Build call to TypeCode attribute function for Typ. Decls is the
832 -- declarations list for an appropriate enclosing scope of the point
833 -- where the call will be inserted; if the To_Any attribute for Typ
834 -- needs to be generated at this point, its declaration is appended
837 procedure Build_TypeCode_Function
841 Fnam : out Entity_Id);
842 -- Build TypeCode attribute function for Typ. Loc is the reference
843 -- location for generated nodes, Typ is the type for which the
844 -- conversion function is generated. On return, Decl and Fnam contain
845 -- the declaration and entity for the newly-created function.
847 procedure Build_Name_And_Repository_Id
849 Name_Str : out String_Id;
850 Repo_Id_Str : out String_Id);
851 -- In the PolyORB distribution model, each distributed object type
852 -- and each distributed operation has a globally unique identifier,
853 -- its Repository Id. This subprogram builds and returns two strings
854 -- for entity E (a distributed object type or operation): one
855 -- containing the name of E, the second containing its repository id.
861 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
863 function Build_From_Any_Call
866 Decls : List_Id) return Node_Id
867 renames PolyORB_Support.Helpers.Build_From_Any_Call;
869 function Build_To_Any_Call
871 Decls : List_Id) return Node_Id
872 renames PolyORB_Support.Helpers.Build_To_Any_Call;
874 function Build_TypeCode_Call
877 Decls : List_Id) return Node_Id
878 renames PolyORB_Support.Helpers.Build_TypeCode_Call;
880 ------------------------------------
881 -- Local variables and structures --
882 ------------------------------------
885 -- Needs comments ???
887 Output_From_Constrained : constant array (Boolean) of Name_Id :=
888 (False => Name_Output,
890 -- The attribute to choose depending on the fact that the parameter
891 -- is constrained or not. There is no such thing as Input_From_Constrained
892 -- since this require separate mechanisms ('Input is a function while
893 -- 'Read is a procedure).
895 ---------------------------------------
896 -- Add_Calling_Stubs_To_Declarations --
897 ---------------------------------------
899 procedure Add_Calling_Stubs_To_Declarations
903 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
904 -- Subprogram id 0 is reserved for calls received from
905 -- remote access-to-subprogram dereferences.
907 Current_Declaration : Node_Id;
908 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
909 RCI_Instantiation : Node_Id;
910 Subp_Stubs : Node_Id;
911 Subp_Str : String_Id;
913 pragma Warnings (Off, Subp_Str);
916 -- The first thing added is an instantiation of the generic package
917 -- System.Partition_Interface.RCI_Locator with the name of this remote
918 -- package. This will act as an interface with the name server to
919 -- determine the Partition_ID and the RPC_Receiver for the receiver
922 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
923 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
925 Append_To (Decls, RCI_Instantiation);
926 Analyze (RCI_Instantiation);
928 -- For each subprogram declaration visible in the spec, we do build a
929 -- body. We also increment a counter to assign a different Subprogram_Id
930 -- to each subprograms. The receiving stubs processing do use the same
931 -- mechanism and will thus assign the same Id and do the correct
934 Overload_Counter_Table.Reset;
935 PolyORB_Support.Reserve_NamingContext_Methods;
937 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
938 while Present (Current_Declaration) loop
939 if Nkind (Current_Declaration) = N_Subprogram_Declaration
940 and then Comes_From_Source (Current_Declaration)
942 Assign_Subprogram_Identifier
943 (Defining_Unit_Name (Specification (Current_Declaration)),
944 Current_Subprogram_Number,
948 Build_Subprogram_Calling_Stubs (
949 Vis_Decl => Current_Declaration,
951 Build_Subprogram_Id (Loc,
952 Defining_Unit_Name (Specification (Current_Declaration))),
954 Nkind (Specification (Current_Declaration)) =
955 N_Procedure_Specification
957 Is_Asynchronous (Defining_Unit_Name (Specification
958 (Current_Declaration))));
960 Append_To (Decls, Subp_Stubs);
961 Analyze (Subp_Stubs);
963 Current_Subprogram_Number := Current_Subprogram_Number + 1;
966 Next (Current_Declaration);
968 end Add_Calling_Stubs_To_Declarations;
970 -----------------------------
971 -- Add_Parameter_To_NVList --
972 -----------------------------
974 function Add_Parameter_To_NVList
977 Parameter : Entity_Id;
978 Constrained : Boolean;
979 RACW_Ctrl : Boolean := False;
980 Any : Entity_Id) return Node_Id
982 Parameter_Name_String : String_Id;
983 Parameter_Mode : Node_Id;
985 function Parameter_Passing_Mode
987 Parameter : Entity_Id;
988 Constrained : Boolean) return Node_Id;
989 -- Return an expression that denotes the parameter passing mode to be
990 -- used for Parameter in distribution stubs, where Constrained is
991 -- Parameter's constrained status.
993 ----------------------------
994 -- Parameter_Passing_Mode --
995 ----------------------------
997 function Parameter_Passing_Mode
999 Parameter : Entity_Id;
1000 Constrained : Boolean) return Node_Id
1005 if Out_Present (Parameter) then
1006 if In_Present (Parameter)
1007 or else not Constrained
1009 -- Unconstrained formals must be translated
1010 -- to 'in' or 'inout', not 'out', because
1011 -- they need to be constrained by the actual.
1013 Lib_RE := RE_Mode_Inout;
1015 Lib_RE := RE_Mode_Out;
1019 Lib_RE := RE_Mode_In;
1022 return New_Occurrence_Of (RTE (Lib_RE), Loc);
1023 end Parameter_Passing_Mode;
1025 -- Start of processing for Add_Parameter_To_NVList
1028 if Nkind (Parameter) = N_Defining_Identifier then
1029 Get_Name_String (Chars (Parameter));
1031 Get_Name_String (Chars (Defining_Identifier (Parameter)));
1034 Parameter_Name_String := String_From_Name_Buffer;
1036 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1038 -- When the parameter passed to Add_Parameter_To_NVList is an
1039 -- Extra_Constrained parameter, Parameter is an N_Defining_
1040 -- Identifier, instead of a complete N_Parameter_Specification.
1041 -- Thus, we explicitly set 'in' mode in this case.
1043 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1047 Parameter_Passing_Mode (Loc, Parameter, Constrained);
1051 Make_Procedure_Call_Statement (Loc,
1054 (RTE (RE_NVList_Add_Item), Loc),
1055 Parameter_Associations => New_List (
1056 New_Occurrence_Of (NVList, Loc),
1057 Make_Function_Call (Loc,
1060 (RTE (RE_To_PolyORB_String), Loc),
1061 Parameter_Associations => New_List (
1062 Make_String_Literal (Loc,
1063 Strval => Parameter_Name_String))),
1064 New_Occurrence_Of (Any, Loc),
1066 end Add_Parameter_To_NVList;
1068 --------------------------------
1069 -- Add_RACW_Asynchronous_Flag --
1070 --------------------------------
1072 procedure Add_RACW_Asynchronous_Flag
1073 (Declarations : List_Id;
1074 RACW_Type : Entity_Id)
1076 Loc : constant Source_Ptr := Sloc (RACW_Type);
1078 Asynchronous_Flag : constant Entity_Id :=
1079 Make_Defining_Identifier (Loc,
1080 New_External_Name (Chars (RACW_Type), 'A'));
1083 -- Declare the asynchronous flag. This flag will be changed to True
1084 -- whenever it is known that the RACW type is asynchronous.
1086 Append_To (Declarations,
1087 Make_Object_Declaration (Loc,
1088 Defining_Identifier => Asynchronous_Flag,
1089 Constant_Present => True,
1090 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1091 Expression => New_Occurrence_Of (Standard_False, Loc)));
1093 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1094 end Add_RACW_Asynchronous_Flag;
1096 -----------------------
1097 -- Add_RACW_Features --
1098 -----------------------
1100 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1101 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1102 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1106 Body_Decls : List_Id;
1108 Stub_Type : Entity_Id;
1109 Stub_Type_Access : Entity_Id;
1110 RPC_Receiver_Decl : Node_Id;
1113 -- True when appropriate stubs have already been generated (this is the
1114 -- case when another RACW with the same designated type has already been
1115 -- encountered), in which case we reuse the previous stubs rather than
1116 -- generating new ones.
1119 if not Expander_Active then
1123 -- Mark the current package declaration as containing an RACW, so that
1124 -- the bodies for the calling stubs and the RACW stream subprograms
1125 -- are attached to the tree when the corresponding body is encountered.
1127 Set_Has_RACW (Current_Scope);
1129 -- Look for place to declare the RACW stub type and RACW operations
1135 -- Case of declaring the RACW in the same package as its designated
1136 -- type: we know that the designated type is a private type, so we
1137 -- use the private declarations list.
1139 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1141 if Present (Private_Declarations (Pkg_Spec)) then
1142 Decls := Private_Declarations (Pkg_Spec);
1144 Decls := Visible_Declarations (Pkg_Spec);
1149 -- Case of declaring the RACW in another package than its designated
1150 -- type: use the private declarations list if present; otherwise
1151 -- use the visible declarations.
1153 Decls := List_Containing (Declaration_Node (RACW_Type));
1157 -- If we were unable to find the declarations, that means that the
1158 -- completion of the type was missing. We can safely return and let the
1159 -- error be caught by the semantic analysis.
1166 (Designated_Type => Desig,
1167 RACW_Type => RACW_Type,
1169 Stub_Type => Stub_Type,
1170 Stub_Type_Access => Stub_Type_Access,
1171 RPC_Receiver_Decl => RPC_Receiver_Decl,
1172 Body_Decls => Body_Decls,
1173 Existing => Existing);
1175 -- If this RACW is not in the main unit, do not generate primitive or
1178 if not Entity_Is_In_Main_Unit (RACW_Type) then
1179 Body_Decls := No_List;
1182 Add_RACW_Asynchronous_Flag
1183 (Declarations => Decls,
1184 RACW_Type => RACW_Type);
1186 Specific_Add_RACW_Features
1187 (RACW_Type => RACW_Type,
1189 Stub_Type => Stub_Type,
1190 Stub_Type_Access => Stub_Type_Access,
1191 RPC_Receiver_Decl => RPC_Receiver_Decl,
1192 Body_Decls => Body_Decls);
1194 -- If we already have stubs for this designated type, nothing to do
1200 if Is_Frozen (Desig) then
1201 Validate_RACW_Primitives (RACW_Type);
1202 Add_RACW_Primitive_Declarations_And_Bodies
1203 (Designated_Type => Desig,
1204 Insertion_Node => RPC_Receiver_Decl,
1205 Body_Decls => Body_Decls);
1208 -- Validate_RACW_Primitives requires the list of all primitives of
1209 -- the designated type, so defer processing until Desig is frozen.
1210 -- See Exp_Ch3.Freeze_Type.
1212 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1214 end Add_RACW_Features;
1216 ------------------------------------------------
1217 -- Add_RACW_Primitive_Declarations_And_Bodies --
1218 ------------------------------------------------
1220 procedure Add_RACW_Primitive_Declarations_And_Bodies
1221 (Designated_Type : Entity_Id;
1222 Insertion_Node : Node_Id;
1223 Body_Decls : List_Id)
1225 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1226 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1227 -- the declarations are recognized as belonging to the current package.
1229 Stub_Elements : constant Stub_Structure :=
1230 Stubs_Table.Get (Designated_Type);
1232 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1234 Is_RAS : constant Boolean :=
1235 not Comes_From_Source (Stub_Elements.RACW_Type);
1236 -- Case of the RACW generated to implement a remote access-to-
1239 Build_Bodies : constant Boolean :=
1240 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1241 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1242 -- only when the main unit is the unit that contains the stub type.
1244 Current_Insertion_Node : Node_Id := Insertion_Node;
1246 RPC_Receiver : Entity_Id;
1247 RPC_Receiver_Statements : List_Id;
1248 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1249 RPC_Receiver_Elsif_Parts : List_Id;
1250 RPC_Receiver_Request : Entity_Id;
1251 RPC_Receiver_Subp_Id : Entity_Id;
1252 RPC_Receiver_Subp_Index : Entity_Id;
1254 Subp_Str : String_Id;
1256 Current_Primitive_Elmt : Elmt_Id;
1257 Current_Primitive : Entity_Id;
1258 Current_Primitive_Body : Node_Id;
1259 Current_Primitive_Spec : Node_Id;
1260 Current_Primitive_Decl : Node_Id;
1261 Current_Primitive_Number : Int := 0;
1262 Current_Primitive_Alias : Node_Id;
1263 Current_Receiver : Entity_Id;
1264 Current_Receiver_Body : Node_Id;
1265 RPC_Receiver_Decl : Node_Id;
1266 Possibly_Asynchronous : Boolean;
1269 if not Expander_Active then
1275 Make_Defining_Identifier (Loc,
1276 Chars => New_Internal_Name ('P'));
1278 Specific_Build_RPC_Receiver_Body
1279 (RPC_Receiver => RPC_Receiver,
1280 Request => RPC_Receiver_Request,
1281 Subp_Id => RPC_Receiver_Subp_Id,
1282 Subp_Index => RPC_Receiver_Subp_Index,
1283 Stmts => RPC_Receiver_Statements,
1284 Decl => RPC_Receiver_Decl);
1286 if Get_PCS_Name = Name_PolyORB_DSA then
1288 -- For the case of PolyORB, we need to map a textual operation
1289 -- name into a primitive index. Currently we do so using a simple
1290 -- sequence of string comparisons.
1292 RPC_Receiver_Elsif_Parts := New_List;
1296 -- Build callers, receivers for every primitive operations and a RPC
1297 -- receiver for this type.
1299 if Present (Primitive_Operations (Designated_Type)) then
1300 Overload_Counter_Table.Reset;
1302 Current_Primitive_Elmt :=
1303 First_Elmt (Primitive_Operations (Designated_Type));
1304 while Current_Primitive_Elmt /= No_Elmt loop
1305 Current_Primitive := Node (Current_Primitive_Elmt);
1307 -- Copy the primitive of all the parents, except predefined ones
1308 -- that are not remotely dispatching. Also omit hidden primitives
1309 -- (occurs in the case of primitives of interface progenitors
1310 -- other than immediate ancestors of the Designated_Type).
1312 if Chars (Current_Primitive) /= Name_uSize
1313 and then Chars (Current_Primitive) /= Name_uAlignment
1315 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1316 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1317 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1318 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1319 Is_TSS (Current_Primitive, TSS_Stream_Write))
1320 and then not Is_Hidden (Current_Primitive)
1322 -- The first thing to do is build an up-to-date copy of the
1323 -- spec with all the formals referencing Designated_Type
1324 -- transformed into formals referencing Stub_Type. Since this
1325 -- primitive may have been inherited, go back the alias chain
1326 -- until the real primitive has been found.
1328 Current_Primitive_Alias := Current_Primitive;
1329 while Present (Alias (Current_Primitive_Alias)) loop
1331 (Current_Primitive_Alias
1332 /= Alias (Current_Primitive_Alias));
1333 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
1336 -- Copy the spec from the original declaration for the purpose
1337 -- of declaring an overriding subprogram: we need to replace
1338 -- the type of each controlling formal with Stub_Type. The
1339 -- primitive may have been declared for Designated_Type or
1340 -- inherited from some ancestor type for which we do not have
1341 -- an easily determined Entity_Id. We have no systematic way
1342 -- of knowing which type to substitute Stub_Type for. Instead,
1343 -- Copy_Specification relies on the flag Is_Controlling_Formal
1344 -- to determine which formals to change.
1346 Current_Primitive_Spec :=
1347 Copy_Specification (Loc,
1348 Spec => Parent (Current_Primitive_Alias),
1349 Ctrl_Type => Stub_Elements.Stub_Type);
1351 Current_Primitive_Decl :=
1352 Make_Subprogram_Declaration (Loc,
1353 Specification => Current_Primitive_Spec);
1355 Insert_After_And_Analyze (Current_Insertion_Node,
1356 Current_Primitive_Decl);
1357 Current_Insertion_Node := Current_Primitive_Decl;
1359 Possibly_Asynchronous :=
1360 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1361 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1363 Assign_Subprogram_Identifier (
1364 Defining_Unit_Name (Current_Primitive_Spec),
1365 Current_Primitive_Number,
1368 if Build_Bodies then
1369 Current_Primitive_Body :=
1370 Build_Subprogram_Calling_Stubs
1371 (Vis_Decl => Current_Primitive_Decl,
1373 Build_Subprogram_Id (Loc,
1374 Defining_Unit_Name (Current_Primitive_Spec)),
1375 Asynchronous => Possibly_Asynchronous,
1376 Dynamically_Asynchronous => Possibly_Asynchronous,
1377 Stub_Type => Stub_Elements.Stub_Type,
1378 RACW_Type => Stub_Elements.RACW_Type);
1379 Append_To (Body_Decls, Current_Primitive_Body);
1381 -- Analyzing the body here would cause the Stub type to
1382 -- be frozen, thus preventing subsequent primitive
1383 -- declarations. For this reason, it will be analyzed
1384 -- later in the regular flow (and in the context of the
1385 -- appropriate unit body, see Append_RACW_Bodies).
1389 -- Build the receiver stubs
1391 if Build_Bodies and then not Is_RAS then
1392 Current_Receiver_Body :=
1393 Specific_Build_Subprogram_Receiving_Stubs
1394 (Vis_Decl => Current_Primitive_Decl,
1395 Asynchronous => Possibly_Asynchronous,
1396 Dynamically_Asynchronous => Possibly_Asynchronous,
1397 Stub_Type => Stub_Elements.Stub_Type,
1398 RACW_Type => Stub_Elements.RACW_Type,
1399 Parent_Primitive => Current_Primitive);
1401 Current_Receiver := Defining_Unit_Name (
1402 Specification (Current_Receiver_Body));
1404 Append_To (Body_Decls, Current_Receiver_Body);
1406 -- Add a case alternative to the receiver
1408 if Get_PCS_Name = Name_PolyORB_DSA then
1409 Append_To (RPC_Receiver_Elsif_Parts,
1410 Make_Elsif_Part (Loc,
1412 Make_Function_Call (Loc,
1415 RTE (RE_Caseless_String_Eq), Loc),
1416 Parameter_Associations => New_List (
1417 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1418 Make_String_Literal (Loc, Subp_Str))),
1420 Then_Statements => New_List (
1421 Make_Assignment_Statement (Loc,
1422 Name => New_Occurrence_Of (
1423 RPC_Receiver_Subp_Index, Loc),
1425 Make_Integer_Literal (Loc,
1426 Intval => Current_Primitive_Number)))));
1429 Append_To (RPC_Receiver_Case_Alternatives,
1430 Make_Case_Statement_Alternative (Loc,
1431 Discrete_Choices => New_List (
1432 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1434 Statements => New_List (
1435 Make_Procedure_Call_Statement (Loc,
1437 New_Occurrence_Of (Current_Receiver, Loc),
1438 Parameter_Associations => New_List (
1439 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1442 -- Increment the index of current primitive
1444 Current_Primitive_Number := Current_Primitive_Number + 1;
1447 Next_Elmt (Current_Primitive_Elmt);
1451 -- Build the case statement and the heart of the subprogram
1453 if Build_Bodies and then not Is_RAS then
1454 if Get_PCS_Name = Name_PolyORB_DSA
1455 and then Present (First (RPC_Receiver_Elsif_Parts))
1457 Append_To (RPC_Receiver_Statements,
1458 Make_Implicit_If_Statement (Designated_Type,
1459 Condition => New_Occurrence_Of (Standard_False, Loc),
1460 Then_Statements => New_List,
1461 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1464 Append_To (RPC_Receiver_Case_Alternatives,
1465 Make_Case_Statement_Alternative (Loc,
1466 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1467 Statements => New_List (Make_Null_Statement (Loc))));
1469 Append_To (RPC_Receiver_Statements,
1470 Make_Case_Statement (Loc,
1472 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1473 Alternatives => RPC_Receiver_Case_Alternatives));
1475 Append_To (Body_Decls, RPC_Receiver_Decl);
1476 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1477 Body_Decls, RPC_Receiver, Stub_Elements);
1479 -- Do not analyze RPC receiver body at this stage since it references
1480 -- subprograms that have not been analyzed yet. It will be analyzed in
1481 -- the regular flow (see Append_RACW_Bodies).
1484 end Add_RACW_Primitive_Declarations_And_Bodies;
1486 -----------------------------
1487 -- Add_RAS_Dereference_TSS --
1488 -----------------------------
1490 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1491 Loc : constant Source_Ptr := Sloc (N);
1493 Type_Def : constant Node_Id := Type_Definition (N);
1494 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1495 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1496 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1498 RACW_Primitive_Name : Node_Id;
1500 Proc : constant Entity_Id :=
1501 Make_Defining_Identifier (Loc,
1502 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1504 Proc_Spec : Node_Id;
1505 Param_Specs : List_Id;
1506 Param_Assoc : constant List_Id := New_List;
1507 Stmts : constant List_Id := New_List;
1509 RAS_Parameter : constant Entity_Id :=
1510 Make_Defining_Identifier (Loc,
1511 Chars => New_Internal_Name ('P'));
1513 Is_Function : constant Boolean :=
1514 Nkind (Type_Def) = N_Access_Function_Definition;
1516 Is_Degenerate : Boolean;
1517 -- Set to True if the subprogram_specification for this RAS has an
1518 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1520 Spec : constant Node_Id := Type_Def;
1522 Current_Parameter : Node_Id;
1524 -- Start of processing for Add_RAS_Dereference_TSS
1527 -- The Dereference TSS for a remote access-to-subprogram type has the
1530 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1533 -- This is called whenever a value of a RAS type is dereferenced
1535 -- First construct a list of parameter specifications:
1537 -- The first formal is the RAS values
1539 Param_Specs := New_List (
1540 Make_Parameter_Specification (Loc,
1541 Defining_Identifier => RAS_Parameter,
1544 New_Occurrence_Of (Fat_Type, Loc)));
1546 -- The following formals are copied from the type declaration
1548 Is_Degenerate := False;
1549 Current_Parameter := First (Parameter_Specifications (Type_Def));
1550 Parameters : while Present (Current_Parameter) loop
1551 if Nkind (Parameter_Type (Current_Parameter)) =
1554 Is_Degenerate := True;
1557 Append_To (Param_Specs,
1558 Make_Parameter_Specification (Loc,
1559 Defining_Identifier =>
1560 Make_Defining_Identifier (Loc,
1561 Chars => Chars (Defining_Identifier (Current_Parameter))),
1562 In_Present => In_Present (Current_Parameter),
1563 Out_Present => Out_Present (Current_Parameter),
1565 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1567 New_Copy_Tree (Expression (Current_Parameter))));
1569 Append_To (Param_Assoc,
1570 Make_Identifier (Loc,
1571 Chars => Chars (Defining_Identifier (Current_Parameter))));
1573 Next (Current_Parameter);
1574 end loop Parameters;
1576 if Is_Degenerate then
1577 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1579 -- Generate a dummy body. This code will never actually be executed,
1580 -- because null is the only legal value for a degenerate RAS type.
1581 -- For legality's sake (in order to avoid generating a function that
1582 -- does not contain a return statement), we include a dummy recursive
1583 -- call on the TSS itself.
1586 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1587 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1590 -- For a normal RAS type, we cast the RAS formal to the corresponding
1591 -- tagged type, and perform a dispatching call to its Call primitive
1594 Prepend_To (Param_Assoc,
1595 Unchecked_Convert_To (RACW_Type,
1596 New_Occurrence_Of (RAS_Parameter, Loc)));
1598 RACW_Primitive_Name :=
1599 Make_Selected_Component (Loc,
1600 Prefix => Scope (RACW_Type),
1601 Selector_Name => Name_uCall);
1606 Make_Simple_Return_Statement (Loc,
1608 Make_Function_Call (Loc,
1609 Name => RACW_Primitive_Name,
1610 Parameter_Associations => Param_Assoc)));
1614 Make_Procedure_Call_Statement (Loc,
1615 Name => RACW_Primitive_Name,
1616 Parameter_Associations => Param_Assoc));
1619 -- Build the complete subprogram
1623 Make_Function_Specification (Loc,
1624 Defining_Unit_Name => Proc,
1625 Parameter_Specifications => Param_Specs,
1626 Result_Definition =>
1628 Entity (Result_Definition (Spec)), Loc));
1630 Set_Ekind (Proc, E_Function);
1632 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1636 Make_Procedure_Specification (Loc,
1637 Defining_Unit_Name => Proc,
1638 Parameter_Specifications => Param_Specs);
1640 Set_Ekind (Proc, E_Procedure);
1641 Set_Etype (Proc, Standard_Void_Type);
1645 Make_Subprogram_Body (Loc,
1646 Specification => Proc_Spec,
1647 Declarations => New_List,
1648 Handled_Statement_Sequence =>
1649 Make_Handled_Sequence_Of_Statements (Loc,
1650 Statements => Stmts)));
1652 Set_TSS (Fat_Type, Proc);
1653 end Add_RAS_Dereference_TSS;
1655 -------------------------------
1656 -- Add_RAS_Proxy_And_Analyze --
1657 -------------------------------
1659 procedure Add_RAS_Proxy_And_Analyze
1662 All_Calls_Remote_E : Entity_Id;
1663 Proxy_Object_Addr : out Entity_Id)
1665 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1667 Subp_Name : constant Entity_Id :=
1668 Defining_Unit_Name (Specification (Vis_Decl));
1670 Pkg_Name : constant Entity_Id :=
1671 Make_Defining_Identifier (Loc,
1672 Chars => New_External_Name (Chars (Subp_Name), 'P', -1));
1674 Proxy_Type : constant Entity_Id :=
1675 Make_Defining_Identifier (Loc,
1678 (Related_Id => Chars (Subp_Name),
1681 Proxy_Type_Full_View : constant Entity_Id :=
1682 Make_Defining_Identifier (Loc,
1683 Chars (Proxy_Type));
1685 Subp_Decl_Spec : constant Node_Id :=
1686 Build_RAS_Primitive_Specification
1687 (Subp_Spec => Specification (Vis_Decl),
1688 Remote_Object_Type => Proxy_Type);
1690 Subp_Body_Spec : constant Node_Id :=
1691 Build_RAS_Primitive_Specification
1692 (Subp_Spec => Specification (Vis_Decl),
1693 Remote_Object_Type => Proxy_Type);
1695 Vis_Decls : constant List_Id := New_List;
1696 Pvt_Decls : constant List_Id := New_List;
1697 Actuals : constant List_Id := New_List;
1699 Perform_Call : Node_Id;
1702 -- type subpP is tagged limited private;
1704 Append_To (Vis_Decls,
1705 Make_Private_Type_Declaration (Loc,
1706 Defining_Identifier => Proxy_Type,
1707 Tagged_Present => True,
1708 Limited_Present => True));
1710 -- [subprogram] Call
1711 -- (Self : access subpP;
1712 -- ...other-formals...)
1715 Append_To (Vis_Decls,
1716 Make_Subprogram_Declaration (Loc,
1717 Specification => Subp_Decl_Spec));
1719 -- A : constant System.Address;
1721 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1723 Append_To (Vis_Decls,
1724 Make_Object_Declaration (Loc,
1725 Defining_Identifier => Proxy_Object_Addr,
1726 Constant_Present => True,
1727 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)));
1731 -- type subpP is tagged limited record
1732 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1736 Append_To (Pvt_Decls,
1737 Make_Full_Type_Declaration (Loc,
1738 Defining_Identifier => Proxy_Type_Full_View,
1740 Build_Remote_Subprogram_Proxy_Type (Loc,
1741 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1743 -- Trick semantic analysis into swapping the public and full view when
1744 -- freezing the public view.
1746 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1749 -- (Self : access O;
1750 -- ...other-formals...) is
1752 -- P (...other-formals...);
1756 -- (Self : access O;
1757 -- ...other-formals...)
1760 -- return F (...other-formals...);
1763 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1765 Make_Procedure_Call_Statement (Loc,
1766 Name => New_Occurrence_Of (Subp_Name, Loc),
1767 Parameter_Associations => Actuals);
1770 Make_Simple_Return_Statement (Loc,
1772 Make_Function_Call (Loc,
1773 Name => New_Occurrence_Of (Subp_Name, Loc),
1774 Parameter_Associations => Actuals));
1777 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1778 pragma Assert (Present (Formal));
1781 exit when No (Formal);
1783 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1786 -- O : aliased subpP;
1788 Append_To (Pvt_Decls,
1789 Make_Object_Declaration (Loc,
1790 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
1791 Aliased_Present => True,
1792 Object_Definition => New_Occurrence_Of (Proxy_Type, Loc)));
1794 -- A : constant System.Address := O'Address;
1796 Append_To (Pvt_Decls,
1797 Make_Object_Declaration (Loc,
1798 Defining_Identifier =>
1799 Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)),
1800 Constant_Present => True,
1801 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc),
1803 Make_Attribute_Reference (Loc,
1804 Prefix => New_Occurrence_Of (
1805 Defining_Identifier (Last (Pvt_Decls)), Loc),
1806 Attribute_Name => Name_Address)));
1809 Make_Package_Declaration (Loc,
1810 Specification => Make_Package_Specification (Loc,
1811 Defining_Unit_Name => Pkg_Name,
1812 Visible_Declarations => Vis_Decls,
1813 Private_Declarations => Pvt_Decls,
1814 End_Label => Empty)));
1815 Analyze (Last (Decls));
1818 Make_Package_Body (Loc,
1819 Defining_Unit_Name =>
1820 Make_Defining_Identifier (Loc, Chars (Pkg_Name)),
1821 Declarations => New_List (
1822 Make_Subprogram_Body (Loc,
1823 Specification => Subp_Body_Spec,
1824 Declarations => New_List,
1825 Handled_Statement_Sequence =>
1826 Make_Handled_Sequence_Of_Statements (Loc,
1827 Statements => New_List (Perform_Call))))));
1828 Analyze (Last (Decls));
1829 end Add_RAS_Proxy_And_Analyze;
1831 -----------------------
1832 -- Add_RAST_Features --
1833 -----------------------
1835 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1836 RAS_Type : constant Entity_Id :=
1837 Equivalent_Type (Defining_Identifier (Vis_Decl));
1839 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1840 Add_RAS_Dereference_TSS (Vis_Decl);
1841 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1842 end Add_RAST_Features;
1848 procedure Add_Stub_Type
1849 (Designated_Type : Entity_Id;
1850 RACW_Type : Entity_Id;
1852 Stub_Type : out Entity_Id;
1853 Stub_Type_Access : out Entity_Id;
1854 RPC_Receiver_Decl : out Node_Id;
1855 Body_Decls : out List_Id;
1856 Existing : out Boolean)
1858 Loc : constant Source_Ptr := Sloc (RACW_Type);
1860 Stub_Elements : constant Stub_Structure :=
1861 Stubs_Table.Get (Designated_Type);
1862 Stub_Type_Decl : Node_Id;
1863 Stub_Type_Access_Decl : Node_Id;
1866 if Stub_Elements /= Empty_Stub_Structure then
1867 Stub_Type := Stub_Elements.Stub_Type;
1868 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1869 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1870 Body_Decls := Stub_Elements.Body_Decls;
1877 Make_Defining_Identifier (Loc,
1878 Chars => New_Internal_Name ('S'));
1879 Set_Ekind (Stub_Type, E_Record_Type);
1880 Set_Is_RACW_Stub_Type (Stub_Type);
1882 Make_Defining_Identifier (Loc,
1883 Chars => New_External_Name
1884 (Related_Id => Chars (Stub_Type), Suffix => 'A'));
1886 Specific_Build_Stub_Type
1887 (RACW_Type, Stub_Type,
1888 Stub_Type_Decl, RPC_Receiver_Decl);
1890 Stub_Type_Access_Decl :=
1891 Make_Full_Type_Declaration (Loc,
1892 Defining_Identifier => Stub_Type_Access,
1894 Make_Access_To_Object_Definition (Loc,
1895 All_Present => True,
1896 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1898 Append_To (Decls, Stub_Type_Decl);
1899 Analyze (Last (Decls));
1900 Append_To (Decls, Stub_Type_Access_Decl);
1901 Analyze (Last (Decls));
1903 -- This is in no way a type derivation, but we fake it to make sure that
1904 -- the dispatching table gets built with the corresponding primitive
1905 -- operations at the right place.
1907 Derive_Subprograms (Parent_Type => Designated_Type,
1908 Derived_Type => Stub_Type);
1910 if Present (RPC_Receiver_Decl) then
1911 Append_To (Decls, RPC_Receiver_Decl);
1913 RPC_Receiver_Decl := Last (Decls);
1916 Body_Decls := New_List;
1918 Stubs_Table.Set (Designated_Type,
1919 (Stub_Type => Stub_Type,
1920 Stub_Type_Access => Stub_Type_Access,
1921 RPC_Receiver_Decl => RPC_Receiver_Decl,
1922 Body_Decls => Body_Decls,
1923 RACW_Type => RACW_Type));
1926 ------------------------
1927 -- Append_RACW_Bodies --
1928 ------------------------
1930 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
1933 E := First_Entity (Spec_Id);
1934 while Present (E) loop
1935 if Is_Remote_Access_To_Class_Wide_Type (E) then
1936 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
1941 end Append_RACW_Bodies;
1943 ----------------------------------
1944 -- Assign_Subprogram_Identifier --
1945 ----------------------------------
1947 procedure Assign_Subprogram_Identifier
1952 N : constant Name_Id := Chars (Def);
1954 Overload_Order : constant Int :=
1955 Overload_Counter_Table.Get (N) + 1;
1958 Overload_Counter_Table.Set (N, Overload_Order);
1960 Get_Name_String (N);
1962 -- Homonym handling: as in Exp_Dbug, but much simpler,
1963 -- because the only entities for which we have to generate
1964 -- names here need only to be disambiguated within their
1967 if Overload_Order > 1 then
1968 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
1969 Name_Len := Name_Len + 2;
1970 Add_Nat_To_Name_Buffer (Overload_Order);
1973 Id := String_From_Name_Buffer;
1974 Subprogram_Identifier_Table.Set (Def,
1975 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
1976 end Assign_Subprogram_Identifier;
1978 -------------------------------------
1979 -- Build_Actual_Object_Declaration --
1980 -------------------------------------
1982 procedure Build_Actual_Object_Declaration
1983 (Object : Entity_Id;
1989 Loc : constant Source_Ptr := Sloc (Object);
1991 -- Declare a temporary object for the actual, possibly initialized with
1992 -- a 'Input/From_Any call.
1994 -- Complication arises in the case of limited types, for which such a
1995 -- declaration is illegal in Ada 95. In that case, we first generate a
1996 -- renaming declaration of the 'Input call, and then if needed we
1997 -- generate an overlaid non-constant view.
1999 if Ada_Version <= Ada_95
2000 and then Is_Limited_Type (Etyp)
2001 and then Present (Expr)
2004 -- Object : Etyp renames <func-call>
2007 Make_Object_Renaming_Declaration (Loc,
2008 Defining_Identifier => Object,
2009 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
2014 -- The name defined by the renaming declaration denotes a
2015 -- constant view; create a non-constant object at the same address
2016 -- to be used as the actual.
2019 Constant_Object : constant Entity_Id :=
2020 Make_Defining_Identifier (Loc,
2021 New_Internal_Name ('P'));
2023 Set_Defining_Identifier
2024 (Last (Decls), Constant_Object);
2026 -- We have an unconstrained Etyp: build the actual constrained
2027 -- subtype for the value we just read from the stream.
2029 -- subtype S is <actual subtype of Constant_Object>;
2032 Build_Actual_Subtype (Etyp,
2033 New_Occurrence_Of (Constant_Object, Loc)));
2038 Make_Object_Declaration (Loc,
2039 Defining_Identifier => Object,
2040 Object_Definition =>
2042 (Defining_Identifier (Last (Decls)), Loc)));
2043 Set_Ekind (Object, E_Variable);
2045 -- Suppress default initialization:
2046 -- pragma Import (Ada, Object);
2050 Chars => Name_Import,
2051 Pragma_Argument_Associations => New_List (
2052 Make_Pragma_Argument_Association (Loc,
2053 Chars => Name_Convention,
2054 Expression => Make_Identifier (Loc, Name_Ada)),
2055 Make_Pragma_Argument_Association (Loc,
2056 Chars => Name_Entity,
2057 Expression => New_Occurrence_Of (Object, Loc)))));
2059 -- for Object'Address use Constant_Object'Address;
2062 Make_Attribute_Definition_Clause (Loc,
2063 Name => New_Occurrence_Of (Object, Loc),
2064 Chars => Name_Address,
2066 Make_Attribute_Reference (Loc,
2067 Prefix => New_Occurrence_Of (Constant_Object, Loc),
2068 Attribute_Name => Name_Address)));
2074 -- General case of a regular object declaration. Object is flagged
2075 -- constant unless it has mode out or in out, to allow the backend
2076 -- to optimize where possible.
2078 -- Object : [constant] Etyp [:= <expr>];
2081 Make_Object_Declaration (Loc,
2082 Defining_Identifier => Object,
2083 Constant_Present => Present (Expr) and then not Variable,
2084 Object_Definition => New_Occurrence_Of (Etyp, Loc),
2085 Expression => Expr));
2087 if Constant_Present (Last (Decls)) then
2088 Set_Ekind (Object, E_Constant);
2090 Set_Ekind (Object, E_Variable);
2093 end Build_Actual_Object_Declaration;
2095 ------------------------------
2096 -- Build_Get_Unique_RP_Call --
2097 ------------------------------
2099 function Build_Get_Unique_RP_Call
2101 Pointer : Entity_Id;
2102 Stub_Type : Entity_Id) return List_Id
2106 Make_Procedure_Call_Statement (Loc,
2108 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2109 Parameter_Associations => New_List (
2110 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2111 New_Occurrence_Of (Pointer, Loc)))),
2113 Make_Assignment_Statement (Loc,
2115 Make_Selected_Component (Loc,
2116 Prefix => New_Occurrence_Of (Pointer, Loc),
2118 New_Occurrence_Of (First_Tag_Component
2119 (Designated_Type (Etype (Pointer))), Loc)),
2121 Make_Attribute_Reference (Loc,
2122 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2123 Attribute_Name => Name_Tag)));
2125 -- Note: The assignment to Pointer._Tag is safe here because
2126 -- we carefully ensured that Stub_Type has exactly the same layout
2127 -- as System.Partition_Interface.RACW_Stub_Type.
2129 end Build_Get_Unique_RP_Call;
2131 -----------------------------------
2132 -- Build_Ordered_Parameters_List --
2133 -----------------------------------
2135 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2136 Constrained_List : List_Id;
2137 Unconstrained_List : List_Id;
2138 Current_Parameter : Node_Id;
2141 First_Parameter : Node_Id;
2142 For_RAS : Boolean := False;
2145 if No (Parameter_Specifications (Spec)) then
2149 Constrained_List := New_List;
2150 Unconstrained_List := New_List;
2151 First_Parameter := First (Parameter_Specifications (Spec));
2153 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2154 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2159 -- Loop through the parameters and add them to the right list. Note that
2160 -- we treat a parameter of a null-excluding access type as unconstrained
2161 -- because we can't declare an object of such a type with default
2164 Current_Parameter := First_Parameter;
2165 while Present (Current_Parameter) loop
2166 Ptyp := Parameter_Type (Current_Parameter);
2168 if (Nkind (Ptyp) = N_Access_Definition
2169 or else not Transmit_As_Unconstrained (Etype (Ptyp)))
2170 and then not (For_RAS and then Current_Parameter = First_Parameter)
2172 Append_To (Constrained_List, New_Copy (Current_Parameter));
2174 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2177 Next (Current_Parameter);
2180 -- Unconstrained parameters are returned first
2182 Append_List_To (Unconstrained_List, Constrained_List);
2184 return Unconstrained_List;
2185 end Build_Ordered_Parameters_List;
2187 ----------------------------------
2188 -- Build_Passive_Partition_Stub --
2189 ----------------------------------
2191 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2193 Pkg_Name : String_Id;
2196 Loc : constant Source_Ptr := Sloc (U);
2199 -- Verify that the implementation supports distribution, by accessing
2200 -- a type defined in the proper version of system.rpc
2203 Dist_OK : Entity_Id;
2204 pragma Warnings (Off, Dist_OK);
2206 Dist_OK := RTE (RE_Params_Stream_Type);
2209 -- Use body if present, spec otherwise
2211 if Nkind (U) = N_Package_Declaration then
2212 Pkg_Spec := Specification (U);
2213 L := Visible_Declarations (Pkg_Spec);
2215 Pkg_Spec := Parent (Corresponding_Spec (U));
2216 L := Declarations (U);
2219 Get_Library_Unit_Name_String (Pkg_Spec);
2220 Pkg_Name := String_From_Name_Buffer;
2222 Make_Procedure_Call_Statement (Loc,
2224 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2225 Parameter_Associations => New_List (
2226 Make_String_Literal (Loc, Pkg_Name),
2227 Make_Attribute_Reference (Loc,
2229 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2230 Attribute_Name => Name_Version)));
2233 end Build_Passive_Partition_Stub;
2235 --------------------------------------
2236 -- Build_RPC_Receiver_Specification --
2237 --------------------------------------
2239 function Build_RPC_Receiver_Specification
2240 (RPC_Receiver : Entity_Id;
2241 Request_Parameter : Entity_Id) return Node_Id
2243 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2246 Make_Procedure_Specification (Loc,
2247 Defining_Unit_Name => RPC_Receiver,
2248 Parameter_Specifications => New_List (
2249 Make_Parameter_Specification (Loc,
2250 Defining_Identifier => Request_Parameter,
2252 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2253 end Build_RPC_Receiver_Specification;
2255 ----------------------------------------
2256 -- Build_Remote_Subprogram_Proxy_Type --
2257 ----------------------------------------
2259 function Build_Remote_Subprogram_Proxy_Type
2261 ACR_Expression : Node_Id) return Node_Id
2265 Make_Record_Definition (Loc,
2266 Tagged_Present => True,
2267 Limited_Present => True,
2269 Make_Component_List (Loc,
2271 Component_Items => New_List (
2272 Make_Component_Declaration (Loc,
2273 Defining_Identifier =>
2274 Make_Defining_Identifier (Loc,
2275 Name_All_Calls_Remote),
2276 Component_Definition =>
2277 Make_Component_Definition (Loc,
2278 Subtype_Indication =>
2279 New_Occurrence_Of (Standard_Boolean, Loc)),
2283 Make_Component_Declaration (Loc,
2284 Defining_Identifier =>
2285 Make_Defining_Identifier (Loc,
2287 Component_Definition =>
2288 Make_Component_Definition (Loc,
2289 Subtype_Indication =>
2290 New_Occurrence_Of (RTE (RE_Address), Loc)),
2292 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2294 Make_Component_Declaration (Loc,
2295 Defining_Identifier =>
2296 Make_Defining_Identifier (Loc,
2298 Component_Definition =>
2299 Make_Component_Definition (Loc,
2300 Subtype_Indication =>
2301 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2302 end Build_Remote_Subprogram_Proxy_Type;
2304 --------------------
2305 -- Build_Stub_Tag --
2306 --------------------
2308 function Build_Stub_Tag
2310 RACW_Type : Entity_Id) return Node_Id
2312 Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type);
2315 Make_Attribute_Reference (Loc,
2316 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2317 Attribute_Name => Name_Tag);
2320 ------------------------------------
2321 -- Build_Subprogram_Calling_Stubs --
2322 ------------------------------------
2324 function Build_Subprogram_Calling_Stubs
2325 (Vis_Decl : Node_Id;
2327 Asynchronous : Boolean;
2328 Dynamically_Asynchronous : Boolean := False;
2329 Stub_Type : Entity_Id := Empty;
2330 RACW_Type : Entity_Id := Empty;
2331 Locator : Entity_Id := Empty;
2332 New_Name : Name_Id := No_Name) return Node_Id
2334 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2336 Decls : constant List_Id := New_List;
2337 Statements : constant List_Id := New_List;
2339 Subp_Spec : Node_Id;
2340 -- The specification of the body
2342 Controlling_Parameter : Entity_Id := Empty;
2344 Asynchronous_Expr : Node_Id := Empty;
2346 RCI_Locator : Entity_Id;
2348 Spec_To_Use : Node_Id;
2350 procedure Insert_Partition_Check (Parameter : Node_Id);
2351 -- Check that the parameter has been elaborated on the same partition
2352 -- than the controlling parameter (E.4(19)).
2354 ----------------------------
2355 -- Insert_Partition_Check --
2356 ----------------------------
2358 procedure Insert_Partition_Check (Parameter : Node_Id) is
2359 Parameter_Entity : constant Entity_Id :=
2360 Defining_Identifier (Parameter);
2362 -- The expression that will be built is of the form:
2364 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2365 -- raise Constraint_Error;
2368 -- We do not check that Parameter is in Stub_Type since such a check
2369 -- has been inserted at the point of call already (a tag check since
2370 -- we have multiple controlling operands).
2373 Make_Raise_Constraint_Error (Loc,
2377 Make_Function_Call (Loc,
2379 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2380 Parameter_Associations =>
2382 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2383 New_Occurrence_Of (Parameter_Entity, Loc)),
2384 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2385 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2386 Reason => CE_Partition_Check_Failed));
2387 end Insert_Partition_Check;
2389 -- Start of processing for Build_Subprogram_Calling_Stubs
2392 Subp_Spec := Copy_Specification (Loc,
2393 Spec => Specification (Vis_Decl),
2394 New_Name => New_Name);
2396 if Locator = Empty then
2397 RCI_Locator := RCI_Cache;
2398 Spec_To_Use := Specification (Vis_Decl);
2400 RCI_Locator := Locator;
2401 Spec_To_Use := Subp_Spec;
2404 -- Find a controlling argument if we have a stub type. Also check
2405 -- if this subprogram can be made asynchronous.
2407 if Present (Stub_Type)
2408 and then Present (Parameter_Specifications (Spec_To_Use))
2411 Current_Parameter : Node_Id :=
2412 First (Parameter_Specifications
2415 while Present (Current_Parameter) loop
2417 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2419 if Controlling_Parameter = Empty then
2420 Controlling_Parameter :=
2421 Defining_Identifier (Current_Parameter);
2423 Insert_Partition_Check (Current_Parameter);
2427 Next (Current_Parameter);
2432 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2434 if Dynamically_Asynchronous then
2435 Asynchronous_Expr := Make_Selected_Component (Loc,
2436 Prefix => Controlling_Parameter,
2437 Selector_Name => Name_Asynchronous);
2440 Specific_Build_General_Calling_Stubs
2442 Statements => Statements,
2443 Target => Specific_Build_Stub_Target (Loc,
2444 Decls, RCI_Locator, Controlling_Parameter),
2445 Subprogram_Id => Subp_Id,
2446 Asynchronous => Asynchronous_Expr,
2447 Is_Known_Asynchronous => Asynchronous
2448 and then not Dynamically_Asynchronous,
2449 Is_Known_Non_Asynchronous
2451 and then not Dynamically_Asynchronous,
2452 Is_Function => Nkind (Spec_To_Use) =
2453 N_Function_Specification,
2454 Spec => Spec_To_Use,
2455 Stub_Type => Stub_Type,
2456 RACW_Type => RACW_Type,
2459 RCI_Calling_Stubs_Table.Set
2460 (Defining_Unit_Name (Specification (Vis_Decl)),
2461 Defining_Unit_Name (Spec_To_Use));
2464 Make_Subprogram_Body (Loc,
2465 Specification => Subp_Spec,
2466 Declarations => Decls,
2467 Handled_Statement_Sequence =>
2468 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2469 end Build_Subprogram_Calling_Stubs;
2471 -------------------------
2472 -- Build_Subprogram_Id --
2473 -------------------------
2475 function Build_Subprogram_Id
2477 E : Entity_Id) return Node_Id
2480 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2482 Current_Declaration : Node_Id;
2483 Current_Subp : Entity_Id;
2484 Current_Subp_Str : String_Id;
2485 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2487 pragma Warnings (Off, Current_Subp_Str);
2490 -- Build_Subprogram_Id is called outside of the context of
2491 -- generating calling or receiving stubs. Hence we are processing
2492 -- an 'Access attribute_reference for an RCI subprogram, for the
2493 -- purpose of obtaining a RAS value.
2496 (Is_Remote_Call_Interface (Scope (E))
2498 (Nkind (Parent (E)) = N_Procedure_Specification
2500 Nkind (Parent (E)) = N_Function_Specification));
2502 Current_Declaration :=
2503 First (Visible_Declarations
2504 (Package_Specification_Of_Scope (Scope (E))));
2505 while Present (Current_Declaration) loop
2506 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2507 and then Comes_From_Source (Current_Declaration)
2509 Current_Subp := Defining_Unit_Name (Specification (
2510 Current_Declaration));
2512 Assign_Subprogram_Identifier
2513 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2515 Current_Subp_Number := Current_Subp_Number + 1;
2518 Next (Current_Declaration);
2523 case Get_PCS_Name is
2524 when Name_PolyORB_DSA =>
2525 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2527 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2529 end Build_Subprogram_Id;
2531 ------------------------
2532 -- Copy_Specification --
2533 ------------------------
2535 function Copy_Specification
2538 Ctrl_Type : Entity_Id := Empty;
2539 New_Name : Name_Id := No_Name) return Node_Id
2541 Parameters : List_Id := No_List;
2543 Current_Parameter : Node_Id;
2544 Current_Identifier : Entity_Id;
2545 Current_Type : Node_Id;
2547 Name_For_New_Spec : Name_Id;
2549 New_Identifier : Entity_Id;
2551 -- Comments needed in body below ???
2554 if New_Name = No_Name then
2555 pragma Assert (Nkind (Spec) = N_Function_Specification
2556 or else Nkind (Spec) = N_Procedure_Specification);
2558 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2560 Name_For_New_Spec := New_Name;
2563 if Present (Parameter_Specifications (Spec)) then
2564 Parameters := New_List;
2565 Current_Parameter := First (Parameter_Specifications (Spec));
2566 while Present (Current_Parameter) loop
2567 Current_Identifier := Defining_Identifier (Current_Parameter);
2568 Current_Type := Parameter_Type (Current_Parameter);
2570 if Nkind (Current_Type) = N_Access_Definition then
2571 if Present (Ctrl_Type) then
2572 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2574 Make_Access_Definition (Loc,
2575 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2576 Null_Exclusion_Present =>
2577 Null_Exclusion_Present (Current_Type));
2581 Make_Access_Definition (Loc,
2583 New_Copy_Tree (Subtype_Mark (Current_Type)),
2584 Null_Exclusion_Present =>
2585 Null_Exclusion_Present (Current_Type));
2589 if Present (Ctrl_Type)
2590 and then Is_Controlling_Formal (Current_Identifier)
2592 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2594 Current_Type := New_Copy_Tree (Current_Type);
2598 New_Identifier := Make_Defining_Identifier (Loc,
2599 Chars (Current_Identifier));
2601 Append_To (Parameters,
2602 Make_Parameter_Specification (Loc,
2603 Defining_Identifier => New_Identifier,
2604 Parameter_Type => Current_Type,
2605 In_Present => In_Present (Current_Parameter),
2606 Out_Present => Out_Present (Current_Parameter),
2608 New_Copy_Tree (Expression (Current_Parameter))));
2610 -- For a regular formal parameter (that needs to be marshalled
2611 -- in the context of remote calls), set the Etype now, because
2612 -- marshalling processing might need it.
2614 if Is_Entity_Name (Current_Type) then
2615 Set_Etype (New_Identifier, Entity (Current_Type));
2617 -- Current_Type is an access definition, special processing
2618 -- (not requiring etype) will occur for marshalling.
2624 Next (Current_Parameter);
2628 case Nkind (Spec) is
2630 when N_Function_Specification | N_Access_Function_Definition =>
2632 Make_Function_Specification (Loc,
2633 Defining_Unit_Name =>
2634 Make_Defining_Identifier (Loc,
2635 Chars => Name_For_New_Spec),
2636 Parameter_Specifications => Parameters,
2637 Result_Definition =>
2638 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2640 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2642 Make_Procedure_Specification (Loc,
2643 Defining_Unit_Name =>
2644 Make_Defining_Identifier (Loc,
2645 Chars => Name_For_New_Spec),
2646 Parameter_Specifications => Parameters);
2649 raise Program_Error;
2651 end Copy_Specification;
2653 -----------------------------
2654 -- Corresponding_Stub_Type --
2655 -----------------------------
2657 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2658 Desig : constant Entity_Id :=
2659 Etype (Designated_Type (RACW_Type));
2660 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2662 return Stub_Elements.Stub_Type;
2663 end Corresponding_Stub_Type;
2665 ---------------------------
2666 -- Could_Be_Asynchronous --
2667 ---------------------------
2669 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2670 Current_Parameter : Node_Id;
2673 if Present (Parameter_Specifications (Spec)) then
2674 Current_Parameter := First (Parameter_Specifications (Spec));
2675 while Present (Current_Parameter) loop
2676 if Out_Present (Current_Parameter) then
2680 Next (Current_Parameter);
2685 end Could_Be_Asynchronous;
2687 ---------------------------
2688 -- Declare_Create_NVList --
2689 ---------------------------
2691 procedure Declare_Create_NVList
2699 Make_Object_Declaration (Loc,
2700 Defining_Identifier => NVList,
2701 Aliased_Present => False,
2702 Object_Definition =>
2703 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2706 Make_Procedure_Call_Statement (Loc,
2707 Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2708 Parameter_Associations => New_List (
2709 New_Occurrence_Of (NVList, Loc))));
2710 end Declare_Create_NVList;
2712 ---------------------------------------------
2713 -- Expand_All_Calls_Remote_Subprogram_Call --
2714 ---------------------------------------------
2716 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2717 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2718 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2719 Loc : constant Source_Ptr := Sloc (N);
2720 RCI_Locator : Node_Id;
2721 RCI_Cache : Entity_Id;
2722 Calling_Stubs : Node_Id;
2723 E_Calling_Stubs : Entity_Id;
2726 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2728 if E_Calling_Stubs = Empty then
2729 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2731 if RCI_Cache = Empty then
2734 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2735 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2737 -- The RCI_Locator package is inserted at the top level in the
2738 -- current unit, and must appear in the proper scope, so that it
2739 -- is not prematurely removed by the GCC back-end.
2742 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2745 if Ekind (Scop) = E_Package_Body then
2746 Push_Scope (Spec_Entity (Scop));
2748 elsif Ekind (Scop) = E_Subprogram_Body then
2750 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2756 Analyze (RCI_Locator);
2760 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2763 RCI_Locator := Parent (RCI_Cache);
2766 Calling_Stubs := Build_Subprogram_Calling_Stubs
2767 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2769 Build_Subprogram_Id (Loc, Called_Subprogram),
2770 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2772 Is_Asynchronous (Called_Subprogram),
2773 Locator => RCI_Cache,
2774 New_Name => New_Internal_Name ('S'));
2775 Insert_After (RCI_Locator, Calling_Stubs);
2776 Analyze (Calling_Stubs);
2777 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2780 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2781 end Expand_All_Calls_Remote_Subprogram_Call;
2783 ---------------------------------
2784 -- Expand_Calling_Stubs_Bodies --
2785 ---------------------------------
2787 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2788 Spec : constant Node_Id := Specification (Unit_Node);
2789 Decls : constant List_Id := Visible_Declarations (Spec);
2791 Push_Scope (Scope_Of_Spec (Spec));
2792 Add_Calling_Stubs_To_Declarations
2793 (Specification (Unit_Node), Decls);
2795 end Expand_Calling_Stubs_Bodies;
2797 -----------------------------------
2798 -- Expand_Receiving_Stubs_Bodies --
2799 -----------------------------------
2801 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2804 Stubs_Decls : List_Id;
2805 Stubs_Stmts : List_Id;
2808 if Nkind (Unit_Node) = N_Package_Declaration then
2809 Spec := Specification (Unit_Node);
2810 Decls := Private_Declarations (Spec);
2813 Decls := Visible_Declarations (Spec);
2816 Push_Scope (Scope_Of_Spec (Spec));
2817 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2821 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2822 Decls := Declarations (Unit_Node);
2824 Push_Scope (Scope_Of_Spec (Unit_Node));
2825 Stubs_Decls := New_List;
2826 Stubs_Stmts := New_List;
2827 Specific_Add_Receiving_Stubs_To_Declarations
2828 (Spec, Stubs_Decls, Stubs_Stmts);
2830 Insert_List_Before (First (Decls), Stubs_Decls);
2833 HSS_Stmts : constant List_Id :=
2834 Statements (Handled_Statement_Sequence (Unit_Node));
2836 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2839 if No (First_HSS_Stmt) then
2840 Append_List_To (HSS_Stmts, Stubs_Stmts);
2842 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2848 end Expand_Receiving_Stubs_Bodies;
2850 --------------------
2851 -- GARLIC_Support --
2852 --------------------
2854 package body GARLIC_Support is
2856 -- Local subprograms
2858 procedure Add_RACW_Read_Attribute
2859 (RACW_Type : Entity_Id;
2860 Stub_Type : Entity_Id;
2861 Stub_Type_Access : Entity_Id;
2862 Body_Decls : List_Id);
2863 -- Add Read attribute for the RACW type. The declaration and attribute
2864 -- definition clauses are inserted right after the declaration of
2865 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2866 -- appended to it (case where the RACW declaration is in the main unit).
2868 procedure Add_RACW_Write_Attribute
2869 (RACW_Type : Entity_Id;
2870 Stub_Type : Entity_Id;
2871 Stub_Type_Access : Entity_Id;
2872 RPC_Receiver : Node_Id;
2873 Body_Decls : List_Id);
2874 -- Same as above for the Write attribute
2876 function Stream_Parameter return Node_Id;
2877 function Result return Node_Id;
2878 function Object return Node_Id renames Result;
2879 -- Functions to create occurrences of the formal parameter names of the
2880 -- 'Read and 'Write attributes.
2883 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2884 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2886 procedure Add_RAS_Access_TSS (N : Node_Id);
2887 -- Add a subprogram body for RAS Access TSS
2889 -------------------------------------
2890 -- Add_Obj_RPC_Receiver_Completion --
2891 -------------------------------------
2893 procedure Add_Obj_RPC_Receiver_Completion
2896 RPC_Receiver : Entity_Id;
2897 Stub_Elements : Stub_Structure)
2900 -- The RPC receiver body should not be the completion of the
2901 -- declaration recorded in the stub structure, because then the
2902 -- occurrences of the formal parameters within the body should refer
2903 -- to the entities from the declaration, not from the completion, to
2904 -- which we do not have easy access. Instead, the RPC receiver body
2905 -- acts as its own declaration, and the RPC receiver declaration is
2906 -- completed by a renaming-as-body.
2909 Make_Subprogram_Renaming_Declaration (Loc,
2911 Copy_Specification (Loc,
2912 Specification (Stub_Elements.RPC_Receiver_Decl)),
2913 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2914 end Add_Obj_RPC_Receiver_Completion;
2916 -----------------------
2917 -- Add_RACW_Features --
2918 -----------------------
2920 procedure Add_RACW_Features
2921 (RACW_Type : Entity_Id;
2922 Stub_Type : Entity_Id;
2923 Stub_Type_Access : Entity_Id;
2924 RPC_Receiver_Decl : Node_Id;
2925 Body_Decls : List_Id)
2927 RPC_Receiver : Node_Id;
2928 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2931 Loc := Sloc (RACW_Type);
2935 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2936 -- of the corresponding distributed object type. We retrieve its
2937 -- address from the local proxy object.
2939 RPC_Receiver := Make_Selected_Component (Loc,
2941 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2942 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2945 RPC_Receiver := Make_Attribute_Reference (Loc,
2946 Prefix => New_Occurrence_Of (
2947 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2948 Attribute_Name => Name_Address);
2951 Add_RACW_Write_Attribute
2958 Add_RACW_Read_Attribute
2963 end Add_RACW_Features;
2965 -----------------------------
2966 -- Add_RACW_Read_Attribute --
2967 -----------------------------
2969 procedure Add_RACW_Read_Attribute
2970 (RACW_Type : Entity_Id;
2971 Stub_Type : Entity_Id;
2972 Stub_Type_Access : Entity_Id;
2973 Body_Decls : List_Id)
2975 Proc_Decl : Node_Id;
2976 Attr_Decl : Node_Id;
2978 Body_Node : Node_Id;
2980 Statements : constant List_Id := New_List;
2982 Local_Statements : List_Id;
2983 Remote_Statements : List_Id;
2984 -- Various parts of the procedure
2986 Pnam : constant Entity_Id :=
2987 Make_Defining_Identifier
2988 (Loc, New_Internal_Name ('R'));
2989 Asynchronous_Flag : constant Entity_Id :=
2990 Asynchronous_Flags_Table.Get (RACW_Type);
2991 pragma Assert (Present (Asynchronous_Flag));
2993 -- Prepare local identifiers
2995 Source_Partition : Entity_Id;
2996 Source_Receiver : Entity_Id;
2997 Source_Address : Entity_Id;
2998 Local_Stub : Entity_Id;
2999 Stubbed_Result : Entity_Id;
3001 -- Start of processing for Add_RACW_Read_Attribute
3004 Build_Stream_Procedure (Loc,
3005 RACW_Type, Body_Node, Pnam, Statements, Outp => True);
3006 Proc_Decl := Make_Subprogram_Declaration (Loc,
3007 Copy_Specification (Loc, Specification (Body_Node)));
3010 Make_Attribute_Definition_Clause (Loc,
3011 Name => New_Occurrence_Of (RACW_Type, Loc),
3015 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3017 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3018 Insert_After (Proc_Decl, Attr_Decl);
3020 if No (Body_Decls) then
3022 -- Case of processing an RACW type from another unit than the
3023 -- main one: do not generate a body.
3028 -- Prepare local identifiers
3031 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3033 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3035 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3037 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
3039 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3041 -- Generate object declarations
3044 Make_Object_Declaration (Loc,
3045 Defining_Identifier => Source_Partition,
3046 Object_Definition =>
3047 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
3049 Make_Object_Declaration (Loc,
3050 Defining_Identifier => Source_Receiver,
3051 Object_Definition =>
3052 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3054 Make_Object_Declaration (Loc,
3055 Defining_Identifier => Source_Address,
3056 Object_Definition =>
3057 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3059 Make_Object_Declaration (Loc,
3060 Defining_Identifier => Local_Stub,
3061 Aliased_Present => True,
3062 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
3064 Make_Object_Declaration (Loc,
3065 Defining_Identifier => Stubbed_Result,
3066 Object_Definition =>
3067 New_Occurrence_Of (Stub_Type_Access, Loc),
3069 Make_Attribute_Reference (Loc,
3071 New_Occurrence_Of (Local_Stub, Loc),
3073 Name_Unchecked_Access)));
3075 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3077 Append_List_To (Statements, New_List (
3078 Make_Attribute_Reference (Loc,
3080 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3081 Attribute_Name => Name_Read,
3082 Expressions => New_List (
3084 New_Occurrence_Of (Source_Partition, Loc))),
3086 Make_Attribute_Reference (Loc,
3088 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3091 Expressions => New_List (
3093 New_Occurrence_Of (Source_Receiver, Loc))),
3095 Make_Attribute_Reference (Loc,
3097 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3100 Expressions => New_List (
3102 New_Occurrence_Of (Source_Address, Loc)))));
3104 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3106 Set_Etype (Stubbed_Result, Stub_Type_Access);
3108 -- If the Address is Null_Address, then return a null object, unless
3109 -- RACW_Type is null-excluding, in which case unconditionally raise
3110 -- CONSTRAINT_ERROR instead.
3113 Zero_Statements : List_Id;
3114 -- Statements executed when a zero value is received
3117 if Can_Never_Be_Null (RACW_Type) then
3118 Zero_Statements := New_List (
3119 Make_Raise_Constraint_Error (Loc,
3120 Reason => CE_Null_Not_Allowed));
3122 Zero_Statements := New_List (
3123 Make_Assignment_Statement (Loc,
3125 Expression => Make_Null (Loc)),
3126 Make_Simple_Return_Statement (Loc));
3129 Append_To (Statements,
3130 Make_Implicit_If_Statement (RACW_Type,
3133 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3134 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3135 Then_Statements => Zero_Statements));
3138 -- If the RACW denotes an object created on the current partition,
3139 -- Local_Statements will be executed. The real object will be used.
3141 Local_Statements := New_List (
3142 Make_Assignment_Statement (Loc,
3145 Unchecked_Convert_To (RACW_Type,
3146 OK_Convert_To (RTE (RE_Address),
3147 New_Occurrence_Of (Source_Address, Loc)))));
3149 -- If the object is located on another partition, then a stub object
3150 -- will be created with all the information needed to rebuild the
3151 -- real object at the other end.
3153 Remote_Statements := New_List (
3155 Make_Assignment_Statement (Loc,
3156 Name => Make_Selected_Component (Loc,
3157 Prefix => Stubbed_Result,
3158 Selector_Name => Name_Origin),
3160 New_Occurrence_Of (Source_Partition, Loc)),
3162 Make_Assignment_Statement (Loc,
3163 Name => Make_Selected_Component (Loc,
3164 Prefix => Stubbed_Result,
3165 Selector_Name => Name_Receiver),
3167 New_Occurrence_Of (Source_Receiver, Loc)),
3169 Make_Assignment_Statement (Loc,
3170 Name => Make_Selected_Component (Loc,
3171 Prefix => Stubbed_Result,
3172 Selector_Name => Name_Addr),
3174 New_Occurrence_Of (Source_Address, Loc)));
3176 Append_To (Remote_Statements,
3177 Make_Assignment_Statement (Loc,
3178 Name => Make_Selected_Component (Loc,
3179 Prefix => Stubbed_Result,
3180 Selector_Name => Name_Asynchronous),
3182 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3184 Append_List_To (Remote_Statements,
3185 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3186 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3187 -- set on the stub type if, and only if, the RACW type has a pragma
3188 -- Asynchronous. This is incorrect for RACWs that implement RAS
3189 -- types, because in that case the /designated subprogram/ (not the
3190 -- type) might be asynchronous, and that causes the stub to need to
3191 -- be asynchronous too. A solution is to transport a RAS as a struct
3192 -- containing a RACW and an asynchronous flag, and to properly alter
3193 -- the Asynchronous component in the stub type in the RAS's Input
3196 Append_To (Remote_Statements,
3197 Make_Assignment_Statement (Loc,
3199 Expression => Unchecked_Convert_To (RACW_Type,
3200 New_Occurrence_Of (Stubbed_Result, Loc))));
3202 -- Distinguish between the local and remote cases, and execute the
3203 -- appropriate piece of code.
3205 Append_To (Statements,
3206 Make_Implicit_If_Statement (RACW_Type,
3210 Make_Function_Call (Loc,
3211 Name => New_Occurrence_Of (
3212 RTE (RE_Get_Local_Partition_Id), Loc)),
3213 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3214 Then_Statements => Local_Statements,
3215 Else_Statements => Remote_Statements));
3217 Set_Declarations (Body_Node, Decls);
3218 Append_To (Body_Decls, Body_Node);
3219 end Add_RACW_Read_Attribute;
3221 ------------------------------
3222 -- Add_RACW_Write_Attribute --
3223 ------------------------------
3225 procedure Add_RACW_Write_Attribute
3226 (RACW_Type : Entity_Id;
3227 Stub_Type : Entity_Id;
3228 Stub_Type_Access : Entity_Id;
3229 RPC_Receiver : Node_Id;
3230 Body_Decls : List_Id)
3232 Body_Node : Node_Id;
3233 Proc_Decl : Node_Id;
3234 Attr_Decl : Node_Id;
3236 Statements : constant List_Id := New_List;
3237 Local_Statements : List_Id;
3238 Remote_Statements : List_Id;
3239 Null_Statements : List_Id;
3241 Pnam : constant Entity_Id :=
3242 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3245 Build_Stream_Procedure
3246 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
3248 Proc_Decl := Make_Subprogram_Declaration (Loc,
3249 Copy_Specification (Loc, Specification (Body_Node)));
3252 Make_Attribute_Definition_Clause (Loc,
3253 Name => New_Occurrence_Of (RACW_Type, Loc),
3254 Chars => Name_Write,
3257 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3259 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3260 Insert_After (Proc_Decl, Attr_Decl);
3262 if No (Body_Decls) then
3266 -- Build the code fragment corresponding to the marshalling of a
3269 Local_Statements := New_List (
3271 Pack_Entity_Into_Stream_Access (Loc,
3272 Stream => Stream_Parameter,
3273 Object => RTE (RE_Get_Local_Partition_Id)),
3275 Pack_Node_Into_Stream_Access (Loc,
3276 Stream => Stream_Parameter,
3277 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3278 Etyp => RTE (RE_Unsigned_64)),
3280 Pack_Node_Into_Stream_Access (Loc,
3281 Stream => Stream_Parameter,
3282 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3283 Make_Attribute_Reference (Loc,
3285 Make_Explicit_Dereference (Loc,
3287 Attribute_Name => Name_Address)),
3288 Etyp => RTE (RE_Unsigned_64)));
3290 -- Build the code fragment corresponding to the marshalling of
3293 Remote_Statements := New_List (
3294 Pack_Node_Into_Stream_Access (Loc,
3295 Stream => Stream_Parameter,
3297 Make_Selected_Component (Loc,
3299 Unchecked_Convert_To (Stub_Type_Access, Object),
3300 Selector_Name => Make_Identifier (Loc, Name_Origin)),
3301 Etyp => RTE (RE_Partition_ID)),
3303 Pack_Node_Into_Stream_Access (Loc,
3304 Stream => Stream_Parameter,
3306 Make_Selected_Component (Loc,
3308 Unchecked_Convert_To (Stub_Type_Access, Object),
3309 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
3310 Etyp => RTE (RE_Unsigned_64)),
3312 Pack_Node_Into_Stream_Access (Loc,
3313 Stream => Stream_Parameter,
3315 Make_Selected_Component (Loc,
3317 Unchecked_Convert_To (Stub_Type_Access, Object),
3318 Selector_Name => Make_Identifier (Loc, Name_Addr)),
3319 Etyp => RTE (RE_Unsigned_64)));
3321 -- Build code fragment corresponding to marshalling of a null object
3323 Null_Statements := New_List (
3325 Pack_Entity_Into_Stream_Access (Loc,
3326 Stream => Stream_Parameter,
3327 Object => RTE (RE_Get_Local_Partition_Id)),
3329 Pack_Node_Into_Stream_Access (Loc,
3330 Stream => Stream_Parameter,
3331 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3332 Etyp => RTE (RE_Unsigned_64)),
3334 Pack_Node_Into_Stream_Access (Loc,
3335 Stream => Stream_Parameter,
3336 Object => Make_Integer_Literal (Loc, Uint_0),
3337 Etyp => RTE (RE_Unsigned_64)));
3339 Append_To (Statements,
3340 Make_Implicit_If_Statement (RACW_Type,
3343 Left_Opnd => Object,
3344 Right_Opnd => Make_Null (Loc)),
3346 Then_Statements => Null_Statements,
3348 Elsif_Parts => New_List (
3349 Make_Elsif_Part (Loc,
3353 Make_Attribute_Reference (Loc,
3355 Attribute_Name => Name_Tag),
3358 Make_Attribute_Reference (Loc,
3359 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3360 Attribute_Name => Name_Tag)),
3361 Then_Statements => Remote_Statements)),
3362 Else_Statements => Local_Statements));
3364 Append_To (Body_Decls, Body_Node);
3365 end Add_RACW_Write_Attribute;
3367 ------------------------
3368 -- Add_RAS_Access_TSS --
3369 ------------------------
3371 procedure Add_RAS_Access_TSS (N : Node_Id) is
3372 Loc : constant Source_Ptr := Sloc (N);
3374 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3375 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3376 -- Ras_Type is the access to subprogram type while Fat_Type is the
3377 -- corresponding record type.
3379 RACW_Type : constant Entity_Id :=
3380 Underlying_RACW_Type (Ras_Type);
3381 Desig : constant Entity_Id :=
3382 Etype (Designated_Type (RACW_Type));
3384 Stub_Elements : constant Stub_Structure :=
3385 Stubs_Table.Get (Desig);
3386 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3388 Proc : constant Entity_Id :=
3389 Make_Defining_Identifier (Loc,
3390 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3392 Proc_Spec : Node_Id;
3394 -- Formal parameters
3396 Package_Name : constant Entity_Id :=
3397 Make_Defining_Identifier (Loc,
3401 Subp_Id : constant Entity_Id :=
3402 Make_Defining_Identifier (Loc,
3404 -- Target subprogram
3406 Asynch_P : constant Entity_Id :=
3407 Make_Defining_Identifier (Loc,
3408 Chars => Name_Asynchronous);
3409 -- Is the procedure to which the 'Access applies asynchronous?
3411 All_Calls_Remote : constant Entity_Id :=
3412 Make_Defining_Identifier (Loc,
3413 Chars => Name_All_Calls_Remote);
3414 -- True if an All_Calls_Remote pragma applies to the RCI unit
3415 -- that contains the subprogram.
3417 -- Common local variables
3419 Proc_Decls : List_Id;
3420 Proc_Statements : List_Id;
3422 Origin : constant Entity_Id :=
3423 Make_Defining_Identifier (Loc,
3424 Chars => New_Internal_Name ('P'));
3426 -- Additional local variables for the local case
3428 Proxy_Addr : constant Entity_Id :=
3429 Make_Defining_Identifier (Loc,
3430 Chars => New_Internal_Name ('P'));
3432 -- Additional local variables for the remote case
3434 Local_Stub : constant Entity_Id :=
3435 Make_Defining_Identifier (Loc,
3436 Chars => New_Internal_Name ('L'));
3438 Stub_Ptr : constant Entity_Id :=
3439 Make_Defining_Identifier (Loc,
3440 Chars => New_Internal_Name ('S'));
3443 (Field_Name : Name_Id;
3444 Value : Node_Id) return Node_Id;
3445 -- Construct an assignment that sets the named component in the
3453 (Field_Name : Name_Id;
3454 Value : Node_Id) return Node_Id
3458 Make_Assignment_Statement (Loc,
3460 Make_Selected_Component (Loc,
3462 Selector_Name => Field_Name),
3463 Expression => Value);
3466 -- Start of processing for Add_RAS_Access_TSS
3469 Proc_Decls := New_List (
3471 -- Common declarations
3473 Make_Object_Declaration (Loc,
3474 Defining_Identifier => Origin,
3475 Constant_Present => True,
3476 Object_Definition =>
3477 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3479 Make_Function_Call (Loc,
3481 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3482 Parameter_Associations => New_List (
3483 New_Occurrence_Of (Package_Name, Loc)))),
3485 -- Declaration use only in the local case: proxy address
3487 Make_Object_Declaration (Loc,
3488 Defining_Identifier => Proxy_Addr,
3489 Object_Definition =>
3490 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3492 -- Declarations used only in the remote case: stub object and
3495 Make_Object_Declaration (Loc,
3496 Defining_Identifier => Local_Stub,
3497 Aliased_Present => True,
3498 Object_Definition =>
3499 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3501 Make_Object_Declaration (Loc,
3502 Defining_Identifier =>
3504 Object_Definition =>
3505 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3507 Make_Attribute_Reference (Loc,
3508 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3509 Attribute_Name => Name_Unchecked_Access)));
3511 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3513 -- Build_Get_Unique_RP_Call needs above information
3515 -- Note: Here we assume that the Fat_Type is a record
3516 -- containing just a pointer to a proxy or stub object.
3518 Proc_Statements := New_List (
3522 -- Get_RAS_Info (Pkg, Subp, PA);
3523 -- if Origin = Local_Partition_Id
3524 -- and then not All_Calls_Remote
3526 -- return Fat_Type!(PA);
3529 Make_Procedure_Call_Statement (Loc,
3530 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3531 Parameter_Associations => New_List (
3532 New_Occurrence_Of (Package_Name, Loc),
3533 New_Occurrence_Of (Subp_Id, Loc),
3534 New_Occurrence_Of (Proxy_Addr, Loc))),
3536 Make_Implicit_If_Statement (N,
3542 New_Occurrence_Of (Origin, Loc),
3544 Make_Function_Call (Loc,
3546 RTE (RE_Get_Local_Partition_Id), Loc))),
3550 New_Occurrence_Of (All_Calls_Remote, Loc))),
3552 Then_Statements => New_List (
3553 Make_Simple_Return_Statement (Loc,
3554 Unchecked_Convert_To (Fat_Type,
3555 OK_Convert_To (RTE (RE_Address),
3556 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3558 Set_Field (Name_Origin,
3559 New_Occurrence_Of (Origin, Loc)),
3561 Set_Field (Name_Receiver,
3562 Make_Function_Call (Loc,
3564 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3565 Parameter_Associations => New_List (
3566 New_Occurrence_Of (Package_Name, Loc)))),
3568 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3570 -- E.4.1(9) A remote call is asynchronous if it is a call to
3571 -- a procedure or a call through a value of an access-to-procedure
3572 -- type to which a pragma Asynchronous applies.
3574 -- Asynch_P is true when the procedure is asynchronous;
3575 -- Asynch_T is true when the type is asynchronous.
3577 Set_Field (Name_Asynchronous,
3579 New_Occurrence_Of (Asynch_P, Loc),
3580 New_Occurrence_Of (Boolean_Literals (
3581 Is_Asynchronous (Ras_Type)), Loc))));
3583 Append_List_To (Proc_Statements,
3584 Build_Get_Unique_RP_Call
3585 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3587 -- Return the newly created value
3589 Append_To (Proc_Statements,
3590 Make_Simple_Return_Statement (Loc,
3592 Unchecked_Convert_To (Fat_Type,
3593 New_Occurrence_Of (Stub_Ptr, Loc))));
3596 Make_Function_Specification (Loc,
3597 Defining_Unit_Name => Proc,
3598 Parameter_Specifications => New_List (
3599 Make_Parameter_Specification (Loc,
3600 Defining_Identifier => Package_Name,
3602 New_Occurrence_Of (Standard_String, Loc)),
3604 Make_Parameter_Specification (Loc,
3605 Defining_Identifier => Subp_Id,
3607 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3609 Make_Parameter_Specification (Loc,
3610 Defining_Identifier => Asynch_P,
3612 New_Occurrence_Of (Standard_Boolean, Loc)),
3614 Make_Parameter_Specification (Loc,
3615 Defining_Identifier => All_Calls_Remote,
3617 New_Occurrence_Of (Standard_Boolean, Loc))),
3619 Result_Definition =>
3620 New_Occurrence_Of (Fat_Type, Loc));
3622 -- Set the kind and return type of the function to prevent
3623 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3625 Set_Ekind (Proc, E_Function);
3626 Set_Etype (Proc, Fat_Type);
3629 Make_Subprogram_Body (Loc,
3630 Specification => Proc_Spec,
3631 Declarations => Proc_Decls,
3632 Handled_Statement_Sequence =>
3633 Make_Handled_Sequence_Of_Statements (Loc,
3634 Statements => Proc_Statements)));
3636 Set_TSS (Fat_Type, Proc);
3637 end Add_RAS_Access_TSS;
3639 -----------------------
3640 -- Add_RAST_Features --
3641 -----------------------
3643 procedure Add_RAST_Features
3644 (Vis_Decl : Node_Id;
3645 RAS_Type : Entity_Id)
3647 pragma Warnings (Off);
3648 pragma Unreferenced (RAS_Type);
3649 pragma Warnings (On);
3651 Add_RAS_Access_TSS (Vis_Decl);
3652 end Add_RAST_Features;
3654 -----------------------------------------
3655 -- Add_Receiving_Stubs_To_Declarations --
3656 -----------------------------------------
3658 procedure Add_Receiving_Stubs_To_Declarations
3659 (Pkg_Spec : Node_Id;
3663 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3665 Request_Parameter : Node_Id;
3667 Pkg_RPC_Receiver : constant Entity_Id :=
3668 Make_Defining_Identifier (Loc,
3669 New_Internal_Name ('H'));
3670 Pkg_RPC_Receiver_Statements : List_Id;
3671 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3672 Pkg_RPC_Receiver_Body : Node_Id;
3673 -- A Pkg_RPC_Receiver is built to decode the request
3675 Lookup_RAS_Info : constant Entity_Id :=
3676 Make_Defining_Identifier (Loc,
3677 Chars => New_Internal_Name ('R'));
3678 -- A remote subprogram is created to allow peers to look up
3679 -- RAS information using subprogram ids.
3681 Subp_Id : Entity_Id;
3682 Subp_Index : Entity_Id;
3683 -- Subprogram_Id as read from the incoming stream
3685 Current_Declaration : Node_Id;
3686 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3687 Current_Stubs : Node_Id;
3689 Subp_Info_Array : constant Entity_Id :=
3690 Make_Defining_Identifier (Loc,
3691 Chars => New_Internal_Name ('I'));
3693 Subp_Info_List : constant List_Id := New_List;
3695 Register_Pkg_Actuals : constant List_Id := New_List;
3697 All_Calls_Remote_E : Entity_Id;
3698 Proxy_Object_Addr : Entity_Id;
3700 procedure Append_Stubs_To
3701 (RPC_Receiver_Cases : List_Id;
3703 Subprogram_Number : Int);
3704 -- Add one case to the specified RPC receiver case list
3705 -- associating Subprogram_Number with the subprogram declared
3706 -- by Declaration, for which we have receiving stubs in Stubs.
3708 ---------------------
3709 -- Append_Stubs_To --
3710 ---------------------
3712 procedure Append_Stubs_To
3713 (RPC_Receiver_Cases : List_Id;
3715 Subprogram_Number : Int)
3718 Append_To (RPC_Receiver_Cases,
3719 Make_Case_Statement_Alternative (Loc,
3721 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3724 Make_Procedure_Call_Statement (Loc,
3726 New_Occurrence_Of (Defining_Entity (Stubs), Loc),
3727 Parameter_Associations => New_List (
3728 New_Occurrence_Of (Request_Parameter, Loc))))));
3729 end Append_Stubs_To;
3731 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3734 -- Building receiving stubs consist in several operations:
3736 -- - a package RPC receiver must be built. This subprogram
3737 -- will get a Subprogram_Id from the incoming stream
3738 -- and will dispatch the call to the right subprogram;
3740 -- - a receiving stub for each subprogram visible in the package
3741 -- spec. This stub will read all the parameters from the stream,
3742 -- and put the result as well as the exception occurrence in the
3745 -- - a dummy package with an empty spec and a body made of an
3746 -- elaboration part, whose job is to register the receiving
3747 -- part of this RCI package on the name server. This is done
3748 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3750 Build_RPC_Receiver_Body (
3751 RPC_Receiver => Pkg_RPC_Receiver,
3752 Request => Request_Parameter,
3754 Subp_Index => Subp_Index,
3755 Stmts => Pkg_RPC_Receiver_Statements,
3756 Decl => Pkg_RPC_Receiver_Body);
3757 pragma Assert (Subp_Id = Subp_Index);
3759 -- A null subp_id denotes a call through a RAS, in which case the
3760 -- next Uint_64 element in the stream is the address of the local
3761 -- proxy object, from which we can retrieve the actual subprogram id.
3763 Append_To (Pkg_RPC_Receiver_Statements,
3764 Make_Implicit_If_Statement (Pkg_Spec,
3767 New_Occurrence_Of (Subp_Id, Loc),
3768 Make_Integer_Literal (Loc, 0)),
3770 Then_Statements => New_List (
3771 Make_Assignment_Statement (Loc,
3773 New_Occurrence_Of (Subp_Id, Loc),
3776 Make_Selected_Component (Loc,
3778 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3779 OK_Convert_To (RTE (RE_Address),
3780 Make_Attribute_Reference (Loc,
3782 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3785 Expressions => New_List (
3786 Make_Selected_Component (Loc,
3787 Prefix => Request_Parameter,
3788 Selector_Name => Name_Params))))),
3791 Make_Identifier (Loc, Name_Subp_Id))))));
3793 -- Build a subprogram for RAS information lookups
3795 Current_Declaration :=
3796 Make_Subprogram_Declaration (Loc,
3798 Make_Function_Specification (Loc,
3799 Defining_Unit_Name =>
3801 Parameter_Specifications => New_List (
3802 Make_Parameter_Specification (Loc,
3803 Defining_Identifier =>
3804 Make_Defining_Identifier (Loc, Name_Subp_Id),
3808 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3809 Result_Definition =>
3810 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3812 Append_To (Decls, Current_Declaration);
3813 Analyze (Current_Declaration);
3815 Current_Stubs := Build_Subprogram_Receiving_Stubs
3816 (Vis_Decl => Current_Declaration,
3817 Asynchronous => False);
3818 Append_To (Decls, Current_Stubs);
3819 Analyze (Current_Stubs);
3821 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3824 Subprogram_Number => 1);
3826 -- For each subprogram, the receiving stub will be built and a
3827 -- case statement will be made on the Subprogram_Id to dispatch
3828 -- to the right subprogram.
3830 All_Calls_Remote_E :=
3832 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3834 Overload_Counter_Table.Reset;
3836 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3837 while Present (Current_Declaration) loop
3838 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3839 and then Comes_From_Source (Current_Declaration)
3842 Loc : constant Source_Ptr := Sloc (Current_Declaration);
3843 -- While specifically processing Current_Declaration, use
3844 -- its Sloc as the location of all generated nodes.
3846 Subp_Def : constant Entity_Id :=
3848 (Specification (Current_Declaration));
3850 Subp_Val : String_Id;
3851 pragma Warnings (Off, Subp_Val);
3854 -- Build receiving stub
3857 Build_Subprogram_Receiving_Stubs
3858 (Vis_Decl => Current_Declaration,
3860 Nkind (Specification (Current_Declaration)) =
3861 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,
3870 Vis_Decl => Current_Declaration,
3871 All_Calls_Remote_E => All_Calls_Remote_E,
3872 Proxy_Object_Addr => Proxy_Object_Addr);
3874 -- Compute distribution identifier
3876 Assign_Subprogram_Identifier
3878 Current_Subprogram_Number,
3882 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
3884 -- Add subprogram descriptor (RCI_Subp_Info) to the
3885 -- subprograms table for this receiver. The aggregate
3886 -- below must be kept consistent with the declaration
3887 -- of type RCI_Subp_Info in System.Partition_Interface.
3889 Append_To (Subp_Info_List,
3890 Make_Component_Association (Loc,
3891 Choices => New_List (
3892 Make_Integer_Literal (Loc,
3893 Current_Subprogram_Number)),
3896 Make_Aggregate (Loc,
3897 Component_Associations => New_List (
3898 Make_Component_Association (Loc,
3899 Choices => New_List (
3900 Make_Identifier (Loc, Name_Addr)),
3903 Proxy_Object_Addr, Loc))))));
3905 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3906 Stubs => Current_Stubs,
3907 Subprogram_Number => Current_Subprogram_Number);
3910 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3913 Next (Current_Declaration);
3916 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3917 -- rather than raising an exception since we do not want someone
3918 -- to crash a remote partition by sending invalid subprogram ids.
3919 -- This is consistent with the other parts of the case statement
3920 -- since even in presence of incorrect parameters in the stream,
3921 -- every exception will be caught and (if the subprogram is not an
3922 -- APC) put into the result stream and sent away.
3924 Append_To (Pkg_RPC_Receiver_Cases,
3925 Make_Case_Statement_Alternative (Loc,
3926 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
3927 Statements => New_List (Make_Null_Statement (Loc))));
3929 Append_To (Pkg_RPC_Receiver_Statements,
3930 Make_Case_Statement (Loc,
3931 Expression => New_Occurrence_Of (Subp_Id, Loc),
3932 Alternatives => Pkg_RPC_Receiver_Cases));
3935 Make_Object_Declaration (Loc,
3936 Defining_Identifier => Subp_Info_Array,
3937 Constant_Present => True,
3938 Aliased_Present => True,
3939 Object_Definition =>
3940 Make_Subtype_Indication (Loc,
3942 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3944 Make_Index_Or_Discriminant_Constraint (Loc,
3947 Low_Bound => Make_Integer_Literal (Loc,
3948 First_RCI_Subprogram_Id),
3950 Make_Integer_Literal (Loc,
3952 First_RCI_Subprogram_Id
3953 + List_Length (Subp_Info_List) - 1)))))));
3955 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3956 -- has zero length, and the declaration is for an empty array, in
3957 -- which case no initialization aggregate must be generated.
3959 if Present (First (Subp_Info_List)) then
3960 Set_Expression (Last (Decls),
3961 Make_Aggregate (Loc,
3962 Component_Associations => Subp_Info_List));
3964 -- No initialization provided: remove CONSTANT so that the
3965 -- declaration is not an incomplete deferred constant.
3968 Set_Constant_Present (Last (Decls), False);
3971 Analyze (Last (Decls));
3974 Subp_Info_Addr : Node_Id;
3975 -- Return statement for Lookup_RAS_Info: address of the subprogram
3976 -- information record for the requested subprogram id.
3979 if Present (First (Subp_Info_List)) then
3981 Make_Selected_Component (Loc,
3983 Make_Indexed_Component (Loc,
3984 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
3985 Expressions => New_List (
3986 Convert_To (Standard_Integer,
3987 Make_Identifier (Loc, Name_Subp_Id)))),
3988 Selector_Name => Make_Identifier (Loc, Name_Addr));
3990 -- Case of no visible subprogram: just raise Constraint_Error, we
3991 -- know for sure we got junk from a remote partition.
3995 Make_Raise_Constraint_Error (Loc,
3996 Reason => CE_Range_Check_Failed);
3997 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
4001 Make_Subprogram_Body (Loc,
4003 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
4004 Declarations => No_List,
4005 Handled_Statement_Sequence =>
4006 Make_Handled_Sequence_Of_Statements (Loc,
4007 Statements => New_List (
4008 Make_Simple_Return_Statement (Loc,
4011 (RTE (RE_Unsigned_64), Subp_Info_Addr))))));
4014 Analyze (Last (Decls));
4016 Append_To (Decls, Pkg_RPC_Receiver_Body);
4017 Analyze (Last (Decls));
4019 Get_Library_Unit_Name_String (Pkg_Spec);
4023 Append_To (Register_Pkg_Actuals,
4024 Make_String_Literal (Loc,
4025 Strval => String_From_Name_Buffer));
4029 Append_To (Register_Pkg_Actuals,
4030 Make_Attribute_Reference (Loc,
4031 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
4032 Attribute_Name => Name_Unrestricted_Access));
4036 Append_To (Register_Pkg_Actuals,
4037 Make_Attribute_Reference (Loc,
4039 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
4040 Attribute_Name => Name_Version));
4044 Append_To (Register_Pkg_Actuals,
4045 Make_Attribute_Reference (Loc,
4046 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4047 Attribute_Name => Name_Address));
4051 Append_To (Register_Pkg_Actuals,
4052 Make_Attribute_Reference (Loc,
4053 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4054 Attribute_Name => Name_Length));
4056 -- Generate the call
4059 Make_Procedure_Call_Statement (Loc,
4061 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
4062 Parameter_Associations => Register_Pkg_Actuals));
4063 Analyze (Last (Stmts));
4064 end Add_Receiving_Stubs_To_Declarations;
4066 ---------------------------------
4067 -- Build_General_Calling_Stubs --
4068 ---------------------------------
4070 procedure Build_General_Calling_Stubs
4072 Statements : List_Id;
4073 Target_Partition : Entity_Id;
4074 Target_RPC_Receiver : Node_Id;
4075 Subprogram_Id : Node_Id;
4076 Asynchronous : Node_Id := Empty;
4077 Is_Known_Asynchronous : Boolean := False;
4078 Is_Known_Non_Asynchronous : Boolean := False;
4079 Is_Function : Boolean;
4081 Stub_Type : Entity_Id := Empty;
4082 RACW_Type : Entity_Id := Empty;
4085 Loc : constant Source_Ptr := Sloc (Nod);
4087 Stream_Parameter : Node_Id;
4088 -- Name of the stream used to transmit parameters to the
4091 Result_Parameter : Node_Id;
4092 -- Name of the result parameter (in non-APC cases) which get the
4093 -- result of the remote subprogram.
4095 Exception_Return_Parameter : Node_Id;
4096 -- Name of the parameter which will hold the exception sent by the
4097 -- remote subprogram.
4099 Current_Parameter : Node_Id;
4100 -- Current parameter being handled
4102 Ordered_Parameters_List : constant List_Id :=
4103 Build_Ordered_Parameters_List (Spec);
4105 Asynchronous_Statements : List_Id := No_List;
4106 Non_Asynchronous_Statements : List_Id := No_List;
4107 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4109 Extra_Formal_Statements : constant List_Id := New_List;
4110 -- List of statements for extra formal parameters. It will appear
4111 -- after the regular statements for writing out parameters.
4113 pragma Warnings (Off);
4114 pragma Unreferenced (RACW_Type);
4115 -- Used only for the PolyORB case
4116 pragma Warnings (On);
4119 -- The general form of a calling stub for a given subprogram is:
4121 -- procedure X (...) is P : constant Partition_ID :=
4122 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4123 -- System.RPC.Params_Stream_Type (0); begin
4124 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4125 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4126 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4127 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4129 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4131 -- There are some variations: Do_APC is called for an asynchronous
4132 -- procedure and the part after the call is completely ommitted as
4133 -- well as the declaration of Result. For a function call, 'Input is
4134 -- always used to read the result even if it is constrained.
4137 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4140 Make_Object_Declaration (Loc,
4141 Defining_Identifier => Stream_Parameter,
4142 Aliased_Present => True,
4143 Object_Definition =>
4144 Make_Subtype_Indication (Loc,
4146 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4148 Make_Index_Or_Discriminant_Constraint (Loc,
4150 New_List (Make_Integer_Literal (Loc, 0))))));
4152 if not Is_Known_Asynchronous then
4154 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4157 Make_Object_Declaration (Loc,
4158 Defining_Identifier => Result_Parameter,
4159 Aliased_Present => True,
4160 Object_Definition =>
4161 Make_Subtype_Indication (Loc,
4163 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4165 Make_Index_Or_Discriminant_Constraint (Loc,
4167 New_List (Make_Integer_Literal (Loc, 0))))));
4169 Exception_Return_Parameter :=
4170 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4173 Make_Object_Declaration (Loc,
4174 Defining_Identifier => Exception_Return_Parameter,
4175 Object_Definition =>
4176 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4179 Result_Parameter := Empty;
4180 Exception_Return_Parameter := Empty;
4183 -- Put first the RPC receiver corresponding to the remote package
4185 Append_To (Statements,
4186 Make_Attribute_Reference (Loc,
4188 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4189 Attribute_Name => Name_Write,
4190 Expressions => New_List (
4191 Make_Attribute_Reference (Loc,
4192 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4193 Attribute_Name => Name_Access),
4194 Target_RPC_Receiver)));
4196 -- Then put the Subprogram_Id of the subprogram we want to call in
4199 Append_To (Statements,
4200 Make_Attribute_Reference (Loc,
4201 Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4202 Attribute_Name => Name_Write,
4203 Expressions => New_List (
4204 Make_Attribute_Reference (Loc,
4205 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4206 Attribute_Name => Name_Access),
4209 Current_Parameter := First (Ordered_Parameters_List);
4210 while Present (Current_Parameter) loop
4212 Typ : constant Node_Id :=
4213 Parameter_Type (Current_Parameter);
4215 Constrained : Boolean;
4217 Extra_Parameter : Entity_Id;
4220 if Is_RACW_Controlling_Formal
4221 (Current_Parameter, Stub_Type)
4223 -- In the case of a controlling formal argument, we marshall
4224 -- its addr field rather than the local stub.
4226 Append_To (Statements,
4227 Pack_Node_Into_Stream (Loc,
4228 Stream => Stream_Parameter,
4230 Make_Selected_Component (Loc,
4232 Defining_Identifier (Current_Parameter),
4233 Selector_Name => Name_Addr),
4234 Etyp => RTE (RE_Unsigned_64)));
4239 (Defining_Identifier (Current_Parameter), Loc);
4241 -- Access type parameters are transmitted as in out
4242 -- parameters. However, a dereference is needed so that
4243 -- we marshall the designated object.
4245 if Nkind (Typ) = N_Access_Definition then
4246 Value := Make_Explicit_Dereference (Loc, Value);
4247 Etyp := Etype (Subtype_Mark (Typ));
4249 Etyp := Etype (Typ);
4252 Constrained := not Transmit_As_Unconstrained (Etyp);
4254 -- Any parameter but unconstrained out parameters are
4255 -- transmitted to the peer.
4257 if In_Present (Current_Parameter)
4258 or else not Out_Present (Current_Parameter)
4259 or else not Constrained
4261 Append_To (Statements,
4262 Make_Attribute_Reference (Loc,
4263 Prefix => New_Occurrence_Of (Etyp, Loc),
4265 Output_From_Constrained (Constrained),
4266 Expressions => New_List (
4267 Make_Attribute_Reference (Loc,
4269 New_Occurrence_Of (Stream_Parameter, Loc),
4270 Attribute_Name => Name_Access),
4275 -- If the current parameter has a dynamic constrained status,
4276 -- then this status is transmitted as well.
4277 -- This should be done for accessibility as well ???
4279 if Nkind (Typ) /= N_Access_Definition
4280 and then Need_Extra_Constrained (Current_Parameter)
4282 -- In this block, we do not use the extra formal that has
4283 -- been created because it does not exist at the time of
4284 -- expansion when building calling stubs for remote access
4285 -- to subprogram types. We create an extra variable of this
4286 -- type and push it in the stream after the regular
4289 Extra_Parameter := Make_Defining_Identifier
4290 (Loc, New_Internal_Name ('P'));
4293 Make_Object_Declaration (Loc,
4294 Defining_Identifier => Extra_Parameter,
4295 Constant_Present => True,
4296 Object_Definition =>
4297 New_Occurrence_Of (Standard_Boolean, Loc),
4299 Make_Attribute_Reference (Loc,
4302 Defining_Identifier (Current_Parameter), Loc),
4303 Attribute_Name => Name_Constrained)));
4305 Append_To (Extra_Formal_Statements,
4306 Make_Attribute_Reference (Loc,
4308 New_Occurrence_Of (Standard_Boolean, Loc),
4309 Attribute_Name => Name_Write,
4310 Expressions => New_List (
4311 Make_Attribute_Reference (Loc,
4314 (Stream_Parameter, Loc), Attribute_Name =>
4316 New_Occurrence_Of (Extra_Parameter, Loc))));
4319 Next (Current_Parameter);
4323 -- Append the formal statements list to the statements
4325 Append_List_To (Statements, Extra_Formal_Statements);
4327 if not Is_Known_Non_Asynchronous then
4329 -- Build the call to System.RPC.Do_APC
4331 Asynchronous_Statements := New_List (
4332 Make_Procedure_Call_Statement (Loc,
4334 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4335 Parameter_Associations => New_List (
4336 New_Occurrence_Of (Target_Partition, Loc),
4337 Make_Attribute_Reference (Loc,
4339 New_Occurrence_Of (Stream_Parameter, Loc),
4340 Attribute_Name => Name_Access))));
4342 Asynchronous_Statements := No_List;
4345 if not Is_Known_Asynchronous then
4347 -- Build the call to System.RPC.Do_RPC
4349 Non_Asynchronous_Statements := New_List (
4350 Make_Procedure_Call_Statement (Loc,
4352 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4353 Parameter_Associations => New_List (
4354 New_Occurrence_Of (Target_Partition, Loc),
4356 Make_Attribute_Reference (Loc,
4358 New_Occurrence_Of (Stream_Parameter, Loc),
4359 Attribute_Name => Name_Access),
4361 Make_Attribute_Reference (Loc,
4363 New_Occurrence_Of (Result_Parameter, Loc),
4364 Attribute_Name => Name_Access))));
4366 -- Read the exception occurrence from the result stream and
4367 -- reraise it. It does no harm if this is a Null_Occurrence since
4368 -- this does nothing.
4370 Append_To (Non_Asynchronous_Statements,
4371 Make_Attribute_Reference (Loc,
4373 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4375 Attribute_Name => Name_Read,
4377 Expressions => New_List (
4378 Make_Attribute_Reference (Loc,
4380 New_Occurrence_Of (Result_Parameter, Loc),
4381 Attribute_Name => Name_Access),
4382 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4384 Append_To (Non_Asynchronous_Statements,
4385 Make_Procedure_Call_Statement (Loc,
4387 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4388 Parameter_Associations => New_List (
4389 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4393 -- If this is a function call, then read the value and return
4394 -- it. The return value is written/read using 'Output/'Input.
4396 Append_To (Non_Asynchronous_Statements,
4397 Make_Tag_Check (Loc,
4398 Make_Simple_Return_Statement (Loc,
4400 Make_Attribute_Reference (Loc,
4403 Etype (Result_Definition (Spec)), Loc),
4405 Attribute_Name => Name_Input,
4407 Expressions => New_List (
4408 Make_Attribute_Reference (Loc,
4410 New_Occurrence_Of (Result_Parameter, Loc),
4411 Attribute_Name => Name_Access))))));
4414 -- Loop around parameters and assign out (or in out)
4415 -- parameters. In the case of RACW, controlling arguments
4416 -- cannot possibly have changed since they are remote, so we do
4417 -- not read them from the stream.
4419 Current_Parameter := First (Ordered_Parameters_List);
4420 while Present (Current_Parameter) loop
4422 Typ : constant Node_Id :=
4423 Parameter_Type (Current_Parameter);
4430 (Defining_Identifier (Current_Parameter), Loc);
4432 if Nkind (Typ) = N_Access_Definition then
4433 Value := Make_Explicit_Dereference (Loc, Value);
4434 Etyp := Etype (Subtype_Mark (Typ));
4436 Etyp := Etype (Typ);
4439 if (Out_Present (Current_Parameter)
4440 or else Nkind (Typ) = N_Access_Definition)
4441 and then Etyp /= Stub_Type
4443 Append_To (Non_Asynchronous_Statements,
4444 Make_Attribute_Reference (Loc,
4446 New_Occurrence_Of (Etyp, Loc),
4448 Attribute_Name => Name_Read,
4450 Expressions => New_List (
4451 Make_Attribute_Reference (Loc,
4453 New_Occurrence_Of (Result_Parameter, Loc),
4454 Attribute_Name => Name_Access),
4459 Next (Current_Parameter);
4464 if Is_Known_Asynchronous then
4465 Append_List_To (Statements, Asynchronous_Statements);
4467 elsif Is_Known_Non_Asynchronous then
4468 Append_List_To (Statements, Non_Asynchronous_Statements);
4471 pragma Assert (Present (Asynchronous));
4472 Prepend_To (Asynchronous_Statements,
4473 Make_Attribute_Reference (Loc,
4474 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4475 Attribute_Name => Name_Write,
4476 Expressions => New_List (
4477 Make_Attribute_Reference (Loc,
4479 New_Occurrence_Of (Stream_Parameter, Loc),
4480 Attribute_Name => Name_Access),
4481 New_Occurrence_Of (Standard_True, Loc))));
4483 Prepend_To (Non_Asynchronous_Statements,
4484 Make_Attribute_Reference (Loc,
4485 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4486 Attribute_Name => Name_Write,
4487 Expressions => New_List (
4488 Make_Attribute_Reference (Loc,
4490 New_Occurrence_Of (Stream_Parameter, Loc),
4491 Attribute_Name => Name_Access),
4492 New_Occurrence_Of (Standard_False, Loc))));
4494 Append_To (Statements,
4495 Make_Implicit_If_Statement (Nod,
4496 Condition => Asynchronous,
4497 Then_Statements => Asynchronous_Statements,
4498 Else_Statements => Non_Asynchronous_Statements));
4500 end Build_General_Calling_Stubs;
4502 -----------------------------
4503 -- Build_RPC_Receiver_Body --
4504 -----------------------------
4506 procedure Build_RPC_Receiver_Body
4507 (RPC_Receiver : Entity_Id;
4508 Request : out Entity_Id;
4509 Subp_Id : out Entity_Id;
4510 Subp_Index : out Entity_Id;
4511 Stmts : out List_Id;
4514 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4516 RPC_Receiver_Spec : Node_Id;
4517 RPC_Receiver_Decls : List_Id;
4520 Request := Make_Defining_Identifier (Loc, Name_R);
4522 RPC_Receiver_Spec :=
4523 Build_RPC_Receiver_Specification
4524 (RPC_Receiver => RPC_Receiver,
4525 Request_Parameter => Request);
4527 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4528 Subp_Index := Subp_Id;
4530 -- Subp_Id may not be a constant, because in the case of the RPC
4531 -- receiver for an RCI package, when a call is received from a RAS
4532 -- dereference, it will be assigned during subsequent processing.
4534 RPC_Receiver_Decls := New_List (
4535 Make_Object_Declaration (Loc,
4536 Defining_Identifier => Subp_Id,
4537 Object_Definition =>
4538 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4540 Make_Attribute_Reference (Loc,
4542 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4543 Attribute_Name => Name_Input,
4544 Expressions => New_List (
4545 Make_Selected_Component (Loc,
4547 Selector_Name => Name_Params)))));
4552 Make_Subprogram_Body (Loc,
4553 Specification => RPC_Receiver_Spec,
4554 Declarations => RPC_Receiver_Decls,
4555 Handled_Statement_Sequence =>
4556 Make_Handled_Sequence_Of_Statements (Loc,
4557 Statements => Stmts));
4558 end Build_RPC_Receiver_Body;
4560 -----------------------
4561 -- Build_Stub_Target --
4562 -----------------------
4564 function Build_Stub_Target
4567 RCI_Locator : Entity_Id;
4568 Controlling_Parameter : Entity_Id) return RPC_Target
4570 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4572 Target_Info.Partition :=
4573 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4574 if Present (Controlling_Parameter) then
4576 Make_Object_Declaration (Loc,
4577 Defining_Identifier => Target_Info.Partition,
4578 Constant_Present => True,
4579 Object_Definition =>
4580 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4583 Make_Selected_Component (Loc,
4584 Prefix => Controlling_Parameter,
4585 Selector_Name => Name_Origin)));
4587 Target_Info.RPC_Receiver :=
4588 Make_Selected_Component (Loc,
4589 Prefix => Controlling_Parameter,
4590 Selector_Name => Name_Receiver);
4594 Make_Object_Declaration (Loc,
4595 Defining_Identifier => Target_Info.Partition,
4596 Constant_Present => True,
4597 Object_Definition =>
4598 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4601 Make_Function_Call (Loc,
4602 Name => Make_Selected_Component (Loc,
4604 Make_Identifier (Loc, Chars (RCI_Locator)),
4606 Make_Identifier (Loc,
4607 Name_Get_Active_Partition_ID)))));
4609 Target_Info.RPC_Receiver :=
4610 Make_Selected_Component (Loc,
4612 Make_Identifier (Loc, Chars (RCI_Locator)),
4614 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4617 end Build_Stub_Target;
4619 ---------------------
4620 -- Build_Stub_Type --
4621 ---------------------
4623 procedure Build_Stub_Type
4624 (RACW_Type : Entity_Id;
4625 Stub_Type : Entity_Id;
4626 Stub_Type_Decl : out Node_Id;
4627 RPC_Receiver_Decl : out Node_Id)
4629 Loc : constant Source_Ptr := Sloc (Stub_Type);
4630 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4634 Make_Full_Type_Declaration (Loc,
4635 Defining_Identifier => Stub_Type,
4637 Make_Record_Definition (Loc,
4638 Tagged_Present => True,
4639 Limited_Present => True,
4641 Make_Component_List (Loc,
4642 Component_Items => New_List (
4644 Make_Component_Declaration (Loc,
4645 Defining_Identifier =>
4646 Make_Defining_Identifier (Loc, Name_Origin),
4647 Component_Definition =>
4648 Make_Component_Definition (Loc,
4649 Aliased_Present => False,
4650 Subtype_Indication =>
4652 RTE (RE_Partition_ID), Loc))),
4654 Make_Component_Declaration (Loc,
4655 Defining_Identifier =>
4656 Make_Defining_Identifier (Loc, Name_Receiver),
4657 Component_Definition =>
4658 Make_Component_Definition (Loc,
4659 Aliased_Present => False,
4660 Subtype_Indication =>
4661 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4663 Make_Component_Declaration (Loc,
4664 Defining_Identifier =>
4665 Make_Defining_Identifier (Loc, Name_Addr),
4666 Component_Definition =>
4667 Make_Component_Definition (Loc,
4668 Aliased_Present => False,
4669 Subtype_Indication =>
4670 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4672 Make_Component_Declaration (Loc,
4673 Defining_Identifier =>
4674 Make_Defining_Identifier (Loc, Name_Asynchronous),
4675 Component_Definition =>
4676 Make_Component_Definition (Loc,
4677 Aliased_Present => False,
4678 Subtype_Indication =>
4680 Standard_Boolean, Loc)))))));
4683 RPC_Receiver_Decl := Empty;
4686 RPC_Receiver_Request : constant Entity_Id :=
4687 Make_Defining_Identifier (Loc, Name_R);
4689 RPC_Receiver_Decl :=
4690 Make_Subprogram_Declaration (Loc,
4691 Build_RPC_Receiver_Specification (
4692 RPC_Receiver => Make_Defining_Identifier (Loc,
4693 New_Internal_Name ('R')),
4694 Request_Parameter => RPC_Receiver_Request));
4697 end Build_Stub_Type;
4699 --------------------------------------
4700 -- Build_Subprogram_Receiving_Stubs --
4701 --------------------------------------
4703 function Build_Subprogram_Receiving_Stubs
4704 (Vis_Decl : Node_Id;
4705 Asynchronous : Boolean;
4706 Dynamically_Asynchronous : Boolean := False;
4707 Stub_Type : Entity_Id := Empty;
4708 RACW_Type : Entity_Id := Empty;
4709 Parent_Primitive : Entity_Id := Empty) return Node_Id
4711 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4713 Request_Parameter : constant Entity_Id :=
4714 Make_Defining_Identifier (Loc,
4715 New_Internal_Name ('R'));
4716 -- Formal parameter for receiving stubs: a descriptor for an incoming
4719 Decls : constant List_Id := New_List;
4720 -- All the parameters will get declared before calling the real
4721 -- subprograms. Also the out parameters will be declared.
4723 Statements : constant List_Id := New_List;
4725 Extra_Formal_Statements : constant List_Id := New_List;
4726 -- Statements concerning extra formal parameters
4728 After_Statements : constant List_Id := New_List;
4729 -- Statements to be executed after the subprogram call
4731 Inner_Decls : List_Id := No_List;
4732 -- In case of a function, the inner declarations are needed since
4733 -- the result may be unconstrained.
4735 Excep_Handlers : List_Id := No_List;
4736 Excep_Choice : Entity_Id;
4737 Excep_Code : List_Id;
4739 Parameter_List : constant List_Id := New_List;
4740 -- List of parameters to be passed to the subprogram
4742 Current_Parameter : Node_Id;
4744 Ordered_Parameters_List : constant List_Id :=
4745 Build_Ordered_Parameters_List
4746 (Specification (Vis_Decl));
4748 Subp_Spec : Node_Id;
4749 -- Subprogram specification
4751 Called_Subprogram : Node_Id;
4752 -- The subprogram to call
4754 Null_Raise_Statement : Node_Id;
4756 Dynamic_Async : Entity_Id;
4759 if Present (RACW_Type) then
4760 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4762 Called_Subprogram :=
4764 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4767 if Dynamically_Asynchronous then
4769 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4771 Dynamic_Async := Empty;
4774 if not Asynchronous or Dynamically_Asynchronous then
4776 -- The first statement after the subprogram call is a statement to
4777 -- write a Null_Occurrence into the result stream.
4779 Null_Raise_Statement :=
4780 Make_Attribute_Reference (Loc,
4782 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4783 Attribute_Name => Name_Write,
4784 Expressions => New_List (
4785 Make_Selected_Component (Loc,
4786 Prefix => Request_Parameter,
4787 Selector_Name => Name_Result),
4788 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4790 if Dynamically_Asynchronous then
4791 Null_Raise_Statement :=
4792 Make_Implicit_If_Statement (Vis_Decl,
4794 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4795 Then_Statements => New_List (Null_Raise_Statement));
4798 Append_To (After_Statements, Null_Raise_Statement);
4801 -- Loop through every parameter and get its value from the stream. If
4802 -- the parameter is unconstrained, then the parameter is read using
4803 -- 'Input at the point of declaration.
4805 Current_Parameter := First (Ordered_Parameters_List);
4806 while Present (Current_Parameter) loop
4809 Constrained : Boolean;
4811 Need_Extra_Constrained : Boolean;
4812 -- True when an Extra_Constrained actual is required
4814 Object : constant Entity_Id :=
4815 Make_Defining_Identifier (Loc,
4816 New_Internal_Name ('P'));
4818 Expr : Node_Id := Empty;
4820 Is_Controlling_Formal : constant Boolean :=
4821 Is_RACW_Controlling_Formal
4822 (Current_Parameter, Stub_Type);
4825 if Is_Controlling_Formal then
4827 -- We have a controlling formal parameter. Read its address
4828 -- rather than a real object. The address is in Unsigned_64
4831 Etyp := RTE (RE_Unsigned_64);
4833 Etyp := Etype (Parameter_Type (Current_Parameter));
4836 Constrained := not Transmit_As_Unconstrained (Etyp);
4838 if In_Present (Current_Parameter)
4839 or else not Out_Present (Current_Parameter)
4840 or else not Constrained
4841 or else Is_Controlling_Formal
4843 -- If an input parameter is constrained, then the read of
4844 -- the parameter is deferred until the beginning of the
4845 -- subprogram body. If it is unconstrained, then an
4846 -- expression is built for the object declaration and the
4847 -- variable is set using 'Input instead of 'Read. Note that
4848 -- this deferral does not change the order in which the
4849 -- actuals are read because Build_Ordered_Parameter_List
4850 -- puts them unconstrained first.
4853 Append_To (Statements,
4854 Make_Attribute_Reference (Loc,
4855 Prefix => New_Occurrence_Of (Etyp, Loc),
4856 Attribute_Name => Name_Read,
4857 Expressions => New_List (
4858 Make_Selected_Component (Loc,
4859 Prefix => Request_Parameter,
4860 Selector_Name => Name_Params),
4861 New_Occurrence_Of (Object, Loc))));
4865 -- Build and append Input_With_Tag_Check function
4868 Input_With_Tag_Check (Loc,
4871 Make_Selected_Component (Loc,
4872 Prefix => Request_Parameter,
4873 Selector_Name => Name_Params)));
4875 -- Prepare function call expression
4878 Make_Function_Call (Loc,
4882 (Specification (Last (Decls))), Loc));
4886 Need_Extra_Constrained :=
4887 Nkind (Parameter_Type (Current_Parameter)) /=
4890 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4892 Present (Extra_Constrained
4893 (Defining_Identifier (Current_Parameter)));
4895 -- We may not associate an extra constrained actual to a
4896 -- constant object, so if one is needed, declare the actual
4897 -- as a variable even if it won't be modified.
4899 Build_Actual_Object_Declaration
4902 Variable => Need_Extra_Constrained
4903 or else Out_Present (Current_Parameter),
4907 -- An out parameter may be written back using a 'Write
4908 -- attribute instead of a 'Output because it has been
4909 -- constrained by the parameter given to the caller. Note that
4910 -- out controlling arguments in the case of a RACW are not put
4911 -- back in the stream because the pointer on them has not
4914 if Out_Present (Current_Parameter)
4916 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4918 Append_To (After_Statements,
4919 Make_Attribute_Reference (Loc,
4920 Prefix => New_Occurrence_Of (Etyp, Loc),
4921 Attribute_Name => Name_Write,
4922 Expressions => New_List (
4923 Make_Selected_Component (Loc,
4924 Prefix => Request_Parameter,
4925 Selector_Name => Name_Result),
4926 New_Occurrence_Of (Object, Loc))));
4929 -- For RACW controlling formals, the Etyp of Object is always
4930 -- an RACW, even if the parameter is not of an anonymous access
4931 -- type. In such case, we need to dereference it at call time.
4933 if Is_Controlling_Formal then
4934 if Nkind (Parameter_Type (Current_Parameter)) /=
4937 Append_To (Parameter_List,
4938 Make_Parameter_Association (Loc,
4941 Defining_Identifier (Current_Parameter), Loc),
4942 Explicit_Actual_Parameter =>
4943 Make_Explicit_Dereference (Loc,
4944 Unchecked_Convert_To (RACW_Type,
4945 OK_Convert_To (RTE (RE_Address),
4946 New_Occurrence_Of (Object, Loc))))));
4949 Append_To (Parameter_List,
4950 Make_Parameter_Association (Loc,
4953 Defining_Identifier (Current_Parameter), Loc),
4954 Explicit_Actual_Parameter =>
4955 Unchecked_Convert_To (RACW_Type,
4956 OK_Convert_To (RTE (RE_Address),
4957 New_Occurrence_Of (Object, Loc)))));
4961 Append_To (Parameter_List,
4962 Make_Parameter_Association (Loc,
4965 Defining_Identifier (Current_Parameter), Loc),
4966 Explicit_Actual_Parameter =>
4967 New_Occurrence_Of (Object, Loc)));
4970 -- If the current parameter needs an extra formal, then read it
4971 -- from the stream and set the corresponding semantic field in
4972 -- the variable. If the kind of the parameter identifier is
4973 -- E_Void, then this is a compiler generated parameter that
4974 -- doesn't need an extra constrained status.
4976 -- The case of Extra_Accessibility should also be handled ???
4978 if Need_Extra_Constrained then
4980 Extra_Parameter : constant Entity_Id :=
4982 (Defining_Identifier
4983 (Current_Parameter));
4985 Formal_Entity : constant Entity_Id :=
4986 Make_Defining_Identifier
4987 (Loc, Chars (Extra_Parameter));
4989 Formal_Type : constant Entity_Id :=
4990 Etype (Extra_Parameter);
4994 Make_Object_Declaration (Loc,
4995 Defining_Identifier => Formal_Entity,
4996 Object_Definition =>
4997 New_Occurrence_Of (Formal_Type, Loc)));
4999 Append_To (Extra_Formal_Statements,
5000 Make_Attribute_Reference (Loc,
5001 Prefix => New_Occurrence_Of (
5003 Attribute_Name => Name_Read,
5004 Expressions => New_List (
5005 Make_Selected_Component (Loc,
5006 Prefix => Request_Parameter,
5007 Selector_Name => Name_Params),
5008 New_Occurrence_Of (Formal_Entity, Loc))));
5010 -- Note: the call to Set_Extra_Constrained below relies
5011 -- on the fact that Object's Ekind has been set by
5012 -- Build_Actual_Object_Declaration.
5014 Set_Extra_Constrained (Object, Formal_Entity);
5019 Next (Current_Parameter);
5022 -- Append the formal statements list at the end of regular statements
5024 Append_List_To (Statements, Extra_Formal_Statements);
5026 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
5028 -- The remote subprogram is a function. We build an inner block to
5029 -- be able to hold a potentially unconstrained result in a
5033 Etyp : constant Entity_Id :=
5034 Etype (Result_Definition (Specification (Vis_Decl)));
5035 Result : constant Node_Id :=
5036 Make_Defining_Identifier (Loc,
5037 New_Internal_Name ('R'));
5039 Inner_Decls := New_List (
5040 Make_Object_Declaration (Loc,
5041 Defining_Identifier => Result,
5042 Constant_Present => True,
5043 Object_Definition => New_Occurrence_Of (Etyp, Loc),
5045 Make_Function_Call (Loc,
5046 Name => Called_Subprogram,
5047 Parameter_Associations => Parameter_List)));
5049 if Is_Class_Wide_Type (Etyp) then
5051 -- For a remote call to a function with a class-wide type,
5052 -- check that the returned value satisfies the requirements
5055 Append_To (Inner_Decls,
5056 Make_Transportable_Check (Loc,
5057 New_Occurrence_Of (Result, Loc)));
5061 Append_To (After_Statements,
5062 Make_Attribute_Reference (Loc,
5063 Prefix => New_Occurrence_Of (Etyp, Loc),
5064 Attribute_Name => Name_Output,
5065 Expressions => New_List (
5066 Make_Selected_Component (Loc,
5067 Prefix => Request_Parameter,
5068 Selector_Name => Name_Result),
5069 New_Occurrence_Of (Result, Loc))));
5072 Append_To (Statements,
5073 Make_Block_Statement (Loc,
5074 Declarations => Inner_Decls,
5075 Handled_Statement_Sequence =>
5076 Make_Handled_Sequence_Of_Statements (Loc,
5077 Statements => After_Statements)));
5080 -- The remote subprogram is a procedure. We do not need any inner
5081 -- block in this case.
5083 if Dynamically_Asynchronous then
5085 Make_Object_Declaration (Loc,
5086 Defining_Identifier => Dynamic_Async,
5087 Object_Definition =>
5088 New_Occurrence_Of (Standard_Boolean, Loc)));
5090 Append_To (Statements,
5091 Make_Attribute_Reference (Loc,
5092 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5093 Attribute_Name => Name_Read,
5094 Expressions => New_List (
5095 Make_Selected_Component (Loc,
5096 Prefix => Request_Parameter,
5097 Selector_Name => Name_Params),
5098 New_Occurrence_Of (Dynamic_Async, Loc))));
5101 Append_To (Statements,
5102 Make_Procedure_Call_Statement (Loc,
5103 Name => Called_Subprogram,
5104 Parameter_Associations => Parameter_List));
5106 Append_List_To (Statements, After_Statements);
5109 if Asynchronous and then not Dynamically_Asynchronous then
5111 -- For an asynchronous procedure, add a null exception handler
5113 Excep_Handlers := New_List (
5114 Make_Implicit_Exception_Handler (Loc,
5115 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5116 Statements => New_List (Make_Null_Statement (Loc))));
5119 -- In the other cases, if an exception is raised, then the
5120 -- exception occurrence is copied into the output stream and
5121 -- no other output parameter is written.
5124 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5126 Excep_Code := New_List (
5127 Make_Attribute_Reference (Loc,
5129 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5130 Attribute_Name => Name_Write,
5131 Expressions => New_List (
5132 Make_Selected_Component (Loc,
5133 Prefix => Request_Parameter,
5134 Selector_Name => Name_Result),
5135 New_Occurrence_Of (Excep_Choice, Loc))));
5137 if Dynamically_Asynchronous then
5138 Excep_Code := New_List (
5139 Make_Implicit_If_Statement (Vis_Decl,
5140 Condition => Make_Op_Not (Loc,
5141 New_Occurrence_Of (Dynamic_Async, Loc)),
5142 Then_Statements => Excep_Code));
5145 Excep_Handlers := New_List (
5146 Make_Implicit_Exception_Handler (Loc,
5147 Choice_Parameter => Excep_Choice,
5148 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5149 Statements => Excep_Code));
5154 Make_Procedure_Specification (Loc,
5155 Defining_Unit_Name =>
5156 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
5158 Parameter_Specifications => New_List (
5159 Make_Parameter_Specification (Loc,
5160 Defining_Identifier => Request_Parameter,
5162 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5165 Make_Subprogram_Body (Loc,
5166 Specification => Subp_Spec,
5167 Declarations => Decls,
5168 Handled_Statement_Sequence =>
5169 Make_Handled_Sequence_Of_Statements (Loc,
5170 Statements => Statements,
5171 Exception_Handlers => Excep_Handlers));
5172 end Build_Subprogram_Receiving_Stubs;
5178 function Result return Node_Id is
5180 return Make_Identifier (Loc, Name_V);
5183 ----------------------
5184 -- Stream_Parameter --
5185 ----------------------
5187 function Stream_Parameter return Node_Id is
5189 return Make_Identifier (Loc, Name_S);
5190 end Stream_Parameter;
5194 -------------------------------
5195 -- Get_And_Reset_RACW_Bodies --
5196 -------------------------------
5198 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5199 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
5200 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5202 Body_Decls : List_Id;
5203 -- Returned list of declarations
5206 if Stub_Elements = Empty_Stub_Structure then
5208 -- Stub elements may be missing as a consequence of a previously
5214 Body_Decls := Stub_Elements.Body_Decls;
5215 Stub_Elements.Body_Decls := No_List;
5216 Stubs_Table.Set (Desig, Stub_Elements);
5218 end Get_And_Reset_RACW_Bodies;
5220 -----------------------
5221 -- Get_Stub_Elements --
5222 -----------------------
5224 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is
5225 Desig : constant Entity_Id :=
5226 Etype (Designated_Type (RACW_Type));
5227 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
5229 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5230 return Stub_Elements;
5231 end Get_Stub_Elements;
5233 -----------------------
5234 -- Get_Subprogram_Id --
5235 -----------------------
5237 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5238 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5240 pragma Assert (Result /= No_String);
5242 end Get_Subprogram_Id;
5244 -----------------------
5245 -- Get_Subprogram_Id --
5246 -----------------------
5248 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5250 return Get_Subprogram_Ids (Def).Int_Identifier;
5251 end Get_Subprogram_Id;
5253 ------------------------
5254 -- Get_Subprogram_Ids --
5255 ------------------------
5257 function Get_Subprogram_Ids
5258 (Def : Entity_Id) return Subprogram_Identifiers
5261 return Subprogram_Identifier_Table.Get (Def);
5262 end Get_Subprogram_Ids;
5268 function Hash (F : Entity_Id) return Hash_Index is
5270 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5273 function Hash (F : Name_Id) return Hash_Index is
5275 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5278 --------------------------
5279 -- Input_With_Tag_Check --
5280 --------------------------
5282 function Input_With_Tag_Check
5284 Var_Type : Entity_Id;
5285 Stream : Node_Id) return Node_Id
5289 Make_Subprogram_Body (Loc,
5290 Specification => Make_Function_Specification (Loc,
5291 Defining_Unit_Name =>
5292 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
5293 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5294 Declarations => No_List,
5295 Handled_Statement_Sequence =>
5296 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5297 Make_Tag_Check (Loc,
5298 Make_Simple_Return_Statement (Loc,
5299 Make_Attribute_Reference (Loc,
5300 Prefix => New_Occurrence_Of (Var_Type, Loc),
5301 Attribute_Name => Name_Input,
5303 New_List (Stream)))))));
5304 end Input_With_Tag_Check;
5306 --------------------------------
5307 -- Is_RACW_Controlling_Formal --
5308 --------------------------------
5310 function Is_RACW_Controlling_Formal
5311 (Parameter : Node_Id;
5312 Stub_Type : Entity_Id) return Boolean
5317 -- If the kind of the parameter is E_Void, then it is not a
5318 -- controlling formal (this can happen in the context of RAS).
5320 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5324 -- If the parameter is not a controlling formal, then it cannot
5325 -- be possibly a RACW_Controlling_Formal.
5327 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5331 Typ := Parameter_Type (Parameter);
5332 return (Nkind (Typ) = N_Access_Definition
5333 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5334 or else Etype (Typ) = Stub_Type;
5335 end Is_RACW_Controlling_Formal;
5337 ------------------------------
5338 -- Make_Transportable_Check --
5339 ------------------------------
5341 function Make_Transportable_Check
5343 Expr : Node_Id) return Node_Id is
5346 Make_Raise_Program_Error (Loc,
5349 Build_Get_Transportable (Loc,
5350 Make_Selected_Component (Loc,
5352 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5353 Reason => PE_Non_Transportable_Actual);
5354 end Make_Transportable_Check;
5356 -----------------------------
5357 -- Make_Selected_Component --
5358 -----------------------------
5360 function Make_Selected_Component
5363 Selector_Name : Name_Id) return Node_Id
5366 return Make_Selected_Component (Loc,
5367 Prefix => New_Occurrence_Of (Prefix, Loc),
5368 Selector_Name => Make_Identifier (Loc, Selector_Name));
5369 end Make_Selected_Component;
5371 --------------------
5372 -- Make_Tag_Check --
5373 --------------------
5375 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5376 Occ : constant Entity_Id :=
5377 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5380 return Make_Block_Statement (Loc,
5381 Handled_Statement_Sequence =>
5382 Make_Handled_Sequence_Of_Statements (Loc,
5383 Statements => New_List (N),
5385 Exception_Handlers => New_List (
5386 Make_Implicit_Exception_Handler (Loc,
5387 Choice_Parameter => Occ,
5389 Exception_Choices =>
5390 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5393 New_List (Make_Procedure_Call_Statement (Loc,
5395 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5396 New_List (New_Occurrence_Of (Occ, Loc))))))));
5399 ----------------------------
5400 -- Need_Extra_Constrained --
5401 ----------------------------
5403 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5404 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5406 return Out_Present (Parameter)
5407 and then Has_Discriminants (Etyp)
5408 and then not Is_Constrained (Etyp)
5409 and then not Is_Indefinite_Subtype (Etyp);
5410 end Need_Extra_Constrained;
5412 ------------------------------------
5413 -- Pack_Entity_Into_Stream_Access --
5414 ------------------------------------
5416 function Pack_Entity_Into_Stream_Access
5420 Etyp : Entity_Id := Empty) return Node_Id
5425 if Present (Etyp) then
5428 Typ := Etype (Object);
5432 Pack_Node_Into_Stream_Access (Loc,
5434 Object => New_Occurrence_Of (Object, Loc),
5436 end Pack_Entity_Into_Stream_Access;
5438 ---------------------------
5439 -- Pack_Node_Into_Stream --
5440 ---------------------------
5442 function Pack_Node_Into_Stream
5446 Etyp : Entity_Id) return Node_Id
5448 Write_Attribute : Name_Id := Name_Write;
5451 if not Is_Constrained (Etyp) then
5452 Write_Attribute := Name_Output;
5456 Make_Attribute_Reference (Loc,
5457 Prefix => New_Occurrence_Of (Etyp, Loc),
5458 Attribute_Name => Write_Attribute,
5459 Expressions => New_List (
5460 Make_Attribute_Reference (Loc,
5461 Prefix => New_Occurrence_Of (Stream, Loc),
5462 Attribute_Name => Name_Access),
5464 end Pack_Node_Into_Stream;
5466 ----------------------------------
5467 -- Pack_Node_Into_Stream_Access --
5468 ----------------------------------
5470 function Pack_Node_Into_Stream_Access
5474 Etyp : Entity_Id) return Node_Id
5476 Write_Attribute : Name_Id := Name_Write;
5479 if not Is_Constrained (Etyp) then
5480 Write_Attribute := Name_Output;
5484 Make_Attribute_Reference (Loc,
5485 Prefix => New_Occurrence_Of (Etyp, Loc),
5486 Attribute_Name => Write_Attribute,
5487 Expressions => New_List (
5490 end Pack_Node_Into_Stream_Access;
5492 ---------------------
5493 -- PolyORB_Support --
5494 ---------------------
5496 package body PolyORB_Support is
5498 -- Local subprograms
5500 procedure Add_RACW_Read_Attribute
5501 (RACW_Type : Entity_Id;
5502 Stub_Type : Entity_Id;
5503 Stub_Type_Access : Entity_Id;
5504 Body_Decls : List_Id);
5505 -- Add Read attribute for the RACW type. The declaration and attribute
5506 -- definition clauses are inserted right after the declaration of
5507 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5508 -- appended to it (case where the RACW declaration is in the main unit).
5510 procedure Add_RACW_Write_Attribute
5511 (RACW_Type : Entity_Id;
5512 Stub_Type : Entity_Id;
5513 Stub_Type_Access : Entity_Id;
5514 Body_Decls : List_Id);
5515 -- Same as above for the Write attribute
5517 procedure Add_RACW_From_Any
5518 (RACW_Type : Entity_Id;
5519 Body_Decls : List_Id);
5520 -- Add the From_Any TSS for this RACW type
5522 procedure Add_RACW_To_Any
5523 (RACW_Type : Entity_Id;
5524 Body_Decls : List_Id);
5525 -- Add the To_Any TSS for this RACW type
5527 procedure Add_RACW_TypeCode
5528 (Designated_Type : Entity_Id;
5529 RACW_Type : Entity_Id;
5530 Body_Decls : List_Id);
5531 -- Add the TypeCode TSS for this RACW type
5533 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5534 -- Add the From_Any TSS for this RAS type
5536 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5537 -- Add the To_Any TSS for this RAS type
5539 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5540 -- Add the TypeCode TSS for this RAS type
5542 procedure Add_RAS_Access_TSS (N : Node_Id);
5543 -- Add a subprogram body for RAS Access TSS
5545 -------------------------------------
5546 -- Add_Obj_RPC_Receiver_Completion --
5547 -------------------------------------
5549 procedure Add_Obj_RPC_Receiver_Completion
5552 RPC_Receiver : Entity_Id;
5553 Stub_Elements : Stub_Structure)
5555 Desig : constant Entity_Id :=
5556 Etype (Designated_Type (Stub_Elements.RACW_Type));
5559 Make_Procedure_Call_Statement (Loc,
5562 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5564 Parameter_Associations => New_List (
5568 Make_String_Literal (Loc,
5569 Full_Qualified_Name (Desig)),
5573 Make_Attribute_Reference (Loc,
5576 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5582 Make_Attribute_Reference (Loc,
5585 Defining_Identifier (
5586 Stub_Elements.RPC_Receiver_Decl), Loc),
5589 end Add_Obj_RPC_Receiver_Completion;
5591 -----------------------
5592 -- Add_RACW_Features --
5593 -----------------------
5595 procedure Add_RACW_Features
5596 (RACW_Type : Entity_Id;
5598 Stub_Type : Entity_Id;
5599 Stub_Type_Access : Entity_Id;
5600 RPC_Receiver_Decl : Node_Id;
5601 Body_Decls : List_Id)
5603 pragma Warnings (Off);
5604 pragma Unreferenced (RPC_Receiver_Decl);
5605 pragma Warnings (On);
5609 (RACW_Type => RACW_Type,
5610 Body_Decls => Body_Decls);
5613 (RACW_Type => RACW_Type,
5614 Body_Decls => Body_Decls);
5616 Add_RACW_Write_Attribute
5617 (RACW_Type => RACW_Type,
5618 Stub_Type => Stub_Type,
5619 Stub_Type_Access => Stub_Type_Access,
5620 Body_Decls => Body_Decls);
5622 Add_RACW_Read_Attribute
5623 (RACW_Type => RACW_Type,
5624 Stub_Type => Stub_Type,
5625 Stub_Type_Access => Stub_Type_Access,
5626 Body_Decls => Body_Decls);
5629 (Designated_Type => Desig,
5630 RACW_Type => RACW_Type,
5631 Body_Decls => Body_Decls);
5632 end Add_RACW_Features;
5634 -----------------------
5635 -- Add_RACW_From_Any --
5636 -----------------------
5638 procedure Add_RACW_From_Any
5639 (RACW_Type : Entity_Id;
5640 Body_Decls : List_Id)
5642 Loc : constant Source_Ptr := Sloc (RACW_Type);
5643 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5645 Fnam : constant Entity_Id :=
5646 Make_Defining_Identifier (Loc,
5647 Chars => New_External_Name (Chars (RACW_Type), 'F'));
5649 Func_Spec : Node_Id;
5650 Func_Decl : Node_Id;
5651 Func_Body : Node_Id;
5653 Statements : List_Id;
5654 -- Various parts of the subprogram
5656 Any_Parameter : constant Entity_Id :=
5657 Make_Defining_Identifier (Loc, Name_A);
5659 Asynchronous_Flag : constant Entity_Id :=
5660 Asynchronous_Flags_Table.Get (RACW_Type);
5661 -- The flag object declared in Add_RACW_Asynchronous_Flag
5665 Make_Function_Specification (Loc,
5666 Defining_Unit_Name =>
5668 Parameter_Specifications => New_List (
5669 Make_Parameter_Specification (Loc,
5670 Defining_Identifier =>
5673 New_Occurrence_Of (RTE (RE_Any), Loc))),
5674 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5676 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5677 -- entity in the declaration spec, not those of the body spec.
5679 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5680 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5681 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5683 if No (Body_Decls) then
5687 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5688 -- set on the stub type if, and only if, the RACW type has a pragma
5689 -- Asynchronous. This is incorrect for RACWs that implement RAS
5690 -- types, because in that case the /designated subprogram/ (not the
5691 -- type) might be asynchronous, and that causes the stub to need to
5692 -- be asynchronous too. A solution is to transport a RAS as a struct
5693 -- containing a RACW and an asynchronous flag, and to properly alter
5694 -- the Asynchronous component in the stub type in the RAS's _From_Any
5697 Statements := New_List (
5698 Make_Simple_Return_Statement (Loc,
5699 Expression => Unchecked_Convert_To (RACW_Type,
5700 Make_Function_Call (Loc,
5701 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5702 Parameter_Associations => New_List (
5703 Make_Function_Call (Loc,
5704 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5705 Parameter_Associations => New_List (
5706 New_Occurrence_Of (Any_Parameter, Loc))),
5707 Build_Stub_Tag (Loc, RACW_Type),
5708 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5709 New_Occurrence_Of (Asynchronous_Flag, Loc))))));
5712 Make_Subprogram_Body (Loc,
5713 Specification => Copy_Specification (Loc, Func_Spec),
5714 Declarations => No_List,
5715 Handled_Statement_Sequence =>
5716 Make_Handled_Sequence_Of_Statements (Loc,
5717 Statements => Statements));
5719 Append_To (Body_Decls, Func_Body);
5720 end Add_RACW_From_Any;
5722 -----------------------------
5723 -- Add_RACW_Read_Attribute --
5724 -----------------------------
5726 procedure Add_RACW_Read_Attribute
5727 (RACW_Type : Entity_Id;
5728 Stub_Type : Entity_Id;
5729 Stub_Type_Access : Entity_Id;
5730 Body_Decls : List_Id)
5732 pragma Warnings (Off);
5733 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5734 pragma Warnings (On);
5735 Loc : constant Source_Ptr := Sloc (RACW_Type);
5737 Proc_Decl : Node_Id;
5738 Attr_Decl : Node_Id;
5740 Body_Node : Node_Id;
5742 Decls : constant List_Id := New_List;
5743 Statements : constant List_Id := New_List;
5744 Reference : constant Entity_Id :=
5745 Make_Defining_Identifier (Loc, Name_R);
5746 -- Various parts of the procedure
5748 Pnam : constant Entity_Id := Make_Defining_Identifier (Loc,
5749 New_Internal_Name ('R'));
5751 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5753 Asynchronous_Flag : constant Entity_Id :=
5754 Asynchronous_Flags_Table.Get (RACW_Type);
5755 pragma Assert (Present (Asynchronous_Flag));
5757 function Stream_Parameter return Node_Id;
5758 function Result return Node_Id;
5760 -- Functions to create occurrences of the formal parameter names
5766 function Result return Node_Id is
5768 return Make_Identifier (Loc, Name_V);
5771 ----------------------
5772 -- Stream_Parameter --
5773 ----------------------
5775 function Stream_Parameter return Node_Id is
5777 return Make_Identifier (Loc, Name_S);
5778 end Stream_Parameter;
5780 -- Start of processing for Add_RACW_Read_Attribute
5783 Build_Stream_Procedure
5784 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
5786 Proc_Decl := Make_Subprogram_Declaration (Loc,
5787 Copy_Specification (Loc, Specification (Body_Node)));
5790 Make_Attribute_Definition_Clause (Loc,
5791 Name => New_Occurrence_Of (RACW_Type, Loc),
5795 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5797 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5798 Insert_After (Proc_Decl, Attr_Decl);
5800 if No (Body_Decls) then
5805 Make_Object_Declaration (Loc,
5806 Defining_Identifier =>
5808 Object_Definition =>
5809 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5811 Append_List_To (Statements, New_List (
5812 Make_Attribute_Reference (Loc,
5814 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5815 Attribute_Name => Name_Read,
5816 Expressions => New_List (
5818 New_Occurrence_Of (Reference, Loc))),
5820 Make_Assignment_Statement (Loc,
5824 Unchecked_Convert_To (RACW_Type,
5825 Make_Function_Call (Loc,
5827 New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5828 Parameter_Associations => New_List (
5829 New_Occurrence_Of (Reference, Loc),
5830 Build_Stub_Tag (Loc, RACW_Type),
5831 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5832 New_Occurrence_Of (Asynchronous_Flag, Loc)))))));
5834 Set_Declarations (Body_Node, Decls);
5835 Append_To (Body_Decls, Body_Node);
5836 end Add_RACW_Read_Attribute;
5838 ---------------------
5839 -- Add_RACW_To_Any --
5840 ---------------------
5842 procedure Add_RACW_To_Any
5843 (RACW_Type : Entity_Id;
5844 Body_Decls : List_Id)
5846 Loc : constant Source_Ptr := Sloc (RACW_Type);
5848 Fnam : constant Entity_Id :=
5849 Make_Defining_Identifier (Loc,
5850 Chars => New_External_Name (Chars (RACW_Type), 'T'));
5852 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5854 Stub_Elements : constant Stub_Structure :=
5855 Get_Stub_Elements (RACW_Type);
5857 Func_Spec : Node_Id;
5858 Func_Decl : Node_Id;
5859 Func_Body : Node_Id;
5862 Statements : List_Id;
5863 -- Various parts of the subprogram
5865 RACW_Parameter : constant Entity_Id :=
5866 Make_Defining_Identifier (Loc, Name_R);
5868 Reference : constant Entity_Id :=
5869 Make_Defining_Identifier
5870 (Loc, New_Internal_Name ('R'));
5871 Any : constant Entity_Id :=
5872 Make_Defining_Identifier
5873 (Loc, New_Internal_Name ('A'));
5877 Make_Function_Specification (Loc,
5878 Defining_Unit_Name =>
5880 Parameter_Specifications => New_List (
5881 Make_Parameter_Specification (Loc,
5882 Defining_Identifier =>
5885 New_Occurrence_Of (RACW_Type, Loc))),
5886 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5888 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5889 -- entity in the declaration spec, not in the body spec.
5891 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5893 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5894 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5896 if No (Body_Decls) then
5902 -- R : constant Object_Ref :=
5908 -- RPC_Receiver'Access);
5912 Make_Object_Declaration (Loc,
5913 Defining_Identifier => Reference,
5914 Constant_Present => True,
5915 Object_Definition =>
5916 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5918 Make_Function_Call (Loc,
5919 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5920 Parameter_Associations => New_List (
5921 Unchecked_Convert_To (RTE (RE_Address),
5922 New_Occurrence_Of (RACW_Parameter, Loc)),
5923 Make_String_Literal (Loc,
5924 Strval => Full_Qualified_Name
5925 (Etype (Designated_Type (RACW_Type)))),
5926 Build_Stub_Tag (Loc, RACW_Type),
5927 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5928 Make_Attribute_Reference (Loc,
5931 (Defining_Identifier
5932 (Stub_Elements.RPC_Receiver_Decl), Loc),
5933 Attribute_Name => Name_Access)))),
5935 Make_Object_Declaration (Loc,
5936 Defining_Identifier => Any,
5937 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)));
5941 -- Any := TA_ObjRef (Reference);
5942 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5945 Statements := New_List (
5946 Make_Assignment_Statement (Loc,
5947 Name => New_Occurrence_Of (Any, Loc),
5949 Make_Function_Call (Loc,
5950 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5951 Parameter_Associations => New_List (
5952 New_Occurrence_Of (Reference, Loc)))),
5954 Make_Procedure_Call_Statement (Loc,
5955 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5956 Parameter_Associations => New_List (
5957 New_Occurrence_Of (Any, Loc),
5958 Make_Selected_Component (Loc,
5960 Defining_Identifier (
5961 Stub_Elements.RPC_Receiver_Decl),
5962 Selector_Name => Name_Obj_TypeCode))),
5964 Make_Simple_Return_Statement (Loc,
5965 Expression => New_Occurrence_Of (Any, Loc)));
5968 Make_Subprogram_Body (Loc,
5969 Specification => Copy_Specification (Loc, Func_Spec),
5970 Declarations => Decls,
5971 Handled_Statement_Sequence =>
5972 Make_Handled_Sequence_Of_Statements (Loc,
5973 Statements => Statements));
5974 Append_To (Body_Decls, Func_Body);
5975 end Add_RACW_To_Any;
5977 -----------------------
5978 -- Add_RACW_TypeCode --
5979 -----------------------
5981 procedure Add_RACW_TypeCode
5982 (Designated_Type : Entity_Id;
5983 RACW_Type : Entity_Id;
5984 Body_Decls : List_Id)
5986 Loc : constant Source_Ptr := Sloc (RACW_Type);
5988 Fnam : constant Entity_Id :=
5989 Make_Defining_Identifier (Loc,
5990 Chars => New_External_Name (Chars (RACW_Type), 'Y'));
5992 Stub_Elements : constant Stub_Structure :=
5993 Stubs_Table.Get (Designated_Type);
5994 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5996 Func_Spec : Node_Id;
5997 Func_Decl : Node_Id;
5998 Func_Body : Node_Id;
6002 -- The spec for this subprogram has a dummy 'access RACW' argument,
6003 -- which serves only for overloading purposes.
6006 Make_Function_Specification (Loc,
6007 Defining_Unit_Name => Fnam,
6008 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6010 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6011 -- entity in the declaration spec, not those of the body spec.
6013 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6014 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6015 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6017 if No (Body_Decls) then
6022 Make_Subprogram_Body (Loc,
6023 Specification => Copy_Specification (Loc, Func_Spec),
6024 Declarations => Empty_List,
6025 Handled_Statement_Sequence =>
6026 Make_Handled_Sequence_Of_Statements (Loc,
6027 Statements => New_List (
6028 Make_Simple_Return_Statement (Loc,
6030 Make_Selected_Component (Loc,
6033 (Stub_Elements.RPC_Receiver_Decl),
6034 Selector_Name => Name_Obj_TypeCode)))));
6036 Append_To (Body_Decls, Func_Body);
6037 end Add_RACW_TypeCode;
6039 ------------------------------
6040 -- Add_RACW_Write_Attribute --
6041 ------------------------------
6043 procedure Add_RACW_Write_Attribute
6044 (RACW_Type : Entity_Id;
6045 Stub_Type : Entity_Id;
6046 Stub_Type_Access : Entity_Id;
6047 Body_Decls : List_Id)
6049 pragma Warnings (Off);
6050 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6051 pragma Warnings (On);
6053 Loc : constant Source_Ptr := Sloc (RACW_Type);
6055 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
6057 Stub_Elements : constant Stub_Structure :=
6058 Get_Stub_Elements (RACW_Type);
6060 Body_Node : Node_Id;
6061 Proc_Decl : Node_Id;
6062 Attr_Decl : Node_Id;
6064 Statements : constant List_Id := New_List;
6065 Pnam : constant Entity_Id :=
6066 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
6068 function Stream_Parameter return Node_Id;
6069 function Object return Node_Id;
6070 -- Functions to create occurrences of the formal parameter names
6076 function Object return Node_Id is
6078 return Make_Identifier (Loc, Name_V);
6081 ----------------------
6082 -- Stream_Parameter --
6083 ----------------------
6085 function Stream_Parameter return Node_Id is
6087 return Make_Identifier (Loc, Name_S);
6088 end Stream_Parameter;
6090 -- Start of processing for Add_RACW_Write_Attribute
6093 Build_Stream_Procedure
6094 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
6097 Make_Subprogram_Declaration (Loc,
6098 Copy_Specification (Loc, Specification (Body_Node)));
6101 Make_Attribute_Definition_Clause (Loc,
6102 Name => New_Occurrence_Of (RACW_Type, Loc),
6103 Chars => Name_Write,
6106 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6108 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6109 Insert_After (Proc_Decl, Attr_Decl);
6111 if No (Body_Decls) then
6115 Append_To (Statements,
6116 Pack_Node_Into_Stream_Access (Loc,
6117 Stream => Stream_Parameter,
6119 Make_Function_Call (Loc,
6120 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6121 Parameter_Associations => New_List (
6122 Unchecked_Convert_To (RTE (RE_Address), Object),
6123 Make_String_Literal (Loc,
6124 Strval => Full_Qualified_Name
6125 (Etype (Designated_Type (RACW_Type)))),
6126 Build_Stub_Tag (Loc, RACW_Type),
6127 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
6128 Make_Attribute_Reference (Loc,
6131 (Defining_Identifier
6132 (Stub_Elements.RPC_Receiver_Decl), Loc),
6133 Attribute_Name => Name_Access))),
6135 Etyp => RTE (RE_Object_Ref)));
6137 Append_To (Body_Decls, Body_Node);
6138 end Add_RACW_Write_Attribute;
6140 -----------------------
6141 -- Add_RAST_Features --
6142 -----------------------
6144 procedure Add_RAST_Features
6145 (Vis_Decl : Node_Id;
6146 RAS_Type : Entity_Id)
6149 Add_RAS_Access_TSS (Vis_Decl);
6151 Add_RAS_From_Any (RAS_Type);
6152 Add_RAS_TypeCode (RAS_Type);
6154 -- To_Any uses TypeCode, and therefore needs to be generated last
6156 Add_RAS_To_Any (RAS_Type);
6157 end Add_RAST_Features;
6159 ------------------------
6160 -- Add_RAS_Access_TSS --
6161 ------------------------
6163 procedure Add_RAS_Access_TSS (N : Node_Id) is
6164 Loc : constant Source_Ptr := Sloc (N);
6166 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6167 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6168 -- Ras_Type is the access to subprogram type; Fat_Type is the
6169 -- corresponding record type.
6171 RACW_Type : constant Entity_Id :=
6172 Underlying_RACW_Type (Ras_Type);
6174 Stub_Elements : constant Stub_Structure :=
6175 Get_Stub_Elements (RACW_Type);
6177 Proc : constant Entity_Id :=
6178 Make_Defining_Identifier (Loc,
6179 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6181 Proc_Spec : Node_Id;
6183 -- Formal parameters
6185 Package_Name : constant Entity_Id :=
6186 Make_Defining_Identifier (Loc,
6191 Subp_Id : constant Entity_Id :=
6192 Make_Defining_Identifier (Loc,
6195 -- Target subprogram
6197 Asynch_P : constant Entity_Id :=
6198 Make_Defining_Identifier (Loc,
6199 Chars => Name_Asynchronous);
6200 -- Is the procedure to which the 'Access applies asynchronous?
6202 All_Calls_Remote : constant Entity_Id :=
6203 Make_Defining_Identifier (Loc,
6204 Chars => Name_All_Calls_Remote);
6205 -- True if an All_Calls_Remote pragma applies to the RCI unit
6206 -- that contains the subprogram.
6208 -- Common local variables
6210 Proc_Decls : List_Id;
6211 Proc_Statements : List_Id;
6213 Subp_Ref : constant Entity_Id :=
6214 Make_Defining_Identifier (Loc, Name_R);
6215 -- Reference that designates the target subprogram (returned
6216 -- by Get_RAS_Info).
6218 Is_Local : constant Entity_Id :=
6219 Make_Defining_Identifier (Loc, Name_L);
6220 Local_Addr : constant Entity_Id :=
6221 Make_Defining_Identifier (Loc, Name_A);
6222 -- For the call to Get_Local_Address
6224 -- Additional local variables for the remote case
6226 Local_Stub : constant Entity_Id :=
6227 Make_Defining_Identifier (Loc,
6228 Chars => New_Internal_Name ('L'));
6230 Stub_Ptr : constant Entity_Id :=
6231 Make_Defining_Identifier (Loc,
6232 Chars => New_Internal_Name ('S'));
6235 (Field_Name : Name_Id;
6236 Value : Node_Id) return Node_Id;
6237 -- Construct an assignment that sets the named component in the
6245 (Field_Name : Name_Id;
6246 Value : Node_Id) return Node_Id
6250 Make_Assignment_Statement (Loc,
6252 Make_Selected_Component (Loc,
6254 Selector_Name => Field_Name),
6255 Expression => Value);
6258 -- Start of processing for Add_RAS_Access_TSS
6261 Proc_Decls := New_List (
6263 -- Common declarations
6265 Make_Object_Declaration (Loc,
6266 Defining_Identifier => Subp_Ref,
6267 Object_Definition =>
6268 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6270 Make_Object_Declaration (Loc,
6271 Defining_Identifier => Is_Local,
6272 Object_Definition =>
6273 New_Occurrence_Of (Standard_Boolean, Loc)),
6275 Make_Object_Declaration (Loc,
6276 Defining_Identifier => Local_Addr,
6277 Object_Definition =>
6278 New_Occurrence_Of (RTE (RE_Address), Loc)),
6280 Make_Object_Declaration (Loc,
6281 Defining_Identifier => Local_Stub,
6282 Aliased_Present => True,
6283 Object_Definition =>
6284 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6286 Make_Object_Declaration (Loc,
6287 Defining_Identifier => Stub_Ptr,
6288 Object_Definition =>
6289 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6291 Make_Attribute_Reference (Loc,
6292 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6293 Attribute_Name => Name_Unchecked_Access)));
6295 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6296 -- Build_Get_Unique_RP_Call needs this information
6298 -- Get_RAS_Info (Pkg, Subp, R);
6299 -- Obtain a reference to the target subprogram
6301 Proc_Statements := New_List (
6302 Make_Procedure_Call_Statement (Loc,
6303 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6304 Parameter_Associations => New_List (
6305 New_Occurrence_Of (Package_Name, Loc),
6306 New_Occurrence_Of (Subp_Id, Loc),
6307 New_Occurrence_Of (Subp_Ref, Loc))),
6309 -- Get_Local_Address (R, L, A);
6310 -- Determine whether the subprogram is local (L), and if so
6311 -- obtain the local address of its proxy (A).
6313 Make_Procedure_Call_Statement (Loc,
6314 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6315 Parameter_Associations => New_List (
6316 New_Occurrence_Of (Subp_Ref, Loc),
6317 New_Occurrence_Of (Is_Local, Loc),
6318 New_Occurrence_Of (Local_Addr, Loc))));
6320 -- Note: Here we assume that the Fat_Type is a record containing just
6321 -- an access to a proxy or stub object.
6323 Append_To (Proc_Statements,
6327 Make_Implicit_If_Statement (N,
6328 Condition => New_Occurrence_Of (Is_Local, Loc),
6330 Then_Statements => New_List (
6332 -- if A.Target = null then
6334 Make_Implicit_If_Statement (N,
6337 Make_Selected_Component (Loc,
6339 Unchecked_Convert_To
6340 (RTE (RE_RAS_Proxy_Type_Access),
6341 New_Occurrence_Of (Local_Addr, Loc)),
6342 Selector_Name => Make_Identifier (Loc, Name_Target)),
6345 Then_Statements => New_List (
6347 -- A.Target := Entity_Of (Ref);
6349 Make_Assignment_Statement (Loc,
6351 Make_Selected_Component (Loc,
6353 Unchecked_Convert_To
6354 (RTE (RE_RAS_Proxy_Type_Access),
6355 New_Occurrence_Of (Local_Addr, Loc)),
6356 Selector_Name => Make_Identifier (Loc, Name_Target)),
6358 Make_Function_Call (Loc,
6359 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6360 Parameter_Associations => New_List (
6361 New_Occurrence_Of (Subp_Ref, Loc)))),
6363 -- Inc_Usage (A.Target);
6365 Make_Procedure_Call_Statement (Loc,
6366 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6367 Parameter_Associations => New_List (
6368 Make_Selected_Component (Loc,
6370 Unchecked_Convert_To
6371 (RTE (RE_RAS_Proxy_Type_Access),
6372 New_Occurrence_Of (Local_Addr, Loc)),
6374 Make_Identifier (Loc, Name_Target)))))),
6377 -- if not All_Calls_Remote then
6378 -- return Fat_Type!(A);
6381 Make_Implicit_If_Statement (N,
6385 New_Occurrence_Of (All_Calls_Remote, Loc)),
6387 Then_Statements => New_List (
6388 Make_Simple_Return_Statement (Loc,
6390 Unchecked_Convert_To
6391 (Fat_Type, New_Occurrence_Of (Local_Addr, Loc))))))));
6393 Append_List_To (Proc_Statements, New_List (
6395 -- Stub.Target := Entity_Of (Ref);
6397 Set_Field (Name_Target,
6398 Make_Function_Call (Loc,
6399 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6400 Parameter_Associations => New_List (
6401 New_Occurrence_Of (Subp_Ref, Loc)))),
6403 -- Inc_Usage (Stub.Target);
6405 Make_Procedure_Call_Statement (Loc,
6406 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6407 Parameter_Associations => New_List (
6408 Make_Selected_Component (Loc,
6410 Selector_Name => Name_Target))),
6412 -- E.4.1(9) A remote call is asynchronous if it is a call to
6413 -- a procedure, or a call through a value of an access-to-procedure
6414 -- type, to which a pragma Asynchronous applies.
6416 -- Parameter Asynch_P is true when the procedure is asynchronous;
6417 -- Expression Asynch_T is true when the type is asynchronous.
6419 Set_Field (Name_Asynchronous,
6421 Left_Opnd => New_Occurrence_Of (Asynch_P, Loc),
6424 (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc)))));
6426 Append_List_To (Proc_Statements,
6427 Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
6429 Append_To (Proc_Statements,
6430 Make_Simple_Return_Statement (Loc,
6432 Unchecked_Convert_To (Fat_Type,
6433 New_Occurrence_Of (Stub_Ptr, Loc))));
6436 Make_Function_Specification (Loc,
6437 Defining_Unit_Name => Proc,
6438 Parameter_Specifications => New_List (
6439 Make_Parameter_Specification (Loc,
6440 Defining_Identifier => Package_Name,
6442 New_Occurrence_Of (Standard_String, Loc)),
6444 Make_Parameter_Specification (Loc,
6445 Defining_Identifier => Subp_Id,
6447 New_Occurrence_Of (Standard_String, Loc)),
6449 Make_Parameter_Specification (Loc,
6450 Defining_Identifier => Asynch_P,
6452 New_Occurrence_Of (Standard_Boolean, Loc)),
6454 Make_Parameter_Specification (Loc,
6455 Defining_Identifier => All_Calls_Remote,
6457 New_Occurrence_Of (Standard_Boolean, Loc))),
6459 Result_Definition =>
6460 New_Occurrence_Of (Fat_Type, Loc));
6462 -- Set the kind and return type of the function to prevent
6463 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6465 Set_Ekind (Proc, E_Function);
6466 Set_Etype (Proc, Fat_Type);
6469 Make_Subprogram_Body (Loc,
6470 Specification => Proc_Spec,
6471 Declarations => Proc_Decls,
6472 Handled_Statement_Sequence =>
6473 Make_Handled_Sequence_Of_Statements (Loc,
6474 Statements => Proc_Statements)));
6476 Set_TSS (Fat_Type, Proc);
6477 end Add_RAS_Access_TSS;
6479 ----------------------
6480 -- Add_RAS_From_Any --
6481 ----------------------
6483 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6484 Loc : constant Source_Ptr := Sloc (RAS_Type);
6486 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6487 Make_TSS_Name (RAS_Type, TSS_From_Any));
6489 Func_Spec : Node_Id;
6491 Statements : List_Id;
6493 Any_Parameter : constant Entity_Id :=
6494 Make_Defining_Identifier (Loc, Name_A);
6497 Statements := New_List (
6498 Make_Simple_Return_Statement (Loc,
6500 Make_Aggregate (Loc,
6501 Component_Associations => New_List (
6502 Make_Component_Association (Loc,
6503 Choices => New_List (
6504 Make_Identifier (Loc, Name_Ras)),
6506 PolyORB_Support.Helpers.Build_From_Any_Call (
6507 Underlying_RACW_Type (RAS_Type),
6508 New_Occurrence_Of (Any_Parameter, Loc),
6512 Make_Function_Specification (Loc,
6513 Defining_Unit_Name => Fnam,
6514 Parameter_Specifications => New_List (
6515 Make_Parameter_Specification (Loc,
6516 Defining_Identifier => Any_Parameter,
6517 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
6518 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6521 Make_Subprogram_Body (Loc,
6522 Specification => Func_Spec,
6523 Declarations => No_List,
6524 Handled_Statement_Sequence =>
6525 Make_Handled_Sequence_Of_Statements (Loc,
6526 Statements => Statements)));
6527 Set_TSS (RAS_Type, Fnam);
6528 end Add_RAS_From_Any;
6530 --------------------
6531 -- Add_RAS_To_Any --
6532 --------------------
6534 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6535 Loc : constant Source_Ptr := Sloc (RAS_Type);
6537 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6538 Make_TSS_Name (RAS_Type, TSS_To_Any));
6541 Statements : List_Id;
6543 Func_Spec : Node_Id;
6545 Any : constant Entity_Id :=
6546 Make_Defining_Identifier (Loc,
6547 Chars => New_Internal_Name ('A'));
6548 RAS_Parameter : constant Entity_Id :=
6549 Make_Defining_Identifier (Loc,
6550 Chars => New_Internal_Name ('R'));
6551 RACW_Parameter : constant Node_Id :=
6552 Make_Selected_Component (Loc,
6553 Prefix => RAS_Parameter,
6554 Selector_Name => Name_Ras);
6557 -- Object declarations
6559 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6561 Make_Object_Declaration (Loc,
6562 Defining_Identifier => Any,
6563 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc),
6565 PolyORB_Support.Helpers.Build_To_Any_Call
6566 (RACW_Parameter, No_List)));
6568 Statements := New_List (
6569 Make_Procedure_Call_Statement (Loc,
6570 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6571 Parameter_Associations => New_List (
6572 New_Occurrence_Of (Any, Loc),
6573 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6576 Make_Simple_Return_Statement (Loc,
6577 Expression => New_Occurrence_Of (Any, Loc)));
6580 Make_Function_Specification (Loc,
6581 Defining_Unit_Name => Fnam,
6582 Parameter_Specifications => New_List (
6583 Make_Parameter_Specification (Loc,
6584 Defining_Identifier => RAS_Parameter,
6585 Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))),
6586 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6589 Make_Subprogram_Body (Loc,
6590 Specification => Func_Spec,
6591 Declarations => Decls,
6592 Handled_Statement_Sequence =>
6593 Make_Handled_Sequence_Of_Statements (Loc,
6594 Statements => Statements)));
6595 Set_TSS (RAS_Type, Fnam);
6598 ----------------------
6599 -- Add_RAS_TypeCode --
6600 ----------------------
6602 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6603 Loc : constant Source_Ptr := Sloc (RAS_Type);
6605 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6606 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6608 Func_Spec : Node_Id;
6609 Decls : constant List_Id := New_List;
6610 Name_String : String_Id;
6611 Repo_Id_String : String_Id;
6615 Make_Function_Specification (Loc,
6616 Defining_Unit_Name => Fnam,
6617 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6619 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6620 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6623 Make_Subprogram_Body (Loc,
6624 Specification => Func_Spec,
6625 Declarations => Decls,
6626 Handled_Statement_Sequence =>
6627 Make_Handled_Sequence_Of_Statements (Loc,
6628 Statements => New_List (
6629 Make_Simple_Return_Statement (Loc,
6631 Make_Function_Call (Loc,
6632 Name => New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6633 Parameter_Associations => New_List (
6634 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6635 Make_Aggregate (Loc,
6638 Make_Function_Call (Loc,
6641 (RTE (RE_TA_String), Loc),
6642 Parameter_Associations => New_List (
6643 Make_String_Literal (Loc, Name_String))),
6644 Make_Function_Call (Loc,
6647 (RTE (RE_TA_String), Loc),
6648 Parameter_Associations => New_List (
6649 Make_String_Literal (Loc,
6650 Strval => Repo_Id_String))))))))))));
6651 Set_TSS (RAS_Type, Fnam);
6652 end Add_RAS_TypeCode;
6654 -----------------------------------------
6655 -- Add_Receiving_Stubs_To_Declarations --
6656 -----------------------------------------
6658 procedure Add_Receiving_Stubs_To_Declarations
6659 (Pkg_Spec : Node_Id;
6663 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6665 Pkg_RPC_Receiver : constant Entity_Id :=
6666 Make_Defining_Identifier (Loc,
6667 New_Internal_Name ('H'));
6668 Pkg_RPC_Receiver_Object : Node_Id;
6669 Pkg_RPC_Receiver_Body : Node_Id;
6670 Pkg_RPC_Receiver_Decls : List_Id;
6671 Pkg_RPC_Receiver_Statements : List_Id;
6673 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6674 -- A Pkg_RPC_Receiver is built to decode the request
6677 -- Request object received from neutral layer
6679 Subp_Id : Entity_Id;
6680 -- Subprogram identifier as received from the neutral
6681 -- distribution core.
6683 Subp_Index : Entity_Id;
6684 -- Internal index as determined by matching either the method name
6685 -- from the request structure, or the local subprogram address (in
6688 Is_Local : constant Entity_Id :=
6689 Make_Defining_Identifier (Loc,
6690 Chars => New_Internal_Name ('L'));
6692 Local_Address : constant Entity_Id :=
6693 Make_Defining_Identifier (Loc,
6694 Chars => New_Internal_Name ('A'));
6695 -- Address of a local subprogram designated by a reference
6696 -- corresponding to a RAS.
6698 Dispatch_On_Address : constant List_Id := New_List;
6699 Dispatch_On_Name : constant List_Id := New_List;
6701 Current_Declaration : Node_Id;
6702 Current_Stubs : Node_Id;
6703 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6705 Subp_Info_Array : constant Entity_Id :=
6706 Make_Defining_Identifier (Loc,
6707 Chars => New_Internal_Name ('I'));
6709 Subp_Info_List : constant List_Id := New_List;
6711 Register_Pkg_Actuals : constant List_Id := New_List;
6713 All_Calls_Remote_E : Entity_Id;
6715 procedure Append_Stubs_To
6716 (RPC_Receiver_Cases : List_Id;
6717 Declaration : Node_Id;
6720 Subp_Dist_Name : Entity_Id;
6721 Subp_Proxy_Addr : Entity_Id);
6722 -- Add one case to the specified RPC receiver case list associating
6723 -- Subprogram_Number with the subprogram declared by Declaration, for
6724 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6725 -- subprogram index. Subp_Dist_Name is the string used to call the
6726 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6727 -- object, used in the context of calls through remote
6728 -- access-to-subprogram types.
6730 ---------------------
6731 -- Append_Stubs_To --
6732 ---------------------
6734 procedure Append_Stubs_To
6735 (RPC_Receiver_Cases : List_Id;
6736 Declaration : Node_Id;
6739 Subp_Dist_Name : Entity_Id;
6740 Subp_Proxy_Addr : Entity_Id)
6742 Case_Stmts : List_Id;
6744 Case_Stmts := New_List (
6745 Make_Procedure_Call_Statement (Loc,
6748 Defining_Entity (Stubs), Loc),
6749 Parameter_Associations =>
6750 New_List (New_Occurrence_Of (Request, Loc))));
6752 if Nkind (Specification (Declaration)) = N_Function_Specification
6754 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6756 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6759 Append_To (RPC_Receiver_Cases,
6760 Make_Case_Statement_Alternative (Loc,
6762 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6763 Statements => Case_Stmts));
6765 Append_To (Dispatch_On_Name,
6766 Make_Elsif_Part (Loc,
6768 Make_Function_Call (Loc,
6770 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6771 Parameter_Associations => New_List (
6772 New_Occurrence_Of (Subp_Id, Loc),
6773 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6775 Then_Statements => New_List (
6776 Make_Assignment_Statement (Loc,
6777 New_Occurrence_Of (Subp_Index, Loc),
6778 Make_Integer_Literal (Loc, Subp_Number)))));
6780 Append_To (Dispatch_On_Address,
6781 Make_Elsif_Part (Loc,
6784 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6785 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6787 Then_Statements => New_List (
6788 Make_Assignment_Statement (Loc,
6789 New_Occurrence_Of (Subp_Index, Loc),
6790 Make_Integer_Literal (Loc, Subp_Number)))));
6791 end Append_Stubs_To;
6793 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6796 -- Building receiving stubs consist in several operations:
6798 -- - a package RPC receiver must be built. This subprogram
6799 -- will get a Subprogram_Id from the incoming stream
6800 -- and will dispatch the call to the right subprogram;
6802 -- - a receiving stub for each subprogram visible in the package
6803 -- spec. This stub will read all the parameters from the stream,
6804 -- and put the result as well as the exception occurrence in the
6807 -- - a dummy package with an empty spec and a body made of an
6808 -- elaboration part, whose job is to register the receiving
6809 -- part of this RCI package on the name server. This is done
6810 -- by calling System.Partition_Interface.Register_Receiving_Stub.
6812 Build_RPC_Receiver_Body (
6813 RPC_Receiver => Pkg_RPC_Receiver,
6816 Subp_Index => Subp_Index,
6817 Stmts => Pkg_RPC_Receiver_Statements,
6818 Decl => Pkg_RPC_Receiver_Body);
6819 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6821 -- Extract local address information from the target reference:
6822 -- if non-null, that means that this is a reference that denotes
6823 -- one particular operation, and hence that the operation name
6824 -- must not be taken into account for dispatching.
6826 Append_To (Pkg_RPC_Receiver_Decls,
6827 Make_Object_Declaration (Loc,
6828 Defining_Identifier => Is_Local,
6829 Object_Definition =>
6830 New_Occurrence_Of (Standard_Boolean, Loc)));
6832 Append_To (Pkg_RPC_Receiver_Decls,
6833 Make_Object_Declaration (Loc,
6834 Defining_Identifier => Local_Address,
6835 Object_Definition =>
6836 New_Occurrence_Of (RTE (RE_Address), Loc)));
6838 Append_To (Pkg_RPC_Receiver_Statements,
6839 Make_Procedure_Call_Statement (Loc,
6840 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6841 Parameter_Associations => New_List (
6842 Make_Selected_Component (Loc,
6844 Selector_Name => Name_Target),
6845 New_Occurrence_Of (Is_Local, Loc),
6846 New_Occurrence_Of (Local_Address, Loc))));
6848 -- For each subprogram, the receiving stub will be built and a
6849 -- case statement will be made on the Subprogram_Id to dispatch
6850 -- to the right subprogram.
6852 All_Calls_Remote_E := Boolean_Literals (
6853 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6855 Overload_Counter_Table.Reset;
6856 Reserve_NamingContext_Methods;
6858 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
6859 while Present (Current_Declaration) loop
6860 if Nkind (Current_Declaration) = N_Subprogram_Declaration
6861 and then Comes_From_Source (Current_Declaration)
6864 Loc : constant Source_Ptr := Sloc (Current_Declaration);
6865 -- While specifically processing Current_Declaration, use
6866 -- its Sloc as the location of all generated nodes.
6868 Subp_Def : constant Entity_Id :=
6870 (Specification (Current_Declaration));
6872 Subp_Val : String_Id;
6874 Subp_Dist_Name : constant Entity_Id :=
6875 Make_Defining_Identifier (Loc,
6878 (Related_Id => Chars (Subp_Def),
6880 Suffix_Index => -1));
6882 Proxy_Object_Addr : Entity_Id;
6885 -- Build receiving stub
6888 Build_Subprogram_Receiving_Stubs
6889 (Vis_Decl => Current_Declaration,
6891 Nkind (Specification (Current_Declaration)) =
6892 N_Procedure_Specification
6893 and then Is_Asynchronous (Subp_Def));
6895 Append_To (Decls, Current_Stubs);
6896 Analyze (Current_Stubs);
6900 Add_RAS_Proxy_And_Analyze (Decls,
6901 Vis_Decl => Current_Declaration,
6902 All_Calls_Remote_E => All_Calls_Remote_E,
6903 Proxy_Object_Addr => Proxy_Object_Addr);
6905 -- Compute distribution identifier
6907 Assign_Subprogram_Identifier
6909 Current_Subprogram_Number,
6913 (Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
6916 Make_Object_Declaration (Loc,
6917 Defining_Identifier => Subp_Dist_Name,
6918 Constant_Present => True,
6919 Object_Definition =>
6920 New_Occurrence_Of (Standard_String, Loc),
6922 Make_String_Literal (Loc, Subp_Val)));
6923 Analyze (Last (Decls));
6925 -- Add subprogram descriptor (RCI_Subp_Info) to the
6926 -- subprograms table for this receiver. The aggregate
6927 -- below must be kept consistent with the declaration
6928 -- of type RCI_Subp_Info in System.Partition_Interface.
6930 Append_To (Subp_Info_List,
6931 Make_Component_Association (Loc,
6932 Choices => New_List (
6933 Make_Integer_Literal (Loc, Current_Subprogram_Number)),
6936 Make_Aggregate (Loc,
6937 Expressions => New_List (
6938 Make_Attribute_Reference (Loc,
6940 New_Occurrence_Of (Subp_Dist_Name, Loc),
6941 Attribute_Name => Name_Address),
6943 Make_Attribute_Reference (Loc,
6945 New_Occurrence_Of (Subp_Dist_Name, Loc),
6946 Attribute_Name => Name_Length),
6948 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
6950 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6951 Declaration => Current_Declaration,
6952 Stubs => Current_Stubs,
6953 Subp_Number => Current_Subprogram_Number,
6954 Subp_Dist_Name => Subp_Dist_Name,
6955 Subp_Proxy_Addr => Proxy_Object_Addr);
6958 Current_Subprogram_Number := Current_Subprogram_Number + 1;
6961 Next (Current_Declaration);
6965 Make_Object_Declaration (Loc,
6966 Defining_Identifier => Subp_Info_Array,
6967 Constant_Present => True,
6968 Aliased_Present => True,
6969 Object_Definition =>
6970 Make_Subtype_Indication (Loc,
6972 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6974 Make_Index_Or_Discriminant_Constraint (Loc,
6978 Make_Integer_Literal (Loc,
6979 Intval => First_RCI_Subprogram_Id),
6981 Make_Integer_Literal (Loc,
6983 First_RCI_Subprogram_Id
6984 + List_Length (Subp_Info_List) - 1)))))));
6986 if Present (First (Subp_Info_List)) then
6987 Set_Expression (Last (Decls),
6988 Make_Aggregate (Loc,
6989 Component_Associations => Subp_Info_List));
6991 -- Generate the dispatch statement to determine the subprogram id
6992 -- of the called subprogram.
6994 -- We first test whether the reference that was used to make the
6995 -- call was the base RCI reference (in which case Local_Address is
6996 -- zero, and the method identifier from the request must be used
6997 -- to determine which subprogram is called) or a reference
6998 -- identifying one particular subprogram (in which case
6999 -- Local_Address is the address of that subprogram, and the
7000 -- method name from the request is ignored). The latter occurs
7001 -- for the case of a call through a remote access-to-subprogram.
7003 -- In each case, cascaded elsifs are used to determine the proper
7004 -- subprogram index. Using hash tables might be more efficient.
7006 Append_To (Pkg_RPC_Receiver_Statements,
7007 Make_Implicit_If_Statement (Pkg_Spec,
7010 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
7011 Right_Opnd => New_Occurrence_Of
7012 (RTE (RE_Null_Address), Loc)),
7014 Then_Statements => New_List (
7015 Make_Implicit_If_Statement (Pkg_Spec,
7016 Condition => New_Occurrence_Of (Standard_False, Loc),
7017 Then_Statements => New_List (
7018 Make_Null_Statement (Loc)),
7019 Elsif_Parts => Dispatch_On_Address)),
7021 Else_Statements => New_List (
7022 Make_Implicit_If_Statement (Pkg_Spec,
7023 Condition => New_Occurrence_Of (Standard_False, Loc),
7024 Then_Statements => New_List (Make_Null_Statement (Loc)),
7025 Elsif_Parts => Dispatch_On_Name))));
7028 -- For a degenerate RCI with no visible subprograms,
7029 -- Subp_Info_List has zero length, and the declaration is for an
7030 -- empty array, in which case no initialization aggregate must be
7031 -- generated. We do not generate a Dispatch_Statement either.
7033 -- No initialization provided: remove CONSTANT so that the
7034 -- declaration is not an incomplete deferred constant.
7036 Set_Constant_Present (Last (Decls), False);
7039 -- Analyze Subp_Info_Array declaration
7041 Analyze (Last (Decls));
7043 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7044 -- rather than raising an exception since we do not want someone
7045 -- to crash a remote partition by sending invalid subprogram ids.
7046 -- This is consistent with the other parts of the case statement
7047 -- since even in presence of incorrect parameters in the stream,
7048 -- every exception will be caught and (if the subprogram is not an
7049 -- APC) put into the result stream and sent away.
7051 Append_To (Pkg_RPC_Receiver_Cases,
7052 Make_Case_Statement_Alternative (Loc,
7053 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
7054 Statements => New_List (Make_Null_Statement (Loc))));
7056 Append_To (Pkg_RPC_Receiver_Statements,
7057 Make_Case_Statement (Loc,
7058 Expression => New_Occurrence_Of (Subp_Index, Loc),
7059 Alternatives => Pkg_RPC_Receiver_Cases));
7061 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7064 Append_To (Decls, Pkg_RPC_Receiver_Body);
7065 Analyze (Last (Decls));
7067 Pkg_RPC_Receiver_Object :=
7068 Make_Object_Declaration (Loc,
7069 Defining_Identifier =>
7070 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
7071 Aliased_Present => True,
7072 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
7073 Append_To (Decls, Pkg_RPC_Receiver_Object);
7074 Analyze (Last (Decls));
7076 Get_Library_Unit_Name_String (Pkg_Spec);
7080 Append_To (Register_Pkg_Actuals,
7081 Make_String_Literal (Loc,
7082 Strval => String_From_Name_Buffer));
7086 Append_To (Register_Pkg_Actuals,
7087 Make_Attribute_Reference (Loc,
7090 (Defining_Entity (Pkg_Spec), Loc),
7091 Attribute_Name => Name_Version));
7095 Append_To (Register_Pkg_Actuals,
7096 Make_Attribute_Reference (Loc,
7098 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7099 Attribute_Name => Name_Access));
7103 Append_To (Register_Pkg_Actuals,
7104 Make_Attribute_Reference (Loc,
7107 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc),
7108 Attribute_Name => Name_Access));
7112 Append_To (Register_Pkg_Actuals,
7113 Make_Attribute_Reference (Loc,
7114 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7115 Attribute_Name => Name_Address));
7119 Append_To (Register_Pkg_Actuals,
7120 Make_Attribute_Reference (Loc,
7121 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7122 Attribute_Name => Name_Length));
7124 -- Is_All_Calls_Remote
7126 Append_To (Register_Pkg_Actuals,
7127 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7132 Make_Procedure_Call_Statement (Loc,
7134 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7135 Parameter_Associations => Register_Pkg_Actuals));
7136 Analyze (Last (Stmts));
7137 end Add_Receiving_Stubs_To_Declarations;
7139 ---------------------------------
7140 -- Build_General_Calling_Stubs --
7141 ---------------------------------
7143 procedure Build_General_Calling_Stubs
7145 Statements : List_Id;
7146 Target_Object : Node_Id;
7147 Subprogram_Id : Node_Id;
7148 Asynchronous : Node_Id := Empty;
7149 Is_Known_Asynchronous : Boolean := False;
7150 Is_Known_Non_Asynchronous : Boolean := False;
7151 Is_Function : Boolean;
7153 Stub_Type : Entity_Id := Empty;
7154 RACW_Type : Entity_Id := Empty;
7157 Loc : constant Source_Ptr := Sloc (Nod);
7159 Arguments : Node_Id;
7160 -- Name of the named values list used to transmit parameters
7161 -- to the remote package
7164 -- The request object constructed by these stubs
7167 -- Name of the result named value (in non-APC cases) which get the
7168 -- result of the remote subprogram.
7170 Result_TC : Node_Id;
7171 -- Typecode expression for the result of the request (void
7172 -- typecode for procedures).
7174 Exception_Return_Parameter : Node_Id;
7175 -- Name of the parameter which will hold the exception sent by the
7176 -- remote subprogram.
7178 Current_Parameter : Node_Id;
7179 -- Current parameter being handled
7181 Ordered_Parameters_List : constant List_Id :=
7182 Build_Ordered_Parameters_List (Spec);
7184 Asynchronous_P : Node_Id;
7185 -- A Boolean expression indicating whether this call is asynchronous
7187 Asynchronous_Statements : List_Id := No_List;
7188 Non_Asynchronous_Statements : List_Id := No_List;
7189 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7191 Extra_Formal_Statements : constant List_Id := New_List;
7192 -- List of statements for extra formal parameters. It will appear
7193 -- after the regular statements for writing out parameters.
7195 After_Statements : constant List_Id := New_List;
7196 -- Statements to be executed after call returns (to assign
7197 -- in out or out parameter values).
7200 -- The type of the formal parameter being processed
7202 Is_Controlling_Formal : Boolean;
7203 Is_First_Controlling_Formal : Boolean;
7204 First_Controlling_Formal_Seen : Boolean := False;
7205 -- Controlling formal parameters of distributed object primitives
7206 -- require special handling, and the first such parameter needs even
7207 -- more special handling.
7210 -- ??? document general form of stub subprograms for the PolyORB case
7211 Request := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7214 Make_Object_Declaration (Loc,
7215 Defining_Identifier => Request,
7216 Aliased_Present => False,
7217 Object_Definition =>
7218 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
7221 Make_Defining_Identifier (Loc,
7222 Chars => New_Internal_Name ('R'));
7226 PolyORB_Support.Helpers.Build_TypeCode_Call
7227 (Loc, Etype (Result_Definition (Spec)), Decls);
7229 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7233 Make_Object_Declaration (Loc,
7234 Defining_Identifier => Result,
7235 Aliased_Present => False,
7236 Object_Definition =>
7237 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7239 Make_Aggregate (Loc,
7240 Component_Associations => New_List (
7241 Make_Component_Association (Loc,
7242 Choices => New_List (Make_Identifier (Loc, Name_Name)),
7244 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7245 Make_Component_Association (Loc,
7246 Choices => New_List (
7247 Make_Identifier (Loc, Name_Argument)),
7249 Make_Function_Call (Loc,
7250 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7251 Parameter_Associations => New_List (Result_TC))),
7252 Make_Component_Association (Loc,
7253 Choices => New_List (
7254 Make_Identifier (Loc, Name_Arg_Modes)),
7255 Expression => Make_Integer_Literal (Loc, 0))))));
7257 if not Is_Known_Asynchronous then
7258 Exception_Return_Parameter :=
7259 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7262 Make_Object_Declaration (Loc,
7263 Defining_Identifier => Exception_Return_Parameter,
7264 Object_Definition =>
7265 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7268 Exception_Return_Parameter := Empty;
7271 -- Initialize and fill in arguments list
7274 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7275 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7277 Current_Parameter := First (Ordered_Parameters_List);
7278 while Present (Current_Parameter) loop
7279 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7280 Is_Controlling_Formal := True;
7281 Is_First_Controlling_Formal :=
7282 not First_Controlling_Formal_Seen;
7283 First_Controlling_Formal_Seen := True;
7286 Is_Controlling_Formal := False;
7287 Is_First_Controlling_Formal := False;
7290 if Is_Controlling_Formal then
7292 -- For a controlling formal argument, we send its reference
7297 Etyp := Etype (Parameter_Type (Current_Parameter));
7300 -- The first controlling formal parameter is treated specially:
7301 -- it is used to set the target object of the call.
7303 if not Is_First_Controlling_Formal then
7305 Constrained : constant Boolean :=
7306 Is_Constrained (Etyp)
7307 or else Is_Elementary_Type (Etyp);
7309 Any : constant Entity_Id :=
7310 Make_Defining_Identifier (Loc,
7311 New_Internal_Name ('A'));
7313 Actual_Parameter : Node_Id :=
7315 Defining_Identifier (
7316 Current_Parameter), Loc);
7321 if Is_Controlling_Formal then
7323 -- For a controlling formal parameter (other than the
7324 -- first one), use the corresponding RACW. If the
7325 -- parameter is not an anonymous access parameter, that
7326 -- involves taking its 'Unrestricted_Access.
7328 if Nkind (Parameter_Type (Current_Parameter))
7329 = N_Access_Definition
7331 Actual_Parameter := OK_Convert_To
7332 (Etyp, Actual_Parameter);
7334 Actual_Parameter := OK_Convert_To (Etyp,
7335 Make_Attribute_Reference (Loc,
7336 Prefix => Actual_Parameter,
7337 Attribute_Name => Name_Unrestricted_Access));
7342 if In_Present (Current_Parameter)
7343 or else not Out_Present (Current_Parameter)
7344 or else not Constrained
7345 or else Is_Controlling_Formal
7347 -- The parameter has an input value, is constrained at
7348 -- runtime by an input value, or is a controlling formal
7349 -- parameter (always passed as a reference) other than
7352 Expr := PolyORB_Support.Helpers.Build_To_Any_Call
7353 (Actual_Parameter, Decls);
7356 Expr := Make_Function_Call (Loc,
7357 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7358 Parameter_Associations => New_List (
7359 PolyORB_Support.Helpers.Build_TypeCode_Call
7360 (Loc, Etyp, Decls)));
7364 Make_Object_Declaration (Loc,
7365 Defining_Identifier => Any,
7366 Aliased_Present => False,
7367 Object_Definition =>
7368 New_Occurrence_Of (RTE (RE_Any), Loc),
7369 Expression => Expr));
7371 Append_To (Statements,
7372 Add_Parameter_To_NVList (Loc,
7373 Parameter => Current_Parameter,
7374 NVList => Arguments,
7375 Constrained => Constrained,
7378 if Out_Present (Current_Parameter)
7379 and then not Is_Controlling_Formal
7381 Append_To (After_Statements,
7382 Make_Assignment_Statement (Loc,
7385 Defining_Identifier (Current_Parameter), Loc),
7387 PolyORB_Support.Helpers.Build_From_Any_Call
7388 (Etype (Parameter_Type (Current_Parameter)),
7389 New_Occurrence_Of (Any, Loc),
7396 -- If the current parameter has a dynamic constrained status, then
7397 -- this status is transmitted as well.
7398 -- This should be done for accessibility as well ???
7400 if Nkind (Parameter_Type (Current_Parameter)) /=
7402 and then Need_Extra_Constrained (Current_Parameter)
7404 -- In this block, we do not use the extra formal that has been
7405 -- created because it does not exist at the time of expansion
7406 -- when building calling stubs for remote access to subprogram
7407 -- types. We create an extra variable of this type and push it
7408 -- in the stream after the regular parameters.
7411 Extra_Any_Parameter : constant Entity_Id :=
7412 Make_Defining_Identifier
7413 (Loc, New_Internal_Name ('P'));
7415 Parameter_Exp : constant Node_Id :=
7416 Make_Attribute_Reference (Loc,
7417 Prefix => New_Occurrence_Of (
7418 Defining_Identifier (Current_Parameter), Loc),
7419 Attribute_Name => Name_Constrained);
7422 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7425 Make_Object_Declaration (Loc,
7426 Defining_Identifier => Extra_Any_Parameter,
7427 Aliased_Present => False,
7428 Object_Definition =>
7429 New_Occurrence_Of (RTE (RE_Any), Loc),
7431 PolyORB_Support.Helpers.Build_To_Any_Call
7432 (Parameter_Exp, Decls)));
7434 Append_To (Extra_Formal_Statements,
7435 Add_Parameter_To_NVList (Loc,
7436 Parameter => Extra_Any_Parameter,
7437 NVList => Arguments,
7438 Constrained => True,
7439 Any => Extra_Any_Parameter));
7443 Next (Current_Parameter);
7446 -- Append the formal statements list to the statements
7448 Append_List_To (Statements, Extra_Formal_Statements);
7450 Append_To (Statements,
7451 Make_Procedure_Call_Statement (Loc,
7453 New_Occurrence_Of (RTE (RE_Request_Create), Loc),
7455 Parameter_Associations => New_List (
7458 New_Occurrence_Of (Arguments, Loc),
7459 New_Occurrence_Of (Result, Loc),
7460 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7462 Append_To (Parameter_Associations (Last (Statements)),
7463 New_Occurrence_Of (Request, Loc));
7466 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7468 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7471 (Boolean_Literals (Is_Known_Asynchronous), Loc);
7474 pragma Assert (Present (Asynchronous));
7475 Asynchronous_P := New_Copy_Tree (Asynchronous);
7477 -- The expression node Asynchronous will be used to build an 'if'
7478 -- statement at the end of Build_General_Calling_Stubs: we need to
7479 -- make a copy here.
7482 Append_To (Parameter_Associations (Last (Statements)),
7483 Make_Indexed_Component (Loc,
7486 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7487 Expressions => New_List (Asynchronous_P)));
7489 Append_To (Statements,
7490 Make_Procedure_Call_Statement (Loc,
7492 New_Occurrence_Of (RTE (RE_Request_Invoke), Loc),
7493 Parameter_Associations => New_List (
7494 New_Occurrence_Of (Request, Loc))));
7496 Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7497 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7499 if not Is_Known_Asynchronous then
7501 -- Reraise an exception occurrence from the completed request.
7502 -- If the exception occurrence is empty, this is a no-op.
7504 Append_To (Non_Asynchronous_Statements,
7505 Make_Procedure_Call_Statement (Loc,
7507 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7508 Parameter_Associations => New_List (
7509 New_Occurrence_Of (Request, Loc))));
7513 -- If this is a function call, read the value and return it
7515 Append_To (Non_Asynchronous_Statements,
7516 Make_Tag_Check (Loc,
7517 Make_Simple_Return_Statement (Loc,
7518 PolyORB_Support.Helpers.Build_From_Any_Call
7519 (Etype (Result_Definition (Spec)),
7520 Make_Selected_Component (Loc,
7522 Selector_Name => Name_Argument),
7527 Append_List_To (Non_Asynchronous_Statements, After_Statements);
7529 if Is_Known_Asynchronous then
7530 Append_List_To (Statements, Asynchronous_Statements);
7532 elsif Is_Known_Non_Asynchronous then
7533 Append_List_To (Statements, Non_Asynchronous_Statements);
7536 pragma Assert (Present (Asynchronous));
7537 Append_To (Statements,
7538 Make_Implicit_If_Statement (Nod,
7539 Condition => Asynchronous,
7540 Then_Statements => Asynchronous_Statements,
7541 Else_Statements => Non_Asynchronous_Statements));
7543 end Build_General_Calling_Stubs;
7545 -----------------------
7546 -- Build_Stub_Target --
7547 -----------------------
7549 function Build_Stub_Target
7552 RCI_Locator : Entity_Id;
7553 Controlling_Parameter : Entity_Id) return RPC_Target
7555 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7556 Target_Reference : constant Entity_Id :=
7557 Make_Defining_Identifier (Loc,
7558 New_Internal_Name ('T'));
7560 if Present (Controlling_Parameter) then
7562 Make_Object_Declaration (Loc,
7563 Defining_Identifier => Target_Reference,
7565 Object_Definition =>
7566 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7569 Make_Function_Call (Loc,
7571 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7572 Parameter_Associations => New_List (
7573 Make_Selected_Component (Loc,
7574 Prefix => Controlling_Parameter,
7575 Selector_Name => Name_Target)))));
7577 -- Note: Controlling_Parameter has the same components as
7578 -- System.Partition_Interface.RACW_Stub_Type.
7580 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7583 Target_Info.Object :=
7584 Make_Selected_Component (Loc,
7585 Prefix => Make_Identifier (Loc, Chars (RCI_Locator)),
7587 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7591 end Build_Stub_Target;
7593 ---------------------
7594 -- Build_Stub_Type --
7595 ---------------------
7597 procedure Build_Stub_Type
7598 (RACW_Type : Entity_Id;
7599 Stub_Type : Entity_Id;
7600 Stub_Type_Decl : out Node_Id;
7601 RPC_Receiver_Decl : out Node_Id)
7603 Loc : constant Source_Ptr := Sloc (Stub_Type);
7604 pragma Warnings (Off);
7605 pragma Unreferenced (RACW_Type);
7606 pragma Warnings (On);
7610 Make_Full_Type_Declaration (Loc,
7611 Defining_Identifier => Stub_Type,
7613 Make_Record_Definition (Loc,
7614 Tagged_Present => True,
7615 Limited_Present => True,
7617 Make_Component_List (Loc,
7618 Component_Items => New_List (
7620 Make_Component_Declaration (Loc,
7621 Defining_Identifier =>
7622 Make_Defining_Identifier (Loc, Name_Target),
7623 Component_Definition =>
7624 Make_Component_Definition (Loc,
7625 Aliased_Present => False,
7626 Subtype_Indication =>
7627 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7629 Make_Component_Declaration (Loc,
7630 Defining_Identifier =>
7631 Make_Defining_Identifier (Loc, Name_Asynchronous),
7633 Component_Definition =>
7634 Make_Component_Definition (Loc,
7635 Aliased_Present => False,
7636 Subtype_Indication =>
7637 New_Occurrence_Of (Standard_Boolean, Loc)))))));
7639 RPC_Receiver_Decl :=
7640 Make_Object_Declaration (Loc,
7641 Defining_Identifier => Make_Defining_Identifier (Loc,
7642 New_Internal_Name ('R')),
7643 Aliased_Present => True,
7644 Object_Definition =>
7645 New_Occurrence_Of (RTE (RE_Servant), Loc));
7646 end Build_Stub_Type;
7648 -----------------------------
7649 -- Build_RPC_Receiver_Body --
7650 -----------------------------
7652 procedure Build_RPC_Receiver_Body
7653 (RPC_Receiver : Entity_Id;
7654 Request : out Entity_Id;
7655 Subp_Id : out Entity_Id;
7656 Subp_Index : out Entity_Id;
7657 Stmts : out List_Id;
7660 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7662 RPC_Receiver_Spec : Node_Id;
7663 RPC_Receiver_Decls : List_Id;
7666 Request := Make_Defining_Identifier (Loc, Name_R);
7668 RPC_Receiver_Spec :=
7669 Build_RPC_Receiver_Specification (
7670 RPC_Receiver => RPC_Receiver,
7671 Request_Parameter => Request);
7673 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7674 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7676 RPC_Receiver_Decls := New_List (
7677 Make_Object_Renaming_Declaration (Loc,
7678 Defining_Identifier => Subp_Id,
7679 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7681 Make_Explicit_Dereference (Loc,
7683 Make_Selected_Component (Loc,
7685 Selector_Name => Name_Operation))),
7687 Make_Object_Declaration (Loc,
7688 Defining_Identifier => Subp_Index,
7689 Object_Definition =>
7690 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7692 Make_Attribute_Reference (Loc,
7694 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7695 Attribute_Name => Name_Last)));
7700 Make_Subprogram_Body (Loc,
7701 Specification => RPC_Receiver_Spec,
7702 Declarations => RPC_Receiver_Decls,
7703 Handled_Statement_Sequence =>
7704 Make_Handled_Sequence_Of_Statements (Loc,
7705 Statements => Stmts));
7706 end Build_RPC_Receiver_Body;
7708 --------------------------------------
7709 -- Build_Subprogram_Receiving_Stubs --
7710 --------------------------------------
7712 function Build_Subprogram_Receiving_Stubs
7713 (Vis_Decl : Node_Id;
7714 Asynchronous : Boolean;
7715 Dynamically_Asynchronous : Boolean := False;
7716 Stub_Type : Entity_Id := Empty;
7717 RACW_Type : Entity_Id := Empty;
7718 Parent_Primitive : Entity_Id := Empty) return Node_Id
7720 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7722 Request_Parameter : constant Entity_Id :=
7723 Make_Defining_Identifier (Loc,
7724 New_Internal_Name ('R'));
7725 -- Formal parameter for receiving stubs: a descriptor for an incoming
7728 Outer_Decls : constant List_Id := New_List;
7729 -- At the outermost level, an NVList and Any's are declared for all
7730 -- parameters. The Dynamic_Async flag also needs to be declared there
7731 -- to be visible from the exception handling code.
7733 Outer_Statements : constant List_Id := New_List;
7734 -- Statements that occur prior to the declaration of the actual
7735 -- parameter variables.
7737 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7738 -- Statements concerning extra formal parameters, prior to the
7739 -- declaration of the actual parameter variables.
7741 Decls : constant List_Id := New_List;
7742 -- All the parameters will get declared before calling the real
7743 -- subprograms. Also the out parameters will be declared.
7744 -- At this level, parameters may be unconstrained.
7746 Statements : constant List_Id := New_List;
7748 After_Statements : constant List_Id := New_List;
7749 -- Statements to be executed after the subprogram call
7751 Inner_Decls : List_Id := No_List;
7752 -- In case of a function, the inner declarations are needed since
7753 -- the result may be unconstrained.
7755 Excep_Handlers : List_Id := No_List;
7757 Parameter_List : constant List_Id := New_List;
7758 -- List of parameters to be passed to the subprogram
7760 First_Controlling_Formal_Seen : Boolean := False;
7762 Current_Parameter : Node_Id;
7764 Ordered_Parameters_List : constant List_Id :=
7765 Build_Ordered_Parameters_List
7766 (Specification (Vis_Decl));
7768 Arguments : constant Entity_Id :=
7769 Make_Defining_Identifier (Loc,
7770 New_Internal_Name ('A'));
7771 -- Name of the named values list used to retrieve parameters
7773 Subp_Spec : Node_Id;
7774 -- Subprogram specification
7776 Called_Subprogram : Node_Id;
7777 -- The subprogram to call
7780 if Present (RACW_Type) then
7781 Called_Subprogram :=
7782 New_Occurrence_Of (Parent_Primitive, Loc);
7784 Called_Subprogram :=
7786 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7789 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7791 -- Loop through every parameter and get its value from the stream. If
7792 -- the parameter is unconstrained, then the parameter is read using
7793 -- 'Input at the point of declaration.
7795 Current_Parameter := First (Ordered_Parameters_List);
7796 while Present (Current_Parameter) loop
7799 Constrained : Boolean;
7800 Any : Entity_Id := Empty;
7801 Object : constant Entity_Id :=
7802 Make_Defining_Identifier (Loc,
7803 Chars => New_Internal_Name ('P'));
7804 Expr : Node_Id := Empty;
7806 Is_Controlling_Formal : constant Boolean :=
7807 Is_RACW_Controlling_Formal
7808 (Current_Parameter, Stub_Type);
7810 Is_First_Controlling_Formal : Boolean := False;
7812 Need_Extra_Constrained : Boolean;
7813 -- True when an extra constrained actual is required
7816 if Is_Controlling_Formal then
7818 -- Controlling formals in distributed object primitive
7819 -- operations are handled specially:
7820 -- - the first controlling formal is used as the
7821 -- target of the call;
7822 -- - the remaining controlling formals are transmitted
7826 Is_First_Controlling_Formal :=
7827 not First_Controlling_Formal_Seen;
7828 First_Controlling_Formal_Seen := True;
7831 Etyp := Etype (Parameter_Type (Current_Parameter));
7835 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
7837 if not Is_First_Controlling_Formal then
7839 Make_Defining_Identifier (Loc,
7840 Chars => New_Internal_Name ('A'));
7842 Append_To (Outer_Decls,
7843 Make_Object_Declaration (Loc,
7844 Defining_Identifier => Any,
7845 Object_Definition =>
7846 New_Occurrence_Of (RTE (RE_Any), Loc),
7848 Make_Function_Call (Loc,
7849 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7850 Parameter_Associations => New_List (
7851 PolyORB_Support.Helpers.Build_TypeCode_Call
7852 (Loc, Etyp, Outer_Decls)))));
7854 Append_To (Outer_Statements,
7855 Add_Parameter_To_NVList (Loc,
7856 Parameter => Current_Parameter,
7857 NVList => Arguments,
7858 Constrained => Constrained,
7862 if Is_First_Controlling_Formal then
7864 Addr : constant Entity_Id :=
7865 Make_Defining_Identifier (Loc,
7866 Chars => New_Internal_Name ('A'));
7868 Is_Local : constant Entity_Id :=
7869 Make_Defining_Identifier (Loc,
7870 Chars => New_Internal_Name ('L'));
7873 -- Special case: obtain the first controlling formal
7874 -- from the target of the remote call, instead of the
7877 Append_To (Outer_Decls,
7878 Make_Object_Declaration (Loc,
7879 Defining_Identifier => Addr,
7880 Object_Definition =>
7881 New_Occurrence_Of (RTE (RE_Address), Loc)));
7883 Append_To (Outer_Decls,
7884 Make_Object_Declaration (Loc,
7885 Defining_Identifier => Is_Local,
7886 Object_Definition =>
7887 New_Occurrence_Of (Standard_Boolean, Loc)));
7889 Append_To (Outer_Statements,
7890 Make_Procedure_Call_Statement (Loc,
7892 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7893 Parameter_Associations => New_List (
7894 Make_Selected_Component (Loc,
7897 Request_Parameter, Loc),
7899 Make_Identifier (Loc, Name_Target)),
7900 New_Occurrence_Of (Is_Local, Loc),
7901 New_Occurrence_Of (Addr, Loc))));
7903 Expr := Unchecked_Convert_To (RACW_Type,
7904 New_Occurrence_Of (Addr, Loc));
7907 elsif In_Present (Current_Parameter)
7908 or else not Out_Present (Current_Parameter)
7909 or else not Constrained
7911 -- If an input parameter is constrained, then its reading is
7912 -- deferred until the beginning of the subprogram body. If
7913 -- it is unconstrained, then an expression is built for
7914 -- the object declaration and the variable is set using
7915 -- 'Input instead of 'Read.
7917 Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
7918 Etyp, New_Occurrence_Of (Any, Loc), Decls);
7921 Append_To (Statements,
7922 Make_Assignment_Statement (Loc,
7923 Name => New_Occurrence_Of (Object, Loc),
7924 Expression => Expr));
7929 -- Expr will be used to initialize (and constrain) the
7930 -- parameter when it is declared.
7935 Need_Extra_Constrained :=
7936 Nkind (Parameter_Type (Current_Parameter)) /=
7939 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7941 Present (Extra_Constrained
7942 (Defining_Identifier (Current_Parameter)));
7944 -- We may not associate an extra constrained actual to a
7945 -- constant object, so if one is needed, declare the actual
7946 -- as a variable even if it won't be modified.
7948 Build_Actual_Object_Declaration
7951 Variable => Need_Extra_Constrained
7952 or else Out_Present (Current_Parameter),
7955 Set_Etype (Object, Etyp);
7957 -- An out parameter may be written back using a 'Write
7958 -- attribute instead of a 'Output because it has been
7959 -- constrained by the parameter given to the caller. Note that
7960 -- out controlling arguments in the case of a RACW are not put
7961 -- back in the stream because the pointer on them has not
7964 if Out_Present (Current_Parameter)
7965 and then not Is_Controlling_Formal
7967 Append_To (After_Statements,
7968 Make_Procedure_Call_Statement (Loc,
7969 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
7970 Parameter_Associations => New_List (
7971 New_Occurrence_Of (Any, Loc),
7972 PolyORB_Support.Helpers.Build_To_Any_Call
7973 (New_Occurrence_Of (Object, Loc), Decls))));
7976 -- For RACW controlling formals, the Etyp of Object is always
7977 -- an RACW, even if the parameter is not of an anonymous access
7978 -- type. In such case, we need to dereference it at call time.
7980 if Is_Controlling_Formal then
7981 if Nkind (Parameter_Type (Current_Parameter)) /=
7984 Append_To (Parameter_List,
7985 Make_Parameter_Association (Loc,
7988 (Defining_Identifier (Current_Parameter), Loc),
7989 Explicit_Actual_Parameter =>
7990 Make_Explicit_Dereference (Loc,
7992 Unchecked_Convert_To (RACW_Type,
7993 OK_Convert_To (RTE (RE_Address),
7994 New_Occurrence_Of (Object, Loc))))));
7997 Append_To (Parameter_List,
7998 Make_Parameter_Association (Loc,
8001 (Defining_Identifier (Current_Parameter), Loc),
8003 Explicit_Actual_Parameter =>
8004 Unchecked_Convert_To (RACW_Type,
8005 OK_Convert_To (RTE (RE_Address),
8006 New_Occurrence_Of (Object, Loc)))));
8010 Append_To (Parameter_List,
8011 Make_Parameter_Association (Loc,
8014 Defining_Identifier (Current_Parameter), Loc),
8015 Explicit_Actual_Parameter =>
8016 New_Occurrence_Of (Object, Loc)));
8019 -- If the current parameter needs an extra formal, then read it
8020 -- from the stream and set the corresponding semantic field in
8021 -- the variable. If the kind of the parameter identifier is
8022 -- E_Void, then this is a compiler generated parameter that
8023 -- doesn't need an extra constrained status.
8025 -- The case of Extra_Accessibility should also be handled ???
8027 if Need_Extra_Constrained then
8029 Extra_Parameter : constant Entity_Id :=
8031 (Defining_Identifier
8032 (Current_Parameter));
8034 Extra_Any : constant Entity_Id :=
8035 Make_Defining_Identifier (Loc,
8036 Chars => New_Internal_Name ('A'));
8038 Formal_Entity : constant Entity_Id :=
8039 Make_Defining_Identifier (Loc,
8040 Chars => Chars (Extra_Parameter));
8042 Formal_Type : constant Entity_Id :=
8043 Etype (Extra_Parameter);
8046 Append_To (Outer_Decls,
8047 Make_Object_Declaration (Loc,
8048 Defining_Identifier => Extra_Any,
8049 Object_Definition =>
8050 New_Occurrence_Of (RTE (RE_Any), Loc),
8052 Make_Function_Call (Loc,
8054 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8055 Parameter_Associations => New_List (
8056 PolyORB_Support.Helpers.Build_TypeCode_Call
8057 (Loc, Formal_Type, Outer_Decls)))));
8059 Append_To (Outer_Extra_Formal_Statements,
8060 Add_Parameter_To_NVList (Loc,
8061 Parameter => Extra_Parameter,
8062 NVList => Arguments,
8063 Constrained => True,
8067 Make_Object_Declaration (Loc,
8068 Defining_Identifier => Formal_Entity,
8069 Object_Definition =>
8070 New_Occurrence_Of (Formal_Type, Loc)));
8072 Append_To (Statements,
8073 Make_Assignment_Statement (Loc,
8074 Name => New_Occurrence_Of (Formal_Entity, Loc),
8076 PolyORB_Support.Helpers.Build_From_Any_Call
8078 New_Occurrence_Of (Extra_Any, Loc),
8080 Set_Extra_Constrained (Object, Formal_Entity);
8085 Next (Current_Parameter);
8088 -- Extra Formals should go after all the other parameters
8090 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8092 Append_To (Outer_Statements,
8093 Make_Procedure_Call_Statement (Loc,
8094 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8095 Parameter_Associations => New_List (
8096 New_Occurrence_Of (Request_Parameter, Loc),
8097 New_Occurrence_Of (Arguments, Loc))));
8099 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8101 -- The remote subprogram is a function: Build an inner block to be
8102 -- able to hold a potentially unconstrained result in a variable.
8105 Etyp : constant Entity_Id :=
8106 Etype (Result_Definition (Specification (Vis_Decl)));
8107 Result : constant Node_Id :=
8108 Make_Defining_Identifier (Loc,
8109 Chars => New_Internal_Name ('R'));
8112 Inner_Decls := New_List (
8113 Make_Object_Declaration (Loc,
8114 Defining_Identifier => Result,
8115 Constant_Present => True,
8116 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8118 Make_Function_Call (Loc,
8119 Name => Called_Subprogram,
8120 Parameter_Associations => Parameter_List)));
8122 if Is_Class_Wide_Type (Etyp) then
8124 -- For a remote call to a function with a class-wide type,
8125 -- check that the returned value satisfies the requirements
8128 Append_To (Inner_Decls,
8129 Make_Transportable_Check (Loc,
8130 New_Occurrence_Of (Result, Loc)));
8134 Set_Etype (Result, Etyp);
8135 Append_To (After_Statements,
8136 Make_Procedure_Call_Statement (Loc,
8137 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8138 Parameter_Associations => New_List (
8139 New_Occurrence_Of (Request_Parameter, Loc),
8140 PolyORB_Support.Helpers.Build_To_Any_Call
8141 (New_Occurrence_Of (Result, Loc), Decls))));
8143 -- A DSA function does not have out or inout arguments
8146 Append_To (Statements,
8147 Make_Block_Statement (Loc,
8148 Declarations => Inner_Decls,
8149 Handled_Statement_Sequence =>
8150 Make_Handled_Sequence_Of_Statements (Loc,
8151 Statements => After_Statements)));
8154 -- The remote subprogram is a procedure. We do not need any inner
8155 -- block in this case. No specific processing is required here for
8156 -- the dynamically asynchronous case: the indication of whether
8157 -- call is asynchronous or not is managed by the Sync_Scope
8158 -- attibute of the request, and is handled entirely in the
8161 Append_To (After_Statements,
8162 Make_Procedure_Call_Statement (Loc,
8163 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8164 Parameter_Associations => New_List (
8165 New_Occurrence_Of (Request_Parameter, Loc))));
8167 Append_To (Statements,
8168 Make_Procedure_Call_Statement (Loc,
8169 Name => Called_Subprogram,
8170 Parameter_Associations => Parameter_List));
8172 Append_List_To (Statements, After_Statements);
8176 Make_Procedure_Specification (Loc,
8177 Defining_Unit_Name =>
8178 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
8180 Parameter_Specifications => New_List (
8181 Make_Parameter_Specification (Loc,
8182 Defining_Identifier => Request_Parameter,
8184 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8186 -- An exception raised during the execution of an incoming
8187 -- remote subprogram call and that needs to be sent back
8188 -- to the caller is propagated by the receiving stubs, and
8189 -- will be handled by the caller (the distribution runtime).
8191 if Asynchronous and then not Dynamically_Asynchronous then
8193 -- For an asynchronous procedure, add a null exception handler
8195 Excep_Handlers := New_List (
8196 Make_Implicit_Exception_Handler (Loc,
8197 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8198 Statements => New_List (Make_Null_Statement (Loc))));
8201 -- In the other cases, if an exception is raised, then the
8202 -- exception occurrence is propagated.
8207 Append_To (Outer_Statements,
8208 Make_Block_Statement (Loc,
8209 Declarations => Decls,
8210 Handled_Statement_Sequence =>
8211 Make_Handled_Sequence_Of_Statements (Loc,
8212 Statements => Statements)));
8215 Make_Subprogram_Body (Loc,
8216 Specification => Subp_Spec,
8217 Declarations => Outer_Decls,
8218 Handled_Statement_Sequence =>
8219 Make_Handled_Sequence_Of_Statements (Loc,
8220 Statements => Outer_Statements,
8221 Exception_Handlers => Excep_Handlers));
8222 end Build_Subprogram_Receiving_Stubs;
8228 package body Helpers is
8230 -----------------------
8231 -- Local Subprograms --
8232 -----------------------
8234 function Find_Numeric_Representation
8235 (Typ : Entity_Id) return Entity_Id;
8236 -- Given a numeric type Typ, return the smallest integer or floating
8237 -- point type from Standard, or the smallest unsigned (modular) type
8238 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8240 function Make_Helper_Function_Name
8243 Nam : Name_Id) return Entity_Id;
8244 -- Return the name to be assigned for helper subprogram Nam of Typ
8246 ------------------------------------------------------------
8247 -- Common subprograms for building various tree fragments --
8248 ------------------------------------------------------------
8250 function Build_Get_Aggregate_Element
8254 Idx : Node_Id) return Node_Id;
8255 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8256 -- returning the Idx'th element.
8259 Subprogram : Entity_Id;
8260 -- Reference location for constructed nodes
8263 -- For 'Range and Etype
8266 -- For the construction of the innermost element expression
8268 with procedure Add_Process_Element
8271 Counter : Entity_Id;
8274 procedure Append_Array_Traversal
8277 Counter : Entity_Id := Empty;
8279 -- Build nested loop statements that iterate over the elements of an
8280 -- array Arry. The statement(s) built by Add_Process_Element are
8281 -- executed for each element; Indices is the list of indices to be
8282 -- used in the construction of the indexed component that denotes the
8283 -- current element. Subprogram is the entity for the subprogram for
8284 -- which this iterator is generated. The generated statements are
8285 -- appended to Stmts.
8289 -- The record entity being dealt with
8291 with procedure Add_Process_Element
8293 Container : Node_Or_Entity_Id;
8294 Counter : in out Int;
8297 -- Rec is the instance of the record type, or Empty.
8298 -- Field is either the N_Defining_Identifier for a component,
8299 -- or an N_Variant_Part.
8301 procedure Append_Record_Traversal
8304 Container : Node_Or_Entity_Id;
8305 Counter : in out Int);
8306 -- Process component list Clist. Individual fields are passed
8307 -- to Field_Processing. Each variant part is also processed.
8308 -- Container is the outer Any (for From_Any/To_Any),
8309 -- the outer typecode (for TC) to which the operation applies.
8311 -----------------------------
8312 -- Append_Record_Traversal --
8313 -----------------------------
8315 procedure Append_Record_Traversal
8318 Container : Node_Or_Entity_Id;
8319 Counter : in out Int)
8323 -- Clist's Component_Items and Variant_Part
8333 CI := Component_Items (Clist);
8334 VP := Variant_Part (Clist);
8337 while Present (Item) loop
8338 Def := Defining_Identifier (Item);
8340 if not Is_Internal_Name (Chars (Def)) then
8342 (Stmts, Container, Counter, Rec, Def);
8348 if Present (VP) then
8349 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8351 end Append_Record_Traversal;
8353 -------------------------
8354 -- Build_From_Any_Call --
8355 -------------------------
8357 function Build_From_Any_Call
8360 Decls : List_Id) return Node_Id
8362 Loc : constant Source_Ptr := Sloc (N);
8364 U_Type : Entity_Id := Underlying_Type (Typ);
8366 Fnam : Entity_Id := Empty;
8367 Lib_RE : RE_Id := RE_Null;
8371 -- First simple case where the From_Any function is present
8372 -- in the type's TSS.
8374 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8376 if Sloc (U_Type) <= Standard_Location then
8377 U_Type := Base_Type (U_Type);
8380 -- Check first for Boolean and Character. These are enumeration
8381 -- types, but we treat them specially, since they may require
8382 -- special handling in the transfer protocol. However, this
8383 -- special handling only applies if they have standard
8384 -- representation, otherwise they are treated like any other
8385 -- enumeration type.
8387 if Present (Fnam) then
8390 elsif U_Type = Standard_Boolean then
8393 elsif U_Type = Standard_Character then
8396 elsif U_Type = Standard_Wide_Character then
8399 elsif U_Type = Standard_Wide_Wide_Character then
8400 Lib_RE := RE_FA_WWC;
8402 -- Floating point types
8404 elsif U_Type = Standard_Short_Float then
8407 elsif U_Type = Standard_Float then
8410 elsif U_Type = Standard_Long_Float then
8413 elsif U_Type = Standard_Long_Long_Float then
8414 Lib_RE := RE_FA_LLF;
8418 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8419 Lib_RE := RE_FA_SSI;
8421 elsif U_Type = Etype (Standard_Short_Integer) then
8424 elsif U_Type = Etype (Standard_Integer) then
8427 elsif U_Type = Etype (Standard_Long_Integer) then
8430 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8431 Lib_RE := RE_FA_LLI;
8433 -- Unsigned integer types
8435 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8436 Lib_RE := RE_FA_SSU;
8438 elsif U_Type = RTE (RE_Short_Unsigned) then
8441 elsif U_Type = RTE (RE_Unsigned) then
8444 elsif U_Type = RTE (RE_Long_Unsigned) then
8447 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8448 Lib_RE := RE_FA_LLU;
8450 elsif U_Type = Standard_String then
8451 Lib_RE := RE_FA_String;
8453 -- Special DSA types
8455 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
8458 -- Other (non-primitive) types
8464 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8465 Append_To (Decls, Decl);
8469 -- Call the function
8471 if Lib_RE /= RE_Null then
8472 pragma Assert (No (Fnam));
8473 Fnam := RTE (Lib_RE);
8477 Make_Function_Call (Loc,
8478 Name => New_Occurrence_Of (Fnam, Loc),
8479 Parameter_Associations => New_List (N));
8481 -- We must set the type of Result, so the unchecked conversion
8482 -- from the underlying type to the base type is properly done.
8484 Set_Etype (Result, U_Type);
8486 return Unchecked_Convert_To (Typ, Result);
8487 end Build_From_Any_Call;
8489 -----------------------------
8490 -- Build_From_Any_Function --
8491 -----------------------------
8493 procedure Build_From_Any_Function
8497 Fnam : out Entity_Id)
8500 Decls : constant List_Id := New_List;
8501 Stms : constant List_Id := New_List;
8503 Any_Parameter : constant Entity_Id :=
8504 Make_Defining_Identifier (Loc,
8505 New_Internal_Name ('A'));
8507 Use_Opaque_Representation : Boolean;
8510 if Is_Itype (Typ) then
8511 Build_From_Any_Function
8519 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
8522 Make_Function_Specification (Loc,
8523 Defining_Unit_Name => Fnam,
8524 Parameter_Specifications => New_List (
8525 Make_Parameter_Specification (Loc,
8526 Defining_Identifier => Any_Parameter,
8527 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
8528 Result_Definition => New_Occurrence_Of (Typ, Loc));
8530 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8533 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8535 Use_Opaque_Representation := False;
8537 if Has_Stream_Attribute_Definition
8538 (Typ, TSS_Stream_Output, At_Any_Place => True)
8540 Has_Stream_Attribute_Definition
8541 (Typ, TSS_Stream_Write, At_Any_Place => True)
8543 -- If user-defined stream attributes are specified for this
8544 -- type, use them and transmit data as an opaque sequence of
8547 Use_Opaque_Representation := True;
8549 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
8551 Make_Simple_Return_Statement (Loc,
8556 New_Occurrence_Of (Any_Parameter, Loc),
8559 elsif Is_Record_Type (Typ)
8560 and then not Is_Derived_Type (Typ)
8561 and then not Is_Tagged_Type (Typ)
8563 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8565 Make_Simple_Return_Statement (Loc,
8570 New_Occurrence_Of (Any_Parameter, Loc),
8575 Disc : Entity_Id := Empty;
8576 Discriminant_Associations : List_Id;
8577 Rdef : constant Node_Id :=
8579 (Declaration_Node (Typ));
8580 Component_Counter : Int := 0;
8582 -- The returned object
8584 Res : constant Entity_Id :=
8585 Make_Defining_Identifier (Loc,
8586 New_Internal_Name ('R'));
8588 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8590 procedure FA_Rec_Add_Process_Element
8593 Counter : in out Int;
8597 procedure FA_Append_Record_Traversal is
8598 new Append_Record_Traversal
8600 Add_Process_Element => FA_Rec_Add_Process_Element);
8602 --------------------------------
8603 -- FA_Rec_Add_Process_Element --
8604 --------------------------------
8606 procedure FA_Rec_Add_Process_Element
8609 Counter : in out Int;
8614 if Nkind (Field) = N_Defining_Identifier then
8616 -- A regular component
8619 Make_Assignment_Statement (Loc,
8620 Name => Make_Selected_Component (Loc,
8622 New_Occurrence_Of (Rec, Loc),
8624 New_Occurrence_Of (Field, Loc)),
8626 Build_From_Any_Call (Etype (Field),
8627 Build_Get_Aggregate_Element (Loc,
8629 TC => Build_TypeCode_Call (Loc,
8630 Etype (Field), Decls),
8631 Idx => Make_Integer_Literal (Loc,
8640 Struct_Counter : Int := 0;
8642 Block_Decls : constant List_Id := New_List;
8643 Block_Stmts : constant List_Id := New_List;
8646 Alt_List : constant List_Id := New_List;
8647 Choice_List : List_Id;
8649 Struct_Any : constant Entity_Id :=
8650 Make_Defining_Identifier (Loc,
8651 New_Internal_Name ('S'));
8655 Make_Object_Declaration (Loc,
8656 Defining_Identifier => Struct_Any,
8657 Constant_Present => True,
8658 Object_Definition =>
8659 New_Occurrence_Of (RTE (RE_Any), Loc),
8661 Make_Function_Call (Loc,
8664 (RTE (RE_Extract_Union_Value), Loc),
8666 Parameter_Associations => New_List (
8667 Build_Get_Aggregate_Element (Loc,
8670 Make_Function_Call (Loc,
8671 Name => New_Occurrence_Of (
8672 RTE (RE_Any_Member_Type), Loc),
8673 Parameter_Associations =>
8675 New_Occurrence_Of (Any, Loc),
8676 Make_Integer_Literal (Loc,
8677 Intval => Counter))),
8679 Make_Integer_Literal (Loc,
8680 Intval => Counter))))));
8683 Make_Block_Statement (Loc,
8684 Declarations => Block_Decls,
8685 Handled_Statement_Sequence =>
8686 Make_Handled_Sequence_Of_Statements (Loc,
8687 Statements => Block_Stmts)));
8689 Append_To (Block_Stmts,
8690 Make_Case_Statement (Loc,
8692 Make_Selected_Component (Loc,
8694 Selector_Name => Chars (Name (Field))),
8695 Alternatives => Alt_List));
8697 Variant := First_Non_Pragma (Variants (Field));
8698 while Present (Variant) loop
8701 (Discrete_Choices (Variant));
8703 VP_Stmts := New_List;
8705 -- Struct_Counter should be reset before
8706 -- handling a variant part. Indeed only one
8707 -- of the case statement alternatives will be
8708 -- executed at run-time, so the counter must
8709 -- start at 0 for every case statement.
8711 Struct_Counter := 0;
8713 FA_Append_Record_Traversal (
8715 Clist => Component_List (Variant),
8716 Container => Struct_Any,
8717 Counter => Struct_Counter);
8719 Append_To (Alt_List,
8720 Make_Case_Statement_Alternative (Loc,
8721 Discrete_Choices => Choice_List,
8722 Statements => VP_Stmts));
8723 Next_Non_Pragma (Variant);
8728 Counter := Counter + 1;
8729 end FA_Rec_Add_Process_Element;
8732 -- First all discriminants
8734 if Has_Discriminants (Typ) then
8735 Discriminant_Associations := New_List;
8737 Disc := First_Discriminant (Typ);
8738 while Present (Disc) loop
8740 Disc_Var_Name : constant Entity_Id :=
8741 Make_Defining_Identifier (Loc,
8742 Chars => Chars (Disc));
8743 Disc_Type : constant Entity_Id :=
8748 Make_Object_Declaration (Loc,
8749 Defining_Identifier => Disc_Var_Name,
8750 Constant_Present => True,
8751 Object_Definition =>
8752 New_Occurrence_Of (Disc_Type, Loc),
8755 Build_From_Any_Call (Disc_Type,
8756 Build_Get_Aggregate_Element (Loc,
8757 Any => Any_Parameter,
8758 TC => Build_TypeCode_Call
8759 (Loc, Disc_Type, Decls),
8760 Idx => Make_Integer_Literal (Loc,
8761 Intval => Component_Counter)),
8764 Component_Counter := Component_Counter + 1;
8766 Append_To (Discriminant_Associations,
8767 Make_Discriminant_Association (Loc,
8768 Selector_Names => New_List (
8769 New_Occurrence_Of (Disc, Loc)),
8771 New_Occurrence_Of (Disc_Var_Name, Loc)));
8773 Next_Discriminant (Disc);
8777 Make_Subtype_Indication (Loc,
8778 Subtype_Mark => Res_Definition,
8780 Make_Index_Or_Discriminant_Constraint (Loc,
8781 Discriminant_Associations));
8784 -- Now we have all the discriminants in variables, we can
8785 -- declared a constrained object. Note that we are not
8786 -- initializing (non-discriminant) components directly in
8787 -- the object declarations, because which fields to
8788 -- initialize depends (at run time) on the discriminant
8792 Make_Object_Declaration (Loc,
8793 Defining_Identifier => Res,
8794 Object_Definition => Res_Definition));
8796 -- ... then all components
8798 FA_Append_Record_Traversal (Stms,
8799 Clist => Component_List (Rdef),
8800 Container => Any_Parameter,
8801 Counter => Component_Counter);
8804 Make_Simple_Return_Statement (Loc,
8805 Expression => New_Occurrence_Of (Res, Loc)));
8809 elsif Is_Array_Type (Typ) then
8811 Constrained : constant Boolean := Is_Constrained (Typ);
8813 procedure FA_Ary_Add_Process_Element
8816 Counter : Entity_Id;
8818 -- Assign the current element (as identified by Counter) of
8819 -- Any to the variable denoted by name Datum, and advance
8820 -- Counter by 1. If Datum is not an Any, a call to From_Any
8821 -- for its type is inserted.
8823 --------------------------------
8824 -- FA_Ary_Add_Process_Element --
8825 --------------------------------
8827 procedure FA_Ary_Add_Process_Element
8830 Counter : Entity_Id;
8833 Assignment : constant Node_Id :=
8834 Make_Assignment_Statement (Loc,
8836 Expression => Empty);
8838 Element_Any : Node_Id;
8842 Element_TC : Node_Id;
8845 if Etype (Datum) = RTE (RE_Any) then
8847 -- When Datum is an Any the Etype field is not
8848 -- sufficient to determine the typecode of Datum
8849 -- (which can be a TC_SEQUENCE or TC_ARRAY
8850 -- depending on the value of Constrained).
8852 -- Therefore we retrieve the typecode which has
8853 -- been constructed in Append_Array_Traversal with
8854 -- a call to Get_Any_Type.
8857 Make_Function_Call (Loc,
8858 Name => New_Occurrence_Of (
8859 RTE (RE_Get_Any_Type), Loc),
8860 Parameter_Associations => New_List (
8861 New_Occurrence_Of (Entity (Datum), Loc)));
8863 -- For non Any Datum we simply construct a typecode
8864 -- matching the Etype of the Datum.
8866 Element_TC := Build_TypeCode_Call
8867 (Loc, Etype (Datum), Decls);
8871 Build_Get_Aggregate_Element (Loc,
8874 Idx => New_Occurrence_Of (Counter, Loc));
8877 -- Note: here we *prepend* statements to Stmts, so
8878 -- we must do it in reverse order.
8881 Make_Assignment_Statement (Loc,
8883 New_Occurrence_Of (Counter, Loc),
8886 Left_Opnd => New_Occurrence_Of (Counter, Loc),
8887 Right_Opnd => Make_Integer_Literal (Loc, 1))));
8889 if Nkind (Datum) /= N_Attribute_Reference then
8891 -- We ignore the value of the length of each
8892 -- dimension, since the target array has already
8893 -- been constrained anyway.
8895 if Etype (Datum) /= RTE (RE_Any) then
8896 Set_Expression (Assignment,
8898 (Component_Type (Typ), Element_Any, Decls));
8900 Set_Expression (Assignment, Element_Any);
8903 Prepend_To (Stmts, Assignment);
8905 end FA_Ary_Add_Process_Element;
8907 ------------------------
8908 -- Local Declarations --
8909 ------------------------
8911 Counter : constant Entity_Id :=
8912 Make_Defining_Identifier (Loc, Name_J);
8914 Initial_Counter_Value : Int := 0;
8916 Component_TC : constant Entity_Id :=
8917 Make_Defining_Identifier (Loc, Name_T);
8919 Res : constant Entity_Id :=
8920 Make_Defining_Identifier (Loc, Name_R);
8922 procedure Append_From_Any_Array_Iterator is
8923 new Append_Array_Traversal (
8926 Indices => New_List,
8927 Add_Process_Element => FA_Ary_Add_Process_Element);
8929 Res_Subtype_Indication : Node_Id :=
8930 New_Occurrence_Of (Typ, Loc);
8933 if not Constrained then
8935 Ndim : constant Int := Number_Dimensions (Typ);
8938 Indx : Node_Id := First_Index (Typ);
8941 Ranges : constant List_Id := New_List;
8944 for J in 1 .. Ndim loop
8945 Lnam := New_External_Name ('L', J);
8946 Hnam := New_External_Name ('H', J);
8947 Indt := Etype (Indx);
8950 Make_Object_Declaration (Loc,
8951 Defining_Identifier =>
8952 Make_Defining_Identifier (Loc, Lnam),
8953 Constant_Present => True,
8954 Object_Definition =>
8955 New_Occurrence_Of (Indt, Loc),
8959 Build_Get_Aggregate_Element (Loc,
8960 Any => Any_Parameter,
8961 TC => Build_TypeCode_Call
8964 Make_Integer_Literal (Loc, J - 1)),
8968 Make_Object_Declaration (Loc,
8969 Defining_Identifier =>
8970 Make_Defining_Identifier (Loc, Hnam),
8972 Constant_Present => True,
8974 Object_Definition =>
8975 New_Occurrence_Of (Indt, Loc),
8977 Expression => Make_Attribute_Reference (Loc,
8979 New_Occurrence_Of (Indt, Loc),
8981 Attribute_Name => Name_Val,
8983 Expressions => New_List (
8984 Make_Op_Subtract (Loc,
8989 Standard_Long_Integer,
8990 Make_Identifier (Loc, Lnam)),
8994 Standard_Long_Integer,
8995 Make_Function_Call (Loc,
8997 New_Occurrence_Of (RTE (
8998 RE_Get_Nested_Sequence_Length
9000 Parameter_Associations =>
9003 Any_Parameter, Loc),
9004 Make_Integer_Literal (Loc,
9008 Make_Integer_Literal (Loc, 1))))));
9012 Low_Bound => Make_Identifier (Loc, Lnam),
9013 High_Bound => Make_Identifier (Loc, Hnam)));
9018 -- Now we have all the necessary bound information:
9019 -- apply the set of range constraints to the
9020 -- (unconstrained) nominal subtype of Res.
9022 Initial_Counter_Value := Ndim;
9023 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9024 Subtype_Mark => Res_Subtype_Indication,
9026 Make_Index_Or_Discriminant_Constraint (Loc,
9027 Constraints => Ranges));
9032 Make_Object_Declaration (Loc,
9033 Defining_Identifier => Res,
9034 Object_Definition => Res_Subtype_Indication));
9035 Set_Etype (Res, Typ);
9038 Make_Object_Declaration (Loc,
9039 Defining_Identifier => Counter,
9040 Object_Definition =>
9041 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
9043 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9046 Make_Object_Declaration (Loc,
9047 Defining_Identifier => Component_TC,
9048 Constant_Present => True,
9049 Object_Definition =>
9050 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9052 Build_TypeCode_Call (Loc,
9053 Component_Type (Typ), Decls)));
9055 Append_From_Any_Array_Iterator
9056 (Stms, Any_Parameter, Counter);
9059 Make_Simple_Return_Statement (Loc,
9060 Expression => New_Occurrence_Of (Res, Loc)));
9063 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9065 Make_Simple_Return_Statement (Loc,
9067 Unchecked_Convert_To (Typ,
9069 (Find_Numeric_Representation (Typ),
9070 New_Occurrence_Of (Any_Parameter, Loc),
9074 Use_Opaque_Representation := True;
9077 if Use_Opaque_Representation then
9079 -- Default: type is represented as an opaque sequence of bytes
9082 Strm : constant Entity_Id :=
9083 Make_Defining_Identifier (Loc,
9084 Chars => New_Internal_Name ('S'));
9085 Res : constant Entity_Id :=
9086 Make_Defining_Identifier (Loc,
9087 Chars => New_Internal_Name ('R'));
9090 -- Strm : Buffer_Stream_Type;
9093 Make_Object_Declaration (Loc,
9094 Defining_Identifier => Strm,
9095 Aliased_Present => True,
9096 Object_Definition =>
9097 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9099 -- Allocate_Buffer (Strm);
9102 Make_Procedure_Call_Statement (Loc,
9104 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9105 Parameter_Associations => New_List (
9106 New_Occurrence_Of (Strm, Loc))));
9108 -- Any_To_BS (Strm, A);
9111 Make_Procedure_Call_Statement (Loc,
9112 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
9113 Parameter_Associations => New_List (
9114 New_Occurrence_Of (Any_Parameter, Loc),
9115 New_Occurrence_Of (Strm, Loc))));
9117 if Transmit_As_Unconstrained (Typ) then
9120 -- Res : constant T := T'Input (Strm);
9122 -- Release_Buffer (Strm);
9126 Append_To (Stms, Make_Block_Statement (Loc,
9127 Declarations => New_List (
9128 Make_Object_Declaration (Loc,
9129 Defining_Identifier => Res,
9130 Constant_Present => True,
9131 Object_Definition => New_Occurrence_Of (Typ, Loc),
9133 Make_Attribute_Reference (Loc,
9134 Prefix => New_Occurrence_Of (Typ, Loc),
9135 Attribute_Name => Name_Input,
9136 Expressions => New_List (
9137 Make_Attribute_Reference (Loc,
9139 New_Occurrence_Of (Strm, Loc),
9140 Attribute_Name => Name_Access))))),
9142 Handled_Statement_Sequence =>
9143 Make_Handled_Sequence_Of_Statements (Loc,
9144 Statements => New_List (
9145 Make_Procedure_Call_Statement (Loc,
9148 (RTE (RE_Release_Buffer), Loc),
9149 Parameter_Associations =>
9150 New_List (New_Occurrence_Of (Strm, Loc))),
9152 Make_Simple_Return_Statement (Loc,
9153 Expression => New_Occurrence_Of (Res, Loc))))));
9159 -- T'Read (Strm, Res);
9160 -- Release_Buffer (Strm);
9164 Append_To (Stms, Make_Block_Statement (Loc,
9165 Declarations => New_List (
9166 Make_Object_Declaration (Loc,
9167 Defining_Identifier => Res,
9168 Constant_Present => False,
9169 Object_Definition =>
9170 New_Occurrence_Of (Typ, Loc))),
9172 Handled_Statement_Sequence =>
9173 Make_Handled_Sequence_Of_Statements (Loc,
9174 Statements => New_List (
9175 Make_Attribute_Reference (Loc,
9176 Prefix => New_Occurrence_Of (Typ, Loc),
9177 Attribute_Name => Name_Read,
9178 Expressions => New_List (
9179 Make_Attribute_Reference (Loc,
9181 New_Occurrence_Of (Strm, Loc),
9182 Attribute_Name => Name_Access),
9183 New_Occurrence_Of (Res, Loc))),
9185 Make_Procedure_Call_Statement (Loc,
9188 (RTE (RE_Release_Buffer), Loc),
9189 Parameter_Associations =>
9190 New_List (New_Occurrence_Of (Strm, Loc))),
9192 Make_Simple_Return_Statement (Loc,
9193 Expression => New_Occurrence_Of (Res, Loc))))));
9199 Make_Subprogram_Body (Loc,
9200 Specification => Spec,
9201 Declarations => Decls,
9202 Handled_Statement_Sequence =>
9203 Make_Handled_Sequence_Of_Statements (Loc,
9204 Statements => Stms));
9205 end Build_From_Any_Function;
9207 ---------------------------------
9208 -- Build_Get_Aggregate_Element --
9209 ---------------------------------
9211 function Build_Get_Aggregate_Element
9215 Idx : Node_Id) return Node_Id
9218 return Make_Function_Call (Loc,
9220 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc),
9221 Parameter_Associations => New_List (
9222 New_Occurrence_Of (Any, Loc),
9225 end Build_Get_Aggregate_Element;
9227 -------------------------
9228 -- Build_Reposiroty_Id --
9229 -------------------------
9231 procedure Build_Name_And_Repository_Id
9233 Name_Str : out String_Id;
9234 Repo_Id_Str : out String_Id)
9238 Store_String_Chars ("DSA:");
9239 Get_Library_Unit_Name_String (Scope (E));
9241 (Name_Buffer (Name_Buffer'First ..
9242 Name_Buffer'First + Name_Len - 1));
9243 Store_String_Char ('.');
9244 Get_Name_String (Chars (E));
9246 (Name_Buffer (Name_Buffer'First ..
9247 Name_Buffer'First + Name_Len - 1));
9248 Store_String_Chars (":1.0");
9249 Repo_Id_Str := End_String;
9250 Name_Str := String_From_Name_Buffer;
9251 end Build_Name_And_Repository_Id;
9253 -----------------------
9254 -- Build_To_Any_Call --
9255 -----------------------
9257 function Build_To_Any_Call
9259 Decls : List_Id) return Node_Id
9261 Loc : constant Source_Ptr := Sloc (N);
9263 Typ : Entity_Id := Etype (N);
9265 Fnam : Entity_Id := Empty;
9266 Lib_RE : RE_Id := RE_Null;
9269 -- If N is a selected component, then maybe its Etype has not been
9270 -- set yet: try to use Etype of the selector_name in that case.
9272 if No (Typ) and then Nkind (N) = N_Selected_Component then
9273 Typ := Etype (Selector_Name (N));
9275 pragma Assert (Present (Typ));
9277 -- Get full view for private type, completion for incomplete type
9279 U_Type := Underlying_Type (Typ);
9281 -- First simple case where the To_Any function is present in the
9284 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9286 -- Check first for Boolean and Character. These are enumeration
9287 -- types, but we treat them specially, since they may require
9288 -- special handling in the transfer protocol. However, this
9289 -- special handling only applies if they have standard
9290 -- representation, otherwise they are treated like any other
9291 -- enumeration type.
9293 if Sloc (U_Type) <= Standard_Location then
9294 U_Type := Base_Type (U_Type);
9297 if Present (Fnam) then
9300 elsif U_Type = Standard_Boolean then
9303 elsif U_Type = Standard_Character then
9306 elsif U_Type = Standard_Wide_Character then
9309 elsif U_Type = Standard_Wide_Wide_Character then
9310 Lib_RE := RE_TA_WWC;
9312 -- Floating point types
9314 elsif U_Type = Standard_Short_Float then
9317 elsif U_Type = Standard_Float then
9320 elsif U_Type = Standard_Long_Float then
9323 elsif U_Type = Standard_Long_Long_Float then
9324 Lib_RE := RE_TA_LLF;
9328 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9329 Lib_RE := RE_TA_SSI;
9331 elsif U_Type = Etype (Standard_Short_Integer) then
9334 elsif U_Type = Etype (Standard_Integer) then
9337 elsif U_Type = Etype (Standard_Long_Integer) then
9340 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9341 Lib_RE := RE_TA_LLI;
9343 -- Unsigned integer types
9345 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9346 Lib_RE := RE_TA_SSU;
9348 elsif U_Type = RTE (RE_Short_Unsigned) then
9351 elsif U_Type = RTE (RE_Unsigned) then
9354 elsif U_Type = RTE (RE_Long_Unsigned) then
9357 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9358 Lib_RE := RE_TA_LLU;
9360 elsif U_Type = Standard_String then
9361 Lib_RE := RE_TA_String;
9363 -- Special DSA types
9365 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
9369 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9371 -- No corresponding FA_TC ???
9375 -- Other (non-primitive) types
9381 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9382 Append_To (Decls, Decl);
9386 -- Call the function
9388 if Lib_RE /= RE_Null then
9389 pragma Assert (No (Fnam));
9390 Fnam := RTE (Lib_RE);
9394 Make_Function_Call (Loc,
9395 Name => New_Occurrence_Of (Fnam, Loc),
9396 Parameter_Associations =>
9397 New_List (Unchecked_Convert_To (U_Type, N)));
9398 end Build_To_Any_Call;
9400 ---------------------------
9401 -- Build_To_Any_Function --
9402 ---------------------------
9404 procedure Build_To_Any_Function
9408 Fnam : out Entity_Id)
9411 Decls : constant List_Id := New_List;
9412 Stms : constant List_Id := New_List;
9414 Expr_Parameter : constant Entity_Id :=
9415 Make_Defining_Identifier (Loc, Name_E);
9417 Any : constant Entity_Id :=
9418 Make_Defining_Identifier (Loc, Name_A);
9421 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9423 Use_Opaque_Representation : Boolean;
9424 -- When True, use stream attributes and represent type as an
9425 -- opaque sequence of bytes.
9428 if Is_Itype (Typ) then
9429 Build_To_Any_Function
9437 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
9440 Make_Function_Specification (Loc,
9441 Defining_Unit_Name => Fnam,
9442 Parameter_Specifications => New_List (
9443 Make_Parameter_Specification (Loc,
9444 Defining_Identifier => Expr_Parameter,
9445 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9446 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9447 Set_Etype (Expr_Parameter, Typ);
9450 Make_Object_Declaration (Loc,
9451 Defining_Identifier => Any,
9452 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9454 Use_Opaque_Representation := False;
9456 if Has_Stream_Attribute_Definition
9457 (Typ, TSS_Stream_Output, At_Any_Place => True)
9459 Has_Stream_Attribute_Definition
9460 (Typ, TSS_Stream_Write, At_Any_Place => True)
9462 -- If user-defined stream attributes are specified for this
9463 -- type, use them and transmit data as an opaque sequence of
9466 Use_Opaque_Representation := True;
9468 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9470 -- Non-tagged derived type: convert to root type
9473 Rt_Type : constant Entity_Id := Root_Type (Typ);
9474 Expr : constant Node_Id :=
9477 New_Occurrence_Of (Expr_Parameter, Loc));
9479 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9482 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9484 -- Non-tagged record type
9486 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9488 Rt_Type : constant Entity_Id := Etype (Typ);
9489 Expr : constant Node_Id :=
9490 OK_Convert_To (Rt_Type,
9491 New_Occurrence_Of (Expr_Parameter, Loc));
9495 (Any_Decl, Build_To_Any_Call (Expr, Decls));
9498 -- Comment needed here (and label on declare block ???)
9502 Disc : Entity_Id := Empty;
9503 Rdef : constant Node_Id :=
9504 Type_Definition (Declaration_Node (Typ));
9506 Elements : constant List_Id := New_List;
9508 procedure TA_Rec_Add_Process_Element
9510 Container : Node_Or_Entity_Id;
9511 Counter : in out Int;
9514 -- Processing routine for traversal below
9516 procedure TA_Append_Record_Traversal is
9517 new Append_Record_Traversal
9518 (Rec => Expr_Parameter,
9519 Add_Process_Element => TA_Rec_Add_Process_Element);
9521 --------------------------------
9522 -- TA_Rec_Add_Process_Element --
9523 --------------------------------
9525 procedure TA_Rec_Add_Process_Element
9527 Container : Node_Or_Entity_Id;
9528 Counter : in out Int;
9532 Field_Ref : Node_Id;
9535 if Nkind (Field) = N_Defining_Identifier then
9537 -- A regular component
9539 Field_Ref := Make_Selected_Component (Loc,
9540 Prefix => New_Occurrence_Of (Rec, Loc),
9541 Selector_Name => New_Occurrence_Of (Field, Loc));
9542 Set_Etype (Field_Ref, Etype (Field));
9545 Make_Procedure_Call_Statement (Loc,
9548 RTE (RE_Add_Aggregate_Element), Loc),
9549 Parameter_Associations => New_List (
9550 New_Occurrence_Of (Container, Loc),
9551 Build_To_Any_Call (Field_Ref, Decls))));
9556 Variant_Part : declare
9558 Struct_Counter : Int := 0;
9560 Block_Decls : constant List_Id := New_List;
9561 Block_Stmts : constant List_Id := New_List;
9564 Alt_List : constant List_Id := New_List;
9565 Choice_List : List_Id;
9567 Union_Any : constant Entity_Id :=
9568 Make_Defining_Identifier (Loc,
9569 New_Internal_Name ('V'));
9571 Struct_Any : constant Entity_Id :=
9572 Make_Defining_Identifier (Loc,
9573 New_Internal_Name ('S'));
9575 function Make_Discriminant_Reference
9577 -- Build reference to the discriminant for this
9580 ---------------------------------
9581 -- Make_Discriminant_Reference --
9582 ---------------------------------
9584 function Make_Discriminant_Reference
9587 Nod : constant Node_Id :=
9588 Make_Selected_Component (Loc,
9591 Chars (Name (Field)));
9593 Set_Etype (Nod, Etype (Name (Field)));
9595 end Make_Discriminant_Reference;
9597 -- Start processing for Variant_Part
9601 Make_Block_Statement (Loc,
9604 Handled_Statement_Sequence =>
9605 Make_Handled_Sequence_Of_Statements (Loc,
9606 Statements => Block_Stmts)));
9608 -- Declare variant part aggregate (Union_Any).
9609 -- Knowing the position of this VP in the
9610 -- variant record, we can fetch the VP typecode
9613 Append_To (Block_Decls,
9614 Make_Object_Declaration (Loc,
9615 Defining_Identifier => Union_Any,
9616 Object_Definition =>
9617 New_Occurrence_Of (RTE (RE_Any), Loc),
9619 Make_Function_Call (Loc,
9620 Name => New_Occurrence_Of (
9621 RTE (RE_Create_Any), Loc),
9622 Parameter_Associations => New_List (
9623 Make_Function_Call (Loc,
9626 RTE (RE_Any_Member_Type), Loc),
9627 Parameter_Associations => New_List (
9628 New_Occurrence_Of (Container, Loc),
9629 Make_Integer_Literal (Loc,
9632 -- Declare inner struct aggregate (which
9633 -- contains the components of this VP).
9635 Append_To (Block_Decls,
9636 Make_Object_Declaration (Loc,
9637 Defining_Identifier => Struct_Any,
9638 Object_Definition =>
9639 New_Occurrence_Of (RTE (RE_Any), Loc),
9641 Make_Function_Call (Loc,
9642 Name => New_Occurrence_Of (
9643 RTE (RE_Create_Any), Loc),
9644 Parameter_Associations => New_List (
9645 Make_Function_Call (Loc,
9648 RTE (RE_Any_Member_Type), Loc),
9649 Parameter_Associations => New_List (
9650 New_Occurrence_Of (Union_Any, Loc),
9651 Make_Integer_Literal (Loc,
9654 -- Build case statement
9656 Append_To (Block_Stmts,
9657 Make_Case_Statement (Loc,
9658 Expression => Make_Discriminant_Reference,
9659 Alternatives => Alt_List));
9661 Variant := First_Non_Pragma (Variants (Field));
9662 while Present (Variant) loop
9663 Choice_List := New_Copy_List_Tree
9664 (Discrete_Choices (Variant));
9666 VP_Stmts := New_List;
9668 -- Append discriminant val to union aggregate
9670 Append_To (VP_Stmts,
9671 Make_Procedure_Call_Statement (Loc,
9674 RTE (RE_Add_Aggregate_Element), Loc),
9675 Parameter_Associations => New_List (
9676 New_Occurrence_Of (Union_Any, Loc),
9678 (Make_Discriminant_Reference,
9681 -- Populate inner struct aggregate
9683 -- Struct_Counter should be reset before
9684 -- handling a variant part. Indeed only one
9685 -- of the case statement alternatives will be
9686 -- executed at run-time, so the counter must
9687 -- start at 0 for every case statement.
9689 Struct_Counter := 0;
9691 TA_Append_Record_Traversal (
9693 Clist => Component_List (Variant),
9694 Container => Struct_Any,
9695 Counter => Struct_Counter);
9697 -- Append inner struct to union aggregate
9699 Append_To (VP_Stmts,
9700 Make_Procedure_Call_Statement (Loc,
9703 RTE (RE_Add_Aggregate_Element), Loc),
9704 Parameter_Associations => New_List (
9705 New_Occurrence_Of (Union_Any, Loc),
9706 New_Occurrence_Of (Struct_Any, Loc))));
9708 -- Append union to outer aggregate
9710 Append_To (VP_Stmts,
9711 Make_Procedure_Call_Statement (Loc,
9714 RTE (RE_Add_Aggregate_Element), Loc),
9715 Parameter_Associations => New_List (
9716 New_Occurrence_Of (Container, Loc),
9718 (Union_Any, Loc))));
9720 Append_To (Alt_List,
9721 Make_Case_Statement_Alternative (Loc,
9722 Discrete_Choices => Choice_List,
9723 Statements => VP_Stmts));
9725 Next_Non_Pragma (Variant);
9730 Counter := Counter + 1;
9731 end TA_Rec_Add_Process_Element;
9734 -- Records are encoded in a TC_STRUCT aggregate:
9736 -- -- Outer aggregate (TC_STRUCT)
9737 -- | [discriminant1]
9738 -- | [discriminant2]
9745 -- A component can be a common component or variant part
9747 -- A variant part is encoded as a TC_UNION aggregate:
9749 -- -- Variant Part Aggregate (TC_UNION)
9750 -- | [discriminant choice for this Variant Part]
9752 -- | -- Inner struct (TC_STRUCT)
9757 -- Let's start by building the outer aggregate. First we
9758 -- construct Elements array containing all discriminants.
9760 if Has_Discriminants (Typ) then
9761 Disc := First_Discriminant (Typ);
9762 while Present (Disc) loop
9764 Discriminant : constant Entity_Id :=
9765 Make_Selected_Component (Loc,
9772 Set_Etype (Discriminant, Etype (Disc));
9774 Append_To (Elements,
9775 Make_Component_Association (Loc,
9776 Choices => New_List (
9777 Make_Integer_Literal (Loc, Counter)),
9779 Build_To_Any_Call (Discriminant, Decls)));
9782 Counter := Counter + 1;
9783 Next_Discriminant (Disc);
9787 -- If there are no discriminants, we declare an empty
9791 Dummy_Any : constant Entity_Id :=
9792 Make_Defining_Identifier (Loc,
9793 Chars => New_Internal_Name ('A'));
9797 Make_Object_Declaration (Loc,
9798 Defining_Identifier => Dummy_Any,
9799 Object_Definition =>
9800 New_Occurrence_Of (RTE (RE_Any), Loc)));
9802 Append_To (Elements,
9803 Make_Component_Association (Loc,
9804 Choices => New_List (
9807 Make_Integer_Literal (Loc, 1),
9809 Make_Integer_Literal (Loc, 0))),
9811 New_Occurrence_Of (Dummy_Any, Loc)));
9815 -- We build the result aggregate with discriminants
9816 -- as the first elements.
9818 Set_Expression (Any_Decl,
9819 Make_Function_Call (Loc,
9820 Name => New_Occurrence_Of (
9821 RTE (RE_Any_Aggregate_Build), Loc),
9822 Parameter_Associations => New_List (
9824 Make_Aggregate (Loc,
9825 Component_Associations => Elements))));
9828 -- Then we append all the components to the result
9831 TA_Append_Record_Traversal (Stms,
9832 Clist => Component_List (Rdef),
9834 Counter => Counter);
9838 elsif Is_Array_Type (Typ) then
9840 -- Constrained and unconstrained array types
9843 Constrained : constant Boolean := Is_Constrained (Typ);
9845 procedure TA_Ary_Add_Process_Element
9848 Counter : Entity_Id;
9851 --------------------------------
9852 -- TA_Ary_Add_Process_Element --
9853 --------------------------------
9855 procedure TA_Ary_Add_Process_Element
9858 Counter : Entity_Id;
9861 pragma Warnings (Off);
9862 pragma Unreferenced (Counter);
9863 pragma Warnings (On);
9865 Element_Any : Node_Id;
9868 if Etype (Datum) = RTE (RE_Any) then
9869 Element_Any := Datum;
9871 Element_Any := Build_To_Any_Call (Datum, Decls);
9875 Make_Procedure_Call_Statement (Loc,
9876 Name => New_Occurrence_Of (
9877 RTE (RE_Add_Aggregate_Element), Loc),
9878 Parameter_Associations => New_List (
9879 New_Occurrence_Of (Any, Loc),
9881 end TA_Ary_Add_Process_Element;
9883 procedure Append_To_Any_Array_Iterator is
9884 new Append_Array_Traversal (
9886 Arry => Expr_Parameter,
9887 Indices => New_List,
9888 Add_Process_Element => TA_Ary_Add_Process_Element);
9893 Set_Expression (Any_Decl,
9894 Make_Function_Call (Loc,
9896 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9897 Parameter_Associations => New_List (Result_TC)));
9900 if not Constrained then
9901 Index := First_Index (Typ);
9902 for J in 1 .. Number_Dimensions (Typ) loop
9904 Make_Procedure_Call_Statement (Loc,
9907 RTE (RE_Add_Aggregate_Element), Loc),
9908 Parameter_Associations => New_List (
9909 New_Occurrence_Of (Any, Loc),
9911 OK_Convert_To (Etype (Index),
9912 Make_Attribute_Reference (Loc,
9914 New_Occurrence_Of (Expr_Parameter, Loc),
9915 Attribute_Name => Name_First,
9916 Expressions => New_List (
9917 Make_Integer_Literal (Loc, J)))),
9923 Append_To_Any_Array_Iterator (Stms, Any);
9926 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9930 Set_Expression (Any_Decl,
9933 Find_Numeric_Representation (Typ),
9934 New_Occurrence_Of (Expr_Parameter, Loc)),
9938 -- Default case, including tagged types: opaque representation
9940 Use_Opaque_Representation := True;
9943 if Use_Opaque_Representation then
9945 Strm : constant Entity_Id :=
9946 Make_Defining_Identifier (Loc,
9947 Chars => New_Internal_Name ('S'));
9948 -- Stream used to store data representation produced by
9949 -- stream attribute.
9953 -- Strm : aliased Buffer_Stream_Type;
9956 Make_Object_Declaration (Loc,
9957 Defining_Identifier =>
9961 Object_Definition =>
9962 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9965 -- Allocate_Buffer (Strm);
9968 Make_Procedure_Call_Statement (Loc,
9970 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9971 Parameter_Associations => New_List (
9972 New_Occurrence_Of (Strm, Loc))));
9975 -- T'Output (Strm'Access, E);
9978 Make_Attribute_Reference (Loc,
9979 Prefix => New_Occurrence_Of (Typ, Loc),
9980 Attribute_Name => Name_Output,
9981 Expressions => New_List (
9982 Make_Attribute_Reference (Loc,
9983 Prefix => New_Occurrence_Of (Strm, Loc),
9984 Attribute_Name => Name_Access),
9985 New_Occurrence_Of (Expr_Parameter, Loc))));
9988 -- BS_To_Any (Strm, A);
9991 Make_Procedure_Call_Statement (Loc,
9992 Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
9993 Parameter_Associations => New_List (
9994 New_Occurrence_Of (Strm, Loc),
9995 New_Occurrence_Of (Any, Loc))));
9998 -- Release_Buffer (Strm);
10001 Make_Procedure_Call_Statement (Loc,
10002 Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
10003 Parameter_Associations => New_List (
10004 New_Occurrence_Of (Strm, Loc))));
10008 Append_To (Decls, Any_Decl);
10010 if Present (Result_TC) then
10012 Make_Procedure_Call_Statement (Loc,
10013 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
10014 Parameter_Associations => New_List (
10015 New_Occurrence_Of (Any, Loc),
10020 Make_Simple_Return_Statement (Loc,
10021 Expression => New_Occurrence_Of (Any, Loc)));
10024 Make_Subprogram_Body (Loc,
10025 Specification => Spec,
10026 Declarations => Decls,
10027 Handled_Statement_Sequence =>
10028 Make_Handled_Sequence_Of_Statements (Loc,
10029 Statements => Stms));
10030 end Build_To_Any_Function;
10032 -------------------------
10033 -- Build_TypeCode_Call --
10034 -------------------------
10036 function Build_TypeCode_Call
10039 Decls : List_Id) return Node_Id
10041 U_Type : Entity_Id := Underlying_Type (Typ);
10042 -- The full view, if Typ is private; the completion,
10043 -- if Typ is incomplete.
10045 Fnam : Entity_Id := Empty;
10046 Lib_RE : RE_Id := RE_Null;
10050 -- Special case System.PolyORB.Interface.Any: its primitives have
10051 -- not been set yet, so can't call Find_Inherited_TSS.
10053 if Typ = RTE (RE_Any) then
10054 Fnam := RTE (RE_TC_A);
10057 -- First simple case where the TypeCode is present
10058 -- in the type's TSS.
10060 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10064 if Sloc (U_Type) <= Standard_Location then
10066 -- Do not try to build alias typecodes for subtypes from
10069 U_Type := Base_Type (U_Type);
10072 if U_Type = Standard_Boolean then
10075 elsif U_Type = Standard_Character then
10078 elsif U_Type = Standard_Wide_Character then
10079 Lib_RE := RE_TC_WC;
10081 elsif U_Type = Standard_Wide_Wide_Character then
10082 Lib_RE := RE_TC_WWC;
10084 -- Floating point types
10086 elsif U_Type = Standard_Short_Float then
10087 Lib_RE := RE_TC_SF;
10089 elsif U_Type = Standard_Float then
10092 elsif U_Type = Standard_Long_Float then
10093 Lib_RE := RE_TC_LF;
10095 elsif U_Type = Standard_Long_Long_Float then
10096 Lib_RE := RE_TC_LLF;
10098 -- Integer types (walk back to the base type)
10100 elsif U_Type = Etype (Standard_Short_Short_Integer) then
10101 Lib_RE := RE_TC_SSI;
10103 elsif U_Type = Etype (Standard_Short_Integer) then
10104 Lib_RE := RE_TC_SI;
10106 elsif U_Type = Etype (Standard_Integer) then
10109 elsif U_Type = Etype (Standard_Long_Integer) then
10110 Lib_RE := RE_TC_LI;
10112 elsif U_Type = Etype (Standard_Long_Long_Integer) then
10113 Lib_RE := RE_TC_LLI;
10115 -- Unsigned integer types
10117 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
10118 Lib_RE := RE_TC_SSU;
10120 elsif U_Type = RTE (RE_Short_Unsigned) then
10121 Lib_RE := RE_TC_SU;
10123 elsif U_Type = RTE (RE_Unsigned) then
10126 elsif U_Type = RTE (RE_Long_Unsigned) then
10127 Lib_RE := RE_TC_LU;
10129 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
10130 Lib_RE := RE_TC_LLU;
10132 elsif U_Type = Standard_String then
10133 Lib_RE := RE_TC_String;
10135 -- Special DSA types
10137 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
10140 -- Other (non-primitive) types
10146 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10147 Append_To (Decls, Decl);
10151 if Lib_RE /= RE_Null then
10152 Fnam := RTE (Lib_RE);
10156 -- Call the function
10159 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10161 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10163 Set_Etype (Expr, RTE (RE_TypeCode));
10166 end Build_TypeCode_Call;
10168 -----------------------------
10169 -- Build_TypeCode_Function --
10170 -----------------------------
10172 procedure Build_TypeCode_Function
10175 Decl : out Node_Id;
10176 Fnam : out Entity_Id)
10179 Decls : constant List_Id := New_List;
10180 Stms : constant List_Id := New_List;
10182 TCNam : constant Entity_Id :=
10183 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
10185 Parameters : List_Id;
10187 procedure Add_String_Parameter
10189 Parameter_List : List_Id);
10190 -- Add a literal for S to Parameters
10192 procedure Add_TypeCode_Parameter
10193 (TC_Node : Node_Id;
10194 Parameter_List : List_Id);
10195 -- Add the typecode for Typ to Parameters
10197 procedure Add_Long_Parameter
10198 (Expr_Node : Node_Id;
10199 Parameter_List : List_Id);
10200 -- Add a signed long integer expression to Parameters
10202 procedure Initialize_Parameter_List
10203 (Name_String : String_Id;
10204 Repo_Id_String : String_Id;
10205 Parameter_List : out List_Id);
10206 -- Return a list that contains the first two parameters
10207 -- for a parameterized typecode: name and repository id.
10209 function Make_Constructed_TypeCode
10211 Parameters : List_Id) return Node_Id;
10212 -- Call TC_Build with the given kind and parameters
10214 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10215 -- Make a return statement that calls TC_Build with the given
10216 -- typecode kind, and the constructed parameters list.
10218 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10219 -- Return a typecode that is a TC_Alias for the given typecode
10221 --------------------------
10222 -- Add_String_Parameter --
10223 --------------------------
10225 procedure Add_String_Parameter
10227 Parameter_List : List_Id)
10230 Append_To (Parameter_List,
10231 Make_Function_Call (Loc,
10232 Name => New_Occurrence_Of (RTE (RE_TA_String), Loc),
10233 Parameter_Associations => New_List (
10234 Make_String_Literal (Loc, S))));
10235 end Add_String_Parameter;
10237 ----------------------------
10238 -- Add_TypeCode_Parameter --
10239 ----------------------------
10241 procedure Add_TypeCode_Parameter
10242 (TC_Node : Node_Id;
10243 Parameter_List : List_Id)
10246 Append_To (Parameter_List,
10247 Make_Function_Call (Loc,
10248 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10249 Parameter_Associations => New_List (TC_Node)));
10250 end Add_TypeCode_Parameter;
10252 ------------------------
10253 -- Add_Long_Parameter --
10254 ------------------------
10256 procedure Add_Long_Parameter
10257 (Expr_Node : Node_Id;
10258 Parameter_List : List_Id)
10261 Append_To (Parameter_List,
10262 Make_Function_Call (Loc,
10263 Name => New_Occurrence_Of (RTE (RE_TA_LI), Loc),
10264 Parameter_Associations => New_List (Expr_Node)));
10265 end Add_Long_Parameter;
10267 -------------------------------
10268 -- Initialize_Parameter_List --
10269 -------------------------------
10271 procedure Initialize_Parameter_List
10272 (Name_String : String_Id;
10273 Repo_Id_String : String_Id;
10274 Parameter_List : out List_Id)
10277 Parameter_List := New_List;
10278 Add_String_Parameter (Name_String, Parameter_List);
10279 Add_String_Parameter (Repo_Id_String, Parameter_List);
10280 end Initialize_Parameter_List;
10282 ---------------------------
10283 -- Return_Alias_TypeCode --
10284 ---------------------------
10286 procedure Return_Alias_TypeCode
10287 (Base_TypeCode : Node_Id)
10290 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10291 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
10292 end Return_Alias_TypeCode;
10294 -------------------------------
10295 -- Make_Constructed_TypeCode --
10296 -------------------------------
10298 function Make_Constructed_TypeCode
10300 Parameters : List_Id) return Node_Id
10302 Constructed_TC : constant Node_Id :=
10303 Make_Function_Call (Loc,
10305 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
10306 Parameter_Associations => New_List (
10307 New_Occurrence_Of (Kind, Loc),
10308 Make_Aggregate (Loc,
10309 Expressions => Parameters)));
10311 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10312 return Constructed_TC;
10313 end Make_Constructed_TypeCode;
10315 ---------------------------------
10316 -- Return_Constructed_TypeCode --
10317 ---------------------------------
10319 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10322 Make_Simple_Return_Statement (Loc,
10324 Make_Constructed_TypeCode (Kind, Parameters)));
10325 end Return_Constructed_TypeCode;
10331 procedure TC_Rec_Add_Process_Element
10334 Counter : in out Int;
10338 procedure TC_Append_Record_Traversal is
10339 new Append_Record_Traversal (
10341 Add_Process_Element => TC_Rec_Add_Process_Element);
10343 --------------------------------
10344 -- TC_Rec_Add_Process_Element --
10345 --------------------------------
10347 procedure TC_Rec_Add_Process_Element
10350 Counter : in out Int;
10354 pragma Warnings (Off);
10355 pragma Unreferenced (Any, Counter, Rec);
10356 pragma Warnings (On);
10359 if Nkind (Field) = N_Defining_Identifier then
10361 -- A regular component
10363 Add_TypeCode_Parameter
10364 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10365 Get_Name_String (Chars (Field));
10366 Add_String_Parameter (String_From_Name_Buffer, Params);
10373 Discriminant_Type : constant Entity_Id :=
10374 Etype (Name (Field));
10376 Is_Enum : constant Boolean :=
10377 Is_Enumeration_Type (Discriminant_Type);
10379 Union_TC_Params : List_Id;
10381 U_Name : constant Name_Id :=
10382 New_External_Name (Chars (Typ), 'V', -1);
10384 Name_Str : String_Id;
10385 Struct_TC_Params : List_Id;
10389 Default : constant Node_Id :=
10390 Make_Integer_Literal (Loc, -1);
10392 Dummy_Counter : Int := 0;
10394 Choice_Index : Int := 0;
10396 procedure Add_Params_For_Variant_Components;
10397 -- Add a struct TypeCode and a corresponding member name
10398 -- to the union parameter list.
10400 -- Ordering of declarations is a complete mess in this
10401 -- area, it is supposed to be types/variables, then
10402 -- subprogram specs, then subprogram bodies ???
10404 ---------------------------------------
10405 -- Add_Params_For_Variant_Components --
10406 ---------------------------------------
10408 procedure Add_Params_For_Variant_Components
10410 S_Name : constant Name_Id :=
10411 New_External_Name (U_Name, 'S', -1);
10414 Get_Name_String (S_Name);
10415 Name_Str := String_From_Name_Buffer;
10416 Initialize_Parameter_List
10417 (Name_Str, Name_Str, Struct_TC_Params);
10419 -- Build struct parameters
10421 TC_Append_Record_Traversal (Struct_TC_Params,
10422 Component_List (Variant),
10426 Add_TypeCode_Parameter
10427 (Make_Constructed_TypeCode
10428 (RTE (RE_TC_Struct), Struct_TC_Params),
10431 Add_String_Parameter (Name_Str, Union_TC_Params);
10432 end Add_Params_For_Variant_Components;
10435 Get_Name_String (U_Name);
10436 Name_Str := String_From_Name_Buffer;
10438 Initialize_Parameter_List
10439 (Name_Str, Name_Str, Union_TC_Params);
10441 -- Add union in enclosing parameter list
10443 Add_TypeCode_Parameter
10444 (Make_Constructed_TypeCode
10445 (RTE (RE_TC_Union), Union_TC_Params),
10448 Add_String_Parameter (Name_Str, Params);
10450 -- Build union parameters
10452 Add_TypeCode_Parameter
10453 (Build_TypeCode_Call
10454 (Loc, Discriminant_Type, Decls),
10457 Add_Long_Parameter (Default, Union_TC_Params);
10459 Variant := First_Non_Pragma (Variants (Field));
10460 while Present (Variant) loop
10461 Choice := First (Discrete_Choices (Variant));
10462 while Present (Choice) loop
10463 case Nkind (Choice) is
10466 L : constant Uint :=
10467 Expr_Value (Low_Bound (Choice));
10468 H : constant Uint :=
10469 Expr_Value (High_Bound (Choice));
10471 -- 3.8.1(8) guarantees that the bounds of
10472 -- this range are static.
10479 Expr := New_Occurrence_Of (
10480 Get_Enum_Lit_From_Pos (
10481 Discriminant_Type, J, Loc), Loc);
10484 Make_Integer_Literal (Loc, J);
10486 Append_To (Union_TC_Params,
10487 Build_To_Any_Call (Expr, Decls));
10489 Add_Params_For_Variant_Components;
10494 when N_Others_Choice =>
10496 -- This variant possess a default choice.
10497 -- We must therefore set the default
10498 -- parameter to the current choice index. The
10499 -- default parameter is by construction the
10500 -- fourth in the Union_TC_Params list.
10503 Default_Node : constant Node_Id :=
10504 Pick (Union_TC_Params, 4);
10506 New_Default_Node : constant Node_Id :=
10507 Make_Function_Call (Loc,
10510 (RTE (RE_TA_LI), Loc),
10511 Parameter_Associations =>
10513 Make_Integer_Literal
10514 (Loc, Choice_Index)));
10520 Remove (Default_Node);
10523 -- Add a placeholder member label
10524 -- for the default case.
10525 -- It must be of the discriminant type.
10528 Exp : constant Node_Id :=
10529 Make_Attribute_Reference (Loc,
10530 Prefix => New_Occurrence_Of
10531 (Discriminant_Type, Loc),
10532 Attribute_Name => Name_First);
10534 Set_Etype (Exp, Discriminant_Type);
10535 Append_To (Union_TC_Params,
10536 Build_To_Any_Call (Exp, Decls));
10539 Add_Params_For_Variant_Components;
10543 -- Case of an explicit choice
10546 Exp : constant Node_Id :=
10547 New_Copy_Tree (Choice);
10549 Append_To (Union_TC_Params,
10550 Build_To_Any_Call (Exp, Decls));
10553 Add_Params_For_Variant_Components;
10557 Choice_Index := Choice_Index + 1;
10560 Next_Non_Pragma (Variant);
10564 end TC_Rec_Add_Process_Element;
10566 Type_Name_Str : String_Id;
10567 Type_Repo_Id_Str : String_Id;
10570 if Is_Itype (Typ) then
10571 Build_TypeCode_Function
10573 Typ => Etype (Typ),
10582 Make_Function_Specification (Loc,
10583 Defining_Unit_Name => Fnam,
10584 Parameter_Specifications => Empty_List,
10585 Result_Definition =>
10586 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10588 Build_Name_And_Repository_Id (Typ,
10589 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10591 Initialize_Parameter_List
10592 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10594 if Has_Stream_Attribute_Definition
10595 (Typ, TSS_Stream_Output, At_Any_Place => True)
10597 Has_Stream_Attribute_Definition
10598 (Typ, TSS_Stream_Write, At_Any_Place => True)
10600 -- If user-defined stream attributes are specified for this
10601 -- type, use them and transmit data as an opaque sequence of
10602 -- stream elements.
10604 Return_Alias_TypeCode
10605 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10607 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
10608 Return_Alias_TypeCode (
10609 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10611 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10612 Return_Alias_TypeCode (
10613 Build_TypeCode_Call (Loc,
10614 Find_Numeric_Representation (Typ), Decls));
10616 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
10618 -- Record typecodes are encoded as follows:
10622 -- | [Repository Id]
10624 -- Then for each discriminant:
10626 -- | [Discriminant Type Code]
10627 -- | [Discriminant Name]
10630 -- Then for each component:
10632 -- | [Component Type Code]
10633 -- | [Component Name]
10636 -- Variants components type codes are encoded as follows:
10640 -- | [Repository Id]
10641 -- | [Discriminant Type Code]
10642 -- | [Index of Default Variant Part or -1 for no default]
10644 -- Then for each Variant Part :
10649 -- | | [Variant Part Name]
10650 -- | | [Variant Part Repository Id]
10652 -- | Then for each VP component:
10653 -- | | [VP component Typecode]
10654 -- | | [VP component Name]
10660 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10661 Return_Alias_TypeCode
10662 (Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10666 Disc : Entity_Id := Empty;
10667 Rdef : constant Node_Id :=
10668 Type_Definition (Declaration_Node (Typ));
10669 Dummy_Counter : Int := 0;
10672 -- Construct the discriminants typecodes
10674 if Has_Discriminants (Typ) then
10675 Disc := First_Discriminant (Typ);
10678 while Present (Disc) loop
10679 Add_TypeCode_Parameter (
10680 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10682 Get_Name_String (Chars (Disc));
10683 Add_String_Parameter (
10684 String_From_Name_Buffer,
10686 Next_Discriminant (Disc);
10689 -- then the components typecodes
10691 TC_Append_Record_Traversal
10692 (Parameters, Component_List (Rdef),
10693 Empty, Dummy_Counter);
10694 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10698 elsif Is_Array_Type (Typ) then
10700 Ndim : constant Pos := Number_Dimensions (Typ);
10701 Inner_TypeCode : Node_Id;
10702 Constrained : constant Boolean := Is_Constrained (Typ);
10703 Indx : Node_Id := First_Index (Typ);
10707 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls);
10709 for J in 1 .. Ndim loop
10710 if Constrained then
10711 Inner_TypeCode := Make_Constructed_TypeCode
10712 (RTE (RE_TC_Array), New_List (
10713 Build_To_Any_Call (
10714 OK_Convert_To (RTE (RE_Long_Unsigned),
10715 Make_Attribute_Reference (Loc,
10716 Prefix => New_Occurrence_Of (Typ, Loc),
10717 Attribute_Name => Name_Length,
10718 Expressions => New_List (
10719 Make_Integer_Literal (Loc,
10720 Intval => Ndim - J + 1)))),
10722 Build_To_Any_Call (Inner_TypeCode, Decls)));
10725 -- Unconstrained case: add low bound for each
10728 Add_TypeCode_Parameter
10729 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10731 Get_Name_String (New_External_Name ('L', J));
10732 Add_String_Parameter (
10733 String_From_Name_Buffer,
10737 Inner_TypeCode := Make_Constructed_TypeCode
10738 (RTE (RE_TC_Sequence), New_List (
10739 Build_To_Any_Call (
10740 OK_Convert_To (RTE (RE_Long_Unsigned),
10741 Make_Integer_Literal (Loc, 0)),
10743 Build_To_Any_Call (Inner_TypeCode, Decls)));
10747 if Constrained then
10748 Return_Alias_TypeCode (Inner_TypeCode);
10750 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10752 Store_String_Char ('V');
10753 Add_String_Parameter (End_String, Parameters);
10754 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10759 -- Default: type is represented as an opaque sequence of bytes
10761 Return_Alias_TypeCode
10762 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10766 Make_Subprogram_Body (Loc,
10767 Specification => Spec,
10768 Declarations => Decls,
10769 Handled_Statement_Sequence =>
10770 Make_Handled_Sequence_Of_Statements (Loc,
10771 Statements => Stms));
10772 end Build_TypeCode_Function;
10774 ---------------------------------
10775 -- Find_Numeric_Representation --
10776 ---------------------------------
10778 function Find_Numeric_Representation
10779 (Typ : Entity_Id) return Entity_Id
10781 FST : constant Entity_Id := First_Subtype (Typ);
10782 P_Size : constant Uint := Esize (FST);
10785 if Is_Unsigned_Type (Typ) then
10786 if P_Size <= Standard_Short_Short_Integer_Size then
10787 return RTE (RE_Short_Short_Unsigned);
10789 elsif P_Size <= Standard_Short_Integer_Size then
10790 return RTE (RE_Short_Unsigned);
10792 elsif P_Size <= Standard_Integer_Size then
10793 return RTE (RE_Unsigned);
10795 elsif P_Size <= Standard_Long_Integer_Size then
10796 return RTE (RE_Long_Unsigned);
10799 return RTE (RE_Long_Long_Unsigned);
10802 elsif Is_Integer_Type (Typ) then
10803 if P_Size <= Standard_Short_Short_Integer_Size then
10804 return Standard_Short_Short_Integer;
10806 elsif P_Size <= Standard_Short_Integer_Size then
10807 return Standard_Short_Integer;
10809 elsif P_Size <= Standard_Integer_Size then
10810 return Standard_Integer;
10812 elsif P_Size <= Standard_Long_Integer_Size then
10813 return Standard_Long_Integer;
10816 return Standard_Long_Long_Integer;
10819 elsif Is_Floating_Point_Type (Typ) then
10820 if P_Size <= Standard_Short_Float_Size then
10821 return Standard_Short_Float;
10823 elsif P_Size <= Standard_Float_Size then
10824 return Standard_Float;
10826 elsif P_Size <= Standard_Long_Float_Size then
10827 return Standard_Long_Float;
10830 return Standard_Long_Long_Float;
10834 raise Program_Error;
10837 -- TBD: fixed point types???
10838 -- TBverified numeric types with a biased representation???
10840 end Find_Numeric_Representation;
10842 ---------------------------
10843 -- Append_Array_Traversal --
10844 ---------------------------
10846 procedure Append_Array_Traversal
10849 Counter : Entity_Id := Empty;
10852 Loc : constant Source_Ptr := Sloc (Subprogram);
10853 Typ : constant Entity_Id := Etype (Arry);
10854 Constrained : constant Boolean := Is_Constrained (Typ);
10855 Ndim : constant Pos := Number_Dimensions (Typ);
10857 Inner_Any, Inner_Counter : Entity_Id;
10859 Loop_Stm : Node_Id;
10860 Inner_Stmts : constant List_Id := New_List;
10863 if Depth > Ndim then
10865 -- Processing for one element of an array
10868 Element_Expr : constant Node_Id :=
10869 Make_Indexed_Component (Loc,
10870 New_Occurrence_Of (Arry, Loc),
10873 Set_Etype (Element_Expr, Component_Type (Typ));
10874 Add_Process_Element (Stmts,
10876 Counter => Counter,
10877 Datum => Element_Expr);
10883 Append_To (Indices,
10884 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10886 if not Constrained or else Depth > 1 then
10887 Inner_Any := Make_Defining_Identifier (Loc,
10888 New_External_Name ('A', Depth));
10889 Set_Etype (Inner_Any, RTE (RE_Any));
10891 Inner_Any := Empty;
10894 if Present (Counter) then
10895 Inner_Counter := Make_Defining_Identifier (Loc,
10896 New_External_Name ('J', Depth));
10898 Inner_Counter := Empty;
10902 Loop_Any : Node_Id := Inner_Any;
10905 -- For the first dimension of a constrained array, we add
10906 -- elements directly in the corresponding Any; there is no
10907 -- intervening inner Any.
10909 if No (Loop_Any) then
10913 Append_Array_Traversal (Inner_Stmts,
10915 Counter => Inner_Counter,
10916 Depth => Depth + 1);
10920 Make_Implicit_Loop_Statement (Subprogram,
10921 Iteration_Scheme =>
10922 Make_Iteration_Scheme (Loc,
10923 Loop_Parameter_Specification =>
10924 Make_Loop_Parameter_Specification (Loc,
10925 Defining_Identifier =>
10926 Make_Defining_Identifier (Loc,
10927 Chars => New_External_Name ('L', Depth)),
10929 Discrete_Subtype_Definition =>
10930 Make_Attribute_Reference (Loc,
10931 Prefix => New_Occurrence_Of (Arry, Loc),
10932 Attribute_Name => Name_Range,
10934 Expressions => New_List (
10935 Make_Integer_Literal (Loc, Depth))))),
10936 Statements => Inner_Stmts);
10939 Decls : constant List_Id := New_List;
10940 Dimen_Stmts : constant List_Id := New_List;
10941 Length_Node : Node_Id;
10943 Inner_Any_TypeCode : constant Entity_Id :=
10944 Make_Defining_Identifier (Loc,
10945 New_External_Name ('T', Depth));
10947 Inner_Any_TypeCode_Expr : Node_Id;
10951 if Constrained then
10952 Inner_Any_TypeCode_Expr :=
10953 Make_Function_Call (Loc,
10954 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
10955 Parameter_Associations => New_List (
10956 New_Occurrence_Of (Any, Loc)));
10958 Inner_Any_TypeCode_Expr :=
10959 Make_Function_Call (Loc,
10961 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
10962 Parameter_Associations => New_List (
10963 New_Occurrence_Of (Any, Loc),
10964 Make_Integer_Literal (Loc, Ndim)));
10967 Inner_Any_TypeCode_Expr :=
10968 Make_Function_Call (Loc,
10969 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc),
10970 Parameter_Associations => New_List (
10971 Make_Identifier (Loc,
10972 Chars => New_External_Name ('T', Depth - 1))));
10976 Make_Object_Declaration (Loc,
10977 Defining_Identifier => Inner_Any_TypeCode,
10978 Constant_Present => True,
10979 Object_Definition => New_Occurrence_Of (
10980 RTE (RE_TypeCode), Loc),
10981 Expression => Inner_Any_TypeCode_Expr));
10983 if Present (Inner_Any) then
10985 Make_Object_Declaration (Loc,
10986 Defining_Identifier => Inner_Any,
10987 Object_Definition =>
10988 New_Occurrence_Of (RTE (RE_Any), Loc),
10990 Make_Function_Call (Loc,
10992 New_Occurrence_Of (
10993 RTE (RE_Create_Any), Loc),
10994 Parameter_Associations => New_List (
10995 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
10998 if Present (Inner_Counter) then
11000 Make_Object_Declaration (Loc,
11001 Defining_Identifier => Inner_Counter,
11002 Object_Definition =>
11003 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
11005 Make_Integer_Literal (Loc, 0)));
11008 if not Constrained then
11009 Length_Node := Make_Attribute_Reference (Loc,
11010 Prefix => New_Occurrence_Of (Arry, Loc),
11011 Attribute_Name => Name_Length,
11013 New_List (Make_Integer_Literal (Loc, Depth)));
11014 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
11016 Add_Process_Element (Dimen_Stmts,
11017 Datum => Length_Node,
11019 Counter => Inner_Counter);
11022 -- Loop_Stm does appropriate processing for each element
11025 Append_To (Dimen_Stmts, Loop_Stm);
11027 -- Link outer and inner any
11029 if Present (Inner_Any) then
11030 Add_Process_Element (Dimen_Stmts,
11032 Counter => Counter,
11033 Datum => New_Occurrence_Of (Inner_Any, Loc));
11037 Make_Block_Statement (Loc,
11040 Handled_Statement_Sequence =>
11041 Make_Handled_Sequence_Of_Statements (Loc,
11042 Statements => Dimen_Stmts)));
11044 end Append_Array_Traversal;
11046 -------------------------------
11047 -- Make_Helper_Function_Name --
11048 -------------------------------
11050 function Make_Helper_Function_Name
11053 Nam : Name_Id) return Entity_Id
11058 -- For tagged types, we use a canonical name so that it matches
11059 -- the primitive spec. For all other cases, we use a serialized
11060 -- name so that multiple generations of the same procedure do
11064 if not Is_Tagged_Type (Typ) then
11065 Serial := Increment_Serial_Number;
11068 -- Use prefixed underscore to avoid potential clash with used
11069 -- identifier (we use attribute names for Nam).
11072 Make_Defining_Identifier (Loc,
11075 (Related_Id => Nam,
11076 Suffix => ' ', Suffix_Index => Serial,
11079 end Make_Helper_Function_Name;
11082 -----------------------------------
11083 -- Reserve_NamingContext_Methods --
11084 -----------------------------------
11086 procedure Reserve_NamingContext_Methods is
11087 Str_Resolve : constant String := "resolve";
11089 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11090 Name_Len := Str_Resolve'Length;
11091 Overload_Counter_Table.Set (Name_Find, 1);
11092 end Reserve_NamingContext_Methods;
11094 end PolyORB_Support;
11096 -------------------------------
11097 -- RACW_Type_Is_Asynchronous --
11098 -------------------------------
11100 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11101 Asynchronous_Flag : constant Entity_Id :=
11102 Asynchronous_Flags_Table.Get (RACW_Type);
11104 Replace (Expression (Parent (Asynchronous_Flag)),
11105 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11106 end RACW_Type_Is_Asynchronous;
11108 -------------------------
11109 -- RCI_Package_Locator --
11110 -------------------------
11112 function RCI_Package_Locator
11114 Package_Spec : Node_Id) return Node_Id
11117 Pkg_Name : String_Id;
11120 Get_Library_Unit_Name_String (Package_Spec);
11121 Pkg_Name := String_From_Name_Buffer;
11123 Make_Package_Instantiation (Loc,
11124 Defining_Unit_Name =>
11125 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
11127 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11128 Generic_Associations => New_List (
11129 Make_Generic_Association (Loc,
11131 Make_Identifier (Loc, Name_RCI_Name),
11132 Explicit_Generic_Actual_Parameter =>
11133 Make_String_Literal (Loc,
11134 Strval => Pkg_Name)),
11135 Make_Generic_Association (Loc,
11137 Make_Identifier (Loc, Name_Version),
11138 Explicit_Generic_Actual_Parameter =>
11139 Make_Attribute_Reference (Loc,
11141 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11145 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
11146 Defining_Unit_Name (Inst));
11148 end RCI_Package_Locator;
11150 -----------------------------------------------
11151 -- Remote_Types_Tagged_Full_View_Encountered --
11152 -----------------------------------------------
11154 procedure Remote_Types_Tagged_Full_View_Encountered
11155 (Full_View : Entity_Id)
11157 Stub_Elements : constant Stub_Structure :=
11158 Stubs_Table.Get (Full_View);
11161 -- For an RACW encountered before the freeze point of its designated
11162 -- type, the stub type is generated at the point of the RACW declaration
11163 -- but the primitives are generated only once the designated type is
11164 -- frozen. That freeze can occur in another scope, for example when the
11165 -- RACW is declared in a nested package. In that case we need to
11166 -- reestablish the stub type's scope prior to generating its primitive
11169 if Stub_Elements /= Empty_Stub_Structure then
11171 Saved_Scope : constant Entity_Id := Current_Scope;
11172 Stubs_Scope : constant Entity_Id :=
11173 Scope (Stub_Elements.Stub_Type);
11176 if Current_Scope /= Stubs_Scope then
11177 Push_Scope (Stubs_Scope);
11180 Add_RACW_Primitive_Declarations_And_Bodies
11182 Stub_Elements.RPC_Receiver_Decl,
11183 Stub_Elements.Body_Decls);
11185 if Current_Scope /= Saved_Scope then
11190 end Remote_Types_Tagged_Full_View_Encountered;
11192 -------------------
11193 -- Scope_Of_Spec --
11194 -------------------
11196 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11197 Unit_Name : Node_Id;
11200 Unit_Name := Defining_Unit_Name (Spec);
11201 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11202 Unit_Name := Defining_Identifier (Unit_Name);
11208 ----------------------
11209 -- Set_Renaming_TSS --
11210 ----------------------
11212 procedure Set_Renaming_TSS
11215 TSS_Nam : TSS_Name_Type)
11217 Loc : constant Source_Ptr := Sloc (Nam);
11218 Spec : constant Node_Id := Parent (Nam);
11220 TSS_Node : constant Node_Id :=
11221 Make_Subprogram_Renaming_Declaration (Loc,
11223 Copy_Specification (Loc,
11225 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11226 Name => New_Occurrence_Of (Nam, Loc));
11228 Snam : constant Entity_Id :=
11229 Defining_Unit_Name (Specification (TSS_Node));
11232 if Nkind (Spec) = N_Function_Specification then
11233 Set_Ekind (Snam, E_Function);
11234 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11236 Set_Ekind (Snam, E_Procedure);
11237 Set_Etype (Snam, Standard_Void_Type);
11240 Set_TSS (Typ, Snam);
11241 end Set_Renaming_TSS;
11243 ----------------------------------------------
11244 -- Specific_Add_Obj_RPC_Receiver_Completion --
11245 ----------------------------------------------
11247 procedure Specific_Add_Obj_RPC_Receiver_Completion
11250 RPC_Receiver : Entity_Id;
11251 Stub_Elements : Stub_Structure)
11254 case Get_PCS_Name is
11255 when Name_PolyORB_DSA =>
11256 PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11257 Decls, RPC_Receiver, Stub_Elements);
11259 GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11260 Decls, RPC_Receiver, Stub_Elements);
11262 end Specific_Add_Obj_RPC_Receiver_Completion;
11264 --------------------------------
11265 -- Specific_Add_RACW_Features --
11266 --------------------------------
11268 procedure Specific_Add_RACW_Features
11269 (RACW_Type : Entity_Id;
11271 Stub_Type : Entity_Id;
11272 Stub_Type_Access : Entity_Id;
11273 RPC_Receiver_Decl : Node_Id;
11274 Body_Decls : List_Id)
11277 case Get_PCS_Name is
11278 when Name_PolyORB_DSA =>
11279 PolyORB_Support.Add_RACW_Features
11288 GARLIC_Support.Add_RACW_Features
11295 end Specific_Add_RACW_Features;
11297 --------------------------------
11298 -- Specific_Add_RAST_Features --
11299 --------------------------------
11301 procedure Specific_Add_RAST_Features
11302 (Vis_Decl : Node_Id;
11303 RAS_Type : Entity_Id)
11306 case Get_PCS_Name is
11307 when Name_PolyORB_DSA =>
11308 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11310 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11312 end Specific_Add_RAST_Features;
11314 --------------------------------------------------
11315 -- Specific_Add_Receiving_Stubs_To_Declarations --
11316 --------------------------------------------------
11318 procedure Specific_Add_Receiving_Stubs_To_Declarations
11319 (Pkg_Spec : Node_Id;
11324 case Get_PCS_Name is
11325 when Name_PolyORB_DSA =>
11326 PolyORB_Support.Add_Receiving_Stubs_To_Declarations
11327 (Pkg_Spec, Decls, Stmts);
11329 GARLIC_Support.Add_Receiving_Stubs_To_Declarations
11330 (Pkg_Spec, Decls, Stmts);
11332 end Specific_Add_Receiving_Stubs_To_Declarations;
11334 ------------------------------------------
11335 -- Specific_Build_General_Calling_Stubs --
11336 ------------------------------------------
11338 procedure Specific_Build_General_Calling_Stubs
11340 Statements : List_Id;
11341 Target : RPC_Target;
11342 Subprogram_Id : Node_Id;
11343 Asynchronous : Node_Id := Empty;
11344 Is_Known_Asynchronous : Boolean := False;
11345 Is_Known_Non_Asynchronous : Boolean := False;
11346 Is_Function : Boolean;
11348 Stub_Type : Entity_Id := Empty;
11349 RACW_Type : Entity_Id := Empty;
11353 case Get_PCS_Name is
11354 when Name_PolyORB_DSA =>
11355 PolyORB_Support.Build_General_Calling_Stubs
11361 Is_Known_Asynchronous,
11362 Is_Known_Non_Asynchronous,
11370 GARLIC_Support.Build_General_Calling_Stubs
11374 Target.RPC_Receiver,
11377 Is_Known_Asynchronous,
11378 Is_Known_Non_Asynchronous,
11385 end Specific_Build_General_Calling_Stubs;
11387 --------------------------------------
11388 -- Specific_Build_RPC_Receiver_Body --
11389 --------------------------------------
11391 procedure Specific_Build_RPC_Receiver_Body
11392 (RPC_Receiver : Entity_Id;
11393 Request : out Entity_Id;
11394 Subp_Id : out Entity_Id;
11395 Subp_Index : out Entity_Id;
11396 Stmts : out List_Id;
11397 Decl : out Node_Id)
11400 case Get_PCS_Name is
11401 when Name_PolyORB_DSA =>
11402 PolyORB_Support.Build_RPC_Receiver_Body
11411 GARLIC_Support.Build_RPC_Receiver_Body
11419 end Specific_Build_RPC_Receiver_Body;
11421 --------------------------------
11422 -- Specific_Build_Stub_Target --
11423 --------------------------------
11425 function Specific_Build_Stub_Target
11428 RCI_Locator : Entity_Id;
11429 Controlling_Parameter : Entity_Id) return RPC_Target
11432 case Get_PCS_Name is
11433 when Name_PolyORB_DSA =>
11434 return PolyORB_Support.Build_Stub_Target (Loc,
11435 Decls, RCI_Locator, Controlling_Parameter);
11438 return GARLIC_Support.Build_Stub_Target (Loc,
11439 Decls, RCI_Locator, Controlling_Parameter);
11441 end Specific_Build_Stub_Target;
11443 ------------------------------
11444 -- Specific_Build_Stub_Type --
11445 ------------------------------
11447 procedure Specific_Build_Stub_Type
11448 (RACW_Type : Entity_Id;
11449 Stub_Type : Entity_Id;
11450 Stub_Type_Decl : out Node_Id;
11451 RPC_Receiver_Decl : out Node_Id)
11454 case Get_PCS_Name is
11455 when Name_PolyORB_DSA =>
11456 PolyORB_Support.Build_Stub_Type (
11457 RACW_Type, Stub_Type,
11458 Stub_Type_Decl, RPC_Receiver_Decl);
11461 GARLIC_Support.Build_Stub_Type (
11462 RACW_Type, Stub_Type,
11463 Stub_Type_Decl, RPC_Receiver_Decl);
11465 end Specific_Build_Stub_Type;
11467 function Specific_Build_Subprogram_Receiving_Stubs
11468 (Vis_Decl : Node_Id;
11469 Asynchronous : Boolean;
11470 Dynamically_Asynchronous : Boolean := False;
11471 Stub_Type : Entity_Id := Empty;
11472 RACW_Type : Entity_Id := Empty;
11473 Parent_Primitive : Entity_Id := Empty) return Node_Id
11476 case Get_PCS_Name is
11477 when Name_PolyORB_DSA =>
11478 return PolyORB_Support.Build_Subprogram_Receiving_Stubs
11481 Dynamically_Asynchronous,
11487 return GARLIC_Support.Build_Subprogram_Receiving_Stubs
11490 Dynamically_Asynchronous,
11495 end Specific_Build_Subprogram_Receiving_Stubs;
11497 -------------------------------
11498 -- Transmit_As_Unconstrained --
11499 -------------------------------
11501 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
11504 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
11505 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
11506 end Transmit_As_Unconstrained;
11508 --------------------------
11509 -- Underlying_RACW_Type --
11510 --------------------------
11512 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11513 Record_Type : Entity_Id;
11516 if Ekind (RAS_Typ) = E_Record_Type then
11517 Record_Type := RAS_Typ;
11519 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11520 Record_Type := Equivalent_Type (RAS_Typ);
11524 Etype (Subtype_Indication
11525 (Component_Definition
11526 (First (Component_Items
11529 (Declaration_Node (Record_Type))))))));
11530 end Underlying_RACW_Type;