File : exp_dist.adb
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-2015, 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 ------------------------------------------------------------------------------
25
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;
54
55 with GNAT.HTable; use GNAT.HTable;
56
57 package body Exp_Dist is
58
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:
61
62 -- type Stub is tagged record
63 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
64 -- end record;
65
66 -- is built. This type has two properties:
67
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;
73
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.
81
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.)
90
91 type Hash_Index is range 0 .. 50;
92
93 -----------------------
94 -- Local subprograms --
95 -----------------------
96
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.
100
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.
105
106 type Subprogram_Identifiers is record
107 Str_Identifier : String_Id;
108 Int_Identifier : Int;
109 end record;
110
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.
120
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).
131
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.
140 --
141 -- The integer identifier is used to perform remote calls with GARLIC;
142 -- the string identifier is used in the case of PolyORB.
143 --
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.
149 --
150 -- NOTE: Another design would be to allow a representation clause on
151 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
152
153 pragma Warnings (Off, Get_Subprogram_Id);
154 -- One homonym only is unreferenced (specific to the GARLIC version)
155
156 procedure Add_RAS_Dereference_TSS (N : Node_Id);
157 -- Add a subprogram body for RAS Dereference TSS
158
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.
170
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.
177
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).
185
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.
191
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.
210
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.
216
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.
223
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.
228
229 procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id);
230 -- Add calling stubs to the declarative part
231
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).
235
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.
245
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
252
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
259
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.
266
267 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
268 -- Return the scope represented by a given spec
269
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.
276
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.
280
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.
286
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.
294
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.
306
307 --------------------
308 -- Stub_Structure --
309 --------------------
310
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.
315
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.
323
324 Stub_Type_Access : Entity_Id;
325 -- A local access type designating the stub type (this is not an RACW
326 -- type).
327
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.
334
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.
339
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).
344
345 end record;
346
347 Empty_Stub_Structure : constant Stub_Structure :=
348 (Empty, Empty, Empty, No_List, Empty);
349
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
358
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.
368
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.
378
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
387
388 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure;
389 -- Return the stub information associated with the given RACW type
390
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.
404
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.
408
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.
414
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.
423
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.
429
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;
439
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;
453
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.
466
467 --------------------------------------------
468 -- Hooks for PCS-specific code generation --
469 --------------------------------------------
470
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.
476
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.
489
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.
495
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.
499
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.
506
507 when others =>
508 Partition : Entity_Id;
509 -- A variable containing the Partition_ID of the target partition
510
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;
516
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 in
534 -- 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 : Node with a Parameter_Specifications and a
542 -- Result_Definition if applicable
543 -- Stub_Type : For case of RACW stubs, parameters of type access
544 -- to Stub_Type will be marshalled using the address
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
548
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.
560
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
564
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.
580
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.
595
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.
603
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
609
610 --------------------
611 -- GARLIC_Support --
612 --------------------
613
614 package GARLIC_Support is
615
616 -- Support for generating DSA code that uses the GARLIC PCS
617
618 -- The subprograms below provide the GARLIC versions of the
619 -- corresponding Specific_<subprogram> routine declared above.
620
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);
627
628 procedure Add_RAST_Features
629 (Vis_Decl : Node_Id;
630 RAS_Type : Entity_Id);
631
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);
646
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;
652
653 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id;
654
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;
662
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);
668
669 procedure Add_Receiving_Stubs_To_Declarations
670 (Pkg_Spec : Node_Id;
671 Decls : List_Id;
672 Stmts : List_Id);
673
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);
681
682 end GARLIC_Support;
683
684 ---------------------
685 -- PolyORB_Support --
686 ---------------------
687
688 package PolyORB_Support is
689
690 -- Support for generating DSA code that uses the PolyORB PCS
691
692 -- The subprograms below provide the PolyORB versions of the
693 -- corresponding Specific_<subprogram> routine declared above.
694
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);
702
703 procedure Add_RAST_Features
704 (Vis_Decl : Node_Id;
705 RAS_Type : Entity_Id);
706
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);
720
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;
726
727 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id;
728
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;
736
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);
742
743 procedure Add_Receiving_Stubs_To_Declarations
744 (Pkg_Spec : Node_Id;
745 Decls : List_Id;
746 Stmts : List_Id);
747
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);
755
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).
762
763 -------------
764 -- Helpers --
765 -------------
766
767 package Helpers is
768
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:
774
775 -- A Typecode function returning a high-level description of the
776 -- type's structure;
777
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.
783
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.
793
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.
803
804 function Build_To_Any_Call
805 (Loc : Source_Ptr;
806 N : Node_Id;
807 Decls : List_Id;
808 Constrained : Boolean := False) return Node_Id;
809 -- Build call to To_Any attribute function with expression as actual
810 -- parameter. Loc is the reference location of generated nodes,
811 -- Decls is the declarations list for an appropriate enclosing scope
812 -- of the point where the call will be inserted; if the To_Any
813 -- attribute for the type of N needs to be generated at this point,
814 -- its declaration is appended to Decls. For the case of a limited
815 -- type, there is an additional parameter Constrained indicating
816 -- whether 'Write (when True) or 'Output (when False) is used.
817
818 procedure Build_To_Any_Function
819 (Loc : Source_Ptr;
820 Typ : Entity_Id;
821 Decl : out Node_Id;
822 Fnam : out Entity_Id);
823 -- Build To_Any attribute function for Typ. Loc is the reference
824 -- location for generated nodes, Typ is the type for which the
825 -- conversion function is generated. On return, Decl and Fnam contain
826 -- the declaration and entity for the newly-created function.
827
828 function Build_TypeCode_Call
829 (Loc : Source_Ptr;
830 Typ : Entity_Id;
831 Decls : List_Id) return Node_Id;
832 -- Build call to TypeCode attribute function for Typ. Decls is the
833 -- declarations list for an appropriate enclosing scope of the point
834 -- where the call will be inserted; if the To_Any attribute for Typ
835 -- needs to be generated at this point, its declaration is appended
836 -- to Decls.
837
838 procedure Build_TypeCode_Function
839 (Loc : Source_Ptr;
840 Typ : Entity_Id;
841 Decl : out Node_Id;
842 Fnam : out Entity_Id);
843 -- Build TypeCode attribute function for Typ. Loc is the reference
844 -- location for generated nodes, Typ is the type for which the
845 -- typecode function is generated. On return, Decl and Fnam contain
846 -- the declaration and entity for the newly-created function.
847
848 procedure Build_Name_And_Repository_Id
849 (E : Entity_Id;
850 Name_Str : out String_Id;
851 Repo_Id_Str : out String_Id);
852 -- In the PolyORB distribution model, each distributed object type
853 -- and each distributed operation has a globally unique identifier,
854 -- its Repository Id. This subprogram builds and returns two strings
855 -- for entity E (a distributed object type or operation): one
856 -- containing the name of E, the second containing its repository id.
857
858 procedure Assign_Opaque_From_Any
859 (Loc : Source_Ptr;
860 Stms : List_Id;
861 Typ : Entity_Id;
862 N : Node_Id;
863 Target : Entity_Id;
864 Constrained : Boolean := False);
865 -- For a Target object of type Typ, which has opaque representation
866 -- as a sequence of octets determined by stream attributes (which
867 -- includes all limited types), append code to Stmts performing the
868 -- equivalent of:
869 -- Target := Typ'From_Any (N)
870 --
871 -- or, if Target is Empty:
872 -- return Typ'From_Any (N)
873 --
874 -- Constrained determines whether 'Input (when False) or 'Read
875 -- (when True) is used.
876
877 end Helpers;
878
879 end PolyORB_Support;
880
881 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
882
883 function Build_From_Any_Call
884 (Typ : Entity_Id;
885 N : Node_Id;
886 Decls : List_Id) return Node_Id
887 renames PolyORB_Support.Helpers.Build_From_Any_Call;
888
889 function Build_To_Any_Call
890 (Loc : Source_Ptr;
891 N : Node_Id;
892 Decls : List_Id;
893 Constrained : Boolean := False) return Node_Id
894 renames PolyORB_Support.Helpers.Build_To_Any_Call;
895
896 function Build_TypeCode_Call
897 (Loc : Source_Ptr;
898 Typ : Entity_Id;
899 Decls : List_Id) return Node_Id
900 renames PolyORB_Support.Helpers.Build_TypeCode_Call;
901
902 ------------------------------------
903 -- Local variables and structures --
904 ------------------------------------
905
906 RCI_Cache : Node_Id;
907 -- Needs comments ???
908
909 Output_From_Constrained : constant array (Boolean) of Name_Id :=
910 (False => Name_Output,
911 True => Name_Write);
912 -- The attribute to choose depending on the fact that the parameter
913 -- is constrained or not. There is no such thing as Input_From_Constrained
914 -- since this require separate mechanisms ('Input is a function while
915 -- 'Read is a procedure).
916
917 generic
918 with procedure Process_Subprogram_Declaration (Decl : Node_Id);
919 -- Generate calling or receiving stub for this subprogram declaration
920
921 procedure Build_Package_Stubs (Pkg_Spec : Node_Id);
922 -- Recursively visit the given RCI Package_Specification, calling
923 -- Process_Subprogram_Declaration for each remote subprogram.
924
925 -------------------------
926 -- Build_Package_Stubs --
927 -------------------------
928
929 procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is
930 Decls : constant List_Id := Visible_Declarations (Pkg_Spec);
931 Decl : Node_Id;
932
933 procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id);
934 -- Recurse for the given nested package declaration
935
936 -----------------------
937 -- Visit_Nested_Spec --
938 -----------------------
939
940 procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is
941 Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl);
942 begin
943 Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec));
944 Build_Package_Stubs (Nested_Pkg_Spec);
945 Pop_Scope;
946 end Visit_Nested_Pkg;
947
948 -- Start of processing for Build_Package_Stubs
949
950 begin
951 Decl := First (Decls);
952 while Present (Decl) loop
953 case Nkind (Decl) is
954 when N_Subprogram_Declaration =>
955
956 -- Note: we test Comes_From_Source on Spec, not Decl, because
957 -- in the case of a subprogram instance, only the specification
958 -- (not the declaration) is marked as coming from source.
959
960 if Comes_From_Source (Specification (Decl)) then
961 Process_Subprogram_Declaration (Decl);
962 end if;
963
964 when N_Package_Declaration =>
965
966 -- Case of a nested package or package instantiation coming
967 -- from source. Note that the anonymous wrapper package for
968 -- subprogram instances is not flagged Is_Generic_Instance at
969 -- this point, so there is a distinct circuit to handle them
970 -- (see case N_Subprogram_Instantiation below).
971
972 declare
973 Pkg_Ent : constant Entity_Id :=
974 Defining_Unit_Name (Specification (Decl));
975 begin
976 if Comes_From_Source (Decl)
977 or else
978 (Is_Generic_Instance (Pkg_Ent)
979 and then Comes_From_Source
980 (Get_Package_Instantiation_Node (Pkg_Ent)))
981 then
982 Visit_Nested_Pkg (Decl);
983 end if;
984 end;
985
986 when N_Subprogram_Instantiation =>
987
988 -- The subprogram declaration for an instance of a generic
989 -- subprogram is wrapped in a package that does not come from
990 -- source, so we need to explicitly traverse it here.
991
992 if Comes_From_Source (Decl) then
993 Visit_Nested_Pkg (Instance_Spec (Decl));
994 end if;
995
996 when others =>
997 null;
998 end case;
999 Next (Decl);
1000 end loop;
1001 end Build_Package_Stubs;
1002
1003 ---------------------------------------
1004 -- Add_Calling_Stubs_To_Declarations --
1005 ---------------------------------------
1006
1007 procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is
1008 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
1009
1010 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
1011 -- Subprogram id 0 is reserved for calls received from
1012 -- remote access-to-subprogram dereferences.
1013
1014 RCI_Instantiation : Node_Id;
1015
1016 procedure Visit_Subprogram (Decl : Node_Id);
1017 -- Generate calling stub for one remote subprogram
1018
1019 ----------------------
1020 -- Visit_Subprogram --
1021 ----------------------
1022
1023 procedure Visit_Subprogram (Decl : Node_Id) is
1024 Loc : constant Source_Ptr := Sloc (Decl);
1025 Spec : constant Node_Id := Specification (Decl);
1026 Subp_Stubs : Node_Id;
1027
1028 Subp_Str : String_Id;
1029 pragma Warnings (Off, Subp_Str);
1030
1031 begin
1032 -- Disable expansion of stubs if serious errors have been diagnosed,
1033 -- because otherwise some illegal remote subprogram declarations
1034 -- could cause cascaded errors in stubs.
1035
1036 if Serious_Errors_Detected /= 0 then
1037 return;
1038 end if;
1039
1040 Assign_Subprogram_Identifier
1041 (Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str);
1042
1043 Subp_Stubs :=
1044 Build_Subprogram_Calling_Stubs
1045 (Vis_Decl => Decl,
1046 Subp_Id =>
1047 Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)),
1048 Asynchronous =>
1049 Nkind (Spec) = N_Procedure_Specification
1050 and then Is_Asynchronous (Defining_Unit_Name (Spec)));
1051
1052 Append_To (List_Containing (Decl), Subp_Stubs);
1053 Analyze (Subp_Stubs);
1054
1055 Current_Subprogram_Number := Current_Subprogram_Number + 1;
1056 end Visit_Subprogram;
1057
1058 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
1059
1060 -- Start of processing for Add_Calling_Stubs_To_Declarations
1061
1062 begin
1063 Push_Scope (Scope_Of_Spec (Pkg_Spec));
1064
1065 -- The first thing added is an instantiation of the generic package
1066 -- System.Partition_Interface.RCI_Locator with the name of this remote
1067 -- package. This will act as an interface with the name server to
1068 -- determine the Partition_ID and the RPC_Receiver for the receiver
1069 -- of this package.
1070
1071 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
1072 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
1073
1074 Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation);
1075 Analyze (RCI_Instantiation);
1076
1077 -- For each subprogram declaration visible in the spec, we do build a
1078 -- body. We also increment a counter to assign a different Subprogram_Id
1079 -- to each subprogram. The receiving stubs processing uses the same
1080 -- mechanism and will thus assign the same Id and do the correct
1081 -- dispatching.
1082
1083 Overload_Counter_Table.Reset;
1084 PolyORB_Support.Reserve_NamingContext_Methods;
1085
1086 Visit_Spec (Pkg_Spec);
1087
1088 Pop_Scope;
1089 end Add_Calling_Stubs_To_Declarations;
1090
1091 -----------------------------
1092 -- Add_Parameter_To_NVList --
1093 -----------------------------
1094
1095 function Add_Parameter_To_NVList
1096 (Loc : Source_Ptr;
1097 NVList : Entity_Id;
1098 Parameter : Entity_Id;
1099 Constrained : Boolean;
1100 RACW_Ctrl : Boolean := False;
1101 Any : Entity_Id) return Node_Id
1102 is
1103 Parameter_Name_String : String_Id;
1104 Parameter_Mode : Node_Id;
1105
1106 function Parameter_Passing_Mode
1107 (Loc : Source_Ptr;
1108 Parameter : Entity_Id;
1109 Constrained : Boolean) return Node_Id;
1110 -- Return an expression that denotes the parameter passing mode to be
1111 -- used for Parameter in distribution stubs, where Constrained is
1112 -- Parameter's constrained status.
1113
1114 ----------------------------
1115 -- Parameter_Passing_Mode --
1116 ----------------------------
1117
1118 function Parameter_Passing_Mode
1119 (Loc : Source_Ptr;
1120 Parameter : Entity_Id;
1121 Constrained : Boolean) return Node_Id
1122 is
1123 Lib_RE : RE_Id;
1124
1125 begin
1126 if Out_Present (Parameter) then
1127 if In_Present (Parameter)
1128 or else not Constrained
1129 then
1130 -- Unconstrained formals must be translated
1131 -- to 'in' or 'inout', not 'out', because
1132 -- they need to be constrained by the actual.
1133
1134 Lib_RE := RE_Mode_Inout;
1135 else
1136 Lib_RE := RE_Mode_Out;
1137 end if;
1138
1139 else
1140 Lib_RE := RE_Mode_In;
1141 end if;
1142
1143 return New_Occurrence_Of (RTE (Lib_RE), Loc);
1144 end Parameter_Passing_Mode;
1145
1146 -- Start of processing for Add_Parameter_To_NVList
1147
1148 begin
1149 if Nkind (Parameter) = N_Defining_Identifier then
1150 Get_Name_String (Chars (Parameter));
1151 else
1152 Get_Name_String (Chars (Defining_Identifier (Parameter)));
1153 end if;
1154
1155 Parameter_Name_String := String_From_Name_Buffer;
1156
1157 if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
1158
1159 -- When the parameter passed to Add_Parameter_To_NVList is an
1160 -- Extra_Constrained parameter, Parameter is an N_Defining_
1161 -- Identifier, instead of a complete N_Parameter_Specification.
1162 -- Thus, we explicitly set 'in' mode in this case.
1163
1164 Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
1165
1166 else
1167 Parameter_Mode :=
1168 Parameter_Passing_Mode (Loc, Parameter, Constrained);
1169 end if;
1170
1171 return
1172 Make_Procedure_Call_Statement (Loc,
1173 Name =>
1174 New_Occurrence_Of (RTE (RE_NVList_Add_Item), Loc),
1175 Parameter_Associations => New_List (
1176 New_Occurrence_Of (NVList, Loc),
1177 Make_Function_Call (Loc,
1178 Name =>
1179 New_Occurrence_Of (RTE (RE_To_PolyORB_String), Loc),
1180 Parameter_Associations => New_List (
1181 Make_String_Literal (Loc, Strval => Parameter_Name_String))),
1182 New_Occurrence_Of (Any, Loc),
1183 Parameter_Mode));
1184 end Add_Parameter_To_NVList;
1185
1186 --------------------------------
1187 -- Add_RACW_Asynchronous_Flag --
1188 --------------------------------
1189
1190 procedure Add_RACW_Asynchronous_Flag
1191 (Declarations : List_Id;
1192 RACW_Type : Entity_Id)
1193 is
1194 Loc : constant Source_Ptr := Sloc (RACW_Type);
1195
1196 Asynchronous_Flag : constant Entity_Id :=
1197 Make_Defining_Identifier (Loc,
1198 New_External_Name (Chars (RACW_Type), 'A'));
1199
1200 begin
1201 -- Declare the asynchronous flag. This flag will be changed to True
1202 -- whenever it is known that the RACW type is asynchronous.
1203
1204 Append_To (Declarations,
1205 Make_Object_Declaration (Loc,
1206 Defining_Identifier => Asynchronous_Flag,
1207 Constant_Present => True,
1208 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
1209 Expression => New_Occurrence_Of (Standard_False, Loc)));
1210
1211 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
1212 end Add_RACW_Asynchronous_Flag;
1213
1214 -----------------------
1215 -- Add_RACW_Features --
1216 -----------------------
1217
1218 procedure Add_RACW_Features (RACW_Type : Entity_Id) is
1219 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1220 Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
1221
1222 Pkg_Spec : Node_Id;
1223 Decls : List_Id;
1224 Body_Decls : List_Id;
1225
1226 Stub_Type : Entity_Id;
1227 Stub_Type_Access : Entity_Id;
1228 RPC_Receiver_Decl : Node_Id;
1229
1230 Existing : Boolean;
1231 -- True when appropriate stubs have already been generated (this is the
1232 -- case when another RACW with the same designated type has already been
1233 -- encountered), in which case we reuse the previous stubs rather than
1234 -- generating new ones.
1235
1236 begin
1237 if not Expander_Active then
1238 return;
1239 end if;
1240
1241 -- Mark the current package declaration as containing an RACW, so that
1242 -- the bodies for the calling stubs and the RACW stream subprograms
1243 -- are attached to the tree when the corresponding body is encountered.
1244
1245 Set_Has_RACW (Current_Scope);
1246
1247 -- Look for place to declare the RACW stub type and RACW operations
1248
1249 Pkg_Spec := Empty;
1250
1251 if Same_Scope then
1252
1253 -- Case of declaring the RACW in the same package as its designated
1254 -- type: we know that the designated type is a private type, so we
1255 -- use the private declarations list.
1256
1257 Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
1258
1259 if Present (Private_Declarations (Pkg_Spec)) then
1260 Decls := Private_Declarations (Pkg_Spec);
1261 else
1262 Decls := Visible_Declarations (Pkg_Spec);
1263 end if;
1264
1265 else
1266 -- Case of declaring the RACW in another package than its designated
1267 -- type: use the private declarations list if present; otherwise
1268 -- use the visible declarations.
1269
1270 Decls := List_Containing (Declaration_Node (RACW_Type));
1271
1272 end if;
1273
1274 -- If we were unable to find the declarations, that means that the
1275 -- completion of the type was missing. We can safely return and let the
1276 -- error be caught by the semantic analysis.
1277
1278 if No (Decls) then
1279 return;
1280 end if;
1281
1282 Add_Stub_Type
1283 (Designated_Type => Desig,
1284 RACW_Type => RACW_Type,
1285 Decls => Decls,
1286 Stub_Type => Stub_Type,
1287 Stub_Type_Access => Stub_Type_Access,
1288 RPC_Receiver_Decl => RPC_Receiver_Decl,
1289 Body_Decls => Body_Decls,
1290 Existing => Existing);
1291
1292 -- If this RACW is not in the main unit, do not generate primitive or
1293 -- TSS bodies.
1294
1295 if not Entity_Is_In_Main_Unit (RACW_Type) then
1296 Body_Decls := No_List;
1297 end if;
1298
1299 Add_RACW_Asynchronous_Flag
1300 (Declarations => Decls,
1301 RACW_Type => RACW_Type);
1302
1303 Specific_Add_RACW_Features
1304 (RACW_Type => RACW_Type,
1305 Desig => Desig,
1306 Stub_Type => Stub_Type,
1307 Stub_Type_Access => Stub_Type_Access,
1308 RPC_Receiver_Decl => RPC_Receiver_Decl,
1309 Body_Decls => Body_Decls);
1310
1311 -- If we already have stubs for this designated type, nothing to do
1312
1313 if Existing then
1314 return;
1315 end if;
1316
1317 if Is_Frozen (Desig) then
1318 Validate_RACW_Primitives (RACW_Type);
1319 Add_RACW_Primitive_Declarations_And_Bodies
1320 (Designated_Type => Desig,
1321 Insertion_Node => RPC_Receiver_Decl,
1322 Body_Decls => Body_Decls);
1323
1324 else
1325 -- Validate_RACW_Primitives requires the list of all primitives of
1326 -- the designated type, so defer processing until Desig is frozen.
1327 -- See Exp_Ch3.Freeze_Type.
1328
1329 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
1330 end if;
1331 end Add_RACW_Features;
1332
1333 ------------------------------------------------
1334 -- Add_RACW_Primitive_Declarations_And_Bodies --
1335 ------------------------------------------------
1336
1337 procedure Add_RACW_Primitive_Declarations_And_Bodies
1338 (Designated_Type : Entity_Id;
1339 Insertion_Node : Node_Id;
1340 Body_Decls : List_Id)
1341 is
1342 Loc : constant Source_Ptr := Sloc (Insertion_Node);
1343 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1344 -- the declarations are recognized as belonging to the current package.
1345
1346 Stub_Elements : constant Stub_Structure :=
1347 Stubs_Table.Get (Designated_Type);
1348
1349 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1350
1351 Is_RAS : constant Boolean :=
1352 not Comes_From_Source (Stub_Elements.RACW_Type);
1353 -- Case of the RACW generated to implement a remote access-to-
1354 -- subprogram type.
1355
1356 Build_Bodies : constant Boolean :=
1357 In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
1358 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1359 -- only when the main unit is the unit that contains the stub type.
1360
1361 Current_Insertion_Node : Node_Id := Insertion_Node;
1362
1363 RPC_Receiver : Entity_Id;
1364 RPC_Receiver_Statements : List_Id;
1365 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
1366 RPC_Receiver_Elsif_Parts : List_Id;
1367 RPC_Receiver_Request : Entity_Id;
1368 RPC_Receiver_Subp_Id : Entity_Id;
1369 RPC_Receiver_Subp_Index : Entity_Id;
1370
1371 Subp_Str : String_Id;
1372
1373 Current_Primitive_Elmt : Elmt_Id;
1374 Current_Primitive : Entity_Id;
1375 Current_Primitive_Body : Node_Id;
1376 Current_Primitive_Spec : Node_Id;
1377 Current_Primitive_Decl : Node_Id;
1378 Current_Primitive_Number : Int := 0;
1379 Current_Primitive_Alias : Node_Id;
1380 Current_Receiver : Entity_Id;
1381 Current_Receiver_Body : Node_Id;
1382 RPC_Receiver_Decl : Node_Id;
1383 Possibly_Asynchronous : Boolean;
1384
1385 begin
1386 if not Expander_Active then
1387 return;
1388 end if;
1389
1390 if not Is_RAS then
1391 RPC_Receiver := Make_Temporary (Loc, 'P');
1392
1393 Specific_Build_RPC_Receiver_Body
1394 (RPC_Receiver => RPC_Receiver,
1395 Request => RPC_Receiver_Request,
1396 Subp_Id => RPC_Receiver_Subp_Id,
1397 Subp_Index => RPC_Receiver_Subp_Index,
1398 Stmts => RPC_Receiver_Statements,
1399 Decl => RPC_Receiver_Decl);
1400
1401 if Get_PCS_Name = Name_PolyORB_DSA then
1402
1403 -- For the case of PolyORB, we need to map a textual operation
1404 -- name into a primitive index. Currently we do so using a simple
1405 -- sequence of string comparisons.
1406
1407 RPC_Receiver_Elsif_Parts := New_List;
1408 end if;
1409 end if;
1410
1411 -- Build callers, receivers for every primitive operations and a RPC
1412 -- receiver for this type. Note that we use Direct_Primitive_Operations,
1413 -- not Primitive_Operations, because we really want just the primitives
1414 -- of the tagged type itself, and in the case of a tagged synchronized
1415 -- type we do not want to get the primitives of the corresponding
1416 -- record type).
1417
1418 if Present (Direct_Primitive_Operations (Designated_Type)) then
1419 Overload_Counter_Table.Reset;
1420
1421 Current_Primitive_Elmt :=
1422 First_Elmt (Direct_Primitive_Operations (Designated_Type));
1423 while Current_Primitive_Elmt /= No_Elmt loop
1424 Current_Primitive := Node (Current_Primitive_Elmt);
1425
1426 -- Copy the primitive of all the parents, except predefined ones
1427 -- that are not remotely dispatching. Also omit hidden primitives
1428 -- (occurs in the case of primitives of interface progenitors
1429 -- other than immediate ancestors of the Designated_Type).
1430
1431 if Chars (Current_Primitive) /= Name_uSize
1432 and then Chars (Current_Primitive) /= Name_uAlignment
1433 and then not
1434 (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else
1435 Is_TSS (Current_Primitive, TSS_Stream_Input) or else
1436 Is_TSS (Current_Primitive, TSS_Stream_Output) or else
1437 Is_TSS (Current_Primitive, TSS_Stream_Read) or else
1438 Is_TSS (Current_Primitive, TSS_Stream_Write)
1439 or else
1440 Is_Predefined_Interface_Primitive (Current_Primitive))
1441 and then not Is_Hidden (Current_Primitive)
1442 then
1443 -- The first thing to do is build an up-to-date copy of the
1444 -- spec with all the formals referencing Controlling_Type
1445 -- transformed into formals referencing Stub_Type. Since this
1446 -- primitive may have been inherited, go back the alias chain
1447 -- until the real primitive has been found.
1448
1449 Current_Primitive_Alias := Ultimate_Alias (Current_Primitive);
1450
1451 -- Copy the spec from the original declaration for the purpose
1452 -- of declaring an overriding subprogram: we need to replace
1453 -- the type of each controlling formal with Stub_Type. The
1454 -- primitive may have been declared for Controlling_Type or
1455 -- inherited from some ancestor type for which we do not have
1456 -- an easily determined Entity_Id. We have no systematic way
1457 -- of knowing which type to substitute Stub_Type for. Instead,
1458 -- Copy_Specification relies on the flag Is_Controlling_Formal
1459 -- to determine which formals to change.
1460
1461 Current_Primitive_Spec :=
1462 Copy_Specification (Loc,
1463 Spec => Parent (Current_Primitive_Alias),
1464 Ctrl_Type => Stub_Elements.Stub_Type);
1465
1466 Current_Primitive_Decl :=
1467 Make_Subprogram_Declaration (Loc,
1468 Specification => Current_Primitive_Spec);
1469
1470 Insert_After_And_Analyze (Current_Insertion_Node,
1471 Current_Primitive_Decl);
1472 Current_Insertion_Node := Current_Primitive_Decl;
1473
1474 Possibly_Asynchronous :=
1475 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
1476 and then Could_Be_Asynchronous (Current_Primitive_Spec);
1477
1478 Assign_Subprogram_Identifier (
1479 Defining_Unit_Name (Current_Primitive_Spec),
1480 Current_Primitive_Number,
1481 Subp_Str);
1482
1483 if Build_Bodies then
1484 Current_Primitive_Body :=
1485 Build_Subprogram_Calling_Stubs
1486 (Vis_Decl => Current_Primitive_Decl,
1487 Subp_Id =>
1488 Build_Subprogram_Id (Loc,
1489 Defining_Unit_Name (Current_Primitive_Spec)),
1490 Asynchronous => Possibly_Asynchronous,
1491 Dynamically_Asynchronous => Possibly_Asynchronous,
1492 Stub_Type => Stub_Elements.Stub_Type,
1493 RACW_Type => Stub_Elements.RACW_Type);
1494 Append_To (Body_Decls, Current_Primitive_Body);
1495
1496 -- Analyzing the body here would cause the Stub type to
1497 -- be frozen, thus preventing subsequent primitive
1498 -- declarations. For this reason, it will be analyzed
1499 -- later in the regular flow (and in the context of the
1500 -- appropriate unit body, see Append_RACW_Bodies).
1501
1502 end if;
1503
1504 -- Build the receiver stubs
1505
1506 if Build_Bodies and then not Is_RAS then
1507 Current_Receiver_Body :=
1508 Specific_Build_Subprogram_Receiving_Stubs
1509 (Vis_Decl => Current_Primitive_Decl,
1510 Asynchronous => Possibly_Asynchronous,
1511 Dynamically_Asynchronous => Possibly_Asynchronous,
1512 Stub_Type => Stub_Elements.Stub_Type,
1513 RACW_Type => Stub_Elements.RACW_Type,
1514 Parent_Primitive => Current_Primitive);
1515
1516 Current_Receiver :=
1517 Defining_Unit_Name (Specification (Current_Receiver_Body));
1518
1519 Append_To (Body_Decls, Current_Receiver_Body);
1520
1521 -- Add a case alternative to the receiver
1522
1523 if Get_PCS_Name = Name_PolyORB_DSA then
1524 Append_To (RPC_Receiver_Elsif_Parts,
1525 Make_Elsif_Part (Loc,
1526 Condition =>
1527 Make_Function_Call (Loc,
1528 Name =>
1529 New_Occurrence_Of (
1530 RTE (RE_Caseless_String_Eq), Loc),
1531 Parameter_Associations => New_List (
1532 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
1533 Make_String_Literal (Loc, Subp_Str))),
1534
1535 Then_Statements => New_List (
1536 Make_Assignment_Statement (Loc,
1537 Name => New_Occurrence_Of (
1538 RPC_Receiver_Subp_Index, Loc),
1539 Expression =>
1540 Make_Integer_Literal (Loc,
1541 Intval => Current_Primitive_Number)))));
1542 end if;
1543
1544 Append_To (RPC_Receiver_Case_Alternatives,
1545 Make_Case_Statement_Alternative (Loc,
1546 Discrete_Choices => New_List (
1547 Make_Integer_Literal (Loc, Current_Primitive_Number)),
1548
1549 Statements => New_List (
1550 Make_Procedure_Call_Statement (Loc,
1551 Name =>
1552 New_Occurrence_Of (Current_Receiver, Loc),
1553 Parameter_Associations => New_List (
1554 New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
1555 end if;
1556
1557 -- Increment the index of current primitive
1558
1559 Current_Primitive_Number := Current_Primitive_Number + 1;
1560 end if;
1561
1562 Next_Elmt (Current_Primitive_Elmt);
1563 end loop;
1564 end if;
1565
1566 -- Build the case statement and the heart of the subprogram
1567
1568 if Build_Bodies and then not Is_RAS then
1569 if Get_PCS_Name = Name_PolyORB_DSA
1570 and then Present (First (RPC_Receiver_Elsif_Parts))
1571 then
1572 Append_To (RPC_Receiver_Statements,
1573 Make_Implicit_If_Statement (Designated_Type,
1574 Condition => New_Occurrence_Of (Standard_False, Loc),
1575 Then_Statements => New_List,
1576 Elsif_Parts => RPC_Receiver_Elsif_Parts));
1577 end if;
1578
1579 Append_To (RPC_Receiver_Case_Alternatives,
1580 Make_Case_Statement_Alternative (Loc,
1581 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
1582 Statements => New_List (Make_Null_Statement (Loc))));
1583
1584 Append_To (RPC_Receiver_Statements,
1585 Make_Case_Statement (Loc,
1586 Expression =>
1587 New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
1588 Alternatives => RPC_Receiver_Case_Alternatives));
1589
1590 Append_To (Body_Decls, RPC_Receiver_Decl);
1591 Specific_Add_Obj_RPC_Receiver_Completion (Loc,
1592 Body_Decls, RPC_Receiver, Stub_Elements);
1593
1594 -- Do not analyze RPC receiver body at this stage since it references
1595 -- subprograms that have not been analyzed yet. It will be analyzed in
1596 -- the regular flow (see Append_RACW_Bodies).
1597
1598 end if;
1599 end Add_RACW_Primitive_Declarations_And_Bodies;
1600
1601 -----------------------------
1602 -- Add_RAS_Dereference_TSS --
1603 -----------------------------
1604
1605 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1606 Loc : constant Source_Ptr := Sloc (N);
1607
1608 Type_Def : constant Node_Id := Type_Definition (N);
1609 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1610 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1611 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1612
1613 RACW_Primitive_Name : Node_Id;
1614
1615 Proc : constant Entity_Id :=
1616 Make_Defining_Identifier (Loc,
1617 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1618
1619 Proc_Spec : Node_Id;
1620 Param_Specs : List_Id;
1621 Param_Assoc : constant List_Id := New_List;
1622 Stmts : constant List_Id := New_List;
1623
1624 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'P');
1625
1626 Is_Function : constant Boolean :=
1627 Nkind (Type_Def) = N_Access_Function_Definition;
1628
1629 Is_Degenerate : Boolean;
1630 -- Set to True if the subprogram_specification for this RAS has an
1631 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1632
1633 Spec : constant Node_Id := Type_Def;
1634
1635 Current_Parameter : Node_Id;
1636
1637 -- Start of processing for Add_RAS_Dereference_TSS
1638
1639 begin
1640 -- The Dereference TSS for a remote access-to-subprogram type has the
1641 -- form:
1642
1643 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1644 -- [return <>]
1645
1646 -- This is called whenever a value of a RAS type is dereferenced
1647
1648 -- First construct a list of parameter specifications:
1649
1650 -- The first formal is the RAS values
1651
1652 Param_Specs := New_List (
1653 Make_Parameter_Specification (Loc,
1654 Defining_Identifier => RAS_Parameter,
1655 In_Present => True,
1656 Parameter_Type =>
1657 New_Occurrence_Of (Fat_Type, Loc)));
1658
1659 -- The following formals are copied from the type declaration
1660
1661 Is_Degenerate := False;
1662 Current_Parameter := First (Parameter_Specifications (Type_Def));
1663 Parameters : while Present (Current_Parameter) loop
1664 if Nkind (Parameter_Type (Current_Parameter)) =
1665 N_Access_Definition
1666 then
1667 Is_Degenerate := True;
1668 end if;
1669
1670 Append_To (Param_Specs,
1671 Make_Parameter_Specification (Loc,
1672 Defining_Identifier =>
1673 Make_Defining_Identifier (Loc,
1674 Chars => Chars (Defining_Identifier (Current_Parameter))),
1675 In_Present => In_Present (Current_Parameter),
1676 Out_Present => Out_Present (Current_Parameter),
1677 Parameter_Type =>
1678 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1679 Expression =>
1680 New_Copy_Tree (Expression (Current_Parameter))));
1681
1682 Append_To (Param_Assoc,
1683 Make_Identifier (Loc,
1684 Chars => Chars (Defining_Identifier (Current_Parameter))));
1685
1686 Next (Current_Parameter);
1687 end loop Parameters;
1688
1689 if Is_Degenerate then
1690 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1691
1692 -- Generate a dummy body. This code will never actually be executed,
1693 -- because null is the only legal value for a degenerate RAS type.
1694 -- For legality's sake (in order to avoid generating a function that
1695 -- does not contain a return statement), we include a dummy recursive
1696 -- call on the TSS itself.
1697
1698 Append_To (Stmts,
1699 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1700 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1701
1702 else
1703 -- For a normal RAS type, we cast the RAS formal to the corresponding
1704 -- tagged type, and perform a dispatching call to its Call primitive
1705 -- operation.
1706
1707 Prepend_To (Param_Assoc,
1708 Unchecked_Convert_To (RACW_Type,
1709 New_Occurrence_Of (RAS_Parameter, Loc)));
1710
1711 RACW_Primitive_Name :=
1712 Make_Selected_Component (Loc,
1713 Prefix => Scope (RACW_Type),
1714 Selector_Name => Name_uCall);
1715 end if;
1716
1717 if Is_Function then
1718 Append_To (Stmts,
1719 Make_Simple_Return_Statement (Loc,
1720 Expression =>
1721 Make_Function_Call (Loc,
1722 Name => RACW_Primitive_Name,
1723 Parameter_Associations => Param_Assoc)));
1724
1725 else
1726 Append_To (Stmts,
1727 Make_Procedure_Call_Statement (Loc,
1728 Name => RACW_Primitive_Name,
1729 Parameter_Associations => Param_Assoc));
1730 end if;
1731
1732 -- Build the complete subprogram
1733
1734 if Is_Function then
1735 Proc_Spec :=
1736 Make_Function_Specification (Loc,
1737 Defining_Unit_Name => Proc,
1738 Parameter_Specifications => Param_Specs,
1739 Result_Definition =>
1740 New_Occurrence_Of (
1741 Entity (Result_Definition (Spec)), Loc));
1742
1743 Set_Ekind (Proc, E_Function);
1744 Set_Etype (Proc,
1745 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
1746
1747 else
1748 Proc_Spec :=
1749 Make_Procedure_Specification (Loc,
1750 Defining_Unit_Name => Proc,
1751 Parameter_Specifications => Param_Specs);
1752
1753 Set_Ekind (Proc, E_Procedure);
1754 Set_Etype (Proc, Standard_Void_Type);
1755 end if;
1756
1757 Discard_Node (
1758 Make_Subprogram_Body (Loc,
1759 Specification => Proc_Spec,
1760 Declarations => New_List,
1761 Handled_Statement_Sequence =>
1762 Make_Handled_Sequence_Of_Statements (Loc,
1763 Statements => Stmts)));
1764
1765 Set_TSS (Fat_Type, Proc);
1766 end Add_RAS_Dereference_TSS;
1767
1768 -------------------------------
1769 -- Add_RAS_Proxy_And_Analyze --
1770 -------------------------------
1771
1772 procedure Add_RAS_Proxy_And_Analyze
1773 (Decls : List_Id;
1774 Vis_Decl : Node_Id;
1775 All_Calls_Remote_E : Entity_Id;
1776 Proxy_Object_Addr : out Entity_Id)
1777 is
1778 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1779
1780 Subp_Name : constant Entity_Id :=
1781 Defining_Unit_Name (Specification (Vis_Decl));
1782
1783 Pkg_Name : constant Entity_Id :=
1784 Make_Defining_Identifier (Loc,
1785 Chars => New_External_Name (Chars (Subp_Name), 'P', -1));
1786
1787 Proxy_Type : constant Entity_Id :=
1788 Make_Defining_Identifier (Loc,
1789 Chars =>
1790 New_External_Name
1791 (Related_Id => Chars (Subp_Name),
1792 Suffix => 'P'));
1793
1794 Proxy_Type_Full_View : constant Entity_Id :=
1795 Make_Defining_Identifier (Loc,
1796 Chars (Proxy_Type));
1797
1798 Subp_Decl_Spec : constant Node_Id :=
1799 Build_RAS_Primitive_Specification
1800 (Subp_Spec => Specification (Vis_Decl),
1801 Remote_Object_Type => Proxy_Type);
1802
1803 Subp_Body_Spec : constant Node_Id :=
1804 Build_RAS_Primitive_Specification
1805 (Subp_Spec => Specification (Vis_Decl),
1806 Remote_Object_Type => Proxy_Type);
1807
1808 Vis_Decls : constant List_Id := New_List;
1809 Pvt_Decls : constant List_Id := New_List;
1810 Actuals : constant List_Id := New_List;
1811 Formal : Node_Id;
1812 Perform_Call : Node_Id;
1813
1814 begin
1815 -- type subpP is tagged limited private;
1816
1817 Append_To (Vis_Decls,
1818 Make_Private_Type_Declaration (Loc,
1819 Defining_Identifier => Proxy_Type,
1820 Tagged_Present => True,
1821 Limited_Present => True));
1822
1823 -- [subprogram] Call
1824 -- (Self : access subpP;
1825 -- ...other-formals...)
1826 -- [return T];
1827
1828 Append_To (Vis_Decls,
1829 Make_Subprogram_Declaration (Loc,
1830 Specification => Subp_Decl_Spec));
1831
1832 -- A : constant System.Address;
1833
1834 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1835
1836 Append_To (Vis_Decls,
1837 Make_Object_Declaration (Loc,
1838 Defining_Identifier => Proxy_Object_Addr,
1839 Constant_Present => True,
1840 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc)));
1841
1842 -- private
1843
1844 -- type subpP is tagged limited record
1845 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1846 -- ...
1847 -- end record;
1848
1849 Append_To (Pvt_Decls,
1850 Make_Full_Type_Declaration (Loc,
1851 Defining_Identifier => Proxy_Type_Full_View,
1852 Type_Definition =>
1853 Build_Remote_Subprogram_Proxy_Type (Loc,
1854 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1855
1856 -- Trick semantic analysis into swapping the public and full view when
1857 -- freezing the public view.
1858
1859 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1860
1861 -- procedure Call
1862 -- (Self : access O;
1863 -- ...other-formals...) is
1864 -- begin
1865 -- P (...other-formals...);
1866 -- end Call;
1867
1868 -- function Call
1869 -- (Self : access O;
1870 -- ...other-formals...)
1871 -- return T is
1872 -- begin
1873 -- return F (...other-formals...);
1874 -- end Call;
1875
1876 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1877 Perform_Call :=
1878 Make_Procedure_Call_Statement (Loc,
1879 Name => New_Occurrence_Of (Subp_Name, Loc),
1880 Parameter_Associations => Actuals);
1881 else
1882 Perform_Call :=
1883 Make_Simple_Return_Statement (Loc,
1884 Expression =>
1885 Make_Function_Call (Loc,
1886 Name => New_Occurrence_Of (Subp_Name, Loc),
1887 Parameter_Associations => Actuals));
1888 end if;
1889
1890 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1891 pragma Assert (Present (Formal));
1892 loop
1893 Next (Formal);
1894 exit when No (Formal);
1895 Append_To (Actuals,
1896 New_Occurrence_Of (Defining_Identifier (Formal), Loc));
1897 end loop;
1898
1899 -- O : aliased subpP;
1900
1901 Append_To (Pvt_Decls,
1902 Make_Object_Declaration (Loc,
1903 Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
1904 Aliased_Present => True,
1905 Object_Definition => New_Occurrence_Of (Proxy_Type, Loc)));
1906
1907 -- A : constant System.Address := O'Address;
1908
1909 Append_To (Pvt_Decls,
1910 Make_Object_Declaration (Loc,
1911 Defining_Identifier =>
1912 Make_Defining_Identifier (Loc, Chars (Proxy_Object_Addr)),
1913 Constant_Present => True,
1914 Object_Definition => New_Occurrence_Of (RTE (RE_Address), Loc),
1915 Expression =>
1916 Make_Attribute_Reference (Loc,
1917 Prefix => New_Occurrence_Of (
1918 Defining_Identifier (Last (Pvt_Decls)), Loc),
1919 Attribute_Name => Name_Address)));
1920
1921 Append_To (Decls,
1922 Make_Package_Declaration (Loc,
1923 Specification => Make_Package_Specification (Loc,
1924 Defining_Unit_Name => Pkg_Name,
1925 Visible_Declarations => Vis_Decls,
1926 Private_Declarations => Pvt_Decls,
1927 End_Label => Empty)));
1928 Analyze (Last (Decls));
1929
1930 Append_To (Decls,
1931 Make_Package_Body (Loc,
1932 Defining_Unit_Name =>
1933 Make_Defining_Identifier (Loc, Chars (Pkg_Name)),
1934 Declarations => New_List (
1935 Make_Subprogram_Body (Loc,
1936 Specification => Subp_Body_Spec,
1937 Declarations => New_List,
1938 Handled_Statement_Sequence =>
1939 Make_Handled_Sequence_Of_Statements (Loc,
1940 Statements => New_List (Perform_Call))))));
1941 Analyze (Last (Decls));
1942 end Add_RAS_Proxy_And_Analyze;
1943
1944 -----------------------
1945 -- Add_RAST_Features --
1946 -----------------------
1947
1948 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1949 RAS_Type : constant Entity_Id :=
1950 Equivalent_Type (Defining_Identifier (Vis_Decl));
1951 begin
1952 pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
1953 Add_RAS_Dereference_TSS (Vis_Decl);
1954 Specific_Add_RAST_Features (Vis_Decl, RAS_Type);
1955 end Add_RAST_Features;
1956
1957 -------------------
1958 -- Add_Stub_Type --
1959 -------------------
1960
1961 procedure Add_Stub_Type
1962 (Designated_Type : Entity_Id;
1963 RACW_Type : Entity_Id;
1964 Decls : List_Id;
1965 Stub_Type : out Entity_Id;
1966 Stub_Type_Access : out Entity_Id;
1967 RPC_Receiver_Decl : out Node_Id;
1968 Body_Decls : out List_Id;
1969 Existing : out Boolean)
1970 is
1971 Loc : constant Source_Ptr := Sloc (RACW_Type);
1972
1973 Stub_Elements : constant Stub_Structure :=
1974 Stubs_Table.Get (Designated_Type);
1975 Stub_Type_Decl : Node_Id;
1976 Stub_Type_Access_Decl : Node_Id;
1977
1978 begin
1979 if Stub_Elements /= Empty_Stub_Structure then
1980 Stub_Type := Stub_Elements.Stub_Type;
1981 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1982 RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
1983 Body_Decls := Stub_Elements.Body_Decls;
1984 Existing := True;
1985 return;
1986 end if;
1987
1988 Existing := False;
1989 Stub_Type := Make_Temporary (Loc, 'S');
1990 Set_Ekind (Stub_Type, E_Record_Type);
1991 Set_Is_RACW_Stub_Type (Stub_Type);
1992 Stub_Type_Access :=
1993 Make_Defining_Identifier (Loc,
1994 Chars => New_External_Name
1995 (Related_Id => Chars (Stub_Type), Suffix => 'A'));
1996
1997 RPC_Receiver_Decl := Specific_RPC_Receiver_Decl (RACW_Type);
1998
1999 -- Create new stub type, copying components from generic RACW_Stub_Type
2000
2001 Stub_Type_Decl :=
2002 Make_Full_Type_Declaration (Loc,
2003 Defining_Identifier => Stub_Type,
2004 Type_Definition =>
2005 Make_Record_Definition (Loc,
2006 Tagged_Present => True,
2007 Limited_Present => True,
2008 Component_List =>
2009 Make_Component_List (Loc,
2010 Component_Items =>
2011 Copy_Component_List (RTE (RE_RACW_Stub_Type), Loc))));
2012
2013 -- Does the stub type need to explicitly implement interfaces from the
2014 -- designated type???
2015
2016 -- In particular are there issues in the case where the designated type
2017 -- is a synchronized interface???
2018
2019 Stub_Type_Access_Decl :=
2020 Make_Full_Type_Declaration (Loc,
2021 Defining_Identifier => Stub_Type_Access,
2022 Type_Definition =>
2023 Make_Access_To_Object_Definition (Loc,
2024 All_Present => True,
2025 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
2026
2027 Append_To (Decls, Stub_Type_Decl);
2028 Analyze (Last (Decls));
2029 Append_To (Decls, Stub_Type_Access_Decl);
2030 Analyze (Last (Decls));
2031
2032 -- We can't directly derive the stub type from the designated type,
2033 -- because we don't want any components or discriminants from the real
2034 -- type, so instead we manually fake a derivation to get an appropriate
2035 -- dispatch table.
2036
2037 Derive_Subprograms (Parent_Type => Designated_Type,
2038 Derived_Type => Stub_Type);
2039
2040 if Present (RPC_Receiver_Decl) then
2041 Append_To (Decls, RPC_Receiver_Decl);
2042
2043 else
2044 -- Case of RACW implementing a RAS with the GARLIC PCS: there is
2045 -- no RPC receiver in that case, this is just an indication of
2046 -- where to insert code in the tree (see comment in declaration of
2047 -- type Stub_Structure).
2048
2049 RPC_Receiver_Decl := Last (Decls);
2050 end if;
2051
2052 Body_Decls := New_List;
2053
2054 Stubs_Table.Set (Designated_Type,
2055 (Stub_Type => Stub_Type,
2056 Stub_Type_Access => Stub_Type_Access,
2057 RPC_Receiver_Decl => RPC_Receiver_Decl,
2058 Body_Decls => Body_Decls,
2059 RACW_Type => RACW_Type));
2060 end Add_Stub_Type;
2061
2062 ------------------------
2063 -- Append_RACW_Bodies --
2064 ------------------------
2065
2066 procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
2067 E : Entity_Id;
2068
2069 begin
2070 E := First_Entity (Spec_Id);
2071 while Present (E) loop
2072 if Is_Remote_Access_To_Class_Wide_Type (E) then
2073 Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
2074 end if;
2075
2076 Next_Entity (E);
2077 end loop;
2078 end Append_RACW_Bodies;
2079
2080 ----------------------------------
2081 -- Assign_Subprogram_Identifier --
2082 ----------------------------------
2083
2084 procedure Assign_Subprogram_Identifier
2085 (Def : Entity_Id;
2086 Spn : Int;
2087 Id : out String_Id)
2088 is
2089 N : constant Name_Id := Chars (Def);
2090
2091 Overload_Order : constant Int := Overload_Counter_Table.Get (N) + 1;
2092
2093 begin
2094 Overload_Counter_Table.Set (N, Overload_Order);
2095
2096 Get_Name_String (N);
2097
2098 -- Homonym handling: as in Exp_Dbug, but much simpler, because the only
2099 -- entities for which we have to generate names here need only to be
2100 -- disambiguated within their own scope.
2101
2102 if Overload_Order > 1 then
2103 Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
2104 Name_Len := Name_Len + 2;
2105 Add_Nat_To_Name_Buffer (Overload_Order);
2106 end if;
2107
2108 Id := String_From_Name_Buffer;
2109 Subprogram_Identifier_Table.Set
2110 (Def,
2111 Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
2112 end Assign_Subprogram_Identifier;
2113
2114 -------------------------------------
2115 -- Build_Actual_Object_Declaration --
2116 -------------------------------------
2117
2118 procedure Build_Actual_Object_Declaration
2119 (Object : Entity_Id;
2120 Etyp : Entity_Id;
2121 Variable : Boolean;
2122 Expr : Node_Id;
2123 Decls : List_Id)
2124 is
2125 Loc : constant Source_Ptr := Sloc (Object);
2126
2127 begin
2128 -- Declare a temporary object for the actual, possibly initialized with
2129 -- a 'Input/From_Any call.
2130
2131 -- Complication arises in the case of limited types, for which such a
2132 -- declaration is illegal in Ada 95. In that case, we first generate a
2133 -- renaming declaration of the 'Input call, and then if needed we
2134 -- generate an overlaid non-constant view.
2135
2136 if Ada_Version <= Ada_95
2137 and then Is_Limited_Type (Etyp)
2138 and then Present (Expr)
2139 then
2140
2141 -- Object : Etyp renames <func-call>
2142
2143 Append_To (Decls,
2144 Make_Object_Renaming_Declaration (Loc,
2145 Defining_Identifier => Object,
2146 Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
2147 Name => Expr));
2148
2149 if Variable then
2150
2151 -- The name defined by the renaming declaration denotes a
2152 -- constant view; create a non-constant object at the same address
2153 -- to be used as the actual.
2154
2155 declare
2156 Constant_Object : constant Entity_Id :=
2157 Make_Temporary (Loc, 'P');
2158
2159 begin
2160 Set_Defining_Identifier
2161 (Last (Decls), Constant_Object);
2162
2163 -- We have an unconstrained Etyp: build the actual constrained
2164 -- subtype for the value we just read from the stream.
2165
2166 -- subtype S is <actual subtype of Constant_Object>;
2167
2168 Append_To (Decls,
2169 Build_Actual_Subtype (Etyp,
2170 New_Occurrence_Of (Constant_Object, Loc)));
2171
2172 -- Object : S;
2173
2174 Append_To (Decls,
2175 Make_Object_Declaration (Loc,
2176 Defining_Identifier => Object,
2177 Object_Definition =>
2178 New_Occurrence_Of
2179 (Defining_Identifier (Last (Decls)), Loc)));
2180 Set_Ekind (Object, E_Variable);
2181
2182 -- Suppress default initialization:
2183 -- pragma Import (Ada, Object);
2184
2185 Append_To (Decls,
2186 Make_Pragma (Loc,
2187 Chars => Name_Import,
2188 Pragma_Argument_Associations => New_List (
2189 Make_Pragma_Argument_Association (Loc,
2190 Chars => Name_Convention,
2191 Expression => Make_Identifier (Loc, Name_Ada)),
2192 Make_Pragma_Argument_Association (Loc,
2193 Chars => Name_Entity,
2194 Expression => New_Occurrence_Of (Object, Loc)))));
2195
2196 -- for Object'Address use Constant_Object'Address;
2197
2198 Append_To (Decls,
2199 Make_Attribute_Definition_Clause (Loc,
2200 Name => New_Occurrence_Of (Object, Loc),
2201 Chars => Name_Address,
2202 Expression =>
2203 Make_Attribute_Reference (Loc,
2204 Prefix => New_Occurrence_Of (Constant_Object, Loc),
2205 Attribute_Name => Name_Address)));
2206 end;
2207 end if;
2208
2209 else
2210 -- General case of a regular object declaration. Object is flagged
2211 -- constant unless it has mode out or in out, to allow the backend
2212 -- to optimize where possible.
2213
2214 -- Object : [constant] Etyp [:= <expr>];
2215
2216 Append_To (Decls,
2217 Make_Object_Declaration (Loc,
2218 Defining_Identifier => Object,
2219 Constant_Present => Present (Expr) and then not Variable,
2220 Object_Definition => New_Occurrence_Of (Etyp, Loc),
2221 Expression => Expr));
2222
2223 if Constant_Present (Last (Decls)) then
2224 Set_Ekind (Object, E_Constant);
2225 else
2226 Set_Ekind (Object, E_Variable);
2227 end if;
2228 end if;
2229 end Build_Actual_Object_Declaration;
2230
2231 ------------------------------
2232 -- Build_Get_Unique_RP_Call --
2233 ------------------------------
2234
2235 function Build_Get_Unique_RP_Call
2236 (Loc : Source_Ptr;
2237 Pointer : Entity_Id;
2238 Stub_Type : Entity_Id) return List_Id
2239 is
2240 begin
2241 return New_List (
2242 Make_Procedure_Call_Statement (Loc,
2243 Name =>
2244 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2245 Parameter_Associations => New_List (
2246 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2247 New_Occurrence_Of (Pointer, Loc)))),
2248
2249 Make_Assignment_Statement (Loc,
2250 Name =>
2251 Make_Selected_Component (Loc,
2252 Prefix => New_Occurrence_Of (Pointer, Loc),
2253 Selector_Name =>
2254 New_Occurrence_Of (First_Tag_Component
2255 (Designated_Type (Etype (Pointer))), Loc)),
2256 Expression =>
2257 Make_Attribute_Reference (Loc,
2258 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2259 Attribute_Name => Name_Tag)));
2260
2261 -- Note: The assignment to Pointer._Tag is safe here because
2262 -- we carefully ensured that Stub_Type has exactly the same layout
2263 -- as System.Partition_Interface.RACW_Stub_Type.
2264
2265 end Build_Get_Unique_RP_Call;
2266
2267 -----------------------------------
2268 -- Build_Ordered_Parameters_List --
2269 -----------------------------------
2270
2271 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2272 Constrained_List : List_Id;
2273 Unconstrained_List : List_Id;
2274 Current_Parameter : Node_Id;
2275 Ptyp : Node_Id;
2276
2277 First_Parameter : Node_Id;
2278 For_RAS : Boolean := False;
2279
2280 begin
2281 if No (Parameter_Specifications (Spec)) then
2282 return New_List;
2283 end if;
2284
2285 Constrained_List := New_List;
2286 Unconstrained_List := New_List;
2287 First_Parameter := First (Parameter_Specifications (Spec));
2288
2289 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2290 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2291 then
2292 For_RAS := True;
2293 end if;
2294
2295 -- Loop through the parameters and add them to the right list. Note that
2296 -- we treat a parameter of a null-excluding access type as unconstrained
2297 -- because we can't declare an object of such a type with default
2298 -- initialization.
2299
2300 Current_Parameter := First_Parameter;
2301 while Present (Current_Parameter) loop
2302 Ptyp := Parameter_Type (Current_Parameter);
2303
2304 if (Nkind (Ptyp) = N_Access_Definition
2305 or else not Transmit_As_Unconstrained (Etype (Ptyp)))
2306 and then not (For_RAS and then Current_Parameter = First_Parameter)
2307 then
2308 Append_To (Constrained_List, New_Copy (Current_Parameter));
2309 else
2310 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2311 end if;
2312
2313 Next (Current_Parameter);
2314 end loop;
2315
2316 -- Unconstrained parameters are returned first
2317
2318 Append_List_To (Unconstrained_List, Constrained_List);
2319
2320 return Unconstrained_List;
2321 end Build_Ordered_Parameters_List;
2322
2323 ----------------------------------
2324 -- Build_Passive_Partition_Stub --
2325 ----------------------------------
2326
2327 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2328 Pkg_Spec : Node_Id;
2329 Pkg_Ent : Entity_Id;
2330 L : List_Id;
2331 Reg : Node_Id;
2332 Loc : constant Source_Ptr := Sloc (U);
2333
2334 begin
2335 -- Verify that the implementation supports distribution, by accessing
2336 -- a type defined in the proper version of system.rpc
2337
2338 declare
2339 Dist_OK : Entity_Id;
2340 pragma Warnings (Off, Dist_OK);
2341 begin
2342 Dist_OK := RTE (RE_Params_Stream_Type);
2343 end;
2344
2345 -- Use body if present, spec otherwise
2346
2347 if Nkind (U) = N_Package_Declaration then
2348 Pkg_Spec := Specification (U);
2349 L := Visible_Declarations (Pkg_Spec);
2350 else
2351 Pkg_Spec := Parent (Corresponding_Spec (U));
2352 L := Declarations (U);
2353 end if;
2354 Pkg_Ent := Defining_Entity (Pkg_Spec);
2355
2356 Reg :=
2357 Make_Procedure_Call_Statement (Loc,
2358 Name =>
2359 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2360 Parameter_Associations => New_List (
2361 Make_String_Literal (Loc,
2362 Fully_Qualified_Name_String (Pkg_Ent, Append_NUL => False)),
2363 Make_Attribute_Reference (Loc,
2364 Prefix => New_Occurrence_Of (Pkg_Ent, Loc),
2365 Attribute_Name => Name_Version)));
2366 Append_To (L, Reg);
2367 Analyze (Reg);
2368 end Build_Passive_Partition_Stub;
2369
2370 --------------------------------------
2371 -- Build_RPC_Receiver_Specification --
2372 --------------------------------------
2373
2374 function Build_RPC_Receiver_Specification
2375 (RPC_Receiver : Entity_Id;
2376 Request_Parameter : Entity_Id) return Node_Id
2377 is
2378 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2379 begin
2380 return
2381 Make_Procedure_Specification (Loc,
2382 Defining_Unit_Name => RPC_Receiver,
2383 Parameter_Specifications => New_List (
2384 Make_Parameter_Specification (Loc,
2385 Defining_Identifier => Request_Parameter,
2386 Parameter_Type =>
2387 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
2388 end Build_RPC_Receiver_Specification;
2389
2390 ----------------------------------------
2391 -- Build_Remote_Subprogram_Proxy_Type --
2392 ----------------------------------------
2393
2394 function Build_Remote_Subprogram_Proxy_Type
2395 (Loc : Source_Ptr;
2396 ACR_Expression : Node_Id) return Node_Id
2397 is
2398 begin
2399 return
2400 Make_Record_Definition (Loc,
2401 Tagged_Present => True,
2402 Limited_Present => True,
2403 Component_List =>
2404 Make_Component_List (Loc,
2405 Component_Items => New_List (
2406 Make_Component_Declaration (Loc,
2407 Defining_Identifier =>
2408 Make_Defining_Identifier (Loc,
2409 Name_All_Calls_Remote),
2410 Component_Definition =>
2411 Make_Component_Definition (Loc,
2412 Subtype_Indication =>
2413 New_Occurrence_Of (Standard_Boolean, Loc)),
2414 Expression =>
2415 ACR_Expression),
2416
2417 Make_Component_Declaration (Loc,
2418 Defining_Identifier =>
2419 Make_Defining_Identifier (Loc,
2420 Name_Receiver),
2421 Component_Definition =>
2422 Make_Component_Definition (Loc,
2423 Subtype_Indication =>
2424 New_Occurrence_Of (RTE (RE_Address), Loc)),
2425 Expression =>
2426 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2427
2428 Make_Component_Declaration (Loc,
2429 Defining_Identifier =>
2430 Make_Defining_Identifier (Loc,
2431 Name_Subp_Id),
2432 Component_Definition =>
2433 Make_Component_Definition (Loc,
2434 Subtype_Indication =>
2435 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2436 end Build_Remote_Subprogram_Proxy_Type;
2437
2438 --------------------
2439 -- Build_Stub_Tag --
2440 --------------------
2441
2442 function Build_Stub_Tag
2443 (Loc : Source_Ptr;
2444 RACW_Type : Entity_Id) return Node_Id
2445 is
2446 Stub_Type : constant Entity_Id := Corresponding_Stub_Type (RACW_Type);
2447 begin
2448 return
2449 Make_Attribute_Reference (Loc,
2450 Prefix => New_Occurrence_Of (Stub_Type, Loc),
2451 Attribute_Name => Name_Tag);
2452 end Build_Stub_Tag;
2453
2454 ------------------------------------
2455 -- Build_Subprogram_Calling_Stubs --
2456 ------------------------------------
2457
2458 function Build_Subprogram_Calling_Stubs
2459 (Vis_Decl : Node_Id;
2460 Subp_Id : Node_Id;
2461 Asynchronous : Boolean;
2462 Dynamically_Asynchronous : Boolean := False;
2463 Stub_Type : Entity_Id := Empty;
2464 RACW_Type : Entity_Id := Empty;
2465 Locator : Entity_Id := Empty;
2466 New_Name : Name_Id := No_Name) return Node_Id
2467 is
2468 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2469
2470 Decls : constant List_Id := New_List;
2471 Statements : constant List_Id := New_List;
2472
2473 Subp_Spec : Node_Id;
2474 -- The specification of the body
2475
2476 Controlling_Parameter : Entity_Id := Empty;
2477
2478 Asynchronous_Expr : Node_Id := Empty;
2479
2480 RCI_Locator : Entity_Id;
2481
2482 Spec_To_Use : Node_Id;
2483
2484 procedure Insert_Partition_Check (Parameter : Node_Id);
2485 -- Check that the parameter has been elaborated on the same partition
2486 -- than the controlling parameter (E.4(19)).
2487
2488 ----------------------------
2489 -- Insert_Partition_Check --
2490 ----------------------------
2491
2492 procedure Insert_Partition_Check (Parameter : Node_Id) is
2493 Parameter_Entity : constant Entity_Id :=
2494 Defining_Identifier (Parameter);
2495 begin
2496 -- The expression that will be built is of the form:
2497
2498 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2499 -- raise Constraint_Error;
2500 -- end if;
2501
2502 -- We do not check that Parameter is in Stub_Type since such a check
2503 -- has been inserted at the point of call already (a tag check since
2504 -- we have multiple controlling operands).
2505
2506 Append_To (Decls,
2507 Make_Raise_Constraint_Error (Loc,
2508 Condition =>
2509 Make_Op_Not (Loc,
2510 Right_Opnd =>
2511 Make_Function_Call (Loc,
2512 Name =>
2513 New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
2514 Parameter_Associations =>
2515 New_List (
2516 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2517 New_Occurrence_Of (Parameter_Entity, Loc)),
2518 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2519 New_Occurrence_Of (Controlling_Parameter, Loc))))),
2520 Reason => CE_Partition_Check_Failed));
2521 end Insert_Partition_Check;
2522
2523 -- Start of processing for Build_Subprogram_Calling_Stubs
2524
2525 begin
2526 Subp_Spec :=
2527 Copy_Specification (Loc,
2528 Spec => Specification (Vis_Decl),
2529 New_Name => New_Name);
2530
2531 if Locator = Empty then
2532 RCI_Locator := RCI_Cache;
2533 Spec_To_Use := Specification (Vis_Decl);
2534 else
2535 RCI_Locator := Locator;
2536 Spec_To_Use := Subp_Spec;
2537 end if;
2538
2539 -- Find a controlling argument if we have a stub type. Also check
2540 -- if this subprogram can be made asynchronous.
2541
2542 if Present (Stub_Type)
2543 and then Present (Parameter_Specifications (Spec_To_Use))
2544 then
2545 declare
2546 Current_Parameter : Node_Id :=
2547 First (Parameter_Specifications
2548 (Spec_To_Use));
2549 begin
2550 while Present (Current_Parameter) loop
2551 if
2552 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2553 then
2554 if Controlling_Parameter = Empty then
2555 Controlling_Parameter :=
2556 Defining_Identifier (Current_Parameter);
2557 else
2558 Insert_Partition_Check (Current_Parameter);
2559 end if;
2560 end if;
2561
2562 Next (Current_Parameter);
2563 end loop;
2564 end;
2565 end if;
2566
2567 pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
2568
2569 if Dynamically_Asynchronous then
2570 Asynchronous_Expr := Make_Selected_Component (Loc,
2571 Prefix => Controlling_Parameter,
2572 Selector_Name => Name_Asynchronous);
2573 end if;
2574
2575 Specific_Build_General_Calling_Stubs
2576 (Decls => Decls,
2577 Statements => Statements,
2578 Target => Specific_Build_Stub_Target (Loc,
2579 Decls, RCI_Locator, Controlling_Parameter),
2580 Subprogram_Id => Subp_Id,
2581 Asynchronous => Asynchronous_Expr,
2582 Is_Known_Asynchronous => Asynchronous
2583 and then not Dynamically_Asynchronous,
2584 Is_Known_Non_Asynchronous
2585 => not Asynchronous
2586 and then not Dynamically_Asynchronous,
2587 Is_Function => Nkind (Spec_To_Use) =
2588 N_Function_Specification,
2589 Spec => Spec_To_Use,
2590 Stub_Type => Stub_Type,
2591 RACW_Type => RACW_Type,
2592 Nod => Vis_Decl);
2593
2594 RCI_Calling_Stubs_Table.Set
2595 (Defining_Unit_Name (Specification (Vis_Decl)),
2596 Defining_Unit_Name (Spec_To_Use));
2597
2598 return
2599 Make_Subprogram_Body (Loc,
2600 Specification => Subp_Spec,
2601 Declarations => Decls,
2602 Handled_Statement_Sequence =>
2603 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2604 end Build_Subprogram_Calling_Stubs;
2605
2606 -------------------------
2607 -- Build_Subprogram_Id --
2608 -------------------------
2609
2610 function Build_Subprogram_Id
2611 (Loc : Source_Ptr;
2612 E : Entity_Id) return Node_Id
2613 is
2614 begin
2615 if Get_Subprogram_Ids (E).Str_Identifier = No_String then
2616 declare
2617 Current_Declaration : Node_Id;
2618 Current_Subp : Entity_Id;
2619 Current_Subp_Str : String_Id;
2620 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
2621
2622 pragma Warnings (Off, Current_Subp_Str);
2623
2624 begin
2625 -- Build_Subprogram_Id is called outside of the context of
2626 -- generating calling or receiving stubs. Hence we are processing
2627 -- an 'Access attribute_reference for an RCI subprogram, for the
2628 -- purpose of obtaining a RAS value.
2629
2630 pragma Assert
2631 (Is_Remote_Call_Interface (Scope (E))
2632 and then
2633 (Nkind (Parent (E)) = N_Procedure_Specification
2634 or else
2635 Nkind (Parent (E)) = N_Function_Specification));
2636
2637 Current_Declaration :=
2638 First (Visible_Declarations
2639 (Package_Specification_Of_Scope (Scope (E))));
2640 while Present (Current_Declaration) loop
2641 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2642 and then Comes_From_Source (Current_Declaration)
2643 then
2644 Current_Subp := Defining_Unit_Name (Specification (
2645 Current_Declaration));
2646
2647 Assign_Subprogram_Identifier
2648 (Current_Subp, Current_Subp_Number, Current_Subp_Str);
2649
2650 Current_Subp_Number := Current_Subp_Number + 1;
2651 end if;
2652
2653 Next (Current_Declaration);
2654 end loop;
2655 end;
2656 end if;
2657
2658 case Get_PCS_Name is
2659 when Name_PolyORB_DSA =>
2660 return Make_String_Literal (Loc, Get_Subprogram_Id (E));
2661 when others =>
2662 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2663 end case;
2664 end Build_Subprogram_Id;
2665
2666 ------------------------
2667 -- Copy_Specification --
2668 ------------------------
2669
2670 function Copy_Specification
2671 (Loc : Source_Ptr;
2672 Spec : Node_Id;
2673 Ctrl_Type : Entity_Id := Empty;
2674 New_Name : Name_Id := No_Name) return Node_Id
2675 is
2676 Parameters : List_Id := No_List;
2677
2678 Current_Parameter : Node_Id;
2679 Current_Identifier : Entity_Id;
2680 Current_Type : Node_Id;
2681
2682 Name_For_New_Spec : Name_Id;
2683
2684 New_Identifier : Entity_Id;
2685
2686 -- Comments needed in body below ???
2687
2688 begin
2689 if New_Name = No_Name then
2690 pragma Assert (Nkind (Spec) = N_Function_Specification
2691 or else Nkind (Spec) = N_Procedure_Specification);
2692
2693 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
2694 else
2695 Name_For_New_Spec := New_Name;
2696 end if;
2697
2698 if Present (Parameter_Specifications (Spec)) then
2699 Parameters := New_List;
2700 Current_Parameter := First (Parameter_Specifications (Spec));
2701 while Present (Current_Parameter) loop
2702 Current_Identifier := Defining_Identifier (Current_Parameter);
2703 Current_Type := Parameter_Type (Current_Parameter);
2704
2705 if Nkind (Current_Type) = N_Access_Definition then
2706 if Present (Ctrl_Type) then
2707 pragma Assert (Is_Controlling_Formal (Current_Identifier));
2708 Current_Type :=
2709 Make_Access_Definition (Loc,
2710 Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
2711 Null_Exclusion_Present =>
2712 Null_Exclusion_Present (Current_Type));
2713
2714 else
2715 Current_Type :=
2716 Make_Access_Definition (Loc,
2717 Subtype_Mark =>
2718 New_Copy_Tree (Subtype_Mark (Current_Type)),
2719 Null_Exclusion_Present =>
2720 Null_Exclusion_Present (Current_Type));
2721 end if;
2722
2723 else
2724 if Present (Ctrl_Type)
2725 and then Is_Controlling_Formal (Current_Identifier)
2726 then
2727 Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
2728 else
2729 Current_Type := New_Copy_Tree (Current_Type);
2730 end if;
2731 end if;
2732
2733 New_Identifier := Make_Defining_Identifier (Loc,
2734 Chars (Current_Identifier));
2735
2736 Append_To (Parameters,
2737 Make_Parameter_Specification (Loc,
2738 Defining_Identifier => New_Identifier,
2739 Parameter_Type => Current_Type,
2740 In_Present => In_Present (Current_Parameter),
2741 Out_Present => Out_Present (Current_Parameter),
2742 Expression =>
2743 New_Copy_Tree (Expression (Current_Parameter))));
2744
2745 -- For a regular formal parameter (that needs to be marshalled
2746 -- in the context of remote calls), set the Etype now, because
2747 -- marshalling processing might need it.
2748
2749 if Is_Entity_Name (Current_Type) then
2750 Set_Etype (New_Identifier, Entity (Current_Type));
2751
2752 -- Current_Type is an access definition, special processing
2753 -- (not requiring etype) will occur for marshalling.
2754
2755 else
2756 null;
2757 end if;
2758
2759 Next (Current_Parameter);
2760 end loop;
2761 end if;
2762
2763 case Nkind (Spec) is
2764
2765 when N_Function_Specification | N_Access_Function_Definition =>
2766 return
2767 Make_Function_Specification (Loc,
2768 Defining_Unit_Name =>
2769 Make_Defining_Identifier (Loc,
2770 Chars => Name_For_New_Spec),
2771 Parameter_Specifications => Parameters,
2772 Result_Definition =>
2773 New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
2774
2775 when N_Procedure_Specification | N_Access_Procedure_Definition =>
2776 return
2777 Make_Procedure_Specification (Loc,
2778 Defining_Unit_Name =>
2779 Make_Defining_Identifier (Loc,
2780 Chars => Name_For_New_Spec),
2781 Parameter_Specifications => Parameters);
2782
2783 when others =>
2784 raise Program_Error;
2785 end case;
2786 end Copy_Specification;
2787
2788 -----------------------------
2789 -- Corresponding_Stub_Type --
2790 -----------------------------
2791
2792 function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id is
2793 Desig : constant Entity_Id :=
2794 Etype (Designated_Type (RACW_Type));
2795 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
2796 begin
2797 return Stub_Elements.Stub_Type;
2798 end Corresponding_Stub_Type;
2799
2800 ---------------------------
2801 -- Could_Be_Asynchronous --
2802 ---------------------------
2803
2804 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
2805 Current_Parameter : Node_Id;
2806
2807 begin
2808 if Present (Parameter_Specifications (Spec)) then
2809 Current_Parameter := First (Parameter_Specifications (Spec));
2810 while Present (Current_Parameter) loop
2811 if Out_Present (Current_Parameter) then
2812 return False;
2813 end if;
2814
2815 Next (Current_Parameter);
2816 end loop;
2817 end if;
2818
2819 return True;
2820 end Could_Be_Asynchronous;
2821
2822 ---------------------------
2823 -- Declare_Create_NVList --
2824 ---------------------------
2825
2826 procedure Declare_Create_NVList
2827 (Loc : Source_Ptr;
2828 NVList : Entity_Id;
2829 Decls : List_Id;
2830 Stmts : List_Id)
2831 is
2832 begin
2833 Append_To (Decls,
2834 Make_Object_Declaration (Loc,
2835 Defining_Identifier => NVList,
2836 Aliased_Present => False,
2837 Object_Definition =>
2838 New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
2839
2840 Append_To (Stmts,
2841 Make_Procedure_Call_Statement (Loc,
2842 Name => New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
2843 Parameter_Associations => New_List (
2844 New_Occurrence_Of (NVList, Loc))));
2845 end Declare_Create_NVList;
2846
2847 ---------------------------------------------
2848 -- Expand_All_Calls_Remote_Subprogram_Call --
2849 ---------------------------------------------
2850
2851 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
2852 Loc : constant Source_Ptr := Sloc (N);
2853 Called_Subprogram : constant Entity_Id := Entity (Name (N));
2854 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
2855 RCI_Locator_Decl : Node_Id;
2856 RCI_Locator : Entity_Id;
2857 Calling_Stubs : Node_Id;
2858 E_Calling_Stubs : Entity_Id;
2859
2860 begin
2861 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
2862
2863 if E_Calling_Stubs = Empty then
2864 RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
2865
2866 -- The RCI_Locator package and calling stub are is inserted at the
2867 -- top level in the current unit, and must appear in the proper scope
2868 -- so that it is not prematurely removed by the GCC back end.
2869
2870 declare
2871 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
2872 begin
2873 if Ekind (Scop) = E_Package_Body then
2874 Push_Scope (Spec_Entity (Scop));
2875 elsif Ekind (Scop) = E_Subprogram_Body then
2876 Push_Scope
2877 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
2878 else
2879 Push_Scope (Scop);
2880 end if;
2881 end;
2882
2883 if RCI_Locator = Empty then
2884 RCI_Locator_Decl :=
2885 RCI_Package_Locator (Loc, Package_Specification (RCI_Package));
2886 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
2887 Analyze (RCI_Locator_Decl);
2888 RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
2889
2890 else
2891 RCI_Locator_Decl := Parent (RCI_Locator);
2892 end if;
2893
2894 Calling_Stubs := Build_Subprogram_Calling_Stubs
2895 (Vis_Decl => Parent (Parent (Called_Subprogram)),
2896 Subp_Id =>
2897 Build_Subprogram_Id (Loc, Called_Subprogram),
2898 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
2899 and then
2900 Is_Asynchronous (Called_Subprogram),
2901 Locator => RCI_Locator,
2902 New_Name => New_Internal_Name ('S'));
2903 Insert_After (RCI_Locator_Decl, Calling_Stubs);
2904 Analyze (Calling_Stubs);
2905 Pop_Scope;
2906
2907 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
2908 end if;
2909
2910 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
2911 end Expand_All_Calls_Remote_Subprogram_Call;
2912
2913 ---------------------------------
2914 -- Expand_Calling_Stubs_Bodies --
2915 ---------------------------------
2916
2917 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
2918 Spec : constant Node_Id := Specification (Unit_Node);
2919 begin
2920 Add_Calling_Stubs_To_Declarations (Spec);
2921 end Expand_Calling_Stubs_Bodies;
2922
2923 -----------------------------------
2924 -- Expand_Receiving_Stubs_Bodies --
2925 -----------------------------------
2926
2927 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
2928 Spec : Node_Id;
2929 Decls : List_Id;
2930 Stubs_Decls : List_Id;
2931 Stubs_Stmts : List_Id;
2932
2933 begin
2934 if Nkind (Unit_Node) = N_Package_Declaration then
2935 Spec := Specification (Unit_Node);
2936 Decls := Private_Declarations (Spec);
2937
2938 if No (Decls) then
2939 Decls := Visible_Declarations (Spec);
2940 end if;
2941
2942 Push_Scope (Scope_Of_Spec (Spec));
2943 Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls);
2944
2945 else
2946 Spec :=
2947 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
2948 Decls := Declarations (Unit_Node);
2949
2950 Push_Scope (Scope_Of_Spec (Unit_Node));
2951 Stubs_Decls := New_List;
2952 Stubs_Stmts := New_List;
2953 Specific_Add_Receiving_Stubs_To_Declarations
2954 (Spec, Stubs_Decls, Stubs_Stmts);
2955
2956 Insert_List_Before (First (Decls), Stubs_Decls);
2957
2958 declare
2959 HSS_Stmts : constant List_Id :=
2960 Statements (Handled_Statement_Sequence (Unit_Node));
2961
2962 First_HSS_Stmt : constant Node_Id := First (HSS_Stmts);
2963
2964 begin
2965 if No (First_HSS_Stmt) then
2966 Append_List_To (HSS_Stmts, Stubs_Stmts);
2967 else
2968 Insert_List_Before (First_HSS_Stmt, Stubs_Stmts);
2969 end if;
2970 end;
2971 end if;
2972
2973 Pop_Scope;
2974 end Expand_Receiving_Stubs_Bodies;
2975
2976 --------------------
2977 -- GARLIC_Support --
2978 --------------------
2979
2980 package body GARLIC_Support is
2981
2982 -- Local subprograms
2983
2984 procedure Add_RACW_Read_Attribute
2985 (RACW_Type : Entity_Id;
2986 Stub_Type : Entity_Id;
2987 Stub_Type_Access : Entity_Id;
2988 Body_Decls : List_Id);
2989 -- Add Read attribute for the RACW type. The declaration and attribute
2990 -- definition clauses are inserted right after the declaration of
2991 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2992 -- appended to it (case where the RACW declaration is in the main unit).
2993
2994 procedure Add_RACW_Write_Attribute
2995 (RACW_Type : Entity_Id;
2996 Stub_Type : Entity_Id;
2997 Stub_Type_Access : Entity_Id;
2998 RPC_Receiver : Node_Id;
2999 Body_Decls : List_Id);
3000 -- Same as above for the Write attribute
3001
3002 function Stream_Parameter return Node_Id;
3003 function Result return Node_Id;
3004 function Object return Node_Id renames Result;
3005 -- Functions to create occurrences of the formal parameter names of the
3006 -- 'Read and 'Write attributes.
3007
3008 Loc : Source_Ptr;
3009 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
3010 -- their ancillary subroutines (set on entry by Add_RACW_Features).
3011
3012 procedure Add_RAS_Access_TSS (N : Node_Id);
3013 -- Add a subprogram body for RAS Access TSS
3014
3015 -------------------------------------
3016 -- Add_Obj_RPC_Receiver_Completion --
3017 -------------------------------------
3018
3019 procedure Add_Obj_RPC_Receiver_Completion
3020 (Loc : Source_Ptr;
3021 Decls : List_Id;
3022 RPC_Receiver : Entity_Id;
3023 Stub_Elements : Stub_Structure)
3024 is
3025 begin
3026 -- The RPC receiver body should not be the completion of the
3027 -- declaration recorded in the stub structure, because then the
3028 -- occurrences of the formal parameters within the body should refer
3029 -- to the entities from the declaration, not from the completion, to
3030 -- which we do not have easy access. Instead, the RPC receiver body
3031 -- acts as its own declaration, and the RPC receiver declaration is
3032 -- completed by a renaming-as-body.
3033
3034 Append_To (Decls,
3035 Make_Subprogram_Renaming_Declaration (Loc,
3036 Specification =>
3037 Copy_Specification (Loc,
3038 Specification (Stub_Elements.RPC_Receiver_Decl)),
3039 Name => New_Occurrence_Of (RPC_Receiver, Loc)));
3040 end Add_Obj_RPC_Receiver_Completion;
3041
3042 -----------------------
3043 -- Add_RACW_Features --
3044 -----------------------
3045
3046 procedure Add_RACW_Features
3047 (RACW_Type : Entity_Id;
3048 Stub_Type : Entity_Id;
3049 Stub_Type_Access : Entity_Id;
3050 RPC_Receiver_Decl : Node_Id;
3051 Body_Decls : List_Id)
3052 is
3053 RPC_Receiver : Node_Id;
3054 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
3055
3056 begin
3057 Loc := Sloc (RACW_Type);
3058
3059 if Is_RAS then
3060
3061 -- For a RAS, the RPC receiver is that of the RCI unit, not that
3062 -- of the corresponding distributed object type. We retrieve its
3063 -- address from the local proxy object.
3064
3065 RPC_Receiver := Make_Selected_Component (Loc,
3066 Prefix =>
3067 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
3068 Selector_Name => Make_Identifier (Loc, Name_Receiver));
3069
3070 else
3071 RPC_Receiver := Make_Attribute_Reference (Loc,
3072 Prefix => New_Occurrence_Of (
3073 Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
3074 Attribute_Name => Name_Address);
3075 end if;
3076
3077 Add_RACW_Write_Attribute
3078 (RACW_Type,
3079 Stub_Type,
3080 Stub_Type_Access,
3081 RPC_Receiver,
3082 Body_Decls);
3083
3084 Add_RACW_Read_Attribute
3085 (RACW_Type,
3086 Stub_Type,
3087 Stub_Type_Access,
3088 Body_Decls);
3089 end Add_RACW_Features;
3090
3091 -----------------------------
3092 -- Add_RACW_Read_Attribute --
3093 -----------------------------
3094
3095 procedure Add_RACW_Read_Attribute
3096 (RACW_Type : Entity_Id;
3097 Stub_Type : Entity_Id;
3098 Stub_Type_Access : Entity_Id;
3099 Body_Decls : List_Id)
3100 is
3101 Proc_Decl : Node_Id;
3102 Attr_Decl : Node_Id;
3103
3104 Body_Node : Node_Id;
3105
3106 Statements : constant List_Id := New_List;
3107 Decls : List_Id;
3108 Local_Statements : List_Id;
3109 Remote_Statements : List_Id;
3110 -- Various parts of the procedure
3111
3112 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
3113 Asynchronous_Flag : constant Entity_Id :=
3114 Asynchronous_Flags_Table.Get (RACW_Type);
3115 pragma Assert (Present (Asynchronous_Flag));
3116
3117 -- Prepare local identifiers
3118
3119 Source_Partition : Entity_Id;
3120 Source_Receiver : Entity_Id;
3121 Source_Address : Entity_Id;
3122 Local_Stub : Entity_Id;
3123 Stubbed_Result : Entity_Id;
3124
3125 -- Start of processing for Add_RACW_Read_Attribute
3126
3127 begin
3128 Build_Stream_Procedure (Loc,
3129 RACW_Type, Body_Node, Pnam, Statements, Outp => True);
3130 Proc_Decl := Make_Subprogram_Declaration (Loc,
3131 Copy_Specification (Loc, Specification (Body_Node)));
3132
3133 Attr_Decl :=
3134 Make_Attribute_Definition_Clause (Loc,
3135 Name => New_Occurrence_Of (RACW_Type, Loc),
3136 Chars => Name_Read,
3137 Expression =>
3138 New_Occurrence_Of (
3139 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3140
3141 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3142 Insert_After (Proc_Decl, Attr_Decl);
3143
3144 if No (Body_Decls) then
3145
3146 -- Case of processing an RACW type from another unit than the
3147 -- main one: do not generate a body.
3148
3149 return;
3150 end if;
3151
3152 -- Prepare local identifiers
3153
3154 Source_Partition := Make_Temporary (Loc, 'P');
3155 Source_Receiver := Make_Temporary (Loc, 'S');
3156 Source_Address := Make_Temporary (Loc, 'P');
3157 Local_Stub := Make_Temporary (Loc, 'L');
3158 Stubbed_Result := Make_Temporary (Loc, 'S');
3159
3160 -- Generate object declarations
3161
3162 Decls := New_List (
3163 Make_Object_Declaration (Loc,
3164 Defining_Identifier => Source_Partition,
3165 Object_Definition =>
3166 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
3167
3168 Make_Object_Declaration (Loc,
3169 Defining_Identifier => Source_Receiver,
3170 Object_Definition =>
3171 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3172
3173 Make_Object_Declaration (Loc,
3174 Defining_Identifier => Source_Address,
3175 Object_Definition =>
3176 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3177
3178 Make_Object_Declaration (Loc,
3179 Defining_Identifier => Local_Stub,
3180 Aliased_Present => True,
3181 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
3182
3183 Make_Object_Declaration (Loc,
3184 Defining_Identifier => Stubbed_Result,
3185 Object_Definition =>
3186 New_Occurrence_Of (Stub_Type_Access, Loc),
3187 Expression =>
3188 Make_Attribute_Reference (Loc,
3189 Prefix =>
3190 New_Occurrence_Of (Local_Stub, Loc),
3191 Attribute_Name =>
3192 Name_Unchecked_Access)));
3193
3194 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3195
3196 Append_List_To (Statements, New_List (
3197 Make_Attribute_Reference (Loc,
3198 Prefix =>
3199 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3200 Attribute_Name => Name_Read,
3201 Expressions => New_List (
3202 Stream_Parameter,
3203 New_Occurrence_Of (Source_Partition, Loc))),
3204
3205 Make_Attribute_Reference (Loc,
3206 Prefix =>
3207 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3208 Attribute_Name =>
3209 Name_Read,
3210 Expressions => New_List (
3211 Stream_Parameter,
3212 New_Occurrence_Of (Source_Receiver, Loc))),
3213
3214 Make_Attribute_Reference (Loc,
3215 Prefix =>
3216 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3217 Attribute_Name =>
3218 Name_Read,
3219 Expressions => New_List (
3220 Stream_Parameter,
3221 New_Occurrence_Of (Source_Address, Loc)))));
3222
3223 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3224
3225 Set_Etype (Stubbed_Result, Stub_Type_Access);
3226
3227 -- If the Address is Null_Address, then return a null object, unless
3228 -- RACW_Type is null-excluding, in which case unconditionally raise
3229 -- CONSTRAINT_ERROR instead.
3230
3231 declare
3232 Zero_Statements : List_Id;
3233 -- Statements executed when a zero value is received
3234
3235 begin
3236 if Can_Never_Be_Null (RACW_Type) then
3237 Zero_Statements := New_List (
3238 Make_Raise_Constraint_Error (Loc,
3239 Reason => CE_Null_Not_Allowed));
3240 else
3241 Zero_Statements := New_List (
3242 Make_Assignment_Statement (Loc,
3243 Name => Result,
3244 Expression => Make_Null (Loc)),
3245 Make_Simple_Return_Statement (Loc));
3246 end if;
3247
3248 Append_To (Statements,
3249 Make_Implicit_If_Statement (RACW_Type,
3250 Condition =>
3251 Make_Op_Eq (Loc,
3252 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
3253 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
3254 Then_Statements => Zero_Statements));
3255 end;
3256
3257 -- If the RACW denotes an object created on the current partition,
3258 -- Local_Statements will be executed. The real object will be used.
3259
3260 Local_Statements := New_List (
3261 Make_Assignment_Statement (Loc,
3262 Name => Result,
3263 Expression =>
3264 Unchecked_Convert_To (RACW_Type,
3265 OK_Convert_To (RTE (RE_Address),
3266 New_Occurrence_Of (Source_Address, Loc)))));
3267
3268 -- If the object is located on another partition, then a stub object
3269 -- will be created with all the information needed to rebuild the
3270 -- real object at the other end.
3271
3272 Remote_Statements := New_List (
3273
3274 Make_Assignment_Statement (Loc,
3275 Name => Make_Selected_Component (Loc,
3276 Prefix => Stubbed_Result,
3277 Selector_Name => Name_Origin),
3278 Expression =>
3279 New_Occurrence_Of (Source_Partition, Loc)),
3280
3281 Make_Assignment_Statement (Loc,
3282 Name => Make_Selected_Component (Loc,
3283 Prefix => Stubbed_Result,
3284 Selector_Name => Name_Receiver),
3285 Expression =>
3286 New_Occurrence_Of (Source_Receiver, Loc)),
3287
3288 Make_Assignment_Statement (Loc,
3289 Name => Make_Selected_Component (Loc,
3290 Prefix => Stubbed_Result,
3291 Selector_Name => Name_Addr),
3292 Expression =>
3293 New_Occurrence_Of (Source_Address, Loc)));
3294
3295 Append_To (Remote_Statements,
3296 Make_Assignment_Statement (Loc,
3297 Name => Make_Selected_Component (Loc,
3298 Prefix => Stubbed_Result,
3299 Selector_Name => Name_Asynchronous),
3300 Expression =>
3301 New_Occurrence_Of (Asynchronous_Flag, Loc)));
3302
3303 Append_List_To (Remote_Statements,
3304 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
3305 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3306 -- set on the stub type if, and only if, the RACW type has a pragma
3307 -- Asynchronous. This is incorrect for RACWs that implement RAS
3308 -- types, because in that case the /designated subprogram/ (not the
3309 -- type) might be asynchronous, and that causes the stub to need to
3310 -- be asynchronous too. A solution is to transport a RAS as a struct
3311 -- containing a RACW and an asynchronous flag, and to properly alter
3312 -- the Asynchronous component in the stub type in the RAS's Input
3313 -- TSS.
3314
3315 Append_To (Remote_Statements,
3316 Make_Assignment_Statement (Loc,
3317 Name => Result,
3318 Expression => Unchecked_Convert_To (RACW_Type,
3319 New_Occurrence_Of (Stubbed_Result, Loc))));
3320
3321 -- Distinguish between the local and remote cases, and execute the
3322 -- appropriate piece of code.
3323
3324 Append_To (Statements,
3325 Make_Implicit_If_Statement (RACW_Type,
3326 Condition =>
3327 Make_Op_Eq (Loc,
3328 Left_Opnd =>
3329 Make_Function_Call (Loc,
3330 Name => New_Occurrence_Of (
3331 RTE (RE_Get_Local_Partition_Id), Loc)),
3332 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
3333 Then_Statements => Local_Statements,
3334 Else_Statements => Remote_Statements));
3335
3336 Set_Declarations (Body_Node, Decls);
3337 Append_To (Body_Decls, Body_Node);
3338 end Add_RACW_Read_Attribute;
3339
3340 ------------------------------
3341 -- Add_RACW_Write_Attribute --
3342 ------------------------------
3343
3344 procedure Add_RACW_Write_Attribute
3345 (RACW_Type : Entity_Id;
3346 Stub_Type : Entity_Id;
3347 Stub_Type_Access : Entity_Id;
3348 RPC_Receiver : Node_Id;
3349 Body_Decls : List_Id)
3350 is
3351 Body_Node : Node_Id;
3352 Proc_Decl : Node_Id;
3353 Attr_Decl : Node_Id;
3354
3355 Statements : constant List_Id := New_List;
3356 Local_Statements : List_Id;
3357 Remote_Statements : List_Id;
3358 Null_Statements : List_Id;
3359
3360 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
3361
3362 begin
3363 Build_Stream_Procedure
3364 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
3365
3366 Proc_Decl := Make_Subprogram_Declaration (Loc,
3367 Copy_Specification (Loc, Specification (Body_Node)));
3368
3369 Attr_Decl :=
3370 Make_Attribute_Definition_Clause (Loc,
3371 Name => New_Occurrence_Of (RACW_Type, Loc),
3372 Chars => Name_Write,
3373 Expression =>
3374 New_Occurrence_Of (
3375 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
3376
3377 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
3378 Insert_After (Proc_Decl, Attr_Decl);
3379
3380 if No (Body_Decls) then
3381 return;
3382 end if;
3383
3384 -- Build the code fragment corresponding to the marshalling of a
3385 -- local object.
3386
3387 Local_Statements := New_List (
3388
3389 Pack_Entity_Into_Stream_Access (Loc,
3390 Stream => Stream_Parameter,
3391 Object => RTE (RE_Get_Local_Partition_Id)),
3392
3393 Pack_Node_Into_Stream_Access (Loc,
3394 Stream => Stream_Parameter,
3395 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3396 Etyp => RTE (RE_Unsigned_64)),
3397
3398 Pack_Node_Into_Stream_Access (Loc,
3399 Stream => Stream_Parameter,
3400 Object => OK_Convert_To (RTE (RE_Unsigned_64),
3401 Make_Attribute_Reference (Loc,
3402 Prefix =>
3403 Make_Explicit_Dereference (Loc,
3404 Prefix => Object),
3405 Attribute_Name => Name_Address)),
3406 Etyp => RTE (RE_Unsigned_64)));
3407
3408 -- Build the code fragment corresponding to the marshalling of
3409 -- a remote object.
3410
3411 Remote_Statements := New_List (
3412 Pack_Node_Into_Stream_Access (Loc,
3413 Stream => Stream_Parameter,
3414 Object =>
3415 Make_Selected_Component (Loc,
3416 Prefix =>
3417 Unchecked_Convert_To (Stub_Type_Access, Object),
3418 Selector_Name => Make_Identifier (Loc, Name_Origin)),
3419 Etyp => RTE (RE_Partition_ID)),
3420
3421 Pack_Node_Into_Stream_Access (Loc,
3422 Stream => Stream_Parameter,
3423 Object =>
3424 Make_Selected_Component (Loc,
3425 Prefix =>
3426 Unchecked_Convert_To (Stub_Type_Access, Object),
3427 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
3428 Etyp => RTE (RE_Unsigned_64)),
3429
3430 Pack_Node_Into_Stream_Access (Loc,
3431 Stream => Stream_Parameter,
3432 Object =>
3433 Make_Selected_Component (Loc,
3434 Prefix =>
3435 Unchecked_Convert_To (Stub_Type_Access, Object),
3436 Selector_Name => Make_Identifier (Loc, Name_Addr)),
3437 Etyp => RTE (RE_Unsigned_64)));
3438
3439 -- Build code fragment corresponding to marshalling of a null object
3440
3441 Null_Statements := New_List (
3442
3443 Pack_Entity_Into_Stream_Access (Loc,
3444 Stream => Stream_Parameter,
3445 Object => RTE (RE_Get_Local_Partition_Id)),
3446
3447 Pack_Node_Into_Stream_Access (Loc,
3448 Stream => Stream_Parameter,
3449 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
3450 Etyp => RTE (RE_Unsigned_64)),
3451
3452 Pack_Node_Into_Stream_Access (Loc,
3453 Stream => Stream_Parameter,
3454 Object => Make_Integer_Literal (Loc, Uint_0),
3455 Etyp => RTE (RE_Unsigned_64)));
3456
3457 Append_To (Statements,
3458 Make_Implicit_If_Statement (RACW_Type,
3459 Condition =>
3460 Make_Op_Eq (Loc,
3461 Left_Opnd => Object,
3462 Right_Opnd => Make_Null (Loc)),
3463
3464 Then_Statements => Null_Statements,
3465
3466 Elsif_Parts => New_List (
3467 Make_Elsif_Part (Loc,
3468 Condition =>
3469 Make_Op_Eq (Loc,
3470 Left_Opnd =>
3471 Make_Attribute_Reference (Loc,
3472 Prefix => Object,
3473 Attribute_Name => Name_Tag),
3474
3475 Right_Opnd =>
3476 Make_Attribute_Reference (Loc,
3477 Prefix => New_Occurrence_Of (Stub_Type, Loc),
3478 Attribute_Name => Name_Tag)),
3479 Then_Statements => Remote_Statements)),
3480 Else_Statements => Local_Statements));
3481
3482 Append_To (Body_Decls, Body_Node);
3483 end Add_RACW_Write_Attribute;
3484
3485 ------------------------
3486 -- Add_RAS_Access_TSS --
3487 ------------------------
3488
3489 procedure Add_RAS_Access_TSS (N : Node_Id) is
3490 Loc : constant Source_Ptr := Sloc (N);
3491
3492 Ras_Type : constant Entity_Id := Defining_Identifier (N);
3493 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
3494 -- Ras_Type is the access to subprogram type while Fat_Type is the
3495 -- corresponding record type.
3496
3497 RACW_Type : constant Entity_Id :=
3498 Underlying_RACW_Type (Ras_Type);
3499 Desig : constant Entity_Id :=
3500 Etype (Designated_Type (RACW_Type));
3501
3502 Stub_Elements : constant Stub_Structure :=
3503 Stubs_Table.Get (Desig);
3504 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
3505
3506 Proc : constant Entity_Id :=
3507 Make_Defining_Identifier (Loc,
3508 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
3509
3510 Proc_Spec : Node_Id;
3511
3512 -- Formal parameters
3513
3514 Package_Name : constant Entity_Id :=
3515 Make_Defining_Identifier (Loc,
3516 Chars => Name_P);
3517 -- Target package
3518
3519 Subp_Id : constant Entity_Id :=
3520 Make_Defining_Identifier (Loc,
3521 Chars => Name_S);
3522 -- Target subprogram
3523
3524 Asynch_P : constant Entity_Id :=
3525 Make_Defining_Identifier (Loc,
3526 Chars => Name_Asynchronous);
3527 -- Is the procedure to which the 'Access applies asynchronous?
3528
3529 All_Calls_Remote : constant Entity_Id :=
3530 Make_Defining_Identifier (Loc,
3531 Chars => Name_All_Calls_Remote);
3532 -- True if an All_Calls_Remote pragma applies to the RCI unit
3533 -- that contains the subprogram.
3534
3535 -- Common local variables
3536
3537 Proc_Decls : List_Id;
3538 Proc_Statements : List_Id;
3539
3540 Origin : constant Entity_Id := Make_Temporary (Loc, 'P');
3541
3542 -- Additional local variables for the local case
3543
3544 Proxy_Addr : constant Entity_Id := Make_Temporary (Loc, 'P');
3545
3546 -- Additional local variables for the remote case
3547
3548 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
3549 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
3550
3551 function Set_Field
3552 (Field_Name : Name_Id;
3553 Value : Node_Id) return Node_Id;
3554 -- Construct an assignment that sets the named component in the
3555 -- returned record
3556
3557 ---------------
3558 -- Set_Field --
3559 ---------------
3560
3561 function Set_Field
3562 (Field_Name : Name_Id;
3563 Value : Node_Id) return Node_Id
3564 is
3565 begin
3566 return
3567 Make_Assignment_Statement (Loc,
3568 Name =>
3569 Make_Selected_Component (Loc,
3570 Prefix => Stub_Ptr,
3571 Selector_Name => Field_Name),
3572 Expression => Value);
3573 end Set_Field;
3574
3575 -- Start of processing for Add_RAS_Access_TSS
3576
3577 begin
3578 Proc_Decls := New_List (
3579
3580 -- Common declarations
3581
3582 Make_Object_Declaration (Loc,
3583 Defining_Identifier => Origin,
3584 Constant_Present => True,
3585 Object_Definition =>
3586 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3587 Expression =>
3588 Make_Function_Call (Loc,
3589 Name =>
3590 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
3591 Parameter_Associations => New_List (
3592 New_Occurrence_Of (Package_Name, Loc)))),
3593
3594 -- Declaration use only in the local case: proxy address
3595
3596 Make_Object_Declaration (Loc,
3597 Defining_Identifier => Proxy_Addr,
3598 Object_Definition =>
3599 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
3600
3601 -- Declarations used only in the remote case: stub object and
3602 -- stub pointer.
3603
3604 Make_Object_Declaration (Loc,
3605 Defining_Identifier => Local_Stub,
3606 Aliased_Present => True,
3607 Object_Definition =>
3608 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
3609
3610 Make_Object_Declaration (Loc,
3611 Defining_Identifier =>
3612 Stub_Ptr,
3613 Object_Definition =>
3614 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
3615 Expression =>
3616 Make_Attribute_Reference (Loc,
3617 Prefix => New_Occurrence_Of (Local_Stub, Loc),
3618 Attribute_Name => Name_Unchecked_Access)));
3619
3620 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
3621
3622 -- Build_Get_Unique_RP_Call needs above information
3623
3624 -- Note: Here we assume that the Fat_Type is a record
3625 -- containing just a pointer to a proxy or stub object.
3626
3627 Proc_Statements := New_List (
3628
3629 -- Generate:
3630
3631 -- Get_RAS_Info (Pkg, Subp, PA);
3632 -- if Origin = Local_Partition_Id
3633 -- and then not All_Calls_Remote
3634 -- then
3635 -- return Fat_Type!(PA);
3636 -- end if;
3637
3638 Make_Procedure_Call_Statement (Loc,
3639 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
3640 Parameter_Associations => New_List (
3641 New_Occurrence_Of (Package_Name, Loc),
3642 New_Occurrence_Of (Subp_Id, Loc),
3643 New_Occurrence_Of (Proxy_Addr, Loc))),
3644
3645 Make_Implicit_If_Statement (N,
3646 Condition =>
3647 Make_And_Then (Loc,
3648 Left_Opnd =>
3649 Make_Op_Eq (Loc,
3650 Left_Opnd =>
3651 New_Occurrence_Of (Origin, Loc),
3652 Right_Opnd =>
3653 Make_Function_Call (Loc,
3654 New_Occurrence_Of (
3655 RTE (RE_Get_Local_Partition_Id), Loc))),
3656
3657 Right_Opnd =>
3658 Make_Op_Not (Loc,
3659 New_Occurrence_Of (All_Calls_Remote, Loc))),
3660
3661 Then_Statements => New_List (
3662 Make_Simple_Return_Statement (Loc,
3663 Unchecked_Convert_To (Fat_Type,
3664 OK_Convert_To (RTE (RE_Address),
3665 New_Occurrence_Of (Proxy_Addr, Loc)))))),
3666
3667 Set_Field (Name_Origin,
3668 New_Occurrence_Of (Origin, Loc)),
3669
3670 Set_Field (Name_Receiver,
3671 Make_Function_Call (Loc,
3672 Name =>
3673 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
3674 Parameter_Associations => New_List (
3675 New_Occurrence_Of (Package_Name, Loc)))),
3676
3677 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
3678
3679 -- E.4.1(9) A remote call is asynchronous if it is a call to
3680 -- a procedure or a call through a value of an access-to-procedure
3681 -- type to which a pragma Asynchronous applies.
3682
3683 -- Asynch_P is true when the procedure is asynchronous;
3684 -- Asynch_T is true when the type is asynchronous.
3685
3686 Set_Field (Name_Asynchronous,
3687 Make_Or_Else (Loc,
3688 New_Occurrence_Of (Asynch_P, Loc),
3689 New_Occurrence_Of (Boolean_Literals (
3690 Is_Asynchronous (Ras_Type)), Loc))));
3691
3692 Append_List_To (Proc_Statements,
3693 Build_Get_Unique_RP_Call
3694 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
3695
3696 -- Return the newly created value
3697
3698 Append_To (Proc_Statements,
3699 Make_Simple_Return_Statement (Loc,
3700 Expression =>
3701 Unchecked_Convert_To (Fat_Type,
3702 New_Occurrence_Of (Stub_Ptr, Loc))));
3703
3704 Proc_Spec :=
3705 Make_Function_Specification (Loc,
3706 Defining_Unit_Name => Proc,
3707 Parameter_Specifications => New_List (
3708 Make_Parameter_Specification (Loc,
3709 Defining_Identifier => Package_Name,
3710 Parameter_Type =>
3711 New_Occurrence_Of (Standard_String, Loc)),
3712
3713 Make_Parameter_Specification (Loc,
3714 Defining_Identifier => Subp_Id,
3715 Parameter_Type =>
3716 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
3717
3718 Make_Parameter_Specification (Loc,
3719 Defining_Identifier => Asynch_P,
3720 Parameter_Type =>
3721 New_Occurrence_Of (Standard_Boolean, Loc)),
3722
3723 Make_Parameter_Specification (Loc,
3724 Defining_Identifier => All_Calls_Remote,
3725 Parameter_Type =>
3726 New_Occurrence_Of (Standard_Boolean, Loc))),
3727
3728 Result_Definition =>
3729 New_Occurrence_Of (Fat_Type, Loc));
3730
3731 -- Set the kind and return type of the function to prevent
3732 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3733
3734 Set_Ekind (Proc, E_Function);
3735 Set_Etype (Proc, Fat_Type);
3736
3737 Discard_Node (
3738 Make_Subprogram_Body (Loc,
3739 Specification => Proc_Spec,
3740 Declarations => Proc_Decls,
3741 Handled_Statement_Sequence =>
3742 Make_Handled_Sequence_Of_Statements (Loc,
3743 Statements => Proc_Statements)));
3744
3745 Set_TSS (Fat_Type, Proc);
3746 end Add_RAS_Access_TSS;
3747
3748 -----------------------
3749 -- Add_RAST_Features --
3750 -----------------------
3751
3752 procedure Add_RAST_Features
3753 (Vis_Decl : Node_Id;
3754 RAS_Type : Entity_Id)
3755 is
3756 pragma Unreferenced (RAS_Type);
3757 begin
3758 Add_RAS_Access_TSS (Vis_Decl);
3759 end Add_RAST_Features;
3760
3761 -----------------------------------------
3762 -- Add_Receiving_Stubs_To_Declarations --
3763 -----------------------------------------
3764
3765 procedure Add_Receiving_Stubs_To_Declarations
3766 (Pkg_Spec : Node_Id;
3767 Decls : List_Id;
3768 Stmts : List_Id)
3769 is
3770 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
3771
3772 Request_Parameter : Node_Id;
3773
3774 Pkg_RPC_Receiver : constant Entity_Id :=
3775 Make_Temporary (Loc, 'H');
3776 Pkg_RPC_Receiver_Statements : List_Id;
3777 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
3778 Pkg_RPC_Receiver_Body : Node_Id;
3779 -- A Pkg_RPC_Receiver is built to decode the request
3780
3781 Lookup_RAS : Node_Id;
3782 Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R');
3783 -- A remote subprogram is created to allow peers to look up RAS
3784 -- information using subprogram ids.
3785
3786 Subp_Id : Entity_Id;
3787 Subp_Index : Entity_Id;
3788 -- Subprogram_Id as read from the incoming stream
3789
3790 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
3791 Current_Stubs : Node_Id;
3792
3793 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
3794 Subp_Info_List : constant List_Id := New_List;
3795
3796 Register_Pkg_Actuals : constant List_Id := New_List;
3797
3798 All_Calls_Remote_E : Entity_Id;
3799 Proxy_Object_Addr : Entity_Id;
3800
3801 procedure Append_Stubs_To
3802 (RPC_Receiver_Cases : List_Id;
3803 Stubs : Node_Id;
3804 Subprogram_Number : Int);
3805 -- Add one case to the specified RPC receiver case list
3806 -- associating Subprogram_Number with the subprogram declared
3807 -- by Declaration, for which we have receiving stubs in Stubs.
3808
3809 procedure Visit_Subprogram (Decl : Node_Id);
3810 -- Generate receiving stub for one remote subprogram
3811
3812 ---------------------
3813 -- Append_Stubs_To --
3814 ---------------------
3815
3816 procedure Append_Stubs_To
3817 (RPC_Receiver_Cases : List_Id;
3818 Stubs : Node_Id;
3819 Subprogram_Number : Int)
3820 is
3821 begin
3822 Append_To (RPC_Receiver_Cases,
3823 Make_Case_Statement_Alternative (Loc,
3824 Discrete_Choices =>
3825 New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
3826 Statements =>
3827 New_List (
3828 Make_Procedure_Call_Statement (Loc,
3829 Name =>
3830 New_Occurrence_Of (Defining_Entity (Stubs), Loc),
3831 Parameter_Associations => New_List (
3832 New_Occurrence_Of (Request_Parameter, Loc))))));
3833 end Append_Stubs_To;
3834
3835 ----------------------
3836 -- Visit_Subprogram --
3837 ----------------------
3838
3839 procedure Visit_Subprogram (Decl : Node_Id) is
3840 Loc : constant Source_Ptr := Sloc (Decl);
3841 Spec : constant Node_Id := Specification (Decl);
3842 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
3843
3844 Subp_Val : String_Id;
3845 pragma Warnings (Off, Subp_Val);
3846
3847 begin
3848 -- Disable expansion of stubs if serious errors have been
3849 -- diagnosed, because otherwise some illegal remote subprogram
3850 -- declarations could cause cascaded errors in stubs.
3851
3852 if Serious_Errors_Detected /= 0 then
3853 return;
3854 end if;
3855
3856 -- Build receiving stub
3857
3858 Current_Stubs :=
3859 Build_Subprogram_Receiving_Stubs
3860 (Vis_Decl => Decl,
3861 Asynchronous =>
3862 Nkind (Spec) = N_Procedure_Specification
3863 and then Is_Asynchronous (Subp_Def));
3864
3865 Append_To (Decls, Current_Stubs);
3866 Analyze (Current_Stubs);
3867
3868 -- Build RAS proxy
3869
3870 Add_RAS_Proxy_And_Analyze (Decls,
3871 Vis_Decl => Decl,
3872 All_Calls_Remote_E => All_Calls_Remote_E,
3873 Proxy_Object_Addr => Proxy_Object_Addr);
3874
3875 -- Compute distribution identifier
3876
3877 Assign_Subprogram_Identifier
3878 (Subp_Def, Current_Subp_Number, Subp_Val);
3879
3880 pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
3881
3882 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
3883 -- table for this receiver. This aggregate must be kept consistent
3884 -- with the declaration of RCI_Subp_Info in
3885 -- System.Partition_Interface.
3886
3887 Append_To (Subp_Info_List,
3888 Make_Component_Association (Loc,
3889 Choices => New_List (
3890 Make_Integer_Literal (Loc, Current_Subp_Number)),
3891
3892 Expression =>
3893 Make_Aggregate (Loc,
3894 Component_Associations => New_List (
3895
3896 -- Addr =>
3897
3898 Make_Component_Association (Loc,
3899 Choices =>
3900 New_List (Make_Identifier (Loc, Name_Addr)),
3901 Expression =>
3902 New_Occurrence_Of (Proxy_Object_Addr, Loc))))));
3903
3904 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
3905 Stubs => Current_Stubs,
3906 Subprogram_Number => Current_Subp_Number);
3907
3908 Current_Subp_Number := Current_Subp_Number + 1;
3909 end Visit_Subprogram;
3910
3911 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
3912
3913 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3914
3915 begin
3916 -- Building receiving stubs consist in several operations:
3917
3918 -- - a package RPC receiver must be built. This subprogram
3919 -- will get a Subprogram_Id from the incoming stream
3920 -- and will dispatch the call to the right subprogram;
3921
3922 -- - a receiving stub for each subprogram visible in the package
3923 -- spec. This stub will read all the parameters from the stream,
3924 -- and put the result as well as the exception occurrence in the
3925 -- output stream;
3926
3927 -- - a dummy package with an empty spec and a body made of an
3928 -- elaboration part, whose job is to register the receiving
3929 -- part of this RCI package on the name server. This is done
3930 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3931
3932 Build_RPC_Receiver_Body (
3933 RPC_Receiver => Pkg_RPC_Receiver,
3934 Request => Request_Parameter,
3935 Subp_Id => Subp_Id,
3936 Subp_Index => Subp_Index,
3937 Stmts => Pkg_RPC_Receiver_Statements,
3938 Decl => Pkg_RPC_Receiver_Body);
3939 pragma Assert (Subp_Id = Subp_Index);
3940
3941 -- A null subp_id denotes a call through a RAS, in which case the
3942 -- next Uint_64 element in the stream is the address of the local
3943 -- proxy object, from which we can retrieve the actual subprogram id.
3944
3945 Append_To (Pkg_RPC_Receiver_Statements,
3946 Make_Implicit_If_Statement (Pkg_Spec,
3947 Condition =>
3948 Make_Op_Eq (Loc,
3949 New_Occurrence_Of (Subp_Id, Loc),
3950 Make_Integer_Literal (Loc, 0)),
3951
3952 Then_Statements => New_List (
3953 Make_Assignment_Statement (Loc,
3954 Name =>
3955 New_Occurrence_Of (Subp_Id, Loc),
3956
3957 Expression =>
3958 Make_Selected_Component (Loc,
3959 Prefix =>
3960 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
3961 OK_Convert_To (RTE (RE_Address),
3962 Make_Attribute_Reference (Loc,
3963 Prefix =>
3964 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
3965 Attribute_Name =>
3966 Name_Input,
3967 Expressions => New_List (
3968 Make_Selected_Component (Loc,
3969 Prefix => Request_Parameter,
3970 Selector_Name => Name_Params))))),
3971
3972 Selector_Name => Make_Identifier (Loc, Name_Subp_Id))))));
3973
3974 -- Build a subprogram for RAS information lookups
3975
3976 Lookup_RAS :=
3977 Make_Subprogram_Declaration (Loc,
3978 Specification =>
3979 Make_Function_Specification (Loc,
3980 Defining_Unit_Name =>
3981 Lookup_RAS_Info,
3982 Parameter_Specifications => New_List (
3983 Make_Parameter_Specification (Loc,
3984 Defining_Identifier =>
3985 Make_Defining_Identifier (Loc, Name_Subp_Id),
3986 In_Present =>
3987 True,
3988 Parameter_Type =>
3989 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
3990 Result_Definition =>
3991 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
3992 Append_To (Decls, Lookup_RAS);
3993 Analyze (Lookup_RAS);
3994
3995 Current_Stubs := Build_Subprogram_Receiving_Stubs
3996 (Vis_Decl => Lookup_RAS,
3997 Asynchronous => False);
3998 Append_To (Decls, Current_Stubs);
3999 Analyze (Current_Stubs);
4000
4001 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
4002 Stubs => Current_Stubs,
4003 Subprogram_Number => 1);
4004
4005 -- For each subprogram, the receiving stub will be built and a
4006 -- case statement will be made on the Subprogram_Id to dispatch
4007 -- to the right subprogram.
4008
4009 All_Calls_Remote_E :=
4010 Boolean_Literals
4011 (Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
4012
4013 Overload_Counter_Table.Reset;
4014
4015 Visit_Spec (Pkg_Spec);
4016
4017 -- If we receive an invalid Subprogram_Id, it is best to do nothing
4018 -- rather than raising an exception since we do not want someone
4019 -- to crash a remote partition by sending invalid subprogram ids.
4020 -- This is consistent with the other parts of the case statement
4021 -- since even in presence of incorrect parameters in the stream,
4022 -- every exception will be caught and (if the subprogram is not an
4023 -- APC) put into the result stream and sent away.
4024
4025 Append_To (Pkg_RPC_Receiver_Cases,
4026 Make_Case_Statement_Alternative (Loc,
4027 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4028 Statements => New_List (Make_Null_Statement (Loc))));
4029
4030 Append_To (Pkg_RPC_Receiver_Statements,
4031 Make_Case_Statement (Loc,
4032 Expression => New_Occurrence_Of (Subp_Id, Loc),
4033 Alternatives => Pkg_RPC_Receiver_Cases));
4034
4035 Append_To (Decls,
4036 Make_Object_Declaration (Loc,
4037 Defining_Identifier => Subp_Info_Array,
4038 Constant_Present => True,
4039 Aliased_Present => True,
4040 Object_Definition =>
4041 Make_Subtype_Indication (Loc,
4042 Subtype_Mark =>
4043 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
4044 Constraint =>
4045 Make_Index_Or_Discriminant_Constraint (Loc,
4046 New_List (
4047 Make_Range (Loc,
4048 Low_Bound => Make_Integer_Literal (Loc,
4049 First_RCI_Subprogram_Id),
4050 High_Bound =>
4051 Make_Integer_Literal (Loc,
4052 Intval =>
4053 First_RCI_Subprogram_Id
4054 + List_Length (Subp_Info_List) - 1)))))));
4055
4056 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
4057 -- has zero length, and the declaration is for an empty array, in
4058 -- which case no initialization aggregate must be generated.
4059
4060 if Present (First (Subp_Info_List)) then
4061 Set_Expression (Last (Decls),
4062 Make_Aggregate (Loc,
4063 Component_Associations => Subp_Info_List));
4064
4065 -- No initialization provided: remove CONSTANT so that the
4066 -- declaration is not an incomplete deferred constant.
4067
4068 else
4069 Set_Constant_Present (Last (Decls), False);
4070 end if;
4071
4072 Analyze (Last (Decls));
4073
4074 declare
4075 Subp_Info_Addr : Node_Id;
4076 -- Return statement for Lookup_RAS_Info: address of the subprogram
4077 -- information record for the requested subprogram id.
4078
4079 begin
4080 if Present (First (Subp_Info_List)) then
4081 Subp_Info_Addr :=
4082 Make_Selected_Component (Loc,
4083 Prefix =>
4084 Make_Indexed_Component (Loc,
4085 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4086 Expressions => New_List (
4087 Convert_To (Standard_Integer,
4088 Make_Identifier (Loc, Name_Subp_Id)))),
4089 Selector_Name => Make_Identifier (Loc, Name_Addr));
4090
4091 -- Case of no visible subprogram: just raise Constraint_Error, we
4092 -- know for sure we got junk from a remote partition.
4093
4094 else
4095 Subp_Info_Addr :=
4096 Make_Raise_Constraint_Error (Loc,
4097 Reason => CE_Range_Check_Failed);
4098 Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64));
4099 end if;
4100
4101 Append_To (Decls,
4102 Make_Subprogram_Body (Loc,
4103 Specification =>
4104 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
4105 Declarations => No_List,
4106 Handled_Statement_Sequence =>
4107 Make_Handled_Sequence_Of_Statements (Loc,
4108 Statements => New_List (
4109 Make_Simple_Return_Statement (Loc,
4110 Expression =>
4111 OK_Convert_To
4112 (RTE (RE_Unsigned_64), Subp_Info_Addr))))));
4113 end;
4114
4115 Analyze (Last (Decls));
4116
4117 Append_To (Decls, Pkg_RPC_Receiver_Body);
4118 Analyze (Last (Decls));
4119
4120 -- Name
4121
4122 Append_To (Register_Pkg_Actuals,
4123 Make_String_Literal (Loc,
4124 Strval =>
4125 Fully_Qualified_Name_String
4126 (Defining_Entity (Pkg_Spec), Append_NUL => False)));
4127
4128 -- Receiver
4129
4130 Append_To (Register_Pkg_Actuals,
4131 Make_Attribute_Reference (Loc,
4132 Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
4133 Attribute_Name => Name_Unrestricted_Access));
4134
4135 -- Version
4136
4137 Append_To (Register_Pkg_Actuals,
4138 Make_Attribute_Reference (Loc,
4139 Prefix =>
4140 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
4141 Attribute_Name => Name_Version));
4142
4143 -- Subp_Info
4144
4145 Append_To (Register_Pkg_Actuals,
4146 Make_Attribute_Reference (Loc,
4147 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4148 Attribute_Name => Name_Address));
4149
4150 -- Subp_Info_Len
4151
4152 Append_To (Register_Pkg_Actuals,
4153 Make_Attribute_Reference (Loc,
4154 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
4155 Attribute_Name => Name_Length));
4156
4157 -- Generate the call
4158
4159 Append_To (Stmts,
4160 Make_Procedure_Call_Statement (Loc,
4161 Name =>
4162 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
4163 Parameter_Associations => Register_Pkg_Actuals));
4164 Analyze (Last (Stmts));
4165 end Add_Receiving_Stubs_To_Declarations;
4166
4167 ---------------------------------
4168 -- Build_General_Calling_Stubs --
4169 ---------------------------------
4170
4171 procedure Build_General_Calling_Stubs
4172 (Decls : List_Id;
4173 Statements : List_Id;
4174 Target_Partition : Entity_Id;
4175 Target_RPC_Receiver : Node_Id;
4176 Subprogram_Id : Node_Id;
4177 Asynchronous : Node_Id := Empty;
4178 Is_Known_Asynchronous : Boolean := False;
4179 Is_Known_Non_Asynchronous : Boolean := False;
4180 Is_Function : Boolean;
4181 Spec : Node_Id;
4182 Stub_Type : Entity_Id := Empty;
4183 RACW_Type : Entity_Id := Empty;
4184 Nod : Node_Id)
4185 is
4186 Loc : constant Source_Ptr := Sloc (Nod);
4187
4188 Stream_Parameter : Node_Id;
4189 -- Name of the stream used to transmit parameters to the remote
4190 -- package.
4191
4192 Result_Parameter : Node_Id;
4193 -- Name of the result parameter (in non-APC cases) which get the
4194 -- result of the remote subprogram.
4195
4196 Exception_Return_Parameter : Node_Id;
4197 -- Name of the parameter which will hold the exception sent by the
4198 -- remote subprogram.
4199
4200 Current_Parameter : Node_Id;
4201 -- Current parameter being handled
4202
4203 Ordered_Parameters_List : constant List_Id :=
4204 Build_Ordered_Parameters_List (Spec);
4205
4206 Asynchronous_Statements : List_Id := No_List;
4207 Non_Asynchronous_Statements : List_Id := No_List;
4208 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4209
4210 Extra_Formal_Statements : constant List_Id := New_List;
4211 -- List of statements for extra formal parameters. It will appear
4212 -- after the regular statements for writing out parameters.
4213
4214 pragma Unreferenced (RACW_Type);
4215 -- Used only for the PolyORB case
4216
4217 begin
4218 -- The general form of a calling stub for a given subprogram is:
4219
4220 -- procedure X (...) is P : constant Partition_ID :=
4221 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4222 -- System.RPC.Params_Stream_Type (0); begin
4223 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4224 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4225 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4226 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4227 -- Raise_It;
4228 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4229
4230 -- There are some variations: Do_APC is called for an asynchronous
4231 -- procedure and the part after the call is completely ommitted as
4232 -- well as the declaration of Result. For a function call, 'Input is
4233 -- always used to read the result even if it is constrained.
4234
4235 Stream_Parameter := Make_Temporary (Loc, 'S');
4236
4237 Append_To (Decls,
4238 Make_Object_Declaration (Loc,
4239 Defining_Identifier => Stream_Parameter,
4240 Aliased_Present => True,
4241 Object_Definition =>
4242 Make_Subtype_Indication (Loc,
4243 Subtype_Mark =>
4244 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4245 Constraint =>
4246 Make_Index_Or_Discriminant_Constraint (Loc,
4247 Constraints =>
4248 New_List (Make_Integer_Literal (Loc, 0))))));
4249
4250 if not Is_Known_Asynchronous then
4251 Result_Parameter := Make_Temporary (Loc, 'R');
4252
4253 Append_To (Decls,
4254 Make_Object_Declaration (Loc,
4255 Defining_Identifier => Result_Parameter,
4256 Aliased_Present => True,
4257 Object_Definition =>
4258 Make_Subtype_Indication (Loc,
4259 Subtype_Mark =>
4260 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
4261 Constraint =>
4262 Make_Index_Or_Discriminant_Constraint (Loc,
4263 Constraints =>
4264 New_List (Make_Integer_Literal (Loc, 0))))));
4265
4266 Exception_Return_Parameter := Make_Temporary (Loc, 'E');
4267
4268 Append_To (Decls,
4269 Make_Object_Declaration (Loc,
4270 Defining_Identifier => Exception_Return_Parameter,
4271 Object_Definition =>
4272 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
4273
4274 else
4275 Result_Parameter := Empty;
4276 Exception_Return_Parameter := Empty;
4277 end if;
4278
4279 -- Put first the RPC receiver corresponding to the remote package
4280
4281 Append_To (Statements,
4282 Make_Attribute_Reference (Loc,
4283 Prefix =>
4284 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
4285 Attribute_Name => Name_Write,
4286 Expressions => New_List (
4287 Make_Attribute_Reference (Loc,
4288 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4289 Attribute_Name => Name_Access),
4290 Target_RPC_Receiver)));
4291
4292 -- Then put the Subprogram_Id of the subprogram we want to call in
4293 -- the stream.
4294
4295 Append_To (Statements,
4296 Make_Attribute_Reference (Loc,
4297 Prefix => New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4298 Attribute_Name => Name_Write,
4299 Expressions => New_List (
4300 Make_Attribute_Reference (Loc,
4301 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
4302 Attribute_Name => Name_Access),
4303 Subprogram_Id)));
4304
4305 Current_Parameter := First (Ordered_Parameters_List);
4306 while Present (Current_Parameter) loop
4307 declare
4308 Typ : constant Node_Id :=
4309 Parameter_Type (Current_Parameter);
4310 Etyp : Entity_Id;
4311 Constrained : Boolean;
4312 Value : Node_Id;
4313 Extra_Parameter : Entity_Id;
4314
4315 begin
4316 if Is_RACW_Controlling_Formal
4317 (Current_Parameter, Stub_Type)
4318 then
4319 -- In the case of a controlling formal argument, we marshall
4320 -- its addr field rather than the local stub.
4321
4322 Append_To (Statements,
4323 Pack_Node_Into_Stream (Loc,
4324 Stream => Stream_Parameter,
4325 Object =>
4326 Make_Selected_Component (Loc,
4327 Prefix =>
4328 Defining_Identifier (Current_Parameter),
4329 Selector_Name => Name_Addr),
4330 Etyp => RTE (RE_Unsigned_64)));
4331
4332 else
4333 Value :=
4334 New_Occurrence_Of
4335 (Defining_Identifier (Current_Parameter), Loc);
4336
4337 -- Access type parameters are transmitted as in out
4338 -- parameters. However, a dereference is needed so that
4339 -- we marshall the designated object.
4340
4341 if Nkind (Typ) = N_Access_Definition then
4342 Value := Make_Explicit_Dereference (Loc, Value);
4343 Etyp := Etype (Subtype_Mark (Typ));
4344 else
4345 Etyp := Etype (Typ);
4346 end if;
4347
4348 Constrained := not Transmit_As_Unconstrained (Etyp);
4349
4350 -- Any parameter but unconstrained out parameters are
4351 -- transmitted to the peer.
4352
4353 if In_Present (Current_Parameter)
4354 or else not Out_Present (Current_Parameter)
4355 or else not Constrained
4356 then
4357 Append_To (Statements,
4358 Make_Attribute_Reference (Loc,
4359 Prefix => New_Occurrence_Of (Etyp, Loc),
4360 Attribute_Name =>
4361 Output_From_Constrained (Constrained),
4362 Expressions => New_List (
4363 Make_Attribute_Reference (Loc,
4364 Prefix =>
4365 New_Occurrence_Of (Stream_Parameter, Loc),
4366 Attribute_Name => Name_Access),
4367 Value)));
4368 end if;
4369 end if;
4370
4371 -- If the current parameter has a dynamic constrained status,
4372 -- then this status is transmitted as well.
4373 -- This should be done for accessibility as well ???
4374
4375 if Nkind (Typ) /= N_Access_Definition
4376 and then Need_Extra_Constrained (Current_Parameter)
4377 then
4378 -- In this block, we do not use the extra formal that has
4379 -- been created because it does not exist at the time of
4380 -- expansion when building calling stubs for remote access
4381 -- to subprogram types. We create an extra variable of this
4382 -- type and push it in the stream after the regular
4383 -- parameters.
4384
4385 Extra_Parameter := Make_Temporary (Loc, 'P');
4386
4387 Append_To (Decls,
4388 Make_Object_Declaration (Loc,
4389 Defining_Identifier => Extra_Parameter,
4390 Constant_Present => True,
4391 Object_Definition =>
4392 New_Occurrence_Of (Standard_Boolean, Loc),
4393 Expression =>
4394 Make_Attribute_Reference (Loc,
4395 Prefix =>
4396 New_Occurrence_Of (
4397 Defining_Identifier (Current_Parameter), Loc),
4398 Attribute_Name => Name_Constrained)));
4399
4400 Append_To (Extra_Formal_Statements,
4401 Make_Attribute_Reference (Loc,
4402 Prefix =>
4403 New_Occurrence_Of (Standard_Boolean, Loc),
4404 Attribute_Name => Name_Write,
4405 Expressions => New_List (
4406 Make_Attribute_Reference (Loc,
4407 Prefix =>
4408 New_Occurrence_Of
4409 (Stream_Parameter, Loc), Attribute_Name =>
4410 Name_Access),
4411 New_Occurrence_Of (Extra_Parameter, Loc))));
4412 end if;
4413
4414 Next (Current_Parameter);
4415 end;
4416 end loop;
4417
4418 -- Append the formal statements list to the statements
4419
4420 Append_List_To (Statements, Extra_Formal_Statements);
4421
4422 if not Is_Known_Non_Asynchronous then
4423
4424 -- Build the call to System.RPC.Do_APC
4425
4426 Asynchronous_Statements := New_List (
4427 Make_Procedure_Call_Statement (Loc,
4428 Name =>
4429 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
4430 Parameter_Associations => New_List (
4431 New_Occurrence_Of (Target_Partition, Loc),
4432 Make_Attribute_Reference (Loc,
4433 Prefix =>
4434 New_Occurrence_Of (Stream_Parameter, Loc),
4435 Attribute_Name => Name_Access))));
4436 else
4437 Asynchronous_Statements := No_List;
4438 end if;
4439
4440 if not Is_Known_Asynchronous then
4441
4442 -- Build the call to System.RPC.Do_RPC
4443
4444 Non_Asynchronous_Statements := New_List (
4445 Make_Procedure_Call_Statement (Loc,
4446 Name =>
4447 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
4448 Parameter_Associations => New_List (
4449 New_Occurrence_Of (Target_Partition, Loc),
4450
4451 Make_Attribute_Reference (Loc,
4452 Prefix =>
4453 New_Occurrence_Of (Stream_Parameter, Loc),
4454 Attribute_Name => Name_Access),
4455
4456 Make_Attribute_Reference (Loc,
4457 Prefix =>
4458 New_Occurrence_Of (Result_Parameter, Loc),
4459 Attribute_Name => Name_Access))));
4460
4461 -- Read the exception occurrence from the result stream and
4462 -- reraise it. It does no harm if this is a Null_Occurrence since
4463 -- this does nothing.
4464
4465 Append_To (Non_Asynchronous_Statements,
4466 Make_Attribute_Reference (Loc,
4467 Prefix =>
4468 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4469
4470 Attribute_Name => Name_Read,
4471
4472 Expressions => New_List (
4473 Make_Attribute_Reference (Loc,
4474 Prefix =>
4475 New_Occurrence_Of (Result_Parameter, Loc),
4476 Attribute_Name => Name_Access),
4477 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4478
4479 Append_To (Non_Asynchronous_Statements,
4480 Make_Procedure_Call_Statement (Loc,
4481 Name =>
4482 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
4483 Parameter_Associations => New_List (
4484 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
4485
4486 if Is_Function then
4487
4488 -- If this is a function call, then read the value and return
4489 -- it. The return value is written/read using 'Output/'Input.
4490
4491 Append_To (Non_Asynchronous_Statements,
4492 Make_Tag_Check (Loc,
4493 Make_Simple_Return_Statement (Loc,
4494 Expression =>
4495 Make_Attribute_Reference (Loc,
4496 Prefix =>
4497 New_Occurrence_Of (
4498 Etype (Result_Definition (Spec)), Loc),
4499
4500 Attribute_Name => Name_Input,
4501
4502 Expressions => New_List (
4503 Make_Attribute_Reference (Loc,
4504 Prefix =>
4505 New_Occurrence_Of (Result_Parameter, Loc),
4506 Attribute_Name => Name_Access))))));
4507
4508 else
4509 -- Loop around parameters and assign out (or in out)
4510 -- parameters. In the case of RACW, controlling arguments
4511 -- cannot possibly have changed since they are remote, so
4512 -- we do not read them from the stream.
4513
4514 Current_Parameter := First (Ordered_Parameters_List);
4515 while Present (Current_Parameter) loop
4516 declare
4517 Typ : constant Node_Id :=
4518 Parameter_Type (Current_Parameter);
4519 Etyp : Entity_Id;
4520 Value : Node_Id;
4521
4522 begin
4523 Value :=
4524 New_Occurrence_Of
4525 (Defining_Identifier (Current_Parameter), Loc);
4526
4527 if Nkind (Typ) = N_Access_Definition then
4528 Value := Make_Explicit_Dereference (Loc, Value);
4529 Etyp := Etype (Subtype_Mark (Typ));
4530 else
4531 Etyp := Etype (Typ);
4532 end if;
4533
4534 if (Out_Present (Current_Parameter)
4535 or else Nkind (Typ) = N_Access_Definition)
4536 and then Etyp /= Stub_Type
4537 then
4538 Append_To (Non_Asynchronous_Statements,
4539 Make_Attribute_Reference (Loc,
4540 Prefix =>
4541 New_Occurrence_Of (Etyp, Loc),
4542
4543 Attribute_Name => Name_Read,
4544
4545 Expressions => New_List (
4546 Make_Attribute_Reference (Loc,
4547 Prefix =>
4548 New_Occurrence_Of (Result_Parameter, Loc),
4549 Attribute_Name => Name_Access),
4550 Value)));
4551 end if;
4552 end;
4553
4554 Next (Current_Parameter);
4555 end loop;
4556 end if;
4557 end if;
4558
4559 if Is_Known_Asynchronous then
4560 Append_List_To (Statements, Asynchronous_Statements);
4561
4562 elsif Is_Known_Non_Asynchronous then
4563 Append_List_To (Statements, Non_Asynchronous_Statements);
4564
4565 else
4566 pragma Assert (Present (Asynchronous));
4567 Prepend_To (Asynchronous_Statements,
4568 Make_Attribute_Reference (Loc,
4569 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4570 Attribute_Name => Name_Write,
4571 Expressions => New_List (
4572 Make_Attribute_Reference (Loc,
4573 Prefix =>
4574 New_Occurrence_Of (Stream_Parameter, Loc),
4575 Attribute_Name => Name_Access),
4576 New_Occurrence_Of (Standard_True, Loc))));
4577
4578 Prepend_To (Non_Asynchronous_Statements,
4579 Make_Attribute_Reference (Loc,
4580 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
4581 Attribute_Name => Name_Write,
4582 Expressions => New_List (
4583 Make_Attribute_Reference (Loc,
4584 Prefix =>
4585 New_Occurrence_Of (Stream_Parameter, Loc),
4586 Attribute_Name => Name_Access),
4587 New_Occurrence_Of (Standard_False, Loc))));
4588
4589 Append_To (Statements,
4590 Make_Implicit_If_Statement (Nod,
4591 Condition => Asynchronous,
4592 Then_Statements => Asynchronous_Statements,
4593 Else_Statements => Non_Asynchronous_Statements));
4594 end if;
4595 end Build_General_Calling_Stubs;
4596
4597 -----------------------------
4598 -- Build_RPC_Receiver_Body --
4599 -----------------------------
4600
4601 procedure Build_RPC_Receiver_Body
4602 (RPC_Receiver : Entity_Id;
4603 Request : out Entity_Id;
4604 Subp_Id : out Entity_Id;
4605 Subp_Index : out Entity_Id;
4606 Stmts : out List_Id;
4607 Decl : out Node_Id)
4608 is
4609 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
4610
4611 RPC_Receiver_Spec : Node_Id;
4612 RPC_Receiver_Decls : List_Id;
4613
4614 begin
4615 Request := Make_Defining_Identifier (Loc, Name_R);
4616
4617 RPC_Receiver_Spec :=
4618 Build_RPC_Receiver_Specification
4619 (RPC_Receiver => RPC_Receiver,
4620 Request_Parameter => Request);
4621
4622 Subp_Id := Make_Temporary (Loc, 'P');
4623 Subp_Index := Subp_Id;
4624
4625 -- Subp_Id may not be a constant, because in the case of the RPC
4626 -- receiver for an RCI package, when a call is received from a RAS
4627 -- dereference, it will be assigned during subsequent processing.
4628
4629 RPC_Receiver_Decls := New_List (
4630 Make_Object_Declaration (Loc,
4631 Defining_Identifier => Subp_Id,
4632 Object_Definition =>
4633 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4634 Expression =>
4635 Make_Attribute_Reference (Loc,
4636 Prefix =>
4637 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
4638 Attribute_Name => Name_Input,
4639 Expressions => New_List (
4640 Make_Selected_Component (Loc,
4641 Prefix => Request,
4642 Selector_Name => Name_Params)))));
4643
4644 Stmts := New_List;
4645
4646 Decl :=
4647 Make_Subprogram_Body (Loc,
4648 Specification => RPC_Receiver_Spec,
4649 Declarations => RPC_Receiver_Decls,
4650 Handled_Statement_Sequence =>
4651 Make_Handled_Sequence_Of_Statements (Loc,
4652 Statements => Stmts));
4653 end Build_RPC_Receiver_Body;
4654
4655 -----------------------
4656 -- Build_Stub_Target --
4657 -----------------------
4658
4659 function Build_Stub_Target
4660 (Loc : Source_Ptr;
4661 Decls : List_Id;
4662 RCI_Locator : Entity_Id;
4663 Controlling_Parameter : Entity_Id) return RPC_Target
4664 is
4665 Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
4666
4667 begin
4668 Target_Info.Partition := Make_Temporary (Loc, 'P');
4669
4670 if Present (Controlling_Parameter) then
4671 Append_To (Decls,
4672 Make_Object_Declaration (Loc,
4673 Defining_Identifier => Target_Info.Partition,
4674 Constant_Present => True,
4675 Object_Definition =>
4676 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4677
4678 Expression =>
4679 Make_Selected_Component (Loc,
4680 Prefix => Controlling_Parameter,
4681 Selector_Name => Name_Origin)));
4682
4683 Target_Info.RPC_Receiver :=
4684 Make_Selected_Component (Loc,
4685 Prefix => Controlling_Parameter,
4686 Selector_Name => Name_Receiver);
4687
4688 else
4689 Append_To (Decls,
4690 Make_Object_Declaration (Loc,
4691 Defining_Identifier => Target_Info.Partition,
4692 Constant_Present => True,
4693 Object_Definition =>
4694 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
4695
4696 Expression =>
4697 Make_Function_Call (Loc,
4698 Name => Make_Selected_Component (Loc,
4699 Prefix =>
4700 Make_Identifier (Loc, Chars (RCI_Locator)),
4701 Selector_Name =>
4702 Make_Identifier (Loc,
4703 Name_Get_Active_Partition_ID)))));
4704
4705 Target_Info.RPC_Receiver :=
4706 Make_Selected_Component (Loc,
4707 Prefix =>
4708 Make_Identifier (Loc, Chars (RCI_Locator)),
4709 Selector_Name =>
4710 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
4711 end if;
4712 return Target_Info;
4713 end Build_Stub_Target;
4714
4715 --------------------------------------
4716 -- Build_Subprogram_Receiving_Stubs --
4717 --------------------------------------
4718
4719 function Build_Subprogram_Receiving_Stubs
4720 (Vis_Decl : Node_Id;
4721 Asynchronous : Boolean;
4722 Dynamically_Asynchronous : Boolean := False;
4723 Stub_Type : Entity_Id := Empty;
4724 RACW_Type : Entity_Id := Empty;
4725 Parent_Primitive : Entity_Id := Empty) return Node_Id
4726 is
4727 Loc : constant Source_Ptr := Sloc (Vis_Decl);
4728
4729 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
4730 -- Formal parameter for receiving stubs: a descriptor for an incoming
4731 -- request.
4732
4733 Decls : constant List_Id := New_List;
4734 -- All the parameters will get declared before calling the real
4735 -- subprograms. Also the out parameters will be declared.
4736
4737 Statements : constant List_Id := New_List;
4738
4739 Extra_Formal_Statements : constant List_Id := New_List;
4740 -- Statements concerning extra formal parameters
4741
4742 After_Statements : constant List_Id := New_List;
4743 -- Statements to be executed after the subprogram call
4744
4745 Inner_Decls : List_Id := No_List;
4746 -- In case of a function, the inner declarations are needed since
4747 -- the result may be unconstrained.
4748
4749 Excep_Handlers : List_Id := No_List;
4750 Excep_Choice : Entity_Id;
4751 Excep_Code : List_Id;
4752
4753 Parameter_List : constant List_Id := New_List;
4754 -- List of parameters to be passed to the subprogram
4755
4756 Current_Parameter : Node_Id;
4757
4758 Ordered_Parameters_List : constant List_Id :=
4759 Build_Ordered_Parameters_List
4760 (Specification (Vis_Decl));
4761
4762 Subp_Spec : Node_Id;
4763 -- Subprogram specification
4764
4765 Called_Subprogram : Node_Id;
4766 -- The subprogram to call
4767
4768 Null_Raise_Statement : Node_Id;
4769
4770 Dynamic_Async : Entity_Id;
4771
4772 begin
4773 if Present (RACW_Type) then
4774 Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
4775 else
4776 Called_Subprogram :=
4777 New_Occurrence_Of
4778 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
4779 end if;
4780
4781 if Dynamically_Asynchronous then
4782 Dynamic_Async := Make_Temporary (Loc, 'S');
4783 else
4784 Dynamic_Async := Empty;
4785 end if;
4786
4787 if not Asynchronous or Dynamically_Asynchronous then
4788
4789 -- The first statement after the subprogram call is a statement to
4790 -- write a Null_Occurrence into the result stream.
4791
4792 Null_Raise_Statement :=
4793 Make_Attribute_Reference (Loc,
4794 Prefix =>
4795 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
4796 Attribute_Name => Name_Write,
4797 Expressions => New_List (
4798 Make_Selected_Component (Loc,
4799 Prefix => Request_Parameter,
4800 Selector_Name => Name_Result),
4801 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
4802
4803 if Dynamically_Asynchronous then
4804 Null_Raise_Statement :=
4805 Make_Implicit_If_Statement (Vis_Decl,
4806 Condition =>
4807 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
4808 Then_Statements => New_List (Null_Raise_Statement));
4809 end if;
4810
4811 Append_To (After_Statements, Null_Raise_Statement);
4812 end if;
4813
4814 -- Loop through every parameter and get its value from the stream. If
4815 -- the parameter is unconstrained, then the parameter is read using
4816 -- 'Input at the point of declaration.
4817
4818 Current_Parameter := First (Ordered_Parameters_List);
4819 while Present (Current_Parameter) loop
4820 declare
4821 Etyp : Entity_Id;
4822 Constrained : Boolean;
4823
4824 Need_Extra_Constrained : Boolean;
4825 -- True when an Extra_Constrained actual is required
4826
4827 Object : constant Entity_Id := Make_Temporary (Loc, 'P');
4828
4829 Expr : Node_Id := Empty;
4830
4831 Is_Controlling_Formal : constant Boolean :=
4832 Is_RACW_Controlling_Formal
4833 (Current_Parameter, Stub_Type);
4834
4835 begin
4836 if Is_Controlling_Formal then
4837
4838 -- We have a controlling formal parameter. Read its address
4839 -- rather than a real object. The address is in Unsigned_64
4840 -- form.
4841
4842 Etyp := RTE (RE_Unsigned_64);
4843 else
4844 Etyp := Etype (Parameter_Type (Current_Parameter));
4845 end if;
4846
4847 Constrained := not Transmit_As_Unconstrained (Etyp);
4848
4849 if In_Present (Current_Parameter)
4850 or else not Out_Present (Current_Parameter)
4851 or else not Constrained
4852 or else Is_Controlling_Formal
4853 then
4854 -- If an input parameter is constrained, then the read of
4855 -- the parameter is deferred until the beginning of the
4856 -- subprogram body. If it is unconstrained, then an
4857 -- expression is built for the object declaration and the
4858 -- variable is set using 'Input instead of 'Read. Note that
4859 -- this deferral does not change the order in which the
4860 -- actuals are read because Build_Ordered_Parameter_List
4861 -- puts them unconstrained first.
4862
4863 if Constrained then
4864 Append_To (Statements,
4865 Make_Attribute_Reference (Loc,
4866 Prefix => New_Occurrence_Of (Etyp, Loc),
4867 Attribute_Name => Name_Read,
4868 Expressions => New_List (
4869 Make_Selected_Component (Loc,
4870 Prefix => Request_Parameter,
4871 Selector_Name => Name_Params),
4872 New_Occurrence_Of (Object, Loc))));
4873
4874 else
4875
4876 -- Build and append Input_With_Tag_Check function
4877
4878 Append_To (Decls,
4879 Input_With_Tag_Check (Loc,
4880 Var_Type => Etyp,
4881 Stream =>
4882 Make_Selected_Component (Loc,
4883 Prefix => Request_Parameter,
4884 Selector_Name => Name_Params)));
4885
4886 -- Prepare function call expression
4887
4888 Expr :=
4889 Make_Function_Call (Loc,
4890 Name =>
4891 New_Occurrence_Of
4892 (Defining_Unit_Name
4893 (Specification (Last (Decls))), Loc));
4894 end if;
4895 end if;
4896
4897 Need_Extra_Constrained :=
4898 Nkind (Parameter_Type (Current_Parameter)) /=
4899 N_Access_Definition
4900 and then
4901 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
4902 and then
4903 Present (Extra_Constrained
4904 (Defining_Identifier (Current_Parameter)));
4905
4906 -- We may not associate an extra constrained actual to a
4907 -- constant object, so if one is needed, declare the actual
4908 -- as a variable even if it won't be modified.
4909
4910 Build_Actual_Object_Declaration
4911 (Object => Object,
4912 Etyp => Etyp,
4913 Variable => Need_Extra_Constrained
4914 or else Out_Present (Current_Parameter),
4915 Expr => Expr,
4916 Decls => Decls);
4917
4918 -- An out parameter may be written back using a 'Write
4919 -- attribute instead of a 'Output because it has been
4920 -- constrained by the parameter given to the caller. Note that
4921 -- out controlling arguments in the case of a RACW are not put
4922 -- back in the stream because the pointer on them has not
4923 -- changed.
4924
4925 if Out_Present (Current_Parameter)
4926 and then
4927 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
4928 then
4929 Append_To (After_Statements,
4930 Make_Attribute_Reference (Loc,
4931 Prefix => New_Occurrence_Of (Etyp, Loc),
4932 Attribute_Name => Name_Write,
4933 Expressions => New_List (
4934 Make_Selected_Component (Loc,
4935 Prefix => Request_Parameter,
4936 Selector_Name => Name_Result),
4937 New_Occurrence_Of (Object, Loc))));
4938 end if;
4939
4940 -- For RACW controlling formals, the Etyp of Object is always
4941 -- an RACW, even if the parameter is not of an anonymous access
4942 -- type. In such case, we need to dereference it at call time.
4943
4944 if Is_Controlling_Formal then
4945 if Nkind (Parameter_Type (Current_Parameter)) /=
4946 N_Access_Definition
4947 then
4948 Append_To (Parameter_List,
4949 Make_Parameter_Association (Loc,
4950 Selector_Name =>
4951 New_Occurrence_Of (
4952 Defining_Identifier (Current_Parameter), Loc),
4953 Explicit_Actual_Parameter =>
4954 Make_Explicit_Dereference (Loc,
4955 Unchecked_Convert_To (RACW_Type,
4956 OK_Convert_To (RTE (RE_Address),
4957 New_Occurrence_Of (Object, Loc))))));
4958
4959 else
4960 Append_To (Parameter_List,
4961 Make_Parameter_Association (Loc,
4962 Selector_Name =>
4963 New_Occurrence_Of (
4964 Defining_Identifier (Current_Parameter), Loc),
4965 Explicit_Actual_Parameter =>
4966 Unchecked_Convert_To (RACW_Type,
4967 OK_Convert_To (RTE (RE_Address),
4968 New_Occurrence_Of (Object, Loc)))));
4969 end if;
4970
4971 else
4972 Append_To (Parameter_List,
4973 Make_Parameter_Association (Loc,
4974 Selector_Name =>
4975 New_Occurrence_Of (
4976 Defining_Identifier (Current_Parameter), Loc),
4977 Explicit_Actual_Parameter =>
4978 New_Occurrence_Of (Object, Loc)));
4979 end if;
4980
4981 -- If the current parameter needs an extra formal, then read it
4982 -- from the stream and set the corresponding semantic field in
4983 -- the variable. If the kind of the parameter identifier is
4984 -- E_Void, then this is a compiler generated parameter that
4985 -- doesn't need an extra constrained status.
4986
4987 -- The case of Extra_Accessibility should also be handled ???
4988
4989 if Need_Extra_Constrained then
4990 declare
4991 Extra_Parameter : constant Entity_Id :=
4992 Extra_Constrained
4993 (Defining_Identifier
4994 (Current_Parameter));
4995
4996 Formal_Entity : constant Entity_Id :=
4997 Make_Defining_Identifier
4998 (Loc, Chars (Extra_Parameter));
4999
5000 Formal_Type : constant Entity_Id :=
5001 Etype (Extra_Parameter);
5002
5003 begin
5004 Append_To (Decls,
5005 Make_Object_Declaration (Loc,
5006 Defining_Identifier => Formal_Entity,
5007 Object_Definition =>
5008 New_Occurrence_Of (Formal_Type, Loc)));
5009
5010 Append_To (Extra_Formal_Statements,
5011 Make_Attribute_Reference (Loc,
5012 Prefix => New_Occurrence_Of (
5013 Formal_Type, Loc),
5014 Attribute_Name => Name_Read,
5015 Expressions => New_List (
5016 Make_Selected_Component (Loc,
5017 Prefix => Request_Parameter,
5018 Selector_Name => Name_Params),
5019 New_Occurrence_Of (Formal_Entity, Loc))));
5020
5021 -- Note: the call to Set_Extra_Constrained below relies
5022 -- on the fact that Object's Ekind has been set by
5023 -- Build_Actual_Object_Declaration.
5024
5025 Set_Extra_Constrained (Object, Formal_Entity);
5026 end;
5027 end if;
5028 end;
5029
5030 Next (Current_Parameter);
5031 end loop;
5032
5033 -- Append the formal statements list at the end of regular statements
5034
5035 Append_List_To (Statements, Extra_Formal_Statements);
5036
5037 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
5038
5039 -- The remote subprogram is a function. We build an inner block to
5040 -- be able to hold a potentially unconstrained result in a
5041 -- variable.
5042
5043 declare
5044 Etyp : constant Entity_Id :=
5045 Etype (Result_Definition (Specification (Vis_Decl)));
5046 Result : constant Node_Id := Make_Temporary (Loc, 'R');
5047
5048 begin
5049 Inner_Decls := New_List (
5050 Make_Object_Declaration (Loc,
5051 Defining_Identifier => Result,
5052 Constant_Present => True,
5053 Object_Definition => New_Occurrence_Of (Etyp, Loc),
5054 Expression =>
5055 Make_Function_Call (Loc,
5056 Name => Called_Subprogram,
5057 Parameter_Associations => Parameter_List)));
5058
5059 if Is_Class_Wide_Type (Etyp) then
5060
5061 -- For a remote call to a function with a class-wide type,
5062 -- check that the returned value satisfies the requirements
5063 -- of E.4(18).
5064
5065 Append_To (Inner_Decls,
5066 Make_Transportable_Check (Loc,
5067 New_Occurrence_Of (Result, Loc)));
5068
5069 end if;
5070
5071 Append_To (After_Statements,
5072 Make_Attribute_Reference (Loc,
5073 Prefix => New_Occurrence_Of (Etyp, Loc),
5074 Attribute_Name => Name_Output,
5075 Expressions => New_List (
5076 Make_Selected_Component (Loc,
5077 Prefix => Request_Parameter,
5078 Selector_Name => Name_Result),
5079 New_Occurrence_Of (Result, Loc))));
5080 end;
5081
5082 Append_To (Statements,
5083 Make_Block_Statement (Loc,
5084 Declarations => Inner_Decls,
5085 Handled_Statement_Sequence =>
5086 Make_Handled_Sequence_Of_Statements (Loc,
5087 Statements => After_Statements)));
5088
5089 else
5090 -- The remote subprogram is a procedure. We do not need any inner
5091 -- block in this case.
5092
5093 if Dynamically_Asynchronous then
5094 Append_To (Decls,
5095 Make_Object_Declaration (Loc,
5096 Defining_Identifier => Dynamic_Async,
5097 Object_Definition =>
5098 New_Occurrence_Of (Standard_Boolean, Loc)));
5099
5100 Append_To (Statements,
5101 Make_Attribute_Reference (Loc,
5102 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
5103 Attribute_Name => Name_Read,
5104 Expressions => New_List (
5105 Make_Selected_Component (Loc,
5106 Prefix => Request_Parameter,
5107 Selector_Name => Name_Params),
5108 New_Occurrence_Of (Dynamic_Async, Loc))));
5109 end if;
5110
5111 Append_To (Statements,
5112 Make_Procedure_Call_Statement (Loc,
5113 Name => Called_Subprogram,
5114 Parameter_Associations => Parameter_List));
5115
5116 Append_List_To (Statements, After_Statements);
5117 end if;
5118
5119 if Asynchronous and then not Dynamically_Asynchronous then
5120
5121 -- For an asynchronous procedure, add a null exception handler
5122
5123 Excep_Handlers := New_List (
5124 Make_Implicit_Exception_Handler (Loc,
5125 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5126 Statements => New_List (Make_Null_Statement (Loc))));
5127
5128 else
5129 -- In the other cases, if an exception is raised, then the
5130 -- exception occurrence is copied into the output stream and
5131 -- no other output parameter is written.
5132
5133 Excep_Choice := Make_Temporary (Loc, 'E');
5134
5135 Excep_Code := New_List (
5136 Make_Attribute_Reference (Loc,
5137 Prefix =>
5138 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
5139 Attribute_Name => Name_Write,
5140 Expressions => New_List (
5141 Make_Selected_Component (Loc,
5142 Prefix => Request_Parameter,
5143 Selector_Name => Name_Result),
5144 New_Occurrence_Of (Excep_Choice, Loc))));
5145
5146 if Dynamically_Asynchronous then
5147 Excep_Code := New_List (
5148 Make_Implicit_If_Statement (Vis_Decl,
5149 Condition => Make_Op_Not (Loc,
5150 New_Occurrence_Of (Dynamic_Async, Loc)),
5151 Then_Statements => Excep_Code));
5152 end if;
5153
5154 Excep_Handlers := New_List (
5155 Make_Implicit_Exception_Handler (Loc,
5156 Choice_Parameter => Excep_Choice,
5157 Exception_Choices => New_List (Make_Others_Choice (Loc)),
5158 Statements => Excep_Code));
5159
5160 end if;
5161
5162 Subp_Spec :=
5163 Make_Procedure_Specification (Loc,
5164 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
5165
5166 Parameter_Specifications => New_List (
5167 Make_Parameter_Specification (Loc,
5168 Defining_Identifier => Request_Parameter,
5169 Parameter_Type =>
5170 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
5171
5172 return
5173 Make_Subprogram_Body (Loc,
5174 Specification => Subp_Spec,
5175 Declarations => Decls,
5176 Handled_Statement_Sequence =>
5177 Make_Handled_Sequence_Of_Statements (Loc,
5178 Statements => Statements,
5179 Exception_Handlers => Excep_Handlers));
5180 end Build_Subprogram_Receiving_Stubs;
5181
5182 ------------
5183 -- Result --
5184 ------------
5185
5186 function Result return Node_Id is
5187 begin
5188 return Make_Identifier (Loc, Name_V);
5189 end Result;
5190
5191 -----------------------
5192 -- RPC_Receiver_Decl --
5193 -----------------------
5194
5195 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is
5196 Loc : constant Source_Ptr := Sloc (RACW_Type);
5197 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5198
5199 begin
5200 -- No RPC receiver for remote access-to-subprogram
5201
5202 if Is_RAS then
5203 return Empty;
5204 end if;
5205
5206 return
5207 Make_Subprogram_Declaration (Loc,
5208 Build_RPC_Receiver_Specification
5209 (RPC_Receiver => Make_Temporary (Loc, 'R'),
5210 Request_Parameter => Make_Defining_Identifier (Loc, Name_R)));
5211 end RPC_Receiver_Decl;
5212
5213 ----------------------
5214 -- Stream_Parameter --
5215 ----------------------
5216
5217 function Stream_Parameter return Node_Id is
5218 begin
5219 return Make_Identifier (Loc, Name_S);
5220 end Stream_Parameter;
5221
5222 end GARLIC_Support;
5223
5224 -------------------------------
5225 -- Get_And_Reset_RACW_Bodies --
5226 -------------------------------
5227
5228 function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
5229 Desig : constant Entity_Id :=
5230 Etype (Designated_Type (RACW_Type));
5231
5232 Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
5233
5234 Body_Decls : List_Id;
5235 -- Returned list of declarations
5236
5237 begin
5238 if Stub_Elements = Empty_Stub_Structure then
5239
5240 -- Stub elements may be missing as a consequence of a previously
5241 -- detected error.
5242
5243 return No_List;
5244 end if;
5245
5246 Body_Decls := Stub_Elements.Body_Decls;
5247 Stub_Elements.Body_Decls := No_List;
5248 Stubs_Table.Set (Desig, Stub_Elements);
5249 return Body_Decls;
5250 end Get_And_Reset_RACW_Bodies;
5251
5252 -----------------------
5253 -- Get_Stub_Elements --
5254 -----------------------
5255
5256 function Get_Stub_Elements (RACW_Type : Entity_Id) return Stub_Structure is
5257 Desig : constant Entity_Id :=
5258 Etype (Designated_Type (RACW_Type));
5259 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
5260 begin
5261 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
5262 return Stub_Elements;
5263 end Get_Stub_Elements;
5264
5265 -----------------------
5266 -- Get_Subprogram_Id --
5267 -----------------------
5268
5269 function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
5270 Result : constant String_Id := Get_Subprogram_Ids (Def).Str_Identifier;
5271 begin
5272 pragma Assert (Result /= No_String);
5273 return Result;
5274 end Get_Subprogram_Id;
5275
5276 -----------------------
5277 -- Get_Subprogram_Id --
5278 -----------------------
5279
5280 function Get_Subprogram_Id (Def : Entity_Id) return Int is
5281 begin
5282 return Get_Subprogram_Ids (Def).Int_Identifier;
5283 end Get_Subprogram_Id;
5284
5285 ------------------------
5286 -- Get_Subprogram_Ids --
5287 ------------------------
5288
5289 function Get_Subprogram_Ids
5290 (Def : Entity_Id) return Subprogram_Identifiers
5291 is
5292 begin
5293 return Subprogram_Identifier_Table.Get (Def);
5294 end Get_Subprogram_Ids;
5295
5296 ----------
5297 -- Hash --
5298 ----------
5299
5300 function Hash (F : Entity_Id) return Hash_Index is
5301 begin
5302 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5303 end Hash;
5304
5305 function Hash (F : Name_Id) return Hash_Index is
5306 begin
5307 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
5308 end Hash;
5309
5310 --------------------------
5311 -- Input_With_Tag_Check --
5312 --------------------------
5313
5314 function Input_With_Tag_Check
5315 (Loc : Source_Ptr;
5316 Var_Type : Entity_Id;
5317 Stream : Node_Id) return Node_Id
5318 is
5319 begin
5320 return
5321 Make_Subprogram_Body (Loc,
5322 Specification =>
5323 Make_Function_Specification (Loc,
5324 Defining_Unit_Name => Make_Temporary (Loc, 'S'),
5325 Result_Definition => New_Occurrence_Of (Var_Type, Loc)),
5326 Declarations => No_List,
5327 Handled_Statement_Sequence =>
5328 Make_Handled_Sequence_Of_Statements (Loc, New_List (
5329 Make_Tag_Check (Loc,
5330 Make_Simple_Return_Statement (Loc,
5331 Make_Attribute_Reference (Loc,
5332 Prefix => New_Occurrence_Of (Var_Type, Loc),
5333 Attribute_Name => Name_Input,
5334 Expressions =>
5335 New_List (Stream)))))));
5336 end Input_With_Tag_Check;
5337
5338 --------------------------------
5339 -- Is_RACW_Controlling_Formal --
5340 --------------------------------
5341
5342 function Is_RACW_Controlling_Formal
5343 (Parameter : Node_Id;
5344 Stub_Type : Entity_Id) return Boolean
5345 is
5346 Typ : Entity_Id;
5347
5348 begin
5349 -- If the kind of the parameter is E_Void, then it is not a controlling
5350 -- formal (this can happen in the context of RAS).
5351
5352 if Ekind (Defining_Identifier (Parameter)) = E_Void then
5353 return False;
5354 end if;
5355
5356 -- If the parameter is not a controlling formal, then it cannot be
5357 -- possibly a RACW_Controlling_Formal.
5358
5359 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
5360 return False;
5361 end if;
5362
5363 Typ := Parameter_Type (Parameter);
5364 return (Nkind (Typ) = N_Access_Definition
5365 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
5366 or else Etype (Typ) = Stub_Type;
5367 end Is_RACW_Controlling_Formal;
5368
5369 ------------------------------
5370 -- Make_Transportable_Check --
5371 ------------------------------
5372
5373 function Make_Transportable_Check
5374 (Loc : Source_Ptr;
5375 Expr : Node_Id) return Node_Id is
5376 begin
5377 return
5378 Make_Raise_Program_Error (Loc,
5379 Condition =>
5380 Make_Op_Not (Loc,
5381 Build_Get_Transportable (Loc,
5382 Make_Selected_Component (Loc,
5383 Prefix => Expr,
5384 Selector_Name => Make_Identifier (Loc, Name_uTag)))),
5385 Reason => PE_Non_Transportable_Actual);
5386 end Make_Transportable_Check;
5387
5388 -----------------------------
5389 -- Make_Selected_Component --
5390 -----------------------------
5391
5392 function Make_Selected_Component
5393 (Loc : Source_Ptr;
5394 Prefix : Entity_Id;
5395 Selector_Name : Name_Id) return Node_Id
5396 is
5397 begin
5398 return Make_Selected_Component (Loc,
5399 Prefix => New_Occurrence_Of (Prefix, Loc),
5400 Selector_Name => Make_Identifier (Loc, Selector_Name));
5401 end Make_Selected_Component;
5402
5403 --------------------
5404 -- Make_Tag_Check --
5405 --------------------
5406
5407 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
5408 Occ : constant Entity_Id := Make_Temporary (Loc, 'E');
5409
5410 begin
5411 return Make_Block_Statement (Loc,
5412 Handled_Statement_Sequence =>
5413 Make_Handled_Sequence_Of_Statements (Loc,
5414 Statements => New_List (N),
5415
5416 Exception_Handlers => New_List (
5417 Make_Implicit_Exception_Handler (Loc,
5418 Choice_Parameter => Occ,
5419
5420 Exception_Choices =>
5421 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
5422
5423 Statements =>
5424 New_List (Make_Procedure_Call_Statement (Loc,
5425 New_Occurrence_Of
5426 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
5427 New_List (New_Occurrence_Of (Occ, Loc))))))));
5428 end Make_Tag_Check;
5429
5430 ----------------------------
5431 -- Need_Extra_Constrained --
5432 ----------------------------
5433
5434 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
5435 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
5436 begin
5437 return Out_Present (Parameter)
5438 and then Has_Discriminants (Etyp)
5439 and then not Is_Constrained (Etyp)
5440 and then Is_Definite_Subtype (Etyp);
5441 end Need_Extra_Constrained;
5442
5443 ------------------------------------
5444 -- Pack_Entity_Into_Stream_Access --
5445 ------------------------------------
5446
5447 function Pack_Entity_Into_Stream_Access
5448 (Loc : Source_Ptr;
5449 Stream : Node_Id;
5450 Object : Entity_Id;
5451 Etyp : Entity_Id := Empty) return Node_Id
5452 is
5453 Typ : Entity_Id;
5454
5455 begin
5456 if Present (Etyp) then
5457 Typ := Etyp;
5458 else
5459 Typ := Etype (Object);
5460 end if;
5461
5462 return
5463 Pack_Node_Into_Stream_Access (Loc,
5464 Stream => Stream,
5465 Object => New_Occurrence_Of (Object, Loc),
5466 Etyp => Typ);
5467 end Pack_Entity_Into_Stream_Access;
5468
5469 ---------------------------
5470 -- Pack_Node_Into_Stream --
5471 ---------------------------
5472
5473 function Pack_Node_Into_Stream
5474 (Loc : Source_Ptr;
5475 Stream : Entity_Id;
5476 Object : Node_Id;
5477 Etyp : Entity_Id) return Node_Id
5478 is
5479 Write_Attribute : Name_Id := Name_Write;
5480
5481 begin
5482 if not Is_Constrained (Etyp) then
5483 Write_Attribute := Name_Output;
5484 end if;
5485
5486 return
5487 Make_Attribute_Reference (Loc,
5488 Prefix => New_Occurrence_Of (Etyp, Loc),
5489 Attribute_Name => Write_Attribute,
5490 Expressions => New_List (
5491 Make_Attribute_Reference (Loc,
5492 Prefix => New_Occurrence_Of (Stream, Loc),
5493 Attribute_Name => Name_Access),
5494 Object));
5495 end Pack_Node_Into_Stream;
5496
5497 ----------------------------------
5498 -- Pack_Node_Into_Stream_Access --
5499 ----------------------------------
5500
5501 function Pack_Node_Into_Stream_Access
5502 (Loc : Source_Ptr;
5503 Stream : Node_Id;
5504 Object : Node_Id;
5505 Etyp : Entity_Id) return Node_Id
5506 is
5507 Write_Attribute : Name_Id := Name_Write;
5508
5509 begin
5510 if not Is_Constrained (Etyp) then
5511 Write_Attribute := Name_Output;
5512 end if;
5513
5514 return
5515 Make_Attribute_Reference (Loc,
5516 Prefix => New_Occurrence_Of (Etyp, Loc),
5517 Attribute_Name => Write_Attribute,
5518 Expressions => New_List (
5519 Stream,
5520 Object));
5521 end Pack_Node_Into_Stream_Access;
5522
5523 ---------------------
5524 -- PolyORB_Support --
5525 ---------------------
5526
5527 package body PolyORB_Support is
5528
5529 -- Local subprograms
5530
5531 procedure Add_RACW_Read_Attribute
5532 (RACW_Type : Entity_Id;
5533 Stub_Type : Entity_Id;
5534 Stub_Type_Access : Entity_Id;
5535 Body_Decls : List_Id);
5536 -- Add Read attribute for the RACW type. The declaration and attribute
5537 -- definition clauses are inserted right after the declaration of
5538 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5539 -- appended to it (case where the RACW declaration is in the main unit).
5540
5541 procedure Add_RACW_Write_Attribute
5542 (RACW_Type : Entity_Id;
5543 Stub_Type : Entity_Id;
5544 Stub_Type_Access : Entity_Id;
5545 Body_Decls : List_Id);
5546 -- Same as above for the Write attribute
5547
5548 procedure Add_RACW_From_Any
5549 (RACW_Type : Entity_Id;
5550 Body_Decls : List_Id);
5551 -- Add the From_Any TSS for this RACW type
5552
5553 procedure Add_RACW_To_Any
5554 (RACW_Type : Entity_Id;
5555 Body_Decls : List_Id);
5556 -- Add the To_Any TSS for this RACW type
5557
5558 procedure Add_RACW_TypeCode
5559 (Designated_Type : Entity_Id;
5560 RACW_Type : Entity_Id;
5561 Body_Decls : List_Id);
5562 -- Add the TypeCode TSS for this RACW type
5563
5564 procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
5565 -- Add the From_Any TSS for this RAS type
5566
5567 procedure Add_RAS_To_Any (RAS_Type : Entity_Id);
5568 -- Add the To_Any TSS for this RAS type
5569
5570 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id);
5571 -- Add the TypeCode TSS for this RAS type
5572
5573 procedure Add_RAS_Access_TSS (N : Node_Id);
5574 -- Add a subprogram body for RAS Access TSS
5575
5576 -------------------------------------
5577 -- Add_Obj_RPC_Receiver_Completion --
5578 -------------------------------------
5579
5580 procedure Add_Obj_RPC_Receiver_Completion
5581 (Loc : Source_Ptr;
5582 Decls : List_Id;
5583 RPC_Receiver : Entity_Id;
5584 Stub_Elements : Stub_Structure)
5585 is
5586 Desig : constant Entity_Id :=
5587 Etype (Designated_Type (Stub_Elements.RACW_Type));
5588 begin
5589 Append_To (Decls,
5590 Make_Procedure_Call_Statement (Loc,
5591 Name =>
5592 New_Occurrence_Of (
5593 RTE (RE_Register_Obj_Receiving_Stub), Loc),
5594
5595 Parameter_Associations => New_List (
5596
5597 -- Name
5598
5599 Make_String_Literal (Loc,
5600 Fully_Qualified_Name_String (Desig, Append_NUL => False)),
5601
5602 -- Handler
5603
5604 Make_Attribute_Reference (Loc,
5605 Prefix =>
5606 New_Occurrence_Of (
5607 Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
5608 Attribute_Name =>
5609 Name_Access),
5610
5611 -- Receiver
5612
5613 Make_Attribute_Reference (Loc,
5614 Prefix =>
5615 New_Occurrence_Of (
5616 Defining_Identifier (
5617 Stub_Elements.RPC_Receiver_Decl), Loc),
5618 Attribute_Name =>
5619 Name_Access))));
5620 end Add_Obj_RPC_Receiver_Completion;
5621
5622 -----------------------
5623 -- Add_RACW_Features --
5624 -----------------------
5625
5626 procedure Add_RACW_Features
5627 (RACW_Type : Entity_Id;
5628 Desig : Entity_Id;
5629 Stub_Type : Entity_Id;
5630 Stub_Type_Access : Entity_Id;
5631 RPC_Receiver_Decl : Node_Id;
5632 Body_Decls : List_Id)
5633 is
5634 pragma Unreferenced (RPC_Receiver_Decl);
5635
5636 begin
5637 Add_RACW_From_Any
5638 (RACW_Type => RACW_Type,
5639 Body_Decls => Body_Decls);
5640
5641 Add_RACW_To_Any
5642 (RACW_Type => RACW_Type,
5643 Body_Decls => Body_Decls);
5644
5645 Add_RACW_Write_Attribute
5646 (RACW_Type => RACW_Type,
5647 Stub_Type => Stub_Type,
5648 Stub_Type_Access => Stub_Type_Access,
5649 Body_Decls => Body_Decls);
5650
5651 Add_RACW_Read_Attribute
5652 (RACW_Type => RACW_Type,
5653 Stub_Type => Stub_Type,
5654 Stub_Type_Access => Stub_Type_Access,
5655 Body_Decls => Body_Decls);
5656
5657 Add_RACW_TypeCode
5658 (Designated_Type => Desig,
5659 RACW_Type => RACW_Type,
5660 Body_Decls => Body_Decls);
5661 end Add_RACW_Features;
5662
5663 -----------------------
5664 -- Add_RACW_From_Any --
5665 -----------------------
5666
5667 procedure Add_RACW_From_Any
5668 (RACW_Type : Entity_Id;
5669 Body_Decls : List_Id)
5670 is
5671 Loc : constant Source_Ptr := Sloc (RACW_Type);
5672 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5673 Fnam : constant Entity_Id :=
5674 Make_Defining_Identifier (Loc,
5675 Chars => New_External_Name (Chars (RACW_Type), 'F'));
5676
5677 Func_Spec : Node_Id;
5678 Func_Decl : Node_Id;
5679 Func_Body : Node_Id;
5680
5681 Statements : List_Id;
5682 -- Various parts of the subprogram
5683
5684 Any_Parameter : constant Entity_Id :=
5685 Make_Defining_Identifier (Loc, Name_A);
5686
5687 Asynchronous_Flag : constant Entity_Id :=
5688 Asynchronous_Flags_Table.Get (RACW_Type);
5689 -- The flag object declared in Add_RACW_Asynchronous_Flag
5690
5691 begin
5692 Func_Spec :=
5693 Make_Function_Specification (Loc,
5694 Defining_Unit_Name =>
5695 Fnam,
5696 Parameter_Specifications => New_List (
5697 Make_Parameter_Specification (Loc,
5698 Defining_Identifier =>
5699 Any_Parameter,
5700 Parameter_Type =>
5701 New_Occurrence_Of (RTE (RE_Any), Loc))),
5702 Result_Definition => New_Occurrence_Of (RACW_Type, Loc));
5703
5704 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5705 -- entity in the declaration spec, not those of the body spec.
5706
5707 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5708 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5709 Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
5710
5711 if No (Body_Decls) then
5712 return;
5713 end if;
5714
5715 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5716 -- set on the stub type if, and only if, the RACW type has a pragma
5717 -- Asynchronous. This is incorrect for RACWs that implement RAS
5718 -- types, because in that case the /designated subprogram/ (not the
5719 -- type) might be asynchronous, and that causes the stub to need to
5720 -- be asynchronous too. A solution is to transport a RAS as a struct
5721 -- containing a RACW and an asynchronous flag, and to properly alter
5722 -- the Asynchronous component in the stub type in the RAS's _From_Any
5723 -- TSS.
5724
5725 Statements := New_List (
5726 Make_Simple_Return_Statement (Loc,
5727 Expression => Unchecked_Convert_To (RACW_Type,
5728 Make_Function_Call (Loc,
5729 Name => New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5730 Parameter_Associations => New_List (
5731 Make_Function_Call (Loc,
5732 Name => New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
5733 Parameter_Associations => New_List (
5734 New_Occurrence_Of (Any_Parameter, Loc))),
5735 Build_Stub_Tag (Loc, RACW_Type),
5736 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5737 New_Occurrence_Of (Asynchronous_Flag, Loc))))));
5738
5739 Func_Body :=
5740 Make_Subprogram_Body (Loc,
5741 Specification => Copy_Specification (Loc, Func_Spec),
5742 Declarations => No_List,
5743 Handled_Statement_Sequence =>
5744 Make_Handled_Sequence_Of_Statements (Loc,
5745 Statements => Statements));
5746
5747 Append_To (Body_Decls, Func_Body);
5748 end Add_RACW_From_Any;
5749
5750 -----------------------------
5751 -- Add_RACW_Read_Attribute --
5752 -----------------------------
5753
5754 procedure Add_RACW_Read_Attribute
5755 (RACW_Type : Entity_Id;
5756 Stub_Type : Entity_Id;
5757 Stub_Type_Access : Entity_Id;
5758 Body_Decls : List_Id)
5759 is
5760 pragma Unreferenced (Stub_Type, Stub_Type_Access);
5761
5762 Loc : constant Source_Ptr := Sloc (RACW_Type);
5763
5764 Proc_Decl : Node_Id;
5765 Attr_Decl : Node_Id;
5766
5767 Body_Node : Node_Id;
5768
5769 Decls : constant List_Id := New_List;
5770 Statements : constant List_Id := New_List;
5771 Reference : constant Entity_Id :=
5772 Make_Defining_Identifier (Loc, Name_R);
5773 -- Various parts of the procedure
5774
5775 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
5776
5777 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5778
5779 Asynchronous_Flag : constant Entity_Id :=
5780 Asynchronous_Flags_Table.Get (RACW_Type);
5781 pragma Assert (Present (Asynchronous_Flag));
5782
5783 function Stream_Parameter return Node_Id;
5784 function Result return Node_Id;
5785
5786 -- Functions to create occurrences of the formal parameter names
5787
5788 ------------
5789 -- Result --
5790 ------------
5791
5792 function Result return Node_Id is
5793 begin
5794 return Make_Identifier (Loc, Name_V);
5795 end Result;
5796
5797 ----------------------
5798 -- Stream_Parameter --
5799 ----------------------
5800
5801 function Stream_Parameter return Node_Id is
5802 begin
5803 return Make_Identifier (Loc, Name_S);
5804 end Stream_Parameter;
5805
5806 -- Start of processing for Add_RACW_Read_Attribute
5807
5808 begin
5809 Build_Stream_Procedure
5810 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => True);
5811
5812 Proc_Decl := Make_Subprogram_Declaration (Loc,
5813 Copy_Specification (Loc, Specification (Body_Node)));
5814
5815 Attr_Decl :=
5816 Make_Attribute_Definition_Clause (Loc,
5817 Name => New_Occurrence_Of (RACW_Type, Loc),
5818 Chars => Name_Read,
5819 Expression =>
5820 New_Occurrence_Of (
5821 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
5822
5823 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
5824 Insert_After (Proc_Decl, Attr_Decl);
5825
5826 if No (Body_Decls) then
5827 return;
5828 end if;
5829
5830 Append_To (Decls,
5831 Make_Object_Declaration (Loc,
5832 Defining_Identifier =>
5833 Reference,
5834 Object_Definition =>
5835 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
5836
5837 Append_List_To (Statements, New_List (
5838 Make_Attribute_Reference (Loc,
5839 Prefix =>
5840 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5841 Attribute_Name => Name_Read,
5842 Expressions => New_List (
5843 Stream_Parameter,
5844 New_Occurrence_Of (Reference, Loc))),
5845
5846 Make_Assignment_Statement (Loc,
5847 Name =>
5848 Result,
5849 Expression =>
5850 Unchecked_Convert_To (RACW_Type,
5851 Make_Function_Call (Loc,
5852 Name =>
5853 New_Occurrence_Of (RTE (RE_Get_RACW), Loc),
5854 Parameter_Associations => New_List (
5855 New_Occurrence_Of (Reference, Loc),
5856 Build_Stub_Tag (Loc, RACW_Type),
5857 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5858 New_Occurrence_Of (Asynchronous_Flag, Loc)))))));
5859
5860 Set_Declarations (Body_Node, Decls);
5861 Append_To (Body_Decls, Body_Node);
5862 end Add_RACW_Read_Attribute;
5863
5864 ---------------------
5865 -- Add_RACW_To_Any --
5866 ---------------------
5867
5868 procedure Add_RACW_To_Any
5869 (RACW_Type : Entity_Id;
5870 Body_Decls : List_Id)
5871 is
5872 Loc : constant Source_Ptr := Sloc (RACW_Type);
5873
5874 Fnam : constant Entity_Id :=
5875 Make_Defining_Identifier (Loc,
5876 Chars => New_External_Name (Chars (RACW_Type), 'T'));
5877
5878 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
5879
5880 Stub_Elements : constant Stub_Structure :=
5881 Get_Stub_Elements (RACW_Type);
5882
5883 Func_Spec : Node_Id;
5884 Func_Decl : Node_Id;
5885 Func_Body : Node_Id;
5886
5887 Decls : List_Id;
5888 Statements : List_Id;
5889 -- Various parts of the subprogram
5890
5891 RACW_Parameter : constant Entity_Id :=
5892 Make_Defining_Identifier (Loc, Name_R);
5893
5894 Reference : constant Entity_Id := Make_Temporary (Loc, 'R');
5895 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
5896
5897 begin
5898 Func_Spec :=
5899 Make_Function_Specification (Loc,
5900 Defining_Unit_Name =>
5901 Fnam,
5902 Parameter_Specifications => New_List (
5903 Make_Parameter_Specification (Loc,
5904 Defining_Identifier =>
5905 RACW_Parameter,
5906 Parameter_Type =>
5907 New_Occurrence_Of (RACW_Type, Loc))),
5908 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
5909
5910 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5911 -- entity in the declaration spec, not in the body spec.
5912
5913 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
5914
5915 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
5916 Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
5917
5918 if No (Body_Decls) then
5919 return;
5920 end if;
5921
5922 -- Generate:
5923
5924 -- R : constant Object_Ref :=
5925 -- Get_Reference
5926 -- (Address!(RACW),
5927 -- "typ",
5928 -- Stub_Type'Tag,
5929 -- Is_RAS,
5930 -- RPC_Receiver'Access);
5931 -- A : Any;
5932
5933 Decls := New_List (
5934 Make_Object_Declaration (Loc,
5935 Defining_Identifier => Reference,
5936 Constant_Present => True,
5937 Object_Definition =>
5938 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
5939 Expression =>
5940 Make_Function_Call (Loc,
5941 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
5942 Parameter_Associations => New_List (
5943 Unchecked_Convert_To (RTE (RE_Address),
5944 New_Occurrence_Of (RACW_Parameter, Loc)),
5945 Make_String_Literal (Loc,
5946 Strval => Fully_Qualified_Name_String
5947 (Etype (Designated_Type (RACW_Type)),
5948 Append_NUL => False)),
5949 Build_Stub_Tag (Loc, RACW_Type),
5950 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
5951 Make_Attribute_Reference (Loc,
5952 Prefix =>
5953 New_Occurrence_Of
5954 (Defining_Identifier
5955 (Stub_Elements.RPC_Receiver_Decl), Loc),
5956 Attribute_Name => Name_Access)))),
5957
5958 Make_Object_Declaration (Loc,
5959 Defining_Identifier => Any,
5960 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)));
5961
5962 -- Generate:
5963
5964 -- Any := TA_ObjRef (Reference);
5965 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5966 -- return Any;
5967
5968 Statements := New_List (
5969 Make_Assignment_Statement (Loc,
5970 Name => New_Occurrence_Of (Any, Loc),
5971 Expression =>
5972 Make_Function_Call (Loc,
5973 Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
5974 Parameter_Associations => New_List (
5975 New_Occurrence_Of (Reference, Loc)))),
5976
5977 Make_Procedure_Call_Statement (Loc,
5978 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
5979 Parameter_Associations => New_List (
5980 New_Occurrence_Of (Any, Loc),
5981 Make_Selected_Component (Loc,
5982 Prefix =>
5983 Defining_Identifier (
5984 Stub_Elements.RPC_Receiver_Decl),
5985 Selector_Name => Name_Obj_TypeCode))),
5986
5987 Make_Simple_Return_Statement (Loc,
5988 Expression => New_Occurrence_Of (Any, Loc)));
5989
5990 Func_Body :=
5991 Make_Subprogram_Body (Loc,
5992 Specification => Copy_Specification (Loc, Func_Spec),
5993 Declarations => Decls,
5994 Handled_Statement_Sequence =>
5995 Make_Handled_Sequence_Of_Statements (Loc,
5996 Statements => Statements));
5997 Append_To (Body_Decls, Func_Body);
5998 end Add_RACW_To_Any;
5999
6000 -----------------------
6001 -- Add_RACW_TypeCode --
6002 -----------------------
6003
6004 procedure Add_RACW_TypeCode
6005 (Designated_Type : Entity_Id;
6006 RACW_Type : Entity_Id;
6007 Body_Decls : List_Id)
6008 is
6009 Loc : constant Source_Ptr := Sloc (RACW_Type);
6010
6011 Fnam : constant Entity_Id :=
6012 Make_Defining_Identifier (Loc,
6013 Chars => New_External_Name (Chars (RACW_Type), 'Y'));
6014
6015 Stub_Elements : constant Stub_Structure :=
6016 Stubs_Table.Get (Designated_Type);
6017 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
6018
6019 Func_Spec : Node_Id;
6020 Func_Decl : Node_Id;
6021 Func_Body : Node_Id;
6022
6023 begin
6024 -- The spec for this subprogram has a dummy 'access RACW' argument,
6025 -- which serves only for overloading purposes.
6026
6027 Func_Spec :=
6028 Make_Function_Specification (Loc,
6029 Defining_Unit_Name => Fnam,
6030 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6031
6032 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6033 -- entity in the declaration spec, not those of the body spec.
6034
6035 Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
6036 Insert_After (Declaration_Node (RACW_Type), Func_Decl);
6037 Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
6038
6039 if No (Body_Decls) then
6040 return;
6041 end if;
6042
6043 Func_Body :=
6044 Make_Subprogram_Body (Loc,
6045 Specification => Copy_Specification (Loc, Func_Spec),
6046 Declarations => Empty_List,
6047 Handled_Statement_Sequence =>
6048 Make_Handled_Sequence_Of_Statements (Loc,
6049 Statements => New_List (
6050 Make_Simple_Return_Statement (Loc,
6051 Expression =>
6052 Make_Selected_Component (Loc,
6053 Prefix =>
6054 Defining_Identifier
6055 (Stub_Elements.RPC_Receiver_Decl),
6056 Selector_Name => Name_Obj_TypeCode)))));
6057
6058 Append_To (Body_Decls, Func_Body);
6059 end Add_RACW_TypeCode;
6060
6061 ------------------------------
6062 -- Add_RACW_Write_Attribute --
6063 ------------------------------
6064
6065 procedure Add_RACW_Write_Attribute
6066 (RACW_Type : Entity_Id;
6067 Stub_Type : Entity_Id;
6068 Stub_Type_Access : Entity_Id;
6069 Body_Decls : List_Id)
6070 is
6071 pragma Unreferenced (Stub_Type, Stub_Type_Access);
6072
6073 Loc : constant Source_Ptr := Sloc (RACW_Type);
6074
6075 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
6076
6077 Stub_Elements : constant Stub_Structure :=
6078 Get_Stub_Elements (RACW_Type);
6079
6080 Body_Node : Node_Id;
6081 Proc_Decl : Node_Id;
6082 Attr_Decl : Node_Id;
6083
6084 Statements : constant List_Id := New_List;
6085 Pnam : constant Entity_Id := Make_Temporary (Loc, 'R');
6086
6087 function Stream_Parameter return Node_Id;
6088 function Object return Node_Id;
6089 -- Functions to create occurrences of the formal parameter names
6090
6091 ------------
6092 -- Object --
6093 ------------
6094
6095 function Object return Node_Id is
6096 begin
6097 return Make_Identifier (Loc, Name_V);
6098 end Object;
6099
6100 ----------------------
6101 -- Stream_Parameter --
6102 ----------------------
6103
6104 function Stream_Parameter return Node_Id is
6105 begin
6106 return Make_Identifier (Loc, Name_S);
6107 end Stream_Parameter;
6108
6109 -- Start of processing for Add_RACW_Write_Attribute
6110
6111 begin
6112 Build_Stream_Procedure
6113 (Loc, RACW_Type, Body_Node, Pnam, Statements, Outp => False);
6114
6115 Proc_Decl :=
6116 Make_Subprogram_Declaration (Loc,
6117 Copy_Specification (Loc, Specification (Body_Node)));
6118
6119 Attr_Decl :=
6120 Make_Attribute_Definition_Clause (Loc,
6121 Name => New_Occurrence_Of (RACW_Type, Loc),
6122 Chars => Name_Write,
6123 Expression =>
6124 New_Occurrence_Of (
6125 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
6126
6127 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
6128 Insert_After (Proc_Decl, Attr_Decl);
6129
6130 if No (Body_Decls) then
6131 return;
6132 end if;
6133
6134 Append_To (Statements,
6135 Pack_Node_Into_Stream_Access (Loc,
6136 Stream => Stream_Parameter,
6137 Object =>
6138 Make_Function_Call (Loc,
6139 Name => New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
6140 Parameter_Associations => New_List (
6141 Unchecked_Convert_To (RTE (RE_Address), Object),
6142 Make_String_Literal (Loc,
6143 Strval => Fully_Qualified_Name_String
6144 (Etype (Designated_Type (RACW_Type)),
6145 Append_NUL => False)),
6146 Build_Stub_Tag (Loc, RACW_Type),
6147 New_Occurrence_Of (Boolean_Literals (Is_RAS), Loc),
6148 Make_Attribute_Reference (Loc,
6149 Prefix =>
6150 New_Occurrence_Of
6151 (Defining_Identifier
6152 (Stub_Elements.RPC_Receiver_Decl), Loc),
6153 Attribute_Name => Name_Access))),
6154
6155 Etyp => RTE (RE_Object_Ref)));
6156
6157 Append_To (Body_Decls, Body_Node);
6158 end Add_RACW_Write_Attribute;
6159
6160 -----------------------
6161 -- Add_RAST_Features --
6162 -----------------------
6163
6164 procedure Add_RAST_Features
6165 (Vis_Decl : Node_Id;
6166 RAS_Type : Entity_Id)
6167 is
6168 begin
6169 Add_RAS_Access_TSS (Vis_Decl);
6170
6171 Add_RAS_From_Any (RAS_Type);
6172 Add_RAS_TypeCode (RAS_Type);
6173
6174 -- To_Any uses TypeCode, and therefore needs to be generated last
6175
6176 Add_RAS_To_Any (RAS_Type);
6177 end Add_RAST_Features;
6178
6179 ------------------------
6180 -- Add_RAS_Access_TSS --
6181 ------------------------
6182
6183 procedure Add_RAS_Access_TSS (N : Node_Id) is
6184 Loc : constant Source_Ptr := Sloc (N);
6185
6186 Ras_Type : constant Entity_Id := Defining_Identifier (N);
6187 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
6188 -- Ras_Type is the access to subprogram type; Fat_Type is the
6189 -- corresponding record type.
6190
6191 RACW_Type : constant Entity_Id :=
6192 Underlying_RACW_Type (Ras_Type);
6193
6194 Stub_Elements : constant Stub_Structure :=
6195 Get_Stub_Elements (RACW_Type);
6196
6197 Proc : constant Entity_Id :=
6198 Make_Defining_Identifier (Loc,
6199 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
6200
6201 Proc_Spec : Node_Id;
6202
6203 -- Formal parameters
6204
6205 Package_Name : constant Entity_Id :=
6206 Make_Defining_Identifier (Loc,
6207 Chars => Name_P);
6208
6209 -- Target package
6210
6211 Subp_Id : constant Entity_Id :=
6212 Make_Defining_Identifier (Loc,
6213 Chars => Name_S);
6214
6215 -- Target subprogram
6216
6217 Asynch_P : constant Entity_Id :=
6218 Make_Defining_Identifier (Loc,
6219 Chars => Name_Asynchronous);
6220 -- Is the procedure to which the 'Access applies asynchronous?
6221
6222 All_Calls_Remote : constant Entity_Id :=
6223 Make_Defining_Identifier (Loc,
6224 Chars => Name_All_Calls_Remote);
6225 -- True if an All_Calls_Remote pragma applies to the RCI unit
6226 -- that contains the subprogram.
6227
6228 -- Common local variables
6229
6230 Proc_Decls : List_Id;
6231 Proc_Statements : List_Id;
6232
6233 Subp_Ref : constant Entity_Id :=
6234 Make_Defining_Identifier (Loc, Name_R);
6235 -- Reference that designates the target subprogram (returned
6236 -- by Get_RAS_Info).
6237
6238 Is_Local : constant Entity_Id :=
6239 Make_Defining_Identifier (Loc, Name_L);
6240 Local_Addr : constant Entity_Id :=
6241 Make_Defining_Identifier (Loc, Name_A);
6242 -- For the call to Get_Local_Address
6243
6244 Local_Stub : constant Entity_Id := Make_Temporary (Loc, 'L');
6245 Stub_Ptr : constant Entity_Id := Make_Temporary (Loc, 'S');
6246 -- Additional local variables for the remote case
6247
6248 function Set_Field
6249 (Field_Name : Name_Id;
6250 Value : Node_Id) return Node_Id;
6251 -- Construct an assignment that sets the named component in the
6252 -- returned record
6253
6254 ---------------
6255 -- Set_Field --
6256 ---------------
6257
6258 function Set_Field
6259 (Field_Name : Name_Id;
6260 Value : Node_Id) return Node_Id
6261 is
6262 begin
6263 return
6264 Make_Assignment_Statement (Loc,
6265 Name =>
6266 Make_Selected_Component (Loc,
6267 Prefix => Stub_Ptr,
6268 Selector_Name => Field_Name),
6269 Expression => Value);
6270 end Set_Field;
6271
6272 -- Start of processing for Add_RAS_Access_TSS
6273
6274 begin
6275 Proc_Decls := New_List (
6276
6277 -- Common declarations
6278
6279 Make_Object_Declaration (Loc,
6280 Defining_Identifier => Subp_Ref,
6281 Object_Definition =>
6282 New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
6283
6284 Make_Object_Declaration (Loc,
6285 Defining_Identifier => Is_Local,
6286 Object_Definition =>
6287 New_Occurrence_Of (Standard_Boolean, Loc)),
6288
6289 Make_Object_Declaration (Loc,
6290 Defining_Identifier => Local_Addr,
6291 Object_Definition =>
6292 New_Occurrence_Of (RTE (RE_Address), Loc)),
6293
6294 Make_Object_Declaration (Loc,
6295 Defining_Identifier => Local_Stub,
6296 Aliased_Present => True,
6297 Object_Definition =>
6298 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
6299
6300 Make_Object_Declaration (Loc,
6301 Defining_Identifier => Stub_Ptr,
6302 Object_Definition =>
6303 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
6304 Expression =>
6305 Make_Attribute_Reference (Loc,
6306 Prefix => New_Occurrence_Of (Local_Stub, Loc),
6307 Attribute_Name => Name_Unchecked_Access)));
6308
6309 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
6310 -- Build_Get_Unique_RP_Call needs this information
6311
6312 -- Get_RAS_Info (Pkg, Subp, R);
6313 -- Obtain a reference to the target subprogram
6314
6315 Proc_Statements := New_List (
6316 Make_Procedure_Call_Statement (Loc,
6317 Name => New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
6318 Parameter_Associations => New_List (
6319 New_Occurrence_Of (Package_Name, Loc),
6320 New_Occurrence_Of (Subp_Id, Loc),
6321 New_Occurrence_Of (Subp_Ref, Loc))),
6322
6323 -- Get_Local_Address (R, L, A);
6324 -- Determine whether the subprogram is local (L), and if so
6325 -- obtain the local address of its proxy (A).
6326
6327 Make_Procedure_Call_Statement (Loc,
6328 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6329 Parameter_Associations => New_List (
6330 New_Occurrence_Of (Subp_Ref, Loc),
6331 New_Occurrence_Of (Is_Local, Loc),
6332 New_Occurrence_Of (Local_Addr, Loc))));
6333
6334 -- Note: Here we assume that the Fat_Type is a record containing just
6335 -- an access to a proxy or stub object.
6336
6337 Append_To (Proc_Statements,
6338
6339 -- if L then
6340
6341 Make_Implicit_If_Statement (N,
6342 Condition => New_Occurrence_Of (Is_Local, Loc),
6343
6344 Then_Statements => New_List (
6345
6346 -- if A.Target = null then
6347
6348 Make_Implicit_If_Statement (N,
6349 Condition =>
6350 Make_Op_Eq (Loc,
6351 Make_Selected_Component (Loc,
6352 Prefix =>
6353 Unchecked_Convert_To
6354 (RTE (RE_RAS_Proxy_Type_Access),
6355 New_Occurrence_Of (Local_Addr, Loc)),
6356 Selector_Name => Make_Identifier (Loc, Name_Target)),
6357 Make_Null (Loc)),
6358
6359 Then_Statements => New_List (
6360
6361 -- A.Target := Entity_Of (Ref);
6362
6363 Make_Assignment_Statement (Loc,
6364 Name =>
6365 Make_Selected_Component (Loc,
6366 Prefix =>
6367 Unchecked_Convert_To
6368 (RTE (RE_RAS_Proxy_Type_Access),
6369 New_Occurrence_Of (Local_Addr, Loc)),
6370 Selector_Name => Make_Identifier (Loc, Name_Target)),
6371 Expression =>
6372 Make_Function_Call (Loc,
6373 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6374 Parameter_Associations => New_List (
6375 New_Occurrence_Of (Subp_Ref, Loc)))),
6376
6377 -- Inc_Usage (A.Target);
6378 -- end if;
6379
6380 Make_Procedure_Call_Statement (Loc,
6381 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6382 Parameter_Associations => New_List (
6383 Make_Selected_Component (Loc,
6384 Prefix =>
6385 Unchecked_Convert_To
6386 (RTE (RE_RAS_Proxy_Type_Access),
6387 New_Occurrence_Of (Local_Addr, Loc)),
6388 Selector_Name =>
6389 Make_Identifier (Loc, Name_Target)))))),
6390
6391 -- if not All_Calls_Remote then
6392 -- return Fat_Type!(A);
6393 -- end if;
6394
6395 Make_Implicit_If_Statement (N,
6396 Condition =>
6397 Make_Op_Not (Loc,
6398 Right_Opnd =>
6399 New_Occurrence_Of (All_Calls_Remote, Loc)),
6400
6401 Then_Statements => New_List (
6402 Make_Simple_Return_Statement (Loc,
6403 Expression =>
6404 Unchecked_Convert_To
6405 (Fat_Type, New_Occurrence_Of (Local_Addr, Loc))))))));
6406
6407 Append_List_To (Proc_Statements, New_List (
6408
6409 -- Stub.Target := Entity_Of (Ref);
6410
6411 Set_Field (Name_Target,
6412 Make_Function_Call (Loc,
6413 Name => New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
6414 Parameter_Associations => New_List (
6415 New_Occurrence_Of (Subp_Ref, Loc)))),
6416
6417 -- Inc_Usage (Stub.Target);
6418
6419 Make_Procedure_Call_Statement (Loc,
6420 Name => New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
6421 Parameter_Associations => New_List (
6422 Make_Selected_Component (Loc,
6423 Prefix => Stub_Ptr,
6424 Selector_Name => Name_Target))),
6425
6426 -- E.4.1(9) A remote call is asynchronous if it is a call to
6427 -- a procedure, or a call through a value of an access-to-procedure
6428 -- type, to which a pragma Asynchronous applies.
6429
6430 -- Parameter Asynch_P is true when the procedure is asynchronous;
6431 -- Expression Asynch_T is true when the type is asynchronous.
6432
6433 Set_Field (Name_Asynchronous,
6434 Make_Or_Else (Loc,
6435 Left_Opnd => New_Occurrence_Of (Asynch_P, Loc),
6436 Right_Opnd =>
6437 New_Occurrence_Of
6438 (Boolean_Literals (Is_Asynchronous (Ras_Type)), Loc)))));
6439
6440 Append_List_To (Proc_Statements,
6441 Build_Get_Unique_RP_Call (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
6442
6443 Append_To (Proc_Statements,
6444 Make_Simple_Return_Statement (Loc,
6445 Expression =>
6446 Unchecked_Convert_To (Fat_Type,
6447 New_Occurrence_Of (Stub_Ptr, Loc))));
6448
6449 Proc_Spec :=
6450 Make_Function_Specification (Loc,
6451 Defining_Unit_Name => Proc,
6452 Parameter_Specifications => New_List (
6453 Make_Parameter_Specification (Loc,
6454 Defining_Identifier => Package_Name,
6455 Parameter_Type =>
6456 New_Occurrence_Of (Standard_String, Loc)),
6457
6458 Make_Parameter_Specification (Loc,
6459 Defining_Identifier => Subp_Id,
6460 Parameter_Type =>
6461 New_Occurrence_Of (Standard_String, Loc)),
6462
6463 Make_Parameter_Specification (Loc,
6464 Defining_Identifier => Asynch_P,
6465 Parameter_Type =>
6466 New_Occurrence_Of (Standard_Boolean, Loc)),
6467
6468 Make_Parameter_Specification (Loc,
6469 Defining_Identifier => All_Calls_Remote,
6470 Parameter_Type =>
6471 New_Occurrence_Of (Standard_Boolean, Loc))),
6472
6473 Result_Definition =>
6474 New_Occurrence_Of (Fat_Type, Loc));
6475
6476 -- Set the kind and return type of the function to prevent
6477 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6478
6479 Set_Ekind (Proc, E_Function);
6480 Set_Etype (Proc, Fat_Type);
6481
6482 Discard_Node (
6483 Make_Subprogram_Body (Loc,
6484 Specification => Proc_Spec,
6485 Declarations => Proc_Decls,
6486 Handled_Statement_Sequence =>
6487 Make_Handled_Sequence_Of_Statements (Loc,
6488 Statements => Proc_Statements)));
6489
6490 Set_TSS (Fat_Type, Proc);
6491 end Add_RAS_Access_TSS;
6492
6493 ----------------------
6494 -- Add_RAS_From_Any --
6495 ----------------------
6496
6497 procedure Add_RAS_From_Any (RAS_Type : Entity_Id) is
6498 Loc : constant Source_Ptr := Sloc (RAS_Type);
6499
6500 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6501 Make_TSS_Name (RAS_Type, TSS_From_Any));
6502
6503 Func_Spec : Node_Id;
6504
6505 Statements : List_Id;
6506
6507 Any_Parameter : constant Entity_Id :=
6508 Make_Defining_Identifier (Loc, Name_A);
6509
6510 begin
6511 Statements := New_List (
6512 Make_Simple_Return_Statement (Loc,
6513 Expression =>
6514 Make_Aggregate (Loc,
6515 Component_Associations => New_List (
6516 Make_Component_Association (Loc,
6517 Choices => New_List (Make_Identifier (Loc, Name_Ras)),
6518 Expression =>
6519 PolyORB_Support.Helpers.Build_From_Any_Call
6520 (Underlying_RACW_Type (RAS_Type),
6521 New_Occurrence_Of (Any_Parameter, Loc),
6522 No_List))))));
6523
6524 Func_Spec :=
6525 Make_Function_Specification (Loc,
6526 Defining_Unit_Name => Fnam,
6527 Parameter_Specifications => New_List (
6528 Make_Parameter_Specification (Loc,
6529 Defining_Identifier => Any_Parameter,
6530 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
6531 Result_Definition => New_Occurrence_Of (RAS_Type, Loc));
6532
6533 Discard_Node (
6534 Make_Subprogram_Body (Loc,
6535 Specification => Func_Spec,
6536 Declarations => No_List,
6537 Handled_Statement_Sequence =>
6538 Make_Handled_Sequence_Of_Statements (Loc,
6539 Statements => Statements)));
6540 Set_TSS (RAS_Type, Fnam);
6541 end Add_RAS_From_Any;
6542
6543 --------------------
6544 -- Add_RAS_To_Any --
6545 --------------------
6546
6547 procedure Add_RAS_To_Any (RAS_Type : Entity_Id) is
6548 Loc : constant Source_Ptr := Sloc (RAS_Type);
6549
6550 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6551 Make_TSS_Name (RAS_Type, TSS_To_Any));
6552
6553 Decls : List_Id;
6554 Statements : List_Id;
6555
6556 Func_Spec : Node_Id;
6557
6558 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
6559 RAS_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
6560 RACW_Parameter : constant Node_Id :=
6561 Make_Selected_Component (Loc,
6562 Prefix => RAS_Parameter,
6563 Selector_Name => Name_Ras);
6564
6565 begin
6566 -- Object declarations
6567
6568 Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
6569 Decls := New_List (
6570 Make_Object_Declaration (Loc,
6571 Defining_Identifier => Any,
6572 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc),
6573 Expression =>
6574 PolyORB_Support.Helpers.Build_To_Any_Call
6575 (Loc, RACW_Parameter, No_List)));
6576
6577 Statements := New_List (
6578 Make_Procedure_Call_Statement (Loc,
6579 Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
6580 Parameter_Associations => New_List (
6581 New_Occurrence_Of (Any, Loc),
6582 PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
6583 RAS_Type, Decls))),
6584
6585 Make_Simple_Return_Statement (Loc,
6586 Expression => New_Occurrence_Of (Any, Loc)));
6587
6588 Func_Spec :=
6589 Make_Function_Specification (Loc,
6590 Defining_Unit_Name => Fnam,
6591 Parameter_Specifications => New_List (
6592 Make_Parameter_Specification (Loc,
6593 Defining_Identifier => RAS_Parameter,
6594 Parameter_Type => New_Occurrence_Of (RAS_Type, Loc))),
6595 Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
6596
6597 Discard_Node (
6598 Make_Subprogram_Body (Loc,
6599 Specification => Func_Spec,
6600 Declarations => Decls,
6601 Handled_Statement_Sequence =>
6602 Make_Handled_Sequence_Of_Statements (Loc,
6603 Statements => Statements)));
6604 Set_TSS (RAS_Type, Fnam);
6605 end Add_RAS_To_Any;
6606
6607 ----------------------
6608 -- Add_RAS_TypeCode --
6609 ----------------------
6610
6611 procedure Add_RAS_TypeCode (RAS_Type : Entity_Id) is
6612 Loc : constant Source_Ptr := Sloc (RAS_Type);
6613
6614 Fnam : constant Entity_Id := Make_Defining_Identifier (Loc,
6615 Make_TSS_Name (RAS_Type, TSS_TypeCode));
6616
6617 Func_Spec : Node_Id;
6618 Decls : constant List_Id := New_List;
6619 Name_String : String_Id;
6620 Repo_Id_String : String_Id;
6621
6622 begin
6623 Func_Spec :=
6624 Make_Function_Specification (Loc,
6625 Defining_Unit_Name => Fnam,
6626 Result_Definition => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
6627
6628 PolyORB_Support.Helpers.Build_Name_And_Repository_Id
6629 (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
6630
6631 Discard_Node (
6632 Make_Subprogram_Body (Loc,
6633 Specification => Func_Spec,
6634 Declarations => Decls,
6635 Handled_Statement_Sequence =>
6636 Make_Handled_Sequence_Of_Statements (Loc,
6637 Statements => New_List (
6638 Make_Simple_Return_Statement (Loc,
6639 Expression =>
6640 Make_Function_Call (Loc,
6641 Name =>
6642 New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc),
6643 Parameter_Associations => New_List (
6644 New_Occurrence_Of (RTE (RE_Tk_Objref), Loc),
6645 Make_Aggregate (Loc,
6646 Expressions =>
6647 New_List (
6648 Make_Function_Call (Loc,
6649 Name =>
6650 New_Occurrence_Of
6651 (RTE (RE_TA_Std_String), Loc),
6652 Parameter_Associations => New_List (
6653 Make_String_Literal (Loc, Name_String))),
6654 Make_Function_Call (Loc,
6655 Name =>
6656 New_Occurrence_Of
6657 (RTE (RE_TA_Std_String), Loc),
6658 Parameter_Associations => New_List (
6659 Make_String_Literal (Loc,
6660 Strval => Repo_Id_String))))))))))));
6661 Set_TSS (RAS_Type, Fnam);
6662 end Add_RAS_TypeCode;
6663
6664 -----------------------------------------
6665 -- Add_Receiving_Stubs_To_Declarations --
6666 -----------------------------------------
6667
6668 procedure Add_Receiving_Stubs_To_Declarations
6669 (Pkg_Spec : Node_Id;
6670 Decls : List_Id;
6671 Stmts : List_Id)
6672 is
6673 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
6674
6675 Pkg_RPC_Receiver : constant Entity_Id :=
6676 Make_Temporary (Loc, 'H');
6677 Pkg_RPC_Receiver_Object : Node_Id;
6678 Pkg_RPC_Receiver_Body : Node_Id;
6679 Pkg_RPC_Receiver_Decls : List_Id;
6680 Pkg_RPC_Receiver_Statements : List_Id;
6681
6682 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
6683 -- A Pkg_RPC_Receiver is built to decode the request
6684
6685 Request : Node_Id;
6686 -- Request object received from neutral layer
6687
6688 Subp_Id : Entity_Id;
6689 -- Subprogram identifier as received from the neutral distribution
6690 -- core.
6691
6692 Subp_Index : Entity_Id;
6693 -- Internal index as determined by matching either the method name
6694 -- from the request structure, or the local subprogram address (in
6695 -- case of a RAS).
6696
6697 Is_Local : constant Entity_Id := Make_Temporary (Loc, 'L');
6698
6699 Local_Address : constant Entity_Id := Make_Temporary (Loc, 'A');
6700 -- Address of a local subprogram designated by a reference
6701 -- corresponding to a RAS.
6702
6703 Dispatch_On_Address : constant List_Id := New_List;
6704 Dispatch_On_Name : constant List_Id := New_List;
6705
6706 Current_Subp_Number : Int := First_RCI_Subprogram_Id;
6707
6708 Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
6709 Subp_Info_List : constant List_Id := New_List;
6710
6711 Register_Pkg_Actuals : constant List_Id := New_List;
6712
6713 All_Calls_Remote_E : Entity_Id;
6714
6715 procedure Append_Stubs_To
6716 (RPC_Receiver_Cases : List_Id;
6717 Declaration : Node_Id;
6718 Stubs : Node_Id;
6719 Subp_Number : Int;
6720 Subp_Dist_Name : Entity_Id;
6721 Subp_Proxy_Addr : Entity_Id);
6722 -- Add one case to the specified RPC receiver case list associating
6723 -- Subprogram_Number with the subprogram declared by Declaration, for
6724 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6725 -- subprogram index. Subp_Dist_Name is the string used to call the
6726 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6727 -- object, used in the context of calls through remote
6728 -- access-to-subprogram types.
6729
6730 procedure Visit_Subprogram (Decl : Node_Id);
6731 -- Generate receiving stub for one remote subprogram
6732
6733 ---------------------
6734 -- Append_Stubs_To --
6735 ---------------------
6736
6737 procedure Append_Stubs_To
6738 (RPC_Receiver_Cases : List_Id;
6739 Declaration : Node_Id;
6740 Stubs : Node_Id;
6741 Subp_Number : Int;
6742 Subp_Dist_Name : Entity_Id;
6743 Subp_Proxy_Addr : Entity_Id)
6744 is
6745 Case_Stmts : List_Id;
6746 begin
6747 Case_Stmts := New_List (
6748 Make_Procedure_Call_Statement (Loc,
6749 Name =>
6750 New_Occurrence_Of (
6751 Defining_Entity (Stubs), Loc),
6752 Parameter_Associations =>
6753 New_List (New_Occurrence_Of (Request, Loc))));
6754
6755 if Nkind (Specification (Declaration)) = N_Function_Specification
6756 or else not
6757 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
6758 then
6759 Append_To (Case_Stmts, Make_Simple_Return_Statement (Loc));
6760 end if;
6761
6762 Append_To (RPC_Receiver_Cases,
6763 Make_Case_Statement_Alternative (Loc,
6764 Discrete_Choices =>
6765 New_List (Make_Integer_Literal (Loc, Subp_Number)),
6766 Statements => Case_Stmts));
6767
6768 Append_To (Dispatch_On_Name,
6769 Make_Elsif_Part (Loc,
6770 Condition =>
6771 Make_Function_Call (Loc,
6772 Name =>
6773 New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
6774 Parameter_Associations => New_List (
6775 New_Occurrence_Of (Subp_Id, Loc),
6776 New_Occurrence_Of (Subp_Dist_Name, Loc))),
6777
6778 Then_Statements => New_List (
6779 Make_Assignment_Statement (Loc,
6780 New_Occurrence_Of (Subp_Index, Loc),
6781 Make_Integer_Literal (Loc, Subp_Number)))));
6782
6783 Append_To (Dispatch_On_Address,
6784 Make_Elsif_Part (Loc,
6785 Condition =>
6786 Make_Op_Eq (Loc,
6787 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
6788 Right_Opnd => New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
6789
6790 Then_Statements => New_List (
6791 Make_Assignment_Statement (Loc,
6792 New_Occurrence_Of (Subp_Index, Loc),
6793 Make_Integer_Literal (Loc, Subp_Number)))));
6794 end Append_Stubs_To;
6795
6796 ----------------------
6797 -- Visit_Subprogram --
6798 ----------------------
6799
6800 procedure Visit_Subprogram (Decl : Node_Id) is
6801 Loc : constant Source_Ptr := Sloc (Decl);
6802 Spec : constant Node_Id := Specification (Decl);
6803 Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
6804
6805 Subp_Val : String_Id;
6806
6807 Subp_Dist_Name : constant Entity_Id :=
6808 Make_Defining_Identifier (Loc,
6809 Chars =>
6810 New_External_Name
6811 (Related_Id => Chars (Subp_Def),
6812 Suffix => 'D',
6813 Suffix_Index => -1));
6814
6815 Current_Stubs : Node_Id;
6816 Proxy_Obj_Addr : Entity_Id;
6817
6818 begin
6819 -- Disable expansion of stubs if serious errors have been
6820 -- diagnosed, because otherwise some illegal remote subprogram
6821 -- declarations could cause cascaded errors in stubs.
6822
6823 if Serious_Errors_Detected /= 0 then
6824 return;
6825 end if;
6826
6827 -- Build receiving stub
6828
6829 Current_Stubs :=
6830 Build_Subprogram_Receiving_Stubs
6831 (Vis_Decl => Decl,
6832 Asynchronous => Nkind (Spec) = N_Procedure_Specification
6833 and then Is_Asynchronous (Subp_Def));
6834
6835 Append_To (Decls, Current_Stubs);
6836 Analyze (Current_Stubs);
6837
6838 -- Build RAS proxy
6839
6840 Add_RAS_Proxy_And_Analyze (Decls,
6841 Vis_Decl => Decl,
6842 All_Calls_Remote_E => All_Calls_Remote_E,
6843 Proxy_Object_Addr => Proxy_Obj_Addr);
6844
6845 -- Compute distribution identifier
6846
6847 Assign_Subprogram_Identifier
6848 (Subp_Def, Current_Subp_Number, Subp_Val);
6849
6850 pragma Assert
6851 (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
6852
6853 Append_To (Decls,
6854 Make_Object_Declaration (Loc,
6855 Defining_Identifier => Subp_Dist_Name,
6856 Constant_Present => True,
6857 Object_Definition =>
6858 New_Occurrence_Of (Standard_String, Loc),
6859 Expression =>
6860 Make_String_Literal (Loc, Subp_Val)));
6861 Analyze (Last (Decls));
6862
6863 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
6864 -- table for this receiver. The aggregate below must be kept
6865 -- consistent with the declaration of RCI_Subp_Info in
6866 -- System.Partition_Interface.
6867
6868 Append_To (Subp_Info_List,
6869 Make_Component_Association (Loc,
6870 Choices =>
6871 New_List (Make_Integer_Literal (Loc, Current_Subp_Number)),
6872
6873 Expression =>
6874 Make_Aggregate (Loc,
6875 Expressions => New_List (
6876
6877 -- Name =>
6878
6879 Make_Attribute_Reference (Loc,
6880 Prefix =>
6881 New_Occurrence_Of (Subp_Dist_Name, Loc),
6882 Attribute_Name => Name_Address),
6883
6884 -- Name_Length =>
6885
6886 Make_Attribute_Reference (Loc,
6887 Prefix =>
6888 New_Occurrence_Of (Subp_Dist_Name, Loc),
6889 Attribute_Name => Name_Length),
6890
6891 -- Addr =>
6892
6893 New_Occurrence_Of (Proxy_Obj_Addr, Loc)))));
6894
6895 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
6896 Declaration => Decl,
6897 Stubs => Current_Stubs,
6898 Subp_Number => Current_Subp_Number,
6899 Subp_Dist_Name => Subp_Dist_Name,
6900 Subp_Proxy_Addr => Proxy_Obj_Addr);
6901
6902 Current_Subp_Number := Current_Subp_Number + 1;
6903 end Visit_Subprogram;
6904
6905 procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
6906
6907 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6908
6909 begin
6910 -- Building receiving stubs consist in several operations:
6911
6912 -- - a package RPC receiver must be built. This subprogram will get
6913 -- a Subprogram_Id from the incoming stream and will dispatch the
6914 -- call to the right subprogram;
6915
6916 -- - a receiving stub for each subprogram visible in the package
6917 -- spec. This stub will read all the parameters from the stream,
6918 -- and put the result as well as the exception occurrence in the
6919 -- output stream;
6920
6921 Build_RPC_Receiver_Body (
6922 RPC_Receiver => Pkg_RPC_Receiver,
6923 Request => Request,
6924 Subp_Id => Subp_Id,
6925 Subp_Index => Subp_Index,
6926 Stmts => Pkg_RPC_Receiver_Statements,
6927 Decl => Pkg_RPC_Receiver_Body);
6928 Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
6929
6930 -- Extract local address information from the target reference:
6931 -- if non-null, that means that this is a reference that denotes
6932 -- one particular operation, and hence that the operation name
6933 -- must not be taken into account for dispatching.
6934
6935 Append_To (Pkg_RPC_Receiver_Decls,
6936 Make_Object_Declaration (Loc,
6937 Defining_Identifier => Is_Local,
6938 Object_Definition =>
6939 New_Occurrence_Of (Standard_Boolean, Loc)));
6940
6941 Append_To (Pkg_RPC_Receiver_Decls,
6942 Make_Object_Declaration (Loc,
6943 Defining_Identifier => Local_Address,
6944 Object_Definition =>
6945 New_Occurrence_Of (RTE (RE_Address), Loc)));
6946
6947 Append_To (Pkg_RPC_Receiver_Statements,
6948 Make_Procedure_Call_Statement (Loc,
6949 Name => New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
6950 Parameter_Associations => New_List (
6951 Make_Selected_Component (Loc,
6952 Prefix => Request,
6953 Selector_Name => Name_Target),
6954 New_Occurrence_Of (Is_Local, Loc),
6955 New_Occurrence_Of (Local_Address, Loc))));
6956
6957 -- For each subprogram, the receiving stub will be built and a case
6958 -- statement will be made on the Subprogram_Id to dispatch to the
6959 -- right subprogram.
6960
6961 All_Calls_Remote_E := Boolean_Literals (
6962 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
6963
6964 Overload_Counter_Table.Reset;
6965 Reserve_NamingContext_Methods;
6966
6967 Visit_Spec (Pkg_Spec);
6968
6969 Append_To (Decls,
6970 Make_Object_Declaration (Loc,
6971 Defining_Identifier => Subp_Info_Array,
6972 Constant_Present => True,
6973 Aliased_Present => True,
6974 Object_Definition =>
6975 Make_Subtype_Indication (Loc,
6976 Subtype_Mark =>
6977 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
6978 Constraint =>
6979 Make_Index_Or_Discriminant_Constraint (Loc,
6980 New_List (
6981 Make_Range (Loc,
6982 Low_Bound =>
6983 Make_Integer_Literal (Loc,
6984 Intval => First_RCI_Subprogram_Id),
6985 High_Bound =>
6986 Make_Integer_Literal (Loc,
6987 Intval =>
6988 First_RCI_Subprogram_Id
6989 + List_Length (Subp_Info_List) - 1)))))));
6990
6991 if Present (First (Subp_Info_List)) then
6992 Set_Expression (Last (Decls),
6993 Make_Aggregate (Loc,
6994 Component_Associations => Subp_Info_List));
6995
6996 -- Generate the dispatch statement to determine the subprogram id
6997 -- of the called subprogram.
6998
6999 -- We first test whether the reference that was used to make the
7000 -- call was the base RCI reference (in which case Local_Address is
7001 -- zero, and the method identifier from the request must be used
7002 -- to determine which subprogram is called) or a reference
7003 -- identifying one particular subprogram (in which case
7004 -- Local_Address is the address of that subprogram, and the
7005 -- method name from the request is ignored). The latter occurs
7006 -- for the case of a call through a remote access-to-subprogram.
7007
7008 -- In each case, cascaded elsifs are used to determine the proper
7009 -- subprogram index. Using hash tables might be more efficient.
7010
7011 Append_To (Pkg_RPC_Receiver_Statements,
7012 Make_Implicit_If_Statement (Pkg_Spec,
7013 Condition =>
7014 Make_Op_Ne (Loc,
7015 Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
7016 Right_Opnd => New_Occurrence_Of
7017 (RTE (RE_Null_Address), Loc)),
7018
7019 Then_Statements => New_List (
7020 Make_Implicit_If_Statement (Pkg_Spec,
7021 Condition => New_Occurrence_Of (Standard_False, Loc),
7022 Then_Statements => New_List (
7023 Make_Null_Statement (Loc)),
7024 Elsif_Parts => Dispatch_On_Address)),
7025
7026 Else_Statements => New_List (
7027 Make_Implicit_If_Statement (Pkg_Spec,
7028 Condition => New_Occurrence_Of (Standard_False, Loc),
7029 Then_Statements => New_List (Make_Null_Statement (Loc)),
7030 Elsif_Parts => Dispatch_On_Name))));
7031
7032 else
7033 -- For a degenerate RCI with no visible subprograms,
7034 -- Subp_Info_List has zero length, and the declaration is for an
7035 -- empty array, in which case no initialization aggregate must be
7036 -- generated. We do not generate a Dispatch_Statement either.
7037
7038 -- No initialization provided: remove CONSTANT so that the
7039 -- declaration is not an incomplete deferred constant.
7040
7041 Set_Constant_Present (Last (Decls), False);
7042 end if;
7043
7044 -- Analyze Subp_Info_Array declaration
7045
7046 Analyze (Last (Decls));
7047
7048 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7049 -- rather than raising an exception since we do not want someone
7050 -- to crash a remote partition by sending invalid subprogram ids.
7051 -- This is consistent with the other parts of the case statement
7052 -- since even in presence of incorrect parameters in the stream,
7053 -- every exception will be caught and (if the subprogram is not an
7054 -- APC) put into the result stream and sent away.
7055
7056 Append_To (Pkg_RPC_Receiver_Cases,
7057 Make_Case_Statement_Alternative (Loc,
7058 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
7059 Statements => New_List (Make_Null_Statement (Loc))));
7060
7061 Append_To (Pkg_RPC_Receiver_Statements,
7062 Make_Case_Statement (Loc,
7063 Expression => New_Occurrence_Of (Subp_Index, Loc),
7064 Alternatives => Pkg_RPC_Receiver_Cases));
7065
7066 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7067 -- analyze it.
7068
7069 Append_To (Decls, Pkg_RPC_Receiver_Body);
7070 Analyze (Last (Decls));
7071
7072 Pkg_RPC_Receiver_Object :=
7073 Make_Object_Declaration (Loc,
7074 Defining_Identifier => Make_Temporary (Loc, 'R'),
7075 Aliased_Present => True,
7076 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
7077 Append_To (Decls, Pkg_RPC_Receiver_Object);
7078 Analyze (Last (Decls));
7079
7080 -- Name
7081
7082 Append_To (Register_Pkg_Actuals,
7083 Make_String_Literal (Loc,
7084 Strval =>
7085 Fully_Qualified_Name_String
7086 (Defining_Entity (Pkg_Spec), Append_NUL => False)));
7087
7088 -- Version
7089
7090 Append_To (Register_Pkg_Actuals,
7091 Make_Attribute_Reference (Loc,
7092 Prefix =>
7093 New_Occurrence_Of
7094 (Defining_Entity (Pkg_Spec), Loc),
7095 Attribute_Name => Name_Version));
7096
7097 -- Handler
7098
7099 Append_To (Register_Pkg_Actuals,
7100 Make_Attribute_Reference (Loc,
7101 Prefix =>
7102 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
7103 Attribute_Name => Name_Access));
7104
7105 -- Receiver
7106
7107 Append_To (Register_Pkg_Actuals,
7108 Make_Attribute_Reference (Loc,
7109 Prefix =>
7110 New_Occurrence_Of (
7111 Defining_Identifier (Pkg_RPC_Receiver_Object), Loc),
7112 Attribute_Name => Name_Access));
7113
7114 -- Subp_Info
7115
7116 Append_To (Register_Pkg_Actuals,
7117 Make_Attribute_Reference (Loc,
7118 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7119 Attribute_Name => Name_Address));
7120
7121 -- Subp_Info_Len
7122
7123 Append_To (Register_Pkg_Actuals,
7124 Make_Attribute_Reference (Loc,
7125 Prefix => New_Occurrence_Of (Subp_Info_Array, Loc),
7126 Attribute_Name => Name_Length));
7127
7128 -- Is_All_Calls_Remote
7129
7130 Append_To (Register_Pkg_Actuals,
7131 New_Occurrence_Of (All_Calls_Remote_E, Loc));
7132
7133 -- Finally call Register_Pkg_Receiving_Stub with the above parameters
7134
7135 Append_To (Stmts,
7136 Make_Procedure_Call_Statement (Loc,
7137 Name =>
7138 New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
7139 Parameter_Associations => Register_Pkg_Actuals));
7140 Analyze (Last (Stmts));
7141 end Add_Receiving_Stubs_To_Declarations;
7142
7143 ---------------------------------
7144 -- Build_General_Calling_Stubs --
7145 ---------------------------------
7146
7147 procedure Build_General_Calling_Stubs
7148 (Decls : List_Id;
7149 Statements : List_Id;
7150 Target_Object : Node_Id;
7151 Subprogram_Id : Node_Id;
7152 Asynchronous : Node_Id := Empty;
7153 Is_Known_Asynchronous : Boolean := False;
7154 Is_Known_Non_Asynchronous : Boolean := False;
7155 Is_Function : Boolean;
7156 Spec : Node_Id;
7157 Stub_Type : Entity_Id := Empty;
7158 RACW_Type : Entity_Id := Empty;
7159 Nod : Node_Id)
7160 is
7161 Loc : constant Source_Ptr := Sloc (Nod);
7162
7163 Request : constant Entity_Id := Make_Temporary (Loc, 'R');
7164 -- The request object constructed by these stubs
7165 -- Could we use Name_R instead??? (see GLADE client stubs)
7166
7167 function Make_Request_RTE_Call
7168 (RE : RE_Id;
7169 Actuals : List_Id := New_List) return Node_Id;
7170 -- Generate a procedure call statement calling RE with the given
7171 -- actuals. Request'Access is appended to the list.
7172
7173 ---------------------------
7174 -- Make_Request_RTE_Call --
7175 ---------------------------
7176
7177 function Make_Request_RTE_Call
7178 (RE : RE_Id;
7179 Actuals : List_Id := New_List) return Node_Id
7180 is
7181 begin
7182 Append_To (Actuals,
7183 Make_Attribute_Reference (Loc,
7184 Prefix => New_Occurrence_Of (Request, Loc),
7185 Attribute_Name => Name_Access));
7186 return Make_Procedure_Call_Statement (Loc,
7187 Name =>
7188 New_Occurrence_Of (RTE (RE), Loc),
7189 Parameter_Associations => Actuals);
7190 end Make_Request_RTE_Call;
7191
7192 Arguments : Node_Id;
7193 -- Name of the named values list used to transmit parameters
7194 -- to the remote package
7195
7196 Result : Node_Id;
7197 -- Name of the result named value (in non-APC cases) which get the
7198 -- result of the remote subprogram.
7199
7200 Result_TC : Node_Id;
7201 -- Typecode expression for the result of the request (void
7202 -- typecode for procedures).
7203
7204 Exception_Return_Parameter : Node_Id;
7205 -- Name of the parameter which will hold the exception sent by the
7206 -- remote subprogram.
7207
7208 Current_Parameter : Node_Id;
7209 -- Current parameter being handled
7210
7211 Ordered_Parameters_List : constant List_Id :=
7212 Build_Ordered_Parameters_List (Spec);
7213
7214 Asynchronous_P : Node_Id;
7215 -- A Boolean expression indicating whether this call is asynchronous
7216
7217 Asynchronous_Statements : List_Id := No_List;
7218 Non_Asynchronous_Statements : List_Id := No_List;
7219 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7220
7221 Extra_Formal_Statements : constant List_Id := New_List;
7222 -- List of statements for extra formal parameters. It will appear
7223 -- after the regular statements for writing out parameters.
7224
7225 After_Statements : constant List_Id := New_List;
7226 -- Statements to be executed after call returns (to assign IN OUT or
7227 -- OUT parameter values).
7228
7229 Etyp : Entity_Id;
7230 -- The type of the formal parameter being processed
7231
7232 Is_Controlling_Formal : Boolean;
7233 Is_First_Controlling_Formal : Boolean;
7234 First_Controlling_Formal_Seen : Boolean := False;
7235 -- Controlling formal parameters of distributed object primitives
7236 -- require special handling, and the first such parameter needs even
7237 -- more special handling.
7238
7239 begin
7240 -- ??? document general form of stub subprograms for the PolyORB case
7241
7242 Append_To (Decls,
7243 Make_Object_Declaration (Loc,
7244 Defining_Identifier => Request,
7245 Aliased_Present => True,
7246 Object_Definition =>
7247 New_Occurrence_Of (RTE (RE_Request), Loc)));
7248
7249 Result := Make_Temporary (Loc, 'R');
7250
7251 if Is_Function then
7252 Result_TC :=
7253 PolyORB_Support.Helpers.Build_TypeCode_Call
7254 (Loc, Etype (Result_Definition (Spec)), Decls);
7255 else
7256 Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
7257 end if;
7258
7259 Append_To (Decls,
7260 Make_Object_Declaration (Loc,
7261 Defining_Identifier => Result,
7262 Aliased_Present => False,
7263 Object_Definition =>
7264 New_Occurrence_Of (RTE (RE_NamedValue), Loc),
7265 Expression =>
7266 Make_Aggregate (Loc,
7267 Component_Associations => New_List (
7268 Make_Component_Association (Loc,
7269 Choices => New_List (Make_Identifier (Loc, Name_Name)),
7270 Expression =>
7271 New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
7272 Make_Component_Association (Loc,
7273 Choices => New_List (
7274 Make_Identifier (Loc, Name_Argument)),
7275 Expression =>
7276 Make_Function_Call (Loc,
7277 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7278 Parameter_Associations => New_List (Result_TC))),
7279 Make_Component_Association (Loc,
7280 Choices => New_List (
7281 Make_Identifier (Loc, Name_Arg_Modes)),
7282 Expression => Make_Integer_Literal (Loc, 0))))));
7283
7284 if not Is_Known_Asynchronous then
7285 Exception_Return_Parameter := Make_Temporary (Loc, 'E');
7286
7287 Append_To (Decls,
7288 Make_Object_Declaration (Loc,
7289 Defining_Identifier => Exception_Return_Parameter,
7290 Object_Definition =>
7291 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
7292
7293 else
7294 Exception_Return_Parameter := Empty;
7295 end if;
7296
7297 -- Initialize and fill in arguments list
7298
7299 Arguments := Make_Temporary (Loc, 'A');
7300 Declare_Create_NVList (Loc, Arguments, Decls, Statements);
7301
7302 Current_Parameter := First (Ordered_Parameters_List);
7303 while Present (Current_Parameter) loop
7304 if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
7305 Is_Controlling_Formal := True;
7306 Is_First_Controlling_Formal :=
7307 not First_Controlling_Formal_Seen;
7308 First_Controlling_Formal_Seen := True;
7309
7310 else
7311 Is_Controlling_Formal := False;
7312 Is_First_Controlling_Formal := False;
7313 end if;
7314
7315 if Is_Controlling_Formal then
7316
7317 -- For a controlling formal argument, we send its reference
7318
7319 Etyp := RACW_Type;
7320
7321 else
7322 Etyp := Etype (Parameter_Type (Current_Parameter));
7323 end if;
7324
7325 -- The first controlling formal parameter is treated specially:
7326 -- it is used to set the target object of the call.
7327
7328 if not Is_First_Controlling_Formal then
7329 declare
7330 Constrained : constant Boolean :=
7331 Is_Constrained (Etyp)
7332 or else Is_Elementary_Type (Etyp);
7333
7334 Any : constant Entity_Id := Make_Temporary (Loc, 'A');
7335
7336 Actual_Parameter : Node_Id :=
7337 New_Occurrence_Of (
7338 Defining_Identifier (
7339 Current_Parameter), Loc);
7340
7341 Expr : Node_Id;
7342
7343 begin
7344 if Is_Controlling_Formal then
7345
7346 -- For a controlling formal parameter (other than the
7347 -- first one), use the corresponding RACW. If the
7348 -- parameter is not an anonymous access parameter, that
7349 -- involves taking its 'Unrestricted_Access.
7350
7351 if Nkind (Parameter_Type (Current_Parameter))
7352 = N_Access_Definition
7353 then
7354 Actual_Parameter := OK_Convert_To
7355 (Etyp, Actual_Parameter);
7356 else
7357 Actual_Parameter := OK_Convert_To (Etyp,
7358 Make_Attribute_Reference (Loc,
7359 Prefix => Actual_Parameter,
7360 Attribute_Name => Name_Unrestricted_Access));
7361 end if;
7362
7363 end if;
7364
7365 if In_Present (Current_Parameter)
7366 or else not Out_Present (Current_Parameter)
7367 or else not Constrained
7368 or else Is_Controlling_Formal
7369 then
7370 -- The parameter has an input value, is constrained at
7371 -- runtime by an input value, or is a controlling formal
7372 -- parameter (always passed as a reference) other than
7373 -- the first one.
7374
7375 Expr := PolyORB_Support.Helpers.Build_To_Any_Call
7376 (Loc, Actual_Parameter, Decls);
7377
7378 else
7379 Expr := Make_Function_Call (Loc,
7380 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7381 Parameter_Associations => New_List (
7382 PolyORB_Support.Helpers.Build_TypeCode_Call
7383 (Loc, Etyp, Decls)));
7384 end if;
7385
7386 Append_To (Decls,
7387 Make_Object_Declaration (Loc,
7388 Defining_Identifier => Any,
7389 Aliased_Present => False,
7390 Object_Definition =>
7391 New_Occurrence_Of (RTE (RE_Any), Loc),
7392 Expression => Expr));
7393
7394 Append_To (Statements,
7395 Add_Parameter_To_NVList (Loc,
7396 Parameter => Current_Parameter,
7397 NVList => Arguments,
7398 Constrained => Constrained,
7399 Any => Any));
7400
7401 if Out_Present (Current_Parameter)
7402 and then not Is_Controlling_Formal
7403 then
7404 if Is_Limited_Type (Etyp) then
7405 Helpers.Assign_Opaque_From_Any (Loc,
7406 Stms => After_Statements,
7407 Typ => Etyp,
7408 N => New_Occurrence_Of (Any, Loc),
7409 Target =>
7410 Defining_Identifier (Current_Parameter),
7411 Constrained => True);
7412
7413 else
7414 Append_To (After_Statements,
7415 Make_Assignment_Statement (Loc,
7416 Name =>
7417 New_Occurrence_Of (
7418 Defining_Identifier (Current_Parameter), Loc),
7419 Expression =>
7420 PolyORB_Support.Helpers.Build_From_Any_Call
7421 (Etyp,
7422 New_Occurrence_Of (Any, Loc),
7423 Decls)));
7424 end if;
7425 end if;
7426 end;
7427 end if;
7428
7429 -- If the current parameter has a dynamic constrained status, then
7430 -- this status is transmitted as well.
7431
7432 -- This should be done for accessibility as well ???
7433
7434 if Nkind (Parameter_Type (Current_Parameter)) /=
7435 N_Access_Definition
7436 and then Need_Extra_Constrained (Current_Parameter)
7437 then
7438 -- In this block, we do not use the extra formal that has been
7439 -- created because it does not exist at the time of expansion
7440 -- when building calling stubs for remote access to subprogram
7441 -- types. We create an extra variable of this type and push it
7442 -- in the stream after the regular parameters.
7443
7444 declare
7445 Extra_Any_Parameter : constant Entity_Id :=
7446 Make_Temporary (Loc, 'P');
7447
7448 Parameter_Exp : constant Node_Id :=
7449 Make_Attribute_Reference (Loc,
7450 Prefix => New_Occurrence_Of (
7451 Defining_Identifier (Current_Parameter), Loc),
7452 Attribute_Name => Name_Constrained);
7453
7454 begin
7455 Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
7456
7457 Append_To (Decls,
7458 Make_Object_Declaration (Loc,
7459 Defining_Identifier => Extra_Any_Parameter,
7460 Aliased_Present => False,
7461 Object_Definition =>
7462 New_Occurrence_Of (RTE (RE_Any), Loc),
7463 Expression =>
7464 PolyORB_Support.Helpers.Build_To_Any_Call
7465 (Loc, Parameter_Exp, Decls)));
7466
7467 Append_To (Extra_Formal_Statements,
7468 Add_Parameter_To_NVList (Loc,
7469 Parameter => Extra_Any_Parameter,
7470 NVList => Arguments,
7471 Constrained => True,
7472 Any => Extra_Any_Parameter));
7473 end;
7474 end if;
7475
7476 Next (Current_Parameter);
7477 end loop;
7478
7479 -- Append the formal statements list to the statements
7480
7481 Append_List_To (Statements, Extra_Formal_Statements);
7482
7483 Append_To (Statements,
7484 Make_Procedure_Call_Statement (Loc,
7485 Name =>
7486 New_Occurrence_Of (RTE (RE_Request_Setup), Loc),
7487 Parameter_Associations => New_List (
7488 New_Occurrence_Of (Request, Loc),
7489 Target_Object,
7490 Subprogram_Id,
7491 New_Occurrence_Of (Arguments, Loc),
7492 New_Occurrence_Of (Result, Loc),
7493 New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
7494
7495 pragma Assert
7496 (not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
7497
7498 if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
7499 Asynchronous_P :=
7500 New_Occurrence_Of
7501 (Boolean_Literals (Is_Known_Asynchronous), Loc);
7502
7503 else
7504 pragma Assert (Present (Asynchronous));
7505 Asynchronous_P := New_Copy_Tree (Asynchronous);
7506
7507 -- The expression node Asynchronous will be used to build an 'if'
7508 -- statement at the end of Build_General_Calling_Stubs: we need to
7509 -- make a copy here.
7510 end if;
7511
7512 Append_To (Parameter_Associations (Last (Statements)),
7513 Make_Indexed_Component (Loc,
7514 Prefix =>
7515 New_Occurrence_Of (
7516 RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
7517 Expressions => New_List (Asynchronous_P)));
7518
7519 Append_To (Statements, Make_Request_RTE_Call (RE_Request_Invoke));
7520
7521 -- Asynchronous case
7522
7523 if not Is_Known_Non_Asynchronous then
7524 Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
7525 end if;
7526
7527 -- Non-asynchronous case
7528
7529 if not Is_Known_Asynchronous then
7530 -- Reraise an exception occurrence from the completed request.
7531 -- If the exception occurrence is empty, this is a no-op.
7532
7533 Non_Asynchronous_Statements := New_List (
7534 Make_Procedure_Call_Statement (Loc,
7535 Name =>
7536 New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
7537 Parameter_Associations => New_List (
7538 New_Occurrence_Of (Request, Loc))));
7539
7540 if Is_Function then
7541 -- If this is a function call, read the value and return it
7542
7543 Append_To (Non_Asynchronous_Statements,
7544 Make_Tag_Check (Loc,
7545 Make_Simple_Return_Statement (Loc,
7546 PolyORB_Support.Helpers.Build_From_Any_Call
7547 (Etype (Result_Definition (Spec)),
7548 Make_Selected_Component (Loc,
7549 Prefix => Result,
7550 Selector_Name => Name_Argument),
7551 Decls))));
7552
7553 else
7554
7555 -- Case of a procedure: deal with IN OUT and OUT formals
7556
7557 Append_List_To (Non_Asynchronous_Statements, After_Statements);
7558 end if;
7559 end if;
7560
7561 if Is_Known_Asynchronous then
7562 Append_List_To (Statements, Asynchronous_Statements);
7563
7564 elsif Is_Known_Non_Asynchronous then
7565 Append_List_To (Statements, Non_Asynchronous_Statements);
7566
7567 else
7568 pragma Assert (Present (Asynchronous));
7569 Append_To (Statements,
7570 Make_Implicit_If_Statement (Nod,
7571 Condition => Asynchronous,
7572 Then_Statements => Asynchronous_Statements,
7573 Else_Statements => Non_Asynchronous_Statements));
7574 end if;
7575 end Build_General_Calling_Stubs;
7576
7577 -----------------------
7578 -- Build_Stub_Target --
7579 -----------------------
7580
7581 function Build_Stub_Target
7582 (Loc : Source_Ptr;
7583 Decls : List_Id;
7584 RCI_Locator : Entity_Id;
7585 Controlling_Parameter : Entity_Id) return RPC_Target
7586 is
7587 Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
7588 Target_Reference : constant Entity_Id := Make_Temporary (Loc, 'T');
7589
7590 begin
7591 if Present (Controlling_Parameter) then
7592 Append_To (Decls,
7593 Make_Object_Declaration (Loc,
7594 Defining_Identifier => Target_Reference,
7595
7596 Object_Definition =>
7597 New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
7598
7599 Expression =>
7600 Make_Function_Call (Loc,
7601 Name =>
7602 New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
7603 Parameter_Associations => New_List (
7604 Make_Selected_Component (Loc,
7605 Prefix => Controlling_Parameter,
7606 Selector_Name => Name_Target)))));
7607
7608 -- Note: Controlling_Parameter has the same components as
7609 -- System.Partition_Interface.RACW_Stub_Type.
7610
7611 Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
7612
7613 else
7614 Target_Info.Object :=
7615 Make_Selected_Component (Loc,
7616 Prefix =>
7617 Make_Identifier (Loc, Chars (RCI_Locator)),
7618 Selector_Name =>
7619 Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
7620 end if;
7621
7622 return Target_Info;
7623 end Build_Stub_Target;
7624
7625 -----------------------------
7626 -- Build_RPC_Receiver_Body --
7627 -----------------------------
7628
7629 procedure Build_RPC_Receiver_Body
7630 (RPC_Receiver : Entity_Id;
7631 Request : out Entity_Id;
7632 Subp_Id : out Entity_Id;
7633 Subp_Index : out Entity_Id;
7634 Stmts : out List_Id;
7635 Decl : out Node_Id)
7636 is
7637 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
7638
7639 RPC_Receiver_Spec : Node_Id;
7640 RPC_Receiver_Decls : List_Id;
7641
7642 begin
7643 Request := Make_Defining_Identifier (Loc, Name_R);
7644
7645 RPC_Receiver_Spec :=
7646 Build_RPC_Receiver_Specification
7647 (RPC_Receiver => RPC_Receiver,
7648 Request_Parameter => Request);
7649
7650 Subp_Id := Make_Defining_Identifier (Loc, Name_P);
7651 Subp_Index := Make_Defining_Identifier (Loc, Name_I);
7652
7653 RPC_Receiver_Decls := New_List (
7654 Make_Object_Renaming_Declaration (Loc,
7655 Defining_Identifier => Subp_Id,
7656 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
7657 Name =>
7658 Make_Explicit_Dereference (Loc,
7659 Prefix =>
7660 Make_Selected_Component (Loc,
7661 Prefix => Request,
7662 Selector_Name => Name_Operation))),
7663
7664 Make_Object_Declaration (Loc,
7665 Defining_Identifier => Subp_Index,
7666 Object_Definition =>
7667 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7668 Expression =>
7669 Make_Attribute_Reference (Loc,
7670 Prefix =>
7671 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
7672 Attribute_Name => Name_Last)));
7673
7674 Stmts := New_List;
7675
7676 Decl :=
7677 Make_Subprogram_Body (Loc,
7678 Specification => RPC_Receiver_Spec,
7679 Declarations => RPC_Receiver_Decls,
7680 Handled_Statement_Sequence =>
7681 Make_Handled_Sequence_Of_Statements (Loc,
7682 Statements => Stmts));
7683 end Build_RPC_Receiver_Body;
7684
7685 --------------------------------------
7686 -- Build_Subprogram_Receiving_Stubs --
7687 --------------------------------------
7688
7689 function Build_Subprogram_Receiving_Stubs
7690 (Vis_Decl : Node_Id;
7691 Asynchronous : Boolean;
7692 Dynamically_Asynchronous : Boolean := False;
7693 Stub_Type : Entity_Id := Empty;
7694 RACW_Type : Entity_Id := Empty;
7695 Parent_Primitive : Entity_Id := Empty) return Node_Id
7696 is
7697 Loc : constant Source_Ptr := Sloc (Vis_Decl);
7698
7699 Request_Parameter : constant Entity_Id := Make_Temporary (Loc, 'R');
7700 -- Formal parameter for receiving stubs: a descriptor for an incoming
7701 -- request.
7702
7703 Outer_Decls : constant List_Id := New_List;
7704 -- At the outermost level, an NVList and Any's are declared for all
7705 -- parameters. The Dynamic_Async flag also needs to be declared there
7706 -- to be visible from the exception handling code.
7707
7708 Outer_Statements : constant List_Id := New_List;
7709 -- Statements that occur prior to the declaration of the actual
7710 -- parameter variables.
7711
7712 Outer_Extra_Formal_Statements : constant List_Id := New_List;
7713 -- Statements concerning extra formal parameters, prior to the
7714 -- declaration of the actual parameter variables.
7715
7716 Decls : constant List_Id := New_List;
7717 -- All the parameters will get declared before calling the real
7718 -- subprograms. Also the out parameters will be declared. At this
7719 -- level, parameters may be unconstrained.
7720
7721 Statements : constant List_Id := New_List;
7722
7723 After_Statements : constant List_Id := New_List;
7724 -- Statements to be executed after the subprogram call
7725
7726 Inner_Decls : List_Id := No_List;
7727 -- In case of a function, the inner declarations are needed since
7728 -- the result may be unconstrained.
7729
7730 Excep_Handlers : List_Id := No_List;
7731
7732 Parameter_List : constant List_Id := New_List;
7733 -- List of parameters to be passed to the subprogram
7734
7735 First_Controlling_Formal_Seen : Boolean := False;
7736
7737 Current_Parameter : Node_Id;
7738
7739 Ordered_Parameters_List : constant List_Id :=
7740 Build_Ordered_Parameters_List
7741 (Specification (Vis_Decl));
7742
7743 Arguments : constant Entity_Id := Make_Temporary (Loc, 'A');
7744 -- Name of the named values list used to retrieve parameters
7745
7746 Subp_Spec : Node_Id;
7747 -- Subprogram specification
7748
7749 Called_Subprogram : Node_Id;
7750 -- The subprogram to call
7751
7752 begin
7753 if Present (RACW_Type) then
7754 Called_Subprogram :=
7755 New_Occurrence_Of (Parent_Primitive, Loc);
7756 else
7757 Called_Subprogram :=
7758 New_Occurrence_Of
7759 (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
7760 end if;
7761
7762 Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
7763
7764 -- Loop through every parameter and get its value from the stream. If
7765 -- the parameter is unconstrained, then the parameter is read using
7766 -- 'Input at the point of declaration.
7767
7768 Current_Parameter := First (Ordered_Parameters_List);
7769 while Present (Current_Parameter) loop
7770 declare
7771 Etyp : Entity_Id;
7772 Constrained : Boolean;
7773 Any : Entity_Id := Empty;
7774 Object : constant Entity_Id := Make_Temporary (Loc, 'P');
7775 Expr : Node_Id := Empty;
7776
7777 Is_Controlling_Formal : constant Boolean :=
7778 Is_RACW_Controlling_Formal
7779 (Current_Parameter, Stub_Type);
7780
7781 Is_First_Controlling_Formal : Boolean := False;
7782
7783 Need_Extra_Constrained : Boolean;
7784 -- True when an extra constrained actual is required
7785
7786 begin
7787 if Is_Controlling_Formal then
7788
7789 -- Controlling formals in distributed object primitive
7790 -- operations are handled specially:
7791
7792 -- - the first controlling formal is used as the
7793 -- target of the call;
7794
7795 -- - the remaining controlling formals are transmitted
7796 -- as RACWs.
7797
7798 Etyp := RACW_Type;
7799 Is_First_Controlling_Formal :=
7800 not First_Controlling_Formal_Seen;
7801 First_Controlling_Formal_Seen := True;
7802
7803 else
7804 Etyp := Etype (Parameter_Type (Current_Parameter));
7805 end if;
7806
7807 Constrained :=
7808 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
7809
7810 if not Is_First_Controlling_Formal then
7811 Any := Make_Temporary (Loc, 'A');
7812
7813 Append_To (Outer_Decls,
7814 Make_Object_Declaration (Loc,
7815 Defining_Identifier => Any,
7816 Object_Definition =>
7817 New_Occurrence_Of (RTE (RE_Any), Loc),
7818 Expression =>
7819 Make_Function_Call (Loc,
7820 Name => New_Occurrence_Of (RTE (RE_Create_Any), Loc),
7821 Parameter_Associations => New_List (
7822 PolyORB_Support.Helpers.Build_TypeCode_Call
7823 (Loc, Etyp, Outer_Decls)))));
7824
7825 Append_To (Outer_Statements,
7826 Add_Parameter_To_NVList (Loc,
7827 Parameter => Current_Parameter,
7828 NVList => Arguments,
7829 Constrained => Constrained,
7830 Any => Any));
7831 end if;
7832
7833 if Is_First_Controlling_Formal then
7834 declare
7835 Addr : constant Entity_Id := Make_Temporary (Loc, 'A');
7836
7837 Is_Local : constant Entity_Id :=
7838 Make_Temporary (Loc, 'L');
7839
7840 begin
7841 -- Special case: obtain the first controlling formal
7842 -- from the target of the remote call, instead of the
7843 -- argument list.
7844
7845 Append_To (Outer_Decls,
7846 Make_Object_Declaration (Loc,
7847 Defining_Identifier => Addr,
7848 Object_Definition =>
7849 New_Occurrence_Of (RTE (RE_Address), Loc)));
7850
7851 Append_To (Outer_Decls,
7852 Make_Object_Declaration (Loc,
7853 Defining_Identifier => Is_Local,
7854 Object_Definition =>
7855 New_Occurrence_Of (Standard_Boolean, Loc)));
7856
7857 Append_To (Outer_Statements,
7858 Make_Procedure_Call_Statement (Loc,
7859 Name =>
7860 New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
7861 Parameter_Associations => New_List (
7862 Make_Selected_Component (Loc,
7863 Prefix =>
7864 New_Occurrence_Of (
7865 Request_Parameter, Loc),
7866 Selector_Name =>
7867 Make_Identifier (Loc, Name_Target)),
7868 New_Occurrence_Of (Is_Local, Loc),
7869 New_Occurrence_Of (Addr, Loc))));
7870
7871 Expr := Unchecked_Convert_To (RACW_Type,
7872 New_Occurrence_Of (Addr, Loc));
7873 end;
7874
7875 elsif In_Present (Current_Parameter)
7876 or else not Out_Present (Current_Parameter)
7877 or else not Constrained
7878 then
7879 -- If an input parameter is constrained, then its reading is
7880 -- deferred until the beginning of the subprogram body. If
7881 -- it is unconstrained, then an expression is built for
7882 -- the object declaration and the variable is set using
7883 -- 'Input instead of 'Read.
7884
7885 if Constrained and then Is_Limited_Type (Etyp) then
7886 Helpers.Assign_Opaque_From_Any (Loc,
7887 Stms => Statements,
7888 Typ => Etyp,
7889 N => New_Occurrence_Of (Any, Loc),
7890 Target => Object);
7891
7892 else
7893 Expr := Helpers.Build_From_Any_Call
7894 (Etyp, New_Occurrence_Of (Any, Loc), Decls);
7895
7896 if Constrained then
7897 Append_To (Statements,
7898 Make_Assignment_Statement (Loc,
7899 Name => New_Occurrence_Of (Object, Loc),
7900 Expression => Expr));
7901 Expr := Empty;
7902
7903 else
7904 -- Expr will be used to initialize (and constrain) the
7905 -- parameter when it is declared.
7906 null;
7907 end if;
7908
7909 null;
7910 end if;
7911 end if;
7912
7913 Need_Extra_Constrained :=
7914 Nkind (Parameter_Type (Current_Parameter)) /=
7915 N_Access_Definition
7916 and then
7917 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
7918 and then
7919 Present (Extra_Constrained
7920 (Defining_Identifier (Current_Parameter)));
7921
7922 -- We may not associate an extra constrained actual to a
7923 -- constant object, so if one is needed, declare the actual
7924 -- as a variable even if it won't be modified.
7925
7926 Build_Actual_Object_Declaration
7927 (Object => Object,
7928 Etyp => Etyp,
7929 Variable => Need_Extra_Constrained
7930 or else Out_Present (Current_Parameter),
7931 Expr => Expr,
7932 Decls => Decls);
7933 Set_Etype (Object, Etyp);
7934
7935 -- An out parameter may be written back using a 'Write
7936 -- attribute instead of a 'Output because it has been
7937 -- constrained by the parameter given to the caller. Note that
7938 -- OUT controlling arguments in the case of a RACW are not put
7939 -- back in the stream because the pointer on them has not
7940 -- changed.
7941
7942 if Out_Present (Current_Parameter)
7943 and then not Is_Controlling_Formal
7944 then
7945 Append_To (After_Statements,
7946 Make_Procedure_Call_Statement (Loc,
7947 Name => New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
7948 Parameter_Associations => New_List (
7949 New_Occurrence_Of (Any, Loc),
7950 PolyORB_Support.Helpers.Build_To_Any_Call
7951 (Loc,
7952 New_Occurrence_Of (Object, Loc),
7953 Decls,
7954 Constrained => True))));
7955 end if;
7956
7957 -- For RACW controlling formals, the Etyp of Object is always
7958 -- an RACW, even if the parameter is not of an anonymous access
7959 -- type. In such case, we need to dereference it at call time.
7960
7961 if Is_Controlling_Formal then
7962 if Nkind (Parameter_Type (Current_Parameter)) /=
7963 N_Access_Definition
7964 then
7965 Append_To (Parameter_List,
7966 Make_Parameter_Association (Loc,
7967 Selector_Name =>
7968 New_Occurrence_Of
7969 (Defining_Identifier (Current_Parameter), Loc),
7970 Explicit_Actual_Parameter =>
7971 Make_Explicit_Dereference (Loc,
7972 Prefix => New_Occurrence_Of (Object, Loc))));
7973
7974 else
7975 Append_To (Parameter_List,
7976 Make_Parameter_Association (Loc,
7977 Selector_Name =>
7978 New_Occurrence_Of
7979 (Defining_Identifier (Current_Parameter), Loc),
7980
7981 Explicit_Actual_Parameter =>
7982 New_Occurrence_Of (Object, Loc)));
7983 end if;
7984
7985 else
7986 Append_To (Parameter_List,
7987 Make_Parameter_Association (Loc,
7988 Selector_Name =>
7989 New_Occurrence_Of (
7990 Defining_Identifier (Current_Parameter), Loc),
7991 Explicit_Actual_Parameter =>
7992 New_Occurrence_Of (Object, Loc)));
7993 end if;
7994
7995 -- If the current parameter needs an extra formal, then read it
7996 -- from the stream and set the corresponding semantic field in
7997 -- the variable. If the kind of the parameter identifier is
7998 -- E_Void, then this is a compiler generated parameter that
7999 -- doesn't need an extra constrained status.
8000
8001 -- The case of Extra_Accessibility should also be handled ???
8002
8003 if Need_Extra_Constrained then
8004 declare
8005 Extra_Parameter : constant Entity_Id :=
8006 Extra_Constrained
8007 (Defining_Identifier
8008 (Current_Parameter));
8009
8010 Extra_Any : constant Entity_Id :=
8011 Make_Temporary (Loc, 'A');
8012
8013 Formal_Entity : constant Entity_Id :=
8014 Make_Defining_Identifier (Loc,
8015 Chars => Chars (Extra_Parameter));
8016
8017 Formal_Type : constant Entity_Id :=
8018 Etype (Extra_Parameter);
8019
8020 begin
8021 Append_To (Outer_Decls,
8022 Make_Object_Declaration (Loc,
8023 Defining_Identifier => Extra_Any,
8024 Object_Definition =>
8025 New_Occurrence_Of (RTE (RE_Any), Loc),
8026 Expression =>
8027 Make_Function_Call (Loc,
8028 Name =>
8029 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
8030 Parameter_Associations => New_List (
8031 PolyORB_Support.Helpers.Build_TypeCode_Call
8032 (Loc, Formal_Type, Outer_Decls)))));
8033
8034 Append_To (Outer_Extra_Formal_Statements,
8035 Add_Parameter_To_NVList (Loc,
8036 Parameter => Extra_Parameter,
8037 NVList => Arguments,
8038 Constrained => True,
8039 Any => Extra_Any));
8040
8041 Append_To (Decls,
8042 Make_Object_Declaration (Loc,
8043 Defining_Identifier => Formal_Entity,
8044 Object_Definition =>
8045 New_Occurrence_Of (Formal_Type, Loc)));
8046
8047 Append_To (Statements,
8048 Make_Assignment_Statement (Loc,
8049 Name => New_Occurrence_Of (Formal_Entity, Loc),
8050 Expression =>
8051 PolyORB_Support.Helpers.Build_From_Any_Call
8052 (Formal_Type,
8053 New_Occurrence_Of (Extra_Any, Loc),
8054 Decls)));
8055 Set_Extra_Constrained (Object, Formal_Entity);
8056 end;
8057 end if;
8058 end;
8059
8060 Next (Current_Parameter);
8061 end loop;
8062
8063 -- Extra Formals should go after all the other parameters
8064
8065 Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
8066
8067 Append_To (Outer_Statements,
8068 Make_Procedure_Call_Statement (Loc,
8069 Name => New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
8070 Parameter_Associations => New_List (
8071 New_Occurrence_Of (Request_Parameter, Loc),
8072 New_Occurrence_Of (Arguments, Loc))));
8073
8074 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
8075
8076 -- The remote subprogram is a function: Build an inner block to be
8077 -- able to hold a potentially unconstrained result in a variable.
8078
8079 declare
8080 Etyp : constant Entity_Id :=
8081 Etype (Result_Definition (Specification (Vis_Decl)));
8082 Result : constant Node_Id := Make_Temporary (Loc, 'R');
8083
8084 begin
8085 Inner_Decls := New_List (
8086 Make_Object_Declaration (Loc,
8087 Defining_Identifier => Result,
8088 Constant_Present => True,
8089 Object_Definition => New_Occurrence_Of (Etyp, Loc),
8090 Expression =>
8091 Make_Function_Call (Loc,
8092 Name => Called_Subprogram,
8093 Parameter_Associations => Parameter_List)));
8094
8095 if Is_Class_Wide_Type (Etyp) then
8096
8097 -- For a remote call to a function with a class-wide type,
8098 -- check that the returned value satisfies the requirements
8099 -- of (RM E.4(18)).
8100
8101 Append_To (Inner_Decls,
8102 Make_Transportable_Check (Loc,
8103 New_Occurrence_Of (Result, Loc)));
8104
8105 end if;
8106
8107 Set_Etype (Result, Etyp);
8108 Append_To (After_Statements,
8109 Make_Procedure_Call_Statement (Loc,
8110 Name => New_Occurrence_Of (RTE (RE_Set_Result), Loc),
8111 Parameter_Associations => New_List (
8112 New_Occurrence_Of (Request_Parameter, Loc),
8113 PolyORB_Support.Helpers.Build_To_Any_Call
8114 (Loc, New_Occurrence_Of (Result, Loc), Decls))));
8115
8116 -- A DSA function does not have out or inout arguments
8117 end;
8118
8119 Append_To (Statements,
8120 Make_Block_Statement (Loc,
8121 Declarations => Inner_Decls,
8122 Handled_Statement_Sequence =>
8123 Make_Handled_Sequence_Of_Statements (Loc,
8124 Statements => After_Statements)));
8125
8126 else
8127 -- The remote subprogram is a procedure. We do not need any inner
8128 -- block in this case. No specific processing is required here for
8129 -- the dynamically asynchronous case: the indication of whether
8130 -- call is asynchronous or not is managed by the Sync_Scope
8131 -- attibute of the request, and is handled entirely in the
8132 -- protocol layer.
8133
8134 Append_To (After_Statements,
8135 Make_Procedure_Call_Statement (Loc,
8136 Name => New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
8137 Parameter_Associations => New_List (
8138 New_Occurrence_Of (Request_Parameter, Loc))));
8139
8140 Append_To (Statements,
8141 Make_Procedure_Call_Statement (Loc,
8142 Name => Called_Subprogram,
8143 Parameter_Associations => Parameter_List));
8144
8145 Append_List_To (Statements, After_Statements);
8146 end if;
8147
8148 Subp_Spec :=
8149 Make_Procedure_Specification (Loc,
8150 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
8151
8152 Parameter_Specifications => New_List (
8153 Make_Parameter_Specification (Loc,
8154 Defining_Identifier => Request_Parameter,
8155 Parameter_Type =>
8156 New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
8157
8158 -- An exception raised during the execution of an incoming remote
8159 -- subprogram call and that needs to be sent back to the caller is
8160 -- propagated by the receiving stubs, and will be handled by the
8161 -- caller (the distribution runtime).
8162
8163 if Asynchronous and then not Dynamically_Asynchronous then
8164
8165 -- For an asynchronous procedure, add a null exception handler
8166
8167 Excep_Handlers := New_List (
8168 Make_Implicit_Exception_Handler (Loc,
8169 Exception_Choices => New_List (Make_Others_Choice (Loc)),
8170 Statements => New_List (Make_Null_Statement (Loc))));
8171
8172 else
8173 -- In the other cases, if an exception is raised, then the
8174 -- exception occurrence is propagated.
8175
8176 null;
8177 end if;
8178
8179 Append_To (Outer_Statements,
8180 Make_Block_Statement (Loc,
8181 Declarations => Decls,
8182 Handled_Statement_Sequence =>
8183 Make_Handled_Sequence_Of_Statements (Loc,
8184 Statements => Statements)));
8185
8186 return
8187 Make_Subprogram_Body (Loc,
8188 Specification => Subp_Spec,
8189 Declarations => Outer_Decls,
8190 Handled_Statement_Sequence =>
8191 Make_Handled_Sequence_Of_Statements (Loc,
8192 Statements => Outer_Statements,
8193 Exception_Handlers => Excep_Handlers));
8194 end Build_Subprogram_Receiving_Stubs;
8195
8196 -------------
8197 -- Helpers --
8198 -------------
8199
8200 package body Helpers is
8201
8202 -----------------------
8203 -- Local Subprograms --
8204 -----------------------
8205
8206 function Find_Numeric_Representation
8207 (Typ : Entity_Id) return Entity_Id;
8208 -- Given a numeric type Typ, return the smallest integer or modular
8209 -- type from Interfaces, or the smallest floating point type from
8210 -- Standard whose range encompasses that of Typ.
8211
8212 function Make_Helper_Function_Name
8213 (Loc : Source_Ptr;
8214 Typ : Entity_Id;
8215 Nam : Name_Id) return Entity_Id;
8216 -- Return the name to be assigned for helper subprogram Nam of Typ
8217
8218 ------------------------------------------------------------
8219 -- Common subprograms for building various tree fragments --
8220 ------------------------------------------------------------
8221
8222 function Build_Get_Aggregate_Element
8223 (Loc : Source_Ptr;
8224 Any : Entity_Id;
8225 TC : Node_Id;
8226 Idx : Node_Id) return Node_Id;
8227 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8228 -- returning the Idx'th element.
8229
8230 generic
8231 Subprogram : Entity_Id;
8232 -- Reference location for constructed nodes
8233
8234 Arry : Entity_Id;
8235 -- For 'Range and Etype
8236
8237 Indexes : List_Id;
8238 -- For the construction of the innermost element expression
8239
8240 with procedure Add_Process_Element
8241 (Stmts : List_Id;
8242 Any : Entity_Id;
8243 Counter : Entity_Id;
8244 Datum : Node_Id);
8245
8246 procedure Append_Array_Traversal
8247 (Stmts : List_Id;
8248 Any : Entity_Id;
8249 Counter : Entity_Id := Empty;
8250 Depth : Pos := 1);
8251 -- Build nested loop statements that iterate over the elements of an
8252 -- array Arry. The statement(s) built by Add_Process_Element are
8253 -- executed for each element; Indexes is the list of indexes to be
8254 -- used in the construction of the indexed component that denotes the
8255 -- current element. Subprogram is the entity for the subprogram for
8256 -- which this iterator is generated. The generated statements are
8257 -- appended to Stmts.
8258
8259 generic
8260 Rec : Entity_Id;
8261 -- The record entity being dealt with
8262
8263 with procedure Add_Process_Element
8264 (Stmts : List_Id;
8265 Container : Node_Or_Entity_Id;
8266 Counter : in out Int;
8267 Rec : Entity_Id;
8268 Field : Node_Id);
8269 -- Rec is the instance of the record type, or Empty.
8270 -- Field is either the N_Defining_Identifier for a component,
8271 -- or an N_Variant_Part.
8272
8273 procedure Append_Record_Traversal
8274 (Stmts : List_Id;
8275 Clist : Node_Id;
8276 Container : Node_Or_Entity_Id;
8277 Counter : in out Int);
8278 -- Process component list Clist. Individual fields are passed
8279 -- to Field_Processing. Each variant part is also processed.
8280 -- Container is the outer Any (for From_Any/To_Any),
8281 -- the outer typecode (for TC) to which the operation applies.
8282
8283 -----------------------------
8284 -- Append_Record_Traversal --
8285 -----------------------------
8286
8287 procedure Append_Record_Traversal
8288 (Stmts : List_Id;
8289 Clist : Node_Id;
8290 Container : Node_Or_Entity_Id;
8291 Counter : in out Int)
8292 is
8293 CI : List_Id;
8294 VP : Node_Id;
8295 -- Clist's Component_Items and Variant_Part
8296
8297 Item : Node_Id;
8298 Def : Entity_Id;
8299
8300 begin
8301 if No (Clist) then
8302 return;
8303 end if;
8304
8305 CI := Component_Items (Clist);
8306 VP := Variant_Part (Clist);
8307
8308 Item := First (CI);
8309 while Present (Item) loop
8310 Def := Defining_Identifier (Item);
8311
8312 if not Is_Internal_Name (Chars (Def)) then
8313 Add_Process_Element
8314 (Stmts, Container, Counter, Rec, Def);
8315 end if;
8316
8317 Next (Item);
8318 end loop;
8319
8320 if Present (VP) then
8321 Add_Process_Element (Stmts, Container, Counter, Rec, VP);
8322 end if;
8323 end Append_Record_Traversal;
8324
8325 -----------------------------
8326 -- Assign_Opaque_From_Any --
8327 -----------------------------
8328
8329 procedure Assign_Opaque_From_Any
8330 (Loc : Source_Ptr;
8331 Stms : List_Id;
8332 Typ : Entity_Id;
8333 N : Node_Id;
8334 Target : Entity_Id;
8335 Constrained : Boolean := False)
8336 is
8337 Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
8338 Expr : Node_Id;
8339
8340 Read_Call_List : List_Id;
8341 -- List on which to place the 'Read attribute reference
8342
8343 begin
8344 -- Strm : Buffer_Stream_Type;
8345
8346 Append_To (Stms,
8347 Make_Object_Declaration (Loc,
8348 Defining_Identifier => Strm,
8349 Aliased_Present => True,
8350 Object_Definition =>
8351 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
8352
8353 -- Any_To_BS (Strm, A);
8354
8355 Append_To (Stms,
8356 Make_Procedure_Call_Statement (Loc,
8357 Name => New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
8358 Parameter_Associations => New_List (
8359 N,
8360 New_Occurrence_Of (Strm, Loc))));
8361
8362 if Transmit_As_Unconstrained (Typ) and then not Constrained then
8363 Expr :=
8364 Make_Attribute_Reference (Loc,
8365 Prefix => New_Occurrence_Of (Typ, Loc),
8366 Attribute_Name => Name_Input,
8367 Expressions => New_List (
8368 Make_Attribute_Reference (Loc,
8369 Prefix => New_Occurrence_Of (Strm, Loc),
8370 Attribute_Name => Name_Access)));
8371
8372 -- Target := Typ'Input (Strm'Access)
8373
8374 if Present (Target) then
8375 Append_To (Stms,
8376 Make_Assignment_Statement (Loc,
8377 Name => New_Occurrence_Of (Target, Loc),
8378 Expression => Expr));
8379
8380 -- return Typ'Input (Strm'Access);
8381
8382 else
8383 Append_To (Stms,
8384 Make_Simple_Return_Statement (Loc,
8385 Expression => Expr));
8386 end if;
8387
8388 else
8389 if Present (Target) then
8390 Read_Call_List := Stms;
8391 Expr := New_Occurrence_Of (Target, Loc);
8392
8393 else
8394 declare
8395 Temp : constant Entity_Id := Make_Temporary (Loc, 'R');
8396
8397 begin
8398 Read_Call_List := New_List;
8399 Expr := New_Occurrence_Of (Temp, Loc);
8400
8401 Append_To (Stms, Make_Block_Statement (Loc,
8402 Declarations => New_List (
8403 Make_Object_Declaration (Loc,
8404 Defining_Identifier =>
8405 Temp,
8406 Object_Definition =>
8407 New_Occurrence_Of (Typ, Loc))),
8408
8409 Handled_Statement_Sequence =>
8410 Make_Handled_Sequence_Of_Statements (Loc,
8411 Statements => Read_Call_List)));
8412 end;
8413 end if;
8414
8415 -- Typ'Read (Strm'Access, [Target|Temp])
8416
8417 Append_To (Read_Call_List,
8418 Make_Attribute_Reference (Loc,
8419 Prefix => New_Occurrence_Of (Typ, Loc),
8420 Attribute_Name => Name_Read,
8421 Expressions => New_List (
8422 Make_Attribute_Reference (Loc,
8423 Prefix => New_Occurrence_Of (Strm, Loc),
8424 Attribute_Name => Name_Access),
8425 Expr)));
8426
8427 if No (Target) then
8428
8429 -- return Temp
8430
8431 Append_To (Read_Call_List,
8432 Make_Simple_Return_Statement (Loc,
8433 Expression => New_Copy (Expr)));
8434 end if;
8435 end if;
8436 end Assign_Opaque_From_Any;
8437
8438 -------------------------
8439 -- Build_From_Any_Call --
8440 -------------------------
8441
8442 function Build_From_Any_Call
8443 (Typ : Entity_Id;
8444 N : Node_Id;
8445 Decls : List_Id) return Node_Id
8446 is
8447 Loc : constant Source_Ptr := Sloc (N);
8448
8449 U_Type : Entity_Id := Underlying_Type (Typ);
8450
8451 Fnam : Entity_Id := Empty;
8452 Lib_RE : RE_Id := RE_Null;
8453 Result : Node_Id;
8454
8455 begin
8456 -- First simple case where the From_Any function is present
8457 -- in the type's TSS.
8458
8459 Fnam := Find_Inherited_TSS (U_Type, TSS_From_Any);
8460
8461 -- For the subtype representing a generic actual type, go to the
8462 -- actual type.
8463
8464 if Is_Generic_Actual_Type (U_Type) then
8465 U_Type := Underlying_Type (Base_Type (U_Type));
8466 end if;
8467
8468 -- For a standard subtype, go to the base type
8469
8470 if Sloc (U_Type) <= Standard_Location then
8471 U_Type := Base_Type (U_Type);
8472
8473 -- For a user subtype, go to first subtype
8474
8475 elsif Comes_From_Source (U_Type)
8476 and then Nkind (Declaration_Node (U_Type))
8477 = N_Subtype_Declaration
8478 then
8479 U_Type := First_Subtype (U_Type);
8480 end if;
8481
8482 -- Check first for Boolean and Character. These are enumeration
8483 -- types, but we treat them specially, since they may require
8484 -- special handling in the transfer protocol. However, this
8485 -- special handling only applies if they have standard
8486 -- representation, otherwise they are treated like any other
8487 -- enumeration type.
8488
8489 if Present (Fnam) then
8490 null;
8491
8492 elsif U_Type = Standard_Boolean then
8493 Lib_RE := RE_FA_B;
8494
8495 elsif U_Type = Standard_Character then
8496 Lib_RE := RE_FA_C;
8497
8498 elsif U_Type = Standard_Wide_Character then
8499 Lib_RE := RE_FA_WC;
8500
8501 elsif U_Type = Standard_Wide_Wide_Character then
8502 Lib_RE := RE_FA_WWC;
8503
8504 -- Floating point types
8505
8506 elsif U_Type = Standard_Short_Float then
8507 Lib_RE := RE_FA_SF;
8508
8509 elsif U_Type = Standard_Float then
8510 Lib_RE := RE_FA_F;
8511
8512 elsif U_Type = Standard_Long_Float then
8513 Lib_RE := RE_FA_LF;
8514
8515 elsif U_Type = Standard_Long_Long_Float then
8516 Lib_RE := RE_FA_LLF;
8517
8518 -- Integer types
8519
8520 elsif U_Type = RTE (RE_Integer_8) then
8521 Lib_RE := RE_FA_I8;
8522
8523 elsif U_Type = RTE (RE_Integer_16) then
8524 Lib_RE := RE_FA_I16;
8525
8526 elsif U_Type = RTE (RE_Integer_32) then
8527 Lib_RE := RE_FA_I32;
8528
8529 elsif U_Type = RTE (RE_Integer_64) then
8530 Lib_RE := RE_FA_I64;
8531
8532 -- Unsigned integer types
8533
8534 elsif U_Type = RTE (RE_Unsigned_8) then
8535 Lib_RE := RE_FA_U8;
8536
8537 elsif U_Type = RTE (RE_Unsigned_16) then
8538 Lib_RE := RE_FA_U16;
8539
8540 elsif U_Type = RTE (RE_Unsigned_32) then
8541 Lib_RE := RE_FA_U32;
8542
8543 elsif U_Type = RTE (RE_Unsigned_64) then
8544 Lib_RE := RE_FA_U64;
8545
8546 elsif Is_RTE (U_Type, RE_Unbounded_String) then
8547 Lib_RE := RE_FA_String;
8548
8549 -- Special DSA types
8550
8551 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
8552 Lib_RE := RE_FA_A;
8553
8554 -- Other (non-primitive) types
8555
8556 else
8557 declare
8558 Decl : Entity_Id;
8559
8560 begin
8561 Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
8562 Append_To (Decls, Decl);
8563 end;
8564 end if;
8565
8566 -- Call the function
8567
8568 if Lib_RE /= RE_Null then
8569 pragma Assert (No (Fnam));
8570 Fnam := RTE (Lib_RE);
8571 end if;
8572
8573 Result :=
8574 Make_Function_Call (Loc,
8575 Name => New_Occurrence_Of (Fnam, Loc),
8576 Parameter_Associations => New_List (N));
8577
8578 -- We must set the type of Result, so the unchecked conversion
8579 -- from the underlying type to the base type is properly done.
8580
8581 Set_Etype (Result, U_Type);
8582
8583 return Unchecked_Convert_To (Typ, Result);
8584 end Build_From_Any_Call;
8585
8586 -----------------------------
8587 -- Build_From_Any_Function --
8588 -----------------------------
8589
8590 procedure Build_From_Any_Function
8591 (Loc : Source_Ptr;
8592 Typ : Entity_Id;
8593 Decl : out Node_Id;
8594 Fnam : out Entity_Id)
8595 is
8596 Spec : Node_Id;
8597 Decls : constant List_Id := New_List;
8598 Stms : constant List_Id := New_List;
8599
8600 Any_Parameter : constant Entity_Id := Make_Temporary (Loc, 'A');
8601
8602 Use_Opaque_Representation : Boolean;
8603
8604 begin
8605 -- For a derived type, we can't go past the base type (to the
8606 -- parent type) here, because that would cause the attribute's
8607 -- formal parameter to have the wrong type; hence the Base_Type
8608 -- check here.
8609
8610 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
8611 Build_From_Any_Function
8612 (Loc => Loc,
8613 Typ => Etype (Typ),
8614 Decl => Decl,
8615 Fnam => Fnam);
8616 return;
8617 end if;
8618
8619 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_From_Any);
8620
8621 Spec :=
8622 Make_Function_Specification (Loc,
8623 Defining_Unit_Name => Fnam,
8624 Parameter_Specifications => New_List (
8625 Make_Parameter_Specification (Loc,
8626 Defining_Identifier => Any_Parameter,
8627 Parameter_Type => New_Occurrence_Of (RTE (RE_Any), Loc))),
8628 Result_Definition => New_Occurrence_Of (Typ, Loc));
8629
8630 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8631
8632 pragma Assert
8633 (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
8634
8635 Use_Opaque_Representation := False;
8636
8637 if Has_Stream_Attribute_Definition
8638 (Typ, TSS_Stream_Output, At_Any_Place => True)
8639 or else
8640 Has_Stream_Attribute_Definition
8641 (Typ, TSS_Stream_Write, At_Any_Place => True)
8642 then
8643 -- If user-defined stream attributes are specified for this
8644 -- type, use them and transmit data as an opaque sequence of
8645 -- stream elements.
8646
8647 Use_Opaque_Representation := True;
8648
8649 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
8650 Append_To (Stms,
8651 Make_Simple_Return_Statement (Loc,
8652 Expression =>
8653 OK_Convert_To (Typ,
8654 Build_From_Any_Call
8655 (Root_Type (Typ),
8656 New_Occurrence_Of (Any_Parameter, Loc),
8657 Decls))));
8658
8659 elsif Is_Record_Type (Typ)
8660 and then not Is_Derived_Type (Typ)
8661 and then not Is_Tagged_Type (Typ)
8662 then
8663 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
8664 Append_To (Stms,
8665 Make_Simple_Return_Statement (Loc,
8666 Expression =>
8667 Build_From_Any_Call
8668 (Etype (Typ),
8669 New_Occurrence_Of (Any_Parameter, Loc),
8670 Decls)));
8671
8672 else
8673 declare
8674 Disc : Entity_Id := Empty;
8675 Discriminant_Associations : List_Id;
8676 Rdef : constant Node_Id :=
8677 Type_Definition
8678 (Declaration_Node (Typ));
8679 Component_Counter : Int := 0;
8680
8681 -- The returned object
8682
8683 Res : constant Entity_Id := Make_Temporary (Loc, 'R');
8684
8685 Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
8686
8687 procedure FA_Rec_Add_Process_Element
8688 (Stmts : List_Id;
8689 Any : Entity_Id;
8690 Counter : in out Int;
8691 Rec : Entity_Id;
8692 Field : Node_Id);
8693
8694 procedure FA_Append_Record_Traversal is
8695 new Append_Record_Traversal
8696 (Rec => Res,
8697 Add_Process_Element => FA_Rec_Add_Process_Element);
8698
8699 --------------------------------
8700 -- FA_Rec_Add_Process_Element --
8701 --------------------------------
8702
8703 procedure FA_Rec_Add_Process_Element
8704 (Stmts : List_Id;
8705 Any : Entity_Id;
8706 Counter : in out Int;
8707 Rec : Entity_Id;
8708 Field : Node_Id)
8709 is
8710 Ctyp : Entity_Id;
8711 begin
8712 if Nkind (Field) = N_Defining_Identifier then
8713 -- A regular component
8714
8715 Ctyp := Etype (Field);
8716
8717 Append_To (Stmts,
8718 Make_Assignment_Statement (Loc,
8719 Name => Make_Selected_Component (Loc,
8720 Prefix =>
8721 New_Occurrence_Of (Rec, Loc),
8722 Selector_Name =>
8723 New_Occurrence_Of (Field, Loc)),
8724
8725 Expression =>
8726 Build_From_Any_Call (Ctyp,
8727 Build_Get_Aggregate_Element (Loc,
8728 Any => Any,
8729 TC =>
8730 Build_TypeCode_Call (Loc, Ctyp, Decls),
8731 Idx =>
8732 Make_Integer_Literal (Loc, Counter)),
8733 Decls)));
8734
8735 else
8736 -- A variant part
8737
8738 declare
8739 Variant : Node_Id;
8740 Struct_Counter : Int := 0;
8741
8742 Block_Decls : constant List_Id := New_List;
8743 Block_Stmts : constant List_Id := New_List;
8744 VP_Stmts : List_Id;
8745
8746 Alt_List : constant List_Id := New_List;
8747 Choice_List : List_Id;
8748
8749 Struct_Any : constant Entity_Id :=
8750 Make_Temporary (Loc, 'S');
8751
8752 begin
8753 Append_To (Decls,
8754 Make_Object_Declaration (Loc,
8755 Defining_Identifier => Struct_Any,
8756 Constant_Present => True,
8757 Object_Definition =>
8758 New_Occurrence_Of (RTE (RE_Any), Loc),
8759 Expression =>
8760 Make_Function_Call (Loc,
8761 Name =>
8762 New_Occurrence_Of
8763 (RTE (RE_Extract_Union_Value), Loc),
8764
8765 Parameter_Associations => New_List (
8766 Build_Get_Aggregate_Element (Loc,
8767 Any => Any,
8768 TC =>
8769 Make_Function_Call (Loc,
8770 Name => New_Occurrence_Of (
8771 RTE (RE_Any_Member_Type), Loc),
8772 Parameter_Associations =>
8773 New_List (
8774 New_Occurrence_Of (Any, Loc),
8775 Make_Integer_Literal (Loc,
8776 Intval => Counter))),
8777 Idx =>
8778 Make_Integer_Literal (Loc,
8779 Intval => Counter))))));
8780
8781 Append_To (Stmts,
8782 Make_Block_Statement (Loc,
8783 Declarations => Block_Decls,
8784 Handled_Statement_Sequence =>
8785 Make_Handled_Sequence_Of_Statements (Loc,
8786 Statements => Block_Stmts)));
8787
8788 Append_To (Block_Stmts,
8789 Make_Case_Statement (Loc,
8790 Expression =>
8791 Make_Selected_Component (Loc,
8792 Prefix => Rec,
8793 Selector_Name => Chars (Name (Field))),
8794 Alternatives => Alt_List));
8795
8796 Variant := First_Non_Pragma (Variants (Field));
8797 while Present (Variant) loop
8798 Choice_List :=
8799 New_Copy_List_Tree
8800 (Discrete_Choices (Variant));
8801
8802 VP_Stmts := New_List;
8803
8804 -- Struct_Counter should be reset before
8805 -- handling a variant part. Indeed only one
8806 -- of the case statement alternatives will be
8807 -- executed at run time, so the counter must
8808 -- start at 0 for every case statement.
8809
8810 Struct_Counter := 0;
8811
8812 FA_Append_Record_Traversal (
8813 Stmts => VP_Stmts,
8814 Clist => Component_List (Variant),
8815 Container => Struct_Any,
8816 Counter => Struct_Counter);
8817
8818 Append_To (Alt_List,
8819 Make_Case_Statement_Alternative (Loc,
8820 Discrete_Choices => Choice_List,
8821 Statements => VP_Stmts));
8822 Next_Non_Pragma (Variant);
8823 end loop;
8824 end;
8825 end if;
8826
8827 Counter := Counter + 1;
8828 end FA_Rec_Add_Process_Element;
8829
8830 begin
8831 -- First all discriminants
8832
8833 if Has_Discriminants (Typ) then
8834 Discriminant_Associations := New_List;
8835
8836 Disc := First_Discriminant (Typ);
8837 while Present (Disc) loop
8838 declare
8839 Disc_Var_Name : constant Entity_Id :=
8840 Make_Defining_Identifier (Loc,
8841 Chars => Chars (Disc));
8842 Disc_Type : constant Entity_Id :=
8843 Etype (Disc);
8844
8845 begin
8846 Append_To (Decls,
8847 Make_Object_Declaration (Loc,
8848 Defining_Identifier => Disc_Var_Name,
8849 Constant_Present => True,
8850 Object_Definition =>
8851 New_Occurrence_Of (Disc_Type, Loc),
8852
8853 Expression =>
8854 Build_From_Any_Call (Disc_Type,
8855 Build_Get_Aggregate_Element (Loc,
8856 Any => Any_Parameter,
8857 TC => Build_TypeCode_Call
8858 (Loc, Disc_Type, Decls),
8859 Idx => Make_Integer_Literal (Loc,
8860 Intval => Component_Counter)),
8861 Decls)));
8862
8863 Component_Counter := Component_Counter + 1;
8864
8865 Append_To (Discriminant_Associations,
8866 Make_Discriminant_Association (Loc,
8867 Selector_Names => New_List (
8868 New_Occurrence_Of (Disc, Loc)),
8869 Expression =>
8870 New_Occurrence_Of (Disc_Var_Name, Loc)));
8871 end;
8872 Next_Discriminant (Disc);
8873 end loop;
8874
8875 Res_Definition :=
8876 Make_Subtype_Indication (Loc,
8877 Subtype_Mark => Res_Definition,
8878 Constraint =>
8879 Make_Index_Or_Discriminant_Constraint (Loc,
8880 Discriminant_Associations));
8881 end if;
8882
8883 -- Now we have all the discriminants in variables, we can
8884 -- declared a constrained object. Note that we are not
8885 -- initializing (non-discriminant) components directly in
8886 -- the object declarations, because which fields to
8887 -- initialize depends (at run time) on the discriminant
8888 -- values.
8889
8890 Append_To (Decls,
8891 Make_Object_Declaration (Loc,
8892 Defining_Identifier => Res,
8893 Object_Definition => Res_Definition));
8894
8895 -- ... then all components
8896
8897 FA_Append_Record_Traversal (Stms,
8898 Clist => Component_List (Rdef),
8899 Container => Any_Parameter,
8900 Counter => Component_Counter);
8901
8902 Append_To (Stms,
8903 Make_Simple_Return_Statement (Loc,
8904 Expression => New_Occurrence_Of (Res, Loc)));
8905 end;
8906 end if;
8907
8908 elsif Is_Array_Type (Typ) then
8909 declare
8910 Constrained : constant Boolean := Is_Constrained (Typ);
8911
8912 procedure FA_Ary_Add_Process_Element
8913 (Stmts : List_Id;
8914 Any : Entity_Id;
8915 Counter : Entity_Id;
8916 Datum : Node_Id);
8917 -- Assign the current element (as identified by Counter) of
8918 -- Any to the variable denoted by name Datum, and advance
8919 -- Counter by 1. If Datum is not an Any, a call to From_Any
8920 -- for its type is inserted.
8921
8922 --------------------------------
8923 -- FA_Ary_Add_Process_Element --
8924 --------------------------------
8925
8926 procedure FA_Ary_Add_Process_Element
8927 (Stmts : List_Id;
8928 Any : Entity_Id;
8929 Counter : Entity_Id;
8930 Datum : Node_Id)
8931 is
8932 Assignment : constant Node_Id :=
8933 Make_Assignment_Statement (Loc,
8934 Name => Datum,
8935 Expression => Empty);
8936
8937 Element_Any : Node_Id;
8938
8939 begin
8940 declare
8941 Element_TC : Node_Id;
8942
8943 begin
8944 if Etype (Datum) = RTE (RE_Any) then
8945
8946 -- When Datum is an Any the Etype field is not
8947 -- sufficient to determine the typecode of Datum
8948 -- (which can be a TC_SEQUENCE or TC_ARRAY
8949 -- depending on the value of Constrained).
8950
8951 -- Therefore we retrieve the typecode which has
8952 -- been constructed in Append_Array_Traversal with
8953 -- a call to Get_Any_Type.
8954
8955 Element_TC :=
8956 Make_Function_Call (Loc,
8957 Name => New_Occurrence_Of (
8958 RTE (RE_Get_Any_Type), Loc),
8959 Parameter_Associations => New_List (
8960 New_Occurrence_Of (Entity (Datum), Loc)));
8961 else
8962 -- For non Any Datum we simply construct a typecode
8963 -- matching the Etype of the Datum.
8964
8965 Element_TC := Build_TypeCode_Call
8966 (Loc, Etype (Datum), Decls);
8967 end if;
8968
8969 Element_Any :=
8970 Build_Get_Aggregate_Element (Loc,
8971 Any => Any,
8972 TC => Element_TC,
8973 Idx => New_Occurrence_Of (Counter, Loc));
8974 end;
8975
8976 -- Note: here we *prepend* statements to Stmts, so
8977 -- we must do it in reverse order.
8978
8979 Prepend_To (Stmts,
8980 Make_Assignment_Statement (Loc,
8981 Name =>
8982 New_Occurrence_Of (Counter, Loc),
8983 Expression =>
8984 Make_Op_Add (Loc,
8985 Left_Opnd => New_Occurrence_Of (Counter, Loc),
8986 Right_Opnd => Make_Integer_Literal (Loc, 1))));
8987
8988 if Nkind (Datum) /= N_Attribute_Reference then
8989
8990 -- We ignore the value of the length of each
8991 -- dimension, since the target array has already been
8992 -- constrained anyway.
8993
8994 if Etype (Datum) /= RTE (RE_Any) then
8995 Set_Expression (Assignment,
8996 Build_From_Any_Call
8997 (Component_Type (Typ), Element_Any, Decls));
8998 else
8999 Set_Expression (Assignment, Element_Any);
9000 end if;
9001
9002 Prepend_To (Stmts, Assignment);
9003 end if;
9004 end FA_Ary_Add_Process_Element;
9005
9006 ------------------------
9007 -- Local Declarations --
9008 ------------------------
9009
9010 Counter : constant Entity_Id :=
9011 Make_Defining_Identifier (Loc, Name_J);
9012
9013 Initial_Counter_Value : Int := 0;
9014
9015 Component_TC : constant Entity_Id :=
9016 Make_Defining_Identifier (Loc, Name_T);
9017
9018 Res : constant Entity_Id :=
9019 Make_Defining_Identifier (Loc, Name_R);
9020
9021 procedure Append_From_Any_Array_Iterator is
9022 new Append_Array_Traversal (
9023 Subprogram => Fnam,
9024 Arry => Res,
9025 Indexes => New_List,
9026 Add_Process_Element => FA_Ary_Add_Process_Element);
9027
9028 Res_Subtype_Indication : Node_Id :=
9029 New_Occurrence_Of (Typ, Loc);
9030
9031 begin
9032 if not Constrained then
9033 declare
9034 Ndim : constant Int := Number_Dimensions (Typ);
9035 Lnam : Name_Id;
9036 Hnam : Name_Id;
9037 Indx : Node_Id := First_Index (Typ);
9038 Indt : Entity_Id;
9039
9040 Ranges : constant List_Id := New_List;
9041
9042 begin
9043 for J in 1 .. Ndim loop
9044 Lnam := New_External_Name ('L', J);
9045 Hnam := New_External_Name ('H', J);
9046
9047 -- Note, for empty arrays bounds may be out of
9048 -- the range of Etype (Indx).
9049
9050 Indt := Base_Type (Etype (Indx));
9051
9052 Append_To (Decls,
9053 Make_Object_Declaration (Loc,
9054 Defining_Identifier =>
9055 Make_Defining_Identifier (Loc, Lnam),
9056 Constant_Present => True,
9057 Object_Definition =>
9058 New_Occurrence_Of (Indt, Loc),
9059 Expression =>
9060 Build_From_Any_Call
9061 (Indt,
9062 Build_Get_Aggregate_Element (Loc,
9063 Any => Any_Parameter,
9064 TC => Build_TypeCode_Call
9065 (Loc, Indt, Decls),
9066 Idx =>
9067 Make_Integer_Literal (Loc, J - 1)),
9068 Decls)));
9069
9070 Append_To (Decls,
9071 Make_Object_Declaration (Loc,
9072 Defining_Identifier =>
9073 Make_Defining_Identifier (Loc, Hnam),
9074
9075 Constant_Present => True,
9076
9077 Object_Definition =>
9078 New_Occurrence_Of (Indt, Loc),
9079
9080 Expression => Make_Attribute_Reference (Loc,
9081 Prefix =>
9082 New_Occurrence_Of (Indt, Loc),
9083
9084 Attribute_Name => Name_Val,
9085
9086 Expressions => New_List (
9087 Make_Op_Subtract (Loc,
9088 Left_Opnd =>
9089 Make_Op_Add (Loc,
9090 Left_Opnd =>
9091 OK_Convert_To
9092 (Standard_Long_Integer,
9093 Make_Identifier (Loc, Lnam)),
9094
9095 Right_Opnd =>
9096 OK_Convert_To
9097 (Standard_Long_Integer,
9098 Make_Function_Call (Loc,
9099 Name =>
9100 New_Occurrence_Of (RTE (
9101 RE_Get_Nested_Sequence_Length
9102 ), Loc),
9103 Parameter_Associations =>
9104 New_List (
9105 New_Occurrence_Of (
9106 Any_Parameter, Loc),
9107 Make_Integer_Literal (Loc,
9108 Intval => J))))),
9109
9110 Right_Opnd =>
9111 Make_Integer_Literal (Loc, 1))))));
9112
9113 Append_To (Ranges,
9114 Make_Range (Loc,
9115 Low_Bound => Make_Identifier (Loc, Lnam),
9116 High_Bound => Make_Identifier (Loc, Hnam)));
9117
9118 Next_Index (Indx);
9119 end loop;
9120
9121 -- Now we have all the necessary bound information:
9122 -- apply the set of range constraints to the
9123 -- (unconstrained) nominal subtype of Res.
9124
9125 Initial_Counter_Value := Ndim;
9126 Res_Subtype_Indication := Make_Subtype_Indication (Loc,
9127 Subtype_Mark => Res_Subtype_Indication,
9128 Constraint =>
9129 Make_Index_Or_Discriminant_Constraint (Loc,
9130 Constraints => Ranges));
9131 end;
9132 end if;
9133
9134 Append_To (Decls,
9135 Make_Object_Declaration (Loc,
9136 Defining_Identifier => Res,
9137 Object_Definition => Res_Subtype_Indication));
9138 Set_Etype (Res, Typ);
9139
9140 Append_To (Decls,
9141 Make_Object_Declaration (Loc,
9142 Defining_Identifier => Counter,
9143 Object_Definition =>
9144 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc),
9145 Expression =>
9146 Make_Integer_Literal (Loc, Initial_Counter_Value)));
9147
9148 Append_To (Decls,
9149 Make_Object_Declaration (Loc,
9150 Defining_Identifier => Component_TC,
9151 Constant_Present => True,
9152 Object_Definition =>
9153 New_Occurrence_Of (RTE (RE_TypeCode), Loc),
9154 Expression =>
9155 Build_TypeCode_Call (Loc,
9156 Component_Type (Typ), Decls)));
9157
9158 Append_From_Any_Array_Iterator
9159 (Stms, Any_Parameter, Counter);
9160
9161 Append_To (Stms,
9162 Make_Simple_Return_Statement (Loc,
9163 Expression => New_Occurrence_Of (Res, Loc)));
9164 end;
9165
9166 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9167 Append_To (Stms,
9168 Make_Simple_Return_Statement (Loc,
9169 Expression =>
9170 Unchecked_Convert_To (Typ,
9171 Build_From_Any_Call
9172 (Find_Numeric_Representation (Typ),
9173 New_Occurrence_Of (Any_Parameter, Loc),
9174 Decls))));
9175
9176 else
9177 Use_Opaque_Representation := True;
9178 end if;
9179
9180 if Use_Opaque_Representation then
9181 Assign_Opaque_From_Any (Loc,
9182 Stms => Stms,
9183 Typ => Typ,
9184 N => New_Occurrence_Of (Any_Parameter, Loc),
9185 Target => Empty);
9186 end if;
9187
9188 Decl :=
9189 Make_Subprogram_Body (Loc,
9190 Specification => Spec,
9191 Declarations => Decls,
9192 Handled_Statement_Sequence =>
9193 Make_Handled_Sequence_Of_Statements (Loc,
9194 Statements => Stms));
9195 end Build_From_Any_Function;
9196
9197 ---------------------------------
9198 -- Build_Get_Aggregate_Element --
9199 ---------------------------------
9200
9201 function Build_Get_Aggregate_Element
9202 (Loc : Source_Ptr;
9203 Any : Entity_Id;
9204 TC : Node_Id;
9205 Idx : Node_Id) return Node_Id
9206 is
9207 begin
9208 return Make_Function_Call (Loc,
9209 Name =>
9210 New_Occurrence_Of (RTE (RE_Get_Aggregate_Element), Loc),
9211 Parameter_Associations => New_List (
9212 New_Occurrence_Of (Any, Loc),
9213 TC,
9214 Idx));
9215 end Build_Get_Aggregate_Element;
9216
9217 -------------------------
9218 -- Build_Reposiroty_Id --
9219 -------------------------
9220
9221 procedure Build_Name_And_Repository_Id
9222 (E : Entity_Id;
9223 Name_Str : out String_Id;
9224 Repo_Id_Str : out String_Id)
9225 is
9226 begin
9227 Name_Str := Fully_Qualified_Name_String (E, Append_NUL => False);
9228 Start_String;
9229 Store_String_Chars ("DSA:");
9230 Store_String_Chars (Name_Str);
9231 Store_String_Chars (":1.0");
9232 Repo_Id_Str := End_String;
9233 end Build_Name_And_Repository_Id;
9234
9235 -----------------------
9236 -- Build_To_Any_Call --
9237 -----------------------
9238
9239 function Build_To_Any_Call
9240 (Loc : Source_Ptr;
9241 N : Node_Id;
9242 Decls : List_Id;
9243 Constrained : Boolean := False) return Node_Id
9244 is
9245 Typ : Entity_Id := Etype (N);
9246 U_Type : Entity_Id;
9247 C_Type : Entity_Id;
9248 Fnam : Entity_Id := Empty;
9249 Lib_RE : RE_Id := RE_Null;
9250
9251 begin
9252 -- If N is a selected component, then maybe its Etype has not been
9253 -- set yet: try to use Etype of the selector_name in that case.
9254
9255 if No (Typ) and then Nkind (N) = N_Selected_Component then
9256 Typ := Etype (Selector_Name (N));
9257 end if;
9258
9259 pragma Assert (Present (Typ));
9260
9261 -- Get full view for private type, completion for incomplete type
9262
9263 U_Type := Underlying_Type (Typ);
9264
9265 -- First simple case where the To_Any function is present in the
9266 -- type's TSS.
9267
9268 Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
9269
9270 -- For the subtype representing a generic actual type, go to the
9271 -- actual type.
9272
9273 if Is_Generic_Actual_Type (U_Type) then
9274 U_Type := Underlying_Type (Base_Type (U_Type));
9275 end if;
9276
9277 -- For a standard subtype, go to the base type
9278
9279 if Sloc (U_Type) <= Standard_Location then
9280 U_Type := Base_Type (U_Type);
9281
9282 -- For a user subtype, go to first subtype
9283
9284 elsif Comes_From_Source (U_Type)
9285 and then Nkind (Declaration_Node (U_Type))
9286 = N_Subtype_Declaration
9287 then
9288 U_Type := First_Subtype (U_Type);
9289 end if;
9290
9291 if Present (Fnam) then
9292 null;
9293
9294 -- Check first for Boolean and Character. These are enumeration
9295 -- types, but we treat them specially, since they may require
9296 -- special handling in the transfer protocol. However, this
9297 -- special handling only applies if they have standard
9298 -- representation, otherwise they are treated like any other
9299 -- enumeration type.
9300
9301 elsif U_Type = Standard_Boolean then
9302 Lib_RE := RE_TA_B;
9303
9304 elsif U_Type = Standard_Character then
9305 Lib_RE := RE_TA_C;
9306
9307 elsif U_Type = Standard_Wide_Character then
9308 Lib_RE := RE_TA_WC;
9309
9310 elsif U_Type = Standard_Wide_Wide_Character then
9311 Lib_RE := RE_TA_WWC;
9312
9313 -- Floating point types
9314
9315 elsif U_Type = Standard_Short_Float then
9316 Lib_RE := RE_TA_SF;
9317
9318 elsif U_Type = Standard_Float then
9319 Lib_RE := RE_TA_F;
9320
9321 elsif U_Type = Standard_Long_Float then
9322 Lib_RE := RE_TA_LF;
9323
9324 elsif U_Type = Standard_Long_Long_Float then
9325 Lib_RE := RE_TA_LLF;
9326
9327 -- Integer types
9328
9329 elsif U_Type = RTE (RE_Integer_8) then
9330 Lib_RE := RE_TA_I8;
9331
9332 elsif U_Type = RTE (RE_Integer_16) then
9333 Lib_RE := RE_TA_I16;
9334
9335 elsif U_Type = RTE (RE_Integer_32) then
9336 Lib_RE := RE_TA_I32;
9337
9338 elsif U_Type = RTE (RE_Integer_64) then
9339 Lib_RE := RE_TA_I64;
9340
9341 -- Unsigned integer types
9342
9343 elsif U_Type = RTE (RE_Unsigned_8) then
9344 Lib_RE := RE_TA_U8;
9345
9346 elsif U_Type = RTE (RE_Unsigned_16) then
9347 Lib_RE := RE_TA_U16;
9348
9349 elsif U_Type = RTE (RE_Unsigned_32) then
9350 Lib_RE := RE_TA_U32;
9351
9352 elsif U_Type = RTE (RE_Unsigned_64) then
9353 Lib_RE := RE_TA_U64;
9354
9355 elsif Is_RTE (U_Type, RE_Unbounded_String) then
9356 Lib_RE := RE_TA_String;
9357
9358 -- Special DSA types
9359
9360 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
9361 Lib_RE := RE_TA_A;
9362 U_Type := Typ;
9363
9364 elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
9365
9366 -- No corresponding FA_TC ???
9367
9368 Lib_RE := RE_TA_TC;
9369
9370 -- Other (non-primitive) types
9371
9372 else
9373 declare
9374 Decl : Entity_Id;
9375 begin
9376 Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
9377 Append_To (Decls, Decl);
9378 end;
9379 end if;
9380
9381 -- Call the function
9382
9383 if Lib_RE /= RE_Null then
9384 pragma Assert (No (Fnam));
9385 Fnam := RTE (Lib_RE);
9386 end if;
9387
9388 -- If Fnam is already analyzed, find the proper expected type,
9389 -- else we have a newly constructed To_Any function and we know
9390 -- that the expected type of its parameter is U_Type.
9391
9392 if Ekind (Fnam) = E_Function
9393 and then Present (First_Formal (Fnam))
9394 then
9395 C_Type := Etype (First_Formal (Fnam));
9396 else
9397 C_Type := U_Type;
9398 end if;
9399
9400 declare
9401 Params : constant List_Id :=
9402 New_List (OK_Convert_To (C_Type, N));
9403 begin
9404 if Is_Limited_Type (C_Type) then
9405 Append_To (Params,
9406 New_Occurrence_Of (Boolean_Literals (Constrained), Loc));
9407 end if;
9408
9409 return
9410 Make_Function_Call (Loc,
9411 Name => New_Occurrence_Of (Fnam, Loc),
9412 Parameter_Associations => Params);
9413 end;
9414 end Build_To_Any_Call;
9415
9416 ---------------------------
9417 -- Build_To_Any_Function --
9418 ---------------------------
9419
9420 procedure Build_To_Any_Function
9421 (Loc : Source_Ptr;
9422 Typ : Entity_Id;
9423 Decl : out Node_Id;
9424 Fnam : out Entity_Id)
9425 is
9426 Spec : Node_Id;
9427 Params : List_Id;
9428 Decls : List_Id;
9429 Stms : List_Id;
9430
9431 Expr_Formal : Entity_Id;
9432 Cstr_Formal : Entity_Id;
9433 Any : Entity_Id;
9434 Result_TC : Node_Id;
9435
9436 Any_Decl : Node_Id;
9437
9438 Use_Opaque_Representation : Boolean;
9439 -- When True, use stream attributes and represent type as an
9440 -- opaque sequence of bytes.
9441
9442 begin
9443 -- For a derived type, we can't go past the base type (to the
9444 -- parent type) here, because that would cause the attribute's
9445 -- formal parameter to have the wrong type; hence the Base_Type
9446 -- check here.
9447
9448 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
9449 Build_To_Any_Function
9450 (Loc => Loc,
9451 Typ => Etype (Typ),
9452 Decl => Decl,
9453 Fnam => Fnam);
9454 return;
9455 end if;
9456
9457 Decls := New_List;
9458 Stms := New_List;
9459
9460 Any := Make_Defining_Identifier (Loc, Name_A);
9461 Result_TC := Build_TypeCode_Call (Loc, Typ, Decls);
9462
9463 Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
9464
9465 Expr_Formal := Make_Defining_Identifier (Loc, Name_E);
9466 Params := New_List (
9467 Make_Parameter_Specification (Loc,
9468 Defining_Identifier => Expr_Formal,
9469 Parameter_Type => New_Occurrence_Of (Typ, Loc)));
9470 Set_Etype (Expr_Formal, Typ);
9471
9472 if Is_Limited_Type (Typ) then
9473 Cstr_Formal := Make_Defining_Identifier (Loc, Name_C);
9474 Append_To (Params,
9475 Make_Parameter_Specification (Loc,
9476 Defining_Identifier => Cstr_Formal,
9477 Parameter_Type =>
9478 New_Occurrence_Of (Standard_Boolean, Loc)));
9479 end if;
9480
9481 Spec :=
9482 Make_Function_Specification (Loc,
9483 Defining_Unit_Name => Fnam,
9484 Parameter_Specifications => Params,
9485 Result_Definition =>
9486 New_Occurrence_Of (RTE (RE_Any), Loc));
9487
9488 Any_Decl :=
9489 Make_Object_Declaration (Loc,
9490 Defining_Identifier => Any,
9491 Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
9492
9493 Use_Opaque_Representation := False;
9494
9495 if Has_Stream_Attribute_Definition
9496 (Typ, TSS_Stream_Output, At_Any_Place => True)
9497 or else
9498 Has_Stream_Attribute_Definition
9499 (Typ, TSS_Stream_Write, At_Any_Place => True)
9500 then
9501 -- If user-defined stream attributes are specified for this
9502 -- type, use them and transmit data as an opaque sequence of
9503 -- stream elements.
9504
9505 Use_Opaque_Representation := True;
9506
9507 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
9508
9509 -- Untagged derived type: convert to root type
9510
9511 declare
9512 Rt_Type : constant Entity_Id := Root_Type (Typ);
9513 Expr : constant Node_Id :=
9514 OK_Convert_To
9515 (Rt_Type,
9516 New_Occurrence_Of (Expr_Formal, Loc));
9517 begin
9518 Set_Expression (Any_Decl,
9519 Build_To_Any_Call (Loc, Expr, Decls));
9520 end;
9521
9522 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
9523
9524 -- Untagged record type
9525
9526 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
9527 declare
9528 Rt_Type : constant Entity_Id := Etype (Typ);
9529 Expr : constant Node_Id :=
9530 OK_Convert_To (Rt_Type,
9531 New_Occurrence_Of (Expr_Formal, Loc));
9532
9533 begin
9534 Set_Expression
9535 (Any_Decl, Build_To_Any_Call (Loc, Expr, Decls));
9536 end;
9537
9538 -- Comment needed here (and label on declare block ???)
9539
9540 else
9541 declare
9542 Disc : Entity_Id := Empty;
9543 Rdef : constant Node_Id :=
9544 Type_Definition (Declaration_Node (Typ));
9545 Counter : Int := 0;
9546 Elements : constant List_Id := New_List;
9547
9548 procedure TA_Rec_Add_Process_Element
9549 (Stmts : List_Id;
9550 Container : Node_Or_Entity_Id;
9551 Counter : in out Int;
9552 Rec : Entity_Id;
9553 Field : Node_Id);
9554 -- Processing routine for traversal below
9555
9556 procedure TA_Append_Record_Traversal is
9557 new Append_Record_Traversal
9558 (Rec => Expr_Formal,
9559 Add_Process_Element => TA_Rec_Add_Process_Element);
9560
9561 --------------------------------
9562 -- TA_Rec_Add_Process_Element --
9563 --------------------------------
9564
9565 procedure TA_Rec_Add_Process_Element
9566 (Stmts : List_Id;
9567 Container : Node_Or_Entity_Id;
9568 Counter : in out Int;
9569 Rec : Entity_Id;
9570 Field : Node_Id)
9571 is
9572 Field_Ref : Node_Id;
9573
9574 begin
9575 if Nkind (Field) = N_Defining_Identifier then
9576
9577 -- A regular component
9578
9579 Field_Ref := Make_Selected_Component (Loc,
9580 Prefix => New_Occurrence_Of (Rec, Loc),
9581 Selector_Name => New_Occurrence_Of (Field, Loc));
9582 Set_Etype (Field_Ref, Etype (Field));
9583
9584 Append_To (Stmts,
9585 Make_Procedure_Call_Statement (Loc,
9586 Name =>
9587 New_Occurrence_Of (
9588 RTE (RE_Add_Aggregate_Element), Loc),
9589 Parameter_Associations => New_List (
9590 New_Occurrence_Of (Container, Loc),
9591 Build_To_Any_Call (Loc, Field_Ref, Decls))));
9592
9593 else
9594 -- A variant part
9595
9596 Variant_Part : declare
9597 Variant : Node_Id;
9598 Struct_Counter : Int := 0;
9599
9600 Block_Decls : constant List_Id := New_List;
9601 Block_Stmts : constant List_Id := New_List;
9602 VP_Stmts : List_Id;
9603
9604 Alt_List : constant List_Id := New_List;
9605 Choice_List : List_Id;
9606
9607 Union_Any : constant Entity_Id :=
9608 Make_Temporary (Loc, 'V');
9609
9610 Struct_Any : constant Entity_Id :=
9611 Make_Temporary (Loc, 'S');
9612
9613 function Make_Discriminant_Reference
9614 return Node_Id;
9615 -- Build reference to the discriminant for this
9616 -- variant part.
9617
9618 ---------------------------------
9619 -- Make_Discriminant_Reference --
9620 ---------------------------------
9621
9622 function Make_Discriminant_Reference
9623 return Node_Id
9624 is
9625 Nod : constant Node_Id :=
9626 Make_Selected_Component (Loc,
9627 Prefix => Rec,
9628 Selector_Name =>
9629 Chars (Name (Field)));
9630 begin
9631 Set_Etype (Nod, Etype (Name (Field)));
9632 return Nod;
9633 end Make_Discriminant_Reference;
9634
9635 -- Start of processing for Variant_Part
9636
9637 begin
9638 Append_To (Stmts,
9639 Make_Block_Statement (Loc,
9640 Declarations =>
9641 Block_Decls,
9642 Handled_Statement_Sequence =>
9643 Make_Handled_Sequence_Of_Statements (Loc,
9644 Statements => Block_Stmts)));
9645
9646 -- Declare variant part aggregate (Union_Any).
9647 -- Knowing the position of this VP in the
9648 -- variant record, we can fetch the VP typecode
9649 -- from Container.
9650
9651 Append_To (Block_Decls,
9652 Make_Object_Declaration (Loc,
9653 Defining_Identifier => Union_Any,
9654 Object_Definition =>
9655 New_Occurrence_Of (RTE (RE_Any), Loc),
9656 Expression =>
9657 Make_Function_Call (Loc,
9658 Name => New_Occurrence_Of (
9659 RTE (RE_Create_Any), Loc),
9660 Parameter_Associations => New_List (
9661 Make_Function_Call (Loc,
9662 Name =>
9663 New_Occurrence_Of (
9664 RTE (RE_Any_Member_Type), Loc),
9665 Parameter_Associations => New_List (
9666 New_Occurrence_Of (Container, Loc),
9667 Make_Integer_Literal (Loc,
9668 Counter)))))));
9669
9670 -- Declare inner struct aggregate (which
9671 -- contains the components of this VP).
9672
9673 Append_To (Block_Decls,
9674 Make_Object_Declaration (Loc,
9675 Defining_Identifier => Struct_Any,
9676 Object_Definition =>
9677 New_Occurrence_Of (RTE (RE_Any), Loc),
9678 Expression =>
9679 Make_Function_Call (Loc,
9680 Name => New_Occurrence_Of (
9681 RTE (RE_Create_Any), Loc),
9682 Parameter_Associations => New_List (
9683 Make_Function_Call (Loc,
9684 Name =>
9685 New_Occurrence_Of (
9686 RTE (RE_Any_Member_Type), Loc),
9687 Parameter_Associations => New_List (
9688 New_Occurrence_Of (Union_Any, Loc),
9689 Make_Integer_Literal (Loc,
9690 Uint_1)))))));
9691
9692 -- Build case statement
9693
9694 Append_To (Block_Stmts,
9695 Make_Case_Statement (Loc,
9696 Expression => Make_Discriminant_Reference,
9697 Alternatives => Alt_List));
9698
9699 Variant := First_Non_Pragma (Variants (Field));
9700 while Present (Variant) loop
9701 Choice_List := New_Copy_List_Tree
9702 (Discrete_Choices (Variant));
9703
9704 VP_Stmts := New_List;
9705
9706 -- Append discriminant val to union aggregate
9707
9708 Append_To (VP_Stmts,
9709 Make_Procedure_Call_Statement (Loc,
9710 Name =>
9711 New_Occurrence_Of (
9712 RTE (RE_Add_Aggregate_Element), Loc),
9713 Parameter_Associations => New_List (
9714 New_Occurrence_Of (Union_Any, Loc),
9715 Build_To_Any_Call
9716 (Loc,
9717 Make_Discriminant_Reference,
9718 Block_Decls))));
9719
9720 -- Populate inner struct aggregate
9721
9722 -- Struct_Counter should be reset before
9723 -- handling a variant part. Indeed only one
9724 -- of the case statement alternatives will be
9725 -- executed at run time, so the counter must
9726 -- start at 0 for every case statement.
9727
9728 Struct_Counter := 0;
9729
9730 TA_Append_Record_Traversal
9731 (Stmts => VP_Stmts,
9732 Clist => Component_List (Variant),
9733 Container => Struct_Any,
9734 Counter => Struct_Counter);
9735
9736 -- Append inner struct to union aggregate
9737
9738 Append_To (VP_Stmts,
9739 Make_Procedure_Call_Statement (Loc,
9740 Name =>
9741 New_Occurrence_Of
9742 (RTE (RE_Add_Aggregate_Element), Loc),
9743 Parameter_Associations => New_List (
9744 New_Occurrence_Of (Union_Any, Loc),
9745 New_Occurrence_Of (Struct_Any, Loc))));
9746
9747 -- Append union to outer aggregate
9748
9749 Append_To (VP_Stmts,
9750 Make_Procedure_Call_Statement (Loc,
9751 Name =>
9752 New_Occurrence_Of
9753 (RTE (RE_Add_Aggregate_Element), Loc),
9754 Parameter_Associations => New_List (
9755 New_Occurrence_Of (Container, Loc),
9756 New_Occurrence_Of
9757 (Union_Any, Loc))));
9758
9759 Append_To (Alt_List,
9760 Make_Case_Statement_Alternative (Loc,
9761 Discrete_Choices => Choice_List,
9762 Statements => VP_Stmts));
9763
9764 Next_Non_Pragma (Variant);
9765 end loop;
9766 end Variant_Part;
9767 end if;
9768
9769 Counter := Counter + 1;
9770 end TA_Rec_Add_Process_Element;
9771
9772 begin
9773 -- Records are encoded in a TC_STRUCT aggregate:
9774
9775 -- -- Outer aggregate (TC_STRUCT)
9776 -- | [discriminant1]
9777 -- | [discriminant2]
9778 -- | ...
9779 -- |
9780 -- | [component1]
9781 -- | [component2]
9782 -- | ...
9783
9784 -- A component can be a common component or variant part
9785
9786 -- A variant part is encoded as a TC_UNION aggregate:
9787
9788 -- -- Variant Part Aggregate (TC_UNION)
9789 -- | [discriminant choice for this Variant Part]
9790 -- |
9791 -- | -- Inner struct (TC_STRUCT)
9792 -- | | [component1]
9793 -- | | [component2]
9794 -- | | ...
9795
9796 -- Let's start by building the outer aggregate. First we
9797 -- construct Elements array containing all discriminants.
9798
9799 if Has_Discriminants (Typ) then
9800 Disc := First_Discriminant (Typ);
9801 while Present (Disc) loop
9802 declare
9803 Discriminant : constant Entity_Id :=
9804 Make_Selected_Component (Loc,
9805 Prefix => Expr_Formal,
9806 Selector_Name => Chars (Disc));
9807 begin
9808 Set_Etype (Discriminant, Etype (Disc));
9809 Append_To (Elements,
9810 Make_Component_Association (Loc,
9811 Choices => New_List (
9812 Make_Integer_Literal (Loc, Counter)),
9813 Expression =>
9814 Build_To_Any_Call (Loc,
9815 Discriminant, Decls)));
9816 end;
9817
9818 Counter := Counter + 1;
9819 Next_Discriminant (Disc);
9820 end loop;
9821
9822 else
9823 -- If there are no discriminants, we declare an empty
9824 -- Elements array.
9825
9826 declare
9827 Dummy_Any : constant Entity_Id :=
9828 Make_Temporary (Loc, 'A');
9829
9830 begin
9831 Append_To (Decls,
9832 Make_Object_Declaration (Loc,
9833 Defining_Identifier => Dummy_Any,
9834 Object_Definition =>
9835 New_Occurrence_Of (RTE (RE_Any), Loc)));
9836
9837 Append_To (Elements,
9838 Make_Component_Association (Loc,
9839 Choices => New_List (
9840 Make_Range (Loc,
9841 Low_Bound =>
9842 Make_Integer_Literal (Loc, 1),
9843 High_Bound =>
9844 Make_Integer_Literal (Loc, 0))),
9845 Expression =>
9846 New_Occurrence_Of (Dummy_Any, Loc)));
9847 end;
9848 end if;
9849
9850 -- We build the result aggregate with discriminants
9851 -- as the first elements.
9852
9853 Set_Expression (Any_Decl,
9854 Make_Function_Call (Loc,
9855 Name => New_Occurrence_Of
9856 (RTE (RE_Any_Aggregate_Build), Loc),
9857 Parameter_Associations => New_List (
9858 Result_TC,
9859 Make_Aggregate (Loc,
9860 Component_Associations => Elements))));
9861 Result_TC := Empty;
9862
9863 -- Then we append all the components to the result
9864 -- aggregate.
9865
9866 TA_Append_Record_Traversal (Stms,
9867 Clist => Component_List (Rdef),
9868 Container => Any,
9869 Counter => Counter);
9870 end;
9871 end if;
9872
9873 elsif Is_Array_Type (Typ) then
9874
9875 -- Constrained and unconstrained array types
9876
9877 declare
9878 Constrained : constant Boolean :=
9879 not Transmit_As_Unconstrained (Typ);
9880
9881 procedure TA_Ary_Add_Process_Element
9882 (Stmts : List_Id;
9883 Any : Entity_Id;
9884 Counter : Entity_Id;
9885 Datum : Node_Id);
9886
9887 --------------------------------
9888 -- TA_Ary_Add_Process_Element --
9889 --------------------------------
9890
9891 procedure TA_Ary_Add_Process_Element
9892 (Stmts : List_Id;
9893 Any : Entity_Id;
9894 Counter : Entity_Id;
9895 Datum : Node_Id)
9896 is
9897 pragma Unreferenced (Counter);
9898
9899 Element_Any : Node_Id;
9900
9901 begin
9902 if Etype (Datum) = RTE (RE_Any) then
9903 Element_Any := Datum;
9904 else
9905 Element_Any := Build_To_Any_Call (Loc, Datum, Decls);
9906 end if;
9907
9908 Append_To (Stmts,
9909 Make_Procedure_Call_Statement (Loc,
9910 Name => New_Occurrence_Of (
9911 RTE (RE_Add_Aggregate_Element), Loc),
9912 Parameter_Associations => New_List (
9913 New_Occurrence_Of (Any, Loc),
9914 Element_Any)));
9915 end TA_Ary_Add_Process_Element;
9916
9917 procedure Append_To_Any_Array_Iterator is
9918 new Append_Array_Traversal (
9919 Subprogram => Fnam,
9920 Arry => Expr_Formal,
9921 Indexes => New_List,
9922 Add_Process_Element => TA_Ary_Add_Process_Element);
9923
9924 Index : Node_Id;
9925
9926 begin
9927 Set_Expression (Any_Decl,
9928 Make_Function_Call (Loc,
9929 Name =>
9930 New_Occurrence_Of (RTE (RE_Create_Any), Loc),
9931 Parameter_Associations => New_List (Result_TC)));
9932 Result_TC := Empty;
9933
9934 if not Constrained then
9935 Index := First_Index (Typ);
9936 for J in 1 .. Number_Dimensions (Typ) loop
9937 Append_To (Stms,
9938 Make_Procedure_Call_Statement (Loc,
9939 Name =>
9940 New_Occurrence_Of
9941 (RTE (RE_Add_Aggregate_Element), Loc),
9942 Parameter_Associations => New_List (
9943 New_Occurrence_Of (Any, Loc),
9944 Build_To_Any_Call (Loc,
9945 OK_Convert_To (Etype (Index),
9946 Make_Attribute_Reference (Loc,
9947 Prefix =>
9948 New_Occurrence_Of (Expr_Formal, Loc),
9949 Attribute_Name => Name_First,
9950 Expressions => New_List (
9951 Make_Integer_Literal (Loc, J)))),
9952 Decls))));
9953 Next_Index (Index);
9954 end loop;
9955 end if;
9956
9957 Append_To_Any_Array_Iterator (Stms, Any);
9958 end;
9959
9960 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
9961
9962 -- Integer types
9963
9964 Set_Expression (Any_Decl,
9965 Build_To_Any_Call (Loc,
9966 OK_Convert_To (
9967 Find_Numeric_Representation (Typ),
9968 New_Occurrence_Of (Expr_Formal, Loc)),
9969 Decls));
9970
9971 else
9972 -- Default case, including tagged types: opaque representation
9973
9974 Use_Opaque_Representation := True;
9975 end if;
9976
9977 if Use_Opaque_Representation then
9978 declare
9979 Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
9980 -- Stream used to store data representation produced by
9981 -- stream attribute.
9982
9983 begin
9984 -- Generate:
9985 -- Strm : aliased Buffer_Stream_Type;
9986
9987 Append_To (Decls,
9988 Make_Object_Declaration (Loc,
9989 Defining_Identifier => Strm,
9990 Aliased_Present => True,
9991 Object_Definition =>
9992 New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
9993
9994 -- Generate:
9995 -- T'Output (Strm'Access, E);
9996 -- or
9997 -- T'Write (Strm'Access, E);
9998 -- depending on whether to transmit as unconstrained.
9999
10000 -- For limited types, select at run time depending on
10001 -- Constrained parameter.
10002
10003 declare
10004 function Stream_Call (Attr : Name_Id) return Node_Id;
10005 -- Return a call to the named attribute
10006
10007 -----------------
10008 -- Stream_Call --
10009 -----------------
10010
10011 function Stream_Call (Attr : Name_Id) return Node_Id is
10012 begin
10013 return Make_Attribute_Reference (Loc,
10014 Prefix =>
10015 New_Occurrence_Of (Typ, Loc),
10016 Attribute_Name => Attr,
10017 Expressions => New_List (
10018 Make_Attribute_Reference (Loc,
10019 Prefix =>
10020 New_Occurrence_Of (Strm, Loc),
10021 Attribute_Name => Name_Access),
10022 New_Occurrence_Of (Expr_Formal, Loc)));
10023
10024 end Stream_Call;
10025
10026 begin
10027 if Is_Limited_Type (Typ) then
10028 Append_To (Stms,
10029 Make_Implicit_If_Statement (Typ,
10030 Condition =>
10031 New_Occurrence_Of (Cstr_Formal, Loc),
10032 Then_Statements => New_List (
10033 Stream_Call (Name_Write)),
10034 Else_Statements => New_List (
10035 Stream_Call (Name_Output))));
10036
10037 elsif Transmit_As_Unconstrained (Typ) then
10038 Append_To (Stms, Stream_Call (Name_Output));
10039
10040 else
10041 Append_To (Stms, Stream_Call (Name_Write));
10042 end if;
10043 end;
10044
10045 -- Generate:
10046 -- BS_To_Any (Strm, A);
10047
10048 Append_To (Stms,
10049 Make_Procedure_Call_Statement (Loc,
10050 Name =>
10051 New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
10052 Parameter_Associations => New_List (
10053 New_Occurrence_Of (Strm, Loc),
10054 New_Occurrence_Of (Any, Loc))));
10055
10056 -- Generate:
10057 -- Release_Buffer (Strm);
10058
10059 Append_To (Stms,
10060 Make_Procedure_Call_Statement (Loc,
10061 Name =>
10062 New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
10063 Parameter_Associations => New_List (
10064 New_Occurrence_Of (Strm, Loc))));
10065 end;
10066 end if;
10067
10068 Append_To (Decls, Any_Decl);
10069
10070 if Present (Result_TC) then
10071 Append_To (Stms,
10072 Make_Procedure_Call_Statement (Loc,
10073 Name =>
10074 New_Occurrence_Of (RTE (RE_Set_TC), Loc),
10075 Parameter_Associations => New_List (
10076 New_Occurrence_Of (Any, Loc),
10077 Result_TC)));
10078 end if;
10079
10080 Append_To (Stms,
10081 Make_Simple_Return_Statement (Loc,
10082 Expression => New_Occurrence_Of (Any, Loc)));
10083
10084 Decl :=
10085 Make_Subprogram_Body (Loc,
10086 Specification => Spec,
10087 Declarations => Decls,
10088 Handled_Statement_Sequence =>
10089 Make_Handled_Sequence_Of_Statements (Loc,
10090 Statements => Stms));
10091 end Build_To_Any_Function;
10092
10093 -------------------------
10094 -- Build_TypeCode_Call --
10095 -------------------------
10096
10097 function Build_TypeCode_Call
10098 (Loc : Source_Ptr;
10099 Typ : Entity_Id;
10100 Decls : List_Id) return Node_Id
10101 is
10102 U_Type : Entity_Id := Underlying_Type (Typ);
10103 -- The full view, if Typ is private; the completion,
10104 -- if Typ is incomplete.
10105
10106 Fnam : Entity_Id := Empty;
10107 Lib_RE : RE_Id := RE_Null;
10108 Expr : Node_Id;
10109
10110 begin
10111 -- Special case System.PolyORB.Interface.Any: its primitives have
10112 -- not been set yet, so can't call Find_Inherited_TSS.
10113
10114 if Typ = RTE (RE_Any) then
10115 Fnam := RTE (RE_TC_A);
10116
10117 else
10118 -- First simple case where the TypeCode is present
10119 -- in the type's TSS.
10120
10121 Fnam := Find_Inherited_TSS (U_Type, TSS_TypeCode);
10122 end if;
10123
10124 -- For the subtype representing a generic actual type, go to the
10125 -- actual type.
10126
10127 if Is_Generic_Actual_Type (U_Type) then
10128 U_Type := Underlying_Type (Base_Type (U_Type));
10129 end if;
10130
10131 -- For a standard subtype, go to the base type
10132
10133 if Sloc (U_Type) <= Standard_Location then
10134 U_Type := Base_Type (U_Type);
10135
10136 -- For a user subtype, go to first subtype
10137
10138 elsif Comes_From_Source (U_Type)
10139 and then Nkind (Declaration_Node (U_Type))
10140 = N_Subtype_Declaration
10141 then
10142 U_Type := First_Subtype (U_Type);
10143 end if;
10144
10145 if No (Fnam) then
10146 if U_Type = Standard_Boolean then
10147 Lib_RE := RE_TC_B;
10148
10149 elsif U_Type = Standard_Character then
10150 Lib_RE := RE_TC_C;
10151
10152 elsif U_Type = Standard_Wide_Character then
10153 Lib_RE := RE_TC_WC;
10154
10155 elsif U_Type = Standard_Wide_Wide_Character then
10156 Lib_RE := RE_TC_WWC;
10157
10158 -- Floating point types
10159
10160 elsif U_Type = Standard_Short_Float then
10161 Lib_RE := RE_TC_SF;
10162
10163 elsif U_Type = Standard_Float then
10164 Lib_RE := RE_TC_F;
10165
10166 elsif U_Type = Standard_Long_Float then
10167 Lib_RE := RE_TC_LF;
10168
10169 elsif U_Type = Standard_Long_Long_Float then
10170 Lib_RE := RE_TC_LLF;
10171
10172 -- Integer types (walk back to the base type)
10173
10174 elsif U_Type = RTE (RE_Integer_8) then
10175 Lib_RE := RE_TC_I8;
10176
10177 elsif U_Type = RTE (RE_Integer_16) then
10178 Lib_RE := RE_TC_I16;
10179
10180 elsif U_Type = RTE (RE_Integer_32) then
10181 Lib_RE := RE_TC_I32;
10182
10183 elsif U_Type = RTE (RE_Integer_64) then
10184 Lib_RE := RE_TC_I64;
10185
10186 -- Unsigned integer types
10187
10188 elsif U_Type = RTE (RE_Unsigned_8) then
10189 Lib_RE := RE_TC_U8;
10190
10191 elsif U_Type = RTE (RE_Unsigned_16) then
10192 Lib_RE := RE_TC_U16;
10193
10194 elsif U_Type = RTE (RE_Unsigned_32) then
10195 Lib_RE := RE_TC_U32;
10196
10197 elsif U_Type = RTE (RE_Unsigned_64) then
10198 Lib_RE := RE_TC_U64;
10199
10200 elsif Is_RTE (U_Type, RE_Unbounded_String) then
10201 Lib_RE := RE_TC_String;
10202
10203 -- Special DSA types
10204
10205 elsif Is_RTE (U_Type, RE_Any_Container_Ptr) then
10206 Lib_RE := RE_TC_A;
10207
10208 -- Other (non-primitive) types
10209
10210 else
10211 declare
10212 Decl : Entity_Id;
10213 begin
10214 Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
10215 Append_To (Decls, Decl);
10216 end;
10217 end if;
10218
10219 if Lib_RE /= RE_Null then
10220 Fnam := RTE (Lib_RE);
10221 end if;
10222 end if;
10223
10224 -- Call the function
10225
10226 Expr :=
10227 Make_Function_Call (Loc, Name => New_Occurrence_Of (Fnam, Loc));
10228
10229 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10230
10231 Set_Etype (Expr, RTE (RE_TypeCode));
10232
10233 return Expr;
10234 end Build_TypeCode_Call;
10235
10236 -----------------------------
10237 -- Build_TypeCode_Function --
10238 -----------------------------
10239
10240 procedure Build_TypeCode_Function
10241 (Loc : Source_Ptr;
10242 Typ : Entity_Id;
10243 Decl : out Node_Id;
10244 Fnam : out Entity_Id)
10245 is
10246 Spec : Node_Id;
10247 Decls : constant List_Id := New_List;
10248 Stms : constant List_Id := New_List;
10249
10250 TCNam : constant Entity_Id :=
10251 Make_Helper_Function_Name (Loc, Typ, Name_TypeCode);
10252
10253 Parameters : List_Id;
10254
10255 procedure Add_String_Parameter
10256 (S : String_Id;
10257 Parameter_List : List_Id);
10258 -- Add a literal for S to Parameters
10259
10260 procedure Add_TypeCode_Parameter
10261 (TC_Node : Node_Id;
10262 Parameter_List : List_Id);
10263 -- Add the typecode for Typ to Parameters
10264
10265 procedure Add_Long_Parameter
10266 (Expr_Node : Node_Id;
10267 Parameter_List : List_Id);
10268 -- Add a signed long integer expression to Parameters
10269
10270 procedure Initialize_Parameter_List
10271 (Name_String : String_Id;
10272 Repo_Id_String : String_Id;
10273 Parameter_List : out List_Id);
10274 -- Return a list that contains the first two parameters
10275 -- for a parameterized typecode: name and repository id.
10276
10277 function Make_Constructed_TypeCode
10278 (Kind : Entity_Id;
10279 Parameters : List_Id) return Node_Id;
10280 -- Call Build_Complex_TC with the given kind and parameters
10281
10282 procedure Return_Constructed_TypeCode (Kind : Entity_Id);
10283 -- Make a return statement that calls Build_Complex_TC with the
10284 -- given typecode kind, and the constructed parameters list.
10285
10286 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
10287 -- Return a typecode that is a TC_Alias for the given typecode
10288
10289 --------------------------
10290 -- Add_String_Parameter --
10291 --------------------------
10292
10293 procedure Add_String_Parameter
10294 (S : String_Id;
10295 Parameter_List : List_Id)
10296 is
10297 begin
10298 Append_To (Parameter_List,
10299 Make_Function_Call (Loc,
10300 Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc),
10301 Parameter_Associations => New_List (
10302 Make_String_Literal (Loc, S))));
10303 end Add_String_Parameter;
10304
10305 ----------------------------
10306 -- Add_TypeCode_Parameter --
10307 ----------------------------
10308
10309 procedure Add_TypeCode_Parameter
10310 (TC_Node : Node_Id;
10311 Parameter_List : List_Id)
10312 is
10313 begin
10314 Append_To (Parameter_List,
10315 Make_Function_Call (Loc,
10316 Name => New_Occurrence_Of (RTE (RE_TA_TC), Loc),
10317 Parameter_Associations => New_List (TC_Node)));
10318 end Add_TypeCode_Parameter;
10319
10320 ------------------------
10321 -- Add_Long_Parameter --
10322 ------------------------
10323
10324 procedure Add_Long_Parameter
10325 (Expr_Node : Node_Id;
10326 Parameter_List : List_Id)
10327 is
10328 begin
10329 Append_To (Parameter_List,
10330 Make_Function_Call (Loc,
10331 Name =>
10332 New_Occurrence_Of (RTE (RE_TA_I32), Loc),
10333 Parameter_Associations => New_List (Expr_Node)));
10334 end Add_Long_Parameter;
10335
10336 -------------------------------
10337 -- Initialize_Parameter_List --
10338 -------------------------------
10339
10340 procedure Initialize_Parameter_List
10341 (Name_String : String_Id;
10342 Repo_Id_String : String_Id;
10343 Parameter_List : out List_Id)
10344 is
10345 begin
10346 Parameter_List := New_List;
10347 Add_String_Parameter (Name_String, Parameter_List);
10348 Add_String_Parameter (Repo_Id_String, Parameter_List);
10349 end Initialize_Parameter_List;
10350
10351 ---------------------------
10352 -- Return_Alias_TypeCode --
10353 ---------------------------
10354
10355 procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id) is
10356 begin
10357 Add_TypeCode_Parameter (Base_TypeCode, Parameters);
10358 Return_Constructed_TypeCode (RTE (RE_Tk_Alias));
10359 end Return_Alias_TypeCode;
10360
10361 -------------------------------
10362 -- Make_Constructed_TypeCode --
10363 -------------------------------
10364
10365 function Make_Constructed_TypeCode
10366 (Kind : Entity_Id;
10367 Parameters : List_Id) return Node_Id
10368 is
10369 Constructed_TC : constant Node_Id :=
10370 Make_Function_Call (Loc,
10371 Name =>
10372 New_Occurrence_Of (RTE (RE_Build_Complex_TC), Loc),
10373 Parameter_Associations => New_List (
10374 New_Occurrence_Of (Kind, Loc),
10375 Make_Aggregate (Loc,
10376 Expressions => Parameters)));
10377 begin
10378 Set_Etype (Constructed_TC, RTE (RE_TypeCode));
10379 return Constructed_TC;
10380 end Make_Constructed_TypeCode;
10381
10382 ---------------------------------
10383 -- Return_Constructed_TypeCode --
10384 ---------------------------------
10385
10386 procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
10387 begin
10388 Append_To (Stms,
10389 Make_Simple_Return_Statement (Loc,
10390 Expression =>
10391 Make_Constructed_TypeCode (Kind, Parameters)));
10392 end Return_Constructed_TypeCode;
10393
10394 ------------------
10395 -- Record types --
10396 ------------------
10397
10398 procedure TC_Rec_Add_Process_Element
10399 (Params : List_Id;
10400 Any : Entity_Id;
10401 Counter : in out Int;
10402 Rec : Entity_Id;
10403 Field : Node_Id);
10404
10405 procedure TC_Append_Record_Traversal is
10406 new Append_Record_Traversal (
10407 Rec => Empty,
10408 Add_Process_Element => TC_Rec_Add_Process_Element);
10409
10410 --------------------------------
10411 -- TC_Rec_Add_Process_Element --
10412 --------------------------------
10413
10414 procedure TC_Rec_Add_Process_Element
10415 (Params : List_Id;
10416 Any : Entity_Id;
10417 Counter : in out Int;
10418 Rec : Entity_Id;
10419 Field : Node_Id)
10420 is
10421 pragma Unreferenced (Any, Counter, Rec);
10422
10423 begin
10424 if Nkind (Field) = N_Defining_Identifier then
10425
10426 -- A regular component
10427
10428 Add_TypeCode_Parameter
10429 (Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
10430 Get_Name_String (Chars (Field));
10431 Add_String_Parameter (String_From_Name_Buffer, Params);
10432
10433 else
10434
10435 -- A variant part
10436
10437 Variant_Part : declare
10438 Disc_Type : constant Entity_Id := Etype (Name (Field));
10439
10440 Is_Enum : constant Boolean :=
10441 Is_Enumeration_Type (Disc_Type);
10442
10443 Union_TC_Params : List_Id;
10444
10445 U_Name : constant Name_Id :=
10446 New_External_Name (Chars (Typ), 'V', -1);
10447
10448 Name_Str : String_Id;
10449 Struct_TC_Params : List_Id;
10450
10451 Variant : Node_Id;
10452 Choice : Node_Id;
10453 Default : constant Node_Id :=
10454 Make_Integer_Literal (Loc, -1);
10455
10456 Dummy_Counter : Int := 0;
10457
10458 Choice_Index : Int := 0;
10459 -- Index of current choice in TypeCode, used to identify
10460 -- it as the default choice if it is a "when others".
10461
10462 procedure Add_Params_For_Variant_Components;
10463 -- Add a struct TypeCode and a corresponding member name
10464 -- to the union parameter list.
10465
10466 -- Ordering of declarations is a complete mess in this
10467 -- area, it is supposed to be types/variables, then
10468 -- subprogram specs, then subprogram bodies ???
10469
10470 ---------------------------------------
10471 -- Add_Params_For_Variant_Components --
10472 ---------------------------------------
10473
10474 procedure Add_Params_For_Variant_Components is
10475 S_Name : constant Name_Id :=
10476 New_External_Name (U_Name, 'S', -1);
10477
10478 begin
10479 Get_Name_String (S_Name);
10480 Name_Str := String_From_Name_Buffer;
10481 Initialize_Parameter_List
10482 (Name_Str, Name_Str, Struct_TC_Params);
10483
10484 -- Build struct parameters
10485
10486 TC_Append_Record_Traversal (Struct_TC_Params,
10487 Component_List (Variant),
10488 Empty,
10489 Dummy_Counter);
10490
10491 Add_TypeCode_Parameter
10492 (Make_Constructed_TypeCode
10493 (RTE (RE_Tk_Struct), Struct_TC_Params),
10494 Union_TC_Params);
10495
10496 Add_String_Parameter (Name_Str, Union_TC_Params);
10497 end Add_Params_For_Variant_Components;
10498
10499 -- Start of processing for Variant_Part
10500
10501 begin
10502 Get_Name_String (U_Name);
10503 Name_Str := String_From_Name_Buffer;
10504
10505 Initialize_Parameter_List
10506 (Name_Str, Name_Str, Union_TC_Params);
10507
10508 -- Add union in enclosing parameter list
10509
10510 Add_TypeCode_Parameter
10511 (Make_Constructed_TypeCode
10512 (RTE (RE_Tk_Union), Union_TC_Params),
10513 Params);
10514
10515 Add_String_Parameter (Name_Str, Params);
10516
10517 -- Build union parameters
10518
10519 Add_TypeCode_Parameter
10520 (Build_TypeCode_Call (Loc, Disc_Type, Decls),
10521 Union_TC_Params);
10522
10523 Add_Long_Parameter (Default, Union_TC_Params);
10524
10525 Variant := First_Non_Pragma (Variants (Field));
10526 while Present (Variant) loop
10527 Choice := First (Discrete_Choices (Variant));
10528 while Present (Choice) loop
10529 case Nkind (Choice) is
10530 when N_Range =>
10531 declare
10532 L : constant Uint :=
10533 Expr_Value (Low_Bound (Choice));
10534 H : constant Uint :=
10535 Expr_Value (High_Bound (Choice));
10536 J : Uint := L;
10537 -- 3.8.1(8) guarantees that the bounds of
10538 -- this range are static.
10539
10540 Expr : Node_Id;
10541
10542 begin
10543 while J <= H loop
10544 if Is_Enum then
10545 Expr := Get_Enum_Lit_From_Pos
10546 (Disc_Type, J, Loc);
10547 else
10548 Expr :=
10549 Make_Integer_Literal (Loc, J);
10550 end if;
10551
10552 Set_Etype (Expr, Disc_Type);
10553 Append_To (Union_TC_Params,
10554 Build_To_Any_Call (Loc, Expr, Decls));
10555
10556 Add_Params_For_Variant_Components;
10557 J := J + Uint_1;
10558 end loop;
10559
10560 Choice_Index :=
10561 Choice_Index + UI_To_Int (H - L) + 1;
10562 end;
10563
10564 when N_Others_Choice =>
10565
10566 -- This variant has a default choice. We must
10567 -- therefore set the default parameter to the
10568 -- current choice index. This parameter is by
10569 -- construction the 4th in Union_TC_Params.
10570
10571 Replace
10572 (Pick (Union_TC_Params, 4),
10573 Make_Function_Call (Loc,
10574 Name =>
10575 New_Occurrence_Of
10576 (RTE (RE_TA_I32), Loc),
10577 Parameter_Associations =>
10578 New_List (
10579 Make_Integer_Literal (Loc,
10580 Intval => Choice_Index))));
10581
10582 -- Add a placeholder member label for the
10583 -- default case, which must have the
10584 -- discriminant type.
10585
10586 declare
10587 Exp : constant Node_Id :=
10588 Make_Attribute_Reference (Loc,
10589 Prefix => New_Occurrence_Of
10590 (Disc_Type, Loc),
10591 Attribute_Name => Name_First);
10592 begin
10593 Set_Etype (Exp, Disc_Type);
10594 Append_To (Union_TC_Params,
10595 Build_To_Any_Call (Loc, Exp, Decls));
10596 end;
10597
10598 Add_Params_For_Variant_Components;
10599 Choice_Index := Choice_Index + 1;
10600
10601 -- Case of an explicit choice
10602
10603 when others =>
10604 declare
10605 Exp : constant Node_Id :=
10606 New_Copy_Tree (Choice);
10607 begin
10608 Append_To (Union_TC_Params,
10609 Build_To_Any_Call (Loc, Exp, Decls));
10610 end;
10611
10612 Add_Params_For_Variant_Components;
10613 Choice_Index := Choice_Index + 1;
10614 end case;
10615
10616 Next (Choice);
10617 end loop;
10618
10619 Next_Non_Pragma (Variant);
10620 end loop;
10621 end Variant_Part;
10622 end if;
10623 end TC_Rec_Add_Process_Element;
10624
10625 Type_Name_Str : String_Id;
10626 Type_Repo_Id_Str : String_Id;
10627
10628 -- Start of processing for Build_TypeCode_Function
10629
10630 begin
10631 -- For a derived type, we can't go past the base type (to the
10632 -- parent type) here, because that would cause the attribute's
10633 -- formal parameter to have the wrong type; hence the Base_Type
10634 -- check here.
10635
10636 if Is_Itype (Typ) and then Typ /= Base_Type (Typ) then
10637 Build_TypeCode_Function
10638 (Loc => Loc,
10639 Typ => Etype (Typ),
10640 Decl => Decl,
10641 Fnam => Fnam);
10642 return;
10643 end if;
10644
10645 Fnam := TCNam;
10646
10647 Spec :=
10648 Make_Function_Specification (Loc,
10649 Defining_Unit_Name => Fnam,
10650 Parameter_Specifications => Empty_List,
10651 Result_Definition =>
10652 New_Occurrence_Of (RTE (RE_TypeCode), Loc));
10653
10654 Build_Name_And_Repository_Id (Typ,
10655 Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
10656
10657 Initialize_Parameter_List
10658 (Type_Name_Str, Type_Repo_Id_Str, Parameters);
10659
10660 if Has_Stream_Attribute_Definition
10661 (Typ, TSS_Stream_Output, At_Any_Place => True)
10662 or else
10663 Has_Stream_Attribute_Definition
10664 (Typ, TSS_Stream_Write, At_Any_Place => True)
10665 then
10666 -- If user-defined stream attributes are specified for this
10667 -- type, use them and transmit data as an opaque sequence of
10668 -- stream elements.
10669
10670 Return_Alias_TypeCode
10671 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10672
10673 elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
10674 Return_Alias_TypeCode (
10675 Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10676
10677 elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
10678 Return_Alias_TypeCode (
10679 Build_TypeCode_Call (Loc,
10680 Find_Numeric_Representation (Typ), Decls));
10681
10682 elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
10683
10684 -- Record typecodes are encoded as follows:
10685 -- -- TC_STRUCT
10686 -- |
10687 -- | [Name]
10688 -- | [Repository Id]
10689 --
10690 -- Then for each discriminant:
10691 --
10692 -- | [Discriminant Type Code]
10693 -- | [Discriminant Name]
10694 -- | ...
10695 --
10696 -- Then for each component:
10697 --
10698 -- | [Component Type Code]
10699 -- | [Component Name]
10700 -- | ...
10701 --
10702 -- Variants components type codes are encoded as follows:
10703 -- -- TC_UNION
10704 -- |
10705 -- | [Name]
10706 -- | [Repository Id]
10707 -- | [Discriminant Type Code]
10708 -- | [Index of Default Variant Part or -1 for no default]
10709 --
10710 -- Then for each Variant Part :
10711 --
10712 -- | [VP Label]
10713 -- |
10714 -- | -- TC_STRUCT
10715 -- | | [Variant Part Name]
10716 -- | | [Variant Part Repository Id]
10717 -- | |
10718 -- | Then for each VP component:
10719 -- | | [VP component Typecode]
10720 -- | | [VP component Name]
10721 -- | | ...
10722 -- | --
10723 -- |
10724 -- | [VP Name]
10725
10726 if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
10727 Return_Alias_TypeCode
10728 (Build_TypeCode_Call (Loc, Etype (Typ), Decls));
10729
10730 else
10731 declare
10732 Disc : Entity_Id := Empty;
10733 Rdef : constant Node_Id :=
10734 Type_Definition (Declaration_Node (Typ));
10735 Dummy_Counter : Int := 0;
10736
10737 begin
10738 -- Construct the discriminants typecodes
10739
10740 if Has_Discriminants (Typ) then
10741 Disc := First_Discriminant (Typ);
10742 end if;
10743
10744 while Present (Disc) loop
10745 Add_TypeCode_Parameter (
10746 Build_TypeCode_Call (Loc, Etype (Disc), Decls),
10747 Parameters);
10748 Get_Name_String (Chars (Disc));
10749 Add_String_Parameter (
10750 String_From_Name_Buffer,
10751 Parameters);
10752 Next_Discriminant (Disc);
10753 end loop;
10754
10755 -- then the components typecodes
10756
10757 TC_Append_Record_Traversal
10758 (Parameters, Component_List (Rdef),
10759 Empty, Dummy_Counter);
10760 Return_Constructed_TypeCode (RTE (RE_Tk_Struct));
10761 end;
10762 end if;
10763
10764 elsif Is_Array_Type (Typ) then
10765 declare
10766 Ndim : constant Pos := Number_Dimensions (Typ);
10767 Inner_TypeCode : Node_Id;
10768 Constrained : constant Boolean := Is_Constrained (Typ);
10769 Indx : Node_Id := First_Index (Typ);
10770
10771 begin
10772 Inner_TypeCode :=
10773 Build_TypeCode_Call (Loc, Component_Type (Typ), Decls);
10774
10775 for J in 1 .. Ndim loop
10776 if Constrained then
10777 Inner_TypeCode := Make_Constructed_TypeCode
10778 (RTE (RE_Tk_Array), New_List (
10779 Build_To_Any_Call (Loc,
10780 OK_Convert_To (RTE (RE_Unsigned_32),
10781 Make_Attribute_Reference (Loc,
10782 Prefix => New_Occurrence_Of (Typ, Loc),
10783 Attribute_Name => Name_Length,
10784 Expressions => New_List (
10785 Make_Integer_Literal (Loc,
10786 Intval => Ndim - J + 1)))),
10787 Decls),
10788 Build_To_Any_Call (Loc, Inner_TypeCode, Decls)));
10789
10790 else
10791 -- Unconstrained case: add low bound for each
10792 -- dimension.
10793
10794 Add_TypeCode_Parameter
10795 (Build_TypeCode_Call (Loc, Etype (Indx), Decls),
10796 Parameters);
10797 Get_Name_String (New_External_Name ('L', J));
10798 Add_String_Parameter (
10799 String_From_Name_Buffer,
10800 Parameters);
10801 Next_Index (Indx);
10802
10803 Inner_TypeCode := Make_Constructed_TypeCode
10804 (RTE (RE_Tk_Sequence), New_List (
10805 Build_To_Any_Call (Loc,
10806 OK_Convert_To (RTE (RE_Unsigned_32),
10807 Make_Integer_Literal (Loc, 0)),
10808 Decls),
10809 Build_To_Any_Call (Loc, Inner_TypeCode, Decls)));
10810 end if;
10811 end loop;
10812
10813 if Constrained then
10814 Return_Alias_TypeCode (Inner_TypeCode);
10815 else
10816 Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
10817 Start_String;
10818 Store_String_Char ('V');
10819 Add_String_Parameter (End_String, Parameters);
10820 Return_Constructed_TypeCode (RTE (RE_Tk_Struct));
10821 end if;
10822 end;
10823
10824 else
10825 -- Default: type is represented as an opaque sequence of bytes
10826
10827 Return_Alias_TypeCode
10828 (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
10829 end if;
10830
10831 Decl :=
10832 Make_Subprogram_Body (Loc,
10833 Specification => Spec,
10834 Declarations => Decls,
10835 Handled_Statement_Sequence =>
10836 Make_Handled_Sequence_Of_Statements (Loc,
10837 Statements => Stms));
10838 end Build_TypeCode_Function;
10839
10840 ---------------------------------
10841 -- Find_Numeric_Representation --
10842 ---------------------------------
10843
10844 function Find_Numeric_Representation
10845 (Typ : Entity_Id) return Entity_Id
10846 is
10847 FST : constant Entity_Id := First_Subtype (Typ);
10848 P_Size : constant Uint := Esize (FST);
10849
10850 begin
10851 -- Special case: for Stream_Element_Offset and Storage_Offset,
10852 -- always force transmission as a 64-bit value.
10853
10854 if Is_RTE (FST, RE_Stream_Element_Offset)
10855 or else
10856 Is_RTE (FST, RE_Storage_Offset)
10857 then
10858 return RTE (RE_Unsigned_64);
10859 end if;
10860
10861 if Is_Unsigned_Type (Typ) then
10862 if P_Size <= 8 then
10863 return RTE (RE_Unsigned_8);
10864
10865 elsif P_Size <= 16 then
10866 return RTE (RE_Unsigned_16);
10867
10868 elsif P_Size <= 32 then
10869 return RTE (RE_Unsigned_32);
10870
10871 else
10872 return RTE (RE_Unsigned_64);
10873 end if;
10874
10875 elsif Is_Integer_Type (Typ) then
10876 if P_Size <= 8 then
10877 return RTE (RE_Integer_8);
10878
10879 elsif P_Size <= Standard_Short_Integer_Size then
10880 return RTE (RE_Integer_16);
10881
10882 elsif P_Size <= Standard_Integer_Size then
10883 return RTE (RE_Integer_32);
10884
10885 else
10886 return RTE (RE_Integer_64);
10887 end if;
10888
10889 elsif Is_Floating_Point_Type (Typ) then
10890 if P_Size <= Standard_Short_Float_Size then
10891 return Standard_Short_Float;
10892
10893 elsif P_Size <= Standard_Float_Size then
10894 return Standard_Float;
10895
10896 elsif P_Size <= Standard_Long_Float_Size then
10897 return Standard_Long_Float;
10898
10899 else
10900 return Standard_Long_Long_Float;
10901 end if;
10902
10903 else
10904 raise Program_Error;
10905 end if;
10906
10907 -- TBD: fixed point types???
10908 -- TBverified numeric types with a biased representation???
10909
10910 end Find_Numeric_Representation;
10911
10912 ---------------------------
10913 -- Append_Array_Traversal --
10914 ---------------------------
10915
10916 procedure Append_Array_Traversal
10917 (Stmts : List_Id;
10918 Any : Entity_Id;
10919 Counter : Entity_Id := Empty;
10920 Depth : Pos := 1)
10921 is
10922 Loc : constant Source_Ptr := Sloc (Subprogram);
10923 Typ : constant Entity_Id := Etype (Arry);
10924 Constrained : constant Boolean := Is_Constrained (Typ);
10925 Ndim : constant Pos := Number_Dimensions (Typ);
10926
10927 Inner_Any, Inner_Counter : Entity_Id;
10928
10929 Loop_Stm : Node_Id;
10930 Inner_Stmts : constant List_Id := New_List;
10931
10932 begin
10933 if Depth > Ndim then
10934
10935 -- Processing for one element of an array
10936
10937 declare
10938 Element_Expr : constant Node_Id :=
10939 Make_Indexed_Component (Loc,
10940 New_Occurrence_Of (Arry, Loc),
10941 Indexes);
10942 begin
10943 Set_Etype (Element_Expr, Component_Type (Typ));
10944 Add_Process_Element (Stmts,
10945 Any => Any,
10946 Counter => Counter,
10947 Datum => Element_Expr);
10948 end;
10949
10950 return;
10951 end if;
10952
10953 Append_To (Indexes,
10954 Make_Identifier (Loc, New_External_Name ('L', Depth)));
10955
10956 if not Constrained or else Depth > 1 then
10957 Inner_Any := Make_Defining_Identifier (Loc,
10958 New_External_Name ('A', Depth));
10959 Set_Etype (Inner_Any, RTE (RE_Any));
10960 else
10961 Inner_Any := Empty;
10962 end if;
10963
10964 if Present (Counter) then
10965 Inner_Counter := Make_Defining_Identifier (Loc,
10966 New_External_Name ('J', Depth));
10967 else
10968 Inner_Counter := Empty;
10969 end if;
10970
10971 declare
10972 Loop_Any : Node_Id := Inner_Any;
10973
10974 begin
10975 -- For the first dimension of a constrained array, we add
10976 -- elements directly in the corresponding Any; there is no
10977 -- intervening inner Any.
10978
10979 if No (Loop_Any) then
10980 Loop_Any := Any;
10981 end if;
10982
10983 Append_Array_Traversal (Inner_Stmts,
10984 Any => Loop_Any,
10985 Counter => Inner_Counter,
10986 Depth => Depth + 1);
10987 end;
10988
10989 Loop_Stm :=
10990 Make_Implicit_Loop_Statement (Subprogram,
10991 Iteration_Scheme =>
10992 Make_Iteration_Scheme (Loc,
10993 Loop_Parameter_Specification =>
10994 Make_Loop_Parameter_Specification (Loc,
10995 Defining_Identifier =>
10996 Make_Defining_Identifier (Loc,
10997 Chars => New_External_Name ('L', Depth)),
10998
10999 Discrete_Subtype_Definition =>
11000 Make_Attribute_Reference (Loc,
11001 Prefix => New_Occurrence_Of (Arry, Loc),
11002 Attribute_Name => Name_Range,
11003
11004 Expressions => New_List (
11005 Make_Integer_Literal (Loc, Depth))))),
11006 Statements => Inner_Stmts);
11007
11008 declare
11009 Decls : constant List_Id := New_List;
11010 Dimen_Stmts : constant List_Id := New_List;
11011 Length_Node : Node_Id;
11012
11013 Inner_Any_TypeCode : constant Entity_Id :=
11014 Make_Defining_Identifier (Loc,
11015 New_External_Name ('T', Depth));
11016
11017 Inner_Any_TypeCode_Expr : Node_Id;
11018
11019 begin
11020 if Depth = 1 then
11021 if Constrained then
11022 Inner_Any_TypeCode_Expr :=
11023 Make_Function_Call (Loc,
11024 Name => New_Occurrence_Of (RTE (RE_Get_TC), Loc),
11025 Parameter_Associations => New_List (
11026 New_Occurrence_Of (Any, Loc)));
11027
11028 else
11029 Inner_Any_TypeCode_Expr :=
11030 Make_Function_Call (Loc,
11031 Name =>
11032 New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
11033 Parameter_Associations => New_List (
11034 New_Occurrence_Of (Any, Loc),
11035 Make_Integer_Literal (Loc, Ndim)));
11036 end if;
11037
11038 else
11039 Inner_Any_TypeCode_Expr :=
11040 Make_Function_Call (Loc,
11041 Name => New_Occurrence_Of (RTE (RE_Content_Type), Loc),
11042 Parameter_Associations => New_List (
11043 Make_Identifier (Loc,
11044 Chars => New_External_Name ('T', Depth - 1))));
11045 end if;
11046
11047 Append_To (Decls,
11048 Make_Object_Declaration (Loc,
11049 Defining_Identifier => Inner_Any_TypeCode,
11050 Constant_Present => True,
11051 Object_Definition => New_Occurrence_Of (
11052 RTE (RE_TypeCode), Loc),
11053 Expression => Inner_Any_TypeCode_Expr));
11054
11055 if Present (Inner_Any) then
11056 Append_To (Decls,
11057 Make_Object_Declaration (Loc,
11058 Defining_Identifier => Inner_Any,
11059 Object_Definition =>
11060 New_Occurrence_Of (RTE (RE_Any), Loc),
11061 Expression =>
11062 Make_Function_Call (Loc,
11063 Name =>
11064 New_Occurrence_Of (
11065 RTE (RE_Create_Any), Loc),
11066 Parameter_Associations => New_List (
11067 New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
11068 end if;
11069
11070 if Present (Inner_Counter) then
11071 Append_To (Decls,
11072 Make_Object_Declaration (Loc,
11073 Defining_Identifier => Inner_Counter,
11074 Object_Definition =>
11075 New_Occurrence_Of (RTE (RE_Unsigned_32), Loc),
11076 Expression =>
11077 Make_Integer_Literal (Loc, 0)));
11078 end if;
11079
11080 if not Constrained then
11081 Length_Node := Make_Attribute_Reference (Loc,
11082 Prefix => New_Occurrence_Of (Arry, Loc),
11083 Attribute_Name => Name_Length,
11084 Expressions =>
11085 New_List (Make_Integer_Literal (Loc, Depth)));
11086 Set_Etype (Length_Node, RTE (RE_Unsigned_32));
11087
11088 Add_Process_Element (Dimen_Stmts,
11089 Datum => Length_Node,
11090 Any => Inner_Any,
11091 Counter => Inner_Counter);
11092 end if;
11093
11094 -- Loop_Stm does appropriate processing for each element
11095 -- of Inner_Any.
11096
11097 Append_To (Dimen_Stmts, Loop_Stm);
11098
11099 -- Link outer and inner any
11100
11101 if Present (Inner_Any) then
11102 Add_Process_Element (Dimen_Stmts,
11103 Any => Any,
11104 Counter => Counter,
11105 Datum => New_Occurrence_Of (Inner_Any, Loc));
11106 end if;
11107
11108 Append_To (Stmts,
11109 Make_Block_Statement (Loc,
11110 Declarations =>
11111 Decls,
11112 Handled_Statement_Sequence =>
11113 Make_Handled_Sequence_Of_Statements (Loc,
11114 Statements => Dimen_Stmts)));
11115 end;
11116 end Append_Array_Traversal;
11117
11118 -------------------------------
11119 -- Make_Helper_Function_Name --
11120 -------------------------------
11121
11122 function Make_Helper_Function_Name
11123 (Loc : Source_Ptr;
11124 Typ : Entity_Id;
11125 Nam : Name_Id) return Entity_Id
11126 is
11127 begin
11128 declare
11129 Serial : Nat := 0;
11130 -- For tagged types that aren't frozen yet, generate the helper
11131 -- under its canonical name so that it matches the primitive
11132 -- spec. For all other cases, we use a serialized name so that
11133 -- multiple generations of the same procedure do not clash.
11134
11135 begin
11136 if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then
11137 null;
11138 else
11139 Serial := Increment_Serial_Number;
11140 end if;
11141
11142 -- Use prefixed underscore to avoid potential clash with user
11143 -- identifier (we use attribute names for Nam).
11144
11145 return
11146 Make_Defining_Identifier (Loc,
11147 Chars =>
11148 New_External_Name
11149 (Related_Id => Nam,
11150 Suffix => ' ',
11151 Suffix_Index => Serial,
11152 Prefix => '_'));
11153 end;
11154 end Make_Helper_Function_Name;
11155 end Helpers;
11156
11157 -----------------------------------
11158 -- Reserve_NamingContext_Methods --
11159 -----------------------------------
11160
11161 procedure Reserve_NamingContext_Methods is
11162 Str_Resolve : constant String := "resolve";
11163 begin
11164 Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
11165 Name_Len := Str_Resolve'Length;
11166 Overload_Counter_Table.Set (Name_Find, 1);
11167 end Reserve_NamingContext_Methods;
11168
11169 -----------------------
11170 -- RPC_Receiver_Decl --
11171 -----------------------
11172
11173 function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is
11174 Loc : constant Source_Ptr := Sloc (RACW_Type);
11175 begin
11176 return
11177 Make_Object_Declaration (Loc,
11178 Defining_Identifier => Make_Temporary (Loc, 'R'),
11179 Aliased_Present => True,
11180 Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc));
11181 end RPC_Receiver_Decl;
11182
11183 end PolyORB_Support;
11184
11185 -------------------------------
11186 -- RACW_Type_Is_Asynchronous --
11187 -------------------------------
11188
11189 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
11190 Asynchronous_Flag : constant Entity_Id :=
11191 Asynchronous_Flags_Table.Get (RACW_Type);
11192 begin
11193 Replace (Expression (Parent (Asynchronous_Flag)),
11194 New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
11195 end RACW_Type_Is_Asynchronous;
11196
11197 -------------------------
11198 -- RCI_Package_Locator --
11199 -------------------------
11200
11201 function RCI_Package_Locator
11202 (Loc : Source_Ptr;
11203 Package_Spec : Node_Id) return Node_Id
11204 is
11205 Inst : Node_Id;
11206 Pkg_Name : constant String_Id :=
11207 Fully_Qualified_Name_String
11208 (Defining_Entity (Package_Spec), Append_NUL => False);
11209
11210 begin
11211 Inst :=
11212 Make_Package_Instantiation (Loc,
11213 Defining_Unit_Name => Make_Temporary (Loc, 'R'),
11214
11215 Name =>
11216 New_Occurrence_Of (RTE (RE_RCI_Locator), Loc),
11217
11218 Generic_Associations => New_List (
11219 Make_Generic_Association (Loc,
11220 Selector_Name =>
11221 Make_Identifier (Loc, Name_RCI_Name),
11222 Explicit_Generic_Actual_Parameter =>
11223 Make_String_Literal (Loc,
11224 Strval => Pkg_Name)),
11225
11226 Make_Generic_Association (Loc,
11227 Selector_Name =>
11228 Make_Identifier (Loc, Name_Version),
11229 Explicit_Generic_Actual_Parameter =>
11230 Make_Attribute_Reference (Loc,
11231 Prefix =>
11232 New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
11233 Attribute_Name =>
11234 Name_Version))));
11235
11236 RCI_Locator_Table.Set
11237 (Defining_Unit_Name (Package_Spec),
11238 Defining_Unit_Name (Inst));
11239 return Inst;
11240 end RCI_Package_Locator;
11241
11242 -----------------------------------------------
11243 -- Remote_Types_Tagged_Full_View_Encountered --
11244 -----------------------------------------------
11245
11246 procedure Remote_Types_Tagged_Full_View_Encountered
11247 (Full_View : Entity_Id)
11248 is
11249 Stub_Elements : constant Stub_Structure :=
11250 Stubs_Table.Get (Full_View);
11251
11252 begin
11253 -- For an RACW encountered before the freeze point of its designated
11254 -- type, the stub type is generated at the point of the RACW declaration
11255 -- but the primitives are generated only once the designated type is
11256 -- frozen. That freeze can occur in another scope, for example when the
11257 -- RACW is declared in a nested package. In that case we need to
11258 -- reestablish the stub type's scope prior to generating its primitive
11259 -- operations.
11260
11261 if Stub_Elements /= Empty_Stub_Structure then
11262 declare
11263 Saved_Scope : constant Entity_Id := Current_Scope;
11264 Stubs_Scope : constant Entity_Id :=
11265 Scope (Stub_Elements.Stub_Type);
11266
11267 begin
11268 if Current_Scope /= Stubs_Scope then
11269 Push_Scope (Stubs_Scope);
11270 end if;
11271
11272 Add_RACW_Primitive_Declarations_And_Bodies
11273 (Full_View,
11274 Stub_Elements.RPC_Receiver_Decl,
11275 Stub_Elements.Body_Decls);
11276
11277 if Current_Scope /= Saved_Scope then
11278 Pop_Scope;
11279 end if;
11280 end;
11281 end if;
11282 end Remote_Types_Tagged_Full_View_Encountered;
11283
11284 -------------------
11285 -- Scope_Of_Spec --
11286 -------------------
11287
11288 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
11289 Unit_Name : Node_Id;
11290
11291 begin
11292 Unit_Name := Defining_Unit_Name (Spec);
11293 while Nkind (Unit_Name) /= N_Defining_Identifier loop
11294 Unit_Name := Defining_Identifier (Unit_Name);
11295 end loop;
11296
11297 return Unit_Name;
11298 end Scope_Of_Spec;
11299
11300 ----------------------
11301 -- Set_Renaming_TSS --
11302 ----------------------
11303
11304 procedure Set_Renaming_TSS
11305 (Typ : Entity_Id;
11306 Nam : Entity_Id;
11307 TSS_Nam : TSS_Name_Type)
11308 is
11309 Loc : constant Source_Ptr := Sloc (Nam);
11310 Spec : constant Node_Id := Parent (Nam);
11311
11312 TSS_Node : constant Node_Id :=
11313 Make_Subprogram_Renaming_Declaration (Loc,
11314 Specification =>
11315 Copy_Specification (Loc,
11316 Spec => Spec,
11317 New_Name => Make_TSS_Name (Typ, TSS_Nam)),
11318 Name => New_Occurrence_Of (Nam, Loc));
11319
11320 Snam : constant Entity_Id :=
11321 Defining_Unit_Name (Specification (TSS_Node));
11322
11323 begin
11324 if Nkind (Spec) = N_Function_Specification then
11325 Set_Ekind (Snam, E_Function);
11326 Set_Etype (Snam, Entity (Result_Definition (Spec)));
11327 else
11328 Set_Ekind (Snam, E_Procedure);
11329 Set_Etype (Snam, Standard_Void_Type);
11330 end if;
11331
11332 Set_TSS (Typ, Snam);
11333 end Set_Renaming_TSS;
11334
11335 ----------------------------------------------
11336 -- Specific_Add_Obj_RPC_Receiver_Completion --
11337 ----------------------------------------------
11338
11339 procedure Specific_Add_Obj_RPC_Receiver_Completion
11340 (Loc : Source_Ptr;
11341 Decls : List_Id;
11342 RPC_Receiver : Entity_Id;
11343 Stub_Elements : Stub_Structure)
11344 is
11345 begin
11346 case Get_PCS_Name is
11347 when Name_PolyORB_DSA =>
11348 PolyORB_Support.Add_Obj_RPC_Receiver_Completion
11349 (Loc, Decls, RPC_Receiver, Stub_Elements);
11350 when others =>
11351 GARLIC_Support.Add_Obj_RPC_Receiver_Completion
11352 (Loc, Decls, RPC_Receiver, Stub_Elements);
11353 end case;
11354 end Specific_Add_Obj_RPC_Receiver_Completion;
11355
11356 --------------------------------
11357 -- Specific_Add_RACW_Features --
11358 --------------------------------
11359
11360 procedure Specific_Add_RACW_Features
11361 (RACW_Type : Entity_Id;
11362 Desig : Entity_Id;
11363 Stub_Type : Entity_Id;
11364 Stub_Type_Access : Entity_Id;
11365 RPC_Receiver_Decl : Node_Id;
11366 Body_Decls : List_Id)
11367 is
11368 begin
11369 case Get_PCS_Name is
11370 when Name_PolyORB_DSA =>
11371 PolyORB_Support.Add_RACW_Features
11372 (RACW_Type,
11373 Desig,
11374 Stub_Type,
11375 Stub_Type_Access,
11376 RPC_Receiver_Decl,
11377 Body_Decls);
11378
11379 when others =>
11380 GARLIC_Support.Add_RACW_Features
11381 (RACW_Type,
11382 Stub_Type,
11383 Stub_Type_Access,
11384 RPC_Receiver_Decl,
11385 Body_Decls);
11386 end case;
11387 end Specific_Add_RACW_Features;
11388
11389 --------------------------------
11390 -- Specific_Add_RAST_Features --
11391 --------------------------------
11392
11393 procedure Specific_Add_RAST_Features
11394 (Vis_Decl : Node_Id;
11395 RAS_Type : Entity_Id)
11396 is
11397 begin
11398 case Get_PCS_Name is
11399 when Name_PolyORB_DSA =>
11400 PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11401 when others =>
11402 GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
11403 end case;
11404 end Specific_Add_RAST_Features;
11405
11406 --------------------------------------------------
11407 -- Specific_Add_Receiving_Stubs_To_Declarations --
11408 --------------------------------------------------
11409
11410 procedure Specific_Add_Receiving_Stubs_To_Declarations
11411 (Pkg_Spec : Node_Id;
11412 Decls : List_Id;
11413 Stmts : List_Id)
11414 is
11415 begin
11416 case Get_PCS_Name is
11417 when Name_PolyORB_DSA =>
11418 PolyORB_Support.Add_Receiving_Stubs_To_Declarations
11419 (Pkg_Spec, Decls, Stmts);
11420 when others =>
11421 GARLIC_Support.Add_Receiving_Stubs_To_Declarations
11422 (Pkg_Spec, Decls, Stmts);
11423 end case;
11424 end Specific_Add_Receiving_Stubs_To_Declarations;
11425
11426 ------------------------------------------
11427 -- Specific_Build_General_Calling_Stubs --
11428 ------------------------------------------
11429
11430 procedure Specific_Build_General_Calling_Stubs
11431 (Decls : List_Id;
11432 Statements : List_Id;
11433 Target : RPC_Target;
11434 Subprogram_Id : Node_Id;
11435 Asynchronous : Node_Id := Empty;
11436 Is_Known_Asynchronous : Boolean := False;
11437 Is_Known_Non_Asynchronous : Boolean := False;
11438 Is_Function : Boolean;
11439 Spec : Node_Id;
11440 Stub_Type : Entity_Id := Empty;
11441 RACW_Type : Entity_Id := Empty;
11442 Nod : Node_Id)
11443 is
11444 begin
11445 case Get_PCS_Name is
11446 when Name_PolyORB_DSA =>
11447 PolyORB_Support.Build_General_Calling_Stubs
11448 (Decls,
11449 Statements,
11450 Target.Object,
11451 Subprogram_Id,
11452 Asynchronous,
11453 Is_Known_Asynchronous,
11454 Is_Known_Non_Asynchronous,
11455 Is_Function,
11456 Spec,
11457 Stub_Type,
11458 RACW_Type,
11459 Nod);
11460
11461 when others =>
11462 GARLIC_Support.Build_General_Calling_Stubs
11463 (Decls,
11464 Statements,
11465 Target.Partition,
11466 Target.RPC_Receiver,
11467 Subprogram_Id,
11468 Asynchronous,
11469 Is_Known_Asynchronous,
11470 Is_Known_Non_Asynchronous,
11471 Is_Function,
11472 Spec,
11473 Stub_Type,
11474 RACW_Type,
11475 Nod);
11476 end case;
11477 end Specific_Build_General_Calling_Stubs;
11478
11479 --------------------------------------
11480 -- Specific_Build_RPC_Receiver_Body --
11481 --------------------------------------
11482
11483 procedure Specific_Build_RPC_Receiver_Body
11484 (RPC_Receiver : Entity_Id;
11485 Request : out Entity_Id;
11486 Subp_Id : out Entity_Id;
11487 Subp_Index : out Entity_Id;
11488 Stmts : out List_Id;
11489 Decl : out Node_Id)
11490 is
11491 begin
11492 case Get_PCS_Name is
11493 when Name_PolyORB_DSA =>
11494 PolyORB_Support.Build_RPC_Receiver_Body
11495 (RPC_Receiver,
11496 Request,
11497 Subp_Id,
11498 Subp_Index,
11499 Stmts,
11500 Decl);
11501
11502 when others =>
11503 GARLIC_Support.Build_RPC_Receiver_Body
11504 (RPC_Receiver,
11505 Request,
11506 Subp_Id,
11507 Subp_Index,
11508 Stmts,
11509 Decl);
11510 end case;
11511 end Specific_Build_RPC_Receiver_Body;
11512
11513 --------------------------------
11514 -- Specific_Build_Stub_Target --
11515 --------------------------------
11516
11517 function Specific_Build_Stub_Target
11518 (Loc : Source_Ptr;
11519 Decls : List_Id;
11520 RCI_Locator : Entity_Id;
11521 Controlling_Parameter : Entity_Id) return RPC_Target
11522 is
11523 begin
11524 case Get_PCS_Name is
11525 when Name_PolyORB_DSA =>
11526 return
11527 PolyORB_Support.Build_Stub_Target
11528 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11529
11530 when others =>
11531 return
11532 GARLIC_Support.Build_Stub_Target
11533 (Loc, Decls, RCI_Locator, Controlling_Parameter);
11534 end case;
11535 end Specific_Build_Stub_Target;
11536
11537 --------------------------------
11538 -- Specific_RPC_Receiver_Decl --
11539 --------------------------------
11540
11541 function Specific_RPC_Receiver_Decl
11542 (RACW_Type : Entity_Id) return Node_Id
11543 is
11544 begin
11545 case Get_PCS_Name is
11546 when Name_PolyORB_DSA =>
11547 return PolyORB_Support.RPC_Receiver_Decl (RACW_Type);
11548
11549 when others =>
11550 return GARLIC_Support.RPC_Receiver_Decl (RACW_Type);
11551 end case;
11552 end Specific_RPC_Receiver_Decl;
11553
11554 -----------------------------------------------
11555 -- Specific_Build_Subprogram_Receiving_Stubs --
11556 -----------------------------------------------
11557
11558 function Specific_Build_Subprogram_Receiving_Stubs
11559 (Vis_Decl : Node_Id;
11560 Asynchronous : Boolean;
11561 Dynamically_Asynchronous : Boolean := False;
11562 Stub_Type : Entity_Id := Empty;
11563 RACW_Type : Entity_Id := Empty;
11564 Parent_Primitive : Entity_Id := Empty) return Node_Id
11565 is
11566 begin
11567 case Get_PCS_Name is
11568 when Name_PolyORB_DSA =>
11569 return
11570 PolyORB_Support.Build_Subprogram_Receiving_Stubs
11571 (Vis_Decl,
11572 Asynchronous,
11573 Dynamically_Asynchronous,
11574 Stub_Type,
11575 RACW_Type,
11576 Parent_Primitive);
11577
11578 when others =>
11579 return
11580 GARLIC_Support.Build_Subprogram_Receiving_Stubs
11581 (Vis_Decl,
11582 Asynchronous,
11583 Dynamically_Asynchronous,
11584 Stub_Type,
11585 RACW_Type,
11586 Parent_Primitive);
11587 end case;
11588 end Specific_Build_Subprogram_Receiving_Stubs;
11589
11590 -------------------------------
11591 -- Transmit_As_Unconstrained --
11592 -------------------------------
11593
11594 function Transmit_As_Unconstrained (Typ : Entity_Id) return Boolean is
11595 begin
11596 return
11597 not (Is_Elementary_Type (Typ) or else Is_Constrained (Typ))
11598 or else (Is_Access_Type (Typ) and then Can_Never_Be_Null (Typ));
11599 end Transmit_As_Unconstrained;
11600
11601 --------------------------
11602 -- Underlying_RACW_Type --
11603 --------------------------
11604
11605 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
11606 Record_Type : Entity_Id;
11607
11608 begin
11609 if Ekind (RAS_Typ) = E_Record_Type then
11610 Record_Type := RAS_Typ;
11611 else
11612 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
11613 Record_Type := Equivalent_Type (RAS_Typ);
11614 end if;
11615
11616 return
11617 Etype (Subtype_Indication
11618 (Component_Definition
11619 (First (Component_Items
11620 (Component_List
11621 (Type_Definition
11622 (Declaration_Node (Record_Type))))))));
11623 end Underlying_RACW_Type;
11624
11625 end Exp_Dist;