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