Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / exp_dist.adb
blob364330339fe09ce84833e90ab27a8f4cdd354b9d
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-2013, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Elists; use Elists;
29 with Exp_Atag; use Exp_Atag;
30 with Exp_Disp; use Exp_Disp;
31 with Exp_Strm; use Exp_Strm;
32 with Exp_Tss; use Exp_Tss;
33 with Exp_Util; use Exp_Util;
34 with Lib; use Lib;
35 with Nlists; use Nlists;
36 with Nmake; use Nmake;
37 with Opt; use Opt;
38 with Rtsfind; use Rtsfind;
39 with Sem; use Sem;
40 with Sem_Aux; use Sem_Aux;
41 with Sem_Cat; use Sem_Cat;
42 with Sem_Ch3; use Sem_Ch3;
43 with Sem_Ch8; use Sem_Ch8;
44 with Sem_Ch12; use Sem_Ch12;
45 with Sem_Dist; use Sem_Dist;
46 with Sem_Eval; use Sem_Eval;
47 with Sem_Util; use Sem_Util;
48 with Sinfo; use Sinfo;
49 with Stand; use Stand;
50 with Stringt; use Stringt;
51 with Tbuild; use Tbuild;
52 with Ttypes; use Ttypes;
53 with Uintp; use Uintp;
55 with GNAT.HTable; use GNAT.HTable;
57 package body Exp_Dist is
59 -- The following model has been used to implement distributed objects:
60 -- given a designated type D and a RACW type R, then a record of the form:
62 -- type Stub is tagged record
63 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
64 -- end record;
66 -- is built. This type has two properties:
68 -- 1) Since it has the same structure as RACW_Stub_Type, it can
69 -- be converted to and from this type to make it suitable for
70 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
71 -- to avoid memory leaks when the same remote object arrives on the
72 -- same partition through several paths;
74 -- 2) It also has the same dispatching table as the designated type D,
75 -- and thus can be used as an object designated by a value of type
76 -- R on any partition other than the one on which the object has
77 -- been created, since only dispatching calls will be performed and
78 -- the fields themselves will not be used. We call Derive_Subprograms
79 -- to fake half a derivation to ensure that the subprograms do have
80 -- the same dispatching table.
82 First_RCI_Subprogram_Id : constant := 2;
83 -- RCI subprograms are numbered starting at 2. The RCI receiver for
84 -- an RCI package can thus identify calls received through remote
85 -- access-to-subprogram dereferences by the fact that they have a
86 -- (primitive) subprogram id of 0, and 1 is used for the internal RAS
87 -- information lookup operation. (This is for the Garlic code generation,
88 -- where subprograms are identified by numbers; in the PolyORB version,
89 -- they are identified by name, with a numeric suffix for homonyms.)
91 type Hash_Index is range 0 .. 50;
93 -----------------------
94 -- Local subprograms --
95 -----------------------
97 function Hash (F : Entity_Id) return Hash_Index;
98 -- DSA expansion associates stubs to distributed object types using a hash
99 -- table on entity ids.
101 function Hash (F : Name_Id) return Hash_Index;
102 -- The generation of subprogram identifiers requires an overload counter
103 -- to be associated with each remote subprogram name. These counters are
104 -- maintained in a hash table on name ids.
106 type Subprogram_Identifiers is record
107 Str_Identifier : String_Id;
108 Int_Identifier : Int;
109 end record;
111 package Subprogram_Identifier_Table is
112 new Simple_HTable (Header_Num => Hash_Index,
113 Element => Subprogram_Identifiers,
114 No_Element => (No_String, 0),
115 Key => Entity_Id,
116 Hash => Hash,
117 Equal => "=");
118 -- Mapping between a remote subprogram and the corresponding subprogram
119 -- identifiers.
121 package Overload_Counter_Table is
122 new Simple_HTable (Header_Num => Hash_Index,
123 Element => Int,
124 No_Element => 0,
125 Key => Name_Id,
126 Hash => Hash,
127 Equal => "=");
128 -- Mapping between a subprogram name and an integer that counts the number
129 -- of defining subprogram names with that Name_Id encountered so far in a
130 -- given context (an interface).
132 function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
133 function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
134 function Get_Subprogram_Id (Def : Entity_Id) return Int;
135 -- Given a subprogram defined in a RCI package, get its distribution
136 -- subprogram identifiers (the distribution identifiers are a unique
137 -- subprogram number, and the non-qualified subprogram name, in the
138 -- casing used for the subprogram declaration; if the name is overloaded,
139 -- a double underscore and a serial number are appended.
141 -- The integer identifier is used to perform remote calls with GARLIC;
142 -- the string identifier is used in the case of PolyORB.
144 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
145 -- when receiving a call, the calling stubs will create requests with the
146 -- exact casing of the defining unit name of the called subprogram, so as
147 -- to allow calls to subprograms on distributed nodes that do distinguish
148 -- between casings.
150 -- NOTE: Another design would be to allow a representation clause on
151 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
153 pragma Warnings (Off, Get_Subprogram_Id);
154 -- One homonym only is unreferenced (specific to the GARLIC version)
156 procedure Add_RAS_Dereference_TSS (N : Node_Id);
157 -- Add a subprogram body for RAS Dereference TSS
159 procedure Add_RAS_Proxy_And_Analyze
160 (Decls : List_Id;
161 Vis_Decl : Node_Id;
162 All_Calls_Remote_E : Entity_Id;
163 Proxy_Object_Addr : out Entity_Id);
164 -- Add the proxy type required, on the receiving (server) side, to handle
165 -- calls to the subprogram declared by Vis_Decl through a remote access
166 -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
167 -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
168 -- is appended to Decls. Proxy_Object_Addr is a constant of type
169 -- System.Address that designates an instance of the proxy object.
171 function Build_Remote_Subprogram_Proxy_Type
172 (Loc : Source_Ptr;
173 ACR_Expression : Node_Id) return Node_Id;
174 -- Build and return a tagged record type definition for an RCI subprogram
175 -- proxy type. ACR_Expression is used as the initialization value for the
176 -- 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_Stub_Tag
187 (Loc : Source_Ptr;
188 RACW_Type : Entity_Id) return Node_Id;
189 -- Return an expression denoting the tag of the stub type associated with
190 -- RACW_Type.
192 function Build_Subprogram_Calling_Stubs
193 (Vis_Decl : Node_Id;
194 Subp_Id : Node_Id;
195 Asynchronous : Boolean;
196 Dynamically_Asynchronous : Boolean := False;
197 Stub_Type : Entity_Id := Empty;
198 RACW_Type : Entity_Id := Empty;
199 Locator : Entity_Id := Empty;
200 New_Name : Name_Id := No_Name) return Node_Id;
201 -- Build the calling stub for a given subprogram with the subprogram ID
202 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
203 -- parameters of this type will be marshalled instead of the object itself.
204 -- It will then be converted into Stub_Type before performing the real
205 -- call. If Dynamically_Asynchronous is True, then it will be computed at
206 -- run time whether the call is asynchronous or not. Otherwise, the value
207 -- of the formal Asynchronous will be used. If Locator is not Empty, it
208 -- will be used instead of RCI_Cache. If New_Name is given, then it will
209 -- be used instead of the original name.
211 function Build_RPC_Receiver_Specification
212 (RPC_Receiver : Entity_Id;
213 Request_Parameter : Entity_Id) return Node_Id;
214 -- Make a subprogram specification for an RPC receiver, with the given
215 -- defining unit name and formal parameter.
217 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
218 -- Return an ordered parameter list: unconstrained parameters are put
219 -- at the beginning of the list and constrained ones are put after. If
220 -- there are no parameters, an empty list is returned. Special case:
221 -- the controlling formal of the equivalent RACW operation for a RAS
222 -- type is always left in first position.
224 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean;
225 -- True when Typ is an unconstrained type, or a null-excluding access type.
226 -- In either case, this means stubs cannot contain a default-initialized
227 -- object declaration of such type.
229 procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id);
230 -- Add calling stubs to the declarative part
232 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
233 -- Return True if nothing prevents the program whose specification is
234 -- given to be asynchronous (i.e. no [IN] OUT parameters).
236 function Pack_Entity_Into_Stream_Access
237 (Loc : Source_Ptr;
238 Stream : Node_Id;
239 Object : Entity_Id;
240 Etyp : Entity_Id := Empty) return Node_Id;
241 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
242 -- then Etype (Object) will be used if present. If the type is
243 -- constrained, then 'Write will be used to output the object,
244 -- If the type is unconstrained, 'Output will be used.
246 function Pack_Node_Into_Stream
247 (Loc : Source_Ptr;
248 Stream : Entity_Id;
249 Object : Node_Id;
250 Etyp : Entity_Id) return Node_Id;
251 -- Similar to above, with an arbitrary node instead of an entity
253 function Pack_Node_Into_Stream_Access
254 (Loc : Source_Ptr;
255 Stream : Node_Id;
256 Object : Node_Id;
257 Etyp : Entity_Id) return Node_Id;
258 -- Similar to above, with Stream instead of Stream'Access
260 function Make_Selected_Component
261 (Loc : Source_Ptr;
262 Prefix : Entity_Id;
263 Selector_Name : Name_Id) return Node_Id;
264 -- Return a selected_component whose prefix denotes the given entity, and
265 -- with the given Selector_Name.
267 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
268 -- Return the scope represented by a given spec
270 procedure Set_Renaming_TSS
271 (Typ : Entity_Id;
272 Nam : Entity_Id;
273 TSS_Nam : TSS_Name_Type);
274 -- Create a renaming declaration of subprogram Nam, and register it as a
275 -- TSS for Typ with name TSS_Nam.
277 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
278 -- Return True if the current parameter needs an extra formal to reflect
279 -- its constrained status.
281 function Is_RACW_Controlling_Formal
282 (Parameter : Node_Id;
283 Stub_Type : Entity_Id) return Boolean;
284 -- Return True if the current parameter is a controlling formal argument
285 -- of type Stub_Type or access to Stub_Type.
287 procedure Declare_Create_NVList
288 (Loc : Source_Ptr;
289 NVList : Entity_Id;
290 Decls : List_Id;
291 Stmts : List_Id);
292 -- Append the declaration of NVList to Decls, and its
293 -- initialization to Stmts.
295 function Add_Parameter_To_NVList
296 (Loc : Source_Ptr;
297 NVList : Entity_Id;
298 Parameter : Entity_Id;
299 Constrained : Boolean;
300 RACW_Ctrl : Boolean := False;
301 Any : Entity_Id) return Node_Id;
302 -- Return a call to Add_Item to add the Any corresponding to the designated
303 -- formal Parameter (with the indicated Constrained status) to NVList.
304 -- RACW_Ctrl must be set to True for controlling formals of distributed
305 -- object primitive operations.
307 --------------------
308 -- Stub_Structure --
309 --------------------
311 -- This record describes various tree fragments associated with the
312 -- generation of RACW calling stubs. One such record exists for every
313 -- distributed object type, i.e. each tagged type that is the designated
314 -- type of one or more RACW type.
316 type Stub_Structure is record
317 Stub_Type : Entity_Id;
318 -- Stub type: this type has the same primitive operations as the
319 -- designated types, but the provided bodies for these operations
320 -- a remote call to an actual target object potentially located on
321 -- another partition; each value of the stub type encapsulates a
322 -- reference to a remote object.
324 Stub_Type_Access : Entity_Id;
325 -- A local access type designating the stub type (this is not an RACW
326 -- type).
328 RPC_Receiver_Decl : Node_Id;
329 -- Declaration for the RPC receiver entity associated with the
330 -- designated type. As an exception, in the case of GARLIC, for an RACW
331 -- that implements a RAS, no object RPC receiver is generated. Instead,
332 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
333 -- would have been inserted.
335 Body_Decls : List_Id;
336 -- List of subprogram bodies to be included in generated code: bodies
337 -- for the RACW's stream attributes, and for the primitive operations
338 -- of the stub type.
340 RACW_Type : Entity_Id;
341 -- One of the RACW types designating this distributed object type
342 -- (they are all interchangeable; we use any one of them in order to
343 -- avoid having to create various anonymous access types).
345 end record;
347 Empty_Stub_Structure : constant Stub_Structure :=
348 (Empty, Empty, Empty, No_List, Empty);
350 package Stubs_Table is
351 new Simple_HTable (Header_Num => Hash_Index,
352 Element => Stub_Structure,
353 No_Element => Empty_Stub_Structure,
354 Key => Entity_Id,
355 Hash => Hash,
356 Equal => "=");
357 -- Mapping between a RACW designated type and its stub type
359 package Asynchronous_Flags_Table is
360 new Simple_HTable (Header_Num => Hash_Index,
361 Element => Entity_Id,
362 No_Element => Empty,
363 Key => Entity_Id,
364 Hash => Hash,
365 Equal => "=");
366 -- Mapping between a RACW type and a constant having the value True
367 -- if the RACW is asynchronous and False otherwise.
369 package RCI_Locator_Table is
370 new Simple_HTable (Header_Num => Hash_Index,
371 Element => Entity_Id,
372 No_Element => Empty,
373 Key => Entity_Id,
374 Hash => Hash,
375 Equal => "=");
376 -- Mapping between a RCI package on which All_Calls_Remote applies and
377 -- the generic instantiation of RCI_Locator for this package.
379 package RCI_Calling_Stubs_Table is
380 new Simple_HTable (Header_Num => Hash_Index,
381 Element => Entity_Id,
382 No_Element => Empty,
383 Key => Entity_Id,
384 Hash => Hash,
385 Equal => "=");
386 -- Mapping between a RCI subprogram and the corresponding calling stubs
388 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure;
389 -- Return the stub information associated with the given RACW type
391 procedure Add_Stub_Type
392 (Designated_Type : Entity_Id;
393 RACW_Type : Entity_Id;
394 Decls : List_Id;
395 Stub_Type : out Entity_Id;
396 Stub_Type_Access : out Entity_Id;
397 RPC_Receiver_Decl : out Node_Id;
398 Body_Decls : out List_Id;
399 Existing : out Boolean);
400 -- Add the declaration of the stub type, the access to stub type and the
401 -- object RPC receiver at the end of Decls. If these already exist,
402 -- then nothing is added in the tree but the right values are returned
403 -- anyhow and Existing is set to True.
405 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
406 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
407 -- structure table, reset it to No_List, and return the previous value.
409 procedure Add_RACW_Asynchronous_Flag
410 (Declarations : List_Id;
411 RACW_Type : Entity_Id);
412 -- Declare a boolean constant associated with RACW_Type whose value
413 -- indicates at run time whether a pragma Asynchronous applies to it.
415 procedure Assign_Subprogram_Identifier
416 (Def : Entity_Id;
417 Spn : Int;
418 Id : out String_Id);
419 -- Determine the distribution subprogram identifier to
420 -- be used for remote subprogram Def, return it in Id and
421 -- store it in a hash table for later retrieval by
422 -- Get_Subprogram_Id. Spn is the subprogram number.
424 function RCI_Package_Locator
425 (Loc : Source_Ptr;
426 Package_Spec : Node_Id) return Node_Id;
427 -- Instantiate the generic package RCI_Locator in order to locate the
428 -- RCI package whose spec is given as argument.
430 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
431 -- Surround a node N by a tag check, as in:
432 -- begin
433 -- <N>;
434 -- exception
435 -- when E : Ada.Tags.Tag_Error =>
436 -- Raise_Exception (Program_Error'Identity,
437 -- Exception_Message (E));
438 -- end;
440 function Input_With_Tag_Check
441 (Loc : Source_Ptr;
442 Var_Type : Entity_Id;
443 Stream : Node_Id) return Node_Id;
444 -- Return a function with the following form:
445 -- function R return Var_Type is
446 -- begin
447 -- return Var_Type'Input (S);
448 -- exception
449 -- when E : Ada.Tags.Tag_Error =>
450 -- Raise_Exception (Program_Error'Identity,
451 -- Exception_Message (E));
452 -- end R;
454 procedure Build_Actual_Object_Declaration
455 (Object : Entity_Id;
456 Etyp : Entity_Id;
457 Variable : Boolean;
458 Expr : Node_Id;
459 Decls : List_Id);
460 -- Build the declaration of an object with the given defining identifier,
461 -- initialized with Expr if provided, to serve as actual parameter in a
462 -- server stub. If Variable is true, the declared object will be a variable
463 -- (case of an out or in out formal), else it will be a constant. Object's
464 -- Ekind is set accordingly. The declaration, as well as any other
465 -- declarations it requires, are appended to Decls.
467 --------------------------------------------
468 -- Hooks for PCS-specific code generation --
469 --------------------------------------------
471 -- Part of the code generation circuitry for distribution needs to be
472 -- tailored for each implementation of the PCS. For each routine that
473 -- needs to be specialized, a Specific_<routine> wrapper is created,
474 -- which calls the corresponding <routine> in package
475 -- <pcs_implementation>_Support.
477 procedure Specific_Add_RACW_Features
478 (RACW_Type : Entity_Id;
479 Desig : Entity_Id;
480 Stub_Type : Entity_Id;
481 Stub_Type_Access : Entity_Id;
482 RPC_Receiver_Decl : Node_Id;
483 Body_Decls : List_Id);
484 -- Add declaration for TSSs for a given RACW type. The declarations are
485 -- added just after the declaration of the RACW type itself. If the RACW
486 -- appears in the main unit, Body_Decls is a list of declarations to which
487 -- the bodies are appended. Else Body_Decls is No_List.
488 -- PCS-specific ancillary subprogram for Add_RACW_Features.
490 procedure Specific_Add_RAST_Features
491 (Vis_Decl : Node_Id;
492 RAS_Type : Entity_Id);
493 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
494 -- subprogram for Add_RAST_Features.
496 -- An RPC_Target record is used during construction of calling stubs
497 -- to pass PCS-specific tree fragments corresponding to the information
498 -- necessary to locate the target of a remote subprogram call.
500 type RPC_Target (PCS_Kind : PCS_Names) is record
501 case PCS_Kind is
502 when Name_PolyORB_DSA =>
503 Object : Node_Id;
504 -- An expression whose value is a PolyORB reference to the target
505 -- object.
507 when others =>
508 Partition : Entity_Id;
509 -- A variable containing the Partition_ID of the target partition
511 RPC_Receiver : Node_Id;
512 -- An expression whose value is the address of the target RPC
513 -- receiver.
514 end case;
515 end record;
517 procedure Specific_Build_General_Calling_Stubs
518 (Decls : List_Id;
519 Statements : List_Id;
520 Target : RPC_Target;
521 Subprogram_Id : Node_Id;
522 Asynchronous : Node_Id := Empty;
523 Is_Known_Asynchronous : Boolean := False;
524 Is_Known_Non_Asynchronous : Boolean := False;
525 Is_Function : Boolean;
526 Spec : Node_Id;
527 Stub_Type : Entity_Id := Empty;
528 RACW_Type : Entity_Id := Empty;
529 Nod : Node_Id);
530 -- Build calling stubs for general purpose. The parameters are:
531 -- Decls : a place to put declarations
532 -- Statements : a place to put statements
533 -- Target : PCS-specific target information (see details
534 -- in RPC_Target declaration).
535 -- Subprogram_Id : a node containing the subprogram ID
536 -- Asynchronous : True if an APC must be made instead of an RPC.
537 -- The value needs not be supplied if one of the
538 -- Is_Known_... is True.
539 -- Is_Known_Async... : True if we know that this is asynchronous
540 -- Is_Known_Non_A... : True if we know that this is not asynchronous
541 -- Spec : a node with a Parameter_Specifications and
542 -- a Result_Definition if applicable
543 -- Stub_Type : in case of RACW stubs, parameters of type access
544 -- to Stub_Type will be marshalled using the
545 -- address of the object (the addr field) rather
546 -- than using the 'Write on the stub itself
547 -- Nod : used to provide sloc for generated code
549 function Specific_Build_Stub_Target
550 (Loc : Source_Ptr;
551 Decls : List_Id;
552 RCI_Locator : Entity_Id;
553 Controlling_Parameter : Entity_Id) return RPC_Target;
554 -- Build call target information nodes for use within calling stubs. In the
555 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
556 -- for an RACW, Controlling_Parameter is the entity for the controlling
557 -- formal parameter used to determine the location of the target of the
558 -- call. Decls provides a location where variable declarations can be
559 -- appended to construct the necessary values.
561 function Specific_RPC_Receiver_Decl
562 (RACW_Type : Entity_Id) return Node_Id;
563 -- Build the RPC receiver, for RACW, if applicable, else return Empty
565 procedure Specific_Build_RPC_Receiver_Body
566 (RPC_Receiver : Entity_Id;
567 Request : out Entity_Id;
568 Subp_Id : out Entity_Id;
569 Subp_Index : out Entity_Id;
570 Stmts : out List_Id;
571 Decl : out Node_Id);
572 -- Make a subprogram body for an RPC receiver, with the given
573 -- defining unit name. On return:
574 -- - Subp_Id is the subprogram identifier from the PCS.
575 -- - Subp_Index is the index in the list of subprograms
576 -- used for dispatching (a variable of type Subprogram_Id).
577 -- - Stmts is the place where the request dispatching
578 -- statements can occur,
579 -- - Decl is the subprogram body declaration.
581 function Specific_Build_Subprogram_Receiving_Stubs
582 (Vis_Decl : Node_Id;
583 Asynchronous : Boolean;
584 Dynamically_Asynchronous : Boolean := False;
585 Stub_Type : Entity_Id := Empty;
586 RACW_Type : Entity_Id := Empty;
587 Parent_Primitive : Entity_Id := Empty) return Node_Id;
588 -- Build the receiving stub for a given subprogram. The subprogram
589 -- declaration is also built by this procedure, and the value returned
590 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
591 -- found in the specification, then its address is read from the stream
592 -- instead of the object itself and converted into an access to
593 -- class-wide type before doing the real call using any of the RACW type
594 -- pointing on the designated type.
596 procedure Specific_Add_Obj_RPC_Receiver_Completion
597 (Loc : Source_Ptr;
598 Decls : List_Id;
599 RPC_Receiver : Entity_Id;
600 Stub_Elements : Stub_Structure);
601 -- Add the necessary code to Decls after the completion of generation
602 -- of the RACW RPC receiver described by Stub_Elements.
604 procedure Specific_Add_Receiving_Stubs_To_Declarations
605 (Pkg_Spec : Node_Id;
606 Decls : List_Id;
607 Stmts : List_Id);
608 -- Add receiving stubs to the declarative part of an RCI unit
610 --------------------
611 -- GARLIC_Support --
612 --------------------
614 package GARLIC_Support is
616 -- Support for generating DSA code that uses the GARLIC PCS
618 -- The subprograms below provide the GARLIC versions of the
619 -- corresponding Specific_<subprogram> routine declared above.
621 procedure Add_RACW_Features
622 (RACW_Type : Entity_Id;
623 Stub_Type : Entity_Id;
624 Stub_Type_Access : Entity_Id;
625 RPC_Receiver_Decl : Node_Id;
626 Body_Decls : List_Id);
628 procedure Add_RAST_Features
629 (Vis_Decl : Node_Id;
630 RAS_Type : Entity_Id);
632 procedure Build_General_Calling_Stubs
633 (Decls : List_Id;
634 Statements : List_Id;
635 Target_Partition : Entity_Id; -- From RPC_Target
636 Target_RPC_Receiver : Node_Id; -- From RPC_Target
637 Subprogram_Id : Node_Id;
638 Asynchronous : Node_Id := Empty;
639 Is_Known_Asynchronous : Boolean := False;
640 Is_Known_Non_Asynchronous : Boolean := False;
641 Is_Function : Boolean;
642 Spec : Node_Id;
643 Stub_Type : Entity_Id := Empty;
644 RACW_Type : Entity_Id := Empty;
645 Nod : Node_Id);
647 function Build_Stub_Target
648 (Loc : Source_Ptr;
649 Decls : List_Id;
650 RCI_Locator : Entity_Id;
651 Controlling_Parameter : Entity_Id) return RPC_Target;
653 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id;
655 function Build_Subprogram_Receiving_Stubs
656 (Vis_Decl : Node_Id;
657 Asynchronous : Boolean;
658 Dynamically_Asynchronous : Boolean := False;
659 Stub_Type : Entity_Id := Empty;
660 RACW_Type : Entity_Id := Empty;
661 Parent_Primitive : Entity_Id := Empty) return Node_Id;
663 procedure Add_Obj_RPC_Receiver_Completion
664 (Loc : Source_Ptr;
665 Decls : List_Id;
666 RPC_Receiver : Entity_Id;
667 Stub_Elements : Stub_Structure);
669 procedure Add_Receiving_Stubs_To_Declarations
670 (Pkg_Spec : Node_Id;
671 Decls : List_Id;
672 Stmts : List_Id);
674 procedure Build_RPC_Receiver_Body
675 (RPC_Receiver : Entity_Id;
676 Request : out Entity_Id;
677 Subp_Id : out Entity_Id;
678 Subp_Index : out Entity_Id;
679 Stmts : out List_Id;
680 Decl : out Node_Id);
682 end GARLIC_Support;
684 ---------------------
685 -- PolyORB_Support --
686 ---------------------
688 package PolyORB_Support is
690 -- Support for generating DSA code that uses the PolyORB PCS
692 -- The subprograms below provide the PolyORB versions of the
693 -- corresponding Specific_<subprogram> routine declared above.
695 procedure Add_RACW_Features
696 (RACW_Type : Entity_Id;
697 Desig : Entity_Id;
698 Stub_Type : Entity_Id;
699 Stub_Type_Access : Entity_Id;
700 RPC_Receiver_Decl : Node_Id;
701 Body_Decls : List_Id);
703 procedure Add_RAST_Features
704 (Vis_Decl : Node_Id;
705 RAS_Type : Entity_Id);
707 procedure Build_General_Calling_Stubs
708 (Decls : List_Id;
709 Statements : List_Id;
710 Target_Object : Node_Id; -- From RPC_Target
711 Subprogram_Id : Node_Id;
712 Asynchronous : Node_Id := Empty;
713 Is_Known_Asynchronous : Boolean := False;
714 Is_Known_Non_Asynchronous : Boolean := False;
715 Is_Function : Boolean;
716 Spec : Node_Id;
717 Stub_Type : Entity_Id := Empty;
718 RACW_Type : Entity_Id := Empty;
719 Nod : Node_Id);
721 function Build_Stub_Target
722 (Loc : Source_Ptr;
723 Decls : List_Id;
724 RCI_Locator : Entity_Id;
725 Controlling_Parameter : Entity_Id) return RPC_Target;
727 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id;
729 function Build_Subprogram_Receiving_Stubs
730 (Vis_Decl : Node_Id;
731 Asynchronous : Boolean;
732 Dynamically_Asynchronous : Boolean := False;
733 Stub_Type : Entity_Id := Empty;
734 RACW_Type : Entity_Id := Empty;
735 Parent_Primitive : Entity_Id := Empty) return Node_Id;
737 procedure Add_Obj_RPC_Receiver_Completion
738 (Loc : Source_Ptr;
739 Decls : List_Id;
740 RPC_Receiver : Entity_Id;
741 Stub_Elements : Stub_Structure);
743 procedure Add_Receiving_Stubs_To_Declarations
744 (Pkg_Spec : Node_Id;
745 Decls : List_Id;
746 Stmts : List_Id);
748 procedure Build_RPC_Receiver_Body
749 (RPC_Receiver : Entity_Id;
750 Request : out Entity_Id;
751 Subp_Id : out Entity_Id;
752 Subp_Index : out Entity_Id;
753 Stmts : out List_Id;
754 Decl : out Node_Id);
756 procedure Reserve_NamingContext_Methods;
757 -- Mark the method names for interface NamingContext as already used in
758 -- the overload table, so no clashes occur with user code (with the
759 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
760 -- their methods to be accessed as objects, for the implementation of
761 -- remote access-to-subprogram types).
763 -------------
764 -- Helpers --
765 -------------
767 package Helpers is
769 -- Routines to build distribution helper subprograms for user-defined
770 -- types. For implementation of the Distributed systems annex (DSA)
771 -- over the PolyORB generic middleware components, it is necessary to
772 -- generate several supporting subprograms for each application data
773 -- type used in inter-partition communication. These subprograms are:
775 -- A Typecode function returning a high-level description of the
776 -- type's structure;
778 -- Two conversion functions allowing conversion of values of the
779 -- type from and to the generic data containers used by PolyORB.
780 -- These generic containers are called 'Any' type values after the
781 -- CORBA terminology, and hence the conversion subprograms are
782 -- named To_Any and From_Any.
784 function Build_From_Any_Call
785 (Typ : Entity_Id;
786 N : Node_Id;
787 Decls : List_Id) return Node_Id;
788 -- Build call to From_Any attribute function of type Typ with
789 -- expression N as actual parameter. Decls is the declarations list
790 -- for an appropriate enclosing scope of the point where the call
791 -- will be inserted; if the From_Any attribute for Typ needs to be
792 -- generated at this point, its declaration is appended to Decls.
794 procedure Build_From_Any_Function
795 (Loc : Source_Ptr;
796 Typ : Entity_Id;
797 Decl : out Node_Id;
798 Fnam : out Entity_Id);
799 -- Build From_Any attribute function for Typ. Loc is the reference
800 -- location for generated nodes, Typ is the type for which the
801 -- conversion function is generated. On return, Decl and Fnam contain
802 -- the declaration and entity for the newly-created function.
804 function Build_To_Any_Call
805 (Loc : Source_Ptr;
806 N : Node_Id;
807 Decls : List_Id) return Node_Id;
808 -- Build call to To_Any attribute function with expression as actual
809 -- parameter. Loc is the reference location ofr generated nodes,
810 -- Decls is the declarations list for an appropriate enclosing scope
811 -- of the point where the call will be inserted; if the To_Any
812 -- attribute for the type of N needs to be generated at this point,
813 -- its declaration is appended to Decls.
815 procedure Build_To_Any_Function
816 (Loc : Source_Ptr;
817 Typ : Entity_Id;
818 Decl : out Node_Id;
819 Fnam : out Entity_Id);
820 -- Build To_Any attribute function for Typ. Loc is the reference
821 -- location for generated nodes, Typ is the type for which the
822 -- conversion function is generated. On return, Decl and Fnam contain
823 -- the declaration and entity for the newly-created function.
825 function Build_TypeCode_Call
826 (Loc : Source_Ptr;
827 Typ : Entity_Id;
828 Decls : List_Id) return Node_Id;
829 -- Build call to TypeCode attribute function for Typ. Decls is the
830 -- declarations list for an appropriate enclosing scope of the point
831 -- where the call will be inserted; if the To_Any attribute for Typ
832 -- needs to be generated at this point, its declaration is appended
833 -- to Decls.
835 procedure Build_TypeCode_Function
836 (Loc : Source_Ptr;
837 Typ : Entity_Id;
838 Decl : out Node_Id;
839 Fnam : out Entity_Id);
840 -- Build TypeCode attribute function for Typ. Loc is the reference
841 -- location for generated nodes, Typ is the type for which the
842 -- typecode function is generated. On return, Decl and Fnam contain
843 -- the declaration and entity for the newly-created function.
845 procedure Build_Name_And_Repository_Id
846 (E : Entity_Id;
847 Name_Str : out String_Id;
848 Repo_Id_Str : out String_Id);
849 -- In the PolyORB distribution model, each distributed object type
850 -- and each distributed operation has a globally unique identifier,
851 -- its Repository Id. This subprogram builds and returns two strings
852 -- for entity E (a distributed object type or operation): one
853 -- containing the name of E, the second containing its repository id.
855 procedure Assign_Opaque_From_Any
856 (Loc : Source_Ptr;
857 Stms : List_Id;
858 Typ : Entity_Id;
859 N : Node_Id;
860 Target : Entity_Id);
861 -- For a Target object of type Typ, which has opaque representation
862 -- as a sequence of octets determined by stream attributes (which
863 -- includes all limited types), append code to Stmts performing the
864 -- equivalent of:
865 -- Target := Typ'From_Any (N)
867 -- or, if Target is Empty:
868 -- return Typ'From_Any (N)
870 end Helpers;
872 end PolyORB_Support;
874 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
876 function Build_From_Any_Call
877 (Typ : Entity_Id;
878 N : Node_Id;
879 Decls : List_Id) return Node_Id
880 renames PolyORB_Support.Helpers.Build_From_Any_Call;
882 function Build_To_Any_Call
883 (Loc : Source_Ptr;
884 N : Node_Id;
885 Decls : List_Id) return Node_Id
886 renames PolyORB_Support.Helpers.Build_To_Any_Call;
888 function Build_TypeCode_Call
889 (Loc : Source_Ptr;
890 Typ : Entity_Id;
891 Decls : List_Id) return Node_Id
892 renames PolyORB_Support.Helpers.Build_TypeCode_Call;
894 ------------------------------------
895 -- Local variables and structures --
896 ------------------------------------
898 RCI_Cache : Node_Id;
899 -- Needs comments ???
901 Output_From_Constrained : constant array (Boolean) of Name_Id :=
902 (False => Name_Output,
903 True => Name_Write);
904 -- The attribute to choose depending on the fact that the parameter
905 -- is constrained or not. There is no such thing as Input_From_Constrained
906 -- since this require separate mechanisms ('Input is a function while
907 -- 'Read is a procedure).
909 generic
910 with procedure Process_Subprogram_Declaration (Decl : Node_Id);
911 -- Generate calling or receiving stub for this subprogram declaration
913 procedure Build_Package_Stubs (Pkg_Spec : Node_Id);
914 -- Recursively visit the given RCI Package_Specification, calling
915 -- Process_Subprogram_Declaration for each remote subprogram.
917 -------------------------
918 -- Build_Package_Stubs --
919 -------------------------
921 procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is
922 Decls : constant List_Id := Visible_Declarations (Pkg_Spec);
923 Decl : Node_Id;
925 procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id);
926 -- Recurse for the given nested package declaration
928 -----------------------
929 -- Visit_Nested_Spec --
930 -----------------------
932 procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is
933 Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl);
934 begin
935 Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec));
936 Build_Package_Stubs (Nested_Pkg_Spec);
937 Pop_Scope;
938 end Visit_Nested_Pkg;
940 -- Start of processing for Build_Package_Stubs
942 begin
943 Decl := First (Decls);
944 while Present (Decl) loop
945 case Nkind (Decl) is
946 when N_Subprogram_Declaration =>
948 -- Note: we test Comes_From_Source on Spec, not Decl, because
949 -- in the case of a subprogram instance, only the specification
950 -- (not the declaration) is marked as coming from source.
952 if Comes_From_Source (Specification (Decl)) then
953 Process_Subprogram_Declaration (Decl);
954 end if;
956 when N_Package_Declaration =>
958 -- Case of a nested package or package instantiation coming
959 -- from source. Note that the anonymous wrapper package for
960 -- subprogram instances is not flagged Is_Generic_Instance at
961 -- this point, so there is a distinct circuit to handle them
962 -- (see case N_Subprogram_Instantiation below).
964 declare
965 Pkg_Ent : constant Entity_Id :=
966 Defining_Unit_Name (Specification (Decl));
967 begin
968 if Comes_From_Source (Decl)
969 or else
970 (Is_Generic_Instance (Pkg_Ent)
971 and then Comes_From_Source
972 (Get_Package_Instantiation_Node (Pkg_Ent)))
973 then
974 Visit_Nested_Pkg (Decl);
975 end if;
976 end;
978 when N_Subprogram_Instantiation =>
980 -- The subprogram declaration for an instance of a generic
981 -- subprogram is wrapped in a package that does not come from
982 -- source, so we need to explicitly traverse it here.
984 if Comes_From_Source (Decl) then
985 Visit_Nested_Pkg (Instance_Spec (Decl));
986 end if;
988 when others =>
989 null;
990 end case;
991 Next (Decl);
992 end loop;
993 end Build_Package_Stubs;
995 ---------------------------------------
996 -- Add_Calling_Stubs_To_Declarations --
997 ---------------------------------------
999 procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is
1000 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
1002 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
1003 -- Subprogram id 0 is reserved for calls received from
1004 -- remote access-to-subprogram dereferences.
1006 RCI_Instantiation : Node_Id;
1008 procedure Visit_Subprogram (Decl : Node_Id);
1009 -- Generate calling stub for one remote subprogram
1011 ----------------------
1012 -- Visit_Subprogram --
1013 ----------------------
1015 procedure Visit_Subprogram (Decl : Node_Id) is
1016 Loc : constant Source_Ptr := Sloc (Decl);
1017 Spec : constant Node_Id := Specification (Decl);
1018 Subp_Stubs : Node_Id;
1020 Subp_Str : String_Id;
1021 pragma Warnings (Off, Subp_Str);
1023 begin
1024 -- Disable expansion of stubs if serious errors have been diagnosed,
1025 -- because otherwise some illegal remote subprogram declarations
1026 -- could cause cascaded errors in stubs.
1028 if Serious_Errors_Detected /= 0 then
1029 return;
1030 end if;
1032 Assign_Subprogram_Identifier
1033 (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str);
1035 Subp_Stubs :=
1036 Build_Subprogram_Calling_Stubs
1037 (Vis_Decl => Decl,
1038 Subp_Id =>
1039 Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)),
1040 Asynchronous =>
1041 Nkind (Spec) = N_Procedure_Specification
1042 and then Is_Asynchronous (Defining_Unit_Name (Spec)));
1044 Append_To (List_Containing (Decl), Subp_Stubs);
1045 Analyze (Subp_Stubs);
1047 Current_Subprogram_Number := Current_Subprogram_Number + 1;
1048 end Visit_Subprogram;
1050 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
1052 -- Start of processing for Add_Calling_Stubs_To_Declarations
1054 begin
1055 Push_Scope (Scope_Of_Spec (Pkg_Spec));
1057 -- The first thing added is an instantiation of the generic package
1058 -- System.Partition_Interface.RCI_Locator with the name of this remote
1059 -- package. This will act as an interface with the name server to
1060 -- determine the Partition_ID and the RPC_Receiver for the receiver
1061 -- of this package.
1063 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
1064 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
1066 Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation);
1067 Analyze (RCI_Instantiation);
1069 -- For each subprogram declaration visible in the spec, we do build a
1070 -- body. We also increment a counter to assign a different Subprogram_Id
1071 -- to each subprogram. The receiving stubs processing uses the same
1072 -- mechanism and will thus assign the same Id and do the correct
1073 -- dispatching.
1075 Overload_Counter_Table.Reset;
1076 PolyORB_Support.Reserve_NamingContext_Methods;
1078 Visit_Spec (Pkg_Spec);
1080 Pop_Scope;
1081 end Add_Calling_Stubs_To_Declarations;
1083 -----------------------------
1084 -- Add_Parameter_To_NVList --
1085 -----------------------------
1087 function Add_Parameter_To_NVList
1088 (Loc : Source_Ptr;
1089 NVList : Entity_Id;
1090 Parameter : Entity_Id;
1091 Constrained : Boolean;
1092 RACW_Ctrl : Boolean := False;
1093 Any : Entity_Id) return Node_Id
1095 Parameter_Name_String : String_Id;
1096 Parameter_Mode : Node_Id;
1098 function Parameter_Passing_Mode
1099 (Loc : Source_Ptr;
1100 Parameter : Entity_Id;
1101 Constrained : Boolean) return Node_Id;
1102 -- Return an expression that denotes the parameter passing mode to be
1103 -- used for Parameter in distribution stubs, where Constrained is
1104 -- Parameter's constrained status.
1106 ----------------------------
1107 -- Parameter_Passing_Mode --
1108 ----------------------------
1110 function Parameter_Passing_Mode
1111 (Loc : Source_Ptr;
1112 Parameter : Entity_Id;
1113 Constrained : Boolean) return Node_Id
1115 Lib_RE : RE_Id;
1117 begin
1118 if Out_Present (Parameter) then
1119 if In_Present (Parameter)
1120 or else not Constrained
1121 then
1122 -- Unconstrained formals must be translated
1123 -- to 'in' or 'inout', not 'out', because
1124 -- they need to be constrained by the actual.
1126 Lib_RE := RE_Mode_Inout;
1127 else
1128 Lib_RE := RE_Mode_Out;
1129 end if;
1131 else
1132 Lib_RE := RE_Mode_In;
1133 end if;
1135 return New_Occurrence_Of (RTE (Lib_RE), Loc);
1136 end Parameter_Passing_Mode;
1138 -- Start of processing for Add_Parameter_To_NVList
1140 begin
1141 if Nkind (Parameter) = N_Defining_Identifier then
1142 Get_Name_String (Chars (Parameter));
1143 else
1144 Get_Name_String (Chars (Defining_Identifier (Parameter)));
1145 end if;
1147 Parameter_Name_String := String_From_Name_Buffer;
1149 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1151 -- When the parameter passed to Add_Parameter_To_NVList is an
1152 -- Extra_Constrained parameter, Parameter is an N_Defining_
1153 -- Identifier, instead of a complete N_Parameter_Specification.
1154 -- Thus, we explicitly set 'in' mode in this case.
1156 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1158 else
1159 Parameter_Mode :=
1160 Parameter_Passing_Mode (Loc, Parameter, Constrained);
1161 end if;
1163 return
1164 Make_Procedure_Call_Statement (Loc,
1165 Name =>
1166 New_Occurrence_Of
1167 (RTE (RE_NVList_Add_Item), Loc),
1168 Parameter_Associations => New_List (
1169 New_Occurrence_Of (NVList, Loc),
1170 Make_Function_Call (Loc,
1171 Name =>
1172 New_Occurrence_Of
1173 (RTE (RE_To_PolyORB_String), Loc),
1174 Parameter_Associations => New_List (
1175 Make_String_Literal (Loc,
1176 Strval => Parameter_Name_String))),
1177 New_Occurrence_Of (Any, Loc),
1178 Parameter_Mode));
1179 end Add_Parameter_To_NVList;
1181 --------------------------------
1182 -- Add_RACW_Asynchronous_Flag --
1183 --------------------------------
1185 procedure Add_RACW_Asynchronous_Flag
1186 (Declarations : List_Id;
1187 RACW_Type : Entity_Id)
1189 Loc : constant Source_Ptr := Sloc (RACW_Type);
1191 Asynchronous_Flag : constant Entity_Id :=
1192 Make_Defining_Identifier (Loc,
1193 New_External_Name (Chars (RACW_Type), 'A'));
1195 begin
1196 -- Declare the asynchronous flag. This flag will be changed to True
1197 -- whenever it is known that the RACW type is asynchronous.
1199 Append_To (Declarations,
1200 Make_Object_Declaration (Loc,
1201 Defining_Identifier => Asynchronous_Flag,
1202 Constant_Present => True,
1203 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1204 Expression => New_Occurrence_Of (Standard_False, Loc)));
1206 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1207 end Add_RACW_Asynchronous_Flag;
1209 -----------------------
1210 -- Add_RACW_Features --
1211 -----------------------
1213 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1214 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1215 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1217 Pkg_Spec : Node_Id;
1218 Decls : List_Id;
1219 Body_Decls : List_Id;
1221 Stub_Type : Entity_Id;
1222 Stub_Type_Access : Entity_Id;
1223 RPC_Receiver_Decl : Node_Id;
1225 Existing : Boolean;
1226 -- True when appropriate stubs have already been generated (this is the
1227 -- case when another RACW with the same designated type has already been
1228 -- encountered), in which case we reuse the previous stubs rather than
1229 -- generating new ones.
1231 begin
1232 if not Expander_Active then
1233 return;
1234 end if;
1236 -- Mark the current package declaration as containing an RACW, so that
1237 -- the bodies for the calling stubs and the RACW stream subprograms
1238 -- are attached to the tree when the corresponding body is encountered.
1240 Set_Has_RACW (Current_Scope);
1242 -- Look for place to declare the RACW stub type and RACW operations
1244 Pkg_Spec := Empty;
1246 if Same_Scope then
1248 -- Case of declaring the RACW in the same package as its designated
1249 -- type: we know that the designated type is a private type, so we
1250 -- use the private declarations list.
1252 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1254 if Present (Private_Declarations (Pkg_Spec)) then
1255 Decls := Private_Declarations (Pkg_Spec);
1256 else
1257 Decls := Visible_Declarations (Pkg_Spec);
1258 end if;
1260 else
1261 -- Case of declaring the RACW in another package than its designated
1262 -- type: use the private declarations list if present; otherwise
1263 -- use the visible declarations.
1265 Decls := List_Containing (Declaration_Node (RACW_Type));
1267 end if;
1269 -- If we were unable to find the declarations, that means that the
1270 -- completion of the type was missing. We can safely return and let the
1271 -- error be caught by the semantic analysis.
1273 if No (Decls) then
1274 return;
1275 end if;
1277 Add_Stub_Type
1278 (Designated_Type => Desig,
1279 RACW_Type => RACW_Type,
1280 Decls => Decls,
1281 Stub_Type => Stub_Type,
1282 Stub_Type_Access => Stub_Type_Access,
1283 RPC_Receiver_Decl => RPC_Receiver_Decl,
1284 Body_Decls => Body_Decls,
1285 Existing => Existing);
1287 -- If this RACW is not in the main unit, do not generate primitive or
1288 -- TSS bodies.
1290 if not Entity_Is_In_Main_Unit (RACW_Type) then
1291 Body_Decls := No_List;
1292 end if;
1294 Add_RACW_Asynchronous_Flag
1295 (Declarations => Decls,
1296 RACW_Type => RACW_Type);
1298 Specific_Add_RACW_Features
1299 (RACW_Type => RACW_Type,
1300 Desig => Desig,
1301 Stub_Type => Stub_Type,
1302 Stub_Type_Access => Stub_Type_Access,
1303 RPC_Receiver_Decl => RPC_Receiver_Decl,
1304 Body_Decls => Body_Decls);
1306 -- If we already have stubs for this designated type, nothing to do
1308 if Existing then
1309 return;
1310 end if;
1312 if Is_Frozen (Desig) then
1313 Validate_RACW_Primitives (RACW_Type);
1314 Add_RACW_Primitive_Declarations_And_Bodies
1315 (Designated_Type => Desig,
1316 Insertion_Node => RPC_Receiver_Decl,
1317 Body_Decls => Body_Decls);
1319 else
1320 -- Validate_RACW_Primitives requires the list of all primitives of
1321 -- the designated type, so defer processing until Desig is frozen.
1322 -- See Exp_Ch3.Freeze_Type.
1324 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1325 end if;
1326 end Add_RACW_Features;
1328 ------------------------------------------------
1329 -- Add_RACW_Primitive_Declarations_And_Bodies --
1330 ------------------------------------------------
1332 procedure Add_RACW_Primitive_Declarations_And_Bodies
1333 (Designated_Type : Entity_Id;
1334 Insertion_Node : Node_Id;
1335 Body_Decls : List_Id)
1337 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1338 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1339 -- the declarations are recognized as belonging to the current package.
1341 Stub_Elements : constant Stub_Structure :=
1342 Stubs_Table.Get (Designated_Type);
1344 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1346 Is_RAS : constant Boolean :=
1347 not Comes_From_Source (Stub_Elements.RACW_Type);
1348 -- Case of the RACW generated to implement a remote access-to-
1349 -- subprogram type.
1351 Build_Bodies : constant Boolean :=
1352 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1353 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1354 -- only when the main unit is the unit that contains the stub type.
1356 Current_Insertion_Node : Node_Id := Insertion_Node;
1358 RPC_Receiver : Entity_Id;
1359 RPC_Receiver_Statements : List_Id;
1360 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1361 RPC_Receiver_Elsif_Parts : List_Id;
1362 RPC_Receiver_Request : Entity_Id;
1363 RPC_Receiver_Subp_Id : Entity_Id;
1364 RPC_Receiver_Subp_Index : Entity_Id;
1366 Subp_Str : String_Id;
1368 Current_Primitive_Elmt : Elmt_Id;
1369 Current_Primitive : Entity_Id;
1370 Current_Primitive_Body : Node_Id;
1371 Current_Primitive_Spec : Node_Id;
1372 Current_Primitive_Decl : Node_Id;
1373 Current_Primitive_Number : Int := 0;
1374 Current_Primitive_Alias : Node_Id;
1375 Current_Receiver : Entity_Id;
1376 Current_Receiver_Body : Node_Id;
1377 RPC_Receiver_Decl : Node_Id;
1378 Possibly_Asynchronous : Boolean;
1380 begin
1381 if not Expander_Active then
1382 return;
1383 end if;
1385 if not Is_RAS then
1386 RPC_Receiver := Make_Temporary (Loc, 'P');
1388 Specific_Build_RPC_Receiver_Body
1389 (RPC_Receiver => RPC_Receiver,
1390 Request => RPC_Receiver_Request,
1391 Subp_Id => RPC_Receiver_Subp_Id,
1392 Subp_Index => RPC_Receiver_Subp_Index,
1393 Stmts => RPC_Receiver_Statements,
1394 Decl => RPC_Receiver_Decl);
1396 if Get_PCS_Name = Name_PolyORB_DSA then
1398 -- For the case of PolyORB, we need to map a textual operation
1399 -- name into a primitive index. Currently we do so using a simple
1400 -- sequence of string comparisons.
1402 RPC_Receiver_Elsif_Parts := New_List;
1403 end if;
1404 end if;
1406 -- Build callers, receivers for every primitive operations and a RPC
1407 -- receiver for this type. Note that we use Direct_Primitive_Operations,
1408 -- not Primitive_Operations, because we really want just the primitives
1409 -- of the tagged type itself, and in the case of a tagged synchronized
1410 -- type we do not want to get the primitives of the corresponding
1411 -- record type).
1413 if Present (Direct_Primitive_Operations (Designated_Type)) then
1414 Overload_Counter_Table.Reset;
1416 Current_Primitive_Elmt :=
1417 First_Elmt (Direct_Primitive_Operations (Designated_Type));
1418 while Current_Primitive_Elmt /= No_Elmt loop
1419 Current_Primitive := Node (Current_Primitive_Elmt);
1421 -- Copy the primitive of all the parents, except predefined ones
1422 -- that are not remotely dispatching. Also omit hidden primitives
1423 -- (occurs in the case of primitives of interface progenitors
1424 -- other than immediate ancestors of the Designated_Type).
1426 if Chars (Current_Primitive) /= Name_uSize
1427 and then Chars (Current_Primitive) /= Name_uAlignment
1428 and then not
1429 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1430 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1431 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1432 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1433 Is_TSS (Current_Primitive, TSS_Stream_Write)
1434 or else
1435 Is_Predefined_Interface_Primitive (Current_Primitive))
1436 and then not Is_Hidden (Current_Primitive)
1437 then
1438 -- The first thing to do is build an up-to-date copy of the
1439 -- spec with all the formals referencing Controlling_Type
1440 -- transformed into formals referencing Stub_Type. Since this
1441 -- primitive may have been inherited, go back the alias chain
1442 -- until the real primitive has been found.
1444 Current_Primitive_Alias := Ultimate_Alias (Current_Primitive);
1446 -- Copy the spec from the original declaration for the purpose
1447 -- of declaring an overriding subprogram: we need to replace
1448 -- the type of each controlling formal with Stub_Type. The
1449 -- primitive may have been declared for Controlling_Type or
1450 -- inherited from some ancestor type for which we do not have
1451 -- an easily determined Entity_Id. We have no systematic way
1452 -- of knowing which type to substitute Stub_Type for. Instead,
1453 -- Copy_Specification relies on the flag Is_Controlling_Formal
1454 -- to determine which formals to change.
1456 Current_Primitive_Spec :=
1457 Copy_Specification (Loc,
1458 Spec => Parent (Current_Primitive_Alias),
1459 Ctrl_Type => Stub_Elements.Stub_Type);
1461 Current_Primitive_Decl :=
1462 Make_Subprogram_Declaration (Loc,
1463 Specification => Current_Primitive_Spec);
1465 Insert_After_And_Analyze (Current_Insertion_Node,
1466 Current_Primitive_Decl);
1467 Current_Insertion_Node := Current_Primitive_Decl;
1469 Possibly_Asynchronous :=
1470 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1471 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1473 Assign_Subprogram_Identifier (
1474 Defining_Unit_Name (Current_Primitive_Spec),
1475 Current_Primitive_Number,
1476 Subp_Str);
1478 if Build_Bodies then
1479 Current_Primitive_Body :=
1480 Build_Subprogram_Calling_Stubs
1481 (Vis_Decl => Current_Primitive_Decl,
1482 Subp_Id =>
1483 Build_Subprogram_Id (Loc,
1484 Defining_Unit_Name (Current_Primitive_Spec)),
1485 Asynchronous => Possibly_Asynchronous,
1486 Dynamically_Asynchronous => Possibly_Asynchronous,
1487 Stub_Type => Stub_Elements.Stub_Type,
1488 RACW_Type => Stub_Elements.RACW_Type);
1489 Append_To (Body_Decls, Current_Primitive_Body);
1491 -- Analyzing the body here would cause the Stub type to
1492 -- be frozen, thus preventing subsequent primitive
1493 -- declarations. For this reason, it will be analyzed
1494 -- later in the regular flow (and in the context of the
1495 -- appropriate unit body, see Append_RACW_Bodies).
1497 end if;
1499 -- Build the receiver stubs
1501 if Build_Bodies and then not Is_RAS then
1502 Current_Receiver_Body :=
1503 Specific_Build_Subprogram_Receiving_Stubs
1504 (Vis_Decl => Current_Primitive_Decl,
1505 Asynchronous => Possibly_Asynchronous,
1506 Dynamically_Asynchronous => Possibly_Asynchronous,
1507 Stub_Type => Stub_Elements.Stub_Type,
1508 RACW_Type => Stub_Elements.RACW_Type,
1509 Parent_Primitive => Current_Primitive);
1511 Current_Receiver :=
1512 Defining_Unit_Name (Specification (Current_Receiver_Body));
1514 Append_To (Body_Decls, Current_Receiver_Body);
1516 -- Add a case alternative to the receiver
1518 if Get_PCS_Name = Name_PolyORB_DSA then
1519 Append_To (RPC_Receiver_Elsif_Parts,
1520 Make_Elsif_Part (Loc,
1521 Condition =>
1522 Make_Function_Call (Loc,
1523 Name =>
1524 New_Occurrence_Of (
1525 RTE (RE_Caseless_String_Eq), Loc),
1526 Parameter_Associations => New_List (
1527 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1528 Make_String_Literal (Loc, Subp_Str))),
1530 Then_Statements => New_List (
1531 Make_Assignment_Statement (Loc,
1532 Name => New_Occurrence_Of (
1533 RPC_Receiver_Subp_Index, Loc),
1534 Expression =>
1535 Make_Integer_Literal (Loc,
1536 Intval => Current_Primitive_Number)))));
1537 end if;
1539 Append_To (RPC_Receiver_Case_Alternatives,
1540 Make_Case_Statement_Alternative (Loc,
1541 Discrete_Choices => New_List (
1542 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1544 Statements => New_List (
1545 Make_Procedure_Call_Statement (Loc,
1546 Name =>
1547 New_Occurrence_Of (Current_Receiver, Loc),
1548 Parameter_Associations => New_List (
1549 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1550 end if;
1552 -- Increment the index of current primitive
1554 Current_Primitive_Number := Current_Primitive_Number + 1;
1555 end if;
1557 Next_Elmt (Current_Primitive_Elmt);
1558 end loop;
1559 end if;
1561 -- Build the case statement and the heart of the subprogram
1563 if Build_Bodies and then not Is_RAS then
1564 if Get_PCS_Name = Name_PolyORB_DSA
1565 and then Present (First (RPC_Receiver_Elsif_Parts))
1566 then
1567 Append_To (RPC_Receiver_Statements,
1568 Make_Implicit_If_Statement (Designated_Type,
1569 Condition => New_Occurrence_Of (Standard_False, Loc),
1570 Then_Statements => New_List,
1571 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1572 end if;
1574 Append_To (RPC_Receiver_Case_Alternatives,
1575 Make_Case_Statement_Alternative (Loc,
1576 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1577 Statements => New_List (Make_Null_Statement (Loc))));
1579 Append_To (RPC_Receiver_Statements,
1580 Make_Case_Statement (Loc,
1581 Expression =>
1582 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1583 Alternatives => RPC_Receiver_Case_Alternatives));
1585 Append_To (Body_Decls, RPC_Receiver_Decl);
1586 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1587 Body_Decls, RPC_Receiver, Stub_Elements);
1589 -- Do not analyze RPC receiver body at this stage since it references
1590 -- subprograms that have not been analyzed yet. It will be analyzed in
1591 -- the regular flow (see Append_RACW_Bodies).
1593 end if;
1594 end Add_RACW_Primitive_Declarations_And_Bodies;
1596 -----------------------------
1597 -- Add_RAS_Dereference_TSS --
1598 -----------------------------
1600 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1601 Loc : constant Source_Ptr := Sloc (N);
1603 Type_Def : constant Node_Id := Type_Definition (N);
1604 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1605 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1606 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1608 RACW_Primitive_Name : Node_Id;
1610 Proc : constant Entity_Id :=
1611 Make_Defining_Identifier (Loc,
1612 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1614 Proc_Spec : Node_Id;
1615 Param_Specs : List_Id;
1616 Param_Assoc : constant List_Id := New_List;
1617 Stmts : constant List_Id := New_List;
1619 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P');
1621 Is_Function : constant Boolean :=
1622 Nkind (Type_Def) = N_Access_Function_Definition;
1624 Is_Degenerate : Boolean;
1625 -- Set to True if the subprogram_specification for this RAS has an
1626 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1628 Spec : constant Node_Id := Type_Def;
1630 Current_Parameter : Node_Id;
1632 -- Start of processing for Add_RAS_Dereference_TSS
1634 begin
1635 -- The Dereference TSS for a remote access-to-subprogram type has the
1636 -- form:
1638 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1639 -- [return <>]
1641 -- This is called whenever a value of a RAS type is dereferenced
1643 -- First construct a list of parameter specifications:
1645 -- The first formal is the RAS values
1647 Param_Specs := New_List (
1648 Make_Parameter_Specification (Loc,
1649 Defining_Identifier => RAS_Parameter,
1650 In_Present => True,
1651 Parameter_Type =>
1652 New_Occurrence_Of (Fat_Type, Loc)));
1654 -- The following formals are copied from the type declaration
1656 Is_Degenerate := False;
1657 Current_Parameter := First (Parameter_Specifications (Type_Def));
1658 Parameters : while Present (Current_Parameter) loop
1659 if Nkind (Parameter_Type (Current_Parameter)) =
1660 N_Access_Definition
1661 then
1662 Is_Degenerate := True;
1663 end if;
1665 Append_To (Param_Specs,
1666 Make_Parameter_Specification (Loc,
1667 Defining_Identifier =>
1668 Make_Defining_Identifier (Loc,
1669 Chars => Chars (Defining_Identifier (Current_Parameter))),
1670 In_Present => In_Present (Current_Parameter),
1671 Out_Present => Out_Present (Current_Parameter),
1672 Parameter_Type =>
1673 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1674 Expression =>
1675 New_Copy_Tree (Expression (Current_Parameter))));
1677 Append_To (Param_Assoc,
1678 Make_Identifier (Loc,
1679 Chars => Chars (Defining_Identifier (Current_Parameter))));
1681 Next (Current_Parameter);
1682 end loop Parameters;
1684 if Is_Degenerate then
1685 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1687 -- Generate a dummy body. This code will never actually be executed,
1688 -- because null is the only legal value for a degenerate RAS type.
1689 -- For legality's sake (in order to avoid generating a function that
1690 -- does not contain a return statement), we include a dummy recursive
1691 -- call on the TSS itself.
1693 Append_To (Stmts,
1694 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1695 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1697 else
1698 -- For a normal RAS type, we cast the RAS formal to the corresponding
1699 -- tagged type, and perform a dispatching call to its Call primitive
1700 -- operation.
1702 Prepend_To (Param_Assoc,
1703 Unchecked_Convert_To (RACW_Type,
1704 New_Occurrence_Of (RAS_Parameter, Loc)));
1706 RACW_Primitive_Name :=
1707 Make_Selected_Component (Loc,
1708 Prefix => Scope (RACW_Type),
1709 Selector_Name => Name_uCall);
1710 end if;
1712 if Is_Function then
1713 Append_To (Stmts,
1714 Make_Simple_Return_Statement (Loc,
1715 Expression =>
1716 Make_Function_Call (Loc,
1717 Name => RACW_Primitive_Name,
1718 Parameter_Associations => Param_Assoc)));
1720 else
1721 Append_To (Stmts,
1722 Make_Procedure_Call_Statement (Loc,
1723 Name => RACW_Primitive_Name,
1724 Parameter_Associations => Param_Assoc));
1725 end if;
1727 -- Build the complete subprogram
1729 if Is_Function then
1730 Proc_Spec :=
1731 Make_Function_Specification (Loc,
1732 Defining_Unit_Name => Proc,
1733 Parameter_Specifications => Param_Specs,
1734 Result_Definition =>
1735 New_Occurrence_Of (
1736 Entity (Result_Definition (Spec)), Loc));
1738 Set_Ekind (Proc, E_Function);
1739 Set_Etype (Proc,
1740 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1742 else
1743 Proc_Spec :=
1744 Make_Procedure_Specification (Loc,
1745 Defining_Unit_Name => Proc,
1746 Parameter_Specifications => Param_Specs);
1748 Set_Ekind (Proc, E_Procedure);
1749 Set_Etype (Proc, Standard_Void_Type);
1750 end if;
1752 Discard_Node (
1753 Make_Subprogram_Body (Loc,
1754 Specification => Proc_Spec,
1755 Declarations => New_List,
1756 Handled_Statement_Sequence =>
1757 Make_Handled_Sequence_Of_Statements (Loc,
1758 Statements => Stmts)));
1760 Set_TSS (Fat_Type, Proc);
1761 end Add_RAS_Dereference_TSS;
1763 -------------------------------
1764 -- Add_RAS_Proxy_And_Analyze --
1765 -------------------------------
1767 procedure Add_RAS_Proxy_And_Analyze
1768 (Decls : List_Id;
1769 Vis_Decl : Node_Id;
1770 All_Calls_Remote_E : Entity_Id;
1771 Proxy_Object_Addr : out Entity_Id)
1773 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1775 Subp_Name : constant Entity_Id :=
1776 Defining_Unit_Name (Specification (Vis_Decl));
1778 Pkg_Name : constant Entity_Id :=
1779 Make_Defining_Identifier (Loc,
1780 Chars => New_External_Name (Chars (Subp_Name), 'P', -1));
1782 Proxy_Type : constant Entity_Id :=
1783 Make_Defining_Identifier (Loc,
1784 Chars =>
1785 New_External_Name
1786 (Related_Id => Chars (Subp_Name),
1787 Suffix => 'P'));
1789 Proxy_Type_Full_View : constant Entity_Id :=
1790 Make_Defining_Identifier (Loc,
1791 Chars (Proxy_Type));
1793 Subp_Decl_Spec : constant Node_Id :=
1794 Build_RAS_Primitive_Specification
1795 (Subp_Spec => Specification (Vis_Decl),
1796 Remote_Object_Type => Proxy_Type);
1798 Subp_Body_Spec : constant Node_Id :=
1799 Build_RAS_Primitive_Specification
1800 (Subp_Spec => Specification (Vis_Decl),
1801 Remote_Object_Type => Proxy_Type);
1803 Vis_Decls : constant List_Id := New_List;
1804 Pvt_Decls : constant List_Id := New_List;
1805 Actuals : constant List_Id := New_List;
1806 Formal : Node_Id;
1807 Perform_Call : Node_Id;
1809 begin
1810 -- type subpP is tagged limited private;
1812 Append_To (Vis_Decls,
1813 Make_Private_Type_Declaration (Loc,
1814 Defining_Identifier => Proxy_Type,
1815 Tagged_Present => True,
1816 Limited_Present => True));
1818 -- [subprogram] Call
1819 -- (Self : access subpP;
1820 -- ...other-formals...)
1821 -- [return T];
1823 Append_To (Vis_Decls,
1824 Make_Subprogram_Declaration (Loc,
1825 Specification => Subp_Decl_Spec));
1827 -- A : constant System.Address;
1829 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1831 Append_To (Vis_Decls,
1832 Make_Object_Declaration (Loc,
1833 Defining_Identifier => Proxy_Object_Addr,
1834 Constant_Present => True,
1835 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)));
1837 -- private
1839 -- type subpP is tagged limited record
1840 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1841 -- ...
1842 -- end record;
1844 Append_To (Pvt_Decls,
1845 Make_Full_Type_Declaration (Loc,
1846 Defining_Identifier => Proxy_Type_Full_View,
1847 Type_Definition =>
1848 Build_Remote_Subprogram_Proxy_Type (Loc,
1849 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1851 -- Trick semantic analysis into swapping the public and full view when
1852 -- freezing the public view.
1854 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1856 -- procedure Call
1857 -- (Self : access O;
1858 -- ...other-formals...) is
1859 -- begin
1860 -- P (...other-formals...);
1861 -- end Call;
1863 -- function Call
1864 -- (Self : access O;
1865 -- ...other-formals...)
1866 -- return T is
1867 -- begin
1868 -- return F (...other-formals...);
1869 -- end Call;
1871 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1872 Perform_Call :=
1873 Make_Procedure_Call_Statement (Loc,
1874 Name => New_Occurrence_Of (Subp_Name, Loc),
1875 Parameter_Associations => Actuals);
1876 else
1877 Perform_Call :=
1878 Make_Simple_Return_Statement (Loc,
1879 Expression =>
1880 Make_Function_Call (Loc,
1881 Name => New_Occurrence_Of (Subp_Name, Loc),
1882 Parameter_Associations => Actuals));
1883 end if;
1885 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1886 pragma Assert (Present (Formal));
1887 loop
1888 Next (Formal);
1889 exit when No (Formal);
1890 Append_To (Actuals,
1891 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1892 end loop;
1894 -- O : aliased subpP;
1896 Append_To (Pvt_Decls,
1897 Make_Object_Declaration (Loc,
1898 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
1899 Aliased_Present => True,
1900 Object_Definition => New_Occurrence_Of (Proxy_Type, Loc)));
1902 -- A : constant System.Address := O'Address;
1904 Append_To (Pvt_Decls,
1905 Make_Object_Declaration (Loc,
1906 Defining_Identifier =>
1907 Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)),
1908 Constant_Present => True,
1909 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc),
1910 Expression =>
1911 Make_Attribute_Reference (Loc,
1912 Prefix => New_Occurrence_Of (
1913 Defining_Identifier (Last (Pvt_Decls)), Loc),
1914 Attribute_Name => Name_Address)));
1916 Append_To (Decls,
1917 Make_Package_Declaration (Loc,
1918 Specification => Make_Package_Specification (Loc,
1919 Defining_Unit_Name => Pkg_Name,
1920 Visible_Declarations => Vis_Decls,
1921 Private_Declarations => Pvt_Decls,
1922 End_Label => Empty)));
1923 Analyze (Last (Decls));
1925 Append_To (Decls,
1926 Make_Package_Body (Loc,
1927 Defining_Unit_Name =>
1928 Make_Defining_Identifier (Loc, Chars (Pkg_Name)),
1929 Declarations => New_List (
1930 Make_Subprogram_Body (Loc,
1931 Specification => Subp_Body_Spec,
1932 Declarations => New_List,
1933 Handled_Statement_Sequence =>
1934 Make_Handled_Sequence_Of_Statements (Loc,
1935 Statements => New_List (Perform_Call))))));
1936 Analyze (Last (Decls));
1937 end Add_RAS_Proxy_And_Analyze;
1939 -----------------------
1940 -- Add_RAST_Features --
1941 -----------------------
1943 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1944 RAS_Type : constant Entity_Id :=
1945 Equivalent_Type (Defining_Identifier (Vis_Decl));
1946 begin
1947 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1948 Add_RAS_Dereference_TSS (Vis_Decl);
1949 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1950 end Add_RAST_Features;
1952 -------------------
1953 -- Add_Stub_Type --
1954 -------------------
1956 procedure Add_Stub_Type
1957 (Designated_Type : Entity_Id;
1958 RACW_Type : Entity_Id;
1959 Decls : List_Id;
1960 Stub_Type : out Entity_Id;
1961 Stub_Type_Access : out Entity_Id;
1962 RPC_Receiver_Decl : out Node_Id;
1963 Body_Decls : out List_Id;
1964 Existing : out Boolean)
1966 Loc : constant Source_Ptr := Sloc (RACW_Type);
1968 Stub_Elements : constant Stub_Structure :=
1969 Stubs_Table.Get (Designated_Type);
1970 Stub_Type_Decl : Node_Id;
1971 Stub_Type_Access_Decl : Node_Id;
1973 begin
1974 if Stub_Elements /= Empty_Stub_Structure then
1975 Stub_Type := Stub_Elements.Stub_Type;
1976 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1977 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1978 Body_Decls := Stub_Elements.Body_Decls;
1979 Existing := True;
1980 return;
1981 end if;
1983 Existing := False;
1984 Stub_Type := Make_Temporary (Loc, 'S');
1985 Set_Ekind (Stub_Type, E_Record_Type);
1986 Set_Is_RACW_Stub_Type (Stub_Type);
1987 Stub_Type_Access :=
1988 Make_Defining_Identifier (Loc,
1989 Chars => New_External_Name
1990 (Related_Id => Chars (Stub_Type), Suffix => 'A'));
1992 RPC_Receiver_Decl := Specific_RPC_Receiver_Decl (RACW_Type);
1994 -- Create new stub type, copying components from generic RACW_Stub_Type
1996 Stub_Type_Decl :=
1997 Make_Full_Type_Declaration (Loc,
1998 Defining_Identifier => Stub_Type,
1999 Type_Definition =>
2000 Make_Record_Definition (Loc,
2001 Tagged_Present => True,
2002 Limited_Present => True,
2003 Component_List =>
2004 Make_Component_List (Loc,
2005 Component_Items =>
2006 Copy_Component_List (RTE (RE_RACW_Stub_Type), Loc))));
2008 -- Does the stub type need to explicitly implement interfaces from the
2009 -- designated type???
2011 -- In particular are there issues in the case where the designated type
2012 -- is a synchronized interface???
2014 Stub_Type_Access_Decl :=
2015 Make_Full_Type_Declaration (Loc,
2016 Defining_Identifier => Stub_Type_Access,
2017 Type_Definition =>
2018 Make_Access_To_Object_Definition (Loc,
2019 All_Present => True,
2020 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
2022 Append_To (Decls, Stub_Type_Decl);
2023 Analyze (Last (Decls));
2024 Append_To (Decls, Stub_Type_Access_Decl);
2025 Analyze (Last (Decls));
2027 -- We can't directly derive the stub type from the designated type,
2028 -- because we don't want any components or discriminants from the real
2029 -- type, so instead we manually fake a derivation to get an appropriate
2030 -- dispatch table.
2032 Derive_Subprograms (Parent_Type => Designated_Type,
2033 Derived_Type => Stub_Type);
2035 if Present (RPC_Receiver_Decl) then
2036 Append_To (Decls, RPC_Receiver_Decl);
2038 else
2039 -- Kludge, requires comment???
2041 RPC_Receiver_Decl := Last (Decls);
2042 end if;
2044 Body_Decls := New_List;
2046 Stubs_Table.Set (Designated_Type,
2047 (Stub_Type => Stub_Type,
2048 Stub_Type_Access => Stub_Type_Access,
2049 RPC_Receiver_Decl => RPC_Receiver_Decl,
2050 Body_Decls => Body_Decls,
2051 RACW_Type => RACW_Type));
2052 end Add_Stub_Type;
2054 ------------------------
2055 -- Append_RACW_Bodies --
2056 ------------------------
2058 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
2059 E : Entity_Id;
2061 begin
2062 E := First_Entity (Spec_Id);
2063 while Present (E) loop
2064 if Is_Remote_Access_To_Class_Wide_Type (E) then
2065 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
2066 end if;
2068 Next_Entity (E);
2069 end loop;
2070 end Append_RACW_Bodies;
2072 ----------------------------------
2073 -- Assign_Subprogram_Identifier --
2074 ----------------------------------
2076 procedure Assign_Subprogram_Identifier
2077 (Def : Entity_Id;
2078 Spn : Int;
2079 Id : out String_Id)
2081 N : constant Name_Id := Chars (Def);
2083 Overload_Order : constant Int := Overload_Counter_Table.Get (N) + 1;
2085 begin
2086 Overload_Counter_Table.Set (N, Overload_Order);
2088 Get_Name_String (N);
2090 -- Homonym handling: as in Exp_Dbug, but much simpler, because the only
2091 -- entities for which we have to generate names here need only to be
2092 -- disambiguated within their own scope.
2094 if Overload_Order > 1 then
2095 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
2096 Name_Len := Name_Len + 2;
2097 Add_Nat_To_Name_Buffer (Overload_Order);
2098 end if;
2100 Id := String_From_Name_Buffer;
2101 Subprogram_Identifier_Table.Set
2102 (Def,
2103 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
2104 end Assign_Subprogram_Identifier;
2106 -------------------------------------
2107 -- Build_Actual_Object_Declaration --
2108 -------------------------------------
2110 procedure Build_Actual_Object_Declaration
2111 (Object : Entity_Id;
2112 Etyp : Entity_Id;
2113 Variable : Boolean;
2114 Expr : Node_Id;
2115 Decls : List_Id)
2117 Loc : constant Source_Ptr := Sloc (Object);
2119 begin
2120 -- Declare a temporary object for the actual, possibly initialized with
2121 -- a 'Input/From_Any call.
2123 -- Complication arises in the case of limited types, for which such a
2124 -- declaration is illegal in Ada 95. In that case, we first generate a
2125 -- renaming declaration of the 'Input call, and then if needed we
2126 -- generate an overlaid non-constant view.
2128 if Ada_Version <= Ada_95
2129 and then Is_Limited_Type (Etyp)
2130 and then Present (Expr)
2131 then
2133 -- Object : Etyp renames <func-call>
2135 Append_To (Decls,
2136 Make_Object_Renaming_Declaration (Loc,
2137 Defining_Identifier => Object,
2138 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
2139 Name => Expr));
2141 if Variable then
2143 -- The name defined by the renaming declaration denotes a
2144 -- constant view; create a non-constant object at the same address
2145 -- to be used as the actual.
2147 declare
2148 Constant_Object : constant Entity_Id :=
2149 Make_Temporary (Loc, 'P');
2151 begin
2152 Set_Defining_Identifier
2153 (Last (Decls), Constant_Object);
2155 -- We have an unconstrained Etyp: build the actual constrained
2156 -- subtype for the value we just read from the stream.
2158 -- subtype S is <actual subtype of Constant_Object>;
2160 Append_To (Decls,
2161 Build_Actual_Subtype (Etyp,
2162 New_Occurrence_Of (Constant_Object, Loc)));
2164 -- Object : S;
2166 Append_To (Decls,
2167 Make_Object_Declaration (Loc,
2168 Defining_Identifier => Object,
2169 Object_Definition =>
2170 New_Occurrence_Of
2171 (Defining_Identifier (Last (Decls)), Loc)));
2172 Set_Ekind (Object, E_Variable);
2174 -- Suppress default initialization:
2175 -- pragma Import (Ada, Object);
2177 Append_To (Decls,
2178 Make_Pragma (Loc,
2179 Chars => Name_Import,
2180 Pragma_Argument_Associations => New_List (
2181 Make_Pragma_Argument_Association (Loc,
2182 Chars => Name_Convention,
2183 Expression => Make_Identifier (Loc, Name_Ada)),
2184 Make_Pragma_Argument_Association (Loc,
2185 Chars => Name_Entity,
2186 Expression => New_Occurrence_Of (Object, Loc)))));
2188 -- for Object'Address use Constant_Object'Address;
2190 Append_To (Decls,
2191 Make_Attribute_Definition_Clause (Loc,
2192 Name => New_Occurrence_Of (Object, Loc),
2193 Chars => Name_Address,
2194 Expression =>
2195 Make_Attribute_Reference (Loc,
2196 Prefix => New_Occurrence_Of (Constant_Object, Loc),
2197 Attribute_Name => Name_Address)));
2198 end;
2199 end if;
2201 else
2202 -- General case of a regular object declaration. Object is flagged
2203 -- constant unless it has mode out or in out, to allow the backend
2204 -- to optimize where possible.
2206 -- Object : [constant] Etyp [:= <expr>];
2208 Append_To (Decls,
2209 Make_Object_Declaration (Loc,
2210 Defining_Identifier => Object,
2211 Constant_Present => Present (Expr) and then not Variable,
2212 Object_Definition => New_Occurrence_Of (Etyp, Loc),
2213 Expression => Expr));
2215 if Constant_Present (Last (Decls)) then
2216 Set_Ekind (Object, E_Constant);
2217 else
2218 Set_Ekind (Object, E_Variable);
2219 end if;
2220 end if;
2221 end Build_Actual_Object_Declaration;
2223 ------------------------------
2224 -- Build_Get_Unique_RP_Call --
2225 ------------------------------
2227 function Build_Get_Unique_RP_Call
2228 (Loc : Source_Ptr;
2229 Pointer : Entity_Id;
2230 Stub_Type : Entity_Id) return List_Id
2232 begin
2233 return New_List (
2234 Make_Procedure_Call_Statement (Loc,
2235 Name =>
2236 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2237 Parameter_Associations => New_List (
2238 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2239 New_Occurrence_Of (Pointer, Loc)))),
2241 Make_Assignment_Statement (Loc,
2242 Name =>
2243 Make_Selected_Component (Loc,
2244 Prefix => New_Occurrence_Of (Pointer, Loc),
2245 Selector_Name =>
2246 New_Occurrence_Of (First_Tag_Component
2247 (Designated_Type (Etype (Pointer))), Loc)),
2248 Expression =>
2249 Make_Attribute_Reference (Loc,
2250 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2251 Attribute_Name => Name_Tag)));
2253 -- Note: The assignment to Pointer._Tag is safe here because
2254 -- we carefully ensured that Stub_Type has exactly the same layout
2255 -- as System.Partition_Interface.RACW_Stub_Type.
2257 end Build_Get_Unique_RP_Call;
2259 -----------------------------------
2260 -- Build_Ordered_Parameters_List --
2261 -----------------------------------
2263 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2264 Constrained_List : List_Id;
2265 Unconstrained_List : List_Id;
2266 Current_Parameter : Node_Id;
2267 Ptyp : Node_Id;
2269 First_Parameter : Node_Id;
2270 For_RAS : Boolean := False;
2272 begin
2273 if No (Parameter_Specifications (Spec)) then
2274 return New_List;
2275 end if;
2277 Constrained_List := New_List;
2278 Unconstrained_List := New_List;
2279 First_Parameter := First (Parameter_Specifications (Spec));
2281 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2282 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2283 then
2284 For_RAS := True;
2285 end if;
2287 -- Loop through the parameters and add them to the right list. Note that
2288 -- we treat a parameter of a null-excluding access type as unconstrained
2289 -- because we can't declare an object of such a type with default
2290 -- initialization.
2292 Current_Parameter := First_Parameter;
2293 while Present (Current_Parameter) loop
2294 Ptyp := Parameter_Type (Current_Parameter);
2296 if (Nkind (Ptyp) = N_Access_Definition
2297 or else not Transmit_As_Unconstrained (Etype (Ptyp)))
2298 and then not (For_RAS and then Current_Parameter = First_Parameter)
2299 then
2300 Append_To (Constrained_List, New_Copy (Current_Parameter));
2301 else
2302 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2303 end if;
2305 Next (Current_Parameter);
2306 end loop;
2308 -- Unconstrained parameters are returned first
2310 Append_List_To (Unconstrained_List, Constrained_List);
2312 return Unconstrained_List;
2313 end Build_Ordered_Parameters_List;
2315 ----------------------------------
2316 -- Build_Passive_Partition_Stub --
2317 ----------------------------------
2319 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2320 Pkg_Spec : Node_Id;
2321 Pkg_Ent : Entity_Id;
2322 L : List_Id;
2323 Reg : Node_Id;
2324 Loc : constant Source_Ptr := Sloc (U);
2326 begin
2327 -- Verify that the implementation supports distribution, by accessing
2328 -- a type defined in the proper version of system.rpc
2330 declare
2331 Dist_OK : Entity_Id;
2332 pragma Warnings (Off, Dist_OK);
2333 begin
2334 Dist_OK := RTE (RE_Params_Stream_Type);
2335 end;
2337 -- Use body if present, spec otherwise
2339 if Nkind (U) = N_Package_Declaration then
2340 Pkg_Spec := Specification (U);
2341 L := Visible_Declarations (Pkg_Spec);
2342 else
2343 Pkg_Spec := Parent (Corresponding_Spec (U));
2344 L := Declarations (U);
2345 end if;
2346 Pkg_Ent := Defining_Entity (Pkg_Spec);
2348 Reg :=
2349 Make_Procedure_Call_Statement (Loc,
2350 Name =>
2351 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2352 Parameter_Associations => New_List (
2353 Make_String_Literal (Loc,
2354 Fully_Qualified_Name_String (Pkg_Ent, Append_NUL => False)),
2355 Make_Attribute_Reference (Loc,
2356 Prefix => New_Occurrence_Of (Pkg_Ent, Loc),
2357 Attribute_Name => Name_Version)));
2358 Append_To (L, Reg);
2359 Analyze (Reg);
2360 end Build_Passive_Partition_Stub;
2362 --------------------------------------
2363 -- Build_RPC_Receiver_Specification --
2364 --------------------------------------
2366 function Build_RPC_Receiver_Specification
2367 (RPC_Receiver : Entity_Id;
2368 Request_Parameter : Entity_Id) return Node_Id
2370 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2371 begin
2372 return
2373 Make_Procedure_Specification (Loc,
2374 Defining_Unit_Name => RPC_Receiver,
2375 Parameter_Specifications => New_List (
2376 Make_Parameter_Specification (Loc,
2377 Defining_Identifier => Request_Parameter,
2378 Parameter_Type =>
2379 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2380 end Build_RPC_Receiver_Specification;
2382 ----------------------------------------
2383 -- Build_Remote_Subprogram_Proxy_Type --
2384 ----------------------------------------
2386 function Build_Remote_Subprogram_Proxy_Type
2387 (Loc : Source_Ptr;
2388 ACR_Expression : Node_Id) return Node_Id
2390 begin
2391 return
2392 Make_Record_Definition (Loc,
2393 Tagged_Present => True,
2394 Limited_Present => True,
2395 Component_List =>
2396 Make_Component_List (Loc,
2397 Component_Items => New_List (
2398 Make_Component_Declaration (Loc,
2399 Defining_Identifier =>
2400 Make_Defining_Identifier (Loc,
2401 Name_All_Calls_Remote),
2402 Component_Definition =>
2403 Make_Component_Definition (Loc,
2404 Subtype_Indication =>
2405 New_Occurrence_Of (Standard_Boolean, Loc)),
2406 Expression =>
2407 ACR_Expression),
2409 Make_Component_Declaration (Loc,
2410 Defining_Identifier =>
2411 Make_Defining_Identifier (Loc,
2412 Name_Receiver),
2413 Component_Definition =>
2414 Make_Component_Definition (Loc,
2415 Subtype_Indication =>
2416 New_Occurrence_Of (RTE (RE_Address), Loc)),
2417 Expression =>
2418 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2420 Make_Component_Declaration (Loc,
2421 Defining_Identifier =>
2422 Make_Defining_Identifier (Loc,
2423 Name_Subp_Id),
2424 Component_Definition =>
2425 Make_Component_Definition (Loc,
2426 Subtype_Indication =>
2427 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2428 end Build_Remote_Subprogram_Proxy_Type;
2430 --------------------
2431 -- Build_Stub_Tag --
2432 --------------------
2434 function Build_Stub_Tag
2435 (Loc : Source_Ptr;
2436 RACW_Type : Entity_Id) return Node_Id
2438 Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type);
2439 begin
2440 return
2441 Make_Attribute_Reference (Loc,
2442 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2443 Attribute_Name => Name_Tag);
2444 end Build_Stub_Tag;
2446 ------------------------------------
2447 -- Build_Subprogram_Calling_Stubs --
2448 ------------------------------------
2450 function Build_Subprogram_Calling_Stubs
2451 (Vis_Decl : Node_Id;
2452 Subp_Id : Node_Id;
2453 Asynchronous : Boolean;
2454 Dynamically_Asynchronous : Boolean := False;
2455 Stub_Type : Entity_Id := Empty;
2456 RACW_Type : Entity_Id := Empty;
2457 Locator : Entity_Id := Empty;
2458 New_Name : Name_Id := No_Name) return Node_Id
2460 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2462 Decls : constant List_Id := New_List;
2463 Statements : constant List_Id := New_List;
2465 Subp_Spec : Node_Id;
2466 -- The specification of the body
2468 Controlling_Parameter : Entity_Id := Empty;
2470 Asynchronous_Expr : Node_Id := Empty;
2472 RCI_Locator : Entity_Id;
2474 Spec_To_Use : Node_Id;
2476 procedure Insert_Partition_Check (Parameter : Node_Id);
2477 -- Check that the parameter has been elaborated on the same partition
2478 -- than the controlling parameter (E.4(19)).
2480 ----------------------------
2481 -- Insert_Partition_Check --
2482 ----------------------------
2484 procedure Insert_Partition_Check (Parameter : Node_Id) is
2485 Parameter_Entity : constant Entity_Id :=
2486 Defining_Identifier (Parameter);
2487 begin
2488 -- The expression that will be built is of the form:
2490 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2491 -- raise Constraint_Error;
2492 -- end if;
2494 -- We do not check that Parameter is in Stub_Type since such a check
2495 -- has been inserted at the point of call already (a tag check since
2496 -- we have multiple controlling operands).
2498 Append_To (Decls,
2499 Make_Raise_Constraint_Error (Loc,
2500 Condition =>
2501 Make_Op_Not (Loc,
2502 Right_Opnd =>
2503 Make_Function_Call (Loc,
2504 Name =>
2505 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2506 Parameter_Associations =>
2507 New_List (
2508 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2509 New_Occurrence_Of (Parameter_Entity, Loc)),
2510 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2511 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2512 Reason => CE_Partition_Check_Failed));
2513 end Insert_Partition_Check;
2515 -- Start of processing for Build_Subprogram_Calling_Stubs
2517 begin
2518 Subp_Spec :=
2519 Copy_Specification (Loc,
2520 Spec => Specification (Vis_Decl),
2521 New_Name => New_Name);
2523 if Locator = Empty then
2524 RCI_Locator := RCI_Cache;
2525 Spec_To_Use := Specification (Vis_Decl);
2526 else
2527 RCI_Locator := Locator;
2528 Spec_To_Use := Subp_Spec;
2529 end if;
2531 -- Find a controlling argument if we have a stub type. Also check
2532 -- if this subprogram can be made asynchronous.
2534 if Present (Stub_Type)
2535 and then Present (Parameter_Specifications (Spec_To_Use))
2536 then
2537 declare
2538 Current_Parameter : Node_Id :=
2539 First (Parameter_Specifications
2540 (Spec_To_Use));
2541 begin
2542 while Present (Current_Parameter) loop
2544 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2545 then
2546 if Controlling_Parameter = Empty then
2547 Controlling_Parameter :=
2548 Defining_Identifier (Current_Parameter);
2549 else
2550 Insert_Partition_Check (Current_Parameter);
2551 end if;
2552 end if;
2554 Next (Current_Parameter);
2555 end loop;
2556 end;
2557 end if;
2559 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2561 if Dynamically_Asynchronous then
2562 Asynchronous_Expr := Make_Selected_Component (Loc,
2563 Prefix => Controlling_Parameter,
2564 Selector_Name => Name_Asynchronous);
2565 end if;
2567 Specific_Build_General_Calling_Stubs
2568 (Decls => Decls,
2569 Statements => Statements,
2570 Target => Specific_Build_Stub_Target (Loc,
2571 Decls, RCI_Locator, Controlling_Parameter),
2572 Subprogram_Id => Subp_Id,
2573 Asynchronous => Asynchronous_Expr,
2574 Is_Known_Asynchronous => Asynchronous
2575 and then not Dynamically_Asynchronous,
2576 Is_Known_Non_Asynchronous
2577 => not Asynchronous
2578 and then not Dynamically_Asynchronous,
2579 Is_Function => Nkind (Spec_To_Use) =
2580 N_Function_Specification,
2581 Spec => Spec_To_Use,
2582 Stub_Type => Stub_Type,
2583 RACW_Type => RACW_Type,
2584 Nod => Vis_Decl);
2586 RCI_Calling_Stubs_Table.Set
2587 (Defining_Unit_Name (Specification (Vis_Decl)),
2588 Defining_Unit_Name (Spec_To_Use));
2590 return
2591 Make_Subprogram_Body (Loc,
2592 Specification => Subp_Spec,
2593 Declarations => Decls,
2594 Handled_Statement_Sequence =>
2595 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2596 end Build_Subprogram_Calling_Stubs;
2598 -------------------------
2599 -- Build_Subprogram_Id --
2600 -------------------------
2602 function Build_Subprogram_Id
2603 (Loc : Source_Ptr;
2604 E : Entity_Id) return Node_Id
2606 begin
2607 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2608 declare
2609 Current_Declaration : Node_Id;
2610 Current_Subp : Entity_Id;
2611 Current_Subp_Str : String_Id;
2612 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2614 pragma Warnings (Off, Current_Subp_Str);
2616 begin
2617 -- Build_Subprogram_Id is called outside of the context of
2618 -- generating calling or receiving stubs. Hence we are processing
2619 -- an 'Access attribute_reference for an RCI subprogram, for the
2620 -- purpose of obtaining a RAS value.
2622 pragma Assert
2623 (Is_Remote_Call_Interface (Scope (E))
2624 and then
2625 (Nkind (Parent (E)) = N_Procedure_Specification
2626 or else
2627 Nkind (Parent (E)) = N_Function_Specification));
2629 Current_Declaration :=
2630 First (Visible_Declarations
2631 (Package_Specification_Of_Scope (Scope (E))));
2632 while Present (Current_Declaration) loop
2633 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2634 and then Comes_From_Source (Current_Declaration)
2635 then
2636 Current_Subp := Defining_Unit_Name (Specification (
2637 Current_Declaration));
2639 Assign_Subprogram_Identifier
2640 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2642 Current_Subp_Number := Current_Subp_Number + 1;
2643 end if;
2645 Next (Current_Declaration);
2646 end loop;
2647 end;
2648 end if;
2650 case Get_PCS_Name is
2651 when Name_PolyORB_DSA =>
2652 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2653 when others =>
2654 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2655 end case;
2656 end Build_Subprogram_Id;
2658 ------------------------
2659 -- Copy_Specification --
2660 ------------------------
2662 function Copy_Specification
2663 (Loc : Source_Ptr;
2664 Spec : Node_Id;
2665 Ctrl_Type : Entity_Id := Empty;
2666 New_Name : Name_Id := No_Name) return Node_Id
2668 Parameters : List_Id := No_List;
2670 Current_Parameter : Node_Id;
2671 Current_Identifier : Entity_Id;
2672 Current_Type : Node_Id;
2674 Name_For_New_Spec : Name_Id;
2676 New_Identifier : Entity_Id;
2678 -- Comments needed in body below ???
2680 begin
2681 if New_Name = No_Name then
2682 pragma Assert (Nkind (Spec) = N_Function_Specification
2683 or else Nkind (Spec) = N_Procedure_Specification);
2685 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2686 else
2687 Name_For_New_Spec := New_Name;
2688 end if;
2690 if Present (Parameter_Specifications (Spec)) then
2691 Parameters := New_List;
2692 Current_Parameter := First (Parameter_Specifications (Spec));
2693 while Present (Current_Parameter) loop
2694 Current_Identifier := Defining_Identifier (Current_Parameter);
2695 Current_Type := Parameter_Type (Current_Parameter);
2697 if Nkind (Current_Type) = N_Access_Definition then
2698 if Present (Ctrl_Type) then
2699 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2700 Current_Type :=
2701 Make_Access_Definition (Loc,
2702 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2703 Null_Exclusion_Present =>
2704 Null_Exclusion_Present (Current_Type));
2706 else
2707 Current_Type :=
2708 Make_Access_Definition (Loc,
2709 Subtype_Mark =>
2710 New_Copy_Tree (Subtype_Mark (Current_Type)),
2711 Null_Exclusion_Present =>
2712 Null_Exclusion_Present (Current_Type));
2713 end if;
2715 else
2716 if Present (Ctrl_Type)
2717 and then Is_Controlling_Formal (Current_Identifier)
2718 then
2719 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2720 else
2721 Current_Type := New_Copy_Tree (Current_Type);
2722 end if;
2723 end if;
2725 New_Identifier := Make_Defining_Identifier (Loc,
2726 Chars (Current_Identifier));
2728 Append_To (Parameters,
2729 Make_Parameter_Specification (Loc,
2730 Defining_Identifier => New_Identifier,
2731 Parameter_Type => Current_Type,
2732 In_Present => In_Present (Current_Parameter),
2733 Out_Present => Out_Present (Current_Parameter),
2734 Expression =>
2735 New_Copy_Tree (Expression (Current_Parameter))));
2737 -- For a regular formal parameter (that needs to be marshalled
2738 -- in the context of remote calls), set the Etype now, because
2739 -- marshalling processing might need it.
2741 if Is_Entity_Name (Current_Type) then
2742 Set_Etype (New_Identifier, Entity (Current_Type));
2744 -- Current_Type is an access definition, special processing
2745 -- (not requiring etype) will occur for marshalling.
2747 else
2748 null;
2749 end if;
2751 Next (Current_Parameter);
2752 end loop;
2753 end if;
2755 case Nkind (Spec) is
2757 when N_Function_Specification | N_Access_Function_Definition =>
2758 return
2759 Make_Function_Specification (Loc,
2760 Defining_Unit_Name =>
2761 Make_Defining_Identifier (Loc,
2762 Chars => Name_For_New_Spec),
2763 Parameter_Specifications => Parameters,
2764 Result_Definition =>
2765 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2767 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2768 return
2769 Make_Procedure_Specification (Loc,
2770 Defining_Unit_Name =>
2771 Make_Defining_Identifier (Loc,
2772 Chars => Name_For_New_Spec),
2773 Parameter_Specifications => Parameters);
2775 when others =>
2776 raise Program_Error;
2777 end case;
2778 end Copy_Specification;
2780 -----------------------------
2781 -- Corresponding_Stub_Type --
2782 -----------------------------
2784 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2785 Desig : constant Entity_Id :=
2786 Etype (Designated_Type (RACW_Type));
2787 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2788 begin
2789 return Stub_Elements.Stub_Type;
2790 end Corresponding_Stub_Type;
2792 ---------------------------
2793 -- Could_Be_Asynchronous --
2794 ---------------------------
2796 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2797 Current_Parameter : Node_Id;
2799 begin
2800 if Present (Parameter_Specifications (Spec)) then
2801 Current_Parameter := First (Parameter_Specifications (Spec));
2802 while Present (Current_Parameter) loop
2803 if Out_Present (Current_Parameter) then
2804 return False;
2805 end if;
2807 Next (Current_Parameter);
2808 end loop;
2809 end if;
2811 return True;
2812 end Could_Be_Asynchronous;
2814 ---------------------------
2815 -- Declare_Create_NVList --
2816 ---------------------------
2818 procedure Declare_Create_NVList
2819 (Loc : Source_Ptr;
2820 NVList : Entity_Id;
2821 Decls : List_Id;
2822 Stmts : List_Id)
2824 begin
2825 Append_To (Decls,
2826 Make_Object_Declaration (Loc,
2827 Defining_Identifier => NVList,
2828 Aliased_Present => False,
2829 Object_Definition =>
2830 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2832 Append_To (Stmts,
2833 Make_Procedure_Call_Statement (Loc,
2834 Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2835 Parameter_Associations => New_List (
2836 New_Occurrence_Of (NVList, Loc))));
2837 end Declare_Create_NVList;
2839 ---------------------------------------------
2840 -- Expand_All_Calls_Remote_Subprogram_Call --
2841 ---------------------------------------------
2843 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2844 Loc : constant Source_Ptr := Sloc (N);
2845 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2846 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2847 RCI_Locator_Decl : Node_Id;
2848 RCI_Locator : Entity_Id;
2849 Calling_Stubs : Node_Id;
2850 E_Calling_Stubs : Entity_Id;
2852 begin
2853 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2855 if E_Calling_Stubs = Empty then
2856 RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
2858 -- The RCI_Locator package and calling stub are is inserted at the
2859 -- top level in the current unit, and must appear in the proper scope
2860 -- so that it is not prematurely removed by the GCC back end.
2862 declare
2863 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2864 begin
2865 if Ekind (Scop) = E_Package_Body then
2866 Push_Scope (Spec_Entity (Scop));
2867 elsif Ekind (Scop) = E_Subprogram_Body then
2868 Push_Scope
2869 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2870 else
2871 Push_Scope (Scop);
2872 end if;
2873 end;
2875 if RCI_Locator = Empty then
2876 RCI_Locator_Decl :=
2877 RCI_Package_Locator
2878 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
2879 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
2880 Analyze (RCI_Locator_Decl);
2881 RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
2883 else
2884 RCI_Locator_Decl := Parent (RCI_Locator);
2885 end if;
2887 Calling_Stubs := Build_Subprogram_Calling_Stubs
2888 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2889 Subp_Id =>
2890 Build_Subprogram_Id (Loc, Called_Subprogram),
2891 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2892 and then
2893 Is_Asynchronous (Called_Subprogram),
2894 Locator => RCI_Locator,
2895 New_Name => New_Internal_Name ('S'));
2896 Insert_After (RCI_Locator_Decl, Calling_Stubs);
2897 Analyze (Calling_Stubs);
2898 Pop_Scope;
2900 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2901 end if;
2903 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2904 end Expand_All_Calls_Remote_Subprogram_Call;
2906 ---------------------------------
2907 -- Expand_Calling_Stubs_Bodies --
2908 ---------------------------------
2910 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2911 Spec : constant Node_Id := Specification (Unit_Node);
2912 begin
2913 Add_Calling_Stubs_To_Declarations (Spec);
2914 end Expand_Calling_Stubs_Bodies;
2916 -----------------------------------
2917 -- Expand_Receiving_Stubs_Bodies --
2918 -----------------------------------
2920 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2921 Spec : Node_Id;
2922 Decls : List_Id;
2923 Stubs_Decls : List_Id;
2924 Stubs_Stmts : List_Id;
2926 begin
2927 if Nkind (Unit_Node) = N_Package_Declaration then
2928 Spec := Specification (Unit_Node);
2929 Decls := Private_Declarations (Spec);
2931 if No (Decls) then
2932 Decls := Visible_Declarations (Spec);
2933 end if;
2935 Push_Scope (Scope_Of_Spec (Spec));
2936 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2938 else
2939 Spec :=
2940 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2941 Decls := Declarations (Unit_Node);
2943 Push_Scope (Scope_Of_Spec (Unit_Node));
2944 Stubs_Decls := New_List;
2945 Stubs_Stmts := New_List;
2946 Specific_Add_Receiving_Stubs_To_Declarations
2947 (Spec, Stubs_Decls, Stubs_Stmts);
2949 Insert_List_Before (First (Decls), Stubs_Decls);
2951 declare
2952 HSS_Stmts : constant List_Id :=
2953 Statements (Handled_Statement_Sequence (Unit_Node));
2955 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2957 begin
2958 if No (First_HSS_Stmt) then
2959 Append_List_To (HSS_Stmts, Stubs_Stmts);
2960 else
2961 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2962 end if;
2963 end;
2964 end if;
2966 Pop_Scope;
2967 end Expand_Receiving_Stubs_Bodies;
2969 --------------------
2970 -- GARLIC_Support --
2971 --------------------
2973 package body GARLIC_Support is
2975 -- Local subprograms
2977 procedure Add_RACW_Read_Attribute
2978 (RACW_Type : Entity_Id;
2979 Stub_Type : Entity_Id;
2980 Stub_Type_Access : Entity_Id;
2981 Body_Decls : List_Id);
2982 -- Add Read attribute for the RACW type. The declaration and attribute
2983 -- definition clauses are inserted right after the declaration of
2984 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2985 -- appended to it (case where the RACW declaration is in the main unit).
2987 procedure Add_RACW_Write_Attribute
2988 (RACW_Type : Entity_Id;
2989 Stub_Type : Entity_Id;
2990 Stub_Type_Access : Entity_Id;
2991 RPC_Receiver : Node_Id;
2992 Body_Decls : List_Id);
2993 -- Same as above for the Write attribute
2995 function Stream_Parameter return Node_Id;
2996 function Result return Node_Id;
2997 function Object return Node_Id renames Result;
2998 -- Functions to create occurrences of the formal parameter names of the
2999 -- 'Read and 'Write attributes.
3001 Loc : Source_Ptr;
3002 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
3003 -- their ancillary subroutines (set on entry by Add_RACW_Features).
3005 procedure Add_RAS_Access_TSS (N : Node_Id);
3006 -- Add a subprogram body for RAS Access TSS
3008 -------------------------------------
3009 -- Add_Obj_RPC_Receiver_Completion --
3010 -------------------------------------
3012 procedure Add_Obj_RPC_Receiver_Completion
3013 (Loc : Source_Ptr;
3014 Decls : List_Id;
3015 RPC_Receiver : Entity_Id;
3016 Stub_Elements : Stub_Structure)
3018 begin
3019 -- The RPC receiver body should not be the completion of the
3020 -- declaration recorded in the stub structure, because then the
3021 -- occurrences of the formal parameters within the body should refer
3022 -- to the entities from the declaration, not from the completion, to
3023 -- which we do not have easy access. Instead, the RPC receiver body
3024 -- acts as its own declaration, and the RPC receiver declaration is
3025 -- completed by a renaming-as-body.
3027 Append_To (Decls,
3028 Make_Subprogram_Renaming_Declaration (Loc,
3029 Specification =>
3030 Copy_Specification (Loc,
3031 Specification (Stub_Elements.RPC_Receiver_Decl)),
3032 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
3033 end Add_Obj_RPC_Receiver_Completion;
3035 -----------------------
3036 -- Add_RACW_Features --
3037 -----------------------
3039 procedure Add_RACW_Features
3040 (RACW_Type : Entity_Id;
3041 Stub_Type : Entity_Id;
3042 Stub_Type_Access : Entity_Id;
3043 RPC_Receiver_Decl : Node_Id;
3044 Body_Decls : List_Id)
3046 RPC_Receiver : Node_Id;
3047 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
3049 begin
3050 Loc := Sloc (RACW_Type);
3052 if Is_RAS then
3054 -- For a RAS, the RPC receiver is that of the RCI unit, not that
3055 -- of the corresponding distributed object type. We retrieve its
3056 -- address from the local proxy object.
3058 RPC_Receiver := Make_Selected_Component (Loc,
3059 Prefix =>
3060 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
3061 Selector_Name => Make_Identifier (Loc, Name_Receiver));
3063 else
3064 RPC_Receiver := Make_Attribute_Reference (Loc,
3065 Prefix => New_Occurrence_Of (
3066 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
3067 Attribute_Name => Name_Address);
3068 end if;
3070 Add_RACW_Write_Attribute
3071 (RACW_Type,
3072 Stub_Type,
3073 Stub_Type_Access,
3074 RPC_Receiver,
3075 Body_Decls);
3077 Add_RACW_Read_Attribute
3078 (RACW_Type,
3079 Stub_Type,
3080 Stub_Type_Access,
3081 Body_Decls);
3082 end Add_RACW_Features;
3084 -----------------------------
3085 -- Add_RACW_Read_Attribute --
3086 -----------------------------
3088 procedure Add_RACW_Read_Attribute
3089 (RACW_Type : Entity_Id;
3090 Stub_Type : Entity_Id;
3091 Stub_Type_Access : Entity_Id;
3092 Body_Decls : List_Id)
3094 Proc_Decl : Node_Id;
3095 Attr_Decl : Node_Id;
3097 Body_Node : Node_Id;
3099 Statements : constant List_Id := New_List;
3100 Decls : List_Id;
3101 Local_Statements : List_Id;
3102 Remote_Statements : List_Id;
3103 -- Various parts of the procedure
3105 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
3106 Asynchronous_Flag : constant Entity_Id :=
3107 Asynchronous_Flags_Table.Get (RACW_Type);
3108 pragma Assert (Present (Asynchronous_Flag));
3110 -- Prepare local identifiers
3112 Source_Partition : Entity_Id;
3113 Source_Receiver : Entity_Id;
3114 Source_Address : Entity_Id;
3115 Local_Stub : Entity_Id;
3116 Stubbed_Result : Entity_Id;
3118 -- Start of processing for Add_RACW_Read_Attribute
3120 begin
3121 Build_Stream_Procedure (Loc,
3122 RACW_Type, Body_Node, Pnam, Statements, Outp => True);
3123 Proc_Decl := Make_Subprogram_Declaration (Loc,
3124 Copy_Specification (Loc, Specification (Body_Node)));
3126 Attr_Decl :=
3127 Make_Attribute_Definition_Clause (Loc,
3128 Name => New_Occurrence_Of (RACW_Type, Loc),
3129 Chars => Name_Read,
3130 Expression =>
3131 New_Occurrence_Of (
3132 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3134 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3135 Insert_After (Proc_Decl, Attr_Decl);
3137 if No (Body_Decls) then
3139 -- Case of processing an RACW type from another unit than the
3140 -- main one: do not generate a body.
3142 return;
3143 end if;
3145 -- Prepare local identifiers
3147 Source_Partition := Make_Temporary (Loc, 'P');
3148 Source_Receiver := Make_Temporary (Loc, 'S');
3149 Source_Address := Make_Temporary (Loc, 'P');
3150 Local_Stub := Make_Temporary (Loc, 'L');
3151 Stubbed_Result := Make_Temporary (Loc, 'S');
3153 -- Generate object declarations
3155 Decls := New_List (
3156 Make_Object_Declaration (Loc,
3157 Defining_Identifier => Source_Partition,
3158 Object_Definition =>
3159 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
3161 Make_Object_Declaration (Loc,
3162 Defining_Identifier => Source_Receiver,
3163 Object_Definition =>
3164 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3166 Make_Object_Declaration (Loc,
3167 Defining_Identifier => Source_Address,
3168 Object_Definition =>
3169 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3171 Make_Object_Declaration (Loc,
3172 Defining_Identifier => Local_Stub,
3173 Aliased_Present => True,
3174 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
3176 Make_Object_Declaration (Loc,
3177 Defining_Identifier => Stubbed_Result,
3178 Object_Definition =>
3179 New_Occurrence_Of (Stub_Type_Access, Loc),
3180 Expression =>
3181 Make_Attribute_Reference (Loc,
3182 Prefix =>
3183 New_Occurrence_Of (Local_Stub, Loc),
3184 Attribute_Name =>
3185 Name_Unchecked_Access)));
3187 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3189 Append_List_To (Statements, New_List (
3190 Make_Attribute_Reference (Loc,
3191 Prefix =>
3192 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3193 Attribute_Name => Name_Read,
3194 Expressions => New_List (
3195 Stream_Parameter,
3196 New_Occurrence_Of (Source_Partition, Loc))),
3198 Make_Attribute_Reference (Loc,
3199 Prefix =>
3200 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3201 Attribute_Name =>
3202 Name_Read,
3203 Expressions => New_List (
3204 Stream_Parameter,
3205 New_Occurrence_Of (Source_Receiver, Loc))),
3207 Make_Attribute_Reference (Loc,
3208 Prefix =>
3209 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3210 Attribute_Name =>
3211 Name_Read,
3212 Expressions => New_List (
3213 Stream_Parameter,
3214 New_Occurrence_Of (Source_Address, Loc)))));
3216 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3218 Set_Etype (Stubbed_Result, Stub_Type_Access);
3220 -- If the Address is Null_Address, then return a null object, unless
3221 -- RACW_Type is null-excluding, in which case unconditionally raise
3222 -- CONSTRAINT_ERROR instead.
3224 declare
3225 Zero_Statements : List_Id;
3226 -- Statements executed when a zero value is received
3228 begin
3229 if Can_Never_Be_Null (RACW_Type) then
3230 Zero_Statements := New_List (
3231 Make_Raise_Constraint_Error (Loc,
3232 Reason => CE_Null_Not_Allowed));
3233 else
3234 Zero_Statements := New_List (
3235 Make_Assignment_Statement (Loc,
3236 Name => Result,
3237 Expression => Make_Null (Loc)),
3238 Make_Simple_Return_Statement (Loc));
3239 end if;
3241 Append_To (Statements,
3242 Make_Implicit_If_Statement (RACW_Type,
3243 Condition =>
3244 Make_Op_Eq (Loc,
3245 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3246 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3247 Then_Statements => Zero_Statements));
3248 end;
3250 -- If the RACW denotes an object created on the current partition,
3251 -- Local_Statements will be executed. The real object will be used.
3253 Local_Statements := New_List (
3254 Make_Assignment_Statement (Loc,
3255 Name => Result,
3256 Expression =>
3257 Unchecked_Convert_To (RACW_Type,
3258 OK_Convert_To (RTE (RE_Address),
3259 New_Occurrence_Of (Source_Address, Loc)))));
3261 -- If the object is located on another partition, then a stub object
3262 -- will be created with all the information needed to rebuild the
3263 -- real object at the other end.
3265 Remote_Statements := New_List (
3267 Make_Assignment_Statement (Loc,
3268 Name => Make_Selected_Component (Loc,
3269 Prefix => Stubbed_Result,
3270 Selector_Name => Name_Origin),
3271 Expression =>
3272 New_Occurrence_Of (Source_Partition, Loc)),
3274 Make_Assignment_Statement (Loc,
3275 Name => Make_Selected_Component (Loc,
3276 Prefix => Stubbed_Result,
3277 Selector_Name => Name_Receiver),
3278 Expression =>
3279 New_Occurrence_Of (Source_Receiver, Loc)),
3281 Make_Assignment_Statement (Loc,
3282 Name => Make_Selected_Component (Loc,
3283 Prefix => Stubbed_Result,
3284 Selector_Name => Name_Addr),
3285 Expression =>
3286 New_Occurrence_Of (Source_Address, Loc)));
3288 Append_To (Remote_Statements,
3289 Make_Assignment_Statement (Loc,
3290 Name => Make_Selected_Component (Loc,
3291 Prefix => Stubbed_Result,
3292 Selector_Name => Name_Asynchronous),
3293 Expression =>
3294 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3296 Append_List_To (Remote_Statements,
3297 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3298 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3299 -- set on the stub type if, and only if, the RACW type has a pragma
3300 -- Asynchronous. This is incorrect for RACWs that implement RAS
3301 -- types, because in that case the /designated subprogram/ (not the
3302 -- type) might be asynchronous, and that causes the stub to need to
3303 -- be asynchronous too. A solution is to transport a RAS as a struct
3304 -- containing a RACW and an asynchronous flag, and to properly alter
3305 -- the Asynchronous component in the stub type in the RAS's Input
3306 -- TSS.
3308 Append_To (Remote_Statements,
3309 Make_Assignment_Statement (Loc,
3310 Name => Result,
3311 Expression => Unchecked_Convert_To (RACW_Type,
3312 New_Occurrence_Of (Stubbed_Result, Loc))));
3314 -- Distinguish between the local and remote cases, and execute the
3315 -- appropriate piece of code.
3317 Append_To (Statements,
3318 Make_Implicit_If_Statement (RACW_Type,
3319 Condition =>
3320 Make_Op_Eq (Loc,
3321 Left_Opnd =>
3322 Make_Function_Call (Loc,
3323 Name => New_Occurrence_Of (
3324 RTE (RE_Get_Local_Partition_Id), Loc)),
3325 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3326 Then_Statements => Local_Statements,
3327 Else_Statements => Remote_Statements));
3329 Set_Declarations (Body_Node, Decls);
3330 Append_To (Body_Decls, Body_Node);
3331 end Add_RACW_Read_Attribute;
3333 ------------------------------
3334 -- Add_RACW_Write_Attribute --
3335 ------------------------------
3337 procedure Add_RACW_Write_Attribute
3338 (RACW_Type : Entity_Id;
3339 Stub_Type : Entity_Id;
3340 Stub_Type_Access : Entity_Id;
3341 RPC_Receiver : Node_Id;
3342 Body_Decls : List_Id)
3344 Body_Node : Node_Id;
3345 Proc_Decl : Node_Id;
3346 Attr_Decl : Node_Id;
3348 Statements : constant List_Id := New_List;
3349 Local_Statements : List_Id;
3350 Remote_Statements : List_Id;
3351 Null_Statements : List_Id;
3353 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
3355 begin
3356 Build_Stream_Procedure
3357 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
3359 Proc_Decl := Make_Subprogram_Declaration (Loc,
3360 Copy_Specification (Loc, Specification (Body_Node)));
3362 Attr_Decl :=
3363 Make_Attribute_Definition_Clause (Loc,
3364 Name => New_Occurrence_Of (RACW_Type, Loc),
3365 Chars => Name_Write,
3366 Expression =>
3367 New_Occurrence_Of (
3368 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3370 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3371 Insert_After (Proc_Decl, Attr_Decl);
3373 if No (Body_Decls) then
3374 return;
3375 end if;
3377 -- Build the code fragment corresponding to the marshalling of a
3378 -- local object.
3380 Local_Statements := New_List (
3382 Pack_Entity_Into_Stream_Access (Loc,
3383 Stream => Stream_Parameter,
3384 Object => RTE (RE_Get_Local_Partition_Id)),
3386 Pack_Node_Into_Stream_Access (Loc,
3387 Stream => Stream_Parameter,
3388 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3389 Etyp => RTE (RE_Unsigned_64)),
3391 Pack_Node_Into_Stream_Access (Loc,
3392 Stream => Stream_Parameter,
3393 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3394 Make_Attribute_Reference (Loc,
3395 Prefix =>
3396 Make_Explicit_Dereference (Loc,
3397 Prefix => Object),
3398 Attribute_Name => Name_Address)),
3399 Etyp => RTE (RE_Unsigned_64)));
3401 -- Build the code fragment corresponding to the marshalling of
3402 -- a remote object.
3404 Remote_Statements := New_List (
3405 Pack_Node_Into_Stream_Access (Loc,
3406 Stream => Stream_Parameter,
3407 Object =>
3408 Make_Selected_Component (Loc,
3409 Prefix =>
3410 Unchecked_Convert_To (Stub_Type_Access, Object),
3411 Selector_Name => Make_Identifier (Loc, Name_Origin)),
3412 Etyp => RTE (RE_Partition_ID)),
3414 Pack_Node_Into_Stream_Access (Loc,
3415 Stream => Stream_Parameter,
3416 Object =>
3417 Make_Selected_Component (Loc,
3418 Prefix =>
3419 Unchecked_Convert_To (Stub_Type_Access, Object),
3420 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
3421 Etyp => RTE (RE_Unsigned_64)),
3423 Pack_Node_Into_Stream_Access (Loc,
3424 Stream => Stream_Parameter,
3425 Object =>
3426 Make_Selected_Component (Loc,
3427 Prefix =>
3428 Unchecked_Convert_To (Stub_Type_Access, Object),
3429 Selector_Name => Make_Identifier (Loc, Name_Addr)),
3430 Etyp => RTE (RE_Unsigned_64)));
3432 -- Build code fragment corresponding to marshalling of a null object
3434 Null_Statements := New_List (
3436 Pack_Entity_Into_Stream_Access (Loc,
3437 Stream => Stream_Parameter,
3438 Object => RTE (RE_Get_Local_Partition_Id)),
3440 Pack_Node_Into_Stream_Access (Loc,
3441 Stream => Stream_Parameter,
3442 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3443 Etyp => RTE (RE_Unsigned_64)),
3445 Pack_Node_Into_Stream_Access (Loc,
3446 Stream => Stream_Parameter,
3447 Object => Make_Integer_Literal (Loc, Uint_0),
3448 Etyp => RTE (RE_Unsigned_64)));
3450 Append_To (Statements,
3451 Make_Implicit_If_Statement (RACW_Type,
3452 Condition =>
3453 Make_Op_Eq (Loc,
3454 Left_Opnd => Object,
3455 Right_Opnd => Make_Null (Loc)),
3457 Then_Statements => Null_Statements,
3459 Elsif_Parts => New_List (
3460 Make_Elsif_Part (Loc,
3461 Condition =>
3462 Make_Op_Eq (Loc,
3463 Left_Opnd =>
3464 Make_Attribute_Reference (Loc,
3465 Prefix => Object,
3466 Attribute_Name => Name_Tag),
3468 Right_Opnd =>
3469 Make_Attribute_Reference (Loc,
3470 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3471 Attribute_Name => Name_Tag)),
3472 Then_Statements => Remote_Statements)),
3473 Else_Statements => Local_Statements));
3475 Append_To (Body_Decls, Body_Node);
3476 end Add_RACW_Write_Attribute;
3478 ------------------------
3479 -- Add_RAS_Access_TSS --
3480 ------------------------
3482 procedure Add_RAS_Access_TSS (N : Node_Id) is
3483 Loc : constant Source_Ptr := Sloc (N);
3485 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3486 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3487 -- Ras_Type is the access to subprogram type while Fat_Type is the
3488 -- corresponding record type.
3490 RACW_Type : constant Entity_Id :=
3491 Underlying_RACW_Type (Ras_Type);
3492 Desig : constant Entity_Id :=
3493 Etype (Designated_Type (RACW_Type));
3495 Stub_Elements : constant Stub_Structure :=
3496 Stubs_Table.Get (Desig);
3497 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3499 Proc : constant Entity_Id :=
3500 Make_Defining_Identifier (Loc,
3501 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3503 Proc_Spec : Node_Id;
3505 -- Formal parameters
3507 Package_Name : constant Entity_Id :=
3508 Make_Defining_Identifier (Loc,
3509 Chars => Name_P);
3510 -- Target package
3512 Subp_Id : constant Entity_Id :=
3513 Make_Defining_Identifier (Loc,
3514 Chars => Name_S);
3515 -- Target subprogram
3517 Asynch_P : constant Entity_Id :=
3518 Make_Defining_Identifier (Loc,
3519 Chars => Name_Asynchronous);
3520 -- Is the procedure to which the 'Access applies asynchronous?
3522 All_Calls_Remote : constant Entity_Id :=
3523 Make_Defining_Identifier (Loc,
3524 Chars => Name_All_Calls_Remote);
3525 -- True if an All_Calls_Remote pragma applies to the RCI unit
3526 -- that contains the subprogram.
3528 -- Common local variables
3530 Proc_Decls : List_Id;
3531 Proc_Statements : List_Id;
3533 Origin : constant Entity_Id := Make_Temporary (Loc, 'P');
3535 -- Additional local variables for the local case
3537 Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P');
3539 -- Additional local variables for the remote case
3541 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
3542 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
3544 function Set_Field
3545 (Field_Name : Name_Id;
3546 Value : Node_Id) return Node_Id;
3547 -- Construct an assignment that sets the named component in the
3548 -- returned record
3550 ---------------
3551 -- Set_Field --
3552 ---------------
3554 function Set_Field
3555 (Field_Name : Name_Id;
3556 Value : Node_Id) return Node_Id
3558 begin
3559 return
3560 Make_Assignment_Statement (Loc,
3561 Name =>
3562 Make_Selected_Component (Loc,
3563 Prefix => Stub_Ptr,
3564 Selector_Name => Field_Name),
3565 Expression => Value);
3566 end Set_Field;
3568 -- Start of processing for Add_RAS_Access_TSS
3570 begin
3571 Proc_Decls := New_List (
3573 -- Common declarations
3575 Make_Object_Declaration (Loc,
3576 Defining_Identifier => Origin,
3577 Constant_Present => True,
3578 Object_Definition =>
3579 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3580 Expression =>
3581 Make_Function_Call (Loc,
3582 Name =>
3583 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3584 Parameter_Associations => New_List (
3585 New_Occurrence_Of (Package_Name, Loc)))),
3587 -- Declaration use only in the local case: proxy address
3589 Make_Object_Declaration (Loc,
3590 Defining_Identifier => Proxy_Addr,
3591 Object_Definition =>
3592 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3594 -- Declarations used only in the remote case: stub object and
3595 -- stub pointer.
3597 Make_Object_Declaration (Loc,
3598 Defining_Identifier => Local_Stub,
3599 Aliased_Present => True,
3600 Object_Definition =>
3601 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3603 Make_Object_Declaration (Loc,
3604 Defining_Identifier =>
3605 Stub_Ptr,
3606 Object_Definition =>
3607 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3608 Expression =>
3609 Make_Attribute_Reference (Loc,
3610 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3611 Attribute_Name => Name_Unchecked_Access)));
3613 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3615 -- Build_Get_Unique_RP_Call needs above information
3617 -- Note: Here we assume that the Fat_Type is a record
3618 -- containing just a pointer to a proxy or stub object.
3620 Proc_Statements := New_List (
3622 -- Generate:
3624 -- Get_RAS_Info (Pkg, Subp, PA);
3625 -- if Origin = Local_Partition_Id
3626 -- and then not All_Calls_Remote
3627 -- then
3628 -- return Fat_Type!(PA);
3629 -- end if;
3631 Make_Procedure_Call_Statement (Loc,
3632 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3633 Parameter_Associations => New_List (
3634 New_Occurrence_Of (Package_Name, Loc),
3635 New_Occurrence_Of (Subp_Id, Loc),
3636 New_Occurrence_Of (Proxy_Addr, Loc))),
3638 Make_Implicit_If_Statement (N,
3639 Condition =>
3640 Make_And_Then (Loc,
3641 Left_Opnd =>
3642 Make_Op_Eq (Loc,
3643 Left_Opnd =>
3644 New_Occurrence_Of (Origin, Loc),
3645 Right_Opnd =>
3646 Make_Function_Call (Loc,
3647 New_Occurrence_Of (
3648 RTE (RE_Get_Local_Partition_Id), Loc))),
3650 Right_Opnd =>
3651 Make_Op_Not (Loc,
3652 New_Occurrence_Of (All_Calls_Remote, Loc))),
3654 Then_Statements => New_List (
3655 Make_Simple_Return_Statement (Loc,
3656 Unchecked_Convert_To (Fat_Type,
3657 OK_Convert_To (RTE (RE_Address),
3658 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3660 Set_Field (Name_Origin,
3661 New_Occurrence_Of (Origin, Loc)),
3663 Set_Field (Name_Receiver,
3664 Make_Function_Call (Loc,
3665 Name =>
3666 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3667 Parameter_Associations => New_List (
3668 New_Occurrence_Of (Package_Name, Loc)))),
3670 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3672 -- E.4.1(9) A remote call is asynchronous if it is a call to
3673 -- a procedure or a call through a value of an access-to-procedure
3674 -- type to which a pragma Asynchronous applies.
3676 -- Asynch_P is true when the procedure is asynchronous;
3677 -- Asynch_T is true when the type is asynchronous.
3679 Set_Field (Name_Asynchronous,
3680 Make_Or_Else (Loc,
3681 New_Occurrence_Of (Asynch_P, Loc),
3682 New_Occurrence_Of (Boolean_Literals (
3683 Is_Asynchronous (Ras_Type)), Loc))));
3685 Append_List_To (Proc_Statements,
3686 Build_Get_Unique_RP_Call
3687 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3689 -- Return the newly created value
3691 Append_To (Proc_Statements,
3692 Make_Simple_Return_Statement (Loc,
3693 Expression =>
3694 Unchecked_Convert_To (Fat_Type,
3695 New_Occurrence_Of (Stub_Ptr, Loc))));
3697 Proc_Spec :=
3698 Make_Function_Specification (Loc,
3699 Defining_Unit_Name => Proc,
3700 Parameter_Specifications => New_List (
3701 Make_Parameter_Specification (Loc,
3702 Defining_Identifier => Package_Name,
3703 Parameter_Type =>
3704 New_Occurrence_Of (Standard_String, Loc)),
3706 Make_Parameter_Specification (Loc,
3707 Defining_Identifier => Subp_Id,
3708 Parameter_Type =>
3709 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3711 Make_Parameter_Specification (Loc,
3712 Defining_Identifier => Asynch_P,
3713 Parameter_Type =>
3714 New_Occurrence_Of (Standard_Boolean, Loc)),
3716 Make_Parameter_Specification (Loc,
3717 Defining_Identifier => All_Calls_Remote,
3718 Parameter_Type =>
3719 New_Occurrence_Of (Standard_Boolean, Loc))),
3721 Result_Definition =>
3722 New_Occurrence_Of (Fat_Type, Loc));
3724 -- Set the kind and return type of the function to prevent
3725 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3727 Set_Ekind (Proc, E_Function);
3728 Set_Etype (Proc, Fat_Type);
3730 Discard_Node (
3731 Make_Subprogram_Body (Loc,
3732 Specification => Proc_Spec,
3733 Declarations => Proc_Decls,
3734 Handled_Statement_Sequence =>
3735 Make_Handled_Sequence_Of_Statements (Loc,
3736 Statements => Proc_Statements)));
3738 Set_TSS (Fat_Type, Proc);
3739 end Add_RAS_Access_TSS;
3741 -----------------------
3742 -- Add_RAST_Features --
3743 -----------------------
3745 procedure Add_RAST_Features
3746 (Vis_Decl : Node_Id;
3747 RAS_Type : Entity_Id)
3749 pragma Unreferenced (RAS_Type);
3750 begin
3751 Add_RAS_Access_TSS (Vis_Decl);
3752 end Add_RAST_Features;
3754 -----------------------------------------
3755 -- Add_Receiving_Stubs_To_Declarations --
3756 -----------------------------------------
3758 procedure Add_Receiving_Stubs_To_Declarations
3759 (Pkg_Spec : Node_Id;
3760 Decls : List_Id;
3761 Stmts : List_Id)
3763 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3765 Request_Parameter : Node_Id;
3767 Pkg_RPC_Receiver : constant Entity_Id :=
3768 Make_Temporary (Loc, 'H');
3769 Pkg_RPC_Receiver_Statements : List_Id;
3770 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3771 Pkg_RPC_Receiver_Body : Node_Id;
3772 -- A Pkg_RPC_Receiver is built to decode the request
3774 Lookup_RAS : Node_Id;
3775 Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R');
3776 -- A remote subprogram is created to allow peers to look up RAS
3777 -- information using subprogram ids.
3779 Subp_Id : Entity_Id;
3780 Subp_Index : Entity_Id;
3781 -- Subprogram_Id as read from the incoming stream
3783 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
3784 Current_Stubs : Node_Id;
3786 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
3787 Subp_Info_List : constant List_Id := New_List;
3789 Register_Pkg_Actuals : constant List_Id := New_List;
3791 All_Calls_Remote_E : Entity_Id;
3792 Proxy_Object_Addr : Entity_Id;
3794 procedure Append_Stubs_To
3795 (RPC_Receiver_Cases : List_Id;
3796 Stubs : Node_Id;
3797 Subprogram_Number : Int);
3798 -- Add one case to the specified RPC receiver case list
3799 -- associating Subprogram_Number with the subprogram declared
3800 -- by Declaration, for which we have receiving stubs in Stubs.
3802 procedure Visit_Subprogram (Decl : Node_Id);
3803 -- Generate receiving stub for one remote subprogram
3805 ---------------------
3806 -- Append_Stubs_To --
3807 ---------------------
3809 procedure Append_Stubs_To
3810 (RPC_Receiver_Cases : List_Id;
3811 Stubs : Node_Id;
3812 Subprogram_Number : Int)
3814 begin
3815 Append_To (RPC_Receiver_Cases,
3816 Make_Case_Statement_Alternative (Loc,
3817 Discrete_Choices =>
3818 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3819 Statements =>
3820 New_List (
3821 Make_Procedure_Call_Statement (Loc,
3822 Name =>
3823 New_Occurrence_Of (Defining_Entity (Stubs), Loc),
3824 Parameter_Associations => New_List (
3825 New_Occurrence_Of (Request_Parameter, Loc))))));
3826 end Append_Stubs_To;
3828 ----------------------
3829 -- Visit_Subprogram --
3830 ----------------------
3832 procedure Visit_Subprogram (Decl : Node_Id) is
3833 Loc : constant Source_Ptr := Sloc (Decl);
3834 Spec : constant Node_Id := Specification (Decl);
3835 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
3837 Subp_Val : String_Id;
3838 pragma Warnings (Off, Subp_Val);
3840 begin
3841 -- Disable expansion of stubs if serious errors have been
3842 -- diagnosed, because otherwise some illegal remote subprogram
3843 -- declarations could cause cascaded errors in stubs.
3845 if Serious_Errors_Detected /= 0 then
3846 return;
3847 end if;
3849 -- Build receiving stub
3851 Current_Stubs :=
3852 Build_Subprogram_Receiving_Stubs
3853 (Vis_Decl => Decl,
3854 Asynchronous =>
3855 Nkind (Spec) = N_Procedure_Specification
3856 and then Is_Asynchronous (Subp_Def));
3858 Append_To (Decls, Current_Stubs);
3859 Analyze (Current_Stubs);
3861 -- Build RAS proxy
3863 Add_RAS_Proxy_And_Analyze (Decls,
3864 Vis_Decl => Decl,
3865 All_Calls_Remote_E => All_Calls_Remote_E,
3866 Proxy_Object_Addr => Proxy_Object_Addr);
3868 -- Compute distribution identifier
3870 Assign_Subprogram_Identifier
3871 (Subp_Def, Current_Subp_Number, Subp_Val);
3873 pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
3875 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
3876 -- table for this receiver. This aggregate must be kept consistent
3877 -- with the declaration of RCI_Subp_Info in
3878 -- System.Partition_Interface.
3880 Append_To (Subp_Info_List,
3881 Make_Component_Association (Loc,
3882 Choices => New_List (
3883 Make_Integer_Literal (Loc, Current_Subp_Number)),
3885 Expression =>
3886 Make_Aggregate (Loc,
3887 Component_Associations => New_List (
3889 -- Addr =>
3891 Make_Component_Association (Loc,
3892 Choices =>
3893 New_List (Make_Identifier (Loc, Name_Addr)),
3894 Expression =>
3895 New_Occurrence_Of (Proxy_Object_Addr, Loc))))));
3897 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3898 Stubs => Current_Stubs,
3899 Subprogram_Number => Current_Subp_Number);
3901 Current_Subp_Number := Current_Subp_Number + 1;
3902 end Visit_Subprogram;
3904 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
3906 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3908 begin
3909 -- Building receiving stubs consist in several operations:
3911 -- - a package RPC receiver must be built. This subprogram
3912 -- will get a Subprogram_Id from the incoming stream
3913 -- and will dispatch the call to the right subprogram;
3915 -- - a receiving stub for each subprogram visible in the package
3916 -- spec. This stub will read all the parameters from the stream,
3917 -- and put the result as well as the exception occurrence in the
3918 -- output stream;
3920 -- - a dummy package with an empty spec and a body made of an
3921 -- elaboration part, whose job is to register the receiving
3922 -- part of this RCI package on the name server. This is done
3923 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3925 Build_RPC_Receiver_Body (
3926 RPC_Receiver => Pkg_RPC_Receiver,
3927 Request => Request_Parameter,
3928 Subp_Id => Subp_Id,
3929 Subp_Index => Subp_Index,
3930 Stmts => Pkg_RPC_Receiver_Statements,
3931 Decl => Pkg_RPC_Receiver_Body);
3932 pragma Assert (Subp_Id = Subp_Index);
3934 -- A null subp_id denotes a call through a RAS, in which case the
3935 -- next Uint_64 element in the stream is the address of the local
3936 -- proxy object, from which we can retrieve the actual subprogram id.
3938 Append_To (Pkg_RPC_Receiver_Statements,
3939 Make_Implicit_If_Statement (Pkg_Spec,
3940 Condition =>
3941 Make_Op_Eq (Loc,
3942 New_Occurrence_Of (Subp_Id, Loc),
3943 Make_Integer_Literal (Loc, 0)),
3945 Then_Statements => New_List (
3946 Make_Assignment_Statement (Loc,
3947 Name =>
3948 New_Occurrence_Of (Subp_Id, Loc),
3950 Expression =>
3951 Make_Selected_Component (Loc,
3952 Prefix =>
3953 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3954 OK_Convert_To (RTE (RE_Address),
3955 Make_Attribute_Reference (Loc,
3956 Prefix =>
3957 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3958 Attribute_Name =>
3959 Name_Input,
3960 Expressions => New_List (
3961 Make_Selected_Component (Loc,
3962 Prefix => Request_Parameter,
3963 Selector_Name => Name_Params))))),
3965 Selector_Name => Make_Identifier (Loc, Name_Subp_Id))))));
3967 -- Build a subprogram for RAS information lookups
3969 Lookup_RAS :=
3970 Make_Subprogram_Declaration (Loc,
3971 Specification =>
3972 Make_Function_Specification (Loc,
3973 Defining_Unit_Name =>
3974 Lookup_RAS_Info,
3975 Parameter_Specifications => New_List (
3976 Make_Parameter_Specification (Loc,
3977 Defining_Identifier =>
3978 Make_Defining_Identifier (Loc, Name_Subp_Id),
3979 In_Present =>
3980 True,
3981 Parameter_Type =>
3982 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3983 Result_Definition =>
3984 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3985 Append_To (Decls, Lookup_RAS);
3986 Analyze (Lookup_RAS);
3988 Current_Stubs := Build_Subprogram_Receiving_Stubs
3989 (Vis_Decl => Lookup_RAS,
3990 Asynchronous => False);
3991 Append_To (Decls, Current_Stubs);
3992 Analyze (Current_Stubs);
3994 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3995 Stubs => Current_Stubs,
3996 Subprogram_Number => 1);
3998 -- For each subprogram, the receiving stub will be built and a
3999 -- case statement will be made on the Subprogram_Id to dispatch
4000 -- to the right subprogram.
4002 All_Calls_Remote_E :=
4003 Boolean_Literals
4004 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
4006 Overload_Counter_Table.Reset;
4008 Visit_Spec (Pkg_Spec);
4010 -- If we receive an invalid Subprogram_Id, it is best to do nothing
4011 -- rather than raising an exception since we do not want someone
4012 -- to crash a remote partition by sending invalid subprogram ids.
4013 -- This is consistent with the other parts of the case statement
4014 -- since even in presence of incorrect parameters in the stream,
4015 -- every exception will be caught and (if the subprogram is not an
4016 -- APC) put into the result stream and sent away.
4018 Append_To (Pkg_RPC_Receiver_Cases,
4019 Make_Case_Statement_Alternative (Loc,
4020 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4021 Statements => New_List (Make_Null_Statement (Loc))));
4023 Append_To (Pkg_RPC_Receiver_Statements,
4024 Make_Case_Statement (Loc,
4025 Expression => New_Occurrence_Of (Subp_Id, Loc),
4026 Alternatives => Pkg_RPC_Receiver_Cases));
4028 Append_To (Decls,
4029 Make_Object_Declaration (Loc,
4030 Defining_Identifier => Subp_Info_Array,
4031 Constant_Present => True,
4032 Aliased_Present => True,
4033 Object_Definition =>
4034 Make_Subtype_Indication (Loc,
4035 Subtype_Mark =>
4036 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
4037 Constraint =>
4038 Make_Index_Or_Discriminant_Constraint (Loc,
4039 New_List (
4040 Make_Range (Loc,
4041 Low_Bound => Make_Integer_Literal (Loc,
4042 First_RCI_Subprogram_Id),
4043 High_Bound =>
4044 Make_Integer_Literal (Loc,
4045 Intval =>
4046 First_RCI_Subprogram_Id
4047 + List_Length (Subp_Info_List) - 1)))))));
4049 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
4050 -- has zero length, and the declaration is for an empty array, in
4051 -- which case no initialization aggregate must be generated.
4053 if Present (First (Subp_Info_List)) then
4054 Set_Expression (Last (Decls),
4055 Make_Aggregate (Loc,
4056 Component_Associations => Subp_Info_List));
4058 -- No initialization provided: remove CONSTANT so that the
4059 -- declaration is not an incomplete deferred constant.
4061 else
4062 Set_Constant_Present (Last (Decls), False);
4063 end if;
4065 Analyze (Last (Decls));
4067 declare
4068 Subp_Info_Addr : Node_Id;
4069 -- Return statement for Lookup_RAS_Info: address of the subprogram
4070 -- information record for the requested subprogram id.
4072 begin
4073 if Present (First (Subp_Info_List)) then
4074 Subp_Info_Addr :=
4075 Make_Selected_Component (Loc,
4076 Prefix =>
4077 Make_Indexed_Component (Loc,
4078 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4079 Expressions => New_List (
4080 Convert_To (Standard_Integer,
4081 Make_Identifier (Loc, Name_Subp_Id)))),
4082 Selector_Name => Make_Identifier (Loc, Name_Addr));
4084 -- Case of no visible subprogram: just raise Constraint_Error, we
4085 -- know for sure we got junk from a remote partition.
4087 else
4088 Subp_Info_Addr :=
4089 Make_Raise_Constraint_Error (Loc,
4090 Reason => CE_Range_Check_Failed);
4091 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
4092 end if;
4094 Append_To (Decls,
4095 Make_Subprogram_Body (Loc,
4096 Specification =>
4097 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
4098 Declarations => No_List,
4099 Handled_Statement_Sequence =>
4100 Make_Handled_Sequence_Of_Statements (Loc,
4101 Statements => New_List (
4102 Make_Simple_Return_Statement (Loc,
4103 Expression =>
4104 OK_Convert_To
4105 (RTE (RE_Unsigned_64), Subp_Info_Addr))))));
4106 end;
4108 Analyze (Last (Decls));
4110 Append_To (Decls, Pkg_RPC_Receiver_Body);
4111 Analyze (Last (Decls));
4113 -- Name
4115 Append_To (Register_Pkg_Actuals,
4116 Make_String_Literal (Loc,
4117 Strval =>
4118 Fully_Qualified_Name_String
4119 (Defining_Entity (Pkg_Spec), Append_NUL => False)));
4121 -- Receiver
4123 Append_To (Register_Pkg_Actuals,
4124 Make_Attribute_Reference (Loc,
4125 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
4126 Attribute_Name => Name_Unrestricted_Access));
4128 -- Version
4130 Append_To (Register_Pkg_Actuals,
4131 Make_Attribute_Reference (Loc,
4132 Prefix =>
4133 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
4134 Attribute_Name => Name_Version));
4136 -- Subp_Info
4138 Append_To (Register_Pkg_Actuals,
4139 Make_Attribute_Reference (Loc,
4140 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4141 Attribute_Name => Name_Address));
4143 -- Subp_Info_Len
4145 Append_To (Register_Pkg_Actuals,
4146 Make_Attribute_Reference (Loc,
4147 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4148 Attribute_Name => Name_Length));
4150 -- Generate the call
4152 Append_To (Stmts,
4153 Make_Procedure_Call_Statement (Loc,
4154 Name =>
4155 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
4156 Parameter_Associations => Register_Pkg_Actuals));
4157 Analyze (Last (Stmts));
4158 end Add_Receiving_Stubs_To_Declarations;
4160 ---------------------------------
4161 -- Build_General_Calling_Stubs --
4162 ---------------------------------
4164 procedure Build_General_Calling_Stubs
4165 (Decls : List_Id;
4166 Statements : List_Id;
4167 Target_Partition : Entity_Id;
4168 Target_RPC_Receiver : Node_Id;
4169 Subprogram_Id : Node_Id;
4170 Asynchronous : Node_Id := Empty;
4171 Is_Known_Asynchronous : Boolean := False;
4172 Is_Known_Non_Asynchronous : Boolean := False;
4173 Is_Function : Boolean;
4174 Spec : Node_Id;
4175 Stub_Type : Entity_Id := Empty;
4176 RACW_Type : Entity_Id := Empty;
4177 Nod : Node_Id)
4179 Loc : constant Source_Ptr := Sloc (Nod);
4181 Stream_Parameter : Node_Id;
4182 -- Name of the stream used to transmit parameters to the remote
4183 -- package.
4185 Result_Parameter : Node_Id;
4186 -- Name of the result parameter (in non-APC cases) which get the
4187 -- result of the remote subprogram.
4189 Exception_Return_Parameter : Node_Id;
4190 -- Name of the parameter which will hold the exception sent by the
4191 -- remote subprogram.
4193 Current_Parameter : Node_Id;
4194 -- Current parameter being handled
4196 Ordered_Parameters_List : constant List_Id :=
4197 Build_Ordered_Parameters_List (Spec);
4199 Asynchronous_Statements : List_Id := No_List;
4200 Non_Asynchronous_Statements : List_Id := No_List;
4201 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4203 Extra_Formal_Statements : constant List_Id := New_List;
4204 -- List of statements for extra formal parameters. It will appear
4205 -- after the regular statements for writing out parameters.
4207 pragma Unreferenced (RACW_Type);
4208 -- Used only for the PolyORB case
4210 begin
4211 -- The general form of a calling stub for a given subprogram is:
4213 -- procedure X (...) is P : constant Partition_ID :=
4214 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4215 -- System.RPC.Params_Stream_Type (0); begin
4216 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4217 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4218 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4219 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4220 -- Raise_It;
4221 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4223 -- There are some variations: Do_APC is called for an asynchronous
4224 -- procedure and the part after the call is completely ommitted as
4225 -- well as the declaration of Result. For a function call, 'Input is
4226 -- always used to read the result even if it is constrained.
4228 Stream_Parameter := Make_Temporary (Loc, 'S');
4230 Append_To (Decls,
4231 Make_Object_Declaration (Loc,
4232 Defining_Identifier => Stream_Parameter,
4233 Aliased_Present => True,
4234 Object_Definition =>
4235 Make_Subtype_Indication (Loc,
4236 Subtype_Mark =>
4237 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4238 Constraint =>
4239 Make_Index_Or_Discriminant_Constraint (Loc,
4240 Constraints =>
4241 New_List (Make_Integer_Literal (Loc, 0))))));
4243 if not Is_Known_Asynchronous then
4244 Result_Parameter := Make_Temporary (Loc, 'R');
4246 Append_To (Decls,
4247 Make_Object_Declaration (Loc,
4248 Defining_Identifier => Result_Parameter,
4249 Aliased_Present => True,
4250 Object_Definition =>
4251 Make_Subtype_Indication (Loc,
4252 Subtype_Mark =>
4253 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4254 Constraint =>
4255 Make_Index_Or_Discriminant_Constraint (Loc,
4256 Constraints =>
4257 New_List (Make_Integer_Literal (Loc, 0))))));
4259 Exception_Return_Parameter := Make_Temporary (Loc, 'E');
4261 Append_To (Decls,
4262 Make_Object_Declaration (Loc,
4263 Defining_Identifier => Exception_Return_Parameter,
4264 Object_Definition =>
4265 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4267 else
4268 Result_Parameter := Empty;
4269 Exception_Return_Parameter := Empty;
4270 end if;
4272 -- Put first the RPC receiver corresponding to the remote package
4274 Append_To (Statements,
4275 Make_Attribute_Reference (Loc,
4276 Prefix =>
4277 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4278 Attribute_Name => Name_Write,
4279 Expressions => New_List (
4280 Make_Attribute_Reference (Loc,
4281 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4282 Attribute_Name => Name_Access),
4283 Target_RPC_Receiver)));
4285 -- Then put the Subprogram_Id of the subprogram we want to call in
4286 -- the stream.
4288 Append_To (Statements,
4289 Make_Attribute_Reference (Loc,
4290 Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4291 Attribute_Name => Name_Write,
4292 Expressions => New_List (
4293 Make_Attribute_Reference (Loc,
4294 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4295 Attribute_Name => Name_Access),
4296 Subprogram_Id)));
4298 Current_Parameter := First (Ordered_Parameters_List);
4299 while Present (Current_Parameter) loop
4300 declare
4301 Typ : constant Node_Id :=
4302 Parameter_Type (Current_Parameter);
4303 Etyp : Entity_Id;
4304 Constrained : Boolean;
4305 Value : Node_Id;
4306 Extra_Parameter : Entity_Id;
4308 begin
4309 if Is_RACW_Controlling_Formal
4310 (Current_Parameter, Stub_Type)
4311 then
4312 -- In the case of a controlling formal argument, we marshall
4313 -- its addr field rather than the local stub.
4315 Append_To (Statements,
4316 Pack_Node_Into_Stream (Loc,
4317 Stream => Stream_Parameter,
4318 Object =>
4319 Make_Selected_Component (Loc,
4320 Prefix =>
4321 Defining_Identifier (Current_Parameter),
4322 Selector_Name => Name_Addr),
4323 Etyp => RTE (RE_Unsigned_64)));
4325 else
4326 Value :=
4327 New_Occurrence_Of
4328 (Defining_Identifier (Current_Parameter), Loc);
4330 -- Access type parameters are transmitted as in out
4331 -- parameters. However, a dereference is needed so that
4332 -- we marshall the designated object.
4334 if Nkind (Typ) = N_Access_Definition then
4335 Value := Make_Explicit_Dereference (Loc, Value);
4336 Etyp := Etype (Subtype_Mark (Typ));
4337 else
4338 Etyp := Etype (Typ);
4339 end if;
4341 Constrained := not Transmit_As_Unconstrained (Etyp);
4343 -- Any parameter but unconstrained out parameters are
4344 -- transmitted to the peer.
4346 if In_Present (Current_Parameter)
4347 or else not Out_Present (Current_Parameter)
4348 or else not Constrained
4349 then
4350 Append_To (Statements,
4351 Make_Attribute_Reference (Loc,
4352 Prefix => New_Occurrence_Of (Etyp, Loc),
4353 Attribute_Name =>
4354 Output_From_Constrained (Constrained),
4355 Expressions => New_List (
4356 Make_Attribute_Reference (Loc,
4357 Prefix =>
4358 New_Occurrence_Of (Stream_Parameter, Loc),
4359 Attribute_Name => Name_Access),
4360 Value)));
4361 end if;
4362 end if;
4364 -- If the current parameter has a dynamic constrained status,
4365 -- then this status is transmitted as well.
4366 -- This should be done for accessibility as well ???
4368 if Nkind (Typ) /= N_Access_Definition
4369 and then Need_Extra_Constrained (Current_Parameter)
4370 then
4371 -- In this block, we do not use the extra formal that has
4372 -- been created because it does not exist at the time of
4373 -- expansion when building calling stubs for remote access
4374 -- to subprogram types. We create an extra variable of this
4375 -- type and push it in the stream after the regular
4376 -- parameters.
4378 Extra_Parameter := Make_Temporary (Loc, 'P');
4380 Append_To (Decls,
4381 Make_Object_Declaration (Loc,
4382 Defining_Identifier => Extra_Parameter,
4383 Constant_Present => True,
4384 Object_Definition =>
4385 New_Occurrence_Of (Standard_Boolean, Loc),
4386 Expression =>
4387 Make_Attribute_Reference (Loc,
4388 Prefix =>
4389 New_Occurrence_Of (
4390 Defining_Identifier (Current_Parameter), Loc),
4391 Attribute_Name => Name_Constrained)));
4393 Append_To (Extra_Formal_Statements,
4394 Make_Attribute_Reference (Loc,
4395 Prefix =>
4396 New_Occurrence_Of (Standard_Boolean, Loc),
4397 Attribute_Name => Name_Write,
4398 Expressions => New_List (
4399 Make_Attribute_Reference (Loc,
4400 Prefix =>
4401 New_Occurrence_Of
4402 (Stream_Parameter, Loc), Attribute_Name =>
4403 Name_Access),
4404 New_Occurrence_Of (Extra_Parameter, Loc))));
4405 end if;
4407 Next (Current_Parameter);
4408 end;
4409 end loop;
4411 -- Append the formal statements list to the statements
4413 Append_List_To (Statements, Extra_Formal_Statements);
4415 if not Is_Known_Non_Asynchronous then
4417 -- Build the call to System.RPC.Do_APC
4419 Asynchronous_Statements := New_List (
4420 Make_Procedure_Call_Statement (Loc,
4421 Name =>
4422 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4423 Parameter_Associations => New_List (
4424 New_Occurrence_Of (Target_Partition, Loc),
4425 Make_Attribute_Reference (Loc,
4426 Prefix =>
4427 New_Occurrence_Of (Stream_Parameter, Loc),
4428 Attribute_Name => Name_Access))));
4429 else
4430 Asynchronous_Statements := No_List;
4431 end if;
4433 if not Is_Known_Asynchronous then
4435 -- Build the call to System.RPC.Do_RPC
4437 Non_Asynchronous_Statements := New_List (
4438 Make_Procedure_Call_Statement (Loc,
4439 Name =>
4440 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4441 Parameter_Associations => New_List (
4442 New_Occurrence_Of (Target_Partition, Loc),
4444 Make_Attribute_Reference (Loc,
4445 Prefix =>
4446 New_Occurrence_Of (Stream_Parameter, Loc),
4447 Attribute_Name => Name_Access),
4449 Make_Attribute_Reference (Loc,
4450 Prefix =>
4451 New_Occurrence_Of (Result_Parameter, Loc),
4452 Attribute_Name => Name_Access))));
4454 -- Read the exception occurrence from the result stream and
4455 -- reraise it. It does no harm if this is a Null_Occurrence since
4456 -- this does nothing.
4458 Append_To (Non_Asynchronous_Statements,
4459 Make_Attribute_Reference (Loc,
4460 Prefix =>
4461 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4463 Attribute_Name => Name_Read,
4465 Expressions => New_List (
4466 Make_Attribute_Reference (Loc,
4467 Prefix =>
4468 New_Occurrence_Of (Result_Parameter, Loc),
4469 Attribute_Name => Name_Access),
4470 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4472 Append_To (Non_Asynchronous_Statements,
4473 Make_Procedure_Call_Statement (Loc,
4474 Name =>
4475 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4476 Parameter_Associations => New_List (
4477 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4479 if Is_Function then
4481 -- If this is a function call, then read the value and return
4482 -- it. The return value is written/read using 'Output/'Input.
4484 Append_To (Non_Asynchronous_Statements,
4485 Make_Tag_Check (Loc,
4486 Make_Simple_Return_Statement (Loc,
4487 Expression =>
4488 Make_Attribute_Reference (Loc,
4489 Prefix =>
4490 New_Occurrence_Of (
4491 Etype (Result_Definition (Spec)), Loc),
4493 Attribute_Name => Name_Input,
4495 Expressions => New_List (
4496 Make_Attribute_Reference (Loc,
4497 Prefix =>
4498 New_Occurrence_Of (Result_Parameter, Loc),
4499 Attribute_Name => Name_Access))))));
4501 else
4502 -- Loop around parameters and assign out (or in out)
4503 -- parameters. In the case of RACW, controlling arguments
4504 -- cannot possibly have changed since they are remote, so
4505 -- we do not read them from the stream.
4507 Current_Parameter := First (Ordered_Parameters_List);
4508 while Present (Current_Parameter) loop
4509 declare
4510 Typ : constant Node_Id :=
4511 Parameter_Type (Current_Parameter);
4512 Etyp : Entity_Id;
4513 Value : Node_Id;
4515 begin
4516 Value :=
4517 New_Occurrence_Of
4518 (Defining_Identifier (Current_Parameter), Loc);
4520 if Nkind (Typ) = N_Access_Definition then
4521 Value := Make_Explicit_Dereference (Loc, Value);
4522 Etyp := Etype (Subtype_Mark (Typ));
4523 else
4524 Etyp := Etype (Typ);
4525 end if;
4527 if (Out_Present (Current_Parameter)
4528 or else Nkind (Typ) = N_Access_Definition)
4529 and then Etyp /= Stub_Type
4530 then
4531 Append_To (Non_Asynchronous_Statements,
4532 Make_Attribute_Reference (Loc,
4533 Prefix =>
4534 New_Occurrence_Of (Etyp, Loc),
4536 Attribute_Name => Name_Read,
4538 Expressions => New_List (
4539 Make_Attribute_Reference (Loc,
4540 Prefix =>
4541 New_Occurrence_Of (Result_Parameter, Loc),
4542 Attribute_Name => Name_Access),
4543 Value)));
4544 end if;
4545 end;
4547 Next (Current_Parameter);
4548 end loop;
4549 end if;
4550 end if;
4552 if Is_Known_Asynchronous then
4553 Append_List_To (Statements, Asynchronous_Statements);
4555 elsif Is_Known_Non_Asynchronous then
4556 Append_List_To (Statements, Non_Asynchronous_Statements);
4558 else
4559 pragma Assert (Present (Asynchronous));
4560 Prepend_To (Asynchronous_Statements,
4561 Make_Attribute_Reference (Loc,
4562 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4563 Attribute_Name => Name_Write,
4564 Expressions => New_List (
4565 Make_Attribute_Reference (Loc,
4566 Prefix =>
4567 New_Occurrence_Of (Stream_Parameter, Loc),
4568 Attribute_Name => Name_Access),
4569 New_Occurrence_Of (Standard_True, Loc))));
4571 Prepend_To (Non_Asynchronous_Statements,
4572 Make_Attribute_Reference (Loc,
4573 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4574 Attribute_Name => Name_Write,
4575 Expressions => New_List (
4576 Make_Attribute_Reference (Loc,
4577 Prefix =>
4578 New_Occurrence_Of (Stream_Parameter, Loc),
4579 Attribute_Name => Name_Access),
4580 New_Occurrence_Of (Standard_False, Loc))));
4582 Append_To (Statements,
4583 Make_Implicit_If_Statement (Nod,
4584 Condition => Asynchronous,
4585 Then_Statements => Asynchronous_Statements,
4586 Else_Statements => Non_Asynchronous_Statements));
4587 end if;
4588 end Build_General_Calling_Stubs;
4590 -----------------------------
4591 -- Build_RPC_Receiver_Body --
4592 -----------------------------
4594 procedure Build_RPC_Receiver_Body
4595 (RPC_Receiver : Entity_Id;
4596 Request : out Entity_Id;
4597 Subp_Id : out Entity_Id;
4598 Subp_Index : out Entity_Id;
4599 Stmts : out List_Id;
4600 Decl : out Node_Id)
4602 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4604 RPC_Receiver_Spec : Node_Id;
4605 RPC_Receiver_Decls : List_Id;
4607 begin
4608 Request := Make_Defining_Identifier (Loc, Name_R);
4610 RPC_Receiver_Spec :=
4611 Build_RPC_Receiver_Specification
4612 (RPC_Receiver => RPC_Receiver,
4613 Request_Parameter => Request);
4615 Subp_Id := Make_Temporary (Loc, 'P');
4616 Subp_Index := Subp_Id;
4618 -- Subp_Id may not be a constant, because in the case of the RPC
4619 -- receiver for an RCI package, when a call is received from a RAS
4620 -- dereference, it will be assigned during subsequent processing.
4622 RPC_Receiver_Decls := New_List (
4623 Make_Object_Declaration (Loc,
4624 Defining_Identifier => Subp_Id,
4625 Object_Definition =>
4626 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4627 Expression =>
4628 Make_Attribute_Reference (Loc,
4629 Prefix =>
4630 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4631 Attribute_Name => Name_Input,
4632 Expressions => New_List (
4633 Make_Selected_Component (Loc,
4634 Prefix => Request,
4635 Selector_Name => Name_Params)))));
4637 Stmts := New_List;
4639 Decl :=
4640 Make_Subprogram_Body (Loc,
4641 Specification => RPC_Receiver_Spec,
4642 Declarations => RPC_Receiver_Decls,
4643 Handled_Statement_Sequence =>
4644 Make_Handled_Sequence_Of_Statements (Loc,
4645 Statements => Stmts));
4646 end Build_RPC_Receiver_Body;
4648 -----------------------
4649 -- Build_Stub_Target --
4650 -----------------------
4652 function Build_Stub_Target
4653 (Loc : Source_Ptr;
4654 Decls : List_Id;
4655 RCI_Locator : Entity_Id;
4656 Controlling_Parameter : Entity_Id) return RPC_Target
4658 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4660 begin
4661 Target_Info.Partition := Make_Temporary (Loc, 'P');
4663 if Present (Controlling_Parameter) then
4664 Append_To (Decls,
4665 Make_Object_Declaration (Loc,
4666 Defining_Identifier => Target_Info.Partition,
4667 Constant_Present => True,
4668 Object_Definition =>
4669 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4671 Expression =>
4672 Make_Selected_Component (Loc,
4673 Prefix => Controlling_Parameter,
4674 Selector_Name => Name_Origin)));
4676 Target_Info.RPC_Receiver :=
4677 Make_Selected_Component (Loc,
4678 Prefix => Controlling_Parameter,
4679 Selector_Name => Name_Receiver);
4681 else
4682 Append_To (Decls,
4683 Make_Object_Declaration (Loc,
4684 Defining_Identifier => Target_Info.Partition,
4685 Constant_Present => True,
4686 Object_Definition =>
4687 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4689 Expression =>
4690 Make_Function_Call (Loc,
4691 Name => Make_Selected_Component (Loc,
4692 Prefix =>
4693 Make_Identifier (Loc, Chars (RCI_Locator)),
4694 Selector_Name =>
4695 Make_Identifier (Loc,
4696 Name_Get_Active_Partition_ID)))));
4698 Target_Info.RPC_Receiver :=
4699 Make_Selected_Component (Loc,
4700 Prefix =>
4701 Make_Identifier (Loc, Chars (RCI_Locator)),
4702 Selector_Name =>
4703 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4704 end if;
4705 return Target_Info;
4706 end Build_Stub_Target;
4708 --------------------------------------
4709 -- Build_Subprogram_Receiving_Stubs --
4710 --------------------------------------
4712 function Build_Subprogram_Receiving_Stubs
4713 (Vis_Decl : Node_Id;
4714 Asynchronous : Boolean;
4715 Dynamically_Asynchronous : Boolean := False;
4716 Stub_Type : Entity_Id := Empty;
4717 RACW_Type : Entity_Id := Empty;
4718 Parent_Primitive : Entity_Id := Empty) return Node_Id
4720 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4722 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
4723 -- Formal parameter for receiving stubs: a descriptor for an incoming
4724 -- request.
4726 Decls : constant List_Id := New_List;
4727 -- All the parameters will get declared before calling the real
4728 -- subprograms. Also the out parameters will be declared.
4730 Statements : constant List_Id := New_List;
4732 Extra_Formal_Statements : constant List_Id := New_List;
4733 -- Statements concerning extra formal parameters
4735 After_Statements : constant List_Id := New_List;
4736 -- Statements to be executed after the subprogram call
4738 Inner_Decls : List_Id := No_List;
4739 -- In case of a function, the inner declarations are needed since
4740 -- the result may be unconstrained.
4742 Excep_Handlers : List_Id := No_List;
4743 Excep_Choice : Entity_Id;
4744 Excep_Code : List_Id;
4746 Parameter_List : constant List_Id := New_List;
4747 -- List of parameters to be passed to the subprogram
4749 Current_Parameter : Node_Id;
4751 Ordered_Parameters_List : constant List_Id :=
4752 Build_Ordered_Parameters_List
4753 (Specification (Vis_Decl));
4755 Subp_Spec : Node_Id;
4756 -- Subprogram specification
4758 Called_Subprogram : Node_Id;
4759 -- The subprogram to call
4761 Null_Raise_Statement : Node_Id;
4763 Dynamic_Async : Entity_Id;
4765 begin
4766 if Present (RACW_Type) then
4767 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4768 else
4769 Called_Subprogram :=
4770 New_Occurrence_Of
4771 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4772 end if;
4774 if Dynamically_Asynchronous then
4775 Dynamic_Async := Make_Temporary (Loc, 'S');
4776 else
4777 Dynamic_Async := Empty;
4778 end if;
4780 if not Asynchronous or Dynamically_Asynchronous then
4782 -- The first statement after the subprogram call is a statement to
4783 -- write a Null_Occurrence into the result stream.
4785 Null_Raise_Statement :=
4786 Make_Attribute_Reference (Loc,
4787 Prefix =>
4788 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4789 Attribute_Name => Name_Write,
4790 Expressions => New_List (
4791 Make_Selected_Component (Loc,
4792 Prefix => Request_Parameter,
4793 Selector_Name => Name_Result),
4794 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4796 if Dynamically_Asynchronous then
4797 Null_Raise_Statement :=
4798 Make_Implicit_If_Statement (Vis_Decl,
4799 Condition =>
4800 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4801 Then_Statements => New_List (Null_Raise_Statement));
4802 end if;
4804 Append_To (After_Statements, Null_Raise_Statement);
4805 end if;
4807 -- Loop through every parameter and get its value from the stream. If
4808 -- the parameter is unconstrained, then the parameter is read using
4809 -- 'Input at the point of declaration.
4811 Current_Parameter := First (Ordered_Parameters_List);
4812 while Present (Current_Parameter) loop
4813 declare
4814 Etyp : Entity_Id;
4815 Constrained : Boolean;
4817 Need_Extra_Constrained : Boolean;
4818 -- True when an Extra_Constrained actual is required
4820 Object : constant Entity_Id := Make_Temporary (Loc, 'P');
4822 Expr : Node_Id := Empty;
4824 Is_Controlling_Formal : constant Boolean :=
4825 Is_RACW_Controlling_Formal
4826 (Current_Parameter, Stub_Type);
4828 begin
4829 if Is_Controlling_Formal then
4831 -- We have a controlling formal parameter. Read its address
4832 -- rather than a real object. The address is in Unsigned_64
4833 -- form.
4835 Etyp := RTE (RE_Unsigned_64);
4836 else
4837 Etyp := Etype (Parameter_Type (Current_Parameter));
4838 end if;
4840 Constrained := not Transmit_As_Unconstrained (Etyp);
4842 if In_Present (Current_Parameter)
4843 or else not Out_Present (Current_Parameter)
4844 or else not Constrained
4845 or else Is_Controlling_Formal
4846 then
4847 -- If an input parameter is constrained, then the read of
4848 -- the parameter is deferred until the beginning of the
4849 -- subprogram body. If it is unconstrained, then an
4850 -- expression is built for the object declaration and the
4851 -- variable is set using 'Input instead of 'Read. Note that
4852 -- this deferral does not change the order in which the
4853 -- actuals are read because Build_Ordered_Parameter_List
4854 -- puts them unconstrained first.
4856 if Constrained then
4857 Append_To (Statements,
4858 Make_Attribute_Reference (Loc,
4859 Prefix => New_Occurrence_Of (Etyp, Loc),
4860 Attribute_Name => Name_Read,
4861 Expressions => New_List (
4862 Make_Selected_Component (Loc,
4863 Prefix => Request_Parameter,
4864 Selector_Name => Name_Params),
4865 New_Occurrence_Of (Object, Loc))));
4867 else
4869 -- Build and append Input_With_Tag_Check function
4871 Append_To (Decls,
4872 Input_With_Tag_Check (Loc,
4873 Var_Type => Etyp,
4874 Stream =>
4875 Make_Selected_Component (Loc,
4876 Prefix => Request_Parameter,
4877 Selector_Name => Name_Params)));
4879 -- Prepare function call expression
4881 Expr :=
4882 Make_Function_Call (Loc,
4883 Name =>
4884 New_Occurrence_Of
4885 (Defining_Unit_Name
4886 (Specification (Last (Decls))), Loc));
4887 end if;
4888 end if;
4890 Need_Extra_Constrained :=
4891 Nkind (Parameter_Type (Current_Parameter)) /=
4892 N_Access_Definition
4893 and then
4894 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4895 and then
4896 Present (Extra_Constrained
4897 (Defining_Identifier (Current_Parameter)));
4899 -- We may not associate an extra constrained actual to a
4900 -- constant object, so if one is needed, declare the actual
4901 -- as a variable even if it won't be modified.
4903 Build_Actual_Object_Declaration
4904 (Object => Object,
4905 Etyp => Etyp,
4906 Variable => Need_Extra_Constrained
4907 or else Out_Present (Current_Parameter),
4908 Expr => Expr,
4909 Decls => Decls);
4911 -- An out parameter may be written back using a 'Write
4912 -- attribute instead of a 'Output because it has been
4913 -- constrained by the parameter given to the caller. Note that
4914 -- out controlling arguments in the case of a RACW are not put
4915 -- back in the stream because the pointer on them has not
4916 -- changed.
4918 if Out_Present (Current_Parameter)
4919 and then
4920 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4921 then
4922 Append_To (After_Statements,
4923 Make_Attribute_Reference (Loc,
4924 Prefix => New_Occurrence_Of (Etyp, Loc),
4925 Attribute_Name => Name_Write,
4926 Expressions => New_List (
4927 Make_Selected_Component (Loc,
4928 Prefix => Request_Parameter,
4929 Selector_Name => Name_Result),
4930 New_Occurrence_Of (Object, Loc))));
4931 end if;
4933 -- For RACW controlling formals, the Etyp of Object is always
4934 -- an RACW, even if the parameter is not of an anonymous access
4935 -- type. In such case, we need to dereference it at call time.
4937 if Is_Controlling_Formal then
4938 if Nkind (Parameter_Type (Current_Parameter)) /=
4939 N_Access_Definition
4940 then
4941 Append_To (Parameter_List,
4942 Make_Parameter_Association (Loc,
4943 Selector_Name =>
4944 New_Occurrence_Of (
4945 Defining_Identifier (Current_Parameter), Loc),
4946 Explicit_Actual_Parameter =>
4947 Make_Explicit_Dereference (Loc,
4948 Unchecked_Convert_To (RACW_Type,
4949 OK_Convert_To (RTE (RE_Address),
4950 New_Occurrence_Of (Object, Loc))))));
4952 else
4953 Append_To (Parameter_List,
4954 Make_Parameter_Association (Loc,
4955 Selector_Name =>
4956 New_Occurrence_Of (
4957 Defining_Identifier (Current_Parameter), Loc),
4958 Explicit_Actual_Parameter =>
4959 Unchecked_Convert_To (RACW_Type,
4960 OK_Convert_To (RTE (RE_Address),
4961 New_Occurrence_Of (Object, Loc)))));
4962 end if;
4964 else
4965 Append_To (Parameter_List,
4966 Make_Parameter_Association (Loc,
4967 Selector_Name =>
4968 New_Occurrence_Of (
4969 Defining_Identifier (Current_Parameter), Loc),
4970 Explicit_Actual_Parameter =>
4971 New_Occurrence_Of (Object, Loc)));
4972 end if;
4974 -- If the current parameter needs an extra formal, then read it
4975 -- from the stream and set the corresponding semantic field in
4976 -- the variable. If the kind of the parameter identifier is
4977 -- E_Void, then this is a compiler generated parameter that
4978 -- doesn't need an extra constrained status.
4980 -- The case of Extra_Accessibility should also be handled ???
4982 if Need_Extra_Constrained then
4983 declare
4984 Extra_Parameter : constant Entity_Id :=
4985 Extra_Constrained
4986 (Defining_Identifier
4987 (Current_Parameter));
4989 Formal_Entity : constant Entity_Id :=
4990 Make_Defining_Identifier
4991 (Loc, Chars (Extra_Parameter));
4993 Formal_Type : constant Entity_Id :=
4994 Etype (Extra_Parameter);
4996 begin
4997 Append_To (Decls,
4998 Make_Object_Declaration (Loc,
4999 Defining_Identifier => Formal_Entity,
5000 Object_Definition =>
5001 New_Occurrence_Of (Formal_Type, Loc)));
5003 Append_To (Extra_Formal_Statements,
5004 Make_Attribute_Reference (Loc,
5005 Prefix => New_Occurrence_Of (
5006 Formal_Type, Loc),
5007 Attribute_Name => Name_Read,
5008 Expressions => New_List (
5009 Make_Selected_Component (Loc,
5010 Prefix => Request_Parameter,
5011 Selector_Name => Name_Params),
5012 New_Occurrence_Of (Formal_Entity, Loc))));
5014 -- Note: the call to Set_Extra_Constrained below relies
5015 -- on the fact that Object's Ekind has been set by
5016 -- Build_Actual_Object_Declaration.
5018 Set_Extra_Constrained (Object, Formal_Entity);
5019 end;
5020 end if;
5021 end;
5023 Next (Current_Parameter);
5024 end loop;
5026 -- Append the formal statements list at the end of regular statements
5028 Append_List_To (Statements, Extra_Formal_Statements);
5030 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
5032 -- The remote subprogram is a function. We build an inner block to
5033 -- be able to hold a potentially unconstrained result in a
5034 -- variable.
5036 declare
5037 Etyp : constant Entity_Id :=
5038 Etype (Result_Definition (Specification (Vis_Decl)));
5039 Result : constant Node_Id := Make_Temporary (Loc, 'R');
5041 begin
5042 Inner_Decls := New_List (
5043 Make_Object_Declaration (Loc,
5044 Defining_Identifier => Result,
5045 Constant_Present => True,
5046 Object_Definition => New_Occurrence_Of (Etyp, Loc),
5047 Expression =>
5048 Make_Function_Call (Loc,
5049 Name => Called_Subprogram,
5050 Parameter_Associations => Parameter_List)));
5052 if Is_Class_Wide_Type (Etyp) then
5054 -- For a remote call to a function with a class-wide type,
5055 -- check that the returned value satisfies the requirements
5056 -- of E.4(18).
5058 Append_To (Inner_Decls,
5059 Make_Transportable_Check (Loc,
5060 New_Occurrence_Of (Result, Loc)));
5062 end if;
5064 Append_To (After_Statements,
5065 Make_Attribute_Reference (Loc,
5066 Prefix => New_Occurrence_Of (Etyp, Loc),
5067 Attribute_Name => Name_Output,
5068 Expressions => New_List (
5069 Make_Selected_Component (Loc,
5070 Prefix => Request_Parameter,
5071 Selector_Name => Name_Result),
5072 New_Occurrence_Of (Result, Loc))));
5073 end;
5075 Append_To (Statements,
5076 Make_Block_Statement (Loc,
5077 Declarations => Inner_Decls,
5078 Handled_Statement_Sequence =>
5079 Make_Handled_Sequence_Of_Statements (Loc,
5080 Statements => After_Statements)));
5082 else
5083 -- The remote subprogram is a procedure. We do not need any inner
5084 -- block in this case.
5086 if Dynamically_Asynchronous then
5087 Append_To (Decls,
5088 Make_Object_Declaration (Loc,
5089 Defining_Identifier => Dynamic_Async,
5090 Object_Definition =>
5091 New_Occurrence_Of (Standard_Boolean, Loc)));
5093 Append_To (Statements,
5094 Make_Attribute_Reference (Loc,
5095 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5096 Attribute_Name => Name_Read,
5097 Expressions => New_List (
5098 Make_Selected_Component (Loc,
5099 Prefix => Request_Parameter,
5100 Selector_Name => Name_Params),
5101 New_Occurrence_Of (Dynamic_Async, Loc))));
5102 end if;
5104 Append_To (Statements,
5105 Make_Procedure_Call_Statement (Loc,
5106 Name => Called_Subprogram,
5107 Parameter_Associations => Parameter_List));
5109 Append_List_To (Statements, After_Statements);
5110 end if;
5112 if Asynchronous and then not Dynamically_Asynchronous then
5114 -- For an asynchronous procedure, add a null exception handler
5116 Excep_Handlers := New_List (
5117 Make_Implicit_Exception_Handler (Loc,
5118 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5119 Statements => New_List (Make_Null_Statement (Loc))));
5121 else
5122 -- In the other cases, if an exception is raised, then the
5123 -- exception occurrence is copied into the output stream and
5124 -- no other output parameter is written.
5126 Excep_Choice := Make_Temporary (Loc, 'E');
5128 Excep_Code := New_List (
5129 Make_Attribute_Reference (Loc,
5130 Prefix =>
5131 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5132 Attribute_Name => Name_Write,
5133 Expressions => New_List (
5134 Make_Selected_Component (Loc,
5135 Prefix => Request_Parameter,
5136 Selector_Name => Name_Result),
5137 New_Occurrence_Of (Excep_Choice, Loc))));
5139 if Dynamically_Asynchronous then
5140 Excep_Code := New_List (
5141 Make_Implicit_If_Statement (Vis_Decl,
5142 Condition => Make_Op_Not (Loc,
5143 New_Occurrence_Of (Dynamic_Async, Loc)),
5144 Then_Statements => Excep_Code));
5145 end if;
5147 Excep_Handlers := New_List (
5148 Make_Implicit_Exception_Handler (Loc,
5149 Choice_Parameter => Excep_Choice,
5150 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5151 Statements => Excep_Code));
5153 end if;
5155 Subp_Spec :=
5156 Make_Procedure_Specification (Loc,
5157 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
5159 Parameter_Specifications => New_List (
5160 Make_Parameter_Specification (Loc,
5161 Defining_Identifier => Request_Parameter,
5162 Parameter_Type =>
5163 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5165 return
5166 Make_Subprogram_Body (Loc,
5167 Specification => Subp_Spec,
5168 Declarations => Decls,
5169 Handled_Statement_Sequence =>
5170 Make_Handled_Sequence_Of_Statements (Loc,
5171 Statements => Statements,
5172 Exception_Handlers => Excep_Handlers));
5173 end Build_Subprogram_Receiving_Stubs;
5175 ------------
5176 -- Result --
5177 ------------
5179 function Result return Node_Id is
5180 begin
5181 return Make_Identifier (Loc, Name_V);
5182 end Result;
5184 -----------------------
5185 -- RPC_Receiver_Decl --
5186 -----------------------
5188 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is
5189 Loc : constant Source_Ptr := Sloc (RACW_Type);
5190 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5192 begin
5193 -- No RPC receiver for remote access-to-subprogram
5195 if Is_RAS then
5196 return Empty;
5197 end if;
5199 return
5200 Make_Subprogram_Declaration (Loc,
5201 Build_RPC_Receiver_Specification
5202 (RPC_Receiver => Make_Temporary (Loc, 'R'),
5203 Request_Parameter => Make_Defining_Identifier (Loc, Name_R)));
5204 end RPC_Receiver_Decl;
5206 ----------------------
5207 -- Stream_Parameter --
5208 ----------------------
5210 function Stream_Parameter return Node_Id is
5211 begin
5212 return Make_Identifier (Loc, Name_S);
5213 end Stream_Parameter;
5215 end GARLIC_Support;
5217 -------------------------------
5218 -- Get_And_Reset_RACW_Bodies --
5219 -------------------------------
5221 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5222 Desig : constant Entity_Id :=
5223 Etype (Designated_Type (RACW_Type));
5225 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5227 Body_Decls : List_Id;
5228 -- Returned list of declarations
5230 begin
5231 if Stub_Elements = Empty_Stub_Structure then
5233 -- Stub elements may be missing as a consequence of a previously
5234 -- detected error.
5236 return No_List;
5237 end if;
5239 Body_Decls := Stub_Elements.Body_Decls;
5240 Stub_Elements.Body_Decls := No_List;
5241 Stubs_Table.Set (Desig, Stub_Elements);
5242 return Body_Decls;
5243 end Get_And_Reset_RACW_Bodies;
5245 -----------------------
5246 -- Get_Stub_Elements --
5247 -----------------------
5249 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is
5250 Desig : constant Entity_Id :=
5251 Etype (Designated_Type (RACW_Type));
5252 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
5253 begin
5254 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5255 return Stub_Elements;
5256 end Get_Stub_Elements;
5258 -----------------------
5259 -- Get_Subprogram_Id --
5260 -----------------------
5262 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5263 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5264 begin
5265 pragma Assert (Result /= No_String);
5266 return Result;
5267 end Get_Subprogram_Id;
5269 -----------------------
5270 -- Get_Subprogram_Id --
5271 -----------------------
5273 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5274 begin
5275 return Get_Subprogram_Ids (Def).Int_Identifier;
5276 end Get_Subprogram_Id;
5278 ------------------------
5279 -- Get_Subprogram_Ids --
5280 ------------------------
5282 function Get_Subprogram_Ids
5283 (Def : Entity_Id) return Subprogram_Identifiers
5285 begin
5286 return Subprogram_Identifier_Table.Get (Def);
5287 end Get_Subprogram_Ids;
5289 ----------
5290 -- Hash --
5291 ----------
5293 function Hash (F : Entity_Id) return Hash_Index is
5294 begin
5295 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5296 end Hash;
5298 function Hash (F : Name_Id) return Hash_Index is
5299 begin
5300 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5301 end Hash;
5303 --------------------------
5304 -- Input_With_Tag_Check --
5305 --------------------------
5307 function Input_With_Tag_Check
5308 (Loc : Source_Ptr;
5309 Var_Type : Entity_Id;
5310 Stream : Node_Id) return Node_Id
5312 begin
5313 return
5314 Make_Subprogram_Body (Loc,
5315 Specification =>
5316 Make_Function_Specification (Loc,
5317 Defining_Unit_Name => Make_Temporary (Loc, 'S'),
5318 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5319 Declarations => No_List,
5320 Handled_Statement_Sequence =>
5321 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5322 Make_Tag_Check (Loc,
5323 Make_Simple_Return_Statement (Loc,
5324 Make_Attribute_Reference (Loc,
5325 Prefix => New_Occurrence_Of (Var_Type, Loc),
5326 Attribute_Name => Name_Input,
5327 Expressions =>
5328 New_List (Stream)))))));
5329 end Input_With_Tag_Check;
5331 --------------------------------
5332 -- Is_RACW_Controlling_Formal --
5333 --------------------------------
5335 function Is_RACW_Controlling_Formal
5336 (Parameter : Node_Id;
5337 Stub_Type : Entity_Id) return Boolean
5339 Typ : Entity_Id;
5341 begin
5342 -- If the kind of the parameter is E_Void, then it is not a controlling
5343 -- formal (this can happen in the context of RAS).
5345 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5346 return False;
5347 end if;
5349 -- If the parameter is not a controlling formal, then it cannot be
5350 -- possibly a RACW_Controlling_Formal.
5352 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5353 return False;
5354 end if;
5356 Typ := Parameter_Type (Parameter);
5357 return (Nkind (Typ) = N_Access_Definition
5358 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5359 or else Etype (Typ) = Stub_Type;
5360 end Is_RACW_Controlling_Formal;
5362 ------------------------------
5363 -- Make_Transportable_Check --
5364 ------------------------------
5366 function Make_Transportable_Check
5367 (Loc : Source_Ptr;
5368 Expr : Node_Id) return Node_Id is
5369 begin
5370 return
5371 Make_Raise_Program_Error (Loc,
5372 Condition =>
5373 Make_Op_Not (Loc,
5374 Build_Get_Transportable (Loc,
5375 Make_Selected_Component (Loc,
5376 Prefix => Expr,
5377 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5378 Reason => PE_Non_Transportable_Actual);
5379 end Make_Transportable_Check;
5381 -----------------------------
5382 -- Make_Selected_Component --
5383 -----------------------------
5385 function Make_Selected_Component
5386 (Loc : Source_Ptr;
5387 Prefix : Entity_Id;
5388 Selector_Name : Name_Id) return Node_Id
5390 begin
5391 return Make_Selected_Component (Loc,
5392 Prefix => New_Occurrence_Of (Prefix, Loc),
5393 Selector_Name => Make_Identifier (Loc, Selector_Name));
5394 end Make_Selected_Component;
5396 --------------------
5397 -- Make_Tag_Check --
5398 --------------------
5400 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5401 Occ : constant Entity_Id := Make_Temporary (Loc, 'E');
5403 begin
5404 return Make_Block_Statement (Loc,
5405 Handled_Statement_Sequence =>
5406 Make_Handled_Sequence_Of_Statements (Loc,
5407 Statements => New_List (N),
5409 Exception_Handlers => New_List (
5410 Make_Implicit_Exception_Handler (Loc,
5411 Choice_Parameter => Occ,
5413 Exception_Choices =>
5414 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5416 Statements =>
5417 New_List (Make_Procedure_Call_Statement (Loc,
5418 New_Occurrence_Of
5419 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5420 New_List (New_Occurrence_Of (Occ, Loc))))))));
5421 end Make_Tag_Check;
5423 ----------------------------
5424 -- Need_Extra_Constrained --
5425 ----------------------------
5427 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5428 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5429 begin
5430 return Out_Present (Parameter)
5431 and then Has_Discriminants (Etyp)
5432 and then not Is_Constrained (Etyp)
5433 and then not Is_Indefinite_Subtype (Etyp);
5434 end Need_Extra_Constrained;
5436 ------------------------------------
5437 -- Pack_Entity_Into_Stream_Access --
5438 ------------------------------------
5440 function Pack_Entity_Into_Stream_Access
5441 (Loc : Source_Ptr;
5442 Stream : Node_Id;
5443 Object : Entity_Id;
5444 Etyp : Entity_Id := Empty) return Node_Id
5446 Typ : Entity_Id;
5448 begin
5449 if Present (Etyp) then
5450 Typ := Etyp;
5451 else
5452 Typ := Etype (Object);
5453 end if;
5455 return
5456 Pack_Node_Into_Stream_Access (Loc,
5457 Stream => Stream,
5458 Object => New_Occurrence_Of (Object, Loc),
5459 Etyp => Typ);
5460 end Pack_Entity_Into_Stream_Access;
5462 ---------------------------
5463 -- Pack_Node_Into_Stream --
5464 ---------------------------
5466 function Pack_Node_Into_Stream
5467 (Loc : Source_Ptr;
5468 Stream : Entity_Id;
5469 Object : Node_Id;
5470 Etyp : Entity_Id) return Node_Id
5472 Write_Attribute : Name_Id := Name_Write;
5474 begin
5475 if not Is_Constrained (Etyp) then
5476 Write_Attribute := Name_Output;
5477 end if;
5479 return
5480 Make_Attribute_Reference (Loc,
5481 Prefix => New_Occurrence_Of (Etyp, Loc),
5482 Attribute_Name => Write_Attribute,
5483 Expressions => New_List (
5484 Make_Attribute_Reference (Loc,
5485 Prefix => New_Occurrence_Of (Stream, Loc),
5486 Attribute_Name => Name_Access),
5487 Object));
5488 end Pack_Node_Into_Stream;
5490 ----------------------------------
5491 -- Pack_Node_Into_Stream_Access --
5492 ----------------------------------
5494 function Pack_Node_Into_Stream_Access
5495 (Loc : Source_Ptr;
5496 Stream : Node_Id;
5497 Object : Node_Id;
5498 Etyp : Entity_Id) return Node_Id
5500 Write_Attribute : Name_Id := Name_Write;
5502 begin
5503 if not Is_Constrained (Etyp) then
5504 Write_Attribute := Name_Output;
5505 end if;
5507 return
5508 Make_Attribute_Reference (Loc,
5509 Prefix => New_Occurrence_Of (Etyp, Loc),
5510 Attribute_Name => Write_Attribute,
5511 Expressions => New_List (
5512 Stream,
5513 Object));
5514 end Pack_Node_Into_Stream_Access;
5516 ---------------------
5517 -- PolyORB_Support --
5518 ---------------------
5520 package body PolyORB_Support is
5522 -- Local subprograms
5524 procedure Add_RACW_Read_Attribute
5525 (RACW_Type : Entity_Id;
5526 Stub_Type : Entity_Id;
5527 Stub_Type_Access : Entity_Id;
5528 Body_Decls : List_Id);
5529 -- Add Read attribute for the RACW type. The declaration and attribute
5530 -- definition clauses are inserted right after the declaration of
5531 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5532 -- appended to it (case where the RACW declaration is in the main unit).
5534 procedure Add_RACW_Write_Attribute
5535 (RACW_Type : Entity_Id;
5536 Stub_Type : Entity_Id;
5537 Stub_Type_Access : Entity_Id;
5538 Body_Decls : List_Id);
5539 -- Same as above for the Write attribute
5541 procedure Add_RACW_From_Any
5542 (RACW_Type : Entity_Id;
5543 Body_Decls : List_Id);
5544 -- Add the From_Any TSS for this RACW type
5546 procedure Add_RACW_To_Any
5547 (RACW_Type : Entity_Id;
5548 Body_Decls : List_Id);
5549 -- Add the To_Any TSS for this RACW type
5551 procedure Add_RACW_TypeCode
5552 (Designated_Type : Entity_Id;
5553 RACW_Type : Entity_Id;
5554 Body_Decls : List_Id);
5555 -- Add the TypeCode TSS for this RACW type
5557 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5558 -- Add the From_Any TSS for this RAS type
5560 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5561 -- Add the To_Any TSS for this RAS type
5563 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5564 -- Add the TypeCode TSS for this RAS type
5566 procedure Add_RAS_Access_TSS (N : Node_Id);
5567 -- Add a subprogram body for RAS Access TSS
5569 -------------------------------------
5570 -- Add_Obj_RPC_Receiver_Completion --
5571 -------------------------------------
5573 procedure Add_Obj_RPC_Receiver_Completion
5574 (Loc : Source_Ptr;
5575 Decls : List_Id;
5576 RPC_Receiver : Entity_Id;
5577 Stub_Elements : Stub_Structure)
5579 Desig : constant Entity_Id :=
5580 Etype (Designated_Type (Stub_Elements.RACW_Type));
5581 begin
5582 Append_To (Decls,
5583 Make_Procedure_Call_Statement (Loc,
5584 Name =>
5585 New_Occurrence_Of (
5586 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5588 Parameter_Associations => New_List (
5590 -- Name
5592 Make_String_Literal (Loc,
5593 Fully_Qualified_Name_String (Desig, Append_NUL => False)),
5595 -- Handler
5597 Make_Attribute_Reference (Loc,
5598 Prefix =>
5599 New_Occurrence_Of (
5600 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5601 Attribute_Name =>
5602 Name_Access),
5604 -- Receiver
5606 Make_Attribute_Reference (Loc,
5607 Prefix =>
5608 New_Occurrence_Of (
5609 Defining_Identifier (
5610 Stub_Elements.RPC_Receiver_Decl), Loc),
5611 Attribute_Name =>
5612 Name_Access))));
5613 end Add_Obj_RPC_Receiver_Completion;
5615 -----------------------
5616 -- Add_RACW_Features --
5617 -----------------------
5619 procedure Add_RACW_Features
5620 (RACW_Type : Entity_Id;
5621 Desig : Entity_Id;
5622 Stub_Type : Entity_Id;
5623 Stub_Type_Access : Entity_Id;
5624 RPC_Receiver_Decl : Node_Id;
5625 Body_Decls : List_Id)
5627 pragma Unreferenced (RPC_Receiver_Decl);
5629 begin
5630 Add_RACW_From_Any
5631 (RACW_Type => RACW_Type,
5632 Body_Decls => Body_Decls);
5634 Add_RACW_To_Any
5635 (RACW_Type => RACW_Type,
5636 Body_Decls => Body_Decls);
5638 Add_RACW_Write_Attribute
5639 (RACW_Type => RACW_Type,
5640 Stub_Type => Stub_Type,
5641 Stub_Type_Access => Stub_Type_Access,
5642 Body_Decls => Body_Decls);
5644 Add_RACW_Read_Attribute
5645 (RACW_Type => RACW_Type,
5646 Stub_Type => Stub_Type,
5647 Stub_Type_Access => Stub_Type_Access,
5648 Body_Decls => Body_Decls);
5650 Add_RACW_TypeCode
5651 (Designated_Type => Desig,
5652 RACW_Type => RACW_Type,
5653 Body_Decls => Body_Decls);
5654 end Add_RACW_Features;
5656 -----------------------
5657 -- Add_RACW_From_Any --
5658 -----------------------
5660 procedure Add_RACW_From_Any
5661 (RACW_Type : Entity_Id;
5662 Body_Decls : List_Id)
5664 Loc : constant Source_Ptr := Sloc (RACW_Type);
5665 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5666 Fnam : constant Entity_Id :=
5667 Make_Defining_Identifier (Loc,
5668 Chars => New_External_Name (Chars (RACW_Type), 'F'));
5670 Func_Spec : Node_Id;
5671 Func_Decl : Node_Id;
5672 Func_Body : Node_Id;
5674 Statements : List_Id;
5675 -- Various parts of the subprogram
5677 Any_Parameter : constant Entity_Id :=
5678 Make_Defining_Identifier (Loc, Name_A);
5680 Asynchronous_Flag : constant Entity_Id :=
5681 Asynchronous_Flags_Table.Get (RACW_Type);
5682 -- The flag object declared in Add_RACW_Asynchronous_Flag
5684 begin
5685 Func_Spec :=
5686 Make_Function_Specification (Loc,
5687 Defining_Unit_Name =>
5688 Fnam,
5689 Parameter_Specifications => New_List (
5690 Make_Parameter_Specification (Loc,
5691 Defining_Identifier =>
5692 Any_Parameter,
5693 Parameter_Type =>
5694 New_Occurrence_Of (RTE (RE_Any), Loc))),
5695 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5697 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5698 -- entity in the declaration spec, not those of the body spec.
5700 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5701 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5702 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5704 if No (Body_Decls) then
5705 return;
5706 end if;
5708 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5709 -- set on the stub type if, and only if, the RACW type has a pragma
5710 -- Asynchronous. This is incorrect for RACWs that implement RAS
5711 -- types, because in that case the /designated subprogram/ (not the
5712 -- type) might be asynchronous, and that causes the stub to need to
5713 -- be asynchronous too. A solution is to transport a RAS as a struct
5714 -- containing a RACW and an asynchronous flag, and to properly alter
5715 -- the Asynchronous component in the stub type in the RAS's _From_Any
5716 -- TSS.
5718 Statements := New_List (
5719 Make_Simple_Return_Statement (Loc,
5720 Expression => Unchecked_Convert_To (RACW_Type,
5721 Make_Function_Call (Loc,
5722 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5723 Parameter_Associations => New_List (
5724 Make_Function_Call (Loc,
5725 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5726 Parameter_Associations => New_List (
5727 New_Occurrence_Of (Any_Parameter, Loc))),
5728 Build_Stub_Tag (Loc, RACW_Type),
5729 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5730 New_Occurrence_Of (Asynchronous_Flag, Loc))))));
5732 Func_Body :=
5733 Make_Subprogram_Body (Loc,
5734 Specification => Copy_Specification (Loc, Func_Spec),
5735 Declarations => No_List,
5736 Handled_Statement_Sequence =>
5737 Make_Handled_Sequence_Of_Statements (Loc,
5738 Statements => Statements));
5740 Append_To (Body_Decls, Func_Body);
5741 end Add_RACW_From_Any;
5743 -----------------------------
5744 -- Add_RACW_Read_Attribute --
5745 -----------------------------
5747 procedure Add_RACW_Read_Attribute
5748 (RACW_Type : Entity_Id;
5749 Stub_Type : Entity_Id;
5750 Stub_Type_Access : Entity_Id;
5751 Body_Decls : List_Id)
5753 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5755 Loc : constant Source_Ptr := Sloc (RACW_Type);
5757 Proc_Decl : Node_Id;
5758 Attr_Decl : Node_Id;
5760 Body_Node : Node_Id;
5762 Decls : constant List_Id := New_List;
5763 Statements : constant List_Id := New_List;
5764 Reference : constant Entity_Id :=
5765 Make_Defining_Identifier (Loc, Name_R);
5766 -- Various parts of the procedure
5768 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
5770 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5772 Asynchronous_Flag : constant Entity_Id :=
5773 Asynchronous_Flags_Table.Get (RACW_Type);
5774 pragma Assert (Present (Asynchronous_Flag));
5776 function Stream_Parameter return Node_Id;
5777 function Result return Node_Id;
5779 -- Functions to create occurrences of the formal parameter names
5781 ------------
5782 -- Result --
5783 ------------
5785 function Result return Node_Id is
5786 begin
5787 return Make_Identifier (Loc, Name_V);
5788 end Result;
5790 ----------------------
5791 -- Stream_Parameter --
5792 ----------------------
5794 function Stream_Parameter return Node_Id is
5795 begin
5796 return Make_Identifier (Loc, Name_S);
5797 end Stream_Parameter;
5799 -- Start of processing for Add_RACW_Read_Attribute
5801 begin
5802 Build_Stream_Procedure
5803 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
5805 Proc_Decl := Make_Subprogram_Declaration (Loc,
5806 Copy_Specification (Loc, Specification (Body_Node)));
5808 Attr_Decl :=
5809 Make_Attribute_Definition_Clause (Loc,
5810 Name => New_Occurrence_Of (RACW_Type, Loc),
5811 Chars => Name_Read,
5812 Expression =>
5813 New_Occurrence_Of (
5814 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5816 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5817 Insert_After (Proc_Decl, Attr_Decl);
5819 if No (Body_Decls) then
5820 return;
5821 end if;
5823 Append_To (Decls,
5824 Make_Object_Declaration (Loc,
5825 Defining_Identifier =>
5826 Reference,
5827 Object_Definition =>
5828 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5830 Append_List_To (Statements, New_List (
5831 Make_Attribute_Reference (Loc,
5832 Prefix =>
5833 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5834 Attribute_Name => Name_Read,
5835 Expressions => New_List (
5836 Stream_Parameter,
5837 New_Occurrence_Of (Reference, Loc))),
5839 Make_Assignment_Statement (Loc,
5840 Name =>
5841 Result,
5842 Expression =>
5843 Unchecked_Convert_To (RACW_Type,
5844 Make_Function_Call (Loc,
5845 Name =>
5846 New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5847 Parameter_Associations => New_List (
5848 New_Occurrence_Of (Reference, Loc),
5849 Build_Stub_Tag (Loc, RACW_Type),
5850 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5851 New_Occurrence_Of (Asynchronous_Flag, Loc)))))));
5853 Set_Declarations (Body_Node, Decls);
5854 Append_To (Body_Decls, Body_Node);
5855 end Add_RACW_Read_Attribute;
5857 ---------------------
5858 -- Add_RACW_To_Any --
5859 ---------------------
5861 procedure Add_RACW_To_Any
5862 (RACW_Type : Entity_Id;
5863 Body_Decls : List_Id)
5865 Loc : constant Source_Ptr := Sloc (RACW_Type);
5867 Fnam : constant Entity_Id :=
5868 Make_Defining_Identifier (Loc,
5869 Chars => New_External_Name (Chars (RACW_Type), 'T'));
5871 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5873 Stub_Elements : constant Stub_Structure :=
5874 Get_Stub_Elements (RACW_Type);
5876 Func_Spec : Node_Id;
5877 Func_Decl : Node_Id;
5878 Func_Body : Node_Id;
5880 Decls : List_Id;
5881 Statements : List_Id;
5882 -- Various parts of the subprogram
5884 RACW_Parameter : constant Entity_Id :=
5885 Make_Defining_Identifier (Loc, Name_R);
5887 Reference : constant Entity_Id := Make_Temporary (Loc, 'R');
5888 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
5890 begin
5891 Func_Spec :=
5892 Make_Function_Specification (Loc,
5893 Defining_Unit_Name =>
5894 Fnam,
5895 Parameter_Specifications => New_List (
5896 Make_Parameter_Specification (Loc,
5897 Defining_Identifier =>
5898 RACW_Parameter,
5899 Parameter_Type =>
5900 New_Occurrence_Of (RACW_Type, Loc))),
5901 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5903 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5904 -- entity in the declaration spec, not in the body spec.
5906 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5908 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5909 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5911 if No (Body_Decls) then
5912 return;
5913 end if;
5915 -- Generate:
5917 -- R : constant Object_Ref :=
5918 -- Get_Reference
5919 -- (Address!(RACW),
5920 -- "typ",
5921 -- Stub_Type'Tag,
5922 -- Is_RAS,
5923 -- RPC_Receiver'Access);
5924 -- A : Any;
5926 Decls := New_List (
5927 Make_Object_Declaration (Loc,
5928 Defining_Identifier => Reference,
5929 Constant_Present => True,
5930 Object_Definition =>
5931 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5932 Expression =>
5933 Make_Function_Call (Loc,
5934 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5935 Parameter_Associations => New_List (
5936 Unchecked_Convert_To (RTE (RE_Address),
5937 New_Occurrence_Of (RACW_Parameter, Loc)),
5938 Make_String_Literal (Loc,
5939 Strval => Fully_Qualified_Name_String
5940 (Etype (Designated_Type (RACW_Type)),
5941 Append_NUL => False)),
5942 Build_Stub_Tag (Loc, RACW_Type),
5943 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5944 Make_Attribute_Reference (Loc,
5945 Prefix =>
5946 New_Occurrence_Of
5947 (Defining_Identifier
5948 (Stub_Elements.RPC_Receiver_Decl), Loc),
5949 Attribute_Name => Name_Access)))),
5951 Make_Object_Declaration (Loc,
5952 Defining_Identifier => Any,
5953 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)));
5955 -- Generate:
5957 -- Any := TA_ObjRef (Reference);
5958 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5959 -- return Any;
5961 Statements := New_List (
5962 Make_Assignment_Statement (Loc,
5963 Name => New_Occurrence_Of (Any, Loc),
5964 Expression =>
5965 Make_Function_Call (Loc,
5966 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5967 Parameter_Associations => New_List (
5968 New_Occurrence_Of (Reference, Loc)))),
5970 Make_Procedure_Call_Statement (Loc,
5971 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5972 Parameter_Associations => New_List (
5973 New_Occurrence_Of (Any, Loc),
5974 Make_Selected_Component (Loc,
5975 Prefix =>
5976 Defining_Identifier (
5977 Stub_Elements.RPC_Receiver_Decl),
5978 Selector_Name => Name_Obj_TypeCode))),
5980 Make_Simple_Return_Statement (Loc,
5981 Expression => New_Occurrence_Of (Any, Loc)));
5983 Func_Body :=
5984 Make_Subprogram_Body (Loc,
5985 Specification => Copy_Specification (Loc, Func_Spec),
5986 Declarations => Decls,
5987 Handled_Statement_Sequence =>
5988 Make_Handled_Sequence_Of_Statements (Loc,
5989 Statements => Statements));
5990 Append_To (Body_Decls, Func_Body);
5991 end Add_RACW_To_Any;
5993 -----------------------
5994 -- Add_RACW_TypeCode --
5995 -----------------------
5997 procedure Add_RACW_TypeCode
5998 (Designated_Type : Entity_Id;
5999 RACW_Type : Entity_Id;
6000 Body_Decls : List_Id)
6002 Loc : constant Source_Ptr := Sloc (RACW_Type);
6004 Fnam : constant Entity_Id :=
6005 Make_Defining_Identifier (Loc,
6006 Chars => New_External_Name (Chars (RACW_Type), 'Y'));
6008 Stub_Elements : constant Stub_Structure :=
6009 Stubs_Table.Get (Designated_Type);
6010 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6012 Func_Spec : Node_Id;
6013 Func_Decl : Node_Id;
6014 Func_Body : Node_Id;
6016 begin
6017 -- The spec for this subprogram has a dummy 'access RACW' argument,
6018 -- which serves only for overloading purposes.
6020 Func_Spec :=
6021 Make_Function_Specification (Loc,
6022 Defining_Unit_Name => Fnam,
6023 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6025 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6026 -- entity in the declaration spec, not those of the body spec.
6028 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6029 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6030 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6032 if No (Body_Decls) then
6033 return;
6034 end if;
6036 Func_Body :=
6037 Make_Subprogram_Body (Loc,
6038 Specification => Copy_Specification (Loc, Func_Spec),
6039 Declarations => Empty_List,
6040 Handled_Statement_Sequence =>
6041 Make_Handled_Sequence_Of_Statements (Loc,
6042 Statements => New_List (
6043 Make_Simple_Return_Statement (Loc,
6044 Expression =>
6045 Make_Selected_Component (Loc,
6046 Prefix =>
6047 Defining_Identifier
6048 (Stub_Elements.RPC_Receiver_Decl),
6049 Selector_Name => Name_Obj_TypeCode)))));
6051 Append_To (Body_Decls, Func_Body);
6052 end Add_RACW_TypeCode;
6054 ------------------------------
6055 -- Add_RACW_Write_Attribute --
6056 ------------------------------
6058 procedure Add_RACW_Write_Attribute
6059 (RACW_Type : Entity_Id;
6060 Stub_Type : Entity_Id;
6061 Stub_Type_Access : Entity_Id;
6062 Body_Decls : List_Id)
6064 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6066 Loc : constant Source_Ptr := Sloc (RACW_Type);
6068 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
6070 Stub_Elements : constant Stub_Structure :=
6071 Get_Stub_Elements (RACW_Type);
6073 Body_Node : Node_Id;
6074 Proc_Decl : Node_Id;
6075 Attr_Decl : Node_Id;
6077 Statements : constant List_Id := New_List;
6078 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
6080 function Stream_Parameter return Node_Id;
6081 function Object return Node_Id;
6082 -- Functions to create occurrences of the formal parameter names
6084 ------------
6085 -- Object --
6086 ------------
6088 function Object return Node_Id is
6089 begin
6090 return Make_Identifier (Loc, Name_V);
6091 end Object;
6093 ----------------------
6094 -- Stream_Parameter --
6095 ----------------------
6097 function Stream_Parameter return Node_Id is
6098 begin
6099 return Make_Identifier (Loc, Name_S);
6100 end Stream_Parameter;
6102 -- Start of processing for Add_RACW_Write_Attribute
6104 begin
6105 Build_Stream_Procedure
6106 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
6108 Proc_Decl :=
6109 Make_Subprogram_Declaration (Loc,
6110 Copy_Specification (Loc, Specification (Body_Node)));
6112 Attr_Decl :=
6113 Make_Attribute_Definition_Clause (Loc,
6114 Name => New_Occurrence_Of (RACW_Type, Loc),
6115 Chars => Name_Write,
6116 Expression =>
6117 New_Occurrence_Of (
6118 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6120 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6121 Insert_After (Proc_Decl, Attr_Decl);
6123 if No (Body_Decls) then
6124 return;
6125 end if;
6127 Append_To (Statements,
6128 Pack_Node_Into_Stream_Access (Loc,
6129 Stream => Stream_Parameter,
6130 Object =>
6131 Make_Function_Call (Loc,
6132 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6133 Parameter_Associations => New_List (
6134 Unchecked_Convert_To (RTE (RE_Address), Object),
6135 Make_String_Literal (Loc,
6136 Strval => Fully_Qualified_Name_String
6137 (Etype (Designated_Type (RACW_Type)),
6138 Append_NUL => False)),
6139 Build_Stub_Tag (Loc, RACW_Type),
6140 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
6141 Make_Attribute_Reference (Loc,
6142 Prefix =>
6143 New_Occurrence_Of
6144 (Defining_Identifier
6145 (Stub_Elements.RPC_Receiver_Decl), Loc),
6146 Attribute_Name => Name_Access))),
6148 Etyp => RTE (RE_Object_Ref)));
6150 Append_To (Body_Decls, Body_Node);
6151 end Add_RACW_Write_Attribute;
6153 -----------------------
6154 -- Add_RAST_Features --
6155 -----------------------
6157 procedure Add_RAST_Features
6158 (Vis_Decl : Node_Id;
6159 RAS_Type : Entity_Id)
6161 begin
6162 Add_RAS_Access_TSS (Vis_Decl);
6164 Add_RAS_From_Any (RAS_Type);
6165 Add_RAS_TypeCode (RAS_Type);
6167 -- To_Any uses TypeCode, and therefore needs to be generated last
6169 Add_RAS_To_Any (RAS_Type);
6170 end Add_RAST_Features;
6172 ------------------------
6173 -- Add_RAS_Access_TSS --
6174 ------------------------
6176 procedure Add_RAS_Access_TSS (N : Node_Id) is
6177 Loc : constant Source_Ptr := Sloc (N);
6179 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6180 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6181 -- Ras_Type is the access to subprogram type; Fat_Type is the
6182 -- corresponding record type.
6184 RACW_Type : constant Entity_Id :=
6185 Underlying_RACW_Type (Ras_Type);
6187 Stub_Elements : constant Stub_Structure :=
6188 Get_Stub_Elements (RACW_Type);
6190 Proc : constant Entity_Id :=
6191 Make_Defining_Identifier (Loc,
6192 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6194 Proc_Spec : Node_Id;
6196 -- Formal parameters
6198 Package_Name : constant Entity_Id :=
6199 Make_Defining_Identifier (Loc,
6200 Chars => Name_P);
6202 -- Target package
6204 Subp_Id : constant Entity_Id :=
6205 Make_Defining_Identifier (Loc,
6206 Chars => Name_S);
6208 -- Target subprogram
6210 Asynch_P : constant Entity_Id :=
6211 Make_Defining_Identifier (Loc,
6212 Chars => Name_Asynchronous);
6213 -- Is the procedure to which the 'Access applies asynchronous?
6215 All_Calls_Remote : constant Entity_Id :=
6216 Make_Defining_Identifier (Loc,
6217 Chars => Name_All_Calls_Remote);
6218 -- True if an All_Calls_Remote pragma applies to the RCI unit
6219 -- that contains the subprogram.
6221 -- Common local variables
6223 Proc_Decls : List_Id;
6224 Proc_Statements : List_Id;
6226 Subp_Ref : constant Entity_Id :=
6227 Make_Defining_Identifier (Loc, Name_R);
6228 -- Reference that designates the target subprogram (returned
6229 -- by Get_RAS_Info).
6231 Is_Local : constant Entity_Id :=
6232 Make_Defining_Identifier (Loc, Name_L);
6233 Local_Addr : constant Entity_Id :=
6234 Make_Defining_Identifier (Loc, Name_A);
6235 -- For the call to Get_Local_Address
6237 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
6238 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
6239 -- Additional local variables for the remote case
6241 function Set_Field
6242 (Field_Name : Name_Id;
6243 Value : Node_Id) return Node_Id;
6244 -- Construct an assignment that sets the named component in the
6245 -- returned record
6247 ---------------
6248 -- Set_Field --
6249 ---------------
6251 function Set_Field
6252 (Field_Name : Name_Id;
6253 Value : Node_Id) return Node_Id
6255 begin
6256 return
6257 Make_Assignment_Statement (Loc,
6258 Name =>
6259 Make_Selected_Component (Loc,
6260 Prefix => Stub_Ptr,
6261 Selector_Name => Field_Name),
6262 Expression => Value);
6263 end Set_Field;
6265 -- Start of processing for Add_RAS_Access_TSS
6267 begin
6268 Proc_Decls := New_List (
6270 -- Common declarations
6272 Make_Object_Declaration (Loc,
6273 Defining_Identifier => Subp_Ref,
6274 Object_Definition =>
6275 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6277 Make_Object_Declaration (Loc,
6278 Defining_Identifier => Is_Local,
6279 Object_Definition =>
6280 New_Occurrence_Of (Standard_Boolean, Loc)),
6282 Make_Object_Declaration (Loc,
6283 Defining_Identifier => Local_Addr,
6284 Object_Definition =>
6285 New_Occurrence_Of (RTE (RE_Address), Loc)),
6287 Make_Object_Declaration (Loc,
6288 Defining_Identifier => Local_Stub,
6289 Aliased_Present => True,
6290 Object_Definition =>
6291 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6293 Make_Object_Declaration (Loc,
6294 Defining_Identifier => Stub_Ptr,
6295 Object_Definition =>
6296 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6297 Expression =>
6298 Make_Attribute_Reference (Loc,
6299 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6300 Attribute_Name => Name_Unchecked_Access)));
6302 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6303 -- Build_Get_Unique_RP_Call needs this information
6305 -- Get_RAS_Info (Pkg, Subp, R);
6306 -- Obtain a reference to the target subprogram
6308 Proc_Statements := New_List (
6309 Make_Procedure_Call_Statement (Loc,
6310 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6311 Parameter_Associations => New_List (
6312 New_Occurrence_Of (Package_Name, Loc),
6313 New_Occurrence_Of (Subp_Id, Loc),
6314 New_Occurrence_Of (Subp_Ref, Loc))),
6316 -- Get_Local_Address (R, L, A);
6317 -- Determine whether the subprogram is local (L), and if so
6318 -- obtain the local address of its proxy (A).
6320 Make_Procedure_Call_Statement (Loc,
6321 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6322 Parameter_Associations => New_List (
6323 New_Occurrence_Of (Subp_Ref, Loc),
6324 New_Occurrence_Of (Is_Local, Loc),
6325 New_Occurrence_Of (Local_Addr, Loc))));
6327 -- Note: Here we assume that the Fat_Type is a record containing just
6328 -- an access to a proxy or stub object.
6330 Append_To (Proc_Statements,
6332 -- if L then
6334 Make_Implicit_If_Statement (N,
6335 Condition => New_Occurrence_Of (Is_Local, Loc),
6337 Then_Statements => New_List (
6339 -- if A.Target = null then
6341 Make_Implicit_If_Statement (N,
6342 Condition =>
6343 Make_Op_Eq (Loc,
6344 Make_Selected_Component (Loc,
6345 Prefix =>
6346 Unchecked_Convert_To
6347 (RTE (RE_RAS_Proxy_Type_Access),
6348 New_Occurrence_Of (Local_Addr, Loc)),
6349 Selector_Name => Make_Identifier (Loc, Name_Target)),
6350 Make_Null (Loc)),
6352 Then_Statements => New_List (
6354 -- A.Target := Entity_Of (Ref);
6356 Make_Assignment_Statement (Loc,
6357 Name =>
6358 Make_Selected_Component (Loc,
6359 Prefix =>
6360 Unchecked_Convert_To
6361 (RTE (RE_RAS_Proxy_Type_Access),
6362 New_Occurrence_Of (Local_Addr, Loc)),
6363 Selector_Name => Make_Identifier (Loc, Name_Target)),
6364 Expression =>
6365 Make_Function_Call (Loc,
6366 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6367 Parameter_Associations => New_List (
6368 New_Occurrence_Of (Subp_Ref, Loc)))),
6370 -- Inc_Usage (A.Target);
6371 -- end if;
6373 Make_Procedure_Call_Statement (Loc,
6374 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6375 Parameter_Associations => New_List (
6376 Make_Selected_Component (Loc,
6377 Prefix =>
6378 Unchecked_Convert_To
6379 (RTE (RE_RAS_Proxy_Type_Access),
6380 New_Occurrence_Of (Local_Addr, Loc)),
6381 Selector_Name =>
6382 Make_Identifier (Loc, Name_Target)))))),
6384 -- if not All_Calls_Remote then
6385 -- return Fat_Type!(A);
6386 -- end if;
6388 Make_Implicit_If_Statement (N,
6389 Condition =>
6390 Make_Op_Not (Loc,
6391 Right_Opnd =>
6392 New_Occurrence_Of (All_Calls_Remote, Loc)),
6394 Then_Statements => New_List (
6395 Make_Simple_Return_Statement (Loc,
6396 Expression =>
6397 Unchecked_Convert_To
6398 (Fat_Type, New_Occurrence_Of (Local_Addr, Loc))))))));
6400 Append_List_To (Proc_Statements, New_List (
6402 -- Stub.Target := Entity_Of (Ref);
6404 Set_Field (Name_Target,
6405 Make_Function_Call (Loc,
6406 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6407 Parameter_Associations => New_List (
6408 New_Occurrence_Of (Subp_Ref, Loc)))),
6410 -- Inc_Usage (Stub.Target);
6412 Make_Procedure_Call_Statement (Loc,
6413 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6414 Parameter_Associations => New_List (
6415 Make_Selected_Component (Loc,
6416 Prefix => Stub_Ptr,
6417 Selector_Name => Name_Target))),
6419 -- E.4.1(9) A remote call is asynchronous if it is a call to
6420 -- a procedure, or a call through a value of an access-to-procedure
6421 -- type, to which a pragma Asynchronous applies.
6423 -- Parameter Asynch_P is true when the procedure is asynchronous;
6424 -- Expression Asynch_T is true when the type is asynchronous.
6426 Set_Field (Name_Asynchronous,
6427 Make_Or_Else (Loc,
6428 Left_Opnd => New_Occurrence_Of (Asynch_P, Loc),
6429 Right_Opnd =>
6430 New_Occurrence_Of
6431 (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc)))));
6433 Append_List_To (Proc_Statements,
6434 Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
6436 Append_To (Proc_Statements,
6437 Make_Simple_Return_Statement (Loc,
6438 Expression =>
6439 Unchecked_Convert_To (Fat_Type,
6440 New_Occurrence_Of (Stub_Ptr, Loc))));
6442 Proc_Spec :=
6443 Make_Function_Specification (Loc,
6444 Defining_Unit_Name => Proc,
6445 Parameter_Specifications => New_List (
6446 Make_Parameter_Specification (Loc,
6447 Defining_Identifier => Package_Name,
6448 Parameter_Type =>
6449 New_Occurrence_Of (Standard_String, Loc)),
6451 Make_Parameter_Specification (Loc,
6452 Defining_Identifier => Subp_Id,
6453 Parameter_Type =>
6454 New_Occurrence_Of (Standard_String, Loc)),
6456 Make_Parameter_Specification (Loc,
6457 Defining_Identifier => Asynch_P,
6458 Parameter_Type =>
6459 New_Occurrence_Of (Standard_Boolean, Loc)),
6461 Make_Parameter_Specification (Loc,
6462 Defining_Identifier => All_Calls_Remote,
6463 Parameter_Type =>
6464 New_Occurrence_Of (Standard_Boolean, Loc))),
6466 Result_Definition =>
6467 New_Occurrence_Of (Fat_Type, Loc));
6469 -- Set the kind and return type of the function to prevent
6470 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6472 Set_Ekind (Proc, E_Function);
6473 Set_Etype (Proc, Fat_Type);
6475 Discard_Node (
6476 Make_Subprogram_Body (Loc,
6477 Specification => Proc_Spec,
6478 Declarations => Proc_Decls,
6479 Handled_Statement_Sequence =>
6480 Make_Handled_Sequence_Of_Statements (Loc,
6481 Statements => Proc_Statements)));
6483 Set_TSS (Fat_Type, Proc);
6484 end Add_RAS_Access_TSS;
6486 ----------------------
6487 -- Add_RAS_From_Any --
6488 ----------------------
6490 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6491 Loc : constant Source_Ptr := Sloc (RAS_Type);
6493 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6494 Make_TSS_Name (RAS_Type, TSS_From_Any));
6496 Func_Spec : Node_Id;
6498 Statements : List_Id;
6500 Any_Parameter : constant Entity_Id :=
6501 Make_Defining_Identifier (Loc, Name_A);
6503 begin
6504 Statements := New_List (
6505 Make_Simple_Return_Statement (Loc,
6506 Expression =>
6507 Make_Aggregate (Loc,
6508 Component_Associations => New_List (
6509 Make_Component_Association (Loc,
6510 Choices => New_List (Make_Identifier (Loc, Name_Ras)),
6511 Expression =>
6512 PolyORB_Support.Helpers.Build_From_Any_Call
6513 (Underlying_RACW_Type (RAS_Type),
6514 New_Occurrence_Of (Any_Parameter, Loc),
6515 No_List))))));
6517 Func_Spec :=
6518 Make_Function_Specification (Loc,
6519 Defining_Unit_Name => Fnam,
6520 Parameter_Specifications => New_List (
6521 Make_Parameter_Specification (Loc,
6522 Defining_Identifier => Any_Parameter,
6523 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
6524 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6526 Discard_Node (
6527 Make_Subprogram_Body (Loc,
6528 Specification => Func_Spec,
6529 Declarations => No_List,
6530 Handled_Statement_Sequence =>
6531 Make_Handled_Sequence_Of_Statements (Loc,
6532 Statements => Statements)));
6533 Set_TSS (RAS_Type, Fnam);
6534 end Add_RAS_From_Any;
6536 --------------------
6537 -- Add_RAS_To_Any --
6538 --------------------
6540 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6541 Loc : constant Source_Ptr := Sloc (RAS_Type);
6543 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6544 Make_TSS_Name (RAS_Type, TSS_To_Any));
6546 Decls : List_Id;
6547 Statements : List_Id;
6549 Func_Spec : Node_Id;
6551 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
6552 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
6553 RACW_Parameter : constant Node_Id :=
6554 Make_Selected_Component (Loc,
6555 Prefix => RAS_Parameter,
6556 Selector_Name => Name_Ras);
6558 begin
6559 -- Object declarations
6561 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6562 Decls := New_List (
6563 Make_Object_Declaration (Loc,
6564 Defining_Identifier => Any,
6565 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc),
6566 Expression =>
6567 PolyORB_Support.Helpers.Build_To_Any_Call
6568 (Loc, RACW_Parameter, No_List)));
6570 Statements := New_List (
6571 Make_Procedure_Call_Statement (Loc,
6572 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6573 Parameter_Associations => New_List (
6574 New_Occurrence_Of (Any, Loc),
6575 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6576 RAS_Type, Decls))),
6578 Make_Simple_Return_Statement (Loc,
6579 Expression => New_Occurrence_Of (Any, Loc)));
6581 Func_Spec :=
6582 Make_Function_Specification (Loc,
6583 Defining_Unit_Name => Fnam,
6584 Parameter_Specifications => New_List (
6585 Make_Parameter_Specification (Loc,
6586 Defining_Identifier => RAS_Parameter,
6587 Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))),
6588 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6590 Discard_Node (
6591 Make_Subprogram_Body (Loc,
6592 Specification => Func_Spec,
6593 Declarations => Decls,
6594 Handled_Statement_Sequence =>
6595 Make_Handled_Sequence_Of_Statements (Loc,
6596 Statements => Statements)));
6597 Set_TSS (RAS_Type, Fnam);
6598 end Add_RAS_To_Any;
6600 ----------------------
6601 -- Add_RAS_TypeCode --
6602 ----------------------
6604 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6605 Loc : constant Source_Ptr := Sloc (RAS_Type);
6607 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6608 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6610 Func_Spec : Node_Id;
6611 Decls : constant List_Id := New_List;
6612 Name_String : String_Id;
6613 Repo_Id_String : String_Id;
6615 begin
6616 Func_Spec :=
6617 Make_Function_Specification (Loc,
6618 Defining_Unit_Name => Fnam,
6619 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6621 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6622 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6624 Discard_Node (
6625 Make_Subprogram_Body (Loc,
6626 Specification => Func_Spec,
6627 Declarations => Decls,
6628 Handled_Statement_Sequence =>
6629 Make_Handled_Sequence_Of_Statements (Loc,
6630 Statements => New_List (
6631 Make_Simple_Return_Statement (Loc,
6632 Expression =>
6633 Make_Function_Call (Loc,
6634 Name =>
6635 New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc),
6636 Parameter_Associations => New_List (
6637 New_Occurrence_Of (RTE (RE_Tk_Objref), Loc),
6638 Make_Aggregate (Loc,
6639 Expressions =>
6640 New_List (
6641 Make_Function_Call (Loc,
6642 Name =>
6643 New_Occurrence_Of
6644 (RTE (RE_TA_Std_String), Loc),
6645 Parameter_Associations => New_List (
6646 Make_String_Literal (Loc, Name_String))),
6647 Make_Function_Call (Loc,
6648 Name =>
6649 New_Occurrence_Of
6650 (RTE (RE_TA_Std_String), Loc),
6651 Parameter_Associations => New_List (
6652 Make_String_Literal (Loc,
6653 Strval => Repo_Id_String))))))))))));
6654 Set_TSS (RAS_Type, Fnam);
6655 end Add_RAS_TypeCode;
6657 -----------------------------------------
6658 -- Add_Receiving_Stubs_To_Declarations --
6659 -----------------------------------------
6661 procedure Add_Receiving_Stubs_To_Declarations
6662 (Pkg_Spec : Node_Id;
6663 Decls : List_Id;
6664 Stmts : List_Id)
6666 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6668 Pkg_RPC_Receiver : constant Entity_Id :=
6669 Make_Temporary (Loc, 'H');
6670 Pkg_RPC_Receiver_Object : Node_Id;
6671 Pkg_RPC_Receiver_Body : Node_Id;
6672 Pkg_RPC_Receiver_Decls : List_Id;
6673 Pkg_RPC_Receiver_Statements : List_Id;
6675 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6676 -- A Pkg_RPC_Receiver is built to decode the request
6678 Request : Node_Id;
6679 -- Request object received from neutral layer
6681 Subp_Id : Entity_Id;
6682 -- Subprogram identifier as received from the neutral distribution
6683 -- core.
6685 Subp_Index : Entity_Id;
6686 -- Internal index as determined by matching either the method name
6687 -- from the request structure, or the local subprogram address (in
6688 -- case of a RAS).
6690 Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L');
6692 Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A');
6693 -- Address of a local subprogram designated by a reference
6694 -- corresponding to a RAS.
6696 Dispatch_On_Address : constant List_Id := New_List;
6697 Dispatch_On_Name : constant List_Id := New_List;
6699 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
6701 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
6702 Subp_Info_List : constant List_Id := New_List;
6704 Register_Pkg_Actuals : constant List_Id := New_List;
6706 All_Calls_Remote_E : Entity_Id;
6708 procedure Append_Stubs_To
6709 (RPC_Receiver_Cases : List_Id;
6710 Declaration : Node_Id;
6711 Stubs : Node_Id;
6712 Subp_Number : Int;
6713 Subp_Dist_Name : Entity_Id;
6714 Subp_Proxy_Addr : Entity_Id);
6715 -- Add one case to the specified RPC receiver case list associating
6716 -- Subprogram_Number with the subprogram declared by Declaration, for
6717 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6718 -- subprogram index. Subp_Dist_Name is the string used to call the
6719 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6720 -- object, used in the context of calls through remote
6721 -- access-to-subprogram types.
6723 procedure Visit_Subprogram (Decl : Node_Id);
6724 -- Generate receiving stub for one remote subprogram
6726 ---------------------
6727 -- Append_Stubs_To --
6728 ---------------------
6730 procedure Append_Stubs_To
6731 (RPC_Receiver_Cases : List_Id;
6732 Declaration : Node_Id;
6733 Stubs : Node_Id;
6734 Subp_Number : Int;
6735 Subp_Dist_Name : Entity_Id;
6736 Subp_Proxy_Addr : Entity_Id)
6738 Case_Stmts : List_Id;
6739 begin
6740 Case_Stmts := New_List (
6741 Make_Procedure_Call_Statement (Loc,
6742 Name =>
6743 New_Occurrence_Of (
6744 Defining_Entity (Stubs), Loc),
6745 Parameter_Associations =>
6746 New_List (New_Occurrence_Of (Request, Loc))));
6748 if Nkind (Specification (Declaration)) = N_Function_Specification
6749 or else not
6750 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6751 then
6752 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6753 end if;
6755 Append_To (RPC_Receiver_Cases,
6756 Make_Case_Statement_Alternative (Loc,
6757 Discrete_Choices =>
6758 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6759 Statements => Case_Stmts));
6761 Append_To (Dispatch_On_Name,
6762 Make_Elsif_Part (Loc,
6763 Condition =>
6764 Make_Function_Call (Loc,
6765 Name =>
6766 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6767 Parameter_Associations => New_List (
6768 New_Occurrence_Of (Subp_Id, Loc),
6769 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6771 Then_Statements => New_List (
6772 Make_Assignment_Statement (Loc,
6773 New_Occurrence_Of (Subp_Index, Loc),
6774 Make_Integer_Literal (Loc, Subp_Number)))));
6776 Append_To (Dispatch_On_Address,
6777 Make_Elsif_Part (Loc,
6778 Condition =>
6779 Make_Op_Eq (Loc,
6780 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6781 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6783 Then_Statements => New_List (
6784 Make_Assignment_Statement (Loc,
6785 New_Occurrence_Of (Subp_Index, Loc),
6786 Make_Integer_Literal (Loc, Subp_Number)))));
6787 end Append_Stubs_To;
6789 ----------------------
6790 -- Visit_Subprogram --
6791 ----------------------
6793 procedure Visit_Subprogram (Decl : Node_Id) is
6794 Loc : constant Source_Ptr := Sloc (Decl);
6795 Spec : constant Node_Id := Specification (Decl);
6796 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
6798 Subp_Val : String_Id;
6800 Subp_Dist_Name : constant Entity_Id :=
6801 Make_Defining_Identifier (Loc,
6802 Chars =>
6803 New_External_Name
6804 (Related_Id => Chars (Subp_Def),
6805 Suffix => 'D',
6806 Suffix_Index => -1));
6808 Current_Stubs : Node_Id;
6809 Proxy_Obj_Addr : Entity_Id;
6811 begin
6812 -- Disable expansion of stubs if serious errors have been
6813 -- diagnosed, because otherwise some illegal remote subprogram
6814 -- declarations could cause cascaded errors in stubs.
6816 if Serious_Errors_Detected /= 0 then
6817 return;
6818 end if;
6820 -- Build receiving stub
6822 Current_Stubs :=
6823 Build_Subprogram_Receiving_Stubs
6824 (Vis_Decl => Decl,
6825 Asynchronous => Nkind (Spec) = N_Procedure_Specification
6826 and then Is_Asynchronous (Subp_Def));
6828 Append_To (Decls, Current_Stubs);
6829 Analyze (Current_Stubs);
6831 -- Build RAS proxy
6833 Add_RAS_Proxy_And_Analyze (Decls,
6834 Vis_Decl => Decl,
6835 All_Calls_Remote_E => All_Calls_Remote_E,
6836 Proxy_Object_Addr => Proxy_Obj_Addr);
6838 -- Compute distribution identifier
6840 Assign_Subprogram_Identifier
6841 (Subp_Def, Current_Subp_Number, Subp_Val);
6843 pragma Assert
6844 (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
6846 Append_To (Decls,
6847 Make_Object_Declaration (Loc,
6848 Defining_Identifier => Subp_Dist_Name,
6849 Constant_Present => True,
6850 Object_Definition =>
6851 New_Occurrence_Of (Standard_String, Loc),
6852 Expression =>
6853 Make_String_Literal (Loc, Subp_Val)));
6854 Analyze (Last (Decls));
6856 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
6857 -- table for this receiver. The aggregate below must be kept
6858 -- consistent with the declaration of RCI_Subp_Info in
6859 -- System.Partition_Interface.
6861 Append_To (Subp_Info_List,
6862 Make_Component_Association (Loc,
6863 Choices =>
6864 New_List (Make_Integer_Literal (Loc, Current_Subp_Number)),
6866 Expression =>
6867 Make_Aggregate (Loc,
6868 Expressions => New_List (
6870 -- Name =>
6872 Make_Attribute_Reference (Loc,
6873 Prefix =>
6874 New_Occurrence_Of (Subp_Dist_Name, Loc),
6875 Attribute_Name => Name_Address),
6877 -- Name_Length =>
6879 Make_Attribute_Reference (Loc,
6880 Prefix =>
6881 New_Occurrence_Of (Subp_Dist_Name, Loc),
6882 Attribute_Name => Name_Length),
6884 -- Addr =>
6886 New_Occurrence_Of (Proxy_Obj_Addr, Loc)))));
6888 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6889 Declaration => Decl,
6890 Stubs => Current_Stubs,
6891 Subp_Number => Current_Subp_Number,
6892 Subp_Dist_Name => Subp_Dist_Name,
6893 Subp_Proxy_Addr => Proxy_Obj_Addr);
6895 Current_Subp_Number := Current_Subp_Number + 1;
6896 end Visit_Subprogram;
6898 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
6900 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6902 begin
6903 -- Building receiving stubs consist in several operations:
6905 -- - a package RPC receiver must be built. This subprogram will get
6906 -- a Subprogram_Id from the incoming stream and will dispatch the
6907 -- call to the right subprogram;
6909 -- - a receiving stub for each subprogram visible in the package
6910 -- spec. This stub will read all the parameters from the stream,
6911 -- and put the result as well as the exception occurrence in the
6912 -- output stream;
6914 Build_RPC_Receiver_Body (
6915 RPC_Receiver => Pkg_RPC_Receiver,
6916 Request => Request,
6917 Subp_Id => Subp_Id,
6918 Subp_Index => Subp_Index,
6919 Stmts => Pkg_RPC_Receiver_Statements,
6920 Decl => Pkg_RPC_Receiver_Body);
6921 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6923 -- Extract local address information from the target reference:
6924 -- if non-null, that means that this is a reference that denotes
6925 -- one particular operation, and hence that the operation name
6926 -- must not be taken into account for dispatching.
6928 Append_To (Pkg_RPC_Receiver_Decls,
6929 Make_Object_Declaration (Loc,
6930 Defining_Identifier => Is_Local,
6931 Object_Definition =>
6932 New_Occurrence_Of (Standard_Boolean, Loc)));
6934 Append_To (Pkg_RPC_Receiver_Decls,
6935 Make_Object_Declaration (Loc,
6936 Defining_Identifier => Local_Address,
6937 Object_Definition =>
6938 New_Occurrence_Of (RTE (RE_Address), Loc)));
6940 Append_To (Pkg_RPC_Receiver_Statements,
6941 Make_Procedure_Call_Statement (Loc,
6942 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6943 Parameter_Associations => New_List (
6944 Make_Selected_Component (Loc,
6945 Prefix => Request,
6946 Selector_Name => Name_Target),
6947 New_Occurrence_Of (Is_Local, Loc),
6948 New_Occurrence_Of (Local_Address, Loc))));
6950 -- For each subprogram, the receiving stub will be built and a case
6951 -- statement will be made on the Subprogram_Id to dispatch to the
6952 -- right subprogram.
6954 All_Calls_Remote_E := Boolean_Literals (
6955 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6957 Overload_Counter_Table.Reset;
6958 Reserve_NamingContext_Methods;
6960 Visit_Spec (Pkg_Spec);
6962 Append_To (Decls,
6963 Make_Object_Declaration (Loc,
6964 Defining_Identifier => Subp_Info_Array,
6965 Constant_Present => True,
6966 Aliased_Present => True,
6967 Object_Definition =>
6968 Make_Subtype_Indication (Loc,
6969 Subtype_Mark =>
6970 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6971 Constraint =>
6972 Make_Index_Or_Discriminant_Constraint (Loc,
6973 New_List (
6974 Make_Range (Loc,
6975 Low_Bound =>
6976 Make_Integer_Literal (Loc,
6977 Intval => First_RCI_Subprogram_Id),
6978 High_Bound =>
6979 Make_Integer_Literal (Loc,
6980 Intval =>
6981 First_RCI_Subprogram_Id
6982 + List_Length (Subp_Info_List) - 1)))))));
6984 if Present (First (Subp_Info_List)) then
6985 Set_Expression (Last (Decls),
6986 Make_Aggregate (Loc,
6987 Component_Associations => Subp_Info_List));
6989 -- Generate the dispatch statement to determine the subprogram id
6990 -- of the called subprogram.
6992 -- We first test whether the reference that was used to make the
6993 -- call was the base RCI reference (in which case Local_Address is
6994 -- zero, and the method identifier from the request must be used
6995 -- to determine which subprogram is called) or a reference
6996 -- identifying one particular subprogram (in which case
6997 -- Local_Address is the address of that subprogram, and the
6998 -- method name from the request is ignored). The latter occurs
6999 -- for the case of a call through a remote access-to-subprogram.
7001 -- In each case, cascaded elsifs are used to determine the proper
7002 -- subprogram index. Using hash tables might be more efficient.
7004 Append_To (Pkg_RPC_Receiver_Statements,
7005 Make_Implicit_If_Statement (Pkg_Spec,
7006 Condition =>
7007 Make_Op_Ne (Loc,
7008 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
7009 Right_Opnd => New_Occurrence_Of
7010 (RTE (RE_Null_Address), Loc)),
7012 Then_Statements => New_List (
7013 Make_Implicit_If_Statement (Pkg_Spec,
7014 Condition => New_Occurrence_Of (Standard_False, Loc),
7015 Then_Statements => New_List (
7016 Make_Null_Statement (Loc)),
7017 Elsif_Parts => Dispatch_On_Address)),
7019 Else_Statements => New_List (
7020 Make_Implicit_If_Statement (Pkg_Spec,
7021 Condition => New_Occurrence_Of (Standard_False, Loc),
7022 Then_Statements => New_List (Make_Null_Statement (Loc)),
7023 Elsif_Parts => Dispatch_On_Name))));
7025 else
7026 -- For a degenerate RCI with no visible subprograms,
7027 -- Subp_Info_List has zero length, and the declaration is for an
7028 -- empty array, in which case no initialization aggregate must be
7029 -- generated. We do not generate a Dispatch_Statement either.
7031 -- No initialization provided: remove CONSTANT so that the
7032 -- declaration is not an incomplete deferred constant.
7034 Set_Constant_Present (Last (Decls), False);
7035 end if;
7037 -- Analyze Subp_Info_Array declaration
7039 Analyze (Last (Decls));
7041 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7042 -- rather than raising an exception since we do not want someone
7043 -- to crash a remote partition by sending invalid subprogram ids.
7044 -- This is consistent with the other parts of the case statement
7045 -- since even in presence of incorrect parameters in the stream,
7046 -- every exception will be caught and (if the subprogram is not an
7047 -- APC) put into the result stream and sent away.
7049 Append_To (Pkg_RPC_Receiver_Cases,
7050 Make_Case_Statement_Alternative (Loc,
7051 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
7052 Statements => New_List (Make_Null_Statement (Loc))));
7054 Append_To (Pkg_RPC_Receiver_Statements,
7055 Make_Case_Statement (Loc,
7056 Expression => New_Occurrence_Of (Subp_Index, Loc),
7057 Alternatives => Pkg_RPC_Receiver_Cases));
7059 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7060 -- analyze it.
7062 Append_To (Decls, Pkg_RPC_Receiver_Body);
7063 Analyze (Last (Decls));
7065 Pkg_RPC_Receiver_Object :=
7066 Make_Object_Declaration (Loc,
7067 Defining_Identifier => Make_Temporary (Loc, 'R'),
7068 Aliased_Present => True,
7069 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
7070 Append_To (Decls, Pkg_RPC_Receiver_Object);
7071 Analyze (Last (Decls));
7073 -- Name
7075 Append_To (Register_Pkg_Actuals,
7076 Make_String_Literal (Loc,
7077 Strval =>
7078 Fully_Qualified_Name_String
7079 (Defining_Entity (Pkg_Spec), Append_NUL => False)));
7081 -- Version
7083 Append_To (Register_Pkg_Actuals,
7084 Make_Attribute_Reference (Loc,
7085 Prefix =>
7086 New_Occurrence_Of
7087 (Defining_Entity (Pkg_Spec), Loc),
7088 Attribute_Name => Name_Version));
7090 -- Handler
7092 Append_To (Register_Pkg_Actuals,
7093 Make_Attribute_Reference (Loc,
7094 Prefix =>
7095 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7096 Attribute_Name => Name_Access));
7098 -- Receiver
7100 Append_To (Register_Pkg_Actuals,
7101 Make_Attribute_Reference (Loc,
7102 Prefix =>
7103 New_Occurrence_Of (
7104 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc),
7105 Attribute_Name => Name_Access));
7107 -- Subp_Info
7109 Append_To (Register_Pkg_Actuals,
7110 Make_Attribute_Reference (Loc,
7111 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7112 Attribute_Name => Name_Address));
7114 -- Subp_Info_Len
7116 Append_To (Register_Pkg_Actuals,
7117 Make_Attribute_Reference (Loc,
7118 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7119 Attribute_Name => Name_Length));
7121 -- Is_All_Calls_Remote
7123 Append_To (Register_Pkg_Actuals,
7124 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7126 -- Finally call Register_Pkg_Receiving_Stub with the above parameters
7128 Append_To (Stmts,
7129 Make_Procedure_Call_Statement (Loc,
7130 Name =>
7131 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7132 Parameter_Associations => Register_Pkg_Actuals));
7133 Analyze (Last (Stmts));
7134 end Add_Receiving_Stubs_To_Declarations;
7136 ---------------------------------
7137 -- Build_General_Calling_Stubs --
7138 ---------------------------------
7140 procedure Build_General_Calling_Stubs
7141 (Decls : List_Id;
7142 Statements : List_Id;
7143 Target_Object : Node_Id;
7144 Subprogram_Id : Node_Id;
7145 Asynchronous : Node_Id := Empty;
7146 Is_Known_Asynchronous : Boolean := False;
7147 Is_Known_Non_Asynchronous : Boolean := False;
7148 Is_Function : Boolean;
7149 Spec : Node_Id;
7150 Stub_Type : Entity_Id := Empty;
7151 RACW_Type : Entity_Id := Empty;
7152 Nod : Node_Id)
7154 Loc : constant Source_Ptr := Sloc (Nod);
7156 Request : constant Entity_Id := Make_Temporary (Loc, 'R');
7157 -- The request object constructed by these stubs
7158 -- Could we use Name_R instead??? (see GLADE client stubs)
7160 function Make_Request_RTE_Call
7161 (RE : RE_Id;
7162 Actuals : List_Id := New_List) return Node_Id;
7163 -- Generate a procedure call statement calling RE with the given
7164 -- actuals. Request'Access is appended to the list.
7166 ---------------------------
7167 -- Make_Request_RTE_Call --
7168 ---------------------------
7170 function Make_Request_RTE_Call
7171 (RE : RE_Id;
7172 Actuals : List_Id := New_List) return Node_Id
7174 begin
7175 Append_To (Actuals,
7176 Make_Attribute_Reference (Loc,
7177 Prefix => New_Occurrence_Of (Request, Loc),
7178 Attribute_Name => Name_Access));
7179 return Make_Procedure_Call_Statement (Loc,
7180 Name =>
7181 New_Occurrence_Of (RTE (RE), Loc),
7182 Parameter_Associations => Actuals);
7183 end Make_Request_RTE_Call;
7185 Arguments : Node_Id;
7186 -- Name of the named values list used to transmit parameters
7187 -- to the remote package
7189 Result : Node_Id;
7190 -- Name of the result named value (in non-APC cases) which get the
7191 -- result of the remote subprogram.
7193 Result_TC : Node_Id;
7194 -- Typecode expression for the result of the request (void
7195 -- typecode for procedures).
7197 Exception_Return_Parameter : Node_Id;
7198 -- Name of the parameter which will hold the exception sent by the
7199 -- remote subprogram.
7201 Current_Parameter : Node_Id;
7202 -- Current parameter being handled
7204 Ordered_Parameters_List : constant List_Id :=
7205 Build_Ordered_Parameters_List (Spec);
7207 Asynchronous_P : Node_Id;
7208 -- A Boolean expression indicating whether this call is asynchronous
7210 Asynchronous_Statements : List_Id := No_List;
7211 Non_Asynchronous_Statements : List_Id := No_List;
7212 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7214 Extra_Formal_Statements : constant List_Id := New_List;
7215 -- List of statements for extra formal parameters. It will appear
7216 -- after the regular statements for writing out parameters.
7218 After_Statements : constant List_Id := New_List;
7219 -- Statements to be executed after call returns (to assign IN OUT or
7220 -- OUT parameter values).
7222 Etyp : Entity_Id;
7223 -- The type of the formal parameter being processed
7225 Is_Controlling_Formal : Boolean;
7226 Is_First_Controlling_Formal : Boolean;
7227 First_Controlling_Formal_Seen : Boolean := False;
7228 -- Controlling formal parameters of distributed object primitives
7229 -- require special handling, and the first such parameter needs even
7230 -- more special handling.
7232 begin
7233 -- ??? document general form of stub subprograms for the PolyORB case
7235 Append_To (Decls,
7236 Make_Object_Declaration (Loc,
7237 Defining_Identifier => Request,
7238 Aliased_Present => True,
7239 Object_Definition =>
7240 New_Occurrence_Of (RTE (RE_Request), Loc)));
7242 Result := Make_Temporary (Loc, 'R');
7244 if Is_Function then
7245 Result_TC :=
7246 PolyORB_Support.Helpers.Build_TypeCode_Call
7247 (Loc, Etype (Result_Definition (Spec)), Decls);
7248 else
7249 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7250 end if;
7252 Append_To (Decls,
7253 Make_Object_Declaration (Loc,
7254 Defining_Identifier => Result,
7255 Aliased_Present => False,
7256 Object_Definition =>
7257 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7258 Expression =>
7259 Make_Aggregate (Loc,
7260 Component_Associations => New_List (
7261 Make_Component_Association (Loc,
7262 Choices => New_List (Make_Identifier (Loc, Name_Name)),
7263 Expression =>
7264 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7265 Make_Component_Association (Loc,
7266 Choices => New_List (
7267 Make_Identifier (Loc, Name_Argument)),
7268 Expression =>
7269 Make_Function_Call (Loc,
7270 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7271 Parameter_Associations => New_List (Result_TC))),
7272 Make_Component_Association (Loc,
7273 Choices => New_List (
7274 Make_Identifier (Loc, Name_Arg_Modes)),
7275 Expression => Make_Integer_Literal (Loc, 0))))));
7277 if not Is_Known_Asynchronous then
7278 Exception_Return_Parameter := Make_Temporary (Loc, 'E');
7280 Append_To (Decls,
7281 Make_Object_Declaration (Loc,
7282 Defining_Identifier => Exception_Return_Parameter,
7283 Object_Definition =>
7284 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7286 else
7287 Exception_Return_Parameter := Empty;
7288 end if;
7290 -- Initialize and fill in arguments list
7292 Arguments := Make_Temporary (Loc, 'A');
7293 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7295 Current_Parameter := First (Ordered_Parameters_List);
7296 while Present (Current_Parameter) loop
7297 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7298 Is_Controlling_Formal := True;
7299 Is_First_Controlling_Formal :=
7300 not First_Controlling_Formal_Seen;
7301 First_Controlling_Formal_Seen := True;
7303 else
7304 Is_Controlling_Formal := False;
7305 Is_First_Controlling_Formal := False;
7306 end if;
7308 if Is_Controlling_Formal then
7310 -- For a controlling formal argument, we send its reference
7312 Etyp := RACW_Type;
7314 else
7315 Etyp := Etype (Parameter_Type (Current_Parameter));
7316 end if;
7318 -- The first controlling formal parameter is treated specially:
7319 -- it is used to set the target object of the call.
7321 if not Is_First_Controlling_Formal then
7322 declare
7323 Constrained : constant Boolean :=
7324 Is_Constrained (Etyp)
7325 or else Is_Elementary_Type (Etyp);
7327 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
7329 Actual_Parameter : Node_Id :=
7330 New_Occurrence_Of (
7331 Defining_Identifier (
7332 Current_Parameter), Loc);
7334 Expr : Node_Id;
7336 begin
7337 if Is_Controlling_Formal then
7339 -- For a controlling formal parameter (other than the
7340 -- first one), use the corresponding RACW. If the
7341 -- parameter is not an anonymous access parameter, that
7342 -- involves taking its 'Unrestricted_Access.
7344 if Nkind (Parameter_Type (Current_Parameter))
7345 = N_Access_Definition
7346 then
7347 Actual_Parameter := OK_Convert_To
7348 (Etyp, Actual_Parameter);
7349 else
7350 Actual_Parameter := OK_Convert_To (Etyp,
7351 Make_Attribute_Reference (Loc,
7352 Prefix => Actual_Parameter,
7353 Attribute_Name => Name_Unrestricted_Access));
7354 end if;
7356 end if;
7358 if In_Present (Current_Parameter)
7359 or else not Out_Present (Current_Parameter)
7360 or else not Constrained
7361 or else Is_Controlling_Formal
7362 then
7363 -- The parameter has an input value, is constrained at
7364 -- runtime by an input value, or is a controlling formal
7365 -- parameter (always passed as a reference) other than
7366 -- the first one.
7368 Expr := PolyORB_Support.Helpers.Build_To_Any_Call
7369 (Loc, Actual_Parameter, Decls);
7371 else
7372 Expr := Make_Function_Call (Loc,
7373 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7374 Parameter_Associations => New_List (
7375 PolyORB_Support.Helpers.Build_TypeCode_Call
7376 (Loc, Etyp, Decls)));
7377 end if;
7379 Append_To (Decls,
7380 Make_Object_Declaration (Loc,
7381 Defining_Identifier => Any,
7382 Aliased_Present => False,
7383 Object_Definition =>
7384 New_Occurrence_Of (RTE (RE_Any), Loc),
7385 Expression => Expr));
7387 Append_To (Statements,
7388 Add_Parameter_To_NVList (Loc,
7389 Parameter => Current_Parameter,
7390 NVList => Arguments,
7391 Constrained => Constrained,
7392 Any => Any));
7394 if Out_Present (Current_Parameter)
7395 and then not Is_Controlling_Formal
7396 then
7397 if Is_Limited_Type (Etyp) then
7398 Helpers.Assign_Opaque_From_Any (Loc,
7399 Stms => After_Statements,
7400 Typ => Etyp,
7401 N => New_Occurrence_Of (Any, Loc),
7402 Target =>
7403 Defining_Identifier (Current_Parameter));
7404 else
7405 Append_To (After_Statements,
7406 Make_Assignment_Statement (Loc,
7407 Name =>
7408 New_Occurrence_Of (
7409 Defining_Identifier (Current_Parameter), Loc),
7410 Expression =>
7411 PolyORB_Support.Helpers.Build_From_Any_Call
7412 (Etyp,
7413 New_Occurrence_Of (Any, Loc),
7414 Decls)));
7415 end if;
7416 end if;
7417 end;
7418 end if;
7420 -- If the current parameter has a dynamic constrained status, then
7421 -- this status is transmitted as well.
7423 -- This should be done for accessibility as well ???
7425 if Nkind (Parameter_Type (Current_Parameter)) /=
7426 N_Access_Definition
7427 and then Need_Extra_Constrained (Current_Parameter)
7428 then
7429 -- In this block, we do not use the extra formal that has been
7430 -- created because it does not exist at the time of expansion
7431 -- when building calling stubs for remote access to subprogram
7432 -- types. We create an extra variable of this type and push it
7433 -- in the stream after the regular parameters.
7435 declare
7436 Extra_Any_Parameter : constant Entity_Id :=
7437 Make_Temporary (Loc, 'P');
7439 Parameter_Exp : constant Node_Id :=
7440 Make_Attribute_Reference (Loc,
7441 Prefix => New_Occurrence_Of (
7442 Defining_Identifier (Current_Parameter), Loc),
7443 Attribute_Name => Name_Constrained);
7445 begin
7446 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7448 Append_To (Decls,
7449 Make_Object_Declaration (Loc,
7450 Defining_Identifier => Extra_Any_Parameter,
7451 Aliased_Present => False,
7452 Object_Definition =>
7453 New_Occurrence_Of (RTE (RE_Any), Loc),
7454 Expression =>
7455 PolyORB_Support.Helpers.Build_To_Any_Call
7456 (Loc, Parameter_Exp, Decls)));
7458 Append_To (Extra_Formal_Statements,
7459 Add_Parameter_To_NVList (Loc,
7460 Parameter => Extra_Any_Parameter,
7461 NVList => Arguments,
7462 Constrained => True,
7463 Any => Extra_Any_Parameter));
7464 end;
7465 end if;
7467 Next (Current_Parameter);
7468 end loop;
7470 -- Append the formal statements list to the statements
7472 Append_List_To (Statements, Extra_Formal_Statements);
7474 Append_To (Statements,
7475 Make_Procedure_Call_Statement (Loc,
7476 Name =>
7477 New_Occurrence_Of (RTE (RE_Request_Setup), Loc),
7478 Parameter_Associations => New_List (
7479 New_Occurrence_Of (Request, Loc),
7480 Target_Object,
7481 Subprogram_Id,
7482 New_Occurrence_Of (Arguments, Loc),
7483 New_Occurrence_Of (Result, Loc),
7484 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7486 pragma Assert
7487 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7489 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7490 Asynchronous_P :=
7491 New_Occurrence_Of
7492 (Boolean_Literals (Is_Known_Asynchronous), Loc);
7494 else
7495 pragma Assert (Present (Asynchronous));
7496 Asynchronous_P := New_Copy_Tree (Asynchronous);
7498 -- The expression node Asynchronous will be used to build an 'if'
7499 -- statement at the end of Build_General_Calling_Stubs: we need to
7500 -- make a copy here.
7501 end if;
7503 Append_To (Parameter_Associations (Last (Statements)),
7504 Make_Indexed_Component (Loc,
7505 Prefix =>
7506 New_Occurrence_Of (
7507 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7508 Expressions => New_List (Asynchronous_P)));
7510 Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke));
7512 -- Asynchronous case
7514 if not Is_Known_Non_Asynchronous then
7515 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7516 end if;
7518 -- Non-asynchronous case
7520 if not Is_Known_Asynchronous then
7521 -- Reraise an exception occurrence from the completed request.
7522 -- If the exception occurrence is empty, this is a no-op.
7524 Non_Asynchronous_Statements := New_List (
7525 Make_Procedure_Call_Statement (Loc,
7526 Name =>
7527 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7528 Parameter_Associations => New_List (
7529 New_Occurrence_Of (Request, Loc))));
7531 if Is_Function then
7532 -- If this is a function call, read the value and return it
7534 Append_To (Non_Asynchronous_Statements,
7535 Make_Tag_Check (Loc,
7536 Make_Simple_Return_Statement (Loc,
7537 PolyORB_Support.Helpers.Build_From_Any_Call
7538 (Etype (Result_Definition (Spec)),
7539 Make_Selected_Component (Loc,
7540 Prefix => Result,
7541 Selector_Name => Name_Argument),
7542 Decls))));
7544 else
7546 -- Case of a procedure: deal with IN OUT and OUT formals
7548 Append_List_To (Non_Asynchronous_Statements, After_Statements);
7549 end if;
7550 end if;
7552 if Is_Known_Asynchronous then
7553 Append_List_To (Statements, Asynchronous_Statements);
7555 elsif Is_Known_Non_Asynchronous then
7556 Append_List_To (Statements, Non_Asynchronous_Statements);
7558 else
7559 pragma Assert (Present (Asynchronous));
7560 Append_To (Statements,
7561 Make_Implicit_If_Statement (Nod,
7562 Condition => Asynchronous,
7563 Then_Statements => Asynchronous_Statements,
7564 Else_Statements => Non_Asynchronous_Statements));
7565 end if;
7566 end Build_General_Calling_Stubs;
7568 -----------------------
7569 -- Build_Stub_Target --
7570 -----------------------
7572 function Build_Stub_Target
7573 (Loc : Source_Ptr;
7574 Decls : List_Id;
7575 RCI_Locator : Entity_Id;
7576 Controlling_Parameter : Entity_Id) return RPC_Target
7578 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7579 Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T');
7581 begin
7582 if Present (Controlling_Parameter) then
7583 Append_To (Decls,
7584 Make_Object_Declaration (Loc,
7585 Defining_Identifier => Target_Reference,
7587 Object_Definition =>
7588 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7590 Expression =>
7591 Make_Function_Call (Loc,
7592 Name =>
7593 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7594 Parameter_Associations => New_List (
7595 Make_Selected_Component (Loc,
7596 Prefix => Controlling_Parameter,
7597 Selector_Name => Name_Target)))));
7599 -- Note: Controlling_Parameter has the same components as
7600 -- System.Partition_Interface.RACW_Stub_Type.
7602 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7604 else
7605 Target_Info.Object :=
7606 Make_Selected_Component (Loc,
7607 Prefix =>
7608 Make_Identifier (Loc, Chars (RCI_Locator)),
7609 Selector_Name =>
7610 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7611 end if;
7613 return Target_Info;
7614 end Build_Stub_Target;
7616 -----------------------------
7617 -- Build_RPC_Receiver_Body --
7618 -----------------------------
7620 procedure Build_RPC_Receiver_Body
7621 (RPC_Receiver : Entity_Id;
7622 Request : out Entity_Id;
7623 Subp_Id : out Entity_Id;
7624 Subp_Index : out Entity_Id;
7625 Stmts : out List_Id;
7626 Decl : out Node_Id)
7628 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7630 RPC_Receiver_Spec : Node_Id;
7631 RPC_Receiver_Decls : List_Id;
7633 begin
7634 Request := Make_Defining_Identifier (Loc, Name_R);
7636 RPC_Receiver_Spec :=
7637 Build_RPC_Receiver_Specification
7638 (RPC_Receiver => RPC_Receiver,
7639 Request_Parameter => Request);
7641 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7642 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7644 RPC_Receiver_Decls := New_List (
7645 Make_Object_Renaming_Declaration (Loc,
7646 Defining_Identifier => Subp_Id,
7647 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7648 Name =>
7649 Make_Explicit_Dereference (Loc,
7650 Prefix =>
7651 Make_Selected_Component (Loc,
7652 Prefix => Request,
7653 Selector_Name => Name_Operation))),
7655 Make_Object_Declaration (Loc,
7656 Defining_Identifier => Subp_Index,
7657 Object_Definition =>
7658 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7659 Expression =>
7660 Make_Attribute_Reference (Loc,
7661 Prefix =>
7662 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7663 Attribute_Name => Name_Last)));
7665 Stmts := New_List;
7667 Decl :=
7668 Make_Subprogram_Body (Loc,
7669 Specification => RPC_Receiver_Spec,
7670 Declarations => RPC_Receiver_Decls,
7671 Handled_Statement_Sequence =>
7672 Make_Handled_Sequence_Of_Statements (Loc,
7673 Statements => Stmts));
7674 end Build_RPC_Receiver_Body;
7676 --------------------------------------
7677 -- Build_Subprogram_Receiving_Stubs --
7678 --------------------------------------
7680 function Build_Subprogram_Receiving_Stubs
7681 (Vis_Decl : Node_Id;
7682 Asynchronous : Boolean;
7683 Dynamically_Asynchronous : Boolean := False;
7684 Stub_Type : Entity_Id := Empty;
7685 RACW_Type : Entity_Id := Empty;
7686 Parent_Primitive : Entity_Id := Empty) return Node_Id
7688 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7690 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
7691 -- Formal parameter for receiving stubs: a descriptor for an incoming
7692 -- request.
7694 Outer_Decls : constant List_Id := New_List;
7695 -- At the outermost level, an NVList and Any's are declared for all
7696 -- parameters. The Dynamic_Async flag also needs to be declared there
7697 -- to be visible from the exception handling code.
7699 Outer_Statements : constant List_Id := New_List;
7700 -- Statements that occur prior to the declaration of the actual
7701 -- parameter variables.
7703 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7704 -- Statements concerning extra formal parameters, prior to the
7705 -- declaration of the actual parameter variables.
7707 Decls : constant List_Id := New_List;
7708 -- All the parameters will get declared before calling the real
7709 -- subprograms. Also the out parameters will be declared. At this
7710 -- level, parameters may be unconstrained.
7712 Statements : constant List_Id := New_List;
7714 After_Statements : constant List_Id := New_List;
7715 -- Statements to be executed after the subprogram call
7717 Inner_Decls : List_Id := No_List;
7718 -- In case of a function, the inner declarations are needed since
7719 -- the result may be unconstrained.
7721 Excep_Handlers : List_Id := No_List;
7723 Parameter_List : constant List_Id := New_List;
7724 -- List of parameters to be passed to the subprogram
7726 First_Controlling_Formal_Seen : Boolean := False;
7728 Current_Parameter : Node_Id;
7730 Ordered_Parameters_List : constant List_Id :=
7731 Build_Ordered_Parameters_List
7732 (Specification (Vis_Decl));
7734 Arguments : constant Entity_Id := Make_Temporary (Loc, 'A');
7735 -- Name of the named values list used to retrieve parameters
7737 Subp_Spec : Node_Id;
7738 -- Subprogram specification
7740 Called_Subprogram : Node_Id;
7741 -- The subprogram to call
7743 begin
7744 if Present (RACW_Type) then
7745 Called_Subprogram :=
7746 New_Occurrence_Of (Parent_Primitive, Loc);
7747 else
7748 Called_Subprogram :=
7749 New_Occurrence_Of
7750 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7751 end if;
7753 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7755 -- Loop through every parameter and get its value from the stream. If
7756 -- the parameter is unconstrained, then the parameter is read using
7757 -- 'Input at the point of declaration.
7759 Current_Parameter := First (Ordered_Parameters_List);
7760 while Present (Current_Parameter) loop
7761 declare
7762 Etyp : Entity_Id;
7763 Constrained : Boolean;
7764 Any : Entity_Id := Empty;
7765 Object : constant Entity_Id := Make_Temporary (Loc, 'P');
7766 Expr : Node_Id := Empty;
7768 Is_Controlling_Formal : constant Boolean :=
7769 Is_RACW_Controlling_Formal
7770 (Current_Parameter, Stub_Type);
7772 Is_First_Controlling_Formal : Boolean := False;
7774 Need_Extra_Constrained : Boolean;
7775 -- True when an extra constrained actual is required
7777 begin
7778 if Is_Controlling_Formal then
7780 -- Controlling formals in distributed object primitive
7781 -- operations are handled specially:
7783 -- - the first controlling formal is used as the
7784 -- target of the call;
7786 -- - the remaining controlling formals are transmitted
7787 -- as RACWs.
7789 Etyp := RACW_Type;
7790 Is_First_Controlling_Formal :=
7791 not First_Controlling_Formal_Seen;
7792 First_Controlling_Formal_Seen := True;
7794 else
7795 Etyp := Etype (Parameter_Type (Current_Parameter));
7796 end if;
7798 Constrained :=
7799 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
7801 if not Is_First_Controlling_Formal then
7802 Any := Make_Temporary (Loc, 'A');
7804 Append_To (Outer_Decls,
7805 Make_Object_Declaration (Loc,
7806 Defining_Identifier => Any,
7807 Object_Definition =>
7808 New_Occurrence_Of (RTE (RE_Any), Loc),
7809 Expression =>
7810 Make_Function_Call (Loc,
7811 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7812 Parameter_Associations => New_List (
7813 PolyORB_Support.Helpers.Build_TypeCode_Call
7814 (Loc, Etyp, Outer_Decls)))));
7816 Append_To (Outer_Statements,
7817 Add_Parameter_To_NVList (Loc,
7818 Parameter => Current_Parameter,
7819 NVList => Arguments,
7820 Constrained => Constrained,
7821 Any => Any));
7822 end if;
7824 if Is_First_Controlling_Formal then
7825 declare
7826 Addr : constant Entity_Id := Make_Temporary (Loc, 'A');
7828 Is_Local : constant Entity_Id :=
7829 Make_Temporary (Loc, 'L');
7831 begin
7832 -- Special case: obtain the first controlling formal
7833 -- from the target of the remote call, instead of the
7834 -- argument list.
7836 Append_To (Outer_Decls,
7837 Make_Object_Declaration (Loc,
7838 Defining_Identifier => Addr,
7839 Object_Definition =>
7840 New_Occurrence_Of (RTE (RE_Address), Loc)));
7842 Append_To (Outer_Decls,
7843 Make_Object_Declaration (Loc,
7844 Defining_Identifier => Is_Local,
7845 Object_Definition =>
7846 New_Occurrence_Of (Standard_Boolean, Loc)));
7848 Append_To (Outer_Statements,
7849 Make_Procedure_Call_Statement (Loc,
7850 Name =>
7851 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7852 Parameter_Associations => New_List (
7853 Make_Selected_Component (Loc,
7854 Prefix =>
7855 New_Occurrence_Of (
7856 Request_Parameter, Loc),
7857 Selector_Name =>
7858 Make_Identifier (Loc, Name_Target)),
7859 New_Occurrence_Of (Is_Local, Loc),
7860 New_Occurrence_Of (Addr, Loc))));
7862 Expr := Unchecked_Convert_To (RACW_Type,
7863 New_Occurrence_Of (Addr, Loc));
7864 end;
7866 elsif In_Present (Current_Parameter)
7867 or else not Out_Present (Current_Parameter)
7868 or else not Constrained
7869 then
7870 -- If an input parameter is constrained, then its reading is
7871 -- deferred until the beginning of the subprogram body. If
7872 -- it is unconstrained, then an expression is built for
7873 -- the object declaration and the variable is set using
7874 -- 'Input instead of 'Read.
7876 if Constrained and then Is_Limited_Type (Etyp) then
7877 Helpers.Assign_Opaque_From_Any (Loc,
7878 Stms => Statements,
7879 Typ => Etyp,
7880 N => New_Occurrence_Of (Any, Loc),
7881 Target => Object);
7883 else
7884 Expr := Helpers.Build_From_Any_Call
7885 (Etyp, New_Occurrence_Of (Any, Loc), Decls);
7887 if Constrained then
7888 Append_To (Statements,
7889 Make_Assignment_Statement (Loc,
7890 Name => New_Occurrence_Of (Object, Loc),
7891 Expression => Expr));
7892 Expr := Empty;
7894 else
7895 -- Expr will be used to initialize (and constrain) the
7896 -- parameter when it is declared.
7897 null;
7898 end if;
7900 null;
7901 end if;
7902 end if;
7904 Need_Extra_Constrained :=
7905 Nkind (Parameter_Type (Current_Parameter)) /=
7906 N_Access_Definition
7907 and then
7908 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7909 and then
7910 Present (Extra_Constrained
7911 (Defining_Identifier (Current_Parameter)));
7913 -- We may not associate an extra constrained actual to a
7914 -- constant object, so if one is needed, declare the actual
7915 -- as a variable even if it won't be modified.
7917 Build_Actual_Object_Declaration
7918 (Object => Object,
7919 Etyp => Etyp,
7920 Variable => Need_Extra_Constrained
7921 or else Out_Present (Current_Parameter),
7922 Expr => Expr,
7923 Decls => Decls);
7924 Set_Etype (Object, Etyp);
7926 -- An out parameter may be written back using a 'Write
7927 -- attribute instead of a 'Output because it has been
7928 -- constrained by the parameter given to the caller. Note that
7929 -- out controlling arguments in the case of a RACW are not put
7930 -- back in the stream because the pointer on them has not
7931 -- changed.
7933 if Out_Present (Current_Parameter)
7934 and then not Is_Controlling_Formal
7935 then
7936 Append_To (After_Statements,
7937 Make_Procedure_Call_Statement (Loc,
7938 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
7939 Parameter_Associations => New_List (
7940 New_Occurrence_Of (Any, Loc),
7941 PolyORB_Support.Helpers.Build_To_Any_Call
7942 (Loc, New_Occurrence_Of (Object, Loc), Decls))));
7943 end if;
7945 -- For RACW controlling formals, the Etyp of Object is always
7946 -- an RACW, even if the parameter is not of an anonymous access
7947 -- type. In such case, we need to dereference it at call time.
7949 if Is_Controlling_Formal then
7950 if Nkind (Parameter_Type (Current_Parameter)) /=
7951 N_Access_Definition
7952 then
7953 Append_To (Parameter_List,
7954 Make_Parameter_Association (Loc,
7955 Selector_Name =>
7956 New_Occurrence_Of
7957 (Defining_Identifier (Current_Parameter), Loc),
7958 Explicit_Actual_Parameter =>
7959 Make_Explicit_Dereference (Loc,
7960 Prefix => New_Occurrence_Of (Object, Loc))));
7962 else
7963 Append_To (Parameter_List,
7964 Make_Parameter_Association (Loc,
7965 Selector_Name =>
7966 New_Occurrence_Of
7967 (Defining_Identifier (Current_Parameter), Loc),
7969 Explicit_Actual_Parameter =>
7970 New_Occurrence_Of (Object, Loc)));
7971 end if;
7973 else
7974 Append_To (Parameter_List,
7975 Make_Parameter_Association (Loc,
7976 Selector_Name =>
7977 New_Occurrence_Of (
7978 Defining_Identifier (Current_Parameter), Loc),
7979 Explicit_Actual_Parameter =>
7980 New_Occurrence_Of (Object, Loc)));
7981 end if;
7983 -- If the current parameter needs an extra formal, then read it
7984 -- from the stream and set the corresponding semantic field in
7985 -- the variable. If the kind of the parameter identifier is
7986 -- E_Void, then this is a compiler generated parameter that
7987 -- doesn't need an extra constrained status.
7989 -- The case of Extra_Accessibility should also be handled ???
7991 if Need_Extra_Constrained then
7992 declare
7993 Extra_Parameter : constant Entity_Id :=
7994 Extra_Constrained
7995 (Defining_Identifier
7996 (Current_Parameter));
7998 Extra_Any : constant Entity_Id :=
7999 Make_Temporary (Loc, 'A');
8001 Formal_Entity : constant Entity_Id :=
8002 Make_Defining_Identifier (Loc,
8003 Chars => Chars (Extra_Parameter));
8005 Formal_Type : constant Entity_Id :=
8006 Etype (Extra_Parameter);
8008 begin
8009 Append_To (Outer_Decls,
8010 Make_Object_Declaration (Loc,
8011 Defining_Identifier => Extra_Any,
8012 Object_Definition =>
8013 New_Occurrence_Of (RTE (RE_Any), Loc),
8014 Expression =>
8015 Make_Function_Call (Loc,
8016 Name =>
8017 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8018 Parameter_Associations => New_List (
8019 PolyORB_Support.Helpers.Build_TypeCode_Call
8020 (Loc, Formal_Type, Outer_Decls)))));
8022 Append_To (Outer_Extra_Formal_Statements,
8023 Add_Parameter_To_NVList (Loc,
8024 Parameter => Extra_Parameter,
8025 NVList => Arguments,
8026 Constrained => True,
8027 Any => Extra_Any));
8029 Append_To (Decls,
8030 Make_Object_Declaration (Loc,
8031 Defining_Identifier => Formal_Entity,
8032 Object_Definition =>
8033 New_Occurrence_Of (Formal_Type, Loc)));
8035 Append_To (Statements,
8036 Make_Assignment_Statement (Loc,
8037 Name => New_Occurrence_Of (Formal_Entity, Loc),
8038 Expression =>
8039 PolyORB_Support.Helpers.Build_From_Any_Call
8040 (Formal_Type,
8041 New_Occurrence_Of (Extra_Any, Loc),
8042 Decls)));
8043 Set_Extra_Constrained (Object, Formal_Entity);
8044 end;
8045 end if;
8046 end;
8048 Next (Current_Parameter);
8049 end loop;
8051 -- Extra Formals should go after all the other parameters
8053 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8055 Append_To (Outer_Statements,
8056 Make_Procedure_Call_Statement (Loc,
8057 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8058 Parameter_Associations => New_List (
8059 New_Occurrence_Of (Request_Parameter, Loc),
8060 New_Occurrence_Of (Arguments, Loc))));
8062 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8064 -- The remote subprogram is a function: Build an inner block to be
8065 -- able to hold a potentially unconstrained result in a variable.
8067 declare
8068 Etyp : constant Entity_Id :=
8069 Etype (Result_Definition (Specification (Vis_Decl)));
8070 Result : constant Node_Id := Make_Temporary (Loc, 'R');
8072 begin
8073 Inner_Decls := New_List (
8074 Make_Object_Declaration (Loc,
8075 Defining_Identifier => Result,
8076 Constant_Present => True,
8077 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8078 Expression =>
8079 Make_Function_Call (Loc,
8080 Name => Called_Subprogram,
8081 Parameter_Associations => Parameter_List)));
8083 if Is_Class_Wide_Type (Etyp) then
8085 -- For a remote call to a function with a class-wide type,
8086 -- check that the returned value satisfies the requirements
8087 -- of (RM E.4(18)).
8089 Append_To (Inner_Decls,
8090 Make_Transportable_Check (Loc,
8091 New_Occurrence_Of (Result, Loc)));
8093 end if;
8095 Set_Etype (Result, Etyp);
8096 Append_To (After_Statements,
8097 Make_Procedure_Call_Statement (Loc,
8098 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8099 Parameter_Associations => New_List (
8100 New_Occurrence_Of (Request_Parameter, Loc),
8101 PolyORB_Support.Helpers.Build_To_Any_Call
8102 (Loc, New_Occurrence_Of (Result, Loc), Decls))));
8104 -- A DSA function does not have out or inout arguments
8105 end;
8107 Append_To (Statements,
8108 Make_Block_Statement (Loc,
8109 Declarations => Inner_Decls,
8110 Handled_Statement_Sequence =>
8111 Make_Handled_Sequence_Of_Statements (Loc,
8112 Statements => After_Statements)));
8114 else
8115 -- The remote subprogram is a procedure. We do not need any inner
8116 -- block in this case. No specific processing is required here for
8117 -- the dynamically asynchronous case: the indication of whether
8118 -- call is asynchronous or not is managed by the Sync_Scope
8119 -- attibute of the request, and is handled entirely in the
8120 -- protocol layer.
8122 Append_To (After_Statements,
8123 Make_Procedure_Call_Statement (Loc,
8124 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8125 Parameter_Associations => New_List (
8126 New_Occurrence_Of (Request_Parameter, Loc))));
8128 Append_To (Statements,
8129 Make_Procedure_Call_Statement (Loc,
8130 Name => Called_Subprogram,
8131 Parameter_Associations => Parameter_List));
8133 Append_List_To (Statements, After_Statements);
8134 end if;
8136 Subp_Spec :=
8137 Make_Procedure_Specification (Loc,
8138 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
8140 Parameter_Specifications => New_List (
8141 Make_Parameter_Specification (Loc,
8142 Defining_Identifier => Request_Parameter,
8143 Parameter_Type =>
8144 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8146 -- An exception raised during the execution of an incoming remote
8147 -- subprogram call and that needs to be sent back to the caller is
8148 -- propagated by the receiving stubs, and will be handled by the
8149 -- caller (the distribution runtime).
8151 if Asynchronous and then not Dynamically_Asynchronous then
8153 -- For an asynchronous procedure, add a null exception handler
8155 Excep_Handlers := New_List (
8156 Make_Implicit_Exception_Handler (Loc,
8157 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8158 Statements => New_List (Make_Null_Statement (Loc))));
8160 else
8161 -- In the other cases, if an exception is raised, then the
8162 -- exception occurrence is propagated.
8164 null;
8165 end if;
8167 Append_To (Outer_Statements,
8168 Make_Block_Statement (Loc,
8169 Declarations => Decls,
8170 Handled_Statement_Sequence =>
8171 Make_Handled_Sequence_Of_Statements (Loc,
8172 Statements => Statements)));
8174 return
8175 Make_Subprogram_Body (Loc,
8176 Specification => Subp_Spec,
8177 Declarations => Outer_Decls,
8178 Handled_Statement_Sequence =>
8179 Make_Handled_Sequence_Of_Statements (Loc,
8180 Statements => Outer_Statements,
8181 Exception_Handlers => Excep_Handlers));
8182 end Build_Subprogram_Receiving_Stubs;
8184 -------------
8185 -- Helpers --
8186 -------------
8188 package body Helpers is
8190 -----------------------
8191 -- Local Subprograms --
8192 -----------------------
8194 function Find_Numeric_Representation
8195 (Typ : Entity_Id) return Entity_Id;
8196 -- Given a numeric type Typ, return the smallest integer or modular
8197 -- type from Interfaces, or the smallest floating point type from
8198 -- Standard whose range encompasses that of Typ.
8200 function Make_Helper_Function_Name
8201 (Loc : Source_Ptr;
8202 Typ : Entity_Id;
8203 Nam : Name_Id) return Entity_Id;
8204 -- Return the name to be assigned for helper subprogram Nam of Typ
8206 ------------------------------------------------------------
8207 -- Common subprograms for building various tree fragments --
8208 ------------------------------------------------------------
8210 function Build_Get_Aggregate_Element
8211 (Loc : Source_Ptr;
8212 Any : Entity_Id;
8213 TC : Node_Id;
8214 Idx : Node_Id) return Node_Id;
8215 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8216 -- returning the Idx'th element.
8218 generic
8219 Subprogram : Entity_Id;
8220 -- Reference location for constructed nodes
8222 Arry : Entity_Id;
8223 -- For 'Range and Etype
8225 Indexes : List_Id;
8226 -- For the construction of the innermost element expression
8228 with procedure Add_Process_Element
8229 (Stmts : List_Id;
8230 Any : Entity_Id;
8231 Counter : Entity_Id;
8232 Datum : Node_Id);
8234 procedure Append_Array_Traversal
8235 (Stmts : List_Id;
8236 Any : Entity_Id;
8237 Counter : Entity_Id := Empty;
8238 Depth : Pos := 1);
8239 -- Build nested loop statements that iterate over the elements of an
8240 -- array Arry. The statement(s) built by Add_Process_Element are
8241 -- executed for each element; Indexes is the list of indexes to be
8242 -- used in the construction of the indexed component that denotes the
8243 -- current element. Subprogram is the entity for the subprogram for
8244 -- which this iterator is generated. The generated statements are
8245 -- appended to Stmts.
8247 generic
8248 Rec : Entity_Id;
8249 -- The record entity being dealt with
8251 with procedure Add_Process_Element
8252 (Stmts : List_Id;
8253 Container : Node_Or_Entity_Id;
8254 Counter : in out Int;
8255 Rec : Entity_Id;
8256 Field : Node_Id);
8257 -- Rec is the instance of the record type, or Empty.
8258 -- Field is either the N_Defining_Identifier for a component,
8259 -- or an N_Variant_Part.
8261 procedure Append_Record_Traversal
8262 (Stmts : List_Id;
8263 Clist : Node_Id;
8264 Container : Node_Or_Entity_Id;
8265 Counter : in out Int);
8266 -- Process component list Clist. Individual fields are passed
8267 -- to Field_Processing. Each variant part is also processed.
8268 -- Container is the outer Any (for From_Any/To_Any),
8269 -- the outer typecode (for TC) to which the operation applies.
8271 -----------------------------
8272 -- Append_Record_Traversal --
8273 -----------------------------
8275 procedure Append_Record_Traversal
8276 (Stmts : List_Id;
8277 Clist : Node_Id;
8278 Container : Node_Or_Entity_Id;
8279 Counter : in out Int)
8281 CI : List_Id;
8282 VP : Node_Id;
8283 -- Clist's Component_Items and Variant_Part
8285 Item : Node_Id;
8286 Def : Entity_Id;
8288 begin
8289 if No (Clist) then
8290 return;
8291 end if;
8293 CI := Component_Items (Clist);
8294 VP := Variant_Part (Clist);
8296 Item := First (CI);
8297 while Present (Item) loop
8298 Def := Defining_Identifier (Item);
8300 if not Is_Internal_Name (Chars (Def)) then
8301 Add_Process_Element
8302 (Stmts, Container, Counter, Rec, Def);
8303 end if;
8305 Next (Item);
8306 end loop;
8308 if Present (VP) then
8309 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8310 end if;
8311 end Append_Record_Traversal;
8313 -----------------------------
8314 -- Assign_Opaque_From_Any --
8315 -----------------------------
8317 procedure Assign_Opaque_From_Any
8318 (Loc : Source_Ptr;
8319 Stms : List_Id;
8320 Typ : Entity_Id;
8321 N : Node_Id;
8322 Target : Entity_Id)
8324 Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
8325 Expr : Node_Id;
8327 Read_Call_List : List_Id;
8328 -- List on which to place the 'Read attribute reference
8330 begin
8331 -- Strm : Buffer_Stream_Type;
8333 Append_To (Stms,
8334 Make_Object_Declaration (Loc,
8335 Defining_Identifier => Strm,
8336 Aliased_Present => True,
8337 Object_Definition =>
8338 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
8340 -- Any_To_BS (Strm, A);
8342 Append_To (Stms,
8343 Make_Procedure_Call_Statement (Loc,
8344 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
8345 Parameter_Associations => New_List (
8347 New_Occurrence_Of (Strm, Loc))));
8349 if Transmit_As_Unconstrained (Typ) then
8350 Expr :=
8351 Make_Attribute_Reference (Loc,
8352 Prefix => New_Occurrence_Of (Typ, Loc),
8353 Attribute_Name => Name_Input,
8354 Expressions => New_List (
8355 Make_Attribute_Reference (Loc,
8356 Prefix => New_Occurrence_Of (Strm, Loc),
8357 Attribute_Name => Name_Access)));
8359 -- Target := Typ'Input (Strm'Access)
8361 if Present (Target) then
8362 Append_To (Stms,
8363 Make_Assignment_Statement (Loc,
8364 Name => New_Occurrence_Of (Target, Loc),
8365 Expression => Expr));
8367 -- return Typ'Input (Strm'Access);
8369 else
8370 Append_To (Stms,
8371 Make_Simple_Return_Statement (Loc,
8372 Expression => Expr));
8373 end if;
8375 else
8376 if Present (Target) then
8377 Read_Call_List := Stms;
8378 Expr := New_Occurrence_Of (Target, Loc);
8380 else
8381 declare
8382 Temp : constant Entity_Id := Make_Temporary (Loc, 'R');
8384 begin
8385 Read_Call_List := New_List;
8386 Expr := New_Occurrence_Of (Temp, Loc);
8388 Append_To (Stms, Make_Block_Statement (Loc,
8389 Declarations => New_List (
8390 Make_Object_Declaration (Loc,
8391 Defining_Identifier =>
8392 Temp,
8393 Object_Definition =>
8394 New_Occurrence_Of (Typ, Loc))),
8396 Handled_Statement_Sequence =>
8397 Make_Handled_Sequence_Of_Statements (Loc,
8398 Statements => Read_Call_List)));
8399 end;
8400 end if;
8402 -- Typ'Read (Strm'Access, [Target|Temp])
8404 Append_To (Read_Call_List,
8405 Make_Attribute_Reference (Loc,
8406 Prefix => New_Occurrence_Of (Typ, Loc),
8407 Attribute_Name => Name_Read,
8408 Expressions => New_List (
8409 Make_Attribute_Reference (Loc,
8410 Prefix => New_Occurrence_Of (Strm, Loc),
8411 Attribute_Name => Name_Access),
8412 Expr)));
8414 if No (Target) then
8416 -- return Temp
8418 Append_To (Read_Call_List,
8419 Make_Simple_Return_Statement (Loc,
8420 Expression => New_Copy (Expr)));
8421 end if;
8422 end if;
8423 end Assign_Opaque_From_Any;
8425 -------------------------
8426 -- Build_From_Any_Call --
8427 -------------------------
8429 function Build_From_Any_Call
8430 (Typ : Entity_Id;
8431 N : Node_Id;
8432 Decls : List_Id) return Node_Id
8434 Loc : constant Source_Ptr := Sloc (N);
8436 U_Type : Entity_Id := Underlying_Type (Typ);
8438 Fnam : Entity_Id := Empty;
8439 Lib_RE : RE_Id := RE_Null;
8440 Result : Node_Id;
8442 begin
8443 -- First simple case where the From_Any function is present
8444 -- in the type's TSS.
8446 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8448 -- For the subtype representing a generic actual type, go to the
8449 -- actual type.
8451 if Is_Generic_Actual_Type (U_Type) then
8452 U_Type := Underlying_Type (Base_Type (U_Type));
8453 end if;
8455 -- For a standard subtype, go to the base type
8457 if Sloc (U_Type) <= Standard_Location then
8458 U_Type := Base_Type (U_Type);
8460 -- For a user subtype, go to first subtype
8462 elsif Comes_From_Source (U_Type)
8463 and then Nkind (Declaration_Node (U_Type))
8464 = N_Subtype_Declaration
8465 then
8466 U_Type := First_Subtype (U_Type);
8467 end if;
8469 -- Check first for Boolean and Character. These are enumeration
8470 -- types, but we treat them specially, since they may require
8471 -- special handling in the transfer protocol. However, this
8472 -- special handling only applies if they have standard
8473 -- representation, otherwise they are treated like any other
8474 -- enumeration type.
8476 if Present (Fnam) then
8477 null;
8479 elsif U_Type = Standard_Boolean then
8480 Lib_RE := RE_FA_B;
8482 elsif U_Type = Standard_Character then
8483 Lib_RE := RE_FA_C;
8485 elsif U_Type = Standard_Wide_Character then
8486 Lib_RE := RE_FA_WC;
8488 elsif U_Type = Standard_Wide_Wide_Character then
8489 Lib_RE := RE_FA_WWC;
8491 -- Floating point types
8493 elsif U_Type = Standard_Short_Float then
8494 Lib_RE := RE_FA_SF;
8496 elsif U_Type = Standard_Float then
8497 Lib_RE := RE_FA_F;
8499 elsif U_Type = Standard_Long_Float then
8500 Lib_RE := RE_FA_LF;
8502 elsif U_Type = Standard_Long_Long_Float then
8503 Lib_RE := RE_FA_LLF;
8505 -- Integer types
8507 elsif U_Type = RTE (RE_Integer_8) then
8508 Lib_RE := RE_FA_I8;
8510 elsif U_Type = RTE (RE_Integer_16) then
8511 Lib_RE := RE_FA_I16;
8513 elsif U_Type = RTE (RE_Integer_32) then
8514 Lib_RE := RE_FA_I32;
8516 elsif U_Type = RTE (RE_Integer_64) then
8517 Lib_RE := RE_FA_I64;
8519 -- Unsigned integer types
8521 elsif U_Type = RTE (RE_Unsigned_8) then
8522 Lib_RE := RE_FA_U8;
8524 elsif U_Type = RTE (RE_Unsigned_16) then
8525 Lib_RE := RE_FA_U16;
8527 elsif U_Type = RTE (RE_Unsigned_32) then
8528 Lib_RE := RE_FA_U32;
8530 elsif U_Type = RTE (RE_Unsigned_64) then
8531 Lib_RE := RE_FA_U64;
8533 elsif Is_RTE (U_Type, RE_Unbounded_String) then
8534 Lib_RE := RE_FA_String;
8536 -- Special DSA types
8538 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
8539 Lib_RE := RE_FA_A;
8541 -- Other (non-primitive) types
8543 else
8544 declare
8545 Decl : Entity_Id;
8547 begin
8548 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8549 Append_To (Decls, Decl);
8550 end;
8551 end if;
8553 -- Call the function
8555 if Lib_RE /= RE_Null then
8556 pragma Assert (No (Fnam));
8557 Fnam := RTE (Lib_RE);
8558 end if;
8560 Result :=
8561 Make_Function_Call (Loc,
8562 Name => New_Occurrence_Of (Fnam, Loc),
8563 Parameter_Associations => New_List (N));
8565 -- We must set the type of Result, so the unchecked conversion
8566 -- from the underlying type to the base type is properly done.
8568 Set_Etype (Result, U_Type);
8570 return Unchecked_Convert_To (Typ, Result);
8571 end Build_From_Any_Call;
8573 -----------------------------
8574 -- Build_From_Any_Function --
8575 -----------------------------
8577 procedure Build_From_Any_Function
8578 (Loc : Source_Ptr;
8579 Typ : Entity_Id;
8580 Decl : out Node_Id;
8581 Fnam : out Entity_Id)
8583 Spec : Node_Id;
8584 Decls : constant List_Id := New_List;
8585 Stms : constant List_Id := New_List;
8587 Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A');
8589 Use_Opaque_Representation : Boolean;
8591 begin
8592 -- For a derived type, we can't go past the base type (to the
8593 -- parent type) here, because that would cause the attribute's
8594 -- formal parameter to have the wrong type; hence the Base_Type
8595 -- check here.
8597 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
8598 Build_From_Any_Function
8599 (Loc => Loc,
8600 Typ => Etype (Typ),
8601 Decl => Decl,
8602 Fnam => Fnam);
8603 return;
8604 end if;
8606 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
8608 Spec :=
8609 Make_Function_Specification (Loc,
8610 Defining_Unit_Name => Fnam,
8611 Parameter_Specifications => New_List (
8612 Make_Parameter_Specification (Loc,
8613 Defining_Identifier => Any_Parameter,
8614 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
8615 Result_Definition => New_Occurrence_Of (Typ, Loc));
8617 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8619 pragma Assert
8620 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8622 Use_Opaque_Representation := False;
8624 if Has_Stream_Attribute_Definition
8625 (Typ, TSS_Stream_Output, At_Any_Place => True)
8626 or else
8627 Has_Stream_Attribute_Definition
8628 (Typ, TSS_Stream_Write, At_Any_Place => True)
8629 then
8630 -- If user-defined stream attributes are specified for this
8631 -- type, use them and transmit data as an opaque sequence of
8632 -- stream elements.
8634 Use_Opaque_Representation := True;
8636 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
8637 Append_To (Stms,
8638 Make_Simple_Return_Statement (Loc,
8639 Expression =>
8640 OK_Convert_To (Typ,
8641 Build_From_Any_Call
8642 (Root_Type (Typ),
8643 New_Occurrence_Of (Any_Parameter, Loc),
8644 Decls))));
8646 elsif Is_Record_Type (Typ)
8647 and then not Is_Derived_Type (Typ)
8648 and then not Is_Tagged_Type (Typ)
8649 then
8650 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8651 Append_To (Stms,
8652 Make_Simple_Return_Statement (Loc,
8653 Expression =>
8654 Build_From_Any_Call
8655 (Etype (Typ),
8656 New_Occurrence_Of (Any_Parameter, Loc),
8657 Decls)));
8659 else
8660 declare
8661 Disc : Entity_Id := Empty;
8662 Discriminant_Associations : List_Id;
8663 Rdef : constant Node_Id :=
8664 Type_Definition
8665 (Declaration_Node (Typ));
8666 Component_Counter : Int := 0;
8668 -- The returned object
8670 Res : constant Entity_Id := Make_Temporary (Loc, 'R');
8672 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8674 procedure FA_Rec_Add_Process_Element
8675 (Stmts : List_Id;
8676 Any : Entity_Id;
8677 Counter : in out Int;
8678 Rec : Entity_Id;
8679 Field : Node_Id);
8681 procedure FA_Append_Record_Traversal is
8682 new Append_Record_Traversal
8683 (Rec => Res,
8684 Add_Process_Element => FA_Rec_Add_Process_Element);
8686 --------------------------------
8687 -- FA_Rec_Add_Process_Element --
8688 --------------------------------
8690 procedure FA_Rec_Add_Process_Element
8691 (Stmts : List_Id;
8692 Any : Entity_Id;
8693 Counter : in out Int;
8694 Rec : Entity_Id;
8695 Field : Node_Id)
8697 Ctyp : Entity_Id;
8698 begin
8699 if Nkind (Field) = N_Defining_Identifier then
8700 -- A regular component
8702 Ctyp := Etype (Field);
8704 Append_To (Stmts,
8705 Make_Assignment_Statement (Loc,
8706 Name => Make_Selected_Component (Loc,
8707 Prefix =>
8708 New_Occurrence_Of (Rec, Loc),
8709 Selector_Name =>
8710 New_Occurrence_Of (Field, Loc)),
8712 Expression =>
8713 Build_From_Any_Call (Ctyp,
8714 Build_Get_Aggregate_Element (Loc,
8715 Any => Any,
8716 TC =>
8717 Build_TypeCode_Call (Loc, Ctyp, Decls),
8718 Idx =>
8719 Make_Integer_Literal (Loc, Counter)),
8720 Decls)));
8722 else
8723 -- A variant part
8725 declare
8726 Variant : Node_Id;
8727 Struct_Counter : Int := 0;
8729 Block_Decls : constant List_Id := New_List;
8730 Block_Stmts : constant List_Id := New_List;
8731 VP_Stmts : List_Id;
8733 Alt_List : constant List_Id := New_List;
8734 Choice_List : List_Id;
8736 Struct_Any : constant Entity_Id :=
8737 Make_Temporary (Loc, 'S');
8739 begin
8740 Append_To (Decls,
8741 Make_Object_Declaration (Loc,
8742 Defining_Identifier => Struct_Any,
8743 Constant_Present => True,
8744 Object_Definition =>
8745 New_Occurrence_Of (RTE (RE_Any), Loc),
8746 Expression =>
8747 Make_Function_Call (Loc,
8748 Name =>
8749 New_Occurrence_Of
8750 (RTE (RE_Extract_Union_Value), Loc),
8752 Parameter_Associations => New_List (
8753 Build_Get_Aggregate_Element (Loc,
8754 Any => Any,
8755 TC =>
8756 Make_Function_Call (Loc,
8757 Name => New_Occurrence_Of (
8758 RTE (RE_Any_Member_Type), Loc),
8759 Parameter_Associations =>
8760 New_List (
8761 New_Occurrence_Of (Any, Loc),
8762 Make_Integer_Literal (Loc,
8763 Intval => Counter))),
8764 Idx =>
8765 Make_Integer_Literal (Loc,
8766 Intval => Counter))))));
8768 Append_To (Stmts,
8769 Make_Block_Statement (Loc,
8770 Declarations => Block_Decls,
8771 Handled_Statement_Sequence =>
8772 Make_Handled_Sequence_Of_Statements (Loc,
8773 Statements => Block_Stmts)));
8775 Append_To (Block_Stmts,
8776 Make_Case_Statement (Loc,
8777 Expression =>
8778 Make_Selected_Component (Loc,
8779 Prefix => Rec,
8780 Selector_Name => Chars (Name (Field))),
8781 Alternatives => Alt_List));
8783 Variant := First_Non_Pragma (Variants (Field));
8784 while Present (Variant) loop
8785 Choice_List :=
8786 New_Copy_List_Tree
8787 (Discrete_Choices (Variant));
8789 VP_Stmts := New_List;
8791 -- Struct_Counter should be reset before
8792 -- handling a variant part. Indeed only one
8793 -- of the case statement alternatives will be
8794 -- executed at run time, so the counter must
8795 -- start at 0 for every case statement.
8797 Struct_Counter := 0;
8799 FA_Append_Record_Traversal (
8800 Stmts => VP_Stmts,
8801 Clist => Component_List (Variant),
8802 Container => Struct_Any,
8803 Counter => Struct_Counter);
8805 Append_To (Alt_List,
8806 Make_Case_Statement_Alternative (Loc,
8807 Discrete_Choices => Choice_List,
8808 Statements => VP_Stmts));
8809 Next_Non_Pragma (Variant);
8810 end loop;
8811 end;
8812 end if;
8814 Counter := Counter + 1;
8815 end FA_Rec_Add_Process_Element;
8817 begin
8818 -- First all discriminants
8820 if Has_Discriminants (Typ) then
8821 Discriminant_Associations := New_List;
8823 Disc := First_Discriminant (Typ);
8824 while Present (Disc) loop
8825 declare
8826 Disc_Var_Name : constant Entity_Id :=
8827 Make_Defining_Identifier (Loc,
8828 Chars => Chars (Disc));
8829 Disc_Type : constant Entity_Id :=
8830 Etype (Disc);
8832 begin
8833 Append_To (Decls,
8834 Make_Object_Declaration (Loc,
8835 Defining_Identifier => Disc_Var_Name,
8836 Constant_Present => True,
8837 Object_Definition =>
8838 New_Occurrence_Of (Disc_Type, Loc),
8840 Expression =>
8841 Build_From_Any_Call (Disc_Type,
8842 Build_Get_Aggregate_Element (Loc,
8843 Any => Any_Parameter,
8844 TC => Build_TypeCode_Call
8845 (Loc, Disc_Type, Decls),
8846 Idx => Make_Integer_Literal (Loc,
8847 Intval => Component_Counter)),
8848 Decls)));
8850 Component_Counter := Component_Counter + 1;
8852 Append_To (Discriminant_Associations,
8853 Make_Discriminant_Association (Loc,
8854 Selector_Names => New_List (
8855 New_Occurrence_Of (Disc, Loc)),
8856 Expression =>
8857 New_Occurrence_Of (Disc_Var_Name, Loc)));
8858 end;
8859 Next_Discriminant (Disc);
8860 end loop;
8862 Res_Definition :=
8863 Make_Subtype_Indication (Loc,
8864 Subtype_Mark => Res_Definition,
8865 Constraint =>
8866 Make_Index_Or_Discriminant_Constraint (Loc,
8867 Discriminant_Associations));
8868 end if;
8870 -- Now we have all the discriminants in variables, we can
8871 -- declared a constrained object. Note that we are not
8872 -- initializing (non-discriminant) components directly in
8873 -- the object declarations, because which fields to
8874 -- initialize depends (at run time) on the discriminant
8875 -- values.
8877 Append_To (Decls,
8878 Make_Object_Declaration (Loc,
8879 Defining_Identifier => Res,
8880 Object_Definition => Res_Definition));
8882 -- ... then all components
8884 FA_Append_Record_Traversal (Stms,
8885 Clist => Component_List (Rdef),
8886 Container => Any_Parameter,
8887 Counter => Component_Counter);
8889 Append_To (Stms,
8890 Make_Simple_Return_Statement (Loc,
8891 Expression => New_Occurrence_Of (Res, Loc)));
8892 end;
8893 end if;
8895 elsif Is_Array_Type (Typ) then
8896 declare
8897 Constrained : constant Boolean := Is_Constrained (Typ);
8899 procedure FA_Ary_Add_Process_Element
8900 (Stmts : List_Id;
8901 Any : Entity_Id;
8902 Counter : Entity_Id;
8903 Datum : Node_Id);
8904 -- Assign the current element (as identified by Counter) of
8905 -- Any to the variable denoted by name Datum, and advance
8906 -- Counter by 1. If Datum is not an Any, a call to From_Any
8907 -- for its type is inserted.
8909 --------------------------------
8910 -- FA_Ary_Add_Process_Element --
8911 --------------------------------
8913 procedure FA_Ary_Add_Process_Element
8914 (Stmts : List_Id;
8915 Any : Entity_Id;
8916 Counter : Entity_Id;
8917 Datum : Node_Id)
8919 Assignment : constant Node_Id :=
8920 Make_Assignment_Statement (Loc,
8921 Name => Datum,
8922 Expression => Empty);
8924 Element_Any : Node_Id;
8926 begin
8927 declare
8928 Element_TC : Node_Id;
8930 begin
8931 if Etype (Datum) = RTE (RE_Any) then
8933 -- When Datum is an Any the Etype field is not
8934 -- sufficient to determine the typecode of Datum
8935 -- (which can be a TC_SEQUENCE or TC_ARRAY
8936 -- depending on the value of Constrained).
8938 -- Therefore we retrieve the typecode which has
8939 -- been constructed in Append_Array_Traversal with
8940 -- a call to Get_Any_Type.
8942 Element_TC :=
8943 Make_Function_Call (Loc,
8944 Name => New_Occurrence_Of (
8945 RTE (RE_Get_Any_Type), Loc),
8946 Parameter_Associations => New_List (
8947 New_Occurrence_Of (Entity (Datum), Loc)));
8948 else
8949 -- For non Any Datum we simply construct a typecode
8950 -- matching the Etype of the Datum.
8952 Element_TC := Build_TypeCode_Call
8953 (Loc, Etype (Datum), Decls);
8954 end if;
8956 Element_Any :=
8957 Build_Get_Aggregate_Element (Loc,
8958 Any => Any,
8959 TC => Element_TC,
8960 Idx => New_Occurrence_Of (Counter, Loc));
8961 end;
8963 -- Note: here we *prepend* statements to Stmts, so
8964 -- we must do it in reverse order.
8966 Prepend_To (Stmts,
8967 Make_Assignment_Statement (Loc,
8968 Name =>
8969 New_Occurrence_Of (Counter, Loc),
8970 Expression =>
8971 Make_Op_Add (Loc,
8972 Left_Opnd => New_Occurrence_Of (Counter, Loc),
8973 Right_Opnd => Make_Integer_Literal (Loc, 1))));
8975 if Nkind (Datum) /= N_Attribute_Reference then
8977 -- We ignore the value of the length of each
8978 -- dimension, since the target array has already been
8979 -- constrained anyway.
8981 if Etype (Datum) /= RTE (RE_Any) then
8982 Set_Expression (Assignment,
8983 Build_From_Any_Call
8984 (Component_Type (Typ), Element_Any, Decls));
8985 else
8986 Set_Expression (Assignment, Element_Any);
8987 end if;
8989 Prepend_To (Stmts, Assignment);
8990 end if;
8991 end FA_Ary_Add_Process_Element;
8993 ------------------------
8994 -- Local Declarations --
8995 ------------------------
8997 Counter : constant Entity_Id :=
8998 Make_Defining_Identifier (Loc, Name_J);
9000 Initial_Counter_Value : Int := 0;
9002 Component_TC : constant Entity_Id :=
9003 Make_Defining_Identifier (Loc, Name_T);
9005 Res : constant Entity_Id :=
9006 Make_Defining_Identifier (Loc, Name_R);
9008 procedure Append_From_Any_Array_Iterator is
9009 new Append_Array_Traversal (
9010 Subprogram => Fnam,
9011 Arry => Res,
9012 Indexes => New_List,
9013 Add_Process_Element => FA_Ary_Add_Process_Element);
9015 Res_Subtype_Indication : Node_Id :=
9016 New_Occurrence_Of (Typ, Loc);
9018 begin
9019 if not Constrained then
9020 declare
9021 Ndim : constant Int := Number_Dimensions (Typ);
9022 Lnam : Name_Id;
9023 Hnam : Name_Id;
9024 Indx : Node_Id := First_Index (Typ);
9025 Indt : Entity_Id;
9027 Ranges : constant List_Id := New_List;
9029 begin
9030 for J in 1 .. Ndim loop
9031 Lnam := New_External_Name ('L', J);
9032 Hnam := New_External_Name ('H', J);
9034 -- Note, for empty arrays bounds may be out of
9035 -- the range of Etype (Indx).
9037 Indt := Base_Type (Etype (Indx));
9039 Append_To (Decls,
9040 Make_Object_Declaration (Loc,
9041 Defining_Identifier =>
9042 Make_Defining_Identifier (Loc, Lnam),
9043 Constant_Present => True,
9044 Object_Definition =>
9045 New_Occurrence_Of (Indt, Loc),
9046 Expression =>
9047 Build_From_Any_Call
9048 (Indt,
9049 Build_Get_Aggregate_Element (Loc,
9050 Any => Any_Parameter,
9051 TC => Build_TypeCode_Call
9052 (Loc, Indt, Decls),
9053 Idx =>
9054 Make_Integer_Literal (Loc, J - 1)),
9055 Decls)));
9057 Append_To (Decls,
9058 Make_Object_Declaration (Loc,
9059 Defining_Identifier =>
9060 Make_Defining_Identifier (Loc, Hnam),
9062 Constant_Present => True,
9064 Object_Definition =>
9065 New_Occurrence_Of (Indt, Loc),
9067 Expression => Make_Attribute_Reference (Loc,
9068 Prefix =>
9069 New_Occurrence_Of (Indt, Loc),
9071 Attribute_Name => Name_Val,
9073 Expressions => New_List (
9074 Make_Op_Subtract (Loc,
9075 Left_Opnd =>
9076 Make_Op_Add (Loc,
9077 Left_Opnd =>
9078 OK_Convert_To
9079 (Standard_Long_Integer,
9080 Make_Identifier (Loc, Lnam)),
9082 Right_Opnd =>
9083 OK_Convert_To
9084 (Standard_Long_Integer,
9085 Make_Function_Call (Loc,
9086 Name =>
9087 New_Occurrence_Of (RTE (
9088 RE_Get_Nested_Sequence_Length
9089 ), Loc),
9090 Parameter_Associations =>
9091 New_List (
9092 New_Occurrence_Of (
9093 Any_Parameter, Loc),
9094 Make_Integer_Literal (Loc,
9095 Intval => J))))),
9097 Right_Opnd =>
9098 Make_Integer_Literal (Loc, 1))))));
9100 Append_To (Ranges,
9101 Make_Range (Loc,
9102 Low_Bound => Make_Identifier (Loc, Lnam),
9103 High_Bound => Make_Identifier (Loc, Hnam)));
9105 Next_Index (Indx);
9106 end loop;
9108 -- Now we have all the necessary bound information:
9109 -- apply the set of range constraints to the
9110 -- (unconstrained) nominal subtype of Res.
9112 Initial_Counter_Value := Ndim;
9113 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9114 Subtype_Mark => Res_Subtype_Indication,
9115 Constraint =>
9116 Make_Index_Or_Discriminant_Constraint (Loc,
9117 Constraints => Ranges));
9118 end;
9119 end if;
9121 Append_To (Decls,
9122 Make_Object_Declaration (Loc,
9123 Defining_Identifier => Res,
9124 Object_Definition => Res_Subtype_Indication));
9125 Set_Etype (Res, Typ);
9127 Append_To (Decls,
9128 Make_Object_Declaration (Loc,
9129 Defining_Identifier => Counter,
9130 Object_Definition =>
9131 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc),
9132 Expression =>
9133 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9135 Append_To (Decls,
9136 Make_Object_Declaration (Loc,
9137 Defining_Identifier => Component_TC,
9138 Constant_Present => True,
9139 Object_Definition =>
9140 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9141 Expression =>
9142 Build_TypeCode_Call (Loc,
9143 Component_Type (Typ), Decls)));
9145 Append_From_Any_Array_Iterator
9146 (Stms, Any_Parameter, Counter);
9148 Append_To (Stms,
9149 Make_Simple_Return_Statement (Loc,
9150 Expression => New_Occurrence_Of (Res, Loc)));
9151 end;
9153 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9154 Append_To (Stms,
9155 Make_Simple_Return_Statement (Loc,
9156 Expression =>
9157 Unchecked_Convert_To (Typ,
9158 Build_From_Any_Call
9159 (Find_Numeric_Representation (Typ),
9160 New_Occurrence_Of (Any_Parameter, Loc),
9161 Decls))));
9163 else
9164 Use_Opaque_Representation := True;
9165 end if;
9167 if Use_Opaque_Representation then
9168 Assign_Opaque_From_Any (Loc,
9169 Stms => Stms,
9170 Typ => Typ,
9171 N => New_Occurrence_Of (Any_Parameter, Loc),
9172 Target => Empty);
9173 end if;
9175 Decl :=
9176 Make_Subprogram_Body (Loc,
9177 Specification => Spec,
9178 Declarations => Decls,
9179 Handled_Statement_Sequence =>
9180 Make_Handled_Sequence_Of_Statements (Loc,
9181 Statements => Stms));
9182 end Build_From_Any_Function;
9184 ---------------------------------
9185 -- Build_Get_Aggregate_Element --
9186 ---------------------------------
9188 function Build_Get_Aggregate_Element
9189 (Loc : Source_Ptr;
9190 Any : Entity_Id;
9191 TC : Node_Id;
9192 Idx : Node_Id) return Node_Id
9194 begin
9195 return Make_Function_Call (Loc,
9196 Name =>
9197 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc),
9198 Parameter_Associations => New_List (
9199 New_Occurrence_Of (Any, Loc),
9201 Idx));
9202 end Build_Get_Aggregate_Element;
9204 -------------------------
9205 -- Build_Reposiroty_Id --
9206 -------------------------
9208 procedure Build_Name_And_Repository_Id
9209 (E : Entity_Id;
9210 Name_Str : out String_Id;
9211 Repo_Id_Str : out String_Id)
9213 begin
9214 Name_Str := Fully_Qualified_Name_String (E, Append_NUL => False);
9215 Start_String;
9216 Store_String_Chars ("DSA:");
9217 Store_String_Chars (Name_Str);
9218 Store_String_Chars (":1.0");
9219 Repo_Id_Str := End_String;
9220 end Build_Name_And_Repository_Id;
9222 -----------------------
9223 -- Build_To_Any_Call --
9224 -----------------------
9226 function Build_To_Any_Call
9227 (Loc : Source_Ptr;
9228 N : Node_Id;
9229 Decls : List_Id) return Node_Id
9231 Typ : Entity_Id := Etype (N);
9232 U_Type : Entity_Id;
9233 C_Type : Entity_Id;
9234 Fnam : Entity_Id := Empty;
9235 Lib_RE : RE_Id := RE_Null;
9237 begin
9238 -- If N is a selected component, then maybe its Etype has not been
9239 -- set yet: try to use Etype of the selector_name in that case.
9241 if No (Typ) and then Nkind (N) = N_Selected_Component then
9242 Typ := Etype (Selector_Name (N));
9243 end if;
9245 pragma Assert (Present (Typ));
9247 -- Get full view for private type, completion for incomplete type
9249 U_Type := Underlying_Type (Typ);
9251 -- First simple case where the To_Any function is present in the
9252 -- type's TSS.
9254 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9256 -- For the subtype representing a generic actual type, go to the
9257 -- actual type.
9259 if Is_Generic_Actual_Type (U_Type) then
9260 U_Type := Underlying_Type (Base_Type (U_Type));
9261 end if;
9263 -- For a standard subtype, go to the base type
9265 if Sloc (U_Type) <= Standard_Location then
9266 U_Type := Base_Type (U_Type);
9268 -- For a user subtype, go to first subtype
9270 elsif Comes_From_Source (U_Type)
9271 and then Nkind (Declaration_Node (U_Type))
9272 = N_Subtype_Declaration
9273 then
9274 U_Type := First_Subtype (U_Type);
9275 end if;
9277 if Present (Fnam) then
9278 null;
9280 -- Check first for Boolean and Character. These are enumeration
9281 -- types, but we treat them specially, since they may require
9282 -- special handling in the transfer protocol. However, this
9283 -- special handling only applies if they have standard
9284 -- representation, otherwise they are treated like any other
9285 -- enumeration type.
9287 elsif U_Type = Standard_Boolean then
9288 Lib_RE := RE_TA_B;
9290 elsif U_Type = Standard_Character then
9291 Lib_RE := RE_TA_C;
9293 elsif U_Type = Standard_Wide_Character then
9294 Lib_RE := RE_TA_WC;
9296 elsif U_Type = Standard_Wide_Wide_Character then
9297 Lib_RE := RE_TA_WWC;
9299 -- Floating point types
9301 elsif U_Type = Standard_Short_Float then
9302 Lib_RE := RE_TA_SF;
9304 elsif U_Type = Standard_Float then
9305 Lib_RE := RE_TA_F;
9307 elsif U_Type = Standard_Long_Float then
9308 Lib_RE := RE_TA_LF;
9310 elsif U_Type = Standard_Long_Long_Float then
9311 Lib_RE := RE_TA_LLF;
9313 -- Integer types
9315 elsif U_Type = RTE (RE_Integer_8) then
9316 Lib_RE := RE_TA_I8;
9318 elsif U_Type = RTE (RE_Integer_16) then
9319 Lib_RE := RE_TA_I16;
9321 elsif U_Type = RTE (RE_Integer_32) then
9322 Lib_RE := RE_TA_I32;
9324 elsif U_Type = RTE (RE_Integer_64) then
9325 Lib_RE := RE_TA_I64;
9327 -- Unsigned integer types
9329 elsif U_Type = RTE (RE_Unsigned_8) then
9330 Lib_RE := RE_TA_U8;
9332 elsif U_Type = RTE (RE_Unsigned_16) then
9333 Lib_RE := RE_TA_U16;
9335 elsif U_Type = RTE (RE_Unsigned_32) then
9336 Lib_RE := RE_TA_U32;
9338 elsif U_Type = RTE (RE_Unsigned_64) then
9339 Lib_RE := RE_TA_U64;
9341 elsif Is_RTE (U_Type, RE_Unbounded_String) then
9342 Lib_RE := RE_TA_String;
9344 -- Special DSA types
9346 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
9347 Lib_RE := RE_TA_A;
9348 U_Type := Typ;
9350 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9352 -- No corresponding FA_TC ???
9354 Lib_RE := RE_TA_TC;
9356 -- Other (non-primitive) types
9358 else
9359 declare
9360 Decl : Entity_Id;
9361 begin
9362 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9363 Append_To (Decls, Decl);
9364 end;
9365 end if;
9367 -- Call the function
9369 if Lib_RE /= RE_Null then
9370 pragma Assert (No (Fnam));
9371 Fnam := RTE (Lib_RE);
9372 end if;
9374 -- If Fnam is already analyzed, find the proper expected type,
9375 -- else we have a newly constructed To_Any function and we know
9376 -- that the expected type of its parameter is U_Type.
9378 if Ekind (Fnam) = E_Function
9379 and then Present (First_Formal (Fnam))
9380 then
9381 C_Type := Etype (First_Formal (Fnam));
9382 else
9383 C_Type := U_Type;
9384 end if;
9386 return
9387 Make_Function_Call (Loc,
9388 Name => New_Occurrence_Of (Fnam, Loc),
9389 Parameter_Associations =>
9390 New_List (OK_Convert_To (C_Type, N)));
9391 end Build_To_Any_Call;
9393 ---------------------------
9394 -- Build_To_Any_Function --
9395 ---------------------------
9397 procedure Build_To_Any_Function
9398 (Loc : Source_Ptr;
9399 Typ : Entity_Id;
9400 Decl : out Node_Id;
9401 Fnam : out Entity_Id)
9403 Spec : Node_Id;
9404 Decls : constant List_Id := New_List;
9405 Stms : constant List_Id := New_List;
9407 Expr_Parameter : Entity_Id;
9408 Any : Entity_Id;
9409 Result_TC : Node_Id;
9411 Any_Decl : Node_Id;
9413 Use_Opaque_Representation : Boolean;
9414 -- When True, use stream attributes and represent type as an
9415 -- opaque sequence of bytes.
9417 begin
9418 -- For a derived type, we can't go past the base type (to the
9419 -- parent type) here, because that would cause the attribute's
9420 -- formal parameter to have the wrong type; hence the Base_Type
9421 -- check here.
9423 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
9424 Build_To_Any_Function
9425 (Loc => Loc,
9426 Typ => Etype (Typ),
9427 Decl => Decl,
9428 Fnam => Fnam);
9429 return;
9430 end if;
9432 Expr_Parameter := Make_Defining_Identifier (Loc, Name_E);
9433 Any := Make_Defining_Identifier (Loc, Name_A);
9434 Result_TC := Build_TypeCode_Call (Loc, Typ, Decls);
9436 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
9438 Spec :=
9439 Make_Function_Specification (Loc,
9440 Defining_Unit_Name => Fnam,
9441 Parameter_Specifications => New_List (
9442 Make_Parameter_Specification (Loc,
9443 Defining_Identifier => Expr_Parameter,
9444 Parameter_Type => New_Occurrence_Of (Typ, Loc))),
9445 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9446 Set_Etype (Expr_Parameter, Typ);
9448 Any_Decl :=
9449 Make_Object_Declaration (Loc,
9450 Defining_Identifier => Any,
9451 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9453 Use_Opaque_Representation := False;
9455 if Has_Stream_Attribute_Definition
9456 (Typ, TSS_Stream_Output, At_Any_Place => True)
9457 or else
9458 Has_Stream_Attribute_Definition
9459 (Typ, TSS_Stream_Write, At_Any_Place => True)
9460 then
9461 -- If user-defined stream attributes are specified for this
9462 -- type, use them and transmit data as an opaque sequence of
9463 -- stream elements.
9465 Use_Opaque_Representation := True;
9467 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9469 -- Non-tagged derived type: convert to root type
9471 declare
9472 Rt_Type : constant Entity_Id := Root_Type (Typ);
9473 Expr : constant Node_Id :=
9474 OK_Convert_To
9475 (Rt_Type,
9476 New_Occurrence_Of (Expr_Parameter, Loc));
9477 begin
9478 Set_Expression (Any_Decl,
9479 Build_To_Any_Call (Loc, Expr, Decls));
9480 end;
9482 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9484 -- Non-tagged record type
9486 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9487 declare
9488 Rt_Type : constant Entity_Id := Etype (Typ);
9489 Expr : constant Node_Id :=
9490 OK_Convert_To (Rt_Type,
9491 New_Occurrence_Of (Expr_Parameter, Loc));
9493 begin
9494 Set_Expression
9495 (Any_Decl, Build_To_Any_Call (Loc, Expr, Decls));
9496 end;
9498 -- Comment needed here (and label on declare block ???)
9500 else
9501 declare
9502 Disc : Entity_Id := Empty;
9503 Rdef : constant Node_Id :=
9504 Type_Definition (Declaration_Node (Typ));
9505 Counter : Int := 0;
9506 Elements : constant List_Id := New_List;
9508 procedure TA_Rec_Add_Process_Element
9509 (Stmts : List_Id;
9510 Container : Node_Or_Entity_Id;
9511 Counter : in out Int;
9512 Rec : Entity_Id;
9513 Field : Node_Id);
9514 -- Processing routine for traversal below
9516 procedure TA_Append_Record_Traversal is
9517 new Append_Record_Traversal
9518 (Rec => Expr_Parameter,
9519 Add_Process_Element => TA_Rec_Add_Process_Element);
9521 --------------------------------
9522 -- TA_Rec_Add_Process_Element --
9523 --------------------------------
9525 procedure TA_Rec_Add_Process_Element
9526 (Stmts : List_Id;
9527 Container : Node_Or_Entity_Id;
9528 Counter : in out Int;
9529 Rec : Entity_Id;
9530 Field : Node_Id)
9532 Field_Ref : Node_Id;
9534 begin
9535 if Nkind (Field) = N_Defining_Identifier then
9537 -- A regular component
9539 Field_Ref := Make_Selected_Component (Loc,
9540 Prefix => New_Occurrence_Of (Rec, Loc),
9541 Selector_Name => New_Occurrence_Of (Field, Loc));
9542 Set_Etype (Field_Ref, Etype (Field));
9544 Append_To (Stmts,
9545 Make_Procedure_Call_Statement (Loc,
9546 Name =>
9547 New_Occurrence_Of (
9548 RTE (RE_Add_Aggregate_Element), Loc),
9549 Parameter_Associations => New_List (
9550 New_Occurrence_Of (Container, Loc),
9551 Build_To_Any_Call (Loc, Field_Ref, Decls))));
9553 else
9554 -- A variant part
9556 Variant_Part : declare
9557 Variant : Node_Id;
9558 Struct_Counter : Int := 0;
9560 Block_Decls : constant List_Id := New_List;
9561 Block_Stmts : constant List_Id := New_List;
9562 VP_Stmts : List_Id;
9564 Alt_List : constant List_Id := New_List;
9565 Choice_List : List_Id;
9567 Union_Any : constant Entity_Id :=
9568 Make_Temporary (Loc, 'V');
9570 Struct_Any : constant Entity_Id :=
9571 Make_Temporary (Loc, 'S');
9573 function Make_Discriminant_Reference
9574 return Node_Id;
9575 -- Build reference to the discriminant for this
9576 -- variant part.
9578 ---------------------------------
9579 -- Make_Discriminant_Reference --
9580 ---------------------------------
9582 function Make_Discriminant_Reference
9583 return Node_Id
9585 Nod : constant Node_Id :=
9586 Make_Selected_Component (Loc,
9587 Prefix => Rec,
9588 Selector_Name =>
9589 Chars (Name (Field)));
9590 begin
9591 Set_Etype (Nod, Etype (Name (Field)));
9592 return Nod;
9593 end Make_Discriminant_Reference;
9595 -- Start of processing for Variant_Part
9597 begin
9598 Append_To (Stmts,
9599 Make_Block_Statement (Loc,
9600 Declarations =>
9601 Block_Decls,
9602 Handled_Statement_Sequence =>
9603 Make_Handled_Sequence_Of_Statements (Loc,
9604 Statements => Block_Stmts)));
9606 -- Declare variant part aggregate (Union_Any).
9607 -- Knowing the position of this VP in the
9608 -- variant record, we can fetch the VP typecode
9609 -- from Container.
9611 Append_To (Block_Decls,
9612 Make_Object_Declaration (Loc,
9613 Defining_Identifier => Union_Any,
9614 Object_Definition =>
9615 New_Occurrence_Of (RTE (RE_Any), Loc),
9616 Expression =>
9617 Make_Function_Call (Loc,
9618 Name => New_Occurrence_Of (
9619 RTE (RE_Create_Any), Loc),
9620 Parameter_Associations => New_List (
9621 Make_Function_Call (Loc,
9622 Name =>
9623 New_Occurrence_Of (
9624 RTE (RE_Any_Member_Type), Loc),
9625 Parameter_Associations => New_List (
9626 New_Occurrence_Of (Container, Loc),
9627 Make_Integer_Literal (Loc,
9628 Counter)))))));
9630 -- Declare inner struct aggregate (which
9631 -- contains the components of this VP).
9633 Append_To (Block_Decls,
9634 Make_Object_Declaration (Loc,
9635 Defining_Identifier => Struct_Any,
9636 Object_Definition =>
9637 New_Occurrence_Of (RTE (RE_Any), Loc),
9638 Expression =>
9639 Make_Function_Call (Loc,
9640 Name => New_Occurrence_Of (
9641 RTE (RE_Create_Any), Loc),
9642 Parameter_Associations => New_List (
9643 Make_Function_Call (Loc,
9644 Name =>
9645 New_Occurrence_Of (
9646 RTE (RE_Any_Member_Type), Loc),
9647 Parameter_Associations => New_List (
9648 New_Occurrence_Of (Union_Any, Loc),
9649 Make_Integer_Literal (Loc,
9650 Uint_1)))))));
9652 -- Build case statement
9654 Append_To (Block_Stmts,
9655 Make_Case_Statement (Loc,
9656 Expression => Make_Discriminant_Reference,
9657 Alternatives => Alt_List));
9659 Variant := First_Non_Pragma (Variants (Field));
9660 while Present (Variant) loop
9661 Choice_List := New_Copy_List_Tree
9662 (Discrete_Choices (Variant));
9664 VP_Stmts := New_List;
9666 -- Append discriminant val to union aggregate
9668 Append_To (VP_Stmts,
9669 Make_Procedure_Call_Statement (Loc,
9670 Name =>
9671 New_Occurrence_Of (
9672 RTE (RE_Add_Aggregate_Element), Loc),
9673 Parameter_Associations => New_List (
9674 New_Occurrence_Of (Union_Any, Loc),
9675 Build_To_Any_Call
9676 (Loc,
9677 Make_Discriminant_Reference,
9678 Block_Decls))));
9680 -- Populate inner struct aggregate
9682 -- Struct_Counter should be reset before
9683 -- handling a variant part. Indeed only one
9684 -- of the case statement alternatives will be
9685 -- executed at run time, so the counter must
9686 -- start at 0 for every case statement.
9688 Struct_Counter := 0;
9690 TA_Append_Record_Traversal
9691 (Stmts => VP_Stmts,
9692 Clist => Component_List (Variant),
9693 Container => Struct_Any,
9694 Counter => Struct_Counter);
9696 -- Append inner struct to union aggregate
9698 Append_To (VP_Stmts,
9699 Make_Procedure_Call_Statement (Loc,
9700 Name =>
9701 New_Occurrence_Of
9702 (RTE (RE_Add_Aggregate_Element), Loc),
9703 Parameter_Associations => New_List (
9704 New_Occurrence_Of (Union_Any, Loc),
9705 New_Occurrence_Of (Struct_Any, Loc))));
9707 -- Append union to outer aggregate
9709 Append_To (VP_Stmts,
9710 Make_Procedure_Call_Statement (Loc,
9711 Name =>
9712 New_Occurrence_Of
9713 (RTE (RE_Add_Aggregate_Element), Loc),
9714 Parameter_Associations => New_List (
9715 New_Occurrence_Of (Container, Loc),
9716 New_Occurrence_Of
9717 (Union_Any, Loc))));
9719 Append_To (Alt_List,
9720 Make_Case_Statement_Alternative (Loc,
9721 Discrete_Choices => Choice_List,
9722 Statements => VP_Stmts));
9724 Next_Non_Pragma (Variant);
9725 end loop;
9726 end Variant_Part;
9727 end if;
9729 Counter := Counter + 1;
9730 end TA_Rec_Add_Process_Element;
9732 begin
9733 -- Records are encoded in a TC_STRUCT aggregate:
9735 -- -- Outer aggregate (TC_STRUCT)
9736 -- | [discriminant1]
9737 -- | [discriminant2]
9738 -- | ...
9739 -- |
9740 -- | [component1]
9741 -- | [component2]
9742 -- | ...
9744 -- A component can be a common component or variant part
9746 -- A variant part is encoded as a TC_UNION aggregate:
9748 -- -- Variant Part Aggregate (TC_UNION)
9749 -- | [discriminant choice for this Variant Part]
9750 -- |
9751 -- | -- Inner struct (TC_STRUCT)
9752 -- | | [component1]
9753 -- | | [component2]
9754 -- | | ...
9756 -- Let's start by building the outer aggregate. First we
9757 -- construct Elements array containing all discriminants.
9759 if Has_Discriminants (Typ) then
9760 Disc := First_Discriminant (Typ);
9761 while Present (Disc) loop
9762 declare
9763 Discriminant : constant Entity_Id :=
9764 Make_Selected_Component (Loc,
9765 Prefix =>
9766 Expr_Parameter,
9767 Selector_Name =>
9768 Chars (Disc));
9770 begin
9771 Set_Etype (Discriminant, Etype (Disc));
9773 Append_To (Elements,
9774 Make_Component_Association (Loc,
9775 Choices => New_List (
9776 Make_Integer_Literal (Loc, Counter)),
9777 Expression =>
9778 Build_To_Any_Call (Loc,
9779 Discriminant, Decls)));
9780 end;
9782 Counter := Counter + 1;
9783 Next_Discriminant (Disc);
9784 end loop;
9786 else
9787 -- If there are no discriminants, we declare an empty
9788 -- Elements array.
9790 declare
9791 Dummy_Any : constant Entity_Id :=
9792 Make_Temporary (Loc, 'A');
9794 begin
9795 Append_To (Decls,
9796 Make_Object_Declaration (Loc,
9797 Defining_Identifier => Dummy_Any,
9798 Object_Definition =>
9799 New_Occurrence_Of (RTE (RE_Any), Loc)));
9801 Append_To (Elements,
9802 Make_Component_Association (Loc,
9803 Choices => New_List (
9804 Make_Range (Loc,
9805 Low_Bound =>
9806 Make_Integer_Literal (Loc, 1),
9807 High_Bound =>
9808 Make_Integer_Literal (Loc, 0))),
9809 Expression =>
9810 New_Occurrence_Of (Dummy_Any, Loc)));
9811 end;
9812 end if;
9814 -- We build the result aggregate with discriminants
9815 -- as the first elements.
9817 Set_Expression (Any_Decl,
9818 Make_Function_Call (Loc,
9819 Name => New_Occurrence_Of
9820 (RTE (RE_Any_Aggregate_Build), Loc),
9821 Parameter_Associations => New_List (
9822 Result_TC,
9823 Make_Aggregate (Loc,
9824 Component_Associations => Elements))));
9825 Result_TC := Empty;
9827 -- Then we append all the components to the result
9828 -- aggregate.
9830 TA_Append_Record_Traversal (Stms,
9831 Clist => Component_List (Rdef),
9832 Container => Any,
9833 Counter => Counter);
9834 end;
9835 end if;
9837 elsif Is_Array_Type (Typ) then
9839 -- Constrained and unconstrained array types
9841 declare
9842 Constrained : constant Boolean := Is_Constrained (Typ);
9844 procedure TA_Ary_Add_Process_Element
9845 (Stmts : List_Id;
9846 Any : Entity_Id;
9847 Counter : Entity_Id;
9848 Datum : Node_Id);
9850 --------------------------------
9851 -- TA_Ary_Add_Process_Element --
9852 --------------------------------
9854 procedure TA_Ary_Add_Process_Element
9855 (Stmts : List_Id;
9856 Any : Entity_Id;
9857 Counter : Entity_Id;
9858 Datum : Node_Id)
9860 pragma Unreferenced (Counter);
9862 Element_Any : Node_Id;
9864 begin
9865 if Etype (Datum) = RTE (RE_Any) then
9866 Element_Any := Datum;
9867 else
9868 Element_Any := Build_To_Any_Call (Loc, Datum, Decls);
9869 end if;
9871 Append_To (Stmts,
9872 Make_Procedure_Call_Statement (Loc,
9873 Name => New_Occurrence_Of (
9874 RTE (RE_Add_Aggregate_Element), Loc),
9875 Parameter_Associations => New_List (
9876 New_Occurrence_Of (Any, Loc),
9877 Element_Any)));
9878 end TA_Ary_Add_Process_Element;
9880 procedure Append_To_Any_Array_Iterator is
9881 new Append_Array_Traversal (
9882 Subprogram => Fnam,
9883 Arry => Expr_Parameter,
9884 Indexes => New_List,
9885 Add_Process_Element => TA_Ary_Add_Process_Element);
9887 Index : Node_Id;
9889 begin
9890 Set_Expression (Any_Decl,
9891 Make_Function_Call (Loc,
9892 Name =>
9893 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9894 Parameter_Associations => New_List (Result_TC)));
9895 Result_TC := Empty;
9897 if not Constrained then
9898 Index := First_Index (Typ);
9899 for J in 1 .. Number_Dimensions (Typ) loop
9900 Append_To (Stms,
9901 Make_Procedure_Call_Statement (Loc,
9902 Name =>
9903 New_Occurrence_Of (
9904 RTE (RE_Add_Aggregate_Element), Loc),
9905 Parameter_Associations => New_List (
9906 New_Occurrence_Of (Any, Loc),
9907 Build_To_Any_Call (Loc,
9908 OK_Convert_To (Etype (Index),
9909 Make_Attribute_Reference (Loc,
9910 Prefix =>
9911 New_Occurrence_Of (Expr_Parameter, Loc),
9912 Attribute_Name => Name_First,
9913 Expressions => New_List (
9914 Make_Integer_Literal (Loc, J)))),
9915 Decls))));
9916 Next_Index (Index);
9917 end loop;
9918 end if;
9920 Append_To_Any_Array_Iterator (Stms, Any);
9921 end;
9923 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9925 -- Integer types
9927 Set_Expression (Any_Decl,
9928 Build_To_Any_Call (Loc,
9929 OK_Convert_To (
9930 Find_Numeric_Representation (Typ),
9931 New_Occurrence_Of (Expr_Parameter, Loc)),
9932 Decls));
9934 else
9935 -- Default case, including tagged types: opaque representation
9937 Use_Opaque_Representation := True;
9938 end if;
9940 if Use_Opaque_Representation then
9941 declare
9942 Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
9943 -- Stream used to store data representation produced by
9944 -- stream attribute.
9946 begin
9947 -- Generate:
9948 -- Strm : aliased Buffer_Stream_Type;
9950 Append_To (Decls,
9951 Make_Object_Declaration (Loc,
9952 Defining_Identifier =>
9953 Strm,
9954 Aliased_Present =>
9955 True,
9956 Object_Definition =>
9957 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9959 -- Generate:
9960 -- T'Output (Strm'Access, E);
9962 Append_To (Stms,
9963 Make_Attribute_Reference (Loc,
9964 Prefix => New_Occurrence_Of (Typ, Loc),
9965 Attribute_Name => Name_Output,
9966 Expressions => New_List (
9967 Make_Attribute_Reference (Loc,
9968 Prefix => New_Occurrence_Of (Strm, Loc),
9969 Attribute_Name => Name_Access),
9970 New_Occurrence_Of (Expr_Parameter, Loc))));
9972 -- Generate:
9973 -- BS_To_Any (Strm, A);
9975 Append_To (Stms,
9976 Make_Procedure_Call_Statement (Loc,
9977 Name => New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
9978 Parameter_Associations => New_List (
9979 New_Occurrence_Of (Strm, Loc),
9980 New_Occurrence_Of (Any, Loc))));
9982 -- Generate:
9983 -- Release_Buffer (Strm);
9985 Append_To (Stms,
9986 Make_Procedure_Call_Statement (Loc,
9987 Name => New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
9988 Parameter_Associations => New_List (
9989 New_Occurrence_Of (Strm, Loc))));
9990 end;
9991 end if;
9993 Append_To (Decls, Any_Decl);
9995 if Present (Result_TC) then
9996 Append_To (Stms,
9997 Make_Procedure_Call_Statement (Loc,
9998 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
9999 Parameter_Associations => New_List (
10000 New_Occurrence_Of (Any, Loc),
10001 Result_TC)));
10002 end if;
10004 Append_To (Stms,
10005 Make_Simple_Return_Statement (Loc,
10006 Expression => New_Occurrence_Of (Any, Loc)));
10008 Decl :=
10009 Make_Subprogram_Body (Loc,
10010 Specification => Spec,
10011 Declarations => Decls,
10012 Handled_Statement_Sequence =>
10013 Make_Handled_Sequence_Of_Statements (Loc,
10014 Statements => Stms));
10015 end Build_To_Any_Function;
10017 -------------------------
10018 -- Build_TypeCode_Call --
10019 -------------------------
10021 function Build_TypeCode_Call
10022 (Loc : Source_Ptr;
10023 Typ : Entity_Id;
10024 Decls : List_Id) return Node_Id
10026 U_Type : Entity_Id := Underlying_Type (Typ);
10027 -- The full view, if Typ is private; the completion,
10028 -- if Typ is incomplete.
10030 Fnam : Entity_Id := Empty;
10031 Lib_RE : RE_Id := RE_Null;
10032 Expr : Node_Id;
10034 begin
10035 -- Special case System.PolyORB.Interface.Any: its primitives have
10036 -- not been set yet, so can't call Find_Inherited_TSS.
10038 if Typ = RTE (RE_Any) then
10039 Fnam := RTE (RE_TC_A);
10041 else
10042 -- First simple case where the TypeCode is present
10043 -- in the type's TSS.
10045 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10046 end if;
10048 -- For the subtype representing a generic actual type, go to the
10049 -- actual type.
10051 if Is_Generic_Actual_Type (U_Type) then
10052 U_Type := Underlying_Type (Base_Type (U_Type));
10053 end if;
10055 -- For a standard subtype, go to the base type
10057 if Sloc (U_Type) <= Standard_Location then
10058 U_Type := Base_Type (U_Type);
10060 -- For a user subtype, go to first subtype
10062 elsif Comes_From_Source (U_Type)
10063 and then Nkind (Declaration_Node (U_Type))
10064 = N_Subtype_Declaration
10065 then
10066 U_Type := First_Subtype (U_Type);
10067 end if;
10069 if No (Fnam) then
10070 if U_Type = Standard_Boolean then
10071 Lib_RE := RE_TC_B;
10073 elsif U_Type = Standard_Character then
10074 Lib_RE := RE_TC_C;
10076 elsif U_Type = Standard_Wide_Character then
10077 Lib_RE := RE_TC_WC;
10079 elsif U_Type = Standard_Wide_Wide_Character then
10080 Lib_RE := RE_TC_WWC;
10082 -- Floating point types
10084 elsif U_Type = Standard_Short_Float then
10085 Lib_RE := RE_TC_SF;
10087 elsif U_Type = Standard_Float then
10088 Lib_RE := RE_TC_F;
10090 elsif U_Type = Standard_Long_Float then
10091 Lib_RE := RE_TC_LF;
10093 elsif U_Type = Standard_Long_Long_Float then
10094 Lib_RE := RE_TC_LLF;
10096 -- Integer types (walk back to the base type)
10098 elsif U_Type = RTE (RE_Integer_8) then
10099 Lib_RE := RE_TC_I8;
10101 elsif U_Type = RTE (RE_Integer_16) then
10102 Lib_RE := RE_TC_I16;
10104 elsif U_Type = RTE (RE_Integer_32) then
10105 Lib_RE := RE_TC_I32;
10107 elsif U_Type = RTE (RE_Integer_64) then
10108 Lib_RE := RE_TC_I64;
10110 -- Unsigned integer types
10112 elsif U_Type = RTE (RE_Unsigned_8) then
10113 Lib_RE := RE_TC_U8;
10115 elsif U_Type = RTE (RE_Unsigned_16) then
10116 Lib_RE := RE_TC_U16;
10118 elsif U_Type = RTE (RE_Unsigned_32) then
10119 Lib_RE := RE_TC_U32;
10121 elsif U_Type = RTE (RE_Unsigned_64) then
10122 Lib_RE := RE_TC_U64;
10124 elsif Is_RTE (U_Type, RE_Unbounded_String) then
10125 Lib_RE := RE_TC_String;
10127 -- Special DSA types
10129 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
10130 Lib_RE := RE_TC_A;
10132 -- Other (non-primitive) types
10134 else
10135 declare
10136 Decl : Entity_Id;
10137 begin
10138 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10139 Append_To (Decls, Decl);
10140 end;
10141 end if;
10143 if Lib_RE /= RE_Null then
10144 Fnam := RTE (Lib_RE);
10145 end if;
10146 end if;
10148 -- Call the function
10150 Expr :=
10151 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10153 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10155 Set_Etype (Expr, RTE (RE_TypeCode));
10157 return Expr;
10158 end Build_TypeCode_Call;
10160 -----------------------------
10161 -- Build_TypeCode_Function --
10162 -----------------------------
10164 procedure Build_TypeCode_Function
10165 (Loc : Source_Ptr;
10166 Typ : Entity_Id;
10167 Decl : out Node_Id;
10168 Fnam : out Entity_Id)
10170 Spec : Node_Id;
10171 Decls : constant List_Id := New_List;
10172 Stms : constant List_Id := New_List;
10174 TCNam : constant Entity_Id :=
10175 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
10177 Parameters : List_Id;
10179 procedure Add_String_Parameter
10180 (S : String_Id;
10181 Parameter_List : List_Id);
10182 -- Add a literal for S to Parameters
10184 procedure Add_TypeCode_Parameter
10185 (TC_Node : Node_Id;
10186 Parameter_List : List_Id);
10187 -- Add the typecode for Typ to Parameters
10189 procedure Add_Long_Parameter
10190 (Expr_Node : Node_Id;
10191 Parameter_List : List_Id);
10192 -- Add a signed long integer expression to Parameters
10194 procedure Initialize_Parameter_List
10195 (Name_String : String_Id;
10196 Repo_Id_String : String_Id;
10197 Parameter_List : out List_Id);
10198 -- Return a list that contains the first two parameters
10199 -- for a parameterized typecode: name and repository id.
10201 function Make_Constructed_TypeCode
10202 (Kind : Entity_Id;
10203 Parameters : List_Id) return Node_Id;
10204 -- Call Build_Complex_TC with the given kind and parameters
10206 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10207 -- Make a return statement that calls Build_Complex_TC with the
10208 -- given typecode kind, and the constructed parameters list.
10210 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10211 -- Return a typecode that is a TC_Alias for the given typecode
10213 --------------------------
10214 -- Add_String_Parameter --
10215 --------------------------
10217 procedure Add_String_Parameter
10218 (S : String_Id;
10219 Parameter_List : List_Id)
10221 begin
10222 Append_To (Parameter_List,
10223 Make_Function_Call (Loc,
10224 Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc),
10225 Parameter_Associations => New_List (
10226 Make_String_Literal (Loc, S))));
10227 end Add_String_Parameter;
10229 ----------------------------
10230 -- Add_TypeCode_Parameter --
10231 ----------------------------
10233 procedure Add_TypeCode_Parameter
10234 (TC_Node : Node_Id;
10235 Parameter_List : List_Id)
10237 begin
10238 Append_To (Parameter_List,
10239 Make_Function_Call (Loc,
10240 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10241 Parameter_Associations => New_List (TC_Node)));
10242 end Add_TypeCode_Parameter;
10244 ------------------------
10245 -- Add_Long_Parameter --
10246 ------------------------
10248 procedure Add_Long_Parameter
10249 (Expr_Node : Node_Id;
10250 Parameter_List : List_Id)
10252 begin
10253 Append_To (Parameter_List,
10254 Make_Function_Call (Loc,
10255 Name =>
10256 New_Occurrence_Of (RTE (RE_TA_I32), Loc),
10257 Parameter_Associations => New_List (Expr_Node)));
10258 end Add_Long_Parameter;
10260 -------------------------------
10261 -- Initialize_Parameter_List --
10262 -------------------------------
10264 procedure Initialize_Parameter_List
10265 (Name_String : String_Id;
10266 Repo_Id_String : String_Id;
10267 Parameter_List : out List_Id)
10269 begin
10270 Parameter_List := New_List;
10271 Add_String_Parameter (Name_String, Parameter_List);
10272 Add_String_Parameter (Repo_Id_String, Parameter_List);
10273 end Initialize_Parameter_List;
10275 ---------------------------
10276 -- Return_Alias_TypeCode --
10277 ---------------------------
10279 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id) is
10280 begin
10281 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10282 Return_Constructed_TypeCode (RTE (RE_Tk_Alias));
10283 end Return_Alias_TypeCode;
10285 -------------------------------
10286 -- Make_Constructed_TypeCode --
10287 -------------------------------
10289 function Make_Constructed_TypeCode
10290 (Kind : Entity_Id;
10291 Parameters : List_Id) return Node_Id
10293 Constructed_TC : constant Node_Id :=
10294 Make_Function_Call (Loc,
10295 Name =>
10296 New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc),
10297 Parameter_Associations => New_List (
10298 New_Occurrence_Of (Kind, Loc),
10299 Make_Aggregate (Loc,
10300 Expressions => Parameters)));
10301 begin
10302 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10303 return Constructed_TC;
10304 end Make_Constructed_TypeCode;
10306 ---------------------------------
10307 -- Return_Constructed_TypeCode --
10308 ---------------------------------
10310 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10311 begin
10312 Append_To (Stms,
10313 Make_Simple_Return_Statement (Loc,
10314 Expression =>
10315 Make_Constructed_TypeCode (Kind, Parameters)));
10316 end Return_Constructed_TypeCode;
10318 ------------------
10319 -- Record types --
10320 ------------------
10322 procedure TC_Rec_Add_Process_Element
10323 (Params : List_Id;
10324 Any : Entity_Id;
10325 Counter : in out Int;
10326 Rec : Entity_Id;
10327 Field : Node_Id);
10329 procedure TC_Append_Record_Traversal is
10330 new Append_Record_Traversal (
10331 Rec => Empty,
10332 Add_Process_Element => TC_Rec_Add_Process_Element);
10334 --------------------------------
10335 -- TC_Rec_Add_Process_Element --
10336 --------------------------------
10338 procedure TC_Rec_Add_Process_Element
10339 (Params : List_Id;
10340 Any : Entity_Id;
10341 Counter : in out Int;
10342 Rec : Entity_Id;
10343 Field : Node_Id)
10345 pragma Unreferenced (Any, Counter, Rec);
10347 begin
10348 if Nkind (Field) = N_Defining_Identifier then
10350 -- A regular component
10352 Add_TypeCode_Parameter
10353 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10354 Get_Name_String (Chars (Field));
10355 Add_String_Parameter (String_From_Name_Buffer, Params);
10357 else
10359 -- A variant part
10361 Variant_Part : declare
10362 Disc_Type : constant Entity_Id := Etype (Name (Field));
10364 Is_Enum : constant Boolean :=
10365 Is_Enumeration_Type (Disc_Type);
10367 Union_TC_Params : List_Id;
10369 U_Name : constant Name_Id :=
10370 New_External_Name (Chars (Typ), 'V', -1);
10372 Name_Str : String_Id;
10373 Struct_TC_Params : List_Id;
10375 Variant : Node_Id;
10376 Choice : Node_Id;
10377 Default : constant Node_Id :=
10378 Make_Integer_Literal (Loc, -1);
10380 Dummy_Counter : Int := 0;
10382 Choice_Index : Int := 0;
10383 -- Index of current choice in TypeCode, used to identify
10384 -- it as the default choice if it is a "when others".
10386 procedure Add_Params_For_Variant_Components;
10387 -- Add a struct TypeCode and a corresponding member name
10388 -- to the union parameter list.
10390 -- Ordering of declarations is a complete mess in this
10391 -- area, it is supposed to be types/variables, then
10392 -- subprogram specs, then subprogram bodies ???
10394 ---------------------------------------
10395 -- Add_Params_For_Variant_Components --
10396 ---------------------------------------
10398 procedure Add_Params_For_Variant_Components is
10399 S_Name : constant Name_Id :=
10400 New_External_Name (U_Name, 'S', -1);
10402 begin
10403 Get_Name_String (S_Name);
10404 Name_Str := String_From_Name_Buffer;
10405 Initialize_Parameter_List
10406 (Name_Str, Name_Str, Struct_TC_Params);
10408 -- Build struct parameters
10410 TC_Append_Record_Traversal (Struct_TC_Params,
10411 Component_List (Variant),
10412 Empty,
10413 Dummy_Counter);
10415 Add_TypeCode_Parameter
10416 (Make_Constructed_TypeCode
10417 (RTE (RE_Tk_Struct), Struct_TC_Params),
10418 Union_TC_Params);
10420 Add_String_Parameter (Name_Str, Union_TC_Params);
10421 end Add_Params_For_Variant_Components;
10423 -- Start of processing for Variant_Part
10425 begin
10426 Get_Name_String (U_Name);
10427 Name_Str := String_From_Name_Buffer;
10429 Initialize_Parameter_List
10430 (Name_Str, Name_Str, Union_TC_Params);
10432 -- Add union in enclosing parameter list
10434 Add_TypeCode_Parameter
10435 (Make_Constructed_TypeCode
10436 (RTE (RE_Tk_Union), Union_TC_Params),
10437 Params);
10439 Add_String_Parameter (Name_Str, Params);
10441 -- Build union parameters
10443 Add_TypeCode_Parameter
10444 (Build_TypeCode_Call (Loc, Disc_Type, Decls),
10445 Union_TC_Params);
10447 Add_Long_Parameter (Default, Union_TC_Params);
10449 Variant := First_Non_Pragma (Variants (Field));
10450 while Present (Variant) loop
10451 Choice := First (Discrete_Choices (Variant));
10452 while Present (Choice) loop
10453 case Nkind (Choice) is
10454 when N_Range =>
10455 declare
10456 L : constant Uint :=
10457 Expr_Value (Low_Bound (Choice));
10458 H : constant Uint :=
10459 Expr_Value (High_Bound (Choice));
10460 J : Uint := L;
10461 -- 3.8.1(8) guarantees that the bounds of
10462 -- this range are static.
10464 Expr : Node_Id;
10466 begin
10467 while J <= H loop
10468 if Is_Enum then
10469 Expr := Get_Enum_Lit_From_Pos
10470 (Disc_Type, J, Loc);
10471 else
10472 Expr :=
10473 Make_Integer_Literal (Loc, J);
10474 end if;
10476 Set_Etype (Expr, Disc_Type);
10477 Append_To (Union_TC_Params,
10478 Build_To_Any_Call (Loc, Expr, Decls));
10480 Add_Params_For_Variant_Components;
10481 J := J + Uint_1;
10482 end loop;
10484 Choice_Index :=
10485 Choice_Index + UI_To_Int (H - L) + 1;
10486 end;
10488 when N_Others_Choice =>
10490 -- This variant has a default choice. We must
10491 -- therefore set the default parameter to the
10492 -- current choice index. This parameter is by
10493 -- construction the 4th in Union_TC_Params.
10495 Replace
10496 (Pick (Union_TC_Params, 4),
10497 Make_Function_Call (Loc,
10498 Name =>
10499 New_Occurrence_Of
10500 (RTE (RE_TA_I32), Loc),
10501 Parameter_Associations =>
10502 New_List (
10503 Make_Integer_Literal (Loc,
10504 Intval => Choice_Index))));
10506 -- Add a placeholder member label for the
10507 -- default case, which must have the
10508 -- discriminant type.
10510 declare
10511 Exp : constant Node_Id :=
10512 Make_Attribute_Reference (Loc,
10513 Prefix => New_Occurrence_Of
10514 (Disc_Type, Loc),
10515 Attribute_Name => Name_First);
10516 begin
10517 Set_Etype (Exp, Disc_Type);
10518 Append_To (Union_TC_Params,
10519 Build_To_Any_Call (Loc, Exp, Decls));
10520 end;
10522 Add_Params_For_Variant_Components;
10523 Choice_Index := Choice_Index + 1;
10525 -- Case of an explicit choice
10527 when others =>
10528 declare
10529 Exp : constant Node_Id :=
10530 New_Copy_Tree (Choice);
10531 begin
10532 Append_To (Union_TC_Params,
10533 Build_To_Any_Call (Loc, Exp, Decls));
10534 end;
10536 Add_Params_For_Variant_Components;
10537 Choice_Index := Choice_Index + 1;
10538 end case;
10540 Next (Choice);
10541 end loop;
10543 Next_Non_Pragma (Variant);
10544 end loop;
10545 end Variant_Part;
10546 end if;
10547 end TC_Rec_Add_Process_Element;
10549 Type_Name_Str : String_Id;
10550 Type_Repo_Id_Str : String_Id;
10552 -- Start of processing for Build_TypeCode_Function
10554 begin
10555 -- For a derived type, we can't go past the base type (to the
10556 -- parent type) here, because that would cause the attribute's
10557 -- formal parameter to have the wrong type; hence the Base_Type
10558 -- check here.
10560 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
10561 Build_TypeCode_Function
10562 (Loc => Loc,
10563 Typ => Etype (Typ),
10564 Decl => Decl,
10565 Fnam => Fnam);
10566 return;
10567 end if;
10569 Fnam := TCNam;
10571 Spec :=
10572 Make_Function_Specification (Loc,
10573 Defining_Unit_Name => Fnam,
10574 Parameter_Specifications => Empty_List,
10575 Result_Definition =>
10576 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10578 Build_Name_And_Repository_Id (Typ,
10579 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10581 Initialize_Parameter_List
10582 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10584 if Has_Stream_Attribute_Definition
10585 (Typ, TSS_Stream_Output, At_Any_Place => True)
10586 or else
10587 Has_Stream_Attribute_Definition
10588 (Typ, TSS_Stream_Write, At_Any_Place => True)
10589 then
10590 -- If user-defined stream attributes are specified for this
10591 -- type, use them and transmit data as an opaque sequence of
10592 -- stream elements.
10594 Return_Alias_TypeCode
10595 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10597 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
10598 Return_Alias_TypeCode (
10599 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10601 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10602 Return_Alias_TypeCode (
10603 Build_TypeCode_Call (Loc,
10604 Find_Numeric_Representation (Typ), Decls));
10606 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
10608 -- Record typecodes are encoded as follows:
10609 -- -- TC_STRUCT
10610 -- |
10611 -- | [Name]
10612 -- | [Repository Id]
10614 -- Then for each discriminant:
10616 -- | [Discriminant Type Code]
10617 -- | [Discriminant Name]
10618 -- | ...
10620 -- Then for each component:
10622 -- | [Component Type Code]
10623 -- | [Component Name]
10624 -- | ...
10626 -- Variants components type codes are encoded as follows:
10627 -- -- TC_UNION
10628 -- |
10629 -- | [Name]
10630 -- | [Repository Id]
10631 -- | [Discriminant Type Code]
10632 -- | [Index of Default Variant Part or -1 for no default]
10634 -- Then for each Variant Part :
10636 -- | [VP Label]
10637 -- |
10638 -- | -- TC_STRUCT
10639 -- | | [Variant Part Name]
10640 -- | | [Variant Part Repository Id]
10641 -- | |
10642 -- | Then for each VP component:
10643 -- | | [VP component Typecode]
10644 -- | | [VP component Name]
10645 -- | | ...
10646 -- | --
10647 -- |
10648 -- | [VP Name]
10650 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10651 Return_Alias_TypeCode
10652 (Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10654 else
10655 declare
10656 Disc : Entity_Id := Empty;
10657 Rdef : constant Node_Id :=
10658 Type_Definition (Declaration_Node (Typ));
10659 Dummy_Counter : Int := 0;
10661 begin
10662 -- Construct the discriminants typecodes
10664 if Has_Discriminants (Typ) then
10665 Disc := First_Discriminant (Typ);
10666 end if;
10668 while Present (Disc) loop
10669 Add_TypeCode_Parameter (
10670 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10671 Parameters);
10672 Get_Name_String (Chars (Disc));
10673 Add_String_Parameter (
10674 String_From_Name_Buffer,
10675 Parameters);
10676 Next_Discriminant (Disc);
10677 end loop;
10679 -- then the components typecodes
10681 TC_Append_Record_Traversal
10682 (Parameters, Component_List (Rdef),
10683 Empty, Dummy_Counter);
10684 Return_Constructed_TypeCode (RTE (RE_Tk_Struct));
10685 end;
10686 end if;
10688 elsif Is_Array_Type (Typ) then
10689 declare
10690 Ndim : constant Pos := Number_Dimensions (Typ);
10691 Inner_TypeCode : Node_Id;
10692 Constrained : constant Boolean := Is_Constrained (Typ);
10693 Indx : Node_Id := First_Index (Typ);
10695 begin
10696 Inner_TypeCode :=
10697 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls);
10699 for J in 1 .. Ndim loop
10700 if Constrained then
10701 Inner_TypeCode := Make_Constructed_TypeCode
10702 (RTE (RE_Tk_Array), New_List (
10703 Build_To_Any_Call (Loc,
10704 OK_Convert_To (RTE (RE_Unsigned_32),
10705 Make_Attribute_Reference (Loc,
10706 Prefix => New_Occurrence_Of (Typ, Loc),
10707 Attribute_Name => Name_Length,
10708 Expressions => New_List (
10709 Make_Integer_Literal (Loc,
10710 Intval => Ndim - J + 1)))),
10711 Decls),
10712 Build_To_Any_Call (Loc, Inner_TypeCode, Decls)));
10714 else
10715 -- Unconstrained case: add low bound for each
10716 -- dimension.
10718 Add_TypeCode_Parameter
10719 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10720 Parameters);
10721 Get_Name_String (New_External_Name ('L', J));
10722 Add_String_Parameter (
10723 String_From_Name_Buffer,
10724 Parameters);
10725 Next_Index (Indx);
10727 Inner_TypeCode := Make_Constructed_TypeCode
10728 (RTE (RE_Tk_Sequence), New_List (
10729 Build_To_Any_Call (Loc,
10730 OK_Convert_To (RTE (RE_Unsigned_32),
10731 Make_Integer_Literal (Loc, 0)),
10732 Decls),
10733 Build_To_Any_Call (Loc, Inner_TypeCode, Decls)));
10734 end if;
10735 end loop;
10737 if Constrained then
10738 Return_Alias_TypeCode (Inner_TypeCode);
10739 else
10740 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10741 Start_String;
10742 Store_String_Char ('V');
10743 Add_String_Parameter (End_String, Parameters);
10744 Return_Constructed_TypeCode (RTE (RE_Tk_Struct));
10745 end if;
10746 end;
10748 else
10749 -- Default: type is represented as an opaque sequence of bytes
10751 Return_Alias_TypeCode
10752 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10753 end if;
10755 Decl :=
10756 Make_Subprogram_Body (Loc,
10757 Specification => Spec,
10758 Declarations => Decls,
10759 Handled_Statement_Sequence =>
10760 Make_Handled_Sequence_Of_Statements (Loc,
10761 Statements => Stms));
10762 end Build_TypeCode_Function;
10764 ---------------------------------
10765 -- Find_Numeric_Representation --
10766 ---------------------------------
10768 function Find_Numeric_Representation
10769 (Typ : Entity_Id) return Entity_Id
10771 FST : constant Entity_Id := First_Subtype (Typ);
10772 P_Size : constant Uint := Esize (FST);
10774 begin
10775 -- Special case: for Stream_Element_Offset and Storage_Offset,
10776 -- always force transmission as a 64-bit value.
10778 if Is_RTE (FST, RE_Stream_Element_Offset)
10779 or else
10780 Is_RTE (FST, RE_Storage_Offset)
10781 then
10782 return RTE (RE_Unsigned_64);
10783 end if;
10785 if Is_Unsigned_Type (Typ) then
10786 if P_Size <= 8 then
10787 return RTE (RE_Unsigned_8);
10789 elsif P_Size <= 16 then
10790 return RTE (RE_Unsigned_16);
10792 elsif P_Size <= 32 then
10793 return RTE (RE_Unsigned_32);
10795 else
10796 return RTE (RE_Unsigned_64);
10797 end if;
10799 elsif Is_Integer_Type (Typ) then
10800 if P_Size <= 8 then
10801 return RTE (RE_Integer_8);
10803 elsif P_Size <= Standard_Short_Integer_Size then
10804 return RTE (RE_Integer_16);
10806 elsif P_Size <= Standard_Integer_Size then
10807 return RTE (RE_Integer_32);
10809 else
10810 return RTE (RE_Integer_64);
10811 end if;
10813 elsif Is_Floating_Point_Type (Typ) then
10814 if P_Size <= Standard_Short_Float_Size then
10815 return Standard_Short_Float;
10817 elsif P_Size <= Standard_Float_Size then
10818 return Standard_Float;
10820 elsif P_Size <= Standard_Long_Float_Size then
10821 return Standard_Long_Float;
10823 else
10824 return Standard_Long_Long_Float;
10825 end if;
10827 else
10828 raise Program_Error;
10829 end if;
10831 -- TBD: fixed point types???
10832 -- TBverified numeric types with a biased representation???
10834 end Find_Numeric_Representation;
10836 ---------------------------
10837 -- Append_Array_Traversal --
10838 ---------------------------
10840 procedure Append_Array_Traversal
10841 (Stmts : List_Id;
10842 Any : Entity_Id;
10843 Counter : Entity_Id := Empty;
10844 Depth : Pos := 1)
10846 Loc : constant Source_Ptr := Sloc (Subprogram);
10847 Typ : constant Entity_Id := Etype (Arry);
10848 Constrained : constant Boolean := Is_Constrained (Typ);
10849 Ndim : constant Pos := Number_Dimensions (Typ);
10851 Inner_Any, Inner_Counter : Entity_Id;
10853 Loop_Stm : Node_Id;
10854 Inner_Stmts : constant List_Id := New_List;
10856 begin
10857 if Depth > Ndim then
10859 -- Processing for one element of an array
10861 declare
10862 Element_Expr : constant Node_Id :=
10863 Make_Indexed_Component (Loc,
10864 New_Occurrence_Of (Arry, Loc),
10865 Indexes);
10866 begin
10867 Set_Etype (Element_Expr, Component_Type (Typ));
10868 Add_Process_Element (Stmts,
10869 Any => Any,
10870 Counter => Counter,
10871 Datum => Element_Expr);
10872 end;
10874 return;
10875 end if;
10877 Append_To (Indexes,
10878 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10880 if not Constrained or else Depth > 1 then
10881 Inner_Any := Make_Defining_Identifier (Loc,
10882 New_External_Name ('A', Depth));
10883 Set_Etype (Inner_Any, RTE (RE_Any));
10884 else
10885 Inner_Any := Empty;
10886 end if;
10888 if Present (Counter) then
10889 Inner_Counter := Make_Defining_Identifier (Loc,
10890 New_External_Name ('J', Depth));
10891 else
10892 Inner_Counter := Empty;
10893 end if;
10895 declare
10896 Loop_Any : Node_Id := Inner_Any;
10898 begin
10899 -- For the first dimension of a constrained array, we add
10900 -- elements directly in the corresponding Any; there is no
10901 -- intervening inner Any.
10903 if No (Loop_Any) then
10904 Loop_Any := Any;
10905 end if;
10907 Append_Array_Traversal (Inner_Stmts,
10908 Any => Loop_Any,
10909 Counter => Inner_Counter,
10910 Depth => Depth + 1);
10911 end;
10913 Loop_Stm :=
10914 Make_Implicit_Loop_Statement (Subprogram,
10915 Iteration_Scheme =>
10916 Make_Iteration_Scheme (Loc,
10917 Loop_Parameter_Specification =>
10918 Make_Loop_Parameter_Specification (Loc,
10919 Defining_Identifier =>
10920 Make_Defining_Identifier (Loc,
10921 Chars => New_External_Name ('L', Depth)),
10923 Discrete_Subtype_Definition =>
10924 Make_Attribute_Reference (Loc,
10925 Prefix => New_Occurrence_Of (Arry, Loc),
10926 Attribute_Name => Name_Range,
10928 Expressions => New_List (
10929 Make_Integer_Literal (Loc, Depth))))),
10930 Statements => Inner_Stmts);
10932 declare
10933 Decls : constant List_Id := New_List;
10934 Dimen_Stmts : constant List_Id := New_List;
10935 Length_Node : Node_Id;
10937 Inner_Any_TypeCode : constant Entity_Id :=
10938 Make_Defining_Identifier (Loc,
10939 New_External_Name ('T', Depth));
10941 Inner_Any_TypeCode_Expr : Node_Id;
10943 begin
10944 if Depth = 1 then
10945 if Constrained then
10946 Inner_Any_TypeCode_Expr :=
10947 Make_Function_Call (Loc,
10948 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
10949 Parameter_Associations => New_List (
10950 New_Occurrence_Of (Any, Loc)));
10952 else
10953 Inner_Any_TypeCode_Expr :=
10954 Make_Function_Call (Loc,
10955 Name =>
10956 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
10957 Parameter_Associations => New_List (
10958 New_Occurrence_Of (Any, Loc),
10959 Make_Integer_Literal (Loc, Ndim)));
10960 end if;
10962 else
10963 Inner_Any_TypeCode_Expr :=
10964 Make_Function_Call (Loc,
10965 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc),
10966 Parameter_Associations => New_List (
10967 Make_Identifier (Loc,
10968 Chars => New_External_Name ('T', Depth - 1))));
10969 end if;
10971 Append_To (Decls,
10972 Make_Object_Declaration (Loc,
10973 Defining_Identifier => Inner_Any_TypeCode,
10974 Constant_Present => True,
10975 Object_Definition => New_Occurrence_Of (
10976 RTE (RE_TypeCode), Loc),
10977 Expression => Inner_Any_TypeCode_Expr));
10979 if Present (Inner_Any) then
10980 Append_To (Decls,
10981 Make_Object_Declaration (Loc,
10982 Defining_Identifier => Inner_Any,
10983 Object_Definition =>
10984 New_Occurrence_Of (RTE (RE_Any), Loc),
10985 Expression =>
10986 Make_Function_Call (Loc,
10987 Name =>
10988 New_Occurrence_Of (
10989 RTE (RE_Create_Any), Loc),
10990 Parameter_Associations => New_List (
10991 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
10992 end if;
10994 if Present (Inner_Counter) then
10995 Append_To (Decls,
10996 Make_Object_Declaration (Loc,
10997 Defining_Identifier => Inner_Counter,
10998 Object_Definition =>
10999 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc),
11000 Expression =>
11001 Make_Integer_Literal (Loc, 0)));
11002 end if;
11004 if not Constrained then
11005 Length_Node := Make_Attribute_Reference (Loc,
11006 Prefix => New_Occurrence_Of (Arry, Loc),
11007 Attribute_Name => Name_Length,
11008 Expressions =>
11009 New_List (Make_Integer_Literal (Loc, Depth)));
11010 Set_Etype (Length_Node, RTE (RE_Unsigned_32));
11012 Add_Process_Element (Dimen_Stmts,
11013 Datum => Length_Node,
11014 Any => Inner_Any,
11015 Counter => Inner_Counter);
11016 end if;
11018 -- Loop_Stm does appropriate processing for each element
11019 -- of Inner_Any.
11021 Append_To (Dimen_Stmts, Loop_Stm);
11023 -- Link outer and inner any
11025 if Present (Inner_Any) then
11026 Add_Process_Element (Dimen_Stmts,
11027 Any => Any,
11028 Counter => Counter,
11029 Datum => New_Occurrence_Of (Inner_Any, Loc));
11030 end if;
11032 Append_To (Stmts,
11033 Make_Block_Statement (Loc,
11034 Declarations =>
11035 Decls,
11036 Handled_Statement_Sequence =>
11037 Make_Handled_Sequence_Of_Statements (Loc,
11038 Statements => Dimen_Stmts)));
11039 end;
11040 end Append_Array_Traversal;
11042 -------------------------------
11043 -- Make_Helper_Function_Name --
11044 -------------------------------
11046 function Make_Helper_Function_Name
11047 (Loc : Source_Ptr;
11048 Typ : Entity_Id;
11049 Nam : Name_Id) return Entity_Id
11051 begin
11052 declare
11053 Serial : Nat := 0;
11054 -- For tagged types that aren't frozen yet, generate the helper
11055 -- under its canonical name so that it matches the primitive
11056 -- spec. For all other cases, we use a serialized name so that
11057 -- multiple generations of the same procedure do not clash.
11059 begin
11060 if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then
11061 null;
11062 else
11063 Serial := Increment_Serial_Number;
11064 end if;
11066 -- Use prefixed underscore to avoid potential clash with user
11067 -- identifier (we use attribute names for Nam).
11069 return
11070 Make_Defining_Identifier (Loc,
11071 Chars =>
11072 New_External_Name
11073 (Related_Id => Nam,
11074 Suffix => ' ',
11075 Suffix_Index => Serial,
11076 Prefix => '_'));
11077 end;
11078 end Make_Helper_Function_Name;
11079 end Helpers;
11081 -----------------------------------
11082 -- Reserve_NamingContext_Methods --
11083 -----------------------------------
11085 procedure Reserve_NamingContext_Methods is
11086 Str_Resolve : constant String := "resolve";
11087 begin
11088 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11089 Name_Len := Str_Resolve'Length;
11090 Overload_Counter_Table.Set (Name_Find, 1);
11091 end Reserve_NamingContext_Methods;
11093 -----------------------
11094 -- RPC_Receiver_Decl --
11095 -----------------------
11097 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is
11098 Loc : constant Source_Ptr := Sloc (RACW_Type);
11099 begin
11100 return
11101 Make_Object_Declaration (Loc,
11102 Defining_Identifier => Make_Temporary (Loc, 'R'),
11103 Aliased_Present => True,
11104 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
11105 end RPC_Receiver_Decl;
11107 end PolyORB_Support;
11109 -------------------------------
11110 -- RACW_Type_Is_Asynchronous --
11111 -------------------------------
11113 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11114 Asynchronous_Flag : constant Entity_Id :=
11115 Asynchronous_Flags_Table.Get (RACW_Type);
11116 begin
11117 Replace (Expression (Parent (Asynchronous_Flag)),
11118 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11119 end RACW_Type_Is_Asynchronous;
11121 -------------------------
11122 -- RCI_Package_Locator --
11123 -------------------------
11125 function RCI_Package_Locator
11126 (Loc : Source_Ptr;
11127 Package_Spec : Node_Id) return Node_Id
11129 Inst : Node_Id;
11130 Pkg_Name : constant String_Id :=
11131 Fully_Qualified_Name_String
11132 (Defining_Entity (Package_Spec), Append_NUL => False);
11134 begin
11135 Inst :=
11136 Make_Package_Instantiation (Loc,
11137 Defining_Unit_Name => Make_Temporary (Loc, 'R'),
11139 Name =>
11140 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11142 Generic_Associations => New_List (
11143 Make_Generic_Association (Loc,
11144 Selector_Name =>
11145 Make_Identifier (Loc, Name_RCI_Name),
11146 Explicit_Generic_Actual_Parameter =>
11147 Make_String_Literal (Loc,
11148 Strval => Pkg_Name)),
11150 Make_Generic_Association (Loc,
11151 Selector_Name =>
11152 Make_Identifier (Loc, Name_Version),
11153 Explicit_Generic_Actual_Parameter =>
11154 Make_Attribute_Reference (Loc,
11155 Prefix =>
11156 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11157 Attribute_Name =>
11158 Name_Version))));
11160 RCI_Locator_Table.Set
11161 (Defining_Unit_Name (Package_Spec),
11162 Defining_Unit_Name (Inst));
11163 return Inst;
11164 end RCI_Package_Locator;
11166 -----------------------------------------------
11167 -- Remote_Types_Tagged_Full_View_Encountered --
11168 -----------------------------------------------
11170 procedure Remote_Types_Tagged_Full_View_Encountered
11171 (Full_View : Entity_Id)
11173 Stub_Elements : constant Stub_Structure :=
11174 Stubs_Table.Get (Full_View);
11176 begin
11177 -- For an RACW encountered before the freeze point of its designated
11178 -- type, the stub type is generated at the point of the RACW declaration
11179 -- but the primitives are generated only once the designated type is
11180 -- frozen. That freeze can occur in another scope, for example when the
11181 -- RACW is declared in a nested package. In that case we need to
11182 -- reestablish the stub type's scope prior to generating its primitive
11183 -- operations.
11185 if Stub_Elements /= Empty_Stub_Structure then
11186 declare
11187 Saved_Scope : constant Entity_Id := Current_Scope;
11188 Stubs_Scope : constant Entity_Id :=
11189 Scope (Stub_Elements.Stub_Type);
11191 begin
11192 if Current_Scope /= Stubs_Scope then
11193 Push_Scope (Stubs_Scope);
11194 end if;
11196 Add_RACW_Primitive_Declarations_And_Bodies
11197 (Full_View,
11198 Stub_Elements.RPC_Receiver_Decl,
11199 Stub_Elements.Body_Decls);
11201 if Current_Scope /= Saved_Scope then
11202 Pop_Scope;
11203 end if;
11204 end;
11205 end if;
11206 end Remote_Types_Tagged_Full_View_Encountered;
11208 -------------------
11209 -- Scope_Of_Spec --
11210 -------------------
11212 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11213 Unit_Name : Node_Id;
11215 begin
11216 Unit_Name := Defining_Unit_Name (Spec);
11217 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11218 Unit_Name := Defining_Identifier (Unit_Name);
11219 end loop;
11221 return Unit_Name;
11222 end Scope_Of_Spec;
11224 ----------------------
11225 -- Set_Renaming_TSS --
11226 ----------------------
11228 procedure Set_Renaming_TSS
11229 (Typ : Entity_Id;
11230 Nam : Entity_Id;
11231 TSS_Nam : TSS_Name_Type)
11233 Loc : constant Source_Ptr := Sloc (Nam);
11234 Spec : constant Node_Id := Parent (Nam);
11236 TSS_Node : constant Node_Id :=
11237 Make_Subprogram_Renaming_Declaration (Loc,
11238 Specification =>
11239 Copy_Specification (Loc,
11240 Spec => Spec,
11241 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11242 Name => New_Occurrence_Of (Nam, Loc));
11244 Snam : constant Entity_Id :=
11245 Defining_Unit_Name (Specification (TSS_Node));
11247 begin
11248 if Nkind (Spec) = N_Function_Specification then
11249 Set_Ekind (Snam, E_Function);
11250 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11251 else
11252 Set_Ekind (Snam, E_Procedure);
11253 Set_Etype (Snam, Standard_Void_Type);
11254 end if;
11256 Set_TSS (Typ, Snam);
11257 end Set_Renaming_TSS;
11259 ----------------------------------------------
11260 -- Specific_Add_Obj_RPC_Receiver_Completion --
11261 ----------------------------------------------
11263 procedure Specific_Add_Obj_RPC_Receiver_Completion
11264 (Loc : Source_Ptr;
11265 Decls : List_Id;
11266 RPC_Receiver : Entity_Id;
11267 Stub_Elements : Stub_Structure)
11269 begin
11270 case Get_PCS_Name is
11271 when Name_PolyORB_DSA =>
11272 PolyORB_Support.Add_Obj_RPC_Receiver_Completion
11273 (Loc, Decls, RPC_Receiver, Stub_Elements);
11274 when others =>
11275 GARLIC_Support.Add_Obj_RPC_Receiver_Completion
11276 (Loc, Decls, RPC_Receiver, Stub_Elements);
11277 end case;
11278 end Specific_Add_Obj_RPC_Receiver_Completion;
11280 --------------------------------
11281 -- Specific_Add_RACW_Features --
11282 --------------------------------
11284 procedure Specific_Add_RACW_Features
11285 (RACW_Type : Entity_Id;
11286 Desig : Entity_Id;
11287 Stub_Type : Entity_Id;
11288 Stub_Type_Access : Entity_Id;
11289 RPC_Receiver_Decl : Node_Id;
11290 Body_Decls : List_Id)
11292 begin
11293 case Get_PCS_Name is
11294 when Name_PolyORB_DSA =>
11295 PolyORB_Support.Add_RACW_Features
11296 (RACW_Type,
11297 Desig,
11298 Stub_Type,
11299 Stub_Type_Access,
11300 RPC_Receiver_Decl,
11301 Body_Decls);
11303 when others =>
11304 GARLIC_Support.Add_RACW_Features
11305 (RACW_Type,
11306 Stub_Type,
11307 Stub_Type_Access,
11308 RPC_Receiver_Decl,
11309 Body_Decls);
11310 end case;
11311 end Specific_Add_RACW_Features;
11313 --------------------------------
11314 -- Specific_Add_RAST_Features --
11315 --------------------------------
11317 procedure Specific_Add_RAST_Features
11318 (Vis_Decl : Node_Id;
11319 RAS_Type : Entity_Id)
11321 begin
11322 case Get_PCS_Name is
11323 when Name_PolyORB_DSA =>
11324 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11325 when others =>
11326 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11327 end case;
11328 end Specific_Add_RAST_Features;
11330 --------------------------------------------------
11331 -- Specific_Add_Receiving_Stubs_To_Declarations --
11332 --------------------------------------------------
11334 procedure Specific_Add_Receiving_Stubs_To_Declarations
11335 (Pkg_Spec : Node_Id;
11336 Decls : List_Id;
11337 Stmts : List_Id)
11339 begin
11340 case Get_PCS_Name is
11341 when Name_PolyORB_DSA =>
11342 PolyORB_Support.Add_Receiving_Stubs_To_Declarations
11343 (Pkg_Spec, Decls, Stmts);
11344 when others =>
11345 GARLIC_Support.Add_Receiving_Stubs_To_Declarations
11346 (Pkg_Spec, Decls, Stmts);
11347 end case;
11348 end Specific_Add_Receiving_Stubs_To_Declarations;
11350 ------------------------------------------
11351 -- Specific_Build_General_Calling_Stubs --
11352 ------------------------------------------
11354 procedure Specific_Build_General_Calling_Stubs
11355 (Decls : List_Id;
11356 Statements : List_Id;
11357 Target : RPC_Target;
11358 Subprogram_Id : Node_Id;
11359 Asynchronous : Node_Id := Empty;
11360 Is_Known_Asynchronous : Boolean := False;
11361 Is_Known_Non_Asynchronous : Boolean := False;
11362 Is_Function : Boolean;
11363 Spec : Node_Id;
11364 Stub_Type : Entity_Id := Empty;
11365 RACW_Type : Entity_Id := Empty;
11366 Nod : Node_Id)
11368 begin
11369 case Get_PCS_Name is
11370 when Name_PolyORB_DSA =>
11371 PolyORB_Support.Build_General_Calling_Stubs
11372 (Decls,
11373 Statements,
11374 Target.Object,
11375 Subprogram_Id,
11376 Asynchronous,
11377 Is_Known_Asynchronous,
11378 Is_Known_Non_Asynchronous,
11379 Is_Function,
11380 Spec,
11381 Stub_Type,
11382 RACW_Type,
11383 Nod);
11385 when others =>
11386 GARLIC_Support.Build_General_Calling_Stubs
11387 (Decls,
11388 Statements,
11389 Target.Partition,
11390 Target.RPC_Receiver,
11391 Subprogram_Id,
11392 Asynchronous,
11393 Is_Known_Asynchronous,
11394 Is_Known_Non_Asynchronous,
11395 Is_Function,
11396 Spec,
11397 Stub_Type,
11398 RACW_Type,
11399 Nod);
11400 end case;
11401 end Specific_Build_General_Calling_Stubs;
11403 --------------------------------------
11404 -- Specific_Build_RPC_Receiver_Body --
11405 --------------------------------------
11407 procedure Specific_Build_RPC_Receiver_Body
11408 (RPC_Receiver : Entity_Id;
11409 Request : out Entity_Id;
11410 Subp_Id : out Entity_Id;
11411 Subp_Index : out Entity_Id;
11412 Stmts : out List_Id;
11413 Decl : out Node_Id)
11415 begin
11416 case Get_PCS_Name is
11417 when Name_PolyORB_DSA =>
11418 PolyORB_Support.Build_RPC_Receiver_Body
11419 (RPC_Receiver,
11420 Request,
11421 Subp_Id,
11422 Subp_Index,
11423 Stmts,
11424 Decl);
11426 when others =>
11427 GARLIC_Support.Build_RPC_Receiver_Body
11428 (RPC_Receiver,
11429 Request,
11430 Subp_Id,
11431 Subp_Index,
11432 Stmts,
11433 Decl);
11434 end case;
11435 end Specific_Build_RPC_Receiver_Body;
11437 --------------------------------
11438 -- Specific_Build_Stub_Target --
11439 --------------------------------
11441 function Specific_Build_Stub_Target
11442 (Loc : Source_Ptr;
11443 Decls : List_Id;
11444 RCI_Locator : Entity_Id;
11445 Controlling_Parameter : Entity_Id) return RPC_Target
11447 begin
11448 case Get_PCS_Name is
11449 when Name_PolyORB_DSA =>
11450 return
11451 PolyORB_Support.Build_Stub_Target
11452 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11454 when others =>
11455 return
11456 GARLIC_Support.Build_Stub_Target
11457 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11458 end case;
11459 end Specific_Build_Stub_Target;
11461 --------------------------------
11462 -- Specific_RPC_Receiver_Decl --
11463 --------------------------------
11465 function Specific_RPC_Receiver_Decl
11466 (RACW_Type : Entity_Id) return Node_Id
11468 begin
11469 case Get_PCS_Name is
11470 when Name_PolyORB_DSA =>
11471 return PolyORB_Support.RPC_Receiver_Decl (RACW_Type);
11473 when others =>
11474 return GARLIC_Support.RPC_Receiver_Decl (RACW_Type);
11475 end case;
11476 end Specific_RPC_Receiver_Decl;
11478 -----------------------------------------------
11479 -- Specific_Build_Subprogram_Receiving_Stubs --
11480 -----------------------------------------------
11482 function Specific_Build_Subprogram_Receiving_Stubs
11483 (Vis_Decl : Node_Id;
11484 Asynchronous : Boolean;
11485 Dynamically_Asynchronous : Boolean := False;
11486 Stub_Type : Entity_Id := Empty;
11487 RACW_Type : Entity_Id := Empty;
11488 Parent_Primitive : Entity_Id := Empty) return Node_Id
11490 begin
11491 case Get_PCS_Name is
11492 when Name_PolyORB_DSA =>
11493 return
11494 PolyORB_Support.Build_Subprogram_Receiving_Stubs
11495 (Vis_Decl,
11496 Asynchronous,
11497 Dynamically_Asynchronous,
11498 Stub_Type,
11499 RACW_Type,
11500 Parent_Primitive);
11502 when others =>
11503 return
11504 GARLIC_Support.Build_Subprogram_Receiving_Stubs
11505 (Vis_Decl,
11506 Asynchronous,
11507 Dynamically_Asynchronous,
11508 Stub_Type,
11509 RACW_Type,
11510 Parent_Primitive);
11511 end case;
11512 end Specific_Build_Subprogram_Receiving_Stubs;
11514 -------------------------------
11515 -- Transmit_As_Unconstrained --
11516 -------------------------------
11518 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
11519 begin
11520 return
11521 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
11522 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
11523 end Transmit_As_Unconstrained;
11525 --------------------------
11526 -- Underlying_RACW_Type --
11527 --------------------------
11529 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11530 Record_Type : Entity_Id;
11532 begin
11533 if Ekind (RAS_Typ) = E_Record_Type then
11534 Record_Type := RAS_Typ;
11535 else
11536 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11537 Record_Type := Equivalent_Type (RAS_Typ);
11538 end if;
11540 return
11541 Etype (Subtype_Indication
11542 (Component_Definition
11543 (First (Component_Items
11544 (Component_List
11545 (Type_Definition
11546 (Declaration_Node (Record_Type))))))));
11547 end Underlying_RACW_Type;
11549 end Exp_Dist;