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