?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
(extendsfdf2): Add pattern accidentally deleted when cirrus instructions were
[official-gcc.git] / gcc / ada / exp_dist.adb
blob66c413fe04314a31d1096f9b0ac9acca2fe7a61f
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P_ D I S T --
6 -- --
7 -- B o d y --
8 -- --
9 -- --
10 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
11 -- --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
22 -- --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 -- --
26 ------------------------------------------------------------------------------
27
28 with Atree; use Atree;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Exp_Tss; use Exp_Tss;
32 with Exp_Util; use Exp_Util;
33 with GNAT.HTable; use GNAT.HTable;
34 with Lib; use Lib;
35 with Namet; use Namet;
36 with Nlists; use Nlists;
37 with Nmake; use Nmake;
38 with Opt; use Opt;
39 with Rtsfind; use Rtsfind;
40 with Sem; use Sem;
41 with Sem_Ch3; use Sem_Ch3;
42 with Sem_Ch8; use Sem_Ch8;
43 with Sem_Dist; use Sem_Dist;
44 with Sem_Util; use Sem_Util;
45 with Sinfo; use Sinfo;
46 with Snames; use Snames;
47 with Stand; use Stand;
48 with Stringt; use Stringt;
49 with Tbuild; use Tbuild;
50 with Uintp; use Uintp;
51 with Uname; use Uname;
52
53 package body Exp_Dist is
54
55 -- The following model has been used to implement distributed objects:
56 -- given a designated type D and a RACW type R, then a record of the
57 -- form:
58 -- type Stub is tagged record
59 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
60 -- end record;
61 -- is built. This type has two properties:
62 --
63 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
64 -- converted to and from this type to make it suitable for
65 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
66 -- to avoid memory leaks when the same remote object arrive on the
67 -- same partition by following different pathes
68 --
69 -- 2) It also has the same dispatching table as the designated type D,
70 -- and thus can be used as an object designated by a value of type
71 -- R on any partition other than the one on which the object has
72 -- been created, since only dispatching calls will be performed and
73 -- the fields themselves will not be used. We call Derive_Subprograms
74 -- to fake half a derivation to ensure that the subprograms do have
75 -- the same dispatching table.
76
77 -----------------------
78 -- Local subprograms --
79 -----------------------
80
81 procedure Build_General_Calling_Stubs
82 (Decls : in List_Id;
83 Statements : in List_Id;
84 Target_Partition : in Entity_Id;
85 RPC_Receiver : in Node_Id;
86 Subprogram_Id : in Node_Id;
87 Asynchronous : in Node_Id := Empty;
88 Is_Known_Asynchronous : in Boolean := False;
89 Is_Known_Non_Asynchronous : in Boolean := False;
90 Is_Function : in Boolean;
91 Spec : in Node_Id;
92 Object_Type : in Entity_Id := Empty;
93 Nod : in Node_Id);
94 -- Build calling stubs for general purpose. The parameters are:
95 -- Decls : a place to put declarations
96 -- Statements : a place to put statements
97 -- Target_Partition : a node containing the target partition that must
98 -- be a N_Defining_Identifier
99 -- RPC_Receiver : a node containing the RPC receiver
100 -- Subprogram_Id : a node containing the subprogram ID
101 -- Asynchronous : True if an APC must be made instead of an RPC.
102 -- The value needs not be supplied if one of the
103 -- Is_Known_... is True.
104 -- Is_Known_Async... : True if we know that this is asynchronous
105 -- Is_Known_Non_A... : True if we know that this is not asynchronous
106 -- Spec : a node with a Parameter_Specifications and
107 -- a Subtype_Mark if applicable
108 -- Object_Type : in case of a RACW, parameters of type access to
109 -- Object_Type will be marshalled using the
110 -- address of this object (the addr field) rather
111 -- than using the 'Write on the object itself
112 -- Nod : used to provide sloc for generated code
113
114 function Build_Subprogram_Calling_Stubs
115 (Vis_Decl : Node_Id;
116 Subp_Id : Int;
117 Asynchronous : Boolean;
118 Dynamically_Asynchronous : Boolean := False;
119 Stub_Type : Entity_Id := Empty;
120 Locator : Entity_Id := Empty;
121 New_Name : Name_Id := No_Name)
122 return Node_Id;
123 -- Build the calling stub for a given subprogram with the subprogram ID
124 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
125 -- parameters of this type will be marshalled instead of the object
126 -- itself. It will then be converted into Stub_Type before performing
127 -- the real call. If Dynamically_Asynchronous is True, then it will be
128 -- computed at run time whether the call is asynchronous or not.
129 -- Otherwise, the value of the formal Asynchronous will be used.
130 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
131 -- New_Name is given, then it will be used instead of the original name.
132
133 function Build_Subprogram_Receiving_Stubs
134 (Vis_Decl : Node_Id;
135 Asynchronous : Boolean;
136 Dynamically_Asynchronous : Boolean := False;
137 Stub_Type : Entity_Id := Empty;
138 RACW_Type : Entity_Id := Empty;
139 Parent_Primitive : Entity_Id := Empty)
140 return Node_Id;
141 -- Build the receiving stub for a given subprogram. The subprogram
142 -- declaration is also built by this procedure, and the value returned
143 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
144 -- found in the specification, then its address is read from the stream
145 -- instead of the object itself and converted into an access to
146 -- class-wide type before doing the real call using any of the RACW type
147 -- pointing on the designated type.
148
149 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
150 -- Return an ordered parameter list: unconstrained parameters are put
151 -- at the beginning of the list and constrained ones are put after. If
152 -- there are no parameters, an empty list is returned.
153
154 procedure Add_Calling_Stubs_To_Declarations
155 (Pkg_Spec : in Node_Id;
156 Decls : in List_Id);
157 -- Add calling stubs to the declarative part
158
159 procedure Add_Receiving_Stubs_To_Declarations
160 (Pkg_Spec : in Node_Id;
161 Decls : in List_Id);
162 -- Add receiving stubs to the declarative part
163
164 procedure Add_RAS_Dereference_Attribute (N : in Node_Id);
165 -- Add a subprogram body for RAS dereference
166
167 procedure Add_RAS_Access_Attribute (N : in Node_Id);
168 -- Add a subprogram body for RAS Access attribute
169
170 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
171 -- Return True if nothing prevents the program whose specification is
172 -- given to be asynchronous (i.e. no out parameter).
173
174 function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id;
175 function Get_String_Id (Val : String) return String_Id;
176 -- Ugly functions used to retrieve a package name. Inherited from the
177 -- old exp_dist.adb and not rewritten yet ???
178
179 function Pack_Entity_Into_Stream_Access
180 (Loc : Source_Ptr;
181 Stream : Entity_Id;
182 Object : Entity_Id;
183 Etyp : Entity_Id := Empty)
184 return Node_Id;
185 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
186 -- then Etype (Object) will be used if present. If the type is
187 -- constrained, then 'Write will be used to output the object,
188 -- If the type is unconstrained, 'Output will be used.
189
190 function Pack_Node_Into_Stream
191 (Loc : Source_Ptr;
192 Stream : Entity_Id;
193 Object : Node_Id;
194 Etyp : Entity_Id)
195 return Node_Id;
196 -- Similar to above, with an arbitrary node instead of an entity
197
198 function Pack_Node_Into_Stream_Access
199 (Loc : Source_Ptr;
200 Stream : Entity_Id;
201 Object : Node_Id;
202 Etyp : Entity_Id)
203 return Node_Id;
204 -- Similar to above, with Stream instead of Stream'Access
205
206 function Copy_Specification
207 (Loc : Source_Ptr;
208 Spec : Node_Id;
209 Object_Type : Entity_Id := Empty;
210 Stub_Type : Entity_Id := Empty;
211 New_Name : Name_Id := No_Name)
212 return Node_Id;
213 -- Build a specification from another one. If Object_Type is not Empty
214 -- and any access to Object_Type is found, then it is replaced by an
215 -- access to Stub_Type. If New_Name is given, then it will be used as
216 -- the name for the newly created spec.
217
218 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
219 -- Return the scope represented by a given spec
220
221 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
222 -- Return True if the current parameter needs an extra formal to reflect
223 -- its constrained status.
224
225 function Is_RACW_Controlling_Formal
226 (Parameter : Node_Id; Stub_Type : Entity_Id)
227 return Boolean;
228 -- Return True if the current parameter is a controlling formal argument
229 -- of type Stub_Type or access to Stub_Type.
230
231 type Stub_Structure is record
232 Stub_Type : Entity_Id;
233 Stub_Type_Access : Entity_Id;
234 Object_RPC_Receiver : Entity_Id;
235 RPC_Receiver_Stream : Entity_Id;
236 RPC_Receiver_Result : Entity_Id;
237 RACW_Type : Entity_Id;
238 end record;
239 -- This structure is necessary because of the two phases analysis of
240 -- a RACW declaration occurring in the same Remote_Types package as the
241 -- designated type. RACW_Type is any of the RACW types pointing on this
242 -- designated type, it is used here to save an anonymous type creation
243 -- for each primitive operation.
244
245 Empty_Stub_Structure : constant Stub_Structure :=
246 (Empty, Empty, Empty, Empty, Empty, Empty);
247
248 type Hash_Index is range 0 .. 50;
249 function Hash (F : Entity_Id) return Hash_Index;
250
251 package Stubs_Table is
252 new Simple_HTable (Header_Num => Hash_Index,
253 Element => Stub_Structure,
254 No_Element => Empty_Stub_Structure,
255 Key => Entity_Id,
256 Hash => Hash,
257 Equal => "=");
258 -- Mapping between a RACW designated type and its stub type
259
260 package Asynchronous_Flags_Table is
261 new Simple_HTable (Header_Num => Hash_Index,
262 Element => Node_Id,
263 No_Element => Empty,
264 Key => Entity_Id,
265 Hash => Hash,
266 Equal => "=");
267 -- Mapping between a RACW type and the node holding the value True if
268 -- the RACW is asynchronous and False otherwise.
269
270 package RCI_Locator_Table is
271 new Simple_HTable (Header_Num => Hash_Index,
272 Element => Entity_Id,
273 No_Element => Empty,
274 Key => Entity_Id,
275 Hash => Hash,
276 Equal => "=");
277 -- Mapping between a RCI package on which All_Calls_Remote applies and
278 -- the generic instantiation of RCI_Info for this package.
279
280 package RCI_Calling_Stubs_Table is
281 new Simple_HTable (Header_Num => Hash_Index,
282 Element => Entity_Id,
283 No_Element => Empty,
284 Key => Entity_Id,
285 Hash => Hash,
286 Equal => "=");
287 -- Mapping between a RCI subprogram and the corresponding calling stubs
288
289 procedure Add_Stub_Type
290 (Designated_Type : in Entity_Id;
291 RACW_Type : in Entity_Id;
292 Decls : in List_Id;
293 Stub_Type : out Entity_Id;
294 Stub_Type_Access : out Entity_Id;
295 Object_RPC_Receiver : out Entity_Id;
296 Existing : out Boolean);
297 -- Add the declaration of the stub type, the access to stub type and the
298 -- object RPC receiver at the end of Decls. If these already exist,
299 -- then nothing is added in the tree but the right values are returned
300 -- anyhow and Existing is set to True.
301
302 procedure Add_RACW_Read_Attribute
303 (RACW_Type : in Entity_Id;
304 Stub_Type : in Entity_Id;
305 Stub_Type_Access : in Entity_Id;
306 Declarations : in List_Id);
307 -- Add Read attribute in Decls for the RACW type. The Read attribute
308 -- is added right after the RACW_Type declaration while the body is
309 -- inserted after Declarations.
310
311 procedure Add_RACW_Write_Attribute
312 (RACW_Type : in Entity_Id;
313 Stub_Type : in Entity_Id;
314 Stub_Type_Access : in Entity_Id;
315 Object_RPC_Receiver : in Entity_Id;
316 Declarations : in List_Id);
317 -- Same thing for the Write attribute
318
319 procedure Add_RACW_Read_Write_Attributes
320 (RACW_Type : in Entity_Id;
321 Stub_Type : in Entity_Id;
322 Stub_Type_Access : in Entity_Id;
323 Object_RPC_Receiver : in Entity_Id;
324 Declarations : in List_Id);
325 -- Add Read and Write attributes declarations and bodies for a given
326 -- RACW type. The declarations are added just after the declaration
327 -- of the RACW type itself, while the bodies are inserted at the end
328 -- of Decls.
329
330 function RCI_Package_Locator
331 (Loc : Source_Ptr;
332 Package_Spec : Node_Id)
333 return Node_Id;
334 -- Instantiate the generic package RCI_Info in order to locate the
335 -- RCI package whose spec is given as argument.
336
337 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
338 -- Surround a node N by a tag check, as in:
339 -- begin
340 -- <N>;
341 -- exception
342 -- when E : Ada.Tags.Tag_Error =>
343 -- Raise_Exception (Program_Error'Identity,
344 -- Exception_Message (E));
345 -- end;
346
347 function Input_With_Tag_Check
348 (Loc : Source_Ptr;
349 Var_Type : Entity_Id;
350 Stream : Entity_Id)
351 return Node_Id;
352 -- Return a function with the following form:
353 -- function R return Var_Type is
354 -- begin
355 -- return Var_Type'Input (S);
356 -- exception
357 -- when E : Ada.Tags.Tag_Error =>
358 -- Raise_Exception (Program_Error'Identity,
359 -- Exception_Message (E));
360 -- end R;
361
362 ------------------------------------
363 -- Local variables and structures --
364 ------------------------------------
365
366 RCI_Cache : Node_Id;
367
368 Output_From_Constrained : constant array (Boolean) of Name_Id :=
369 (False => Name_Output,
370 True => Name_Write);
371 -- The attribute to choose depending on the fact that the parameter
372 -- is constrained or not. There is no such thing as Input_From_Constrained
373 -- since this require separate mechanisms ('Input is a function while
374 -- 'Read is a procedure).
375
376 ---------------------------------------
377 -- Add_Calling_Stubs_To_Declarations --
378 ---------------------------------------
379
380 procedure Add_Calling_Stubs_To_Declarations
381 (Pkg_Spec : in Node_Id;
382 Decls : in List_Id)
383 is
384 Current_Subprogram_Number : Int := 0;
385 Current_Declaration : Node_Id;
386
387 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
388
389 RCI_Instantiation : Node_Id;
390
391 Subp_Stubs : Node_Id;
392
393 begin
394 -- The first thing added is an instantiation of the generic package
395 -- System.Partition_interface.RCI_Info with the name of the (current)
396 -- remote package. This will act as an interface with the name server
397 -- to determine the Partition_ID and the RPC_Receiver for the
398 -- receiver of this package.
399
400 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
401 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
402
403 Append_To (Decls, RCI_Instantiation);
404 Analyze (RCI_Instantiation);
405
406 -- For each subprogram declaration visible in the spec, we do
407 -- build a body. We also increment a counter to assign a different
408 -- Subprogram_Id to each subprograms. The receiving stubs processing
409 -- do use the same mechanism and will thus assign the same Id and
410 -- do the correct dispatching.
411
412 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
413
414 while Current_Declaration /= Empty loop
415
416 if Nkind (Current_Declaration) = N_Subprogram_Declaration
417 and then Comes_From_Source (Current_Declaration)
418 then
419 pragma Assert (Current_Subprogram_Number =
420 Get_Subprogram_Id (Defining_Unit_Name (Specification (
421 Current_Declaration))));
422
423 Subp_Stubs :=
424 Build_Subprogram_Calling_Stubs (
425 Vis_Decl => Current_Declaration,
426 Subp_Id => Current_Subprogram_Number,
427 Asynchronous =>
428 Nkind (Specification (Current_Declaration)) =
429 N_Procedure_Specification
430 and then
431 Is_Asynchronous (Defining_Unit_Name (Specification
432 (Current_Declaration))));
433
434 Append_To (Decls, Subp_Stubs);
435 Analyze (Subp_Stubs);
436
437 Current_Subprogram_Number := Current_Subprogram_Number + 1;
438 end if;
439
440 Next (Current_Declaration);
441 end loop;
442
443 end Add_Calling_Stubs_To_Declarations;
444
445 -----------------------
446 -- Add_RACW_Features --
447 -----------------------
448
449 procedure Add_RACW_Features (RACW_Type : in Entity_Id)
450 is
451 Desig : constant Entity_Id :=
452 Etype (Designated_Type (RACW_Type));
453 Decls : List_Id :=
454 List_Containing (Declaration_Node (RACW_Type));
455
456 Same_Scope : constant Boolean :=
457 Scope (Desig) = Scope (RACW_Type);
458
459 Stub_Type : Entity_Id;
460 Stub_Type_Access : Entity_Id;
461 Object_RPC_Receiver : Entity_Id;
462 Existing : Boolean;
463
464 begin
465 if not Expander_Active then
466 return;
467 end if;
468
469 if Same_Scope then
470
471 -- We are declaring a RACW in the same package than its designated
472 -- type, so the list to use for late declarations must be the
473 -- private part of the package. We do know that this private part
474 -- exists since the designated type has to be a private one.
475
476 Decls := Private_Declarations
477 (Package_Specification_Of_Scope (Current_Scope));
478
479 elsif Nkind (Parent (Decls)) = N_Package_Specification
480 and then Present (Private_Declarations (Parent (Decls)))
481 then
482 Decls := Private_Declarations (Parent (Decls));
483 end if;
484
485 -- If we were unable to find the declarations, that means that the
486 -- completion of the type was missing. We can safely return and let
487 -- the error be caught by the semantic analysis.
488
489 if No (Decls) then
490 return;
491 end if;
492
493 Add_Stub_Type
494 (Designated_Type => Desig,
495 RACW_Type => RACW_Type,
496 Decls => Decls,
497 Stub_Type => Stub_Type,
498 Stub_Type_Access => Stub_Type_Access,
499 Object_RPC_Receiver => Object_RPC_Receiver,
500 Existing => Existing);
501
502 Add_RACW_Read_Write_Attributes
503 (RACW_Type => RACW_Type,
504 Stub_Type => Stub_Type,
505 Stub_Type_Access => Stub_Type_Access,
506 Object_RPC_Receiver => Object_RPC_Receiver,
507 Declarations => Decls);
508
509 if not Same_Scope and then not Existing then
510
511 -- The RACW has been declared in another scope than the designated
512 -- type and has not been handled by another RACW in the same
513 -- package as the first one, so add primitive for the stub type
514 -- here.
515
516 Add_RACW_Primitive_Declarations_And_Bodies
517 (Designated_Type => Desig,
518 Insertion_Node =>
519 Parent (Declaration_Node (Object_RPC_Receiver)),
520 Decls => Decls);
521
522 else
523 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
524 end if;
525 end Add_RACW_Features;
526
527 -------------------------------------------------
528 -- Add_RACW_Primitive_Declarations_And_Bodies --
529 -------------------------------------------------
530
531 procedure Add_RACW_Primitive_Declarations_And_Bodies
532 (Designated_Type : in Entity_Id;
533 Insertion_Node : in Node_Id;
534 Decls : in List_Id)
535 is
536 -- Set sloc of generated declaration to be that of the
537 -- insertion node, so the declarations are recognized as
538 -- belonging to the current package.
539
540 Loc : constant Source_Ptr := Sloc (Insertion_Node);
541
542 Stub_Elements : constant Stub_Structure :=
543 Stubs_Table.Get (Designated_Type);
544
545 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
546
547 Current_Insertion_Node : Node_Id := Insertion_Node;
548
549 RPC_Receiver_Declarations : List_Id;
550 RPC_Receiver_Statements : List_Id;
551 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
552 RPC_Receiver_Subp_Id : Entity_Id;
553
554 Current_Primitive_Elmt : Elmt_Id;
555 Current_Primitive : Entity_Id;
556 Current_Primitive_Body : Node_Id;
557 Current_Primitive_Spec : Node_Id;
558 Current_Primitive_Decl : Node_Id;
559 Current_Primitive_Number : Int := 0;
560
561 Current_Primitive_Alias : Node_Id;
562
563 Current_Receiver : Entity_Id;
564 Current_Receiver_Body : Node_Id;
565
566 RPC_Receiver_Decl : Node_Id;
567
568 Possibly_Asynchronous : Boolean;
569
570 begin
571
572 if not Expander_Active then
573 return;
574 end if;
575
576 -- Build callers, receivers for every primitive operations and a RPC
577 -- receiver for this type.
578
579 if Present (Primitive_Operations (Designated_Type)) then
580
581 Current_Primitive_Elmt :=
582 First_Elmt (Primitive_Operations (Designated_Type));
583
584 while Current_Primitive_Elmt /= No_Elmt loop
585
586 Current_Primitive := Node (Current_Primitive_Elmt);
587
588 -- Copy the primitive of all the parents, except predefined
589 -- ones that are not remotely dispatching.
590
591 if Chars (Current_Primitive) /= Name_uSize
592 and then Chars (Current_Primitive) /= Name_uDeep_Finalize
593 then
594 -- The first thing to do is build an up-to-date copy of
595 -- the spec with all the formals referencing Designated_Type
596 -- transformed into formals referencing Stub_Type. Since this
597 -- primitive may have been inherited, go back the alias chain
598 -- until the real primitive has been found.
599
600 Current_Primitive_Alias := Current_Primitive;
601 while Present (Alias (Current_Primitive_Alias)) loop
602 pragma Assert
603 (Current_Primitive_Alias
604 /= Alias (Current_Primitive_Alias));
605 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
606 end loop;
607
608 Current_Primitive_Spec :=
609 Copy_Specification (Loc,
610 Spec => Parent (Current_Primitive_Alias),
611 Object_Type => Designated_Type,
612 Stub_Type => Stub_Elements.Stub_Type);
613
614 Current_Primitive_Decl :=
615 Make_Subprogram_Declaration (Loc,
616 Specification => Current_Primitive_Spec);
617
618 Insert_After (Current_Insertion_Node, Current_Primitive_Decl);
619 Analyze (Current_Primitive_Decl);
620 Current_Insertion_Node := Current_Primitive_Decl;
621
622 Possibly_Asynchronous :=
623 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
624 and then Could_Be_Asynchronous (Current_Primitive_Spec);
625
626 Current_Primitive_Body :=
627 Build_Subprogram_Calling_Stubs
628 (Vis_Decl => Current_Primitive_Decl,
629 Subp_Id => Current_Primitive_Number,
630 Asynchronous => Possibly_Asynchronous,
631 Dynamically_Asynchronous => Possibly_Asynchronous,
632 Stub_Type => Stub_Elements.Stub_Type);
633 Append_To (Decls, Current_Primitive_Body);
634
635 -- Analyzing the body here would cause the Stub type to be
636 -- frozen, thus preventing subsequent primitive declarations.
637 -- For this reason, it will be analyzed later in the
638 -- regular flow.
639
640 -- Build the receiver stubs
641
642 Current_Receiver_Body :=
643 Build_Subprogram_Receiving_Stubs
644 (Vis_Decl => Current_Primitive_Decl,
645 Asynchronous => Possibly_Asynchronous,
646 Dynamically_Asynchronous => Possibly_Asynchronous,
647 Stub_Type => Stub_Elements.Stub_Type,
648 RACW_Type => Stub_Elements.RACW_Type,
649 Parent_Primitive => Current_Primitive);
650
651 Current_Receiver :=
652 Defining_Unit_Name (Specification (Current_Receiver_Body));
653
654 Append_To (Decls, Current_Receiver_Body);
655
656 -- Add a case alternative to the receiver
657
658 Append_To (RPC_Receiver_Case_Alternatives,
659 Make_Case_Statement_Alternative (Loc,
660 Discrete_Choices => New_List (
661 Make_Integer_Literal (Loc, Current_Primitive_Number)),
662
663 Statements => New_List (
664 Make_Procedure_Call_Statement (Loc,
665 Name =>
666 New_Occurrence_Of (Current_Receiver, Loc),
667 Parameter_Associations => New_List (
668 New_Occurrence_Of
669 (Stub_Elements.RPC_Receiver_Stream, Loc),
670 New_Occurrence_Of
671 (Stub_Elements.RPC_Receiver_Result, Loc))))));
672
673 -- Increment the index of current primitive
674
675 Current_Primitive_Number := Current_Primitive_Number + 1;
676 end if;
677
678 Next_Elmt (Current_Primitive_Elmt);
679 end loop;
680 end if;
681
682 -- Build the case statement and the heart of the subprogram
683
684 Append_To (RPC_Receiver_Case_Alternatives,
685 Make_Case_Statement_Alternative (Loc,
686 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
687 Statements => New_List (Make_Null_Statement (Loc))));
688
689 RPC_Receiver_Subp_Id :=
690 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
691
692 RPC_Receiver_Declarations := New_List (
693 Make_Object_Declaration (Loc,
694 Defining_Identifier => RPC_Receiver_Subp_Id,
695 Object_Definition =>
696 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)));
697
698 RPC_Receiver_Statements := New_List (
699 Make_Attribute_Reference (Loc,
700 Prefix =>
701 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
702 Attribute_Name =>
703 Name_Read,
704 Expressions => New_List (
705 New_Occurrence_Of (Stub_Elements.RPC_Receiver_Stream, Loc),
706 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc))));
707
708 Append_To (RPC_Receiver_Statements,
709 Make_Case_Statement (Loc,
710 Expression =>
711 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
712 Alternatives => RPC_Receiver_Case_Alternatives));
713
714 RPC_Receiver_Decl :=
715 Make_Subprogram_Body (Loc,
716 Specification =>
717 Copy_Specification (Loc,
718 Parent (Stub_Elements.Object_RPC_Receiver)),
719 Declarations => RPC_Receiver_Declarations,
720 Handled_Statement_Sequence =>
721 Make_Handled_Sequence_Of_Statements (Loc,
722 Statements => RPC_Receiver_Statements));
723
724 Append_To (Decls, RPC_Receiver_Decl);
725
726 -- Do not analyze RPC receiver at this stage since it will otherwise
727 -- reference subprograms that have not been analyzed yet. It will
728 -- be analyzed in the regular flow.
729
730 end Add_RACW_Primitive_Declarations_And_Bodies;
731
732 -----------------------------
733 -- Add_RACW_Read_Attribute --
734 -----------------------------
735
736 procedure Add_RACW_Read_Attribute
737 (RACW_Type : in Entity_Id;
738 Stub_Type : in Entity_Id;
739 Stub_Type_Access : in Entity_Id;
740 Declarations : in List_Id)
741 is
742 Loc : constant Source_Ptr := Sloc (RACW_Type);
743
744 Proc_Spec : Node_Id;
745 -- Specification and body of the currently built procedure
746
747 Proc_Body_Spec : Node_Id;
748
749 Proc_Decl : Node_Id;
750 Attr_Decl : Node_Id;
751
752 Body_Node : Node_Id;
753
754 Decls : List_Id;
755 Statements : List_Id;
756 Local_Statements : List_Id;
757 Remote_Statements : List_Id;
758 -- Various parts of the procedure
759
760 Procedure_Name : constant Name_Id :=
761 New_Internal_Name ('R');
762 Source_Partition : constant Entity_Id :=
763 Make_Defining_Identifier
764 (Loc, New_Internal_Name ('P'));
765 Source_Receiver : constant Entity_Id :=
766 Make_Defining_Identifier
767 (Loc, New_Internal_Name ('S'));
768 Source_Address : constant Entity_Id :=
769 Make_Defining_Identifier
770 (Loc, New_Internal_Name ('P'));
771 Stream_Parameter : constant Entity_Id :=
772 Make_Defining_Identifier
773 (Loc, New_Internal_Name ('S'));
774 Result : constant Entity_Id :=
775 Make_Defining_Identifier
776 (Loc, New_Internal_Name ('P'));
777 Stubbed_Result : constant Entity_Id :=
778 Make_Defining_Identifier
779 (Loc, New_Internal_Name ('S'));
780 Asynchronous_Flag : constant Entity_Id :=
781 Make_Defining_Identifier
782 (Loc, New_Internal_Name ('S'));
783 Asynchronous_Node : constant Node_Id :=
784 New_Occurrence_Of (Standard_False, Loc);
785
786 begin
787 -- Declare the asynchronous flag. This flag will be changed to True
788 -- whenever it is known that the RACW type is asynchronous. Also, the
789 -- node gets stored since it may be rewritten when we process the
790 -- asynchronous pragma.
791
792 Append_To (Declarations,
793 Make_Object_Declaration (Loc,
794 Defining_Identifier => Asynchronous_Flag,
795 Constant_Present => True,
796 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
797 Expression => Asynchronous_Node));
798
799 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Node);
800
801 -- Object declarations
802
803 Decls := New_List (
804 Make_Object_Declaration (Loc,
805 Defining_Identifier => Source_Partition,
806 Object_Definition =>
807 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
808
809 Make_Object_Declaration (Loc,
810 Defining_Identifier => Source_Receiver,
811 Object_Definition =>
812 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
813
814 Make_Object_Declaration (Loc,
815 Defining_Identifier => Source_Address,
816 Object_Definition =>
817 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
818
819 Make_Object_Declaration (Loc,
820 Defining_Identifier => Stubbed_Result,
821 Object_Definition =>
822 New_Occurrence_Of (Stub_Type_Access, Loc)));
823
824 -- Read the source Partition_ID and RPC_Receiver from incoming stream
825
826 Statements := New_List (
827 Make_Attribute_Reference (Loc,
828 Prefix =>
829 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
830 Attribute_Name => Name_Read,
831 Expressions => New_List (
832 New_Occurrence_Of (Stream_Parameter, Loc),
833 New_Occurrence_Of (Source_Partition, Loc))),
834
835 Make_Attribute_Reference (Loc,
836 Prefix =>
837 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
838 Attribute_Name =>
839 Name_Read,
840 Expressions => New_List (
841 New_Occurrence_Of (Stream_Parameter, Loc),
842 New_Occurrence_Of (Source_Receiver, Loc))),
843
844 Make_Attribute_Reference (Loc,
845 Prefix =>
846 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
847 Attribute_Name =>
848 Name_Read,
849 Expressions => New_List (
850 New_Occurrence_Of (Stream_Parameter, Loc),
851 New_Occurrence_Of (Source_Address, Loc))));
852
853 -- If the Address is Null_Address, then return a null object
854
855 Append_To (Statements,
856 Make_Implicit_If_Statement (RACW_Type,
857 Condition =>
858 Make_Op_Eq (Loc,
859 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
860 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
861 Then_Statements => New_List (
862 Make_Assignment_Statement (Loc,
863 Name => New_Occurrence_Of (Result, Loc),
864 Expression => Make_Null (Loc)),
865 Make_Return_Statement (Loc))));
866
867 -- If the RACW denotes an object created on the current partition, then
868 -- Local_Statements will be executed. The real object will be used.
869
870 Local_Statements := New_List (
871 Make_Assignment_Statement (Loc,
872 Name => New_Occurrence_Of (Result, Loc),
873 Expression =>
874 Unchecked_Convert_To (RACW_Type,
875 OK_Convert_To (RTE (RE_Address),
876 New_Occurrence_Of (Source_Address, Loc)))));
877
878 -- If the object is located on another partition, then a stub object
879 -- will be created with all the information needed to rebuild the
880 -- real object at the other end.
881
882 Remote_Statements := New_List (
883
884 Make_Assignment_Statement (Loc,
885 Name => New_Occurrence_Of (Stubbed_Result, Loc),
886 Expression =>
887 Make_Allocator (Loc,
888 New_Occurrence_Of (Stub_Type, Loc))),
889
890 Make_Assignment_Statement (Loc,
891 Name => Make_Selected_Component (Loc,
892 Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
893 Selector_Name => Make_Identifier (Loc, Name_Origin)),
894 Expression =>
895 New_Occurrence_Of (Source_Partition, Loc)),
896
897 Make_Assignment_Statement (Loc,
898 Name => Make_Selected_Component (Loc,
899 Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
900 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
901 Expression =>
902 New_Occurrence_Of (Source_Receiver, Loc)),
903
904 Make_Assignment_Statement (Loc,
905 Name => Make_Selected_Component (Loc,
906 Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
907 Selector_Name => Make_Identifier (Loc, Name_Addr)),
908 Expression =>
909 New_Occurrence_Of (Source_Address, Loc)));
910
911 Append_To (Remote_Statements,
912 Make_Assignment_Statement (Loc,
913 Name => Make_Selected_Component (Loc,
914 Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
915 Selector_Name => Make_Identifier (Loc, Name_Asynchronous)),
916 Expression =>
917 New_Occurrence_Of (Asynchronous_Flag, Loc)));
918
919 Append_To (Remote_Statements,
920 Make_Procedure_Call_Statement (Loc,
921 Name =>
922 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
923 Parameter_Associations => New_List (
924 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
925 New_Occurrence_Of (Stubbed_Result, Loc)))));
926
927 Append_To (Remote_Statements,
928 Make_Assignment_Statement (Loc,
929 Name => New_Occurrence_Of (Result, Loc),
930 Expression => Unchecked_Convert_To (RACW_Type,
931 New_Occurrence_Of (Stubbed_Result, Loc))));
932
933 -- Distinguish between the local and remote cases, and execute the
934 -- appropriate piece of code.
935
936 Append_To (Statements,
937 Make_Implicit_If_Statement (RACW_Type,
938 Condition =>
939 Make_Op_Eq (Loc,
940 Left_Opnd =>
941 Make_Function_Call (Loc,
942 Name =>
943 New_Occurrence_Of (RTE (RE_Get_Local_Partition_Id), Loc)),
944 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
945 Then_Statements => Local_Statements,
946 Else_Statements => Remote_Statements));
947
948 Proc_Spec :=
949 Make_Procedure_Specification (Loc,
950 Defining_Unit_Name =>
951 Make_Defining_Identifier (Loc, Procedure_Name),
952
953 Parameter_Specifications => New_List (
954 Make_Parameter_Specification (Loc,
955 Defining_Identifier => Stream_Parameter,
956 Parameter_Type =>
957 Make_Access_Definition (Loc,
958 Subtype_Mark =>
959 Make_Attribute_Reference (Loc,
960 Prefix =>
961 New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc),
962 Attribute_Name =>
963 Name_Class))),
964
965 Make_Parameter_Specification (Loc,
966 Defining_Identifier => Result,
967 Out_Present => True,
968 Parameter_Type =>
969 New_Occurrence_Of (RACW_Type, Loc))));
970
971 Proc_Body_Spec :=
972 Make_Procedure_Specification (Loc,
973 Defining_Unit_Name =>
974 Make_Defining_Identifier (Loc, Procedure_Name),
975
976 Parameter_Specifications => New_List (
977 Make_Parameter_Specification (Loc,
978 Defining_Identifier =>
979 Make_Defining_Identifier (Loc, Chars (Stream_Parameter)),
980 Parameter_Type =>
981 Make_Access_Definition (Loc,
982 Subtype_Mark =>
983 Make_Attribute_Reference (Loc,
984 Prefix =>
985 New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc),
986 Attribute_Name =>
987 Name_Class))),
988
989 Make_Parameter_Specification (Loc,
990 Defining_Identifier =>
991 Make_Defining_Identifier (Loc, Chars (Result)),
992 Out_Present => True,
993 Parameter_Type =>
994 New_Occurrence_Of (RACW_Type, Loc))));
995
996 Body_Node :=
997 Make_Subprogram_Body (Loc,
998 Specification => Proc_Body_Spec,
999 Declarations => Decls,
1000 Handled_Statement_Sequence =>
1001 Make_Handled_Sequence_Of_Statements (Loc,
1002 Statements => Statements));
1003
1004 Proc_Decl :=
1005 Make_Subprogram_Declaration (Loc, Specification => Proc_Spec);
1006
1007 Attr_Decl :=
1008 Make_Attribute_Definition_Clause (Loc,
1009 Name => New_Occurrence_Of (RACW_Type, Loc),
1010 Chars => Name_Read,
1011 Expression =>
1012 New_Occurrence_Of (Defining_Unit_Name (Proc_Spec), Loc));
1013
1014 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
1015 Insert_After (Proc_Decl, Attr_Decl);
1016 Append_To (Declarations, Body_Node);
1017 end Add_RACW_Read_Attribute;
1018
1019 ------------------------------------
1020 -- Add_RACW_Read_Write_Attributes --
1021 ------------------------------------
1022
1023 procedure Add_RACW_Read_Write_Attributes
1024 (RACW_Type : in Entity_Id;
1025 Stub_Type : in Entity_Id;
1026 Stub_Type_Access : in Entity_Id;
1027 Object_RPC_Receiver : in Entity_Id;
1028 Declarations : in List_Id)
1029 is
1030 begin
1031 Add_RACW_Write_Attribute
1032 (RACW_Type => RACW_Type,
1033 Stub_Type => Stub_Type,
1034 Stub_Type_Access => Stub_Type_Access,
1035 Object_RPC_Receiver => Object_RPC_Receiver,
1036 Declarations => Declarations);
1037
1038 Add_RACW_Read_Attribute
1039 (RACW_Type => RACW_Type,
1040 Stub_Type => Stub_Type,
1041 Stub_Type_Access => Stub_Type_Access,
1042 Declarations => Declarations);
1043 end Add_RACW_Read_Write_Attributes;
1044
1045 ------------------------------
1046 -- Add_RACW_Write_Attribute --
1047 ------------------------------
1048
1049 procedure Add_RACW_Write_Attribute
1050 (RACW_Type : in Entity_Id;
1051 Stub_Type : in Entity_Id;
1052 Stub_Type_Access : in Entity_Id;
1053 Object_RPC_Receiver : in Entity_Id;
1054 Declarations : in List_Id)
1055 is
1056 Loc : constant Source_Ptr := Sloc (RACW_Type);
1057
1058 Proc_Spec : Node_Id;
1059
1060 Proc_Body_Spec : Node_Id;
1061
1062 Body_Node : Node_Id;
1063
1064 Proc_Decl : Node_Id;
1065 Attr_Decl : Node_Id;
1066
1067 Statements : List_Id;
1068 Local_Statements : List_Id;
1069 Remote_Statements : List_Id;
1070 Null_Statements : List_Id;
1071
1072 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
1073
1074 Stream_Parameter : constant Entity_Id :=
1075 Make_Defining_Identifier
1076 (Loc, New_Internal_Name ('S'));
1077
1078 Object : constant Entity_Id :=
1079 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1080
1081 begin
1082 -- Build the code fragment corresponding to the marshalling of a
1083 -- local object.
1084
1085 Local_Statements := New_List (
1086
1087 Pack_Entity_Into_Stream_Access (Loc,
1088 Stream => Stream_Parameter,
1089 Object => RTE (RE_Get_Local_Partition_Id)),
1090
1091 Pack_Node_Into_Stream_Access (Loc,
1092 Stream => Stream_Parameter,
1093 Object => OK_Convert_To (RTE (RE_Unsigned_64),
1094 Make_Attribute_Reference (Loc,
1095 Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc),
1096 Attribute_Name => Name_Address)),
1097 Etyp => RTE (RE_Unsigned_64)),
1098
1099 Pack_Node_Into_Stream_Access (Loc,
1100 Stream => Stream_Parameter,
1101 Object => OK_Convert_To (RTE (RE_Unsigned_64),
1102 Make_Attribute_Reference (Loc,
1103 Prefix =>
1104 Make_Explicit_Dereference (Loc,
1105 Prefix => New_Occurrence_Of (Object, Loc)),
1106 Attribute_Name => Name_Address)),
1107 Etyp => RTE (RE_Unsigned_64)));
1108
1109 -- Build the code fragment corresponding to the marshalling of
1110 -- a remote object.
1111
1112 Remote_Statements := New_List (
1113
1114 Pack_Node_Into_Stream_Access (Loc,
1115 Stream => Stream_Parameter,
1116 Object =>
1117 Make_Selected_Component (Loc,
1118 Prefix => Unchecked_Convert_To (Stub_Type_Access,
1119 New_Occurrence_Of (Object, Loc)),
1120 Selector_Name =>
1121 Make_Identifier (Loc, Name_Origin)),
1122 Etyp => RTE (RE_Partition_ID)),
1123
1124 Pack_Node_Into_Stream_Access (Loc,
1125 Stream => Stream_Parameter,
1126 Object =>
1127 Make_Selected_Component (Loc,
1128 Prefix => Unchecked_Convert_To (Stub_Type_Access,
1129 New_Occurrence_Of (Object, Loc)),
1130 Selector_Name =>
1131 Make_Identifier (Loc, Name_Receiver)),
1132 Etyp => RTE (RE_Unsigned_64)),
1133
1134 Pack_Node_Into_Stream_Access (Loc,
1135 Stream => Stream_Parameter,
1136 Object =>
1137 Make_Selected_Component (Loc,
1138 Prefix => Unchecked_Convert_To (Stub_Type_Access,
1139 New_Occurrence_Of (Object, Loc)),
1140 Selector_Name =>
1141 Make_Identifier (Loc, Name_Addr)),
1142 Etyp => RTE (RE_Unsigned_64)));
1143
1144 -- Build the code fragment corresponding to the marshalling of a null
1145 -- object.
1146
1147 Null_Statements := New_List (
1148
1149 Pack_Entity_Into_Stream_Access (Loc,
1150 Stream => Stream_Parameter,
1151 Object => RTE (RE_Get_Local_Partition_Id)),
1152
1153 Pack_Node_Into_Stream_Access (Loc,
1154 Stream => Stream_Parameter,
1155 Object => OK_Convert_To (RTE (RE_Unsigned_64),
1156 Make_Attribute_Reference (Loc,
1157 Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc),
1158 Attribute_Name => Name_Address)),
1159 Etyp => RTE (RE_Unsigned_64)),
1160
1161 Pack_Node_Into_Stream_Access (Loc,
1162 Stream => Stream_Parameter,
1163 Object => Make_Integer_Literal (Loc, Uint_0),
1164 Etyp => RTE (RE_Unsigned_64)));
1165
1166 Statements := New_List (
1167 Make_Implicit_If_Statement (RACW_Type,
1168 Condition =>
1169 Make_Op_Eq (Loc,
1170 Left_Opnd => New_Occurrence_Of (Object, Loc),
1171 Right_Opnd => Make_Null (Loc)),
1172 Then_Statements => Null_Statements,
1173 Elsif_Parts => New_List (
1174 Make_Elsif_Part (Loc,
1175 Condition =>
1176 Make_Op_Eq (Loc,
1177 Left_Opnd =>
1178 Make_Attribute_Reference (Loc,
1179 Prefix => New_Occurrence_Of (Object, Loc),
1180 Attribute_Name => Name_Tag),
1181 Right_Opnd =>
1182 Make_Attribute_Reference (Loc,
1183 Prefix => New_Occurrence_Of (Stub_Type, Loc),
1184 Attribute_Name => Name_Tag)),
1185 Then_Statements => Remote_Statements)),
1186 Else_Statements => Local_Statements));
1187
1188 Proc_Spec :=
1189 Make_Procedure_Specification (Loc,
1190 Defining_Unit_Name =>
1191 Make_Defining_Identifier (Loc, Procedure_Name),
1192
1193 Parameter_Specifications => New_List (
1194 Make_Parameter_Specification (Loc,
1195 Defining_Identifier => Stream_Parameter,
1196 Parameter_Type =>
1197 Make_Access_Definition (Loc,
1198 Subtype_Mark =>
1199 Make_Attribute_Reference (Loc,
1200 Prefix =>
1201 New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc),
1202 Attribute_Name =>
1203 Name_Class))),
1204
1205 Make_Parameter_Specification (Loc,
1206 Defining_Identifier => Object,
1207 In_Present => True,
1208 Parameter_Type =>
1209 New_Occurrence_Of (RACW_Type, Loc))));
1210
1211 Proc_Decl :=
1212 Make_Subprogram_Declaration (Loc, Specification => Proc_Spec);
1213
1214 Attr_Decl :=
1215 Make_Attribute_Definition_Clause (Loc,
1216 Name => New_Occurrence_Of (RACW_Type, Loc),
1217 Chars => Name_Write,
1218 Expression =>
1219 New_Occurrence_Of (Defining_Unit_Name (Proc_Spec), Loc));
1220
1221 Proc_Body_Spec :=
1222 Make_Procedure_Specification (Loc,
1223 Defining_Unit_Name =>
1224 Make_Defining_Identifier (Loc, Procedure_Name),
1225
1226 Parameter_Specifications => New_List (
1227 Make_Parameter_Specification (Loc,
1228 Defining_Identifier =>
1229 Make_Defining_Identifier (Loc, Chars (Stream_Parameter)),
1230 Parameter_Type =>
1231 Make_Access_Definition (Loc,
1232 Subtype_Mark =>
1233 Make_Attribute_Reference (Loc,
1234 Prefix =>
1235 New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc),
1236 Attribute_Name =>
1237 Name_Class))),
1238
1239 Make_Parameter_Specification (Loc,
1240 Defining_Identifier =>
1241 Make_Defining_Identifier (Loc, Chars (Object)),
1242 In_Present => True,
1243 Parameter_Type =>
1244 New_Occurrence_Of (RACW_Type, Loc))));
1245
1246 Body_Node :=
1247 Make_Subprogram_Body (Loc,
1248 Specification => Proc_Body_Spec,
1249 Declarations => No_List,
1250 Handled_Statement_Sequence =>
1251 Make_Handled_Sequence_Of_Statements (Loc,
1252 Statements => Statements));
1253
1254 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
1255 Insert_After (Proc_Decl, Attr_Decl);
1256 Append_To (Declarations, Body_Node);
1257 end Add_RACW_Write_Attribute;
1258
1259 ------------------------------
1260 -- Add_RAS_Access_Attribute --
1261 ------------------------------
1262
1263 procedure Add_RAS_Access_Attribute (N : in Node_Id) is
1264 Ras_Type : constant Entity_Id := Defining_Identifier (N);
1265 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
1266 -- Ras_Type is the access to subprogram type while Fat_Type points to
1267 -- the record type corresponding to a remote access to subprogram type.
1268
1269 Proc_Decls : constant List_Id := New_List;
1270 Proc_Statements : constant List_Id := New_List;
1271
1272 Proc_Spec : Node_Id;
1273 Proc_Body : Node_Id;
1274
1275 Proc : Node_Id;
1276
1277 Param : Node_Id;
1278 Package_Name : Node_Id;
1279 Subp_Id : Node_Id;
1280 Asynchronous : Node_Id;
1281 Return_Value : Node_Id;
1282
1283 Loc : constant Source_Ptr := Sloc (N);
1284
1285 procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id);
1286 -- Set a field name for the return value
1287
1288 procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id)
1289 is
1290 begin
1291 Append_To (Proc_Statements,
1292 Make_Assignment_Statement (Loc,
1293 Name =>
1294 Make_Selected_Component (Loc,
1295 Prefix => New_Occurrence_Of (Return_Value, Loc),
1296 Selector_Name => Make_Identifier (Loc, Field_Name)),
1297 Expression => Value));
1298 end Set_Field;
1299
1300 -- Start of processing for Add_RAS_Access_Attribute
1301
1302 begin
1303 Param := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1304 Package_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1305 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
1306 Asynchronous := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
1307 Return_Value := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1308
1309 -- Create the object which will be returned of type Fat_Type
1310
1311 Append_To (Proc_Decls,
1312 Make_Object_Declaration (Loc,
1313 Defining_Identifier => Return_Value,
1314 Object_Definition =>
1315 New_Occurrence_Of (Fat_Type, Loc)));
1316
1317 -- Initialize the fields of the record type with the appropriate data
1318
1319 Set_Field (Name_Ras,
1320 OK_Convert_To (RTE (RE_Unsigned_64), New_Occurrence_Of (Param, Loc)));
1321
1322 Set_Field (Name_Origin,
1323 Unchecked_Convert_To (Standard_Integer,
1324 Make_Function_Call (Loc,
1325 Name =>
1326 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
1327 Parameter_Associations => New_List (
1328 New_Occurrence_Of (Package_Name, Loc)))));
1329
1330 Set_Field (Name_Receiver,
1331 Make_Function_Call (Loc,
1332 Name =>
1333 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
1334 Parameter_Associations => New_List (
1335 New_Occurrence_Of (Package_Name, Loc))));
1336
1337 Set_Field (Name_Subp_Id,
1338 New_Occurrence_Of (Subp_Id, Loc));
1339
1340 Set_Field (Name_Async,
1341 New_Occurrence_Of (Asynchronous, Loc));
1342
1343 -- Return the newly created value
1344
1345 Append_To (Proc_Statements,
1346 Make_Return_Statement (Loc,
1347 Expression =>
1348 New_Occurrence_Of (Return_Value, Loc)));
1349
1350 Proc := Make_Defining_Identifier (Loc, Name_uRAS_Access);
1351
1352 Proc_Spec :=
1353 Make_Function_Specification (Loc,
1354 Defining_Unit_Name => Proc,
1355 Parameter_Specifications => New_List (
1356 Make_Parameter_Specification (Loc,
1357 Defining_Identifier => Param,
1358 Parameter_Type =>
1359 New_Occurrence_Of (RTE (RE_Address), Loc)),
1360
1361 Make_Parameter_Specification (Loc,
1362 Defining_Identifier => Package_Name,
1363 Parameter_Type =>
1364 New_Occurrence_Of (Standard_String, Loc)),
1365
1366 Make_Parameter_Specification (Loc,
1367 Defining_Identifier => Subp_Id,
1368 Parameter_Type =>
1369 New_Occurrence_Of (Standard_Natural, Loc)),
1370
1371 Make_Parameter_Specification (Loc,
1372 Defining_Identifier => Asynchronous,
1373 Parameter_Type =>
1374 New_Occurrence_Of (Standard_Boolean, Loc))),
1375
1376 Subtype_Mark =>
1377 New_Occurrence_Of (Fat_Type, Loc));
1378
1379 -- Set the kind and return type of the function to prevent ambiguities
1380 -- between Ras_Type and Fat_Type in subsequent analysis.
1381
1382 Set_Ekind (Proc, E_Function);
1383 Set_Etype (Proc, New_Occurrence_Of (Fat_Type, Loc));
1384
1385 Proc_Body :=
1386 Make_Subprogram_Body (Loc,
1387 Specification => Proc_Spec,
1388 Declarations => Proc_Decls,
1389 Handled_Statement_Sequence =>
1390 Make_Handled_Sequence_Of_Statements (Loc,
1391 Statements => Proc_Statements));
1392
1393 Set_TSS (Fat_Type, Proc);
1394
1395 end Add_RAS_Access_Attribute;
1396
1397 -----------------------------------
1398 -- Add_RAS_Dereference_Attribute --
1399 -----------------------------------
1400
1401 procedure Add_RAS_Dereference_Attribute (N : in Node_Id) is
1402 Loc : constant Source_Ptr := Sloc (N);
1403
1404 Type_Def : constant Node_Id := Type_Definition (N);
1405
1406 Ras_Type : constant Entity_Id := Defining_Identifier (N);
1407
1408 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
1409
1410 Proc_Decls : constant List_Id := New_List;
1411 Proc_Statements : constant List_Id := New_List;
1412
1413 Inner_Decls : constant List_Id := New_List;
1414 Inner_Statements : constant List_Id := New_List;
1415
1416 Direct_Statements : constant List_Id := New_List;
1417
1418 Proc : Node_Id;
1419
1420 Proc_Spec : Node_Id;
1421 Proc_Body : Node_Id;
1422
1423 Param_Specs : constant List_Id := New_List;
1424 Param_Assoc : constant List_Id := New_List;
1425
1426 Pointer : Node_Id;
1427
1428 Converted_Ras : Node_Id;
1429 Target_Partition : Node_Id;
1430 RPC_Receiver : Node_Id;
1431 Subprogram_Id : Node_Id;
1432 Asynchronous : Node_Id;
1433
1434 Is_Function : constant Boolean :=
1435 Nkind (Type_Def) = N_Access_Function_Definition;
1436
1437 Spec : constant Node_Id := Type_Def;
1438
1439 Current_Parameter : Node_Id;
1440
1441 begin
1442 -- The way to do it is test if the Ras field is non-null and then if
1443 -- the Origin field is equal to the current partition ID (which is in
1444 -- fact Current_Package'Partition_ID). If this is the case, then it
1445 -- is safe to dereference the Ras field directly rather than
1446 -- performing a remote call.
1447
1448 Pointer :=
1449 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1450
1451 Target_Partition :=
1452 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1453
1454 Append_To (Proc_Decls,
1455 Make_Object_Declaration (Loc,
1456 Defining_Identifier => Target_Partition,
1457 Constant_Present => True,
1458 Object_Definition =>
1459 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
1460 Expression =>
1461 Unchecked_Convert_To (RTE (RE_Partition_ID),
1462 Make_Selected_Component (Loc,
1463 Prefix =>
1464 New_Occurrence_Of (Pointer, Loc),
1465 Selector_Name =>
1466 Make_Identifier (Loc, Name_Origin)))));
1467
1468 RPC_Receiver :=
1469 Make_Selected_Component (Loc,
1470 Prefix =>
1471 New_Occurrence_Of (Pointer, Loc),
1472 Selector_Name =>
1473 Make_Identifier (Loc, Name_Receiver));
1474
1475 Subprogram_Id :=
1476 Unchecked_Convert_To (RTE (RE_Subprogram_Id),
1477 Make_Selected_Component (Loc,
1478 Prefix =>
1479 New_Occurrence_Of (Pointer, Loc),
1480 Selector_Name =>
1481 Make_Identifier (Loc, Name_Subp_Id)));
1482
1483 -- A function is never asynchronous. A procedure may or may not be
1484 -- asynchronous depending on whether a pragma Asynchronous applies
1485 -- on it. Since a RAST may point onto various subprograms, this is
1486 -- only known at runtime so both versions (synchronous and asynchronous)
1487 -- must be built every times it is not a function.
1488
1489 if Is_Function then
1490 Asynchronous := Empty;
1491
1492 else
1493 Asynchronous :=
1494 Make_Selected_Component (Loc,
1495 Prefix =>
1496 New_Occurrence_Of (Pointer, Loc),
1497 Selector_Name =>
1498 Make_Identifier (Loc, Name_Async));
1499
1500 end if;
1501
1502 if Present (Parameter_Specifications (Type_Def)) then
1503 Current_Parameter := First (Parameter_Specifications (Type_Def));
1504
1505 while Current_Parameter /= Empty loop
1506 Append_To (Param_Specs,
1507 Make_Parameter_Specification (Loc,
1508 Defining_Identifier =>
1509 Make_Defining_Identifier (Loc,
1510 Chars => Chars (Defining_Identifier (Current_Parameter))),
1511 In_Present => In_Present (Current_Parameter),
1512 Out_Present => Out_Present (Current_Parameter),
1513 Parameter_Type =>
1514 New_Occurrence_Of
1515 (Etype (Parameter_Type (Current_Parameter)), Loc),
1516 Expression =>
1517 New_Copy_Tree (Expression (Current_Parameter))));
1518
1519 Append_To (Param_Assoc,
1520 Make_Identifier (Loc,
1521 Chars => Chars (Defining_Identifier (Current_Parameter))));
1522
1523 Next (Current_Parameter);
1524 end loop;
1525 end if;
1526
1527 Proc := Make_Defining_Identifier (Loc, Name_uRAS_Dereference);
1528
1529 if Is_Function then
1530 Proc_Spec :=
1531 Make_Function_Specification (Loc,
1532 Defining_Unit_Name => Proc,
1533 Parameter_Specifications => Param_Specs,
1534 Subtype_Mark =>
1535 New_Occurrence_Of (
1536 Entity (Subtype_Mark (Spec)), Loc));
1537
1538 Set_Ekind (Proc, E_Function);
1539
1540 Set_Etype (Proc,
1541 New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
1542
1543 else
1544 Proc_Spec :=
1545 Make_Procedure_Specification (Loc,
1546 Defining_Unit_Name => Proc,
1547 Parameter_Specifications => Param_Specs);
1548
1549 Set_Ekind (Proc, E_Procedure);
1550 Set_Etype (Proc, Standard_Void_Type);
1551 end if;
1552
1553 -- Build the calling stubs for the dereference of the RAS
1554
1555 Build_General_Calling_Stubs
1556 (Decls => Inner_Decls,
1557 Statements => Inner_Statements,
1558 Target_Partition => Target_Partition,
1559 RPC_Receiver => RPC_Receiver,
1560 Subprogram_Id => Subprogram_Id,
1561 Asynchronous => Asynchronous,
1562 Is_Known_Non_Asynchronous => Is_Function,
1563 Is_Function => Is_Function,
1564 Spec => Proc_Spec,
1565 Nod => N);
1566
1567 Converted_Ras :=
1568 Unchecked_Convert_To (Ras_Type,
1569 OK_Convert_To (RTE (RE_Address),
1570 Make_Selected_Component (Loc,
1571 Prefix => New_Occurrence_Of (Pointer, Loc),
1572 Selector_Name => Make_Identifier (Loc, Name_Ras))));
1573
1574 if Is_Function then
1575 Append_To (Direct_Statements,
1576 Make_Return_Statement (Loc,
1577 Expression =>
1578 Make_Function_Call (Loc,
1579 Name =>
1580 Make_Explicit_Dereference (Loc,
1581 Prefix => Converted_Ras),
1582 Parameter_Associations => Param_Assoc)));
1583
1584 else
1585 Append_To (Direct_Statements,
1586 Make_Procedure_Call_Statement (Loc,
1587 Name =>
1588 Make_Explicit_Dereference (Loc,
1589 Prefix => Converted_Ras),
1590 Parameter_Associations => Param_Assoc));
1591 end if;
1592
1593 Prepend_To (Param_Specs,
1594 Make_Parameter_Specification (Loc,
1595 Defining_Identifier => Pointer,
1596 In_Present => True,
1597 Parameter_Type =>
1598 New_Occurrence_Of (Fat_Type, Loc)));
1599
1600 Append_To (Proc_Statements,
1601 Make_Implicit_If_Statement (N,
1602 Condition =>
1603 Make_And_Then (Loc,
1604 Left_Opnd =>
1605 Make_Op_Ne (Loc,
1606 Left_Opnd =>
1607 Make_Selected_Component (Loc,
1608 Prefix => New_Occurrence_Of (Pointer, Loc),
1609 Selector_Name => Make_Identifier (Loc, Name_Ras)),
1610 Right_Opnd =>
1611 Make_Integer_Literal (Loc, Uint_0)),
1612
1613 Right_Opnd =>
1614 Make_Op_Eq (Loc,
1615 Left_Opnd =>
1616 New_Occurrence_Of (Target_Partition, Loc),
1617 Right_Opnd =>
1618 Make_Function_Call (Loc,
1619 New_Occurrence_Of (
1620 RTE (RE_Get_Local_Partition_Id), Loc)))),
1621
1622 Then_Statements =>
1623 Direct_Statements,
1624
1625 Else_Statements => New_List (
1626 Make_Block_Statement (Loc,
1627 Declarations => Inner_Decls,
1628 Handled_Statement_Sequence =>
1629 Make_Handled_Sequence_Of_Statements (Loc,
1630 Statements => Inner_Statements)))));
1631
1632 Proc_Body :=
1633 Make_Subprogram_Body (Loc,
1634 Specification => Proc_Spec,
1635 Declarations => Proc_Decls,
1636 Handled_Statement_Sequence =>
1637 Make_Handled_Sequence_Of_Statements (Loc,
1638 Statements => Proc_Statements));
1639
1640 Set_TSS (Fat_Type, Defining_Unit_Name (Proc_Spec));
1641
1642 end Add_RAS_Dereference_Attribute;
1643
1644 -----------------------
1645 -- Add_RAST_Features --
1646 -----------------------
1647
1648 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1649 begin
1650 -- Do not add attributes more than once in any case. This should
1651 -- be replaced by an assert or this comment removed if we decide
1652 -- that this is normal to be called several times ???
1653
1654 if Present (TSS (Equivalent_Type (Defining_Identifier
1655 (Vis_Decl)), Name_uRAS_Access))
1656 then
1657 return;
1658 end if;
1659
1660 Add_RAS_Dereference_Attribute (Vis_Decl);
1661 Add_RAS_Access_Attribute (Vis_Decl);
1662 end Add_RAST_Features;
1663
1664 -----------------------------------------
1665 -- Add_Receiving_Stubs_To_Declarations --
1666 -----------------------------------------
1667
1668 procedure Add_Receiving_Stubs_To_Declarations
1669 (Pkg_Spec : in Node_Id;
1670 Decls : in List_Id)
1671 is
1672 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
1673
1674 Stream_Parameter : Node_Id;
1675 Result_Parameter : Node_Id;
1676
1677 Pkg_RPC_Receiver : Node_Id;
1678 Pkg_RPC_Receiver_Spec : Node_Id;
1679 Pkg_RPC_Receiver_Formals : List_Id;
1680 Pkg_RPC_Receiver_Decls : List_Id;
1681 Pkg_RPC_Receiver_Statements : List_Id;
1682 Pkg_RPC_Receiver_Cases : List_Id := New_List;
1683 Pkg_RPC_Receiver_Body : Node_Id;
1684 -- A Pkg_RPC_Receiver is built to decode the request
1685
1686 Subp_Id : Node_Id;
1687 -- Subprogram_Id as read from the incoming stream
1688
1689 Current_Declaration : Node_Id;
1690 Current_Subprogram_Number : Int := 0;
1691 Current_Stubs : Node_Id;
1692
1693 Actuals : List_Id;
1694
1695 Dummy_Register_Name : Name_Id;
1696 Dummy_Register_Spec : Node_Id;
1697 Dummy_Register_Decl : Node_Id;
1698 Dummy_Register_Body : Node_Id;
1699
1700 begin
1701 -- Building receiving stubs consist in several operations:
1702
1703 -- - a package RPC receiver must be built. This subprogram
1704 -- will get a Subprogram_Id from the incoming stream
1705 -- and will dispatch the call to the right subprogram
1706
1707 -- - a receiving stub for any subprogram visible in the package
1708 -- spec. This stub will read all the parameters from the stream,
1709 -- and put the result as well as the exception occurrence in the
1710 -- output stream
1711
1712 -- - a dummy package with an empty spec and a body made of an
1713 -- elaboration part, whose job is to register the receiving
1714 -- part of this RCI package on the name server. This is done
1715 -- by calling System.Partition_Interface.Register_Receiving_Stub
1716
1717 Stream_Parameter :=
1718 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1719 Result_Parameter :=
1720 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
1721 Subp_Id :=
1722 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1723
1724 Pkg_RPC_Receiver :=
1725 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1726
1727 -- The parameters of the package RPC receiver are made of two
1728 -- streams, an input one and an output one.
1729
1730 Pkg_RPC_Receiver_Formals := New_List (
1731 Make_Parameter_Specification (Loc,
1732 Defining_Identifier => Stream_Parameter,
1733 Parameter_Type =>
1734 Make_Access_Definition (Loc,
1735 Subtype_Mark =>
1736 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
1737 Make_Parameter_Specification (Loc,
1738 Defining_Identifier => Result_Parameter,
1739 Parameter_Type =>
1740 Make_Access_Definition (Loc,
1741 Subtype_Mark =>
1742 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))));
1743
1744 Pkg_RPC_Receiver_Spec :=
1745 Make_Procedure_Specification (Loc,
1746 Defining_Unit_Name => Pkg_RPC_Receiver,
1747 Parameter_Specifications => Pkg_RPC_Receiver_Formals);
1748
1749 Pkg_RPC_Receiver_Decls := New_List (
1750 Make_Object_Declaration (Loc,
1751 Defining_Identifier => Subp_Id,
1752 Object_Definition =>
1753 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)));
1754
1755 Pkg_RPC_Receiver_Statements := New_List (
1756 Make_Attribute_Reference (Loc,
1757 Prefix =>
1758 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
1759 Attribute_Name =>
1760 Name_Read,
1761 Expressions => New_List (
1762 New_Occurrence_Of (Stream_Parameter, Loc),
1763 New_Occurrence_Of (Subp_Id, Loc))));
1764
1765 -- For each subprogram, the receiving stub will be built and a
1766 -- case statement will be made on the Subprogram_Id to dispatch
1767 -- to the right subprogram.
1768
1769 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
1770
1771 while Current_Declaration /= Empty loop
1772
1773 if Nkind (Current_Declaration) = N_Subprogram_Declaration
1774 and then Comes_From_Source (Current_Declaration)
1775 then
1776 pragma Assert (Current_Subprogram_Number =
1777 Get_Subprogram_Id (Defining_Unit_Name (Specification (
1778 Current_Declaration))));
1779
1780 Current_Stubs :=
1781 Build_Subprogram_Receiving_Stubs
1782 (Vis_Decl => Current_Declaration,
1783 Asynchronous =>
1784 Nkind (Specification (Current_Declaration)) =
1785 N_Procedure_Specification
1786 and then Is_Asynchronous
1787 (Defining_Unit_Name (Specification
1788 (Current_Declaration))));
1789
1790 Append_To (Decls, Current_Stubs);
1791
1792 Analyze (Current_Stubs);
1793
1794 Actuals := New_List (New_Occurrence_Of (Stream_Parameter, Loc));
1795
1796 if Nkind (Specification (Current_Declaration))
1797 = N_Function_Specification
1798 or else
1799 not Is_Asynchronous (
1800 Defining_Entity (Specification (Current_Declaration)))
1801 then
1802 -- An asynchronous procedure does not want an output parameter
1803 -- since no result and no exception will ever be returned.
1804
1805 Append_To (Actuals,
1806 New_Occurrence_Of (Result_Parameter, Loc));
1807
1808 end if;
1809
1810 Append_To (Pkg_RPC_Receiver_Cases,
1811 Make_Case_Statement_Alternative (Loc,
1812 Discrete_Choices =>
1813 New_List (
1814 Make_Integer_Literal (Loc, Current_Subprogram_Number)),
1815
1816 Statements =>
1817 New_List (
1818 Make_Procedure_Call_Statement (Loc,
1819 Name =>
1820 New_Occurrence_Of (
1821 Defining_Entity (Current_Stubs), Loc),
1822 Parameter_Associations =>
1823 Actuals))));
1824
1825 Current_Subprogram_Number := Current_Subprogram_Number + 1;
1826 end if;
1827
1828 Next (Current_Declaration);
1829 end loop;
1830
1831 -- If we receive an invalid Subprogram_Id, it is best to do nothing
1832 -- rather than raising an exception since we do not want someone
1833 -- to crash a remote partition by sending invalid subprogram ids.
1834 -- This is consistent with the other parts of the case statement
1835 -- since even in presence of incorrect parameters in the stream,
1836 -- every exception will be caught and (if the subprogram is not an
1837 -- APC) put into the result stream and sent away.
1838
1839 Append_To (Pkg_RPC_Receiver_Cases,
1840 Make_Case_Statement_Alternative (Loc,
1841 Discrete_Choices =>
1842 New_List (Make_Others_Choice (Loc)),
1843 Statements =>
1844 New_List (Make_Null_Statement (Loc))));
1845
1846 Append_To (Pkg_RPC_Receiver_Statements,
1847 Make_Case_Statement (Loc,
1848 Expression =>
1849 New_Occurrence_Of (Subp_Id, Loc),
1850 Alternatives => Pkg_RPC_Receiver_Cases));
1851
1852 Pkg_RPC_Receiver_Body :=
1853 Make_Subprogram_Body (Loc,
1854 Specification => Pkg_RPC_Receiver_Spec,
1855 Declarations => Pkg_RPC_Receiver_Decls,
1856 Handled_Statement_Sequence =>
1857 Make_Handled_Sequence_Of_Statements (Loc,
1858 Statements => Pkg_RPC_Receiver_Statements));
1859
1860 Append_To (Decls, Pkg_RPC_Receiver_Body);
1861 Analyze (Pkg_RPC_Receiver_Body);
1862
1863 -- Construction of the dummy package used to register the package
1864 -- receiving stubs on the nameserver.
1865
1866 Dummy_Register_Name := New_Internal_Name ('P');
1867
1868 Dummy_Register_Spec :=
1869 Make_Package_Specification (Loc,
1870 Defining_Unit_Name =>
1871 Make_Defining_Identifier (Loc, Dummy_Register_Name),
1872 Visible_Declarations => No_List,
1873 End_Label => Empty);
1874
1875 Dummy_Register_Decl :=
1876 Make_Package_Declaration (Loc,
1877 Specification => Dummy_Register_Spec);
1878
1879 Append_To (Decls,
1880 Dummy_Register_Decl);
1881 Analyze (Dummy_Register_Decl);
1882
1883 Dummy_Register_Body :=
1884 Make_Package_Body (Loc,
1885 Defining_Unit_Name =>
1886 Make_Defining_Identifier (Loc, Dummy_Register_Name),
1887 Declarations => No_List,
1888
1889 Handled_Statement_Sequence =>
1890 Make_Handled_Sequence_Of_Statements (Loc,
1891 Statements => New_List (
1892 Make_Procedure_Call_Statement (Loc,
1893 Name =>
1894 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
1895
1896 Parameter_Associations => New_List (
1897 Make_String_Literal (Loc,
1898 Strval => Get_Pkg_Name_String_Id (Pkg_Spec)),
1899 Make_Attribute_Reference (Loc,
1900 Prefix =>
1901 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
1902 Attribute_Name =>
1903 Name_Unrestricted_Access),
1904 Make_Attribute_Reference (Loc,
1905 Prefix =>
1906 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
1907 Attribute_Name =>
1908 Name_Version))))));
1909
1910 Append_To (Decls, Dummy_Register_Body);
1911 Analyze (Dummy_Register_Body);
1912 end Add_Receiving_Stubs_To_Declarations;
1913
1914 -------------------
1915 -- Add_Stub_Type --
1916 -------------------
1917
1918 procedure Add_Stub_Type
1919 (Designated_Type : in Entity_Id;
1920 RACW_Type : in Entity_Id;
1921 Decls : in List_Id;
1922 Stub_Type : out Entity_Id;
1923 Stub_Type_Access : out Entity_Id;
1924 Object_RPC_Receiver : out Entity_Id;
1925 Existing : out Boolean)
1926 is
1927 Loc : constant Source_Ptr := Sloc (RACW_Type);
1928
1929 Stub_Elements : constant Stub_Structure :=
1930 Stubs_Table.Get (Designated_Type);
1931
1932 Stub_Type_Declaration : Node_Id;
1933 Stub_Type_Access_Declaration : Node_Id;
1934 Object_RPC_Receiver_Declaration : Node_Id;
1935
1936 RPC_Receiver_Stream : Entity_Id;
1937 RPC_Receiver_Result : Entity_Id;
1938
1939 begin
1940 if Stub_Elements /= Empty_Stub_Structure then
1941 Stub_Type := Stub_Elements.Stub_Type;
1942 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1943 Object_RPC_Receiver := Stub_Elements.Object_RPC_Receiver;
1944 Existing := True;
1945 return;
1946 end if;
1947
1948 Existing := False;
1949 Stub_Type :=
1950 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1951 Stub_Type_Access :=
1952 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1953 Object_RPC_Receiver :=
1954 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1955 RPC_Receiver_Stream :=
1956 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1957 RPC_Receiver_Result :=
1958 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1959 Stubs_Table.Set (Designated_Type,
1960 (Stub_Type => Stub_Type,
1961 Stub_Type_Access => Stub_Type_Access,
1962 Object_RPC_Receiver => Object_RPC_Receiver,
1963 RPC_Receiver_Stream => RPC_Receiver_Stream,
1964 RPC_Receiver_Result => RPC_Receiver_Result,
1965 RACW_Type => RACW_Type));
1966
1967 -- The stub type definition below must match exactly the one in
1968 -- s-parint.ads, since unchecked conversions will be used in
1969 -- s-parint.adb to modify pointers passed to Get_Unique_Remote_Pointer.
1970
1971 Stub_Type_Declaration :=
1972 Make_Full_Type_Declaration (Loc,
1973 Defining_Identifier => Stub_Type,
1974 Type_Definition =>
1975 Make_Record_Definition (Loc,
1976 Tagged_Present => True,
1977 Limited_Present => True,
1978 Component_List =>
1979 Make_Component_List (Loc,
1980 Component_Items => New_List (
1981
1982 Make_Component_Declaration (Loc,
1983 Defining_Identifier =>
1984 Make_Defining_Identifier (Loc, Name_Origin),
1985 Subtype_Indication =>
1986 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
1987
1988 Make_Component_Declaration (Loc,
1989 Defining_Identifier =>
1990 Make_Defining_Identifier (Loc, Name_Receiver),
1991 Subtype_Indication =>
1992 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
1993
1994 Make_Component_Declaration (Loc,
1995 Defining_Identifier =>
1996 Make_Defining_Identifier (Loc, Name_Addr),
1997 Subtype_Indication =>
1998 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
1999
2000 Make_Component_Declaration (Loc,
2001 Defining_Identifier =>
2002 Make_Defining_Identifier (Loc, Name_Asynchronous),
2003 Subtype_Indication =>
2004 New_Occurrence_Of (Standard_Boolean, Loc))))));
2005
2006 Append_To (Decls, Stub_Type_Declaration);
2007 Analyze (Stub_Type_Declaration);
2008
2009 -- This is in no way a type derivation, but we fake it to make
2010 -- sure that the dispatching table gets built with the corresponding
2011 -- primitive operations at the right place.
2012
2013 Derive_Subprograms (Parent_Type => Designated_Type,
2014 Derived_Type => Stub_Type);
2015
2016 Stub_Type_Access_Declaration :=
2017 Make_Full_Type_Declaration (Loc,
2018 Defining_Identifier => Stub_Type_Access,
2019 Type_Definition =>
2020 Make_Access_To_Object_Definition (Loc,
2021 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
2022
2023 Append_To (Decls, Stub_Type_Access_Declaration);
2024 Analyze (Stub_Type_Access_Declaration);
2025
2026 Object_RPC_Receiver_Declaration :=
2027 Make_Subprogram_Declaration (Loc,
2028 Make_Procedure_Specification (Loc,
2029 Defining_Unit_Name => Object_RPC_Receiver,
2030 Parameter_Specifications => New_List (
2031 Make_Parameter_Specification (Loc,
2032 Defining_Identifier => RPC_Receiver_Stream,
2033 Parameter_Type =>
2034 Make_Access_Definition (Loc,
2035 Subtype_Mark =>
2036 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
2037
2038 Make_Parameter_Specification (Loc,
2039 Defining_Identifier => RPC_Receiver_Result,
2040 Parameter_Type =>
2041 Make_Access_Definition (Loc,
2042 Subtype_Mark =>
2043 New_Occurrence_Of
2044 (RTE (RE_Params_Stream_Type), Loc))))));
2045
2046 Append_To (Decls, Object_RPC_Receiver_Declaration);
2047 end Add_Stub_Type;
2048
2049 ---------------------------------
2050 -- Build_General_Calling_Stubs --
2051 ---------------------------------
2052
2053 procedure Build_General_Calling_Stubs
2054 (Decls : List_Id;
2055 Statements : List_Id;
2056 Target_Partition : Entity_Id;
2057 RPC_Receiver : Node_Id;
2058 Subprogram_Id : Node_Id;
2059 Asynchronous : Node_Id := Empty;
2060 Is_Known_Asynchronous : Boolean := False;
2061 Is_Known_Non_Asynchronous : Boolean := False;
2062 Is_Function : Boolean;
2063 Spec : Node_Id;
2064 Object_Type : Entity_Id := Empty;
2065 Nod : Node_Id)
2066 is
2067 Loc : constant Source_Ptr := Sloc (Nod);
2068
2069 Stream_Parameter : Node_Id;
2070 -- Name of the stream used to transmit parameters to the remote package
2071
2072 Result_Parameter : Node_Id;
2073 -- Name of the result parameter (in non-APC cases) which get the
2074 -- result of the remote subprogram.
2075
2076 Exception_Return_Parameter : Node_Id;
2077 -- Name of the parameter which will hold the exception sent by the
2078 -- remote subprogram.
2079
2080 Current_Parameter : Node_Id;
2081 -- Current parameter being handled
2082
2083 Ordered_Parameters_List : constant List_Id :=
2084 Build_Ordered_Parameters_List (Spec);
2085
2086 Asynchronous_Statements : List_Id := No_List;
2087 Non_Asynchronous_Statements : List_Id := No_List;
2088 -- Statements specifics to the Asynchronous/Non-Asynchronous cases.
2089
2090 Extra_Formal_Statements : constant List_Id := New_List;
2091 -- List of statements for extra formal parameters. It will appear after
2092 -- the regular statements for writing out parameters.
2093
2094 begin
2095 -- The general form of a calling stub for a given subprogram is:
2096
2097 -- procedure X (...) is
2098 -- P : constant Partition_ID := RCI_Cache.Get_Active_Partition_ID;
2099 -- Stream, Result : aliased System.RPC.Params_Stream_Type (0);
2100 -- begin
2101 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
2102 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
2103 -- Put_Subprogram_Id_In_Stream;
2104 -- Put_Parameters_In_Stream;
2105 -- Do_RPC (Stream, Result);
2106 -- Read_Exception_Occurrence_From_Result; Raise_It;
2107 -- Read_Out_Parameters_And_Function_Return_From_Stream;
2108 -- end X;
2109
2110 -- There are some variations: Do_APC is called for an asynchronous
2111 -- procedure and the part after the call is completely ommitted
2112 -- as well as the declaration of Result. For a function call,
2113 -- 'Input is always used to read the result even if it is constrained.
2114
2115 Stream_Parameter :=
2116 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2117
2118 Append_To (Decls,
2119 Make_Object_Declaration (Loc,
2120 Defining_Identifier => Stream_Parameter,
2121 Aliased_Present => True,
2122 Object_Definition =>
2123 Make_Subtype_Indication (Loc,
2124 Subtype_Mark =>
2125 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
2126 Constraint =>
2127 Make_Index_Or_Discriminant_Constraint (Loc,
2128 Constraints =>
2129 New_List (Make_Integer_Literal (Loc, 0))))));
2130
2131 if not Is_Known_Asynchronous then
2132 Result_Parameter :=
2133 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2134
2135 Append_To (Decls,
2136 Make_Object_Declaration (Loc,
2137 Defining_Identifier => Result_Parameter,
2138 Aliased_Present => True,
2139 Object_Definition =>
2140 Make_Subtype_Indication (Loc,
2141 Subtype_Mark =>
2142 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
2143 Constraint =>
2144 Make_Index_Or_Discriminant_Constraint (Loc,
2145 Constraints =>
2146 New_List (Make_Integer_Literal (Loc, 0))))));
2147
2148 Exception_Return_Parameter :=
2149 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
2150
2151 Append_To (Decls,
2152 Make_Object_Declaration (Loc,
2153 Defining_Identifier => Exception_Return_Parameter,
2154 Object_Definition =>
2155 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
2156
2157 else
2158 Result_Parameter := Empty;
2159 Exception_Return_Parameter := Empty;
2160 end if;
2161
2162 -- Put first the RPC receiver corresponding to the remote package
2163
2164 Append_To (Statements,
2165 Make_Attribute_Reference (Loc,
2166 Prefix =>
2167 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2168 Attribute_Name => Name_Write,
2169 Expressions => New_List (
2170 Make_Attribute_Reference (Loc,
2171 Prefix =>
2172 New_Occurrence_Of (Stream_Parameter, Loc),
2173 Attribute_Name =>
2174 Name_Access),
2175 RPC_Receiver)));
2176
2177 -- Then put the Subprogram_Id of the subprogram we want to call in
2178 -- the stream.
2179
2180 Append_To (Statements,
2181 Make_Attribute_Reference (Loc,
2182 Prefix =>
2183 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
2184 Attribute_Name =>
2185 Name_Write,
2186 Expressions => New_List (
2187 Make_Attribute_Reference (Loc,
2188 Prefix =>
2189 New_Occurrence_Of (Stream_Parameter, Loc),
2190 Attribute_Name => Name_Access),
2191 Subprogram_Id)));
2192
2193 Current_Parameter := First (Ordered_Parameters_List);
2194
2195 while Current_Parameter /= Empty loop
2196
2197 if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then
2198
2199 -- In the case of a controlling formal argument, we marshall
2200 -- its addr field rather than the local stub.
2201
2202 Append_To (Statements,
2203 Pack_Node_Into_Stream (Loc,
2204 Stream => Stream_Parameter,
2205 Object =>
2206 Make_Selected_Component (Loc,
2207 Prefix =>
2208 New_Occurrence_Of (
2209 Defining_Identifier (Current_Parameter), Loc),
2210 Selector_Name =>
2211 Make_Identifier (Loc, Name_Addr)),
2212 Etyp => RTE (RE_Unsigned_64)));
2213
2214 else
2215 declare
2216 Etyp : constant Entity_Id :=
2217 Etype (Parameter_Type (Current_Parameter));
2218
2219 Constrained : constant Boolean :=
2220 Is_Constrained (Etyp)
2221 or else Is_Elementary_Type (Etyp);
2222
2223 begin
2224 if In_Present (Current_Parameter)
2225 or else not Out_Present (Current_Parameter)
2226 or else not Constrained
2227 then
2228 Append_To (Statements,
2229 Make_Attribute_Reference (Loc,
2230 Prefix =>
2231 New_Occurrence_Of (Etyp, Loc),
2232 Attribute_Name => Output_From_Constrained (Constrained),
2233 Expressions => New_List (
2234 Make_Attribute_Reference (Loc,
2235 Prefix =>
2236 New_Occurrence_Of (Stream_Parameter, Loc),
2237 Attribute_Name => Name_Access),
2238 New_Occurrence_Of (
2239 Defining_Identifier (Current_Parameter), Loc))));
2240 end if;
2241 end;
2242 end if;
2243
2244 -- If the current parameter has a dynamic constrained status,
2245 -- then this status is transmitted as well.
2246 -- This should be done for accessibility as well ???
2247
2248 if Nkind (Parameter_Type (Current_Parameter)) /= N_Access_Definition
2249 and then Need_Extra_Constrained (Current_Parameter)
2250 then
2251 -- In this block, we do not use the extra formal that has been
2252 -- created because it does not exist at the time of expansion
2253 -- when building calling stubs for remote access to subprogram
2254 -- types. We create an extra variable of this type and push it
2255 -- in the stream after the regular parameters.
2256
2257 declare
2258 Extra_Parameter : constant Entity_Id :=
2259 Make_Defining_Identifier
2260 (Loc, New_Internal_Name ('P'));
2261
2262 begin
2263 Append_To (Decls,
2264 Make_Object_Declaration (Loc,
2265 Defining_Identifier => Extra_Parameter,
2266 Constant_Present => True,
2267 Object_Definition =>
2268 New_Occurrence_Of (Standard_Boolean, Loc),
2269 Expression =>
2270 Make_Attribute_Reference (Loc,
2271 Prefix =>
2272 New_Occurrence_Of (
2273 Defining_Identifier (Current_Parameter), Loc),
2274 Attribute_Name => Name_Constrained)));
2275
2276 Append_To (Extra_Formal_Statements,
2277 Make_Attribute_Reference (Loc,
2278 Prefix =>
2279 New_Occurrence_Of (Standard_Boolean, Loc),
2280 Attribute_Name =>
2281 Name_Write,
2282 Expressions => New_List (
2283 Make_Attribute_Reference (Loc,
2284 Prefix =>
2285 New_Occurrence_Of (Stream_Parameter, Loc),
2286 Attribute_Name =>
2287 Name_Access),
2288 New_Occurrence_Of (Extra_Parameter, Loc))));
2289 end;
2290 end if;
2291
2292 Next (Current_Parameter);
2293 end loop;
2294
2295 -- Append the formal statements list to the statements
2296
2297 Append_List_To (Statements, Extra_Formal_Statements);
2298
2299 if not Is_Known_Non_Asynchronous then
2300
2301 -- Build the call to System.RPC.Do_APC
2302
2303 Asynchronous_Statements := New_List (
2304 Make_Procedure_Call_Statement (Loc,
2305 Name =>
2306 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
2307 Parameter_Associations => New_List (
2308 New_Occurrence_Of (Target_Partition, Loc),
2309 Make_Attribute_Reference (Loc,
2310 Prefix =>
2311 New_Occurrence_Of (Stream_Parameter, Loc),
2312 Attribute_Name =>
2313 Name_Access))));
2314 else
2315 Asynchronous_Statements := No_List;
2316 end if;
2317
2318 if not Is_Known_Asynchronous then
2319
2320 -- Build the call to System.RPC.Do_RPC
2321
2322 Non_Asynchronous_Statements := New_List (
2323 Make_Procedure_Call_Statement (Loc,
2324 Name =>
2325 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
2326 Parameter_Associations => New_List (
2327 New_Occurrence_Of (Target_Partition, Loc),
2328
2329 Make_Attribute_Reference (Loc,
2330 Prefix =>
2331 New_Occurrence_Of (Stream_Parameter, Loc),
2332 Attribute_Name =>
2333 Name_Access),
2334
2335 Make_Attribute_Reference (Loc,
2336 Prefix =>
2337 New_Occurrence_Of (Result_Parameter, Loc),
2338 Attribute_Name =>
2339 Name_Access))));
2340
2341 -- Read the exception occurrence from the result stream and
2342 -- reraise it. It does no harm if this is a Null_Occurrence since
2343 -- this does nothing.
2344
2345 Append_To (Non_Asynchronous_Statements,
2346 Make_Attribute_Reference (Loc,
2347 Prefix =>
2348 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
2349
2350 Attribute_Name =>
2351 Name_Read,
2352
2353 Expressions => New_List (
2354 Make_Attribute_Reference (Loc,
2355 Prefix =>
2356 New_Occurrence_Of (Result_Parameter, Loc),
2357 Attribute_Name =>
2358 Name_Access),
2359 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
2360
2361 Append_To (Non_Asynchronous_Statements,
2362 Make_Procedure_Call_Statement (Loc,
2363 Name =>
2364 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
2365 Parameter_Associations => New_List (
2366 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
2367
2368 if Is_Function then
2369
2370 -- If this is a function call, then read the value and return
2371 -- it. The return value is written/read using 'Output/'Input.
2372
2373 Append_To (Non_Asynchronous_Statements,
2374 Make_Tag_Check (Loc,
2375 Make_Return_Statement (Loc,
2376 Expression =>
2377 Make_Attribute_Reference (Loc,
2378 Prefix =>
2379 New_Occurrence_Of (
2380 Etype (Subtype_Mark (Spec)), Loc),
2381
2382 Attribute_Name => Name_Input,
2383
2384 Expressions => New_List (
2385 Make_Attribute_Reference (Loc,
2386 Prefix =>
2387 New_Occurrence_Of (Result_Parameter, Loc),
2388 Attribute_Name => Name_Access))))));
2389
2390 else
2391 -- Loop around parameters and assign out (or in out) parameters.
2392 -- In the case of RACW, controlling arguments cannot possibly
2393 -- have changed since they are remote, so we do not read them
2394 -- from the stream.
2395
2396 Current_Parameter :=
2397 First (Ordered_Parameters_List);
2398
2399 while Current_Parameter /= Empty loop
2400
2401 if Out_Present (Current_Parameter)
2402 and then
2403 Etype (Parameter_Type (Current_Parameter)) /= Object_Type
2404 then
2405 Append_To (Non_Asynchronous_Statements,
2406 Make_Attribute_Reference (Loc,
2407 Prefix =>
2408 New_Occurrence_Of (
2409 Etype (Parameter_Type (Current_Parameter)), Loc),
2410
2411 Attribute_Name => Name_Read,
2412
2413 Expressions => New_List (
2414 Make_Attribute_Reference (Loc,
2415 Prefix =>
2416 New_Occurrence_Of (Result_Parameter, Loc),
2417 Attribute_Name =>
2418 Name_Access),
2419 New_Occurrence_Of (
2420 Defining_Identifier (Current_Parameter), Loc))));
2421 end if;
2422
2423 Next (Current_Parameter);
2424 end loop;
2425 end if;
2426 end if;
2427
2428 if Is_Known_Asynchronous then
2429 Append_List_To (Statements, Asynchronous_Statements);
2430
2431 elsif Is_Known_Non_Asynchronous then
2432 Append_List_To (Statements, Non_Asynchronous_Statements);
2433
2434 else
2435 pragma Assert (Asynchronous /= Empty);
2436 Prepend_To (Asynchronous_Statements,
2437 Make_Attribute_Reference (Loc,
2438 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
2439 Attribute_Name => Name_Write,
2440 Expressions => New_List (
2441 Make_Attribute_Reference (Loc,
2442 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
2443 Attribute_Name => Name_Access),
2444 New_Occurrence_Of (Standard_True, Loc))));
2445 Prepend_To (Non_Asynchronous_Statements,
2446 Make_Attribute_Reference (Loc,
2447 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
2448 Attribute_Name => Name_Write,
2449 Expressions => New_List (
2450 Make_Attribute_Reference (Loc,
2451 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
2452 Attribute_Name => Name_Access),
2453 New_Occurrence_Of (Standard_False, Loc))));
2454 Append_To (Statements,
2455 Make_Implicit_If_Statement (Nod,
2456 Condition => Asynchronous,
2457 Then_Statements => Asynchronous_Statements,
2458 Else_Statements => Non_Asynchronous_Statements));
2459 end if;
2460 end Build_General_Calling_Stubs;
2461
2462 -----------------------------------
2463 -- Build_Ordered_Parameters_List --
2464 -----------------------------------
2465
2466 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2467 Constrained_List : List_Id;
2468 Unconstrained_List : List_Id;
2469 Current_Parameter : Node_Id;
2470
2471 begin
2472 if not Present (Parameter_Specifications (Spec)) then
2473 return New_List;
2474 end if;
2475
2476 Constrained_List := New_List;
2477 Unconstrained_List := New_List;
2478
2479 -- Loop through the parameters and add them to the right list
2480
2481 Current_Parameter := First (Parameter_Specifications (Spec));
2482 while Current_Parameter /= Empty loop
2483
2484 if Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
2485 or else
2486 Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
2487 or else
2488 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter)))
2489 then
2490 Append_To (Constrained_List, New_Copy (Current_Parameter));
2491 else
2492 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2493 end if;
2494
2495 Next (Current_Parameter);
2496 end loop;
2497
2498 -- Unconstrained parameters are returned first
2499
2500 Append_List_To (Unconstrained_List, Constrained_List);
2501
2502 return Unconstrained_List;
2503
2504 end Build_Ordered_Parameters_List;
2505
2506 ----------------------------------
2507 -- Build_Passive_Partition_Stub --
2508 ----------------------------------
2509
2510 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2511 Pkg_Spec : Node_Id;
2512 L : List_Id;
2513 Reg : Node_Id;
2514 Loc : constant Source_Ptr := Sloc (U);
2515 Dist_OK : Entity_Id;
2516
2517 begin
2518 -- Verify that the implementation supports distribution, by accessing
2519 -- a type defined in the proper version of system.rpc
2520
2521 Dist_OK := RTE (RE_Params_Stream_Type);
2522
2523 -- Use body if present, spec otherwise
2524
2525 if Nkind (U) = N_Package_Declaration then
2526 Pkg_Spec := Specification (U);
2527 L := Visible_Declarations (Pkg_Spec);
2528 else
2529 Pkg_Spec := Parent (Corresponding_Spec (U));
2530 L := Declarations (U);
2531 end if;
2532
2533 Reg :=
2534 Make_Procedure_Call_Statement (Loc,
2535 Name =>
2536 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2537 Parameter_Associations => New_List (
2538 Make_String_Literal (Loc, Get_Pkg_Name_String_Id (Pkg_Spec)),
2539 Make_Attribute_Reference (Loc,
2540 Prefix =>
2541 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2542 Attribute_Name =>
2543 Name_Version)));
2544 Append_To (L, Reg);
2545 Analyze (Reg);
2546 end Build_Passive_Partition_Stub;
2547
2548 ------------------------------------
2549 -- Build_Subprogram_Calling_Stubs --
2550 ------------------------------------
2551
2552 function Build_Subprogram_Calling_Stubs
2553 (Vis_Decl : Node_Id;
2554 Subp_Id : Int;
2555 Asynchronous : Boolean;
2556 Dynamically_Asynchronous : Boolean := False;
2557 Stub_Type : Entity_Id := Empty;
2558 Locator : Entity_Id := Empty;
2559 New_Name : Name_Id := No_Name)
2560 return Node_Id
2561 is
2562 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2563
2564 Target_Partition : Node_Id;
2565 -- Contains the name of the target partition
2566
2567 Decls : constant List_Id := New_List;
2568 Statements : constant List_Id := New_List;
2569
2570 Subp_Spec : Node_Id;
2571 -- The specification of the body
2572
2573 Controlling_Parameter : Entity_Id := Empty;
2574 RPC_Receiver : Node_Id;
2575
2576 Asynchronous_Expr : Node_Id := Empty;
2577
2578 RCI_Locator : Entity_Id;
2579
2580 Spec_To_Use : Node_Id;
2581
2582 procedure Insert_Partition_Check (Parameter : in Node_Id);
2583 -- Check that the parameter has been elaborated on the same partition
2584 -- than the controlling parameter (E.4(19)).
2585
2586 ----------------------------
2587 -- Insert_Partition_Check --
2588 ----------------------------
2589
2590 procedure Insert_Partition_Check (Parameter : in Node_Id) is
2591 Parameter_Entity : constant Entity_Id :=
2592 Defining_Identifier (Parameter);
2593 Designated_Object : Node_Id;
2594 Condition : Node_Id;
2595
2596 begin
2597 -- The expression that will be built is of the form:
2598 -- if not (Parameter in Stub_Type and then
2599 -- Parameter.Origin = Controlling.Origin)
2600 -- then
2601 -- raise Constraint_Error;
2602 -- end if;
2603 --
2604 -- Condition contains the reversed condition. Also, Parameter is
2605 -- dereferenced if it is an access type. We do not check that
2606 -- Parameter is in Stub_Type since such a check has been inserted
2607 -- at the point of call already (a tag check since we have multiple
2608 -- controlling operands).
2609
2610 if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
2611 Designated_Object :=
2612 Make_Explicit_Dereference (Loc,
2613 Prefix => New_Occurrence_Of (Parameter_Entity, Loc));
2614 else
2615 Designated_Object := New_Occurrence_Of (Parameter_Entity, Loc);
2616 end if;
2617
2618 Condition :=
2619 Make_Op_Eq (Loc,
2620 Left_Opnd =>
2621 Make_Selected_Component (Loc,
2622 Prefix =>
2623 New_Occurrence_Of (Parameter_Entity, Loc),
2624 Selector_Name =>
2625 Make_Identifier (Loc, Name_Origin)),
2626
2627 Right_Opnd =>
2628 Make_Selected_Component (Loc,
2629 Prefix =>
2630 New_Occurrence_Of (Controlling_Parameter, Loc),
2631 Selector_Name =>
2632 Make_Identifier (Loc, Name_Origin)));
2633
2634 Append_To (Decls,
2635 Make_Raise_Constraint_Error (Loc,
2636 Condition =>
2637 Make_Op_Not (Loc, Right_Opnd => Condition),
2638 Reason => CE_Partition_Check_Failed));
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