1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Exp_Atag; use Exp_Atag;
31 with Exp_Strm; use Exp_Strm;
32 with Exp_Tss; use Exp_Tss;
33 with Exp_Util; use Exp_Util;
35 with Nlists; use Nlists;
36 with Nmake; use Nmake;
38 with Rtsfind; use Rtsfind;
40 with Sem_Cat; use Sem_Cat;
41 with Sem_Ch3; use Sem_Ch3;
42 with Sem_Ch8; use Sem_Ch8;
43 with Sem_Dist; use Sem_Dist;
44 with Sem_Eval; use Sem_Eval;
45 with Sem_Util; use Sem_Util;
46 with Sinfo; use Sinfo;
47 with Snames; use Snames;
48 with Stand; use Stand;
49 with Stringt; use Stringt;
50 with Tbuild; use Tbuild;
51 with Ttypes; use Ttypes;
52 with Uintp; use Uintp;
54 with GNAT.HTable; use GNAT.HTable;
56 package body Exp_Dist is
58 -- The following model has been used to implement distributed objects:
59 -- given a designated type D and a RACW type R, then a record of the
62 -- type Stub is tagged record
63 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
66 -- is built. This type has two properties:
68 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
69 -- converted to and from this type to make it suitable for
70 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
71 -- to avoid memory leaks when the same remote object arrive on the
72 -- same partition through several paths;
74 -- 2) It also has the same dispatching table as the designated type D,
75 -- and thus can be used as an object designated by a value of type
76 -- R on any partition other than the one on which the object has
77 -- been created, since only dispatching calls will be performed and
78 -- the fields themselves will not be used. We call Derive_Subprograms
79 -- to fake half a derivation to ensure that the subprograms do have
80 -- the same dispatching table.
82 First_RCI_Subprogram_Id : constant := 2;
83 -- RCI subprograms are numbered starting at 2. The RCI receiver for
84 -- an RCI package can thus identify calls received through remote
85 -- access-to-subprogram dereferences by the fact that they have a
86 -- (primitive) subprogram id of 0, and 1 is used for the internal
87 -- RAS information lookup operation. (This is for the Garlic code
88 -- generation, where subprograms are identified by numbers; in the
89 -- PolyORB version, they are identified by name, with a numeric suffix
92 type Hash_Index is range 0 .. 50;
94 -----------------------
95 -- Local subprograms --
96 -----------------------
98 function Hash (F : Entity_Id) return Hash_Index;
99 -- DSA expansion associates stubs to distributed object types using
100 -- a hash table on entity ids.
102 function Hash (F : Name_Id) return Hash_Index;
103 -- The generation of subprogram identifiers requires an overload counter
104 -- to be associated with each remote subprogram names. These counters
105 -- are maintained in a hash table on name ids.
107 type Subprogram_Identifiers is record
108 Str_Identifier : String_Id;
109 Int_Identifier : Int;
112 package Subprogram_Identifier_Table is
113 new Simple_HTable (Header_Num => Hash_Index,
114 Element => Subprogram_Identifiers,
115 No_Element => (No_String, 0),
119 -- Mapping between a remote subprogram and the corresponding
120 -- subprogram identifiers.
122 package Overload_Counter_Table is
123 new Simple_HTable (Header_Num => Hash_Index,
129 -- Mapping between a subprogram name and an integer that
130 -- counts the number of defining subprogram names with that
131 -- Name_Id encountered so far in a given context (an interface).
133 function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
134 function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
135 function Get_Subprogram_Id (Def : Entity_Id) return Int;
136 -- Given a subprogram defined in a RCI package, get its distribution
137 -- subprogram identifiers (the distribution identifiers are a unique
138 -- subprogram number, and the non-qualified subprogram name, in the
139 -- casing used for the subprogram declaration; if the name is overloaded,
140 -- a double underscore and a serial number are appended.
142 -- The integer identifier is used to perform remote calls with GARLIC;
143 -- the string identifier is used in the case of PolyORB.
145 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
146 -- when receiving a call, the calling stubs will create requests with the
147 -- exact casing of the defining unit name of the called subprogram, so as
148 -- to allow calls to subprograms on distributed nodes that do distinguish
151 -- NOTE: Another design would be to allow a representation clause on
152 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
154 pragma Warnings (Off, Get_Subprogram_Id);
155 -- One homonym only is unreferenced (specific to the GARLIC version)
157 procedure Add_RAS_Dereference_TSS (N : Node_Id);
158 -- Add a subprogram body for RAS Dereference TSS
160 procedure Add_RAS_Proxy_And_Analyze
163 All_Calls_Remote_E : Entity_Id;
164 Proxy_Object_Addr : out Entity_Id);
165 -- Add the proxy type required, on the receiving (server) side, to handle
166 -- calls to the subprogram declared by Vis_Decl through a remote access
167 -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
168 -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
169 -- is appended to Decls. Proxy_Object_Addr is a constant of type
170 -- System.Address that designates an instance of the proxy object.
172 function Build_Remote_Subprogram_Proxy_Type
174 ACR_Expression : Node_Id) return Node_Id;
175 -- Build and return a tagged record type definition for an RCI
176 -- subprogram proxy type.
177 -- ACR_Expression is use as the initialization value for
178 -- the All_Calls_Remote component.
180 function Build_Get_Unique_RP_Call
183 Stub_Type : Entity_Id) return List_Id;
184 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
185 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
186 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
188 function Build_Subprogram_Calling_Stubs
191 Asynchronous : Boolean;
192 Dynamically_Asynchronous : Boolean := False;
193 Stub_Type : Entity_Id := Empty;
194 RACW_Type : Entity_Id := Empty;
195 Locator : Entity_Id := Empty;
196 New_Name : Name_Id := No_Name) return Node_Id;
197 -- Build the calling stub for a given subprogram with the subprogram ID
198 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
199 -- parameters of this type will be marshalled instead of the object
200 -- itself. It will then be converted into Stub_Type before performing
201 -- the real call. If Dynamically_Asynchronous is True, then it will be
202 -- computed at run time whether the call is asynchronous or not.
203 -- Otherwise, the value of the formal Asynchronous will be used.
204 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
205 -- New_Name is given, then it will be used instead of the original name.
207 function Build_RPC_Receiver_Specification
208 (RPC_Receiver : Entity_Id;
209 Request_Parameter : Entity_Id) return Node_Id;
210 -- Make a subprogram specification for an RPC receiver, with the given
211 -- defining unit name and formal parameter.
213 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
214 -- Return an ordered parameter list: unconstrained parameters are put
215 -- at the beginning of the list and constrained ones are put after. If
216 -- there are no parameters, an empty list is returned. Special case:
217 -- the controlling formal of the equivalent RACW operation for a RAS
218 -- type is always left in first position.
220 procedure Add_Calling_Stubs_To_Declarations
223 -- Add calling stubs to the declarative part
225 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
226 -- Return True if nothing prevents the program whose specification is
227 -- given to be asynchronous (i.e. no out parameter).
229 function Pack_Entity_Into_Stream_Access
233 Etyp : Entity_Id := Empty) return Node_Id;
234 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
235 -- then Etype (Object) will be used if present. If the type is
236 -- constrained, then 'Write will be used to output the object,
237 -- If the type is unconstrained, 'Output will be used.
239 function Pack_Node_Into_Stream
243 Etyp : Entity_Id) return Node_Id;
244 -- Similar to above, with an arbitrary node instead of an entity
246 function Pack_Node_Into_Stream_Access
250 Etyp : Entity_Id) return Node_Id;
251 -- Similar to above, with Stream instead of Stream'Access
253 function Make_Selected_Component
256 Selector_Name : Name_Id) return Node_Id;
257 -- Return a selected_component whose prefix denotes the given entity,
258 -- and with the given Selector_Name.
260 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
261 -- Return the scope represented by a given spec
263 procedure Set_Renaming_TSS
266 TSS_Nam : TSS_Name_Type);
267 -- Create a renaming declaration of subprogram Nam,
268 -- and register it as a TSS for Typ with name TSS_Nam.
270 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
271 -- Return True if the current parameter needs an extra formal to reflect
272 -- its constrained status.
274 function Is_RACW_Controlling_Formal
275 (Parameter : Node_Id;
276 Stub_Type : Entity_Id) return Boolean;
277 -- Return True if the current parameter is a controlling formal argument
278 -- of type Stub_Type or access to Stub_Type.
280 procedure Declare_Create_NVList
285 -- Append the declaration of NVList to Decls, and its
286 -- initialization to Stmts.
288 function Add_Parameter_To_NVList
291 Parameter : Entity_Id;
292 Constrained : Boolean;
293 RACW_Ctrl : Boolean := False;
294 Any : Entity_Id) return Node_Id;
295 -- Return a call to Add_Item to add the Any corresponding to the designated
296 -- formal Parameter (with the indicated Constrained status) to NVList.
297 -- RACW_Ctrl must be set to True for controlling formals of distributed
298 -- object primitive operations.
304 -- This record describes various tree fragments associated with the
305 -- generation of RACW calling stubs. One such record exists for every
306 -- distributed object type, i.e. each tagged type that is the designated
307 -- type of one or more RACW type.
309 type Stub_Structure is record
310 Stub_Type : Entity_Id;
311 -- Stub type: this type has the same primitive operations as the
312 -- designated types, but the provided bodies for these operations
313 -- a remote call to an actual target object potentially located on
314 -- another partition; each value of the stub type encapsulates a
315 -- reference to a remote object.
317 Stub_Type_Access : Entity_Id;
318 -- A local access type designating the stub type (this is not an RACW
321 RPC_Receiver_Decl : Node_Id;
322 -- Declaration for the RPC receiver entity associated with the
323 -- designated type. As an exception, for the case of an RACW that
324 -- implements a RAS, no object RPC receiver is generated. Instead,
325 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
326 -- would have been inserted.
328 Body_Decls : List_Id;
329 -- List of subprogram bodies to be included in generated code: bodies
330 -- for the RACW's stream attributes, and for the primitive operations
333 RACW_Type : Entity_Id;
334 -- One of the RACW types designating this distributed object type
335 -- (they are all interchangeable; we use any one of them in order to
336 -- avoid having to create various anonymous access types).
340 Empty_Stub_Structure : constant Stub_Structure :=
341 (Empty, Empty, Empty, No_List, Empty);
343 package Stubs_Table is
344 new Simple_HTable (Header_Num => Hash_Index,
345 Element => Stub_Structure,
346 No_Element => Empty_Stub_Structure,
350 -- Mapping between a RACW designated type and its stub type
352 package Asynchronous_Flags_Table is
353 new Simple_HTable (Header_Num => Hash_Index,
354 Element => Entity_Id,
359 -- Mapping between a RACW type and a constant having the value True
360 -- if the RACW is asynchronous and False otherwise.
362 package RCI_Locator_Table is
363 new Simple_HTable (Header_Num => Hash_Index,
364 Element => Entity_Id,
369 -- Mapping between a RCI package on which All_Calls_Remote applies and
370 -- the generic instantiation of RCI_Locator for this package.
372 package RCI_Calling_Stubs_Table is
373 new Simple_HTable (Header_Num => Hash_Index,
374 Element => Entity_Id,
379 -- Mapping between a RCI subprogram and the corresponding calling stubs
381 procedure Add_Stub_Type
382 (Designated_Type : Entity_Id;
383 RACW_Type : Entity_Id;
385 Stub_Type : out Entity_Id;
386 Stub_Type_Access : out Entity_Id;
387 RPC_Receiver_Decl : out Node_Id;
388 Body_Decls : out List_Id;
389 Existing : out Boolean);
390 -- Add the declaration of the stub type, the access to stub type and the
391 -- object RPC receiver at the end of Decls. If these already exist,
392 -- then nothing is added in the tree but the right values are returned
393 -- anyhow and Existing is set to True.
395 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
396 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
397 -- structure table, reset it to No_List, and return the previous value.
399 procedure Add_RACW_Asynchronous_Flag
400 (Declarations : List_Id;
401 RACW_Type : Entity_Id);
402 -- Declare a boolean constant associated with RACW_Type whose value
403 -- indicates at run time whether a pragma Asynchronous applies to it.
405 procedure Assign_Subprogram_Identifier
409 -- Determine the distribution subprogram identifier to
410 -- be used for remote subprogram Def, return it in Id and
411 -- store it in a hash table for later retrieval by
412 -- Get_Subprogram_Id. Spn is the subprogram number.
414 function RCI_Package_Locator
416 Package_Spec : Node_Id) return Node_Id;
417 -- Instantiate the generic package RCI_Locator in order to locate the
418 -- RCI package whose spec is given as argument.
420 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
421 -- Surround a node N by a tag check, as in:
425 -- when E : Ada.Tags.Tag_Error =>
426 -- Raise_Exception (Program_Error'Identity,
427 -- Exception_Message (E));
430 function Input_With_Tag_Check
432 Var_Type : Entity_Id;
433 Stream : Node_Id) return Node_Id;
434 -- Return a function with the following form:
435 -- function R return Var_Type is
437 -- return Var_Type'Input (S);
439 -- when E : Ada.Tags.Tag_Error =>
440 -- Raise_Exception (Program_Error'Identity,
441 -- Exception_Message (E));
444 procedure Build_Actual_Object_Declaration
450 -- Build the declaration of an object with the given defining identifier,
451 -- initialized with Expr if provided, to serve as actual parameter in a
452 -- server stub. If Variable is true, the declared object will be a variable
453 -- (case of an out or in out formal), else it will be a constant. Object's
454 -- Ekind is set accordingly. The declaration, as well as any other
455 -- declarations it requires, are appended to Decls.
457 --------------------------------------------
458 -- Hooks for PCS-specific code generation --
459 --------------------------------------------
461 -- Part of the code generation circuitry for distribution needs to be
462 -- tailored for each implementation of the PCS. For each routine that
463 -- needs to be specialized, a Specific_<routine> wrapper is created,
464 -- which calls the corresponding <routine> in package
465 -- <pcs_implementation>_Support.
467 procedure Specific_Add_RACW_Features
468 (RACW_Type : Entity_Id;
470 Stub_Type : Entity_Id;
471 Stub_Type_Access : Entity_Id;
472 RPC_Receiver_Decl : Node_Id;
473 Body_Decls : List_Id);
474 -- Add declaration for TSSs for a given RACW type. The declarations are
475 -- added just after the declaration of the RACW type itself, while the
476 -- bodies are inserted at the end of Body_Decls. Runtime-specific ancillary
477 -- subprogram for Add_RACW_Features.
479 procedure Specific_Add_RAST_Features
481 RAS_Type : Entity_Id);
482 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
483 -- subprogram for Add_RAST_Features.
485 -- An RPC_Target record is used during construction of calling stubs
486 -- to pass PCS-specific tree fragments corresponding to the information
487 -- necessary to locate the target of a remote subprogram call.
489 type RPC_Target (PCS_Kind : PCS_Names) is record
491 when Name_PolyORB_DSA =>
493 -- An expression whose value is a PolyORB reference to the target
496 Partition : Entity_Id;
497 -- A variable containing the Partition_ID of the target parition
499 RPC_Receiver : Node_Id;
500 -- An expression whose value is the address of the target RPC
505 procedure Specific_Build_General_Calling_Stubs
507 Statements : List_Id;
509 Subprogram_Id : Node_Id;
510 Asynchronous : Node_Id := Empty;
511 Is_Known_Asynchronous : Boolean := False;
512 Is_Known_Non_Asynchronous : Boolean := False;
513 Is_Function : Boolean;
515 Stub_Type : Entity_Id := Empty;
516 RACW_Type : Entity_Id := Empty;
518 -- Build calling stubs for general purpose. The parameters are:
519 -- Decls : a place to put declarations
520 -- Statements : a place to put statements
521 -- Target : PCS-specific target information (see details
522 -- in RPC_Target declaration).
523 -- Subprogram_Id : a node containing the subprogram ID
524 -- Asynchronous : True if an APC must be made instead of an RPC.
525 -- The value needs not be supplied if one of the
526 -- Is_Known_... is True.
527 -- Is_Known_Async... : True if we know that this is asynchronous
528 -- Is_Known_Non_A... : True if we know that this is not asynchronous
529 -- Spec : a node with a Parameter_Specifications and
530 -- a Result_Definition if applicable
531 -- Stub_Type : in case of RACW stubs, parameters of type access
532 -- to Stub_Type will be marshalled using the
533 -- address of the object (the addr field) rather
534 -- than using the 'Write on the stub itself
535 -- Nod : used to provide sloc for generated code
537 function Specific_Build_Stub_Target
540 RCI_Locator : Entity_Id;
541 Controlling_Parameter : Entity_Id) return RPC_Target;
542 -- Build call target information nodes for use within calling stubs. In the
543 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
544 -- for an RACW, Controlling_Parameter is the entity for the controlling
545 -- formal parameter used to determine the location of the target of the
546 -- call. Decls provides a location where variable declarations can be
547 -- appended to construct the necessary values.
549 procedure Specific_Build_Stub_Type
550 (RACW_Type : Entity_Id;
551 Stub_Type : Entity_Id;
552 Stub_Type_Decl : out Node_Id;
553 RPC_Receiver_Decl : out Node_Id);
554 -- Build a type declaration for the stub type associated with an RACW
555 -- type, and the necessary RPC receiver, if applicable. PCS-specific
556 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
557 -- is generated, then RPC_Receiver_Decl is set to Empty.
559 procedure Specific_Build_RPC_Receiver_Body
560 (RPC_Receiver : Entity_Id;
561 Request : out Entity_Id;
562 Subp_Id : out Entity_Id;
563 Subp_Index : out Entity_Id;
566 -- Make a subprogram body for an RPC receiver, with the given
567 -- defining unit name. On return:
568 -- - Subp_Id is the subprogram identifier from the PCS.
569 -- - Subp_Index is the index in the list of subprograms
570 -- used for dispatching (a variable of type Subprogram_Id).
571 -- - Stmts is the place where the request dispatching
572 -- statements can occur,
573 -- - Decl is the subprogram body declaration.
575 function Specific_Build_Subprogram_Receiving_Stubs
577 Asynchronous : Boolean;
578 Dynamically_Asynchronous : Boolean := False;
579 Stub_Type : Entity_Id := Empty;
580 RACW_Type : Entity_Id := Empty;
581 Parent_Primitive : Entity_Id := Empty) return Node_Id;
582 -- Build the receiving stub for a given subprogram. The subprogram
583 -- declaration is also built by this procedure, and the value returned
584 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
585 -- found in the specification, then its address is read from the stream
586 -- instead of the object itself and converted into an access to
587 -- class-wide type before doing the real call using any of the RACW type
588 -- pointing on the designated type.
590 procedure Specific_Add_Obj_RPC_Receiver_Completion
593 RPC_Receiver : Entity_Id;
594 Stub_Elements : Stub_Structure);
595 -- Add the necessary code to Decls after the completion of generation
596 -- of the RACW RPC receiver described by Stub_Elements.
598 procedure Specific_Add_Receiving_Stubs_To_Declarations
602 -- Add receiving stubs to the declarative part of an RCI unit
604 package GARLIC_Support is
606 -- Support for generating DSA code that uses the GARLIC PCS
608 -- The subprograms below provide the GARLIC versions of
609 -- the corresponding Specific_<subprogram> routine declared
612 procedure Add_RACW_Features
613 (RACW_Type : Entity_Id;
614 Stub_Type : Entity_Id;
615 Stub_Type_Access : Entity_Id;
616 RPC_Receiver_Decl : Node_Id;
617 Body_Decls : List_Id);
619 procedure Add_RAST_Features
621 RAS_Type : Entity_Id);
623 procedure Build_General_Calling_Stubs
625 Statements : List_Id;
626 Target_Partition : Entity_Id; -- From RPC_Target
627 Target_RPC_Receiver : Node_Id; -- From RPC_Target
628 Subprogram_Id : Node_Id;
629 Asynchronous : Node_Id := Empty;
630 Is_Known_Asynchronous : Boolean := False;
631 Is_Known_Non_Asynchronous : Boolean := False;
632 Is_Function : Boolean;
634 Stub_Type : Entity_Id := Empty;
635 RACW_Type : Entity_Id := Empty;
638 function Build_Stub_Target
641 RCI_Locator : Entity_Id;
642 Controlling_Parameter : Entity_Id) return RPC_Target;
644 procedure Build_Stub_Type
645 (RACW_Type : Entity_Id;
646 Stub_Type : Entity_Id;
647 Stub_Type_Decl : out Node_Id;
648 RPC_Receiver_Decl : out Node_Id);
650 function Build_Subprogram_Receiving_Stubs
652 Asynchronous : Boolean;
653 Dynamically_Asynchronous : Boolean := False;
654 Stub_Type : Entity_Id := Empty;
655 RACW_Type : Entity_Id := Empty;
656 Parent_Primitive : Entity_Id := Empty) return Node_Id;
658 procedure Add_Obj_RPC_Receiver_Completion
661 RPC_Receiver : Entity_Id;
662 Stub_Elements : Stub_Structure);
664 procedure Add_Receiving_Stubs_To_Declarations
669 procedure Build_RPC_Receiver_Body
670 (RPC_Receiver : Entity_Id;
671 Request : out Entity_Id;
672 Subp_Id : out Entity_Id;
673 Subp_Index : out Entity_Id;
679 package PolyORB_Support is
681 -- Support for generating DSA code that uses the PolyORB PCS
683 -- The subprograms below provide the PolyORB versions of
684 -- the corresponding Specific_<subprogram> routine declared
687 procedure Add_RACW_Features
688 (RACW_Type : Entity_Id;
690 Stub_Type : Entity_Id;
691 Stub_Type_Access : Entity_Id;
692 RPC_Receiver_Decl : Node_Id;
693 Body_Decls : List_Id);
695 procedure Add_RAST_Features
697 RAS_Type : Entity_Id);
699 procedure Build_General_Calling_Stubs
701 Statements : List_Id;
702 Target_Object : Node_Id; -- From RPC_Target
703 Subprogram_Id : Node_Id;
704 Asynchronous : Node_Id := Empty;
705 Is_Known_Asynchronous : Boolean := False;
706 Is_Known_Non_Asynchronous : Boolean := False;
707 Is_Function : Boolean;
709 Stub_Type : Entity_Id := Empty;
710 RACW_Type : Entity_Id := Empty;
713 function Build_Stub_Target
716 RCI_Locator : Entity_Id;
717 Controlling_Parameter : Entity_Id) return RPC_Target;
719 procedure Build_Stub_Type
720 (RACW_Type : Entity_Id;
721 Stub_Type : Entity_Id;
722 Stub_Type_Decl : out Node_Id;
723 RPC_Receiver_Decl : out Node_Id);
725 function Build_Subprogram_Receiving_Stubs
727 Asynchronous : Boolean;
728 Dynamically_Asynchronous : Boolean := False;
729 Stub_Type : Entity_Id := Empty;
730 RACW_Type : Entity_Id := Empty;
731 Parent_Primitive : Entity_Id := Empty) return Node_Id;
733 procedure Add_Obj_RPC_Receiver_Completion
736 RPC_Receiver : Entity_Id;
737 Stub_Elements : Stub_Structure);
739 procedure Add_Receiving_Stubs_To_Declarations
744 procedure Build_RPC_Receiver_Body
745 (RPC_Receiver : Entity_Id;
746 Request : out Entity_Id;
747 Subp_Id : out Entity_Id;
748 Subp_Index : out Entity_Id;
752 procedure Reserve_NamingContext_Methods;
753 -- Mark the method names for interface NamingContext as already used in
754 -- the overload table, so no clashes occur with user code (with the
755 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
756 -- their methods to be accessed as objects, for the implementation of
757 -- remote access-to-subprogram types).
761 -- Routines to build distribtion helper subprograms for user-defined
762 -- types. For implementation of the Distributed systems annex (DSA)
763 -- over the PolyORB generic middleware components, it is necessary to
764 -- generate several supporting subprograms for each application data
765 -- type used in inter-partition communication. These subprograms are:
766 -- * a Typecode function returning a high-level description of the
768 -- * two conversion functions allowing conversion of values of the
769 -- type from and to the generic data containers used by PolyORB.
770 -- These generic containers are called 'Any' type values after
771 -- the CORBA terminology, and hence the conversion subprograms
772 -- are named To_Any and From_Any.
774 function Build_From_Any_Call
777 Decls : List_Id) return Node_Id;
778 -- Build call to From_Any attribute function of type Typ with
779 -- expression N as actual parameter. Decls is the declarations list
780 -- for an appropriate enclosing scope of the point where the call
781 -- will be inserted; if the From_Any attribute for Typ needs to be
782 -- generated at this point, its declaration is appended to Decls.
784 procedure Build_From_Any_Function
788 Fnam : out Entity_Id);
789 -- Build From_Any attribute function for Typ. Loc is the reference
790 -- location for generated nodes, Typ is the type for which the
791 -- conversion function is generated. On return, Decl and Fnam contain
792 -- the declaration and entity for the newly-created function.
794 function Build_To_Any_Call
796 Decls : List_Id) return Node_Id;
797 -- Build call to To_Any attribute function with expression as actual
798 -- parameter. Decls is the declarations list for an appropriate
799 -- enclosing scope of the point where the call will be inserted; if
800 -- the To_Any attribute for Typ needs to be generated at this point,
801 -- its declaration is appended to Decls.
803 procedure Build_To_Any_Function
807 Fnam : out Entity_Id);
808 -- Build To_Any attribute function for Typ. Loc is the reference
809 -- location for generated nodes, Typ is the type for which the
810 -- conversion function is generated. On return, Decl and Fnam contain
811 -- the declaration and entity for the newly-created function.
813 function Build_TypeCode_Call
816 Decls : List_Id) return Node_Id;
817 -- Build call to TypeCode attribute function for Typ. Decls is the
818 -- declarations list for an appropriate enclosing scope of the point
819 -- where the call will be inserted; if the To_Any attribute for Typ
820 -- needs to be generated at this point, its declaration is appended
823 procedure Build_TypeCode_Function
827 Fnam : out Entity_Id);
828 -- Build TypeCode attribute function for Typ. Loc is the reference
829 -- location for generated nodes, Typ is the type for which the
830 -- conversion function is generated. On return, Decl and Fnam contain
831 -- the declaration and entity for the newly-created function.
833 procedure Build_Name_And_Repository_Id
835 Name_Str : out String_Id;
836 Repo_Id_Str : out String_Id);
837 -- In the PolyORB distribution model, each distributed object type
838 -- and each distributed operation has a globally unique identifier,
839 -- its Repository Id. This subprogram builds and returns two strings
840 -- for entity E (a distributed object type or operation): one
841 -- containing the name of E, the second containing its repository id.
847 ------------------------------------
848 -- Local variables and structures --
849 ------------------------------------
852 -- Needs comments ???
854 Output_From_Constrained : constant array (Boolean) of Name_Id :=
855 (False => Name_Output,
857 -- The attribute to choose depending on the fact that the parameter
858 -- is constrained or not. There is no such thing as Input_From_Constrained
859 -- since this require separate mechanisms ('Input is a function while
860 -- 'Read is a procedure).
862 ---------------------------------------
863 -- Add_Calling_Stubs_To_Declarations --
864 ---------------------------------------
866 procedure Add_Calling_Stubs_To_Declarations
870 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
871 -- Subprogram id 0 is reserved for calls received from
872 -- remote access-to-subprogram dereferences.
874 Current_Declaration : Node_Id;
875 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
876 RCI_Instantiation : Node_Id;
877 Subp_Stubs : Node_Id;
878 Subp_Str : String_Id;
881 -- The first thing added is an instantiation of the generic package
882 -- System.Partition_Interface.RCI_Locator with the name of this
883 -- remote package. This will act as an interface with the name server
884 -- to determine the Partition_ID and the RPC_Receiver for the
885 -- receiver of this package.
887 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
888 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
890 Append_To (Decls, RCI_Instantiation);
891 Analyze (RCI_Instantiation);
893 -- For each subprogram declaration visible in the spec, we do
894 -- build a body. We also increment a counter to assign a different
895 -- Subprogram_Id to each subprograms. The receiving stubs processing
896 -- do use the same mechanism and will thus assign the same Id and
897 -- do the correct dispatching.
899 Overload_Counter_Table.Reset;
900 PolyORB_Support.Reserve_NamingContext_Methods;
902 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
904 while Present (Current_Declaration) loop
905 if Nkind (Current_Declaration) = N_Subprogram_Declaration
906 and then Comes_From_Source (Current_Declaration)
908 Assign_Subprogram_Identifier (
909 Defining_Unit_Name (Specification (Current_Declaration)),
910 Current_Subprogram_Number,
914 Build_Subprogram_Calling_Stubs (
915 Vis_Decl => Current_Declaration,
917 Build_Subprogram_Id (Loc,
918 Defining_Unit_Name (Specification (Current_Declaration))),
920 Nkind (Specification (Current_Declaration)) =
921 N_Procedure_Specification
923 Is_Asynchronous (Defining_Unit_Name (Specification
924 (Current_Declaration))));
926 Append_To (Decls, Subp_Stubs);
927 Analyze (Subp_Stubs);
929 Current_Subprogram_Number := Current_Subprogram_Number + 1;
932 Next (Current_Declaration);
934 end Add_Calling_Stubs_To_Declarations;
936 -----------------------------
937 -- Add_Parameter_To_NVList --
938 -----------------------------
940 function Add_Parameter_To_NVList
943 Parameter : Entity_Id;
944 Constrained : Boolean;
945 RACW_Ctrl : Boolean := False;
946 Any : Entity_Id) return Node_Id
948 Parameter_Name_String : String_Id;
949 Parameter_Mode : Node_Id;
951 function Parameter_Passing_Mode
953 Parameter : Entity_Id;
954 Constrained : Boolean) return Node_Id;
955 -- Return an expression that denotes the parameter passing
956 -- mode to be used for Parameter in distribution stubs,
957 -- where Constrained is Parameter's constrained status.
959 ----------------------------
960 -- Parameter_Passing_Mode --
961 ----------------------------
963 function Parameter_Passing_Mode
965 Parameter : Entity_Id;
966 Constrained : Boolean) return Node_Id
971 if Out_Present (Parameter) then
972 if In_Present (Parameter)
973 or else not Constrained
975 -- Unconstrained formals must be translated
976 -- to 'in' or 'inout', not 'out', because
977 -- they need to be constrained by the actual.
979 Lib_RE := RE_Mode_Inout;
981 Lib_RE := RE_Mode_Out;
985 Lib_RE := RE_Mode_In;
988 return New_Occurrence_Of (RTE (Lib_RE), Loc);
989 end Parameter_Passing_Mode;
991 -- Start of processing for Add_Parameter_To_NVList
994 if Nkind (Parameter) = N_Defining_Identifier then
995 Get_Name_String (Chars (Parameter));
997 Get_Name_String (Chars (Defining_Identifier
1001 Parameter_Name_String := String_From_Name_Buffer;
1003 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1005 -- When the parameter passed to Add_Parameter_To_NVList is an
1006 -- Extra_Constrained parameter, Parameter is an N_Defining_
1007 -- Identifier, instead of a complete N_Parameter_Specification.
1008 -- Thus, we explicitly set 'in' mode in this case.
1010 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1013 Parameter_Mode := Parameter_Passing_Mode (Loc,
1014 Parameter, Constrained);
1018 Make_Procedure_Call_Statement (Loc,
1021 (RTE (RE_NVList_Add_Item), Loc),
1022 Parameter_Associations => New_List (
1023 New_Occurrence_Of (NVList, Loc),
1024 Make_Function_Call (Loc,
1027 (RTE (RE_To_PolyORB_String), Loc),
1028 Parameter_Associations => New_List (
1029 Make_String_Literal (Loc,
1030 Strval => Parameter_Name_String))),
1031 New_Occurrence_Of (Any, Loc),
1033 end Add_Parameter_To_NVList;
1035 --------------------------------
1036 -- Add_RACW_Asynchronous_Flag --
1037 --------------------------------
1039 procedure Add_RACW_Asynchronous_Flag
1040 (Declarations : List_Id;
1041 RACW_Type : Entity_Id)
1043 Loc : constant Source_Ptr := Sloc (RACW_Type);
1045 Asynchronous_Flag : constant Entity_Id :=
1046 Make_Defining_Identifier (Loc,
1047 New_External_Name (Chars (RACW_Type), 'A'));
1050 -- Declare the asynchronous flag. This flag will be changed to True
1051 -- whenever it is known that the RACW type is asynchronous.
1053 Append_To (Declarations,
1054 Make_Object_Declaration (Loc,
1055 Defining_Identifier => Asynchronous_Flag,
1056 Constant_Present => True,
1057 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1058 Expression => New_Occurrence_Of (Standard_False, Loc)));
1060 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1061 end Add_RACW_Asynchronous_Flag;
1063 -----------------------
1064 -- Add_RACW_Features --
1065 -----------------------
1067 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1068 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1069 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1073 Body_Decls : List_Id;
1075 Stub_Type : Entity_Id;
1076 Stub_Type_Access : Entity_Id;
1077 RPC_Receiver_Decl : Node_Id;
1080 -- True when appropriate stubs have already been generated (this is the
1081 -- case when another RACW with the same designated type has already been
1082 -- encountered, in which case we reuse the previous stubs rather than
1083 -- generating new ones).
1086 if not Expander_Active then
1090 -- Mark the current package declaration as containing an RACW, so that
1091 -- the bodies for the calling stubs and the RACW stream subprograms
1092 -- are attached to the tree when the corresponding body is encountered.
1094 Set_Has_RACW (Current_Scope);
1096 -- Look for place to declare the RACW stub type and RACW operations
1102 -- Case of declaring the RACW in the same package as its designated
1103 -- type: we know that the designated type is a private type, so we
1104 -- use the private declarations list.
1106 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1108 if Present (Private_Declarations (Pkg_Spec)) then
1109 Decls := Private_Declarations (Pkg_Spec);
1111 Decls := Visible_Declarations (Pkg_Spec);
1116 -- Case of declaring the RACW in another package than its designated
1117 -- type: use the private declarations list if present; otherwise
1118 -- use the visible declarations.
1120 Decls := List_Containing (Declaration_Node (RACW_Type));
1124 -- If we were unable to find the declarations, that means that the
1125 -- completion of the type was missing. We can safely return and let the
1126 -- error be caught by the semantic analysis.
1133 (Designated_Type => Desig,
1134 RACW_Type => RACW_Type,
1136 Stub_Type => Stub_Type,
1137 Stub_Type_Access => Stub_Type_Access,
1138 RPC_Receiver_Decl => RPC_Receiver_Decl,
1139 Body_Decls => Body_Decls,
1140 Existing => Existing);
1142 Add_RACW_Asynchronous_Flag
1143 (Declarations => Decls,
1144 RACW_Type => RACW_Type);
1146 Specific_Add_RACW_Features
1147 (RACW_Type => RACW_Type,
1149 Stub_Type => Stub_Type,
1150 Stub_Type_Access => Stub_Type_Access,
1151 RPC_Receiver_Decl => RPC_Receiver_Decl,
1152 Body_Decls => Body_Decls);
1154 if not Same_Scope and then not Existing then
1156 -- The RACW has been declared in another scope than the designated
1157 -- type and has not been handled by another RACW in the same package
1158 -- as the first one, so add primitives for the stub type here.
1160 Validate_RACW_Primitives (RACW_Type);
1161 Add_RACW_Primitive_Declarations_And_Bodies
1162 (Designated_Type => Desig,
1163 Insertion_Node => RPC_Receiver_Decl,
1164 Body_Decls => Body_Decls);
1167 -- Validate_RACW_Primitives will be called when the designated type
1168 -- is frozen, see Exp_Ch3.Freeze_Type.
1169 -- ??? Shouldn't we have a pragma Assert (not Is_Frozen (Desig))?
1171 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1173 end Add_RACW_Features;
1175 ------------------------------------------------
1176 -- Add_RACW_Primitive_Declarations_And_Bodies --
1177 ------------------------------------------------
1179 procedure Add_RACW_Primitive_Declarations_And_Bodies
1180 (Designated_Type : Entity_Id;
1181 Insertion_Node : Node_Id;
1182 Body_Decls : List_Id)
1184 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1185 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1186 -- the declarations are recognized as belonging to the current package.
1188 Stub_Elements : constant Stub_Structure :=
1189 Stubs_Table.Get (Designated_Type);
1191 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1193 Is_RAS : constant Boolean :=
1194 not Comes_From_Source (Stub_Elements.RACW_Type);
1195 -- Case of the RACW generated to implement a remote access-to-
1198 Build_Bodies : constant Boolean :=
1199 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1200 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1201 -- only when the main unit is the unit that contains the stub type.
1203 Current_Insertion_Node : Node_Id := Insertion_Node;
1205 RPC_Receiver : Entity_Id;
1206 RPC_Receiver_Statements : List_Id;
1207 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1208 RPC_Receiver_Elsif_Parts : List_Id;
1209 RPC_Receiver_Request : Entity_Id;
1210 RPC_Receiver_Subp_Id : Entity_Id;
1211 RPC_Receiver_Subp_Index : Entity_Id;
1213 Subp_Str : String_Id;
1215 Current_Primitive_Elmt : Elmt_Id;
1216 Current_Primitive : Entity_Id;
1217 Current_Primitive_Body : Node_Id;
1218 Current_Primitive_Spec : Node_Id;
1219 Current_Primitive_Decl : Node_Id;
1220 Current_Primitive_Number : Int := 0;
1222 Current_Primitive_Alias : Node_Id;
1224 Current_Receiver : Entity_Id;
1225 Current_Receiver_Body : Node_Id;
1227 RPC_Receiver_Decl : Node_Id;
1229 Possibly_Asynchronous : Boolean;
1232 if not Expander_Active then
1237 RPC_Receiver := Make_Defining_Identifier (Loc,
1238 New_Internal_Name ('P'));
1239 Specific_Build_RPC_Receiver_Body (
1240 RPC_Receiver => RPC_Receiver,
1241 Request => RPC_Receiver_Request,
1242 Subp_Id => RPC_Receiver_Subp_Id,
1243 Subp_Index => RPC_Receiver_Subp_Index,
1244 Stmts => RPC_Receiver_Statements,
1245 Decl => RPC_Receiver_Decl);
1247 if Get_PCS_Name = Name_PolyORB_DSA then
1249 -- For the case of PolyORB, we need to map a textual operation
1250 -- name into a primitive index. Currently we do so using a simple
1251 -- sequence of string comparisons.
1253 RPC_Receiver_Elsif_Parts := New_List;
1257 -- Build callers, receivers for every primitive operations and a RPC
1258 -- receiver for this type.
1260 if Present (Primitive_Operations (Designated_Type)) then
1261 Overload_Counter_Table.Reset;
1263 Current_Primitive_Elmt :=
1264 First_Elmt (Primitive_Operations (Designated_Type));
1265 while Current_Primitive_Elmt /= No_Elmt loop
1266 Current_Primitive := Node (Current_Primitive_Elmt);
1268 -- Copy the primitive of all the parents, except predefined ones
1269 -- that are not remotely dispatching.
1271 if Chars (Current_Primitive) /= Name_uSize
1272 and then Chars (Current_Primitive) /= Name_uAlignment
1274 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1275 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1276 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1277 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1278 Is_TSS (Current_Primitive, TSS_Stream_Write))
1280 -- The first thing to do is build an up-to-date copy of the
1281 -- spec with all the formals referencing Designated_Type
1282 -- transformed into formals referencing Stub_Type. Since this
1283 -- primitive may have been inherited, go back the alias chain
1284 -- until the real primitive has been found.
1286 Current_Primitive_Alias := Current_Primitive;
1287 while Present (Alias (Current_Primitive_Alias)) loop
1289 (Current_Primitive_Alias
1290 /= Alias (Current_Primitive_Alias));
1291 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
1294 -- Copy the spec from the original declaration for the purpose
1295 -- of declaring an overriding subprogram: we need to replace
1296 -- the type of each controlling formal with Stub_Type. The
1297 -- primitive may have been declared for Designated_Type or
1298 -- inherited from some ancestor type for which we do not have
1299 -- an easily determined Entity_Id. We have no systematic way
1300 -- of knowing which type to substitute Stub_Type for. Instead,
1301 -- Copy_Specification relies on the flag Is_Controlling_Formal
1302 -- to determine which formals to change.
1304 Current_Primitive_Spec :=
1305 Copy_Specification (Loc,
1306 Spec => Parent (Current_Primitive_Alias),
1307 Ctrl_Type => Stub_Elements.Stub_Type);
1309 Current_Primitive_Decl :=
1310 Make_Subprogram_Declaration (Loc,
1311 Specification => Current_Primitive_Spec);
1313 Insert_After_And_Analyze (Current_Insertion_Node,
1314 Current_Primitive_Decl);
1315 Current_Insertion_Node := Current_Primitive_Decl;
1317 Possibly_Asynchronous :=
1318 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1319 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1321 Assign_Subprogram_Identifier (
1322 Defining_Unit_Name (Current_Primitive_Spec),
1323 Current_Primitive_Number,
1326 if Build_Bodies then
1327 Current_Primitive_Body :=
1328 Build_Subprogram_Calling_Stubs
1329 (Vis_Decl => Current_Primitive_Decl,
1331 Build_Subprogram_Id (Loc,
1332 Defining_Unit_Name (Current_Primitive_Spec)),
1333 Asynchronous => Possibly_Asynchronous,
1334 Dynamically_Asynchronous => Possibly_Asynchronous,
1335 Stub_Type => Stub_Elements.Stub_Type,
1336 RACW_Type => Stub_Elements.RACW_Type);
1337 Append_To (Body_Decls, Current_Primitive_Body);
1339 -- Analyzing the body here would cause the Stub type to be
1340 -- frozen, thus preventing subsequent primitive
1341 -- declarations. For this reason, it will be analyzed later
1342 -- in the regular flow (and in the context of the
1343 -- appropriate unit body, see Append_RACW_Bodies).
1347 -- Build the receiver stubs
1349 if Build_Bodies and then not Is_RAS then
1350 Current_Receiver_Body :=
1351 Specific_Build_Subprogram_Receiving_Stubs
1352 (Vis_Decl => Current_Primitive_Decl,
1353 Asynchronous => Possibly_Asynchronous,
1354 Dynamically_Asynchronous => Possibly_Asynchronous,
1355 Stub_Type => Stub_Elements.Stub_Type,
1356 RACW_Type => Stub_Elements.RACW_Type,
1357 Parent_Primitive => Current_Primitive);
1359 Current_Receiver := Defining_Unit_Name (
1360 Specification (Current_Receiver_Body));
1362 Append_To (Body_Decls, Current_Receiver_Body);
1364 -- Add a case alternative to the receiver
1366 if Get_PCS_Name = Name_PolyORB_DSA then
1367 Append_To (RPC_Receiver_Elsif_Parts,
1368 Make_Elsif_Part (Loc,
1370 Make_Function_Call (Loc,
1373 RTE (RE_Caseless_String_Eq), Loc),
1374 Parameter_Associations => New_List (
1375 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1376 Make_String_Literal (Loc, Subp_Str))),
1377 Then_Statements => New_List (
1378 Make_Assignment_Statement (Loc,
1379 Name => New_Occurrence_Of (
1380 RPC_Receiver_Subp_Index, Loc),
1382 Make_Integer_Literal (Loc,
1383 Current_Primitive_Number)))));
1386 Append_To (RPC_Receiver_Case_Alternatives,
1387 Make_Case_Statement_Alternative (Loc,
1388 Discrete_Choices => New_List (
1389 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1391 Statements => New_List (
1392 Make_Procedure_Call_Statement (Loc,
1394 New_Occurrence_Of (Current_Receiver, Loc),
1395 Parameter_Associations => New_List (
1396 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1399 -- Increment the index of current primitive
1401 Current_Primitive_Number := Current_Primitive_Number + 1;
1404 Next_Elmt (Current_Primitive_Elmt);
1408 -- Build the case statement and the heart of the subprogram
1410 if Build_Bodies and then not Is_RAS then
1411 if Get_PCS_Name = Name_PolyORB_DSA
1412 and then Present (First (RPC_Receiver_Elsif_Parts))
1414 Append_To (RPC_Receiver_Statements,
1415 Make_Implicit_If_Statement (Designated_Type,
1416 Condition => New_Occurrence_Of (Standard_False, Loc),
1417 Then_Statements => New_List,
1418 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1421 Append_To (RPC_Receiver_Case_Alternatives,
1422 Make_Case_Statement_Alternative (Loc,
1423 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1424 Statements => New_List (Make_Null_Statement (Loc))));
1426 Append_To (RPC_Receiver_Statements,
1427 Make_Case_Statement (Loc,
1429 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1430 Alternatives => RPC_Receiver_Case_Alternatives));
1432 Append_To (Body_Decls, RPC_Receiver_Decl);
1433 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1434 Body_Decls, RPC_Receiver, Stub_Elements);
1436 -- Do not analyze RPC receiver body at this stage since it references
1437 -- subprograms that have not been analyzed yet. It will be analyzed in
1438 -- the regular flow (see Append_RACW_Bodies).
1441 end Add_RACW_Primitive_Declarations_And_Bodies;
1443 -----------------------------
1444 -- Add_RAS_Dereference_TSS --
1445 -----------------------------
1447 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1448 Loc : constant Source_Ptr := Sloc (N);
1450 Type_Def : constant Node_Id := Type_Definition (N);
1452 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1453 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1454 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1455 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1457 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
1458 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1460 RACW_Primitive_Name : Node_Id;
1462 Proc : constant Entity_Id :=
1463 Make_Defining_Identifier (Loc,
1464 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1466 Proc_Spec : Node_Id;
1467 Param_Specs : List_Id;
1468 Param_Assoc : constant List_Id := New_List;
1469 Stmts : constant List_Id := New_List;
1471 RAS_Parameter : constant Entity_Id :=
1472 Make_Defining_Identifier (Loc,
1473 Chars => New_Internal_Name ('P'));
1475 Is_Function : constant Boolean :=
1476 Nkind (Type_Def) = N_Access_Function_Definition;
1478 Is_Degenerate : Boolean;
1479 -- Set to True if the subprogram_specification for this RAS has an
1480 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1482 Spec : constant Node_Id := Type_Def;
1484 Current_Parameter : Node_Id;
1486 -- Start of processing for Add_RAS_Dereference_TSS
1489 -- The Dereference TSS for a remote access-to-subprogram type has the
1492 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1495 -- This is called whenever a value of a RAS type is dereferenced
1497 -- First construct a list of parameter specifications:
1499 -- The first formal is the RAS values
1501 Param_Specs := New_List (
1502 Make_Parameter_Specification (Loc,
1503 Defining_Identifier => RAS_Parameter,
1506 New_Occurrence_Of (Fat_Type, Loc)));
1508 -- The following formals are copied from the type declaration
1510 Is_Degenerate := False;
1511 Current_Parameter := First (Parameter_Specifications (Type_Def));
1512 Parameters : while Present (Current_Parameter) loop
1513 if Nkind (Parameter_Type (Current_Parameter)) =
1516 Is_Degenerate := True;
1519 Append_To (Param_Specs,
1520 Make_Parameter_Specification (Loc,
1521 Defining_Identifier =>
1522 Make_Defining_Identifier (Loc,
1523 Chars => Chars (Defining_Identifier (Current_Parameter))),
1524 In_Present => In_Present (Current_Parameter),
1525 Out_Present => Out_Present (Current_Parameter),
1527 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1529 New_Copy_Tree (Expression (Current_Parameter))));
1531 Append_To (Param_Assoc,
1532 Make_Identifier (Loc,
1533 Chars => Chars (Defining_Identifier (Current_Parameter))));
1535 Next (Current_Parameter);
1536 end loop Parameters;
1538 if Is_Degenerate then
1539 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1541 -- Generate a dummy body. This code will never actually be executed,
1542 -- because null is the only legal value for a degenerate RAS type.
1543 -- For legality's sake (in order to avoid generating a function
1544 -- that does not contain a return statement), we include a dummy
1545 -- recursive call on the TSS itself.
1548 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1549 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1552 -- For a normal RAS type, we cast the RAS formal to the corresponding
1553 -- tagged type, and perform a dispatching call to its Call primitive
1556 Prepend_To (Param_Assoc,
1557 Unchecked_Convert_To (RACW_Type,
1558 New_Occurrence_Of (RAS_Parameter, Loc)));
1560 RACW_Primitive_Name :=
1561 Make_Selected_Component (Loc,
1562 Prefix => Scope (RACW_Type),
1563 Selector_Name => Name_uCall);
1568 Make_Return_Statement (Loc,
1570 Make_Function_Call (Loc,
1571 Name => RACW_Primitive_Name,
1572 Parameter_Associations => Param_Assoc)));
1576 Make_Procedure_Call_Statement (Loc,
1577 Name => RACW_Primitive_Name,
1578 Parameter_Associations => Param_Assoc));
1581 -- Build the complete subprogram
1585 Make_Function_Specification (Loc,
1586 Defining_Unit_Name => Proc,
1587 Parameter_Specifications => Param_Specs,
1588 Result_Definition =>
1590 Entity (Result_Definition (Spec)), Loc));
1592 Set_Ekind (Proc, E_Function);
1594 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1598 Make_Procedure_Specification (Loc,
1599 Defining_Unit_Name => Proc,
1600 Parameter_Specifications => Param_Specs);
1602 Set_Ekind (Proc, E_Procedure);
1603 Set_Etype (Proc, Standard_Void_Type);
1607 Make_Subprogram_Body (Loc,
1608 Specification => Proc_Spec,
1609 Declarations => New_List,
1610 Handled_Statement_Sequence =>
1611 Make_Handled_Sequence_Of_Statements (Loc,
1612 Statements => Stmts)));
1614 Set_TSS (Fat_Type, Proc);
1615 end Add_RAS_Dereference_TSS;
1617 -------------------------------
1618 -- Add_RAS_Proxy_And_Analyze --
1619 -------------------------------
1621 procedure Add_RAS_Proxy_And_Analyze
1624 All_Calls_Remote_E : Entity_Id;
1625 Proxy_Object_Addr : out Entity_Id)
1627 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1629 Subp_Name : constant Entity_Id :=
1630 Defining_Unit_Name (Specification (Vis_Decl));
1632 Pkg_Name : constant Entity_Id :=
1633 Make_Defining_Identifier (Loc,
1635 New_External_Name (Chars (Subp_Name), 'P', -1));
1637 Proxy_Type : constant Entity_Id :=
1638 Make_Defining_Identifier (Loc,
1641 Related_Id => Chars (Subp_Name),
1644 Proxy_Type_Full_View : constant Entity_Id :=
1645 Make_Defining_Identifier (Loc,
1646 Chars (Proxy_Type));
1648 Subp_Decl_Spec : constant Node_Id :=
1649 Build_RAS_Primitive_Specification
1650 (Subp_Spec => Specification (Vis_Decl),
1651 Remote_Object_Type => Proxy_Type);
1653 Subp_Body_Spec : constant Node_Id :=
1654 Build_RAS_Primitive_Specification
1655 (Subp_Spec => Specification (Vis_Decl),
1656 Remote_Object_Type => Proxy_Type);
1658 Vis_Decls : constant List_Id := New_List;
1659 Pvt_Decls : constant List_Id := New_List;
1660 Actuals : constant List_Id := New_List;
1662 Perform_Call : Node_Id;
1665 -- type subpP is tagged limited private;
1667 Append_To (Vis_Decls,
1668 Make_Private_Type_Declaration (Loc,
1669 Defining_Identifier => Proxy_Type,
1670 Tagged_Present => True,
1671 Limited_Present => True));
1673 -- [subprogram] Call
1674 -- (Self : access subpP;
1675 -- ...other-formals...)
1678 Append_To (Vis_Decls,
1679 Make_Subprogram_Declaration (Loc,
1680 Specification => Subp_Decl_Spec));
1682 -- A : constant System.Address;
1684 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1686 Append_To (Vis_Decls,
1687 Make_Object_Declaration (Loc,
1688 Defining_Identifier =>
1692 Object_Definition =>
1693 New_Occurrence_Of (RTE (RE_Address), Loc)));
1697 -- type subpP is tagged limited record
1698 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1702 Append_To (Pvt_Decls,
1703 Make_Full_Type_Declaration (Loc,
1704 Defining_Identifier =>
1705 Proxy_Type_Full_View,
1707 Build_Remote_Subprogram_Proxy_Type (Loc,
1708 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1710 -- Trick semantic analysis into swapping the public and full view when
1711 -- freezing the public view.
1713 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1716 -- (Self : access O;
1717 -- ...other-formals...) is
1719 -- P (...other-formals...);
1723 -- (Self : access O;
1724 -- ...other-formals...)
1727 -- return F (...other-formals...);
1730 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1732 Make_Procedure_Call_Statement (Loc,
1734 New_Occurrence_Of (Subp_Name, Loc),
1735 Parameter_Associations =>
1739 Make_Return_Statement (Loc,
1741 Make_Function_Call (Loc,
1743 New_Occurrence_Of (Subp_Name, Loc),
1744 Parameter_Associations =>
1748 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1749 pragma Assert (Present (Formal));
1752 exit when No (Formal);
1754 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1757 -- O : aliased subpP;
1759 Append_To (Pvt_Decls,
1760 Make_Object_Declaration (Loc,
1761 Defining_Identifier =>
1762 Make_Defining_Identifier (Loc,
1766 Object_Definition =>
1767 New_Occurrence_Of (Proxy_Type, Loc)));
1769 -- A : constant System.Address := O'Address;
1771 Append_To (Pvt_Decls,
1772 Make_Object_Declaration (Loc,
1773 Defining_Identifier =>
1774 Make_Defining_Identifier (Loc,
1775 Chars (Proxy_Object_Addr)),
1778 Object_Definition =>
1779 New_Occurrence_Of (RTE (RE_Address), Loc),
1781 Make_Attribute_Reference (Loc,
1782 Prefix => New_Occurrence_Of (
1783 Defining_Identifier (Last (Pvt_Decls)), Loc),
1788 Make_Package_Declaration (Loc,
1789 Specification => Make_Package_Specification (Loc,
1790 Defining_Unit_Name => Pkg_Name,
1791 Visible_Declarations => Vis_Decls,
1792 Private_Declarations => Pvt_Decls,
1793 End_Label => Empty)));
1794 Analyze (Last (Decls));
1797 Make_Package_Body (Loc,
1798 Defining_Unit_Name =>
1799 Make_Defining_Identifier (Loc,
1801 Declarations => New_List (
1802 Make_Subprogram_Body (Loc,
1805 Declarations => New_List,
1806 Handled_Statement_Sequence =>
1807 Make_Handled_Sequence_Of_Statements (Loc,
1808 Statements => New_List (Perform_Call))))));
1809 Analyze (Last (Decls));
1810 end Add_RAS_Proxy_And_Analyze;
1812 -----------------------
1813 -- Add_RAST_Features --
1814 -----------------------
1816 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1817 RAS_Type : constant Entity_Id :=
1818 Equivalent_Type (Defining_Identifier (Vis_Decl));
1820 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1821 Add_RAS_Dereference_TSS (Vis_Decl);
1822 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1823 end Add_RAST_Features;
1829 procedure Add_Stub_Type
1830 (Designated_Type : Entity_Id;
1831 RACW_Type : Entity_Id;
1833 Stub_Type : out Entity_Id;
1834 Stub_Type_Access : out Entity_Id;
1835 RPC_Receiver_Decl : out Node_Id;
1836 Body_Decls : out List_Id;
1837 Existing : out Boolean)
1839 Loc : constant Source_Ptr := Sloc (RACW_Type);
1841 Stub_Elements : constant Stub_Structure :=
1842 Stubs_Table.Get (Designated_Type);
1843 Stub_Type_Decl : Node_Id;
1844 Stub_Type_Access_Decl : Node_Id;
1847 if Stub_Elements /= Empty_Stub_Structure then
1848 Stub_Type := Stub_Elements.Stub_Type;
1849 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1850 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1851 Body_Decls := Stub_Elements.Body_Decls;
1858 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1860 Make_Defining_Identifier (Loc,
1862 Related_Id => Chars (Stub_Type),
1865 Specific_Build_Stub_Type (
1866 RACW_Type, Stub_Type,
1867 Stub_Type_Decl, RPC_Receiver_Decl);
1869 Stub_Type_Access_Decl :=
1870 Make_Full_Type_Declaration (Loc,
1871 Defining_Identifier => Stub_Type_Access,
1873 Make_Access_To_Object_Definition (Loc,
1874 All_Present => True,
1875 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1877 Append_To (Decls, Stub_Type_Decl);
1878 Analyze (Last (Decls));
1879 Append_To (Decls, Stub_Type_Access_Decl);
1880 Analyze (Last (Decls));
1882 -- This is in no way a type derivation, but we fake it to make sure that
1883 -- the dispatching table gets built with the corresponding primitive
1884 -- operations at the right place.
1886 Derive_Subprograms (Parent_Type => Designated_Type,
1887 Derived_Type => Stub_Type);
1889 if Present (RPC_Receiver_Decl) then
1890 Append_To (Decls, RPC_Receiver_Decl);
1892 RPC_Receiver_Decl := Last (Decls);
1895 Body_Decls := New_List;
1897 Stubs_Table.Set (Designated_Type,
1898 (Stub_Type => Stub_Type,
1899 Stub_Type_Access => Stub_Type_Access,
1900 RPC_Receiver_Decl => RPC_Receiver_Decl,
1901 Body_Decls => Body_Decls,
1902 RACW_Type => RACW_Type));
1905 ------------------------
1906 -- Append_RACW_Bodies --
1907 ------------------------
1909 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
1913 E := First_Entity (Spec_Id);
1914 while Present (E) loop
1915 if Is_Remote_Access_To_Class_Wide_Type (E) then
1916 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
1921 end Append_RACW_Bodies;
1923 ----------------------------------
1924 -- Assign_Subprogram_Identifier --
1925 ----------------------------------
1927 procedure Assign_Subprogram_Identifier
1932 N : constant Name_Id := Chars (Def);
1934 Overload_Order : constant Int :=
1935 Overload_Counter_Table.Get (N) + 1;
1938 Overload_Counter_Table.Set (N, Overload_Order);
1940 Get_Name_String (N);
1942 -- Homonym handling: as in Exp_Dbug, but much simpler,
1943 -- because the only entities for which we have to generate
1944 -- names here need only to be disambiguated within their
1947 if Overload_Order > 1 then
1948 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
1949 Name_Len := Name_Len + 2;
1950 Add_Nat_To_Name_Buffer (Overload_Order);
1953 Id := String_From_Name_Buffer;
1954 Subprogram_Identifier_Table.Set (Def,
1955 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
1956 end Assign_Subprogram_Identifier;
1958 -------------------------------------
1959 -- Build_Actual_Object_Declaration --
1960 -------------------------------------
1962 procedure Build_Actual_Object_Declaration
1963 (Object : Entity_Id;
1969 Loc : constant Source_Ptr := Sloc (Object);
1971 -- Declare a temporary object for the actual, possibly initialized with
1972 -- a 'Input/From_Any call.
1974 -- Complication arises in the case of limited types, for which such a
1975 -- declaration is illegal in Ada 95. In that case, we first generate a
1976 -- renaming declaration of the 'Input call, and then if needed we
1977 -- generate an overlaid non-constant view.
1979 if Ada_Version <= Ada_95
1980 and then Is_Limited_Type (Etyp)
1981 and then Present (Expr)
1984 -- Object : Etyp renames <func-call>
1987 Make_Object_Renaming_Declaration (Loc,
1988 Defining_Identifier => Object,
1989 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
1994 -- The name defined by the renaming declaration denotes a
1995 -- constant view; create a non-constant object at the same address
1996 -- to be used as the actual.
1999 Constant_Object : constant Entity_Id :=
2000 Make_Defining_Identifier (Loc,
2001 New_Internal_Name ('P'));
2003 Set_Defining_Identifier
2004 (Last (Decls), Constant_Object);
2006 -- We have an unconstrained Etyp: build the actual constrained
2007 -- subtype for the value we just read from the stream.
2009 -- suubtype S is <actual subtype of Constant_Object>;
2012 Build_Actual_Subtype (Etyp,
2013 New_Occurrence_Of (Constant_Object, Loc)));
2018 Make_Object_Declaration (Loc,
2019 Defining_Identifier => Object,
2020 Object_Definition =>
2022 (Defining_Identifier (Last (Decls)), Loc)));
2023 Set_Ekind (Object, E_Variable);
2025 -- Suppress default initialization:
2026 -- pragma Import (Ada, Object);
2030 Chars => Name_Import,
2031 Pragma_Argument_Associations => New_List (
2032 Make_Pragma_Argument_Association (Loc,
2033 Chars => Name_Convention,
2034 Expression => Make_Identifier (Loc, Name_Ada)),
2035 Make_Pragma_Argument_Association (Loc,
2036 Chars => Name_Entity,
2037 Expression => New_Occurrence_Of (Object, Loc)))));
2039 -- for Object'Address use Constant_Object'Address;
2042 Make_Attribute_Definition_Clause (Loc,
2043 Name => New_Occurrence_Of (Object, Loc),
2044 Chars => Name_Address,
2046 Make_Attribute_Reference (Loc,
2048 New_Occurrence_Of (Constant_Object, Loc),
2056 -- General case of a regular object declaration. Object is flagged
2057 -- constant unless it has mode out or in out, to allow the backend
2058 -- to optimize where possible.
2060 -- Object : [constant] Etyp [:= <expr>];
2063 Make_Object_Declaration (Loc,
2064 Defining_Identifier => Object,
2065 Constant_Present => Present (Expr) and then not Variable,
2066 Object_Definition =>
2067 New_Occurrence_Of (Etyp, Loc),
2068 Expression => Expr));
2070 if Constant_Present (Last (Decls)) then
2071 Set_Ekind (Object, E_Constant);
2073 Set_Ekind (Object, E_Variable);
2076 end Build_Actual_Object_Declaration;
2078 ------------------------------
2079 -- Build_Get_Unique_RP_Call --
2080 ------------------------------
2082 function Build_Get_Unique_RP_Call
2084 Pointer : Entity_Id;
2085 Stub_Type : Entity_Id) return List_Id
2089 Make_Procedure_Call_Statement (Loc,
2091 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2092 Parameter_Associations => New_List (
2093 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2094 New_Occurrence_Of (Pointer, Loc)))),
2096 Make_Assignment_Statement (Loc,
2098 Make_Selected_Component (Loc,
2100 New_Occurrence_Of (Pointer, Loc),
2102 New_Occurrence_Of (First_Tag_Component
2103 (Designated_Type (Etype (Pointer))), Loc)),
2105 Make_Attribute_Reference (Loc,
2107 New_Occurrence_Of (Stub_Type, Loc),
2111 -- Note: The assignment to Pointer._Tag is safe here because
2112 -- we carefully ensured that Stub_Type has exactly the same layout
2113 -- as System.Partition_Interface.RACW_Stub_Type.
2115 end Build_Get_Unique_RP_Call;
2117 -----------------------------------
2118 -- Build_Ordered_Parameters_List --
2119 -----------------------------------
2121 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2122 Constrained_List : List_Id;
2123 Unconstrained_List : List_Id;
2124 Current_Parameter : Node_Id;
2126 First_Parameter : Node_Id;
2127 For_RAS : Boolean := False;
2130 if No (Parameter_Specifications (Spec)) then
2134 Constrained_List := New_List;
2135 Unconstrained_List := New_List;
2136 First_Parameter := First (Parameter_Specifications (Spec));
2138 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2139 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2144 -- Loop through the parameters and add them to the right list
2146 Current_Parameter := First_Parameter;
2147 while Present (Current_Parameter) loop
2148 if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
2150 Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
2152 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
2153 and then not (For_RAS and then Current_Parameter = First_Parameter)
2155 Append_To (Constrained_List, New_Copy (Current_Parameter));
2157 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2160 Next (Current_Parameter);
2163 -- Unconstrained parameters are returned first
2165 Append_List_To (Unconstrained_List, Constrained_List);
2167 return Unconstrained_List;
2168 end Build_Ordered_Parameters_List;
2170 ----------------------------------
2171 -- Build_Passive_Partition_Stub --
2172 ----------------------------------
2174 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2176 Pkg_Name : String_Id;
2179 Loc : constant Source_Ptr := Sloc (U);
2182 -- Verify that the implementation supports distribution, by accessing
2183 -- a type defined in the proper version of system.rpc
2186 Dist_OK : Entity_Id;
2187 pragma Warnings (Off, Dist_OK);
2189 Dist_OK := RTE (RE_Params_Stream_Type);
2192 -- Use body if present, spec otherwise
2194 if Nkind (U) = N_Package_Declaration then
2195 Pkg_Spec := Specification (U);
2196 L := Visible_Declarations (Pkg_Spec);
2198 Pkg_Spec := Parent (Corresponding_Spec (U));
2199 L := Declarations (U);
2202 Get_Library_Unit_Name_String (Pkg_Spec);
2203 Pkg_Name := String_From_Name_Buffer;
2205 Make_Procedure_Call_Statement (Loc,
2207 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2208 Parameter_Associations => New_List (
2209 Make_String_Literal (Loc, Pkg_Name),
2210 Make_Attribute_Reference (Loc,
2212 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2217 end Build_Passive_Partition_Stub;
2219 --------------------------------------
2220 -- Build_RPC_Receiver_Specification --
2221 --------------------------------------
2223 function Build_RPC_Receiver_Specification
2224 (RPC_Receiver : Entity_Id;
2225 Request_Parameter : Entity_Id) return Node_Id
2227 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2230 Make_Procedure_Specification (Loc,
2231 Defining_Unit_Name => RPC_Receiver,
2232 Parameter_Specifications => New_List (
2233 Make_Parameter_Specification (Loc,
2234 Defining_Identifier => Request_Parameter,
2236 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2237 end Build_RPC_Receiver_Specification;
2239 ----------------------------------------
2240 -- Build_Remote_Subprogram_Proxy_Type --
2241 ----------------------------------------
2243 function Build_Remote_Subprogram_Proxy_Type
2245 ACR_Expression : Node_Id) return Node_Id
2249 Make_Record_Definition (Loc,
2250 Tagged_Present => True,
2251 Limited_Present => True,
2253 Make_Component_List (Loc,
2255 Component_Items => New_List (
2256 Make_Component_Declaration (Loc,
2257 Defining_Identifier =>
2258 Make_Defining_Identifier (Loc,
2259 Name_All_Calls_Remote),
2260 Component_Definition =>
2261 Make_Component_Definition (Loc,
2262 Subtype_Indication =>
2263 New_Occurrence_Of (Standard_Boolean, Loc)),
2267 Make_Component_Declaration (Loc,
2268 Defining_Identifier =>
2269 Make_Defining_Identifier (Loc,
2271 Component_Definition =>
2272 Make_Component_Definition (Loc,
2273 Subtype_Indication =>
2274 New_Occurrence_Of (RTE (RE_Address), Loc)),
2276 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2278 Make_Component_Declaration (Loc,
2279 Defining_Identifier =>
2280 Make_Defining_Identifier (Loc,
2282 Component_Definition =>
2283 Make_Component_Definition (Loc,
2284 Subtype_Indication =>
2285 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2286 end Build_Remote_Subprogram_Proxy_Type;
2288 ------------------------------------
2289 -- Build_Subprogram_Calling_Stubs --
2290 ------------------------------------
2292 function Build_Subprogram_Calling_Stubs
2293 (Vis_Decl : Node_Id;
2295 Asynchronous : Boolean;
2296 Dynamically_Asynchronous : Boolean := False;
2297 Stub_Type : Entity_Id := Empty;
2298 RACW_Type : Entity_Id := Empty;
2299 Locator : Entity_Id := Empty;
2300 New_Name : Name_Id := No_Name) return Node_Id
2302 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2304 Decls : constant List_Id := New_List;
2305 Statements : constant List_Id := New_List;
2307 Subp_Spec : Node_Id;
2308 -- The specification of the body
2310 Controlling_Parameter : Entity_Id := Empty;
2312 Asynchronous_Expr : Node_Id := Empty;
2314 RCI_Locator : Entity_Id;
2316 Spec_To_Use : Node_Id;
2318 procedure Insert_Partition_Check (Parameter : Node_Id);
2319 -- Check that the parameter has been elaborated on the same partition
2320 -- than the controlling parameter (E.4(19)).
2322 ----------------------------
2323 -- Insert_Partition_Check --
2324 ----------------------------
2326 procedure Insert_Partition_Check (Parameter : Node_Id) is
2327 Parameter_Entity : constant Entity_Id :=
2328 Defining_Identifier (Parameter);
2330 -- The expression that will be built is of the form:
2332 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2333 -- raise Constraint_Error;
2336 -- We do not check that Parameter is in Stub_Type since such a check
2337 -- has been inserted at the point of call already (a tag check since
2338 -- we have multiple controlling operands).
2341 Make_Raise_Constraint_Error (Loc,
2345 Make_Function_Call (Loc,
2347 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2348 Parameter_Associations =>
2350 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2351 New_Occurrence_Of (Parameter_Entity, Loc)),
2352 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2353 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2354 Reason => CE_Partition_Check_Failed));
2355 end Insert_Partition_Check;
2357 -- Start of processing for Build_Subprogram_Calling_Stubs
2360 Subp_Spec := Copy_Specification (Loc,
2361 Spec => Specification (Vis_Decl),
2362 New_Name => New_Name);
2364 if Locator = Empty then
2365 RCI_Locator := RCI_Cache;
2366 Spec_To_Use := Specification (Vis_Decl);
2368 RCI_Locator := Locator;
2369 Spec_To_Use := Subp_Spec;
2372 -- Find a controlling argument if we have a stub type. Also check
2373 -- if this subprogram can be made asynchronous.
2375 if Present (Stub_Type)
2376 and then Present (Parameter_Specifications (Spec_To_Use))
2379 Current_Parameter : Node_Id :=
2380 First (Parameter_Specifications
2383 while Present (Current_Parameter) loop
2385 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2387 if Controlling_Parameter = Empty then
2388 Controlling_Parameter :=
2389 Defining_Identifier (Current_Parameter);
2391 Insert_Partition_Check (Current_Parameter);
2395 Next (Current_Parameter);
2400 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2402 if Dynamically_Asynchronous then
2403 Asynchronous_Expr := Make_Selected_Component (Loc,
2404 Prefix => Controlling_Parameter,
2405 Selector_Name => Name_Asynchronous);
2408 Specific_Build_General_Calling_Stubs
2410 Statements => Statements,
2411 Target => Specific_Build_Stub_Target (Loc,
2412 Decls, RCI_Locator, Controlling_Parameter),
2413 Subprogram_Id => Subp_Id,
2414 Asynchronous => Asynchronous_Expr,
2415 Is_Known_Asynchronous => Asynchronous
2416 and then not Dynamically_Asynchronous,
2417 Is_Known_Non_Asynchronous
2419 and then not Dynamically_Asynchronous,
2420 Is_Function => Nkind (Spec_To_Use) =
2421 N_Function_Specification,
2422 Spec => Spec_To_Use,
2423 Stub_Type => Stub_Type,
2424 RACW_Type => RACW_Type,
2427 RCI_Calling_Stubs_Table.Set
2428 (Defining_Unit_Name (Specification (Vis_Decl)),
2429 Defining_Unit_Name (Spec_To_Use));
2432 Make_Subprogram_Body (Loc,
2433 Specification => Subp_Spec,
2434 Declarations => Decls,
2435 Handled_Statement_Sequence =>
2436 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2437 end Build_Subprogram_Calling_Stubs;
2439 -------------------------
2440 -- Build_Subprogram_Id --
2441 -------------------------
2443 function Build_Subprogram_Id
2445 E : Entity_Id) return Node_Id
2448 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2450 Current_Declaration : Node_Id;
2451 Current_Subp : Entity_Id;
2452 Current_Subp_Str : String_Id;
2453 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2456 -- Build_Subprogram_Id is called outside of the context of
2457 -- generating calling or receiving stubs. Hence we are processing
2458 -- an 'Access attribute_reference for an RCI subprogram, for the
2459 -- purpose of obtaining a RAS value.
2462 (Is_Remote_Call_Interface (Scope (E))
2464 (Nkind (Parent (E)) = N_Procedure_Specification
2466 Nkind (Parent (E)) = N_Function_Specification));
2468 Current_Declaration :=
2469 First (Visible_Declarations
2470 (Package_Specification_Of_Scope (Scope (E))));
2471 while Present (Current_Declaration) loop
2472 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2473 and then Comes_From_Source (Current_Declaration)
2475 Current_Subp := Defining_Unit_Name (Specification (
2476 Current_Declaration));
2478 Assign_Subprogram_Identifier
2479 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2481 Current_Subp_Number := Current_Subp_Number + 1;
2484 Next (Current_Declaration);
2489 case Get_PCS_Name is
2490 when Name_PolyORB_DSA =>
2491 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2493 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2495 end Build_Subprogram_Id;
2497 ------------------------
2498 -- Copy_Specification --
2499 ------------------------
2501 function Copy_Specification
2504 Ctrl_Type : Entity_Id := Empty;
2505 New_Name : Name_Id := No_Name) return Node_Id
2507 Parameters : List_Id := No_List;
2509 Current_Parameter : Node_Id;
2510 Current_Identifier : Entity_Id;
2511 Current_Type : Node_Id;
2513 Name_For_New_Spec : Name_Id;
2515 New_Identifier : Entity_Id;
2517 -- Comments needed in body below ???
2520 if New_Name = No_Name then
2521 pragma Assert (Nkind (Spec) = N_Function_Specification
2522 or else Nkind (Spec) = N_Procedure_Specification);
2524 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2526 Name_For_New_Spec := New_Name;
2529 if Present (Parameter_Specifications (Spec)) then
2530 Parameters := New_List;
2531 Current_Parameter := First (Parameter_Specifications (Spec));
2532 while Present (Current_Parameter) loop
2533 Current_Identifier := Defining_Identifier (Current_Parameter);
2534 Current_Type := Parameter_Type (Current_Parameter);
2536 if Nkind (Current_Type) = N_Access_Definition then
2537 if Present (Ctrl_Type) then
2538 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2540 Make_Access_Definition (Loc,
2541 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2542 Null_Exclusion_Present =>
2543 Null_Exclusion_Present (Current_Type));
2547 Make_Access_Definition (Loc,
2549 New_Copy_Tree (Subtype_Mark (Current_Type)),
2550 Null_Exclusion_Present =>
2551 Null_Exclusion_Present (Current_Type));
2555 if Present (Ctrl_Type)
2556 and then Is_Controlling_Formal (Current_Identifier)
2558 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2560 Current_Type := New_Copy_Tree (Current_Type);
2564 New_Identifier := Make_Defining_Identifier (Loc,
2565 Chars (Current_Identifier));
2567 Append_To (Parameters,
2568 Make_Parameter_Specification (Loc,
2569 Defining_Identifier => New_Identifier,
2570 Parameter_Type => Current_Type,
2571 In_Present => In_Present (Current_Parameter),
2572 Out_Present => Out_Present (Current_Parameter),
2574 New_Copy_Tree (Expression (Current_Parameter))));
2576 -- For a regular formal parameter (that needs to be marshalled
2577 -- in the context of remote calls), set the Etype now, because
2578 -- marshalling processing might need it.
2580 if Is_Entity_Name (Current_Type) then
2581 Set_Etype (New_Identifier, Entity (Current_Type));
2583 -- Current_Type is an access definition, special processing
2584 -- (not requiring etype) will occur for marshalling.
2590 Next (Current_Parameter);
2594 case Nkind (Spec) is
2596 when N_Function_Specification | N_Access_Function_Definition =>
2598 Make_Function_Specification (Loc,
2599 Defining_Unit_Name =>
2600 Make_Defining_Identifier (Loc,
2601 Chars => Name_For_New_Spec),
2602 Parameter_Specifications => Parameters,
2603 Result_Definition =>
2604 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2606 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2608 Make_Procedure_Specification (Loc,
2609 Defining_Unit_Name =>
2610 Make_Defining_Identifier (Loc,
2611 Chars => Name_For_New_Spec),
2612 Parameter_Specifications => Parameters);
2615 raise Program_Error;
2617 end Copy_Specification;
2619 -----------------------------
2620 -- Corresponding_Stub_Type --
2621 -----------------------------
2623 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2624 Desig : constant Entity_Id :=
2625 Etype (Designated_Type (RACW_Type));
2626 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2628 return Stub_Elements.Stub_Type;
2629 end Corresponding_Stub_Type;
2631 ---------------------------
2632 -- Could_Be_Asynchronous --
2633 ---------------------------
2635 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2636 Current_Parameter : Node_Id;
2639 if Present (Parameter_Specifications (Spec)) then
2640 Current_Parameter := First (Parameter_Specifications (Spec));
2641 while Present (Current_Parameter) loop
2642 if Out_Present (Current_Parameter) then
2646 Next (Current_Parameter);
2651 end Could_Be_Asynchronous;
2653 ---------------------------
2654 -- Declare_Create_NVList --
2655 ---------------------------
2657 procedure Declare_Create_NVList
2665 Make_Object_Declaration (Loc,
2666 Defining_Identifier => NVList,
2667 Aliased_Present => False,
2668 Object_Definition =>
2669 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2672 Make_Procedure_Call_Statement (Loc,
2674 New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2675 Parameter_Associations => New_List (
2676 New_Occurrence_Of (NVList, Loc))));
2677 end Declare_Create_NVList;
2679 ---------------------------------------------
2680 -- Expand_All_Calls_Remote_Subprogram_Call --
2681 ---------------------------------------------
2683 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2684 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2685 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2686 Loc : constant Source_Ptr := Sloc (N);
2687 RCI_Locator : Node_Id;
2688 RCI_Cache : Entity_Id;
2689 Calling_Stubs : Node_Id;
2690 E_Calling_Stubs : Entity_Id;
2693 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2695 if E_Calling_Stubs = Empty then
2696 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2698 if RCI_Cache = Empty then
2701 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2702 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2704 -- The RCI_Locator package is inserted at the top level in the
2705 -- current unit, and must appear in the proper scope, so that it
2706 -- is not prematurely removed by the GCC back-end.
2709 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2712 if Ekind (Scop) = E_Package_Body then
2713 Push_Scope (Spec_Entity (Scop));
2715 elsif Ekind (Scop) = E_Subprogram_Body then
2717 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2723 Analyze (RCI_Locator);
2727 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2730 RCI_Locator := Parent (RCI_Cache);
2733 Calling_Stubs := Build_Subprogram_Calling_Stubs
2734 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2736 Build_Subprogram_Id (Loc, Called_Subprogram),
2737 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2739 Is_Asynchronous (Called_Subprogram),
2740 Locator => RCI_Cache,
2741 New_Name => New_Internal_Name ('S'));
2742 Insert_After (RCI_Locator, Calling_Stubs);
2743 Analyze (Calling_Stubs);
2744 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2747 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2748 end Expand_All_Calls_Remote_Subprogram_Call;
2750 ---------------------------------
2751 -- Expand_Calling_Stubs_Bodies --
2752 ---------------------------------
2754 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2755 Spec : constant Node_Id := Specification (Unit_Node);
2756 Decls : constant List_Id := Visible_Declarations (Spec);
2758 Push_Scope (Scope_Of_Spec (Spec));
2759 Add_Calling_Stubs_To_Declarations
2760 (Specification (Unit_Node), Decls);
2762 end Expand_Calling_Stubs_Bodies;
2764 -----------------------------------
2765 -- Expand_Receiving_Stubs_Bodies --
2766 -----------------------------------
2768 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2774 if Nkind (Unit_Node) = N_Package_Declaration then
2775 Spec := Specification (Unit_Node);
2776 Decls := Private_Declarations (Spec);
2779 Decls := Visible_Declarations (Spec);
2782 Push_Scope (Scope_Of_Spec (Spec));
2783 Specific_Add_Receiving_Stubs_To_Declarations
2784 (Spec, Decls, Decls);
2787 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2788 Decls := Declarations (Unit_Node);
2790 Push_Scope (Scope_Of_Spec (Unit_Node));
2792 Specific_Add_Receiving_Stubs_To_Declarations
2793 (Spec, Temp, Statements (Handled_Statement_Sequence (Unit_Node)));
2794 Insert_List_Before (First (Decls), Temp);
2798 end Expand_Receiving_Stubs_Bodies;
2800 --------------------
2801 -- GARLIC_Support --
2802 --------------------
2804 package body GARLIC_Support is
2806 -- Local subprograms
2808 procedure Add_RACW_Read_Attribute
2809 (RACW_Type : Entity_Id;
2810 Stub_Type : Entity_Id;
2811 Stub_Type_Access : Entity_Id;
2812 Body_Decls : List_Id);
2813 -- Add Read attribute for the RACW type. The declaration and attribute
2814 -- definition clauses are inserted right after the declaration of
2815 -- RACW_Type, while the subprogram body is appended to Body_Decls.
2817 procedure Add_RACW_Write_Attribute
2818 (RACW_Type : Entity_Id;
2819 Stub_Type : Entity_Id;
2820 Stub_Type_Access : Entity_Id;
2821 RPC_Receiver : Node_Id;
2822 Body_Decls : List_Id);
2823 -- Same as above for the Write attribute
2825 function Stream_Parameter return Node_Id;
2826 function Result return Node_Id;
2827 function Object return Node_Id renames Result;
2828 -- Functions to create occurrences of the formal parameter names of the
2829 -- 'Read and 'Write attributes.
2832 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
2833 -- their ancillary subroutines (set on entry by Add_RACW_Features).
2835 procedure Add_RAS_Access_TSS (N : Node_Id);
2836 -- Add a subprogram body for RAS Access TSS
2838 -------------------------------------
2839 -- Add_Obj_RPC_Receiver_Completion --
2840 -------------------------------------
2842 procedure Add_Obj_RPC_Receiver_Completion
2845 RPC_Receiver : Entity_Id;
2846 Stub_Elements : Stub_Structure) is
2848 -- The RPC receiver body should not be the completion of the
2849 -- declaration recorded in the stub structure, because then the
2850 -- occurrences of the formal parameters within the body should refer
2851 -- to the entities from the declaration, not from the completion, to
2852 -- which we do not have easy access. Instead, the RPC receiver body
2853 -- acts as its own declaration, and the RPC receiver declaration is
2854 -- completed by a renaming-as-body.
2857 Make_Subprogram_Renaming_Declaration (Loc,
2859 Copy_Specification (Loc,
2860 Specification (Stub_Elements.RPC_Receiver_Decl)),
2861 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2862 end Add_Obj_RPC_Receiver_Completion;
2864 -----------------------
2865 -- Add_RACW_Features --
2866 -----------------------
2868 procedure Add_RACW_Features
2869 (RACW_Type : Entity_Id;
2870 Stub_Type : Entity_Id;
2871 Stub_Type_Access : Entity_Id;
2872 RPC_Receiver_Decl : Node_Id;
2873 Body_Decls : List_Id)
2875 RPC_Receiver : Node_Id;
2876 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2879 Loc := Sloc (RACW_Type);
2883 -- For a RAS, the RPC receiver is that of the RCI unit, not that
2884 -- of the corresponding distributed object type. We retrieve its
2885 -- address from the local proxy object.
2887 RPC_Receiver := Make_Selected_Component (Loc,
2889 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2890 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2893 RPC_Receiver := Make_Attribute_Reference (Loc,
2894 Prefix => New_Occurrence_Of (
2895 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2896 Attribute_Name => Name_Address);
2899 Add_RACW_Write_Attribute (
2906 Add_RACW_Read_Attribute (
2911 end Add_RACW_Features;
2913 -----------------------------
2914 -- Add_RACW_Read_Attribute --
2915 -----------------------------
2917 procedure Add_RACW_Read_Attribute
2918 (RACW_Type : Entity_Id;
2919 Stub_Type : Entity_Id;
2920 Stub_Type_Access : Entity_Id;
2921 Body_Decls : List_Id)
2923 Proc_Decl : Node_Id;
2924 Attr_Decl : Node_Id;
2926 Body_Node : Node_Id;
2929 Statements : List_Id;
2930 Local_Statements : List_Id;
2931 Remote_Statements : List_Id;
2932 -- Various parts of the procedure
2934 Procedure_Name : constant Name_Id :=
2935 New_Internal_Name ('R');
2936 Source_Partition : constant Entity_Id :=
2937 Make_Defining_Identifier
2938 (Loc, New_Internal_Name ('P'));
2939 Source_Receiver : constant Entity_Id :=
2940 Make_Defining_Identifier
2941 (Loc, New_Internal_Name ('S'));
2942 Source_Address : constant Entity_Id :=
2943 Make_Defining_Identifier
2944 (Loc, New_Internal_Name ('P'));
2945 Local_Stub : constant Entity_Id :=
2946 Make_Defining_Identifier
2947 (Loc, New_Internal_Name ('L'));
2948 Stubbed_Result : constant Entity_Id :=
2949 Make_Defining_Identifier
2950 (Loc, New_Internal_Name ('S'));
2951 Asynchronous_Flag : constant Entity_Id :=
2952 Asynchronous_Flags_Table.Get (RACW_Type);
2953 pragma Assert (Present (Asynchronous_Flag));
2955 -- Start of processing for Add_RACW_Read_Attribute
2958 -- Generate object declarations
2961 Make_Object_Declaration (Loc,
2962 Defining_Identifier => Source_Partition,
2963 Object_Definition =>
2964 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
2966 Make_Object_Declaration (Loc,
2967 Defining_Identifier => Source_Receiver,
2968 Object_Definition =>
2969 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2971 Make_Object_Declaration (Loc,
2972 Defining_Identifier => Source_Address,
2973 Object_Definition =>
2974 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2976 Make_Object_Declaration (Loc,
2977 Defining_Identifier => Local_Stub,
2978 Aliased_Present => True,
2979 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
2981 Make_Object_Declaration (Loc,
2982 Defining_Identifier => Stubbed_Result,
2983 Object_Definition =>
2984 New_Occurrence_Of (Stub_Type_Access, Loc),
2986 Make_Attribute_Reference (Loc,
2988 New_Occurrence_Of (Local_Stub, Loc),
2990 Name_Unchecked_Access)));
2992 -- Read the source Partition_ID and RPC_Receiver from incoming stream
2994 Statements := New_List (
2995 Make_Attribute_Reference (Loc,
2997 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
2998 Attribute_Name => Name_Read,
2999 Expressions => New_List (
3001 New_Occurrence_Of (Source_Partition, Loc))),
3003 Make_Attribute_Reference (Loc,
3005 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3008 Expressions => New_List (
3010 New_Occurrence_Of (Source_Receiver, Loc))),
3012 Make_Attribute_Reference (Loc,
3014 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3017 Expressions => New_List (
3019 New_Occurrence_Of (Source_Address, Loc))));
3021 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3023 Set_Etype (Stubbed_Result, Stub_Type_Access);
3025 -- If the Address is Null_Address, then return a null object
3027 Append_To (Statements,
3028 Make_Implicit_If_Statement (RACW_Type,
3031 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3032 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3033 Then_Statements => New_List (
3034 Make_Assignment_Statement (Loc,
3036 Expression => Make_Null (Loc)),
3037 Make_Return_Statement (Loc))));
3039 -- If the RACW denotes an object created on the current partition,
3040 -- Local_Statements will be executed. The real object will be used.
3042 Local_Statements := New_List (
3043 Make_Assignment_Statement (Loc,
3046 Unchecked_Convert_To (RACW_Type,
3047 OK_Convert_To (RTE (RE_Address),
3048 New_Occurrence_Of (Source_Address, Loc)))));
3050 -- If the object is located on another partition, then a stub object
3051 -- will be created with all the information needed to rebuild the
3052 -- real object at the other end.
3054 Remote_Statements := New_List (
3056 Make_Assignment_Statement (Loc,
3057 Name => Make_Selected_Component (Loc,
3058 Prefix => Stubbed_Result,
3059 Selector_Name => Name_Origin),
3061 New_Occurrence_Of (Source_Partition, Loc)),
3063 Make_Assignment_Statement (Loc,
3064 Name => Make_Selected_Component (Loc,
3065 Prefix => Stubbed_Result,
3066 Selector_Name => Name_Receiver),
3068 New_Occurrence_Of (Source_Receiver, Loc)),
3070 Make_Assignment_Statement (Loc,
3071 Name => Make_Selected_Component (Loc,
3072 Prefix => Stubbed_Result,
3073 Selector_Name => Name_Addr),
3075 New_Occurrence_Of (Source_Address, Loc)));
3077 Append_To (Remote_Statements,
3078 Make_Assignment_Statement (Loc,
3079 Name => Make_Selected_Component (Loc,
3080 Prefix => Stubbed_Result,
3081 Selector_Name => Name_Asynchronous),
3083 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3085 Append_List_To (Remote_Statements,
3086 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3087 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3088 -- set on the stub type if, and only if, the RACW type has a pragma
3089 -- Asynchronous. This is incorrect for RACWs that implement RAS
3090 -- types, because in that case the /designated subprogram/ (not the
3091 -- type) might be asynchronous, and that causes the stub to need to
3092 -- be asynchronous too. A solution is to transport a RAS as a struct
3093 -- containing a RACW and an asynchronous flag, and to properly alter
3094 -- the Asynchronous component in the stub type in the RAS's Input
3097 Append_To (Remote_Statements,
3098 Make_Assignment_Statement (Loc,
3100 Expression => Unchecked_Convert_To (RACW_Type,
3101 New_Occurrence_Of (Stubbed_Result, Loc))));
3103 -- Distinguish between the local and remote cases, and execute the
3104 -- appropriate piece of code.
3106 Append_To (Statements,
3107 Make_Implicit_If_Statement (RACW_Type,
3111 Make_Function_Call (Loc,
3112 Name => New_Occurrence_Of (
3113 RTE (RE_Get_Local_Partition_Id), Loc)),
3114 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3115 Then_Statements => Local_Statements,
3116 Else_Statements => Remote_Statements));
3118 Build_Stream_Procedure
3119 (Loc, RACW_Type, Body_Node,
3120 Make_Defining_Identifier (Loc, Procedure_Name),
3121 Statements, Outp => True);
3122 Set_Declarations (Body_Node, Decls);
3124 Proc_Decl := Make_Subprogram_Declaration (Loc,
3125 Copy_Specification (Loc, Specification (Body_Node)));
3128 Make_Attribute_Definition_Clause (Loc,
3129 Name => New_Occurrence_Of (RACW_Type, Loc),
3133 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3135 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3136 Insert_After (Proc_Decl, Attr_Decl);
3137 Append_To (Body_Decls, Body_Node);
3138 end Add_RACW_Read_Attribute;
3140 ------------------------------
3141 -- Add_RACW_Write_Attribute --
3142 ------------------------------
3144 procedure Add_RACW_Write_Attribute
3145 (RACW_Type : Entity_Id;
3146 Stub_Type : Entity_Id;
3147 Stub_Type_Access : Entity_Id;
3148 RPC_Receiver : Node_Id;
3149 Body_Decls : List_Id)
3151 Body_Node : Node_Id;
3152 Proc_Decl : Node_Id;
3153 Attr_Decl : Node_Id;
3155 Statements : List_Id;
3156 Local_Statements : List_Id;
3157 Remote_Statements : List_Id;
3158 Null_Statements : List_Id;
3160 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
3163 -- Build the code fragment corresponding to the marshalling of a
3166 Local_Statements := New_List (
3168 Pack_Entity_Into_Stream_Access (Loc,
3169 Stream => Stream_Parameter,
3170 Object => RTE (RE_Get_Local_Partition_Id)),
3172 Pack_Node_Into_Stream_Access (Loc,
3173 Stream => Stream_Parameter,
3174 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3175 Etyp => RTE (RE_Unsigned_64)),
3177 Pack_Node_Into_Stream_Access (Loc,
3178 Stream => Stream_Parameter,
3179 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3180 Make_Attribute_Reference (Loc,
3182 Make_Explicit_Dereference (Loc,
3184 Attribute_Name => Name_Address)),
3185 Etyp => RTE (RE_Unsigned_64)));
3187 -- Build the code fragment corresponding to the marshalling of
3190 Remote_Statements := New_List (
3192 Pack_Node_Into_Stream_Access (Loc,
3193 Stream => Stream_Parameter,
3195 Make_Selected_Component (Loc,
3196 Prefix => Unchecked_Convert_To (Stub_Type_Access,
3199 Make_Identifier (Loc, Name_Origin)),
3200 Etyp => RTE (RE_Partition_ID)),
3202 Pack_Node_Into_Stream_Access (Loc,
3203 Stream => Stream_Parameter,
3205 Make_Selected_Component (Loc,
3206 Prefix => Unchecked_Convert_To (Stub_Type_Access,
3209 Make_Identifier (Loc, Name_Receiver)),
3210 Etyp => RTE (RE_Unsigned_64)),
3212 Pack_Node_Into_Stream_Access (Loc,
3213 Stream => Stream_Parameter,
3215 Make_Selected_Component (Loc,
3216 Prefix => Unchecked_Convert_To (Stub_Type_Access,
3219 Make_Identifier (Loc, Name_Addr)),
3220 Etyp => RTE (RE_Unsigned_64)));
3222 -- Build code fragment corresponding to marshalling of a null object
3224 Null_Statements := New_List (
3226 Pack_Entity_Into_Stream_Access (Loc,
3227 Stream => Stream_Parameter,
3228 Object => RTE (RE_Get_Local_Partition_Id)),
3230 Pack_Node_Into_Stream_Access (Loc,
3231 Stream => Stream_Parameter,
3232 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3233 Etyp => RTE (RE_Unsigned_64)),
3235 Pack_Node_Into_Stream_Access (Loc,
3236 Stream => Stream_Parameter,
3237 Object => Make_Integer_Literal (Loc, Uint_0),
3238 Etyp => RTE (RE_Unsigned_64)));
3240 Statements := New_List (
3241 Make_Implicit_If_Statement (RACW_Type,
3244 Left_Opnd => Object,
3245 Right_Opnd => Make_Null (Loc)),
3246 Then_Statements => Null_Statements,
3247 Elsif_Parts => New_List (
3248 Make_Elsif_Part (Loc,
3252 Make_Attribute_Reference (Loc,
3254 Attribute_Name => Name_Tag),
3256 Make_Attribute_Reference (Loc,
3257 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3258 Attribute_Name => Name_Tag)),
3259 Then_Statements => Remote_Statements)),
3260 Else_Statements => Local_Statements));
3262 Build_Stream_Procedure
3263 (Loc, RACW_Type, Body_Node,
3264 Make_Defining_Identifier (Loc, Procedure_Name),
3265 Statements, Outp => False);
3267 Proc_Decl := Make_Subprogram_Declaration (Loc,
3268 Copy_Specification (Loc, Specification (Body_Node)));
3271 Make_Attribute_Definition_Clause (Loc,
3272 Name => New_Occurrence_Of (RACW_Type, Loc),
3273 Chars => Name_Write,
3276 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3278 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3279 Insert_After (Proc_Decl, Attr_Decl);
3280 Append_To (Body_Decls, Body_Node);
3281 end Add_RACW_Write_Attribute;
3283 ------------------------
3284 -- Add_RAS_Access_TSS --
3285 ------------------------
3287 procedure Add_RAS_Access_TSS (N : Node_Id) is
3288 Loc : constant Source_Ptr := Sloc (N);
3290 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3291 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3292 -- Ras_Type is the access to subprogram type while Fat_Type is the
3293 -- corresponding record type.
3295 RACW_Type : constant Entity_Id :=
3296 Underlying_RACW_Type (Ras_Type);
3297 Desig : constant Entity_Id :=
3298 Etype (Designated_Type (RACW_Type));
3300 Stub_Elements : constant Stub_Structure :=
3301 Stubs_Table.Get (Desig);
3302 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3304 Proc : constant Entity_Id :=
3305 Make_Defining_Identifier (Loc,
3306 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3308 Proc_Spec : Node_Id;
3310 -- Formal parameters
3312 Package_Name : constant Entity_Id :=
3313 Make_Defining_Identifier (Loc,
3317 Subp_Id : constant Entity_Id :=
3318 Make_Defining_Identifier (Loc,
3320 -- Target subprogram
3322 Asynch_P : constant Entity_Id :=
3323 Make_Defining_Identifier (Loc,
3324 Chars => Name_Asynchronous);
3325 -- Is the procedure to which the 'Access applies asynchronous?
3327 All_Calls_Remote : constant Entity_Id :=
3328 Make_Defining_Identifier (Loc,
3329 Chars => Name_All_Calls_Remote);
3330 -- True if an All_Calls_Remote pragma applies to the RCI unit
3331 -- that contains the subprogram.
3333 -- Common local variables
3335 Proc_Decls : List_Id;
3336 Proc_Statements : List_Id;
3338 Origin : constant Entity_Id :=
3339 Make_Defining_Identifier (Loc,
3340 Chars => New_Internal_Name ('P'));
3342 -- Additional local variables for the local case
3344 Proxy_Addr : constant Entity_Id :=
3345 Make_Defining_Identifier (Loc,
3346 Chars => New_Internal_Name ('P'));
3348 -- Additional local variables for the remote case
3350 Local_Stub : constant Entity_Id :=
3351 Make_Defining_Identifier (Loc,
3352 Chars => New_Internal_Name ('L'));
3354 Stub_Ptr : constant Entity_Id :=
3355 Make_Defining_Identifier (Loc,
3356 Chars => New_Internal_Name ('S'));
3359 (Field_Name : Name_Id;
3360 Value : Node_Id) return Node_Id;
3361 -- Construct an assignment that sets the named component in the
3369 (Field_Name : Name_Id;
3370 Value : Node_Id) return Node_Id
3374 Make_Assignment_Statement (Loc,
3376 Make_Selected_Component (Loc,
3378 Selector_Name => Field_Name),
3379 Expression => Value);
3382 -- Start of processing for Add_RAS_Access_TSS
3385 Proc_Decls := New_List (
3387 -- Common declarations
3389 Make_Object_Declaration (Loc,
3390 Defining_Identifier => Origin,
3391 Constant_Present => True,
3392 Object_Definition =>
3393 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3395 Make_Function_Call (Loc,
3397 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3398 Parameter_Associations => New_List (
3399 New_Occurrence_Of (Package_Name, Loc)))),
3401 -- Declaration use only in the local case: proxy address
3403 Make_Object_Declaration (Loc,
3404 Defining_Identifier => Proxy_Addr,
3405 Object_Definition =>
3406 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3408 -- Declarations used only in the remote case: stub object and
3411 Make_Object_Declaration (Loc,
3412 Defining_Identifier => Local_Stub,
3413 Aliased_Present => True,
3414 Object_Definition =>
3415 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3417 Make_Object_Declaration (Loc,
3418 Defining_Identifier =>
3420 Object_Definition =>
3421 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3423 Make_Attribute_Reference (Loc,
3424 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3425 Attribute_Name => Name_Unchecked_Access)));
3427 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3428 -- Build_Get_Unique_RP_Call needs this information
3430 -- Note: Here we assume that the Fat_Type is a record
3431 -- containing just a pointer to a proxy or stub object.
3433 Proc_Statements := New_List (
3437 -- Get_RAS_Info (Pkg, Subp, PA);
3438 -- if Origin = Local_Partition_Id
3439 -- and then not All_Calls_Remote
3441 -- return Fat_Type!(PA);
3444 Make_Procedure_Call_Statement (Loc,
3446 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3447 Parameter_Associations => New_List (
3448 New_Occurrence_Of (Package_Name, Loc),
3449 New_Occurrence_Of (Subp_Id, Loc),
3450 New_Occurrence_Of (Proxy_Addr, Loc))),
3452 Make_Implicit_If_Statement (N,
3458 New_Occurrence_Of (Origin, Loc),
3460 Make_Function_Call (Loc,
3462 RTE (RE_Get_Local_Partition_Id), Loc))),
3465 New_Occurrence_Of (All_Calls_Remote, Loc))),
3466 Then_Statements => New_List (
3467 Make_Return_Statement (Loc,
3468 Unchecked_Convert_To (Fat_Type,
3469 OK_Convert_To (RTE (RE_Address),
3470 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3472 Set_Field (Name_Origin,
3473 New_Occurrence_Of (Origin, Loc)),
3475 Set_Field (Name_Receiver,
3476 Make_Function_Call (Loc,
3478 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3479 Parameter_Associations => New_List (
3480 New_Occurrence_Of (Package_Name, Loc)))),
3482 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3484 -- E.4.1(9) A remote call is asynchronous if it is a call to
3485 -- a procedure, or a call through a value of an access-to-procedure
3486 -- type, to which a pragma Asynchronous applies.
3488 -- Parameter Asynch_P is true when the procedure is asynchronous;
3489 -- Expression Asynch_T is true when the type is asynchronous.
3491 Set_Field (Name_Asynchronous,
3493 New_Occurrence_Of (Asynch_P, Loc),
3494 New_Occurrence_Of (Boolean_Literals (
3495 Is_Asynchronous (Ras_Type)), Loc))));
3497 Append_List_To (Proc_Statements,
3498 Build_Get_Unique_RP_Call
3499 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3501 -- Return the newly created value
3503 Append_To (Proc_Statements,
3504 Make_Return_Statement (Loc,
3506 Unchecked_Convert_To (Fat_Type,
3507 New_Occurrence_Of (Stub_Ptr, Loc))));
3510 Make_Function_Specification (Loc,
3511 Defining_Unit_Name => Proc,
3512 Parameter_Specifications => New_List (
3513 Make_Parameter_Specification (Loc,
3514 Defining_Identifier => Package_Name,
3516 New_Occurrence_Of (Standard_String, Loc)),
3518 Make_Parameter_Specification (Loc,
3519 Defining_Identifier => Subp_Id,
3521 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3523 Make_Parameter_Specification (Loc,
3524 Defining_Identifier => Asynch_P,
3526 New_Occurrence_Of (Standard_Boolean, Loc)),
3528 Make_Parameter_Specification (Loc,
3529 Defining_Identifier => All_Calls_Remote,
3531 New_Occurrence_Of (Standard_Boolean, Loc))),
3533 Result_Definition =>
3534 New_Occurrence_Of (Fat_Type, Loc));
3536 -- Set the kind and return type of the function to prevent
3537 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3539 Set_Ekind (Proc, E_Function);
3540 Set_Etype (Proc, Fat_Type);
3543 Make_Subprogram_Body (Loc,
3544 Specification => Proc_Spec,
3545 Declarations => Proc_Decls,
3546 Handled_Statement_Sequence =>
3547 Make_Handled_Sequence_Of_Statements (Loc,
3548 Statements => Proc_Statements)));
3550 Set_TSS (Fat_Type, Proc);
3551 end Add_RAS_Access_TSS;
3553 -----------------------
3554 -- Add_RAST_Features --
3555 -----------------------
3557 procedure Add_RAST_Features
3558 (Vis_Decl : Node_Id;
3559 RAS_Type : Entity_Id)
3561 pragma Warnings (Off);
3562 pragma Unreferenced (RAS_Type);
3563 pragma Warnings (On);
3565 Add_RAS_Access_TSS (Vis_Decl);
3566 end Add_RAST_Features;
3568 -----------------------------------------
3569 -- Add_Receiving_Stubs_To_Declarations --
3570 -----------------------------------------
3572 procedure Add_Receiving_Stubs_To_Declarations
3573 (Pkg_Spec : Node_Id;
3577 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3579 Request_Parameter : Node_Id;
3581 Pkg_RPC_Receiver : constant Entity_Id :=
3582 Make_Defining_Identifier (Loc,
3583 New_Internal_Name ('H'));
3584 Pkg_RPC_Receiver_Statements : List_Id;
3585 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3586 Pkg_RPC_Receiver_Body : Node_Id;
3587 -- A Pkg_RPC_Receiver is built to decode the request
3589 Lookup_RAS_Info : constant Entity_Id :=
3590 Make_Defining_Identifier (Loc,
3591 Chars => New_Internal_Name ('R'));
3592 -- A remote subprogram is created to allow peers to look up
3593 -- RAS information using subprogram ids.
3595 Subp_Id : Entity_Id;
3596 Subp_Index : Entity_Id;
3597 -- Subprogram_Id as read from the incoming stream
3599 Current_Declaration : Node_Id;
3600 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3601 Current_Stubs : Node_Id;
3603 Subp_Info_Array : constant Entity_Id :=
3604 Make_Defining_Identifier (Loc,
3605 Chars => New_Internal_Name ('I'));
3607 Subp_Info_List : constant List_Id := New_List;
3609 Register_Pkg_Actuals : constant List_Id := New_List;
3611 All_Calls_Remote_E : Entity_Id;
3612 Proxy_Object_Addr : Entity_Id;
3614 procedure Append_Stubs_To
3615 (RPC_Receiver_Cases : List_Id;
3617 Subprogram_Number : Int);
3618 -- Add one case to the specified RPC receiver case list
3619 -- associating Subprogram_Number with the subprogram declared
3620 -- by Declaration, for which we have receiving stubs in Stubs.
3622 ---------------------
3623 -- Append_Stubs_To --
3624 ---------------------
3626 procedure Append_Stubs_To
3627 (RPC_Receiver_Cases : List_Id;
3629 Subprogram_Number : Int)
3632 Append_To (RPC_Receiver_Cases,
3633 Make_Case_Statement_Alternative (Loc,
3635 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3638 Make_Procedure_Call_Statement (Loc,
3641 Defining_Entity (Stubs), Loc),
3642 Parameter_Associations => New_List (
3643 New_Occurrence_Of (Request_Parameter, Loc))))));
3644 end Append_Stubs_To;
3646 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3649 -- Building receiving stubs consist in several operations:
3651 -- - a package RPC receiver must be built. This subprogram
3652 -- will get a Subprogram_Id from the incoming stream
3653 -- and will dispatch the call to the right subprogram;
3655 -- - a receiving stub for each subprogram visible in the package
3656 -- spec. This stub will read all the parameters from the stream,
3657 -- and put the result as well as the exception occurrence in the
3660 -- - a dummy package with an empty spec and a body made of an
3661 -- elaboration part, whose job is to register the receiving
3662 -- part of this RCI package on the name server. This is done
3663 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3665 Build_RPC_Receiver_Body (
3666 RPC_Receiver => Pkg_RPC_Receiver,
3667 Request => Request_Parameter,
3669 Subp_Index => Subp_Index,
3670 Stmts => Pkg_RPC_Receiver_Statements,
3671 Decl => Pkg_RPC_Receiver_Body);
3672 pragma Assert (Subp_Id = Subp_Index);
3674 -- A null subp_id denotes a call through a RAS, in which case the
3675 -- next Uint_64 element in the stream is the address of the local
3676 -- proxy object, from which we can retrieve the actual subprogram id.
3678 Append_To (Pkg_RPC_Receiver_Statements,
3679 Make_Implicit_If_Statement (Pkg_Spec,
3682 New_Occurrence_Of (Subp_Id, Loc),
3683 Make_Integer_Literal (Loc, 0)),
3684 Then_Statements => New_List (
3685 Make_Assignment_Statement (Loc,
3687 New_Occurrence_Of (Subp_Id, Loc),
3689 Make_Selected_Component (Loc,
3691 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3692 OK_Convert_To (RTE (RE_Address),
3693 Make_Attribute_Reference (Loc,
3695 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3698 Expressions => New_List (
3699 Make_Selected_Component (Loc,
3700 Prefix => Request_Parameter,
3701 Selector_Name => Name_Params))))),
3703 Make_Identifier (Loc, Name_Subp_Id))))));
3705 -- Build a subprogram for RAS information lookups
3707 Current_Declaration :=
3708 Make_Subprogram_Declaration (Loc,
3710 Make_Function_Specification (Loc,
3711 Defining_Unit_Name =>
3713 Parameter_Specifications => New_List (
3714 Make_Parameter_Specification (Loc,
3715 Defining_Identifier =>
3716 Make_Defining_Identifier (Loc, Name_Subp_Id),
3720 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3721 Result_Definition =>
3722 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3723 Append_To (Decls, Current_Declaration);
3724 Analyze (Current_Declaration);
3726 Current_Stubs := Build_Subprogram_Receiving_Stubs
3727 (Vis_Decl => Current_Declaration,
3728 Asynchronous => False);
3729 Append_To (Decls, Current_Stubs);
3730 Analyze (Current_Stubs);
3732 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3735 Subprogram_Number => 1);
3737 -- For each subprogram, the receiving stub will be built and a
3738 -- case statement will be made on the Subprogram_Id to dispatch
3739 -- to the right subprogram.
3741 All_Calls_Remote_E := Boolean_Literals (
3742 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3744 Overload_Counter_Table.Reset;
3746 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3747 while Present (Current_Declaration) loop
3748 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3749 and then Comes_From_Source (Current_Declaration)
3752 Loc : constant Source_Ptr :=
3753 Sloc (Current_Declaration);
3754 -- While specifically processing Current_Declaration, use
3755 -- its Sloc as the location of all generated nodes.
3757 Subp_Def : constant Entity_Id :=
3759 (Specification (Current_Declaration));
3761 Subp_Val : String_Id;
3764 -- Build receiving stub
3767 Build_Subprogram_Receiving_Stubs
3768 (Vis_Decl => Current_Declaration,
3770 Nkind (Specification (Current_Declaration)) =
3771 N_Procedure_Specification
3772 and then Is_Asynchronous (Subp_Def));
3774 Append_To (Decls, Current_Stubs);
3775 Analyze (Current_Stubs);
3779 Add_RAS_Proxy_And_Analyze (Decls,
3781 Current_Declaration,
3782 All_Calls_Remote_E =>
3784 Proxy_Object_Addr =>
3787 -- Compute distribution identifier
3789 Assign_Subprogram_Identifier (
3791 Current_Subprogram_Number,
3794 pragma Assert (Current_Subprogram_Number =
3795 Get_Subprogram_Id (Subp_Def));
3797 -- Add subprogram descriptor (RCI_Subp_Info) to the
3798 -- subprograms table for this receiver. The aggregate
3799 -- below must be kept consistent with the declaration
3800 -- of type RCI_Subp_Info in System.Partition_Interface.
3802 Append_To (Subp_Info_List,
3803 Make_Component_Association (Loc,
3804 Choices => New_List (
3805 Make_Integer_Literal (Loc,
3806 Current_Subprogram_Number)),
3808 Make_Aggregate (Loc,
3809 Component_Associations => New_List (
3810 Make_Component_Association (Loc,
3811 Choices => New_List (
3812 Make_Identifier (Loc, Name_Addr)),
3815 Proxy_Object_Addr, Loc))))));
3817 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3820 Subprogram_Number =>
3821 Current_Subprogram_Number);
3824 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3827 Next (Current_Declaration);
3830 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3831 -- rather than raising an exception since we do not want someone
3832 -- to crash a remote partition by sending invalid subprogram ids.
3833 -- This is consistent with the other parts of the case statement
3834 -- since even in presence of incorrect parameters in the stream,
3835 -- every exception will be caught and (if the subprogram is not an
3836 -- APC) put into the result stream and sent away.
3838 Append_To (Pkg_RPC_Receiver_Cases,
3839 Make_Case_Statement_Alternative (Loc,
3841 New_List (Make_Others_Choice (Loc)),
3843 New_List (Make_Null_Statement (Loc))));
3845 Append_To (Pkg_RPC_Receiver_Statements,
3846 Make_Case_Statement (Loc,
3848 New_Occurrence_Of (Subp_Id, Loc),
3849 Alternatives => Pkg_RPC_Receiver_Cases));
3852 Make_Object_Declaration (Loc,
3853 Defining_Identifier => Subp_Info_Array,
3854 Constant_Present => True,
3855 Aliased_Present => True,
3856 Object_Definition =>
3857 Make_Subtype_Indication (Loc,
3859 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3861 Make_Index_Or_Discriminant_Constraint (Loc,
3864 Low_Bound => Make_Integer_Literal (Loc,
3865 First_RCI_Subprogram_Id),
3867 Make_Integer_Literal (Loc,
3868 First_RCI_Subprogram_Id
3869 + List_Length (Subp_Info_List) - 1)))))));
3871 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
3872 -- has zero length, and the declaration is for an empty array, in
3873 -- which case no initialization aggregate must be generated.
3875 if Present (First (Subp_Info_List)) then
3876 Set_Expression (Last (Decls),
3877 Make_Aggregate (Loc,
3878 Component_Associations => Subp_Info_List));
3880 -- No initialization provided: remove CONSTANT so that the
3881 -- declaration is not an incomplete deferred constant.
3884 Set_Constant_Present (Last (Decls), False);
3887 Analyze (Last (Decls));
3890 Subp_Info_Addr : Node_Id;
3891 -- Return statement for Lookup_RAS_Info: address of the subprogram
3892 -- information record for the requested subprogram id.
3895 if Present (First (Subp_Info_List)) then
3897 Make_Selected_Component (Loc,
3899 Make_Indexed_Component (Loc,
3901 New_Occurrence_Of (Subp_Info_Array, Loc),
3902 Expressions => New_List (
3903 Convert_To (Standard_Integer,
3904 Make_Identifier (Loc, Name_Subp_Id)))),
3906 Make_Identifier (Loc, Name_Addr));
3908 -- Case of no visible subprogram: just raise Constraint_Error, we
3909 -- know for sure we got junk from a remote partition.
3913 Make_Raise_Constraint_Error (Loc,
3914 Reason => CE_Range_Check_Failed);
3915 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
3919 Make_Subprogram_Body (Loc,
3921 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
3924 Handled_Statement_Sequence =>
3925 Make_Handled_Sequence_Of_Statements (Loc,
3926 Statements => New_List (
3927 Make_Return_Statement (Loc,
3929 OK_Convert_To (RTE (RE_Unsigned_64),
3930 Subp_Info_Addr))))));
3933 Analyze (Last (Decls));
3935 Append_To (Decls, Pkg_RPC_Receiver_Body);
3936 Analyze (Last (Decls));
3938 Get_Library_Unit_Name_String (Pkg_Spec);
3942 Append_To (Register_Pkg_Actuals,
3943 Make_String_Literal (Loc,
3944 Strval => String_From_Name_Buffer));
3948 Append_To (Register_Pkg_Actuals,
3949 Make_Attribute_Reference (Loc,
3951 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
3953 Name_Unrestricted_Access));
3957 Append_To (Register_Pkg_Actuals,
3958 Make_Attribute_Reference (Loc,
3960 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
3966 Append_To (Register_Pkg_Actuals,
3967 Make_Attribute_Reference (Loc,
3969 New_Occurrence_Of (Subp_Info_Array, Loc),
3975 Append_To (Register_Pkg_Actuals,
3976 Make_Attribute_Reference (Loc,
3978 New_Occurrence_Of (Subp_Info_Array, Loc),
3982 -- Generate the call
3985 Make_Procedure_Call_Statement (Loc,
3987 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
3988 Parameter_Associations => Register_Pkg_Actuals));
3989 Analyze (Last (Stmts));
3990 end Add_Receiving_Stubs_To_Declarations;
3992 ---------------------------------
3993 -- Build_General_Calling_Stubs --
3994 ---------------------------------
3996 procedure Build_General_Calling_Stubs
3998 Statements : List_Id;
3999 Target_Partition : Entity_Id;
4000 Target_RPC_Receiver : Node_Id;
4001 Subprogram_Id : Node_Id;
4002 Asynchronous : Node_Id := Empty;
4003 Is_Known_Asynchronous : Boolean := False;
4004 Is_Known_Non_Asynchronous : Boolean := False;
4005 Is_Function : Boolean;
4007 Stub_Type : Entity_Id := Empty;
4008 RACW_Type : Entity_Id := Empty;
4011 Loc : constant Source_Ptr := Sloc (Nod);
4013 Stream_Parameter : Node_Id;
4014 -- Name of the stream used to transmit parameters to the
4017 Result_Parameter : Node_Id;
4018 -- Name of the result parameter (in non-APC cases) which get the
4019 -- result of the remote subprogram.
4021 Exception_Return_Parameter : Node_Id;
4022 -- Name of the parameter which will hold the exception sent by the
4023 -- remote subprogram.
4025 Current_Parameter : Node_Id;
4026 -- Current parameter being handled
4028 Ordered_Parameters_List : constant List_Id :=
4029 Build_Ordered_Parameters_List (Spec);
4031 Asynchronous_Statements : List_Id := No_List;
4032 Non_Asynchronous_Statements : List_Id := No_List;
4033 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4035 Extra_Formal_Statements : constant List_Id := New_List;
4036 -- List of statements for extra formal parameters. It will appear
4037 -- after the regular statements for writing out parameters.
4039 pragma Warnings (Off);
4040 pragma Unreferenced (RACW_Type);
4041 -- Used only for the PolyORB case
4042 pragma Warnings (On);
4045 -- The general form of a calling stub for a given subprogram is:
4047 -- procedure X (...) is P : constant Partition_ID :=
4048 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4049 -- System.RPC.Params_Stream_Type (0); begin
4050 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4051 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4052 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4053 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4055 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4057 -- There are some variations: Do_APC is called for an asynchronous
4058 -- procedure and the part after the call is completely ommitted as
4059 -- well as the declaration of Result. For a function call, 'Input is
4060 -- always used to read the result even if it is constrained.
4063 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4066 Make_Object_Declaration (Loc,
4067 Defining_Identifier => Stream_Parameter,
4068 Aliased_Present => True,
4069 Object_Definition =>
4070 Make_Subtype_Indication (Loc,
4072 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4074 Make_Index_Or_Discriminant_Constraint (Loc,
4076 New_List (Make_Integer_Literal (Loc, 0))))));
4078 if not Is_Known_Asynchronous then
4080 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4083 Make_Object_Declaration (Loc,
4084 Defining_Identifier => Result_Parameter,
4085 Aliased_Present => True,
4086 Object_Definition =>
4087 Make_Subtype_Indication (Loc,
4089 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4091 Make_Index_Or_Discriminant_Constraint (Loc,
4093 New_List (Make_Integer_Literal (Loc, 0))))));
4095 Exception_Return_Parameter :=
4096 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4099 Make_Object_Declaration (Loc,
4100 Defining_Identifier => Exception_Return_Parameter,
4101 Object_Definition =>
4102 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4105 Result_Parameter := Empty;
4106 Exception_Return_Parameter := Empty;
4109 -- Put first the RPC receiver corresponding to the remote package
4111 Append_To (Statements,
4112 Make_Attribute_Reference (Loc,
4114 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4115 Attribute_Name => Name_Write,
4116 Expressions => New_List (
4117 Make_Attribute_Reference (Loc,
4119 New_Occurrence_Of (Stream_Parameter, Loc),
4122 Target_RPC_Receiver)));
4124 -- Then put the Subprogram_Id of the subprogram we want to call in
4127 Append_To (Statements,
4128 Make_Attribute_Reference (Loc,
4130 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4133 Expressions => New_List (
4134 Make_Attribute_Reference (Loc,
4136 New_Occurrence_Of (Stream_Parameter, Loc),
4137 Attribute_Name => Name_Access),
4140 Current_Parameter := First (Ordered_Parameters_List);
4141 while Present (Current_Parameter) loop
4143 Typ : constant Node_Id :=
4144 Parameter_Type (Current_Parameter);
4146 Constrained : Boolean;
4148 Extra_Parameter : Entity_Id;
4151 if Is_RACW_Controlling_Formal
4152 (Current_Parameter, Stub_Type)
4154 -- In the case of a controlling formal argument, we marshall
4155 -- its addr field rather than the local stub.
4157 Append_To (Statements,
4158 Pack_Node_Into_Stream (Loc,
4159 Stream => Stream_Parameter,
4161 Make_Selected_Component (Loc,
4163 Defining_Identifier (Current_Parameter),
4164 Selector_Name => Name_Addr),
4165 Etyp => RTE (RE_Unsigned_64)));
4168 Value := New_Occurrence_Of
4169 (Defining_Identifier (Current_Parameter), Loc);
4171 -- Access type parameters are transmitted as in out
4172 -- parameters. However, a dereference is needed so that
4173 -- we marshall the designated object.
4175 if Nkind (Typ) = N_Access_Definition then
4176 Value := Make_Explicit_Dereference (Loc, Value);
4177 Etyp := Etype (Subtype_Mark (Typ));
4179 Etyp := Etype (Typ);
4183 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
4185 -- Any parameter but unconstrained out parameters are
4186 -- transmitted to the peer.
4188 if In_Present (Current_Parameter)
4189 or else not Out_Present (Current_Parameter)
4190 or else not Constrained
4192 Append_To (Statements,
4193 Make_Attribute_Reference (Loc,
4195 New_Occurrence_Of (Etyp, Loc),
4197 Output_From_Constrained (Constrained),
4198 Expressions => New_List (
4199 Make_Attribute_Reference (Loc,
4201 New_Occurrence_Of (Stream_Parameter, Loc),
4202 Attribute_Name => Name_Access),
4207 -- If the current parameter has a dynamic constrained status,
4208 -- then this status is transmitted as well.
4209 -- This should be done for accessibility as well ???
4211 if Nkind (Typ) /= N_Access_Definition
4212 and then Need_Extra_Constrained (Current_Parameter)
4214 -- In this block, we do not use the extra formal that has
4215 -- been created because it does not exist at the time of
4216 -- expansion when building calling stubs for remote access
4217 -- to subprogram types. We create an extra variable of this
4218 -- type and push it in the stream after the regular
4221 Extra_Parameter := Make_Defining_Identifier
4222 (Loc, New_Internal_Name ('P'));
4225 Make_Object_Declaration (Loc,
4226 Defining_Identifier => Extra_Parameter,
4227 Constant_Present => True,
4228 Object_Definition =>
4229 New_Occurrence_Of (Standard_Boolean, Loc),
4231 Make_Attribute_Reference (Loc,
4234 Defining_Identifier (Current_Parameter), Loc),
4235 Attribute_Name => Name_Constrained)));
4237 Append_To (Extra_Formal_Statements,
4238 Make_Attribute_Reference (Loc,
4240 New_Occurrence_Of (Standard_Boolean, Loc),
4243 Expressions => New_List (
4244 Make_Attribute_Reference (Loc,
4246 New_Occurrence_Of (Stream_Parameter, Loc),
4249 New_Occurrence_Of (Extra_Parameter, Loc))));
4252 Next (Current_Parameter);
4256 -- Append the formal statements list to the statements
4258 Append_List_To (Statements, Extra_Formal_Statements);
4260 if not Is_Known_Non_Asynchronous then
4262 -- Build the call to System.RPC.Do_APC
4264 Asynchronous_Statements := New_List (
4265 Make_Procedure_Call_Statement (Loc,
4267 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4268 Parameter_Associations => New_List (
4269 New_Occurrence_Of (Target_Partition, Loc),
4270 Make_Attribute_Reference (Loc,
4272 New_Occurrence_Of (Stream_Parameter, Loc),
4276 Asynchronous_Statements := No_List;
4279 if not Is_Known_Asynchronous then
4281 -- Build the call to System.RPC.Do_RPC
4283 Non_Asynchronous_Statements := New_List (
4284 Make_Procedure_Call_Statement (Loc,
4286 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4287 Parameter_Associations => New_List (
4288 New_Occurrence_Of (Target_Partition, Loc),
4290 Make_Attribute_Reference (Loc,
4292 New_Occurrence_Of (Stream_Parameter, Loc),
4296 Make_Attribute_Reference (Loc,
4298 New_Occurrence_Of (Result_Parameter, Loc),
4302 -- Read the exception occurrence from the result stream and
4303 -- reraise it. It does no harm if this is a Null_Occurrence since
4304 -- this does nothing.
4306 Append_To (Non_Asynchronous_Statements,
4307 Make_Attribute_Reference (Loc,
4309 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4314 Expressions => New_List (
4315 Make_Attribute_Reference (Loc,
4317 New_Occurrence_Of (Result_Parameter, Loc),
4320 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4322 Append_To (Non_Asynchronous_Statements,
4323 Make_Procedure_Call_Statement (Loc,
4325 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4326 Parameter_Associations => New_List (
4327 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4331 -- If this is a function call, then read the value and return
4332 -- it. The return value is written/read using 'Output/'Input.
4334 Append_To (Non_Asynchronous_Statements,
4335 Make_Tag_Check (Loc,
4336 Make_Return_Statement (Loc,
4338 Make_Attribute_Reference (Loc,
4341 Etype (Result_Definition (Spec)), Loc),
4343 Attribute_Name => Name_Input,
4345 Expressions => New_List (
4346 Make_Attribute_Reference (Loc,
4348 New_Occurrence_Of (Result_Parameter, Loc),
4349 Attribute_Name => Name_Access))))));
4352 -- Loop around parameters and assign out (or in out)
4353 -- parameters. In the case of RACW, controlling arguments
4354 -- cannot possibly have changed since they are remote, so we do
4355 -- not read them from the stream.
4357 Current_Parameter := First (Ordered_Parameters_List);
4358 while Present (Current_Parameter) loop
4360 Typ : constant Node_Id :=
4361 Parameter_Type (Current_Parameter);
4368 (Defining_Identifier (Current_Parameter), Loc);
4370 if Nkind (Typ) = N_Access_Definition then
4371 Value := Make_Explicit_Dereference (Loc, Value);
4372 Etyp := Etype (Subtype_Mark (Typ));
4374 Etyp := Etype (Typ);
4377 if (Out_Present (Current_Parameter)
4378 or else Nkind (Typ) = N_Access_Definition)
4379 and then Etyp /= Stub_Type
4381 Append_To (Non_Asynchronous_Statements,
4382 Make_Attribute_Reference (Loc,
4384 New_Occurrence_Of (Etyp, Loc),
4386 Attribute_Name => Name_Read,
4388 Expressions => New_List (
4389 Make_Attribute_Reference (Loc,
4391 New_Occurrence_Of (Result_Parameter, Loc),
4398 Next (Current_Parameter);
4403 if Is_Known_Asynchronous then
4404 Append_List_To (Statements, Asynchronous_Statements);
4406 elsif Is_Known_Non_Asynchronous then
4407 Append_List_To (Statements, Non_Asynchronous_Statements);
4410 pragma Assert (Present (Asynchronous));
4411 Prepend_To (Asynchronous_Statements,
4412 Make_Attribute_Reference (Loc,
4413 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4414 Attribute_Name => Name_Write,
4415 Expressions => New_List (
4416 Make_Attribute_Reference (Loc,
4418 New_Occurrence_Of (Stream_Parameter, Loc),
4419 Attribute_Name => Name_Access),
4420 New_Occurrence_Of (Standard_True, Loc))));
4422 Prepend_To (Non_Asynchronous_Statements,
4423 Make_Attribute_Reference (Loc,
4424 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4425 Attribute_Name => Name_Write,
4426 Expressions => New_List (
4427 Make_Attribute_Reference (Loc,
4429 New_Occurrence_Of (Stream_Parameter, Loc),
4430 Attribute_Name => Name_Access),
4431 New_Occurrence_Of (Standard_False, Loc))));
4433 Append_To (Statements,
4434 Make_Implicit_If_Statement (Nod,
4435 Condition => Asynchronous,
4436 Then_Statements => Asynchronous_Statements,
4437 Else_Statements => Non_Asynchronous_Statements));
4439 end Build_General_Calling_Stubs;
4441 -----------------------------
4442 -- Build_RPC_Receiver_Body --
4443 -----------------------------
4445 procedure Build_RPC_Receiver_Body
4446 (RPC_Receiver : Entity_Id;
4447 Request : out Entity_Id;
4448 Subp_Id : out Entity_Id;
4449 Subp_Index : out Entity_Id;
4450 Stmts : out List_Id;
4453 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4455 RPC_Receiver_Spec : Node_Id;
4456 RPC_Receiver_Decls : List_Id;
4459 Request := Make_Defining_Identifier (Loc, Name_R);
4461 RPC_Receiver_Spec :=
4462 Build_RPC_Receiver_Specification
4463 (RPC_Receiver => RPC_Receiver,
4464 Request_Parameter => Request);
4466 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4467 Subp_Index := Subp_Id;
4469 -- Subp_Id may not be a constant, because in the case of the RPC
4470 -- receiver for an RCI package, when a call is received from a RAS
4471 -- dereference, it will be assigned during subsequent processing.
4473 RPC_Receiver_Decls := New_List (
4474 Make_Object_Declaration (Loc,
4475 Defining_Identifier => Subp_Id,
4476 Object_Definition =>
4477 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4479 Make_Attribute_Reference (Loc,
4481 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4482 Attribute_Name => Name_Input,
4483 Expressions => New_List (
4484 Make_Selected_Component (Loc,
4486 Selector_Name => Name_Params)))));
4491 Make_Subprogram_Body (Loc,
4492 Specification => RPC_Receiver_Spec,
4493 Declarations => RPC_Receiver_Decls,
4494 Handled_Statement_Sequence =>
4495 Make_Handled_Sequence_Of_Statements (Loc,
4496 Statements => Stmts));
4497 end Build_RPC_Receiver_Body;
4499 -----------------------
4500 -- Build_Stub_Target --
4501 -----------------------
4503 function Build_Stub_Target
4506 RCI_Locator : Entity_Id;
4507 Controlling_Parameter : Entity_Id) return RPC_Target
4509 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4511 Target_Info.Partition :=
4512 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4513 if Present (Controlling_Parameter) then
4515 Make_Object_Declaration (Loc,
4516 Defining_Identifier => Target_Info.Partition,
4517 Constant_Present => True,
4518 Object_Definition =>
4519 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4522 Make_Selected_Component (Loc,
4523 Prefix => Controlling_Parameter,
4524 Selector_Name => Name_Origin)));
4526 Target_Info.RPC_Receiver :=
4527 Make_Selected_Component (Loc,
4528 Prefix => Controlling_Parameter,
4529 Selector_Name => Name_Receiver);
4533 Make_Object_Declaration (Loc,
4534 Defining_Identifier => Target_Info.Partition,
4535 Constant_Present => True,
4536 Object_Definition =>
4537 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4540 Make_Function_Call (Loc,
4541 Name => Make_Selected_Component (Loc,
4543 Make_Identifier (Loc, Chars (RCI_Locator)),
4545 Make_Identifier (Loc,
4546 Name_Get_Active_Partition_ID)))));
4548 Target_Info.RPC_Receiver :=
4549 Make_Selected_Component (Loc,
4551 Make_Identifier (Loc, Chars (RCI_Locator)),
4553 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4556 end Build_Stub_Target;
4558 ---------------------
4559 -- Build_Stub_Type --
4560 ---------------------
4562 procedure Build_Stub_Type
4563 (RACW_Type : Entity_Id;
4564 Stub_Type : Entity_Id;
4565 Stub_Type_Decl : out Node_Id;
4566 RPC_Receiver_Decl : out Node_Id)
4568 Loc : constant Source_Ptr := Sloc (Stub_Type);
4569 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4573 Make_Full_Type_Declaration (Loc,
4574 Defining_Identifier => Stub_Type,
4576 Make_Record_Definition (Loc,
4577 Tagged_Present => True,
4578 Limited_Present => True,
4580 Make_Component_List (Loc,
4581 Component_Items => New_List (
4583 Make_Component_Declaration (Loc,
4584 Defining_Identifier =>
4585 Make_Defining_Identifier (Loc, Name_Origin),
4586 Component_Definition =>
4587 Make_Component_Definition (Loc,
4588 Aliased_Present => False,
4589 Subtype_Indication =>
4591 RTE (RE_Partition_ID), Loc))),
4593 Make_Component_Declaration (Loc,
4594 Defining_Identifier =>
4595 Make_Defining_Identifier (Loc, Name_Receiver),
4596 Component_Definition =>
4597 Make_Component_Definition (Loc,
4598 Aliased_Present => False,
4599 Subtype_Indication =>
4600 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4602 Make_Component_Declaration (Loc,
4603 Defining_Identifier =>
4604 Make_Defining_Identifier (Loc, Name_Addr),
4605 Component_Definition =>
4606 Make_Component_Definition (Loc,
4607 Aliased_Present => False,
4608 Subtype_Indication =>
4609 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4611 Make_Component_Declaration (Loc,
4612 Defining_Identifier =>
4613 Make_Defining_Identifier (Loc, Name_Asynchronous),
4614 Component_Definition =>
4615 Make_Component_Definition (Loc,
4616 Aliased_Present => False,
4617 Subtype_Indication =>
4619 Standard_Boolean, Loc)))))));
4622 RPC_Receiver_Decl := Empty;
4625 RPC_Receiver_Request : constant Entity_Id :=
4626 Make_Defining_Identifier (Loc, Name_R);
4628 RPC_Receiver_Decl :=
4629 Make_Subprogram_Declaration (Loc,
4630 Build_RPC_Receiver_Specification (
4631 RPC_Receiver => Make_Defining_Identifier (Loc,
4632 New_Internal_Name ('R')),
4633 Request_Parameter => RPC_Receiver_Request));
4636 end Build_Stub_Type;
4638 --------------------------------------
4639 -- Build_Subprogram_Receiving_Stubs --
4640 --------------------------------------
4642 function Build_Subprogram_Receiving_Stubs
4643 (Vis_Decl : Node_Id;
4644 Asynchronous : Boolean;
4645 Dynamically_Asynchronous : Boolean := False;
4646 Stub_Type : Entity_Id := Empty;
4647 RACW_Type : Entity_Id := Empty;
4648 Parent_Primitive : Entity_Id := Empty) return Node_Id
4650 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4652 Request_Parameter : constant Entity_Id :=
4653 Make_Defining_Identifier (Loc,
4654 New_Internal_Name ('R'));
4655 -- Formal parameter for receiving stubs: a descriptor for an incoming
4658 Decls : constant List_Id := New_List;
4659 -- All the parameters will get declared before calling the real
4660 -- subprograms. Also the out parameters will be declared.
4662 Statements : constant List_Id := New_List;
4664 Extra_Formal_Statements : constant List_Id := New_List;
4665 -- Statements concerning extra formal parameters
4667 After_Statements : constant List_Id := New_List;
4668 -- Statements to be executed after the subprogram call
4670 Inner_Decls : List_Id := No_List;
4671 -- In case of a function, the inner declarations are needed since
4672 -- the result may be unconstrained.
4674 Excep_Handlers : List_Id := No_List;
4675 Excep_Choice : Entity_Id;
4676 Excep_Code : List_Id;
4678 Parameter_List : constant List_Id := New_List;
4679 -- List of parameters to be passed to the subprogram
4681 Current_Parameter : Node_Id;
4683 Ordered_Parameters_List : constant List_Id :=
4684 Build_Ordered_Parameters_List
4685 (Specification (Vis_Decl));
4687 Subp_Spec : Node_Id;
4688 -- Subprogram specification
4690 Called_Subprogram : Node_Id;
4691 -- The subprogram to call
4693 Null_Raise_Statement : Node_Id;
4695 Dynamic_Async : Entity_Id;
4698 if Present (RACW_Type) then
4699 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4701 Called_Subprogram :=
4703 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4706 if Dynamically_Asynchronous then
4708 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4710 Dynamic_Async := Empty;
4713 if not Asynchronous or Dynamically_Asynchronous then
4715 -- The first statement after the subprogram call is a statement to
4716 -- write a Null_Occurrence into the result stream.
4718 Null_Raise_Statement :=
4719 Make_Attribute_Reference (Loc,
4721 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4722 Attribute_Name => Name_Write,
4723 Expressions => New_List (
4724 Make_Selected_Component (Loc,
4725 Prefix => Request_Parameter,
4726 Selector_Name => Name_Result),
4727 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4729 if Dynamically_Asynchronous then
4730 Null_Raise_Statement :=
4731 Make_Implicit_If_Statement (Vis_Decl,
4733 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4734 Then_Statements => New_List (Null_Raise_Statement));
4737 Append_To (After_Statements, Null_Raise_Statement);
4740 -- Loop through every parameter and get its value from the stream. If
4741 -- the parameter is unconstrained, then the parameter is read using
4742 -- 'Input at the point of declaration.
4744 Current_Parameter := First (Ordered_Parameters_List);
4745 while Present (Current_Parameter) loop
4748 Constrained : Boolean;
4750 Need_Extra_Constrained : Boolean;
4751 -- True when an Extra_Constrained actual is required
4753 Object : constant Entity_Id :=
4754 Make_Defining_Identifier (Loc,
4755 New_Internal_Name ('P'));
4757 Expr : Node_Id := Empty;
4759 Is_Controlling_Formal : constant Boolean :=
4760 Is_RACW_Controlling_Formal
4761 (Current_Parameter, Stub_Type);
4764 if Is_Controlling_Formal then
4766 -- We have a controlling formal parameter. Read its address
4767 -- rather than a real object. The address is in Unsigned_64
4770 Etyp := RTE (RE_Unsigned_64);
4772 Etyp := Etype (Parameter_Type (Current_Parameter));
4776 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
4778 if In_Present (Current_Parameter)
4779 or else not Out_Present (Current_Parameter)
4780 or else not Constrained
4781 or else Is_Controlling_Formal
4783 -- If an input parameter is constrained, then the read of
4784 -- the parameter is deferred until the beginning of the
4785 -- subprogram body. If it is unconstrained, then an
4786 -- expression is built for the object declaration and the
4787 -- variable is set using 'Input instead of 'Read. Note that
4788 -- this deferral does not change the order in which the
4789 -- actuals are read because Build_Ordered_Parameter_List
4790 -- puts them unconstrained first.
4793 Append_To (Statements,
4794 Make_Attribute_Reference (Loc,
4795 Prefix => New_Occurrence_Of (Etyp, Loc),
4796 Attribute_Name => Name_Read,
4797 Expressions => New_List (
4798 Make_Selected_Component (Loc,
4799 Prefix => Request_Parameter,
4800 Selector_Name => Name_Params),
4801 New_Occurrence_Of (Object, Loc))));
4805 -- Build and append Input_With_Tag_Check function
4808 Input_With_Tag_Check (Loc,
4810 Stream => Make_Selected_Component (Loc,
4811 Prefix => Request_Parameter,
4812 Selector_Name => Name_Params)));
4814 -- Prepare function call expression
4816 Expr := Make_Function_Call (Loc,
4817 New_Occurrence_Of (Defining_Unit_Name
4818 (Specification (Last (Decls))), Loc));
4822 Need_Extra_Constrained :=
4823 Nkind (Parameter_Type (Current_Parameter)) /=
4826 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4828 Present (Extra_Constrained
4829 (Defining_Identifier (Current_Parameter)));
4831 -- We may not associate an extra constrained actual to a
4832 -- constant object, so if one is needed, declare the actual
4833 -- as a variable even if it won't be modified.
4835 Build_Actual_Object_Declaration
4838 Variable => Need_Extra_Constrained
4839 or else Out_Present (Current_Parameter),
4843 -- An out parameter may be written back using a 'Write
4844 -- attribute instead of a 'Output because it has been
4845 -- constrained by the parameter given to the caller. Note that
4846 -- out controlling arguments in the case of a RACW are not put
4847 -- back in the stream because the pointer on them has not
4850 if Out_Present (Current_Parameter)
4852 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4854 Append_To (After_Statements,
4855 Make_Attribute_Reference (Loc,
4856 Prefix => New_Occurrence_Of (Etyp, Loc),
4857 Attribute_Name => Name_Write,
4858 Expressions => New_List (
4859 Make_Selected_Component (Loc,
4860 Prefix => Request_Parameter,
4861 Selector_Name => Name_Result),
4862 New_Occurrence_Of (Object, Loc))));
4865 -- For RACW controlling formals, the Etyp of Object is always
4866 -- an RACW, even if the parameter is not of an anonymous access
4867 -- type. In such case, we need to dereference it at call time.
4869 if Is_Controlling_Formal then
4870 if Nkind (Parameter_Type (Current_Parameter)) /=
4873 Append_To (Parameter_List,
4874 Make_Parameter_Association (Loc,
4877 Defining_Identifier (Current_Parameter), Loc),
4878 Explicit_Actual_Parameter =>
4879 Make_Explicit_Dereference (Loc,
4880 Unchecked_Convert_To (RACW_Type,
4881 OK_Convert_To (RTE (RE_Address),
4882 New_Occurrence_Of (Object, Loc))))));
4885 Append_To (Parameter_List,
4886 Make_Parameter_Association (Loc,
4889 Defining_Identifier (Current_Parameter), Loc),
4890 Explicit_Actual_Parameter =>
4891 Unchecked_Convert_To (RACW_Type,
4892 OK_Convert_To (RTE (RE_Address),
4893 New_Occurrence_Of (Object, Loc)))));
4897 Append_To (Parameter_List,
4898 Make_Parameter_Association (Loc,
4901 Defining_Identifier (Current_Parameter), Loc),
4902 Explicit_Actual_Parameter =>
4903 New_Occurrence_Of (Object, Loc)));
4906 -- If the current parameter needs an extra formal, then read it
4907 -- from the stream and set the corresponding semantic field in
4908 -- the variable. If the kind of the parameter identifier is
4909 -- E_Void, then this is a compiler generated parameter that
4910 -- doesn't need an extra constrained status.
4912 -- The case of Extra_Accessibility should also be handled ???
4914 if Need_Extra_Constrained then
4916 Extra_Parameter : constant Entity_Id :=
4918 (Defining_Identifier
4919 (Current_Parameter));
4921 Formal_Entity : constant Entity_Id :=
4922 Make_Defining_Identifier
4923 (Loc, Chars (Extra_Parameter));
4925 Formal_Type : constant Entity_Id :=
4926 Etype (Extra_Parameter);
4930 Make_Object_Declaration (Loc,
4931 Defining_Identifier => Formal_Entity,
4932 Object_Definition =>
4933 New_Occurrence_Of (Formal_Type, Loc)));
4935 Append_To (Extra_Formal_Statements,
4936 Make_Attribute_Reference (Loc,
4937 Prefix => New_Occurrence_Of (
4939 Attribute_Name => Name_Read,
4940 Expressions => New_List (
4941 Make_Selected_Component (Loc,
4942 Prefix => Request_Parameter,
4943 Selector_Name => Name_Params),
4944 New_Occurrence_Of (Formal_Entity, Loc))));
4946 -- Note: the call to Set_Extra_Constrained below relies
4947 -- on the fact that Object's Ekind has been set by
4948 -- Build_Actual_Object_Declaration.
4950 Set_Extra_Constrained (Object, Formal_Entity);
4955 Next (Current_Parameter);
4958 -- Append the formal statements list at the end of regular statements
4960 Append_List_To (Statements, Extra_Formal_Statements);
4962 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
4964 -- The remote subprogram is a function. We build an inner block to
4965 -- be able to hold a potentially unconstrained result in a
4969 Etyp : constant Entity_Id :=
4970 Etype (Result_Definition (Specification (Vis_Decl)));
4971 Result : constant Node_Id :=
4972 Make_Defining_Identifier (Loc,
4973 New_Internal_Name ('R'));
4975 Inner_Decls := New_List (
4976 Make_Object_Declaration (Loc,
4977 Defining_Identifier => Result,
4978 Constant_Present => True,
4979 Object_Definition => New_Occurrence_Of (Etyp, Loc),
4981 Make_Function_Call (Loc,
4982 Name => Called_Subprogram,
4983 Parameter_Associations => Parameter_List)));
4985 if Is_Class_Wide_Type (Etyp) then
4987 -- For a remote call to a function with a class-wide type,
4988 -- check that the returned value satisfies the requirements
4991 Append_To (Inner_Decls,
4992 Make_Transportable_Check (Loc,
4993 New_Occurrence_Of (Result, Loc)));
4997 Append_To (After_Statements,
4998 Make_Attribute_Reference (Loc,
4999 Prefix => New_Occurrence_Of (Etyp, Loc),
5000 Attribute_Name => Name_Output,
5001 Expressions => New_List (
5002 Make_Selected_Component (Loc,
5003 Prefix => Request_Parameter,
5004 Selector_Name => Name_Result),
5005 New_Occurrence_Of (Result, Loc))));
5008 Append_To (Statements,
5009 Make_Block_Statement (Loc,
5010 Declarations => Inner_Decls,
5011 Handled_Statement_Sequence =>
5012 Make_Handled_Sequence_Of_Statements (Loc,
5013 Statements => After_Statements)));
5016 -- The remote subprogram is a procedure. We do not need any inner
5017 -- block in this case.
5019 if Dynamically_Asynchronous then
5021 Make_Object_Declaration (Loc,
5022 Defining_Identifier => Dynamic_Async,
5023 Object_Definition =>
5024 New_Occurrence_Of (Standard_Boolean, Loc)));
5026 Append_To (Statements,
5027 Make_Attribute_Reference (Loc,
5028 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5029 Attribute_Name => Name_Read,
5030 Expressions => New_List (
5031 Make_Selected_Component (Loc,
5032 Prefix => Request_Parameter,
5033 Selector_Name => Name_Params),
5034 New_Occurrence_Of (Dynamic_Async, Loc))));
5037 Append_To (Statements,
5038 Make_Procedure_Call_Statement (Loc,
5039 Name => Called_Subprogram,
5040 Parameter_Associations => Parameter_List));
5042 Append_List_To (Statements, After_Statements);
5045 if Asynchronous and then not Dynamically_Asynchronous then
5047 -- For an asynchronous procedure, add a null exception handler
5049 Excep_Handlers := New_List (
5050 Make_Implicit_Exception_Handler (Loc,
5051 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5052 Statements => New_List (Make_Null_Statement (Loc))));
5055 -- In the other cases, if an exception is raised, then the
5056 -- exception occurrence is copied into the output stream and
5057 -- no other output parameter is written.
5060 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5062 Excep_Code := New_List (
5063 Make_Attribute_Reference (Loc,
5065 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5066 Attribute_Name => Name_Write,
5067 Expressions => New_List (
5068 Make_Selected_Component (Loc,
5069 Prefix => Request_Parameter,
5070 Selector_Name => Name_Result),
5071 New_Occurrence_Of (Excep_Choice, Loc))));
5073 if Dynamically_Asynchronous then
5074 Excep_Code := New_List (
5075 Make_Implicit_If_Statement (Vis_Decl,
5076 Condition => Make_Op_Not (Loc,
5077 New_Occurrence_Of (Dynamic_Async, Loc)),
5078 Then_Statements => Excep_Code));
5081 Excep_Handlers := New_List (
5082 Make_Implicit_Exception_Handler (Loc,
5083 Choice_Parameter => Excep_Choice,
5084 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5085 Statements => Excep_Code));
5090 Make_Procedure_Specification (Loc,
5091 Defining_Unit_Name =>
5092 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
5094 Parameter_Specifications => New_List (
5095 Make_Parameter_Specification (Loc,
5096 Defining_Identifier => Request_Parameter,
5098 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5101 Make_Subprogram_Body (Loc,
5102 Specification => Subp_Spec,
5103 Declarations => Decls,
5104 Handled_Statement_Sequence =>
5105 Make_Handled_Sequence_Of_Statements (Loc,
5106 Statements => Statements,
5107 Exception_Handlers => Excep_Handlers));
5108 end Build_Subprogram_Receiving_Stubs;
5114 function Result return Node_Id is
5116 return Make_Identifier (Loc, Name_V);
5119 ----------------------
5120 -- Stream_Parameter --
5121 ----------------------
5123 function Stream_Parameter return Node_Id is
5125 return Make_Identifier (Loc, Name_S);
5126 end Stream_Parameter;
5130 -------------------------------
5131 -- Get_And_Reset_RACW_Bodies --
5132 -------------------------------
5134 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5135 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
5136 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5138 Body_Decls : List_Id;
5139 -- Returned list of declarations
5142 if Stub_Elements = Empty_Stub_Structure then
5144 -- Stub elements may be missing as a consequence of a previously
5150 Body_Decls := Stub_Elements.Body_Decls;
5151 Stub_Elements.Body_Decls := No_List;
5152 Stubs_Table.Set (Desig, Stub_Elements);
5154 end Get_And_Reset_RACW_Bodies;
5156 -----------------------
5157 -- Get_Subprogram_Id --
5158 -----------------------
5160 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5161 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5163 pragma Assert (Result /= No_String);
5165 end Get_Subprogram_Id;
5167 -----------------------
5168 -- Get_Subprogram_Id --
5169 -----------------------
5171 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5173 return Get_Subprogram_Ids (Def).Int_Identifier;
5174 end Get_Subprogram_Id;
5176 ------------------------
5177 -- Get_Subprogram_Ids --
5178 ------------------------
5180 function Get_Subprogram_Ids
5181 (Def : Entity_Id) return Subprogram_Identifiers
5184 return Subprogram_Identifier_Table.Get (Def);
5185 end Get_Subprogram_Ids;
5191 function Hash (F : Entity_Id) return Hash_Index is
5193 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5196 function Hash (F : Name_Id) return Hash_Index is
5198 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5201 --------------------------
5202 -- Input_With_Tag_Check --
5203 --------------------------
5205 function Input_With_Tag_Check
5207 Var_Type : Entity_Id;
5208 Stream : Node_Id) return Node_Id
5212 Make_Subprogram_Body (Loc,
5213 Specification => Make_Function_Specification (Loc,
5214 Defining_Unit_Name =>
5215 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
5216 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5217 Declarations => No_List,
5218 Handled_Statement_Sequence =>
5219 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5220 Make_Tag_Check (Loc,
5221 Make_Return_Statement (Loc,
5222 Make_Attribute_Reference (Loc,
5223 Prefix => New_Occurrence_Of (Var_Type, Loc),
5224 Attribute_Name => Name_Input,
5226 New_List (Stream)))))));
5227 end Input_With_Tag_Check;
5229 --------------------------------
5230 -- Is_RACW_Controlling_Formal --
5231 --------------------------------
5233 function Is_RACW_Controlling_Formal
5234 (Parameter : Node_Id;
5235 Stub_Type : Entity_Id) return Boolean
5240 -- If the kind of the parameter is E_Void, then it is not a
5241 -- controlling formal (this can happen in the context of RAS).
5243 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5247 -- If the parameter is not a controlling formal, then it cannot
5248 -- be possibly a RACW_Controlling_Formal.
5250 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5254 Typ := Parameter_Type (Parameter);
5255 return (Nkind (Typ) = N_Access_Definition
5256 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5257 or else Etype (Typ) = Stub_Type;
5258 end Is_RACW_Controlling_Formal;
5260 ------------------------------
5261 -- Make_Transportable_Check --
5262 ------------------------------
5264 function Make_Transportable_Check
5266 Expr : Node_Id) return Node_Id is
5269 Make_Raise_Program_Error (Loc,
5272 Build_Get_Transportable (Loc,
5273 Make_Selected_Component (Loc,
5275 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5276 Reason => PE_Non_Transportable_Actual);
5277 end Make_Transportable_Check;
5279 -----------------------------
5280 -- Make_Selected_Component --
5281 -----------------------------
5283 function Make_Selected_Component
5286 Selector_Name : Name_Id) return Node_Id
5289 return Make_Selected_Component (Loc,
5290 Prefix => New_Occurrence_Of (Prefix, Loc),
5291 Selector_Name => Make_Identifier (Loc, Selector_Name));
5292 end Make_Selected_Component;
5294 --------------------
5295 -- Make_Tag_Check --
5296 --------------------
5298 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5299 Occ : constant Entity_Id :=
5300 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5303 return Make_Block_Statement (Loc,
5304 Handled_Statement_Sequence =>
5305 Make_Handled_Sequence_Of_Statements (Loc,
5306 Statements => New_List (N),
5308 Exception_Handlers => New_List (
5309 Make_Implicit_Exception_Handler (Loc,
5310 Choice_Parameter => Occ,
5312 Exception_Choices =>
5313 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5316 New_List (Make_Procedure_Call_Statement (Loc,
5318 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5319 New_List (New_Occurrence_Of (Occ, Loc))))))));
5322 ----------------------------
5323 -- Need_Extra_Constrained --
5324 ----------------------------
5326 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5327 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5329 return Out_Present (Parameter)
5330 and then Has_Discriminants (Etyp)
5331 and then not Is_Constrained (Etyp)
5332 and then not Is_Indefinite_Subtype (Etyp);
5333 end Need_Extra_Constrained;
5335 ------------------------------------
5336 -- Pack_Entity_Into_Stream_Access --
5337 ------------------------------------
5339 function Pack_Entity_Into_Stream_Access
5343 Etyp : Entity_Id := Empty) return Node_Id
5348 if Present (Etyp) then
5351 Typ := Etype (Object);
5355 Pack_Node_Into_Stream_Access (Loc,
5357 Object => New_Occurrence_Of (Object, Loc),
5359 end Pack_Entity_Into_Stream_Access;
5361 ---------------------------
5362 -- Pack_Node_Into_Stream --
5363 ---------------------------
5365 function Pack_Node_Into_Stream
5369 Etyp : Entity_Id) return Node_Id
5371 Write_Attribute : Name_Id := Name_Write;
5374 if not Is_Constrained (Etyp) then
5375 Write_Attribute := Name_Output;
5379 Make_Attribute_Reference (Loc,
5380 Prefix => New_Occurrence_Of (Etyp, Loc),
5381 Attribute_Name => Write_Attribute,
5382 Expressions => New_List (
5383 Make_Attribute_Reference (Loc,
5384 Prefix => New_Occurrence_Of (Stream, Loc),
5385 Attribute_Name => Name_Access),
5387 end Pack_Node_Into_Stream;
5389 ----------------------------------
5390 -- Pack_Node_Into_Stream_Access --
5391 ----------------------------------
5393 function Pack_Node_Into_Stream_Access
5397 Etyp : Entity_Id) return Node_Id
5399 Write_Attribute : Name_Id := Name_Write;
5402 if not Is_Constrained (Etyp) then
5403 Write_Attribute := Name_Output;
5407 Make_Attribute_Reference (Loc,
5408 Prefix => New_Occurrence_Of (Etyp, Loc),
5409 Attribute_Name => Write_Attribute,
5410 Expressions => New_List (
5413 end Pack_Node_Into_Stream_Access;
5415 ---------------------
5416 -- PolyORB_Support --
5417 ---------------------
5419 package body PolyORB_Support is
5421 -- Local subprograms
5423 procedure Add_RACW_Read_Attribute
5424 (RACW_Type : Entity_Id;
5425 Stub_Type : Entity_Id;
5426 Stub_Type_Access : Entity_Id;
5427 Body_Decls : List_Id);
5428 -- Add Read attribute for the RACW type. The declaration and attribute
5429 -- definition clauses are inserted right after the declaration of
5430 -- RACW_Type, while the subprogram body is appended to Body_Decls.
5432 procedure Add_RACW_Write_Attribute
5433 (RACW_Type : Entity_Id;
5434 Stub_Type : Entity_Id;
5435 Stub_Type_Access : Entity_Id;
5436 Body_Decls : List_Id);
5437 -- Same as above for the Write attribute
5439 procedure Add_RACW_From_Any
5440 (RACW_Type : Entity_Id;
5441 Stub_Type : Entity_Id;
5442 Stub_Type_Access : Entity_Id;
5443 Body_Decls : List_Id);
5444 -- Add the From_Any TSS for this RACW type
5446 procedure Add_RACW_To_Any
5447 (Designated_Type : Entity_Id;
5448 RACW_Type : Entity_Id;
5449 Stub_Type : Entity_Id;
5450 Stub_Type_Access : Entity_Id;
5451 Body_Decls : List_Id);
5452 -- Add the To_Any TSS for this RACW type
5454 procedure Add_RACW_TypeCode
5455 (Designated_Type : Entity_Id;
5456 RACW_Type : Entity_Id;
5457 Body_Decls : List_Id);
5458 -- Add the TypeCode TSS for this RACW type
5460 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5461 -- Add the From_Any TSS for this RAS type
5463 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5464 -- Add the To_Any TSS for this RAS type
5466 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5467 -- Add the TypeCode TSS for this RAS type
5469 procedure Add_RAS_Access_TSS (N : Node_Id);
5470 -- Add a subprogram body for RAS Access TSS
5472 -------------------------------------
5473 -- Add_Obj_RPC_Receiver_Completion --
5474 -------------------------------------
5476 procedure Add_Obj_RPC_Receiver_Completion
5479 RPC_Receiver : Entity_Id;
5480 Stub_Elements : Stub_Structure)
5482 Desig : constant Entity_Id :=
5483 Etype (Designated_Type (Stub_Elements.RACW_Type));
5486 Make_Procedure_Call_Statement (Loc,
5489 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5491 Parameter_Associations => New_List (
5495 Make_String_Literal (Loc,
5496 Full_Qualified_Name (Desig)),
5500 Make_Attribute_Reference (Loc,
5503 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5509 Make_Attribute_Reference (Loc,
5512 Defining_Identifier (
5513 Stub_Elements.RPC_Receiver_Decl), Loc),
5516 end Add_Obj_RPC_Receiver_Completion;
5518 -----------------------
5519 -- Add_RACW_Features --
5520 -----------------------
5522 procedure Add_RACW_Features
5523 (RACW_Type : Entity_Id;
5525 Stub_Type : Entity_Id;
5526 Stub_Type_Access : Entity_Id;
5527 RPC_Receiver_Decl : Node_Id;
5528 Body_Decls : List_Id)
5530 pragma Warnings (Off);
5531 pragma Unreferenced (RPC_Receiver_Decl);
5532 pragma Warnings (On);
5536 (RACW_Type => RACW_Type,
5537 Stub_Type => Stub_Type,
5538 Stub_Type_Access => Stub_Type_Access,
5539 Body_Decls => Body_Decls);
5542 (Designated_Type => Desig,
5543 RACW_Type => RACW_Type,
5544 Stub_Type => Stub_Type,
5545 Stub_Type_Access => Stub_Type_Access,
5546 Body_Decls => Body_Decls);
5548 -- In the PolyORB case, the RACW 'Read and 'Write attributes are
5549 -- implemented in terms of the From_Any and To_Any TSSs, so these
5550 -- TSSs must be expanded before 'Read and 'Write.
5552 Add_RACW_Write_Attribute
5553 (RACW_Type => RACW_Type,
5554 Stub_Type => Stub_Type,
5555 Stub_Type_Access => Stub_Type_Access,
5556 Body_Decls => Body_Decls);
5558 Add_RACW_Read_Attribute
5559 (RACW_Type => RACW_Type,
5560 Stub_Type => Stub_Type,
5561 Stub_Type_Access => Stub_Type_Access,
5562 Body_Decls => Body_Decls);
5565 (Designated_Type => Desig,
5566 RACW_Type => RACW_Type,
5567 Body_Decls => Body_Decls);
5568 end Add_RACW_Features;
5570 -----------------------
5571 -- Add_RACW_From_Any --
5572 -----------------------
5574 procedure Add_RACW_From_Any
5575 (RACW_Type : Entity_Id;
5576 Stub_Type : Entity_Id;
5577 Stub_Type_Access : Entity_Id;
5578 Body_Decls : List_Id)
5580 Loc : constant Source_Ptr := Sloc (RACW_Type);
5581 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5583 Fnam : constant Entity_Id :=
5584 Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
5586 Func_Spec : Node_Id;
5587 Func_Decl : Node_Id;
5588 Func_Body : Node_Id;
5591 Statements : List_Id;
5592 Stub_Statements : List_Id;
5593 Local_Statements : List_Id;
5594 -- Various parts of the subprogram
5596 Any_Parameter : constant Entity_Id :=
5597 Make_Defining_Identifier (Loc, Name_A);
5598 Reference : constant Entity_Id :=
5599 Make_Defining_Identifier
5600 (Loc, New_Internal_Name ('R'));
5601 Is_Local : constant Entity_Id :=
5602 Make_Defining_Identifier
5603 (Loc, New_Internal_Name ('L'));
5604 Addr : constant Entity_Id :=
5605 Make_Defining_Identifier
5606 (Loc, New_Internal_Name ('A'));
5607 Local_Stub : constant Entity_Id :=
5608 Make_Defining_Identifier
5609 (Loc, New_Internal_Name ('L'));
5610 Stubbed_Result : constant Entity_Id :=
5611 Make_Defining_Identifier
5612 (Loc, New_Internal_Name ('S'));
5614 Stub_Condition : Node_Id;
5615 -- An expression that determines whether we create a stub for the
5616 -- newly-unpacked RACW. Normally we create a stub only for remote
5617 -- objects, but in the case of an RACW used to implement a RAS, we
5618 -- also create a stub for local subprograms if a pragma
5619 -- All_Calls_Remote applies.
5621 Asynchronous_Flag : constant Entity_Id :=
5622 Asynchronous_Flags_Table.Get (RACW_Type);
5623 -- The flag object declared in Add_RACW_Asynchronous_Flag
5627 -- Object declarations
5630 Make_Object_Declaration (Loc,
5631 Defining_Identifier =>
5633 Object_Definition =>
5634 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5636 Make_Function_Call (Loc,
5638 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5639 Parameter_Associations => New_List (
5640 New_Occurrence_Of (Any_Parameter, Loc)))),
5642 Make_Object_Declaration (Loc,
5643 Defining_Identifier => Local_Stub,
5644 Aliased_Present => True,
5645 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
5647 Make_Object_Declaration (Loc,
5648 Defining_Identifier => Stubbed_Result,
5649 Object_Definition =>
5650 New_Occurrence_Of (Stub_Type_Access, Loc),
5652 Make_Attribute_Reference (Loc,
5654 New_Occurrence_Of (Local_Stub, Loc),
5656 Name_Unchecked_Access)),
5658 Make_Object_Declaration (Loc,
5659 Defining_Identifier => Is_Local,
5660 Object_Definition =>
5661 New_Occurrence_Of (Standard_Boolean, Loc)),
5663 Make_Object_Declaration (Loc,
5664 Defining_Identifier => Addr,
5665 Object_Definition =>
5666 New_Occurrence_Of (RTE (RE_Address), Loc)));
5668 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5670 Set_Etype (Stubbed_Result, Stub_Type_Access);
5672 -- If the ref Is_Nil, return a null pointer
5674 Statements := New_List (
5675 Make_Implicit_If_Statement (RACW_Type,
5677 Make_Function_Call (Loc,
5679 New_Occurrence_Of (RTE (RE_Is_Nil), Loc),
5680 Parameter_Associations => New_List (
5681 New_Occurrence_Of (Reference, Loc))),
5682 Then_Statements => New_List (
5683 Make_Return_Statement (Loc,
5685 Make_Null (Loc)))));
5687 Append_To (Statements,
5688 Make_Procedure_Call_Statement (Loc,
5690 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
5691 Parameter_Associations => New_List (
5692 New_Occurrence_Of (Reference, Loc),
5693 New_Occurrence_Of (Is_Local, Loc),
5694 New_Occurrence_Of (Addr, Loc))));
5696 -- If the object is located on another partition, then a stub object
5697 -- will be created with all the information needed to rebuild the
5698 -- real object at the other end. This stanza is always used in the
5699 -- case of RAS types, for which a stub is required even for local
5702 Stub_Statements := New_List (
5703 Make_Assignment_Statement (Loc,
5704 Name => Make_Selected_Component (Loc,
5705 Prefix => Stubbed_Result,
5706 Selector_Name => Name_Target),
5708 Make_Function_Call (Loc,
5710 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
5711 Parameter_Associations => New_List (
5712 New_Occurrence_Of (Reference, Loc)))),
5714 Make_Procedure_Call_Statement (Loc,
5716 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
5717 Parameter_Associations => New_List (
5718 Make_Selected_Component (Loc,
5719 Prefix => Stubbed_Result,
5720 Selector_Name => Name_Target))),
5722 Make_Assignment_Statement (Loc,
5723 Name => Make_Selected_Component (Loc,
5724 Prefix => Stubbed_Result,
5725 Selector_Name => Name_Asynchronous),
5727 New_Occurrence_Of (Asynchronous_Flag, Loc)));
5729 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5730 -- set on the stub type if, and only if, the RACW type has a pragma
5731 -- Asynchronous. This is incorrect for RACWs that implement RAS
5732 -- types, because in that case the /designated subprogram/ (not the
5733 -- type) might be asynchronous, and that causes the stub to need to
5734 -- be asynchronous too. A solution is to transport a RAS as a struct
5735 -- containing a RACW and an asynchronous flag, and to properly alter
5736 -- the Asynchronous component in the stub type in the RAS's _From_Any
5739 Append_List_To (Stub_Statements,
5740 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
5742 -- Distinguish between the local and remote cases, and execute the
5743 -- appropriate piece of code.
5745 Stub_Condition := New_Occurrence_Of (Is_Local, Loc);
5748 Stub_Condition := Make_And_Then (Loc,
5752 Make_Selected_Component (Loc,
5754 Unchecked_Convert_To (
5755 RTE (RE_RAS_Proxy_Type_Access),
5756 New_Occurrence_Of (Addr, Loc)),
5758 Make_Identifier (Loc,
5759 Name_All_Calls_Remote)));
5762 Local_Statements := New_List (
5763 Make_Return_Statement (Loc,
5765 Unchecked_Convert_To (RACW_Type,
5766 New_Occurrence_Of (Addr, Loc))));
5768 Append_To (Statements,
5769 Make_Implicit_If_Statement (RACW_Type,
5772 Then_Statements => Local_Statements,
5773 Else_Statements => Stub_Statements));
5775 Append_To (Statements,
5776 Make_Return_Statement (Loc,
5777 Expression => Unchecked_Convert_To (RACW_Type,
5778 New_Occurrence_Of (Stubbed_Result, Loc))));
5781 Make_Function_Specification (Loc,
5782 Defining_Unit_Name =>
5784 Parameter_Specifications => New_List (
5785 Make_Parameter_Specification (Loc,
5786 Defining_Identifier =>
5789 New_Occurrence_Of (RTE (RE_Any), Loc))),
5790 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5792 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5793 -- entity in the declaration spec, not those of the body spec.
5795 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5798 Make_Subprogram_Body (Loc,
5800 Copy_Specification (Loc, Func_Spec),
5801 Declarations => Decls,
5802 Handled_Statement_Sequence =>
5803 Make_Handled_Sequence_Of_Statements (Loc,
5804 Statements => Statements));
5806 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5807 Append_To (Body_Decls, Func_Body);
5809 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5810 end Add_RACW_From_Any;
5812 -----------------------------
5813 -- Add_RACW_Read_Attribute --
5814 -----------------------------
5816 procedure Add_RACW_Read_Attribute
5817 (RACW_Type : Entity_Id;
5818 Stub_Type : Entity_Id;
5819 Stub_Type_Access : Entity_Id;
5820 Body_Decls : List_Id)
5822 pragma Warnings (Off);
5823 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5824 pragma Warnings (On);
5825 Loc : constant Source_Ptr := Sloc (RACW_Type);
5827 Proc_Decl : Node_Id;
5828 Attr_Decl : Node_Id;
5830 Body_Node : Node_Id;
5833 Statements : List_Id;
5834 -- Various parts of the procedure
5836 Procedure_Name : constant Name_Id :=
5837 New_Internal_Name ('R');
5838 Source_Ref : constant Entity_Id :=
5839 Make_Defining_Identifier
5840 (Loc, New_Internal_Name ('R'));
5841 Asynchronous_Flag : constant Entity_Id :=
5842 Asynchronous_Flags_Table.Get (RACW_Type);
5843 pragma Assert (Present (Asynchronous_Flag));
5845 function Stream_Parameter return Node_Id;
5846 function Result return Node_Id;
5847 -- Functions to create occurrences of the formal parameter names
5853 function Result return Node_Id is
5855 return Make_Identifier (Loc, Name_V);
5858 ----------------------
5859 -- Stream_Parameter --
5860 ----------------------
5862 function Stream_Parameter return Node_Id is
5864 return Make_Identifier (Loc, Name_S);
5865 end Stream_Parameter;
5867 -- Start of processing for Add_RACW_Read_Attribute
5870 -- Generate object declarations
5873 Make_Object_Declaration (Loc,
5874 Defining_Identifier => Source_Ref,
5875 Object_Definition =>
5876 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5878 Statements := New_List (
5879 Make_Attribute_Reference (Loc,
5881 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5882 Attribute_Name => Name_Read,
5883 Expressions => New_List (
5885 New_Occurrence_Of (Source_Ref, Loc))),
5886 Make_Assignment_Statement (Loc,
5890 PolyORB_Support.Helpers.Build_From_Any_Call (
5892 Make_Function_Call (Loc,
5894 New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5895 Parameter_Associations => New_List (
5896 New_Occurrence_Of (Source_Ref, Loc))),
5899 Build_Stream_Procedure
5900 (Loc, RACW_Type, Body_Node,
5901 Make_Defining_Identifier (Loc, Procedure_Name),
5902 Statements, Outp => True);
5903 Set_Declarations (Body_Node, Decls);
5905 Proc_Decl := Make_Subprogram_Declaration (Loc,
5906 Copy_Specification (Loc, Specification (Body_Node)));
5909 Make_Attribute_Definition_Clause (Loc,
5910 Name => New_Occurrence_Of (RACW_Type, Loc),
5914 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5916 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5917 Insert_After (Proc_Decl, Attr_Decl);
5918 Append_To (Body_Decls, Body_Node);
5919 end Add_RACW_Read_Attribute;
5921 ---------------------
5922 -- Add_RACW_To_Any --
5923 ---------------------
5925 procedure Add_RACW_To_Any
5926 (Designated_Type : Entity_Id;
5927 RACW_Type : Entity_Id;
5928 Stub_Type : Entity_Id;
5929 Stub_Type_Access : Entity_Id;
5930 Body_Decls : List_Id)
5932 Loc : constant Source_Ptr := Sloc (RACW_Type);
5934 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5938 Stub_Elements : constant Stub_Structure :=
5939 Stubs_Table.Get (Designated_Type);
5940 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5942 Func_Spec : Node_Id;
5943 Func_Decl : Node_Id;
5944 Func_Body : Node_Id;
5947 Statements : List_Id;
5948 Null_Statements : List_Id;
5949 Local_Statements : List_Id := No_List;
5950 Stub_Statements : List_Id;
5952 -- Various parts of the subprogram
5954 RACW_Parameter : constant Entity_Id
5955 := Make_Defining_Identifier (Loc, Name_R);
5957 Reference : constant Entity_Id :=
5958 Make_Defining_Identifier
5959 (Loc, New_Internal_Name ('R'));
5960 Any : constant Entity_Id :=
5961 Make_Defining_Identifier
5962 (Loc, New_Internal_Name ('A'));
5966 -- Object declarations
5969 Make_Object_Declaration (Loc,
5970 Defining_Identifier =>
5972 Object_Definition =>
5973 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
5974 Make_Object_Declaration (Loc,
5975 Defining_Identifier =>
5977 Object_Definition =>
5978 New_Occurrence_Of (RTE (RE_Any), Loc)));
5980 -- If the object is null, nothing to do (Reference is already
5983 Null_Statements := New_List (Make_Null_Statement (Loc));
5987 -- If the object is a RAS designating a local subprogram, we
5988 -- already have a target reference.
5990 Local_Statements := New_List (
5991 Make_Procedure_Call_Statement (Loc,
5993 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
5994 Parameter_Associations => New_List (
5995 New_Occurrence_Of (Reference, Loc),
5996 Make_Selected_Component (Loc,
5998 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
5999 New_Occurrence_Of (RACW_Parameter, Loc)),
6000 Selector_Name => Make_Identifier (Loc, Name_Target)))));
6003 -- If the object is a local RACW object, use Get_Reference now to
6004 -- obtain a reference.
6006 Local_Statements := New_List (
6007 Make_Procedure_Call_Statement (Loc,
6009 New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6010 Parameter_Associations => New_List (
6011 Unchecked_Convert_To (
6013 New_Occurrence_Of (RACW_Parameter, Loc)),
6014 Make_String_Literal (Loc,
6015 Full_Qualified_Name (Designated_Type)),
6016 Make_Attribute_Reference (Loc,
6019 Defining_Identifier (
6020 Stub_Elements.RPC_Receiver_Decl), Loc),
6023 New_Occurrence_Of (Reference, Loc))));
6026 -- If the object is located on another partition, use the target from
6029 Stub_Statements := New_List (
6030 Make_Procedure_Call_Statement (Loc,
6032 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
6033 Parameter_Associations => New_List (
6034 New_Occurrence_Of (Reference, Loc),
6035 Make_Selected_Component (Loc,
6036 Prefix => Unchecked_Convert_To (Stub_Type_Access,
6037 New_Occurrence_Of (RACW_Parameter, Loc)),
6039 Make_Identifier (Loc, Name_Target)))));
6041 -- Distinguish between the null, local and remote cases, and execute
6042 -- the appropriate piece of code.
6045 Make_Implicit_If_Statement (RACW_Type,
6048 Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc),
6049 Right_Opnd => Make_Null (Loc)),
6050 Then_Statements => Null_Statements,
6051 Elsif_Parts => New_List (
6052 Make_Elsif_Part (Loc,
6056 Make_Attribute_Reference (Loc,
6058 New_Occurrence_Of (RACW_Parameter, Loc),
6059 Attribute_Name => Name_Tag),
6061 Make_Attribute_Reference (Loc,
6062 Prefix => New_Occurrence_Of (Stub_Type, Loc),
6063 Attribute_Name => Name_Tag)),
6064 Then_Statements => Local_Statements)),
6065 Else_Statements => Stub_Statements);
6067 Statements := New_List (
6069 Make_Assignment_Statement (Loc,
6071 New_Occurrence_Of (Any, Loc),
6073 Make_Function_Call (Loc,
6074 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
6075 Parameter_Associations => New_List (
6076 New_Occurrence_Of (Reference, Loc)))),
6077 Make_Procedure_Call_Statement (Loc,
6079 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6080 Parameter_Associations => New_List (
6081 New_Occurrence_Of (Any, Loc),
6082 Make_Selected_Component (Loc,
6084 Defining_Identifier (
6085 Stub_Elements.RPC_Receiver_Decl),
6086 Selector_Name => Name_Obj_TypeCode))),
6087 Make_Return_Statement (Loc,
6089 New_Occurrence_Of (Any, Loc)));
6091 Fnam := Make_Defining_Identifier (
6092 Loc, New_Internal_Name ('T'));
6095 Make_Function_Specification (Loc,
6096 Defining_Unit_Name =>
6098 Parameter_Specifications => New_List (
6099 Make_Parameter_Specification (Loc,
6100 Defining_Identifier =>
6103 New_Occurrence_Of (RACW_Type, Loc))),
6104 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6106 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6107 -- entity in the declaration spec, not in the body spec.
6109 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6112 Make_Subprogram_Body (Loc,
6114 Copy_Specification (Loc, Func_Spec),
6115 Declarations => Decls,
6116 Handled_Statement_Sequence =>
6117 Make_Handled_Sequence_Of_Statements (Loc,
6118 Statements => Statements));
6120 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6121 Append_To (Body_Decls, Func_Body);
6123 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
6124 end Add_RACW_To_Any;
6126 -----------------------
6127 -- Add_RACW_TypeCode --
6128 -----------------------
6130 procedure Add_RACW_TypeCode
6131 (Designated_Type : Entity_Id;
6132 RACW_Type : Entity_Id;
6133 Body_Decls : List_Id)
6135 Loc : constant Source_Ptr := Sloc (RACW_Type);
6139 Stub_Elements : constant Stub_Structure :=
6140 Stubs_Table.Get (Designated_Type);
6141 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6143 Func_Spec : Node_Id;
6144 Func_Decl : Node_Id;
6145 Func_Body : Node_Id;
6149 Make_Defining_Identifier (Loc,
6150 Chars => New_Internal_Name ('T'));
6152 -- The spec for this subprogram has a dummy 'access RACW' argument,
6153 -- which serves only for overloading purposes.
6156 Make_Function_Specification (Loc,
6157 Defining_Unit_Name =>
6159 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6161 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6162 -- entity in the declaration spec, not those of the body spec.
6164 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6167 Make_Subprogram_Body (Loc,
6169 Copy_Specification (Loc, Func_Spec),
6170 Declarations => Empty_List,
6171 Handled_Statement_Sequence =>
6172 Make_Handled_Sequence_Of_Statements (Loc,
6173 Statements => New_List (
6174 Make_Return_Statement (Loc,
6176 Make_Selected_Component (Loc,
6178 Defining_Identifier (
6179 Stub_Elements.RPC_Receiver_Decl),
6180 Selector_Name => Name_Obj_TypeCode)))));
6182 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6183 Append_To (Body_Decls, Func_Body);
6185 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6186 end Add_RACW_TypeCode;
6188 ------------------------------
6189 -- Add_RACW_Write_Attribute --
6190 ------------------------------
6192 procedure Add_RACW_Write_Attribute
6193 (RACW_Type : Entity_Id;
6194 Stub_Type : Entity_Id;
6195 Stub_Type_Access : Entity_Id;
6196 Body_Decls : List_Id)
6198 pragma Warnings (Off);
6199 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6200 pragma Warnings (On);
6202 Loc : constant Source_Ptr := Sloc (RACW_Type);
6204 Body_Node : Node_Id;
6205 Proc_Decl : Node_Id;
6206 Attr_Decl : Node_Id;
6208 Statements : List_Id;
6209 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
6211 function Stream_Parameter return Node_Id;
6212 function Object return Node_Id;
6213 -- Functions to create occurrences of the formal parameter names
6219 function Object return Node_Id is
6220 Object_Ref : constant Node_Id :=
6221 Make_Identifier (Loc, Name_V);
6224 -- Etype must be set for Build_To_Any_Call
6226 Set_Etype (Object_Ref, RACW_Type);
6231 ----------------------
6232 -- Stream_Parameter --
6233 ----------------------
6235 function Stream_Parameter return Node_Id is
6237 return Make_Identifier (Loc, Name_S);
6238 end Stream_Parameter;
6240 -- Start of processing for Add_RACW_Write_Attribute
6243 Statements := New_List (
6244 Pack_Node_Into_Stream_Access (Loc,
6245 Stream => Stream_Parameter,
6247 Make_Function_Call (Loc,
6249 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
6250 Parameter_Associations => New_List (
6251 PolyORB_Support.Helpers.Build_To_Any_Call
6252 (Object, Body_Decls))),
6253 Etyp => RTE (RE_Object_Ref)));
6255 Build_Stream_Procedure
6256 (Loc, RACW_Type, Body_Node,
6257 Make_Defining_Identifier (Loc, Procedure_Name),
6258 Statements, Outp => False);
6261 Make_Subprogram_Declaration (Loc,
6262 Copy_Specification (Loc, Specification (Body_Node)));
6265 Make_Attribute_Definition_Clause (Loc,
6266 Name => New_Occurrence_Of (RACW_Type, Loc),
6267 Chars => Name_Write,
6270 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6272 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6273 Insert_After (Proc_Decl, Attr_Decl);
6274 Append_To (Body_Decls, Body_Node);
6275 end Add_RACW_Write_Attribute;
6277 -----------------------
6278 -- Add_RAST_Features --
6279 -----------------------
6281 procedure Add_RAST_Features
6282 (Vis_Decl : Node_Id;
6283 RAS_Type : Entity_Id)
6286 Add_RAS_Access_TSS (Vis_Decl);
6288 Add_RAS_From_Any (RAS_Type);
6289 Add_RAS_TypeCode (RAS_Type);
6291 -- To_Any uses TypeCode, and therefore needs to be generated last
6293 Add_RAS_To_Any (RAS_Type);
6294 end Add_RAST_Features;
6296 ------------------------
6297 -- Add_RAS_Access_TSS --
6298 ------------------------
6300 procedure Add_RAS_Access_TSS (N : Node_Id) is
6301 Loc : constant Source_Ptr := Sloc (N);
6303 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6304 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6305 -- Ras_Type is the access to subprogram type; Fat_Type is the
6306 -- corresponding record type.
6308 RACW_Type : constant Entity_Id :=
6309 Underlying_RACW_Type (Ras_Type);
6310 Desig : constant Entity_Id :=
6311 Etype (Designated_Type (RACW_Type));
6313 Stub_Elements : constant Stub_Structure :=
6314 Stubs_Table.Get (Desig);
6315 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6317 Proc : constant Entity_Id :=
6318 Make_Defining_Identifier (Loc,
6319 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6321 Proc_Spec : Node_Id;
6323 -- Formal parameters
6325 Package_Name : constant Entity_Id :=
6326 Make_Defining_Identifier (Loc,
6331 Subp_Id : constant Entity_Id :=
6332 Make_Defining_Identifier (Loc,
6335 -- Target subprogram
6337 Asynch_P : constant Entity_Id :=
6338 Make_Defining_Identifier (Loc,
6339 Chars => Name_Asynchronous);
6340 -- Is the procedure to which the 'Access applies asynchronous?
6342 All_Calls_Remote : constant Entity_Id :=
6343 Make_Defining_Identifier (Loc,
6344 Chars => Name_All_Calls_Remote);
6345 -- True if an All_Calls_Remote pragma applies to the RCI unit
6346 -- that contains the subprogram.
6348 -- Common local variables
6350 Proc_Decls : List_Id;
6351 Proc_Statements : List_Id;
6353 Subp_Ref : constant Entity_Id :=
6354 Make_Defining_Identifier (Loc, Name_R);
6355 -- Reference that designates the target subprogram (returned
6356 -- by Get_RAS_Info).
6358 Is_Local : constant Entity_Id :=
6359 Make_Defining_Identifier (Loc, Name_L);
6360 Local_Addr : constant Entity_Id :=
6361 Make_Defining_Identifier (Loc, Name_A);
6362 -- For the call to Get_Local_Address
6364 -- Additional local variables for the remote case
6366 Local_Stub : constant Entity_Id :=
6367 Make_Defining_Identifier (Loc,
6368 Chars => New_Internal_Name ('L'));
6370 Stub_Ptr : constant Entity_Id :=
6371 Make_Defining_Identifier (Loc,
6372 Chars => New_Internal_Name ('S'));
6375 (Field_Name : Name_Id;
6376 Value : Node_Id) return Node_Id;
6377 -- Construct an assignment that sets the named component in the
6385 (Field_Name : Name_Id;
6386 Value : Node_Id) return Node_Id
6390 Make_Assignment_Statement (Loc,
6392 Make_Selected_Component (Loc,
6394 Selector_Name => Field_Name),
6395 Expression => Value);
6398 -- Start of processing for Add_RAS_Access_TSS
6401 Proc_Decls := New_List (
6403 -- Common declarations
6405 Make_Object_Declaration (Loc,
6406 Defining_Identifier => Subp_Ref,
6407 Object_Definition =>
6408 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6410 Make_Object_Declaration (Loc,
6411 Defining_Identifier => Is_Local,
6412 Object_Definition =>
6413 New_Occurrence_Of (Standard_Boolean, Loc)),
6415 Make_Object_Declaration (Loc,
6416 Defining_Identifier => Local_Addr,
6417 Object_Definition =>
6418 New_Occurrence_Of (RTE (RE_Address), Loc)),
6420 Make_Object_Declaration (Loc,
6421 Defining_Identifier => Local_Stub,
6422 Aliased_Present => True,
6423 Object_Definition =>
6424 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6426 Make_Object_Declaration (Loc,
6427 Defining_Identifier =>
6429 Object_Definition =>
6430 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6432 Make_Attribute_Reference (Loc,
6433 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6434 Attribute_Name => Name_Unchecked_Access)));
6436 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6437 -- Build_Get_Unique_RP_Call needs this information
6439 -- Get_RAS_Info (Pkg, Subp, R);
6440 -- Obtain a reference to the target subprogram
6442 Proc_Statements := New_List (
6443 Make_Procedure_Call_Statement (Loc,
6445 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6446 Parameter_Associations => New_List (
6447 New_Occurrence_Of (Package_Name, Loc),
6448 New_Occurrence_Of (Subp_Id, Loc),
6449 New_Occurrence_Of (Subp_Ref, Loc))),
6451 -- Get_Local_Address (R, L, A);
6452 -- Determine whether the subprogram is local (L), and if so
6453 -- obtain the local address of its proxy (A).
6455 Make_Procedure_Call_Statement (Loc,
6457 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6458 Parameter_Associations => New_List (
6459 New_Occurrence_Of (Subp_Ref, Loc),
6460 New_Occurrence_Of (Is_Local, Loc),
6461 New_Occurrence_Of (Local_Addr, Loc))));
6463 -- Note: Here we assume that the Fat_Type is a record containing just
6464 -- an access to a proxy or stub object.
6466 Append_To (Proc_Statements,
6470 Make_Implicit_If_Statement (N,
6472 New_Occurrence_Of (Is_Local, Loc),
6474 Then_Statements => New_List (
6476 -- if A.Target = null then
6478 Make_Implicit_If_Statement (N,
6481 Make_Selected_Component (Loc,
6483 Unchecked_Convert_To (
6484 RTE (RE_RAS_Proxy_Type_Access),
6485 New_Occurrence_Of (Local_Addr, Loc)),
6487 Make_Identifier (Loc, Name_Target)),
6490 Then_Statements => New_List (
6492 -- A.Target := Entity_Of (Ref);
6494 Make_Assignment_Statement (Loc,
6496 Make_Selected_Component (Loc,
6498 Unchecked_Convert_To (
6499 RTE (RE_RAS_Proxy_Type_Access),
6500 New_Occurrence_Of (Local_Addr, Loc)),
6502 Make_Identifier (Loc, Name_Target)),
6504 Make_Function_Call (Loc,
6506 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6507 Parameter_Associations => New_List (
6508 New_Occurrence_Of (Subp_Ref, Loc)))),
6510 -- Inc_Usage (A.Target);
6512 Make_Procedure_Call_Statement (Loc,
6514 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6515 Parameter_Associations => New_List (
6516 Make_Selected_Component (Loc,
6518 Unchecked_Convert_To (
6519 RTE (RE_RAS_Proxy_Type_Access),
6520 New_Occurrence_Of (Local_Addr, Loc)),
6521 Selector_Name => Make_Identifier (Loc,
6525 -- if not All_Calls_Remote then
6526 -- return Fat_Type!(A);
6529 Make_Implicit_If_Statement (N,
6532 New_Occurrence_Of (All_Calls_Remote, Loc)),
6534 Then_Statements => New_List (
6535 Make_Return_Statement (Loc,
6536 Unchecked_Convert_To (Fat_Type,
6537 New_Occurrence_Of (Local_Addr, Loc))))))));
6539 Append_List_To (Proc_Statements, New_List (
6541 -- Stub.Target := Entity_Of (Ref);
6543 Set_Field (Name_Target,
6544 Make_Function_Call (Loc,
6546 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6547 Parameter_Associations => New_List (
6548 New_Occurrence_Of (Subp_Ref, Loc)))),
6550 -- Inc_Usage (Stub.Target);
6552 Make_Procedure_Call_Statement (Loc,
6554 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6555 Parameter_Associations => New_List (
6556 Make_Selected_Component (Loc,
6558 Selector_Name => Name_Target))),
6560 -- E.4.1(9) A remote call is asynchronous if it is a call to
6561 -- a procedure, or a call through a value of an access-to-procedure
6562 -- type, to which a pragma Asynchronous applies.
6564 -- Parameter Asynch_P is true when the procedure is asynchronous;
6565 -- Expression Asynch_T is true when the type is asynchronous.
6567 Set_Field (Name_Asynchronous,
6569 New_Occurrence_Of (Asynch_P, Loc),
6570 New_Occurrence_Of (Boolean_Literals (
6571 Is_Asynchronous (Ras_Type)), Loc)))));
6573 Append_List_To (Proc_Statements,
6574 Build_Get_Unique_RP_Call (Loc,
6575 Stub_Ptr, Stub_Elements.Stub_Type));
6577 Append_To (Proc_Statements,
6578 Make_Return_Statement (Loc,
6580 Unchecked_Convert_To (Fat_Type,
6581 New_Occurrence_Of (Stub_Ptr, Loc))));
6584 Make_Function_Specification (Loc,
6585 Defining_Unit_Name => Proc,
6586 Parameter_Specifications => New_List (
6587 Make_Parameter_Specification (Loc,
6588 Defining_Identifier => Package_Name,
6590 New_Occurrence_Of (Standard_String, Loc)),
6592 Make_Parameter_Specification (Loc,
6593 Defining_Identifier => Subp_Id,
6595 New_Occurrence_Of (Standard_String, Loc)),
6597 Make_Parameter_Specification (Loc,
6598 Defining_Identifier => Asynch_P,
6600 New_Occurrence_Of (Standard_Boolean, Loc)),
6602 Make_Parameter_Specification (Loc,
6603 Defining_Identifier => All_Calls_Remote,
6605 New_Occurrence_Of (Standard_Boolean, Loc))),
6607 Result_Definition =>
6608 New_Occurrence_Of (Fat_Type, Loc));
6610 -- Set the kind and return type of the function to prevent
6611 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6613 Set_Ekind (Proc, E_Function);
6614 Set_Etype (Proc, Fat_Type);
6617 Make_Subprogram_Body (Loc,
6618 Specification => Proc_Spec,
6619 Declarations => Proc_Decls,
6620 Handled_Statement_Sequence =>
6621 Make_Handled_Sequence_Of_Statements (Loc,
6622 Statements => Proc_Statements)));
6624 Set_TSS (Fat_Type, Proc);
6625 end Add_RAS_Access_TSS;
6627 ----------------------
6628 -- Add_RAS_From_Any --
6629 ----------------------
6631 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6632 Loc : constant Source_Ptr := Sloc (RAS_Type);
6634 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6635 Make_TSS_Name (RAS_Type, TSS_From_Any));
6637 Func_Spec : Node_Id;
6639 Statements : List_Id;
6641 Any_Parameter : constant Entity_Id :=
6642 Make_Defining_Identifier (Loc, Name_A);
6645 Statements := New_List (
6646 Make_Return_Statement (Loc,
6648 Make_Aggregate (Loc,
6649 Component_Associations => New_List (
6650 Make_Component_Association (Loc,
6651 Choices => New_List (
6652 Make_Identifier (Loc, Name_Ras)),
6654 PolyORB_Support.Helpers.Build_From_Any_Call (
6655 Underlying_RACW_Type (RAS_Type),
6656 New_Occurrence_Of (Any_Parameter, Loc),
6660 Make_Function_Specification (Loc,
6661 Defining_Unit_Name =>
6663 Parameter_Specifications => New_List (
6664 Make_Parameter_Specification (Loc,
6665 Defining_Identifier =>
6668 New_Occurrence_Of (RTE (RE_Any), Loc))),
6669 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6672 Make_Subprogram_Body (Loc,
6673 Specification => Func_Spec,
6674 Declarations => No_List,
6675 Handled_Statement_Sequence =>
6676 Make_Handled_Sequence_Of_Statements (Loc,
6677 Statements => Statements)));
6678 Set_TSS (RAS_Type, Fnam);
6679 end Add_RAS_From_Any;
6681 --------------------
6682 -- Add_RAS_To_Any --
6683 --------------------
6685 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6686 Loc : constant Source_Ptr := Sloc (RAS_Type);
6688 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6689 Make_TSS_Name (RAS_Type, TSS_To_Any));
6692 Statements : List_Id;
6694 Func_Spec : Node_Id;
6696 Any : constant Entity_Id :=
6697 Make_Defining_Identifier (Loc,
6698 Chars => New_Internal_Name ('A'));
6699 RAS_Parameter : constant Entity_Id :=
6700 Make_Defining_Identifier (Loc,
6701 Chars => New_Internal_Name ('R'));
6702 RACW_Parameter : constant Node_Id :=
6703 Make_Selected_Component (Loc,
6704 Prefix => RAS_Parameter,
6705 Selector_Name => Name_Ras);
6708 -- Object declarations
6710 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6712 Make_Object_Declaration (Loc,
6713 Defining_Identifier =>
6715 Object_Definition =>
6716 New_Occurrence_Of (RTE (RE_Any), Loc),
6718 PolyORB_Support.Helpers.Build_To_Any_Call
6719 (RACW_Parameter, No_List)));
6721 Statements := New_List (
6722 Make_Procedure_Call_Statement (Loc,
6724 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6725 Parameter_Associations => New_List (
6726 New_Occurrence_Of (Any, Loc),
6727 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6729 Make_Return_Statement (Loc,
6731 New_Occurrence_Of (Any, Loc)));
6734 Make_Function_Specification (Loc,
6735 Defining_Unit_Name =>
6737 Parameter_Specifications => New_List (
6738 Make_Parameter_Specification (Loc,
6739 Defining_Identifier =>
6742 New_Occurrence_Of (RAS_Type, Loc))),
6743 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6746 Make_Subprogram_Body (Loc,
6747 Specification => Func_Spec,
6748 Declarations => Decls,
6749 Handled_Statement_Sequence =>
6750 Make_Handled_Sequence_Of_Statements (Loc,
6751 Statements => Statements)));
6752 Set_TSS (RAS_Type, Fnam);
6755 ----------------------
6756 -- Add_RAS_TypeCode --
6757 ----------------------
6759 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6760 Loc : constant Source_Ptr := Sloc (RAS_Type);
6762 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6763 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6765 Func_Spec : Node_Id;
6767 Decls : constant List_Id := New_List;
6768 Name_String, Repo_Id_String : String_Id;
6772 Make_Function_Specification (Loc,
6773 Defining_Unit_Name =>
6775 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6777 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6778 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6781 Make_Subprogram_Body (Loc,
6782 Specification => Func_Spec,
6783 Declarations => Decls,
6784 Handled_Statement_Sequence =>
6785 Make_Handled_Sequence_Of_Statements (Loc,
6786 Statements => New_List (
6787 Make_Return_Statement (Loc,
6789 Make_Function_Call (Loc,
6791 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6792 Parameter_Associations => New_List (
6793 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6794 Make_Aggregate (Loc,
6797 Make_Function_Call (Loc,
6798 Name => New_Occurrence_Of (
6799 RTE (RE_TA_String), Loc),
6800 Parameter_Associations => New_List (
6801 Make_String_Literal (Loc, Name_String))),
6802 Make_Function_Call (Loc,
6803 Name => New_Occurrence_Of (
6804 RTE (RE_TA_String), Loc),
6805 Parameter_Associations => New_List (
6806 Make_String_Literal (Loc,
6807 Repo_Id_String))))))))))));
6808 Set_TSS (RAS_Type, Fnam);
6809 end Add_RAS_TypeCode;
6811 -----------------------------------------
6812 -- Add_Receiving_Stubs_To_Declarations --
6813 -----------------------------------------
6815 procedure Add_Receiving_Stubs_To_Declarations
6816 (Pkg_Spec : Node_Id;
6820 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6822 Pkg_RPC_Receiver : constant Entity_Id :=
6823 Make_Defining_Identifier (Loc,
6824 New_Internal_Name ('H'));
6825 Pkg_RPC_Receiver_Object : Node_Id;
6827 Pkg_RPC_Receiver_Body : Node_Id;
6828 Pkg_RPC_Receiver_Decls : List_Id;
6829 Pkg_RPC_Receiver_Statements : List_Id;
6830 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6831 -- A Pkg_RPC_Receiver is built to decode the request
6834 -- Request object received from neutral layer
6836 Subp_Id : Entity_Id;
6837 -- Subprogram identifier as received from the neutral
6838 -- distribution core.
6840 Subp_Index : Entity_Id;
6841 -- Internal index as determined by matching either the
6842 -- method name from the request structure, or the local
6843 -- subprogram address (in case of a RAS).
6845 Is_Local : constant Entity_Id :=
6846 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
6847 Local_Address : constant Entity_Id :=
6848 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
6849 -- Address of a local subprogram designated by a
6850 -- reference corresponding to a RAS.
6852 Dispatch_On_Address : constant List_Id := New_List;
6853 Dispatch_On_Name : constant List_Id := New_List;
6855 Current_Declaration : Node_Id;
6856 Current_Stubs : Node_Id;
6857 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6859 Subp_Info_Array : constant Entity_Id :=
6860 Make_Defining_Identifier (Loc,
6861 Chars => New_Internal_Name ('I'));
6863 Subp_Info_List : constant List_Id := New_List;
6865 Register_Pkg_Actuals : constant List_Id := New_List;
6867 All_Calls_Remote_E : Entity_Id;
6869 procedure Append_Stubs_To
6870 (RPC_Receiver_Cases : List_Id;
6871 Declaration : Node_Id;
6874 Subp_Dist_Name : Entity_Id;
6875 Subp_Proxy_Addr : Entity_Id);
6876 -- Add one case to the specified RPC receiver case list associating
6877 -- Subprogram_Number with the subprogram declared by Declaration, for
6878 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6879 -- subprogram index. Subp_Dist_Name is the string used to call the
6880 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6881 -- object, used in the context of calls through remote
6882 -- access-to-subprogram types.
6884 ---------------------
6885 -- Append_Stubs_To --
6886 ---------------------
6888 procedure Append_Stubs_To
6889 (RPC_Receiver_Cases : List_Id;
6890 Declaration : Node_Id;
6893 Subp_Dist_Name : Entity_Id;
6894 Subp_Proxy_Addr : Entity_Id)
6896 Case_Stmts : List_Id;
6898 Case_Stmts := New_List (
6899 Make_Procedure_Call_Statement (Loc,
6902 Defining_Entity (Stubs), Loc),
6903 Parameter_Associations =>
6904 New_List (New_Occurrence_Of (Request, Loc))));
6905 if Nkind (Specification (Declaration))
6906 = N_Function_Specification
6908 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6910 Append_To (Case_Stmts, Make_Return_Statement (Loc));
6913 Append_To (RPC_Receiver_Cases,
6914 Make_Case_Statement_Alternative (Loc,
6916 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6920 Append_To (Dispatch_On_Name,
6921 Make_Elsif_Part (Loc,
6923 Make_Function_Call (Loc,
6925 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6926 Parameter_Associations => New_List (
6927 New_Occurrence_Of (Subp_Id, Loc),
6928 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6929 Then_Statements => New_List (
6930 Make_Assignment_Statement (Loc,
6931 New_Occurrence_Of (Subp_Index, Loc),
6932 Make_Integer_Literal (Loc,
6935 Append_To (Dispatch_On_Address,
6936 Make_Elsif_Part (Loc,
6940 New_Occurrence_Of (Local_Address, Loc),
6942 New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6943 Then_Statements => New_List (
6944 Make_Assignment_Statement (Loc,
6945 New_Occurrence_Of (Subp_Index, Loc),
6946 Make_Integer_Literal (Loc,
6948 end Append_Stubs_To;
6950 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6953 -- Building receiving stubs consist in several operations:
6955 -- - a package RPC receiver must be built. This subprogram
6956 -- will get a Subprogram_Id from the incoming stream
6957 -- and will dispatch the call to the right subprogram;
6959 -- - a receiving stub for each subprogram visible in the package
6960 -- spec. This stub will read all the parameters from the stream,
6961 -- and put the result as well as the exception occurrence in the
6964 -- - a dummy package with an empty spec and a body made of an
6965 -- elaboration part, whose job is to register the receiving
6966 -- part of this RCI package on the name server. This is done
6967 -- by calling System.Partition_Interface.Register_Receiving_Stub.
6969 Build_RPC_Receiver_Body (
6970 RPC_Receiver => Pkg_RPC_Receiver,
6973 Subp_Index => Subp_Index,
6974 Stmts => Pkg_RPC_Receiver_Statements,
6975 Decl => Pkg_RPC_Receiver_Body);
6976 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6978 -- Extract local address information from the target reference:
6979 -- if non-null, that means that this is a reference that denotes
6980 -- one particular operation, and hence that the operation name
6981 -- must not be taken into account for dispatching.
6983 Append_To (Pkg_RPC_Receiver_Decls,
6984 Make_Object_Declaration (Loc,
6985 Defining_Identifier =>
6987 Object_Definition =>
6988 New_Occurrence_Of (Standard_Boolean, Loc)));
6989 Append_To (Pkg_RPC_Receiver_Decls,
6990 Make_Object_Declaration (Loc,
6991 Defining_Identifier =>
6993 Object_Definition =>
6994 New_Occurrence_Of (RTE (RE_Address), Loc)));
6995 Append_To (Pkg_RPC_Receiver_Statements,
6996 Make_Procedure_Call_Statement (Loc,
6998 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6999 Parameter_Associations => New_List (
7000 Make_Selected_Component (Loc,
7002 Selector_Name => Name_Target),
7003 New_Occurrence_Of (Is_Local, Loc),
7004 New_Occurrence_Of (Local_Address, Loc))));
7006 -- For each subprogram, the receiving stub will be built and a
7007 -- case statement will be made on the Subprogram_Id to dispatch
7008 -- to the right subprogram.
7010 All_Calls_Remote_E := Boolean_Literals (
7011 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
7013 Overload_Counter_Table.Reset;
7014 Reserve_NamingContext_Methods;
7016 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
7017 while Present (Current_Declaration) loop
7018 if Nkind (Current_Declaration) = N_Subprogram_Declaration
7019 and then Comes_From_Source (Current_Declaration)
7022 Loc : constant Source_Ptr :=
7023 Sloc (Current_Declaration);
7024 -- While specifically processing Current_Declaration, use
7025 -- its Sloc as the location of all generated nodes.
7027 Subp_Def : constant Entity_Id :=
7029 (Specification (Current_Declaration));
7031 Subp_Val : String_Id;
7033 Subp_Dist_Name : constant Entity_Id :=
7034 Make_Defining_Identifier (Loc,
7036 Related_Id => Chars (Subp_Def),
7038 Suffix_Index => -1));
7040 Proxy_Object_Addr : Entity_Id;
7043 -- Build receiving stub
7046 Build_Subprogram_Receiving_Stubs
7047 (Vis_Decl => Current_Declaration,
7049 Nkind (Specification (Current_Declaration)) =
7050 N_Procedure_Specification
7051 and then Is_Asynchronous (Subp_Def));
7053 Append_To (Decls, Current_Stubs);
7054 Analyze (Current_Stubs);
7058 Add_RAS_Proxy_And_Analyze (Decls,
7060 Current_Declaration,
7061 All_Calls_Remote_E =>
7063 Proxy_Object_Addr =>
7066 -- Compute distribution identifier
7068 Assign_Subprogram_Identifier (
7070 Current_Subprogram_Number,
7073 pragma Assert (Current_Subprogram_Number =
7074 Get_Subprogram_Id (Subp_Def));
7077 Make_Object_Declaration (Loc,
7078 Defining_Identifier => Subp_Dist_Name,
7079 Constant_Present => True,
7080 Object_Definition => New_Occurrence_Of (
7081 Standard_String, Loc),
7083 Make_String_Literal (Loc, Subp_Val)));
7084 Analyze (Last (Decls));
7086 -- Add subprogram descriptor (RCI_Subp_Info) to the
7087 -- subprograms table for this receiver. The aggregate
7088 -- below must be kept consistent with the declaration
7089 -- of type RCI_Subp_Info in System.Partition_Interface.
7091 Append_To (Subp_Info_List,
7092 Make_Component_Association (Loc,
7093 Choices => New_List (
7094 Make_Integer_Literal (Loc,
7095 Current_Subprogram_Number)),
7097 Make_Aggregate (Loc,
7098 Expressions => New_List (
7099 Make_Attribute_Reference (Loc,
7102 Subp_Dist_Name, Loc),
7103 Attribute_Name => Name_Address),
7104 Make_Attribute_Reference (Loc,
7107 Subp_Dist_Name, Loc),
7108 Attribute_Name => Name_Length),
7109 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
7111 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
7112 Declaration => Current_Declaration,
7113 Stubs => Current_Stubs,
7114 Subp_Number => Current_Subprogram_Number,
7115 Subp_Dist_Name => Subp_Dist_Name,
7116 Subp_Proxy_Addr => Proxy_Object_Addr);
7119 Current_Subprogram_Number := Current_Subprogram_Number + 1;
7122 Next (Current_Declaration);
7126 Make_Object_Declaration (Loc,
7127 Defining_Identifier => Subp_Info_Array,
7128 Constant_Present => True,
7129 Aliased_Present => True,
7130 Object_Definition =>
7131 Make_Subtype_Indication (Loc,
7133 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
7135 Make_Index_Or_Discriminant_Constraint (Loc,
7138 Low_Bound => Make_Integer_Literal (Loc,
7139 First_RCI_Subprogram_Id),
7141 Make_Integer_Literal (Loc,
7142 First_RCI_Subprogram_Id
7143 + List_Length (Subp_Info_List) - 1)))))));
7145 if Present (First (Subp_Info_List)) then
7146 Set_Expression (Last (Decls),
7147 Make_Aggregate (Loc,
7148 Component_Associations => Subp_Info_List));
7150 -- Generate the dispatch statement to determine the subprogram id
7151 -- of the called subprogram.
7153 -- We first test whether the reference that was used to make the
7154 -- call was the base RCI reference (in which case Local_Address is
7155 -- zero, and the method identifier from the request must be used
7156 -- to determine which subprogram is called) or a reference
7157 -- identifying one particular subprogram (in which case
7158 -- Local_Address is the address of that subprogram, and the
7159 -- method name from the request is ignored). The latter occurs
7160 -- for the case of a call through a remote access-to-subprogram.
7162 -- In each case, cascaded elsifs are used to determine the proper
7163 -- subprogram index. Using hash tables might be more efficient.
7165 Append_To (Pkg_RPC_Receiver_Statements,
7166 Make_Implicit_If_Statement (Pkg_Spec,
7169 Left_Opnd => New_Occurrence_Of
7170 (Local_Address, Loc),
7171 Right_Opnd => New_Occurrence_Of
7172 (RTE (RE_Null_Address), Loc)),
7173 Then_Statements => New_List (
7174 Make_Implicit_If_Statement (Pkg_Spec,
7176 New_Occurrence_Of (Standard_False, Loc),
7177 Then_Statements => New_List (
7178 Make_Null_Statement (Loc)),
7180 Dispatch_On_Address)),
7182 Else_Statements => New_List (
7183 Make_Implicit_If_Statement (Pkg_Spec,
7185 New_Occurrence_Of (Standard_False, Loc),
7186 Then_Statements => New_List (
7187 Make_Null_Statement (Loc)),
7189 Dispatch_On_Name))));
7192 -- For a degenerate RCI with no visible subprograms,
7193 -- Subp_Info_List has zero length, and the declaration is for an
7194 -- empty array, in which case no initialization aggregate must be
7195 -- generated. We do not generate a Dispatch_Statement either.
7197 -- No initialization provided: remove CONSTANT so that the
7198 -- declaration is not an incomplete deferred constant.
7200 Set_Constant_Present (Last (Decls), False);
7203 -- Analyze Subp_Info_Array declaration
7205 Analyze (Last (Decls));
7207 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7208 -- rather than raising an exception since we do not want someone
7209 -- to crash a remote partition by sending invalid subprogram ids.
7210 -- This is consistent with the other parts of the case statement
7211 -- since even in presence of incorrect parameters in the stream,
7212 -- every exception will be caught and (if the subprogram is not an
7213 -- APC) put into the result stream and sent away.
7215 Append_To (Pkg_RPC_Receiver_Cases,
7216 Make_Case_Statement_Alternative (Loc,
7218 New_List (Make_Others_Choice (Loc)),
7220 New_List (Make_Null_Statement (Loc))));
7222 Append_To (Pkg_RPC_Receiver_Statements,
7223 Make_Case_Statement (Loc,
7225 New_Occurrence_Of (Subp_Index, Loc),
7226 Alternatives => Pkg_RPC_Receiver_Cases));
7228 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7231 Append_To (Decls, Pkg_RPC_Receiver_Body);
7232 Analyze (Last (Decls));
7234 Pkg_RPC_Receiver_Object :=
7235 Make_Object_Declaration (Loc,
7236 Defining_Identifier =>
7237 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
7238 Aliased_Present => True,
7239 Object_Definition =>
7240 New_Occurrence_Of (RTE (RE_Servant), Loc));
7241 Append_To (Decls, Pkg_RPC_Receiver_Object);
7242 Analyze (Last (Decls));
7244 Get_Library_Unit_Name_String (Pkg_Spec);
7245 Append_To (Register_Pkg_Actuals,
7247 Make_String_Literal (Loc,
7248 Strval => String_From_Name_Buffer));
7250 Append_To (Register_Pkg_Actuals,
7252 Make_Attribute_Reference (Loc,
7255 (Defining_Entity (Pkg_Spec), Loc),
7259 Append_To (Register_Pkg_Actuals,
7261 Make_Attribute_Reference (Loc,
7263 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7264 Attribute_Name => Name_Access));
7266 Append_To (Register_Pkg_Actuals,
7268 Make_Attribute_Reference (Loc,
7271 Defining_Identifier (
7272 Pkg_RPC_Receiver_Object), Loc),
7276 Append_To (Register_Pkg_Actuals,
7278 Make_Attribute_Reference (Loc,
7280 New_Occurrence_Of (Subp_Info_Array, Loc),
7284 Append_To (Register_Pkg_Actuals,
7286 Make_Attribute_Reference (Loc,
7288 New_Occurrence_Of (Subp_Info_Array, Loc),
7292 Append_To (Register_Pkg_Actuals,
7293 -- Is_All_Calls_Remote
7294 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7297 Make_Procedure_Call_Statement (Loc,
7299 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7300 Parameter_Associations => Register_Pkg_Actuals));
7301 Analyze (Last (Stmts));
7303 end Add_Receiving_Stubs_To_Declarations;
7305 ---------------------------------
7306 -- Build_General_Calling_Stubs --
7307 ---------------------------------
7309 procedure Build_General_Calling_Stubs
7311 Statements : List_Id;
7312 Target_Object : Node_Id;
7313 Subprogram_Id : Node_Id;
7314 Asynchronous : Node_Id := Empty;
7315 Is_Known_Asynchronous : Boolean := False;
7316 Is_Known_Non_Asynchronous : Boolean := False;
7317 Is_Function : Boolean;
7319 Stub_Type : Entity_Id := Empty;
7320 RACW_Type : Entity_Id := Empty;
7323 Loc : constant Source_Ptr := Sloc (Nod);
7325 Arguments : Node_Id;
7326 -- Name of the named values list used to transmit parameters
7327 -- to the remote package
7330 -- The request object constructed by these stubs
7333 -- Name of the result named value (in non-APC cases) which get the
7334 -- result of the remote subprogram.
7336 Result_TC : Node_Id;
7337 -- Typecode expression for the result of the request (void
7338 -- typecode for procedures).
7340 Exception_Return_Parameter : Node_Id;
7341 -- Name of the parameter which will hold the exception sent by the
7342 -- remote subprogram.
7344 Current_Parameter : Node_Id;
7345 -- Current parameter being handled
7347 Ordered_Parameters_List : constant List_Id :=
7348 Build_Ordered_Parameters_List (Spec);
7350 Asynchronous_P : Node_Id;
7351 -- A Boolean expression indicating whether this call is asynchronous
7353 Asynchronous_Statements : List_Id := No_List;
7354 Non_Asynchronous_Statements : List_Id := No_List;
7355 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7357 Extra_Formal_Statements : constant List_Id := New_List;
7358 -- List of statements for extra formal parameters. It will appear
7359 -- after the regular statements for writing out parameters.
7361 After_Statements : constant List_Id := New_List;
7362 -- Statements to be executed after call returns (to assign
7363 -- in out or out parameter values).
7366 -- The type of the formal parameter being processed
7368 Is_Controlling_Formal : Boolean;
7369 Is_First_Controlling_Formal : Boolean;
7370 First_Controlling_Formal_Seen : Boolean := False;
7371 -- Controlling formal parameters of distributed object primitives
7372 -- require special handling, and the first such parameter needs even
7373 -- more special handling.
7376 -- ??? document general form of stub subprograms for the PolyORB case
7378 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7381 Make_Object_Declaration (Loc,
7382 Defining_Identifier => Request,
7383 Aliased_Present => False,
7384 Object_Definition =>
7385 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
7388 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7391 Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7392 Etype (Result_Definition (Spec)), Decls);
7394 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7398 Make_Object_Declaration (Loc,
7399 Defining_Identifier => Result,
7400 Aliased_Present => False,
7401 Object_Definition =>
7402 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7404 Make_Aggregate (Loc,
7405 Component_Associations => New_List (
7406 Make_Component_Association (Loc,
7407 Choices => New_List (
7408 Make_Identifier (Loc, Name_Name)),
7410 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7411 Make_Component_Association (Loc,
7412 Choices => New_List (
7413 Make_Identifier (Loc, Name_Argument)),
7415 Make_Function_Call (Loc,
7417 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7418 Parameter_Associations => New_List (
7420 Make_Component_Association (Loc,
7421 Choices => New_List (
7422 Make_Identifier (Loc, Name_Arg_Modes)),
7424 Make_Integer_Literal (Loc, 0))))));
7426 if not Is_Known_Asynchronous then
7427 Exception_Return_Parameter :=
7428 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7431 Make_Object_Declaration (Loc,
7432 Defining_Identifier => Exception_Return_Parameter,
7433 Object_Definition =>
7434 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7437 Exception_Return_Parameter := Empty;
7440 -- Initialize and fill in arguments list
7443 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7444 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7446 Current_Parameter := First (Ordered_Parameters_List);
7447 while Present (Current_Parameter) loop
7449 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7450 Is_Controlling_Formal := True;
7451 Is_First_Controlling_Formal :=
7452 not First_Controlling_Formal_Seen;
7453 First_Controlling_Formal_Seen := True;
7455 Is_Controlling_Formal := False;
7456 Is_First_Controlling_Formal := False;
7459 if Is_Controlling_Formal then
7461 -- In the case of a controlling formal argument, we send its
7467 Etyp := Etype (Parameter_Type (Current_Parameter));
7470 -- The first controlling formal parameter is treated specially: it
7471 -- is used to set the target object of the call.
7473 if not Is_First_Controlling_Formal then
7476 Constrained : constant Boolean :=
7477 Is_Constrained (Etyp)
7478 or else Is_Elementary_Type (Etyp);
7480 Any : constant Entity_Id :=
7481 Make_Defining_Identifier (Loc,
7482 New_Internal_Name ('A'));
7484 Actual_Parameter : Node_Id :=
7486 Defining_Identifier (
7487 Current_Parameter), Loc);
7492 if Is_Controlling_Formal then
7494 -- For a controlling formal parameter (other than the
7495 -- first one), use the corresponding RACW. If the
7496 -- parameter is not an anonymous access parameter, that
7497 -- involves taking its 'Unrestricted_Access.
7499 if Nkind (Parameter_Type (Current_Parameter))
7500 = N_Access_Definition
7502 Actual_Parameter := OK_Convert_To
7503 (Etyp, Actual_Parameter);
7505 Actual_Parameter := OK_Convert_To (Etyp,
7506 Make_Attribute_Reference (Loc,
7510 Name_Unrestricted_Access));
7515 if In_Present (Current_Parameter)
7516 or else not Out_Present (Current_Parameter)
7517 or else not Constrained
7518 or else Is_Controlling_Formal
7520 -- The parameter has an input value, is constrained at
7521 -- runtime by an input value, or is a controlling formal
7522 -- parameter (always passed as a reference) other than
7525 Expr := PolyORB_Support.Helpers.Build_To_Any_Call (
7526 Actual_Parameter, Decls);
7528 Expr := Make_Function_Call (Loc,
7530 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7531 Parameter_Associations => New_List (
7532 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7537 Make_Object_Declaration (Loc,
7538 Defining_Identifier =>
7540 Aliased_Present => False,
7541 Object_Definition =>
7542 New_Occurrence_Of (RTE (RE_Any), Loc),
7546 Append_To (Statements,
7547 Add_Parameter_To_NVList (Loc,
7548 Parameter => Current_Parameter,
7549 NVList => Arguments,
7550 Constrained => Constrained,
7553 if Out_Present (Current_Parameter)
7554 and then not Is_Controlling_Formal
7556 Append_To (After_Statements,
7557 Make_Assignment_Statement (Loc,
7560 Defining_Identifier (Current_Parameter), Loc),
7562 PolyORB_Support.Helpers.Build_From_Any_Call (
7563 Etype (Parameter_Type (Current_Parameter)),
7564 New_Occurrence_Of (Any, Loc),
7571 -- If the current parameter has a dynamic constrained status, then
7572 -- this status is transmitted as well.
7573 -- This should be done for accessibility as well ???
7575 if Nkind (Parameter_Type (Current_Parameter))
7576 /= N_Access_Definition
7577 and then Need_Extra_Constrained (Current_Parameter)
7579 -- In this block, we do not use the extra formal that has been
7580 -- created because it does not exist at the time of expansion
7581 -- when building calling stubs for remote access to subprogram
7582 -- types. We create an extra variable of this type and push it
7583 -- in the stream after the regular parameters.
7586 Extra_Any_Parameter : constant Entity_Id :=
7587 Make_Defining_Identifier
7588 (Loc, New_Internal_Name ('P'));
7590 Parameter_Exp : constant Node_Id :=
7591 Make_Attribute_Reference (Loc,
7592 Prefix => New_Occurrence_Of (
7593 Defining_Identifier (Current_Parameter), Loc),
7594 Attribute_Name => Name_Constrained);
7596 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7599 Make_Object_Declaration (Loc,
7600 Defining_Identifier =>
7601 Extra_Any_Parameter,
7602 Aliased_Present => False,
7603 Object_Definition =>
7604 New_Occurrence_Of (RTE (RE_Any), Loc),
7606 PolyORB_Support.Helpers.Build_To_Any_Call (
7610 Append_To (Extra_Formal_Statements,
7611 Add_Parameter_To_NVList (Loc,
7612 Parameter => Extra_Any_Parameter,
7613 NVList => Arguments,
7614 Constrained => True,
7615 Any => Extra_Any_Parameter));
7619 Next (Current_Parameter);
7622 -- Append the formal statements list to the statements
7624 Append_List_To (Statements, Extra_Formal_Statements);
7626 Append_To (Statements,
7627 Make_Procedure_Call_Statement (Loc,
7629 New_Occurrence_Of (RTE (RE_Request_Create), Loc),
7630 Parameter_Associations => New_List (
7633 New_Occurrence_Of (Arguments, Loc),
7634 New_Occurrence_Of (Result, Loc),
7635 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7637 Append_To (Parameter_Associations (Last (Statements)),
7638 New_Occurrence_Of (Request, Loc));
7641 not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7642 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7643 Asynchronous_P := New_Occurrence_Of (
7644 Boolean_Literals (Is_Known_Asynchronous), Loc);
7646 pragma Assert (Present (Asynchronous));
7647 Asynchronous_P := New_Copy_Tree (Asynchronous);
7648 -- The expression node Asynchronous will be used to build an 'if'
7649 -- statement at the end of Build_General_Calling_Stubs: we need to
7650 -- make a copy here.
7653 Append_To (Parameter_Associations (Last (Statements)),
7654 Make_Indexed_Component (Loc,
7657 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7658 Expressions => New_List (Asynchronous_P)));
7660 Append_To (Statements,
7661 Make_Procedure_Call_Statement (Loc,
7663 New_Occurrence_Of (RTE (RE_Request_Invoke), Loc),
7664 Parameter_Associations => New_List (
7665 New_Occurrence_Of (Request, Loc))));
7667 Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7668 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7670 if not Is_Known_Asynchronous then
7672 -- Reraise an exception occurrence from the completed request.
7673 -- If the exception occurrence is empty, this is a no-op.
7675 Append_To (Non_Asynchronous_Statements,
7676 Make_Procedure_Call_Statement (Loc,
7678 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7679 Parameter_Associations => New_List (
7680 New_Occurrence_Of (Request, Loc))));
7684 -- If this is a function call, read the value and return it
7686 Append_To (Non_Asynchronous_Statements,
7687 Make_Tag_Check (Loc,
7688 Make_Return_Statement (Loc,
7689 PolyORB_Support.Helpers.Build_From_Any_Call (
7690 Etype (Result_Definition (Spec)),
7691 Make_Selected_Component (Loc,
7693 Selector_Name => Name_Argument),
7698 Append_List_To (Non_Asynchronous_Statements,
7701 if Is_Known_Asynchronous then
7702 Append_List_To (Statements, Asynchronous_Statements);
7704 elsif Is_Known_Non_Asynchronous then
7705 Append_List_To (Statements, Non_Asynchronous_Statements);
7708 pragma Assert (Present (Asynchronous));
7709 Append_To (Statements,
7710 Make_Implicit_If_Statement (Nod,
7711 Condition => Asynchronous,
7712 Then_Statements => Asynchronous_Statements,
7713 Else_Statements => Non_Asynchronous_Statements));
7715 end Build_General_Calling_Stubs;
7717 -----------------------
7718 -- Build_Stub_Target --
7719 -----------------------
7721 function Build_Stub_Target
7724 RCI_Locator : Entity_Id;
7725 Controlling_Parameter : Entity_Id) return RPC_Target
7727 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7728 Target_Reference : constant Entity_Id :=
7729 Make_Defining_Identifier (Loc,
7730 New_Internal_Name ('T'));
7732 if Present (Controlling_Parameter) then
7734 Make_Object_Declaration (Loc,
7735 Defining_Identifier => Target_Reference,
7736 Object_Definition =>
7737 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7739 Make_Function_Call (Loc,
7741 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7742 Parameter_Associations => New_List (
7743 Make_Selected_Component (Loc,
7744 Prefix => Controlling_Parameter,
7745 Selector_Name => Name_Target)))));
7746 -- Controlling_Parameter has the same components as
7747 -- System.Partition_Interface.RACW_Stub_Type.
7749 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7752 Target_Info.Object :=
7753 Make_Selected_Component (Loc,
7755 Make_Identifier (Loc, Chars (RCI_Locator)),
7757 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7760 end Build_Stub_Target;
7762 ---------------------
7763 -- Build_Stub_Type --
7764 ---------------------
7766 procedure Build_Stub_Type
7767 (RACW_Type : Entity_Id;
7768 Stub_Type : Entity_Id;
7769 Stub_Type_Decl : out Node_Id;
7770 RPC_Receiver_Decl : out Node_Id)
7772 Loc : constant Source_Ptr := Sloc (Stub_Type);
7773 pragma Warnings (Off);
7774 pragma Unreferenced (RACW_Type);
7775 pragma Warnings (On);
7779 Make_Full_Type_Declaration (Loc,
7780 Defining_Identifier => Stub_Type,
7782 Make_Record_Definition (Loc,
7783 Tagged_Present => True,
7784 Limited_Present => True,
7786 Make_Component_List (Loc,
7787 Component_Items => New_List (
7789 Make_Component_Declaration (Loc,
7790 Defining_Identifier =>
7791 Make_Defining_Identifier (Loc, Name_Target),
7792 Component_Definition =>
7793 Make_Component_Definition (Loc,
7796 Subtype_Indication =>
7797 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7799 Make_Component_Declaration (Loc,
7800 Defining_Identifier =>
7801 Make_Defining_Identifier (Loc, Name_Asynchronous),
7802 Component_Definition =>
7803 Make_Component_Definition (Loc,
7804 Aliased_Present => False,
7805 Subtype_Indication =>
7807 Standard_Boolean, Loc)))))));
7809 RPC_Receiver_Decl :=
7810 Make_Object_Declaration (Loc,
7811 Defining_Identifier => Make_Defining_Identifier (Loc,
7812 New_Internal_Name ('R')),
7813 Aliased_Present => True,
7814 Object_Definition =>
7815 New_Occurrence_Of (RTE (RE_Servant), Loc));
7816 end Build_Stub_Type;
7818 -----------------------------
7819 -- Build_RPC_Receiver_Body --
7820 -----------------------------
7822 procedure Build_RPC_Receiver_Body
7823 (RPC_Receiver : Entity_Id;
7824 Request : out Entity_Id;
7825 Subp_Id : out Entity_Id;
7826 Subp_Index : out Entity_Id;
7827 Stmts : out List_Id;
7830 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7832 RPC_Receiver_Spec : Node_Id;
7833 RPC_Receiver_Decls : List_Id;
7836 Request := Make_Defining_Identifier (Loc, Name_R);
7838 RPC_Receiver_Spec :=
7839 Build_RPC_Receiver_Specification (
7840 RPC_Receiver => RPC_Receiver,
7841 Request_Parameter => Request);
7843 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7844 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7846 RPC_Receiver_Decls := New_List (
7847 Make_Object_Renaming_Declaration (Loc,
7848 Defining_Identifier => Subp_Id,
7849 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7851 Make_Explicit_Dereference (Loc,
7853 Make_Selected_Component (Loc,
7855 Selector_Name => Name_Operation))),
7857 Make_Object_Declaration (Loc,
7858 Defining_Identifier => Subp_Index,
7859 Object_Definition =>
7860 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7862 Make_Attribute_Reference (Loc,
7864 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7865 Attribute_Name => Name_Last)));
7870 Make_Subprogram_Body (Loc,
7871 Specification => RPC_Receiver_Spec,
7872 Declarations => RPC_Receiver_Decls,
7873 Handled_Statement_Sequence =>
7874 Make_Handled_Sequence_Of_Statements (Loc,
7875 Statements => Stmts));
7876 end Build_RPC_Receiver_Body;
7878 --------------------------------------
7879 -- Build_Subprogram_Receiving_Stubs --
7880 --------------------------------------
7882 function Build_Subprogram_Receiving_Stubs
7883 (Vis_Decl : Node_Id;
7884 Asynchronous : Boolean;
7885 Dynamically_Asynchronous : Boolean := False;
7886 Stub_Type : Entity_Id := Empty;
7887 RACW_Type : Entity_Id := Empty;
7888 Parent_Primitive : Entity_Id := Empty) return Node_Id
7890 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7892 Request_Parameter : constant Entity_Id :=
7893 Make_Defining_Identifier (Loc,
7894 New_Internal_Name ('R'));
7895 -- Formal parameter for receiving stubs: a descriptor for an incoming
7898 Outer_Decls : constant List_Id := New_List;
7899 -- At the outermost level, an NVList and Any's are declared for all
7900 -- parameters. The Dynamic_Async flag also needs to be declared there
7901 -- to be visible from the exception handling code.
7903 Outer_Statements : constant List_Id := New_List;
7904 -- Statements that occur prior to the declaration of the actual
7905 -- parameter variables.
7907 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7908 -- Statements concerning extra formal parameters, prior to the
7909 -- declaration of the actual parameter variables.
7911 Decls : constant List_Id := New_List;
7912 -- All the parameters will get declared before calling the real
7913 -- subprograms. Also the out parameters will be declared.
7914 -- At this level, parameters may be unconstrained.
7916 Statements : constant List_Id := New_List;
7918 After_Statements : constant List_Id := New_List;
7919 -- Statements to be executed after the subprogram call
7921 Inner_Decls : List_Id := No_List;
7922 -- In case of a function, the inner declarations are needed since
7923 -- the result may be unconstrained.
7925 Excep_Handlers : List_Id := No_List;
7927 Parameter_List : constant List_Id := New_List;
7928 -- List of parameters to be passed to the subprogram
7930 First_Controlling_Formal_Seen : Boolean := False;
7932 Current_Parameter : Node_Id;
7934 Ordered_Parameters_List : constant List_Id :=
7935 Build_Ordered_Parameters_List
7936 (Specification (Vis_Decl));
7938 Arguments : constant Entity_Id :=
7939 Make_Defining_Identifier (Loc,
7940 New_Internal_Name ('A'));
7941 -- Name of the named values list used to retrieve parameters
7943 Subp_Spec : Node_Id;
7944 -- Subprogram specification
7946 Called_Subprogram : Node_Id;
7947 -- The subprogram to call
7950 if Present (RACW_Type) then
7951 Called_Subprogram :=
7952 New_Occurrence_Of (Parent_Primitive, Loc);
7954 Called_Subprogram :=
7956 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7959 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7961 -- Loop through every parameter and get its value from the stream. If
7962 -- the parameter is unconstrained, then the parameter is read using
7963 -- 'Input at the point of declaration.
7965 Current_Parameter := First (Ordered_Parameters_List);
7966 while Present (Current_Parameter) loop
7969 Constrained : Boolean;
7970 Any : Entity_Id := Empty;
7971 Object : constant Entity_Id :=
7972 Make_Defining_Identifier (Loc,
7973 New_Internal_Name ('P'));
7974 Expr : Node_Id := Empty;
7976 Is_Controlling_Formal : constant Boolean
7977 := Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
7979 Is_First_Controlling_Formal : Boolean := False;
7981 Need_Extra_Constrained : Boolean;
7982 -- True when an extra constrained actual is required
7985 if Is_Controlling_Formal then
7987 -- Controlling formals in distributed object primitive
7988 -- operations are handled specially:
7989 -- - the first controlling formal is used as the
7990 -- target of the call;
7991 -- - the remaining controlling formals are transmitted
7995 Is_First_Controlling_Formal :=
7996 not First_Controlling_Formal_Seen;
7997 First_Controlling_Formal_Seen := True;
7999 Etyp := Etype (Parameter_Type (Current_Parameter));
8003 Is_Constrained (Etyp)
8004 or else Is_Elementary_Type (Etyp);
8006 if not Is_First_Controlling_Formal then
8007 Any := Make_Defining_Identifier (Loc,
8008 New_Internal_Name ('A'));
8009 Append_To (Outer_Decls,
8010 Make_Object_Declaration (Loc,
8011 Defining_Identifier =>
8013 Object_Definition =>
8014 New_Occurrence_Of (RTE (RE_Any), Loc),
8016 Make_Function_Call (Loc,
8018 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8019 Parameter_Associations => New_List (
8020 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
8021 Etyp, Outer_Decls)))));
8023 Append_To (Outer_Statements,
8024 Add_Parameter_To_NVList (Loc,
8025 Parameter => Current_Parameter,
8026 NVList => Arguments,
8027 Constrained => Constrained,
8031 if Is_First_Controlling_Formal then
8033 Addr : constant Entity_Id :=
8034 Make_Defining_Identifier (Loc,
8035 New_Internal_Name ('A'));
8036 Is_Local : constant Entity_Id :=
8037 Make_Defining_Identifier (Loc,
8038 New_Internal_Name ('L'));
8041 -- Special case: obtain the first controlling formal
8042 -- from the target of the remote call, instead of the
8045 Append_To (Outer_Decls,
8046 Make_Object_Declaration (Loc,
8047 Defining_Identifier =>
8049 Object_Definition =>
8050 New_Occurrence_Of (RTE (RE_Address), Loc)));
8051 Append_To (Outer_Decls,
8052 Make_Object_Declaration (Loc,
8053 Defining_Identifier =>
8055 Object_Definition =>
8056 New_Occurrence_Of (Standard_Boolean, Loc)));
8057 Append_To (Outer_Statements,
8058 Make_Procedure_Call_Statement (Loc,
8061 RTE (RE_Get_Local_Address), Loc),
8062 Parameter_Associations => New_List (
8063 Make_Selected_Component (Loc,
8066 Request_Parameter, Loc),
8068 Make_Identifier (Loc, Name_Target)),
8069 New_Occurrence_Of (Is_Local, Loc),
8070 New_Occurrence_Of (Addr, Loc))));
8072 Expr := Unchecked_Convert_To (RACW_Type,
8073 New_Occurrence_Of (Addr, Loc));
8076 elsif In_Present (Current_Parameter)
8077 or else not Out_Present (Current_Parameter)
8078 or else not Constrained
8080 -- If an input parameter is constrained, then its reading is
8081 -- deferred until the beginning of the subprogram body. If
8082 -- it is unconstrained, then an expression is built for
8083 -- the object declaration and the variable is set using
8084 -- 'Input instead of 'Read.
8086 Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
8087 Etyp, New_Occurrence_Of (Any, Loc), Decls);
8090 Append_To (Statements,
8091 Make_Assignment_Statement (Loc,
8093 New_Occurrence_Of (Object, Loc),
8099 -- Expr will be used to initialize (and constrain) the
8100 -- parameter when it is declared.
8105 Need_Extra_Constrained :=
8106 Nkind (Parameter_Type (Current_Parameter)) /=
8109 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
8111 Present (Extra_Constrained
8112 (Defining_Identifier (Current_Parameter)));
8114 -- We may not associate an extra constrained actual to a
8115 -- constant object, so if one is needed, declare the actual
8116 -- as a variable even if it won't be modified.
8118 Build_Actual_Object_Declaration
8121 Variable => Need_Extra_Constrained
8122 or else Out_Present (Current_Parameter),
8125 Set_Etype (Object, Etyp);
8127 -- An out parameter may be written back using a 'Write
8128 -- attribute instead of a 'Output because it has been
8129 -- constrained by the parameter given to the caller. Note that
8130 -- out controlling arguments in the case of a RACW are not put
8131 -- back in the stream because the pointer on them has not
8134 if Out_Present (Current_Parameter)
8135 and then not Is_Controlling_Formal
8137 Append_To (After_Statements,
8138 Make_Procedure_Call_Statement (Loc,
8140 New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
8141 Parameter_Associations => New_List (
8142 New_Occurrence_Of (Any, Loc),
8143 PolyORB_Support.Helpers.Build_To_Any_Call (
8144 New_Occurrence_Of (Object, Loc),
8148 -- For RACW controlling formals, the Etyp of Object is always
8149 -- an RACW, even if the parameter is not of an anonymous access
8150 -- type. In such case, we need to dereference it at call time.
8152 if Is_Controlling_Formal then
8153 if Nkind (Parameter_Type (Current_Parameter)) /=
8156 Append_To (Parameter_List,
8157 Make_Parameter_Association (Loc,
8160 Defining_Identifier (Current_Parameter), Loc),
8161 Explicit_Actual_Parameter =>
8162 Make_Explicit_Dereference (Loc,
8163 Unchecked_Convert_To (RACW_Type,
8164 OK_Convert_To (RTE (RE_Address),
8165 New_Occurrence_Of (Object, Loc))))));
8168 Append_To (Parameter_List,
8169 Make_Parameter_Association (Loc,
8172 Defining_Identifier (Current_Parameter), Loc),
8173 Explicit_Actual_Parameter =>
8174 Unchecked_Convert_To (RACW_Type,
8175 OK_Convert_To (RTE (RE_Address),
8176 New_Occurrence_Of (Object, Loc)))));
8180 Append_To (Parameter_List,
8181 Make_Parameter_Association (Loc,
8184 Defining_Identifier (Current_Parameter), Loc),
8185 Explicit_Actual_Parameter =>
8186 New_Occurrence_Of (Object, Loc)));
8189 -- If the current parameter needs an extra formal, then read it
8190 -- from the stream and set the corresponding semantic field in
8191 -- the variable. If the kind of the parameter identifier is
8192 -- E_Void, then this is a compiler generated parameter that
8193 -- doesn't need an extra constrained status.
8195 -- The case of Extra_Accessibility should also be handled ???
8197 if Need_Extra_Constrained then
8199 Extra_Parameter : constant Entity_Id :=
8201 (Defining_Identifier
8202 (Current_Parameter));
8203 Extra_Any : constant Entity_Id :=
8204 Make_Defining_Identifier
8205 (Loc, New_Internal_Name ('A'));
8207 Formal_Entity : constant Entity_Id :=
8208 Make_Defining_Identifier
8209 (Loc, Chars (Extra_Parameter));
8211 Formal_Type : constant Entity_Id :=
8212 Etype (Extra_Parameter);
8214 Append_To (Outer_Decls,
8215 Make_Object_Declaration (Loc,
8216 Defining_Identifier =>
8218 Object_Definition =>
8219 New_Occurrence_Of (RTE (RE_Any), Loc),
8221 Make_Function_Call (Loc,
8223 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8224 Parameter_Associations => New_List (
8225 PolyORB_Support.Helpers.Build_TypeCode_Call
8226 (Loc, Formal_Type, Outer_Decls)))));
8228 Append_To (Outer_Extra_Formal_Statements,
8229 Add_Parameter_To_NVList (Loc,
8230 Parameter => Extra_Parameter,
8231 NVList => Arguments,
8232 Constrained => True,
8236 Make_Object_Declaration (Loc,
8237 Defining_Identifier => Formal_Entity,
8238 Object_Definition =>
8239 New_Occurrence_Of (Formal_Type, Loc)));
8241 Append_To (Statements,
8242 Make_Assignment_Statement (Loc,
8244 New_Occurrence_Of (Formal_Entity, Loc),
8246 PolyORB_Support.Helpers.Build_From_Any_Call (
8248 New_Occurrence_Of (Extra_Any, Loc),
8250 Set_Extra_Constrained (Object, Formal_Entity);
8255 Next (Current_Parameter);
8258 -- Extra Formals should go after all the other parameters
8260 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8262 Append_To (Outer_Statements,
8263 Make_Procedure_Call_Statement (Loc,
8265 New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8266 Parameter_Associations => New_List (
8267 New_Occurrence_Of (Request_Parameter, Loc),
8268 New_Occurrence_Of (Arguments, Loc))));
8270 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8272 -- The remote subprogram is a function. We build an inner block to
8273 -- be able to hold a potentially unconstrained result in a
8277 Etyp : constant Entity_Id :=
8278 Etype (Result_Definition (Specification (Vis_Decl)));
8279 Result : constant Node_Id :=
8280 Make_Defining_Identifier (Loc,
8281 New_Internal_Name ('R'));
8283 Inner_Decls := New_List (
8284 Make_Object_Declaration (Loc,
8285 Defining_Identifier => Result,
8286 Constant_Present => True,
8287 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8289 Make_Function_Call (Loc,
8290 Name => Called_Subprogram,
8291 Parameter_Associations => Parameter_List)));
8293 if Is_Class_Wide_Type (Etyp) then
8295 -- For a remote call to a function with a class-wide type,
8296 -- check that the returned value satisfies the requirements
8299 Append_To (Inner_Decls,
8300 Make_Transportable_Check (Loc,
8301 New_Occurrence_Of (Result, Loc)));
8305 Set_Etype (Result, Etyp);
8306 Append_To (After_Statements,
8307 Make_Procedure_Call_Statement (Loc,
8309 New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8310 Parameter_Associations => New_List (
8311 New_Occurrence_Of (Request_Parameter, Loc),
8312 PolyORB_Support.Helpers.Build_To_Any_Call (
8313 New_Occurrence_Of (Result, Loc),
8315 -- A DSA function does not have out or inout arguments
8318 Append_To (Statements,
8319 Make_Block_Statement (Loc,
8320 Declarations => Inner_Decls,
8321 Handled_Statement_Sequence =>
8322 Make_Handled_Sequence_Of_Statements (Loc,
8323 Statements => After_Statements)));
8326 -- The remote subprogram is a procedure. We do not need any inner
8327 -- block in this case. No specific processing is required here for
8328 -- the dynamically asynchronous case: the indication of whether
8329 -- call is asynchronous or not is managed by the Sync_Scope
8330 -- attibute of the request, and is handled entirely in the
8333 Append_To (After_Statements,
8334 Make_Procedure_Call_Statement (Loc,
8336 New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8337 Parameter_Associations => New_List (
8338 New_Occurrence_Of (Request_Parameter, Loc))));
8340 Append_To (Statements,
8341 Make_Procedure_Call_Statement (Loc,
8342 Name => Called_Subprogram,
8343 Parameter_Associations => Parameter_List));
8345 Append_List_To (Statements, After_Statements);
8349 Make_Procedure_Specification (Loc,
8350 Defining_Unit_Name =>
8351 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
8353 Parameter_Specifications => New_List (
8354 Make_Parameter_Specification (Loc,
8355 Defining_Identifier => Request_Parameter,
8357 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8359 -- An exception raised during the execution of an incoming
8360 -- remote subprogram call and that needs to be sent back
8361 -- to the caller is propagated by the receiving stubs, and
8362 -- will be handled by the caller (the distribution runtime).
8364 if Asynchronous and then not Dynamically_Asynchronous then
8366 -- For an asynchronous procedure, add a null exception handler
8368 Excep_Handlers := New_List (
8369 Make_Implicit_Exception_Handler (Loc,
8370 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8371 Statements => New_List (Make_Null_Statement (Loc))));
8375 -- In the other cases, if an exception is raised, then the
8376 -- exception occurrence is propagated.
8381 Append_To (Outer_Statements,
8382 Make_Block_Statement (Loc,
8385 Handled_Statement_Sequence =>
8386 Make_Handled_Sequence_Of_Statements (Loc,
8387 Statements => Statements)));
8390 Make_Subprogram_Body (Loc,
8391 Specification => Subp_Spec,
8392 Declarations => Outer_Decls,
8393 Handled_Statement_Sequence =>
8394 Make_Handled_Sequence_Of_Statements (Loc,
8395 Statements => Outer_Statements,
8396 Exception_Handlers => Excep_Handlers));
8397 end Build_Subprogram_Receiving_Stubs;
8403 package body Helpers is
8405 -----------------------
8406 -- Local Subprograms --
8407 -----------------------
8409 function Find_Numeric_Representation
8410 (Typ : Entity_Id) return Entity_Id;
8411 -- Given a numeric type Typ, return the smallest integer or floarting
8412 -- point type from Standard, or the smallest unsigned (modular) type
8413 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8415 function Make_Stream_Procedure_Function_Name
8418 Nam : Name_Id) return Entity_Id;
8419 -- Return the name to be assigned for stream subprogram Nam of Typ.
8420 -- (copied from exp_strm.adb, should be shared???)
8422 ------------------------------------------------------------
8423 -- Common subprograms for building various tree fragments --
8424 ------------------------------------------------------------
8426 function Build_Get_Aggregate_Element
8430 Idx : Node_Id) return Node_Id;
8431 -- Build a call to Get_Aggregate_Element on Any
8432 -- for typecode TC, returning the Idx'th element.
8435 Subprogram : Entity_Id;
8436 -- Reference location for constructed nodes
8439 -- For 'Range and Etype
8442 -- For the construction of the innermost element expression
8444 with procedure Add_Process_Element
8447 Counter : Entity_Id;
8450 procedure Append_Array_Traversal
8453 Counter : Entity_Id := Empty;
8455 -- Build nested loop statements that iterate over the elements of an
8456 -- array Arry. The statement(s) built by Add_Process_Element are
8457 -- executed for each element; Indices is the list of indices to be
8458 -- used in the construction of the indexed component that denotes the
8459 -- current element. Subprogram is the entity for the subprogram for
8460 -- which this iterator is generated. The generated statements are
8461 -- appended to Stmts.
8465 -- The record entity being dealt with
8467 with procedure Add_Process_Element
8469 Container : Node_Or_Entity_Id;
8470 Counter : in out Int;
8473 -- Rec is the instance of the record type, or Empty.
8474 -- Field is either the N_Defining_Identifier for a component,
8475 -- or an N_Variant_Part.
8477 procedure Append_Record_Traversal
8480 Container : Node_Or_Entity_Id;
8481 Counter : in out Int);
8482 -- Process component list Clist. Individual fields are passed
8483 -- to Field_Processing. Each variant part is also processed.
8484 -- Container is the outer Any (for From_Any/To_Any),
8485 -- the outer typecode (for TC) to which the operation applies.
8487 -----------------------------
8488 -- Append_Record_Traversal --
8489 -----------------------------
8491 procedure Append_Record_Traversal
8494 Container : Node_Or_Entity_Id;
8495 Counter : in out Int)
8499 -- Clist's Component_Items and Variant_Part
8509 CI := Component_Items (Clist);
8510 VP := Variant_Part (Clist);
8513 while Present (Item) loop
8514 Def := Defining_Identifier (Item);
8515 if not Is_Internal_Name (Chars (Def)) then
8517 (Stmts, Container, Counter, Rec, Def);
8522 if Present (VP) then
8523 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8525 end Append_Record_Traversal;
8527 -------------------------
8528 -- Build_From_Any_Call --
8529 -------------------------
8531 function Build_From_Any_Call
8534 Decls : List_Id) return Node_Id
8536 Loc : constant Source_Ptr := Sloc (N);
8538 U_Type : Entity_Id := Underlying_Type (Typ);
8540 Fnam : Entity_Id := Empty;
8541 Lib_RE : RE_Id := RE_Null;
8545 -- First simple case where the From_Any function is present
8546 -- in the type's TSS.
8548 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8550 if Sloc (U_Type) <= Standard_Location then
8551 U_Type := Base_Type (U_Type);
8554 -- Check first for Boolean and Character. These are enumeration
8555 -- types, but we treat them specially, since they may require
8556 -- special handling in the transfer protocol. However, this
8557 -- special handling only applies if they have standard
8558 -- representation, otherwise they are treated like any other
8559 -- enumeration type.
8561 if Present (Fnam) then
8564 elsif U_Type = Standard_Boolean then
8567 elsif U_Type = Standard_Character then
8570 elsif U_Type = Standard_Wide_Character then
8573 elsif U_Type = Standard_Wide_Wide_Character then
8574 Lib_RE := RE_FA_WWC;
8576 -- Floating point types
8578 elsif U_Type = Standard_Short_Float then
8581 elsif U_Type = Standard_Float then
8584 elsif U_Type = Standard_Long_Float then
8587 elsif U_Type = Standard_Long_Long_Float then
8588 Lib_RE := RE_FA_LLF;
8592 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8593 Lib_RE := RE_FA_SSI;
8595 elsif U_Type = Etype (Standard_Short_Integer) then
8598 elsif U_Type = Etype (Standard_Integer) then
8601 elsif U_Type = Etype (Standard_Long_Integer) then
8604 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8605 Lib_RE := RE_FA_LLI;
8607 -- Unsigned integer types
8609 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8610 Lib_RE := RE_FA_SSU;
8612 elsif U_Type = RTE (RE_Short_Unsigned) then
8615 elsif U_Type = RTE (RE_Unsigned) then
8618 elsif U_Type = RTE (RE_Long_Unsigned) then
8621 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8622 Lib_RE := RE_FA_LLU;
8624 elsif U_Type = Standard_String then
8625 Lib_RE := RE_FA_String;
8627 -- Other (non-primitive) types
8633 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8634 Append_To (Decls, Decl);
8638 -- Call the function
8640 if Lib_RE /= RE_Null then
8641 pragma Assert (No (Fnam));
8642 Fnam := RTE (Lib_RE);
8646 Make_Function_Call (Loc,
8647 Name => New_Occurrence_Of (Fnam, Loc),
8648 Parameter_Associations => New_List (N));
8650 -- We must set the type of Result, so the unchecked conversion
8651 -- from the underlying type to the base type is properly done.
8653 Set_Etype (Result, U_Type);
8655 return Unchecked_Convert_To (Typ, Result);
8656 end Build_From_Any_Call;
8658 -----------------------------
8659 -- Build_From_Any_Function --
8660 -----------------------------
8662 procedure Build_From_Any_Function
8666 Fnam : out Entity_Id)
8669 Decls : constant List_Id := New_List;
8670 Stms : constant List_Id := New_List;
8671 Any_Parameter : constant Entity_Id
8672 := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
8674 if Is_Itype (Typ) then
8675 Build_From_Any_Function
8683 Fnam := Make_Stream_Procedure_Function_Name (Loc,
8684 Typ, Name_uFrom_Any);
8687 Make_Function_Specification (Loc,
8688 Defining_Unit_Name => Fnam,
8689 Parameter_Specifications => New_List (
8690 Make_Parameter_Specification (Loc,
8691 Defining_Identifier =>
8694 New_Occurrence_Of (RTE (RE_Any), Loc))),
8695 Result_Definition => New_Occurrence_Of (Typ, Loc));
8697 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8700 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8702 if Is_Derived_Type (Typ)
8703 and then not Is_Tagged_Type (Typ)
8706 Make_Return_Statement (Loc,
8710 Build_From_Any_Call (
8712 New_Occurrence_Of (Any_Parameter, Loc),
8715 elsif Is_Record_Type (Typ)
8716 and then not Is_Derived_Type (Typ)
8717 and then not Is_Tagged_Type (Typ)
8719 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8721 Make_Return_Statement (Loc,
8725 Build_From_Any_Call (
8727 New_Occurrence_Of (Any_Parameter, Loc),
8731 Disc : Entity_Id := Empty;
8732 Discriminant_Associations : List_Id;
8733 Rdef : constant Node_Id :=
8734 Type_Definition (Declaration_Node (Typ));
8735 Component_Counter : Int := 0;
8737 -- The returned object
8739 Res : constant Entity_Id :=
8740 Make_Defining_Identifier (Loc,
8741 New_Internal_Name ('R'));
8743 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8745 procedure FA_Rec_Add_Process_Element
8748 Counter : in out Int;
8752 procedure FA_Append_Record_Traversal is
8753 new Append_Record_Traversal
8755 Add_Process_Element => FA_Rec_Add_Process_Element);
8757 --------------------------------
8758 -- FA_Rec_Add_Process_Element --
8759 --------------------------------
8761 procedure FA_Rec_Add_Process_Element
8764 Counter : in out Int;
8769 if Nkind (Field) = N_Defining_Identifier then
8771 -- A regular component
8774 Make_Assignment_Statement (Loc,
8775 Name => Make_Selected_Component (Loc,
8777 New_Occurrence_Of (Rec, Loc),
8779 New_Occurrence_Of (Field, Loc)),
8781 Build_From_Any_Call (Etype (Field),
8782 Build_Get_Aggregate_Element (Loc,
8784 Tc => Build_TypeCode_Call (Loc,
8785 Etype (Field), Decls),
8786 Idx => Make_Integer_Literal (Loc,
8795 Struct_Counter : Int := 0;
8797 Block_Decls : constant List_Id := New_List;
8798 Block_Stmts : constant List_Id := New_List;
8801 Alt_List : constant List_Id := New_List;
8802 Choice_List : List_Id;
8804 Struct_Any : constant Entity_Id :=
8805 Make_Defining_Identifier (Loc,
8806 New_Internal_Name ('S'));
8810 Make_Object_Declaration (Loc,
8811 Defining_Identifier =>
8815 Object_Definition =>
8816 New_Occurrence_Of (RTE (RE_Any), Loc),
8818 Make_Function_Call (Loc,
8819 Name => New_Occurrence_Of (
8820 RTE (RE_Extract_Union_Value), Loc),
8821 Parameter_Associations => New_List (
8822 Build_Get_Aggregate_Element (Loc,
8824 Tc => Make_Function_Call (Loc,
8825 Name => New_Occurrence_Of (
8826 RTE (RE_Any_Member_Type), Loc),
8827 Parameter_Associations =>
8829 New_Occurrence_Of (Any, Loc),
8830 Make_Integer_Literal (Loc,
8832 Idx => Make_Integer_Literal (Loc,
8836 Make_Block_Statement (Loc,
8839 Handled_Statement_Sequence =>
8840 Make_Handled_Sequence_Of_Statements (Loc,
8841 Statements => Block_Stmts)));
8843 Append_To (Block_Stmts,
8844 Make_Case_Statement (Loc,
8846 Make_Selected_Component (Loc,
8849 Chars (Name (Field))),
8853 Variant := First_Non_Pragma (Variants (Field));
8855 while Present (Variant) loop
8856 Choice_List := New_Copy_List_Tree
8857 (Discrete_Choices (Variant));
8859 VP_Stmts := New_List;
8861 -- Struct_Counter should be reset before
8862 -- handling a variant part. Indeed only one
8863 -- of the case statement alternatives will be
8864 -- executed at run-time, so the counter must
8865 -- start at 0 for every case statement.
8867 Struct_Counter := 0;
8869 FA_Append_Record_Traversal (
8871 Clist => Component_List (Variant),
8872 Container => Struct_Any,
8873 Counter => Struct_Counter);
8875 Append_To (Alt_List,
8876 Make_Case_Statement_Alternative (Loc,
8877 Discrete_Choices => Choice_List,
8880 Next_Non_Pragma (Variant);
8884 Counter := Counter + 1;
8885 end FA_Rec_Add_Process_Element;
8888 -- First all discriminants
8890 if Has_Discriminants (Typ) then
8891 Disc := First_Discriminant (Typ);
8892 Discriminant_Associations := New_List;
8894 while Present (Disc) loop
8896 Disc_Var_Name : constant Entity_Id :=
8897 Make_Defining_Identifier (Loc, Chars (Disc));
8898 Disc_Type : constant Entity_Id :=
8902 Make_Object_Declaration (Loc,
8903 Defining_Identifier =>
8905 Constant_Present => True,
8906 Object_Definition =>
8907 New_Occurrence_Of (Disc_Type, Loc),
8909 Build_From_Any_Call (Disc_Type,
8910 Build_Get_Aggregate_Element (Loc,
8911 Any => Any_Parameter,
8912 Tc => Build_TypeCode_Call
8913 (Loc, Disc_Type, Decls),
8914 Idx => Make_Integer_Literal
8915 (Loc, Component_Counter)),
8917 Component_Counter := Component_Counter + 1;
8919 Append_To (Discriminant_Associations,
8920 Make_Discriminant_Association (Loc,
8921 Selector_Names => New_List (
8922 New_Occurrence_Of (Disc, Loc)),
8924 New_Occurrence_Of (Disc_Var_Name, Loc)));
8926 Next_Discriminant (Disc);
8929 Res_Definition := Make_Subtype_Indication (Loc,
8930 Subtype_Mark => Res_Definition,
8932 Make_Index_Or_Discriminant_Constraint (Loc,
8933 Discriminant_Associations));
8936 -- Now we have all the discriminants in variables, we can
8937 -- declared a constrained object. Note that we are not
8938 -- initializing (non-discriminant) components directly in
8939 -- the object declarations, because which fields to
8940 -- initialize depends (at run time) on the discriminant
8944 Make_Object_Declaration (Loc,
8945 Defining_Identifier =>
8947 Object_Definition =>
8950 -- ... then all components
8952 FA_Append_Record_Traversal (Stms,
8953 Clist => Component_List (Rdef),
8954 Container => Any_Parameter,
8955 Counter => Component_Counter);
8958 Make_Return_Statement (Loc,
8959 Expression => New_Occurrence_Of (Res, Loc)));
8963 elsif Is_Array_Type (Typ) then
8965 Constrained : constant Boolean := Is_Constrained (Typ);
8967 procedure FA_Ary_Add_Process_Element
8970 Counter : Entity_Id;
8972 -- Assign the current element (as identified by Counter) of
8973 -- Any to the variable denoted by name Datum, and advance
8974 -- Counter by 1. If Datum is not an Any, a call to From_Any
8975 -- for its type is inserted.
8977 --------------------------------
8978 -- FA_Ary_Add_Process_Element --
8979 --------------------------------
8981 procedure FA_Ary_Add_Process_Element
8984 Counter : Entity_Id;
8987 Assignment : constant Node_Id :=
8988 Make_Assignment_Statement (Loc,
8990 Expression => Empty);
8992 Element_Any : Node_Id;
8996 Element_TC : Node_Id;
8999 if Etype (Datum) = RTE (RE_Any) then
9001 -- When Datum is an Any the Etype field is not
9002 -- sufficient to determine the typecode of Datum
9003 -- (which can be a TC_SEQUENCE or TC_ARRAY
9004 -- depending on the value of Constrained).
9005 -- Therefore we retrieve the typecode which has
9006 -- been constructed in Append_Array_Traversal with
9007 -- a call to Get_Any_Type.
9010 Make_Function_Call (Loc,
9011 Name => New_Occurrence_Of (
9012 RTE (RE_Get_Any_Type), Loc),
9013 Parameter_Associations => New_List (
9014 New_Occurrence_Of (Entity (Datum), Loc)));
9016 -- For non Any Datum we simply construct a typecode
9017 -- matching the Etype of the Datum.
9019 Element_TC := Build_TypeCode_Call
9020 (Loc, Etype (Datum), Decls);
9024 Build_Get_Aggregate_Element (Loc,
9027 Idx => New_Occurrence_Of (Counter, Loc));
9030 -- Note: here we *prepend* statements to Stmts, so
9031 -- we must do it in reverse order.
9034 Make_Assignment_Statement (Loc,
9036 New_Occurrence_Of (Counter, Loc),
9040 New_Occurrence_Of (Counter, Loc),
9042 Make_Integer_Literal (Loc, 1))));
9044 if Nkind (Datum) /= N_Attribute_Reference then
9046 -- We ignore the value of the length of each
9047 -- dimension, since the target array has already
9048 -- been constrained anyway.
9050 if Etype (Datum) /= RTE (RE_Any) then
9051 Set_Expression (Assignment,
9052 Build_From_Any_Call (
9053 Component_Type (Typ),
9057 Set_Expression (Assignment, Element_Any);
9059 Prepend_To (Stmts, Assignment);
9061 end FA_Ary_Add_Process_Element;
9063 Counter : constant Entity_Id :=
9064 Make_Defining_Identifier (Loc, Name_J);
9066 Initial_Counter_Value : Int := 0;
9068 Component_TC : constant Entity_Id :=
9069 Make_Defining_Identifier (Loc, Name_T);
9071 Res : constant Entity_Id :=
9072 Make_Defining_Identifier (Loc, Name_R);
9074 procedure Append_From_Any_Array_Iterator is
9075 new Append_Array_Traversal (
9078 Indices => New_List,
9079 Add_Process_Element => FA_Ary_Add_Process_Element);
9081 Res_Subtype_Indication : Node_Id :=
9082 New_Occurrence_Of (Typ, Loc);
9085 if not Constrained then
9087 Ndim : constant Int := Number_Dimensions (Typ);
9090 Indx : Node_Id := First_Index (Typ);
9093 Ranges : constant List_Id := New_List;
9096 for J in 1 .. Ndim loop
9097 Lnam := New_External_Name ('L', J);
9098 Hnam := New_External_Name ('H', J);
9099 Indt := Etype (Indx);
9102 Make_Object_Declaration (Loc,
9103 Defining_Identifier =>
9104 Make_Defining_Identifier (Loc, Lnam),
9107 Object_Definition =>
9108 New_Occurrence_Of (Indt, Loc),
9110 Build_From_Any_Call (
9112 Build_Get_Aggregate_Element (Loc,
9113 Any => Any_Parameter,
9114 Tc => Build_TypeCode_Call (Loc,
9116 Idx => Make_Integer_Literal (Loc, J - 1)),
9120 Make_Object_Declaration (Loc,
9121 Defining_Identifier =>
9122 Make_Defining_Identifier (Loc, Hnam),
9125 Object_Definition =>
9126 New_Occurrence_Of (Indt, Loc),
9127 Expression => Make_Attribute_Reference (Loc,
9129 New_Occurrence_Of (Indt, Loc),
9130 Attribute_Name => Name_Val,
9131 Expressions => New_List (
9132 Make_Op_Subtract (Loc,
9137 Standard_Long_Integer,
9138 Make_Identifier (Loc, Lnam)),
9141 Standard_Long_Integer,
9142 Make_Function_Call (Loc,
9143 Name => New_Occurrence_Of (RTE (
9144 RE_Get_Nested_Sequence_Length
9146 Parameter_Associations =>
9149 Any_Parameter, Loc),
9150 Make_Integer_Literal (Loc,
9153 Make_Integer_Literal (Loc, 1))))));
9157 Low_Bound => Make_Identifier (Loc, Lnam),
9158 High_Bound => Make_Identifier (Loc, Hnam)));
9163 -- Now we have all the necessary bound information:
9164 -- apply the set of range constraints to the
9165 -- (unconstrained) nominal subtype of Res.
9167 Initial_Counter_Value := Ndim;
9168 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9170 Res_Subtype_Indication,
9172 Make_Index_Or_Discriminant_Constraint (Loc,
9173 Constraints => Ranges));
9178 Make_Object_Declaration (Loc,
9179 Defining_Identifier => Res,
9180 Object_Definition => Res_Subtype_Indication));
9181 Set_Etype (Res, Typ);
9184 Make_Object_Declaration (Loc,
9185 Defining_Identifier => Counter,
9186 Object_Definition =>
9187 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
9189 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9192 Make_Object_Declaration (Loc,
9193 Defining_Identifier => Component_TC,
9194 Constant_Present => True,
9195 Object_Definition =>
9196 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9198 Build_TypeCode_Call (Loc,
9199 Component_Type (Typ), Decls)));
9201 Append_From_Any_Array_Iterator (Stms,
9202 Any_Parameter, Counter);
9205 Make_Return_Statement (Loc,
9206 Expression => New_Occurrence_Of (Res, Loc)));
9209 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9211 Make_Return_Statement (Loc,
9213 Unchecked_Convert_To (
9215 Build_From_Any_Call (
9216 Find_Numeric_Representation (Typ),
9217 New_Occurrence_Of (Any_Parameter, Loc),
9221 -- Default: type is represented as an opaque sequence of bytes
9224 Strm : constant Entity_Id :=
9225 Make_Defining_Identifier (Loc,
9226 Chars => New_Internal_Name ('S'));
9227 Res : constant Entity_Id :=
9228 Make_Defining_Identifier (Loc,
9229 Chars => New_Internal_Name ('R'));
9232 -- Strm : Buffer_Stream_Type;
9235 Make_Object_Declaration (Loc,
9236 Defining_Identifier =>
9240 Object_Definition =>
9241 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9243 -- Allocate_Buffer (Strm);
9246 Make_Procedure_Call_Statement (Loc,
9248 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9249 Parameter_Associations => New_List (
9250 New_Occurrence_Of (Strm, Loc))));
9252 -- Any_To_BS (Strm, A);
9255 Make_Procedure_Call_Statement (Loc,
9257 New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
9258 Parameter_Associations => New_List (
9259 New_Occurrence_Of (Any_Parameter, Loc),
9260 New_Occurrence_Of (Strm, Loc))));
9263 -- Res : constant T := T'Input (Strm);
9265 -- Release_Buffer (Strm);
9269 Append_To (Stms, Make_Block_Statement (Loc,
9270 Declarations => New_List (
9271 Make_Object_Declaration (Loc,
9272 Defining_Identifier => Res,
9273 Constant_Present => True,
9274 Object_Definition =>
9275 New_Occurrence_Of (Typ, Loc),
9277 Make_Attribute_Reference (Loc,
9278 Prefix => New_Occurrence_Of (Typ, Loc),
9279 Attribute_Name => Name_Input,
9280 Expressions => New_List (
9281 Make_Attribute_Reference (Loc,
9282 Prefix => New_Occurrence_Of (Strm, Loc),
9283 Attribute_Name => Name_Access))))),
9285 Handled_Statement_Sequence =>
9286 Make_Handled_Sequence_Of_Statements (Loc,
9287 Statements => New_List (
9288 Make_Procedure_Call_Statement (Loc,
9290 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
9291 Parameter_Associations =>
9293 New_Occurrence_Of (Strm, Loc))),
9294 Make_Return_Statement (Loc,
9295 Expression => New_Occurrence_Of (Res, Loc))))));
9301 Make_Subprogram_Body (Loc,
9302 Specification => Spec,
9303 Declarations => Decls,
9304 Handled_Statement_Sequence =>
9305 Make_Handled_Sequence_Of_Statements (Loc,
9306 Statements => Stms));
9307 end Build_From_Any_Function;
9309 ---------------------------------
9310 -- Build_Get_Aggregate_Element --
9311 ---------------------------------
9313 function Build_Get_Aggregate_Element
9317 Idx : Node_Id) return Node_Id
9320 return Make_Function_Call (Loc,
9323 RTE (RE_Get_Aggregate_Element), Loc),
9324 Parameter_Associations => New_List (
9325 New_Occurrence_Of (Any, Loc),
9328 end Build_Get_Aggregate_Element;
9330 -------------------------
9331 -- Build_Reposiroty_Id --
9332 -------------------------
9334 procedure Build_Name_And_Repository_Id
9336 Name_Str : out String_Id;
9337 Repo_Id_Str : out String_Id)
9341 Store_String_Chars ("DSA:");
9342 Get_Library_Unit_Name_String (Scope (E));
9343 Store_String_Chars (
9344 Name_Buffer (Name_Buffer'First
9345 .. Name_Buffer'First + Name_Len - 1));
9346 Store_String_Char ('.');
9347 Get_Name_String (Chars (E));
9348 Store_String_Chars (
9349 Name_Buffer (Name_Buffer'First
9350 .. Name_Buffer'First + Name_Len - 1));
9351 Store_String_Chars (":1.0");
9352 Repo_Id_Str := End_String;
9353 Name_Str := String_From_Name_Buffer;
9354 end Build_Name_And_Repository_Id;
9356 -----------------------
9357 -- Build_To_Any_Call --
9358 -----------------------
9360 function Build_To_Any_Call
9362 Decls : List_Id) return Node_Id
9364 Loc : constant Source_Ptr := Sloc (N);
9366 Typ : Entity_Id := Etype (N);
9369 Fnam : Entity_Id := Empty;
9370 Lib_RE : RE_Id := RE_Null;
9373 -- If N is a selected component, then maybe its Etype has not been
9374 -- set yet: try to use the Etype of the selector_name in that
9377 if No (Typ) and then Nkind (N) = N_Selected_Component then
9378 Typ := Etype (Selector_Name (N));
9380 pragma Assert (Present (Typ));
9382 -- The full view, if Typ is private; the completion, if Typ is
9385 U_Type := Underlying_Type (Typ);
9387 -- First simple case where the To_Any function is present in the
9390 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9392 -- Check first for Boolean and Character. These are enumeration
9393 -- types, but we treat them specially, since they may require
9394 -- special handling in the transfer protocol. However, this
9395 -- special handling only applies if they have standard
9396 -- representation, otherwise they are treated like any other
9397 -- enumeration type.
9399 if Sloc (U_Type) <= Standard_Location then
9400 U_Type := Base_Type (U_Type);
9403 if Present (Fnam) then
9406 elsif U_Type = Standard_Boolean then
9409 elsif U_Type = Standard_Character then
9412 elsif U_Type = Standard_Wide_Character then
9415 elsif U_Type = Standard_Wide_Wide_Character then
9416 Lib_RE := RE_TA_WWC;
9418 -- Floating point types
9420 elsif U_Type = Standard_Short_Float then
9423 elsif U_Type = Standard_Float then
9426 elsif U_Type = Standard_Long_Float then
9429 elsif U_Type = Standard_Long_Long_Float then
9430 Lib_RE := RE_TA_LLF;
9434 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9435 Lib_RE := RE_TA_SSI;
9437 elsif U_Type = Etype (Standard_Short_Integer) then
9440 elsif U_Type = Etype (Standard_Integer) then
9443 elsif U_Type = Etype (Standard_Long_Integer) then
9446 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9447 Lib_RE := RE_TA_LLI;
9449 -- Unsigned integer types
9451 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9452 Lib_RE := RE_TA_SSU;
9454 elsif U_Type = RTE (RE_Short_Unsigned) then
9457 elsif U_Type = RTE (RE_Unsigned) then
9460 elsif U_Type = RTE (RE_Long_Unsigned) then
9463 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9464 Lib_RE := RE_TA_LLU;
9466 elsif U_Type = Standard_String then
9467 Lib_RE := RE_TA_String;
9469 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9472 -- Other (non-primitive) types
9478 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9479 Append_To (Decls, Decl);
9483 -- Call the function
9485 if Lib_RE /= RE_Null then
9486 pragma Assert (No (Fnam));
9487 Fnam := RTE (Lib_RE);
9491 Make_Function_Call (Loc,
9492 Name => New_Occurrence_Of (Fnam, Loc),
9493 Parameter_Associations =>
9494 New_List (Unchecked_Convert_To (U_Type, N)));
9495 end Build_To_Any_Call;
9497 ---------------------------
9498 -- Build_To_Any_Function --
9499 ---------------------------
9501 procedure Build_To_Any_Function
9505 Fnam : out Entity_Id)
9508 Decls : constant List_Id := New_List;
9509 Stms : constant List_Id := New_List;
9511 Expr_Parameter : constant Entity_Id :=
9512 Make_Defining_Identifier (Loc, Name_E);
9514 Any : constant Entity_Id :=
9515 Make_Defining_Identifier (Loc, Name_A);
9518 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9521 if Is_Itype (Typ) then
9522 Build_To_Any_Function
9530 Fnam := Make_Stream_Procedure_Function_Name (Loc,
9534 Make_Function_Specification (Loc,
9535 Defining_Unit_Name => Fnam,
9536 Parameter_Specifications => New_List (
9537 Make_Parameter_Specification (Loc,
9538 Defining_Identifier =>
9541 New_Occurrence_Of (Typ, Loc))),
9542 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9543 Set_Etype (Expr_Parameter, Typ);
9546 Make_Object_Declaration (Loc,
9547 Defining_Identifier =>
9549 Object_Definition =>
9550 New_Occurrence_Of (RTE (RE_Any), Loc));
9552 if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9554 Rt_Type : constant Entity_Id
9556 Expr : constant Node_Id
9559 New_Occurrence_Of (Expr_Parameter, Loc));
9561 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9564 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9565 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9567 Rt_Type : constant Entity_Id
9569 Expr : constant Node_Id
9572 New_Occurrence_Of (Expr_Parameter, Loc));
9575 Set_Expression (Any_Decl,
9576 Build_To_Any_Call (Expr, Decls));
9581 Disc : Entity_Id := Empty;
9582 Rdef : constant Node_Id :=
9583 Type_Definition (Declaration_Node (Typ));
9585 Elements : constant List_Id := New_List;
9587 procedure TA_Rec_Add_Process_Element
9589 Container : Node_Or_Entity_Id;
9590 Counter : in out Int;
9594 procedure TA_Append_Record_Traversal is
9595 new Append_Record_Traversal
9596 (Rec => Expr_Parameter,
9597 Add_Process_Element => TA_Rec_Add_Process_Element);
9599 --------------------------------
9600 -- TA_Rec_Add_Process_Element --
9601 --------------------------------
9603 procedure TA_Rec_Add_Process_Element
9605 Container : Node_Or_Entity_Id;
9606 Counter : in out Int;
9610 Field_Ref : Node_Id;
9613 if Nkind (Field) = N_Defining_Identifier then
9615 -- A regular component
9617 Field_Ref := Make_Selected_Component (Loc,
9618 Prefix => New_Occurrence_Of (Rec, Loc),
9619 Selector_Name => New_Occurrence_Of (Field, Loc));
9620 Set_Etype (Field_Ref, Etype (Field));
9623 Make_Procedure_Call_Statement (Loc,
9626 RTE (RE_Add_Aggregate_Element), Loc),
9627 Parameter_Associations => New_List (
9628 New_Occurrence_Of (Container, Loc),
9629 Build_To_Any_Call (Field_Ref, Decls))));
9636 Struct_Counter : Int := 0;
9638 Block_Decls : constant List_Id := New_List;
9639 Block_Stmts : constant List_Id := New_List;
9642 Alt_List : constant List_Id := New_List;
9643 Choice_List : List_Id;
9645 Union_Any : constant Entity_Id :=
9646 Make_Defining_Identifier (Loc,
9647 New_Internal_Name ('V'));
9649 Struct_Any : constant Entity_Id :=
9650 Make_Defining_Identifier (Loc,
9651 New_Internal_Name ('S'));
9653 function Make_Discriminant_Reference
9655 -- Build a selected component for the
9656 -- discriminant of this variant part.
9658 ---------------------------------
9659 -- Make_Discriminant_Reference --
9660 ---------------------------------
9662 function Make_Discriminant_Reference
9665 Nod : constant Node_Id :=
9666 Make_Selected_Component (Loc,
9669 Chars (Name (Field)));
9671 Set_Etype (Nod, Etype (Name (Field)));
9673 end Make_Discriminant_Reference;
9677 Make_Block_Statement (Loc,
9680 Handled_Statement_Sequence =>
9681 Make_Handled_Sequence_Of_Statements (Loc,
9682 Statements => Block_Stmts)));
9684 -- Declare the Variant Part aggregate
9686 -- Knowing the position of this VP in
9687 -- the variant record, we can fetch the
9688 -- VP typecode from Container.
9690 Append_To (Block_Decls,
9691 Make_Object_Declaration (Loc,
9692 Defining_Identifier => Union_Any,
9693 Object_Definition =>
9694 New_Occurrence_Of (RTE (RE_Any), Loc),
9696 Make_Function_Call (Loc,
9697 Name => New_Occurrence_Of (
9698 RTE (RE_Create_Any), Loc),
9699 Parameter_Associations => New_List (
9700 Make_Function_Call (Loc,
9703 RTE (RE_Any_Member_Type), Loc),
9704 Parameter_Associations => New_List (
9705 New_Occurrence_Of (Container, Loc),
9706 Make_Integer_Literal (Loc,
9709 -- Declare the inner struct aggregate
9710 -- (that will contain the components
9713 Append_To (Block_Decls,
9714 Make_Object_Declaration (Loc,
9715 Defining_Identifier => Struct_Any,
9716 Object_Definition =>
9717 New_Occurrence_Of (RTE (RE_Any), Loc),
9719 Make_Function_Call (Loc,
9720 Name => New_Occurrence_Of (
9721 RTE (RE_Create_Any), Loc),
9722 Parameter_Associations => New_List (
9723 Make_Function_Call (Loc,
9726 RTE (RE_Any_Member_Type), Loc),
9727 Parameter_Associations => New_List (
9728 New_Occurrence_Of (Union_Any, Loc),
9729 Make_Integer_Literal (Loc,
9732 -- Construct a case statement that will choose
9733 -- the appropriate code at runtime depending on
9734 -- the discriminant.
9736 Append_To (Block_Stmts,
9737 Make_Case_Statement (Loc,
9739 Make_Discriminant_Reference,
9743 Variant := First_Non_Pragma (Variants (Field));
9744 while Present (Variant) loop
9745 Choice_List := New_Copy_List_Tree
9746 (Discrete_Choices (Variant));
9748 VP_Stmts := New_List;
9750 -- Append discriminant value to union
9753 Append_To (VP_Stmts,
9754 Make_Procedure_Call_Statement (Loc,
9757 RTE (RE_Add_Aggregate_Element), Loc),
9758 Parameter_Associations => New_List (
9759 New_Occurrence_Of (Union_Any, Loc),
9761 Make_Discriminant_Reference,
9764 -- Populate inner struct aggregate
9766 -- Struct_Counter should be reset before
9767 -- handling a variant part. Indeed only one
9768 -- of the case statement alternatives will be
9769 -- executed at run-time, so the counter must
9770 -- start at 0 for every case statement.
9772 Struct_Counter := 0;
9774 TA_Append_Record_Traversal (
9776 Clist => Component_List (Variant),
9777 Container => Struct_Any,
9778 Counter => Struct_Counter);
9780 -- Append inner struct to union aggregate
9782 Append_To (VP_Stmts,
9783 Make_Procedure_Call_Statement (Loc,
9786 RTE (RE_Add_Aggregate_Element), Loc),
9787 Parameter_Associations => New_List (
9788 New_Occurrence_Of (Union_Any, Loc),
9789 New_Occurrence_Of (Struct_Any, Loc))));
9791 -- Append union to outer aggregate
9793 Append_To (VP_Stmts,
9794 Make_Procedure_Call_Statement (Loc,
9797 RTE (RE_Add_Aggregate_Element), Loc),
9798 Parameter_Associations => New_List (
9799 New_Occurrence_Of (Container, Loc),
9801 (Union_Any, Loc))));
9803 Append_To (Alt_List,
9804 Make_Case_Statement_Alternative (Loc,
9805 Discrete_Choices => Choice_List,
9806 Statements => VP_Stmts));
9808 Next_Non_Pragma (Variant);
9812 Counter := Counter + 1;
9813 end TA_Rec_Add_Process_Element;
9816 -- Records are encoded in a TC_STRUCT aggregate:
9817 -- -- Outer aggregate (TC_STRUCT)
9818 -- | [discriminant1]
9819 -- | [discriminant2]
9826 -- A component can be a common component or a variant
9829 -- A variant part is encoded as a TC_UNION aggregate:
9830 -- -- Variant Part Aggregate (TC_UNION)
9831 -- | [discriminant choice for this Variant Part]
9833 -- | -- Inner struct (TC_STRUCT)
9838 -- Let's start by building the outer aggregate
9839 -- First we construct an Elements array containing all
9840 -- the discriminants.
9842 if Has_Discriminants (Typ) then
9843 Disc := First_Discriminant (Typ);
9845 while Present (Disc) loop
9848 Discriminant : constant Entity_Id :=
9849 Make_Selected_Component (Loc,
9850 Prefix => Expr_Parameter,
9851 Selector_Name => Chars (Disc));
9853 Set_Etype (Discriminant, Etype (Disc));
9855 Append_To (Elements,
9856 Make_Component_Association (Loc,
9857 Choices => New_List (
9858 Make_Integer_Literal (Loc, Counter)),
9860 Build_To_Any_Call (Discriminant, Decls)));
9862 Counter := Counter + 1;
9863 Next_Discriminant (Disc);
9867 -- If there are no discriminants, we declare an empty
9871 Dummy_Any : constant Entity_Id :=
9872 Make_Defining_Identifier (Loc,
9873 Chars => New_Internal_Name ('A'));
9877 Make_Object_Declaration (Loc,
9878 Defining_Identifier => Dummy_Any,
9879 Object_Definition =>
9880 New_Occurrence_Of (RTE (RE_Any), Loc)));
9882 Append_To (Elements,
9883 Make_Component_Association (Loc,
9884 Choices => New_List (
9887 Make_Integer_Literal (Loc, 1),
9889 Make_Integer_Literal (Loc, 0))),
9891 New_Occurrence_Of (Dummy_Any, Loc)));
9895 -- We build the result aggregate with discriminants
9896 -- as the first elements.
9898 Set_Expression (Any_Decl,
9899 Make_Function_Call (Loc,
9900 Name => New_Occurrence_Of (
9901 RTE (RE_Any_Aggregate_Build), Loc),
9902 Parameter_Associations => New_List (
9904 Make_Aggregate (Loc,
9905 Component_Associations => Elements))));
9908 -- Then we append all the components to the result
9911 TA_Append_Record_Traversal (Stms,
9912 Clist => Component_List (Rdef),
9914 Counter => Counter);
9918 elsif Is_Array_Type (Typ) then
9920 Constrained : constant Boolean := Is_Constrained (Typ);
9922 procedure TA_Ary_Add_Process_Element
9925 Counter : Entity_Id;
9928 --------------------------------
9929 -- TA_Ary_Add_Process_Element --
9930 --------------------------------
9932 procedure TA_Ary_Add_Process_Element
9935 Counter : Entity_Id;
9938 pragma Warnings (Off);
9939 pragma Unreferenced (Counter);
9940 pragma Warnings (On);
9942 Element_Any : Node_Id;
9945 if Etype (Datum) = RTE (RE_Any) then
9946 Element_Any := Datum;
9948 Element_Any := Build_To_Any_Call (Datum, Decls);
9952 Make_Procedure_Call_Statement (Loc,
9953 Name => New_Occurrence_Of (
9954 RTE (RE_Add_Aggregate_Element), Loc),
9955 Parameter_Associations => New_List (
9956 New_Occurrence_Of (Any, Loc),
9958 end TA_Ary_Add_Process_Element;
9960 procedure Append_To_Any_Array_Iterator is
9961 new Append_Array_Traversal (
9963 Arry => Expr_Parameter,
9964 Indices => New_List,
9965 Add_Process_Element => TA_Ary_Add_Process_Element);
9970 Set_Expression (Any_Decl,
9971 Make_Function_Call (Loc,
9973 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9974 Parameter_Associations => New_List (Result_TC)));
9977 if not Constrained then
9978 Index := First_Index (Typ);
9979 for J in 1 .. Number_Dimensions (Typ) loop
9981 Make_Procedure_Call_Statement (Loc,
9984 RTE (RE_Add_Aggregate_Element), Loc),
9985 Parameter_Associations => New_List (
9986 New_Occurrence_Of (Any, Loc),
9988 OK_Convert_To (Etype (Index),
9989 Make_Attribute_Reference (Loc,
9991 New_Occurrence_Of (Expr_Parameter, Loc),
9992 Attribute_Name => Name_First,
9993 Expressions => New_List (
9994 Make_Integer_Literal (Loc, J)))),
10000 Append_To_Any_Array_Iterator (Stms, Any);
10003 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10004 Set_Expression (Any_Decl,
10005 Build_To_Any_Call (
10007 Find_Numeric_Representation (Typ),
10008 New_Occurrence_Of (Expr_Parameter, Loc)),
10012 -- Default: type is represented as an opaque sequence of bytes
10015 Strm : constant Entity_Id := Make_Defining_Identifier (Loc,
10016 New_Internal_Name ('S'));
10019 -- Strm : aliased Buffer_Stream_Type;
10022 Make_Object_Declaration (Loc,
10023 Defining_Identifier =>
10027 Object_Definition =>
10028 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
10030 -- Allocate_Buffer (Strm);
10033 Make_Procedure_Call_Statement (Loc,
10035 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
10036 Parameter_Associations => New_List (
10037 New_Occurrence_Of (Strm, Loc))));
10039 -- T'Output (Strm'Access, E);
10042 Make_Attribute_Reference (Loc,
10043 Prefix => New_Occurrence_Of (Typ, Loc),
10044 Attribute_Name => Name_Output,
10045 Expressions => New_List (
10046 Make_Attribute_Reference (Loc,
10047 Prefix => New_Occurrence_Of (Strm, Loc),
10048 Attribute_Name => Name_Access),
10049 New_Occurrence_Of (Expr_Parameter, Loc))));
10051 -- BS_To_Any (Strm, A);
10054 Make_Procedure_Call_Statement (Loc,
10056 New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
10057 Parameter_Associations => New_List (
10058 New_Occurrence_Of (Strm, Loc),
10059 New_Occurrence_Of (Any, Loc))));
10061 -- Release_Buffer (Strm);
10064 Make_Procedure_Call_Statement (Loc,
10066 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
10067 Parameter_Associations => New_List (
10068 New_Occurrence_Of (Strm, Loc))));
10072 Append_To (Decls, Any_Decl);
10074 if Present (Result_TC) then
10076 Make_Procedure_Call_Statement (Loc,
10077 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
10078 Parameter_Associations => New_List (
10079 New_Occurrence_Of (Any, Loc),
10084 Make_Return_Statement (Loc,
10085 Expression => New_Occurrence_Of (Any, Loc)));
10088 Make_Subprogram_Body (Loc,
10089 Specification => Spec,
10090 Declarations => Decls,
10091 Handled_Statement_Sequence =>
10092 Make_Handled_Sequence_Of_Statements (Loc,
10093 Statements => Stms));
10094 end Build_To_Any_Function;
10096 -------------------------
10097 -- Build_TypeCode_Call --
10098 -------------------------
10100 function Build_TypeCode_Call
10103 Decls : List_Id) return Node_Id
10105 U_Type : Entity_Id := Underlying_Type (Typ);
10106 -- The full view, if Typ is private; the completion,
10107 -- if Typ is incomplete.
10109 Fnam : Entity_Id := Empty;
10110 Lib_RE : RE_Id := RE_Null;
10115 -- Special case System.PolyORB.Interface.Any: its primitives have
10116 -- not been set yet, so can't call Find_Inherited_TSS.
10118 if Typ = RTE (RE_Any) then
10119 Fnam := RTE (RE_TC_Any);
10122 -- First simple case where the TypeCode is present
10123 -- in the type's TSS.
10125 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10129 if Sloc (U_Type) <= Standard_Location then
10131 -- Do not try to build alias typecodes for subtypes from
10134 U_Type := Base_Type (U_Type);
10137 if U_Type = Standard_Boolean then
10140 elsif U_Type = Standard_Character then
10143 elsif U_Type = Standard_Wide_Character then
10144 Lib_RE := RE_TC_WC;
10146 elsif U_Type = Standard_Wide_Wide_Character then
10147 Lib_RE := RE_TC_WWC;
10149 -- Floating point types
10151 elsif U_Type = Standard_Short_Float then
10152 Lib_RE := RE_TC_SF;
10154 elsif U_Type = Standard_Float then
10157 elsif U_Type = Standard_Long_Float then
10158 Lib_RE := RE_TC_LF;
10160 elsif U_Type = Standard_Long_Long_Float then
10161 Lib_RE := RE_TC_LLF;
10163 -- Integer types (walk back to the base type)
10165 elsif U_Type = Etype (Standard_Short_Short_Integer) then
10166 Lib_RE := RE_TC_SSI;
10168 elsif U_Type = Etype (Standard_Short_Integer) then
10169 Lib_RE := RE_TC_SI;
10171 elsif U_Type = Etype (Standard_Integer) then
10174 elsif U_Type = Etype (Standard_Long_Integer) then
10175 Lib_RE := RE_TC_LI;
10177 elsif U_Type = Etype (Standard_Long_Long_Integer) then
10178 Lib_RE := RE_TC_LLI;
10180 -- Unsigned integer types
10182 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
10183 Lib_RE := RE_TC_SSU;
10185 elsif U_Type = RTE (RE_Short_Unsigned) then
10186 Lib_RE := RE_TC_SU;
10188 elsif U_Type = RTE (RE_Unsigned) then
10191 elsif U_Type = RTE (RE_Long_Unsigned) then
10192 Lib_RE := RE_TC_LU;
10194 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
10195 Lib_RE := RE_TC_LLU;
10197 elsif U_Type = Standard_String then
10198 Lib_RE := RE_TC_String;
10200 -- Other (non-primitive) types
10206 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10207 Append_To (Decls, Decl);
10211 if Lib_RE /= RE_Null then
10212 Fnam := RTE (Lib_RE);
10216 -- Call the function
10219 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10221 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10223 Set_Etype (Expr, RTE (RE_TypeCode));
10226 end Build_TypeCode_Call;
10228 -----------------------------
10229 -- Build_TypeCode_Function --
10230 -----------------------------
10232 procedure Build_TypeCode_Function
10235 Decl : out Node_Id;
10236 Fnam : out Entity_Id)
10239 Decls : constant List_Id := New_List;
10240 Stms : constant List_Id := New_List;
10242 TCNam : constant Entity_Id :=
10243 Make_Stream_Procedure_Function_Name (Loc,
10244 Typ, Name_uTypeCode);
10246 Parameters : List_Id;
10248 procedure Add_String_Parameter
10250 Parameter_List : List_Id);
10251 -- Add a literal for S to Parameters
10253 procedure Add_TypeCode_Parameter
10254 (TC_Node : Node_Id;
10255 Parameter_List : List_Id);
10256 -- Add the typecode for Typ to Parameters
10258 procedure Add_Long_Parameter
10259 (Expr_Node : Node_Id;
10260 Parameter_List : List_Id);
10261 -- Add a signed long integer expression to Parameters
10263 procedure Initialize_Parameter_List
10264 (Name_String : String_Id;
10265 Repo_Id_String : String_Id;
10266 Parameter_List : out List_Id);
10267 -- Return a list that contains the first two parameters
10268 -- for a parameterized typecode: name and repository id.
10270 function Make_Constructed_TypeCode
10272 Parameters : List_Id) return Node_Id;
10273 -- Call TC_Build with the given kind and parameters
10275 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10276 -- Make a return statement that calls TC_Build with the given
10277 -- typecode kind, and the constructed parameters list.
10279 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10280 -- Return a typecode that is a TC_Alias for the given typecode
10282 --------------------------
10283 -- Add_String_Parameter --
10284 --------------------------
10286 procedure Add_String_Parameter
10288 Parameter_List : List_Id)
10291 Append_To (Parameter_List,
10292 Make_Function_Call (Loc,
10294 New_Occurrence_Of (RTE (RE_TA_String), Loc),
10295 Parameter_Associations => New_List (
10296 Make_String_Literal (Loc, S))));
10297 end Add_String_Parameter;
10299 ----------------------------
10300 -- Add_TypeCode_Parameter --
10301 ----------------------------
10303 procedure Add_TypeCode_Parameter
10304 (TC_Node : Node_Id;
10305 Parameter_List : List_Id)
10308 Append_To (Parameter_List,
10309 Make_Function_Call (Loc,
10311 New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10312 Parameter_Associations => New_List (
10314 end Add_TypeCode_Parameter;
10316 ------------------------
10317 -- Add_Long_Parameter --
10318 ------------------------
10320 procedure Add_Long_Parameter
10321 (Expr_Node : Node_Id;
10322 Parameter_List : List_Id)
10325 Append_To (Parameter_List,
10326 Make_Function_Call (Loc,
10328 New_Occurrence_Of (RTE (RE_TA_LI), Loc),
10329 Parameter_Associations => New_List (Expr_Node)));
10330 end Add_Long_Parameter;
10332 -------------------------------
10333 -- Initialize_Parameter_List --
10334 -------------------------------
10336 procedure Initialize_Parameter_List
10337 (Name_String : String_Id;
10338 Repo_Id_String : String_Id;
10339 Parameter_List : out List_Id)
10342 Parameter_List := New_List;
10343 Add_String_Parameter (Name_String, Parameter_List);
10344 Add_String_Parameter (Repo_Id_String, Parameter_List);
10345 end Initialize_Parameter_List;
10347 ---------------------------
10348 -- Return_Alias_TypeCode --
10349 ---------------------------
10351 procedure Return_Alias_TypeCode
10352 (Base_TypeCode : Node_Id)
10355 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10356 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
10357 end Return_Alias_TypeCode;
10359 -------------------------------
10360 -- Make_Constructed_TypeCode --
10361 -------------------------------
10363 function Make_Constructed_TypeCode
10365 Parameters : List_Id) return Node_Id
10367 Constructed_TC : constant Node_Id :=
10368 Make_Function_Call (Loc,
10370 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
10371 Parameter_Associations => New_List (
10372 New_Occurrence_Of (Kind, Loc),
10373 Make_Aggregate (Loc,
10374 Expressions => Parameters)));
10376 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10377 return Constructed_TC;
10378 end Make_Constructed_TypeCode;
10380 ---------------------------------
10381 -- Return_Constructed_TypeCode --
10382 ---------------------------------
10384 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10387 Make_Return_Statement (Loc,
10389 Make_Constructed_TypeCode (Kind, Parameters)));
10390 end Return_Constructed_TypeCode;
10396 procedure TC_Rec_Add_Process_Element
10399 Counter : in out Int;
10403 procedure TC_Append_Record_Traversal is
10404 new Append_Record_Traversal (
10406 Add_Process_Element => TC_Rec_Add_Process_Element);
10408 --------------------------------
10409 -- TC_Rec_Add_Process_Element --
10410 --------------------------------
10412 procedure TC_Rec_Add_Process_Element
10415 Counter : in out Int;
10419 pragma Warnings (Off);
10420 pragma Unreferenced (Any, Counter, Rec);
10421 pragma Warnings (On);
10424 if Nkind (Field) = N_Defining_Identifier then
10426 -- A regular component
10428 Add_TypeCode_Parameter (
10429 Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10430 Get_Name_String (Chars (Field));
10431 Add_String_Parameter (String_From_Name_Buffer, Params);
10438 Discriminant_Type : constant Entity_Id :=
10439 Etype (Name (Field));
10441 Is_Enum : constant Boolean :=
10442 Is_Enumeration_Type (Discriminant_Type);
10444 Union_TC_Params : List_Id;
10446 U_Name : constant Name_Id :=
10447 New_External_Name (Chars (Typ), 'V', -1);
10449 Name_Str : String_Id;
10450 Struct_TC_Params : List_Id;
10454 Default : constant Node_Id :=
10455 Make_Integer_Literal (Loc, -1);
10457 Dummy_Counter : Int := 0;
10459 Choice_Index : Int := 0;
10461 procedure Add_Params_For_Variant_Components;
10462 -- Add a struct TypeCode and a corresponding member name
10463 -- to the union parameter list.
10465 -- Ordering of declarations is a complete mess in this
10466 -- area, it is supposed to be types/varibles, then
10467 -- subprogram specs, then subprogram bodies ???
10469 ---------------------------------------
10470 -- Add_Params_For_Variant_Components --
10471 ---------------------------------------
10473 procedure Add_Params_For_Variant_Components
10475 S_Name : constant Name_Id :=
10476 New_External_Name (U_Name, 'S', -1);
10479 Get_Name_String (S_Name);
10480 Name_Str := String_From_Name_Buffer;
10481 Initialize_Parameter_List
10482 (Name_Str, Name_Str, Struct_TC_Params);
10484 -- Build struct parameters
10486 TC_Append_Record_Traversal (Struct_TC_Params,
10487 Component_List (Variant),
10491 Add_TypeCode_Parameter
10492 (Make_Constructed_TypeCode
10493 (RTE (RE_TC_Struct), Struct_TC_Params),
10496 Add_String_Parameter (Name_Str, Union_TC_Params);
10497 end Add_Params_For_Variant_Components;
10500 Get_Name_String (U_Name);
10501 Name_Str := String_From_Name_Buffer;
10503 Initialize_Parameter_List
10504 (Name_Str, Name_Str, Union_TC_Params);
10506 -- Add union in enclosing parameter list
10508 Add_TypeCode_Parameter
10509 (Make_Constructed_TypeCode
10510 (RTE (RE_TC_Union), Union_TC_Params),
10513 Add_String_Parameter (Name_Str, Params);
10515 -- Build union parameters
10517 Add_TypeCode_Parameter
10518 (Build_TypeCode_Call
10519 (Loc, Discriminant_Type, Decls),
10522 Add_Long_Parameter (Default, Union_TC_Params);
10524 Variant := First_Non_Pragma (Variants (Field));
10525 while Present (Variant) loop
10526 Choice := First (Discrete_Choices (Variant));
10527 while Present (Choice) loop
10528 case Nkind (Choice) is
10531 L : constant Uint :=
10532 Expr_Value (Low_Bound (Choice));
10533 H : constant Uint :=
10534 Expr_Value (High_Bound (Choice));
10536 -- 3.8.1(8) guarantees that the bounds of
10537 -- this range are static.
10544 Expr := New_Occurrence_Of (
10545 Get_Enum_Lit_From_Pos (
10546 Discriminant_Type, J, Loc), Loc);
10549 Make_Integer_Literal (Loc, J);
10551 Append_To (Union_TC_Params,
10552 Make_Function_Call (Loc,
10553 Name => New_Occurrence_Of
10554 (RTE (RE_TA_A), Loc),
10555 Parameter_Associations =>
10560 Add_Params_For_Variant_Components;
10565 when N_Others_Choice =>
10567 -- This variant possess a default choice.
10568 -- We must therefore set the default
10569 -- parameter to the current choice index. The
10570 -- default parameter is by construction the
10571 -- fourth in the Union_TC_Params list.
10574 Default_Node : constant Node_Id :=
10575 Pick (Union_TC_Params, 4);
10577 New_Default_Node : constant Node_Id :=
10578 Make_Function_Call (Loc,
10581 (RTE (RE_TA_LI), Loc),
10582 Parameter_Associations =>
10584 Make_Integer_Literal
10585 (Loc, Choice_Index)));
10591 Remove (Default_Node);
10594 -- Add a placeholder member label
10595 -- for the default case.
10596 -- It must be of the discriminant
10600 Exp : constant Node_Id :=
10601 Make_Attribute_Reference (Loc,
10602 Prefix => New_Occurrence_Of
10603 (Discriminant_Type, Loc),
10604 Attribute_Name => Name_First);
10606 Set_Etype (Exp, Discriminant_Type);
10607 Append_To (Union_TC_Params,
10608 Make_Function_Call (Loc,
10609 Name => New_Occurrence_Of
10610 (RTE (RE_TA_A), Loc),
10611 Parameter_Associations =>
10617 Add_Params_For_Variant_Components;
10621 Exp : constant Node_Id :=
10622 New_Copy_Tree (Choice);
10624 Append_To (Union_TC_Params,
10625 Make_Function_Call (Loc,
10626 Name => New_Occurrence_Of
10627 (RTE (RE_TA_A), Loc),
10628 Parameter_Associations =>
10634 Add_Params_For_Variant_Components;
10637 Choice_Index := Choice_Index + 1;
10641 Next_Non_Pragma (Variant);
10646 end TC_Rec_Add_Process_Element;
10648 Type_Name_Str : String_Id;
10649 Type_Repo_Id_Str : String_Id;
10652 if Is_Itype (Typ) then
10653 Build_TypeCode_Function
10655 Typ => Etype (Typ),
10664 Make_Function_Specification (Loc,
10665 Defining_Unit_Name => Fnam,
10666 Parameter_Specifications => Empty_List,
10667 Result_Definition =>
10668 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10670 Build_Name_And_Repository_Id (Typ,
10671 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10672 Initialize_Parameter_List
10673 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10675 if Is_Derived_Type (Typ)
10676 and then not Is_Tagged_Type (Typ)
10678 Return_Alias_TypeCode (
10679 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10681 elsif Is_Integer_Type (Typ)
10682 or else Is_Unsigned_Type (Typ)
10684 Return_Alias_TypeCode (
10685 Build_TypeCode_Call (Loc,
10686 Find_Numeric_Representation (Typ), Decls));
10688 elsif Is_Record_Type (Typ)
10689 and then not Is_Tagged_Type (Typ)
10692 -- Record typecodes are encoded as follows:
10696 -- | [Repository Id]
10698 -- Then for each discriminant:
10700 -- | [Discriminant Type Code]
10701 -- | [Discriminant Name]
10704 -- Then for each component:
10706 -- | [Component Type Code]
10707 -- | [Component Name]
10710 -- Variants components type codes are encoded as follows:
10714 -- | [Repository Id]
10715 -- | [Discriminant Type Code]
10716 -- | [Index of Default Variant Part or -1 for no default]
10718 -- Then for each Variant Part :
10723 -- | | [Variant Part Name]
10724 -- | | [Variant Part Repository Id]
10726 -- | Then for each VP component:
10727 -- | | [VP component Typecode]
10728 -- | | [VP component Name]
10734 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10735 Return_Alias_TypeCode (
10736 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10739 Disc : Entity_Id := Empty;
10740 Rdef : constant Node_Id :=
10741 Type_Definition (Declaration_Node (Typ));
10742 Dummy_Counter : Int := 0;
10744 -- Construct the discriminants typecodes
10746 if Has_Discriminants (Typ) then
10747 Disc := First_Discriminant (Typ);
10749 while Present (Disc) loop
10750 Add_TypeCode_Parameter (
10751 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10753 Get_Name_String (Chars (Disc));
10754 Add_String_Parameter (
10755 String_From_Name_Buffer,
10757 Next_Discriminant (Disc);
10760 -- then the components typecodes
10762 TC_Append_Record_Traversal
10763 (Parameters, Component_List (Rdef),
10764 Empty, Dummy_Counter);
10765 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10769 elsif Is_Array_Type (Typ) then
10771 Ndim : constant Pos := Number_Dimensions (Typ);
10772 Inner_TypeCode : Node_Id;
10773 Constrained : constant Boolean := Is_Constrained (Typ);
10774 Indx : Node_Id := First_Index (Typ);
10777 Inner_TypeCode := Build_TypeCode_Call (Loc,
10778 Component_Type (Typ),
10781 for J in 1 .. Ndim loop
10782 if Constrained then
10783 Inner_TypeCode := Make_Constructed_TypeCode
10784 (RTE (RE_TC_Array), New_List (
10785 Build_To_Any_Call (
10786 OK_Convert_To (RTE (RE_Long_Unsigned),
10787 Make_Attribute_Reference (Loc,
10789 New_Occurrence_Of (Typ, Loc),
10792 Expressions => New_List (
10793 Make_Integer_Literal (Loc,
10796 Build_To_Any_Call (Inner_TypeCode, Decls)));
10799 -- Unconstrained case: add low bound for each
10802 Add_TypeCode_Parameter
10803 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10805 Get_Name_String (New_External_Name ('L', J));
10806 Add_String_Parameter (
10807 String_From_Name_Buffer,
10811 Inner_TypeCode := Make_Constructed_TypeCode
10812 (RTE (RE_TC_Sequence), New_List (
10813 Build_To_Any_Call (
10814 OK_Convert_To (RTE (RE_Long_Unsigned),
10815 Make_Integer_Literal (Loc, 0)),
10817 Build_To_Any_Call (Inner_TypeCode, Decls)));
10821 if Constrained then
10822 Return_Alias_TypeCode (Inner_TypeCode);
10824 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10826 Store_String_Char ('V');
10827 Add_String_Parameter (End_String, Parameters);
10828 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10833 -- Default: type is represented as an opaque sequence of bytes
10835 Return_Alias_TypeCode
10836 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10840 Make_Subprogram_Body (Loc,
10841 Specification => Spec,
10842 Declarations => Decls,
10843 Handled_Statement_Sequence =>
10844 Make_Handled_Sequence_Of_Statements (Loc,
10845 Statements => Stms));
10846 end Build_TypeCode_Function;
10848 ---------------------------------
10849 -- Find_Numeric_Representation --
10850 ---------------------------------
10852 function Find_Numeric_Representation
10853 (Typ : Entity_Id) return Entity_Id
10855 FST : constant Entity_Id := First_Subtype (Typ);
10856 P_Size : constant Uint := Esize (FST);
10859 if Is_Unsigned_Type (Typ) then
10860 if P_Size <= Standard_Short_Short_Integer_Size then
10861 return RTE (RE_Short_Short_Unsigned);
10863 elsif P_Size <= Standard_Short_Integer_Size then
10864 return RTE (RE_Short_Unsigned);
10866 elsif P_Size <= Standard_Integer_Size then
10867 return RTE (RE_Unsigned);
10869 elsif P_Size <= Standard_Long_Integer_Size then
10870 return RTE (RE_Long_Unsigned);
10873 return RTE (RE_Long_Long_Unsigned);
10876 elsif Is_Integer_Type (Typ) then
10877 if P_Size <= Standard_Short_Short_Integer_Size then
10878 return Standard_Short_Short_Integer;
10880 elsif P_Size <= Standard_Short_Integer_Size then
10881 return Standard_Short_Integer;
10883 elsif P_Size <= Standard_Integer_Size then
10884 return Standard_Integer;
10886 elsif P_Size <= Standard_Long_Integer_Size then
10887 return Standard_Long_Integer;
10890 return Standard_Long_Long_Integer;
10893 elsif Is_Floating_Point_Type (Typ) then
10894 if P_Size <= Standard_Short_Float_Size then
10895 return Standard_Short_Float;
10897 elsif P_Size <= Standard_Float_Size then
10898 return Standard_Float;
10900 elsif P_Size <= Standard_Long_Float_Size then
10901 return Standard_Long_Float;
10904 return Standard_Long_Long_Float;
10908 raise Program_Error;
10911 -- TBD: fixed point types???
10912 -- TBverified numeric types with a biased representation???
10914 end Find_Numeric_Representation;
10916 ---------------------------
10917 -- Append_Array_Traversal --
10918 ---------------------------
10920 procedure Append_Array_Traversal
10923 Counter : Entity_Id := Empty;
10926 Loc : constant Source_Ptr := Sloc (Subprogram);
10927 Typ : constant Entity_Id := Etype (Arry);
10928 Constrained : constant Boolean := Is_Constrained (Typ);
10929 Ndim : constant Pos := Number_Dimensions (Typ);
10931 Inner_Any, Inner_Counter : Entity_Id;
10933 Loop_Stm : Node_Id;
10934 Inner_Stmts : constant List_Id := New_List;
10937 if Depth > Ndim then
10939 -- Processing for one element of an array
10942 Element_Expr : constant Node_Id :=
10943 Make_Indexed_Component (Loc,
10944 New_Occurrence_Of (Arry, Loc),
10948 Set_Etype (Element_Expr, Component_Type (Typ));
10949 Add_Process_Element (Stmts,
10951 Counter => Counter,
10952 Datum => Element_Expr);
10958 Append_To (Indices,
10959 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10961 if not Constrained or else Depth > 1 then
10962 Inner_Any := Make_Defining_Identifier (Loc,
10963 New_External_Name ('A', Depth));
10964 Set_Etype (Inner_Any, RTE (RE_Any));
10966 Inner_Any := Empty;
10969 if Present (Counter) then
10970 Inner_Counter := Make_Defining_Identifier (Loc,
10971 New_External_Name ('J', Depth));
10973 Inner_Counter := Empty;
10977 Loop_Any : Node_Id := Inner_Any;
10980 -- For the first dimension of a constrained array, we add
10981 -- elements directly in the corresponding Any; there is no
10982 -- intervening inner Any.
10984 if No (Loop_Any) then
10988 Append_Array_Traversal (Inner_Stmts,
10990 Counter => Inner_Counter,
10991 Depth => Depth + 1);
10995 Make_Implicit_Loop_Statement (Subprogram,
10996 Iteration_Scheme =>
10997 Make_Iteration_Scheme (Loc,
10998 Loop_Parameter_Specification =>
10999 Make_Loop_Parameter_Specification (Loc,
11000 Defining_Identifier =>
11001 Make_Defining_Identifier (Loc,
11002 Chars => New_External_Name ('L', Depth)),
11004 Discrete_Subtype_Definition =>
11005 Make_Attribute_Reference (Loc,
11006 Prefix => New_Occurrence_Of (Arry, Loc),
11007 Attribute_Name => Name_Range,
11009 Expressions => New_List (
11010 Make_Integer_Literal (Loc, Depth))))),
11011 Statements => Inner_Stmts);
11014 Decls : constant List_Id := New_List;
11015 Dimen_Stmts : constant List_Id := New_List;
11016 Length_Node : Node_Id;
11018 Inner_Any_TypeCode : constant Entity_Id :=
11019 Make_Defining_Identifier (Loc,
11020 New_External_Name ('T', Depth));
11022 Inner_Any_TypeCode_Expr : Node_Id;
11026 if Constrained then
11027 Inner_Any_TypeCode_Expr :=
11028 Make_Function_Call (Loc,
11030 New_Occurrence_Of (RTE (RE_Get_TC), Loc),
11031 Parameter_Associations => New_List (
11032 New_Occurrence_Of (Any, Loc)));
11034 Inner_Any_TypeCode_Expr :=
11035 Make_Function_Call (Loc,
11037 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
11038 Parameter_Associations => New_List (
11039 New_Occurrence_Of (Any, Loc),
11040 Make_Integer_Literal (Loc, Ndim)));
11043 Inner_Any_TypeCode_Expr :=
11044 Make_Function_Call (Loc,
11046 New_Occurrence_Of (RTE (RE_Content_Type), Loc),
11047 Parameter_Associations => New_List (
11048 Make_Identifier (Loc,
11049 New_External_Name ('T', Depth - 1))));
11053 Make_Object_Declaration (Loc,
11054 Defining_Identifier => Inner_Any_TypeCode,
11055 Constant_Present => True,
11056 Object_Definition => New_Occurrence_Of (
11057 RTE (RE_TypeCode), Loc),
11058 Expression => Inner_Any_TypeCode_Expr));
11060 if Present (Inner_Any) then
11062 Make_Object_Declaration (Loc,
11063 Defining_Identifier => Inner_Any,
11064 Object_Definition =>
11065 New_Occurrence_Of (RTE (RE_Any), Loc),
11067 Make_Function_Call (Loc,
11069 New_Occurrence_Of (
11070 RTE (RE_Create_Any), Loc),
11071 Parameter_Associations => New_List (
11072 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
11075 if Present (Inner_Counter) then
11077 Make_Object_Declaration (Loc,
11078 Defining_Identifier => Inner_Counter,
11079 Object_Definition =>
11080 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
11082 Make_Integer_Literal (Loc, 0)));
11085 if not Constrained then
11086 Length_Node := Make_Attribute_Reference (Loc,
11087 Prefix => New_Occurrence_Of (Arry, Loc),
11088 Attribute_Name => Name_Length,
11090 New_List (Make_Integer_Literal (Loc, Depth)));
11091 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
11093 Add_Process_Element (Dimen_Stmts,
11094 Datum => Length_Node,
11096 Counter => Inner_Counter);
11099 -- Loop_Stm does appropriate processing for each element
11102 Append_To (Dimen_Stmts, Loop_Stm);
11104 -- Link outer and inner any
11106 if Present (Inner_Any) then
11107 Add_Process_Element (Dimen_Stmts,
11109 Counter => Counter,
11110 Datum => New_Occurrence_Of (Inner_Any, Loc));
11114 Make_Block_Statement (Loc,
11117 Handled_Statement_Sequence =>
11118 Make_Handled_Sequence_Of_Statements (Loc,
11119 Statements => Dimen_Stmts)));
11121 end Append_Array_Traversal;
11123 -----------------------------------------
11124 -- Make_Stream_Procedure_Function_Name --
11125 -----------------------------------------
11127 function Make_Stream_Procedure_Function_Name
11130 Nam : Name_Id) return Entity_Id
11133 -- For tagged types, we use a canonical name so that it matches
11134 -- the primitive spec. For all other cases, we use a serialized
11135 -- name so that multiple generations of the same procedure do not
11138 if Is_Tagged_Type (Typ) then
11139 return Make_Defining_Identifier (Loc, Nam);
11141 return Make_Defining_Identifier (Loc,
11143 New_External_Name (Nam, ' ', Increment_Serial_Number));
11145 end Make_Stream_Procedure_Function_Name;
11148 -----------------------------------
11149 -- Reserve_NamingContext_Methods --
11150 -----------------------------------
11152 procedure Reserve_NamingContext_Methods is
11153 Str_Resolve : constant String := "resolve";
11155 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11156 Name_Len := Str_Resolve'Length;
11157 Overload_Counter_Table.Set (Name_Find, 1);
11158 end Reserve_NamingContext_Methods;
11160 end PolyORB_Support;
11162 -------------------------------
11163 -- RACW_Type_Is_Asynchronous --
11164 -------------------------------
11166 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11167 Asynchronous_Flag : constant Entity_Id :=
11168 Asynchronous_Flags_Table.Get (RACW_Type);
11170 Replace (Expression (Parent (Asynchronous_Flag)),
11171 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11172 end RACW_Type_Is_Asynchronous;
11174 -------------------------
11175 -- RCI_Package_Locator --
11176 -------------------------
11178 function RCI_Package_Locator
11180 Package_Spec : Node_Id) return Node_Id
11183 Pkg_Name : String_Id;
11186 Get_Library_Unit_Name_String (Package_Spec);
11187 Pkg_Name := String_From_Name_Buffer;
11189 Make_Package_Instantiation (Loc,
11190 Defining_Unit_Name =>
11191 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
11193 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11194 Generic_Associations => New_List (
11195 Make_Generic_Association (Loc,
11197 Make_Identifier (Loc, Name_RCI_Name),
11198 Explicit_Generic_Actual_Parameter =>
11199 Make_String_Literal (Loc,
11200 Strval => Pkg_Name)),
11201 Make_Generic_Association (Loc,
11203 Make_Identifier (Loc, Name_Version),
11204 Explicit_Generic_Actual_Parameter =>
11205 Make_Attribute_Reference (Loc,
11207 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11211 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
11212 Defining_Unit_Name (Inst));
11214 end RCI_Package_Locator;
11216 -----------------------------------------------
11217 -- Remote_Types_Tagged_Full_View_Encountered --
11218 -----------------------------------------------
11220 procedure Remote_Types_Tagged_Full_View_Encountered
11221 (Full_View : Entity_Id)
11223 Stub_Elements : constant Stub_Structure :=
11224 Stubs_Table.Get (Full_View);
11226 if Stub_Elements /= Empty_Stub_Structure then
11227 Add_RACW_Primitive_Declarations_And_Bodies
11229 Stub_Elements.RPC_Receiver_Decl,
11230 Stub_Elements.Body_Decls);
11232 end Remote_Types_Tagged_Full_View_Encountered;
11234 -------------------
11235 -- Scope_Of_Spec --
11236 -------------------
11238 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11239 Unit_Name : Node_Id;
11242 Unit_Name := Defining_Unit_Name (Spec);
11243 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11244 Unit_Name := Defining_Identifier (Unit_Name);
11250 ----------------------
11251 -- Set_Renaming_TSS --
11252 ----------------------
11254 procedure Set_Renaming_TSS
11257 TSS_Nam : TSS_Name_Type)
11259 Loc : constant Source_Ptr := Sloc (Nam);
11260 Spec : constant Node_Id := Parent (Nam);
11262 TSS_Node : constant Node_Id :=
11263 Make_Subprogram_Renaming_Declaration (Loc,
11265 Copy_Specification (Loc,
11267 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11268 Name => New_Occurrence_Of (Nam, Loc));
11270 Snam : constant Entity_Id :=
11271 Defining_Unit_Name (Specification (TSS_Node));
11274 if Nkind (Spec) = N_Function_Specification then
11275 Set_Ekind (Snam, E_Function);
11276 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11278 Set_Ekind (Snam, E_Procedure);
11279 Set_Etype (Snam, Standard_Void_Type);
11282 Set_TSS (Typ, Snam);
11283 end Set_Renaming_TSS;
11285 ----------------------------------------------
11286 -- Specific_Add_Obj_RPC_Receiver_Completion --
11287 ----------------------------------------------
11289 procedure Specific_Add_Obj_RPC_Receiver_Completion
11292 RPC_Receiver : Entity_Id;
11293 Stub_Elements : Stub_Structure) is
11295 case Get_PCS_Name is
11296 when Name_PolyORB_DSA =>
11297 PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11298 Decls, RPC_Receiver, Stub_Elements);
11300 GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
11301 Decls, RPC_Receiver, Stub_Elements);
11303 end Specific_Add_Obj_RPC_Receiver_Completion;
11305 --------------------------------
11306 -- Specific_Add_RACW_Features --
11307 --------------------------------
11309 procedure Specific_Add_RACW_Features
11310 (RACW_Type : Entity_Id;
11312 Stub_Type : Entity_Id;
11313 Stub_Type_Access : Entity_Id;
11314 RPC_Receiver_Decl : Node_Id;
11315 Body_Decls : List_Id) is
11317 case Get_PCS_Name is
11318 when Name_PolyORB_DSA =>
11319 PolyORB_Support.Add_RACW_Features (
11328 GARLIC_Support.Add_RACW_Features (
11335 end Specific_Add_RACW_Features;
11337 --------------------------------
11338 -- Specific_Add_RAST_Features --
11339 --------------------------------
11341 procedure Specific_Add_RAST_Features
11342 (Vis_Decl : Node_Id;
11343 RAS_Type : Entity_Id) is
11345 case Get_PCS_Name is
11346 when Name_PolyORB_DSA =>
11347 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11349 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11351 end Specific_Add_RAST_Features;
11353 --------------------------------------------------
11354 -- Specific_Add_Receiving_Stubs_To_Declarations --
11355 --------------------------------------------------
11357 procedure Specific_Add_Receiving_Stubs_To_Declarations
11358 (Pkg_Spec : Node_Id;
11363 case Get_PCS_Name is
11364 when Name_PolyORB_DSA =>
11365 PolyORB_Support.Add_Receiving_Stubs_To_Declarations (
11366 Pkg_Spec, Decls, Stmts);
11368 GARLIC_Support.Add_Receiving_Stubs_To_Declarations (
11369 Pkg_Spec, Decls, Stmts);
11371 end Specific_Add_Receiving_Stubs_To_Declarations;
11373 ------------------------------------------
11374 -- Specific_Build_General_Calling_Stubs --
11375 ------------------------------------------
11377 procedure Specific_Build_General_Calling_Stubs
11379 Statements : List_Id;
11380 Target : RPC_Target;
11381 Subprogram_Id : Node_Id;
11382 Asynchronous : Node_Id := Empty;
11383 Is_Known_Asynchronous : Boolean := False;
11384 Is_Known_Non_Asynchronous : Boolean := False;
11385 Is_Function : Boolean;
11387 Stub_Type : Entity_Id := Empty;
11388 RACW_Type : Entity_Id := Empty;
11392 case Get_PCS_Name is
11393 when Name_PolyORB_DSA =>
11394 PolyORB_Support.Build_General_Calling_Stubs (
11400 Is_Known_Asynchronous,
11401 Is_Known_Non_Asynchronous,
11408 GARLIC_Support.Build_General_Calling_Stubs (
11412 Target.RPC_Receiver,
11415 Is_Known_Asynchronous,
11416 Is_Known_Non_Asynchronous,
11423 end Specific_Build_General_Calling_Stubs;
11425 --------------------------------------
11426 -- Specific_Build_RPC_Receiver_Body --
11427 --------------------------------------
11429 procedure Specific_Build_RPC_Receiver_Body
11430 (RPC_Receiver : Entity_Id;
11431 Request : out Entity_Id;
11432 Subp_Id : out Entity_Id;
11433 Subp_Index : out Entity_Id;
11434 Stmts : out List_Id;
11435 Decl : out Node_Id)
11438 case Get_PCS_Name is
11439 when Name_PolyORB_DSA =>
11440 PolyORB_Support.Build_RPC_Receiver_Body
11448 GARLIC_Support.Build_RPC_Receiver_Body
11456 end Specific_Build_RPC_Receiver_Body;
11458 --------------------------------
11459 -- Specific_Build_Stub_Target --
11460 --------------------------------
11462 function Specific_Build_Stub_Target
11465 RCI_Locator : Entity_Id;
11466 Controlling_Parameter : Entity_Id) return RPC_Target
11469 case Get_PCS_Name is
11470 when Name_PolyORB_DSA =>
11471 return PolyORB_Support.Build_Stub_Target (Loc,
11472 Decls, RCI_Locator, Controlling_Parameter);
11474 return GARLIC_Support.Build_Stub_Target (Loc,
11475 Decls, RCI_Locator, Controlling_Parameter);
11477 end Specific_Build_Stub_Target;
11479 ------------------------------
11480 -- Specific_Build_Stub_Type --
11481 ------------------------------
11483 procedure Specific_Build_Stub_Type
11484 (RACW_Type : Entity_Id;
11485 Stub_Type : Entity_Id;
11486 Stub_Type_Decl : out Node_Id;
11487 RPC_Receiver_Decl : out Node_Id)
11490 case Get_PCS_Name is
11491 when Name_PolyORB_DSA =>
11492 PolyORB_Support.Build_Stub_Type (
11493 RACW_Type, Stub_Type,
11494 Stub_Type_Decl, RPC_Receiver_Decl);
11496 GARLIC_Support.Build_Stub_Type (
11497 RACW_Type, Stub_Type,
11498 Stub_Type_Decl, RPC_Receiver_Decl);
11500 end Specific_Build_Stub_Type;
11502 function Specific_Build_Subprogram_Receiving_Stubs
11503 (Vis_Decl : Node_Id;
11504 Asynchronous : Boolean;
11505 Dynamically_Asynchronous : Boolean := False;
11506 Stub_Type : Entity_Id := Empty;
11507 RACW_Type : Entity_Id := Empty;
11508 Parent_Primitive : Entity_Id := Empty) return Node_Id
11511 case Get_PCS_Name is
11512 when Name_PolyORB_DSA =>
11513 return PolyORB_Support.Build_Subprogram_Receiving_Stubs (
11516 Dynamically_Asynchronous,
11521 return GARLIC_Support.Build_Subprogram_Receiving_Stubs (
11524 Dynamically_Asynchronous,
11529 end Specific_Build_Subprogram_Receiving_Stubs;
11531 --------------------------
11532 -- Underlying_RACW_Type --
11533 --------------------------
11535 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11536 Record_Type : Entity_Id;
11539 if Ekind (RAS_Typ) = E_Record_Type then
11540 Record_Type := RAS_Typ;
11542 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11543 Record_Type := Equivalent_Type (RAS_Typ);
11547 Etype (Subtype_Indication (
11548 Component_Definition (
11549 First (Component_Items (Component_List (
11550 Type_Definition (Declaration_Node (Record_Type))))))));
11551 end Underlying_RACW_Type;