?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* Merge with edge-vector-mergepoint-20040918.
[official-gcc.git] / gcc / ada / exp_dist.adb
blob7015079326942725535813f20972b0d3152900b2
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-2004 Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Exp_Strm; use Exp_Strm;
31 with Exp_Tss; use Exp_Tss;
32 with Exp_Util; use Exp_Util;
33 with GNAT.HTable; use GNAT.HTable;
34 with Lib; use Lib;
35 with Namet; use Namet;
36 with Nlists; use Nlists;
37 with Nmake; use Nmake;
38 with Opt; use Opt;
39 with Rtsfind; use Rtsfind;
40 with Sem; use Sem;
41 with Sem_Ch3; use Sem_Ch3;
42 with Sem_Ch8; use Sem_Ch8;
43 with Sem_Dist; use Sem_Dist;
44 with Sem_Util; use Sem_Util;
45 with Sinfo; use Sinfo;
46 with Snames; use Snames;
47 with Stand; use Stand;
48 with Stringt; use Stringt;
49 with Tbuild; use Tbuild;
50 with Uintp; use Uintp;
51 with Uname; use Uname;
52
53 package body Exp_Dist is
54
55 -- The following model has been used to implement distributed objects:
56 -- given a designated type D and a RACW type R, then a record of the
57 -- form:
58
59 -- type Stub is tagged record
60 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
61 -- end record;
62
63 -- is built. This type has two properties:
64
65 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
66 -- converted to and from this type to make it suitable for
67 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
68 -- to avoid memory leaks when the same remote object arrive on the
69 -- same partition through several paths;
70
71 -- 2) It also has the same dispatching table as the designated type D,
72 -- and thus can be used as an object designated by a value of type
73 -- R on any partition other than the one on which the object has
74 -- been created, since only dispatching calls will be performed and
75 -- the fields themselves will not be used. We call Derive_Subprograms
76 -- to fake half a derivation to ensure that the subprograms do have
77 -- the same dispatching table.
78
79 First_RCI_Subprogram_Id : constant := 2;
80 -- RCI subprograms are numbered starting at 2. The RCI receiver for
81 -- an RCI package can thus identify calls received through remote
82 -- access-to-subprogram dereferences by the fact that they have a
83 -- (primitive) subprogram id of 0, and 1 is used for the internal
84 -- RAS information lookup operation.
85
86 -----------------------
87 -- Local subprograms --
88 -----------------------
89
90 procedure Add_RAS_Proxy_And_Analyze
91 (Decls : List_Id;
92 Vis_Decl : Node_Id;
93 All_Calls_Remote_E : Entity_Id;
94 Proxy_Object_Addr : out Entity_Id);
95 -- Add the proxy type necessary to call the subprogram declared
96 -- by Vis_Decl through a remote access to subprogram type.
97 -- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote
98 -- applies, Standard_False otherwise. The new proxy type is appended
99 -- to Decls. Proxy_Object_Addr is a constant of type System.Address that
100 -- designates an instance of the proxy object.
101
102 function Build_Remote_Subprogram_Proxy_Type
103 (Loc : Source_Ptr;
104 ACR_Expression : Node_Id) return Node_Id;
105 -- Build and return a tagged record type definition for an RCI
106 -- subprogram proxy type.
107 -- ACR_Expression is use as the initialization value for
108 -- the All_Calls_Remote component.
109
110 function Get_Subprogram_Id (E : Entity_Id) return Int;
111 -- Given a subprogram defined in a RCI package, get its subprogram id
112 -- which will be used for remote calls.
113
114 function Build_Get_Unique_RP_Call
115 (Loc : Source_Ptr;
116 Pointer : Entity_Id;
117 Stub_Type : Entity_Id) return List_Id;
118 -- Build a call to Get_Unique_Remote_Pointer (Pointer),
119 -- followed by a tag fixup (Get_Unique_Remote_Pointer may have
120 -- changed Pointer'Tag to RACW_Stub_Type'Tag, while the desired
121 -- tag is that of Stub_Type).
122
123 procedure Build_General_Calling_Stubs
124 (Decls : List_Id;
125 Statements : List_Id;
126 Target_Partition : Entity_Id;
127 RPC_Receiver : Node_Id;
128 Subprogram_Id : Node_Id;
129 Asynchronous : Node_Id := Empty;
130 Is_Known_Asynchronous : Boolean := False;
131 Is_Known_Non_Asynchronous : Boolean := False;
132 Is_Function : Boolean;
133 Spec : Node_Id;
134 Object_Type : Entity_Id := Empty;
135 Nod : Node_Id);
136 -- Build calling stubs for general purpose. The parameters are:
137 -- Decls : a place to put declarations
138 -- Statements : a place to put statements
139 -- Target_Partition : a node containing the target partition that must
140 -- be a N_Defining_Identifier
141 -- RPC_Receiver : a node containing the RPC receiver
142 -- Subprogram_Id : a node containing the subprogram ID
143 -- Asynchronous : True if an APC must be made instead of an RPC.
144 -- The value needs not be supplied if one of the
145 -- Is_Known_... is True.
146 -- Is_Known_Async... : True if we know that this is asynchronous
147 -- Is_Known_Non_A... : True if we know that this is not asynchronous
148 -- Spec : a node with a Parameter_Specifications and
149 -- a Subtype_Mark if applicable
150 -- Object_Type : in case of a RACW, parameters of type access to
151 -- Object_Type will be marshalled using the
152 -- address of this object (the addr field) rather
153 -- than using the 'Write on the object itself
154 -- Nod : used to provide sloc for generated code
155
156 function Build_Subprogram_Calling_Stubs
157 (Vis_Decl : Node_Id;
158 Subp_Id : Int;
159 Asynchronous : Boolean;
160 Dynamically_Asynchronous : Boolean := False;
161 Stub_Type : Entity_Id := Empty;
162 Locator : Entity_Id := Empty;
163 New_Name : Name_Id := No_Name) return Node_Id;
164 -- Build the calling stub for a given subprogram with the subprogram ID
165 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
166 -- parameters of this type will be marshalled instead of the object
167 -- itself. It will then be converted into Stub_Type before performing
168 -- the real call. If Dynamically_Asynchronous is True, then it will be
169 -- computed at run time whether the call is asynchronous or not.
170 -- Otherwise, the value of the formal Asynchronous will be used.
171 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
172 -- New_Name is given, then it will be used instead of the original name.
173
174 function Build_Subprogram_Receiving_Stubs
175 (Vis_Decl : Node_Id;
176 Asynchronous : Boolean;
177 Dynamically_Asynchronous : Boolean := False;
178 Stub_Type : Entity_Id := Empty;
179 RACW_Type : Entity_Id := Empty;
180 Parent_Primitive : Entity_Id := Empty) return Node_Id;
181 -- Build the receiving stub for a given subprogram. The subprogram
182 -- declaration is also built by this procedure, and the value returned
183 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
184 -- found in the specification, then its address is read from the stream
185 -- instead of the object itself and converted into an access to
186 -- class-wide type before doing the real call using any of the RACW type
187 -- pointing on the designated type.
188
189 function Build_RPC_Receiver_Specification
190 (RPC_Receiver : Entity_Id;
191 Stream_Parameter : Entity_Id;
192 Result_Parameter : Entity_Id) return Node_Id;
193 -- Make a subprogram specification for an RPC receiver,
194 -- with the given defining unit name and formal parameters.
195
196 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
197 -- Return an ordered parameter list: unconstrained parameters are put
198 -- at the beginning of the list and constrained ones are put after. If
199 -- there are no parameters, an empty list is returned. Special case:
200 -- the controlling formal of the equivalent RACW operation for a RAS
201 -- type is always left in first position.
202
203 procedure Add_Calling_Stubs_To_Declarations
204 (Pkg_Spec : Node_Id;
205 Decls : List_Id);
206 -- Add calling stubs to the declarative part
207
208 procedure Add_Receiving_Stubs_To_Declarations
209 (Pkg_Spec : Node_Id;
210 Decls : List_Id);
211 -- Add receiving stubs to the declarative part
212
213 procedure Add_RAS_Dereference_TSS (N : Node_Id);
214 -- Add a subprogram body for RAS Dereference TSS
215
216 procedure Add_RAS_Access_TSS (N : Node_Id);
217 -- Add a subprogram body for RAS Access TSS
218
219 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
220 -- Return True if nothing prevents the program whose specification is
221 -- given to be asynchronous (i.e. no out parameter).
222
223 function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id;
224 function Get_String_Id (Val : String) return String_Id;
225 -- Ugly functions used to retrieve a package name. Inherited from the
226 -- old exp_dist.adb and not rewritten yet ???
227
228 function Pack_Entity_Into_Stream_Access
229 (Loc : Source_Ptr;
230 Stream : Node_Id;
231 Object : Entity_Id;
232 Etyp : Entity_Id := Empty) return Node_Id;
233 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
234 -- then Etype (Object) will be used if present. If the type is
235 -- constrained, then 'Write will be used to output the object,
236 -- If the type is unconstrained, 'Output will be used.
237
238 function Pack_Node_Into_Stream
239 (Loc : Source_Ptr;
240 Stream : Entity_Id;
241 Object : Node_Id;
242 Etyp : Entity_Id) return Node_Id;
243 -- Similar to above, with an arbitrary node instead of an entity
244
245 function Pack_Node_Into_Stream_Access
246 (Loc : Source_Ptr;
247 Stream : Node_Id;
248 Object : Node_Id;
249 Etyp : Entity_Id) return Node_Id;
250 -- Similar to above, with Stream instead of Stream'Access
251
252 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
253 -- Return the scope represented by a given spec
254
255 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
256 -- Return True if the current parameter needs an extra formal to reflect
257 -- its constrained status.
258
259 function Is_RACW_Controlling_Formal
260 (Parameter : Node_Id; Stub_Type : Entity_Id) return Boolean;
261 -- Return True if the current parameter is a controlling formal argument
262 -- of type Stub_Type or access to Stub_Type.
263
264 type Stub_Structure is record
265 Stub_Type : Entity_Id;
266 Stub_Type_Access : Entity_Id;
267 Object_RPC_Receiver : Entity_Id;
268 RPC_Receiver_Stream : Entity_Id;
269 RPC_Receiver_Result : Entity_Id;
270 RACW_Type : Entity_Id;
271 end record;
272 -- This structure is necessary because of the two phases analysis of
273 -- a RACW declaration occurring in the same Remote_Types package as the
274 -- designated type. RACW_Type is any of the RACW types pointing on this
275 -- designated type, it is used here to save an anonymous type creation
276 -- for each primitive operation.
277
278 Empty_Stub_Structure : constant Stub_Structure :=
279 (Empty, Empty, Empty, Empty, Empty, Empty);
280
281 type Hash_Index is range 0 .. 50;
282 function Hash (F : Entity_Id) return Hash_Index;
283
284 package Stubs_Table is
285 new Simple_HTable (Header_Num => Hash_Index,
286 Element => Stub_Structure,
287 No_Element => Empty_Stub_Structure,
288 Key => Entity_Id,
289 Hash => Hash,
290 Equal => "=");
291 -- Mapping between a RACW designated type and its stub type
292
293 package Asynchronous_Flags_Table is
294 new Simple_HTable (Header_Num => Hash_Index,
295 Element => Node_Id,
296 No_Element => Empty,
297 Key => Entity_Id,
298 Hash => Hash,
299 Equal => "=");
300 -- Mapping between a RACW type and the node holding the value True if
301 -- the RACW is asynchronous and False otherwise.
302
303 package RCI_Locator_Table is
304 new Simple_HTable (Header_Num => Hash_Index,
305 Element => Entity_Id,
306 No_Element => Empty,
307 Key => Entity_Id,
308 Hash => Hash,
309 Equal => "=");
310 -- Mapping between a RCI package on which All_Calls_Remote applies and
311 -- the generic instantiation of RCI_Info for this package.
312
313 package RCI_Calling_Stubs_Table is
314 new Simple_HTable (Header_Num => Hash_Index,
315 Element => Entity_Id,
316 No_Element => Empty,
317 Key => Entity_Id,
318 Hash => Hash,
319 Equal => "=");
320 -- Mapping between a RCI subprogram and the corresponding calling stubs
321
322 procedure Add_Stub_Type
323 (Designated_Type : Entity_Id;
324 RACW_Type : Entity_Id;
325 Decls : List_Id;
326 Stub_Type : out Entity_Id;
327 Stub_Type_Access : out Entity_Id;
328 Object_RPC_Receiver : out Entity_Id;
329 Existing : out Boolean);
330 -- Add the declaration of the stub type, the access to stub type and the
331 -- object RPC receiver at the end of Decls. If these already exist,
332 -- then nothing is added in the tree but the right values are returned
333 -- anyhow and Existing is set to True.
334
335 procedure Add_RACW_Read_Attribute
336 (RACW_Type : Entity_Id;
337 Stub_Type : Entity_Id;
338 Stub_Type_Access : Entity_Id;
339 Declarations : List_Id);
340 -- Add Read attribute in Decls for the RACW type. The Read attribute
341 -- is added right after the RACW_Type declaration while the body is
342 -- inserted after Declarations.
343
344 procedure Add_RACW_Write_Attribute
345 (RACW_Type : Entity_Id;
346 Stub_Type : Entity_Id;
347 Stub_Type_Access : Entity_Id;
348 Object_RPC_Receiver : Entity_Id;
349 Declarations : List_Id);
350 -- Same thing for the Write attribute
351
352 procedure Add_RACW_Read_Write_Attributes
353 (RACW_Type : Entity_Id;
354 Stub_Type : Entity_Id;
355 Stub_Type_Access : Entity_Id;
356 Object_RPC_Receiver : Entity_Id;
357 Declarations : List_Id);
358 -- Add Read and Write attributes declarations and bodies for a given
359 -- RACW type. The declarations are added just after the declaration
360 -- of the RACW type itself, while the bodies are inserted at the end
361 -- of Decls.
362
363 function RCI_Package_Locator
364 (Loc : Source_Ptr;
365 Package_Spec : Node_Id) return Node_Id;
366 -- Instantiate the generic package RCI_Info in order to locate the
367 -- RCI package whose spec is given as argument.
368
369 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
370 -- Surround a node N by a tag check, as in:
371 -- begin
372 -- <N>;
373 -- exception
374 -- when E : Ada.Tags.Tag_Error =>
375 -- Raise_Exception (Program_Error'Identity,
376 -- Exception_Message (E));
377 -- end;
378
379 function Input_With_Tag_Check
380 (Loc : Source_Ptr;
381 Var_Type : Entity_Id;
382 Stream : Entity_Id) return Node_Id;
383 -- Return a function with the following form:
384 -- function R return Var_Type is
385 -- begin
386 -- return Var_Type'Input (S);
387 -- exception
388 -- when E : Ada.Tags.Tag_Error =>
389 -- Raise_Exception (Program_Error'Identity,
390 -- Exception_Message (E));
391 -- end R;
392
393 ------------------------------------
394 -- Local variables and structures --
395 ------------------------------------
396
397 RCI_Cache : Node_Id;
398
399 Output_From_Constrained : constant array (Boolean) of Name_Id :=
400 (False => Name_Output,
401 True => Name_Write);
402 -- The attribute to choose depending on the fact that the parameter
403 -- is constrained or not. There is no such thing as Input_From_Constrained
404 -- since this require separate mechanisms ('Input is a function while
405 -- 'Read is a procedure).
406
407 ---------------------------------------
408 -- Add_Calling_Stubs_To_Declarations --
409 ---------------------------------------
410
411 procedure Add_Calling_Stubs_To_Declarations
412 (Pkg_Spec : Node_Id;
413 Decls : List_Id)
414 is
415 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
416 -- Subprogram id 0 is reserved for calls received from
417 -- remote access-to-subprogram dereferences.
418
419 Current_Declaration : Node_Id;
420 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
421 RCI_Instantiation : Node_Id;
422 Subp_Stubs : Node_Id;
423
424 begin
425 -- The first thing added is an instantiation of the generic package
426 -- System.Partition_interface.RCI_Info with the name of the (current)
427 -- remote package. This will act as an interface with the name server
428 -- to determine the Partition_ID and the RPC_Receiver for the
429 -- receiver of this package.
430
431 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
432 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
433
434 Append_To (Decls, RCI_Instantiation);
435 Analyze (RCI_Instantiation);
436
437 -- For each subprogram declaration visible in the spec, we do
438 -- build a body. We also increment a counter to assign a different
439 -- Subprogram_Id to each subprograms. The receiving stubs processing
440 -- do use the same mechanism and will thus assign the same Id and
441 -- do the correct dispatching.
442
443 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
444 while Current_Declaration /= Empty loop
445 if Nkind (Current_Declaration) = N_Subprogram_Declaration
446 and then Comes_From_Source (Current_Declaration)
447 then
448 pragma Assert (Current_Subprogram_Number =
449 Get_Subprogram_Id (Defining_Unit_Name (Specification (
450 Current_Declaration))));
451
452 Subp_Stubs :=
453 Build_Subprogram_Calling_Stubs (
454 Vis_Decl => Current_Declaration,
455 Subp_Id => Current_Subprogram_Number,
456 Asynchronous =>
457 Nkind (Specification (Current_Declaration)) =
458 N_Procedure_Specification
459 and then
460 Is_Asynchronous (Defining_Unit_Name (Specification
461 (Current_Declaration))));
462
463 Append_To (Decls, Subp_Stubs);
464 Analyze (Subp_Stubs);
465
466 Current_Subprogram_Number := Current_Subprogram_Number + 1;
467 end if;
468
469 Next (Current_Declaration);
470 end loop;
471 end Add_Calling_Stubs_To_Declarations;
472
473 -----------------------
474 -- Add_RACW_Features --
475 -----------------------
476
477 procedure Add_RACW_Features (RACW_Type : Entity_Id)
478 is
479 Desig : constant Entity_Id :=
480 Etype (Designated_Type (RACW_Type));
481 Decls : List_Id :=
482 List_Containing (Declaration_Node (RACW_Type));
483
484 Same_Scope : constant Boolean :=
485 Scope (Desig) = Scope (RACW_Type);
486
487 Stub_Type : Entity_Id;
488 Stub_Type_Access : Entity_Id;
489 Object_RPC_Receiver : Entity_Id;
490 Existing : Boolean;
491
492 begin
493 if not Expander_Active then
494 return;
495 end if;
496
497 if Same_Scope then
498
499 -- We are declaring a RACW in the same package than its designated
500 -- type, so the list to use for late declarations must be the
501 -- private part of the package. We do know that this private part
502 -- exists since the designated type has to be a private one.
503
504 Decls := Private_Declarations
505 (Package_Specification_Of_Scope (Current_Scope));
506
507 elsif Nkind (Parent (Decls)) = N_Package_Specification
508 and then Present (Private_Declarations (Parent (Decls)))
509 then
510 Decls := Private_Declarations (Parent (Decls));
511 end if;
512
513 -- If we were unable to find the declarations, that means that the
514 -- completion of the type was missing. We can safely return and let
515 -- the error be caught by the semantic analysis.
516
517 if No (Decls) then
518 return;
519 end if;
520
521 Add_Stub_Type
522 (Designated_Type => Desig,
523 RACW_Type => RACW_Type,
524 Decls => Decls,
525 Stub_Type => Stub_Type,
526 Stub_Type_Access => Stub_Type_Access,
527 Object_RPC_Receiver => Object_RPC_Receiver,
528 Existing => Existing);
529
530 Add_RACW_Read_Write_Attributes
531 (RACW_Type => RACW_Type,
532 Stub_Type => Stub_Type,
533 Stub_Type_Access => Stub_Type_Access,
534 Object_RPC_Receiver => Object_RPC_Receiver,
535 Declarations => Decls);
536
537 if not Same_Scope and then not Existing then
538
539 -- The RACW has been declared in another scope than the designated
540 -- type and has not been handled by another RACW in the same
541 -- package as the first one, so add primitive for the stub type
542 -- here.
543
544 Add_RACW_Primitive_Declarations_And_Bodies
545 (Designated_Type => Desig,
546 Insertion_Node =>
547 Parent (Declaration_Node (Object_RPC_Receiver)),
548 Decls => Decls);
549
550 else
551 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
552 end if;
553 end Add_RACW_Features;
554
555 ------------------------------------------------
556 -- Add_RACW_Primitive_Declarations_And_Bodies --
557 ------------------------------------------------
558
559 procedure Add_RACW_Primitive_Declarations_And_Bodies
560 (Designated_Type : Entity_Id;
561 Insertion_Node : Node_Id;
562 Decls : List_Id)
563 is
564 -- Set sloc of generated declaration to be that of the
565 -- insertion node, so the declarations are recognized as
566 -- belonging to the current package.
567
568 Loc : constant Source_Ptr := Sloc (Insertion_Node);
569
570 Stub_Elements : constant Stub_Structure :=
571 Stubs_Table.Get (Designated_Type);
572
573 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
574
575 Current_Insertion_Node : Node_Id := Insertion_Node;
576
577 RPC_Receiver_Declarations : List_Id;
578 RPC_Receiver_Statements : List_Id;
579 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
580 RPC_Receiver_Subp_Id : Entity_Id;
581
582 Current_Primitive_Elmt : Elmt_Id;
583 Current_Primitive : Entity_Id;
584 Current_Primitive_Body : Node_Id;
585 Current_Primitive_Spec : Node_Id;
586 Current_Primitive_Decl : Node_Id;
587 Current_Primitive_Number : Int := 0;
588
589 Current_Primitive_Alias : Node_Id;
590
591 Current_Receiver : Entity_Id;
592 Current_Receiver_Body : Node_Id;
593
594 RPC_Receiver_Decl : Node_Id;
595
596 Possibly_Asynchronous : Boolean;
597
598 begin
599 if not Expander_Active then
600 return;
601 end if;
602
603 -- Build callers, receivers for every primitive operations and a RPC
604 -- receiver for this type.
605
606 if Present (Primitive_Operations (Designated_Type)) then
607
608 Current_Primitive_Elmt :=
609 First_Elmt (Primitive_Operations (Designated_Type));
610 while Current_Primitive_Elmt /= No_Elmt loop
611 Current_Primitive := Node (Current_Primitive_Elmt);
612
613 -- Copy the primitive of all the parents, except predefined
614 -- ones that are not remotely dispatching.
615
616 if Chars (Current_Primitive) /= Name_uSize
617 and then Chars (Current_Primitive) /= Name_uAlignment
618 and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize)
619 then
620 -- The first thing to do is build an up-to-date copy of
621 -- the spec with all the formals referencing Designated_Type
622 -- transformed into formals referencing Stub_Type. Since this
623 -- primitive may have been inherited, go back the alias chain
624 -- until the real primitive has been found.
625
626 Current_Primitive_Alias := Current_Primitive;
627 while Present (Alias (Current_Primitive_Alias)) loop
628 pragma Assert
629 (Current_Primitive_Alias
630 /= Alias (Current_Primitive_Alias));
631 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
632 end loop;
633
634 Current_Primitive_Spec :=
635 Copy_Specification (Loc,
636 Spec => Parent (Current_Primitive_Alias),
637 Object_Type => Designated_Type,
638 Stub_Type => Stub_Elements.Stub_Type);
639
640 Current_Primitive_Decl :=
641 Make_Subprogram_Declaration (Loc,
642 Specification => Current_Primitive_Spec);
643
644 Insert_After (Current_Insertion_Node, Current_Primitive_Decl);
645 Analyze (Current_Primitive_Decl);
646 Current_Insertion_Node := Current_Primitive_Decl;
647
648 Possibly_Asynchronous :=
649 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
650 and then Could_Be_Asynchronous (Current_Primitive_Spec);
651
652 Current_Primitive_Body :=
653 Build_Subprogram_Calling_Stubs
654 (Vis_Decl => Current_Primitive_Decl,
655 Subp_Id => Current_Primitive_Number,
656 Asynchronous => Possibly_Asynchronous,
657 Dynamically_Asynchronous => Possibly_Asynchronous,
658 Stub_Type => Stub_Elements.Stub_Type);
659 Append_To (Decls, Current_Primitive_Body);
660
661 -- Analyzing the body here would cause the Stub type to be
662 -- frozen, thus preventing subsequent primitive declarations.
663 -- For this reason, it will be analyzed later in the
664 -- regular flow.
665
666 -- Build the receiver stubs
667
668 Current_Receiver_Body :=
669 Build_Subprogram_Receiving_Stubs
670 (Vis_Decl => Current_Primitive_Decl,
671 Asynchronous => Possibly_Asynchronous,
672 Dynamically_Asynchronous => Possibly_Asynchronous,
673 Stub_Type => Stub_Elements.Stub_Type,
674 RACW_Type => Stub_Elements.RACW_Type,
675 Parent_Primitive => Current_Primitive);
676
677 Current_Receiver :=
678 Defining_Unit_Name (Specification (Current_Receiver_Body));
679
680 Append_To (Decls, Current_Receiver_Body);
681
682 -- Add a case alternative to the receiver
683
684 Append_To (RPC_Receiver_Case_Alternatives,
685 Make_Case_Statement_Alternative (Loc,
686 Discrete_Choices => New_List (
687 Make_Integer_Literal (Loc, Current_Primitive_Number)),
688
689 Statements => New_List (
690 Make_Procedure_Call_Statement (Loc,
691 Name =>
692 New_Occurrence_Of (Current_Receiver, Loc),
693 Parameter_Associations => New_List (
694 New_Occurrence_Of
695 (Stub_Elements.RPC_Receiver_Stream, Loc),
696 New_Occurrence_Of
697 (Stub_Elements.RPC_Receiver_Result, Loc))))));
698
699 -- Increment the index of current primitive
700
701 Current_Primitive_Number := Current_Primitive_Number + 1;
702 end if;
703
704 Next_Elmt (Current_Primitive_Elmt);
705 end loop;
706 end if;
707
708 -- Build the case statement and the heart of the subprogram
709
710 Append_To (RPC_Receiver_Case_Alternatives,
711 Make_Case_Statement_Alternative (Loc,
712 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
713 Statements => New_List (Make_Null_Statement (Loc))));
714
715 RPC_Receiver_Subp_Id :=
716 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
717
718 RPC_Receiver_Declarations := New_List (
719 Make_Object_Declaration (Loc,
720 Defining_Identifier => RPC_Receiver_Subp_Id,
721 Object_Definition =>
722 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)));
723
724 RPC_Receiver_Statements := New_List (
725 Make_Attribute_Reference (Loc,
726 Prefix =>
727 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
728 Attribute_Name =>
729 Name_Read,
730 Expressions => New_List (
731 New_Occurrence_Of (Stub_Elements.RPC_Receiver_Stream, Loc),
732 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc))));
733
734 Append_To (RPC_Receiver_Statements,
735 Make_Case_Statement (Loc,
736 Expression =>
737 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
738 Alternatives => RPC_Receiver_Case_Alternatives));
739
740 RPC_Receiver_Decl :=
741 Make_Subprogram_Body (Loc,
742 Specification =>
743 Copy_Specification (Loc,
744 Parent (Stub_Elements.Object_RPC_Receiver)),
745 Declarations => RPC_Receiver_Declarations,
746 Handled_Statement_Sequence =>
747 Make_Handled_Sequence_Of_Statements (Loc,
748 Statements => RPC_Receiver_Statements));
749
750 Append_To (Decls, RPC_Receiver_Decl);
751
752 -- Do not analyze RPC receiver at this stage since it will otherwise
753 -- reference subprograms that have not been analyzed yet. It will
754 -- be analyzed in the regular flow.
755
756 end Add_RACW_Primitive_Declarations_And_Bodies;
757
758 -----------------------------
759 -- Add_RACW_Read_Attribute --
760 -----------------------------
761
762 procedure Add_RACW_Read_Attribute
763 (RACW_Type : Entity_Id;
764 Stub_Type : Entity_Id;
765 Stub_Type_Access : Entity_Id;
766 Declarations : List_Id)
767 is
768 Loc : constant Source_Ptr := Sloc (RACW_Type);
769
770 Proc_Decl : Node_Id;
771 Attr_Decl : Node_Id;
772
773 Body_Node : Node_Id;
774
775 Decls : List_Id;
776 Statements : List_Id;
777 Local_Statements : List_Id;
778 Remote_Statements : List_Id;
779 -- Various parts of the procedure
780
781 Procedure_Name : constant Name_Id :=
782 New_Internal_Name ('R');
783 Source_Partition : constant Entity_Id :=
784 Make_Defining_Identifier
785 (Loc, New_Internal_Name ('P'));
786 Source_Receiver : constant Entity_Id :=
787 Make_Defining_Identifier
788 (Loc, New_Internal_Name ('S'));
789 Source_Address : constant Entity_Id :=
790 Make_Defining_Identifier
791 (Loc, New_Internal_Name ('P'));
792 Local_Stub : constant Entity_Id :=
793 Make_Defining_Identifier
794 (Loc, New_Internal_Name ('L'));
795 Stubbed_Result : constant Entity_Id :=
796 Make_Defining_Identifier
797 (Loc, New_Internal_Name ('S'));
798 Asynchronous_Flag : constant Entity_Id :=
799 Make_Defining_Identifier
800 (Loc, New_Internal_Name ('S'));
801 Asynchronous_Node : constant Node_Id :=
802 New_Occurrence_Of (Standard_False, Loc);
803
804 -- Functions to create occurrences of the formal
805 -- parameter names.
806
807 function Stream_Parameter return Node_Id;
808 function Result return Node_Id;
809
810 function Stream_Parameter return Node_Id is
811 begin
812 return Make_Identifier (Loc, Name_S);
813 end Stream_Parameter;
814
815 function Result return Node_Id is
816 begin
817 return Make_Identifier (Loc, Name_V);
818 end Result;
819
820 begin
821 -- Declare the asynchronous flag. This flag will be changed to True
822 -- whenever it is known that the RACW type is asynchronous. Also, the
823 -- node gets stored since it may be rewritten when we process the
824 -- asynchronous pragma.
825
826 Append_To (Declarations,
827 Make_Object_Declaration (Loc,
828 Defining_Identifier => Asynchronous_Flag,
829 Constant_Present => True,
830 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
831 Expression => Asynchronous_Node));
832
833 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Node);
834
835 -- Object declarations
836
837 Decls := New_List (
838 Make_Object_Declaration (Loc,
839 Defining_Identifier => Source_Partition,
840 Object_Definition =>
841 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
842
843 Make_Object_Declaration (Loc,
844 Defining_Identifier => Source_Receiver,
845 Object_Definition =>
846 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
847
848 Make_Object_Declaration (Loc,
849 Defining_Identifier => Source_Address,
850 Object_Definition =>
851 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
852
853 Make_Object_Declaration (Loc,
854 Defining_Identifier => Local_Stub,
855 Aliased_Present => True,
856 Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
857
858 Make_Object_Declaration (Loc,
859 Defining_Identifier => Stubbed_Result,
860 Object_Definition =>
861 New_Occurrence_Of (Stub_Type_Access, Loc),
862 Expression =>
863 Make_Attribute_Reference (Loc,
864 Prefix =>
865 New_Occurrence_Of (Local_Stub, Loc),
866 Attribute_Name =>
867 Name_Unchecked_Access)));
868
869 -- Read the source Partition_ID and RPC_Receiver from incoming stream
870
871 Statements := New_List (
872 Make_Attribute_Reference (Loc,
873 Prefix =>
874 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
875 Attribute_Name => Name_Read,
876 Expressions => New_List (
877 Stream_Parameter,
878 New_Occurrence_Of (Source_Partition, Loc))),
879
880 Make_Attribute_Reference (Loc,
881 Prefix =>
882 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
883 Attribute_Name =>
884 Name_Read,
885 Expressions => New_List (
886 Stream_Parameter,
887 New_Occurrence_Of (Source_Receiver, Loc))),
888
889 Make_Attribute_Reference (Loc,
890 Prefix =>
891 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
892 Attribute_Name =>
893 Name_Read,
894 Expressions => New_List (
895 Stream_Parameter,
896 New_Occurrence_Of (Source_Address, Loc))));
897
898 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
899
900 Set_Etype (Stubbed_Result, Stub_Type_Access);
901
902 -- If the Address is Null_Address, then return a null object
903
904 Append_To (Statements,
905 Make_Implicit_If_Statement (RACW_Type,
906 Condition =>
907 Make_Op_Eq (Loc,
908 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
909 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
910 Then_Statements => New_List (
911 Make_Assignment_Statement (Loc,
912 Name => Result,
913 Expression => Make_Null (Loc)),
914 Make_Return_Statement (Loc))));
915
916 -- If the RACW denotes an object created on the current partition, then
917 -- Local_Statements will be executed. The real object will be used.
918
919 Local_Statements := New_List (
920 Make_Assignment_Statement (Loc,
921 Name => Result,
922 Expression =>
923 Unchecked_Convert_To (RACW_Type,
924 OK_Convert_To (RTE (RE_Address),
925 New_Occurrence_Of (Source_Address, Loc)))));
926
927 -- If the object is located on another partition, then a stub object
928 -- will be created with all the information needed to rebuild the
929 -- real object at the other end.
930
931 Remote_Statements := New_List (
932
933 Make_Assignment_Statement (Loc,
934 Name => Make_Selected_Component (Loc,
935 Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
936 Selector_Name => Make_Identifier (Loc, Name_Origin)),
937 Expression =>
938 New_Occurrence_Of (Source_Partition, Loc)),
939
940 Make_Assignment_Statement (Loc,
941 Name => Make_Selected_Component (Loc,
942 Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
943 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
944 Expression =>
945 New_Occurrence_Of (Source_Receiver, Loc)),
946
947 Make_Assignment_Statement (Loc,
948 Name => Make_Selected_Component (Loc,
949 Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
950 Selector_Name => Make_Identifier (Loc, Name_Addr)),
951 Expression =>
952 New_Occurrence_Of (Source_Address, Loc)));
953
954 Append_To (Remote_Statements,
955 Make_Assignment_Statement (Loc,
956 Name => Make_Selected_Component (Loc,
957 Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
958 Selector_Name => Make_Identifier (Loc, Name_Asynchronous)),
959 Expression =>
960 New_Occurrence_Of (Asynchronous_Flag, Loc)));
961
962 Append_List_To (Remote_Statements,
963 Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
964 -- ??? Issue with asynchronous calls here: the Asynchronous
965 -- flag is set on the stub type if, and only if, the RACW type
966 -- has a pragma Asynchronous. This is incorrect for RACWs that
967 -- implement RAS types, because in that case the /designated
968 -- subprogram/ (not the type) might be asynchronous, and
969 -- that causes the stub to need to be asynchronous too.
970 -- A solution is to transport a RAS as a struct containing
971 -- a RACW and an asynchronous flag, and to properly alter
972 -- the Asynchronous component in the stub type in the RAS's
973 -- Input TSS.
974
975 Append_To (Remote_Statements,
976 Make_Assignment_Statement (Loc,
977 Name => Result,
978 Expression => Unchecked_Convert_To (RACW_Type,
979 New_Occurrence_Of (Stubbed_Result, Loc))));
980
981 -- Distinguish between the local and remote cases, and execute the
982 -- appropriate piece of code.
983
984 Append_To (Statements,
985 Make_Implicit_If_Statement (RACW_Type,
986 Condition =>
987 Make_Op_Eq (Loc,
988 Left_Opnd =>
989 Make_Function_Call (Loc,
990 Name =>
991 New_Occurrence_Of (RTE (RE_Get_Local_Partition_Id), Loc)),
992 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
993 Then_Statements => Local_Statements,
994 Else_Statements => Remote_Statements));
995
996 Build_Stream_Procedure
997 (Loc, RACW_Type, Body_Node,
998 Make_Defining_Identifier (Loc, Procedure_Name),
999 Statements, Outp => True);
1000 Set_Declarations (Body_Node, Decls);
1001
1002 Proc_Decl := Make_Subprogram_Declaration (Loc,
1003 Copy_Specification (Loc, Specification (Body_Node)));
1004
1005 Attr_Decl :=
1006 Make_Attribute_Definition_Clause (Loc,
1007 Name => New_Occurrence_Of (RACW_Type, Loc),
1008 Chars => Name_Read,
1009 Expression =>
1010 New_Occurrence_Of (
1011 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
1012
1013 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
1014 Insert_After (Proc_Decl, Attr_Decl);
1015 Append_To (Declarations, Body_Node);
1016 end Add_RACW_Read_Attribute;
1017
1018 ------------------------------------
1019 -- Add_RACW_Read_Write_Attributes --
1020 ------------------------------------
1021
1022 procedure Add_RACW_Read_Write_Attributes
1023 (RACW_Type : Entity_Id;
1024 Stub_Type : Entity_Id;
1025 Stub_Type_Access : Entity_Id;
1026 Object_RPC_Receiver : Entity_Id;
1027 Declarations : List_Id)
1028 is
1029 begin
1030 Add_RACW_Write_Attribute
1031 (RACW_Type => RACW_Type,
1032 Stub_Type => Stub_Type,
1033 Stub_Type_Access => Stub_Type_Access,
1034 Object_RPC_Receiver => Object_RPC_Receiver,
1035 Declarations => Declarations);
1036
1037 Add_RACW_Read_Attribute
1038 (RACW_Type => RACW_Type,
1039 Stub_Type => Stub_Type,
1040 Stub_Type_Access => Stub_Type_Access,
1041 Declarations => Declarations);
1042 end Add_RACW_Read_Write_Attributes;
1043
1044 ------------------------------
1045 -- Add_RACW_Write_Attribute --
1046 ------------------------------
1047
1048 procedure Add_RACW_Write_Attribute
1049 (RACW_Type : Entity_Id;
1050 Stub_Type : Entity_Id;
1051 Stub_Type_Access : Entity_Id;
1052 Object_RPC_Receiver : Entity_Id;
1053 Declarations : List_Id)
1054 is
1055 Loc : constant Source_Ptr := Sloc (RACW_Type);
1056
1057 Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
1058
1059 Body_Node : Node_Id;
1060 Proc_Decl : Node_Id;
1061 Attr_Decl : Node_Id;
1062
1063 RPC_Receiver : Node_Id;
1064
1065 Statements : List_Id;
1066 Local_Statements : List_Id;
1067 Remote_Statements : List_Id;
1068 Null_Statements : List_Id;
1069
1070 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
1071
1072 -- Functions to create occurrences of the formal
1073 -- parameter names.
1074
1075 function Stream_Parameter return Node_Id;
1076 function Object return Node_Id;
1077
1078 function Stream_Parameter return Node_Id is
1079 begin
1080 return Make_Identifier (Loc, Name_S);
1081 end Stream_Parameter;
1082
1083 function Object return Node_Id is
1084 begin
1085 return Make_Identifier (Loc, Name_V);
1086 end Object;
1087
1088 begin
1089 -- Build the code fragment corresponding to the marshalling of a
1090 -- local object.
1091
1092 if Is_RAS then
1093
1094 -- For a RAS, the RPC receiver is that of the RCI unit,
1095 -- not that of the corresponding distributed object type.
1096 -- We retrieve its address from the local proxy object.
1097
1098 RPC_Receiver := Make_Selected_Component (Loc,
1099 Prefix =>
1100 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
1101 Selector_Name =>
1102 Make_Identifier (Loc, Name_Receiver));
1103
1104 else
1105 RPC_Receiver := Make_Attribute_Reference (Loc,
1106 Prefix =>
1107 New_Occurrence_Of (Object_RPC_Receiver, Loc),
1108 Attribute_Name =>
1109 Name_Address);
1110 end if;
1111
1112 Local_Statements := New_List (
1113
1114 Pack_Entity_Into_Stream_Access (Loc,
1115 Stream => Stream_Parameter,
1116 Object => RTE (RE_Get_Local_Partition_Id)),
1117
1118 Pack_Node_Into_Stream_Access (Loc,
1119 Stream => Stream_Parameter,
1120 Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
1121 Etyp => RTE (RE_Unsigned_64)),
1122
1123 Pack_Node_Into_Stream_Access (Loc,
1124 Stream => Stream_Parameter,
1125 Object => OK_Convert_To (RTE (RE_Unsigned_64),
1126 Make_Attribute_Reference (Loc,
1127 Prefix =>
1128 Make_Explicit_Dereference (Loc,
1129 Prefix => Object),
1130 Attribute_Name => Name_Address)),
1131 Etyp => RTE (RE_Unsigned_64)));
1132
1133 -- Build the code fragment corresponding to the marshalling of
1134 -- a remote object.
1135
1136 Remote_Statements := New_List (
1137
1138 Pack_Node_Into_Stream_Access (Loc,
1139 Stream => Stream_Parameter,
1140 Object =>
1141 Make_Selected_Component (Loc,
1142 Prefix => Unchecked_Convert_To (Stub_Type_Access,
1143 Object),
1144 Selector_Name =>
1145 Make_Identifier (Loc, Name_Origin)),
1146 Etyp => RTE (RE_Partition_ID)),
1147
1148 Pack_Node_Into_Stream_Access (Loc,
1149 Stream => Stream_Parameter,
1150 Object =>
1151 Make_Selected_Component (Loc,
1152 Prefix => Unchecked_Convert_To (Stub_Type_Access,
1153 Object),
1154 Selector_Name =>
1155 Make_Identifier (Loc, Name_Receiver)),
1156 Etyp => RTE (RE_Unsigned_64)),
1157
1158 Pack_Node_Into_Stream_Access (Loc,
1159 Stream => Stream_Parameter,
1160 Object =>
1161 Make_Selected_Component (Loc,
1162 Prefix => Unchecked_Convert_To (Stub_Type_Access,
1163 Object),
1164 Selector_Name =>
1165 Make_Identifier (Loc, Name_Addr)),
1166 Etyp => RTE (RE_Unsigned_64)));
1167
1168 -- Build the code fragment corresponding to the marshalling of a null
1169 -- object.
1170
1171 Null_Statements := New_List (
1172
1173 Pack_Entity_Into_Stream_Access (Loc,
1174 Stream => Stream_Parameter,
1175 Object => RTE (RE_Get_Local_Partition_Id)),
1176
1177 Pack_Node_Into_Stream_Access (Loc,
1178 Stream => Stream_Parameter,
1179 Object => OK_Convert_To (RTE (RE_Unsigned_64),
1180 Make_Attribute_Reference (Loc,
1181 Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc),
1182 Attribute_Name => Name_Address)),
1183 Etyp => RTE (RE_Unsigned_64)),
1184
1185 Pack_Node_Into_Stream_Access (Loc,
1186 Stream => Stream_Parameter,
1187 Object => Make_Integer_Literal (Loc, Uint_0),
1188 Etyp => RTE (RE_Unsigned_64)));
1189
1190 Statements := New_List (
1191 Make_Implicit_If_Statement (RACW_Type,
1192 Condition =>
1193 Make_Op_Eq (Loc,
1194 Left_Opnd => Object,
1195 Right_Opnd => Make_Null (Loc)),
1196 Then_Statements => Null_Statements,
1197 Elsif_Parts => New_List (
1198 Make_Elsif_Part (Loc,
1199 Condition =>
1200 Make_Op_Eq (Loc,
1201 Left_Opnd =>
1202 Make_Attribute_Reference (Loc,
1203 Prefix => Object,
1204 Attribute_Name => Name_Tag),
1205 Right_Opnd =>
1206 Make_Attribute_Reference (Loc,
1207 Prefix => New_Occurrence_Of (Stub_Type, Loc),
1208 Attribute_Name => Name_Tag)),
1209 Then_Statements => Remote_Statements)),
1210 Else_Statements => Local_Statements));
1211
1212 Build_Stream_Procedure
1213 (Loc, RACW_Type, Body_Node,
1214 Make_Defining_Identifier (Loc, Procedure_Name),
1215 Statements, Outp => False);
1216
1217 Proc_Decl := Make_Subprogram_Declaration (Loc,
1218 Copy_Specification (Loc, Specification (Body_Node)));
1219
1220 Attr_Decl :=
1221 Make_Attribute_Definition_Clause (Loc,
1222 Name => New_Occurrence_Of (RACW_Type, Loc),
1223 Chars => Name_Write,
1224 Expression =>
1225 New_Occurrence_Of (
1226 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
1227
1228 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
1229 Insert_After (Proc_Decl, Attr_Decl);
1230 Append_To (Declarations, Body_Node);
1231 end Add_RACW_Write_Attribute;
1232
1233 ------------------------
1234 -- Add_RAS_Access_TSS --
1235 ------------------------
1236
1237 procedure Add_RAS_Access_TSS (N : Node_Id) is
1238 Loc : constant Source_Ptr := Sloc (N);
1239
1240 Ras_Type : constant Entity_Id := Defining_Identifier (N);
1241 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
1242 -- Ras_Type is the access to subprogram type while Fat_Type points to
1243 -- the record type corresponding to a remote access to subprogram type.
1244
1245 RACW_Type : constant Entity_Id :=
1246 Underlying_RACW_Type (Ras_Type);
1247 Desig : constant Entity_Id :=
1248 Etype (Designated_Type (RACW_Type));
1249
1250 Stub_Elements : constant Stub_Structure :=
1251 Stubs_Table.Get (Desig);
1252 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1253
1254 Proc : constant Entity_Id :=
1255 Make_Defining_Identifier (Loc,
1256 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
1257 Proc_Spec : Node_Id;
1258
1259 -- Formal parameters
1260
1261 Package_Name : constant Entity_Id :=
1262 Make_Defining_Identifier (Loc,
1263 Chars => Name_P);
1264 -- Target package
1265
1266 Subp_Id : constant Entity_Id :=
1267 Make_Defining_Identifier (Loc,
1268 Chars => Name_S);
1269 -- Target subprogram
1270
1271 Asynch_P : constant Entity_Id :=
1272 Make_Defining_Identifier (Loc,
1273 Chars => Name_Asynchronous);
1274 -- Is the procedure to which the 'Access applies asynchronous?
1275
1276 All_Calls_Remote : constant Entity_Id :=
1277 Make_Defining_Identifier (Loc,
1278 Chars => Name_All_Calls_Remote);
1279 -- True if an All_Calls_Remote pragma applies to the RCI unit
1280 -- that contains the subprogram.
1281
1282 -- Common local variables
1283
1284 Proc_Decls : List_Id;
1285 Proc_Statements : List_Id;
1286
1287 Origin : constant Entity_Id :=
1288 Make_Defining_Identifier (Loc,
1289 Chars => New_Internal_Name ('P'));
1290
1291 -- Additional local variables for the local case
1292
1293 Proxy_Addr : constant Entity_Id :=
1294 Make_Defining_Identifier (Loc,
1295 Chars => New_Internal_Name ('P'));
1296
1297 -- Additional local variables for the remote case
1298
1299 Local_Stub : constant Entity_Id :=
1300 Make_Defining_Identifier (Loc,
1301 Chars => New_Internal_Name ('L'));
1302
1303 Stub_Ptr : constant Entity_Id :=
1304 Make_Defining_Identifier (Loc,
1305 Chars => New_Internal_Name ('S'));
1306
1307 function Set_Field
1308 (Field_Name : Name_Id;
1309 Value : Node_Id) return Node_Id;
1310 -- Construct an assignment that sets the named component in the
1311 -- returned record
1312
1313 ---------------
1314 -- Set_Field --
1315 ---------------
1316
1317 function Set_Field
1318 (Field_Name : Name_Id;
1319 Value : Node_Id) return Node_Id
1320 is
1321 begin
1322 return
1323 Make_Assignment_Statement (Loc,
1324 Name =>
1325 Make_Selected_Component (Loc,
1326 Prefix => New_Occurrence_Of (Stub_Ptr, Loc),
1327 Selector_Name => Make_Identifier (Loc, Field_Name)),
1328 Expression => Value);
1329 end Set_Field;
1330
1331 -- Start of processing for Add_RAS_Access_TSS
1332
1333 begin
1334 Proc_Decls := New_List (
1335
1336 -- Common declarations
1337
1338 Make_Object_Declaration (Loc,
1339 Defining_Identifier => Origin,
1340 Constant_Present => True,
1341 Object_Definition =>
1342 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
1343 Expression =>
1344 Make_Function_Call (Loc,
1345 Name =>
1346 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
1347 Parameter_Associations => New_List (
1348 New_Occurrence_Of (Package_Name, Loc)))),
1349
1350 -- Declaration use only in the local case: proxy address
1351
1352 Make_Object_Declaration (Loc,
1353 Defining_Identifier => Proxy_Addr,
1354 Object_Definition =>
1355 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
1356
1357 -- Declarations used only in the remote case: stub object and
1358 -- stub pointer.
1359
1360 Make_Object_Declaration (Loc,
1361 Defining_Identifier => Local_Stub,
1362 Aliased_Present => True,
1363 Object_Definition =>
1364 New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
1365
1366 Make_Object_Declaration (Loc,
1367 Defining_Identifier =>
1368 Stub_Ptr,
1369 Object_Definition =>
1370 New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
1371 Expression =>
1372 Make_Attribute_Reference (Loc,
1373 Prefix => New_Occurrence_Of (Local_Stub, Loc),
1374 Attribute_Name => Name_Unchecked_Access)));
1375
1376 Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
1377 -- Build_Get_Unique_RP_Call needs this information.
1378
1379 -- Note: Here we assume that the Fat_Type is a record
1380 -- containing just a pointer to a proxy or stub object.
1381
1382 Proc_Statements := New_List (
1383
1384 -- Get_RAS_Info (Pkg, Subp, PA);
1385 -- if Origin = Local_Partition_Id and then not All_Calls_Remote then
1386 -- return Fat_Type!(PA);
1387 -- end if;
1388
1389 Make_Procedure_Call_Statement (Loc,
1390 Name =>
1391 New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
1392 Parameter_Associations => New_List (
1393 New_Occurrence_Of (Package_Name, Loc),
1394 New_Occurrence_Of (Subp_Id, Loc),
1395 New_Occurrence_Of (Proxy_Addr, Loc))),
1396
1397 Make_Implicit_If_Statement (N,
1398 Condition =>
1399 Make_And_Then (Loc,
1400 Left_Opnd =>
1401 Make_Op_Eq (Loc,
1402 Left_Opnd =>
1403 New_Occurrence_Of (Origin, Loc),
1404 Right_Opnd =>
1405 Make_Function_Call (Loc,
1406 New_Occurrence_Of (
1407 RTE (RE_Get_Local_Partition_Id), Loc))),
1408 Right_Opnd =>
1409 Make_Op_Not (Loc,
1410 New_Occurrence_Of (All_Calls_Remote, Loc))),
1411 Then_Statements => New_List (
1412 Make_Return_Statement (Loc,
1413 Unchecked_Convert_To (Fat_Type,
1414 OK_Convert_To (RTE (RE_Address),
1415 New_Occurrence_Of (Proxy_Addr, Loc)))))),
1416
1417 Set_Field (Name_Origin,
1418 New_Occurrence_Of (Origin, Loc)),
1419
1420 Set_Field (Name_Receiver,
1421 Make_Function_Call (Loc,
1422 Name =>
1423 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
1424 Parameter_Associations => New_List (
1425 New_Occurrence_Of (Package_Name, Loc)))),
1426
1427 Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
1428
1429 Set_Field (Name_Asynchronous,
1430 Make_Or_Else (Loc,
1431 New_Occurrence_Of (Asynch_P, Loc),
1432 New_Occurrence_Of (Boolean_Literals (
1433 Is_Asynchronous (Ras_Type)), Loc))));
1434 -- E.4.1(9) A remote call is asynchronous if it is a call to
1435 -- a procedure, or a call through a value of an access-to-procedure
1436 -- type, to which a pragma Asynchronous applies.
1437 -- Parameter Asynch_P is true when the procedure is asynchronous;
1438 -- Expression Asynch_T is true when the type is asynchronous.
1439
1440 Append_List_To (Proc_Statements,
1441 Build_Get_Unique_RP_Call
1442 (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
1443
1444 -- Return the newly created value
1445
1446 Append_To (Proc_Statements,
1447 Make_Return_Statement (Loc,
1448 Expression =>
1449 Unchecked_Convert_To (Fat_Type,
1450 New_Occurrence_Of (Stub_Ptr, Loc))));
1451
1452 Proc_Spec :=
1453 Make_Function_Specification (Loc,
1454 Defining_Unit_Name => Proc,
1455 Parameter_Specifications => New_List (
1456 Make_Parameter_Specification (Loc,
1457 Defining_Identifier => Package_Name,
1458 Parameter_Type =>
1459 New_Occurrence_Of (Standard_String, Loc)),
1460
1461 Make_Parameter_Specification (Loc,
1462 Defining_Identifier => Subp_Id,
1463 Parameter_Type =>
1464 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
1465
1466 Make_Parameter_Specification (Loc,
1467 Defining_Identifier => Asynch_P,
1468 Parameter_Type =>
1469 New_Occurrence_Of (Standard_Boolean, Loc)),
1470
1471 Make_Parameter_Specification (Loc,
1472 Defining_Identifier => All_Calls_Remote,
1473 Parameter_Type =>
1474 New_Occurrence_Of (Standard_Boolean, Loc))),
1475
1476 Subtype_Mark =>
1477 New_Occurrence_Of (Fat_Type, Loc));
1478
1479 -- Set the kind and return type of the function to prevent ambiguities
1480 -- between Ras_Type and Fat_Type in subsequent analysis.
1481
1482 Set_Ekind (Proc, E_Function);
1483 Set_Etype (Proc, New_Occurrence_Of (Fat_Type, Loc));
1484
1485 Discard_Node (
1486 Make_Subprogram_Body (Loc,
1487 Specification => Proc_Spec,
1488 Declarations => Proc_Decls,
1489 Handled_Statement_Sequence =>
1490 Make_Handled_Sequence_Of_Statements (Loc,
1491 Statements => Proc_Statements)));
1492
1493 Set_TSS (Fat_Type, Proc);
1494 end Add_RAS_Access_TSS;
1495
1496 -----------------------------
1497 -- Add_RAS_Dereference_TSS --
1498 -----------------------------
1499
1500 procedure Add_RAS_Dereference_TSS (N : Node_Id) is
1501 Loc : constant Source_Ptr := Sloc (N);
1502
1503 Type_Def : constant Node_Id := Type_Definition (N);
1504
1505 RAS_Type : constant Entity_Id := Defining_Identifier (N);
1506 Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
1507 RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
1508 Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
1509
1510 Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
1511 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
1512
1513 RACW_Primitive_Name : Node_Id;
1514
1515 Proc : constant Entity_Id :=
1516 Make_Defining_Identifier (Loc,
1517 Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
1518
1519 Proc_Spec : Node_Id;
1520 Param_Specs : List_Id;
1521 Param_Assoc : constant List_Id := New_List;
1522 Stmts : constant List_Id := New_List;
1523
1524 RAS_Parameter : constant Entity_Id :=
1525 Make_Defining_Identifier (Loc,
1526 Chars => New_Internal_Name ('P'));
1527
1528 Is_Function : constant Boolean :=
1529 Nkind (Type_Def) = N_Access_Function_Definition;
1530
1531 Is_Degenerate : Boolean;
1532 -- Set to True if the subprogram_specification for this RAS has
1533 -- an anonymous access parameter (see Process_Remote_AST_Declaration).
1534
1535 Spec : constant Node_Id := Type_Def;
1536
1537 Current_Parameter : Node_Id;
1538
1539 begin
1540 Param_Specs := New_List (
1541 Make_Parameter_Specification (Loc,
1542 Defining_Identifier => RAS_Parameter,
1543 In_Present => True,
1544 Parameter_Type =>
1545 New_Occurrence_Of (Fat_Type, Loc)));
1546
1547 Is_Degenerate := False;
1548 Current_Parameter := First (Parameter_Specifications (Type_Def));
1549 Parameters : while Current_Parameter /= Empty loop
1550 if Nkind (Parameter_Type (Current_Parameter))
1551 = N_Access_Definition
1552 then
1553 Is_Degenerate := True;
1554 end if;
1555 Append_To (Param_Specs,
1556 Make_Parameter_Specification (Loc,
1557 Defining_Identifier =>
1558 Make_Defining_Identifier (Loc,
1559 Chars => Chars (Defining_Identifier (Current_Parameter))),
1560 In_Present => In_Present (Current_Parameter),
1561 Out_Present => Out_Present (Current_Parameter),
1562 Parameter_Type =>
1563 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1564 Expression =>
1565 New_Copy_Tree (Expression (Current_Parameter))));
1566
1567 Append_To (Param_Assoc,
1568 Make_Identifier (Loc,
1569 Chars => Chars (Defining_Identifier (Current_Parameter))));
1570
1571 Next (Current_Parameter);
1572 end loop Parameters;
1573
1574 if Is_Degenerate then
1575 Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
1576
1577 -- Generate a dummy body recursing on the Dereference TSS, since
1578 -- actually it will never be executed.
1579
1580 Append_To (Stmts,
1581 Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1582 RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
1583
1584 else
1585 Prepend_To (Param_Assoc,
1586 Unchecked_Convert_To (RACW_Type,
1587 New_Occurrence_Of (RAS_Parameter, Loc)));
1588
1589 RACW_Primitive_Name :=
1590 Make_Selected_Component (Loc,
1591 Prefix =>
1592 New_Occurrence_Of (Scope (RACW_Type), Loc),
1593 Selector_Name =>
1594 Make_Identifier (Loc, Name_Call));
1595 end if;
1596
1597 if Is_Function then
1598 Append_To (Stmts,
1599 Make_Return_Statement (Loc,
1600 Expression =>
1601 Make_Function_Call (Loc,
1602 Name =>
1603 RACW_Primitive_Name,
1604 Parameter_Associations => Param_Assoc)));
1605
1606 else
1607 Append_To (Stmts,
1608 Make_Procedure_Call_Statement (Loc,
1609 Name =>
1610 RACW_Primitive_Name,
1611 Parameter_Associations => Param_Assoc));
1612 end if;
1613
1614 -- Build the complete subprogram.
1615
1616 if Is_Function then
1617 Proc_Spec :=
1618 Make_Function_Specification (Loc,
1619 Defining_Unit_Name => Proc,
1620 Parameter_Specifications => Param_Specs,
1621 Subtype_Mark =>
1622 New_Occurrence_Of (
1623 Entity (Subtype_Mark (Spec)), Loc));
1624
1625 Set_Ekind (Proc, E_Function);
1626 Set_Etype (Proc,
1627 New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
1628
1629 else
1630 Proc_Spec :=
1631 Make_Procedure_Specification (Loc,
1632 Defining_Unit_Name => Proc,
1633 Parameter_Specifications => Param_Specs);
1634
1635 Set_Ekind (Proc, E_Procedure);
1636 Set_Etype (Proc, Standard_Void_Type);
1637 end if;
1638
1639 Discard_Node (
1640 Make_Subprogram_Body (Loc,
1641 Specification => Proc_Spec,
1642 Declarations => New_List,
1643 Handled_Statement_Sequence =>
1644 Make_Handled_Sequence_Of_Statements (Loc,
1645 Statements => Stmts)));
1646
1647 Set_TSS (Fat_Type, Proc);
1648 end Add_RAS_Dereference_TSS;
1649
1650 -------------------------------
1651 -- Add_RAS_Proxy_And_Analyze --
1652 -------------------------------
1653
1654 procedure Add_RAS_Proxy_And_Analyze
1655 (Decls : List_Id;
1656 Vis_Decl : Node_Id;
1657 All_Calls_Remote_E : Entity_Id;
1658 Proxy_Object_Addr : out Entity_Id)
1659 is
1660 Loc : constant Source_Ptr := Sloc (Vis_Decl);
1661
1662 Subp_Name : constant Entity_Id :=
1663 Defining_Unit_Name (Specification (Vis_Decl));
1664
1665 Pkg_Name : constant Entity_Id :=
1666 Make_Defining_Identifier (Loc,
1667 Chars =>
1668 New_External_Name (Chars (Subp_Name), 'P', -1));
1669
1670 Proxy_Type : constant Entity_Id :=
1671 Make_Defining_Identifier (Loc,
1672 Chars =>
1673 New_External_Name (
1674 Related_Id => Chars (Subp_Name),
1675 Suffix => 'P'));
1676
1677 Proxy_Type_Full_View : constant Entity_Id :=
1678 Make_Defining_Identifier (Loc,
1679 Chars (Proxy_Type));
1680
1681 Subp_Decl_Spec : constant Node_Id :=
1682 Build_RAS_Primitive_Specification
1683 (Subp_Spec => Specification (Vis_Decl),
1684 Remote_Object_Type => Proxy_Type);
1685
1686 Subp_Body_Spec : constant Node_Id :=
1687 Build_RAS_Primitive_Specification
1688 (Subp_Spec => Specification (Vis_Decl),
1689 Remote_Object_Type => Proxy_Type);
1690
1691 Vis_Decls : constant List_Id := New_List;
1692 Pvt_Decls : constant List_Id := New_List;
1693 Actuals : constant List_Id := New_List;
1694 Formal : Node_Id;
1695 Perform_Call : Node_Id;
1696
1697 begin
1698 -- type subpP is tagged limited private;
1699
1700 Append_To (Vis_Decls,
1701 Make_Private_Type_Declaration (Loc,
1702 Defining_Identifier => Proxy_Type,
1703 Tagged_Present => True,
1704 Limited_Present => True));
1705
1706 -- [subprogram] Call
1707 -- (Self : access subpP;
1708 -- ...other-formals...)
1709 -- [return T];
1710
1711 Append_To (Vis_Decls,
1712 Make_Subprogram_Declaration (Loc,
1713 Specification => Subp_Decl_Spec));
1714
1715 -- A : constant System.Address;
1716
1717 Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
1718
1719 Append_To (Vis_Decls,
1720 Make_Object_Declaration (Loc,
1721 Defining_Identifier =>
1722 Proxy_Object_Addr,
1723 Constant_Present =>
1724 True,
1725 Object_Definition =>
1726 New_Occurrence_Of (RTE (RE_Address), Loc)));
1727
1728 -- private
1729
1730 -- type subpP is tagged limited record
1731 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1732 -- ...
1733 -- end record;
1734
1735 Append_To (Pvt_Decls,
1736 Make_Full_Type_Declaration (Loc,
1737 Defining_Identifier =>
1738 Proxy_Type_Full_View,
1739 Type_Definition =>
1740 Build_Remote_Subprogram_Proxy_Type (Loc,
1741 New_Occurrence_Of (All_Calls_Remote_E, Loc))));
1742
1743 -- Trick semantic analysis into swapping the public and
1744 -- full view when freezing the public view.
1745
1746 Set_Comes_From_Source (Proxy_Type_Full_View, True);
1747
1748
1749 -- procedure Call
1750 -- (Self : access O;
1751 -- ...other-formals...) is
1752 -- begin
1753 -- P (...other-formals...);
1754 -- end Call;
1755
1756 -- function Call
1757 -- (Self : access O;
1758 -- ...other-formals...)
1759 -- return T is
1760 -- begin
1761 -- return F (...other-formals...);
1762 -- end Call;
1763
1764 if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
1765 Perform_Call :=
1766 Make_Procedure_Call_Statement (Loc,
1767 Name =>
1768 New_Occurrence_Of (Subp_Name, Loc),
1769 Parameter_Associations =>
1770 Actuals);
1771 else
1772 Perform_Call :=
1773 Make_Return_Statement (Loc,
1774 Expression =>
1775 Make_Function_Call (Loc,
1776 Name =>
1777 New_Occurrence_Of (Subp_Name, Loc),
1778 Parameter_Associations =>
1779 Actuals));
1780 end if;
1781
1782 Formal := First (Parameter_Specifications (Subp_Decl_Spec));
1783 pragma Assert (Present (Formal));
1784 Next (Formal);
1785
1786 while Present (Formal) loop
1787 Append_To (Actuals, New_Occurrence_Of (
1788 Defining_Identifier (Formal), Loc));
1789 Next (Formal);
1790 end loop;
1791
1792 -- O : aliased subpP;
1793
1794 Append_To (Pvt_Decls,
1795 Make_Object_Declaration (Loc,
1796 Defining_Identifier =>
1797 Make_Defining_Identifier (Loc,
1798 Name_uO),
1799 Aliased_Present =>
1800 True,
1801 Object_Definition =>
1802 New_Occurrence_Of (Proxy_Type, Loc)));
1803
1804 -- A : constant System.Address := O'Address;
1805
1806 Append_To (Pvt_Decls,
1807 Make_Object_Declaration (Loc,
1808 Defining_Identifier =>
1809 Make_Defining_Identifier (Loc,
1810 Chars (Proxy_Object_Addr)),
1811 Constant_Present =>
1812 True,
1813 Object_Definition =>
1814 New_Occurrence_Of (RTE (RE_Address), Loc),
1815 Expression =>
1816 Make_Attribute_Reference (Loc,
1817 Prefix => New_Occurrence_Of (
1818 Defining_Identifier (Last (Pvt_Decls)), Loc),
1819 Attribute_Name =>
1820 Name_Address)));
1821
1822 Append_To (Decls,
1823 Make_Package_Declaration (Loc,
1824 Specification => Make_Package_Specification (Loc,
1825 Defining_Unit_Name => Pkg_Name,
1826 Visible_Declarations => Vis_Decls,
1827 Private_Declarations => Pvt_Decls,
1828 End_Label => Empty)));
1829 Analyze (Last (Decls));
1830
1831 Append_To (Decls,
1832 Make_Package_Body (Loc,
1833 Defining_Unit_Name =>
1834 Make_Defining_Identifier (Loc,
1835 Chars (Pkg_Name)),
1836 Declarations => New_List (
1837 Make_Subprogram_Body (Loc,
1838 Specification =>
1839 Subp_Body_Spec,
1840 Declarations => New_List,
1841 Handled_Statement_Sequence =>
1842 Make_Handled_Sequence_Of_Statements (Loc,
1843 Statements => New_List (Perform_Call))))));
1844 Analyze (Last (Decls));
1845 end Add_RAS_Proxy_And_Analyze;
1846
1847 -----------------------
1848 -- Add_RAST_Features --
1849 -----------------------
1850
1851 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1852 begin
1853 -- Do not add attributes more than once in any case. This should
1854 -- be replaced by an assert or this comment removed if we decide
1855 -- that this is normal to be called several times ???
1856
1857 if Present (TSS (Equivalent_Type (Defining_Identifier (Vis_Decl)),
1858 TSS_RAS_Access))
1859 then
1860 return;
1861 end if;
1862
1863 Add_RAS_Dereference_TSS (Vis_Decl);
1864 Add_RAS_Access_TSS (Vis_Decl);
1865 end Add_RAST_Features;
1866
1867 -----------------------------------------
1868 -- Add_Receiving_Stubs_To_Declarations --
1869 -----------------------------------------
1870
1871 procedure Add_Receiving_Stubs_To_Declarations
1872 (Pkg_Spec : Node_Id;
1873 Decls : List_Id)
1874 is
1875 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
1876
1877 Stream_Parameter : Node_Id;
1878 Result_Parameter : Node_Id;
1879
1880 Pkg_RPC_Receiver : Node_Id;
1881 Pkg_RPC_Receiver_Spec : Node_Id;
1882 Pkg_RPC_Receiver_Decls : List_Id;
1883 Pkg_RPC_Receiver_Statements : List_Id;
1884 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
1885 Pkg_RPC_Receiver_Body : Node_Id;
1886 -- A Pkg_RPC_Receiver is built to decode the request
1887
1888 Lookup_RAS_Info : constant Entity_Id :=
1889 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
1890 -- A remote subprogram is created to allow peers to look up
1891 -- RAS information using subprogram ids.
1892
1893 Subp_Id : Node_Id;
1894 -- Subprogram_Id as read from the incoming stream
1895
1896 Current_Declaration : Node_Id;
1897 Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
1898 Current_Stubs : Node_Id;
1899
1900 Subp_Info_Array : constant Entity_Id :=
1901 Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
1902
1903 Subp_Info_List : constant List_Id := New_List;
1904
1905 Dummy_Register_Name : Name_Id;
1906 Dummy_Register_Spec : Node_Id;
1907 Dummy_Register_Decl : Node_Id;
1908 Dummy_Register_Body : Node_Id;
1909
1910 All_Calls_Remote_E : Entity_Id;
1911 Proxy_Object_Addr : Entity_Id;
1912
1913 procedure Append_Stubs_To
1914 (RPC_Receiver_Cases : List_Id;
1915 Declaration : Node_Id;
1916 Stubs : Node_Id;
1917 Subprogram_Number : Int);
1918 -- Add one case to the specified RPC receiver case list
1919 -- associating Subprogram_Number with the subprogram declared
1920 -- by Declaration, for which we have receiving stubs in Stubs.
1921
1922 procedure Append_Stubs_To
1923 (RPC_Receiver_Cases : List_Id;
1924 Declaration : Node_Id;
1925 Stubs : Node_Id;
1926 Subprogram_Number : Int)
1927 is
1928 Actuals : constant List_Id :=
1929 New_List (New_Occurrence_Of (Stream_Parameter, Loc));
1930 begin
1931 if Nkind (Specification (Declaration)) = N_Function_Specification
1932 or else not
1933 Is_Asynchronous (Defining_Entity (Specification (Declaration)))
1934 then
1935 -- An asynchronous procedure does not want an output parameter
1936 -- since no result and no exception will ever be returned.
1937
1938 Append_To (Actuals,
1939 New_Occurrence_Of (Result_Parameter, Loc));
1940 end if;
1941
1942 Append_To (RPC_Receiver_Cases,
1943 Make_Case_Statement_Alternative (Loc,
1944 Discrete_Choices =>
1945 New_List (
1946 Make_Integer_Literal (Loc, Subprogram_Number)),
1947
1948 Statements =>
1949 New_List (
1950 Make_Procedure_Call_Statement (Loc,
1951 Name =>
1952 New_Occurrence_Of (
1953 Defining_Entity (Stubs), Loc),
1954 Parameter_Associations =>
1955 Actuals))));
1956 end Append_Stubs_To;
1957
1958 -- Start of processing for Add_Receiving_Stubs_To_Declarations
1959
1960 begin
1961 -- Building receiving stubs consist in several operations:
1962
1963 -- - a package RPC receiver must be built. This subprogram
1964 -- will get a Subprogram_Id from the incoming stream
1965 -- and will dispatch the call to the right subprogram
1966
1967 -- - a receiving stub for any subprogram visible in the package
1968 -- spec. This stub will read all the parameters from the stream,
1969 -- and put the result as well as the exception occurrence in the
1970 -- output stream
1971
1972 -- - a dummy package with an empty spec and a body made of an
1973 -- elaboration part, whose job is to register the receiving
1974 -- part of this RCI package on the name server. This is done
1975 -- by calling System.Partition_Interface.Register_Receiving_Stub
1976
1977 Stream_Parameter :=
1978 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1979 Result_Parameter :=
1980 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
1981 Subp_Id :=
1982 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1983
1984 Pkg_RPC_Receiver :=
1985 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1986
1987 -- The parameters of the package RPC receiver are made of two
1988 -- streams, an input one and an output one.
1989
1990 Pkg_RPC_Receiver_Spec :=
1991 Build_RPC_Receiver_Specification
1992 (RPC_Receiver => Pkg_RPC_Receiver,
1993 Stream_Parameter => Stream_Parameter,
1994 Result_Parameter => Result_Parameter);
1995
1996 Pkg_RPC_Receiver_Decls := New_List (
1997 Make_Object_Declaration (Loc,
1998 Defining_Identifier => Subp_Id,
1999 Object_Definition =>
2000 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)));
2001
2002 Pkg_RPC_Receiver_Statements := New_List (
2003 Make_Attribute_Reference (Loc,
2004 Prefix =>
2005 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
2006 Attribute_Name =>
2007 Name_Read,
2008 Expressions => New_List (
2009 New_Occurrence_Of (Stream_Parameter, Loc),
2010 New_Occurrence_Of (Subp_Id, Loc))));
2011
2012 -- A null subp_id denotes a call through a RAS, in which case the
2013 -- next Uint_64 element in the stream is the address of the local
2014 -- proxy object, from which we can retrieve the actual subprogram id.
2015
2016 Append_To (Pkg_RPC_Receiver_Statements,
2017 Make_Implicit_If_Statement (Pkg_Spec,
2018 Condition =>
2019 Make_Op_Eq (Loc,
2020 New_Occurrence_Of (Subp_Id, Loc),
2021 Make_Integer_Literal (Loc, 0)),
2022 Then_Statements => New_List (
2023 Make_Assignment_Statement (Loc,
2024 Name =>
2025 New_Occurrence_Of (Subp_Id, Loc),
2026 Expression =>
2027 Make_Selected_Component (Loc,
2028 Prefix =>
2029 Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
2030 OK_Convert_To (RTE (RE_Address),
2031 Make_Attribute_Reference (Loc,
2032 Prefix =>
2033 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2034 Attribute_Name =>
2035 Name_Input,
2036 Expressions => New_List (
2037 New_Occurrence_Of (Stream_Parameter, Loc))))),
2038 Selector_Name =>
2039 Make_Identifier (Loc, Name_Subp_Id))))));
2040
2041 All_Calls_Remote_E := Boolean_Literals (
2042 Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
2043
2044 -- Build a subprogram for RAS information lookups
2045
2046 Current_Declaration :=
2047 Make_Subprogram_Declaration (Loc,
2048 Specification =>
2049 Make_Function_Specification (Loc,
2050 Defining_Unit_Name =>
2051 Lookup_RAS_Info,
2052 Parameter_Specifications => New_List (
2053 Make_Parameter_Specification (Loc,
2054 Defining_Identifier =>
2055 Make_Defining_Identifier (Loc, Name_Subp_Id),
2056 In_Present =>
2057 True,
2058 Parameter_Type =>
2059 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
2060 Subtype_Mark =>
2061 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
2062 Append_To (Decls, Current_Declaration);
2063 Analyze (Current_Declaration);
2064
2065 Current_Stubs := Build_Subprogram_Receiving_Stubs
2066 (Vis_Decl => Current_Declaration,
2067 Asynchronous => False);
2068 Append_To (Decls, Current_Stubs);
2069 Analyze (Current_Stubs);
2070
2071 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
2072 Declaration =>
2073 Current_Declaration,
2074 Stubs =>
2075 Current_Stubs,
2076 Subprogram_Number => 1);
2077
2078 -- For each subprogram, the receiving stub will be built and a
2079 -- case statement will be made on the Subprogram_Id to dispatch
2080 -- to the right subprogram.
2081
2082 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
2083 while Current_Declaration /= Empty loop
2084 if Nkind (Current_Declaration) = N_Subprogram_Declaration
2085 and then Comes_From_Source (Current_Declaration)
2086 then
2087 pragma Assert (Current_Subprogram_Number =
2088 Get_Subprogram_Id (Defining_Unit_Name (Specification (
2089 Current_Declaration))));
2090
2091 -- Build receiving stub
2092
2093 Current_Stubs :=
2094 Build_Subprogram_Receiving_Stubs
2095 (Vis_Decl => Current_Declaration,
2096 Asynchronous =>
2097 Nkind (Specification (Current_Declaration)) =
2098 N_Procedure_Specification
2099 and then Is_Asynchronous
2100 (Defining_Unit_Name (Specification
2101 (Current_Declaration))));
2102
2103 Append_To (Decls, Current_Stubs);
2104 Analyze (Current_Stubs);
2105
2106 -- Build RAS proxy
2107
2108 Add_RAS_Proxy_And_Analyze (Decls,
2109 Vis_Decl =>
2110 Current_Declaration,
2111 All_Calls_Remote_E =>
2112 All_Calls_Remote_E,
2113 Proxy_Object_Addr =>
2114 Proxy_Object_Addr);
2115
2116 -- Add subprogram descriptor (RCI_Subp_Info) to the
2117 -- subprograms table for this receiver. The aggregate
2118 -- below must be kept consistent with the declaration
2119 -- of type RCI_Subp_Info in System.Partition_Interface.
2120
2121 Append_To (Subp_Info_List,
2122 Make_Component_Association (Loc,
2123 Choices => New_List (
2124 Make_Integer_Literal (Loc,
2125 Current_Subprogram_Number)),
2126 Expression =>
2127 Make_Aggregate (Loc,
2128 Component_Associations => New_List (
2129 Make_Component_Association (Loc,
2130 Choices => New_List (
2131 Make_Identifier (Loc, Name_Addr)),
2132 Expression =>
2133 New_Occurrence_Of (Proxy_Object_Addr, Loc))))));
2134
2135 Append_Stubs_To (Pkg_RPC_Receiver_Cases,
2136 Declaration =>
2137 Current_Declaration,
2138 Stubs =>
2139 Current_Stubs,
2140 Subprogram_Number =>
2141 Current_Subprogram_Number);
2142 Current_Subprogram_Number := Current_Subprogram_Number + 1;
2143 end if;
2144
2145 Next (Current_Declaration);
2146 end loop;
2147
2148 -- If we receive an invalid Subprogram_Id, it is best to do nothing
2149 -- rather than raising an exception since we do not want someone
2150 -- to crash a remote partition by sending invalid subprogram ids.
2151 -- This is consistent with the other parts of the case statement
2152 -- since even in presence of incorrect parameters in the stream,
2153 -- every exception will be caught and (if the subprogram is not an
2154 -- APC) put into the result stream and sent away.
2155
2156 Append_To (Pkg_RPC_Receiver_Cases,
2157 Make_Case_Statement_Alternative (Loc,
2158 Discrete_Choices =>
2159 New_List (Make_Others_Choice (Loc)),
2160 Statements =>
2161 New_List (Make_Null_Statement (Loc))));
2162
2163 Append_To (Pkg_RPC_Receiver_Statements,
2164 Make_Case_Statement (Loc,
2165 Expression =>
2166 New_Occurrence_Of (Subp_Id, Loc),
2167 Alternatives => Pkg_RPC_Receiver_Cases));
2168
2169 Append_To (Decls,
2170 Make_Object_Declaration (Loc,
2171 Defining_Identifier => Subp_Info_Array,
2172 Constant_Present => True,
2173 Aliased_Present => True,
2174 Object_Definition =>
2175 Make_Subtype_Indication (Loc,
2176 Subtype_Mark =>
2177 New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
2178 Constraint =>
2179 Make_Index_Or_Discriminant_Constraint (Loc,
2180 New_List (
2181 Make_Range (Loc,
2182 Low_Bound => Make_Integer_Literal (Loc,
2183 First_RCI_Subprogram_Id),
2184 High_Bound =>
2185 Make_Integer_Literal (Loc,
2186 First_RCI_Subprogram_Id
2187 + List_Length (Subp_Info_List) - 1))))),
2188 Expression =>
2189 Make_Aggregate (Loc,
2190 Component_Associations => Subp_Info_List)));
2191 Analyze (Last (Decls));
2192
2193 Append_To (Decls,
2194 Make_Subprogram_Body (Loc,
2195 Specification =>
2196 Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
2197 Declarations =>
2198 No_List,
2199 Handled_Statement_Sequence =>
2200 Make_Handled_Sequence_Of_Statements (Loc,
2201 Statements => New_List (
2202 Make_Return_Statement (Loc,
2203 Expression => OK_Convert_To (RTE (RE_Unsigned_64),
2204 Make_Selected_Component (Loc,
2205 Prefix =>
2206 Make_Indexed_Component (Loc,
2207 Prefix =>
2208 New_Occurrence_Of (Subp_Info_Array, Loc),
2209 Expressions => New_List (
2210 Convert_To (Standard_Integer,
2211 Make_Identifier (Loc, Name_Subp_Id)))),
2212 Selector_Name =>
2213 Make_Identifier (Loc, Name_Addr))))))));
2214 Analyze (Last (Decls));
2215
2216 Pkg_RPC_Receiver_Body :=
2217 Make_Subprogram_Body (Loc,
2218 Specification => Pkg_RPC_Receiver_Spec,
2219 Declarations => Pkg_RPC_Receiver_Decls,
2220 Handled_Statement_Sequence =>
2221 Make_Handled_Sequence_Of_Statements (Loc,
2222 Statements => Pkg_RPC_Receiver_Statements));
2223
2224 Append_To (Decls, Pkg_RPC_Receiver_Body);
2225 Analyze (Pkg_RPC_Receiver_Body);
2226
2227 -- Construction of the dummy package used to register the package
2228 -- receiving stubs on the nameserver.
2229
2230 Dummy_Register_Name := New_Internal_Name ('P');
2231
2232 Dummy_Register_Spec :=
2233 Make_Package_Specification (Loc,
2234 Defining_Unit_Name =>
2235 Make_Defining_Identifier (Loc, Dummy_Register_Name),
2236 Visible_Declarations => No_List,
2237 End_Label => Empty);
2238
2239 Dummy_Register_Decl :=
2240 Make_Package_Declaration (Loc,
2241 Specification => Dummy_Register_Spec);
2242
2243 Append_To (Decls,
2244 Dummy_Register_Decl);
2245 Analyze (Dummy_Register_Decl);
2246
2247 Dummy_Register_Body :=
2248 Make_Package_Body (Loc,
2249 Defining_Unit_Name =>
2250 Make_Defining_Identifier (Loc, Dummy_Register_Name),
2251 Declarations => No_List,
2252
2253 Handled_Statement_Sequence =>
2254 Make_Handled_Sequence_Of_Statements (Loc,
2255 Statements => New_List (
2256 Make_Procedure_Call_Statement (Loc,
2257 Name =>
2258 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
2259
2260 Parameter_Associations => New_List (
2261 Make_String_Literal (Loc,
2262 Strval => Get_Pkg_Name_String_Id (Pkg_Spec)),
2263 Make_Attribute_Reference (Loc,
2264 Prefix =>
2265 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
2266 Attribute_Name =>
2267 Name_Unrestricted_Access),
2268 Make_Attribute_Reference (Loc,
2269 Prefix =>
2270 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2271 Attribute_Name =>
2272 Name_Version),
2273 Make_Attribute_Reference (Loc,
2274 Prefix =>
2275 New_Occurrence_Of (Subp_Info_Array, Loc),
2276 Attribute_Name =>
2277 Name_Address),
2278 Make_Attribute_Reference (Loc,
2279 Prefix =>
2280 New_Occurrence_Of (Subp_Info_Array, Loc),
2281 Attribute_Name =>
2282 Name_Length))))));
2283
2284 Append_To (Decls, Dummy_Register_Body);
2285 Analyze (Dummy_Register_Body);
2286 end Add_Receiving_Stubs_To_Declarations;
2287
2288 -------------------
2289 -- Add_Stub_Type --
2290 -------------------
2291
2292 procedure Add_Stub_Type
2293 (Designated_Type : Entity_Id;
2294 RACW_Type : Entity_Id;
2295 Decls : List_Id;
2296 Stub_Type : out Entity_Id;
2297 Stub_Type_Access : out Entity_Id;
2298 Object_RPC_Receiver : out Entity_Id;
2299 Existing : out Boolean)
2300 is
2301 Loc : constant Source_Ptr := Sloc (RACW_Type);
2302
2303 Stub_Elements : constant Stub_Structure :=
2304 Stubs_Table.Get (Designated_Type);
2305
2306 Stub_Type_Declaration : Node_Id;
2307 Stub_Type_Access_Declaration : Node_Id;
2308 Object_RPC_Receiver_Declaration : Node_Id;
2309
2310 RPC_Receiver_Stream : Entity_Id;
2311 RPC_Receiver_Result : Entity_Id;
2312
2313 begin
2314 if Stub_Elements /= Empty_Stub_Structure then
2315 Stub_Type := Stub_Elements.Stub_Type;
2316 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
2317 Object_RPC_Receiver := Stub_Elements.Object_RPC_Receiver;
2318 Existing := True;
2319 return;
2320 end if;
2321
2322 Existing := False;
2323 Stub_Type :=
2324 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2325 Stub_Type_Access :=
2326 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2327 Object_RPC_Receiver :=
2328 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
2329 RPC_Receiver_Stream :=
2330 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2331 RPC_Receiver_Result :=
2332 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2333 Stubs_Table.Set (Designated_Type,
2334 (Stub_Type => Stub_Type,
2335 Stub_Type_Access => Stub_Type_Access,
2336 Object_RPC_Receiver => Object_RPC_Receiver,
2337 RPC_Receiver_Stream => RPC_Receiver_Stream,
2338 RPC_Receiver_Result => RPC_Receiver_Result,
2339 RACW_Type => RACW_Type));
2340
2341 -- The stub type definition below must match exactly the one in
2342 -- s-parint.ads, since unchecked conversions will be used in
2343 -- s-parint.adb to modify pointers passed to Get_Unique_Remote_Pointer.
2344
2345 Stub_Type_Declaration :=
2346 Make_Full_Type_Declaration (Loc,
2347 Defining_Identifier => Stub_Type,
2348 Type_Definition =>
2349 Make_Record_Definition (Loc,
2350 Tagged_Present => True,
2351 Limited_Present => True,
2352 Component_List =>
2353 Make_Component_List (Loc,
2354 Component_Items => New_List (
2355
2356 Make_Component_Declaration (Loc,
2357 Defining_Identifier =>
2358 Make_Defining_Identifier (Loc, Name_Origin),
2359 Component_Definition =>
2360 Make_Component_Definition (Loc,
2361 Aliased_Present => False,
2362 Subtype_Indication =>
2363 New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
2364
2365 Make_Component_Declaration (Loc,
2366 Defining_Identifier =>
2367 Make_Defining_Identifier (Loc, Name_Receiver),
2368 Component_Definition =>
2369 Make_Component_Definition (Loc,
2370 Aliased_Present => False,
2371 Subtype_Indication =>
2372 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
2373
2374 Make_Component_Declaration (Loc,
2375 Defining_Identifier =>
2376 Make_Defining_Identifier (Loc, Name_Addr),
2377 Component_Definition =>
2378 Make_Component_Definition (Loc,
2379 Aliased_Present => False,
2380 Subtype_Indication =>
2381 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
2382
2383 Make_Component_Declaration (Loc,
2384 Defining_Identifier =>
2385 Make_Defining_Identifier (Loc, Name_Asynchronous),
2386 Component_Definition =>
2387 Make_Component_Definition (Loc,
2388 Aliased_Present => False,
2389 Subtype_Indication =>
2390 New_Occurrence_Of (Standard_Boolean, Loc)))))));
2391
2392 Append_To (Decls, Stub_Type_Declaration);
2393 Analyze (Stub_Type_Declaration);
2394
2395 -- This is in no way a type derivation, but we fake it to make
2396 -- sure that the dispatching table gets built with the corresponding
2397 -- primitive operations at the right place.
2398
2399 Derive_Subprograms (Parent_Type => Designated_Type,
2400 Derived_Type => Stub_Type);
2401
2402 Stub_Type_Access_Declaration :=
2403 Make_Full_Type_Declaration (Loc,
2404 Defining_Identifier => Stub_Type_Access,
2405 Type_Definition =>
2406 Make_Access_To_Object_Definition (Loc,
2407 All_Present => True,
2408 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
2409
2410 Append_To (Decls, Stub_Type_Access_Declaration);
2411 Analyze (Stub_Type_Access_Declaration);
2412
2413 Object_RPC_Receiver_Declaration :=
2414 Make_Subprogram_Declaration (Loc,
2415 Build_RPC_Receiver_Specification (
2416 RPC_Receiver => Object_RPC_Receiver,
2417 Stream_Parameter => RPC_Receiver_Stream,
2418 Result_Parameter => RPC_Receiver_Result));
2419
2420 Append_To (Decls, Object_RPC_Receiver_Declaration);
2421 end Add_Stub_Type;
2422
2423 ---------------------------------
2424 -- Build_General_Calling_Stubs --
2425 ---------------------------------
2426
2427 procedure Build_General_Calling_Stubs
2428 (Decls : List_Id;
2429 Statements : List_Id;
2430 Target_Partition : Entity_Id;
2431 RPC_Receiver : Node_Id;
2432 Subprogram_Id : Node_Id;
2433 Asynchronous : Node_Id := Empty;
2434 Is_Known_Asynchronous : Boolean := False;
2435 Is_Known_Non_Asynchronous : Boolean := False;
2436 Is_Function : Boolean;
2437 Spec : Node_Id;
2438 Object_Type : Entity_Id := Empty;
2439 Nod : Node_Id)
2440 is
2441 Loc : constant Source_Ptr := Sloc (Nod);
2442
2443 Stream_Parameter : Node_Id;
2444 -- Name of the stream used to transmit parameters to the remote package
2445
2446 Result_Parameter : Node_Id;
2447 -- Name of the result parameter (in non-APC cases) which get the
2448 -- result of the remote subprogram.
2449
2450 Exception_Return_Parameter : Node_Id;
2451 -- Name of the parameter which will hold the exception sent by the
2452 -- remote subprogram.
2453
2454 Current_Parameter : Node_Id;
2455 -- Current parameter being handled
2456
2457 Ordered_Parameters_List : constant List_Id :=
2458 Build_Ordered_Parameters_List (Spec);
2459
2460 Asynchronous_Statements : List_Id := No_List;
2461 Non_Asynchronous_Statements : List_Id := No_List;
2462 -- Statements specifics to the Asynchronous/Non-Asynchronous cases.
2463
2464 Extra_Formal_Statements : constant List_Id := New_List;
2465 -- List of statements for extra formal parameters. It will appear after
2466 -- the regular statements for writing out parameters.
2467
2468 begin
2469 -- The general form of a calling stub for a given subprogram is:
2470
2471 -- procedure X (...) is
2472 -- P : constant Partition_ID := RCI_Cache.Get_Active_Partition_ID;
2473 -- Stream, Result : aliased System.RPC.Params_Stream_Type (0);
2474 -- begin
2475 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
2476 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
2477 -- Put_Subprogram_Id_In_Stream;
2478 -- Put_Parameters_In_Stream;
2479 -- Do_RPC (Stream, Result);
2480 -- Read_Exception_Occurrence_From_Result; Raise_It;
2481 -- Read_Out_Parameters_And_Function_Return_From_Stream;
2482 -- end X;
2483
2484 -- There are some variations: Do_APC is called for an asynchronous
2485 -- procedure and the part after the call is completely ommitted
2486 -- as well as the declaration of Result. For a function call,
2487 -- 'Input is always used to read the result even if it is constrained.
2488
2489 Stream_Parameter :=
2490 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2491
2492 Append_To (Decls,
2493 Make_Object_Declaration (Loc,
2494 Defining_Identifier => Stream_Parameter,
2495 Aliased_Present => True,
2496 Object_Definition =>
2497 Make_Subtype_Indication (Loc,
2498 Subtype_Mark =>
2499 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
2500 Constraint =>
2501 Make_Index_Or_Discriminant_Constraint (Loc,
2502 Constraints =>
2503 New_List (Make_Integer_Literal (Loc, 0))))));
2504
2505 if not Is_Known_Asynchronous then
2506 Result_Parameter :=
2507 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2508
2509 Append_To (Decls,
2510 Make_Object_Declaration (Loc,
2511 Defining_Identifier => Result_Parameter,
2512 Aliased_Present => True,
2513 Object_Definition =>
2514 Make_Subtype_Indication (Loc,
2515 Subtype_Mark =>
2516 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
2517 Constraint =>
2518 Make_Index_Or_Discriminant_Constraint (Loc,
2519 Constraints =>
2520 New_List (Make_Integer_Literal (Loc, 0))))));
2521
2522 Exception_Return_Parameter :=
2523 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
2524
2525 Append_To (Decls,
2526 Make_Object_Declaration (Loc,
2527 Defining_Identifier => Exception_Return_Parameter,
2528 Object_Definition =>
2529 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
2530
2531 else
2532 Result_Parameter := Empty;
2533 Exception_Return_Parameter := Empty;
2534 end if;
2535
2536 -- Put first the RPC receiver corresponding to the remote package
2537
2538 Append_To (Statements,
2539 Make_Attribute_Reference (Loc,
2540 Prefix =>
2541 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2542 Attribute_Name => Name_Write,
2543 Expressions => New_List (
2544 Make_Attribute_Reference (Loc,
2545 Prefix =>
2546 New_Occurrence_Of (Stream_Parameter, Loc),
2547 Attribute_Name =>
2548 Name_Access),
2549 RPC_Receiver)));
2550
2551 -- Then put the Subprogram_Id of the subprogram we want to call in
2552 -- the stream.
2553
2554 Append_To (Statements,
2555 Make_Attribute_Reference (Loc,
2556 Prefix =>
2557 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
2558 Attribute_Name =>
2559 Name_Write,
2560 Expressions => New_List (
2561 Make_Attribute_Reference (Loc,
2562 Prefix =>
2563 New_Occurrence_Of (Stream_Parameter, Loc),
2564 Attribute_Name => Name_Access),
2565 Subprogram_Id)));
2566
2567 Current_Parameter := First (Ordered_Parameters_List);
2568 while Current_Parameter /= Empty loop
2569 declare
2570 Typ : constant Node_Id :=
2571 Parameter_Type (Current_Parameter);
2572 Etyp : Entity_Id;
2573 Constrained : Boolean;
2574 Value : Node_Id;
2575 Extra_Parameter : Entity_Id;
2576
2577 begin
2578 if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then
2579
2580 -- In the case of a controlling formal argument, we marshall
2581 -- its addr field rather than the local stub.
2582
2583 Append_To (Statements,
2584 Pack_Node_Into_Stream (Loc,
2585 Stream => Stream_Parameter,
2586 Object =>
2587 Make_Selected_Component (Loc,
2588 Prefix =>
2589 New_Occurrence_Of (
2590 Defining_Identifier (Current_Parameter), Loc),
2591 Selector_Name =>
2592 Make_Identifier (Loc, Name_Addr)),
2593 Etyp => RTE (RE_Unsigned_64)));
2594
2595 else
2596 Value := New_Occurrence_Of
2597 (Defining_Identifier (Current_Parameter), Loc);
2598
2599 -- Access type parameters are transmitted as in out
2600 -- parameters. However, a dereference is needed so that
2601 -- we marshall the designated object.
2602
2603 if Nkind (Typ) = N_Access_Definition then
2604 Value := Make_Explicit_Dereference (Loc, Value);
2605 Etyp := Etype (Subtype_Mark (Typ));
2606 else
2607 Etyp := Etype (Typ);
2608 end if;
2609
2610 Constrained :=
2611 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
2612
2613 -- Any parameter but unconstrained out parameters are
2614 -- transmitted to the peer.
2615
2616 if In_Present (Current_Parameter)
2617 or else not Out_Present (Current_Parameter)
2618 or else not Constrained
2619 then
2620 Append_To (Statements,
2621 Make_Attribute_Reference (Loc,
2622 Prefix =>
2623 New_Occurrence_Of (Etyp, Loc),
2624 Attribute_Name => Output_From_Constrained (Constrained),
2625 Expressions => New_List (
2626 Make_Attribute_Reference (Loc,
2627 Prefix =>
2628 New_Occurrence_Of (Stream_Parameter, Loc),
2629 Attribute_Name => Name_Access),
2630 Value)));
2631 end if;
2632 end if;
2633
2634 -- If the current parameter has a dynamic constrained status,
2635 -- then this status is transmitted as well.
2636 -- This should be done for accessibility as well ???
2637
2638 if Nkind (Typ) /= N_Access_Definition
2639 and then Need_Extra_Constrained (Current_Parameter)
2640 then
2641 -- In this block, we do not use the extra formal that has been
2642 -- created because it does not exist at the time of expansion
2643 -- when building calling stubs for remote access to subprogram
2644 -- types. We create an extra variable of this type and push it
2645 -- in the stream after the regular parameters.
2646
2647 Extra_Parameter := Make_Defining_Identifier
2648 (Loc, New_Internal_Name ('P'));
2649
2650 Append_To (Decls,
2651 Make_Object_Declaration (Loc,
2652 Defining_Identifier => Extra_Parameter,
2653 Constant_Present => True,
2654 Object_Definition =>
2655 New_Occurrence_Of (Standard_Boolean, Loc),
2656 Expression =>
2657 Make_Attribute_Reference (Loc,
2658 Prefix =>
2659 New_Occurrence_Of (
2660 Defining_Identifier (Current_Parameter), Loc),
2661 Attribute_Name => Name_Constrained)));
2662
2663 Append_To (Extra_Formal_Statements,
2664 Make_Attribute_Reference (Loc,
2665 Prefix =>
2666 New_Occurrence_Of (Standard_Boolean, Loc),
2667 Attribute_Name =>
2668 Name_Write,
2669 Expressions => New_List (
2670 Make_Attribute_Reference (Loc,
2671 Prefix =>
2672 New_Occurrence_Of (Stream_Parameter, Loc),
2673 Attribute_Name =>
2674 Name_Access),
2675 New_Occurrence_Of (Extra_Parameter, Loc))));
2676 end if;
2677
2678 Next (Current_Parameter);
2679 end;
2680 end loop;
2681
2682 -- Append the formal statements list to the statements
2683
2684 Append_List_To (Statements, Extra_Formal_Statements);
2685
2686 if not Is_Known_Non_Asynchronous then
2687
2688 -- Build the call to System.RPC.Do_APC
2689
2690 Asynchronous_Statements := New_List (
2691 Make_Procedure_Call_Statement (Loc,
2692 Name =>
2693 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
2694 Parameter_Associations => New_List (
2695 New_Occurrence_Of (Target_Partition, Loc),
2696 Make_Attribute_Reference (Loc,
2697 Prefix =>
2698 New_Occurrence_Of (Stream_Parameter, Loc),
2699 Attribute_Name =>
2700 Name_Access))));
2701 else
2702 Asynchronous_Statements := No_List;
2703 end if;
2704
2705 if not Is_Known_Asynchronous then
2706
2707 -- Build the call to System.RPC.Do_RPC
2708
2709 Non_Asynchronous_Statements := New_List (
2710 Make_Procedure_Call_Statement (Loc,
2711 Name =>
2712 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
2713 Parameter_Associations => New_List (
2714 New_Occurrence_Of (Target_Partition, Loc),
2715
2716 Make_Attribute_Reference (Loc,
2717 Prefix =>
2718 New_Occurrence_Of (Stream_Parameter, Loc),
2719 Attribute_Name =>
2720 Name_Access),
2721
2722 Make_Attribute_Reference (Loc,
2723 Prefix =>
2724 New_Occurrence_Of (Result_Parameter, Loc),
2725 Attribute_Name =>
2726 Name_Access))));
2727
2728 -- Read the exception occurrence from the result stream and
2729 -- reraise it. It does no harm if this is a Null_Occurrence since
2730 -- this does nothing.
2731
2732 Append_To (Non_Asynchronous_Statements,
2733 Make_Attribute_Reference (Loc,
2734 Prefix =>
2735 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
2736
2737 Attribute_Name =>
2738 Name_Read,
2739
2740 Expressions => New_List (
2741 Make_Attribute_Reference (Loc,
2742 Prefix =>
2743 New_Occurrence_Of (Result_Parameter, Loc),
2744 Attribute_Name =>
2745 Name_Access),
2746 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
2747
2748 Append_To (Non_Asynchronous_Statements,
2749 Make_Procedure_Call_Statement (Loc,
2750 Name =>
2751 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
2752 Parameter_Associations => New_List (
2753 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
2754
2755 if Is_Function then
2756
2757 -- If this is a function call, then read the value and return
2758 -- it. The return value is written/read using 'Output/'Input.
2759
2760 Append_To (Non_Asynchronous_Statements,
2761 Make_Tag_Check (Loc,
2762 Make_Return_Statement (Loc,
2763 Expression =>
2764 Make_Attribute_Reference (Loc,
2765 Prefix =>
2766 New_Occurrence_Of (
2767 Etype (Subtype_Mark (Spec)), Loc),
2768
2769 Attribute_Name => Name_Input,
2770
2771 Expressions => New_List (
2772 Make_Attribute_Reference (Loc,
2773 Prefix =>
2774 New_Occurrence_Of (Result_Parameter, Loc),
2775 Attribute_Name => Name_Access))))));
2776
2777 else
2778 -- Loop around parameters and assign out (or in out) parameters.
2779 -- In the case of RACW, controlling arguments cannot possibly
2780 -- have changed since they are remote, so we do not read them
2781 -- from the stream.
2782
2783 Current_Parameter := First (Ordered_Parameters_List);
2784 while Current_Parameter /= Empty loop
2785 declare
2786 Typ : constant Node_Id :=
2787 Parameter_Type (Current_Parameter);
2788 Etyp : Entity_Id;
2789 Value : Node_Id;
2790
2791 begin
2792 Value :=
2793 New_Occurrence_Of
2794 (Defining_Identifier (Current_Parameter), Loc);
2795
2796 if Nkind (Typ) = N_Access_Definition then
2797 Value := Make_Explicit_Dereference (Loc, Value);
2798 Etyp := Etype (Subtype_Mark (Typ));
2799 else
2800 Etyp := Etype (Typ);
2801 end if;
2802
2803 if (Out_Present (Current_Parameter)
2804 or else Nkind (Typ) = N_Access_Definition)
2805 and then Etyp /= Object_Type
2806 then
2807 Append_To (Non_Asynchronous_Statements,
2808 Make_Attribute_Reference (Loc,
2809 Prefix =>
2810 New_Occurrence_Of (Etyp, Loc),
2811
2812 Attribute_Name => Name_Read,
2813
2814 Expressions => New_List (
2815 Make_Attribute_Reference (Loc,
2816 Prefix =>
2817 New_Occurrence_Of (Result_Parameter, Loc),
2818 Attribute_Name =>
2819 Name_Access),
2820 Value)));
2821 end if;
2822 end;
2823
2824 Next (Current_Parameter);
2825 end loop;
2826 end if;
2827 end if;
2828
2829 if Is_Known_Asynchronous then
2830 Append_List_To (Statements, Asynchronous_Statements);
2831
2832 elsif Is_Known_Non_Asynchronous then
2833 Append_List_To (Statements, Non_Asynchronous_Statements);
2834
2835 else
2836 pragma Assert (Asynchronous /= Empty);
2837 Prepend_To (Asynchronous_Statements,
2838 Make_Attribute_Reference (Loc,
2839 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
2840 Attribute_Name => Name_Write,
2841 Expressions => New_List (
2842 Make_Attribute_Reference (Loc,
2843 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
2844 Attribute_Name => Name_Access),
2845 New_Occurrence_Of (Standard_True, Loc))));
2846
2847 Prepend_To (Non_Asynchronous_Statements,
2848 Make_Attribute_Reference (Loc,
2849 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
2850 Attribute_Name => Name_Write,
2851 Expressions => New_List (
2852 Make_Attribute_Reference (Loc,
2853 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
2854 Attribute_Name => Name_Access),
2855 New_Occurrence_Of (Standard_False, Loc))));
2856
2857 Append_To (Statements,
2858 Make_Implicit_If_Statement (Nod,
2859 Condition => Asynchronous,
2860 Then_Statements => Asynchronous_Statements,
2861 Else_Statements => Non_Asynchronous_Statements));
2862 end if;
2863 end Build_General_Calling_Stubs;
2864
2865 ------------------------------
2866 -- Build_Get_Unique_RP_Call --
2867 ------------------------------
2868
2869 function Build_Get_Unique_RP_Call
2870 (Loc : Source_Ptr;
2871 Pointer : Entity_Id;
2872 Stub_Type : Entity_Id) return List_Id
2873 is
2874 begin
2875 return New_List (
2876 Make_Procedure_Call_Statement (Loc,
2877 Name =>
2878 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
2879 Parameter_Associations => New_List (
2880 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
2881 New_Occurrence_Of (Pointer, Loc)))),
2882
2883 Make_Assignment_Statement (Loc,
2884 Name =>
2885 Make_Selected_Component (Loc,
2886 Prefix =>
2887 New_Occurrence_Of (Pointer, Loc),
2888 Selector_Name =>
2889 New_Occurrence_Of (Tag_Component
2890 (Designated_Type (Etype (Pointer))), Loc)),
2891 Expression =>
2892 Make_Attribute_Reference (Loc,
2893 Prefix =>
2894 New_Occurrence_Of (Stub_Type, Loc),
2895 Attribute_Name =>
2896 Name_Tag)));
2897
2898 -- Note: The assignment to Pointer._Tag is safe here because
2899 -- we carefully ensured that Stub_Type has exactly the same layout
2900 -- as System.Partition_Interface.RACW_Stub_Type.
2901
2902 end Build_Get_Unique_RP_Call;
2903
2904 ----------------------------------------
2905 -- Build_Remote_Subprogram_Proxy_Type --
2906 ----------------------------------------
2907
2908 function Build_Remote_Subprogram_Proxy_Type
2909 (Loc : Source_Ptr;
2910 ACR_Expression : Node_Id) return Node_Id
2911 is
2912 begin
2913 return
2914 Make_Record_Definition (Loc,
2915 Tagged_Present => True,
2916 Limited_Present => True,
2917 Component_List =>
2918 Make_Component_List (Loc,
2919
2920 Component_Items => New_List (
2921 Make_Component_Declaration (Loc,
2922 Make_Defining_Identifier (Loc,
2923 Name_All_Calls_Remote),
2924 Make_Component_Definition (Loc,
2925 Subtype_Indication =>
2926 New_Occurrence_Of (Standard_Boolean, Loc)),
2927 ACR_Expression),
2928
2929 Make_Component_Declaration (Loc,
2930 Make_Defining_Identifier (Loc,
2931 Name_Receiver),
2932 Make_Component_Definition (Loc,
2933 Subtype_Indication =>
2934 New_Occurrence_Of (RTE (RE_Address), Loc)),
2935 New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
2936
2937 Make_Component_Declaration (Loc,
2938 Make_Defining_Identifier (Loc,
2939 Name_Subp_Id),
2940 Make_Component_Definition (Loc,
2941 Subtype_Indication =>
2942 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
2943 end Build_Remote_Subprogram_Proxy_Type;
2944
2945 -----------------------------------
2946 -- Build_Ordered_Parameters_List --
2947 -----------------------------------
2948
2949 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2950 Constrained_List : List_Id;
2951 Unconstrained_List : List_Id;
2952 Current_Parameter : Node_Id;
2953
2954 First_Parameter : Node_Id;
2955 For_RAS : Boolean := False;
2956
2957 begin
2958 if not Present (Parameter_Specifications (Spec)) then
2959 return New_List;
2960 end if;
2961
2962 Constrained_List := New_List;
2963 Unconstrained_List := New_List;
2964 First_Parameter := First (Parameter_Specifications (Spec));
2965
2966 if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
2967 and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
2968 then
2969 For_RAS := True;
2970 end if;
2971
2972 -- Loop through the parameters and add them to the right list
2973
2974 Current_Parameter := First_Parameter;
2975 while Current_Parameter /= Empty loop
2976 if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
2977 or else
2978 Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
2979 or else
2980 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
2981 and then not (For_RAS and then Current_Parameter = First_Parameter)
2982 then
2983 Append_To (Constrained_List, New_Copy (Current_Parameter));
2984 else
2985 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2986 end if;
2987
2988 Next (Current_Parameter);
2989 end loop;
2990
2991 -- Unconstrained parameters are returned first
2992
2993 Append_List_To (Unconstrained_List, Constrained_List);
2994
2995 return Unconstrained_List;
2996 end Build_Ordered_Parameters_List;
2997
2998 ----------------------------------
2999 -- Build_Passive_Partition_Stub --
3000 ----------------------------------
3001
3002 procedure Build_Passive_Partition_Stub (U : Node_Id) is
3003 Pkg_Spec : Node_Id;
3004 L : List_Id;
3005 Reg : Node_Id;
3006 Loc : constant Source_Ptr := Sloc (U);
3007
3008 begin
3009 -- Verify that the implementation supports distribution, by accessing
3010 -- a type defined in the proper version of system.rpc
3011
3012 declare
3013 Dist_OK : Entity_Id;
3014 pragma Warnings (Off, Dist_OK);
3015 begin
3016 Dist_OK := RTE (RE_Params_Stream_Type);
3017 end;
3018
3019 -- Use body if present, spec otherwise
3020
3021 if Nkind (U) = N_Package_Declaration then
3022 Pkg_Spec := Specification (U);
3023 L := Visible_Declarations (Pkg_Spec);
3024 else
3025 Pkg_Spec := Parent (Corresponding_Spec (U));
3026 L := Declarations (U);
3027 end if;
3028
3029 Reg :=
3030 Make_Procedure_Call_Statement (Loc,
3031 Name =>
3032 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
3033 Parameter_Associations => New_List (
3034 Make_String_Literal (Loc, Get_Pkg_Name_String_Id (Pkg_Spec)),
3035 Make_Attribute_Reference (Loc,
3036 Prefix =>
3037 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
3038 Attribute_Name =>
3039 Name_Version)));
3040 Append_To (L, Reg);
3041 Analyze (Reg);
3042 end Build_Passive_Partition_Stub;
3043
3044 --------------------------------------
3045 -- Build_RPC_Receiver_Specification --
3046 --------------------------------------
3047
3048 function Build_RPC_Receiver_Specification
3049 (RPC_Receiver : Entity_Id;
3050 Stream_Parameter : Entity_Id;
3051 Result_Parameter : Entity_Id) return Node_Id
3052 is
3053 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
3054
3055 begin
3056 return
3057 Make_Procedure_Specification (Loc,
3058 Defining_Unit_Name => RPC_Receiver,
3059 Parameter_Specifications => New_List (
3060 Make_Parameter_Specification (Loc,
3061 Defining_Identifier => Stream_Parameter,
3062 Parameter_Type =>
3063 Make_Access_Definition (Loc,
3064 Subtype_Mark =>
3065 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
3066
3067 Make_Parameter_Specification (Loc,
3068 Defining_Identifier => Result_Parameter,
3069 Parameter_Type =>
3070 Make_Access_Definition (Loc,
3071 Subtype_Mark =>
3072 New_Occurrence_Of
3073 (RTE (RE_Params_Stream_Type), Loc)))));
3074 end Build_RPC_Receiver_Specification;
3075
3076 ------------------------------------
3077 -- Build_Subprogram_Calling_Stubs --
3078 ------------------------------------
3079
3080 function Build_Subprogram_Calling_Stubs
3081 (Vis_Decl : Node_Id;
3082 Subp_Id : Int;
3083 Asynchronous : Boolean;
3084 Dynamically_Asynchronous : Boolean := False;
3085 Stub_Type : Entity_Id := Empty;
3086 Locator : Entity_Id := Empty;
3087 New_Name : Name_Id := No_Name) return Node_Id
3088 is
3089 Loc : constant Source_Ptr := Sloc (Vis_Decl);
3090
3091 Target_Partition : Node_Id;
3092 -- Contains the name of the target partition
3093
3094 Decls : constant List_Id := New_List;
3095 Statements : constant List_Id := New_List;
3096
3097 Subp_Spec : Node_Id;
3098 -- The specification of the body
3099
3100 Controlling_Parameter : Entity_Id := Empty;
3101 RPC_Receiver : Node_Id;
3102
3103 Asynchronous_Expr : Node_Id := Empty;
3104
3105 RCI_Locator : Entity_Id;
3106
3107 Spec_To_Use : Node_Id;
3108
3109 procedure Insert_Partition_Check (Parameter : Node_Id);
3110 -- Check that the parameter has been elaborated on the same partition
3111 -- than the controlling parameter (E.4(19)).
3112
3113 ----------------------------
3114 -- Insert_Partition_Check --
3115 ----------------------------
3116
3117 procedure Insert_Partition_Check (Parameter : Node_Id) is
3118 Parameter_Entity : constant Entity_Id :=
3119 Defining_Identifier (Parameter);
3120 Condition : Node_Id;
3121
3122 Designated_Object : Node_Id;
3123 pragma Warnings (Off, Designated_Object);
3124 -- Is it really right that this is unreferenced ???
3125
3126 begin
3127 -- The expression that will be built is of the form:
3128 -- if not (Parameter in Stub_Type and then
3129 -- Parameter.Origin = Controlling.Origin)
3130 -- then
3131 -- raise Constraint_Error;
3132 -- end if;
3133
3134 -- Condition contains the reversed condition. Also, Parameter is
3135 -- dereferenced if it is an access type. We do not check that
3136 -- Parameter is in Stub_Type since such a check has been inserted
3137 -- at the point of call already (a tag check since we have multiple
3138 -- controlling operands).
3139
3140 if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
3141 Designated_Object :=
3142 Make_Explicit_Dereference (Loc,
3143 Prefix => New_Occurrence_Of (Parameter_Entity, Loc));
3144 else
3145 Designated_Object := New_Occurrence_Of (Parameter_Entity, Loc);
3146 end if;
3147
3148 Condition :=
3149 Make_Op_Eq (Loc,
3150 Left_Opnd =>
3151 Make_Selected_Component (Loc,
3152 Prefix =>
3153 New_Occurrence_Of (Parameter_Entity, Loc),
3154 Selector_Name =>
3155 Make_Identifier (Loc, Name_Origin)),
3156
3157 Right_Opnd =>
3158 Make_Selected_Component (Loc,
3159 Prefix =>
3160 New_Occurrence_Of (Controlling_Parameter, Loc),
3161 Selector_Name =>
3162 Make_Identifier (Loc, Name_Origin)));
3163
3164 Append_To (Decls,
3165 Make_Raise_Constraint_Error (Loc,
3166 Condition =>
3167 Make_Op_Not (Loc, Right_Opnd => Condition),
3168 Reason => CE_Partition_Check_Failed));
3169 end Insert_Partition_Check;
3170
3171 -- Start of processing for Build_Subprogram_Calling_Stubs
3172
3173 begin
3174 Target_Partition :=
3175 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3176
3177 Subp_Spec := Copy_Specification (Loc,
3178 Spec => Specification (Vis_Decl),
3179 New_Name => New_Name);
3180
3181 if Locator = Empty then
3182 RCI_Locator := RCI_Cache;
3183 Spec_To_Use := Specification (Vis_Decl);
3184 else
3185 RCI_Locator := Locator;
3186 Spec_To_Use := Subp_Spec;
3187 end if;
3188
3189 -- Find a controlling argument if we have a stub type. Also check
3190 -- if this subprogram can be made asynchronous.
3191
3192 if Stub_Type /= Empty
3193 and then Present (Parameter_Specifications (Spec_To_Use))
3194 then
3195 declare
3196 Current_Parameter : Node_Id :=
3197 First (Parameter_Specifications
3198 (Spec_To_Use));
3199 begin
3200 while Current_Parameter /= Empty loop
3201
3202 if
3203 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
3204 then
3205 if Controlling_Parameter = Empty then
3206 Controlling_Parameter :=
3207 Defining_Identifier (Current_Parameter);
3208 else
3209 Insert_Partition_Check (Current_Parameter);
3210 end if;
3211 end if;
3212
3213 Next (Current_Parameter);
3214 end loop;
3215 end;
3216 end if;
3217
3218 if Stub_Type /= Empty then
3219 pragma Assert (Controlling_Parameter /= Empty);
3220
3221 Append_To (Decls,
3222 Make_Object_Declaration (Loc,
3223 Defining_Identifier => Target_Partition,
3224 Constant_Present => True,
3225 Object_Definition =>
3226 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3227
3228 Expression =>
3229 Make_Selected_Component (Loc,
3230 Prefix =>
3231 New_Occurrence_Of (Controlling_Parameter, Loc),
3232 Selector_Name =>
3233 Make_Identifier (Loc, Name_Origin))));
3234
3235 RPC_Receiver :=
3236 Make_Selected_Component (Loc,
3237 Prefix =>
3238 New_Occurrence_Of (Controlling_Parameter, Loc),
3239 Selector_Name =>
3240 Make_Identifier (Loc, Name_Receiver));
3241
3242 else
3243 Append_To (Decls,
3244 Make_Object_Declaration (Loc,
3245 Defining_Identifier => Target_Partition,
3246 Constant_Present => True,
3247 Object_Definition =>
3248 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
3249
3250 Expression =>
3251 Make_Function_Call (Loc,
3252 Name => Make_Selected_Component (Loc,
3253 Prefix =>
3254 Make_Identifier (Loc, Chars (RCI_Locator)),
3255 Selector_Name =>
3256 Make_Identifier (Loc, Name_Get_Active_Partition_ID)))));
3257
3258 RPC_Receiver :=
3259 Make_Selected_Component (Loc,
3260 Prefix =>
3261 Make_Identifier (Loc, Chars (RCI_Locator)),
3262 Selector_Name =>
3263 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
3264 end if;
3265
3266 if Dynamically_Asynchronous then
3267 Asynchronous_Expr :=
3268 Make_Selected_Component (Loc,
3269 Prefix =>
3270 New_Occurrence_Of (Controlling_Parameter, Loc),
3271 Selector_Name =>
3272 Make_Identifier (Loc, Name_Asynchronous));
3273 end if;
3274
3275 Build_General_Calling_Stubs
3276 (Decls => Decls,
3277 Statements => Statements,
3278 Target_Partition => Target_Partition,
3279 RPC_Receiver => RPC_Receiver,
3280 Subprogram_Id => Make_Integer_Literal (Loc, Subp_Id),
3281 Asynchronous => Asynchronous_Expr,
3282 Is_Known_Asynchronous => Asynchronous
3283 and then not Dynamically_Asynchronous,
3284 Is_Known_Non_Asynchronous
3285 => not Asynchronous
3286 and then not Dynamically_Asynchronous,
3287 Is_Function => Nkind (Spec_To_Use) =
3288 N_Function_Specification,
3289 Spec => Spec_To_Use,
3290 Object_Type => Stub_Type,
3291 Nod => Vis_Decl);
3292
3293 RCI_Calling_Stubs_Table.Set
3294 (Defining_Unit_Name (Specification (Vis_Decl)),
3295 Defining_Unit_Name (Spec_To_Use));
3296
3297 return
3298 Make_Subprogram_Body (Loc,
3299 Specification => Subp_Spec,
3300 Declarations => Decls,
3301 Handled_Statement_Sequence =>
3302 Make_Handled_Sequence_Of_Statements (Loc, Statements));
3303 end Build_Subprogram_Calling_Stubs;
3304
3305 -------------------------
3306 -- Build_Subprogram_Id --
3307 -------------------------
3308
3309 function Build_Subprogram_Id
3310 (Loc : Source_Ptr;
3311 E : Entity_Id) return Node_Id
3312 is
3313 begin
3314 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
3315 end Build_Subprogram_Id;
3316
3317 --------------------------------------
3318 -- Build_Subprogram_Receiving_Stubs --
3319 --------------------------------------
3320
3321 function Build_Subprogram_Receiving_Stubs
3322 (Vis_Decl : Node_Id;
3323 Asynchronous : Boolean;
3324 Dynamically_Asynchronous : Boolean := False;
3325 Stub_Type : Entity_Id := Empty;
3326 RACW_Type : Entity_Id := Empty;
3327 Parent_Primitive : Entity_Id := Empty) return Node_Id
3328 is
3329 Loc : constant Source_Ptr := Sloc (Vis_Decl);
3330
3331 Stream_Parameter : Node_Id;
3332 Result_Parameter : Node_Id;
3333 -- See explanations of those in Build_Subprogram_Calling_Stubs
3334
3335 Decls : constant List_Id := New_List;
3336 -- All the parameters will get declared before calling the real
3337 -- subprograms. Also the out parameters will be declared.
3338
3339 Statements : constant List_Id := New_List;
3340
3341 Extra_Formal_Statements : constant List_Id := New_List;
3342 -- Statements concerning extra formal parameters
3343
3344 After_Statements : constant List_Id := New_List;
3345 -- Statements to be executed after the subprogram call
3346
3347 Inner_Decls : List_Id := No_List;
3348 -- In case of a function, the inner declarations are needed since
3349 -- the result may be unconstrained.
3350
3351 Excep_Handler : Node_Id;
3352 Excep_Choice : Entity_Id;
3353 Excep_Code : List_Id;
3354
3355 Parameter_List : constant List_Id := New_List;
3356 -- List of parameters to be passed to the subprogram
3357
3358 Current_Parameter : Node_Id;
3359
3360 Ordered_Parameters_List : constant List_Id :=
3361 Build_Ordered_Parameters_List
3362 (Specification (Vis_Decl));
3363
3364 Subp_Spec : Node_Id;
3365 -- Subprogram specification
3366
3367 Called_Subprogram : Node_Id;
3368 -- The subprogram to call
3369
3370 Null_Raise_Statement : Node_Id;
3371
3372 Dynamic_Async : Entity_Id;
3373
3374 begin
3375 if RACW_Type /= Empty then
3376 Called_Subprogram :=
3377 New_Occurrence_Of (Parent_Primitive, Loc);
3378 else
3379 Called_Subprogram :=
3380 New_Occurrence_Of (
3381 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
3382 end if;
3383
3384 Stream_Parameter :=
3385 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3386
3387 if Dynamically_Asynchronous then
3388 Dynamic_Async :=
3389 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3390 else
3391 Dynamic_Async := Empty;
3392 end if;
3393
3394 if not Asynchronous or else Dynamically_Asynchronous then
3395 Result_Parameter :=
3396 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3397
3398 -- The first statement after the subprogram call is a statement to
3399 -- writes a Null_Occurrence into the result stream.
3400
3401 Null_Raise_Statement :=
3402 Make_Attribute_Reference (Loc,
3403 Prefix =>
3404 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
3405 Attribute_Name => Name_Write,
3406 Expressions => New_List (
3407 New_Occurrence_Of (Result_Parameter, Loc),
3408 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
3409
3410 if Dynamically_Asynchronous then
3411 Null_Raise_Statement :=
3412 Make_Implicit_If_Statement (Vis_Decl,
3413 Condition =>
3414 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
3415 Then_Statements => New_List (Null_Raise_Statement));
3416 end if;
3417
3418 Append_To (After_Statements, Null_Raise_Statement);
3419
3420 else
3421 Result_Parameter := Empty;
3422 end if;
3423
3424 -- Loop through every parameter and get its value from the stream. If
3425 -- the parameter is unconstrained, then the parameter is read using
3426 -- 'Input at the point of declaration.
3427
3428 Current_Parameter := First (Ordered_Parameters_List);
3429
3430 while Current_Parameter /= Empty loop
3431
3432 declare
3433 Etyp : Entity_Id;
3434 RACW_Controlling : Boolean;
3435 Constrained : Boolean;
3436 Object : Entity_Id;
3437 Expr : Node_Id := Empty;
3438
3439 begin
3440 Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3441 Set_Ekind (Object, E_Variable);
3442
3443 RACW_Controlling :=
3444 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
3445
3446 if RACW_Controlling then
3447
3448 -- We have a controlling formal parameter. Read its address
3449 -- rather than a real object. The address is in Unsigned_64
3450 -- form.
3451
3452 Etyp := RTE (RE_Unsigned_64);
3453 else
3454 Etyp := Etype (Parameter_Type (Current_Parameter));
3455 end if;
3456
3457 Constrained :=
3458 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
3459
3460 if In_Present (Current_Parameter)
3461 or else not Out_Present (Current_Parameter)
3462 or else not Constrained
3463 or else RACW_Controlling
3464 then
3465 -- If an input parameter is contrained, then its reading is
3466 -- deferred until the beginning of the subprogram body. If
3467 -- it is unconstrained, then an expression is built for
3468 -- the object declaration and the variable is set using
3469 -- 'Input instead of 'Read.
3470
3471 if Constrained and then not RACW_Controlling then
3472 Append_To (Statements,
3473 Make_Attribute_Reference (Loc,
3474 Prefix => New_Occurrence_Of (Etyp, Loc),
3475 Attribute_Name => Name_Read,
3476 Expressions => New_List (
3477 New_Occurrence_Of (Stream_Parameter, Loc),
3478 New_Occurrence_Of (Object, Loc))));
3479
3480 else
3481 Expr := Input_With_Tag_Check (Loc,
3482 Var_Type => Etyp,
3483 Stream => Stream_Parameter);
3484 Append_To (Decls, Expr);
3485 Expr := Make_Function_Call (Loc,
3486 New_Occurrence_Of (Defining_Unit_Name
3487 (Specification (Expr)), Loc));
3488 end if;
3489 end if;
3490
3491 -- If we do not have to output the current parameter, then
3492 -- it can well be flagged as constant. This may allow further
3493 -- optimizations done by the back end.
3494
3495 Append_To (Decls,
3496 Make_Object_Declaration (Loc,
3497 Defining_Identifier => Object,
3498 Constant_Present =>
3499 not Constrained and then not Out_Present (Current_Parameter),
3500 Object_Definition =>
3501 New_Occurrence_Of (Etyp, Loc),
3502 Expression => Expr));
3503
3504 -- An out parameter may be written back using a 'Write
3505 -- attribute instead of a 'Output because it has been
3506 -- constrained by the parameter given to the caller. Note that
3507 -- out controlling arguments in the case of a RACW are not put
3508 -- back in the stream because the pointer on them has not
3509 -- changed.
3510
3511 if Out_Present (Current_Parameter)
3512 and then
3513 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
3514 then
3515 Append_To (After_Statements,
3516 Make_Attribute_Reference (Loc,
3517 Prefix => New_Occurrence_Of (Etyp, Loc),
3518 Attribute_Name => Name_Write,
3519 Expressions => New_List (
3520 New_Occurrence_Of (Result_Parameter, Loc),
3521 New_Occurrence_Of (Object, Loc))));
3522 end if;
3523
3524 if
3525 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
3526 then
3527 if Nkind (Parameter_Type (Current_Parameter)) /=
3528 N_Access_Definition
3529 then
3530 Append_To (Parameter_List,
3531 Make_Parameter_Association (Loc,
3532 Selector_Name =>
3533 New_Occurrence_Of (
3534 Defining_Identifier (Current_Parameter), Loc),
3535 Explicit_Actual_Parameter =>
3536 Make_Explicit_Dereference (Loc,
3537 Unchecked_Convert_To (RACW_Type,
3538 OK_Convert_To (RTE (RE_Address),
3539 New_Occurrence_Of (Object, Loc))))));
3540
3541 else
3542 Append_To (Parameter_List,
3543 Make_Parameter_Association (Loc,
3544 Selector_Name =>
3545 New_Occurrence_Of (
3546 Defining_Identifier (Current_Parameter), Loc),
3547 Explicit_Actual_Parameter =>
3548 Unchecked_Convert_To (RACW_Type,
3549 OK_Convert_To (RTE (RE_Address),
3550 New_Occurrence_Of (Object, Loc)))));
3551 end if;
3552
3553 else
3554 Append_To (Parameter_List,
3555 Make_Parameter_Association (Loc,
3556 Selector_Name =>
3557 New_Occurrence_Of (
3558 Defining_Identifier (Current_Parameter), Loc),
3559 Explicit_Actual_Parameter =>
3560 New_Occurrence_Of (Object, Loc)));
3561 end if;
3562
3563 -- If the current parameter needs an extra formal, then read it
3564 -- from the stream and set the corresponding semantic field in
3565 -- the variable. If the kind of the parameter identifier is
3566 -- E_Void, then this is a compiler generated parameter that
3567 -- doesn't need an extra constrained status.
3568
3569 -- The case of Extra_Accessibility should also be handled ???
3570
3571 if Nkind (Parameter_Type (Current_Parameter)) /=
3572 N_Access_Definition
3573 and then
3574 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
3575 and then
3576 Present (Extra_Constrained
3577 (Defining_Identifier (Current_Parameter)))
3578 then
3579 declare
3580 Extra_Parameter : constant Entity_Id :=
3581 Extra_Constrained
3582 (Defining_Identifier
3583 (Current_Parameter));
3584
3585 Formal_Entity : constant Entity_Id :=
3586 Make_Defining_Identifier
3587 (Loc, Chars (Extra_Parameter));
3588
3589 Formal_Type : constant Entity_Id :=
3590 Etype (Extra_Parameter);
3591
3592 begin
3593 Append_To (Decls,
3594 Make_Object_Declaration (Loc,
3595 Defining_Identifier => Formal_Entity,
3596 Object_Definition =>
3597 New_Occurrence_Of (Formal_Type, Loc)));
3598
3599 Append_To (Extra_Formal_Statements,
3600 Make_Attribute_Reference (Loc,
3601 Prefix => New_Occurrence_Of (Formal_Type, Loc),
3602 Attribute_Name => Name_Read,
3603 Expressions => New_List (
3604 New_Occurrence_Of (Stream_Parameter, Loc),
3605 New_Occurrence_Of (Formal_Entity, Loc))));
3606 Set_Extra_Constrained (Object, Formal_Entity);
3607 end;
3608 end if;
3609 end;
3610
3611 Next (Current_Parameter);
3612 end loop;
3613
3614 -- Append the formal statements list at the end of regular statements
3615
3616 Append_List_To (Statements, Extra_Formal_Statements);
3617
3618 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
3619
3620 -- The remote subprogram is a function. We build an inner block to
3621 -- be able to hold a potentially unconstrained result in a variable.
3622
3623 declare
3624 Etyp : constant Entity_Id :=
3625 Etype (Subtype_Mark (Specification (Vis_Decl)));
3626 Result : constant Node_Id :=
3627 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3628
3629 begin
3630 Inner_Decls := New_List (
3631 Make_Object_Declaration (Loc,
3632 Defining_Identifier => Result,
3633 Constant_Present => True,
3634 Object_Definition => New_Occurrence_Of (Etyp, Loc),
3635 Expression =>
3636 Make_Function_Call (Loc,
3637 Name => Called_Subprogram,
3638 Parameter_Associations => Parameter_List)));
3639
3640 Append_To (After_Statements,
3641 Make_Attribute_Reference (Loc,
3642 Prefix => New_Occurrence_Of (Etyp, Loc),
3643 Attribute_Name => Name_Output,
3644 Expressions => New_List (
3645 New_Occurrence_Of (Result_Parameter, Loc),
3646 New_Occurrence_Of (Result, Loc))));
3647 end;
3648
3649 Append_To (Statements,
3650 Make_Block_Statement (Loc,
3651 Declarations => Inner_Decls,
3652 Handled_Statement_Sequence =>
3653 Make_Handled_Sequence_Of_Statements (Loc,
3654 Statements => After_Statements)));
3655
3656 else
3657 -- The remote subprogram is a procedure. We do not need any inner
3658 -- block in this case.
3659
3660 if Dynamically_Asynchronous then
3661 Append_To (Decls,
3662 Make_Object_Declaration (Loc,
3663 Defining_Identifier => Dynamic_Async,
3664 Object_Definition =>
3665 New_Occurrence_Of (Standard_Boolean, Loc)));
3666
3667 Append_To (Statements,
3668 Make_Attribute_Reference (Loc,
3669 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
3670 Attribute_Name => Name_Read,
3671 Expressions => New_List (
3672 New_Occurrence_Of (Stream_Parameter, Loc),
3673 New_Occurrence_Of (Dynamic_Async, Loc))));
3674 end if;
3675
3676 Append_To (Statements,
3677 Make_Procedure_Call_Statement (Loc,
3678 Name => Called_Subprogram,
3679 Parameter_Associations => Parameter_List));
3680
3681 Append_List_To (Statements, After_Statements);
3682 end if;
3683
3684 if Asynchronous and then not Dynamically_Asynchronous then
3685
3686 -- An asynchronous procedure does not want a Result
3687 -- parameter. Also, we put an exception handler with an others
3688 -- clause that does nothing.
3689
3690 Subp_Spec :=
3691 Make_Procedure_Specification (Loc,
3692 Defining_Unit_Name =>
3693 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
3694 Parameter_Specifications => New_List (
3695 Make_Parameter_Specification (Loc,
3696 Defining_Identifier => Stream_Parameter,
3697 Parameter_Type =>
3698 Make_Access_Definition (Loc,
3699 Subtype_Mark =>
3700 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc)))));
3701
3702 Excep_Handler :=
3703 Make_Exception_Handler (Loc,
3704 Exception_Choices =>
3705 New_List (Make_Others_Choice (Loc)),
3706 Statements => New_List (
3707 Make_Null_Statement (Loc)));
3708
3709 else
3710 -- In the other cases, if an exception is raised, then the
3711 -- exception occurrence is copied into the output stream and
3712 -- no other output parameter is written.
3713
3714 Excep_Choice :=
3715 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3716
3717 Excep_Code := New_List (
3718 Make_Attribute_Reference (Loc,
3719 Prefix =>
3720 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
3721 Attribute_Name => Name_Write,
3722 Expressions => New_List (
3723 New_Occurrence_Of (Result_Parameter, Loc),
3724 New_Occurrence_Of (Excep_Choice, Loc))));
3725
3726 if Dynamically_Asynchronous then
3727 Excep_Code := New_List (
3728 Make_Implicit_If_Statement (Vis_Decl,
3729 Condition => Make_Op_Not (Loc,
3730 New_Occurrence_Of (Dynamic_Async, Loc)),
3731 Then_Statements => Excep_Code));
3732 end if;
3733
3734 Excep_Handler :=
3735 Make_Exception_Handler (Loc,
3736 Choice_Parameter => Excep_Choice,
3737 Exception_Choices => New_List (Make_Others_Choice (Loc)),
3738 Statements => Excep_Code);
3739
3740 Subp_Spec :=
3741 Make_Procedure_Specification (Loc,
3742 Defining_Unit_Name =>
3743 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
3744
3745 Parameter_Specifications => New_List (
3746 Make_Parameter_Specification (Loc,
3747 Defining_Identifier => Stream_Parameter,
3748 Parameter_Type =>
3749 Make_Access_Definition (Loc,
3750 Subtype_Mark =>
3751 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
3752
3753 Make_Parameter_Specification (Loc,
3754 Defining_Identifier => Result_Parameter,
3755 Parameter_Type =>
3756 Make_Access_Definition (Loc,
3757 Subtype_Mark =>
3758 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc)))));
3759 end if;
3760
3761 return
3762 Make_Subprogram_Body (Loc,
3763 Specification => Subp_Spec,
3764 Declarations => Decls,
3765 Handled_Statement_Sequence =>
3766 Make_Handled_Sequence_Of_Statements (Loc,
3767 Statements => Statements,
3768 Exception_Handlers => New_List (Excep_Handler)));
3769 end Build_Subprogram_Receiving_Stubs;
3770
3771 ------------------------
3772 -- Copy_Specification --
3773 ------------------------
3774
3775 function Copy_Specification
3776 (Loc : Source_Ptr;
3777 Spec : Node_Id;
3778 Object_Type : Entity_Id := Empty;
3779 Stub_Type : Entity_Id := Empty;
3780 New_Name : Name_Id := No_Name) return Node_Id
3781 is
3782 Parameters : List_Id := No_List;
3783
3784 Current_Parameter : Node_Id;
3785 Current_Identifier : Entity_Id;
3786 Current_Type : Node_Id;
3787 Current_Etype : Entity_Id;
3788
3789 Name_For_New_Spec : Name_Id;
3790
3791 New_Identifier : Entity_Id;
3792
3793 begin
3794 if New_Name = No_Name then
3795 pragma Assert (Nkind (Spec) = N_Function_Specification
3796 or else Nkind (Spec) = N_Procedure_Specification);
3797
3798 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
3799 else
3800 Name_For_New_Spec := New_Name;
3801 end if;
3802
3803 if Present (Parameter_Specifications (Spec)) then
3804 Parameters := New_List;
3805 Current_Parameter := First (Parameter_Specifications (Spec));
3806 while Current_Parameter /= Empty loop
3807 Current_Identifier := Defining_Identifier (Current_Parameter);
3808 Current_Type := Parameter_Type (Current_Parameter);
3809
3810 if Nkind (Current_Type) = N_Access_Definition then
3811 Current_Etype := Entity (Subtype_Mark (Current_Type));
3812
3813 if Present (Object_Type) then
3814 pragma Assert (
3815 Root_Type (Current_Etype) = Root_Type (Object_Type));
3816 Current_Type :=
3817 Make_Access_Definition (Loc,
3818 Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
3819 else
3820 Current_Type :=
3821 Make_Access_Definition (Loc,
3822 Subtype_Mark =>
3823 New_Occurrence_Of (Current_Etype, Loc));
3824 end if;
3825
3826 else
3827 Current_Etype := Entity (Current_Type);
3828
3829 if Object_Type /= Empty
3830 and then Current_Etype = Object_Type
3831 then
3832 Current_Type := New_Occurrence_Of (Stub_Type, Loc);
3833 else
3834 Current_Type := New_Occurrence_Of (Current_Etype, Loc);
3835 end if;
3836 end if;
3837
3838 New_Identifier := Make_Defining_Identifier (Loc,
3839 Chars (Current_Identifier));
3840
3841 Append_To (Parameters,
3842 Make_Parameter_Specification (Loc,
3843 Defining_Identifier => New_Identifier,
3844 Parameter_Type => Current_Type,
3845 In_Present => In_Present (Current_Parameter),
3846 Out_Present => Out_Present (Current_Parameter),
3847 Expression =>
3848 New_Copy_Tree (Expression (Current_Parameter))));
3849
3850 Next (Current_Parameter);
3851 end loop;
3852 end if;
3853
3854 case Nkind (Spec) is
3855
3856 when N_Function_Specification | N_Access_Function_Definition =>
3857 return
3858 Make_Function_Specification (Loc,
3859 Defining_Unit_Name =>
3860 Make_Defining_Identifier (Loc,
3861 Chars => Name_For_New_Spec),
3862 Parameter_Specifications => Parameters,
3863 Subtype_Mark =>
3864 New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
3865
3866 when N_Procedure_Specification | N_Access_Procedure_Definition =>
3867 return
3868 Make_Procedure_Specification (Loc,
3869 Defining_Unit_Name =>
3870 Make_Defining_Identifier (Loc,
3871 Chars => Name_For_New_Spec),
3872 Parameter_Specifications => Parameters);
3873
3874 when others =>
3875 raise Program_Error;
3876 end case;
3877 end Copy_Specification;
3878
3879 ---------------------------
3880 -- Could_Be_Asynchronous --
3881 ---------------------------
3882
3883 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
3884 Current_Parameter : Node_Id;
3885
3886 begin
3887 if Present (Parameter_Specifications (Spec)) then
3888 Current_Parameter := First (Parameter_Specifications (Spec));
3889 while Current_Parameter /= Empty loop
3890 if Out_Present (Current_Parameter) then
3891 return False;
3892 end if;
3893
3894 Next (Current_Parameter);
3895 end loop;
3896 end if;
3897
3898 return True;
3899 end Could_Be_Asynchronous;
3900
3901 ---------------------------------------------
3902 -- Expand_All_Calls_Remote_Subprogram_Call --
3903 ---------------------------------------------
3904
3905 procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
3906 Called_Subprogram : constant Entity_Id := Entity (Name (N));
3907 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
3908 Loc : constant Source_Ptr := Sloc (N);
3909 RCI_Locator : Node_Id;
3910 RCI_Cache : Entity_Id;
3911 Calling_Stubs : Node_Id;
3912 E_Calling_Stubs : Entity_Id;
3913
3914 begin
3915 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
3916
3917 if E_Calling_Stubs = Empty then
3918 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
3919
3920 if RCI_Cache = Empty then
3921 RCI_Locator :=
3922 RCI_Package_Locator
3923 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
3924 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
3925
3926 -- The RCI_Locator package is inserted at the top level in the
3927 -- current unit, and must appear in the proper scope, so that it
3928 -- is not prematurely removed by the GCC back-end.
3929
3930 declare
3931 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
3932
3933 begin
3934 if Ekind (Scop) = E_Package_Body then
3935 New_Scope (Spec_Entity (Scop));
3936
3937 elsif Ekind (Scop) = E_Subprogram_Body then
3938 New_Scope
3939 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
3940
3941 else
3942 New_Scope (Scop);
3943 end if;
3944
3945 Analyze (RCI_Locator);
3946 Pop_Scope;
3947 end;
3948
3949 RCI_Cache := Defining_Unit_Name (RCI_Locator);
3950
3951 else
3952 RCI_Locator := Parent (RCI_Cache);
3953 end if;
3954
3955 Calling_Stubs := Build_Subprogram_Calling_Stubs
3956 (Vis_Decl => Parent (Parent (Called_Subprogram)),
3957 Subp_Id => Get_Subprogram_Id (Called_Subprogram),
3958 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
3959 and then
3960 Is_Asynchronous (Called_Subprogram),
3961 Locator => RCI_Cache,
3962 New_Name => New_Internal_Name ('S'));
3963 Insert_After (RCI_Locator, Calling_Stubs);
3964 Analyze (Calling_Stubs);
3965 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
3966 end if;
3967
3968 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
3969 end Expand_All_Calls_Remote_Subprogram_Call;
3970
3971 ---------------------------------
3972 -- Expand_Calling_Stubs_Bodies --
3973 ---------------------------------
3974
3975 procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
3976 Spec : constant Node_Id := Specification (Unit_Node);
3977 Decls : constant List_Id := Visible_Declarations (Spec);
3978
3979 begin
3980 New_Scope (Scope_Of_Spec (Spec));
3981 Add_Calling_Stubs_To_Declarations (Specification (Unit_Node),
3982 Decls);
3983 Pop_Scope;
3984 end Expand_Calling_Stubs_Bodies;
3985
3986 -----------------------------------
3987 -- Expand_Receiving_Stubs_Bodies --
3988 -----------------------------------
3989
3990 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
3991 Spec : Node_Id;
3992 Decls : List_Id;
3993 Temp : List_Id;
3994
3995 begin
3996 if Nkind (Unit_Node) = N_Package_Declaration then
3997 Spec := Specification (Unit_Node);
3998 Decls := Visible_Declarations (Spec);
3999 New_Scope (Scope_Of_Spec (Spec));
4000 Add_Receiving_Stubs_To_Declarations (Spec, Decls);
4001
4002 else
4003 Spec :=
4004 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
4005 Decls := Declarations (Unit_Node);
4006 New_Scope (Scope_Of_Spec (Unit_Node));
4007 Temp := New_List;
4008 Add_Receiving_Stubs_To_Declarations (Spec, Temp);
4009 Insert_List_Before (First (Decls), Temp);
4010 end if;
4011
4012 Pop_Scope;
4013 end Expand_Receiving_Stubs_Bodies;
4014
4015 ----------------------------
4016 -- Get_Pkg_Name_string_Id --
4017 ----------------------------
4018
4019 function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id is
4020 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
4021
4022 begin
4023 Get_Unit_Name_String (Unit_Name_Id);
4024
4025 -- Remove seven last character (" (spec)" or " (body)").
4026
4027 Name_Len := Name_Len - 7;
4028 pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
4029
4030 return Get_String_Id (Name_Buffer (1 .. Name_Len));
4031 end Get_Pkg_Name_String_Id;
4032
4033 -------------------
4034 -- Get_String_Id --
4035 -------------------
4036
4037 function Get_String_Id (Val : String) return String_Id is
4038 begin
4039 Start_String;
4040 Store_String_Chars (Val);
4041 return End_String;
4042 end Get_String_Id;
4043
4044 -----------------------
4045 -- Get_Subprogram_Id --
4046 -----------------------
4047
4048 function Get_Subprogram_Id (E : Entity_Id) return Int is
4049 Current_Declaration : Node_Id;
4050 Result : Int := First_RCI_Subprogram_Id;
4051
4052 begin
4053 pragma Assert
4054 (Is_Remote_Call_Interface (Scope (E))
4055 and then
4056 (Nkind (Parent (E)) = N_Procedure_Specification
4057 or else
4058 Nkind (Parent (E)) = N_Function_Specification));
4059
4060 Current_Declaration :=
4061 First (Visible_Declarations
4062 (Package_Specification_Of_Scope (Scope (E))));
4063
4064 while Current_Declaration /= Empty loop
4065 if Nkind (Current_Declaration) = N_Subprogram_Declaration
4066 and then Comes_From_Source (Current_Declaration)
4067 then
4068 if Defining_Unit_Name
4069 (Specification (Current_Declaration)) = E
4070 then
4071 return Result;
4072 end if;
4073
4074 Result := Result + 1;
4075 end if;
4076
4077 Next (Current_Declaration);
4078 end loop;
4079
4080 -- Error if we do not find it
4081
4082 raise Program_Error;
4083 end Get_Subprogram_Id;
4084
4085 ----------
4086 -- Hash --
4087 ----------
4088
4089 function Hash (F : Entity_Id) return Hash_Index is
4090 begin
4091 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
4092 end Hash;
4093
4094 --------------------------
4095 -- Input_With_Tag_Check --
4096 --------------------------
4097
4098 function Input_With_Tag_Check
4099 (Loc : Source_Ptr;
4100 Var_Type : Entity_Id;
4101 Stream : Entity_Id)
4102 return Node_Id
4103 is
4104 begin
4105 return
4106 Make_Subprogram_Body (Loc,
4107 Specification => Make_Function_Specification (Loc,
4108 Defining_Unit_Name =>
4109 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
4110 Subtype_Mark => New_Occurrence_Of (Var_Type, Loc)),
4111 Declarations => No_List,
4112 Handled_Statement_Sequence =>
4113 Make_Handled_Sequence_Of_Statements (Loc, New_List (
4114 Make_Tag_Check (Loc,
4115 Make_Return_Statement (Loc,
4116 Make_Attribute_Reference (Loc,
4117 Prefix => New_Occurrence_Of (Var_Type, Loc),
4118 Attribute_Name => Name_Input,
4119 Expressions =>
4120 New_List (New_Occurrence_Of (Stream, Loc))))))));
4121 end Input_With_Tag_Check;
4122
4123 --------------------------------
4124 -- Is_RACW_Controlling_Formal --
4125 --------------------------------
4126
4127 function Is_RACW_Controlling_Formal
4128 (Parameter : Node_Id;
4129 Stub_Type : Entity_Id)
4130 return Boolean
4131 is
4132 Typ : Entity_Id;
4133
4134 begin
4135 -- If the kind of the parameter is E_Void, then it is not a
4136 -- controlling formal (this can happen in the context of RAS).
4137
4138 if Ekind (Defining_Identifier (Parameter)) = E_Void then
4139 return False;
4140 end if;
4141
4142 -- If the parameter is not a controlling formal, then it cannot
4143 -- be possibly a RACW_Controlling_Formal.
4144
4145 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
4146 return False;
4147 end if;
4148
4149 Typ := Parameter_Type (Parameter);
4150 return (Nkind (Typ) = N_Access_Definition
4151 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
4152 or else Etype (Typ) = Stub_Type;
4153 end Is_RACW_Controlling_Formal;
4154
4155 --------------------
4156 -- Make_Tag_Check --
4157 --------------------
4158
4159 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
4160 Occ : constant Entity_Id :=
4161 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4162
4163 begin
4164 return Make_Block_Statement (Loc,
4165 Handled_Statement_Sequence =>
4166 Make_Handled_Sequence_Of_Statements (Loc,
4167 Statements => New_List (N),
4168
4169 Exception_Handlers => New_List (
4170 Make_Exception_Handler (Loc,
4171 Choice_Parameter => Occ,
4172
4173 Exception_Choices =>
4174 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
4175
4176 Statements =>
4177 New_List (Make_Procedure_Call_Statement (Loc,
4178 New_Occurrence_Of
4179 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
4180 New_List (New_Occurrence_Of (Occ, Loc))))))));
4181 end Make_Tag_Check;
4182
4183 ----------------------------
4184 -- Need_Extra_Constrained --
4185 ----------------------------
4186
4187 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
4188 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
4189
4190 begin
4191 return Out_Present (Parameter)
4192 and then Has_Discriminants (Etyp)
4193 and then not Is_Constrained (Etyp)
4194 and then not Is_Indefinite_Subtype (Etyp);
4195 end Need_Extra_Constrained;
4196
4197 ------------------------------------
4198 -- Pack_Entity_Into_Stream_Access --
4199 ------------------------------------
4200
4201 function Pack_Entity_Into_Stream_Access
4202 (Loc : Source_Ptr;
4203 Stream : Node_Id;
4204 Object : Entity_Id;
4205 Etyp : Entity_Id := Empty) return Node_Id
4206 is
4207 Typ : Entity_Id;
4208
4209 begin
4210 if Etyp /= Empty then
4211 Typ := Etyp;
4212 else
4213 Typ := Etype (Object);
4214 end if;
4215
4216 return
4217 Pack_Node_Into_Stream_Access (Loc,
4218 Stream => Stream,
4219 Object => New_Occurrence_Of (Object, Loc),
4220 Etyp => Typ);
4221 end Pack_Entity_Into_Stream_Access;
4222
4223 ---------------------------
4224 -- Pack_Node_Into_Stream --
4225 ---------------------------
4226
4227 function Pack_Node_Into_Stream
4228 (Loc : Source_Ptr;
4229 Stream : Entity_Id;
4230 Object : Node_Id;
4231 Etyp : Entity_Id) return Node_Id
4232 is
4233 Write_Attribute : Name_Id := Name_Write;
4234
4235 begin
4236 if not Is_Constrained (Etyp) then
4237 Write_Attribute := Name_Output;
4238 end if;
4239
4240 return
4241 Make_Attribute_Reference (Loc,
4242 Prefix => New_Occurrence_Of (Etyp, Loc),
4243 Attribute_Name => Write_Attribute,
4244 Expressions => New_List (
4245 Make_Attribute_Reference (Loc,
4246 Prefix => New_Occurrence_Of (Stream, Loc),
4247 Attribute_Name => Name_Access),
4248 Object));
4249 end Pack_Node_Into_Stream;
4250
4251 ----------------------------------
4252 -- Pack_Node_Into_Stream_Access --
4253 ----------------------------------
4254
4255 function Pack_Node_Into_Stream_Access
4256 (Loc : Source_Ptr;
4257 Stream : Node_Id;
4258 Object : Node_Id;
4259 Etyp : Entity_Id) return Node_Id
4260 is
4261 Write_Attribute : Name_Id := Name_Write;
4262
4263 begin
4264 if not Is_Constrained (Etyp) then
4265 Write_Attribute := Name_Output;
4266 end if;
4267
4268 return
4269 Make_Attribute_Reference (Loc,
4270 Prefix => New_Occurrence_Of (Etyp, Loc),
4271 Attribute_Name => Write_Attribute,
4272 Expressions => New_List (
4273 Stream,
4274 Object));
4275 end Pack_Node_Into_Stream_Access;
4276
4277 -------------------------------
4278 -- RACW_Type_Is_Asynchronous --
4279 -------------------------------
4280
4281 procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
4282 N : constant Node_Id := Asynchronous_Flags_Table.Get (RACW_Type);
4283 pragma Assert (N /= Empty);
4284 begin
4285 Replace (N, New_Occurrence_Of (Standard_True, Sloc (N)));
4286 end RACW_Type_Is_Asynchronous;
4287
4288 -------------------------
4289 -- RCI_Package_Locator --
4290 -------------------------
4291
4292 function RCI_Package_Locator
4293 (Loc : Source_Ptr;
4294 Package_Spec : Node_Id) return Node_Id
4295 is
4296 Inst : constant Node_Id :=
4297 Make_Package_Instantiation (Loc,
4298 Defining_Unit_Name =>
4299 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
4300 Name =>
4301 New_Occurrence_Of (RTE (RE_RCI_Info), Loc),
4302 Generic_Associations => New_List (
4303 Make_Generic_Association (Loc,
4304 Selector_Name =>
4305 Make_Identifier (Loc, Name_RCI_Name),
4306 Explicit_Generic_Actual_Parameter =>
4307 Make_String_Literal (Loc,
4308 Strval => Get_Pkg_Name_String_Id (Package_Spec)))));
4309
4310 begin
4311 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
4312 Defining_Unit_Name (Inst));
4313 return Inst;
4314 end RCI_Package_Locator;
4315
4316 -----------------------------------------------
4317 -- Remote_Types_Tagged_Full_View_Encountered --
4318 -----------------------------------------------
4319
4320 procedure Remote_Types_Tagged_Full_View_Encountered
4321 (Full_View : Entity_Id)
4322 is
4323 Stub_Elements : constant Stub_Structure :=
4324 Stubs_Table.Get (Full_View);
4325
4326 begin
4327 if Stub_Elements /= Empty_Stub_Structure then
4328 Add_RACW_Primitive_Declarations_And_Bodies
4329 (Full_View,
4330 Parent (Declaration_Node (Stub_Elements.Object_RPC_Receiver)),
4331 List_Containing (Declaration_Node (Full_View)));
4332 end if;
4333 end Remote_Types_Tagged_Full_View_Encountered;
4334
4335 -------------------
4336 -- Scope_Of_Spec --
4337 -------------------
4338
4339 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
4340 Unit_Name : Node_Id := Defining_Unit_Name (Spec);
4341
4342 begin
4343 while Nkind (Unit_Name) /= N_Defining_Identifier loop
4344 Unit_Name := Defining_Identifier (Unit_Name);
4345 end loop;
4346
4347 return Unit_Name;
4348 end Scope_Of_Spec;
4349
4350 --------------------------
4351 -- Underlying_RACW_Type --
4352 --------------------------
4353
4354 function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
4355 Record_Type : Entity_Id;
4356
4357 begin
4358 if Ekind (RAS_Typ) = E_Record_Type then
4359 Record_Type := RAS_Typ;
4360 else
4361 pragma Assert (Present (Equivalent_Type (RAS_Typ)));
4362 Record_Type := Equivalent_Type (RAS_Typ);
4363 end if;
4364
4365 return
4366 Etype (Subtype_Indication (
4367 Component_Definition (
4368 First (Component_Items (Component_List (
4369 Type_Definition (Declaration_Node (Record_Type))))))));
4370 end Underlying_RACW_Type;
4371
4372 end Exp_Dist;
Mirror of the offical gcc git repository hosted at gcc.gnu.org