* gimplify.c (find_single_pointer_decl_1): New static function.
[official-gcc.git] / gcc / ada / exp_dist.adb
blobd0e016d68982949450f611bd9708f36eeafbeee9
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P_ D I S T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
10 -- --
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. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Exp_Strm; use Exp_Strm;
31 with Exp_Tss; use Exp_Tss;
32 with Exp_Util; use Exp_Util;
33 with GNAT.HTable; use GNAT.HTable;
34 with Lib; use Lib;
35 with Namet; use Namet;
36 with Nlists; use Nlists;
37 with Nmake; use Nmake;
38 with Opt; use Opt;
39 with Rtsfind; use Rtsfind;
40 with Sem; use Sem;
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 package body Exp_Dist is
56 -- The following model has been used to implement distributed objects:
57 -- given a designated type D and a RACW type R, then a record of the
58 -- form:
60 -- type Stub is tagged record
61 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
62 -- end record;
64 -- is built. This type has two properties:
66 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
67 -- converted to and from this type to make it suitable for
68 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
69 -- to avoid memory leaks when the same remote object arrive on the
70 -- same partition through several paths;
72 -- 2) It also has the same dispatching table as the designated type D,
73 -- and thus can be used as an object designated by a value of type
74 -- R on any partition other than the one on which the object has
75 -- been created, since only dispatching calls will be performed and
76 -- the fields themselves will not be used. We call Derive_Subprograms
77 -- to fake half a derivation to ensure that the subprograms do have
78 -- the same dispatching table.
80 First_RCI_Subprogram_Id : constant := 2;
81 -- RCI subprograms are numbered starting at 2. The RCI receiver for
82 -- an RCI package can thus identify calls received through remote
83 -- access-to-subprogram dereferences by the fact that they have a
84 -- (primitive) subprogram id of 0, and 1 is used for the internal
85 -- RAS information lookup operation. (This is for the Garlic code
86 -- generation, where subprograms are identified by numbers; in the
87 -- PolyORB version, they are identified by name, with a numeric suffix
88 -- for homonyms.)
90 type Hash_Index is range 0 .. 50;
92 -----------------------
93 -- Local subprograms --
94 -----------------------
96 function Hash (F : Entity_Id) return Hash_Index;
97 -- DSA expansion associates stubs to distributed object types using
98 -- a hash table on entity ids.
100 function Hash (F : Name_Id) return Hash_Index;
101 -- The generation of subprogram identifiers requires an overload counter
102 -- to be associated with each remote subprogram names. These counters
103 -- are maintained in a hash table on name ids.
105 type Subprogram_Identifiers is record
106 Str_Identifier : String_Id;
107 Int_Identifier : Int;
108 end record;
110 package Subprogram_Identifier_Table is
111 new Simple_HTable (Header_Num => Hash_Index,
112 Element => Subprogram_Identifiers,
113 No_Element => (No_String, 0),
114 Key => Entity_Id,
115 Hash => Hash,
116 Equal => "=");
117 -- Mapping between a remote subprogram and the corresponding
118 -- subprogram identifiers.
120 package Overload_Counter_Table is
121 new Simple_HTable (Header_Num => Hash_Index,
122 Element => Int,
123 No_Element => 0,
124 Key => Name_Id,
125 Hash => Hash,
126 Equal => "=");
127 -- Mapping between a subprogram name and an integer that
128 -- counts the number of defining subprogram names with that
129 -- Name_Id encountered so far in a given context (an interface).
131 function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
132 function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
133 function Get_Subprogram_Id (Def : Entity_Id) return Int;
134 -- Given a subprogram defined in a RCI package, get its distribution
135 -- subprogram identifiers (the distribution identifiers are a unique
136 -- subprogram number, and the non-qualified subprogram name, in the
137 -- casing used for the subprogram declaration; if the name is overloaded,
138 -- a double underscore and a serial number are appended.
140 -- The integer identifier is used to perform remote calls with GARLIC;
141 -- the string identifier is used in the case of PolyORB.
143 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
144 -- when receiving a call, the calling stubs will create requests with the
145 -- exact casing of the defining unit name of the called subprogram, so as
146 -- to allow calls to subprograms on distributed nodes that do distinguish
147 -- between casings.
149 -- NOTE: Another design would be to allow a representation clause on
150 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
152 pragma Warnings (Off, Get_Subprogram_Id);
153 -- One homonym only is unreferenced (specific to the GARLIC version)
155 procedure Add_RAS_Dereference_TSS (N : Node_Id);
156 -- Add a subprogram body for RAS Dereference TSS
158 procedure Add_RAS_Proxy_And_Analyze
159 (Decls : List_Id;
160 Vis_Decl : Node_Id;
161 All_Calls_Remote_E : Entity_Id;
162 Proxy_Object_Addr : out Entity_Id);
163 -- Add the proxy type necessary to call the subprogram declared
164 -- by Vis_Decl through a remote access to subprogram type.
165 -- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote
166 -- applies, Standard_False otherwise. The new proxy type is appended
167 -- to Decls. Proxy_Object_Addr is a constant of type System.Address that
168 -- designates an instance of the proxy object.
170 function Build_Remote_Subprogram_Proxy_Type
171 (Loc : Source_Ptr;
172 ACR_Expression : Node_Id) return Node_Id;
173 -- Build and return a tagged record type definition for an RCI
174 -- subprogram proxy type.
175 -- ACR_Expression is use as the initialization value for
176 -- the All_Calls_Remote component.
178 function Build_Get_Unique_RP_Call
179 (Loc : Source_Ptr;
180 Pointer : Entity_Id;
181 Stub_Type : Entity_Id) return List_Id;
182 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
183 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
184 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
186 function Build_Subprogram_Calling_Stubs
187 (Vis_Decl : Node_Id;
188 Subp_Id : Node_Id;
189 Asynchronous : Boolean;
190 Dynamically_Asynchronous : Boolean := False;
191 Stub_Type : Entity_Id := Empty;
192 RACW_Type : Entity_Id := Empty;
193 Locator : Entity_Id := Empty;
194 New_Name : Name_Id := No_Name) return Node_Id;
195 -- Build the calling stub for a given subprogram with the subprogram ID
196 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
197 -- parameters of this type will be marshalled instead of the object
198 -- itself. It will then be converted into Stub_Type before performing
199 -- the real call. If Dynamically_Asynchronous is True, then it will be
200 -- computed at run time whether the call is asynchronous or not.
201 -- Otherwise, the value of the formal Asynchronous will be used.
202 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
203 -- New_Name is given, then it will be used instead of the original name.
205 function Build_RPC_Receiver_Specification
206 (RPC_Receiver : Entity_Id;
207 Request_Parameter : Entity_Id) return Node_Id;
208 -- Make a subprogram specification for an RPC receiver, with the given
209 -- defining unit name and formal parameter.
211 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
212 -- Return an ordered parameter list: unconstrained parameters are put
213 -- at the beginning of the list and constrained ones are put after. If
214 -- there are no parameters, an empty list is returned. Special case:
215 -- the controlling formal of the equivalent RACW operation for a RAS
216 -- type is always left in first position.
218 procedure Add_Calling_Stubs_To_Declarations
219 (Pkg_Spec : Node_Id;
220 Decls : List_Id);
221 -- Add calling stubs to the declarative part
223 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
224 -- Return True if nothing prevents the program whose specification is
225 -- given to be asynchronous (i.e. no out parameter).
227 function Pack_Entity_Into_Stream_Access
228 (Loc : Source_Ptr;
229 Stream : Node_Id;
230 Object : Entity_Id;
231 Etyp : Entity_Id := Empty) return Node_Id;
232 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
233 -- then Etype (Object) will be used if present. If the type is
234 -- constrained, then 'Write will be used to output the object,
235 -- If the type is unconstrained, 'Output will be used.
237 function Pack_Node_Into_Stream
238 (Loc : Source_Ptr;
239 Stream : Entity_Id;
240 Object : Node_Id;
241 Etyp : Entity_Id) return Node_Id;
242 -- Similar to above, with an arbitrary node instead of an entity
244 function Pack_Node_Into_Stream_Access
245 (Loc : Source_Ptr;
246 Stream : Node_Id;
247 Object : Node_Id;
248 Etyp : Entity_Id) return Node_Id;
249 -- Similar to above, with Stream instead of Stream'Access
251 function Make_Selected_Component
252 (Loc : Source_Ptr;
253 Prefix : Entity_Id;
254 Selector_Name : Name_Id) return Node_Id;
255 -- Return a selected_component whose prefix denotes the given entity,
256 -- and with the given Selector_Name.
258 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
259 -- Return the scope represented by a given spec
261 procedure Set_Renaming_TSS
262 (Typ : Entity_Id;
263 Nam : Entity_Id;
264 TSS_Nam : TSS_Name_Type);
265 -- Create a renaming declaration of subprogram Nam,
266 -- and register it as a TSS for Typ with name TSS_Nam.
268 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
269 -- Return True if the current parameter needs an extra formal to reflect
270 -- its constrained status.
272 function Is_RACW_Controlling_Formal
273 (Parameter : Node_Id; Stub_Type : Entity_Id) return Boolean;
274 -- Return True if the current parameter is a controlling formal argument
275 -- of type Stub_Type or access to Stub_Type.
277 procedure Declare_Create_NVList
278 (Loc : Source_Ptr;
279 NVList : Entity_Id;
280 Decls : List_Id;
281 Stmts : List_Id);
282 -- Append the declaration of NVList to Decls, and its
283 -- initialization to Stmts.
285 function Add_Parameter_To_NVList
286 (Loc : Source_Ptr;
287 NVList : Entity_Id;
288 Parameter : Entity_Id;
289 Constrained : Boolean;
290 RACW_Ctrl : Boolean := False;
291 Any : Entity_Id) return Node_Id;
292 -- Return a call to Add_Item to add the Any corresponding
293 -- to the designated formal Parameter (with the indicated
294 -- Constrained status) to NVList. RACW_Ctrl must be set to
295 -- True for controlling formals of distributed object primitive
296 -- operations.
298 type Stub_Structure is record
299 Stub_Type : Entity_Id;
300 Stub_Type_Access : Entity_Id;
301 RPC_Receiver_Decl : Node_Id;
302 RACW_Type : Entity_Id;
303 end record;
304 -- This structure is necessary because of the two phases analysis of
305 -- a RACW declaration occurring in the same Remote_Types package as the
306 -- designated type. RACW_Type is any of the RACW types pointing on this
307 -- designated type, it is used here to save an anonymous type creation
308 -- for each primitive operation.
310 -- For a RACW that implements a RAS, no object RPC receiver is generated.
311 -- Instead, RPC_Receiver_Decl is the declaration after which the
312 -- RPC receiver would have been inserted.
314 Empty_Stub_Structure : constant Stub_Structure :=
315 (Empty, Empty, Empty, Empty);
317 package Stubs_Table is
318 new Simple_HTable (Header_Num => Hash_Index,
319 Element => Stub_Structure,
320 No_Element => Empty_Stub_Structure,
321 Key => Entity_Id,
322 Hash => Hash,
323 Equal => "=");
324 -- Mapping between a RACW designated type and its stub type
326 package Asynchronous_Flags_Table is
327 new Simple_HTable (Header_Num => Hash_Index,
328 Element => Entity_Id,
329 No_Element => Empty,
330 Key => Entity_Id,
331 Hash => Hash,
332 Equal => "=");
333 -- Mapping between a RACW type and a constant having the value True
334 -- if the RACW is asynchronous and False otherwise.
336 package RCI_Locator_Table is
337 new Simple_HTable (Header_Num => Hash_Index,
338 Element => Entity_Id,
339 No_Element => Empty,
340 Key => Entity_Id,
341 Hash => Hash,
342 Equal => "=");
343 -- Mapping between a RCI package on which All_Calls_Remote applies and
344 -- the generic instantiation of RCI_Locator for this package.
346 package RCI_Calling_Stubs_Table is
347 new Simple_HTable (Header_Num => Hash_Index,
348 Element => Entity_Id,
349 No_Element => Empty,
350 Key => Entity_Id,
351 Hash => Hash,
352 Equal => "=");
353 -- Mapping between a RCI subprogram and the corresponding calling stubs
355 procedure Add_Stub_Type
356 (Designated_Type : Entity_Id;
357 RACW_Type : Entity_Id;
358 Decls : List_Id;
359 Stub_Type : out Entity_Id;
360 Stub_Type_Access : out Entity_Id;
361 RPC_Receiver_Decl : out Node_Id;
362 Existing : out Boolean);
363 -- Add the declaration of the stub type, the access to stub type and the
364 -- object RPC receiver at the end of Decls. If these already exist,
365 -- then nothing is added in the tree but the right values are returned
366 -- anyhow and Existing is set to True.
368 procedure Add_RACW_Asynchronous_Flag
369 (Declarations : List_Id;
370 RACW_Type : Entity_Id);
371 -- Declare a boolean constant associated with RACW_Type whose value
372 -- indicates at run time whether a pragma Asynchronous applies to it.
374 procedure Assign_Subprogram_Identifier
375 (Def : Entity_Id;
376 Spn : Int;
377 Id : out String_Id);
378 -- Determine the distribution subprogram identifier to
379 -- be used for remote subprogram Def, return it in Id and
380 -- store it in a hash table for later retrieval by
381 -- Get_Subprogram_Id. Spn is the subprogram number.
383 function RCI_Package_Locator
384 (Loc : Source_Ptr;
385 Package_Spec : Node_Id) return Node_Id;
386 -- Instantiate the generic package RCI_Locator in order to locate the
387 -- RCI package whose spec is given as argument.
389 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
390 -- Surround a node N by a tag check, as in:
391 -- begin
392 -- <N>;
393 -- exception
394 -- when E : Ada.Tags.Tag_Error =>
395 -- Raise_Exception (Program_Error'Identity,
396 -- Exception_Message (E));
397 -- end;
399 function Input_With_Tag_Check
400 (Loc : Source_Ptr;
401 Var_Type : Entity_Id;
402 Stream : Node_Id) return Node_Id;
403 -- Return a function with the following form:
404 -- function R return Var_Type is
405 -- begin
406 -- return Var_Type'Input (S);
407 -- exception
408 -- when E : Ada.Tags.Tag_Error =>
409 -- Raise_Exception (Program_Error'Identity,
410 -- Exception_Message (E));
411 -- end R;
413 --------------------------------------------
414 -- Hooks for PCS-specific code generation --
415 --------------------------------------------
417 -- Part of the code generation circuitry for distribution needs to be
418 -- tailored for each implementation of the PCS. For each routine that
419 -- needs to be specialized, a Specific_<routine> wrapper is created,
420 -- which calls the corresponding <routine> in package
421 -- <pcs_implementation>_Support.
423 procedure Specific_Add_RACW_Features
424 (RACW_Type : Entity_Id;
425 Desig : Entity_Id;
426 Stub_Type : Entity_Id;
427 Stub_Type_Access : Entity_Id;
428 RPC_Receiver_Decl : Node_Id;
429 Declarations : List_Id);
430 -- Add declaration for TSSs for a given RACW type. The declarations are
431 -- added just after the declaration of the RACW type itself, while the
432 -- bodies are inserted at the end of Decls. Runtime-specific ancillary
433 -- subprogram for Add_RACW_Features.
435 procedure Specific_Add_RAST_Features
436 (Vis_Decl : Node_Id;
437 RAS_Type : Entity_Id);
438 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
439 -- subprogram for Add_RAST_Features.
441 -- An RPC_Target record is used during construction of calling stubs
442 -- to pass PCS-specific tree fragments corresponding to the information
443 -- necessary to locate the target of a remote subprogram call.
445 type RPC_Target (PCS_Kind : PCS_Names) is record
446 case PCS_Kind is
447 when Name_PolyORB_DSA =>
448 Object : Node_Id;
449 -- An expression whose value is a PolyORB reference to the target
450 -- object.
451 when others =>
452 Partition : Entity_Id;
453 -- A variable containing the Partition_ID of the target parition
455 RPC_Receiver : Node_Id;
456 -- An expression whose value is the address of the target RPC
457 -- receiver.
458 end case;
459 end record;
461 procedure Specific_Build_General_Calling_Stubs
462 (Decls : List_Id;
463 Statements : List_Id;
464 Target : RPC_Target;
465 Subprogram_Id : Node_Id;
466 Asynchronous : Node_Id := Empty;
467 Is_Known_Asynchronous : Boolean := False;
468 Is_Known_Non_Asynchronous : Boolean := False;
469 Is_Function : Boolean;
470 Spec : Node_Id;
471 Stub_Type : Entity_Id := Empty;
472 RACW_Type : Entity_Id := Empty;
473 Nod : Node_Id);
474 -- Build calling stubs for general purpose. The parameters are:
475 -- Decls : a place to put declarations
476 -- Statements : a place to put statements
477 -- Target : PCS-specific target information (see details
478 -- in RPC_Target declaration).
479 -- Subprogram_Id : a node containing the subprogram ID
480 -- Asynchronous : True if an APC must be made instead of an RPC.
481 -- The value needs not be supplied if one of the
482 -- Is_Known_... is True.
483 -- Is_Known_Async... : True if we know that this is asynchronous
484 -- Is_Known_Non_A... : True if we know that this is not asynchronous
485 -- Spec : a node with a Parameter_Specifications and
486 -- a Result_Definition if applicable
487 -- Stub_Type : in case of RACW stubs, parameters of type access
488 -- to Stub_Type will be marshalled using the
489 -- address of the object (the addr field) rather
490 -- than using the 'Write on the stub itself
491 -- Nod : used to provide sloc for generated code
493 function Specific_Build_Stub_Target
494 (Loc : Source_Ptr;
495 Decls : List_Id;
496 RCI_Locator : Entity_Id;
497 Controlling_Parameter : Entity_Id) return RPC_Target;
498 -- Build call target information nodes for use within calling stubs. In the
499 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
500 -- for an RACW, Controlling_Parameter is the entity for the controlling
501 -- formal parameter used to determine the location of the target of the
502 -- call. Decls provides a location where variable declarations can be
503 -- appended to construct the necessary values.
505 procedure Specific_Build_Stub_Type
506 (RACW_Type : Entity_Id;
507 Stub_Type : Entity_Id;
508 Stub_Type_Decl : out Node_Id;
509 RPC_Receiver_Decl : out Node_Id);
510 -- Build a type declaration for the stub type associated with an RACW
511 -- type, and the necessary RPC receiver, if applicable. PCS-specific
512 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
513 -- is generated, then RPC_Receiver_Decl is set to Empty.
515 procedure Specific_Build_RPC_Receiver_Body
516 (RPC_Receiver : Entity_Id;
517 Request : out Entity_Id;
518 Subp_Id : out Entity_Id;
519 Subp_Index : out Entity_Id;
520 Stmts : out List_Id;
521 Decl : out Node_Id);
522 -- Make a subprogram body for an RPC receiver, with the given
523 -- defining unit name. On return:
524 -- - Subp_Id is the subprogram identifier from the PCS.
525 -- - Subp_Index is the index in the list of subprograms
526 -- used for dispatching (a variable of type Subprogram_Id).
527 -- - Stmts is the place where the request dispatching
528 -- statements can occur,
529 -- - Decl is the subprogram body declaration.
531 function Specific_Build_Subprogram_Receiving_Stubs
532 (Vis_Decl : Node_Id;
533 Asynchronous : Boolean;
534 Dynamically_Asynchronous : Boolean := False;
535 Stub_Type : Entity_Id := Empty;
536 RACW_Type : Entity_Id := Empty;
537 Parent_Primitive : Entity_Id := Empty) return Node_Id;
538 -- Build the receiving stub for a given subprogram. The subprogram
539 -- declaration is also built by this procedure, and the value returned
540 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
541 -- found in the specification, then its address is read from the stream
542 -- instead of the object itself and converted into an access to
543 -- class-wide type before doing the real call using any of the RACW type
544 -- pointing on the designated type.
546 procedure Specific_Add_Obj_RPC_Receiver_Completion
547 (Loc : Source_Ptr;
548 Decls : List_Id;
549 RPC_Receiver : Entity_Id;
550 Stub_Elements : Stub_Structure);
551 -- Add the necessary code to Decls after the completion of generation
552 -- of the RACW RPC receiver described by Stub_Elements.
554 procedure Specific_Add_Receiving_Stubs_To_Declarations
555 (Pkg_Spec : Node_Id;
556 Decls : List_Id);
557 -- Add receiving stubs to the declarative part of an RCI unit
559 package GARLIC_Support is
561 -- Support for generating DSA code that uses the GARLIC PCS
563 -- The subprograms below provide the GARLIC versions of
564 -- the corresponding Specific_<subprogram> routine declared
565 -- above.
567 procedure Add_RACW_Features
568 (RACW_Type : Entity_Id;
569 Stub_Type : Entity_Id;
570 Stub_Type_Access : Entity_Id;
571 RPC_Receiver_Decl : Node_Id;
572 Declarations : List_Id);
574 procedure Add_RAST_Features
575 (Vis_Decl : Node_Id;
576 RAS_Type : Entity_Id);
578 procedure Build_General_Calling_Stubs
579 (Decls : List_Id;
580 Statements : List_Id;
581 Target_Partition : Entity_Id; -- From RPC_Target
582 Target_RPC_Receiver : Node_Id; -- From RPC_Target
583 Subprogram_Id : Node_Id;
584 Asynchronous : Node_Id := Empty;
585 Is_Known_Asynchronous : Boolean := False;
586 Is_Known_Non_Asynchronous : Boolean := False;
587 Is_Function : Boolean;
588 Spec : Node_Id;
589 Stub_Type : Entity_Id := Empty;
590 RACW_Type : Entity_Id := Empty;
591 Nod : Node_Id);
593 function Build_Stub_Target
594 (Loc : Source_Ptr;
595 Decls : List_Id;
596 RCI_Locator : Entity_Id;
597 Controlling_Parameter : Entity_Id) return RPC_Target;
599 procedure Build_Stub_Type
600 (RACW_Type : Entity_Id;
601 Stub_Type : Entity_Id;
602 Stub_Type_Decl : out Node_Id;
603 RPC_Receiver_Decl : out Node_Id);
605 function Build_Subprogram_Receiving_Stubs
606 (Vis_Decl : Node_Id;
607 Asynchronous : Boolean;
608 Dynamically_Asynchronous : Boolean := False;
609 Stub_Type : Entity_Id := Empty;
610 RACW_Type : Entity_Id := Empty;
611 Parent_Primitive : Entity_Id := Empty) return Node_Id;
613 procedure Add_Obj_RPC_Receiver_Completion
614 (Loc : Source_Ptr;
615 Decls : List_Id;
616 RPC_Receiver : Entity_Id;
617 Stub_Elements : Stub_Structure);
619 procedure Add_Receiving_Stubs_To_Declarations
620 (Pkg_Spec : Node_Id;
621 Decls : List_Id);
623 procedure Build_RPC_Receiver_Body
624 (RPC_Receiver : Entity_Id;
625 Request : out Entity_Id;
626 Subp_Id : out Entity_Id;
627 Subp_Index : out Entity_Id;
628 Stmts : out List_Id;
629 Decl : out Node_Id);
631 end GARLIC_Support;
633 package PolyORB_Support is
635 -- Support for generating DSA code that uses the PolyORB PCS
637 -- The subprograms below provide the PolyORB versions of
638 -- the corresponding Specific_<subprogram> routine declared
639 -- above.
641 procedure Add_RACW_Features
642 (RACW_Type : Entity_Id;
643 Desig : Entity_Id;
644 Stub_Type : Entity_Id;
645 Stub_Type_Access : Entity_Id;
646 RPC_Receiver_Decl : Node_Id;
647 Declarations : List_Id);
649 procedure Add_RAST_Features
650 (Vis_Decl : Node_Id;
651 RAS_Type : Entity_Id);
653 procedure Build_General_Calling_Stubs
654 (Decls : List_Id;
655 Statements : List_Id;
656 Target_Object : Node_Id; -- From RPC_Target
657 Subprogram_Id : Node_Id;
658 Asynchronous : Node_Id := Empty;
659 Is_Known_Asynchronous : Boolean := False;
660 Is_Known_Non_Asynchronous : Boolean := False;
661 Is_Function : Boolean;
662 Spec : Node_Id;
663 Stub_Type : Entity_Id := Empty;
664 RACW_Type : Entity_Id := Empty;
665 Nod : Node_Id);
667 function Build_Stub_Target
668 (Loc : Source_Ptr;
669 Decls : List_Id;
670 RCI_Locator : Entity_Id;
671 Controlling_Parameter : Entity_Id) return RPC_Target;
673 procedure Build_Stub_Type
674 (RACW_Type : Entity_Id;
675 Stub_Type : Entity_Id;
676 Stub_Type_Decl : out Node_Id;
677 RPC_Receiver_Decl : out Node_Id);
679 function Build_Subprogram_Receiving_Stubs
680 (Vis_Decl : Node_Id;
681 Asynchronous : Boolean;
682 Dynamically_Asynchronous : Boolean := False;
683 Stub_Type : Entity_Id := Empty;
684 RACW_Type : Entity_Id := Empty;
685 Parent_Primitive : Entity_Id := Empty) return Node_Id;
687 procedure Add_Obj_RPC_Receiver_Completion
688 (Loc : Source_Ptr;
689 Decls : List_Id;
690 RPC_Receiver : Entity_Id;
691 Stub_Elements : Stub_Structure);
693 procedure Add_Receiving_Stubs_To_Declarations
694 (Pkg_Spec : Node_Id;
695 Decls : List_Id);
697 procedure Build_RPC_Receiver_Body
698 (RPC_Receiver : Entity_Id;
699 Request : out Entity_Id;
700 Subp_Id : out Entity_Id;
701 Subp_Index : out Entity_Id;
702 Stmts : out List_Id;
703 Decl : out Node_Id);
705 procedure Reserve_NamingContext_Methods;
706 -- Mark the method names for interface NamingContext as already used in
707 -- the overload table, so no clashes occur with user code (with the
708 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
709 -- their methods to be accessed as objects, for the implementation of
710 -- remote access-to-subprogram types).
712 package Helpers is
714 -- Routines to build distribtion helper subprograms for user-defined
715 -- types. For implementation of the Distributed systems annex (DSA)
716 -- over the PolyORB generic middleware components, it is necessary to
717 -- generate several supporting subprograms for each application data
718 -- type used in inter-partition communication. These subprograms are:
719 -- * a Typecode function returning a high-level description of the
720 -- type's structure;
721 -- * two conversion functions allowing conversion of values of the
722 -- type from and to the generic data containers used by PolyORB.
723 -- These generic containers are called 'Any' type values after
724 -- the CORBA terminology, and hence the conversion subprograms
725 -- are named To_Any and From_Any.
727 function Build_From_Any_Call
728 (Typ : Entity_Id;
729 N : Node_Id;
730 Decls : List_Id) return Node_Id;
731 -- Build call to From_Any attribute function of type Typ with
732 -- expression N as actual parameter. Decls is the declarations list
733 -- for an appropriate enclosing scope of the point where the call
734 -- will be inserted; if the From_Any attribute for Typ needs to be
735 -- generated at this point, its declaration is appended to Decls.
737 procedure Build_From_Any_Function
738 (Loc : Source_Ptr;
739 Typ : Entity_Id;
740 Decl : out Node_Id;
741 Fnam : out Entity_Id);
742 -- Build From_Any attribute function for Typ. Loc is the reference
743 -- location for generated nodes, Typ is the type for which the
744 -- conversion function is generated. On return, Decl and Fnam contain
745 -- the declaration and entity for the newly-created function.
747 function Build_To_Any_Call
748 (N : Node_Id;
749 Decls : List_Id) return Node_Id;
750 -- Build call to To_Any attribute function with expression as actual
751 -- parameter. Decls is the declarations list for an appropriate
752 -- enclosing scope of the point where the call will be inserted; if
753 -- the To_Any attribute for Typ needs to be generated at this point,
754 -- its declaration is appended to Decls.
756 procedure Build_To_Any_Function
757 (Loc : Source_Ptr;
758 Typ : Entity_Id;
759 Decl : out Node_Id;
760 Fnam : out Entity_Id);
761 -- Build To_Any attribute function for Typ. Loc is the reference
762 -- location for generated nodes, Typ is the type for which the
763 -- conversion function is generated. On return, Decl and Fnam contain
764 -- the declaration and entity for the newly-created function.
766 function Build_TypeCode_Call
767 (Loc : Source_Ptr;
768 Typ : Entity_Id;
769 Decls : List_Id) return Node_Id;
770 -- Build call to TypeCode attribute function for Typ. Decls is the
771 -- declarations list for an appropriate enclosing scope of the point
772 -- where the call will be inserted; if the To_Any attribute for Typ
773 -- needs to be generated at this point, its declaration is appended
774 -- to Decls.
776 procedure Build_TypeCode_Function
777 (Loc : Source_Ptr;
778 Typ : Entity_Id;
779 Decl : out Node_Id;
780 Fnam : out Entity_Id);
781 -- Build TypeCode attribute function for Typ. Loc is the reference
782 -- location for generated nodes, Typ is the type for which the
783 -- conversion function is generated. On return, Decl and Fnam contain
784 -- the declaration and entity for the newly-created function.
786 procedure Build_Name_And_Repository_Id
787 (E : Entity_Id;
788 Name_Str : out String_Id;
789 Repo_Id_Str : out String_Id);
790 -- In the PolyORB distribution model, each distributed object type
791 -- and each distributed operation has a globally unique identifier,
792 -- its Repository Id. This subprogram builds and returns two strings
793 -- for entity E (a distributed object type or operation): one
794 -- containing the name of E, the second containing its repository id.
796 end Helpers;
798 end PolyORB_Support;
800 ------------------------------------
801 -- Local variables and structures --
802 ------------------------------------
804 RCI_Cache : Node_Id;
805 -- Needs comments ???
807 Output_From_Constrained : constant array (Boolean) of Name_Id :=
808 (False => Name_Output,
809 True => Name_Write);
810 -- The attribute to choose depending on the fact that the parameter
811 -- is constrained or not. There is no such thing as Input_From_Constrained
812 -- since this require separate mechanisms ('Input is a function while
813 -- 'Read is a procedure).
815 ---------------------------------------
816 -- Add_Calling_Stubs_To_Declarations --
817 ---------------------------------------
819 procedure Add_Calling_Stubs_To_Declarations
820 (Pkg_Spec : Node_Id;
821 Decls : List_Id)
823 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
824 -- Subprogram id 0 is reserved for calls received from
825 -- remote access-to-subprogram dereferences.
827 Current_Declaration : Node_Id;
828 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
829 RCI_Instantiation : Node_Id;
830 Subp_Stubs : Node_Id;
831 Subp_Str : String_Id;
833 begin
834 -- The first thing added is an instantiation of the generic package
835 -- System.Partition_Interface.RCI_Locator with the name of this
836 -- remote package. This will act as an interface with the name server
837 -- to determine the Partition_ID and the RPC_Receiver for the
838 -- receiver of this package.
840 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
841 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
843 Append_To (Decls, RCI_Instantiation);
844 Analyze (RCI_Instantiation);
846 -- For each subprogram declaration visible in the spec, we do
847 -- build a body. We also increment a counter to assign a different
848 -- Subprogram_Id to each subprograms. The receiving stubs processing
849 -- do use the same mechanism and will thus assign the same Id and
850 -- do the correct dispatching.
852 Overload_Counter_Table.Reset;
853 PolyORB_Support.Reserve_NamingContext_Methods;
855 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
857 while Present (Current_Declaration) loop
858 if Nkind (Current_Declaration) = N_Subprogram_Declaration
859 and then Comes_From_Source (Current_Declaration)
860 then
861 Assign_Subprogram_Identifier (
862 Defining_Unit_Name (Specification (Current_Declaration)),
863 Current_Subprogram_Number,
864 Subp_Str);
866 Subp_Stubs :=
867 Build_Subprogram_Calling_Stubs (
868 Vis_Decl => Current_Declaration,
869 Subp_Id =>
870 Build_Subprogram_Id (Loc,
871 Defining_Unit_Name (Specification (Current_Declaration))),
872 Asynchronous =>
873 Nkind (Specification (Current_Declaration)) =
874 N_Procedure_Specification
875 and then
876 Is_Asynchronous (Defining_Unit_Name (Specification
877 (Current_Declaration))));
879 Append_To (Decls, Subp_Stubs);
880 Analyze (Subp_Stubs);
882 Current_Subprogram_Number := Current_Subprogram_Number + 1;
883 end if;
885 Next (Current_Declaration);
886 end loop;
887 end Add_Calling_Stubs_To_Declarations;
889 -----------------------------
890 -- Add_Parameter_To_NVList --
891 -----------------------------
893 function Add_Parameter_To_NVList
894 (Loc : Source_Ptr;
895 NVList : Entity_Id;
896 Parameter : Entity_Id;
897 Constrained : Boolean;
898 RACW_Ctrl : Boolean := False;
899 Any : Entity_Id) return Node_Id
901 Parameter_Name_String : String_Id;
902 Parameter_Mode : Node_Id;
904 function Parameter_Passing_Mode
905 (Loc : Source_Ptr;
906 Parameter : Entity_Id;
907 Constrained : Boolean) return Node_Id;
908 -- Return an expression that denotes the parameter passing
909 -- mode to be used for Parameter in distribution stubs,
910 -- where Constrained is Parameter's constrained status.
912 ----------------------------
913 -- Parameter_Passing_Mode --
914 ----------------------------
916 function Parameter_Passing_Mode
917 (Loc : Source_Ptr;
918 Parameter : Entity_Id;
919 Constrained : Boolean) return Node_Id
921 Lib_RE : RE_Id;
923 begin
924 if Out_Present (Parameter) then
925 if In_Present (Parameter)
926 or else not Constrained
927 then
928 -- Unconstrained formals must be translated
929 -- to 'in' or 'inout', not 'out', because
930 -- they need to be constrained by the actual.
932 Lib_RE := RE_Mode_Inout;
933 else
934 Lib_RE := RE_Mode_Out;
935 end if;
937 else
938 Lib_RE := RE_Mode_In;
939 end if;
941 return New_Occurrence_Of (RTE (Lib_RE), Loc);
942 end Parameter_Passing_Mode;
944 -- Start of processing for Add_Parameter_To_NVList
946 begin
947 if Nkind (Parameter) = N_Defining_Identifier then
948 Get_Name_String (Chars (Parameter));
949 else
950 Get_Name_String (Chars (Defining_Identifier
951 (Parameter)));
952 end if;
954 Parameter_Name_String := String_From_Name_Buffer;
956 if RACW_Ctrl then
957 Parameter_Mode := New_Occurrence_Of
958 (RTE (RE_Mode_In), Loc);
959 else
960 Parameter_Mode := Parameter_Passing_Mode (Loc,
961 Parameter, Constrained);
962 end if;
964 return
965 Make_Procedure_Call_Statement (Loc,
966 Name =>
967 New_Occurrence_Of
968 (RTE (RE_NVList_Add_Item), Loc),
969 Parameter_Associations => New_List (
970 New_Occurrence_Of (NVList, Loc),
971 Make_Function_Call (Loc,
972 Name =>
973 New_Occurrence_Of
974 (RTE (RE_To_PolyORB_String), Loc),
975 Parameter_Associations => New_List (
976 Make_String_Literal (Loc,
977 Strval => Parameter_Name_String))),
978 New_Occurrence_Of (Any, Loc),
979 Parameter_Mode));
980 end Add_Parameter_To_NVList;
982 --------------------------------
983 -- Add_RACW_Asynchronous_Flag --
984 --------------------------------
986 procedure Add_RACW_Asynchronous_Flag
987 (Declarations : List_Id;
988 RACW_Type : Entity_Id)
990 Loc : constant Source_Ptr := Sloc (RACW_Type);
992 Asynchronous_Flag : constant Entity_Id :=
993 Make_Defining_Identifier (Loc,
994 New_External_Name (Chars (RACW_Type), 'A'));
996 begin
997 -- Declare the asynchronous flag. This flag will be changed to True
998 -- whenever it is known that the RACW type is asynchronous.
1000 Append_To (Declarations,
1001 Make_Object_Declaration (Loc,
1002 Defining_Identifier => Asynchronous_Flag,
1003 Constant_Present => True,
1004 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1005 Expression => New_Occurrence_Of (Standard_False, Loc)));
1007 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1008 end Add_RACW_Asynchronous_Flag;
1010 -----------------------
1011 -- Add_RACW_Features --
1012 -----------------------
1014 procedure Add_RACW_Features (RACW_Type : Entity_Id)
1016 Desig : constant Entity_Id :=
1017 Etype (Designated_Type (RACW_Type));
1018 Decls : List_Id :=
1019 List_Containing (Declaration_Node (RACW_Type));
1021 Same_Scope : constant Boolean :=
1022 Scope (Desig) = Scope (RACW_Type);
1024 Stub_Type : Entity_Id;
1025 Stub_Type_Access : Entity_Id;
1026 RPC_Receiver_Decl : Node_Id;
1027 Existing : Boolean;
1029 begin
1030 if not Expander_Active then
1031 return;
1032 end if;
1034 if Same_Scope then
1036 -- We are declaring a RACW in the same package than its designated
1037 -- type, so the list to use for late declarations must be the
1038 -- private part of the package. We do know that this private part
1039 -- exists since the designated type has to be a private one.
1041 Decls := Private_Declarations
1042 (Package_Specification_Of_Scope (Current_Scope));
1044 elsif Nkind (Parent (Decls)) = N_Package_Specification
1045 and then Present (Private_Declarations (Parent (Decls)))
1046 then
1047 Decls := Private_Declarations (Parent (Decls));
1048 end if;
1050 -- If we were unable to find the declarations, that means that the
1051 -- completion of the type was missing. We can safely return and let
1052 -- the error be caught by the semantic analysis.
1054 if No (Decls) then
1055 return;
1056 end if;
1058 Add_Stub_Type
1059 (Designated_Type => Desig,
1060 RACW_Type => RACW_Type,
1061 Decls => Decls,
1062 Stub_Type => Stub_Type,
1063 Stub_Type_Access => Stub_Type_Access,
1064 RPC_Receiver_Decl => RPC_Receiver_Decl,
1065 Existing => Existing);
1067 Add_RACW_Asynchronous_Flag
1068 (Declarations => Decls,
1069 RACW_Type => RACW_Type);
1071 Specific_Add_RACW_Features
1072 (RACW_Type => RACW_Type,
1073 Desig => Desig,
1074 Stub_Type => Stub_Type,
1075 Stub_Type_Access => Stub_Type_Access,
1076 RPC_Receiver_Decl => RPC_Receiver_Decl,
1077 Declarations => Decls);
1079 if not Same_Scope and then not Existing then
1081 -- The RACW has been declared in another scope than the designated
1082 -- type and has not been handled by another RACW in the same package
1083 -- as the first one, so add primitive for the stub type here.
1085 Add_RACW_Primitive_Declarations_And_Bodies
1086 (Designated_Type => Desig,
1087 Insertion_Node => RPC_Receiver_Decl,
1088 Decls => Decls);
1090 else
1091 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1092 end if;
1093 end Add_RACW_Features;
1095 ------------------------------------------------
1096 -- Add_RACW_Primitive_Declarations_And_Bodies --
1097 ------------------------------------------------
1099 procedure Add_RACW_Primitive_Declarations_And_Bodies
1100 (Designated_Type : Entity_Id;
1101 Insertion_Node : Node_Id;
1102 Decls : List_Id)
1104 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1105 -- the declarations are recognized as belonging to the current package.
1107 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1109 Stub_Elements : constant Stub_Structure :=
1110 Stubs_Table.Get (Designated_Type);
1112 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1113 Is_RAS : constant Boolean :=
1114 not Comes_From_Source (Stub_Elements.RACW_Type);
1116 Current_Insertion_Node : Node_Id := Insertion_Node;
1118 RPC_Receiver : Entity_Id;
1119 RPC_Receiver_Statements : List_Id;
1120 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1121 RPC_Receiver_Elsif_Parts : List_Id;
1122 RPC_Receiver_Request : Entity_Id;
1123 RPC_Receiver_Subp_Id : Entity_Id;
1124 RPC_Receiver_Subp_Index : Entity_Id;
1126 Subp_Str : String_Id;
1128 Current_Primitive_Elmt : Elmt_Id;
1129 Current_Primitive : Entity_Id;
1130 Current_Primitive_Body : Node_Id;
1131 Current_Primitive_Spec : Node_Id;
1132 Current_Primitive_Decl : Node_Id;
1133 Current_Primitive_Number : Int := 0;
1135 Current_Primitive_Alias : Node_Id;
1137 Current_Receiver : Entity_Id;
1138 Current_Receiver_Body : Node_Id;
1140 RPC_Receiver_Decl : Node_Id;
1142 Possibly_Asynchronous : Boolean;
1144 begin
1145 if not Expander_Active then
1146 return;
1147 end if;
1149 if not Is_RAS then
1150 RPC_Receiver := Make_Defining_Identifier (Loc,
1151 New_Internal_Name ('P'));
1152 Specific_Build_RPC_Receiver_Body (
1153 RPC_Receiver => RPC_Receiver,
1154 Request => RPC_Receiver_Request,
1155 Subp_Id => RPC_Receiver_Subp_Id,
1156 Subp_Index => RPC_Receiver_Subp_Index,
1157 Stmts => RPC_Receiver_Statements,
1158 Decl => RPC_Receiver_Decl);
1160 if Get_PCS_Name = Name_PolyORB_DSA then
1162 -- For the case of PolyORB, we need to map a textual operation
1163 -- name into a primitive index. Currently we do so using a
1164 -- simple sequence of string comparisons.
1166 RPC_Receiver_Elsif_Parts := New_List;
1167 end if;
1168 end if;
1170 -- Build callers, receivers for every primitive operations and a RPC
1171 -- receiver for this type.
1173 if Present (Primitive_Operations (Designated_Type)) then
1174 Overload_Counter_Table.Reset;
1176 Current_Primitive_Elmt :=
1177 First_Elmt (Primitive_Operations (Designated_Type));
1178 while Current_Primitive_Elmt /= No_Elmt loop
1179 Current_Primitive := Node (Current_Primitive_Elmt);
1181 -- Copy the primitive of all the parents, except predefined
1182 -- ones that are not remotely dispatching.
1184 if Chars (Current_Primitive) /= Name_uSize
1185 and then Chars (Current_Primitive) /= Name_uAlignment
1186 and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize)
1187 then
1188 -- The first thing to do is build an up-to-date copy of
1189 -- the spec with all the formals referencing Designated_Type
1190 -- transformed into formals referencing Stub_Type. Since this
1191 -- primitive may have been inherited, go back the alias chain
1192 -- until the real primitive has been found.
1194 Current_Primitive_Alias := Current_Primitive;
1195 while Present (Alias (Current_Primitive_Alias)) loop
1196 pragma Assert
1197 (Current_Primitive_Alias
1198 /= Alias (Current_Primitive_Alias));
1199 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
1200 end loop;
1202 Current_Primitive_Spec :=
1203 Copy_Specification (Loc,
1204 Spec => Parent (Current_Primitive_Alias),
1205 Object_Type => Designated_Type,
1206 Stub_Type => Stub_Elements.Stub_Type);
1208 Current_Primitive_Decl :=
1209 Make_Subprogram_Declaration (Loc,
1210 Specification => Current_Primitive_Spec);
1212 Insert_After (Current_Insertion_Node, Current_Primitive_Decl);
1213 Analyze (Current_Primitive_Decl);
1214 Current_Insertion_Node := Current_Primitive_Decl;
1216 Possibly_Asynchronous :=
1217 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1218 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1220 Assign_Subprogram_Identifier (
1221 Defining_Unit_Name (Current_Primitive_Spec),
1222 Current_Primitive_Number,
1223 Subp_Str);
1225 Current_Primitive_Body :=
1226 Build_Subprogram_Calling_Stubs
1227 (Vis_Decl => Current_Primitive_Decl,
1228 Subp_Id =>
1229 Build_Subprogram_Id (Loc,
1230 Defining_Unit_Name (Current_Primitive_Spec)),
1231 Asynchronous => Possibly_Asynchronous,
1232 Dynamically_Asynchronous => Possibly_Asynchronous,
1233 Stub_Type => Stub_Elements.Stub_Type,
1234 RACW_Type => Stub_Elements.RACW_Type);
1235 Append_To (Decls, Current_Primitive_Body);
1237 -- Analyzing the body here would cause the Stub type to be
1238 -- frozen, thus preventing subsequent primitive declarations.
1239 -- For this reason, it will be analyzed later in the
1240 -- regular flow.
1242 -- Build the receiver stubs
1244 if not Is_RAS then
1245 Current_Receiver_Body :=
1246 Specific_Build_Subprogram_Receiving_Stubs
1247 (Vis_Decl => Current_Primitive_Decl,
1248 Asynchronous => Possibly_Asynchronous,
1249 Dynamically_Asynchronous => Possibly_Asynchronous,
1250 Stub_Type => Stub_Elements.Stub_Type,
1251 RACW_Type => Stub_Elements.RACW_Type,
1252 Parent_Primitive => Current_Primitive);
1254 Current_Receiver := Defining_Unit_Name (
1255 Specification (Current_Receiver_Body));
1257 Append_To (Decls, Current_Receiver_Body);
1259 -- Add a case alternative to the receiver
1261 if Get_PCS_Name = Name_PolyORB_DSA then
1262 Append_To (RPC_Receiver_Elsif_Parts,
1263 Make_Elsif_Part (Loc,
1264 Condition =>
1265 Make_Function_Call (Loc,
1266 Name =>
1267 New_Occurrence_Of (
1268 RTE (RE_Caseless_String_Eq), Loc),
1269 Parameter_Associations => New_List (
1270 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1271 Make_String_Literal (Loc, Subp_Str))),
1272 Then_Statements => New_List (
1273 Make_Assignment_Statement (Loc,
1274 Name => New_Occurrence_Of (
1275 RPC_Receiver_Subp_Index, Loc),
1276 Expression =>
1277 Make_Integer_Literal (Loc,
1278 Current_Primitive_Number)))));
1279 end if;
1281 Append_To (RPC_Receiver_Case_Alternatives,
1282 Make_Case_Statement_Alternative (Loc,
1283 Discrete_Choices => New_List (
1284 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1286 Statements => New_List (
1287 Make_Procedure_Call_Statement (Loc,
1288 Name =>
1289 New_Occurrence_Of (Current_Receiver, Loc),
1290 Parameter_Associations => New_List (
1291 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1292 end if;
1294 -- Increment the index of current primitive
1296 Current_Primitive_Number := Current_Primitive_Number + 1;
1297 end if;
1299 Next_Elmt (Current_Primitive_Elmt);
1300 end loop;
1301 end if;
1303 -- Build the case statement and the heart of the subprogram
1305 if not Is_RAS then
1306 if Get_PCS_Name = Name_PolyORB_DSA
1307 and then Present (First (RPC_Receiver_Elsif_Parts))
1308 then
1309 Append_To (RPC_Receiver_Statements,
1310 Make_Implicit_If_Statement (Designated_Type,
1311 Condition => New_Occurrence_Of (Standard_False, Loc),
1312 Then_Statements => New_List,
1313 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1314 end if;
1316 Append_To (RPC_Receiver_Case_Alternatives,
1317 Make_Case_Statement_Alternative (Loc,
1318 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1319 Statements => New_List (Make_Null_Statement (Loc))));
1321 Append_To (RPC_Receiver_Statements,
1322 Make_Case_Statement (Loc,
1323 Expression =>
1324 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1325 Alternatives => RPC_Receiver_Case_Alternatives));
1327 Append_To (Decls, RPC_Receiver_Decl);
1328 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1329 Decls, RPC_Receiver, Stub_Elements);
1330 end if;
1332 -- Do not analyze RPC receiver at this stage since it will otherwise
1333 -- reference subprograms that have not been analyzed yet. It will
1334 -- be analyzed in the regular flow.
1336 end Add_RACW_Primitive_Declarations_And_Bodies;
1338 -----------------------------
1339 -- Add_RAS_Dereference_TSS --
1340 -----------------------------
1342 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1343 Loc : constant Source_Ptr := Sloc (N);
1345 Type_Def : constant Node_Id := Type_Definition (N);
1347 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1348 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1349 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1350 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1352 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
1353 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1355 RACW_Primitive_Name : Node_Id;
1357 Proc : constant Entity_Id :=
1358 Make_Defining_Identifier (Loc,
1359 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1361 Proc_Spec : Node_Id;
1362 Param_Specs : List_Id;
1363 Param_Assoc : constant List_Id := New_List;
1364 Stmts : constant List_Id := New_List;
1366 RAS_Parameter : constant Entity_Id :=
1367 Make_Defining_Identifier (Loc,
1368 Chars => New_Internal_Name ('P'));
1370 Is_Function : constant Boolean :=
1371 Nkind (Type_Def) = N_Access_Function_Definition;
1373 Is_Degenerate : Boolean;
1374 -- Set to True if the subprogram_specification for this RAS has
1375 -- an anonymous access parameter (see Process_Remote_AST_Declaration).
1377 Spec : constant Node_Id := Type_Def;
1379 Current_Parameter : Node_Id;
1381 -- Start of processing for Add_RAS_Dereference_TSS
1383 begin
1384 -- The Dereference TSS for a remote access-to-subprogram type
1385 -- has the form:
1387 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1388 -- [return <>]
1390 -- This is called whenever a value of a RAS type is dereferenced
1392 -- First construct a list of parameter specifications:
1394 -- The first formal is the RAS values
1396 Param_Specs := New_List (
1397 Make_Parameter_Specification (Loc,
1398 Defining_Identifier => RAS_Parameter,
1399 In_Present => True,
1400 Parameter_Type =>
1401 New_Occurrence_Of (Fat_Type, Loc)));
1403 -- The following formals are copied from the type declaration
1405 Is_Degenerate := False;
1406 Current_Parameter := First (Parameter_Specifications (Type_Def));
1407 Parameters : while Present (Current_Parameter) loop
1408 if Nkind (Parameter_Type (Current_Parameter))
1409 = N_Access_Definition
1410 then
1411 Is_Degenerate := True;
1412 end if;
1413 Append_To (Param_Specs,
1414 Make_Parameter_Specification (Loc,
1415 Defining_Identifier =>
1416 Make_Defining_Identifier (Loc,
1417 Chars => Chars (Defining_Identifier (Current_Parameter))),
1418 In_Present => In_Present (Current_Parameter),
1419 Out_Present => Out_Present (Current_Parameter),
1420 Parameter_Type =>
1421 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1422 Expression =>
1423 New_Copy_Tree (Expression (Current_Parameter))));
1425 Append_To (Param_Assoc,
1426 Make_Identifier (Loc,
1427 Chars => Chars (Defining_Identifier (Current_Parameter))));
1429 Next (Current_Parameter);
1430 end loop Parameters;
1432 if Is_Degenerate then
1433 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1435 -- Generate a dummy body. This code will never actually be executed,
1436 -- because null is the only legal value for a degenerate RAS type.
1437 -- For legality's sake (in order to avoid generating a function
1438 -- that does not contain a return statement), we include a dummy
1439 -- recursive call on the TSS itself.
1441 Append_To (Stmts,
1442 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1443 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1445 else
1446 -- For a normal RAS type, we cast the RAS formal to the corresponding
1447 -- tagged type, and perform a dispatching call to its Call
1448 -- primitive operation.
1450 Prepend_To (Param_Assoc,
1451 Unchecked_Convert_To (RACW_Type,
1452 New_Occurrence_Of (RAS_Parameter, Loc)));
1454 RACW_Primitive_Name := Make_Selected_Component (Loc,
1455 Prefix => Scope (RACW_Type),
1456 Selector_Name => Name_Call);
1457 end if;
1459 if Is_Function then
1460 Append_To (Stmts,
1461 Make_Return_Statement (Loc,
1462 Expression =>
1463 Make_Function_Call (Loc,
1464 Name =>
1465 RACW_Primitive_Name,
1466 Parameter_Associations => Param_Assoc)));
1468 else
1469 Append_To (Stmts,
1470 Make_Procedure_Call_Statement (Loc,
1471 Name =>
1472 RACW_Primitive_Name,
1473 Parameter_Associations => Param_Assoc));
1474 end if;
1476 -- Build the complete subprogram
1478 if Is_Function then
1479 Proc_Spec :=
1480 Make_Function_Specification (Loc,
1481 Defining_Unit_Name => Proc,
1482 Parameter_Specifications => Param_Specs,
1483 Result_Definition =>
1484 New_Occurrence_Of (
1485 Entity (Result_Definition (Spec)), Loc));
1487 Set_Ekind (Proc, E_Function);
1488 Set_Etype (Proc,
1489 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1491 else
1492 Proc_Spec :=
1493 Make_Procedure_Specification (Loc,
1494 Defining_Unit_Name => Proc,
1495 Parameter_Specifications => Param_Specs);
1497 Set_Ekind (Proc, E_Procedure);
1498 Set_Etype (Proc, Standard_Void_Type);
1499 end if;
1501 Discard_Node (
1502 Make_Subprogram_Body (Loc,
1503 Specification => Proc_Spec,
1504 Declarations => New_List,
1505 Handled_Statement_Sequence =>
1506 Make_Handled_Sequence_Of_Statements (Loc,
1507 Statements => Stmts)));
1509 Set_TSS (Fat_Type, Proc);
1510 end Add_RAS_Dereference_TSS;
1512 -------------------------------
1513 -- Add_RAS_Proxy_And_Analyze --
1514 -------------------------------
1516 procedure Add_RAS_Proxy_And_Analyze
1517 (Decls : List_Id;
1518 Vis_Decl : Node_Id;
1519 All_Calls_Remote_E : Entity_Id;
1520 Proxy_Object_Addr : out Entity_Id)
1522 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1524 Subp_Name : constant Entity_Id :=
1525 Defining_Unit_Name (Specification (Vis_Decl));
1527 Pkg_Name : constant Entity_Id :=
1528 Make_Defining_Identifier (Loc,
1529 Chars =>
1530 New_External_Name (Chars (Subp_Name), 'P', -1));
1532 Proxy_Type : constant Entity_Id :=
1533 Make_Defining_Identifier (Loc,
1534 Chars =>
1535 New_External_Name (
1536 Related_Id => Chars (Subp_Name),
1537 Suffix => 'P'));
1539 Proxy_Type_Full_View : constant Entity_Id :=
1540 Make_Defining_Identifier (Loc,
1541 Chars (Proxy_Type));
1543 Subp_Decl_Spec : constant Node_Id :=
1544 Build_RAS_Primitive_Specification
1545 (Subp_Spec => Specification (Vis_Decl),
1546 Remote_Object_Type => Proxy_Type);
1548 Subp_Body_Spec : constant Node_Id :=
1549 Build_RAS_Primitive_Specification
1550 (Subp_Spec => Specification (Vis_Decl),
1551 Remote_Object_Type => Proxy_Type);
1553 Vis_Decls : constant List_Id := New_List;
1554 Pvt_Decls : constant List_Id := New_List;
1555 Actuals : constant List_Id := New_List;
1556 Formal : Node_Id;
1557 Perform_Call : Node_Id;
1559 begin
1560 -- type subpP is tagged limited private;
1562 Append_To (Vis_Decls,
1563 Make_Private_Type_Declaration (Loc,
1564 Defining_Identifier => Proxy_Type,
1565 Tagged_Present => True,
1566 Limited_Present => True));
1568 -- [subprogram] Call
1569 -- (Self : access subpP;
1570 -- ...other-formals...)
1571 -- [return T];
1573 Append_To (Vis_Decls,
1574 Make_Subprogram_Declaration (Loc,
1575 Specification => Subp_Decl_Spec));
1577 -- A : constant System.Address;
1579 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1581 Append_To (Vis_Decls,
1582 Make_Object_Declaration (Loc,
1583 Defining_Identifier =>
1584 Proxy_Object_Addr,
1585 Constant_Present =>
1586 True,
1587 Object_Definition =>
1588 New_Occurrence_Of (RTE (RE_Address), Loc)));
1590 -- private
1592 -- type subpP is tagged limited record
1593 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1594 -- ...
1595 -- end record;
1597 Append_To (Pvt_Decls,
1598 Make_Full_Type_Declaration (Loc,
1599 Defining_Identifier =>
1600 Proxy_Type_Full_View,
1601 Type_Definition =>
1602 Build_Remote_Subprogram_Proxy_Type (Loc,
1603 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1605 -- Trick semantic analysis into swapping the public and
1606 -- full view when freezing the public view.
1608 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1610 -- procedure Call
1611 -- (Self : access O;
1612 -- ...other-formals...) is
1613 -- begin
1614 -- P (...other-formals...);
1615 -- end Call;
1617 -- function Call
1618 -- (Self : access O;
1619 -- ...other-formals...)
1620 -- return T is
1621 -- begin
1622 -- return F (...other-formals...);
1623 -- end Call;
1625 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1626 Perform_Call :=
1627 Make_Procedure_Call_Statement (Loc,
1628 Name =>
1629 New_Occurrence_Of (Subp_Name, Loc),
1630 Parameter_Associations =>
1631 Actuals);
1632 else
1633 Perform_Call :=
1634 Make_Return_Statement (Loc,
1635 Expression =>
1636 Make_Function_Call (Loc,
1637 Name =>
1638 New_Occurrence_Of (Subp_Name, Loc),
1639 Parameter_Associations =>
1640 Actuals));
1641 end if;
1643 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1644 pragma Assert (Present (Formal));
1645 loop
1646 Next (Formal);
1647 exit when No (Formal);
1648 Append_To (Actuals,
1649 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1650 end loop;
1652 -- O : aliased subpP;
1654 Append_To (Pvt_Decls,
1655 Make_Object_Declaration (Loc,
1656 Defining_Identifier =>
1657 Make_Defining_Identifier (Loc,
1658 Name_uO),
1659 Aliased_Present =>
1660 True,
1661 Object_Definition =>
1662 New_Occurrence_Of (Proxy_Type, Loc)));
1664 -- A : constant System.Address := O'Address;
1666 Append_To (Pvt_Decls,
1667 Make_Object_Declaration (Loc,
1668 Defining_Identifier =>
1669 Make_Defining_Identifier (Loc,
1670 Chars (Proxy_Object_Addr)),
1671 Constant_Present =>
1672 True,
1673 Object_Definition =>
1674 New_Occurrence_Of (RTE (RE_Address), Loc),
1675 Expression =>
1676 Make_Attribute_Reference (Loc,
1677 Prefix => New_Occurrence_Of (
1678 Defining_Identifier (Last (Pvt_Decls)), Loc),
1679 Attribute_Name =>
1680 Name_Address)));
1682 Append_To (Decls,
1683 Make_Package_Declaration (Loc,
1684 Specification => Make_Package_Specification (Loc,
1685 Defining_Unit_Name => Pkg_Name,
1686 Visible_Declarations => Vis_Decls,
1687 Private_Declarations => Pvt_Decls,
1688 End_Label => Empty)));
1689 Analyze (Last (Decls));
1691 Append_To (Decls,
1692 Make_Package_Body (Loc,
1693 Defining_Unit_Name =>
1694 Make_Defining_Identifier (Loc,
1695 Chars (Pkg_Name)),
1696 Declarations => New_List (
1697 Make_Subprogram_Body (Loc,
1698 Specification =>
1699 Subp_Body_Spec,
1700 Declarations => New_List,
1701 Handled_Statement_Sequence =>
1702 Make_Handled_Sequence_Of_Statements (Loc,
1703 Statements => New_List (Perform_Call))))));
1704 Analyze (Last (Decls));
1705 end Add_RAS_Proxy_And_Analyze;
1707 -----------------------
1708 -- Add_RAST_Features --
1709 -----------------------
1711 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1712 RAS_Type : constant Entity_Id :=
1713 Equivalent_Type (Defining_Identifier (Vis_Decl));
1714 begin
1715 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1716 Add_RAS_Dereference_TSS (Vis_Decl);
1717 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1718 end Add_RAST_Features;
1720 -------------------
1721 -- Add_Stub_Type --
1722 -------------------
1724 procedure Add_Stub_Type
1725 (Designated_Type : Entity_Id;
1726 RACW_Type : Entity_Id;
1727 Decls : List_Id;
1728 Stub_Type : out Entity_Id;
1729 Stub_Type_Access : out Entity_Id;
1730 RPC_Receiver_Decl : out Node_Id;
1731 Existing : out Boolean)
1733 Loc : constant Source_Ptr := Sloc (RACW_Type);
1735 Stub_Elements : constant Stub_Structure :=
1736 Stubs_Table.Get (Designated_Type);
1737 Stub_Type_Decl : Node_Id;
1738 Stub_Type_Access_Decl : Node_Id;
1740 begin
1741 if Stub_Elements /= Empty_Stub_Structure then
1742 Stub_Type := Stub_Elements.Stub_Type;
1743 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1744 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1745 Existing := True;
1746 return;
1747 end if;
1749 Existing := False;
1750 Stub_Type :=
1751 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1752 Stub_Type_Access :=
1753 Make_Defining_Identifier (Loc,
1754 New_External_Name (
1755 Related_Id => Chars (Stub_Type),
1756 Suffix => 'A'));
1758 Specific_Build_Stub_Type (
1759 RACW_Type, Stub_Type,
1760 Stub_Type_Decl, RPC_Receiver_Decl);
1762 Stub_Type_Access_Decl :=
1763 Make_Full_Type_Declaration (Loc,
1764 Defining_Identifier => Stub_Type_Access,
1765 Type_Definition =>
1766 Make_Access_To_Object_Definition (Loc,
1767 All_Present => True,
1768 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1770 Append_To (Decls, Stub_Type_Decl);
1771 Analyze (Last (Decls));
1772 Append_To (Decls, Stub_Type_Access_Decl);
1773 Analyze (Last (Decls));
1775 -- This is in no way a type derivation, but we fake it to make
1776 -- sure that the dispatching table gets built with the corresponding
1777 -- primitive operations at the right place.
1779 Derive_Subprograms (Parent_Type => Designated_Type,
1780 Derived_Type => Stub_Type);
1782 if Present (RPC_Receiver_Decl) then
1783 Append_To (Decls, RPC_Receiver_Decl);
1784 else
1785 RPC_Receiver_Decl := Last (Decls);
1786 end if;
1788 Stubs_Table.Set (Designated_Type,
1789 (Stub_Type => Stub_Type,
1790 Stub_Type_Access => Stub_Type_Access,
1791 RPC_Receiver_Decl => RPC_Receiver_Decl,
1792 RACW_Type => RACW_Type));
1793 end Add_Stub_Type;
1795 ----------------------------------
1796 -- Assign_Subprogram_Identifier --
1797 ----------------------------------
1799 procedure Assign_Subprogram_Identifier
1800 (Def : Entity_Id;
1801 Spn : Int;
1802 Id : out String_Id)
1804 N : constant Name_Id := Chars (Def);
1806 Overload_Order : constant Int :=
1807 Overload_Counter_Table.Get (N) + 1;
1809 begin
1810 Overload_Counter_Table.Set (N, Overload_Order);
1812 Get_Name_String (N);
1814 -- Homonym handling: as in Exp_Dbug, but much simpler,
1815 -- because the only entities for which we have to generate
1816 -- names here need only to be disambiguated within their
1817 -- own scope.
1819 if Overload_Order > 1 then
1820 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
1821 Name_Len := Name_Len + 2;
1822 Add_Nat_To_Name_Buffer (Overload_Order);
1823 end if;
1825 Id := String_From_Name_Buffer;
1826 Subprogram_Identifier_Table.Set (Def,
1827 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
1828 end Assign_Subprogram_Identifier;
1830 ------------------------------
1831 -- Build_Get_Unique_RP_Call --
1832 ------------------------------
1834 function Build_Get_Unique_RP_Call
1835 (Loc : Source_Ptr;
1836 Pointer : Entity_Id;
1837 Stub_Type : Entity_Id) return List_Id
1839 begin
1840 return New_List (
1841 Make_Procedure_Call_Statement (Loc,
1842 Name =>
1843 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
1844 Parameter_Associations => New_List (
1845 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
1846 New_Occurrence_Of (Pointer, Loc)))),
1848 Make_Assignment_Statement (Loc,
1849 Name =>
1850 Make_Selected_Component (Loc,
1851 Prefix =>
1852 New_Occurrence_Of (Pointer, Loc),
1853 Selector_Name =>
1854 New_Occurrence_Of (First_Tag_Component
1855 (Designated_Type (Etype (Pointer))), Loc)),
1856 Expression =>
1857 Make_Attribute_Reference (Loc,
1858 Prefix =>
1859 New_Occurrence_Of (Stub_Type, Loc),
1860 Attribute_Name =>
1861 Name_Tag)));
1863 -- Note: The assignment to Pointer._Tag is safe here because
1864 -- we carefully ensured that Stub_Type has exactly the same layout
1865 -- as System.Partition_Interface.RACW_Stub_Type.
1867 end Build_Get_Unique_RP_Call;
1869 -----------------------------------
1870 -- Build_Ordered_Parameters_List --
1871 -----------------------------------
1873 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
1874 Constrained_List : List_Id;
1875 Unconstrained_List : List_Id;
1876 Current_Parameter : Node_Id;
1878 First_Parameter : Node_Id;
1879 For_RAS : Boolean := False;
1881 begin
1882 if not Present (Parameter_Specifications (Spec)) then
1883 return New_List;
1884 end if;
1886 Constrained_List := New_List;
1887 Unconstrained_List := New_List;
1888 First_Parameter := First (Parameter_Specifications (Spec));
1890 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
1891 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
1892 then
1893 For_RAS := True;
1894 end if;
1896 -- Loop through the parameters and add them to the right list
1898 Current_Parameter := First_Parameter;
1899 while Present (Current_Parameter) loop
1900 if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
1901 or else
1902 Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
1903 or else
1904 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
1905 and then not (For_RAS and then Current_Parameter = First_Parameter)
1906 then
1907 Append_To (Constrained_List, New_Copy (Current_Parameter));
1908 else
1909 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
1910 end if;
1912 Next (Current_Parameter);
1913 end loop;
1915 -- Unconstrained parameters are returned first
1917 Append_List_To (Unconstrained_List, Constrained_List);
1919 return Unconstrained_List;
1920 end Build_Ordered_Parameters_List;
1922 ----------------------------------
1923 -- Build_Passive_Partition_Stub --
1924 ----------------------------------
1926 procedure Build_Passive_Partition_Stub (U : Node_Id) is
1927 Pkg_Spec : Node_Id;
1928 Pkg_Name : String_Id;
1929 L : List_Id;
1930 Reg : Node_Id;
1931 Loc : constant Source_Ptr := Sloc (U);
1933 begin
1934 -- Verify that the implementation supports distribution, by accessing
1935 -- a type defined in the proper version of system.rpc
1937 declare
1938 Dist_OK : Entity_Id;
1939 pragma Warnings (Off, Dist_OK);
1940 begin
1941 Dist_OK := RTE (RE_Params_Stream_Type);
1942 end;
1944 -- Use body if present, spec otherwise
1946 if Nkind (U) = N_Package_Declaration then
1947 Pkg_Spec := Specification (U);
1948 L := Visible_Declarations (Pkg_Spec);
1949 else
1950 Pkg_Spec := Parent (Corresponding_Spec (U));
1951 L := Declarations (U);
1952 end if;
1954 Get_Library_Unit_Name_String (Pkg_Spec);
1955 Pkg_Name := String_From_Name_Buffer;
1956 Reg :=
1957 Make_Procedure_Call_Statement (Loc,
1958 Name =>
1959 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
1960 Parameter_Associations => New_List (
1961 Make_String_Literal (Loc, Pkg_Name),
1962 Make_Attribute_Reference (Loc,
1963 Prefix =>
1964 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
1965 Attribute_Name =>
1966 Name_Version)));
1967 Append_To (L, Reg);
1968 Analyze (Reg);
1969 end Build_Passive_Partition_Stub;
1971 --------------------------------------
1972 -- Build_RPC_Receiver_Specification --
1973 --------------------------------------
1975 function Build_RPC_Receiver_Specification
1976 (RPC_Receiver : Entity_Id;
1977 Request_Parameter : Entity_Id) return Node_Id
1979 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
1980 begin
1981 return
1982 Make_Procedure_Specification (Loc,
1983 Defining_Unit_Name => RPC_Receiver,
1984 Parameter_Specifications => New_List (
1985 Make_Parameter_Specification (Loc,
1986 Defining_Identifier => Request_Parameter,
1987 Parameter_Type =>
1988 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
1989 end Build_RPC_Receiver_Specification;
1991 ----------------------------------------
1992 -- Build_Remote_Subprogram_Proxy_Type --
1993 ----------------------------------------
1995 function Build_Remote_Subprogram_Proxy_Type
1996 (Loc : Source_Ptr;
1997 ACR_Expression : Node_Id) return Node_Id
1999 begin
2000 return
2001 Make_Record_Definition (Loc,
2002 Tagged_Present => True,
2003 Limited_Present => True,
2004 Component_List =>
2005 Make_Component_List (Loc,
2007 Component_Items => New_List (
2008 Make_Component_Declaration (Loc,
2009 Defining_Identifier =>
2010 Make_Defining_Identifier (Loc,
2011 Name_All_Calls_Remote),
2012 Component_Definition =>
2013 Make_Component_Definition (Loc,
2014 Subtype_Indication =>
2015 New_Occurrence_Of (Standard_Boolean, Loc)),
2016 Expression =>
2017 ACR_Expression),
2019 Make_Component_Declaration (Loc,
2020 Defining_Identifier =>
2021 Make_Defining_Identifier (Loc,
2022 Name_Receiver),
2023 Component_Definition =>
2024 Make_Component_Definition (Loc,
2025 Subtype_Indication =>
2026 New_Occurrence_Of (RTE (RE_Address), Loc)),
2027 Expression =>
2028 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2030 Make_Component_Declaration (Loc,
2031 Defining_Identifier =>
2032 Make_Defining_Identifier (Loc,
2033 Name_Subp_Id),
2034 Component_Definition =>
2035 Make_Component_Definition (Loc,
2036 Subtype_Indication =>
2037 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2038 end Build_Remote_Subprogram_Proxy_Type;
2040 ------------------------------------
2041 -- Build_Subprogram_Calling_Stubs --
2042 ------------------------------------
2044 function Build_Subprogram_Calling_Stubs
2045 (Vis_Decl : Node_Id;
2046 Subp_Id : Node_Id;
2047 Asynchronous : Boolean;
2048 Dynamically_Asynchronous : Boolean := False;
2049 Stub_Type : Entity_Id := Empty;
2050 RACW_Type : Entity_Id := Empty;
2051 Locator : Entity_Id := Empty;
2052 New_Name : Name_Id := No_Name) return Node_Id
2054 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2056 Decls : constant List_Id := New_List;
2057 Statements : constant List_Id := New_List;
2059 Subp_Spec : Node_Id;
2060 -- The specification of the body
2062 Controlling_Parameter : Entity_Id := Empty;
2064 Asynchronous_Expr : Node_Id := Empty;
2066 RCI_Locator : Entity_Id;
2068 Spec_To_Use : Node_Id;
2070 procedure Insert_Partition_Check (Parameter : Node_Id);
2071 -- Check that the parameter has been elaborated on the same partition
2072 -- than the controlling parameter (E.4(19)).
2074 ----------------------------
2075 -- Insert_Partition_Check --
2076 ----------------------------
2078 procedure Insert_Partition_Check (Parameter : Node_Id) is
2079 Parameter_Entity : constant Entity_Id :=
2080 Defining_Identifier (Parameter);
2081 begin
2082 -- The expression that will be built is of the form:
2084 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2085 -- raise Constraint_Error;
2086 -- end if;
2088 -- We do not check that Parameter is in Stub_Type since such a check
2089 -- has been inserted at the point of call already (a tag check since
2090 -- we have multiple controlling operands).
2092 Append_To (Decls,
2093 Make_Raise_Constraint_Error (Loc,
2094 Condition =>
2095 Make_Op_Not (Loc,
2096 Right_Opnd =>
2097 Make_Function_Call (Loc,
2098 Name =>
2099 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2100 Parameter_Associations =>
2101 New_List (
2102 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2103 New_Occurrence_Of (Parameter_Entity, Loc)),
2104 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2105 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2106 Reason => CE_Partition_Check_Failed));
2107 end Insert_Partition_Check;
2109 -- Start of processing for Build_Subprogram_Calling_Stubs
2111 begin
2112 Subp_Spec := Copy_Specification (Loc,
2113 Spec => Specification (Vis_Decl),
2114 New_Name => New_Name);
2116 if Locator = Empty then
2117 RCI_Locator := RCI_Cache;
2118 Spec_To_Use := Specification (Vis_Decl);
2119 else
2120 RCI_Locator := Locator;
2121 Spec_To_Use := Subp_Spec;
2122 end if;
2124 -- Find a controlling argument if we have a stub type. Also check
2125 -- if this subprogram can be made asynchronous.
2127 if Present (Stub_Type)
2128 and then Present (Parameter_Specifications (Spec_To_Use))
2129 then
2130 declare
2131 Current_Parameter : Node_Id :=
2132 First (Parameter_Specifications
2133 (Spec_To_Use));
2134 begin
2135 while Present (Current_Parameter) loop
2137 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2138 then
2139 if Controlling_Parameter = Empty then
2140 Controlling_Parameter :=
2141 Defining_Identifier (Current_Parameter);
2142 else
2143 Insert_Partition_Check (Current_Parameter);
2144 end if;
2145 end if;
2147 Next (Current_Parameter);
2148 end loop;
2149 end;
2150 end if;
2152 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2154 if Dynamically_Asynchronous then
2155 Asynchronous_Expr := Make_Selected_Component (Loc,
2156 Prefix => Controlling_Parameter,
2157 Selector_Name => Name_Asynchronous);
2158 end if;
2160 Specific_Build_General_Calling_Stubs
2161 (Decls => Decls,
2162 Statements => Statements,
2163 Target => Specific_Build_Stub_Target (Loc,
2164 Decls, RCI_Locator, Controlling_Parameter),
2165 Subprogram_Id => Subp_Id,
2166 Asynchronous => Asynchronous_Expr,
2167 Is_Known_Asynchronous => Asynchronous
2168 and then not Dynamically_Asynchronous,
2169 Is_Known_Non_Asynchronous
2170 => not Asynchronous
2171 and then not Dynamically_Asynchronous,
2172 Is_Function => Nkind (Spec_To_Use) =
2173 N_Function_Specification,
2174 Spec => Spec_To_Use,
2175 Stub_Type => Stub_Type,
2176 RACW_Type => RACW_Type,
2177 Nod => Vis_Decl);
2179 RCI_Calling_Stubs_Table.Set
2180 (Defining_Unit_Name (Specification (Vis_Decl)),
2181 Defining_Unit_Name (Spec_To_Use));
2183 return
2184 Make_Subprogram_Body (Loc,
2185 Specification => Subp_Spec,
2186 Declarations => Decls,
2187 Handled_Statement_Sequence =>
2188 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2189 end Build_Subprogram_Calling_Stubs;
2191 -------------------------
2192 -- Build_Subprogram_Id --
2193 -------------------------
2195 function Build_Subprogram_Id
2196 (Loc : Source_Ptr;
2197 E : Entity_Id) return Node_Id
2199 begin
2200 case Get_PCS_Name is
2201 when Name_PolyORB_DSA =>
2202 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2203 when others =>
2204 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2205 end case;
2206 end Build_Subprogram_Id;
2208 ------------------------
2209 -- Copy_Specification --
2210 ------------------------
2212 function Copy_Specification
2213 (Loc : Source_Ptr;
2214 Spec : Node_Id;
2215 Object_Type : Entity_Id := Empty;
2216 Stub_Type : Entity_Id := Empty;
2217 New_Name : Name_Id := No_Name) return Node_Id
2219 Parameters : List_Id := No_List;
2221 Current_Parameter : Node_Id;
2222 Current_Identifier : Entity_Id;
2223 Current_Type : Node_Id;
2224 Current_Etype : Entity_Id;
2226 Name_For_New_Spec : Name_Id;
2228 New_Identifier : Entity_Id;
2230 -- Comments needed in body below ???
2232 begin
2233 if New_Name = No_Name then
2234 pragma Assert (Nkind (Spec) = N_Function_Specification
2235 or else Nkind (Spec) = N_Procedure_Specification);
2237 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2238 else
2239 Name_For_New_Spec := New_Name;
2240 end if;
2242 if Present (Parameter_Specifications (Spec)) then
2243 Parameters := New_List;
2244 Current_Parameter := First (Parameter_Specifications (Spec));
2245 while Present (Current_Parameter) loop
2246 Current_Identifier := Defining_Identifier (Current_Parameter);
2247 Current_Type := Parameter_Type (Current_Parameter);
2249 if Nkind (Current_Type) = N_Access_Definition then
2250 Current_Etype := Entity (Subtype_Mark (Current_Type));
2252 if Present (Object_Type) then
2253 pragma Assert (
2254 Root_Type (Current_Etype) = Root_Type (Object_Type));
2255 Current_Type :=
2256 Make_Access_Definition (Loc,
2257 Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
2258 else
2259 Current_Type :=
2260 Make_Access_Definition (Loc,
2261 Subtype_Mark =>
2262 New_Occurrence_Of (Current_Etype, Loc));
2263 end if;
2265 else
2266 Current_Etype := Entity (Current_Type);
2268 if Present (Object_Type)
2269 and then Current_Etype = Object_Type
2270 then
2271 Current_Type := New_Occurrence_Of (Stub_Type, Loc);
2272 else
2273 Current_Type := New_Occurrence_Of (Current_Etype, Loc);
2274 end if;
2275 end if;
2277 New_Identifier := Make_Defining_Identifier (Loc,
2278 Chars (Current_Identifier));
2280 Append_To (Parameters,
2281 Make_Parameter_Specification (Loc,
2282 Defining_Identifier => New_Identifier,
2283 Parameter_Type => Current_Type,
2284 In_Present => In_Present (Current_Parameter),
2285 Out_Present => Out_Present (Current_Parameter),
2286 Expression =>
2287 New_Copy_Tree (Expression (Current_Parameter))));
2289 -- For a regular formal parameter (that needs to be marshalled
2290 -- in the context of remote calls), set the Etype now, because
2291 -- marshalling processing might need it.
2293 if Is_Entity_Name (Current_Type) then
2294 Set_Etype (New_Identifier, Entity (Current_Type));
2296 -- Current_Type is an access definition, special processing
2297 -- (not requiring etype) will occur for marshalling.
2299 else
2300 null;
2301 end if;
2303 Next (Current_Parameter);
2304 end loop;
2305 end if;
2307 case Nkind (Spec) is
2309 when N_Function_Specification | N_Access_Function_Definition =>
2310 return
2311 Make_Function_Specification (Loc,
2312 Defining_Unit_Name =>
2313 Make_Defining_Identifier (Loc,
2314 Chars => Name_For_New_Spec),
2315 Parameter_Specifications => Parameters,
2316 Result_Definition =>
2317 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2319 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2320 return
2321 Make_Procedure_Specification (Loc,
2322 Defining_Unit_Name =>
2323 Make_Defining_Identifier (Loc,
2324 Chars => Name_For_New_Spec),
2325 Parameter_Specifications => Parameters);
2327 when others =>
2328 raise Program_Error;
2329 end case;
2330 end Copy_Specification;
2332 ---------------------------
2333 -- Could_Be_Asynchronous --
2334 ---------------------------
2336 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2337 Current_Parameter : Node_Id;
2339 begin
2340 if Present (Parameter_Specifications (Spec)) then
2341 Current_Parameter := First (Parameter_Specifications (Spec));
2342 while Present (Current_Parameter) loop
2343 if Out_Present (Current_Parameter) then
2344 return False;
2345 end if;
2347 Next (Current_Parameter);
2348 end loop;
2349 end if;
2351 return True;
2352 end Could_Be_Asynchronous;
2354 ---------------------------
2355 -- Declare_Create_NVList --
2356 ---------------------------
2358 procedure Declare_Create_NVList
2359 (Loc : Source_Ptr;
2360 NVList : Entity_Id;
2361 Decls : List_Id;
2362 Stmts : List_Id)
2364 begin
2365 Append_To (Decls,
2366 Make_Object_Declaration (Loc,
2367 Defining_Identifier => NVList,
2368 Aliased_Present => False,
2369 Object_Definition =>
2370 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2372 Append_To (Stmts,
2373 Make_Procedure_Call_Statement (Loc,
2374 Name =>
2375 New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2376 Parameter_Associations => New_List (
2377 New_Occurrence_Of (NVList, Loc))));
2378 end Declare_Create_NVList;
2380 ---------------------------------------------
2381 -- Expand_All_Calls_Remote_Subprogram_Call --
2382 ---------------------------------------------
2384 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2385 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2386 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2387 Loc : constant Source_Ptr := Sloc (N);
2388 RCI_Locator : Node_Id;
2389 RCI_Cache : Entity_Id;
2390 Calling_Stubs : Node_Id;
2391 E_Calling_Stubs : Entity_Id;
2393 begin
2394 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2396 if E_Calling_Stubs = Empty then
2397 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
2399 if RCI_Cache = Empty then
2400 RCI_Locator :=
2401 RCI_Package_Locator
2402 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2403 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
2405 -- The RCI_Locator package is inserted at the top level in the
2406 -- current unit, and must appear in the proper scope, so that it
2407 -- is not prematurely removed by the GCC back-end.
2409 declare
2410 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2412 begin
2413 if Ekind (Scop) = E_Package_Body then
2414 New_Scope (Spec_Entity (Scop));
2416 elsif Ekind (Scop) = E_Subprogram_Body then
2417 New_Scope
2418 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2420 else
2421 New_Scope (Scop);
2422 end if;
2424 Analyze (RCI_Locator);
2425 Pop_Scope;
2426 end;
2428 RCI_Cache := Defining_Unit_Name (RCI_Locator);
2430 else
2431 RCI_Locator := Parent (RCI_Cache);
2432 end if;
2434 Calling_Stubs := Build_Subprogram_Calling_Stubs
2435 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2436 Subp_Id =>
2437 Build_Subprogram_Id (Loc, Called_Subprogram),
2438 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2439 and then
2440 Is_Asynchronous (Called_Subprogram),
2441 Locator => RCI_Cache,
2442 New_Name => New_Internal_Name ('S'));
2443 Insert_After (RCI_Locator, Calling_Stubs);
2444 Analyze (Calling_Stubs);
2445 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2446 end if;
2448 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2449 end Expand_All_Calls_Remote_Subprogram_Call;
2451 ---------------------------------
2452 -- Expand_Calling_Stubs_Bodies --
2453 ---------------------------------
2455 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2456 Spec : constant Node_Id := Specification (Unit_Node);
2457 Decls : constant List_Id := Visible_Declarations (Spec);
2458 begin
2459 New_Scope (Scope_Of_Spec (Spec));
2460 Add_Calling_Stubs_To_Declarations
2461 (Specification (Unit_Node), Decls);
2462 Pop_Scope;
2463 end Expand_Calling_Stubs_Bodies;
2465 -----------------------------------
2466 -- Expand_Receiving_Stubs_Bodies --
2467 -----------------------------------
2469 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2470 Spec : Node_Id;
2471 Decls : List_Id;
2472 Temp : List_Id;
2474 begin
2475 if Nkind (Unit_Node) = N_Package_Declaration then
2476 Spec := Specification (Unit_Node);
2477 Decls := Private_Declarations (Spec);
2479 if No (Decls) then
2480 Decls := Visible_Declarations (Spec);
2481 end if;
2483 New_Scope (Scope_Of_Spec (Spec));
2484 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls);
2486 else
2487 Spec :=
2488 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2489 Decls := Declarations (Unit_Node);
2490 New_Scope (Scope_Of_Spec (Unit_Node));
2491 Temp := New_List;
2492 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp);
2493 Insert_List_Before (First (Decls), Temp);
2494 end if;
2496 Pop_Scope;
2497 end Expand_Receiving_Stubs_Bodies;
2499 --------------------
2500 -- GARLIC_Support --
2501 --------------------
2503 package body GARLIC_Support is
2505 -- Local subprograms
2507 procedure Add_RACW_Read_Attribute
2508 (RACW_Type : Entity_Id;
2509 Stub_Type : Entity_Id;
2510 Stub_Type_Access : Entity_Id;
2511 Declarations : List_Id);
2512 -- Add Read attribute in Decls for the RACW type. The Read attribute
2513 -- is added right after the RACW_Type declaration while the body is
2514 -- inserted after Declarations.
2516 procedure Add_RACW_Write_Attribute
2517 (RACW_Type : Entity_Id;
2518 Stub_Type : Entity_Id;
2519 Stub_Type_Access : Entity_Id;
2520 RPC_Receiver : Node_Id;
2521 Declarations : List_Id);
2522 -- Same thing for the Write attribute
2524 function Stream_Parameter return Node_Id;
2525 function Result return Node_Id;
2526 function Object return Node_Id renames Result;
2527 -- Functions to create occurrences of the formal parameter names of
2528 -- the 'Read and 'Write attributes.
2530 Loc : Source_Ptr;
2531 -- Shared source location used by Add_{Read,Write}_Read_Attribute
2532 -- and their ancillary subroutines (set on entry by Add_RACW_Features).
2534 procedure Add_RAS_Access_TSS (N : Node_Id);
2535 -- Add a subprogram body for RAS Access TSS
2537 -------------------------------------
2538 -- Add_Obj_RPC_Receiver_Completion --
2539 -------------------------------------
2541 procedure Add_Obj_RPC_Receiver_Completion
2542 (Loc : Source_Ptr;
2543 Decls : List_Id;
2544 RPC_Receiver : Entity_Id;
2545 Stub_Elements : Stub_Structure) is
2546 begin
2547 -- The RPC receiver body should not be the completion of the
2548 -- declaration recorded in the stub structure, because then the
2549 -- occurrences of the formal parameters within the body should
2550 -- refer to the entities from the declaration, not from the
2551 -- completion, to which we do not have easy access. Instead, the
2552 -- RPC receiver body acts as its own declaration, and the RPC
2553 -- receiver declaration is completed by a renaming-as-body.
2555 Append_To (Decls,
2556 Make_Subprogram_Renaming_Declaration (Loc,
2557 Specification =>
2558 Copy_Specification (Loc,
2559 Specification (Stub_Elements.RPC_Receiver_Decl)),
2560 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
2561 end Add_Obj_RPC_Receiver_Completion;
2563 -----------------------
2564 -- Add_RACW_Features --
2565 -----------------------
2567 procedure Add_RACW_Features
2568 (RACW_Type : Entity_Id;
2569 Stub_Type : Entity_Id;
2570 Stub_Type_Access : Entity_Id;
2571 RPC_Receiver_Decl : Node_Id;
2572 Declarations : List_Id)
2574 RPC_Receiver : Node_Id;
2575 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
2577 begin
2578 Loc := Sloc (RACW_Type);
2580 if Is_RAS then
2582 -- For a RAS, the RPC receiver is that of the RCI unit,
2583 -- not that of the corresponding distributed object type.
2584 -- We retrieve its address from the local proxy object.
2586 RPC_Receiver := Make_Selected_Component (Loc,
2587 Prefix =>
2588 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
2589 Selector_Name => Make_Identifier (Loc, Name_Receiver));
2591 else
2592 RPC_Receiver := Make_Attribute_Reference (Loc,
2593 Prefix => New_Occurrence_Of (
2594 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
2595 Attribute_Name => Name_Address);
2596 end if;
2598 Add_RACW_Write_Attribute (
2599 RACW_Type,
2600 Stub_Type,
2601 Stub_Type_Access,
2602 RPC_Receiver,
2603 Declarations);
2605 Add_RACW_Read_Attribute (
2606 RACW_Type,
2607 Stub_Type,
2608 Stub_Type_Access,
2609 Declarations);
2610 end Add_RACW_Features;
2612 -----------------------------
2613 -- Add_RACW_Read_Attribute --
2614 -----------------------------
2616 procedure Add_RACW_Read_Attribute
2617 (RACW_Type : Entity_Id;
2618 Stub_Type : Entity_Id;
2619 Stub_Type_Access : Entity_Id;
2620 Declarations : List_Id)
2622 Proc_Decl : Node_Id;
2623 Attr_Decl : Node_Id;
2625 Body_Node : Node_Id;
2627 Decls : List_Id;
2628 Statements : List_Id;
2629 Local_Statements : List_Id;
2630 Remote_Statements : List_Id;
2631 -- Various parts of the procedure
2633 Procedure_Name : constant Name_Id :=
2634 New_Internal_Name ('R');
2635 Source_Partition : constant Entity_Id :=
2636 Make_Defining_Identifier
2637 (Loc, New_Internal_Name ('P'));
2638 Source_Receiver : constant Entity_Id :=
2639 Make_Defining_Identifier
2640 (Loc, New_Internal_Name ('S'));
2641 Source_Address : constant Entity_Id :=
2642 Make_Defining_Identifier
2643 (Loc, New_Internal_Name ('P'));
2644 Local_Stub : constant Entity_Id :=
2645 Make_Defining_Identifier
2646 (Loc, New_Internal_Name ('L'));
2647 Stubbed_Result : constant Entity_Id :=
2648 Make_Defining_Identifier
2649 (Loc, New_Internal_Name ('S'));
2650 Asynchronous_Flag : constant Entity_Id :=
2651 Asynchronous_Flags_Table.Get (RACW_Type);
2652 pragma Assert (Present (Asynchronous_Flag));
2654 -- Start of processing for Add_RACW_Read_Attribute
2656 begin
2657 -- Generate object declarations
2659 Decls := New_List (
2660 Make_Object_Declaration (Loc,
2661 Defining_Identifier => Source_Partition,
2662 Object_Definition =>
2663 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
2665 Make_Object_Declaration (Loc,
2666 Defining_Identifier => Source_Receiver,
2667 Object_Definition =>
2668 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2670 Make_Object_Declaration (Loc,
2671 Defining_Identifier => Source_Address,
2672 Object_Definition =>
2673 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
2675 Make_Object_Declaration (Loc,
2676 Defining_Identifier => Local_Stub,
2677 Aliased_Present => True,
2678 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
2680 Make_Object_Declaration (Loc,
2681 Defining_Identifier => Stubbed_Result,
2682 Object_Definition =>
2683 New_Occurrence_Of (Stub_Type_Access, Loc),
2684 Expression =>
2685 Make_Attribute_Reference (Loc,
2686 Prefix =>
2687 New_Occurrence_Of (Local_Stub, Loc),
2688 Attribute_Name =>
2689 Name_Unchecked_Access)));
2691 -- Read the source Partition_ID and RPC_Receiver from incoming stream
2693 Statements := New_List (
2694 Make_Attribute_Reference (Loc,
2695 Prefix =>
2696 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
2697 Attribute_Name => Name_Read,
2698 Expressions => New_List (
2699 Stream_Parameter,
2700 New_Occurrence_Of (Source_Partition, Loc))),
2702 Make_Attribute_Reference (Loc,
2703 Prefix =>
2704 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2705 Attribute_Name =>
2706 Name_Read,
2707 Expressions => New_List (
2708 Stream_Parameter,
2709 New_Occurrence_Of (Source_Receiver, Loc))),
2711 Make_Attribute_Reference (Loc,
2712 Prefix =>
2713 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2714 Attribute_Name =>
2715 Name_Read,
2716 Expressions => New_List (
2717 Stream_Parameter,
2718 New_Occurrence_Of (Source_Address, Loc))));
2720 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
2722 Set_Etype (Stubbed_Result, Stub_Type_Access);
2724 -- If the Address is Null_Address, then return a null object
2726 Append_To (Statements,
2727 Make_Implicit_If_Statement (RACW_Type,
2728 Condition =>
2729 Make_Op_Eq (Loc,
2730 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
2731 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
2732 Then_Statements => New_List (
2733 Make_Assignment_Statement (Loc,
2734 Name => Result,
2735 Expression => Make_Null (Loc)),
2736 Make_Return_Statement (Loc))));
2738 -- If the RACW denotes an object created on the current partition,
2739 -- Local_Statements will be executed. The real object will be used.
2741 Local_Statements := New_List (
2742 Make_Assignment_Statement (Loc,
2743 Name => Result,
2744 Expression =>
2745 Unchecked_Convert_To (RACW_Type,
2746 OK_Convert_To (RTE (RE_Address),
2747 New_Occurrence_Of (Source_Address, Loc)))));
2749 -- If the object is located on another partition, then a stub object
2750 -- will be created with all the information needed to rebuild the
2751 -- real object at the other end.
2753 Remote_Statements := New_List (
2755 Make_Assignment_Statement (Loc,
2756 Name => Make_Selected_Component (Loc,
2757 Prefix => Stubbed_Result,
2758 Selector_Name => Name_Origin),
2759 Expression =>
2760 New_Occurrence_Of (Source_Partition, Loc)),
2762 Make_Assignment_Statement (Loc,
2763 Name => Make_Selected_Component (Loc,
2764 Prefix => Stubbed_Result,
2765 Selector_Name => Name_Receiver),
2766 Expression =>
2767 New_Occurrence_Of (Source_Receiver, Loc)),
2769 Make_Assignment_Statement (Loc,
2770 Name => Make_Selected_Component (Loc,
2771 Prefix => Stubbed_Result,
2772 Selector_Name => Name_Addr),
2773 Expression =>
2774 New_Occurrence_Of (Source_Address, Loc)));
2776 Append_To (Remote_Statements,
2777 Make_Assignment_Statement (Loc,
2778 Name => Make_Selected_Component (Loc,
2779 Prefix => Stubbed_Result,
2780 Selector_Name => Name_Asynchronous),
2781 Expression =>
2782 New_Occurrence_Of (Asynchronous_Flag, Loc)));
2784 Append_List_To (Remote_Statements,
2785 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
2786 -- ??? Issue with asynchronous calls here: the Asynchronous
2787 -- flag is set on the stub type if, and only if, the RACW type
2788 -- has a pragma Asynchronous. This is incorrect for RACWs that
2789 -- implement RAS types, because in that case the /designated
2790 -- subprogram/ (not the type) might be asynchronous, and
2791 -- that causes the stub to need to be asynchronous too.
2792 -- A solution is to transport a RAS as a struct containing
2793 -- a RACW and an asynchronous flag, and to properly alter
2794 -- the Asynchronous component in the stub type in the RAS's
2795 -- Input TSS.
2797 Append_To (Remote_Statements,
2798 Make_Assignment_Statement (Loc,
2799 Name => Result,
2800 Expression => Unchecked_Convert_To (RACW_Type,
2801 New_Occurrence_Of (Stubbed_Result, Loc))));
2803 -- Distinguish between the local and remote cases, and execute the
2804 -- appropriate piece of code.
2806 Append_To (Statements,
2807 Make_Implicit_If_Statement (RACW_Type,
2808 Condition =>
2809 Make_Op_Eq (Loc,
2810 Left_Opnd =>
2811 Make_Function_Call (Loc,
2812 Name => New_Occurrence_Of (
2813 RTE (RE_Get_Local_Partition_Id), Loc)),
2814 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
2815 Then_Statements => Local_Statements,
2816 Else_Statements => Remote_Statements));
2818 Build_Stream_Procedure
2819 (Loc, RACW_Type, Body_Node,
2820 Make_Defining_Identifier (Loc, Procedure_Name),
2821 Statements, Outp => True);
2822 Set_Declarations (Body_Node, Decls);
2824 Proc_Decl := Make_Subprogram_Declaration (Loc,
2825 Copy_Specification (Loc, Specification (Body_Node)));
2827 Attr_Decl :=
2828 Make_Attribute_Definition_Clause (Loc,
2829 Name => New_Occurrence_Of (RACW_Type, Loc),
2830 Chars => Name_Read,
2831 Expression =>
2832 New_Occurrence_Of (
2833 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2835 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2836 Insert_After (Proc_Decl, Attr_Decl);
2837 Append_To (Declarations, Body_Node);
2838 end Add_RACW_Read_Attribute;
2840 ------------------------------
2841 -- Add_RACW_Write_Attribute --
2842 ------------------------------
2844 procedure Add_RACW_Write_Attribute
2845 (RACW_Type : Entity_Id;
2846 Stub_Type : Entity_Id;
2847 Stub_Type_Access : Entity_Id;
2848 RPC_Receiver : Node_Id;
2849 Declarations : List_Id)
2851 Body_Node : Node_Id;
2852 Proc_Decl : Node_Id;
2853 Attr_Decl : Node_Id;
2855 Statements : List_Id;
2856 Local_Statements : List_Id;
2857 Remote_Statements : List_Id;
2858 Null_Statements : List_Id;
2860 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
2862 begin
2863 -- Build the code fragment corresponding to the marshalling of a
2864 -- local object.
2866 Local_Statements := New_List (
2868 Pack_Entity_Into_Stream_Access (Loc,
2869 Stream => Stream_Parameter,
2870 Object => RTE (RE_Get_Local_Partition_Id)),
2872 Pack_Node_Into_Stream_Access (Loc,
2873 Stream => Stream_Parameter,
2874 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2875 Etyp => RTE (RE_Unsigned_64)),
2877 Pack_Node_Into_Stream_Access (Loc,
2878 Stream => Stream_Parameter,
2879 Object => OK_Convert_To (RTE (RE_Unsigned_64),
2880 Make_Attribute_Reference (Loc,
2881 Prefix =>
2882 Make_Explicit_Dereference (Loc,
2883 Prefix => Object),
2884 Attribute_Name => Name_Address)),
2885 Etyp => RTE (RE_Unsigned_64)));
2887 -- Build the code fragment corresponding to the marshalling of
2888 -- a remote object.
2890 Remote_Statements := New_List (
2892 Pack_Node_Into_Stream_Access (Loc,
2893 Stream => Stream_Parameter,
2894 Object =>
2895 Make_Selected_Component (Loc,
2896 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2897 Object),
2898 Selector_Name =>
2899 Make_Identifier (Loc, Name_Origin)),
2900 Etyp => RTE (RE_Partition_ID)),
2902 Pack_Node_Into_Stream_Access (Loc,
2903 Stream => Stream_Parameter,
2904 Object =>
2905 Make_Selected_Component (Loc,
2906 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2907 Object),
2908 Selector_Name =>
2909 Make_Identifier (Loc, Name_Receiver)),
2910 Etyp => RTE (RE_Unsigned_64)),
2912 Pack_Node_Into_Stream_Access (Loc,
2913 Stream => Stream_Parameter,
2914 Object =>
2915 Make_Selected_Component (Loc,
2916 Prefix => Unchecked_Convert_To (Stub_Type_Access,
2917 Object),
2918 Selector_Name =>
2919 Make_Identifier (Loc, Name_Addr)),
2920 Etyp => RTE (RE_Unsigned_64)));
2922 -- Build code fragment corresponding to marshalling of a null object
2924 Null_Statements := New_List (
2926 Pack_Entity_Into_Stream_Access (Loc,
2927 Stream => Stream_Parameter,
2928 Object => RTE (RE_Get_Local_Partition_Id)),
2930 Pack_Node_Into_Stream_Access (Loc,
2931 Stream => Stream_Parameter,
2932 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
2933 Etyp => RTE (RE_Unsigned_64)),
2935 Pack_Node_Into_Stream_Access (Loc,
2936 Stream => Stream_Parameter,
2937 Object => Make_Integer_Literal (Loc, Uint_0),
2938 Etyp => RTE (RE_Unsigned_64)));
2940 Statements := New_List (
2941 Make_Implicit_If_Statement (RACW_Type,
2942 Condition =>
2943 Make_Op_Eq (Loc,
2944 Left_Opnd => Object,
2945 Right_Opnd => Make_Null (Loc)),
2946 Then_Statements => Null_Statements,
2947 Elsif_Parts => New_List (
2948 Make_Elsif_Part (Loc,
2949 Condition =>
2950 Make_Op_Eq (Loc,
2951 Left_Opnd =>
2952 Make_Attribute_Reference (Loc,
2953 Prefix => Object,
2954 Attribute_Name => Name_Tag),
2955 Right_Opnd =>
2956 Make_Attribute_Reference (Loc,
2957 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2958 Attribute_Name => Name_Tag)),
2959 Then_Statements => Remote_Statements)),
2960 Else_Statements => Local_Statements));
2962 Build_Stream_Procedure
2963 (Loc, RACW_Type, Body_Node,
2964 Make_Defining_Identifier (Loc, Procedure_Name),
2965 Statements, Outp => False);
2967 Proc_Decl := Make_Subprogram_Declaration (Loc,
2968 Copy_Specification (Loc, Specification (Body_Node)));
2970 Attr_Decl :=
2971 Make_Attribute_Definition_Clause (Loc,
2972 Name => New_Occurrence_Of (RACW_Type, Loc),
2973 Chars => Name_Write,
2974 Expression =>
2975 New_Occurrence_Of (
2976 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
2978 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
2979 Insert_After (Proc_Decl, Attr_Decl);
2980 Append_To (Declarations, Body_Node);
2981 end Add_RACW_Write_Attribute;
2983 ------------------------
2984 -- Add_RAS_Access_TSS --
2985 ------------------------
2987 procedure Add_RAS_Access_TSS (N : Node_Id) is
2988 Loc : constant Source_Ptr := Sloc (N);
2990 Ras_Type : constant Entity_Id := Defining_Identifier (N);
2991 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
2992 -- Ras_Type is the access to subprogram type while Fat_Type is the
2993 -- corresponding record type.
2995 RACW_Type : constant Entity_Id :=
2996 Underlying_RACW_Type (Ras_Type);
2997 Desig : constant Entity_Id :=
2998 Etype (Designated_Type (RACW_Type));
3000 Stub_Elements : constant Stub_Structure :=
3001 Stubs_Table.Get (Desig);
3002 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3004 Proc : constant Entity_Id :=
3005 Make_Defining_Identifier (Loc,
3006 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3008 Proc_Spec : Node_Id;
3010 -- Formal parameters
3012 Package_Name : constant Entity_Id :=
3013 Make_Defining_Identifier (Loc,
3014 Chars => Name_P);
3015 -- Target package
3017 Subp_Id : constant Entity_Id :=
3018 Make_Defining_Identifier (Loc,
3019 Chars => Name_S);
3020 -- Target subprogram
3022 Asynch_P : constant Entity_Id :=
3023 Make_Defining_Identifier (Loc,
3024 Chars => Name_Asynchronous);
3025 -- Is the procedure to which the 'Access applies asynchronous?
3027 All_Calls_Remote : constant Entity_Id :=
3028 Make_Defining_Identifier (Loc,
3029 Chars => Name_All_Calls_Remote);
3030 -- True if an All_Calls_Remote pragma applies to the RCI unit
3031 -- that contains the subprogram.
3033 -- Common local variables
3035 Proc_Decls : List_Id;
3036 Proc_Statements : List_Id;
3038 Origin : constant Entity_Id :=
3039 Make_Defining_Identifier (Loc,
3040 Chars => New_Internal_Name ('P'));
3042 -- Additional local variables for the local case
3044 Proxy_Addr : constant Entity_Id :=
3045 Make_Defining_Identifier (Loc,
3046 Chars => New_Internal_Name ('P'));
3048 -- Additional local variables for the remote case
3050 Local_Stub : constant Entity_Id :=
3051 Make_Defining_Identifier (Loc,
3052 Chars => New_Internal_Name ('L'));
3054 Stub_Ptr : constant Entity_Id :=
3055 Make_Defining_Identifier (Loc,
3056 Chars => New_Internal_Name ('S'));
3058 function Set_Field
3059 (Field_Name : Name_Id;
3060 Value : Node_Id) return Node_Id;
3061 -- Construct an assignment that sets the named component in the
3062 -- returned record
3064 ---------------
3065 -- Set_Field --
3066 ---------------
3068 function Set_Field
3069 (Field_Name : Name_Id;
3070 Value : Node_Id) return Node_Id
3072 begin
3073 return
3074 Make_Assignment_Statement (Loc,
3075 Name =>
3076 Make_Selected_Component (Loc,
3077 Prefix => Stub_Ptr,
3078 Selector_Name => Field_Name),
3079 Expression => Value);
3080 end Set_Field;
3082 -- Start of processing for Add_RAS_Access_TSS
3084 begin
3085 Proc_Decls := New_List (
3087 -- Common declarations
3089 Make_Object_Declaration (Loc,
3090 Defining_Identifier => Origin,
3091 Constant_Present => True,
3092 Object_Definition =>
3093 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3094 Expression =>
3095 Make_Function_Call (Loc,
3096 Name =>
3097 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3098 Parameter_Associations => New_List (
3099 New_Occurrence_Of (Package_Name, Loc)))),
3101 -- Declaration use only in the local case: proxy address
3103 Make_Object_Declaration (Loc,
3104 Defining_Identifier => Proxy_Addr,
3105 Object_Definition =>
3106 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3108 -- Declarations used only in the remote case: stub object and
3109 -- stub pointer.
3111 Make_Object_Declaration (Loc,
3112 Defining_Identifier => Local_Stub,
3113 Aliased_Present => True,
3114 Object_Definition =>
3115 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3117 Make_Object_Declaration (Loc,
3118 Defining_Identifier =>
3119 Stub_Ptr,
3120 Object_Definition =>
3121 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3122 Expression =>
3123 Make_Attribute_Reference (Loc,
3124 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3125 Attribute_Name => Name_Unchecked_Access)));
3127 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3128 -- Build_Get_Unique_RP_Call needs this information
3130 -- Note: Here we assume that the Fat_Type is a record
3131 -- containing just a pointer to a proxy or stub object.
3133 Proc_Statements := New_List (
3135 -- Generate:
3137 -- Get_RAS_Info (Pkg, Subp, PA);
3138 -- if Origin = Local_Partition_Id
3139 -- and then not All_Calls_Remote
3140 -- then
3141 -- return Fat_Type!(PA);
3142 -- end if;
3144 Make_Procedure_Call_Statement (Loc,
3145 Name =>
3146 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3147 Parameter_Associations => New_List (
3148 New_Occurrence_Of (Package_Name, Loc),
3149 New_Occurrence_Of (Subp_Id, Loc),
3150 New_Occurrence_Of (Proxy_Addr, Loc))),
3152 Make_Implicit_If_Statement (N,
3153 Condition =>
3154 Make_And_Then (Loc,
3155 Left_Opnd =>
3156 Make_Op_Eq (Loc,
3157 Left_Opnd =>
3158 New_Occurrence_Of (Origin, Loc),
3159 Right_Opnd =>
3160 Make_Function_Call (Loc,
3161 New_Occurrence_Of (
3162 RTE (RE_Get_Local_Partition_Id), Loc))),
3163 Right_Opnd =>
3164 Make_Op_Not (Loc,
3165 New_Occurrence_Of (All_Calls_Remote, Loc))),
3166 Then_Statements => New_List (
3167 Make_Return_Statement (Loc,
3168 Unchecked_Convert_To (Fat_Type,
3169 OK_Convert_To (RTE (RE_Address),
3170 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3172 Set_Field (Name_Origin,
3173 New_Occurrence_Of (Origin, Loc)),
3175 Set_Field (Name_Receiver,
3176 Make_Function_Call (Loc,
3177 Name =>
3178 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3179 Parameter_Associations => New_List (
3180 New_Occurrence_Of (Package_Name, Loc)))),
3182 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3184 -- E.4.1(9) A remote call is asynchronous if it is a call to
3185 -- a procedure, or a call through a value of an access-to-procedure
3186 -- type, to which a pragma Asynchronous applies.
3188 -- Parameter Asynch_P is true when the procedure is asynchronous;
3189 -- Expression Asynch_T is true when the type is asynchronous.
3191 Set_Field (Name_Asynchronous,
3192 Make_Or_Else (Loc,
3193 New_Occurrence_Of (Asynch_P, Loc),
3194 New_Occurrence_Of (Boolean_Literals (
3195 Is_Asynchronous (Ras_Type)), Loc))));
3197 Append_List_To (Proc_Statements,
3198 Build_Get_Unique_RP_Call
3199 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3201 -- Return the newly created value
3203 Append_To (Proc_Statements,
3204 Make_Return_Statement (Loc,
3205 Expression =>
3206 Unchecked_Convert_To (Fat_Type,
3207 New_Occurrence_Of (Stub_Ptr, Loc))));
3209 Proc_Spec :=
3210 Make_Function_Specification (Loc,
3211 Defining_Unit_Name => Proc,
3212 Parameter_Specifications => New_List (
3213 Make_Parameter_Specification (Loc,
3214 Defining_Identifier => Package_Name,
3215 Parameter_Type =>
3216 New_Occurrence_Of (Standard_String, Loc)),
3218 Make_Parameter_Specification (Loc,
3219 Defining_Identifier => Subp_Id,
3220 Parameter_Type =>
3221 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3223 Make_Parameter_Specification (Loc,
3224 Defining_Identifier => Asynch_P,
3225 Parameter_Type =>
3226 New_Occurrence_Of (Standard_Boolean, Loc)),
3228 Make_Parameter_Specification (Loc,
3229 Defining_Identifier => All_Calls_Remote,
3230 Parameter_Type =>
3231 New_Occurrence_Of (Standard_Boolean, Loc))),
3233 Result_Definition =>
3234 New_Occurrence_Of (Fat_Type, Loc));
3236 -- Set the kind and return type of the function to prevent
3237 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3239 Set_Ekind (Proc, E_Function);
3240 Set_Etype (Proc, Fat_Type);
3242 Discard_Node (
3243 Make_Subprogram_Body (Loc,
3244 Specification => Proc_Spec,
3245 Declarations => Proc_Decls,
3246 Handled_Statement_Sequence =>
3247 Make_Handled_Sequence_Of_Statements (Loc,
3248 Statements => Proc_Statements)));
3250 Set_TSS (Fat_Type, Proc);
3251 end Add_RAS_Access_TSS;
3253 -----------------------
3254 -- Add_RAST_Features --
3255 -----------------------
3257 procedure Add_RAST_Features
3258 (Vis_Decl : Node_Id;
3259 RAS_Type : Entity_Id)
3261 pragma Warnings (Off);
3262 pragma Unreferenced (RAS_Type);
3263 pragma Warnings (On);
3264 begin
3265 Add_RAS_Access_TSS (Vis_Decl);
3266 end Add_RAST_Features;
3268 -----------------------------------------
3269 -- Add_Receiving_Stubs_To_Declarations --
3270 -----------------------------------------
3272 procedure Add_Receiving_Stubs_To_Declarations
3273 (Pkg_Spec : Node_Id;
3274 Decls : List_Id)
3276 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3278 Request_Parameter : Node_Id;
3280 Pkg_RPC_Receiver : constant Entity_Id :=
3281 Make_Defining_Identifier (Loc,
3282 New_Internal_Name ('H'));
3283 Pkg_RPC_Receiver_Statements : List_Id;
3284 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3285 Pkg_RPC_Receiver_Body : Node_Id;
3286 -- A Pkg_RPC_Receiver is built to decode the request
3288 Lookup_RAS_Info : constant Entity_Id :=
3289 Make_Defining_Identifier (Loc,
3290 Chars => New_Internal_Name ('R'));
3291 -- A remote subprogram is created to allow peers to look up
3292 -- RAS information using subprogram ids.
3294 Subp_Id : Entity_Id;
3295 Subp_Index : Entity_Id;
3296 -- Subprogram_Id as read from the incoming stream
3298 Current_Declaration : Node_Id;
3299 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
3300 Current_Stubs : Node_Id;
3302 Subp_Info_Array : constant Entity_Id :=
3303 Make_Defining_Identifier (Loc,
3304 Chars => New_Internal_Name ('I'));
3306 Subp_Info_List : constant List_Id := New_List;
3308 Register_Pkg_Actuals : constant List_Id := New_List;
3310 All_Calls_Remote_E : Entity_Id;
3311 Proxy_Object_Addr : Entity_Id;
3313 procedure Append_Stubs_To
3314 (RPC_Receiver_Cases : List_Id;
3315 Stubs : Node_Id;
3316 Subprogram_Number : Int);
3317 -- Add one case to the specified RPC receiver case list
3318 -- associating Subprogram_Number with the subprogram declared
3319 -- by Declaration, for which we have receiving stubs in Stubs.
3321 ---------------------
3322 -- Append_Stubs_To --
3323 ---------------------
3325 procedure Append_Stubs_To
3326 (RPC_Receiver_Cases : List_Id;
3327 Stubs : Node_Id;
3328 Subprogram_Number : Int)
3330 begin
3331 Append_To (RPC_Receiver_Cases,
3332 Make_Case_Statement_Alternative (Loc,
3333 Discrete_Choices =>
3334 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3335 Statements =>
3336 New_List (
3337 Make_Procedure_Call_Statement (Loc,
3338 Name =>
3339 New_Occurrence_Of (
3340 Defining_Entity (Stubs), Loc),
3341 Parameter_Associations => New_List (
3342 New_Occurrence_Of (Request_Parameter, Loc))))));
3343 end Append_Stubs_To;
3345 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3347 begin
3348 -- Building receiving stubs consist in several operations:
3350 -- - a package RPC receiver must be built. This subprogram
3351 -- will get a Subprogram_Id from the incoming stream
3352 -- and will dispatch the call to the right subprogram
3354 -- - a receiving stub for any subprogram visible in the package
3355 -- spec. This stub will read all the parameters from the stream,
3356 -- and put the result as well as the exception occurrence in the
3357 -- output stream
3359 -- - a dummy package with an empty spec and a body made of an
3360 -- elaboration part, whose job is to register the receiving
3361 -- part of this RCI package on the name server. This is done
3362 -- by calling System.Partition_Interface.Register_Receiving_Stub
3364 Build_RPC_Receiver_Body (
3365 RPC_Receiver => Pkg_RPC_Receiver,
3366 Request => Request_Parameter,
3367 Subp_Id => Subp_Id,
3368 Subp_Index => Subp_Index,
3369 Stmts => Pkg_RPC_Receiver_Statements,
3370 Decl => Pkg_RPC_Receiver_Body);
3371 pragma Assert (Subp_Id = Subp_Index);
3373 -- A null subp_id denotes a call through a RAS, in which case the
3374 -- next Uint_64 element in the stream is the address of the local
3375 -- proxy object, from which we can retrieve the actual subprogram id.
3377 Append_To (Pkg_RPC_Receiver_Statements,
3378 Make_Implicit_If_Statement (Pkg_Spec,
3379 Condition =>
3380 Make_Op_Eq (Loc,
3381 New_Occurrence_Of (Subp_Id, Loc),
3382 Make_Integer_Literal (Loc, 0)),
3383 Then_Statements => New_List (
3384 Make_Assignment_Statement (Loc,
3385 Name =>
3386 New_Occurrence_Of (Subp_Id, Loc),
3387 Expression =>
3388 Make_Selected_Component (Loc,
3389 Prefix =>
3390 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3391 OK_Convert_To (RTE (RE_Address),
3392 Make_Attribute_Reference (Loc,
3393 Prefix =>
3394 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3395 Attribute_Name =>
3396 Name_Input,
3397 Expressions => New_List (
3398 Make_Selected_Component (Loc,
3399 Prefix => Request_Parameter,
3400 Selector_Name => Name_Params))))),
3401 Selector_Name =>
3402 Make_Identifier (Loc, Name_Subp_Id))))));
3404 -- Build a subprogram for RAS information lookups
3406 Current_Declaration :=
3407 Make_Subprogram_Declaration (Loc,
3408 Specification =>
3409 Make_Function_Specification (Loc,
3410 Defining_Unit_Name =>
3411 Lookup_RAS_Info,
3412 Parameter_Specifications => New_List (
3413 Make_Parameter_Specification (Loc,
3414 Defining_Identifier =>
3415 Make_Defining_Identifier (Loc, Name_Subp_Id),
3416 In_Present =>
3417 True,
3418 Parameter_Type =>
3419 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3420 Result_Definition =>
3421 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3422 Append_To (Decls, Current_Declaration);
3423 Analyze (Current_Declaration);
3425 Current_Stubs := Build_Subprogram_Receiving_Stubs
3426 (Vis_Decl => Current_Declaration,
3427 Asynchronous => False);
3428 Append_To (Decls, Current_Stubs);
3429 Analyze (Current_Stubs);
3431 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3432 Stubs =>
3433 Current_Stubs,
3434 Subprogram_Number => 1);
3436 -- For each subprogram, the receiving stub will be built and a
3437 -- case statement will be made on the Subprogram_Id to dispatch
3438 -- to the right subprogram.
3440 All_Calls_Remote_E := Boolean_Literals (
3441 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
3443 Overload_Counter_Table.Reset;
3445 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
3446 while Present (Current_Declaration) loop
3447 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3448 and then Comes_From_Source (Current_Declaration)
3449 then
3450 declare
3451 Loc : constant Source_Ptr :=
3452 Sloc (Current_Declaration);
3453 -- While specifically processing Current_Declaration, use
3454 -- its Sloc as the location of all generated nodes.
3456 Subp_Def : constant Entity_Id :=
3457 Defining_Unit_Name
3458 (Specification (Current_Declaration));
3460 Subp_Val : String_Id;
3462 begin
3463 pragma Assert (Current_Subprogram_Number =
3464 Get_Subprogram_Id (Subp_Def));
3466 -- Build receiving stub
3468 Current_Stubs :=
3469 Build_Subprogram_Receiving_Stubs
3470 (Vis_Decl => Current_Declaration,
3471 Asynchronous =>
3472 Nkind (Specification (Current_Declaration)) =
3473 N_Procedure_Specification
3474 and then Is_Asynchronous (Subp_Def));
3476 Append_To (Decls, Current_Stubs);
3477 Analyze (Current_Stubs);
3479 -- Build RAS proxy
3481 Add_RAS_Proxy_And_Analyze (Decls,
3482 Vis_Decl =>
3483 Current_Declaration,
3484 All_Calls_Remote_E =>
3485 All_Calls_Remote_E,
3486 Proxy_Object_Addr =>
3487 Proxy_Object_Addr);
3489 -- Compute distribution identifier
3491 Assign_Subprogram_Identifier (
3492 Subp_Def,
3493 Current_Subprogram_Number,
3494 Subp_Val);
3496 -- Add subprogram descriptor (RCI_Subp_Info) to the
3497 -- subprograms table for this receiver. The aggregate
3498 -- below must be kept consistent with the declaration
3499 -- of type RCI_Subp_Info in System.Partition_Interface.
3501 Append_To (Subp_Info_List,
3502 Make_Component_Association (Loc,
3503 Choices => New_List (
3504 Make_Integer_Literal (Loc,
3505 Current_Subprogram_Number)),
3506 Expression =>
3507 Make_Aggregate (Loc,
3508 Component_Associations => New_List (
3509 Make_Component_Association (Loc,
3510 Choices => New_List (
3511 Make_Identifier (Loc, Name_Addr)),
3512 Expression =>
3513 New_Occurrence_Of (
3514 Proxy_Object_Addr, Loc))))));
3516 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3517 Stubs =>
3518 Current_Stubs,
3519 Subprogram_Number =>
3520 Current_Subprogram_Number);
3521 end;
3523 Current_Subprogram_Number := Current_Subprogram_Number + 1;
3524 end if;
3526 Next (Current_Declaration);
3527 end loop;
3529 -- If we receive an invalid Subprogram_Id, it is best to do nothing
3530 -- rather than raising an exception since we do not want someone
3531 -- to crash a remote partition by sending invalid subprogram ids.
3532 -- This is consistent with the other parts of the case statement
3533 -- since even in presence of incorrect parameters in the stream,
3534 -- every exception will be caught and (if the subprogram is not an
3535 -- APC) put into the result stream and sent away.
3537 Append_To (Pkg_RPC_Receiver_Cases,
3538 Make_Case_Statement_Alternative (Loc,
3539 Discrete_Choices =>
3540 New_List (Make_Others_Choice (Loc)),
3541 Statements =>
3542 New_List (Make_Null_Statement (Loc))));
3544 Append_To (Pkg_RPC_Receiver_Statements,
3545 Make_Case_Statement (Loc,
3546 Expression =>
3547 New_Occurrence_Of (Subp_Id, Loc),
3548 Alternatives => Pkg_RPC_Receiver_Cases));
3550 Append_To (Decls,
3551 Make_Object_Declaration (Loc,
3552 Defining_Identifier => Subp_Info_Array,
3553 Constant_Present => True,
3554 Aliased_Present => True,
3555 Object_Definition =>
3556 Make_Subtype_Indication (Loc,
3557 Subtype_Mark =>
3558 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
3559 Constraint =>
3560 Make_Index_Or_Discriminant_Constraint (Loc,
3561 New_List (
3562 Make_Range (Loc,
3563 Low_Bound => Make_Integer_Literal (Loc,
3564 First_RCI_Subprogram_Id),
3565 High_Bound =>
3566 Make_Integer_Literal (Loc,
3567 First_RCI_Subprogram_Id
3568 + List_Length (Subp_Info_List) - 1))))),
3569 Expression =>
3570 Make_Aggregate (Loc,
3571 Component_Associations => Subp_Info_List)));
3572 Analyze (Last (Decls));
3574 Append_To (Decls,
3575 Make_Subprogram_Body (Loc,
3576 Specification =>
3577 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
3578 Declarations =>
3579 No_List,
3580 Handled_Statement_Sequence =>
3581 Make_Handled_Sequence_Of_Statements (Loc,
3582 Statements => New_List (
3583 Make_Return_Statement (Loc,
3584 Expression => OK_Convert_To (RTE (RE_Unsigned_64),
3585 Make_Selected_Component (Loc,
3586 Prefix =>
3587 Make_Indexed_Component (Loc,
3588 Prefix =>
3589 New_Occurrence_Of (Subp_Info_Array, Loc),
3590 Expressions => New_List (
3591 Convert_To (Standard_Integer,
3592 Make_Identifier (Loc, Name_Subp_Id)))),
3593 Selector_Name =>
3594 Make_Identifier (Loc, Name_Addr))))))));
3595 Analyze (Last (Decls));
3597 Append_To (Decls, Pkg_RPC_Receiver_Body);
3598 Analyze (Last (Decls));
3600 Get_Library_Unit_Name_String (Pkg_Spec);
3601 Append_To (Register_Pkg_Actuals,
3602 -- Name
3603 Make_String_Literal (Loc,
3604 Strval => String_From_Name_Buffer));
3606 Append_To (Register_Pkg_Actuals,
3607 -- Receiver
3608 Make_Attribute_Reference (Loc,
3609 Prefix =>
3610 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
3611 Attribute_Name =>
3612 Name_Unrestricted_Access));
3614 Append_To (Register_Pkg_Actuals,
3615 -- Version
3616 Make_Attribute_Reference (Loc,
3617 Prefix =>
3618 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
3619 Attribute_Name =>
3620 Name_Version));
3622 Append_To (Register_Pkg_Actuals,
3623 -- Subp_Info
3624 Make_Attribute_Reference (Loc,
3625 Prefix =>
3626 New_Occurrence_Of (Subp_Info_Array, Loc),
3627 Attribute_Name =>
3628 Name_Address));
3630 Append_To (Register_Pkg_Actuals,
3631 -- Subp_Info_Len
3632 Make_Attribute_Reference (Loc,
3633 Prefix =>
3634 New_Occurrence_Of (Subp_Info_Array, Loc),
3635 Attribute_Name =>
3636 Name_Length));
3638 Append_To (Decls,
3639 Make_Procedure_Call_Statement (Loc,
3640 Name =>
3641 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
3642 Parameter_Associations => Register_Pkg_Actuals));
3643 Analyze (Last (Decls));
3644 end Add_Receiving_Stubs_To_Declarations;
3646 ---------------------------------
3647 -- Build_General_Calling_Stubs --
3648 ---------------------------------
3650 procedure Build_General_Calling_Stubs
3651 (Decls : List_Id;
3652 Statements : List_Id;
3653 Target_Partition : Entity_Id;
3654 Target_RPC_Receiver : Node_Id;
3655 Subprogram_Id : Node_Id;
3656 Asynchronous : Node_Id := Empty;
3657 Is_Known_Asynchronous : Boolean := False;
3658 Is_Known_Non_Asynchronous : Boolean := False;
3659 Is_Function : Boolean;
3660 Spec : Node_Id;
3661 Stub_Type : Entity_Id := Empty;
3662 RACW_Type : Entity_Id := Empty;
3663 Nod : Node_Id)
3665 Loc : constant Source_Ptr := Sloc (Nod);
3667 Stream_Parameter : Node_Id;
3668 -- Name of the stream used to transmit parameters to the
3669 -- remote package.
3671 Result_Parameter : Node_Id;
3672 -- Name of the result parameter (in non-APC cases) which get the
3673 -- result of the remote subprogram.
3675 Exception_Return_Parameter : Node_Id;
3676 -- Name of the parameter which will hold the exception sent by the
3677 -- remote subprogram.
3679 Current_Parameter : Node_Id;
3680 -- Current parameter being handled
3682 Ordered_Parameters_List : constant List_Id :=
3683 Build_Ordered_Parameters_List (Spec);
3685 Asynchronous_Statements : List_Id := No_List;
3686 Non_Asynchronous_Statements : List_Id := No_List;
3687 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
3689 Extra_Formal_Statements : constant List_Id := New_List;
3690 -- List of statements for extra formal parameters. It will appear
3691 -- after the regular statements for writing out parameters.
3693 pragma Warnings (Off);
3694 pragma Unreferenced (RACW_Type);
3695 -- Used only for the PolyORB case
3696 pragma Warnings (On);
3698 begin
3699 -- The general form of a calling stub for a given subprogram is:
3701 -- procedure X (...) is P : constant Partition_ID :=
3702 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
3703 -- System.RPC.Params_Stream_Type (0); begin
3704 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
3705 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
3706 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
3707 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
3708 -- Raise_It;
3709 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
3711 -- There are some variations: Do_APC is called for an asynchronous
3712 -- procedure and the part after the call is completely ommitted as
3713 -- well as the declaration of Result. For a function call, 'Input is
3714 -- always used to read the result even if it is constrained.
3716 Stream_Parameter :=
3717 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3719 Append_To (Decls,
3720 Make_Object_Declaration (Loc,
3721 Defining_Identifier => Stream_Parameter,
3722 Aliased_Present => True,
3723 Object_Definition =>
3724 Make_Subtype_Indication (Loc,
3725 Subtype_Mark =>
3726 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
3727 Constraint =>
3728 Make_Index_Or_Discriminant_Constraint (Loc,
3729 Constraints =>
3730 New_List (Make_Integer_Literal (Loc, 0))))));
3732 if not Is_Known_Asynchronous then
3733 Result_Parameter :=
3734 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3736 Append_To (Decls,
3737 Make_Object_Declaration (Loc,
3738 Defining_Identifier => Result_Parameter,
3739 Aliased_Present => True,
3740 Object_Definition =>
3741 Make_Subtype_Indication (Loc,
3742 Subtype_Mark =>
3743 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
3744 Constraint =>
3745 Make_Index_Or_Discriminant_Constraint (Loc,
3746 Constraints =>
3747 New_List (Make_Integer_Literal (Loc, 0))))));
3749 Exception_Return_Parameter :=
3750 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3752 Append_To (Decls,
3753 Make_Object_Declaration (Loc,
3754 Defining_Identifier => Exception_Return_Parameter,
3755 Object_Definition =>
3756 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
3758 else
3759 Result_Parameter := Empty;
3760 Exception_Return_Parameter := Empty;
3761 end if;
3763 -- Put first the RPC receiver corresponding to the remote package
3765 Append_To (Statements,
3766 Make_Attribute_Reference (Loc,
3767 Prefix =>
3768 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3769 Attribute_Name => Name_Write,
3770 Expressions => New_List (
3771 Make_Attribute_Reference (Loc,
3772 Prefix =>
3773 New_Occurrence_Of (Stream_Parameter, Loc),
3774 Attribute_Name =>
3775 Name_Access),
3776 Target_RPC_Receiver)));
3778 -- Then put the Subprogram_Id of the subprogram we want to call in
3779 -- the stream.
3781 Append_To (Statements,
3782 Make_Attribute_Reference (Loc,
3783 Prefix =>
3784 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
3785 Attribute_Name =>
3786 Name_Write,
3787 Expressions => New_List (
3788 Make_Attribute_Reference (Loc,
3789 Prefix =>
3790 New_Occurrence_Of (Stream_Parameter, Loc),
3791 Attribute_Name => Name_Access),
3792 Subprogram_Id)));
3794 Current_Parameter := First (Ordered_Parameters_List);
3795 while Present (Current_Parameter) loop
3796 declare
3797 Typ : constant Node_Id :=
3798 Parameter_Type (Current_Parameter);
3799 Etyp : Entity_Id;
3800 Constrained : Boolean;
3801 Value : Node_Id;
3802 Extra_Parameter : Entity_Id;
3804 begin
3805 if Is_RACW_Controlling_Formal
3806 (Current_Parameter, Stub_Type)
3807 then
3808 -- In the case of a controlling formal argument, we marshall
3809 -- its addr field rather than the local stub.
3811 Append_To (Statements,
3812 Pack_Node_Into_Stream (Loc,
3813 Stream => Stream_Parameter,
3814 Object =>
3815 Make_Selected_Component (Loc,
3816 Prefix =>
3817 Defining_Identifier (Current_Parameter),
3818 Selector_Name => Name_Addr),
3819 Etyp => RTE (RE_Unsigned_64)));
3821 else
3822 Value := New_Occurrence_Of
3823 (Defining_Identifier (Current_Parameter), Loc);
3825 -- Access type parameters are transmitted as in out
3826 -- parameters. However, a dereference is needed so that
3827 -- we marshall the designated object.
3829 if Nkind (Typ) = N_Access_Definition then
3830 Value := Make_Explicit_Dereference (Loc, Value);
3831 Etyp := Etype (Subtype_Mark (Typ));
3832 else
3833 Etyp := Etype (Typ);
3834 end if;
3836 Constrained :=
3837 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
3839 -- Any parameter but unconstrained out parameters are
3840 -- transmitted to the peer.
3842 if In_Present (Current_Parameter)
3843 or else not Out_Present (Current_Parameter)
3844 or else not Constrained
3845 then
3846 Append_To (Statements,
3847 Make_Attribute_Reference (Loc,
3848 Prefix =>
3849 New_Occurrence_Of (Etyp, Loc),
3850 Attribute_Name =>
3851 Output_From_Constrained (Constrained),
3852 Expressions => New_List (
3853 Make_Attribute_Reference (Loc,
3854 Prefix =>
3855 New_Occurrence_Of (Stream_Parameter, Loc),
3856 Attribute_Name => Name_Access),
3857 Value)));
3858 end if;
3859 end if;
3861 -- If the current parameter has a dynamic constrained status,
3862 -- then this status is transmitted as well.
3863 -- This should be done for accessibility as well ???
3865 if Nkind (Typ) /= N_Access_Definition
3866 and then Need_Extra_Constrained (Current_Parameter)
3867 then
3868 -- In this block, we do not use the extra formal that has
3869 -- been created because it does not exist at the time of
3870 -- expansion when building calling stubs for remote access
3871 -- to subprogram types. We create an extra variable of this
3872 -- type and push it in the stream after the regular
3873 -- parameters.
3875 Extra_Parameter := Make_Defining_Identifier
3876 (Loc, New_Internal_Name ('P'));
3878 Append_To (Decls,
3879 Make_Object_Declaration (Loc,
3880 Defining_Identifier => Extra_Parameter,
3881 Constant_Present => True,
3882 Object_Definition =>
3883 New_Occurrence_Of (Standard_Boolean, Loc),
3884 Expression =>
3885 Make_Attribute_Reference (Loc,
3886 Prefix =>
3887 New_Occurrence_Of (
3888 Defining_Identifier (Current_Parameter), Loc),
3889 Attribute_Name => Name_Constrained)));
3891 Append_To (Extra_Formal_Statements,
3892 Make_Attribute_Reference (Loc,
3893 Prefix =>
3894 New_Occurrence_Of (Standard_Boolean, Loc),
3895 Attribute_Name =>
3896 Name_Write,
3897 Expressions => New_List (
3898 Make_Attribute_Reference (Loc,
3899 Prefix =>
3900 New_Occurrence_Of (Stream_Parameter, Loc),
3901 Attribute_Name =>
3902 Name_Access),
3903 New_Occurrence_Of (Extra_Parameter, Loc))));
3904 end if;
3906 Next (Current_Parameter);
3907 end;
3908 end loop;
3910 -- Append the formal statements list to the statements
3912 Append_List_To (Statements, Extra_Formal_Statements);
3914 if not Is_Known_Non_Asynchronous then
3916 -- Build the call to System.RPC.Do_APC
3918 Asynchronous_Statements := New_List (
3919 Make_Procedure_Call_Statement (Loc,
3920 Name =>
3921 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
3922 Parameter_Associations => New_List (
3923 New_Occurrence_Of (Target_Partition, Loc),
3924 Make_Attribute_Reference (Loc,
3925 Prefix =>
3926 New_Occurrence_Of (Stream_Parameter, Loc),
3927 Attribute_Name =>
3928 Name_Access))));
3929 else
3930 Asynchronous_Statements := No_List;
3931 end if;
3933 if not Is_Known_Asynchronous then
3935 -- Build the call to System.RPC.Do_RPC
3937 Non_Asynchronous_Statements := New_List (
3938 Make_Procedure_Call_Statement (Loc,
3939 Name =>
3940 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
3941 Parameter_Associations => New_List (
3942 New_Occurrence_Of (Target_Partition, Loc),
3944 Make_Attribute_Reference (Loc,
3945 Prefix =>
3946 New_Occurrence_Of (Stream_Parameter, Loc),
3947 Attribute_Name =>
3948 Name_Access),
3950 Make_Attribute_Reference (Loc,
3951 Prefix =>
3952 New_Occurrence_Of (Result_Parameter, Loc),
3953 Attribute_Name =>
3954 Name_Access))));
3956 -- Read the exception occurrence from the result stream and
3957 -- reraise it. It does no harm if this is a Null_Occurrence since
3958 -- this does nothing.
3960 Append_To (Non_Asynchronous_Statements,
3961 Make_Attribute_Reference (Loc,
3962 Prefix =>
3963 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
3965 Attribute_Name =>
3966 Name_Read,
3968 Expressions => New_List (
3969 Make_Attribute_Reference (Loc,
3970 Prefix =>
3971 New_Occurrence_Of (Result_Parameter, Loc),
3972 Attribute_Name =>
3973 Name_Access),
3974 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
3976 Append_To (Non_Asynchronous_Statements,
3977 Make_Procedure_Call_Statement (Loc,
3978 Name =>
3979 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
3980 Parameter_Associations => New_List (
3981 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
3983 if Is_Function then
3985 -- If this is a function call, then read the value and return
3986 -- it. The return value is written/read using 'Output/'Input.
3988 Append_To (Non_Asynchronous_Statements,
3989 Make_Tag_Check (Loc,
3990 Make_Return_Statement (Loc,
3991 Expression =>
3992 Make_Attribute_Reference (Loc,
3993 Prefix =>
3994 New_Occurrence_Of (
3995 Etype (Result_Definition (Spec)), Loc),
3997 Attribute_Name => Name_Input,
3999 Expressions => New_List (
4000 Make_Attribute_Reference (Loc,
4001 Prefix =>
4002 New_Occurrence_Of (Result_Parameter, Loc),
4003 Attribute_Name => Name_Access))))));
4005 else
4006 -- Loop around parameters and assign out (or in out)
4007 -- parameters. In the case of RACW, controlling arguments
4008 -- cannot possibly have changed since they are remote, so we do
4009 -- not read them from the stream.
4011 Current_Parameter := First (Ordered_Parameters_List);
4012 while Present (Current_Parameter) loop
4013 declare
4014 Typ : constant Node_Id :=
4015 Parameter_Type (Current_Parameter);
4016 Etyp : Entity_Id;
4017 Value : Node_Id;
4019 begin
4020 Value :=
4021 New_Occurrence_Of
4022 (Defining_Identifier (Current_Parameter), Loc);
4024 if Nkind (Typ) = N_Access_Definition then
4025 Value := Make_Explicit_Dereference (Loc, Value);
4026 Etyp := Etype (Subtype_Mark (Typ));
4027 else
4028 Etyp := Etype (Typ);
4029 end if;
4031 if (Out_Present (Current_Parameter)
4032 or else Nkind (Typ) = N_Access_Definition)
4033 and then Etyp /= Stub_Type
4034 then
4035 Append_To (Non_Asynchronous_Statements,
4036 Make_Attribute_Reference (Loc,
4037 Prefix =>
4038 New_Occurrence_Of (Etyp, Loc),
4040 Attribute_Name => Name_Read,
4042 Expressions => New_List (
4043 Make_Attribute_Reference (Loc,
4044 Prefix =>
4045 New_Occurrence_Of (Result_Parameter, Loc),
4046 Attribute_Name =>
4047 Name_Access),
4048 Value)));
4049 end if;
4050 end;
4052 Next (Current_Parameter);
4053 end loop;
4054 end if;
4055 end if;
4057 if Is_Known_Asynchronous then
4058 Append_List_To (Statements, Asynchronous_Statements);
4060 elsif Is_Known_Non_Asynchronous then
4061 Append_List_To (Statements, Non_Asynchronous_Statements);
4063 else
4064 pragma Assert (Present (Asynchronous));
4065 Prepend_To (Asynchronous_Statements,
4066 Make_Attribute_Reference (Loc,
4067 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4068 Attribute_Name => Name_Write,
4069 Expressions => New_List (
4070 Make_Attribute_Reference (Loc,
4071 Prefix =>
4072 New_Occurrence_Of (Stream_Parameter, Loc),
4073 Attribute_Name => Name_Access),
4074 New_Occurrence_Of (Standard_True, Loc))));
4076 Prepend_To (Non_Asynchronous_Statements,
4077 Make_Attribute_Reference (Loc,
4078 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4079 Attribute_Name => Name_Write,
4080 Expressions => New_List (
4081 Make_Attribute_Reference (Loc,
4082 Prefix =>
4083 New_Occurrence_Of (Stream_Parameter, Loc),
4084 Attribute_Name => Name_Access),
4085 New_Occurrence_Of (Standard_False, Loc))));
4087 Append_To (Statements,
4088 Make_Implicit_If_Statement (Nod,
4089 Condition => Asynchronous,
4090 Then_Statements => Asynchronous_Statements,
4091 Else_Statements => Non_Asynchronous_Statements));
4092 end if;
4093 end Build_General_Calling_Stubs;
4095 -----------------------------
4096 -- Build_RPC_Receiver_Body --
4097 -----------------------------
4099 procedure Build_RPC_Receiver_Body
4100 (RPC_Receiver : Entity_Id;
4101 Request : out Entity_Id;
4102 Subp_Id : out Entity_Id;
4103 Subp_Index : out Entity_Id;
4104 Stmts : out List_Id;
4105 Decl : out Node_Id)
4107 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4109 RPC_Receiver_Spec : Node_Id;
4110 RPC_Receiver_Decls : List_Id;
4112 begin
4113 Request := Make_Defining_Identifier (Loc, Name_R);
4115 RPC_Receiver_Spec :=
4116 Build_RPC_Receiver_Specification
4117 (RPC_Receiver => RPC_Receiver,
4118 Request_Parameter => Request);
4120 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4121 Subp_Index := Subp_Id;
4123 -- Subp_Id may not be a constant, because in the case of the RPC
4124 -- receiver for an RCI package, when a call is received from a RAS
4125 -- dereference, it will be assigned during subsequent processing.
4127 RPC_Receiver_Decls := New_List (
4128 Make_Object_Declaration (Loc,
4129 Defining_Identifier => Subp_Id,
4130 Object_Definition =>
4131 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4132 Expression =>
4133 Make_Attribute_Reference (Loc,
4134 Prefix =>
4135 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4136 Attribute_Name => Name_Input,
4137 Expressions => New_List (
4138 Make_Selected_Component (Loc,
4139 Prefix => Request,
4140 Selector_Name => Name_Params)))));
4142 Stmts := New_List;
4144 Decl :=
4145 Make_Subprogram_Body (Loc,
4146 Specification => RPC_Receiver_Spec,
4147 Declarations => RPC_Receiver_Decls,
4148 Handled_Statement_Sequence =>
4149 Make_Handled_Sequence_Of_Statements (Loc,
4150 Statements => Stmts));
4151 end Build_RPC_Receiver_Body;
4153 -----------------------
4154 -- Build_Stub_Target --
4155 -----------------------
4157 function Build_Stub_Target
4158 (Loc : Source_Ptr;
4159 Decls : List_Id;
4160 RCI_Locator : Entity_Id;
4161 Controlling_Parameter : Entity_Id) return RPC_Target
4163 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4164 begin
4165 Target_Info.Partition :=
4166 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
4167 if Present (Controlling_Parameter) then
4168 Append_To (Decls,
4169 Make_Object_Declaration (Loc,
4170 Defining_Identifier => Target_Info.Partition,
4171 Constant_Present => True,
4172 Object_Definition =>
4173 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4175 Expression =>
4176 Make_Selected_Component (Loc,
4177 Prefix => Controlling_Parameter,
4178 Selector_Name => Name_Origin)));
4180 Target_Info.RPC_Receiver :=
4181 Make_Selected_Component (Loc,
4182 Prefix => Controlling_Parameter,
4183 Selector_Name => Name_Receiver);
4185 else
4186 Append_To (Decls,
4187 Make_Object_Declaration (Loc,
4188 Defining_Identifier => Target_Info.Partition,
4189 Constant_Present => True,
4190 Object_Definition =>
4191 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4193 Expression =>
4194 Make_Function_Call (Loc,
4195 Name => Make_Selected_Component (Loc,
4196 Prefix =>
4197 Make_Identifier (Loc, Chars (RCI_Locator)),
4198 Selector_Name =>
4199 Make_Identifier (Loc,
4200 Name_Get_Active_Partition_ID)))));
4202 Target_Info.RPC_Receiver :=
4203 Make_Selected_Component (Loc,
4204 Prefix =>
4205 Make_Identifier (Loc, Chars (RCI_Locator)),
4206 Selector_Name =>
4207 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4208 end if;
4209 return Target_Info;
4210 end Build_Stub_Target;
4212 ---------------------
4213 -- Build_Stub_Type --
4214 ---------------------
4216 procedure Build_Stub_Type
4217 (RACW_Type : Entity_Id;
4218 Stub_Type : Entity_Id;
4219 Stub_Type_Decl : out Node_Id;
4220 RPC_Receiver_Decl : out Node_Id)
4222 Loc : constant Source_Ptr := Sloc (Stub_Type);
4223 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
4225 begin
4226 Stub_Type_Decl :=
4227 Make_Full_Type_Declaration (Loc,
4228 Defining_Identifier => Stub_Type,
4229 Type_Definition =>
4230 Make_Record_Definition (Loc,
4231 Tagged_Present => True,
4232 Limited_Present => True,
4233 Component_List =>
4234 Make_Component_List (Loc,
4235 Component_Items => New_List (
4237 Make_Component_Declaration (Loc,
4238 Defining_Identifier =>
4239 Make_Defining_Identifier (Loc, Name_Origin),
4240 Component_Definition =>
4241 Make_Component_Definition (Loc,
4242 Aliased_Present => False,
4243 Subtype_Indication =>
4244 New_Occurrence_Of (
4245 RTE (RE_Partition_ID), Loc))),
4247 Make_Component_Declaration (Loc,
4248 Defining_Identifier =>
4249 Make_Defining_Identifier (Loc, Name_Receiver),
4250 Component_Definition =>
4251 Make_Component_Definition (Loc,
4252 Aliased_Present => False,
4253 Subtype_Indication =>
4254 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4256 Make_Component_Declaration (Loc,
4257 Defining_Identifier =>
4258 Make_Defining_Identifier (Loc, Name_Addr),
4259 Component_Definition =>
4260 Make_Component_Definition (Loc,
4261 Aliased_Present => False,
4262 Subtype_Indication =>
4263 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
4265 Make_Component_Declaration (Loc,
4266 Defining_Identifier =>
4267 Make_Defining_Identifier (Loc, Name_Asynchronous),
4268 Component_Definition =>
4269 Make_Component_Definition (Loc,
4270 Aliased_Present => False,
4271 Subtype_Indication =>
4272 New_Occurrence_Of (
4273 Standard_Boolean, Loc)))))));
4275 if Is_RAS then
4276 RPC_Receiver_Decl := Empty;
4277 else
4278 declare
4279 RPC_Receiver_Request : constant Entity_Id :=
4280 Make_Defining_Identifier (Loc, Name_R);
4281 begin
4282 RPC_Receiver_Decl :=
4283 Make_Subprogram_Declaration (Loc,
4284 Build_RPC_Receiver_Specification (
4285 RPC_Receiver => Make_Defining_Identifier (Loc,
4286 New_Internal_Name ('R')),
4287 Request_Parameter => RPC_Receiver_Request));
4288 end;
4289 end if;
4290 end Build_Stub_Type;
4292 --------------------------------------
4293 -- Build_Subprogram_Receiving_Stubs --
4294 --------------------------------------
4296 function Build_Subprogram_Receiving_Stubs
4297 (Vis_Decl : Node_Id;
4298 Asynchronous : Boolean;
4299 Dynamically_Asynchronous : Boolean := False;
4300 Stub_Type : Entity_Id := Empty;
4301 RACW_Type : Entity_Id := Empty;
4302 Parent_Primitive : Entity_Id := Empty) return Node_Id
4304 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4306 Request_Parameter : Node_Id;
4307 -- ???
4309 Decls : constant List_Id := New_List;
4310 -- All the parameters will get declared before calling the real
4311 -- subprograms. Also the out parameters will be declared.
4313 Statements : constant List_Id := New_List;
4315 Extra_Formal_Statements : constant List_Id := New_List;
4316 -- Statements concerning extra formal parameters
4318 After_Statements : constant List_Id := New_List;
4319 -- Statements to be executed after the subprogram call
4321 Inner_Decls : List_Id := No_List;
4322 -- In case of a function, the inner declarations are needed since
4323 -- the result may be unconstrained.
4325 Excep_Handlers : List_Id := No_List;
4326 Excep_Choice : Entity_Id;
4327 Excep_Code : List_Id;
4329 Parameter_List : constant List_Id := New_List;
4330 -- List of parameters to be passed to the subprogram
4332 Current_Parameter : Node_Id;
4334 Ordered_Parameters_List : constant List_Id :=
4335 Build_Ordered_Parameters_List
4336 (Specification (Vis_Decl));
4338 Subp_Spec : Node_Id;
4339 -- Subprogram specification
4341 Called_Subprogram : Node_Id;
4342 -- The subprogram to call
4344 Null_Raise_Statement : Node_Id;
4346 Dynamic_Async : Entity_Id;
4348 begin
4349 if Present (RACW_Type) then
4350 Called_Subprogram :=
4351 New_Occurrence_Of (Parent_Primitive, Loc);
4352 else
4353 Called_Subprogram :=
4354 New_Occurrence_Of (
4355 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4356 end if;
4358 Request_Parameter :=
4359 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4361 if Dynamically_Asynchronous then
4362 Dynamic_Async :=
4363 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
4364 else
4365 Dynamic_Async := Empty;
4366 end if;
4368 if not Asynchronous or Dynamically_Asynchronous then
4370 -- The first statement after the subprogram call is a statement to
4371 -- writes a Null_Occurrence into the result stream.
4373 Null_Raise_Statement :=
4374 Make_Attribute_Reference (Loc,
4375 Prefix =>
4376 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4377 Attribute_Name => Name_Write,
4378 Expressions => New_List (
4379 Make_Selected_Component (Loc,
4380 Prefix => Request_Parameter,
4381 Selector_Name => Name_Result),
4382 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4384 if Dynamically_Asynchronous then
4385 Null_Raise_Statement :=
4386 Make_Implicit_If_Statement (Vis_Decl,
4387 Condition =>
4388 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4389 Then_Statements => New_List (Null_Raise_Statement));
4390 end if;
4392 Append_To (After_Statements, Null_Raise_Statement);
4393 end if;
4395 -- Loop through every parameter and get its value from the stream. If
4396 -- the parameter is unconstrained, then the parameter is read using
4397 -- 'Input at the point of declaration.
4399 Current_Parameter := First (Ordered_Parameters_List);
4400 while Present (Current_Parameter) loop
4401 declare
4402 Etyp : Entity_Id;
4403 Constrained : Boolean;
4405 Object : constant Entity_Id :=
4406 Make_Defining_Identifier (Loc,
4407 New_Internal_Name ('P'));
4409 Expr : Node_Id := Empty;
4411 Is_Controlling_Formal : constant Boolean :=
4412 Is_RACW_Controlling_Formal
4413 (Current_Parameter, Stub_Type);
4415 begin
4416 Set_Ekind (Object, E_Variable);
4418 if Is_Controlling_Formal then
4420 -- We have a controlling formal parameter. Read its address
4421 -- rather than a real object. The address is in Unsigned_64
4422 -- form.
4424 Etyp := RTE (RE_Unsigned_64);
4425 else
4426 Etyp := Etype (Parameter_Type (Current_Parameter));
4427 end if;
4429 Constrained :=
4430 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
4432 if In_Present (Current_Parameter)
4433 or else not Out_Present (Current_Parameter)
4434 or else not Constrained
4435 or else Is_Controlling_Formal
4436 then
4437 -- If an input parameter is contrained, then its reading is
4438 -- deferred until the beginning of the subprogram body. If
4439 -- it is unconstrained, then an expression is built for
4440 -- the object declaration and the variable is set using
4441 -- 'Input instead of 'Read.
4443 if Constrained and then not Is_Controlling_Formal then
4444 Append_To (Statements,
4445 Make_Attribute_Reference (Loc,
4446 Prefix => New_Occurrence_Of (Etyp, Loc),
4447 Attribute_Name => Name_Read,
4448 Expressions => New_List (
4449 Make_Selected_Component (Loc,
4450 Prefix => Request_Parameter,
4451 Selector_Name => Name_Params),
4452 New_Occurrence_Of (Object, Loc))));
4454 else
4455 Expr := Input_With_Tag_Check (Loc,
4456 Var_Type => Etyp,
4457 Stream => Make_Selected_Component (Loc,
4458 Prefix => Request_Parameter,
4459 Selector_Name => Name_Params));
4460 Append_To (Decls, Expr);
4461 Expr := Make_Function_Call (Loc,
4462 New_Occurrence_Of (Defining_Unit_Name
4463 (Specification (Expr)), Loc));
4464 end if;
4465 end if;
4467 -- If we do not have to output the current parameter, then it
4468 -- can well be flagged as constant. This may allow further
4469 -- optimizations done by the back end.
4471 Append_To (Decls,
4472 Make_Object_Declaration (Loc,
4473 Defining_Identifier => Object,
4474 Constant_Present => not Constrained
4475 and then not Out_Present (Current_Parameter),
4476 Object_Definition =>
4477 New_Occurrence_Of (Etyp, Loc),
4478 Expression => Expr));
4480 -- An out parameter may be written back using a 'Write
4481 -- attribute instead of a 'Output because it has been
4482 -- constrained by the parameter given to the caller. Note that
4483 -- out controlling arguments in the case of a RACW are not put
4484 -- back in the stream because the pointer on them has not
4485 -- changed.
4487 if Out_Present (Current_Parameter)
4488 and then
4489 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4490 then
4491 Append_To (After_Statements,
4492 Make_Attribute_Reference (Loc,
4493 Prefix => New_Occurrence_Of (Etyp, Loc),
4494 Attribute_Name => Name_Write,
4495 Expressions => New_List (
4496 Make_Selected_Component (Loc,
4497 Prefix => Request_Parameter,
4498 Selector_Name => Name_Result),
4499 New_Occurrence_Of (Object, Loc))));
4500 end if;
4502 -- For RACW controlling formals, the Etyp of Object is always
4503 -- an RACW, even if the parameter is not of an anonymous access
4504 -- type. In such case, we need to dereference it at call time.
4506 if Is_Controlling_Formal then
4507 if Nkind (Parameter_Type (Current_Parameter)) /=
4508 N_Access_Definition
4509 then
4510 Append_To (Parameter_List,
4511 Make_Parameter_Association (Loc,
4512 Selector_Name =>
4513 New_Occurrence_Of (
4514 Defining_Identifier (Current_Parameter), Loc),
4515 Explicit_Actual_Parameter =>
4516 Make_Explicit_Dereference (Loc,
4517 Unchecked_Convert_To (RACW_Type,
4518 OK_Convert_To (RTE (RE_Address),
4519 New_Occurrence_Of (Object, Loc))))));
4521 else
4522 Append_To (Parameter_List,
4523 Make_Parameter_Association (Loc,
4524 Selector_Name =>
4525 New_Occurrence_Of (
4526 Defining_Identifier (Current_Parameter), Loc),
4527 Explicit_Actual_Parameter =>
4528 Unchecked_Convert_To (RACW_Type,
4529 OK_Convert_To (RTE (RE_Address),
4530 New_Occurrence_Of (Object, Loc)))));
4531 end if;
4533 else
4534 Append_To (Parameter_List,
4535 Make_Parameter_Association (Loc,
4536 Selector_Name =>
4537 New_Occurrence_Of (
4538 Defining_Identifier (Current_Parameter), Loc),
4539 Explicit_Actual_Parameter =>
4540 New_Occurrence_Of (Object, Loc)));
4541 end if;
4543 -- If the current parameter needs an extra formal, then read it
4544 -- from the stream and set the corresponding semantic field in
4545 -- the variable. If the kind of the parameter identifier is
4546 -- E_Void, then this is a compiler generated parameter that
4547 -- doesn't need an extra constrained status.
4549 -- The case of Extra_Accessibility should also be handled ???
4551 if Nkind (Parameter_Type (Current_Parameter)) /=
4552 N_Access_Definition
4553 and then
4554 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4555 and then
4556 Present (Extra_Constrained
4557 (Defining_Identifier (Current_Parameter)))
4558 then
4559 declare
4560 Extra_Parameter : constant Entity_Id :=
4561 Extra_Constrained
4562 (Defining_Identifier
4563 (Current_Parameter));
4565 Formal_Entity : constant Entity_Id :=
4566 Make_Defining_Identifier
4567 (Loc, Chars (Extra_Parameter));
4569 Formal_Type : constant Entity_Id :=
4570 Etype (Extra_Parameter);
4572 begin
4573 Append_To (Decls,
4574 Make_Object_Declaration (Loc,
4575 Defining_Identifier => Formal_Entity,
4576 Object_Definition =>
4577 New_Occurrence_Of (Formal_Type, Loc)));
4579 Append_To (Extra_Formal_Statements,
4580 Make_Attribute_Reference (Loc,
4581 Prefix => New_Occurrence_Of (
4582 Formal_Type, Loc),
4583 Attribute_Name => Name_Read,
4584 Expressions => New_List (
4585 Make_Selected_Component (Loc,
4586 Prefix => Request_Parameter,
4587 Selector_Name => Name_Params),
4588 New_Occurrence_Of (Formal_Entity, Loc))));
4589 Set_Extra_Constrained (Object, Formal_Entity);
4590 end;
4591 end if;
4592 end;
4594 Next (Current_Parameter);
4595 end loop;
4597 -- Append the formal statements list at the end of regular statements
4599 Append_List_To (Statements, Extra_Formal_Statements);
4601 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
4603 -- The remote subprogram is a function. We build an inner block to
4604 -- be able to hold a potentially unconstrained result in a
4605 -- variable.
4607 declare
4608 Etyp : constant Entity_Id :=
4609 Etype (Result_Definition (Specification (Vis_Decl)));
4610 Result : constant Node_Id :=
4611 Make_Defining_Identifier (Loc,
4612 New_Internal_Name ('R'));
4613 begin
4614 Inner_Decls := New_List (
4615 Make_Object_Declaration (Loc,
4616 Defining_Identifier => Result,
4617 Constant_Present => True,
4618 Object_Definition => New_Occurrence_Of (Etyp, Loc),
4619 Expression =>
4620 Make_Function_Call (Loc,
4621 Name => Called_Subprogram,
4622 Parameter_Associations => Parameter_List)));
4624 Append_To (After_Statements,
4625 Make_Attribute_Reference (Loc,
4626 Prefix => New_Occurrence_Of (Etyp, Loc),
4627 Attribute_Name => Name_Output,
4628 Expressions => New_List (
4629 Make_Selected_Component (Loc,
4630 Prefix => Request_Parameter,
4631 Selector_Name => Name_Result),
4632 New_Occurrence_Of (Result, Loc))));
4633 end;
4635 Append_To (Statements,
4636 Make_Block_Statement (Loc,
4637 Declarations => Inner_Decls,
4638 Handled_Statement_Sequence =>
4639 Make_Handled_Sequence_Of_Statements (Loc,
4640 Statements => After_Statements)));
4642 else
4643 -- The remote subprogram is a procedure. We do not need any inner
4644 -- block in this case.
4646 if Dynamically_Asynchronous then
4647 Append_To (Decls,
4648 Make_Object_Declaration (Loc,
4649 Defining_Identifier => Dynamic_Async,
4650 Object_Definition =>
4651 New_Occurrence_Of (Standard_Boolean, Loc)));
4653 Append_To (Statements,
4654 Make_Attribute_Reference (Loc,
4655 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4656 Attribute_Name => Name_Read,
4657 Expressions => New_List (
4658 Make_Selected_Component (Loc,
4659 Prefix => Request_Parameter,
4660 Selector_Name => Name_Params),
4661 New_Occurrence_Of (Dynamic_Async, Loc))));
4662 end if;
4664 Append_To (Statements,
4665 Make_Procedure_Call_Statement (Loc,
4666 Name => Called_Subprogram,
4667 Parameter_Associations => Parameter_List));
4669 Append_List_To (Statements, After_Statements);
4670 end if;
4672 if Asynchronous and then not Dynamically_Asynchronous then
4674 -- For an asynchronous procedure, add a null exception handler
4676 Excep_Handlers := New_List (
4677 Make_Exception_Handler (Loc,
4678 Exception_Choices => New_List (Make_Others_Choice (Loc)),
4679 Statements => New_List (Make_Null_Statement (Loc))));
4681 else
4682 -- In the other cases, if an exception is raised, then the
4683 -- exception occurrence is copied into the output stream and
4684 -- no other output parameter is written.
4686 Excep_Choice :=
4687 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4689 Excep_Code := New_List (
4690 Make_Attribute_Reference (Loc,
4691 Prefix =>
4692 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4693 Attribute_Name => Name_Write,
4694 Expressions => New_List (
4695 Make_Selected_Component (Loc,
4696 Prefix => Request_Parameter,
4697 Selector_Name => Name_Result),
4698 New_Occurrence_Of (Excep_Choice, Loc))));
4700 if Dynamically_Asynchronous then
4701 Excep_Code := New_List (
4702 Make_Implicit_If_Statement (Vis_Decl,
4703 Condition => Make_Op_Not (Loc,
4704 New_Occurrence_Of (Dynamic_Async, Loc)),
4705 Then_Statements => Excep_Code));
4706 end if;
4708 Excep_Handlers := New_List (
4709 Make_Exception_Handler (Loc,
4710 Choice_Parameter => Excep_Choice,
4711 Exception_Choices => New_List (Make_Others_Choice (Loc)),
4712 Statements => Excep_Code));
4714 end if;
4716 Subp_Spec :=
4717 Make_Procedure_Specification (Loc,
4718 Defining_Unit_Name =>
4719 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
4721 Parameter_Specifications => New_List (
4722 Make_Parameter_Specification (Loc,
4723 Defining_Identifier => Request_Parameter,
4724 Parameter_Type =>
4725 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
4727 return
4728 Make_Subprogram_Body (Loc,
4729 Specification => Subp_Spec,
4730 Declarations => Decls,
4731 Handled_Statement_Sequence =>
4732 Make_Handled_Sequence_Of_Statements (Loc,
4733 Statements => Statements,
4734 Exception_Handlers => Excep_Handlers));
4735 end Build_Subprogram_Receiving_Stubs;
4737 ------------
4738 -- Result --
4739 ------------
4741 function Result return Node_Id is
4742 begin
4743 return Make_Identifier (Loc, Name_V);
4744 end Result;
4746 ----------------------
4747 -- Stream_Parameter --
4748 ----------------------
4750 function Stream_Parameter return Node_Id is
4751 begin
4752 return Make_Identifier (Loc, Name_S);
4753 end Stream_Parameter;
4755 end GARLIC_Support;
4757 -----------------------------
4758 -- Make_Selected_Component --
4759 -----------------------------
4761 function Make_Selected_Component
4762 (Loc : Source_Ptr;
4763 Prefix : Entity_Id;
4764 Selector_Name : Name_Id) return Node_Id
4766 begin
4767 return Make_Selected_Component (Loc,
4768 Prefix => New_Occurrence_Of (Prefix, Loc),
4769 Selector_Name => Make_Identifier (Loc, Selector_Name));
4770 end Make_Selected_Component;
4772 -----------------------
4773 -- Get_Subprogram_Id --
4774 -----------------------
4776 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
4777 begin
4778 return Get_Subprogram_Ids (Def).Str_Identifier;
4779 end Get_Subprogram_Id;
4781 -----------------------
4782 -- Get_Subprogram_Id --
4783 -----------------------
4785 function Get_Subprogram_Id (Def : Entity_Id) return Int is
4786 begin
4787 return Get_Subprogram_Ids (Def).Int_Identifier;
4788 end Get_Subprogram_Id;
4790 ------------------------
4791 -- Get_Subprogram_Ids --
4792 ------------------------
4794 function Get_Subprogram_Ids
4795 (Def : Entity_Id) return Subprogram_Identifiers
4797 Result : Subprogram_Identifiers :=
4798 Subprogram_Identifier_Table.Get (Def);
4800 Current_Declaration : Node_Id;
4801 Current_Subp : Entity_Id;
4802 Current_Subp_Str : String_Id;
4803 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
4805 begin
4806 if Result.Str_Identifier = No_String then
4808 -- We are looking up this subprogram's identifier outside of the
4809 -- context of generating calling or receiving stubs. Hence we are
4810 -- processing an 'Access attribute_reference for an RCI subprogram,
4811 -- for the purpose of obtaining a RAS value.
4813 pragma Assert
4814 (Is_Remote_Call_Interface (Scope (Def))
4815 and then
4816 (Nkind (Parent (Def)) = N_Procedure_Specification
4817 or else
4818 Nkind (Parent (Def)) = N_Function_Specification));
4820 Current_Declaration :=
4821 First (Visible_Declarations
4822 (Package_Specification_Of_Scope (Scope (Def))));
4823 while Present (Current_Declaration) loop
4824 if Nkind (Current_Declaration) = N_Subprogram_Declaration
4825 and then Comes_From_Source (Current_Declaration)
4826 then
4827 Current_Subp := Defining_Unit_Name (Specification (
4828 Current_Declaration));
4829 Assign_Subprogram_Identifier
4830 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
4832 if Current_Subp = Def then
4833 Result := (Current_Subp_Str, Current_Subp_Number);
4834 end if;
4836 Current_Subp_Number := Current_Subp_Number + 1;
4837 end if;
4839 Next (Current_Declaration);
4840 end loop;
4841 end if;
4843 pragma Assert (Result.Str_Identifier /= No_String);
4844 return Result;
4845 end Get_Subprogram_Ids;
4847 ----------
4848 -- Hash --
4849 ----------
4851 function Hash (F : Entity_Id) return Hash_Index is
4852 begin
4853 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
4854 end Hash;
4856 function Hash (F : Name_Id) return Hash_Index is
4857 begin
4858 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
4859 end Hash;
4861 --------------------------
4862 -- Input_With_Tag_Check --
4863 --------------------------
4865 function Input_With_Tag_Check
4866 (Loc : Source_Ptr;
4867 Var_Type : Entity_Id;
4868 Stream : Node_Id) return Node_Id
4870 begin
4871 return
4872 Make_Subprogram_Body (Loc,
4873 Specification => Make_Function_Specification (Loc,
4874 Defining_Unit_Name =>
4875 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
4876 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
4877 Declarations => No_List,
4878 Handled_Statement_Sequence =>
4879 Make_Handled_Sequence_Of_Statements (Loc, New_List (
4880 Make_Tag_Check (Loc,
4881 Make_Return_Statement (Loc,
4882 Make_Attribute_Reference (Loc,
4883 Prefix => New_Occurrence_Of (Var_Type, Loc),
4884 Attribute_Name => Name_Input,
4885 Expressions =>
4886 New_List (Stream)))))));
4887 end Input_With_Tag_Check;
4889 --------------------------------
4890 -- Is_RACW_Controlling_Formal --
4891 --------------------------------
4893 function Is_RACW_Controlling_Formal
4894 (Parameter : Node_Id;
4895 Stub_Type : Entity_Id) return Boolean
4897 Typ : Entity_Id;
4899 begin
4900 -- If the kind of the parameter is E_Void, then it is not a
4901 -- controlling formal (this can happen in the context of RAS).
4903 if Ekind (Defining_Identifier (Parameter)) = E_Void then
4904 return False;
4905 end if;
4907 -- If the parameter is not a controlling formal, then it cannot
4908 -- be possibly a RACW_Controlling_Formal.
4910 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
4911 return False;
4912 end if;
4914 Typ := Parameter_Type (Parameter);
4915 return (Nkind (Typ) = N_Access_Definition
4916 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
4917 or else Etype (Typ) = Stub_Type;
4918 end Is_RACW_Controlling_Formal;
4920 --------------------
4921 -- Make_Tag_Check --
4922 --------------------
4924 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
4925 Occ : constant Entity_Id :=
4926 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4928 begin
4929 return Make_Block_Statement (Loc,
4930 Handled_Statement_Sequence =>
4931 Make_Handled_Sequence_Of_Statements (Loc,
4932 Statements => New_List (N),
4934 Exception_Handlers => New_List (
4935 Make_Exception_Handler (Loc,
4936 Choice_Parameter => Occ,
4938 Exception_Choices =>
4939 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
4941 Statements =>
4942 New_List (Make_Procedure_Call_Statement (Loc,
4943 New_Occurrence_Of
4944 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
4945 New_List (New_Occurrence_Of (Occ, Loc))))))));
4946 end Make_Tag_Check;
4948 ----------------------------
4949 -- Need_Extra_Constrained --
4950 ----------------------------
4952 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
4953 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
4954 begin
4955 return Out_Present (Parameter)
4956 and then Has_Discriminants (Etyp)
4957 and then not Is_Constrained (Etyp)
4958 and then not Is_Indefinite_Subtype (Etyp);
4959 end Need_Extra_Constrained;
4961 ------------------------------------
4962 -- Pack_Entity_Into_Stream_Access --
4963 ------------------------------------
4965 function Pack_Entity_Into_Stream_Access
4966 (Loc : Source_Ptr;
4967 Stream : Node_Id;
4968 Object : Entity_Id;
4969 Etyp : Entity_Id := Empty) return Node_Id
4971 Typ : Entity_Id;
4973 begin
4974 if Present (Etyp) then
4975 Typ := Etyp;
4976 else
4977 Typ := Etype (Object);
4978 end if;
4980 return
4981 Pack_Node_Into_Stream_Access (Loc,
4982 Stream => Stream,
4983 Object => New_Occurrence_Of (Object, Loc),
4984 Etyp => Typ);
4985 end Pack_Entity_Into_Stream_Access;
4987 ---------------------------
4988 -- Pack_Node_Into_Stream --
4989 ---------------------------
4991 function Pack_Node_Into_Stream
4992 (Loc : Source_Ptr;
4993 Stream : Entity_Id;
4994 Object : Node_Id;
4995 Etyp : Entity_Id) return Node_Id
4997 Write_Attribute : Name_Id := Name_Write;
4999 begin
5000 if not Is_Constrained (Etyp) then
5001 Write_Attribute := Name_Output;
5002 end if;
5004 return
5005 Make_Attribute_Reference (Loc,
5006 Prefix => New_Occurrence_Of (Etyp, Loc),
5007 Attribute_Name => Write_Attribute,
5008 Expressions => New_List (
5009 Make_Attribute_Reference (Loc,
5010 Prefix => New_Occurrence_Of (Stream, Loc),
5011 Attribute_Name => Name_Access),
5012 Object));
5013 end Pack_Node_Into_Stream;
5015 ----------------------------------
5016 -- Pack_Node_Into_Stream_Access --
5017 ----------------------------------
5019 function Pack_Node_Into_Stream_Access
5020 (Loc : Source_Ptr;
5021 Stream : Node_Id;
5022 Object : Node_Id;
5023 Etyp : Entity_Id) return Node_Id
5025 Write_Attribute : Name_Id := Name_Write;
5027 begin
5028 if not Is_Constrained (Etyp) then
5029 Write_Attribute := Name_Output;
5030 end if;
5032 return
5033 Make_Attribute_Reference (Loc,
5034 Prefix => New_Occurrence_Of (Etyp, Loc),
5035 Attribute_Name => Write_Attribute,
5036 Expressions => New_List (
5037 Stream,
5038 Object));
5039 end Pack_Node_Into_Stream_Access;
5041 ---------------------
5042 -- PolyORB_Support --
5043 ---------------------
5045 package body PolyORB_Support is
5047 -- Local subprograms
5049 procedure Add_RACW_Read_Attribute
5050 (RACW_Type : Entity_Id;
5051 Stub_Type : Entity_Id;
5052 Stub_Type_Access : Entity_Id;
5053 Declarations : List_Id);
5054 -- Add Read attribute in Decls for the RACW type. The Read attribute
5055 -- is added right after the RACW_Type declaration while the body is
5056 -- inserted after Declarations.
5058 procedure Add_RACW_Write_Attribute
5059 (RACW_Type : Entity_Id;
5060 Stub_Type : Entity_Id;
5061 Stub_Type_Access : Entity_Id;
5062 Declarations : List_Id);
5063 -- Same thing for the Write attribute
5065 procedure Add_RACW_From_Any
5066 (RACW_Type : Entity_Id;
5067 Stub_Type : Entity_Id;
5068 Stub_Type_Access : Entity_Id;
5069 Declarations : List_Id);
5070 -- Add the From_Any TSS for this RACW type
5072 procedure Add_RACW_To_Any
5073 (Designated_Type : Entity_Id;
5074 RACW_Type : Entity_Id;
5075 Stub_Type : Entity_Id;
5076 Stub_Type_Access : Entity_Id;
5077 Declarations : List_Id);
5078 -- Add the To_Any TSS for this RACW type
5080 procedure Add_RACW_TypeCode
5081 (Designated_Type : Entity_Id;
5082 RACW_Type : Entity_Id;
5083 Declarations : List_Id);
5084 -- Add the TypeCode TSS for this RACW type
5086 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5087 -- Add the From_Any TSS for this RAS type
5089 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5090 -- Add the To_Any TSS for this RAS type
5092 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5093 -- Add the TypeCode TSS for this RAS type
5095 procedure Add_RAS_Access_TSS (N : Node_Id);
5096 -- Add a subprogram body for RAS Access TSS
5098 -------------------------------------
5099 -- Add_Obj_RPC_Receiver_Completion --
5100 -------------------------------------
5102 procedure Add_Obj_RPC_Receiver_Completion
5103 (Loc : Source_Ptr;
5104 Decls : List_Id;
5105 RPC_Receiver : Entity_Id;
5106 Stub_Elements : Stub_Structure)
5108 Desig : constant Entity_Id :=
5109 Etype (Designated_Type (Stub_Elements.RACW_Type));
5110 begin
5111 Append_To (Decls,
5112 Make_Procedure_Call_Statement (Loc,
5113 Name =>
5114 New_Occurrence_Of (
5115 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5117 Parameter_Associations => New_List (
5119 -- Name
5121 Make_String_Literal (Loc,
5122 Full_Qualified_Name (Desig)),
5124 -- Handler
5126 Make_Attribute_Reference (Loc,
5127 Prefix =>
5128 New_Occurrence_Of (
5129 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5130 Attribute_Name =>
5131 Name_Access),
5133 -- Receiver
5135 Make_Attribute_Reference (Loc,
5136 Prefix =>
5137 New_Occurrence_Of (
5138 Defining_Identifier (
5139 Stub_Elements.RPC_Receiver_Decl), Loc),
5140 Attribute_Name =>
5141 Name_Access))));
5142 end Add_Obj_RPC_Receiver_Completion;
5144 -----------------------
5145 -- Add_RACW_Features --
5146 -----------------------
5148 procedure Add_RACW_Features
5149 (RACW_Type : Entity_Id;
5150 Desig : Entity_Id;
5151 Stub_Type : Entity_Id;
5152 Stub_Type_Access : Entity_Id;
5153 RPC_Receiver_Decl : Node_Id;
5154 Declarations : List_Id)
5156 pragma Warnings (Off);
5157 pragma Unreferenced (RPC_Receiver_Decl);
5158 pragma Warnings (On);
5160 begin
5161 Add_RACW_From_Any
5162 (RACW_Type => RACW_Type,
5163 Stub_Type => Stub_Type,
5164 Stub_Type_Access => Stub_Type_Access,
5165 Declarations => Declarations);
5167 Add_RACW_To_Any
5168 (Designated_Type => Desig,
5169 RACW_Type => RACW_Type,
5170 Stub_Type => Stub_Type,
5171 Stub_Type_Access => Stub_Type_Access,
5172 Declarations => Declarations);
5174 -- In the PolyORB case, the RACW 'Read and 'Write attributes
5175 -- are implemented in terms of the From_Any and To_Any TSSs,
5176 -- so these TSSs must be expanded before 'Read and 'Write.
5178 Add_RACW_Write_Attribute
5179 (RACW_Type => RACW_Type,
5180 Stub_Type => Stub_Type,
5181 Stub_Type_Access => Stub_Type_Access,
5182 Declarations => Declarations);
5184 Add_RACW_Read_Attribute
5185 (RACW_Type => RACW_Type,
5186 Stub_Type => Stub_Type,
5187 Stub_Type_Access => Stub_Type_Access,
5188 Declarations => Declarations);
5190 Add_RACW_TypeCode
5191 (Designated_Type => Desig,
5192 RACW_Type => RACW_Type,
5193 Declarations => Declarations);
5194 end Add_RACW_Features;
5196 -----------------------
5197 -- Add_RACW_From_Any --
5198 -----------------------
5200 procedure Add_RACW_From_Any
5201 (RACW_Type : Entity_Id;
5202 Stub_Type : Entity_Id;
5203 Stub_Type_Access : Entity_Id;
5204 Declarations : List_Id)
5206 Loc : constant Source_Ptr := Sloc (RACW_Type);
5207 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5209 Fnam : constant Entity_Id :=
5210 Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
5212 Func_Spec : Node_Id;
5213 Func_Decl : Node_Id;
5214 Func_Body : Node_Id;
5216 Decls : List_Id;
5217 Statements : List_Id;
5218 Stub_Statements : List_Id;
5219 Local_Statements : List_Id;
5220 -- Various parts of the subprogram
5222 Any_Parameter : constant Entity_Id :=
5223 Make_Defining_Identifier (Loc, Name_A);
5224 Reference : constant Entity_Id :=
5225 Make_Defining_Identifier
5226 (Loc, New_Internal_Name ('R'));
5227 Is_Local : constant Entity_Id :=
5228 Make_Defining_Identifier
5229 (Loc, New_Internal_Name ('L'));
5230 Addr : constant Entity_Id :=
5231 Make_Defining_Identifier
5232 (Loc, New_Internal_Name ('A'));
5233 Local_Stub : constant Entity_Id :=
5234 Make_Defining_Identifier
5235 (Loc, New_Internal_Name ('L'));
5236 Stubbed_Result : constant Entity_Id :=
5237 Make_Defining_Identifier
5238 (Loc, New_Internal_Name ('S'));
5240 Stub_Condition : Node_Id;
5241 -- An expression that determines whether we create a stub for the
5242 -- newly-unpacked RACW. Normally we create a stub only for remote
5243 -- objects, but in the case of an RACW used to implement a RAS,
5244 -- we also create a stub for local subprograms if a pragma
5245 -- All_Calls_Remote applies.
5247 Asynchronous_Flag : constant Entity_Id :=
5248 Asynchronous_Flags_Table.Get (RACW_Type);
5249 -- The flag object declared in Add_RACW_Asynchronous_Flag
5251 begin
5252 -- Object declarations
5254 Decls := New_List (
5255 Make_Object_Declaration (Loc,
5256 Defining_Identifier =>
5257 Reference,
5258 Object_Definition =>
5259 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5260 Expression =>
5261 Make_Function_Call (Loc,
5262 Name =>
5263 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5264 Parameter_Associations => New_List (
5265 New_Occurrence_Of (Any_Parameter, Loc)))),
5267 Make_Object_Declaration (Loc,
5268 Defining_Identifier => Local_Stub,
5269 Aliased_Present => True,
5270 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
5272 Make_Object_Declaration (Loc,
5273 Defining_Identifier => Stubbed_Result,
5274 Object_Definition =>
5275 New_Occurrence_Of (Stub_Type_Access, Loc),
5276 Expression =>
5277 Make_Attribute_Reference (Loc,
5278 Prefix =>
5279 New_Occurrence_Of (Local_Stub, Loc),
5280 Attribute_Name =>
5281 Name_Unchecked_Access)),
5283 Make_Object_Declaration (Loc,
5284 Defining_Identifier => Is_Local,
5285 Object_Definition =>
5286 New_Occurrence_Of (Standard_Boolean, Loc)),
5288 Make_Object_Declaration (Loc,
5289 Defining_Identifier => Addr,
5290 Object_Definition =>
5291 New_Occurrence_Of (RTE (RE_Address), Loc)));
5293 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
5295 Set_Etype (Stubbed_Result, Stub_Type_Access);
5297 -- If the ref Is_Nil, return a null pointer
5299 Statements := New_List (
5300 Make_Implicit_If_Statement (RACW_Type,
5301 Condition =>
5302 Make_Function_Call (Loc,
5303 Name =>
5304 New_Occurrence_Of (RTE (RE_Is_Nil), Loc),
5305 Parameter_Associations => New_List (
5306 New_Occurrence_Of (Reference, Loc))),
5307 Then_Statements => New_List (
5308 Make_Return_Statement (Loc,
5309 Expression =>
5310 Make_Null (Loc)))));
5312 Append_To (Statements,
5313 Make_Procedure_Call_Statement (Loc,
5314 Name =>
5315 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
5316 Parameter_Associations => New_List (
5317 New_Occurrence_Of (Reference, Loc),
5318 New_Occurrence_Of (Is_Local, Loc),
5319 New_Occurrence_Of (Addr, Loc))));
5321 -- If the object is located on another partition, then a stub object
5322 -- will be created with all the information needed to rebuild the
5323 -- real object at the other end. This stanza is always used in the
5324 -- case of RAS types, for which a stub is required even for local
5325 -- subprograms.
5327 Stub_Statements := New_List (
5328 Make_Assignment_Statement (Loc,
5329 Name => Make_Selected_Component (Loc,
5330 Prefix => Stubbed_Result,
5331 Selector_Name => Name_Target),
5332 Expression =>
5333 Make_Function_Call (Loc,
5334 Name =>
5335 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
5336 Parameter_Associations => New_List (
5337 New_Occurrence_Of (Reference, Loc)))),
5339 Make_Procedure_Call_Statement (Loc,
5340 Name =>
5341 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
5342 Parameter_Associations => New_List (
5343 Make_Selected_Component (Loc,
5344 Prefix => Stubbed_Result,
5345 Selector_Name => Name_Target))),
5347 Make_Assignment_Statement (Loc,
5348 Name => Make_Selected_Component (Loc,
5349 Prefix => Stubbed_Result,
5350 Selector_Name => Name_Asynchronous),
5351 Expression =>
5352 New_Occurrence_Of (Asynchronous_Flag, Loc)));
5354 -- ??? Issue with asynchronous calls here: the Asynchronous
5355 -- flag is set on the stub type if, and only if, the RACW type
5356 -- has a pragma Asynchronous. This is incorrect for RACWs that
5357 -- implement RAS types, because in that case the /designated
5358 -- subprogram/ (not the type) might be asynchronous, and
5359 -- that causes the stub to need to be asynchronous too.
5360 -- A solution is to transport a RAS as a struct containing
5361 -- a RACW and an asynchronous flag, and to properly alter
5362 -- the Asynchronous component in the stub type in the RAS's
5363 -- _From_Any TSS.
5365 Append_List_To (Stub_Statements,
5366 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
5368 -- Distinguish between the local and remote cases, and execute the
5369 -- appropriate piece of code.
5371 Stub_Condition := New_Occurrence_Of (Is_Local, Loc);
5373 if Is_RAS then
5374 Stub_Condition := Make_And_Then (Loc,
5375 Left_Opnd =>
5376 Stub_Condition,
5377 Right_Opnd =>
5378 Make_Selected_Component (Loc,
5379 Prefix =>
5380 Unchecked_Convert_To (
5381 RTE (RE_RAS_Proxy_Type_Access),
5382 New_Occurrence_Of (Addr, Loc)),
5383 Selector_Name =>
5384 Make_Identifier (Loc,
5385 Name_All_Calls_Remote)));
5386 end if;
5388 Local_Statements := New_List (
5389 Make_Return_Statement (Loc,
5390 Expression =>
5391 Unchecked_Convert_To (RACW_Type,
5392 New_Occurrence_Of (Addr, Loc))));
5394 Append_To (Statements,
5395 Make_Implicit_If_Statement (RACW_Type,
5396 Condition =>
5397 Stub_Condition,
5398 Then_Statements => Local_Statements,
5399 Else_Statements => Stub_Statements));
5401 Append_To (Statements,
5402 Make_Return_Statement (Loc,
5403 Expression => Unchecked_Convert_To (RACW_Type,
5404 New_Occurrence_Of (Stubbed_Result, Loc))));
5406 Func_Spec :=
5407 Make_Function_Specification (Loc,
5408 Defining_Unit_Name =>
5409 Fnam,
5410 Parameter_Specifications => New_List (
5411 Make_Parameter_Specification (Loc,
5412 Defining_Identifier =>
5413 Any_Parameter,
5414 Parameter_Type =>
5415 New_Occurrence_Of (RTE (RE_Any), Loc))),
5416 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5418 -- NOTE: The usage occurrences of RACW_Parameter must
5419 -- refer to the entity in the declaration spec, not those
5420 -- of the body spec.
5422 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5424 Func_Body :=
5425 Make_Subprogram_Body (Loc,
5426 Specification =>
5427 Copy_Specification (Loc, Func_Spec),
5428 Declarations => Decls,
5429 Handled_Statement_Sequence =>
5430 Make_Handled_Sequence_Of_Statements (Loc,
5431 Statements => Statements));
5433 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5434 Append_To (Declarations, Func_Body);
5436 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5437 end Add_RACW_From_Any;
5439 -----------------------------
5440 -- Add_RACW_Read_Attribute --
5441 -----------------------------
5443 procedure Add_RACW_Read_Attribute
5444 (RACW_Type : Entity_Id;
5445 Stub_Type : Entity_Id;
5446 Stub_Type_Access : Entity_Id;
5447 Declarations : List_Id)
5449 pragma Warnings (Off);
5450 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5451 pragma Warnings (On);
5452 Loc : constant Source_Ptr := Sloc (RACW_Type);
5454 Proc_Decl : Node_Id;
5455 Attr_Decl : Node_Id;
5457 Body_Node : Node_Id;
5459 Decls : List_Id;
5460 Statements : List_Id;
5461 -- Various parts of the procedure
5463 Procedure_Name : constant Name_Id :=
5464 New_Internal_Name ('R');
5465 Source_Ref : constant Entity_Id :=
5466 Make_Defining_Identifier
5467 (Loc, New_Internal_Name ('R'));
5468 Asynchronous_Flag : constant Entity_Id :=
5469 Asynchronous_Flags_Table.Get (RACW_Type);
5470 pragma Assert (Present (Asynchronous_Flag));
5472 function Stream_Parameter return Node_Id;
5473 function Result return Node_Id;
5474 -- Functions to create occurrences of the formal parameter names
5476 ------------
5477 -- Result --
5478 ------------
5480 function Result return Node_Id is
5481 begin
5482 return Make_Identifier (Loc, Name_V);
5483 end Result;
5485 ----------------------
5486 -- Stream_Parameter --
5487 ----------------------
5489 function Stream_Parameter return Node_Id is
5490 begin
5491 return Make_Identifier (Loc, Name_S);
5492 end Stream_Parameter;
5494 -- Start of processing for Add_RACW_Read_Attribute
5496 begin
5497 -- Generate object declarations
5499 Decls := New_List (
5500 Make_Object_Declaration (Loc,
5501 Defining_Identifier => Source_Ref,
5502 Object_Definition =>
5503 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5505 Statements := New_List (
5506 Make_Attribute_Reference (Loc,
5507 Prefix =>
5508 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5509 Attribute_Name => Name_Read,
5510 Expressions => New_List (
5511 Stream_Parameter,
5512 New_Occurrence_Of (Source_Ref, Loc))),
5513 Make_Assignment_Statement (Loc,
5514 Name =>
5515 Result,
5516 Expression =>
5517 PolyORB_Support.Helpers.Build_From_Any_Call (
5518 RACW_Type,
5519 Make_Function_Call (Loc,
5520 Name =>
5521 New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5522 Parameter_Associations => New_List (
5523 New_Occurrence_Of (Source_Ref, Loc))),
5524 Decls)));
5526 Build_Stream_Procedure
5527 (Loc, RACW_Type, Body_Node,
5528 Make_Defining_Identifier (Loc, Procedure_Name),
5529 Statements, Outp => True);
5530 Set_Declarations (Body_Node, Decls);
5532 Proc_Decl := Make_Subprogram_Declaration (Loc,
5533 Copy_Specification (Loc, Specification (Body_Node)));
5535 Attr_Decl :=
5536 Make_Attribute_Definition_Clause (Loc,
5537 Name => New_Occurrence_Of (RACW_Type, Loc),
5538 Chars => Name_Read,
5539 Expression =>
5540 New_Occurrence_Of (
5541 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5543 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5544 Insert_After (Proc_Decl, Attr_Decl);
5545 Append_To (Declarations, Body_Node);
5546 end Add_RACW_Read_Attribute;
5548 ---------------------
5549 -- Add_RACW_To_Any --
5550 ---------------------
5552 procedure Add_RACW_To_Any
5553 (Designated_Type : Entity_Id;
5554 RACW_Type : Entity_Id;
5555 Stub_Type : Entity_Id;
5556 Stub_Type_Access : Entity_Id;
5557 Declarations : List_Id)
5559 Loc : constant Source_Ptr := Sloc (RACW_Type);
5561 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5563 Fnam : Entity_Id;
5565 Stub_Elements : constant Stub_Structure :=
5566 Stubs_Table.Get (Designated_Type);
5567 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5569 Func_Spec : Node_Id;
5570 Func_Decl : Node_Id;
5571 Func_Body : Node_Id;
5573 Decls : List_Id;
5574 Statements : List_Id;
5575 Null_Statements : List_Id;
5576 Local_Statements : List_Id := No_List;
5577 Stub_Statements : List_Id;
5578 If_Node : Node_Id;
5579 -- Various parts of the subprogram
5581 RACW_Parameter : constant Entity_Id
5582 := Make_Defining_Identifier (Loc, Name_R);
5584 Reference : constant Entity_Id :=
5585 Make_Defining_Identifier
5586 (Loc, New_Internal_Name ('R'));
5587 Any : constant Entity_Id :=
5588 Make_Defining_Identifier
5589 (Loc, New_Internal_Name ('A'));
5591 begin
5592 -- Object declarations
5594 Decls := New_List (
5595 Make_Object_Declaration (Loc,
5596 Defining_Identifier =>
5597 Reference,
5598 Object_Definition =>
5599 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
5600 Make_Object_Declaration (Loc,
5601 Defining_Identifier =>
5602 Any,
5603 Object_Definition =>
5604 New_Occurrence_Of (RTE (RE_Any), Loc)));
5606 -- If the object is null, nothing to do (Reference is already
5607 -- a Nil ref.)
5609 Null_Statements := New_List (Make_Null_Statement (Loc));
5611 if Is_RAS then
5613 -- If the object is a RAS designating a local subprogram,
5614 -- we already have a target reference.
5616 Local_Statements := New_List (
5617 Make_Procedure_Call_Statement (Loc,
5618 Name =>
5619 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
5620 Parameter_Associations => New_List (
5621 New_Occurrence_Of (Reference, Loc),
5622 Make_Selected_Component (Loc,
5623 Prefix =>
5624 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
5625 New_Occurrence_Of (RACW_Parameter, Loc)),
5626 Selector_Name => Make_Identifier (Loc, Name_Target)))));
5628 else
5629 -- If the object is a local RACW object, use Get_Reference now
5630 -- to obtain a reference.
5632 Local_Statements := New_List (
5633 Make_Procedure_Call_Statement (Loc,
5634 Name =>
5635 New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5636 Parameter_Associations => New_List (
5637 Unchecked_Convert_To (
5638 RTE (RE_Address),
5639 New_Occurrence_Of (RACW_Parameter, Loc)),
5640 Make_String_Literal (Loc,
5641 Full_Qualified_Name (Designated_Type)),
5642 Make_Attribute_Reference (Loc,
5643 Prefix =>
5644 New_Occurrence_Of (
5645 Defining_Identifier (
5646 Stub_Elements.RPC_Receiver_Decl), Loc),
5647 Attribute_Name =>
5648 Name_Access),
5649 New_Occurrence_Of (Reference, Loc))));
5650 end if;
5652 -- If the object is located on another partition, use the target
5653 -- from the stub.
5655 Stub_Statements := New_List (
5656 Make_Procedure_Call_Statement (Loc,
5657 Name =>
5658 New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
5659 Parameter_Associations => New_List (
5660 New_Occurrence_Of (Reference, Loc),
5661 Make_Selected_Component (Loc,
5662 Prefix => Unchecked_Convert_To (Stub_Type_Access,
5663 New_Occurrence_Of (RACW_Parameter, Loc)),
5664 Selector_Name =>
5665 Make_Identifier (Loc, Name_Target)))));
5667 -- Distinguish between the null, local and remote cases,
5668 -- and execute the appropriate piece of code.
5670 If_Node :=
5671 Make_Implicit_If_Statement (RACW_Type,
5672 Condition =>
5673 Make_Op_Eq (Loc,
5674 Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc),
5675 Right_Opnd => Make_Null (Loc)),
5676 Then_Statements => Null_Statements,
5677 Elsif_Parts => New_List (
5678 Make_Elsif_Part (Loc,
5679 Condition =>
5680 Make_Op_Ne (Loc,
5681 Left_Opnd =>
5682 Make_Attribute_Reference (Loc,
5683 Prefix =>
5684 New_Occurrence_Of (RACW_Parameter, Loc),
5685 Attribute_Name => Name_Tag),
5686 Right_Opnd =>
5687 Make_Attribute_Reference (Loc,
5688 Prefix => New_Occurrence_Of (Stub_Type, Loc),
5689 Attribute_Name => Name_Tag)),
5690 Then_Statements => Local_Statements)),
5691 Else_Statements => Stub_Statements);
5693 Statements := New_List (
5694 If_Node,
5695 Make_Assignment_Statement (Loc,
5696 Name =>
5697 New_Occurrence_Of (Any, Loc),
5698 Expression =>
5699 Make_Function_Call (Loc,
5700 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5701 Parameter_Associations => New_List (
5702 New_Occurrence_Of (Reference, Loc)))),
5703 Make_Procedure_Call_Statement (Loc,
5704 Name =>
5705 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5706 Parameter_Associations => New_List (
5707 New_Occurrence_Of (Any, Loc),
5708 Make_Selected_Component (Loc,
5709 Prefix =>
5710 Defining_Identifier (
5711 Stub_Elements.RPC_Receiver_Decl),
5712 Selector_Name => Name_Obj_TypeCode))),
5713 Make_Return_Statement (Loc,
5714 Expression =>
5715 New_Occurrence_Of (Any, Loc)));
5717 Fnam := Make_Defining_Identifier (
5718 Loc, New_Internal_Name ('T'));
5720 Func_Spec :=
5721 Make_Function_Specification (Loc,
5722 Defining_Unit_Name =>
5723 Fnam,
5724 Parameter_Specifications => New_List (
5725 Make_Parameter_Specification (Loc,
5726 Defining_Identifier =>
5727 RACW_Parameter,
5728 Parameter_Type =>
5729 New_Occurrence_Of (RACW_Type, Loc))),
5730 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5732 -- NOTE: The usage occurrences of RACW_Parameter must
5733 -- refer to the entity in the declaration spec, not in
5734 -- the body spec.
5736 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5738 Func_Body :=
5739 Make_Subprogram_Body (Loc,
5740 Specification =>
5741 Copy_Specification (Loc, Func_Spec),
5742 Declarations => Decls,
5743 Handled_Statement_Sequence =>
5744 Make_Handled_Sequence_Of_Statements (Loc,
5745 Statements => Statements));
5747 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5748 Append_To (Declarations, Func_Body);
5750 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5751 end Add_RACW_To_Any;
5753 -----------------------
5754 -- Add_RACW_TypeCode --
5755 -----------------------
5757 procedure Add_RACW_TypeCode
5758 (Designated_Type : Entity_Id;
5759 RACW_Type : Entity_Id;
5760 Declarations : List_Id)
5762 Loc : constant Source_Ptr := Sloc (RACW_Type);
5764 Fnam : Entity_Id;
5766 Stub_Elements : constant Stub_Structure :=
5767 Stubs_Table.Get (Designated_Type);
5768 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5770 Func_Spec : Node_Id;
5771 Func_Decl : Node_Id;
5772 Func_Body : Node_Id;
5774 begin
5775 Fnam :=
5776 Make_Defining_Identifier (Loc,
5777 Chars => New_Internal_Name ('T'));
5779 -- The spec for this subprogram has a dummy 'access RACW'
5780 -- argument, which serves only for overloading purposes.
5782 Func_Spec :=
5783 Make_Function_Specification (Loc,
5784 Defining_Unit_Name =>
5785 Fnam,
5786 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
5788 -- NOTE: The usage occurrences of RACW_Parameter must
5789 -- refer to the entity in the declaration spec, not those
5790 -- of the body spec.
5792 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5794 Func_Body :=
5795 Make_Subprogram_Body (Loc,
5796 Specification =>
5797 Copy_Specification (Loc, Func_Spec),
5798 Declarations => Empty_List,
5799 Handled_Statement_Sequence =>
5800 Make_Handled_Sequence_Of_Statements (Loc,
5801 Statements => New_List (
5802 Make_Return_Statement (Loc,
5803 Expression =>
5804 Make_Selected_Component (Loc,
5805 Prefix =>
5806 Defining_Identifier (
5807 Stub_Elements.RPC_Receiver_Decl),
5808 Selector_Name => Name_Obj_TypeCode)))));
5810 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5811 Append_To (Declarations, Func_Body);
5813 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
5814 end Add_RACW_TypeCode;
5816 ------------------------------
5817 -- Add_RACW_Write_Attribute --
5818 ------------------------------
5820 procedure Add_RACW_Write_Attribute
5821 (RACW_Type : Entity_Id;
5822 Stub_Type : Entity_Id;
5823 Stub_Type_Access : Entity_Id;
5824 Declarations : List_Id)
5826 Loc : constant Source_Ptr := Sloc (RACW_Type);
5827 pragma Warnings (Off);
5828 pragma Unreferenced (
5829 Stub_Type,
5830 Stub_Type_Access);
5832 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5833 pragma Unreferenced (Is_RAS);
5834 pragma Warnings (On);
5836 Body_Node : Node_Id;
5837 Proc_Decl : Node_Id;
5838 Attr_Decl : Node_Id;
5840 Statements : List_Id;
5841 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
5843 function Stream_Parameter return Node_Id;
5844 function Object return Node_Id;
5845 -- Functions to create occurrences of the formal parameter names
5847 ------------
5848 -- Object --
5849 ------------
5851 function Object return Node_Id is
5852 Object_Ref : constant Node_Id :=
5853 Make_Identifier (Loc, Name_V);
5855 begin
5856 -- Etype must be set for Build_To_Any_Call
5858 Set_Etype (Object_Ref, RACW_Type);
5860 return Object_Ref;
5861 end Object;
5863 ----------------------
5864 -- Stream_Parameter --
5865 ----------------------
5867 function Stream_Parameter return Node_Id is
5868 begin
5869 return Make_Identifier (Loc, Name_S);
5870 end Stream_Parameter;
5872 -- Start of processing for Add_RACW_Write_Attribute
5874 begin
5875 Statements := New_List (
5876 Pack_Node_Into_Stream_Access (Loc,
5877 Stream => Stream_Parameter,
5878 Object =>
5879 Make_Function_Call (Loc,
5880 Name =>
5881 New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5882 Parameter_Associations => New_List (
5883 PolyORB_Support.Helpers.Build_To_Any_Call
5884 (Object, Declarations))),
5885 Etyp => RTE (RE_Object_Ref)));
5887 Build_Stream_Procedure
5888 (Loc, RACW_Type, Body_Node,
5889 Make_Defining_Identifier (Loc, Procedure_Name),
5890 Statements, Outp => False);
5892 Proc_Decl :=
5893 Make_Subprogram_Declaration (Loc,
5894 Copy_Specification (Loc, Specification (Body_Node)));
5896 Attr_Decl :=
5897 Make_Attribute_Definition_Clause (Loc,
5898 Name => New_Occurrence_Of (RACW_Type, Loc),
5899 Chars => Name_Write,
5900 Expression =>
5901 New_Occurrence_Of (
5902 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5904 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5905 Insert_After (Proc_Decl, Attr_Decl);
5906 Append_To (Declarations, Body_Node);
5907 end Add_RACW_Write_Attribute;
5909 -----------------------
5910 -- Add_RAST_Features --
5911 -----------------------
5913 procedure Add_RAST_Features
5914 (Vis_Decl : Node_Id;
5915 RAS_Type : Entity_Id)
5917 begin
5918 Add_RAS_Access_TSS (Vis_Decl);
5920 Add_RAS_From_Any (RAS_Type);
5921 Add_RAS_TypeCode (RAS_Type);
5923 -- To_Any uses TypeCode, and therefore needs to be generated last
5925 Add_RAS_To_Any (RAS_Type);
5926 end Add_RAST_Features;
5928 ------------------------
5929 -- Add_RAS_Access_TSS --
5930 ------------------------
5932 procedure Add_RAS_Access_TSS (N : Node_Id) is
5933 Loc : constant Source_Ptr := Sloc (N);
5935 Ras_Type : constant Entity_Id := Defining_Identifier (N);
5936 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
5937 -- Ras_Type is the access to subprogram type; Fat_Type is the
5938 -- corresponding record type.
5940 RACW_Type : constant Entity_Id :=
5941 Underlying_RACW_Type (Ras_Type);
5942 Desig : constant Entity_Id :=
5943 Etype (Designated_Type (RACW_Type));
5945 Stub_Elements : constant Stub_Structure :=
5946 Stubs_Table.Get (Desig);
5947 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5949 Proc : constant Entity_Id :=
5950 Make_Defining_Identifier (Loc,
5951 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
5953 Proc_Spec : Node_Id;
5955 -- Formal parameters
5957 Package_Name : constant Entity_Id :=
5958 Make_Defining_Identifier (Loc,
5959 Chars => Name_P);
5961 -- Target package
5963 Subp_Id : constant Entity_Id :=
5964 Make_Defining_Identifier (Loc,
5965 Chars => Name_S);
5967 -- Target subprogram
5969 Asynch_P : constant Entity_Id :=
5970 Make_Defining_Identifier (Loc,
5971 Chars => Name_Asynchronous);
5972 -- Is the procedure to which the 'Access applies asynchronous?
5974 All_Calls_Remote : constant Entity_Id :=
5975 Make_Defining_Identifier (Loc,
5976 Chars => Name_All_Calls_Remote);
5977 -- True if an All_Calls_Remote pragma applies to the RCI unit
5978 -- that contains the subprogram.
5980 -- Common local variables
5982 Proc_Decls : List_Id;
5983 Proc_Statements : List_Id;
5985 Subp_Ref : constant Entity_Id :=
5986 Make_Defining_Identifier (Loc, Name_R);
5987 -- Reference that designates the target subprogram (returned
5988 -- by Get_RAS_Info).
5990 Is_Local : constant Entity_Id :=
5991 Make_Defining_Identifier (Loc, Name_L);
5992 Local_Addr : constant Entity_Id :=
5993 Make_Defining_Identifier (Loc, Name_A);
5994 -- For the call to Get_Local_Address
5996 -- Additional local variables for the remote case
5998 Local_Stub : constant Entity_Id :=
5999 Make_Defining_Identifier (Loc,
6000 Chars => New_Internal_Name ('L'));
6002 Stub_Ptr : constant Entity_Id :=
6003 Make_Defining_Identifier (Loc,
6004 Chars => New_Internal_Name ('S'));
6006 function Set_Field
6007 (Field_Name : Name_Id;
6008 Value : Node_Id) return Node_Id;
6009 -- Construct an assignment that sets the named component in the
6010 -- returned record
6012 ---------------
6013 -- Set_Field --
6014 ---------------
6016 function Set_Field
6017 (Field_Name : Name_Id;
6018 Value : Node_Id) return Node_Id
6020 begin
6021 return
6022 Make_Assignment_Statement (Loc,
6023 Name =>
6024 Make_Selected_Component (Loc,
6025 Prefix => Stub_Ptr,
6026 Selector_Name => Field_Name),
6027 Expression => Value);
6028 end Set_Field;
6030 -- Start of processing for Add_RAS_Access_TSS
6032 begin
6033 Proc_Decls := New_List (
6035 -- Common declarations
6037 Make_Object_Declaration (Loc,
6038 Defining_Identifier => Subp_Ref,
6039 Object_Definition =>
6040 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6042 Make_Object_Declaration (Loc,
6043 Defining_Identifier => Is_Local,
6044 Object_Definition =>
6045 New_Occurrence_Of (Standard_Boolean, Loc)),
6047 Make_Object_Declaration (Loc,
6048 Defining_Identifier => Local_Addr,
6049 Object_Definition =>
6050 New_Occurrence_Of (RTE (RE_Address), Loc)),
6052 Make_Object_Declaration (Loc,
6053 Defining_Identifier => Local_Stub,
6054 Aliased_Present => True,
6055 Object_Definition =>
6056 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6058 Make_Object_Declaration (Loc,
6059 Defining_Identifier =>
6060 Stub_Ptr,
6061 Object_Definition =>
6062 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6063 Expression =>
6064 Make_Attribute_Reference (Loc,
6065 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6066 Attribute_Name => Name_Unchecked_Access)));
6068 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6069 -- Build_Get_Unique_RP_Call needs this information
6071 -- Get_RAS_Info (Pkg, Subp, R);
6072 -- Obtain a reference to the target subprogram
6074 Proc_Statements := New_List (
6075 Make_Procedure_Call_Statement (Loc,
6076 Name =>
6077 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6078 Parameter_Associations => New_List (
6079 New_Occurrence_Of (Package_Name, Loc),
6080 New_Occurrence_Of (Subp_Id, Loc),
6081 New_Occurrence_Of (Subp_Ref, Loc))),
6083 -- Get_Local_Address (R, L, A);
6084 -- Determine whether the subprogram is local (L), and if so
6085 -- obtain the local address of its proxy (A).
6087 Make_Procedure_Call_Statement (Loc,
6088 Name =>
6089 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6090 Parameter_Associations => New_List (
6091 New_Occurrence_Of (Subp_Ref, Loc),
6092 New_Occurrence_Of (Is_Local, Loc),
6093 New_Occurrence_Of (Local_Addr, Loc))));
6095 -- Note: Here we assume that the Fat_Type is a record containing just
6096 -- an access to a proxy or stub object.
6098 Append_To (Proc_Statements,
6100 -- if L then
6102 Make_Implicit_If_Statement (N,
6103 Condition =>
6104 New_Occurrence_Of (Is_Local, Loc),
6106 Then_Statements => New_List (
6108 -- if A.Target = null then
6110 Make_Implicit_If_Statement (N,
6111 Condition =>
6112 Make_Op_Eq (Loc,
6113 Make_Selected_Component (Loc,
6114 Prefix =>
6115 Unchecked_Convert_To (
6116 RTE (RE_RAS_Proxy_Type_Access),
6117 New_Occurrence_Of (Local_Addr, Loc)),
6118 Selector_Name =>
6119 Make_Identifier (Loc, Name_Target)),
6120 Make_Null (Loc)),
6122 Then_Statements => New_List (
6124 -- A.Target := Entity_Of (Ref);
6126 Make_Assignment_Statement (Loc,
6127 Name =>
6128 Make_Selected_Component (Loc,
6129 Prefix =>
6130 Unchecked_Convert_To (
6131 RTE (RE_RAS_Proxy_Type_Access),
6132 New_Occurrence_Of (Local_Addr, Loc)),
6133 Selector_Name =>
6134 Make_Identifier (Loc, Name_Target)),
6135 Expression =>
6136 Make_Function_Call (Loc,
6137 Name =>
6138 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6139 Parameter_Associations => New_List (
6140 New_Occurrence_Of (Subp_Ref, Loc)))),
6142 -- Inc_Usage (A.Target);
6144 Make_Procedure_Call_Statement (Loc,
6145 Name =>
6146 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6147 Parameter_Associations => New_List (
6148 Make_Selected_Component (Loc,
6149 Prefix =>
6150 Unchecked_Convert_To (
6151 RTE (RE_RAS_Proxy_Type_Access),
6152 New_Occurrence_Of (Local_Addr, Loc)),
6153 Selector_Name => Make_Identifier (Loc,
6154 Name_Target)))))),
6156 -- end if;
6157 -- if not All_Calls_Remote then
6158 -- return Fat_Type!(A);
6159 -- end if;
6161 Make_Implicit_If_Statement (N,
6162 Condition =>
6163 Make_Op_Not (Loc,
6164 New_Occurrence_Of (All_Calls_Remote, Loc)),
6166 Then_Statements => New_List (
6167 Make_Return_Statement (Loc,
6168 Unchecked_Convert_To (Fat_Type,
6169 New_Occurrence_Of (Local_Addr, Loc))))))));
6171 Append_List_To (Proc_Statements, New_List (
6173 -- Stub.Target := Entity_Of (Ref);
6175 Set_Field (Name_Target,
6176 Make_Function_Call (Loc,
6177 Name =>
6178 New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6179 Parameter_Associations => New_List (
6180 New_Occurrence_Of (Subp_Ref, Loc)))),
6182 -- Inc_Usage (Stub.Target);
6184 Make_Procedure_Call_Statement (Loc,
6185 Name =>
6186 New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6187 Parameter_Associations => New_List (
6188 Make_Selected_Component (Loc,
6189 Prefix => Stub_Ptr,
6190 Selector_Name => Name_Target))),
6192 -- E.4.1(9) A remote call is asynchronous if it is a call to
6193 -- a procedure, or a call through a value of an access-to-procedure
6194 -- type, to which a pragma Asynchronous applies.
6196 -- Parameter Asynch_P is true when the procedure is asynchronous;
6197 -- Expression Asynch_T is true when the type is asynchronous.
6199 Set_Field (Name_Asynchronous,
6200 Make_Or_Else (Loc,
6201 New_Occurrence_Of (Asynch_P, Loc),
6202 New_Occurrence_Of (Boolean_Literals (
6203 Is_Asynchronous (Ras_Type)), Loc)))));
6205 Append_List_To (Proc_Statements,
6206 Build_Get_Unique_RP_Call (Loc,
6207 Stub_Ptr, Stub_Elements.Stub_Type));
6209 Append_To (Proc_Statements,
6210 Make_Return_Statement (Loc,
6211 Expression =>
6212 Unchecked_Convert_To (Fat_Type,
6213 New_Occurrence_Of (Stub_Ptr, Loc))));
6215 Proc_Spec :=
6216 Make_Function_Specification (Loc,
6217 Defining_Unit_Name => Proc,
6218 Parameter_Specifications => New_List (
6219 Make_Parameter_Specification (Loc,
6220 Defining_Identifier => Package_Name,
6221 Parameter_Type =>
6222 New_Occurrence_Of (Standard_String, Loc)),
6224 Make_Parameter_Specification (Loc,
6225 Defining_Identifier => Subp_Id,
6226 Parameter_Type =>
6227 New_Occurrence_Of (Standard_String, Loc)),
6229 Make_Parameter_Specification (Loc,
6230 Defining_Identifier => Asynch_P,
6231 Parameter_Type =>
6232 New_Occurrence_Of (Standard_Boolean, Loc)),
6234 Make_Parameter_Specification (Loc,
6235 Defining_Identifier => All_Calls_Remote,
6236 Parameter_Type =>
6237 New_Occurrence_Of (Standard_Boolean, Loc))),
6239 Result_Definition =>
6240 New_Occurrence_Of (Fat_Type, Loc));
6242 -- Set the kind and return type of the function to prevent
6243 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6245 Set_Ekind (Proc, E_Function);
6246 Set_Etype (Proc, Fat_Type);
6248 Discard_Node (
6249 Make_Subprogram_Body (Loc,
6250 Specification => Proc_Spec,
6251 Declarations => Proc_Decls,
6252 Handled_Statement_Sequence =>
6253 Make_Handled_Sequence_Of_Statements (Loc,
6254 Statements => Proc_Statements)));
6256 Set_TSS (Fat_Type, Proc);
6257 end Add_RAS_Access_TSS;
6259 ----------------------
6260 -- Add_RAS_From_Any --
6261 ----------------------
6263 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6264 Loc : constant Source_Ptr := Sloc (RAS_Type);
6266 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6267 Make_TSS_Name (RAS_Type, TSS_From_Any));
6269 Func_Spec : Node_Id;
6271 Statements : List_Id;
6273 Any_Parameter : constant Entity_Id :=
6274 Make_Defining_Identifier (Loc, Name_A);
6276 begin
6277 Statements := New_List (
6278 Make_Return_Statement (Loc,
6279 Expression =>
6280 Make_Aggregate (Loc,
6281 Component_Associations => New_List (
6282 Make_Component_Association (Loc,
6283 Choices => New_List (
6284 Make_Identifier (Loc, Name_Ras)),
6285 Expression =>
6286 PolyORB_Support.Helpers.Build_From_Any_Call (
6287 Underlying_RACW_Type (RAS_Type),
6288 New_Occurrence_Of (Any_Parameter, Loc),
6289 No_List))))));
6291 Func_Spec :=
6292 Make_Function_Specification (Loc,
6293 Defining_Unit_Name =>
6294 Fnam,
6295 Parameter_Specifications => New_List (
6296 Make_Parameter_Specification (Loc,
6297 Defining_Identifier =>
6298 Any_Parameter,
6299 Parameter_Type =>
6300 New_Occurrence_Of (RTE (RE_Any), Loc))),
6301 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6303 Discard_Node (
6304 Make_Subprogram_Body (Loc,
6305 Specification => Func_Spec,
6306 Declarations => No_List,
6307 Handled_Statement_Sequence =>
6308 Make_Handled_Sequence_Of_Statements (Loc,
6309 Statements => Statements)));
6310 Set_TSS (RAS_Type, Fnam);
6311 end Add_RAS_From_Any;
6313 --------------------
6314 -- Add_RAS_To_Any --
6315 --------------------
6317 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6318 Loc : constant Source_Ptr := Sloc (RAS_Type);
6320 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6321 Make_TSS_Name (RAS_Type, TSS_To_Any));
6323 Decls : List_Id;
6324 Statements : List_Id;
6326 Func_Spec : Node_Id;
6328 Any : constant Entity_Id :=
6329 Make_Defining_Identifier (Loc,
6330 Chars => New_Internal_Name ('A'));
6331 RAS_Parameter : constant Entity_Id :=
6332 Make_Defining_Identifier (Loc,
6333 Chars => New_Internal_Name ('R'));
6334 RACW_Parameter : constant Node_Id :=
6335 Make_Selected_Component (Loc,
6336 Prefix => RAS_Parameter,
6337 Selector_Name => Name_Ras);
6339 begin
6340 -- Object declarations
6342 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6343 Decls := New_List (
6344 Make_Object_Declaration (Loc,
6345 Defining_Identifier =>
6346 Any,
6347 Object_Definition =>
6348 New_Occurrence_Of (RTE (RE_Any), Loc),
6349 Expression =>
6350 PolyORB_Support.Helpers.Build_To_Any_Call
6351 (RACW_Parameter, No_List)));
6353 Statements := New_List (
6354 Make_Procedure_Call_Statement (Loc,
6355 Name =>
6356 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6357 Parameter_Associations => New_List (
6358 New_Occurrence_Of (Any, Loc),
6359 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6360 RAS_Type, Decls))),
6361 Make_Return_Statement (Loc,
6362 Expression =>
6363 New_Occurrence_Of (Any, Loc)));
6365 Func_Spec :=
6366 Make_Function_Specification (Loc,
6367 Defining_Unit_Name =>
6368 Fnam,
6369 Parameter_Specifications => New_List (
6370 Make_Parameter_Specification (Loc,
6371 Defining_Identifier =>
6372 RAS_Parameter,
6373 Parameter_Type =>
6374 New_Occurrence_Of (RAS_Type, Loc))),
6375 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6377 Discard_Node (
6378 Make_Subprogram_Body (Loc,
6379 Specification => Func_Spec,
6380 Declarations => Decls,
6381 Handled_Statement_Sequence =>
6382 Make_Handled_Sequence_Of_Statements (Loc,
6383 Statements => Statements)));
6384 Set_TSS (RAS_Type, Fnam);
6385 end Add_RAS_To_Any;
6387 ----------------------
6388 -- Add_RAS_TypeCode --
6389 ----------------------
6391 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6392 Loc : constant Source_Ptr := Sloc (RAS_Type);
6394 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6395 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6397 Func_Spec : Node_Id;
6399 Decls : constant List_Id := New_List;
6400 Name_String, Repo_Id_String : String_Id;
6402 begin
6403 Func_Spec :=
6404 Make_Function_Specification (Loc,
6405 Defining_Unit_Name =>
6406 Fnam,
6407 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6409 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6410 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6412 Discard_Node (
6413 Make_Subprogram_Body (Loc,
6414 Specification => Func_Spec,
6415 Declarations => Decls,
6416 Handled_Statement_Sequence =>
6417 Make_Handled_Sequence_Of_Statements (Loc,
6418 Statements => New_List (
6419 Make_Return_Statement (Loc,
6420 Expression =>
6421 Make_Function_Call (Loc,
6422 Name =>
6423 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
6424 Parameter_Associations => New_List (
6425 New_Occurrence_Of (RTE (RE_TC_Object), Loc),
6426 Make_Aggregate (Loc,
6427 Expressions =>
6428 New_List (
6429 Make_Function_Call (Loc,
6430 Name => New_Occurrence_Of (
6431 RTE (RE_TA_String), Loc),
6432 Parameter_Associations => New_List (
6433 Make_String_Literal (Loc, Name_String))),
6434 Make_Function_Call (Loc,
6435 Name => New_Occurrence_Of (
6436 RTE (RE_TA_String), Loc),
6437 Parameter_Associations => New_List (
6438 Make_String_Literal (Loc,
6439 Repo_Id_String))))))))))));
6440 Set_TSS (RAS_Type, Fnam);
6441 end Add_RAS_TypeCode;
6443 -----------------------------------------
6444 -- Add_Receiving_Stubs_To_Declarations --
6445 -----------------------------------------
6447 procedure Add_Receiving_Stubs_To_Declarations
6448 (Pkg_Spec : Node_Id;
6449 Decls : List_Id)
6451 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6453 Pkg_RPC_Receiver : constant Entity_Id :=
6454 Make_Defining_Identifier (Loc,
6455 New_Internal_Name ('H'));
6456 Pkg_RPC_Receiver_Object : Node_Id;
6458 Pkg_RPC_Receiver_Body : Node_Id;
6459 Pkg_RPC_Receiver_Decls : List_Id;
6460 Pkg_RPC_Receiver_Statements : List_Id;
6461 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6462 -- A Pkg_RPC_Receiver is built to decode the request
6464 Request : Node_Id;
6465 -- Request object received from neutral layer
6467 Subp_Id : Entity_Id;
6468 -- Subprogram identifier as received from the neutral
6469 -- distribution core.
6471 Subp_Index : Entity_Id;
6472 -- Internal index as determined by matching either the
6473 -- method name from the request structure, or the local
6474 -- subprogram address (in case of a RAS).
6476 Is_Local : constant Entity_Id :=
6477 Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
6478 Local_Address : constant Entity_Id :=
6479 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
6480 -- Address of a local subprogram designated by a
6481 -- reference corresponding to a RAS.
6483 Dispatch_On_Address : constant List_Id := New_List;
6484 Dispatch_On_Name : constant List_Id := New_List;
6486 Current_Declaration : Node_Id;
6487 Current_Stubs : Node_Id;
6488 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
6490 Subp_Info_Array : constant Entity_Id :=
6491 Make_Defining_Identifier (Loc,
6492 Chars => New_Internal_Name ('I'));
6494 Subp_Info_List : constant List_Id := New_List;
6496 Register_Pkg_Actuals : constant List_Id := New_List;
6498 All_Calls_Remote_E : Entity_Id;
6500 procedure Append_Stubs_To
6501 (RPC_Receiver_Cases : List_Id;
6502 Declaration : Node_Id;
6503 Stubs : Node_Id;
6504 Subp_Number : Int;
6505 Subp_Dist_Name : Entity_Id;
6506 Subp_Proxy_Addr : Entity_Id);
6507 -- Add one case to the specified RPC receiver case list associating
6508 -- Subprogram_Number with the subprogram declared by Declaration, for
6509 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6510 -- subprogram index. Subp_Dist_Name is the string used to call the
6511 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6512 -- object, used in the context of calls through remote
6513 -- access-to-subprogram types.
6515 ---------------------
6516 -- Append_Stubs_To --
6517 ---------------------
6519 procedure Append_Stubs_To
6520 (RPC_Receiver_Cases : List_Id;
6521 Declaration : Node_Id;
6522 Stubs : Node_Id;
6523 Subp_Number : Int;
6524 Subp_Dist_Name : Entity_Id;
6525 Subp_Proxy_Addr : Entity_Id)
6527 Case_Stmts : List_Id;
6528 begin
6529 Case_Stmts := New_List (
6530 Make_Procedure_Call_Statement (Loc,
6531 Name =>
6532 New_Occurrence_Of (
6533 Defining_Entity (Stubs), Loc),
6534 Parameter_Associations =>
6535 New_List (New_Occurrence_Of (Request, Loc))));
6536 if Nkind (Specification (Declaration))
6537 = N_Function_Specification
6538 or else not
6539 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6540 then
6541 Append_To (Case_Stmts, Make_Return_Statement (Loc));
6542 end if;
6544 Append_To (RPC_Receiver_Cases,
6545 Make_Case_Statement_Alternative (Loc,
6546 Discrete_Choices =>
6547 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6548 Statements =>
6549 Case_Stmts));
6551 Append_To (Dispatch_On_Name,
6552 Make_Elsif_Part (Loc,
6553 Condition =>
6554 Make_Function_Call (Loc,
6555 Name =>
6556 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6557 Parameter_Associations => New_List (
6558 New_Occurrence_Of (Subp_Id, Loc),
6559 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6560 Then_Statements => New_List (
6561 Make_Assignment_Statement (Loc,
6562 New_Occurrence_Of (Subp_Index, Loc),
6563 Make_Integer_Literal (Loc,
6564 Subp_Number)))));
6566 Append_To (Dispatch_On_Address,
6567 Make_Elsif_Part (Loc,
6568 Condition =>
6569 Make_Op_Eq (Loc,
6570 Left_Opnd =>
6571 New_Occurrence_Of (Local_Address, Loc),
6572 Right_Opnd =>
6573 New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6574 Then_Statements => New_List (
6575 Make_Assignment_Statement (Loc,
6576 New_Occurrence_Of (Subp_Index, Loc),
6577 Make_Integer_Literal (Loc,
6578 Subp_Number)))));
6579 end Append_Stubs_To;
6581 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6583 begin
6584 -- Building receiving stubs consist in several operations:
6586 -- - a package RPC receiver must be built. This subprogram
6587 -- will get a Subprogram_Id from the incoming stream
6588 -- and will dispatch the call to the right subprogram
6590 -- - a receiving stub for any subprogram visible in the package
6591 -- spec. This stub will read all the parameters from the stream,
6592 -- and put the result as well as the exception occurrence in the
6593 -- output stream
6595 -- - a dummy package with an empty spec and a body made of an
6596 -- elaboration part, whose job is to register the receiving
6597 -- part of this RCI package on the name server. This is done
6598 -- by calling System.Partition_Interface.Register_Receiving_Stub
6600 Build_RPC_Receiver_Body (
6601 RPC_Receiver => Pkg_RPC_Receiver,
6602 Request => Request,
6603 Subp_Id => Subp_Id,
6604 Subp_Index => Subp_Index,
6605 Stmts => Pkg_RPC_Receiver_Statements,
6606 Decl => Pkg_RPC_Receiver_Body);
6607 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6609 -- Extract local address information from the target reference:
6610 -- if non-null, that means that this is a reference that denotes
6611 -- one particular operation, and hence that the operation name
6612 -- must not be taken into account for dispatching.
6614 Append_To (Pkg_RPC_Receiver_Decls,
6615 Make_Object_Declaration (Loc,
6616 Defining_Identifier =>
6617 Is_Local,
6618 Object_Definition =>
6619 New_Occurrence_Of (Standard_Boolean, Loc)));
6620 Append_To (Pkg_RPC_Receiver_Decls,
6621 Make_Object_Declaration (Loc,
6622 Defining_Identifier =>
6623 Local_Address,
6624 Object_Definition =>
6625 New_Occurrence_Of (RTE (RE_Address), Loc)));
6626 Append_To (Pkg_RPC_Receiver_Statements,
6627 Make_Procedure_Call_Statement (Loc,
6628 Name =>
6629 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6630 Parameter_Associations => New_List (
6631 Make_Selected_Component (Loc,
6632 Prefix => Request,
6633 Selector_Name => Name_Target),
6634 New_Occurrence_Of (Is_Local, Loc),
6635 New_Occurrence_Of (Local_Address, Loc))));
6637 -- Determine whether the reference that was used to make
6638 -- the call was the base RCI reference (in which case
6639 -- Local_Address is 0, and the method identifier from the
6640 -- request must be used to determine which subprogram is
6641 -- called) or a reference identifying one particular subprogram
6642 -- (in which case Local_Address is the address of that
6643 -- subprogram, and the method name from the request is
6644 -- ignored).
6645 -- In each case, cascaded elsifs are used to determine the
6646 -- proper subprogram index. Using hash tables might be
6647 -- more efficient.
6649 Append_To (Pkg_RPC_Receiver_Statements,
6650 Make_Implicit_If_Statement (Pkg_Spec,
6651 Condition =>
6652 Make_Op_Ne (Loc,
6653 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6654 Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
6655 Then_Statements => New_List (
6656 Make_Implicit_If_Statement (Pkg_Spec,
6657 Condition =>
6658 New_Occurrence_Of (Standard_False, Loc),
6659 Then_Statements => New_List (
6660 Make_Null_Statement (Loc)),
6661 Elsif_Parts =>
6662 Dispatch_On_Address)),
6663 Else_Statements => New_List (
6664 Make_Implicit_If_Statement (Pkg_Spec,
6665 Condition =>
6666 New_Occurrence_Of (Standard_False, Loc),
6667 Then_Statements => New_List (
6668 Make_Null_Statement (Loc)),
6669 Elsif_Parts =>
6670 Dispatch_On_Name))));
6672 -- For each subprogram, the receiving stub will be built and a
6673 -- case statement will be made on the Subprogram_Id to dispatch
6674 -- to the right subprogram.
6676 All_Calls_Remote_E := Boolean_Literals (
6677 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6679 Overload_Counter_Table.Reset;
6680 Reserve_NamingContext_Methods;
6682 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
6683 while Present (Current_Declaration) loop
6684 if Nkind (Current_Declaration) = N_Subprogram_Declaration
6685 and then Comes_From_Source (Current_Declaration)
6686 then
6687 declare
6688 Loc : constant Source_Ptr :=
6689 Sloc (Current_Declaration);
6690 -- While specifically processing Current_Declaration, use
6691 -- its Sloc as the location of all generated nodes.
6693 Subp_Def : constant Entity_Id :=
6694 Defining_Unit_Name
6695 (Specification (Current_Declaration));
6697 Subp_Val : String_Id;
6699 Subp_Dist_Name : constant Entity_Id :=
6700 Make_Defining_Identifier (Loc,
6701 New_External_Name (
6702 Related_Id => Chars (Subp_Def),
6703 Suffix => 'D',
6704 Suffix_Index => -1));
6706 Proxy_Object_Addr : Entity_Id;
6708 begin
6709 pragma Assert (Current_Subprogram_Number =
6710 Get_Subprogram_Id (Subp_Def));
6712 -- Build receiving stub
6714 Current_Stubs :=
6715 Build_Subprogram_Receiving_Stubs
6716 (Vis_Decl => Current_Declaration,
6717 Asynchronous =>
6718 Nkind (Specification (Current_Declaration)) =
6719 N_Procedure_Specification
6720 and then Is_Asynchronous (Subp_Def));
6722 Append_To (Decls, Current_Stubs);
6723 Analyze (Current_Stubs);
6725 -- Build RAS proxy
6727 Add_RAS_Proxy_And_Analyze (Decls,
6728 Vis_Decl =>
6729 Current_Declaration,
6730 All_Calls_Remote_E =>
6731 All_Calls_Remote_E,
6732 Proxy_Object_Addr =>
6733 Proxy_Object_Addr);
6735 -- Compute distribution identifier
6737 Assign_Subprogram_Identifier (
6738 Subp_Def,
6739 Current_Subprogram_Number,
6740 Subp_Val);
6742 Append_To (Decls,
6743 Make_Object_Declaration (Loc,
6744 Defining_Identifier => Subp_Dist_Name,
6745 Constant_Present => True,
6746 Object_Definition => New_Occurrence_Of (
6747 Standard_String, Loc),
6748 Expression =>
6749 Make_String_Literal (Loc, Subp_Val)));
6750 Analyze (Last (Decls));
6752 -- Add subprogram descriptor (RCI_Subp_Info) to the
6753 -- subprograms table for this receiver. The aggregate
6754 -- below must be kept consistent with the declaration
6755 -- of type RCI_Subp_Info in System.Partition_Interface.
6757 Append_To (Subp_Info_List,
6758 Make_Component_Association (Loc,
6759 Choices => New_List (
6760 Make_Integer_Literal (Loc,
6761 Current_Subprogram_Number)),
6762 Expression =>
6763 Make_Aggregate (Loc,
6764 Expressions => New_List (
6765 Make_Attribute_Reference (Loc,
6766 Prefix =>
6767 New_Occurrence_Of (
6768 Subp_Dist_Name, Loc),
6769 Attribute_Name => Name_Address),
6770 Make_Attribute_Reference (Loc,
6771 Prefix =>
6772 New_Occurrence_Of (
6773 Subp_Dist_Name, Loc),
6774 Attribute_Name => Name_Length),
6775 New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
6777 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6778 Declaration => Current_Declaration,
6779 Stubs => Current_Stubs,
6780 Subp_Number => Current_Subprogram_Number,
6781 Subp_Dist_Name => Subp_Dist_Name,
6782 Subp_Proxy_Addr => Proxy_Object_Addr);
6783 end;
6785 Current_Subprogram_Number := Current_Subprogram_Number + 1;
6786 end if;
6788 Next (Current_Declaration);
6789 end loop;
6791 -- If we receive an invalid Subprogram_Id, it is best to do nothing
6792 -- rather than raising an exception since we do not want someone
6793 -- to crash a remote partition by sending invalid subprogram ids.
6794 -- This is consistent with the other parts of the case statement
6795 -- since even in presence of incorrect parameters in the stream,
6796 -- every exception will be caught and (if the subprogram is not an
6797 -- APC) put into the result stream and sent away.
6799 Append_To (Pkg_RPC_Receiver_Cases,
6800 Make_Case_Statement_Alternative (Loc,
6801 Discrete_Choices =>
6802 New_List (Make_Others_Choice (Loc)),
6803 Statements =>
6804 New_List (Make_Null_Statement (Loc))));
6806 Append_To (Pkg_RPC_Receiver_Statements,
6807 Make_Case_Statement (Loc,
6808 Expression =>
6809 New_Occurrence_Of (Subp_Index, Loc),
6810 Alternatives => Pkg_RPC_Receiver_Cases));
6812 Append_To (Decls,
6813 Make_Object_Declaration (Loc,
6814 Defining_Identifier => Subp_Info_Array,
6815 Constant_Present => True,
6816 Aliased_Present => True,
6817 Object_Definition =>
6818 Make_Subtype_Indication (Loc,
6819 Subtype_Mark =>
6820 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6821 Constraint =>
6822 Make_Index_Or_Discriminant_Constraint (Loc,
6823 New_List (
6824 Make_Range (Loc,
6825 Low_Bound => Make_Integer_Literal (Loc,
6826 First_RCI_Subprogram_Id),
6827 High_Bound =>
6828 Make_Integer_Literal (Loc,
6829 First_RCI_Subprogram_Id
6830 + List_Length (Subp_Info_List) - 1))))),
6831 Expression =>
6832 Make_Aggregate (Loc,
6833 Component_Associations => Subp_Info_List)));
6834 Analyze (Last (Decls));
6836 Append_To (Decls, Pkg_RPC_Receiver_Body);
6837 Analyze (Last (Decls));
6839 Pkg_RPC_Receiver_Object :=
6840 Make_Object_Declaration (Loc,
6841 Defining_Identifier =>
6842 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
6843 Aliased_Present => True,
6844 Object_Definition =>
6845 New_Occurrence_Of (RTE (RE_Servant), Loc));
6846 Append_To (Decls, Pkg_RPC_Receiver_Object);
6847 Analyze (Last (Decls));
6849 Get_Library_Unit_Name_String (Pkg_Spec);
6850 Append_To (Register_Pkg_Actuals,
6851 -- Name
6852 Make_String_Literal (Loc,
6853 Strval => String_From_Name_Buffer));
6855 Append_To (Register_Pkg_Actuals,
6856 -- Version
6857 Make_Attribute_Reference (Loc,
6858 Prefix =>
6859 New_Occurrence_Of
6860 (Defining_Entity (Pkg_Spec), Loc),
6861 Attribute_Name =>
6862 Name_Version));
6864 Append_To (Register_Pkg_Actuals,
6865 -- Handler
6866 Make_Attribute_Reference (Loc,
6867 Prefix =>
6868 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
6869 Attribute_Name => Name_Access));
6871 Append_To (Register_Pkg_Actuals,
6872 -- Receiver
6873 Make_Attribute_Reference (Loc,
6874 Prefix =>
6875 New_Occurrence_Of (
6876 Defining_Identifier (
6877 Pkg_RPC_Receiver_Object), Loc),
6878 Attribute_Name =>
6879 Name_Access));
6881 Append_To (Register_Pkg_Actuals,
6882 -- Subp_Info
6883 Make_Attribute_Reference (Loc,
6884 Prefix =>
6885 New_Occurrence_Of (Subp_Info_Array, Loc),
6886 Attribute_Name =>
6887 Name_Address));
6889 Append_To (Register_Pkg_Actuals,
6890 -- Subp_Info_Len
6891 Make_Attribute_Reference (Loc,
6892 Prefix =>
6893 New_Occurrence_Of (Subp_Info_Array, Loc),
6894 Attribute_Name =>
6895 Name_Length));
6897 Append_To (Register_Pkg_Actuals,
6898 -- Is_All_Calls_Remote
6899 New_Occurrence_Of (All_Calls_Remote_E, Loc));
6901 Append_To (Decls,
6902 Make_Procedure_Call_Statement (Loc,
6903 Name =>
6904 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
6905 Parameter_Associations => Register_Pkg_Actuals));
6906 Analyze (Last (Decls));
6908 end Add_Receiving_Stubs_To_Declarations;
6910 ---------------------------------
6911 -- Build_General_Calling_Stubs --
6912 ---------------------------------
6914 procedure Build_General_Calling_Stubs
6915 (Decls : List_Id;
6916 Statements : List_Id;
6917 Target_Object : Node_Id;
6918 Subprogram_Id : Node_Id;
6919 Asynchronous : Node_Id := Empty;
6920 Is_Known_Asynchronous : Boolean := False;
6921 Is_Known_Non_Asynchronous : Boolean := False;
6922 Is_Function : Boolean;
6923 Spec : Node_Id;
6924 Stub_Type : Entity_Id := Empty;
6925 RACW_Type : Entity_Id := Empty;
6926 Nod : Node_Id)
6928 Loc : constant Source_Ptr := Sloc (Nod);
6930 Arguments : Node_Id;
6931 -- Name of the named values list used to transmit parameters
6932 -- to the remote package
6934 Request : Node_Id;
6935 -- The request object constructed by these stubs
6937 Result : Node_Id;
6938 -- Name of the result named value (in non-APC cases) which get the
6939 -- result of the remote subprogram.
6941 Result_TC : Node_Id;
6942 -- Typecode expression for the result of the request (void
6943 -- typecode for procedures).
6945 Exception_Return_Parameter : Node_Id;
6946 -- Name of the parameter which will hold the exception sent by the
6947 -- remote subprogram.
6949 Current_Parameter : Node_Id;
6950 -- Current parameter being handled
6952 Ordered_Parameters_List : constant List_Id :=
6953 Build_Ordered_Parameters_List (Spec);
6955 Asynchronous_P : Node_Id;
6956 -- A Boolean expression indicating whether this call is asynchronous
6958 Asynchronous_Statements : List_Id := No_List;
6959 Non_Asynchronous_Statements : List_Id := No_List;
6960 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
6962 Extra_Formal_Statements : constant List_Id := New_List;
6963 -- List of statements for extra formal parameters. It will appear
6964 -- after the regular statements for writing out parameters.
6966 After_Statements : constant List_Id := New_List;
6967 -- Statements to be executed after call returns (to assign
6968 -- in out or out parameter values).
6970 Etyp : Entity_Id;
6971 -- The type of the formal parameter being processed
6973 Is_Controlling_Formal : Boolean;
6974 Is_First_Controlling_Formal : Boolean;
6975 First_Controlling_Formal_Seen : Boolean := False;
6976 -- Controlling formal parameters of distributed object
6977 -- primitives require special handling, and the first
6978 -- such parameter needs even more.
6980 begin
6981 -- ??? document general form of stub subprograms for the PolyORB case
6982 Request :=
6983 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
6985 Append_To (Decls,
6986 Make_Object_Declaration (Loc,
6987 Defining_Identifier => Request,
6988 Aliased_Present => False,
6989 Object_Definition =>
6990 New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
6992 Result :=
6993 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
6995 if Is_Function then
6996 Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6997 Etype (Result_Definition (Spec)), Decls);
6998 else
6999 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7000 end if;
7002 Append_To (Decls,
7003 Make_Object_Declaration (Loc,
7004 Defining_Identifier => Result,
7005 Aliased_Present => False,
7006 Object_Definition =>
7007 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7008 Expression =>
7009 Make_Aggregate (Loc,
7010 Component_Associations => New_List (
7011 Make_Component_Association (Loc,
7012 Choices => New_List (
7013 Make_Identifier (Loc, Name_Name)),
7014 Expression =>
7015 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7016 Make_Component_Association (Loc,
7017 Choices => New_List (
7018 Make_Identifier (Loc, Name_Argument)),
7019 Expression =>
7020 Make_Function_Call (Loc,
7021 Name =>
7022 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7023 Parameter_Associations => New_List (
7024 Result_TC))),
7025 Make_Component_Association (Loc,
7026 Choices => New_List (
7027 Make_Identifier (Loc, Name_Arg_Modes)),
7028 Expression =>
7029 Make_Integer_Literal (Loc, 0))))));
7031 if not Is_Known_Asynchronous then
7032 Exception_Return_Parameter :=
7033 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
7035 Append_To (Decls,
7036 Make_Object_Declaration (Loc,
7037 Defining_Identifier => Exception_Return_Parameter,
7038 Object_Definition =>
7039 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7041 else
7042 Exception_Return_Parameter := Empty;
7043 end if;
7045 -- Initialize and fill in arguments list
7047 Arguments :=
7048 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7049 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7051 Current_Parameter := First (Ordered_Parameters_List);
7052 while Present (Current_Parameter) loop
7054 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7055 Is_Controlling_Formal := True;
7056 Is_First_Controlling_Formal :=
7057 not First_Controlling_Formal_Seen;
7058 First_Controlling_Formal_Seen := True;
7059 else
7060 Is_Controlling_Formal := False;
7061 Is_First_Controlling_Formal := False;
7062 end if;
7064 if Is_Controlling_Formal then
7066 -- In the case of a controlling formal argument, we send
7067 -- its reference.
7069 Etyp := RACW_Type;
7071 else
7072 Etyp := Etype (Parameter_Type (Current_Parameter));
7073 end if;
7075 -- The first controlling formal parameter is treated
7076 -- specially: it is used to set the target object of
7077 -- the call.
7079 if not Is_First_Controlling_Formal then
7081 declare
7082 Constrained : constant Boolean :=
7083 Is_Constrained (Etyp)
7084 or else Is_Elementary_Type (Etyp);
7086 Any : constant Entity_Id :=
7087 Make_Defining_Identifier (Loc,
7088 New_Internal_Name ('A'));
7090 Actual_Parameter : Node_Id :=
7091 New_Occurrence_Of (
7092 Defining_Identifier (
7093 Current_Parameter), Loc);
7095 Expr : Node_Id;
7097 begin
7098 if Is_Controlling_Formal then
7100 -- For a controlling formal parameter (other
7101 -- than the first one), use the corresponding
7102 -- RACW. If the parameter is not an anonymous
7103 -- access parameter, that involves taking
7104 -- its 'Unrestricted_Access.
7106 if Nkind (Parameter_Type (Current_Parameter))
7107 = N_Access_Definition
7108 then
7109 Actual_Parameter := OK_Convert_To
7110 (Etyp, Actual_Parameter);
7111 else
7112 Actual_Parameter := OK_Convert_To (Etyp,
7113 Make_Attribute_Reference (Loc,
7114 Prefix =>
7115 Actual_Parameter,
7116 Attribute_Name =>
7117 Name_Unrestricted_Access));
7118 end if;
7120 end if;
7122 if In_Present (Current_Parameter)
7123 or else not Out_Present (Current_Parameter)
7124 or else not Constrained
7125 or else Is_Controlling_Formal
7126 then
7127 -- The parameter has an input value, is constrained
7128 -- at runtime by an input value, or is a controlling
7129 -- formal parameter (always passed as a reference)
7130 -- other than the first one.
7132 Expr := PolyORB_Support.Helpers.Build_To_Any_Call (
7133 Actual_Parameter, Decls);
7134 else
7135 Expr := Make_Function_Call (Loc,
7136 Name =>
7137 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7138 Parameter_Associations => New_List (
7139 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7140 Etyp, Decls)));
7141 end if;
7143 Append_To (Decls,
7144 Make_Object_Declaration (Loc,
7145 Defining_Identifier =>
7146 Any,
7147 Aliased_Present => False,
7148 Object_Definition =>
7149 New_Occurrence_Of (RTE (RE_Any), Loc),
7150 Expression =>
7151 Expr));
7153 Append_To (Statements,
7154 Add_Parameter_To_NVList (Loc,
7155 Parameter => Current_Parameter,
7156 NVList => Arguments,
7157 Constrained => Constrained,
7158 Any => Any));
7160 if Out_Present (Current_Parameter)
7161 and then not Is_Controlling_Formal
7162 then
7163 Append_To (After_Statements,
7164 Make_Assignment_Statement (Loc,
7165 Name =>
7166 New_Occurrence_Of (
7167 Defining_Identifier (Current_Parameter), Loc),
7168 Expression =>
7169 PolyORB_Support.Helpers.Build_From_Any_Call (
7170 Etype (Parameter_Type (Current_Parameter)),
7171 New_Occurrence_Of (Any, Loc),
7172 Decls)));
7174 end if;
7175 end;
7176 end if;
7178 -- If the current parameter has a dynamic constrained status,
7179 -- then this status is transmitted as well.
7180 -- This should be done for accessibility as well ???
7182 if Nkind (Parameter_Type (Current_Parameter))
7183 /= N_Access_Definition
7184 and then Need_Extra_Constrained (Current_Parameter)
7185 then
7186 -- In this block, we do not use the extra formal that has been
7187 -- created because it does not exist at the time of expansion
7188 -- when building calling stubs for remote access to subprogram
7189 -- types. We create an extra variable of this type and push it
7190 -- in the stream after the regular parameters.
7192 declare
7193 Extra_Any_Parameter : constant Entity_Id :=
7194 Make_Defining_Identifier
7195 (Loc, New_Internal_Name ('P'));
7197 begin
7198 Append_To (Decls,
7199 Make_Object_Declaration (Loc,
7200 Defining_Identifier =>
7201 Extra_Any_Parameter,
7202 Aliased_Present => False,
7203 Object_Definition =>
7204 New_Occurrence_Of (RTE (RE_Any), Loc),
7205 Expression =>
7206 PolyORB_Support.Helpers.Build_To_Any_Call (
7207 Make_Attribute_Reference (Loc,
7208 Prefix =>
7209 New_Occurrence_Of (
7210 Defining_Identifier (Current_Parameter), Loc),
7211 Attribute_Name => Name_Constrained),
7212 Decls)));
7213 Append_To (Extra_Formal_Statements,
7214 Add_Parameter_To_NVList (Loc,
7215 Parameter => Extra_Any_Parameter,
7216 NVList => Arguments,
7217 Constrained => True,
7218 Any => Extra_Any_Parameter));
7219 end;
7220 end if;
7222 Next (Current_Parameter);
7223 end loop;
7225 -- Append the formal statements list to the statements
7227 Append_List_To (Statements, Extra_Formal_Statements);
7229 Append_To (Statements,
7230 Make_Procedure_Call_Statement (Loc,
7231 Name =>
7232 New_Occurrence_Of (RTE (RE_Request_Create), Loc),
7233 Parameter_Associations => New_List (
7234 Target_Object,
7235 Subprogram_Id,
7236 New_Occurrence_Of (Arguments, Loc),
7237 New_Occurrence_Of (Result, Loc),
7238 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7240 Append_To (Parameter_Associations (Last (Statements)),
7241 New_Occurrence_Of (Request, Loc));
7243 pragma Assert (
7244 not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7245 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7246 Asynchronous_P := New_Occurrence_Of (
7247 Boolean_Literals (Is_Known_Asynchronous), Loc);
7248 else
7249 pragma Assert (Present (Asynchronous));
7250 Asynchronous_P := New_Copy_Tree (Asynchronous);
7251 -- The expression node Asynchronous will be used to build
7252 -- an 'if' statement at the end of Build_General_Calling_Stubs:
7253 -- we need to make a copy here.
7254 end if;
7256 Append_To (Parameter_Associations (Last (Statements)),
7257 Make_Indexed_Component (Loc,
7258 Prefix =>
7259 New_Occurrence_Of (
7260 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7261 Expressions => New_List (Asynchronous_P)));
7263 Append_To (Statements,
7264 Make_Procedure_Call_Statement (Loc,
7265 Name =>
7266 New_Occurrence_Of (RTE (RE_Request_Invoke), Loc),
7267 Parameter_Associations => New_List (
7268 New_Occurrence_Of (Request, Loc))));
7270 Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7271 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7273 if not Is_Known_Asynchronous then
7275 -- Reraise an exception occurrence from the completed request.
7276 -- If the exception occurrence is empty, this is a no-op.
7278 Append_To (Non_Asynchronous_Statements,
7279 Make_Procedure_Call_Statement (Loc,
7280 Name =>
7281 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7282 Parameter_Associations => New_List (
7283 New_Occurrence_Of (Request, Loc))));
7285 if Is_Function then
7287 -- If this is a function call, then read the value and
7288 -- return it.
7290 Append_To (Non_Asynchronous_Statements,
7291 Make_Tag_Check (Loc,
7292 Make_Return_Statement (Loc,
7293 PolyORB_Support.Helpers.Build_From_Any_Call (
7294 Etype (Result_Definition (Spec)),
7295 Make_Selected_Component (Loc,
7296 Prefix => Result,
7297 Selector_Name => Name_Argument),
7298 Decls))));
7299 end if;
7300 end if;
7302 Append_List_To (Non_Asynchronous_Statements,
7303 After_Statements);
7305 if Is_Known_Asynchronous then
7306 Append_List_To (Statements, Asynchronous_Statements);
7308 elsif Is_Known_Non_Asynchronous then
7309 Append_List_To (Statements, Non_Asynchronous_Statements);
7311 else
7312 pragma Assert (Present (Asynchronous));
7313 Append_To (Statements,
7314 Make_Implicit_If_Statement (Nod,
7315 Condition => Asynchronous,
7316 Then_Statements => Asynchronous_Statements,
7317 Else_Statements => Non_Asynchronous_Statements));
7318 end if;
7319 end Build_General_Calling_Stubs;
7321 -----------------------
7322 -- Build_Stub_Target --
7323 -----------------------
7325 function Build_Stub_Target
7326 (Loc : Source_Ptr;
7327 Decls : List_Id;
7328 RCI_Locator : Entity_Id;
7329 Controlling_Parameter : Entity_Id) return RPC_Target
7331 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7332 Target_Reference : constant Entity_Id :=
7333 Make_Defining_Identifier (Loc,
7334 New_Internal_Name ('T'));
7335 begin
7336 if Present (Controlling_Parameter) then
7337 Append_To (Decls,
7338 Make_Object_Declaration (Loc,
7339 Defining_Identifier => Target_Reference,
7340 Object_Definition =>
7341 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7342 Expression =>
7343 Make_Function_Call (Loc,
7344 Name =>
7345 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7346 Parameter_Associations => New_List (
7347 Make_Selected_Component (Loc,
7348 Prefix => Controlling_Parameter,
7349 Selector_Name => Name_Target)))));
7350 -- Controlling_Parameter has the same components
7351 -- as System.Partition_Interface.RACW_Stub_Type.
7353 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7355 else
7356 Target_Info.Object :=
7357 Make_Selected_Component (Loc,
7358 Prefix =>
7359 Make_Identifier (Loc, Chars (RCI_Locator)),
7360 Selector_Name =>
7361 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7362 end if;
7363 return Target_Info;
7364 end Build_Stub_Target;
7366 ---------------------
7367 -- Build_Stub_Type --
7368 ---------------------
7370 procedure Build_Stub_Type
7371 (RACW_Type : Entity_Id;
7372 Stub_Type : Entity_Id;
7373 Stub_Type_Decl : out Node_Id;
7374 RPC_Receiver_Decl : out Node_Id)
7376 Loc : constant Source_Ptr := Sloc (Stub_Type);
7377 pragma Warnings (Off);
7378 pragma Unreferenced (RACW_Type);
7379 pragma Warnings (On);
7381 begin
7382 Stub_Type_Decl :=
7383 Make_Full_Type_Declaration (Loc,
7384 Defining_Identifier => Stub_Type,
7385 Type_Definition =>
7386 Make_Record_Definition (Loc,
7387 Tagged_Present => True,
7388 Limited_Present => True,
7389 Component_List =>
7390 Make_Component_List (Loc,
7391 Component_Items => New_List (
7393 Make_Component_Declaration (Loc,
7394 Defining_Identifier =>
7395 Make_Defining_Identifier (Loc, Name_Target),
7396 Component_Definition =>
7397 Make_Component_Definition (Loc,
7398 Aliased_Present =>
7399 False,
7400 Subtype_Indication =>
7401 New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
7403 Make_Component_Declaration (Loc,
7404 Defining_Identifier =>
7405 Make_Defining_Identifier (Loc, Name_Asynchronous),
7406 Component_Definition =>
7407 Make_Component_Definition (Loc,
7408 Aliased_Present => False,
7409 Subtype_Indication =>
7410 New_Occurrence_Of (
7411 Standard_Boolean, Loc)))))));
7413 RPC_Receiver_Decl :=
7414 Make_Object_Declaration (Loc,
7415 Defining_Identifier => Make_Defining_Identifier (Loc,
7416 New_Internal_Name ('R')),
7417 Aliased_Present => True,
7418 Object_Definition =>
7419 New_Occurrence_Of (RTE (RE_Servant), Loc));
7420 end Build_Stub_Type;
7422 -----------------------------
7423 -- Build_RPC_Receiver_Body --
7424 -----------------------------
7426 procedure Build_RPC_Receiver_Body
7427 (RPC_Receiver : Entity_Id;
7428 Request : out Entity_Id;
7429 Subp_Id : out Entity_Id;
7430 Subp_Index : out Entity_Id;
7431 Stmts : out List_Id;
7432 Decl : out Node_Id)
7434 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7436 RPC_Receiver_Spec : Node_Id;
7437 RPC_Receiver_Decls : List_Id;
7439 begin
7440 Request := Make_Defining_Identifier (Loc, Name_R);
7442 RPC_Receiver_Spec :=
7443 Build_RPC_Receiver_Specification (
7444 RPC_Receiver => RPC_Receiver,
7445 Request_Parameter => Request);
7447 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7448 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7450 RPC_Receiver_Decls := New_List (
7451 Make_Object_Renaming_Declaration (Loc,
7452 Defining_Identifier => Subp_Id,
7453 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7454 Name =>
7455 Make_Explicit_Dereference (Loc,
7456 Prefix =>
7457 Make_Selected_Component (Loc,
7458 Prefix => Request,
7459 Selector_Name => Name_Operation))),
7461 Make_Object_Declaration (Loc,
7462 Defining_Identifier => Subp_Index,
7463 Object_Definition =>
7464 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7465 Expression =>
7466 Make_Attribute_Reference (Loc,
7467 Prefix =>
7468 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7469 Attribute_Name => Name_Last)));
7471 Stmts := New_List;
7473 Decl :=
7474 Make_Subprogram_Body (Loc,
7475 Specification => RPC_Receiver_Spec,
7476 Declarations => RPC_Receiver_Decls,
7477 Handled_Statement_Sequence =>
7478 Make_Handled_Sequence_Of_Statements (Loc,
7479 Statements => Stmts));
7480 end Build_RPC_Receiver_Body;
7482 --------------------------------------
7483 -- Build_Subprogram_Receiving_Stubs --
7484 --------------------------------------
7486 function Build_Subprogram_Receiving_Stubs
7487 (Vis_Decl : Node_Id;
7488 Asynchronous : Boolean;
7489 Dynamically_Asynchronous : Boolean := False;
7490 Stub_Type : Entity_Id := Empty;
7491 RACW_Type : Entity_Id := Empty;
7492 Parent_Primitive : Entity_Id := Empty) return Node_Id
7494 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7496 Request_Parameter : Node_Id;
7497 -- ???
7499 Outer_Decls : constant List_Id := New_List;
7500 -- At the outermost level, an NVList and Any's are
7501 -- declared for all parameters. The Dynamic_Async
7502 -- flag also needs to be declared there to be visible
7503 -- from the exception handling code.
7505 Outer_Statements : constant List_Id := New_List;
7506 -- Statements that occur prior to the declaration of the actual
7507 -- parameter variables.
7509 Decls : constant List_Id := New_List;
7510 -- All the parameters will get declared before calling the real
7511 -- subprograms. Also the out parameters will be declared.
7512 -- At this level, parameters may be unconstrained.
7514 Statements : constant List_Id := New_List;
7516 Extra_Formal_Statements : constant List_Id := New_List;
7517 -- Statements concerning extra formal parameters
7519 After_Statements : constant List_Id := New_List;
7520 -- Statements to be executed after the subprogram call
7522 Inner_Decls : List_Id := No_List;
7523 -- In case of a function, the inner declarations are needed since
7524 -- the result may be unconstrained.
7526 Excep_Handlers : List_Id := No_List;
7528 Parameter_List : constant List_Id := New_List;
7529 -- List of parameters to be passed to the subprogram
7531 First_Controlling_Formal_Seen : Boolean := False;
7533 Current_Parameter : Node_Id;
7535 Ordered_Parameters_List : constant List_Id :=
7536 Build_Ordered_Parameters_List
7537 (Specification (Vis_Decl));
7539 Arguments : Node_Id;
7540 -- Name of the named values list used to retrieve parameters
7542 Subp_Spec : Node_Id;
7543 -- Subprogram specification
7545 Called_Subprogram : Node_Id;
7546 -- The subprogram to call
7548 begin
7549 if Present (RACW_Type) then
7550 Called_Subprogram :=
7551 New_Occurrence_Of (Parent_Primitive, Loc);
7552 else
7553 Called_Subprogram :=
7554 New_Occurrence_Of (
7555 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7556 end if;
7558 Request_Parameter :=
7559 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
7561 Arguments :=
7562 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7563 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7565 -- Loop through every parameter and get its value from the stream. If
7566 -- the parameter is unconstrained, then the parameter is read using
7567 -- 'Input at the point of declaration.
7569 Current_Parameter := First (Ordered_Parameters_List);
7570 while Present (Current_Parameter) loop
7571 declare
7572 Etyp : Entity_Id;
7573 Constrained : Boolean;
7574 Any : Entity_Id := Empty;
7575 Object : constant Entity_Id :=
7576 Make_Defining_Identifier (Loc,
7577 New_Internal_Name ('P'));
7578 Expr : Node_Id := Empty;
7580 Is_Controlling_Formal : constant Boolean
7581 := Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
7583 Is_First_Controlling_Formal : Boolean := False;
7584 begin
7585 Set_Ekind (Object, E_Variable);
7587 if Is_Controlling_Formal then
7589 -- Controlling formals in distributed object primitive
7590 -- operations are handled specially:
7591 -- - the first controlling formal is used as the
7592 -- target of the call;
7593 -- - the remaining controlling formals are transmitted
7594 -- as RACWs.
7596 Etyp := RACW_Type;
7597 Is_First_Controlling_Formal :=
7598 not First_Controlling_Formal_Seen;
7599 First_Controlling_Formal_Seen := True;
7600 else
7601 Etyp := Etype (Parameter_Type (Current_Parameter));
7602 end if;
7604 Constrained :=
7605 Is_Constrained (Etyp)
7606 or else Is_Elementary_Type (Etyp);
7608 if not Is_First_Controlling_Formal then
7609 Any := Make_Defining_Identifier (Loc,
7610 New_Internal_Name ('A'));
7611 Append_To (Outer_Decls,
7612 Make_Object_Declaration (Loc,
7613 Defining_Identifier =>
7614 Any,
7615 Object_Definition =>
7616 New_Occurrence_Of (RTE (RE_Any), Loc),
7617 Expression =>
7618 Make_Function_Call (Loc,
7619 Name =>
7620 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7621 Parameter_Associations => New_List (
7622 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
7623 Etyp, Outer_Decls)))));
7625 Append_To (Outer_Statements,
7626 Add_Parameter_To_NVList (Loc,
7627 Parameter => Current_Parameter,
7628 NVList => Arguments,
7629 Constrained => Constrained,
7630 Any => Any));
7631 end if;
7633 if Is_First_Controlling_Formal then
7634 declare
7635 Addr : constant Entity_Id :=
7636 Make_Defining_Identifier (Loc,
7637 New_Internal_Name ('A'));
7638 Is_Local : constant Entity_Id :=
7639 Make_Defining_Identifier (Loc,
7640 New_Internal_Name ('L'));
7641 begin
7643 -- Special case: obtain the first controlling
7644 -- formal from the target of the remote call,
7645 -- instead of the argument list.
7647 Append_To (Outer_Decls,
7648 Make_Object_Declaration (Loc,
7649 Defining_Identifier =>
7650 Addr,
7651 Object_Definition =>
7652 New_Occurrence_Of (RTE (RE_Address), Loc)));
7653 Append_To (Outer_Decls,
7654 Make_Object_Declaration (Loc,
7655 Defining_Identifier =>
7656 Is_Local,
7657 Object_Definition =>
7658 New_Occurrence_Of (Standard_Boolean, Loc)));
7659 Append_To (Outer_Statements,
7660 Make_Procedure_Call_Statement (Loc,
7661 Name =>
7662 New_Occurrence_Of (
7663 RTE (RE_Get_Local_Address), Loc),
7664 Parameter_Associations => New_List (
7665 Make_Selected_Component (Loc,
7666 Prefix =>
7667 New_Occurrence_Of (
7668 Request_Parameter, Loc),
7669 Selector_Name =>
7670 Make_Identifier (Loc, Name_Target)),
7671 New_Occurrence_Of (Is_Local, Loc),
7672 New_Occurrence_Of (Addr, Loc))));
7674 Expr := Unchecked_Convert_To (RACW_Type,
7675 New_Occurrence_Of (Addr, Loc));
7676 end;
7678 elsif In_Present (Current_Parameter)
7679 or else not Out_Present (Current_Parameter)
7680 or else not Constrained
7681 then
7682 -- If an input parameter is contrained, then its reading is
7683 -- deferred until the beginning of the subprogram body. If
7684 -- it is unconstrained, then an expression is built for
7685 -- the object declaration and the variable is set using
7686 -- 'Input instead of 'Read.
7688 Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
7689 Etyp, New_Occurrence_Of (Any, Loc), Decls);
7691 if Constrained then
7693 Append_To (Statements,
7694 Make_Assignment_Statement (Loc,
7695 Name =>
7696 New_Occurrence_Of (Object, Loc),
7697 Expression =>
7698 Expr));
7699 Expr := Empty;
7700 else
7701 null;
7702 -- Expr will be used to initialize (and constrain)
7703 -- the parameter when it is declared.
7704 end if;
7706 end if;
7708 -- If we do not have to output the current parameter, then
7709 -- it can well be flagged as constant. This may allow further
7710 -- optimizations done by the back end.
7712 Append_To (Decls,
7713 Make_Object_Declaration (Loc,
7714 Defining_Identifier => Object,
7715 Constant_Present => not Constrained
7716 and then not Out_Present (Current_Parameter),
7717 Object_Definition =>
7718 New_Occurrence_Of (Etyp, Loc),
7719 Expression => Expr));
7720 Set_Etype (Object, Etyp);
7722 -- An out parameter may be written back using a 'Write
7723 -- attribute instead of a 'Output because it has been
7724 -- constrained by the parameter given to the caller. Note that
7725 -- out controlling arguments in the case of a RACW are not put
7726 -- back in the stream because the pointer on them has not
7727 -- changed.
7729 if Out_Present (Current_Parameter)
7730 and then not Is_Controlling_Formal
7731 then
7732 Append_To (After_Statements,
7733 Make_Procedure_Call_Statement (Loc,
7734 Name =>
7735 New_Occurrence_Of (RTE (RE_Copy_Any_Value), Loc),
7736 Parameter_Associations => New_List (
7737 New_Occurrence_Of (Any, Loc),
7738 PolyORB_Support.Helpers.Build_To_Any_Call (
7739 New_Occurrence_Of (Object, Loc),
7740 Decls))));
7741 end if;
7743 -- For RACW controlling formals, the Etyp of Object is always
7744 -- an RACW, even if the parameter is not of an anonymous access
7745 -- type. In such case, we need to dereference it at call time.
7747 if Is_Controlling_Formal then
7748 if Nkind (Parameter_Type (Current_Parameter)) /=
7749 N_Access_Definition
7750 then
7751 Append_To (Parameter_List,
7752 Make_Parameter_Association (Loc,
7753 Selector_Name =>
7754 New_Occurrence_Of (
7755 Defining_Identifier (Current_Parameter), Loc),
7756 Explicit_Actual_Parameter =>
7757 Make_Explicit_Dereference (Loc,
7758 Unchecked_Convert_To (RACW_Type,
7759 OK_Convert_To (RTE (RE_Address),
7760 New_Occurrence_Of (Object, Loc))))));
7762 else
7763 Append_To (Parameter_List,
7764 Make_Parameter_Association (Loc,
7765 Selector_Name =>
7766 New_Occurrence_Of (
7767 Defining_Identifier (Current_Parameter), Loc),
7768 Explicit_Actual_Parameter =>
7769 Unchecked_Convert_To (RACW_Type,
7770 OK_Convert_To (RTE (RE_Address),
7771 New_Occurrence_Of (Object, Loc)))));
7772 end if;
7774 else
7775 Append_To (Parameter_List,
7776 Make_Parameter_Association (Loc,
7777 Selector_Name =>
7778 New_Occurrence_Of (
7779 Defining_Identifier (Current_Parameter), Loc),
7780 Explicit_Actual_Parameter =>
7781 New_Occurrence_Of (Object, Loc)));
7782 end if;
7784 -- If the current parameter needs an extra formal, then read it
7785 -- from the stream and set the corresponding semantic field in
7786 -- the variable. If the kind of the parameter identifier is
7787 -- E_Void, then this is a compiler generated parameter that
7788 -- doesn't need an extra constrained status.
7790 -- The case of Extra_Accessibility should also be handled ???
7792 if Nkind (Parameter_Type (Current_Parameter)) /=
7793 N_Access_Definition
7794 and then
7795 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7796 and then
7797 Present (Extra_Constrained
7798 (Defining_Identifier (Current_Parameter)))
7799 then
7800 declare
7801 Extra_Parameter : constant Entity_Id :=
7802 Extra_Constrained
7803 (Defining_Identifier
7804 (Current_Parameter));
7805 Extra_Any : constant Entity_Id :=
7806 Make_Defining_Identifier
7807 (Loc, New_Internal_Name ('A'));
7808 Formal_Entity : constant Entity_Id :=
7809 Make_Defining_Identifier
7810 (Loc, Chars (Extra_Parameter));
7812 Formal_Type : constant Entity_Id :=
7813 Etype (Extra_Parameter);
7814 begin
7815 Append_To (Outer_Decls,
7816 Make_Object_Declaration (Loc,
7817 Defining_Identifier =>
7818 Extra_Any,
7819 Object_Definition =>
7820 New_Occurrence_Of (RTE (RE_Any), Loc)));
7822 Append_To (Outer_Statements,
7823 Add_Parameter_To_NVList (Loc,
7824 Parameter => Extra_Parameter,
7825 NVList => Arguments,
7826 Constrained => True,
7827 Any => Extra_Any));
7829 Append_To (Decls,
7830 Make_Object_Declaration (Loc,
7831 Defining_Identifier => Formal_Entity,
7832 Object_Definition =>
7833 New_Occurrence_Of (Formal_Type, Loc)));
7835 Append_To (Extra_Formal_Statements,
7836 Make_Assignment_Statement (Loc,
7837 Name =>
7838 New_Occurrence_Of (Extra_Parameter, Loc),
7839 Expression =>
7840 PolyORB_Support.Helpers.Build_From_Any_Call (
7841 Etype (Extra_Parameter),
7842 New_Occurrence_Of (Extra_Any, Loc),
7843 Decls)));
7844 Set_Extra_Constrained (Object, Formal_Entity);
7846 end;
7847 end if;
7848 end;
7850 Next (Current_Parameter);
7851 end loop;
7853 Append_To (Outer_Statements,
7854 Make_Procedure_Call_Statement (Loc,
7855 Name =>
7856 New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
7857 Parameter_Associations => New_List (
7858 New_Occurrence_Of (Request_Parameter, Loc),
7859 New_Occurrence_Of (Arguments, Loc))));
7861 Append_List_To (Statements, Extra_Formal_Statements);
7863 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
7865 -- The remote subprogram is a function. We build an inner block to
7866 -- be able to hold a potentially unconstrained result in a
7867 -- variable.
7869 declare
7870 Etyp : constant Entity_Id :=
7871 Etype (Result_Definition (Specification (Vis_Decl)));
7872 Result : constant Node_Id :=
7873 Make_Defining_Identifier (Loc,
7874 New_Internal_Name ('R'));
7875 begin
7876 Inner_Decls := New_List (
7877 Make_Object_Declaration (Loc,
7878 Defining_Identifier => Result,
7879 Constant_Present => True,
7880 Object_Definition => New_Occurrence_Of (Etyp, Loc),
7881 Expression =>
7882 Make_Function_Call (Loc,
7883 Name => Called_Subprogram,
7884 Parameter_Associations => Parameter_List)));
7886 Set_Etype (Result, Etyp);
7887 Append_To (After_Statements,
7888 Make_Procedure_Call_Statement (Loc,
7889 Name =>
7890 New_Occurrence_Of (RTE (RE_Set_Result), Loc),
7891 Parameter_Associations => New_List (
7892 New_Occurrence_Of (Request_Parameter, Loc),
7893 PolyORB_Support.Helpers.Build_To_Any_Call (
7894 New_Occurrence_Of (Result, Loc),
7895 Decls))));
7896 -- A DSA function does not have out or inout arguments
7897 end;
7899 Append_To (Statements,
7900 Make_Block_Statement (Loc,
7901 Declarations => Inner_Decls,
7902 Handled_Statement_Sequence =>
7903 Make_Handled_Sequence_Of_Statements (Loc,
7904 Statements => After_Statements)));
7906 else
7907 -- The remote subprogram is a procedure. We do not need any inner
7908 -- block in this case. No specific processing is required here for
7909 -- the dynamically asynchronous case: the indication of whether
7910 -- call is asynchronous or not is managed by the Sync_Scope
7911 -- attibute of the request, and is handled entirely in the
7912 -- protocol layer.
7914 Append_To (After_Statements,
7915 Make_Procedure_Call_Statement (Loc,
7916 Name =>
7917 New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
7918 Parameter_Associations => New_List (
7919 New_Occurrence_Of (Request_Parameter, Loc))));
7921 Append_To (Statements,
7922 Make_Procedure_Call_Statement (Loc,
7923 Name => Called_Subprogram,
7924 Parameter_Associations => Parameter_List));
7926 Append_List_To (Statements, After_Statements);
7927 end if;
7929 Subp_Spec :=
7930 Make_Procedure_Specification (Loc,
7931 Defining_Unit_Name =>
7932 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
7934 Parameter_Specifications => New_List (
7935 Make_Parameter_Specification (Loc,
7936 Defining_Identifier => Request_Parameter,
7937 Parameter_Type =>
7938 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
7940 -- An exception raised during the execution of an incoming
7941 -- remote subprogram call and that needs to be sent back
7942 -- to the caller is propagated by the receiving stubs, and
7943 -- will be handled by the caller (the distribution runtime).
7945 if Asynchronous and then not Dynamically_Asynchronous then
7947 -- For an asynchronous procedure, add a null exception handler
7949 Excep_Handlers := New_List (
7950 Make_Exception_Handler (Loc,
7951 Exception_Choices => New_List (Make_Others_Choice (Loc)),
7952 Statements => New_List (Make_Null_Statement (Loc))));
7954 else
7956 -- In the other cases, if an exception is raised, then the
7957 -- exception occurrence is propagated.
7959 null;
7960 end if;
7962 Append_To (Outer_Statements,
7963 Make_Block_Statement (Loc,
7964 Declarations =>
7965 Decls,
7966 Handled_Statement_Sequence =>
7967 Make_Handled_Sequence_Of_Statements (Loc,
7968 Statements => Statements)));
7970 return
7971 Make_Subprogram_Body (Loc,
7972 Specification => Subp_Spec,
7973 Declarations => Outer_Decls,
7974 Handled_Statement_Sequence =>
7975 Make_Handled_Sequence_Of_Statements (Loc,
7976 Statements => Outer_Statements,
7977 Exception_Handlers => Excep_Handlers));
7978 end Build_Subprogram_Receiving_Stubs;
7979 -------------
7980 -- Helpers --
7981 -------------
7983 package body Helpers is
7985 -----------------------
7986 -- Local Subprograms --
7987 -----------------------
7989 function Find_Numeric_Representation
7990 (Typ : Entity_Id) return Entity_Id;
7991 -- Given a numeric type Typ, return the smallest integer or floarting
7992 -- point type from Standard, or the smallest unsigned (modular) type
7993 -- from System.Unsigned_Types, whose range encompasses that of Typ.
7995 function Make_Stream_Procedure_Function_Name
7996 (Loc : Source_Ptr;
7997 Typ : Entity_Id;
7998 Nam : Name_Id) return Entity_Id;
7999 -- Return the name to be assigned for stream subprogram Nam of Typ.
8000 -- (copied from exp_strm.adb, should be shared???)
8002 ------------------------------------------------------------
8003 -- Common subprograms for building various tree fragments --
8004 ------------------------------------------------------------
8006 function Build_Get_Aggregate_Element
8007 (Loc : Source_Ptr;
8008 Any : Entity_Id;
8009 TC : Node_Id;
8010 Idx : Node_Id) return Node_Id;
8011 -- Build a call to Get_Aggregate_Element on Any
8012 -- for typecode TC, returning the Idx'th element.
8014 generic
8015 Subprogram : Entity_Id;
8016 -- Reference location for constructed nodes
8018 Arry : Entity_Id;
8019 -- For 'Range and Etype
8021 Indices : List_Id;
8022 -- For the construction of the innermost element expression
8024 with procedure Add_Process_Element
8025 (Stmts : List_Id;
8026 Any : Entity_Id;
8027 Counter : Entity_Id;
8028 Datum : Node_Id);
8030 procedure Append_Array_Traversal
8031 (Stmts : List_Id;
8032 Any : Entity_Id;
8033 Counter : Entity_Id := Empty;
8034 Depth : Pos := 1);
8035 -- Build nested loop statements that iterate over the elements of an
8036 -- array Arry. The statement(s) built by Add_Process_Element are
8037 -- executed for each element; Indices is the list of indices to be
8038 -- used in the construction of the indexed component that denotes the
8039 -- current element. Subprogram is the entity for the subprogram for
8040 -- which this iterator is generated. The generated statements are
8041 -- appended to Stmts.
8043 generic
8044 Rec : Entity_Id;
8045 -- The record entity being dealt with
8047 with procedure Add_Process_Element
8048 (Stmts : List_Id;
8049 Container : Node_Or_Entity_Id;
8050 Counter : in out Int;
8051 Rec : Entity_Id;
8052 Field : Node_Id);
8053 -- Rec is the instance of the record type, or Empty.
8054 -- Field is either the N_Defining_Identifier for a component,
8055 -- or an N_Variant_Part.
8057 procedure Append_Record_Traversal
8058 (Stmts : List_Id;
8059 Clist : Node_Id;
8060 Container : Node_Or_Entity_Id;
8061 Counter : in out Int);
8062 -- Process component list Clist. Individual fields are passed
8063 -- to Field_Processing. Each variant part is also processed.
8064 -- Container is the outer Any (for From_Any/To_Any),
8065 -- the outer typecode (for TC) to which the operation applies.
8067 -----------------------------
8068 -- Append_Record_Traversal --
8069 -----------------------------
8071 procedure Append_Record_Traversal
8072 (Stmts : List_Id;
8073 Clist : Node_Id;
8074 Container : Node_Or_Entity_Id;
8075 Counter : in out Int)
8077 CI : constant List_Id := Component_Items (Clist);
8078 VP : constant Node_Id := Variant_Part (Clist);
8080 Item : Node_Id := First (CI);
8081 Def : Entity_Id;
8083 begin
8084 while Present (Item) loop
8085 Def := Defining_Identifier (Item);
8086 if not Is_Internal_Name (Chars (Def)) then
8087 Add_Process_Element
8088 (Stmts, Container, Counter, Rec, Def);
8089 end if;
8090 Next (Item);
8091 end loop;
8093 if Present (VP) then
8094 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8095 end if;
8096 end Append_Record_Traversal;
8098 -------------------------
8099 -- Build_From_Any_Call --
8100 -------------------------
8102 function Build_From_Any_Call
8103 (Typ : Entity_Id;
8104 N : Node_Id;
8105 Decls : List_Id) return Node_Id
8107 Loc : constant Source_Ptr := Sloc (N);
8109 U_Type : Entity_Id := Underlying_Type (Typ);
8111 Fnam : Entity_Id := Empty;
8112 Lib_RE : RE_Id := RE_Null;
8114 begin
8116 -- First simple case where the From_Any function is present
8117 -- in the type's TSS.
8119 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8121 if Sloc (U_Type) <= Standard_Location then
8122 U_Type := Base_Type (U_Type);
8123 end if;
8125 -- Check first for Boolean and Character. These are enumeration
8126 -- types, but we treat them specially, since they may require
8127 -- special handling in the transfer protocol. However, this
8128 -- special handling only applies if they have standard
8129 -- representation, otherwise they are treated like any other
8130 -- enumeration type.
8132 if Present (Fnam) then
8133 null;
8135 elsif U_Type = Standard_Boolean then
8136 Lib_RE := RE_FA_B;
8138 elsif U_Type = Standard_Character then
8139 Lib_RE := RE_FA_C;
8141 elsif U_Type = Standard_Wide_Character then
8142 Lib_RE := RE_FA_WC;
8144 elsif U_Type = Standard_Wide_Wide_Character then
8145 Lib_RE := RE_FA_WWC;
8147 -- Floating point types
8149 elsif U_Type = Standard_Short_Float then
8150 Lib_RE := RE_FA_SF;
8152 elsif U_Type = Standard_Float then
8153 Lib_RE := RE_FA_F;
8155 elsif U_Type = Standard_Long_Float then
8156 Lib_RE := RE_FA_LF;
8158 elsif U_Type = Standard_Long_Long_Float then
8159 Lib_RE := RE_FA_LLF;
8161 -- Integer types
8163 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8164 Lib_RE := RE_FA_SSI;
8166 elsif U_Type = Etype (Standard_Short_Integer) then
8167 Lib_RE := RE_FA_SI;
8169 elsif U_Type = Etype (Standard_Integer) then
8170 Lib_RE := RE_FA_I;
8172 elsif U_Type = Etype (Standard_Long_Integer) then
8173 Lib_RE := RE_FA_LI;
8175 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8176 Lib_RE := RE_FA_LLI;
8178 -- Unsigned integer types
8180 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8181 Lib_RE := RE_FA_SSU;
8183 elsif U_Type = RTE (RE_Short_Unsigned) then
8184 Lib_RE := RE_FA_SU;
8186 elsif U_Type = RTE (RE_Unsigned) then
8187 Lib_RE := RE_FA_U;
8189 elsif U_Type = RTE (RE_Long_Unsigned) then
8190 Lib_RE := RE_FA_LU;
8192 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8193 Lib_RE := RE_FA_LLU;
8195 elsif U_Type = Standard_String then
8196 Lib_RE := RE_FA_String;
8198 -- Other (non-primitive) types
8200 else
8201 declare
8202 Decl : Entity_Id;
8203 begin
8204 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8205 Append_To (Decls, Decl);
8206 end;
8207 end if;
8209 -- Call the function
8211 if Lib_RE /= RE_Null then
8212 pragma Assert (No (Fnam));
8213 Fnam := RTE (Lib_RE);
8214 end if;
8216 return
8217 Make_Function_Call (Loc,
8218 Name => New_Occurrence_Of (Fnam, Loc),
8219 Parameter_Associations => New_List (N));
8220 end Build_From_Any_Call;
8222 -----------------------------
8223 -- Build_From_Any_Function --
8224 -----------------------------
8226 procedure Build_From_Any_Function
8227 (Loc : Source_Ptr;
8228 Typ : Entity_Id;
8229 Decl : out Node_Id;
8230 Fnam : out Entity_Id)
8232 Spec : Node_Id;
8233 Decls : constant List_Id := New_List;
8234 Stms : constant List_Id := New_List;
8235 Any_Parameter : constant Entity_Id
8236 := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
8237 begin
8238 Fnam := Make_Stream_Procedure_Function_Name (Loc,
8239 Typ, Name_uFrom_Any);
8241 Spec :=
8242 Make_Function_Specification (Loc,
8243 Defining_Unit_Name => Fnam,
8244 Parameter_Specifications => New_List (
8245 Make_Parameter_Specification (Loc,
8246 Defining_Identifier =>
8247 Any_Parameter,
8248 Parameter_Type =>
8249 New_Occurrence_Of (RTE (RE_Any), Loc))),
8250 Result_Definition => New_Occurrence_Of (Typ, Loc));
8252 -- The following is taken care of by Exp_Dist.Add_RACW_From_Any
8254 pragma Assert
8255 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8257 if Is_Derived_Type (Typ)
8258 and then not Is_Tagged_Type (Typ)
8259 then
8260 Append_To (Stms,
8261 Make_Return_Statement (Loc,
8262 Expression =>
8263 OK_Convert_To (
8264 Typ,
8265 Build_From_Any_Call (
8266 Root_Type (Typ),
8267 New_Occurrence_Of (Any_Parameter, Loc),
8268 Decls))));
8270 elsif Is_Record_Type (Typ)
8271 and then not Is_Derived_Type (Typ)
8272 and then not Is_Tagged_Type (Typ)
8273 then
8274 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8275 Append_To (Stms,
8276 Make_Return_Statement (Loc,
8277 Expression =>
8278 OK_Convert_To (
8279 Typ,
8280 Build_From_Any_Call (
8281 Etype (Typ),
8282 New_Occurrence_Of (Any_Parameter, Loc),
8283 Decls))));
8284 else
8285 declare
8286 Disc : Entity_Id := Empty;
8287 Discriminant_Associations : List_Id;
8288 Rdef : constant Node_Id :=
8289 Type_Definition (Declaration_Node (Typ));
8290 Component_Counter : Int := 0;
8292 -- The returned object
8294 Res : constant Entity_Id :=
8295 Make_Defining_Identifier (Loc,
8296 New_Internal_Name ('R'));
8298 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8300 procedure FA_Rec_Add_Process_Element
8301 (Stmts : List_Id;
8302 Any : Entity_Id;
8303 Counter : in out Int;
8304 Rec : Entity_Id;
8305 Field : Node_Id);
8307 procedure FA_Append_Record_Traversal is
8308 new Append_Record_Traversal
8309 (Rec => Res,
8310 Add_Process_Element => FA_Rec_Add_Process_Element);
8312 --------------------------------
8313 -- FA_Rec_Add_Process_Element --
8314 --------------------------------
8316 procedure FA_Rec_Add_Process_Element
8317 (Stmts : List_Id;
8318 Any : Entity_Id;
8319 Counter : in out Int;
8320 Rec : Entity_Id;
8321 Field : Node_Id)
8323 begin
8324 if Nkind (Field) = N_Defining_Identifier then
8326 -- A regular component
8328 Append_To (Stmts,
8329 Make_Assignment_Statement (Loc,
8330 Name => Make_Selected_Component (Loc,
8331 Prefix =>
8332 New_Occurrence_Of (Rec, Loc),
8333 Selector_Name =>
8334 New_Occurrence_Of (Field, Loc)),
8335 Expression =>
8336 Build_From_Any_Call (Etype (Field),
8337 Build_Get_Aggregate_Element (Loc,
8338 Any => Any,
8339 Tc => Build_TypeCode_Call (Loc,
8340 Etype (Field), Decls),
8341 Idx => Make_Integer_Literal (Loc,
8342 Counter)),
8343 Decls)));
8345 else
8346 -- A variant part
8348 declare
8349 Variant : Node_Id;
8350 Struct_Counter : Int := 0;
8352 Block_Decls : constant List_Id := New_List;
8353 Block_Stmts : constant List_Id := New_List;
8354 VP_Stmts : List_Id;
8356 Alt_List : constant List_Id := New_List;
8357 Choice_List : List_Id;
8359 Struct_Any : constant Entity_Id :=
8360 Make_Defining_Identifier (Loc,
8361 New_Internal_Name ('S'));
8363 begin
8364 Append_To (Decls,
8365 Make_Object_Declaration (Loc,
8366 Defining_Identifier =>
8367 Struct_Any,
8368 Constant_Present =>
8369 True,
8370 Object_Definition =>
8371 New_Occurrence_Of (RTE (RE_Any), Loc),
8372 Expression =>
8373 Make_Function_Call (Loc,
8374 Name => New_Occurrence_Of (
8375 RTE (RE_Extract_Union_Value), Loc),
8376 Parameter_Associations => New_List (
8377 Build_Get_Aggregate_Element (Loc,
8378 Any => Any,
8379 Tc => Make_Function_Call (Loc,
8380 Name => New_Occurrence_Of (
8381 RTE (RE_Any_Member_Type), Loc),
8382 Parameter_Associations =>
8383 New_List (
8384 New_Occurrence_Of (Any, Loc),
8385 Make_Integer_Literal (Loc,
8386 Counter))),
8387 Idx => Make_Integer_Literal (Loc,
8388 Counter))))));
8390 Append_To (Stmts,
8391 Make_Block_Statement (Loc,
8392 Declarations =>
8393 Block_Decls,
8394 Handled_Statement_Sequence =>
8395 Make_Handled_Sequence_Of_Statements (Loc,
8396 Statements => Block_Stmts)));
8398 Append_To (Block_Stmts,
8399 Make_Case_Statement (Loc,
8400 Expression =>
8401 Make_Selected_Component (Loc,
8402 Prefix => Rec,
8403 Selector_Name =>
8404 Chars (Name (Field))),
8405 Alternatives =>
8406 Alt_List));
8408 Variant := First_Non_Pragma (Variants (Field));
8410 while Present (Variant) loop
8411 Choice_List := New_Copy_List_Tree
8412 (Discrete_Choices (Variant));
8414 VP_Stmts := New_List;
8415 FA_Append_Record_Traversal (
8416 Stmts => VP_Stmts,
8417 Clist => Component_List (Variant),
8418 Container => Struct_Any,
8419 Counter => Struct_Counter);
8421 Append_To (Alt_List,
8422 Make_Case_Statement_Alternative (Loc,
8423 Discrete_Choices => Choice_List,
8424 Statements =>
8425 VP_Stmts));
8426 Next_Non_Pragma (Variant);
8427 end loop;
8428 end;
8429 end if;
8430 Counter := Counter + 1;
8431 end FA_Rec_Add_Process_Element;
8433 begin
8434 -- First all discriminants
8436 if Has_Discriminants (Typ) then
8437 Disc := First_Discriminant (Typ);
8438 Discriminant_Associations := New_List;
8440 while Present (Disc) loop
8441 declare
8442 Disc_Var_Name : constant Entity_Id :=
8443 Make_Defining_Identifier (Loc, Chars (Disc));
8444 Disc_Type : constant Entity_Id :=
8445 Etype (Disc);
8446 begin
8447 Append_To (Decls,
8448 Make_Object_Declaration (Loc,
8449 Defining_Identifier =>
8450 Disc_Var_Name,
8451 Constant_Present => True,
8452 Object_Definition =>
8453 New_Occurrence_Of (Disc_Type, Loc),
8454 Expression =>
8455 Build_From_Any_Call (Etype (Disc),
8456 Build_Get_Aggregate_Element (Loc,
8457 Any => Any_Parameter,
8458 Tc => Build_TypeCode_Call
8459 (Loc, Etype (Disc), Decls),
8460 Idx => Make_Integer_Literal
8461 (Loc, Component_Counter)),
8462 Decls)));
8463 Component_Counter := Component_Counter + 1;
8465 Append_To (Discriminant_Associations,
8466 Make_Discriminant_Association (Loc,
8467 Selector_Names => New_List (
8468 New_Occurrence_Of (Disc, Loc)),
8469 Expression =>
8470 New_Occurrence_Of (Disc_Var_Name, Loc)));
8471 end;
8472 Next_Discriminant (Disc);
8473 end loop;
8475 Res_Definition := Make_Subtype_Indication (Loc,
8476 Subtype_Mark => Res_Definition,
8477 Constraint =>
8478 Make_Index_Or_Discriminant_Constraint (Loc,
8479 Discriminant_Associations));
8480 end if;
8482 -- Now we have all the discriminants in variables, we can
8483 -- declared a constrained object. Note that we are not
8484 -- initializing (non-discriminant) components directly in
8485 -- the object declarations, because which fields to
8486 -- initialize depends (at run time) on the discriminant
8487 -- values.
8489 Append_To (Decls,
8490 Make_Object_Declaration (Loc,
8491 Defining_Identifier =>
8492 Res,
8493 Object_Definition =>
8494 Res_Definition));
8496 -- ... then all components
8498 FA_Append_Record_Traversal (Stms,
8499 Clist => Component_List (Rdef),
8500 Container => Any_Parameter,
8501 Counter => Component_Counter);
8503 Append_To (Stms,
8504 Make_Return_Statement (Loc,
8505 Expression => New_Occurrence_Of (Res, Loc)));
8506 end;
8507 end if;
8509 elsif Is_Array_Type (Typ) then
8510 declare
8511 Constrained : constant Boolean := Is_Constrained (Typ);
8513 procedure FA_Ary_Add_Process_Element
8514 (Stmts : List_Id;
8515 Any : Entity_Id;
8516 Counter : Entity_Id;
8517 Datum : Node_Id);
8518 -- Assign the current element (as identified by Counter) of
8519 -- Any to the variable denoted by name Datum, and advance
8520 -- Counter by 1. If Datum is not an Any, a call to From_Any
8521 -- for its type is inserted.
8523 --------------------------------
8524 -- FA_Ary_Add_Process_Element --
8525 --------------------------------
8527 procedure FA_Ary_Add_Process_Element
8528 (Stmts : List_Id;
8529 Any : Entity_Id;
8530 Counter : Entity_Id;
8531 Datum : Node_Id)
8533 Assignment : constant Node_Id :=
8534 Make_Assignment_Statement (Loc,
8535 Name => Datum,
8536 Expression => Empty);
8538 Element_Any : constant Node_Id :=
8539 Build_Get_Aggregate_Element (Loc,
8540 Any => Any,
8541 Tc => Build_TypeCode_Call (Loc,
8542 Etype (Datum), Decls),
8543 Idx => New_Occurrence_Of (Counter, Loc));
8545 begin
8546 -- Note: here we *prepend* statements to Stmts, so
8547 -- we must do it in reverse order.
8549 Prepend_To (Stmts,
8550 Make_Assignment_Statement (Loc,
8551 Name =>
8552 New_Occurrence_Of (Counter, Loc),
8553 Expression =>
8554 Make_Op_Add (Loc,
8555 Left_Opnd =>
8556 New_Occurrence_Of (Counter, Loc),
8557 Right_Opnd =>
8558 Make_Integer_Literal (Loc, 1))));
8560 if Nkind (Datum) /= N_Attribute_Reference then
8562 -- We ignore the value of the length of each
8563 -- dimension, since the target array has already
8564 -- been constrained anyway.
8566 if Etype (Datum) /= RTE (RE_Any) then
8567 Set_Expression (Assignment,
8568 Build_From_Any_Call (
8569 Component_Type (Typ),
8570 Element_Any,
8571 Decls));
8572 else
8573 Set_Expression (Assignment, Element_Any);
8574 end if;
8575 Prepend_To (Stmts, Assignment);
8576 end if;
8577 end FA_Ary_Add_Process_Element;
8579 Counter : constant Entity_Id :=
8580 Make_Defining_Identifier (Loc, Name_J);
8582 Initial_Counter_Value : Int := 0;
8584 Component_TC : constant Entity_Id :=
8585 Make_Defining_Identifier (Loc, Name_T);
8587 Res : constant Entity_Id :=
8588 Make_Defining_Identifier (Loc, Name_R);
8590 procedure Append_From_Any_Array_Iterator is
8591 new Append_Array_Traversal (
8592 Subprogram => Fnam,
8593 Arry => Res,
8594 Indices => New_List,
8595 Add_Process_Element => FA_Ary_Add_Process_Element);
8597 Res_Subtype_Indication : Node_Id :=
8598 New_Occurrence_Of (Typ, Loc);
8600 begin
8601 if not Constrained then
8602 declare
8603 Ndim : constant Int := Number_Dimensions (Typ);
8604 Lnam : Name_Id;
8605 Hnam : Name_Id;
8606 Indx : Node_Id := First_Index (Typ);
8607 Indt : Entity_Id;
8609 Ranges : constant List_Id := New_List;
8611 begin
8612 for J in 1 .. Ndim loop
8613 Lnam := New_External_Name ('L', J);
8614 Hnam := New_External_Name ('H', J);
8615 Indt := Etype (Indx);
8617 Append_To (Decls,
8618 Make_Object_Declaration (Loc,
8619 Defining_Identifier =>
8620 Make_Defining_Identifier (Loc, Lnam),
8621 Constant_Present =>
8622 True,
8623 Object_Definition =>
8624 New_Occurrence_Of (Indt, Loc),
8625 Expression =>
8626 Build_From_Any_Call (
8627 Indt,
8628 Build_Get_Aggregate_Element (Loc,
8629 Any => Any_Parameter,
8630 Tc => Build_TypeCode_Call (Loc,
8631 Indt, Decls),
8632 Idx => Make_Integer_Literal (Loc, J - 1)),
8633 Decls)));
8635 Append_To (Decls,
8636 Make_Object_Declaration (Loc,
8637 Defining_Identifier =>
8638 Make_Defining_Identifier (Loc, Hnam),
8639 Constant_Present =>
8640 True,
8641 Object_Definition =>
8642 New_Occurrence_Of (Indt, Loc),
8643 Expression => Make_Attribute_Reference (Loc,
8644 Prefix =>
8645 New_Occurrence_Of (Indt, Loc),
8646 Attribute_Name => Name_Val,
8647 Expressions => New_List (
8648 Make_Op_Subtract (Loc,
8649 Left_Opnd =>
8650 Make_Op_Add (Loc,
8651 Left_Opnd =>
8652 Make_Attribute_Reference (Loc,
8653 Prefix =>
8654 New_Occurrence_Of (Indt, Loc),
8655 Attribute_Name =>
8656 Name_Pos,
8657 Expressions => New_List (
8658 Make_Identifier (Loc, Lnam))),
8659 Right_Opnd =>
8660 Make_Function_Call (Loc,
8661 Name => New_Occurrence_Of (RTE (
8662 RE_Get_Nested_Sequence_Length),
8663 Loc),
8664 Parameter_Associations =>
8665 New_List (
8666 New_Occurrence_Of (
8667 Any_Parameter, Loc),
8668 Make_Integer_Literal (Loc,
8669 J)))),
8670 Right_Opnd =>
8671 Make_Integer_Literal (Loc, 1))))));
8673 Append_To (Ranges,
8674 Make_Range (Loc,
8675 Low_Bound => Make_Identifier (Loc, Lnam),
8676 High_Bound => Make_Identifier (Loc, Hnam)));
8678 Next_Index (Indx);
8679 end loop;
8681 -- Now we have all the necessary bound information:
8682 -- apply the set of range constraints to the
8683 -- (unconstrained) nominal subtype of Res.
8685 Initial_Counter_Value := Ndim;
8686 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
8687 Subtype_Mark =>
8688 Res_Subtype_Indication,
8689 Constraint =>
8690 Make_Index_Or_Discriminant_Constraint (Loc,
8691 Constraints => Ranges));
8692 end;
8693 end if;
8695 Append_To (Decls,
8696 Make_Object_Declaration (Loc,
8697 Defining_Identifier => Res,
8698 Object_Definition => Res_Subtype_Indication));
8699 Set_Etype (Res, Typ);
8701 Append_To (Decls,
8702 Make_Object_Declaration (Loc,
8703 Defining_Identifier => Counter,
8704 Object_Definition =>
8705 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
8706 Expression =>
8707 Make_Integer_Literal (Loc, Initial_Counter_Value)));
8709 Append_To (Decls,
8710 Make_Object_Declaration (Loc,
8711 Defining_Identifier => Component_TC,
8712 Constant_Present => True,
8713 Object_Definition =>
8714 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
8715 Expression =>
8716 Build_TypeCode_Call (Loc,
8717 Component_Type (Typ), Decls)));
8719 Append_From_Any_Array_Iterator (Stms,
8720 Any_Parameter, Counter);
8722 Append_To (Stms,
8723 Make_Return_Statement (Loc,
8724 Expression => New_Occurrence_Of (Res, Loc)));
8725 end;
8727 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
8728 Append_To (Stms,
8729 Make_Return_Statement (Loc,
8730 Expression =>
8731 Unchecked_Convert_To (
8732 Typ,
8733 Build_From_Any_Call (
8734 Find_Numeric_Representation (Typ),
8735 New_Occurrence_Of (Any_Parameter, Loc),
8736 Decls))));
8738 else
8739 -- Default: type is represented as an opaque sequence of bytes
8741 declare
8742 Strm : constant Entity_Id :=
8743 Make_Defining_Identifier (Loc,
8744 Chars => New_Internal_Name ('S'));
8745 Res : constant Entity_Id :=
8746 Make_Defining_Identifier (Loc,
8747 Chars => New_Internal_Name ('R'));
8749 begin
8750 -- Strm : Buffer_Stream_Type;
8752 Append_To (Decls,
8753 Make_Object_Declaration (Loc,
8754 Defining_Identifier =>
8755 Strm,
8756 Aliased_Present =>
8757 True,
8758 Object_Definition =>
8759 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
8761 -- Any_To_BS (Strm, A);
8763 Append_To (Stms,
8764 Make_Procedure_Call_Statement (Loc,
8765 Name =>
8766 New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
8767 Parameter_Associations => New_List (
8768 New_Occurrence_Of (Any_Parameter, Loc),
8769 New_Occurrence_Of (Strm, Loc))));
8771 -- declare
8772 -- Res : constant T := T'Input (Strm);
8773 -- begin
8774 -- Release_Buffer (Strm);
8775 -- return Res;
8776 -- end;
8778 Append_To (Stms, Make_Block_Statement (Loc,
8779 Declarations => New_List (
8780 Make_Object_Declaration (Loc,
8781 Defining_Identifier => Res,
8782 Constant_Present => True,
8783 Object_Definition =>
8784 New_Occurrence_Of (Typ, Loc),
8785 Expression =>
8786 Make_Attribute_Reference (Loc,
8787 Prefix => New_Occurrence_Of (Typ, Loc),
8788 Attribute_Name => Name_Input,
8789 Expressions => New_List (
8790 Make_Attribute_Reference (Loc,
8791 Prefix => New_Occurrence_Of (Strm, Loc),
8792 Attribute_Name => Name_Access))))),
8794 Handled_Statement_Sequence =>
8795 Make_Handled_Sequence_Of_Statements (Loc,
8796 Statements => New_List (
8797 Make_Procedure_Call_Statement (Loc,
8798 Name =>
8799 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
8800 Parameter_Associations =>
8801 New_List (
8802 New_Occurrence_Of (Strm, Loc))),
8803 Make_Return_Statement (Loc,
8804 Expression => New_Occurrence_Of (Res, Loc))))));
8806 end;
8807 end if;
8809 Decl :=
8810 Make_Subprogram_Body (Loc,
8811 Specification => Spec,
8812 Declarations => Decls,
8813 Handled_Statement_Sequence =>
8814 Make_Handled_Sequence_Of_Statements (Loc,
8815 Statements => Stms));
8816 end Build_From_Any_Function;
8818 ---------------------------------
8819 -- Build_Get_Aggregate_Element --
8820 ---------------------------------
8822 function Build_Get_Aggregate_Element
8823 (Loc : Source_Ptr;
8824 Any : Entity_Id;
8825 TC : Node_Id;
8826 Idx : Node_Id) return Node_Id
8828 begin
8829 return Make_Function_Call (Loc,
8830 Name =>
8831 New_Occurrence_Of (
8832 RTE (RE_Get_Aggregate_Element), Loc),
8833 Parameter_Associations => New_List (
8834 New_Occurrence_Of (Any, Loc),
8836 Idx));
8837 end Build_Get_Aggregate_Element;
8839 -------------------------
8840 -- Build_Reposiroty_Id --
8841 -------------------------
8843 procedure Build_Name_And_Repository_Id
8844 (E : Entity_Id;
8845 Name_Str : out String_Id;
8846 Repo_Id_Str : out String_Id)
8848 begin
8849 Start_String;
8850 Store_String_Chars ("DSA:");
8851 Get_Library_Unit_Name_String (Scope (E));
8852 Store_String_Chars (
8853 Name_Buffer (Name_Buffer'First
8854 .. Name_Buffer'First + Name_Len - 1));
8855 Store_String_Char ('.');
8856 Get_Name_String (Chars (E));
8857 Store_String_Chars (
8858 Name_Buffer (Name_Buffer'First
8859 .. Name_Buffer'First + Name_Len - 1));
8860 Store_String_Chars (":1.0");
8861 Repo_Id_Str := End_String;
8862 Name_Str := String_From_Name_Buffer;
8863 end Build_Name_And_Repository_Id;
8865 -----------------------
8866 -- Build_To_Any_Call --
8867 -----------------------
8869 function Build_To_Any_Call
8870 (N : Node_Id;
8871 Decls : List_Id) return Node_Id
8873 Loc : constant Source_Ptr := Sloc (N);
8875 Typ : Entity_Id := Etype (N);
8876 U_Type : Entity_Id;
8878 Fnam : Entity_Id := Empty;
8879 Lib_RE : RE_Id := RE_Null;
8881 begin
8882 -- If N is a selected component, then maybe its Etype
8883 -- has not been set yet: try to use the Etype of the
8884 -- selector_name in that case.
8886 if No (Typ) and then Nkind (N) = N_Selected_Component then
8887 Typ := Etype (Selector_Name (N));
8888 end if;
8889 pragma Assert (Present (Typ));
8891 -- The full view, if Typ is private; the completion,
8892 -- if Typ is incomplete.
8894 U_Type := Underlying_Type (Typ);
8896 -- First simple case where the To_Any function is present
8897 -- in the type's TSS.
8899 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
8901 -- Check first for Boolean and Character. These are enumeration
8902 -- types, but we treat them specially, since they may require
8903 -- special handling in the transfer protocol. However, this
8904 -- special handling only applies if they have standard
8905 -- representation, otherwise they are treated like any other
8906 -- enumeration type.
8908 if Sloc (U_Type) <= Standard_Location then
8909 U_Type := Base_Type (U_Type);
8910 end if;
8912 if Present (Fnam) then
8913 null;
8915 elsif U_Type = Standard_Boolean then
8916 Lib_RE := RE_TA_B;
8918 elsif U_Type = Standard_Character then
8919 Lib_RE := RE_TA_C;
8921 elsif U_Type = Standard_Wide_Character then
8922 Lib_RE := RE_TA_WC;
8924 elsif U_Type = Standard_Wide_Wide_Character then
8925 Lib_RE := RE_TA_WWC;
8927 -- Floating point types
8929 elsif U_Type = Standard_Short_Float then
8930 Lib_RE := RE_TA_SF;
8932 elsif U_Type = Standard_Float then
8933 Lib_RE := RE_TA_F;
8935 elsif U_Type = Standard_Long_Float then
8936 Lib_RE := RE_TA_LF;
8938 elsif U_Type = Standard_Long_Long_Float then
8939 Lib_RE := RE_TA_LLF;
8941 -- Integer types
8943 elsif U_Type = Etype (Standard_Short_Short_Integer) then
8944 Lib_RE := RE_TA_SSI;
8946 elsif U_Type = Etype (Standard_Short_Integer) then
8947 Lib_RE := RE_TA_SI;
8949 elsif U_Type = Etype (Standard_Integer) then
8950 Lib_RE := RE_TA_I;
8952 elsif U_Type = Etype (Standard_Long_Integer) then
8953 Lib_RE := RE_TA_LI;
8955 elsif U_Type = Etype (Standard_Long_Long_Integer) then
8956 Lib_RE := RE_TA_LLI;
8958 -- Unsigned integer types
8960 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
8961 Lib_RE := RE_TA_SSU;
8963 elsif U_Type = RTE (RE_Short_Unsigned) then
8964 Lib_RE := RE_TA_SU;
8966 elsif U_Type = RTE (RE_Unsigned) then
8967 Lib_RE := RE_TA_U;
8969 elsif U_Type = RTE (RE_Long_Unsigned) then
8970 Lib_RE := RE_TA_LU;
8972 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
8973 Lib_RE := RE_TA_LLU;
8975 elsif U_Type = Standard_String then
8976 Lib_RE := RE_TA_String;
8978 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
8979 Lib_RE := RE_TA_TC;
8981 -- Other (non-primitive) types
8983 else
8984 declare
8985 Decl : Entity_Id;
8986 begin
8987 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
8988 Append_To (Decls, Decl);
8989 end;
8990 end if;
8992 -- Call the function
8994 if Lib_RE /= RE_Null then
8995 pragma Assert (No (Fnam));
8996 Fnam := RTE (Lib_RE);
8997 end if;
8999 return
9000 Make_Function_Call (Loc,
9001 Name => New_Occurrence_Of (Fnam, Loc),
9002 Parameter_Associations => New_List (N));
9003 end Build_To_Any_Call;
9005 ---------------------------
9006 -- Build_To_Any_Function --
9007 ---------------------------
9009 procedure Build_To_Any_Function
9010 (Loc : Source_Ptr;
9011 Typ : Entity_Id;
9012 Decl : out Node_Id;
9013 Fnam : out Entity_Id)
9015 Spec : Node_Id;
9016 Decls : constant List_Id := New_List;
9017 Stms : constant List_Id := New_List;
9019 Expr_Parameter : constant Entity_Id :=
9020 Make_Defining_Identifier (Loc, Name_E);
9022 Any : constant Entity_Id :=
9023 Make_Defining_Identifier (Loc, Name_A);
9025 Any_Decl : Node_Id;
9026 Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
9028 begin
9029 Fnam := Make_Stream_Procedure_Function_Name (Loc,
9030 Typ, Name_uTo_Any);
9032 Spec :=
9033 Make_Function_Specification (Loc,
9034 Defining_Unit_Name => Fnam,
9035 Parameter_Specifications => New_List (
9036 Make_Parameter_Specification (Loc,
9037 Defining_Identifier =>
9038 Expr_Parameter,
9039 Parameter_Type =>
9040 New_Occurrence_Of (Typ, Loc))),
9041 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9042 Set_Etype (Expr_Parameter, Typ);
9044 Any_Decl :=
9045 Make_Object_Declaration (Loc,
9046 Defining_Identifier =>
9047 Any,
9048 Object_Definition =>
9049 New_Occurrence_Of (RTE (RE_Any), Loc));
9051 if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9052 declare
9053 Rt_Type : constant Entity_Id
9054 := Root_Type (Typ);
9055 Expr : constant Node_Id
9056 := OK_Convert_To (
9057 Rt_Type,
9058 New_Occurrence_Of (Expr_Parameter, Loc));
9059 begin
9060 Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
9061 end;
9063 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9064 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9065 declare
9066 Rt_Type : constant Entity_Id
9067 := Etype (Typ);
9068 Expr : constant Node_Id
9069 := OK_Convert_To (
9070 Rt_Type,
9071 New_Occurrence_Of (Expr_Parameter, Loc));
9073 begin
9074 Set_Expression (Any_Decl,
9075 Build_To_Any_Call (Expr, Decls));
9076 end;
9078 else
9079 declare
9080 Disc : Entity_Id := Empty;
9081 Rdef : constant Node_Id :=
9082 Type_Definition (Declaration_Node (Typ));
9083 Counter : Int := 0;
9084 Elements : constant List_Id := New_List;
9086 procedure TA_Rec_Add_Process_Element
9087 (Stmts : List_Id;
9088 Container : Node_Or_Entity_Id;
9089 Counter : in out Int;
9090 Rec : Entity_Id;
9091 Field : Node_Id);
9093 procedure TA_Append_Record_Traversal is
9094 new Append_Record_Traversal
9095 (Rec => Expr_Parameter,
9096 Add_Process_Element => TA_Rec_Add_Process_Element);
9098 --------------------------------
9099 -- TA_Rec_Add_Process_Element --
9100 --------------------------------
9102 procedure TA_Rec_Add_Process_Element
9103 (Stmts : List_Id;
9104 Container : Node_Or_Entity_Id;
9105 Counter : in out Int;
9106 Rec : Entity_Id;
9107 Field : Node_Id)
9109 Field_Ref : Node_Id;
9111 begin
9112 if Nkind (Field) = N_Defining_Identifier then
9114 -- A regular component
9116 Field_Ref := Make_Selected_Component (Loc,
9117 Prefix => New_Occurrence_Of (Rec, Loc),
9118 Selector_Name => New_Occurrence_Of (Field, Loc));
9119 Set_Etype (Field_Ref, Etype (Field));
9121 Append_To (Stmts,
9122 Make_Procedure_Call_Statement (Loc,
9123 Name =>
9124 New_Occurrence_Of (
9125 RTE (RE_Add_Aggregate_Element), Loc),
9126 Parameter_Associations => New_List (
9127 New_Occurrence_Of (Any, Loc),
9128 Build_To_Any_Call (Field_Ref, Decls))));
9130 else
9131 -- A variant part
9133 declare
9134 Variant : Node_Id;
9135 Struct_Counter : Int := 0;
9137 Block_Decls : constant List_Id := New_List;
9138 Block_Stmts : constant List_Id := New_List;
9139 VP_Stmts : List_Id;
9141 Alt_List : constant List_Id := New_List;
9142 Choice_List : List_Id;
9144 Union_Any : constant Entity_Id :=
9145 Make_Defining_Identifier (Loc,
9146 New_Internal_Name ('U'));
9148 Struct_Any : constant Entity_Id :=
9149 Make_Defining_Identifier (Loc,
9150 New_Internal_Name ('S'));
9152 function Make_Discriminant_Reference
9153 return Node_Id;
9154 -- Build a selected component for the
9155 -- discriminant of this variant part.
9157 ---------------------------------
9158 -- Make_Discriminant_Reference --
9159 ---------------------------------
9161 function Make_Discriminant_Reference
9162 return Node_Id
9164 Nod : constant Node_Id :=
9165 Make_Selected_Component (Loc,
9166 Prefix => Rec,
9167 Selector_Name =>
9168 Chars (Name (Field)));
9169 begin
9170 Set_Etype (Nod, Name (Field));
9171 return Nod;
9172 end Make_Discriminant_Reference;
9174 begin
9175 Append_To (Stmts,
9176 Make_Block_Statement (Loc,
9177 Declarations =>
9178 Block_Decls,
9179 Handled_Statement_Sequence =>
9180 Make_Handled_Sequence_Of_Statements (Loc,
9181 Statements => Block_Stmts)));
9183 Append_To (Block_Decls,
9184 Make_Object_Declaration (Loc,
9185 Defining_Identifier => Union_Any,
9186 Object_Definition =>
9187 New_Occurrence_Of (RTE (RE_Any), Loc),
9188 Expression =>
9189 Make_Function_Call (Loc,
9190 Name => New_Occurrence_Of (
9191 RTE (RE_Create_Any), Loc),
9192 Parameter_Associations => New_List (
9193 Make_Function_Call (Loc,
9194 Name =>
9195 New_Occurrence_Of (
9196 RTE (RE_Any_Member_Type), Loc),
9197 Parameter_Associations => New_List (
9198 New_Occurrence_Of (Container, Loc),
9199 Make_Integer_Literal (Loc,
9200 Counter)))))));
9202 Append_To (Block_Decls,
9203 Make_Object_Declaration (Loc,
9204 Defining_Identifier => Struct_Any,
9205 Object_Definition =>
9206 New_Occurrence_Of (RTE (RE_Any), Loc),
9207 Expression =>
9208 Make_Function_Call (Loc,
9209 Name => New_Occurrence_Of (
9210 RTE (RE_Create_Any), Loc),
9211 Parameter_Associations => New_List (
9212 Make_Function_Call (Loc,
9213 Name =>
9214 New_Occurrence_Of (
9215 RTE (RE_Any_Member_Type), Loc),
9216 Parameter_Associations => New_List (
9217 New_Occurrence_Of (Union_Any, Loc),
9218 Make_Integer_Literal (Loc,
9219 Uint_0)))))));
9221 Append_To (Block_Stmts,
9222 Make_Case_Statement (Loc,
9223 Expression =>
9224 Make_Discriminant_Reference,
9225 Alternatives =>
9226 Alt_List));
9228 Variant := First_Non_Pragma (Variants (Field));
9229 while Present (Variant) loop
9230 Choice_List := New_Copy_List_Tree
9231 (Discrete_Choices (Variant));
9233 VP_Stmts := New_List;
9234 TA_Append_Record_Traversal (
9235 Stmts => VP_Stmts,
9236 Clist => Component_List (Variant),
9237 Container => Struct_Any,
9238 Counter => Struct_Counter);
9240 -- Append discriminant value and inner struct
9241 -- to union aggregate.
9243 Append_To (VP_Stmts,
9244 Make_Procedure_Call_Statement (Loc,
9245 Name =>
9246 New_Occurrence_Of (
9247 RTE (RE_Add_Aggregate_Element), Loc),
9248 Parameter_Associations => New_List (
9249 New_Occurrence_Of (Union_Any, Loc),
9250 Build_To_Any_Call (
9251 Make_Discriminant_Reference,
9252 Block_Decls))));
9254 Append_To (VP_Stmts,
9255 Make_Procedure_Call_Statement (Loc,
9256 Name =>
9257 New_Occurrence_Of (
9258 RTE (RE_Add_Aggregate_Element), Loc),
9259 Parameter_Associations => New_List (
9260 New_Occurrence_Of (Union_Any, Loc),
9261 New_Occurrence_Of (Struct_Any, Loc))));
9263 -- Append union to outer aggregate
9265 Append_To (VP_Stmts,
9266 Make_Procedure_Call_Statement (Loc,
9267 Name =>
9268 New_Occurrence_Of (
9269 RTE (RE_Add_Aggregate_Element), Loc),
9270 Parameter_Associations => New_List (
9271 New_Occurrence_Of (Container, Loc),
9272 Make_Function_Call (Loc,
9273 Name => New_Occurrence_Of (
9274 RTE (RE_Any_Aggregate_Build), Loc),
9275 Parameter_Associations => New_List (
9276 New_Occurrence_Of (
9277 Union_Any, Loc))))));
9279 Append_To (Alt_List,
9280 Make_Case_Statement_Alternative (Loc,
9281 Discrete_Choices => Choice_List,
9282 Statements =>
9283 VP_Stmts));
9284 Next_Non_Pragma (Variant);
9285 end loop;
9286 end;
9287 end if;
9288 end TA_Rec_Add_Process_Element;
9290 begin
9291 -- First all discriminants
9293 if Has_Discriminants (Typ) then
9294 Disc := First_Discriminant (Typ);
9296 while Present (Disc) loop
9297 Append_To (Elements,
9298 Make_Component_Association (Loc,
9299 Choices => New_List (
9300 Make_Integer_Literal (Loc, Counter)),
9301 Expression =>
9302 Build_To_Any_Call (
9303 Make_Selected_Component (Loc,
9304 Prefix => Expr_Parameter,
9305 Selector_Name => Chars (Disc)),
9306 Decls)));
9307 Counter := Counter + 1;
9308 Next_Discriminant (Disc);
9309 end loop;
9311 else
9312 -- Make elements an empty array
9314 declare
9315 Dummy_Any : constant Entity_Id :=
9316 Make_Defining_Identifier (Loc,
9317 Chars => New_Internal_Name ('A'));
9319 begin
9320 Append_To (Decls,
9321 Make_Object_Declaration (Loc,
9322 Defining_Identifier => Dummy_Any,
9323 Object_Definition =>
9324 New_Occurrence_Of (RTE (RE_Any), Loc)));
9326 Append_To (Elements,
9327 Make_Component_Association (Loc,
9328 Choices => New_List (
9329 Make_Range (Loc,
9330 Low_Bound =>
9331 Make_Integer_Literal (Loc, 1),
9332 High_Bound =>
9333 Make_Integer_Literal (Loc, 0))),
9334 Expression =>
9335 New_Occurrence_Of (Dummy_Any, Loc)));
9336 end;
9337 end if;
9339 Set_Expression (Any_Decl,
9340 Make_Function_Call (Loc,
9341 Name => New_Occurrence_Of (
9342 RTE (RE_Any_Aggregate_Build), Loc),
9343 Parameter_Associations => New_List (
9344 Result_TC,
9345 Make_Aggregate (Loc,
9346 Component_Associations => Elements))));
9347 Result_TC := Empty;
9349 -- ... then all components
9351 TA_Append_Record_Traversal (Stms,
9352 Clist => Component_List (Rdef),
9353 Container => Any,
9354 Counter => Counter);
9355 end;
9356 end if;
9358 elsif Is_Array_Type (Typ) then
9359 declare
9360 Constrained : constant Boolean := Is_Constrained (Typ);
9362 procedure TA_Ary_Add_Process_Element
9363 (Stmts : List_Id;
9364 Any : Entity_Id;
9365 Counter : Entity_Id;
9366 Datum : Node_Id);
9368 --------------------------------
9369 -- TA_Ary_Add_Process_Element --
9370 --------------------------------
9372 procedure TA_Ary_Add_Process_Element
9373 (Stmts : List_Id;
9374 Any : Entity_Id;
9375 Counter : Entity_Id;
9376 Datum : Node_Id)
9378 pragma Warnings (Off);
9379 pragma Unreferenced (Counter);
9380 pragma Warnings (On);
9382 Element_Any : Node_Id;
9384 begin
9385 if Etype (Datum) = RTE (RE_Any) then
9386 Element_Any := Datum;
9387 else
9388 Element_Any := Build_To_Any_Call (Datum, Decls);
9389 end if;
9391 Append_To (Stmts,
9392 Make_Procedure_Call_Statement (Loc,
9393 Name => New_Occurrence_Of (
9394 RTE (RE_Add_Aggregate_Element), Loc),
9395 Parameter_Associations => New_List (
9396 New_Occurrence_Of (Any, Loc),
9397 Element_Any)));
9398 end TA_Ary_Add_Process_Element;
9400 procedure Append_To_Any_Array_Iterator is
9401 new Append_Array_Traversal (
9402 Subprogram => Fnam,
9403 Arry => Expr_Parameter,
9404 Indices => New_List,
9405 Add_Process_Element => TA_Ary_Add_Process_Element);
9407 Index : Node_Id;
9409 begin
9410 Set_Expression (Any_Decl,
9411 Make_Function_Call (Loc,
9412 Name =>
9413 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9414 Parameter_Associations => New_List (Result_TC)));
9415 Result_TC := Empty;
9417 if not Constrained then
9418 Index := First_Index (Typ);
9419 for J in 1 .. Number_Dimensions (Typ) loop
9420 Append_To (Stms,
9421 Make_Procedure_Call_Statement (Loc,
9422 Name =>
9423 New_Occurrence_Of (
9424 RTE (RE_Add_Aggregate_Element), Loc),
9425 Parameter_Associations => New_List (
9426 New_Occurrence_Of (Any, Loc),
9427 Build_To_Any_Call (
9428 OK_Convert_To (Etype (Index),
9429 Make_Attribute_Reference (Loc,
9430 Prefix =>
9431 New_Occurrence_Of (Expr_Parameter, Loc),
9432 Attribute_Name => Name_First,
9433 Expressions => New_List (
9434 Make_Integer_Literal (Loc, J)))),
9435 Decls))));
9436 Next_Index (Index);
9437 end loop;
9438 end if;
9440 Append_To_Any_Array_Iterator (Stms, Any);
9441 end;
9443 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9444 Set_Expression (Any_Decl,
9445 Build_To_Any_Call (
9446 OK_Convert_To (
9447 Find_Numeric_Representation (Typ),
9448 New_Occurrence_Of (Expr_Parameter, Loc)),
9449 Decls));
9451 else
9452 -- Default: type is represented as an opaque sequence of bytes
9454 declare
9455 Strm : constant Entity_Id := Make_Defining_Identifier (Loc,
9456 New_Internal_Name ('S'));
9458 begin
9459 -- Strm : aliased Buffer_Stream_Type;
9461 Append_To (Decls,
9462 Make_Object_Declaration (Loc,
9463 Defining_Identifier =>
9464 Strm,
9465 Aliased_Present =>
9466 True,
9467 Object_Definition =>
9468 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9470 -- Allocate_Buffer (Strm);
9472 Append_To (Stms,
9473 Make_Procedure_Call_Statement (Loc,
9474 Name =>
9475 New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
9476 Parameter_Associations => New_List (
9477 New_Occurrence_Of (Strm, Loc))));
9479 -- T'Output (Strm'Access, E);
9481 Append_To (Stms,
9482 Make_Attribute_Reference (Loc,
9483 Prefix => New_Occurrence_Of (Typ, Loc),
9484 Attribute_Name => Name_Output,
9485 Expressions => New_List (
9486 Make_Attribute_Reference (Loc,
9487 Prefix => New_Occurrence_Of (Strm, Loc),
9488 Attribute_Name => Name_Access),
9489 New_Occurrence_Of (Expr_Parameter, Loc))));
9491 -- BS_To_Any (Strm, A);
9493 Append_To (Stms,
9494 Make_Procedure_Call_Statement (Loc,
9495 Name =>
9496 New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
9497 Parameter_Associations => New_List (
9498 New_Occurrence_Of (Strm, Loc),
9499 New_Occurrence_Of (Any, Loc))));
9501 -- Release_Buffer (Strm);
9503 Append_To (Stms,
9504 Make_Procedure_Call_Statement (Loc,
9505 Name =>
9506 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
9507 Parameter_Associations => New_List (
9508 New_Occurrence_Of (Strm, Loc))));
9509 end;
9510 end if;
9512 Append_To (Decls, Any_Decl);
9514 if Present (Result_TC) then
9515 Append_To (Stms,
9516 Make_Procedure_Call_Statement (Loc,
9517 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
9518 Parameter_Associations => New_List (
9519 New_Occurrence_Of (Any, Loc),
9520 Result_TC)));
9521 end if;
9523 Append_To (Stms,
9524 Make_Return_Statement (Loc,
9525 Expression => New_Occurrence_Of (Any, Loc)));
9527 Decl :=
9528 Make_Subprogram_Body (Loc,
9529 Specification => Spec,
9530 Declarations => Decls,
9531 Handled_Statement_Sequence =>
9532 Make_Handled_Sequence_Of_Statements (Loc,
9533 Statements => Stms));
9534 end Build_To_Any_Function;
9536 -------------------------
9537 -- Build_TypeCode_Call --
9538 -------------------------
9540 function Build_TypeCode_Call
9541 (Loc : Source_Ptr;
9542 Typ : Entity_Id;
9543 Decls : List_Id) return Node_Id
9545 U_Type : Entity_Id := Underlying_Type (Typ);
9546 -- The full view, if Typ is private; the completion,
9547 -- if Typ is incomplete.
9549 Fnam : Entity_Id := Empty;
9550 Lib_RE : RE_Id := RE_Null;
9552 Expr : Node_Id;
9554 begin
9555 -- Special case System.PolyORB.Interface.Any: its primitives have
9556 -- not been set yet, so can't call Find_Inherited_TSS.
9558 if Typ = RTE (RE_Any) then
9559 Fnam := RTE (RE_TC_Any);
9561 else
9562 -- First simple case where the TypeCode is present
9563 -- in the type's TSS.
9565 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
9566 end if;
9568 if No (Fnam) then
9569 if Sloc (U_Type) <= Standard_Location then
9571 -- Do not try to build alias typecodes for subtypes from
9572 -- Standard.
9574 U_Type := Base_Type (U_Type);
9575 end if;
9577 if U_Type = Standard_Boolean then
9578 Lib_RE := RE_TC_B;
9580 elsif U_Type = Standard_Character then
9581 Lib_RE := RE_TC_C;
9583 elsif U_Type = Standard_Wide_Character then
9584 Lib_RE := RE_TC_WC;
9586 elsif U_Type = Standard_Wide_Wide_Character then
9587 Lib_RE := RE_TC_WWC;
9589 -- Floating point types
9591 elsif U_Type = Standard_Short_Float then
9592 Lib_RE := RE_TC_SF;
9594 elsif U_Type = Standard_Float then
9595 Lib_RE := RE_TC_F;
9597 elsif U_Type = Standard_Long_Float then
9598 Lib_RE := RE_TC_LF;
9600 elsif U_Type = Standard_Long_Long_Float then
9601 Lib_RE := RE_TC_LLF;
9603 -- Integer types (walk back to the base type)
9605 elsif U_Type = Etype (Standard_Short_Short_Integer) then
9606 Lib_RE := RE_TC_SSI;
9608 elsif U_Type = Etype (Standard_Short_Integer) then
9609 Lib_RE := RE_TC_SI;
9611 elsif U_Type = Etype (Standard_Integer) then
9612 Lib_RE := RE_TC_I;
9614 elsif U_Type = Etype (Standard_Long_Integer) then
9615 Lib_RE := RE_TC_LI;
9617 elsif U_Type = Etype (Standard_Long_Long_Integer) then
9618 Lib_RE := RE_TC_LLI;
9620 -- Unsigned integer types
9622 elsif U_Type = RTE (RE_Short_Short_Unsigned) then
9623 Lib_RE := RE_TC_SSU;
9625 elsif U_Type = RTE (RE_Short_Unsigned) then
9626 Lib_RE := RE_TC_SU;
9628 elsif U_Type = RTE (RE_Unsigned) then
9629 Lib_RE := RE_TC_U;
9631 elsif U_Type = RTE (RE_Long_Unsigned) then
9632 Lib_RE := RE_TC_LU;
9634 elsif U_Type = RTE (RE_Long_Long_Unsigned) then
9635 Lib_RE := RE_TC_LLU;
9637 elsif U_Type = Standard_String then
9638 Lib_RE := RE_TC_String;
9640 -- Other (non-primitive) types
9642 else
9643 declare
9644 Decl : Entity_Id;
9645 begin
9646 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
9647 Append_To (Decls, Decl);
9648 end;
9649 end if;
9651 if Lib_RE /= RE_Null then
9652 Fnam := RTE (Lib_RE);
9653 end if;
9654 end if;
9656 -- Call the function
9658 Expr :=
9659 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
9661 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
9663 Set_Etype (Expr, RTE (RE_TypeCode));
9665 return Expr;
9666 end Build_TypeCode_Call;
9668 -----------------------------
9669 -- Build_TypeCode_Function --
9670 -----------------------------
9672 procedure Build_TypeCode_Function
9673 (Loc : Source_Ptr;
9674 Typ : Entity_Id;
9675 Decl : out Node_Id;
9676 Fnam : out Entity_Id)
9678 Spec : Node_Id;
9679 Decls : constant List_Id := New_List;
9680 Stms : constant List_Id := New_List;
9682 TCNam : constant Entity_Id :=
9683 Make_Stream_Procedure_Function_Name (Loc,
9684 Typ, Name_uTypeCode);
9686 Parameters : List_Id;
9688 procedure Add_String_Parameter
9689 (S : String_Id;
9690 Parameter_List : List_Id);
9691 -- Add a literal for S to Parameters
9693 procedure Add_TypeCode_Parameter
9694 (TC_Node : Node_Id;
9695 Parameter_List : List_Id);
9696 -- Add the typecode for Typ to Parameters
9698 procedure Add_Long_Parameter
9699 (Expr_Node : Node_Id;
9700 Parameter_List : List_Id);
9701 -- Add a signed long integer expression to Parameters
9703 procedure Initialize_Parameter_List
9704 (Name_String : String_Id;
9705 Repo_Id_String : String_Id;
9706 Parameter_List : out List_Id);
9707 -- Return a list that contains the first two parameters
9708 -- for a parameterized typecode: name and repository id.
9710 function Make_Constructed_TypeCode
9711 (Kind : Entity_Id;
9712 Parameters : List_Id) return Node_Id;
9713 -- Call TC_Build with the given kind and parameters
9715 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
9716 -- Make a return statement that calls TC_Build with the given
9717 -- typecode kind, and the constructed parameters list.
9719 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
9720 -- Return a typecode that is a TC_Alias for the given typecode
9722 --------------------------
9723 -- Add_String_Parameter --
9724 --------------------------
9726 procedure Add_String_Parameter
9727 (S : String_Id;
9728 Parameter_List : List_Id)
9730 begin
9731 Append_To (Parameter_List,
9732 Make_Function_Call (Loc,
9733 Name =>
9734 New_Occurrence_Of (RTE (RE_TA_String), Loc),
9735 Parameter_Associations => New_List (
9736 Make_String_Literal (Loc, S))));
9737 end Add_String_Parameter;
9739 ----------------------------
9740 -- Add_TypeCode_Parameter --
9741 ----------------------------
9743 procedure Add_TypeCode_Parameter
9744 (TC_Node : Node_Id;
9745 Parameter_List : List_Id)
9747 begin
9748 Append_To (Parameter_List,
9749 Make_Function_Call (Loc,
9750 Name =>
9751 New_Occurrence_Of (RTE (RE_TA_TC), Loc),
9752 Parameter_Associations => New_List (
9753 TC_Node)));
9754 end Add_TypeCode_Parameter;
9756 ------------------------
9757 -- Add_Long_Parameter --
9758 ------------------------
9760 procedure Add_Long_Parameter
9761 (Expr_Node : Node_Id;
9762 Parameter_List : List_Id)
9764 begin
9765 Append_To (Parameter_List,
9766 Make_Function_Call (Loc,
9767 Name =>
9768 New_Occurrence_Of (RTE (RE_TA_LI), Loc),
9769 Parameter_Associations => New_List (Expr_Node)));
9770 end Add_Long_Parameter;
9772 -------------------------------
9773 -- Initialize_Parameter_List --
9774 -------------------------------
9776 procedure Initialize_Parameter_List
9777 (Name_String : String_Id;
9778 Repo_Id_String : String_Id;
9779 Parameter_List : out List_Id)
9781 begin
9782 Parameter_List := New_List;
9783 Add_String_Parameter (Name_String, Parameter_List);
9784 Add_String_Parameter (Repo_Id_String, Parameter_List);
9785 end Initialize_Parameter_List;
9787 ---------------------------
9788 -- Return_Alias_TypeCode --
9789 ---------------------------
9791 procedure Return_Alias_TypeCode
9792 (Base_TypeCode : Node_Id)
9794 begin
9795 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
9796 Return_Constructed_TypeCode (RTE (RE_TC_Alias));
9797 end Return_Alias_TypeCode;
9799 -------------------------------
9800 -- Make_Constructed_TypeCode --
9801 -------------------------------
9803 function Make_Constructed_TypeCode
9804 (Kind : Entity_Id;
9805 Parameters : List_Id) return Node_Id
9807 Constructed_TC : constant Node_Id :=
9808 Make_Function_Call (Loc,
9809 Name =>
9810 New_Occurrence_Of (RTE (RE_TC_Build), Loc),
9811 Parameter_Associations => New_List (
9812 New_Occurrence_Of (Kind, Loc),
9813 Make_Aggregate (Loc,
9814 Expressions => Parameters)));
9815 begin
9816 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
9817 return Constructed_TC;
9818 end Make_Constructed_TypeCode;
9820 ---------------------------------
9821 -- Return_Constructed_TypeCode --
9822 ---------------------------------
9824 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
9825 begin
9826 Append_To (Stms,
9827 Make_Return_Statement (Loc,
9828 Expression =>
9829 Make_Constructed_TypeCode (Kind, Parameters)));
9830 end Return_Constructed_TypeCode;
9832 ------------------
9833 -- Record types --
9834 ------------------
9836 procedure TC_Rec_Add_Process_Element
9837 (Params : List_Id;
9838 Any : Entity_Id;
9839 Counter : in out Int;
9840 Rec : Entity_Id;
9841 Field : Node_Id);
9843 procedure TC_Append_Record_Traversal is
9844 new Append_Record_Traversal (
9845 Rec => Empty,
9846 Add_Process_Element => TC_Rec_Add_Process_Element);
9848 --------------------------------
9849 -- TC_Rec_Add_Process_Element --
9850 --------------------------------
9852 procedure TC_Rec_Add_Process_Element
9853 (Params : List_Id;
9854 Any : Entity_Id;
9855 Counter : in out Int;
9856 Rec : Entity_Id;
9857 Field : Node_Id)
9859 pragma Warnings (Off);
9860 pragma Unreferenced (Any, Counter, Rec);
9861 pragma Warnings (On);
9863 begin
9864 if Nkind (Field) = N_Defining_Identifier then
9866 -- A regular component
9868 Add_TypeCode_Parameter (
9869 Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
9870 Get_Name_String (Chars (Field));
9871 Add_String_Parameter (String_From_Name_Buffer, Params);
9873 else
9875 -- A variant part
9877 declare
9878 Discriminant_Type : constant Entity_Id :=
9879 Etype (Name (Field));
9881 Is_Enum : constant Boolean :=
9882 Is_Enumeration_Type (Discriminant_Type);
9884 Union_TC_Params : List_Id;
9886 U_Name : constant Name_Id :=
9887 New_External_Name (Chars (Typ), 'U', -1);
9889 Name_Str : String_Id;
9890 Struct_TC_Params : List_Id;
9892 Variant : Node_Id;
9893 Choice : Node_Id;
9894 Default : constant Node_Id :=
9895 Make_Integer_Literal (Loc, -1);
9897 Dummy_Counter : Int := 0;
9899 procedure Add_Params_For_Variant_Components;
9900 -- Add a struct TypeCode and a corresponding member name
9901 -- to the union parameter list.
9903 -- Ordering of declarations is a complete mess in this
9904 -- area, it is supposed to be types/varibles, then
9905 -- subprogram specs, then subprogram bodies ???
9907 ---------------------------------------
9908 -- Add_Params_For_Variant_Components --
9909 ---------------------------------------
9911 procedure Add_Params_For_Variant_Components
9913 S_Name : constant Name_Id :=
9914 New_External_Name (U_Name, 'S', -1);
9916 begin
9917 Get_Name_String (S_Name);
9918 Name_Str := String_From_Name_Buffer;
9919 Initialize_Parameter_List
9920 (Name_Str, Name_Str, Struct_TC_Params);
9922 -- Build struct parameters
9924 TC_Append_Record_Traversal (Struct_TC_Params,
9925 Component_List (Variant),
9926 Empty,
9927 Dummy_Counter);
9929 Add_TypeCode_Parameter
9930 (Make_Constructed_TypeCode
9931 (RTE (RE_TC_Struct), Struct_TC_Params),
9932 Union_TC_Params);
9934 Add_String_Parameter (Name_Str, Union_TC_Params);
9935 end Add_Params_For_Variant_Components;
9937 begin
9938 Get_Name_String (U_Name);
9939 Name_Str := String_From_Name_Buffer;
9941 Initialize_Parameter_List
9942 (Name_Str, Name_Str, Union_TC_Params);
9944 Add_String_Parameter (Name_Str, Params);
9946 -- Add union in enclosing parameter list
9948 Add_TypeCode_Parameter
9949 (Make_Constructed_TypeCode
9950 (RTE (RE_TC_Union), Union_TC_Params),
9951 Parameters);
9953 -- Build union parameters
9955 Add_TypeCode_Parameter
9956 (Discriminant_Type, Union_TC_Params);
9957 Add_Long_Parameter (Default, Union_TC_Params);
9959 Variant := First_Non_Pragma (Variants (Field));
9960 while Present (Variant) loop
9961 Choice := First (Discrete_Choices (Variant));
9962 while Present (Choice) loop
9963 case Nkind (Choice) is
9964 when N_Range =>
9965 declare
9966 L : constant Uint :=
9967 Expr_Value (Low_Bound (Choice));
9968 H : constant Uint :=
9969 Expr_Value (High_Bound (Choice));
9970 J : Uint := L;
9971 -- 3.8.1(8) guarantees that the bounds of
9972 -- this range are static.
9974 Expr : Node_Id;
9976 begin
9977 while J <= H loop
9978 if Is_Enum then
9979 Expr := New_Occurrence_Of (
9980 Get_Enum_Lit_From_Pos (
9981 Discriminant_Type, J, Loc), Loc);
9982 else
9983 Expr :=
9984 Make_Integer_Literal (Loc, J);
9985 end if;
9986 Append_To (Union_TC_Params,
9987 Build_To_Any_Call (Expr, Decls));
9988 Add_Params_For_Variant_Components;
9989 J := J + Uint_1;
9990 end loop;
9991 end;
9993 when N_Others_Choice =>
9994 Add_Long_Parameter (
9995 Make_Integer_Literal (Loc, 0),
9996 Union_TC_Params);
9997 Add_Params_For_Variant_Components;
9999 when others =>
10000 Append_To (Union_TC_Params,
10001 Build_To_Any_Call (Choice, Decls));
10002 Add_Params_For_Variant_Components;
10004 end case;
10006 end loop;
10008 Next_Non_Pragma (Variant);
10009 end loop;
10011 end;
10012 end if;
10013 end TC_Rec_Add_Process_Element;
10015 Type_Name_Str : String_Id;
10016 Type_Repo_Id_Str : String_Id;
10018 begin
10019 pragma Assert (not Is_Itype (Typ));
10020 Fnam := TCNam;
10022 Spec :=
10023 Make_Function_Specification (Loc,
10024 Defining_Unit_Name => Fnam,
10025 Parameter_Specifications => Empty_List,
10026 Result_Definition =>
10027 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10029 Build_Name_And_Repository_Id (Typ,
10030 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10031 Initialize_Parameter_List
10032 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10034 if Is_Derived_Type (Typ)
10035 and then not Is_Tagged_Type (Typ)
10036 then
10037 declare
10038 Parent_Type : Entity_Id := Etype (Typ);
10039 begin
10041 if Is_Itype (Parent_Type) then
10043 -- Skip implicit base type
10045 Parent_Type := Etype (Parent_Type);
10046 end if;
10048 Return_Alias_TypeCode (
10049 Build_TypeCode_Call (Loc, Parent_Type, Decls));
10050 end;
10052 elsif Is_Integer_Type (Typ)
10053 or else Is_Unsigned_Type (Typ)
10054 then
10055 Return_Alias_TypeCode (
10056 Build_TypeCode_Call (Loc,
10057 Find_Numeric_Representation (Typ), Decls));
10059 elsif Is_Record_Type (Typ)
10060 and then not Is_Tagged_Type (Typ)
10061 then
10062 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10063 Return_Alias_TypeCode (
10064 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10065 else
10066 declare
10067 Disc : Entity_Id := Empty;
10068 Rdef : constant Node_Id :=
10069 Type_Definition (Declaration_Node (Typ));
10070 Dummy_Counter : Int := 0;
10071 begin
10072 -- First all discriminants
10074 if Has_Discriminants (Typ) then
10075 Disc := First_Discriminant (Typ);
10076 end if;
10077 while Present (Disc) loop
10078 Add_TypeCode_Parameter (
10079 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10080 Parameters);
10081 Get_Name_String (Chars (Disc));
10082 Add_String_Parameter (
10083 String_From_Name_Buffer,
10084 Parameters);
10085 Next_Discriminant (Disc);
10086 end loop;
10088 -- ... then all components
10090 TC_Append_Record_Traversal
10091 (Parameters, Component_List (Rdef),
10092 Empty, Dummy_Counter);
10093 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10094 end;
10095 end if;
10097 elsif Is_Array_Type (Typ) then
10098 declare
10099 Ndim : constant Pos := Number_Dimensions (Typ);
10100 Inner_TypeCode : Node_Id;
10101 Constrained : constant Boolean := Is_Constrained (Typ);
10102 Indx : Node_Id := First_Index (Typ);
10104 begin
10105 Inner_TypeCode := Build_TypeCode_Call (Loc,
10106 Component_Type (Typ),
10107 Decls);
10109 for J in 1 .. Ndim loop
10110 if Constrained then
10111 Inner_TypeCode := Make_Constructed_TypeCode
10112 (RTE (RE_TC_Array), New_List (
10113 Build_To_Any_Call (
10114 OK_Convert_To (RTE (RE_Long_Unsigned),
10115 Make_Attribute_Reference (Loc,
10116 Prefix =>
10117 New_Occurrence_Of (Typ, Loc),
10118 Attribute_Name =>
10119 Name_Length,
10120 Expressions => New_List (
10121 Make_Integer_Literal (Loc,
10122 Ndim - J + 1)))),
10123 Decls),
10124 Build_To_Any_Call (Inner_TypeCode, Decls)));
10126 else
10127 -- Unconstrained case: add low bound for each
10128 -- dimension.
10130 Add_TypeCode_Parameter
10131 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10132 Parameters);
10133 Get_Name_String (New_External_Name ('L', J));
10134 Add_String_Parameter (
10135 String_From_Name_Buffer,
10136 Parameters);
10137 Next_Index (Indx);
10139 Inner_TypeCode := Make_Constructed_TypeCode
10140 (RTE (RE_TC_Sequence), New_List (
10141 Build_To_Any_Call (
10142 OK_Convert_To (RTE (RE_Long_Unsigned),
10143 Make_Integer_Literal (Loc, 0)),
10144 Decls),
10145 Build_To_Any_Call (Inner_TypeCode, Decls)));
10146 end if;
10147 end loop;
10149 if Constrained then
10150 Return_Alias_TypeCode (Inner_TypeCode);
10151 else
10152 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10153 Start_String;
10154 Store_String_Char ('V');
10155 Add_String_Parameter (End_String, Parameters);
10156 Return_Constructed_TypeCode (RTE (RE_TC_Struct));
10157 end if;
10158 end;
10160 else
10161 -- Default: type is represented as an opaque sequence of bytes
10163 Return_Alias_TypeCode
10164 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10165 end if;
10167 Decl :=
10168 Make_Subprogram_Body (Loc,
10169 Specification => Spec,
10170 Declarations => Decls,
10171 Handled_Statement_Sequence =>
10172 Make_Handled_Sequence_Of_Statements (Loc,
10173 Statements => Stms));
10174 end Build_TypeCode_Function;
10176 ---------------------------------
10177 -- Find_Numeric_Representation --
10178 ---------------------------------
10180 function Find_Numeric_Representation (Typ : Entity_Id)
10181 return Entity_Id
10183 FST : constant Entity_Id := First_Subtype (Typ);
10184 P_Size : constant Uint := Esize (FST);
10186 begin
10187 if Is_Unsigned_Type (Typ) then
10188 if P_Size <= Standard_Short_Short_Integer_Size then
10189 return RTE (RE_Short_Short_Unsigned);
10191 elsif P_Size <= Standard_Short_Integer_Size then
10192 return RTE (RE_Short_Unsigned);
10194 elsif P_Size <= Standard_Integer_Size then
10195 return RTE (RE_Unsigned);
10197 elsif P_Size <= Standard_Long_Integer_Size then
10198 return RTE (RE_Long_Unsigned);
10200 else
10201 return RTE (RE_Long_Long_Unsigned);
10202 end if;
10204 elsif Is_Integer_Type (Typ) then
10205 if P_Size <= Standard_Short_Short_Integer_Size then
10206 return Standard_Short_Short_Integer;
10208 elsif P_Size <= Standard_Short_Integer_Size then
10209 return Standard_Short_Integer;
10211 elsif P_Size <= Standard_Integer_Size then
10212 return Standard_Integer;
10214 elsif P_Size <= Standard_Long_Integer_Size then
10215 return Standard_Long_Integer;
10217 else
10218 return Standard_Long_Long_Integer;
10219 end if;
10221 elsif Is_Floating_Point_Type (Typ) then
10222 if P_Size <= Standard_Short_Float_Size then
10223 return Standard_Short_Float;
10225 elsif P_Size <= Standard_Float_Size then
10226 return Standard_Float;
10228 elsif P_Size <= Standard_Long_Float_Size then
10229 return Standard_Long_Float;
10231 else
10232 return Standard_Long_Long_Float;
10233 end if;
10235 else
10236 raise Program_Error;
10237 end if;
10239 -- TBD: fixed point types???
10240 -- TBverified numeric types with a biased representation???
10242 end Find_Numeric_Representation;
10244 ---------------------------
10245 -- Append_Array_Traversal --
10246 ---------------------------
10248 procedure Append_Array_Traversal
10249 (Stmts : List_Id;
10250 Any : Entity_Id;
10251 Counter : Entity_Id := Empty;
10252 Depth : Pos := 1)
10254 Loc : constant Source_Ptr := Sloc (Subprogram);
10255 Typ : constant Entity_Id := Etype (Arry);
10256 Constrained : constant Boolean := Is_Constrained (Typ);
10257 Ndim : constant Pos := Number_Dimensions (Typ);
10259 Inner_Any, Inner_Counter : Entity_Id;
10261 Loop_Stm : Node_Id;
10262 Inner_Stmts : constant List_Id := New_List;
10264 begin
10265 if Depth > Ndim then
10267 -- Processing for one element of an array
10269 declare
10270 Element_Expr : constant Node_Id :=
10271 Make_Indexed_Component (Loc,
10272 New_Occurrence_Of (Arry, Loc),
10273 Indices);
10275 begin
10276 Set_Etype (Element_Expr, Component_Type (Typ));
10277 Add_Process_Element (Stmts,
10278 Any => Any,
10279 Counter => Counter,
10280 Datum => Element_Expr);
10281 end;
10283 return;
10284 end if;
10286 Append_To (Indices,
10287 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10289 if Constrained then
10290 Inner_Any := Any;
10291 Inner_Counter := Counter;
10292 else
10293 Inner_Any := Make_Defining_Identifier (Loc,
10294 New_External_Name ('A', Depth));
10295 Set_Etype (Inner_Any, RTE (RE_Any));
10297 if Present (Counter) then
10298 Inner_Counter := Make_Defining_Identifier (Loc,
10299 New_External_Name ('J', Depth));
10300 else
10301 Inner_Counter := Empty;
10302 end if;
10303 end if;
10305 Append_Array_Traversal (Inner_Stmts,
10306 Any => Inner_Any,
10307 Counter => Inner_Counter,
10308 Depth => Depth + 1);
10310 Loop_Stm :=
10311 Make_Implicit_Loop_Statement (Subprogram,
10312 Iteration_Scheme =>
10313 Make_Iteration_Scheme (Loc,
10314 Loop_Parameter_Specification =>
10315 Make_Loop_Parameter_Specification (Loc,
10316 Defining_Identifier =>
10317 Make_Defining_Identifier (Loc,
10318 Chars => New_External_Name ('L', Depth)),
10320 Discrete_Subtype_Definition =>
10321 Make_Attribute_Reference (Loc,
10322 Prefix => New_Occurrence_Of (Arry, Loc),
10323 Attribute_Name => Name_Range,
10325 Expressions => New_List (
10326 Make_Integer_Literal (Loc, Depth))))),
10327 Statements => Inner_Stmts);
10329 if Constrained then
10330 Append_To (Stmts, Loop_Stm);
10331 return;
10332 end if;
10334 declare
10335 Decls : constant List_Id := New_List;
10336 Dimen_Stmts : constant List_Id := New_List;
10337 Length_Node : Node_Id;
10339 Inner_Any_TypeCode : constant Entity_Id :=
10340 Make_Defining_Identifier (Loc,
10341 New_External_Name ('T', Depth));
10343 Inner_Any_TypeCode_Expr : Node_Id;
10345 begin
10346 if Depth = 1 then
10347 Inner_Any_TypeCode_Expr :=
10348 Make_Function_Call (Loc,
10349 Name =>
10350 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
10351 Parameter_Associations => New_List (
10352 New_Occurrence_Of (Any, Loc),
10353 Make_Integer_Literal (Loc, Ndim)));
10354 else
10355 Inner_Any_TypeCode_Expr :=
10356 Make_Function_Call (Loc,
10357 Name =>
10358 New_Occurrence_Of (RTE (RE_Content_Type), Loc),
10359 Parameter_Associations => New_List (
10360 Make_Identifier (Loc,
10361 New_External_Name ('T', Depth - 1))));
10362 end if;
10364 Append_To (Decls,
10365 Make_Object_Declaration (Loc,
10366 Defining_Identifier => Inner_Any_TypeCode,
10367 Constant_Present => True,
10368 Object_Definition => New_Occurrence_Of (
10369 RTE (RE_TypeCode), Loc),
10370 Expression => Inner_Any_TypeCode_Expr));
10371 Append_To (Decls,
10372 Make_Object_Declaration (Loc,
10373 Defining_Identifier => Inner_Any,
10374 Object_Definition =>
10375 New_Occurrence_Of (RTE (RE_Any), Loc),
10376 Expression =>
10377 Make_Function_Call (Loc,
10378 Name =>
10379 New_Occurrence_Of (
10380 RTE (RE_Create_Any), Loc),
10381 Parameter_Associations => New_List (
10382 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
10384 if Present (Inner_Counter) then
10385 Append_To (Decls,
10386 Make_Object_Declaration (Loc,
10387 Defining_Identifier => Inner_Counter,
10388 Object_Definition =>
10389 New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
10390 Expression =>
10391 Make_Integer_Literal (Loc, 0)));
10392 end if;
10394 Length_Node := Make_Attribute_Reference (Loc,
10395 Prefix => New_Occurrence_Of (Arry, Loc),
10396 Attribute_Name => Name_Length,
10397 Expressions =>
10398 New_List (Make_Integer_Literal (Loc, Depth)));
10399 Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
10401 Add_Process_Element (Dimen_Stmts,
10402 Datum => Length_Node,
10403 Any => Inner_Any,
10404 Counter => Inner_Counter);
10406 -- Loop_Stm does approrpriate processing for each element
10407 -- of Inner_Any.
10409 Append_To (Dimen_Stmts, Loop_Stm);
10411 -- Link outer and inner any
10413 Add_Process_Element (Dimen_Stmts,
10414 Any => Any,
10415 Counter => Counter,
10416 Datum => New_Occurrence_Of (Inner_Any, Loc));
10418 Append_To (Stmts,
10419 Make_Block_Statement (Loc,
10420 Declarations =>
10421 Decls,
10422 Handled_Statement_Sequence =>
10423 Make_Handled_Sequence_Of_Statements (Loc,
10424 Statements => Dimen_Stmts)));
10425 end;
10426 end Append_Array_Traversal;
10428 -----------------------------------------
10429 -- Make_Stream_Procedure_Function_Name --
10430 -----------------------------------------
10432 function Make_Stream_Procedure_Function_Name
10433 (Loc : Source_Ptr;
10434 Typ : Entity_Id;
10435 Nam : Name_Id) return Entity_Id
10437 begin
10438 -- For tagged types, we use a canonical name so that it matches
10439 -- the primitive spec. For all other cases, we use a serialized
10440 -- name so that multiple generations of the same procedure do not
10441 -- clash.
10443 if Is_Tagged_Type (Typ) then
10444 return Make_Defining_Identifier (Loc, Nam);
10445 else
10446 return Make_Defining_Identifier (Loc,
10447 Chars =>
10448 New_External_Name (Nam, ' ', Increment_Serial_Number));
10449 end if;
10450 end Make_Stream_Procedure_Function_Name;
10451 end Helpers;
10453 -----------------------------------
10454 -- Reserve_NamingContext_Methods --
10455 -----------------------------------
10457 procedure Reserve_NamingContext_Methods is
10458 Str_Resolve : constant String := "resolve";
10459 begin
10460 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
10461 Name_Len := Str_Resolve'Length;
10462 Overload_Counter_Table.Set (Name_Find, 1);
10463 end Reserve_NamingContext_Methods;
10465 end PolyORB_Support;
10467 -------------------------------
10468 -- RACW_Type_Is_Asynchronous --
10469 -------------------------------
10471 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
10472 Asynchronous_Flag : constant Entity_Id :=
10473 Asynchronous_Flags_Table.Get (RACW_Type);
10474 begin
10475 Replace (Expression (Parent (Asynchronous_Flag)),
10476 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
10477 end RACW_Type_Is_Asynchronous;
10479 -------------------------
10480 -- RCI_Package_Locator --
10481 -------------------------
10483 function RCI_Package_Locator
10484 (Loc : Source_Ptr;
10485 Package_Spec : Node_Id) return Node_Id
10487 Inst : Node_Id;
10488 Pkg_Name : String_Id;
10490 begin
10491 Get_Library_Unit_Name_String (Package_Spec);
10492 Pkg_Name := String_From_Name_Buffer;
10493 Inst :=
10494 Make_Package_Instantiation (Loc,
10495 Defining_Unit_Name =>
10496 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
10497 Name =>
10498 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
10499 Generic_Associations => New_List (
10500 Make_Generic_Association (Loc,
10501 Selector_Name =>
10502 Make_Identifier (Loc, Name_RCI_Name),
10503 Explicit_Generic_Actual_Parameter =>
10504 Make_String_Literal (Loc,
10505 Strval => Pkg_Name))));
10507 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
10508 Defining_Unit_Name (Inst));
10509 return Inst;
10510 end RCI_Package_Locator;
10512 -----------------------------------------------
10513 -- Remote_Types_Tagged_Full_View_Encountered --
10514 -----------------------------------------------
10516 procedure Remote_Types_Tagged_Full_View_Encountered
10517 (Full_View : Entity_Id)
10519 Stub_Elements : constant Stub_Structure :=
10520 Stubs_Table.Get (Full_View);
10521 begin
10522 if Stub_Elements /= Empty_Stub_Structure then
10523 Add_RACW_Primitive_Declarations_And_Bodies
10524 (Full_View,
10525 Stub_Elements.RPC_Receiver_Decl,
10526 List_Containing (Declaration_Node (Full_View)));
10527 end if;
10528 end Remote_Types_Tagged_Full_View_Encountered;
10530 -------------------
10531 -- Scope_Of_Spec --
10532 -------------------
10534 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
10535 Unit_Name : Node_Id := Defining_Unit_Name (Spec);
10537 begin
10538 while Nkind (Unit_Name) /= N_Defining_Identifier loop
10539 Unit_Name := Defining_Identifier (Unit_Name);
10540 end loop;
10542 return Unit_Name;
10543 end Scope_Of_Spec;
10545 ----------------------
10546 -- Set_Renaming_TSS --
10547 ----------------------
10549 procedure Set_Renaming_TSS
10550 (Typ : Entity_Id;
10551 Nam : Entity_Id;
10552 TSS_Nam : TSS_Name_Type)
10554 Loc : constant Source_Ptr := Sloc (Nam);
10555 Spec : constant Node_Id := Parent (Nam);
10557 TSS_Node : constant Node_Id :=
10558 Make_Subprogram_Renaming_Declaration (Loc,
10559 Specification =>
10560 Copy_Specification (Loc,
10561 Spec => Spec,
10562 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
10563 Name => New_Occurrence_Of (Nam, Loc));
10565 Snam : constant Entity_Id :=
10566 Defining_Unit_Name (Specification (TSS_Node));
10568 begin
10569 if Nkind (Spec) = N_Function_Specification then
10570 Set_Ekind (Snam, E_Function);
10571 Set_Etype (Snam, Entity (Result_Definition (Spec)));
10572 else
10573 Set_Ekind (Snam, E_Procedure);
10574 Set_Etype (Snam, Standard_Void_Type);
10575 end if;
10577 Set_TSS (Typ, Snam);
10578 end Set_Renaming_TSS;
10580 ----------------------------------------------
10581 -- Specific_Add_Obj_RPC_Receiver_Completion --
10582 ----------------------------------------------
10584 procedure Specific_Add_Obj_RPC_Receiver_Completion
10585 (Loc : Source_Ptr;
10586 Decls : List_Id;
10587 RPC_Receiver : Entity_Id;
10588 Stub_Elements : Stub_Structure) is
10589 begin
10590 case Get_PCS_Name is
10591 when Name_PolyORB_DSA =>
10592 PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
10593 Decls, RPC_Receiver, Stub_Elements);
10594 when others =>
10595 GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
10596 Decls, RPC_Receiver, Stub_Elements);
10597 end case;
10598 end Specific_Add_Obj_RPC_Receiver_Completion;
10600 --------------------------------
10601 -- Specific_Add_RACW_Features --
10602 --------------------------------
10604 procedure Specific_Add_RACW_Features
10605 (RACW_Type : Entity_Id;
10606 Desig : Entity_Id;
10607 Stub_Type : Entity_Id;
10608 Stub_Type_Access : Entity_Id;
10609 RPC_Receiver_Decl : Node_Id;
10610 Declarations : List_Id) is
10611 begin
10612 case Get_PCS_Name is
10613 when Name_PolyORB_DSA =>
10614 PolyORB_Support.Add_RACW_Features (
10615 RACW_Type,
10616 Desig,
10617 Stub_Type,
10618 Stub_Type_Access,
10619 RPC_Receiver_Decl,
10620 Declarations);
10622 when others =>
10623 GARLIC_Support.Add_RACW_Features (
10624 RACW_Type,
10625 Stub_Type,
10626 Stub_Type_Access,
10627 RPC_Receiver_Decl,
10628 Declarations);
10629 end case;
10630 end Specific_Add_RACW_Features;
10632 --------------------------------
10633 -- Specific_Add_RAST_Features --
10634 --------------------------------
10636 procedure Specific_Add_RAST_Features
10637 (Vis_Decl : Node_Id;
10638 RAS_Type : Entity_Id) is
10639 begin
10640 case Get_PCS_Name is
10641 when Name_PolyORB_DSA =>
10642 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
10643 when others =>
10644 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
10645 end case;
10646 end Specific_Add_RAST_Features;
10648 --------------------------------------------------
10649 -- Specific_Add_Receiving_Stubs_To_Declarations --
10650 --------------------------------------------------
10652 procedure Specific_Add_Receiving_Stubs_To_Declarations
10653 (Pkg_Spec : Node_Id;
10654 Decls : List_Id)
10656 begin
10657 case Get_PCS_Name is
10658 when Name_PolyORB_DSA =>
10659 PolyORB_Support.Add_Receiving_Stubs_To_Declarations (
10660 Pkg_Spec, Decls);
10661 when others =>
10662 GARLIC_Support.Add_Receiving_Stubs_To_Declarations (
10663 Pkg_Spec, Decls);
10664 end case;
10665 end Specific_Add_Receiving_Stubs_To_Declarations;
10667 ------------------------------------------
10668 -- Specific_Build_General_Calling_Stubs --
10669 ------------------------------------------
10671 procedure Specific_Build_General_Calling_Stubs
10672 (Decls : List_Id;
10673 Statements : List_Id;
10674 Target : RPC_Target;
10675 Subprogram_Id : Node_Id;
10676 Asynchronous : Node_Id := Empty;
10677 Is_Known_Asynchronous : Boolean := False;
10678 Is_Known_Non_Asynchronous : Boolean := False;
10679 Is_Function : Boolean;
10680 Spec : Node_Id;
10681 Stub_Type : Entity_Id := Empty;
10682 RACW_Type : Entity_Id := Empty;
10683 Nod : Node_Id)
10685 begin
10686 case Get_PCS_Name is
10687 when Name_PolyORB_DSA =>
10688 PolyORB_Support.Build_General_Calling_Stubs (
10689 Decls,
10690 Statements,
10691 Target.Object,
10692 Subprogram_Id,
10693 Asynchronous,
10694 Is_Known_Asynchronous,
10695 Is_Known_Non_Asynchronous,
10696 Is_Function,
10697 Spec,
10698 Stub_Type,
10699 RACW_Type,
10700 Nod);
10701 when others =>
10702 GARLIC_Support.Build_General_Calling_Stubs (
10703 Decls,
10704 Statements,
10705 Target.Partition,
10706 Target.RPC_Receiver,
10707 Subprogram_Id,
10708 Asynchronous,
10709 Is_Known_Asynchronous,
10710 Is_Known_Non_Asynchronous,
10711 Is_Function,
10712 Spec,
10713 Stub_Type,
10714 RACW_Type,
10715 Nod);
10716 end case;
10717 end Specific_Build_General_Calling_Stubs;
10719 --------------------------------------
10720 -- Specific_Build_RPC_Receiver_Body --
10721 --------------------------------------
10723 procedure Specific_Build_RPC_Receiver_Body
10724 (RPC_Receiver : Entity_Id;
10725 Request : out Entity_Id;
10726 Subp_Id : out Entity_Id;
10727 Subp_Index : out Entity_Id;
10728 Stmts : out List_Id;
10729 Decl : out Node_Id)
10731 begin
10732 case Get_PCS_Name is
10733 when Name_PolyORB_DSA =>
10734 PolyORB_Support.Build_RPC_Receiver_Body
10735 (RPC_Receiver,
10736 Request,
10737 Subp_Id,
10738 Subp_Index,
10739 Stmts,
10740 Decl);
10741 when others =>
10742 GARLIC_Support.Build_RPC_Receiver_Body
10743 (RPC_Receiver,
10744 Request,
10745 Subp_Id,
10746 Subp_Index,
10747 Stmts,
10748 Decl);
10749 end case;
10750 end Specific_Build_RPC_Receiver_Body;
10752 --------------------------------
10753 -- Specific_Build_Stub_Target --
10754 --------------------------------
10756 function Specific_Build_Stub_Target
10757 (Loc : Source_Ptr;
10758 Decls : List_Id;
10759 RCI_Locator : Entity_Id;
10760 Controlling_Parameter : Entity_Id) return RPC_Target is
10761 begin
10762 case Get_PCS_Name is
10763 when Name_PolyORB_DSA =>
10764 return PolyORB_Support.Build_Stub_Target (Loc,
10765 Decls, RCI_Locator, Controlling_Parameter);
10766 when others =>
10767 return GARLIC_Support.Build_Stub_Target (Loc,
10768 Decls, RCI_Locator, Controlling_Parameter);
10769 end case;
10770 end Specific_Build_Stub_Target;
10772 ------------------------------
10773 -- Specific_Build_Stub_Type --
10774 ------------------------------
10776 procedure Specific_Build_Stub_Type
10777 (RACW_Type : Entity_Id;
10778 Stub_Type : Entity_Id;
10779 Stub_Type_Decl : out Node_Id;
10780 RPC_Receiver_Decl : out Node_Id)
10782 begin
10783 case Get_PCS_Name is
10784 when Name_PolyORB_DSA =>
10785 PolyORB_Support.Build_Stub_Type (
10786 RACW_Type, Stub_Type,
10787 Stub_Type_Decl, RPC_Receiver_Decl);
10788 when others =>
10789 GARLIC_Support.Build_Stub_Type (
10790 RACW_Type, Stub_Type,
10791 Stub_Type_Decl, RPC_Receiver_Decl);
10792 end case;
10793 end Specific_Build_Stub_Type;
10795 function Specific_Build_Subprogram_Receiving_Stubs
10796 (Vis_Decl : Node_Id;
10797 Asynchronous : Boolean;
10798 Dynamically_Asynchronous : Boolean := False;
10799 Stub_Type : Entity_Id := Empty;
10800 RACW_Type : Entity_Id := Empty;
10801 Parent_Primitive : Entity_Id := Empty) return Node_Id is
10802 begin
10803 case Get_PCS_Name is
10804 when Name_PolyORB_DSA =>
10805 return PolyORB_Support.Build_Subprogram_Receiving_Stubs (
10806 Vis_Decl,
10807 Asynchronous,
10808 Dynamically_Asynchronous,
10809 Stub_Type,
10810 RACW_Type,
10811 Parent_Primitive);
10812 when others =>
10813 return GARLIC_Support.Build_Subprogram_Receiving_Stubs (
10814 Vis_Decl,
10815 Asynchronous,
10816 Dynamically_Asynchronous,
10817 Stub_Type,
10818 RACW_Type,
10819 Parent_Primitive);
10820 end case;
10821 end Specific_Build_Subprogram_Receiving_Stubs;
10823 --------------------------
10824 -- Underlying_RACW_Type --
10825 --------------------------
10827 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
10828 Record_Type : Entity_Id;
10830 begin
10831 if Ekind (RAS_Typ) = E_Record_Type then
10832 Record_Type := RAS_Typ;
10833 else
10834 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
10835 Record_Type := Equivalent_Type (RAS_Typ);
10836 end if;
10838 return
10839 Etype (Subtype_Indication (
10840 Component_Definition (
10841 First (Component_Items (Component_List (
10842 Type_Definition (Declaration_Node (Record_Type))))))));
10843 end Underlying_RACW_Type;
10845 end Exp_Dist;