1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Exp_Tss
; use Exp_Tss
;
32 with Exp_Util
; use Exp_Util
;
33 with GNAT
.HTable
; use GNAT
.HTable
;
35 with Namet
; use Namet
;
36 with Nlists
; use Nlists
;
37 with Nmake
; use Nmake
;
39 with Rtsfind
; use Rtsfind
;
41 with Sem_Ch3
; use Sem_Ch3
;
42 with Sem_Ch8
; use Sem_Ch8
;
43 with Sem_Dist
; use Sem_Dist
;
44 with Sem_Util
; use Sem_Util
;
45 with Sinfo
; use Sinfo
;
46 with Snames
; use Snames
;
47 with Stand
; use Stand
;
48 with Stringt
; use Stringt
;
49 with Tbuild
; use Tbuild
;
50 with Uintp
; use Uintp
;
51 with Uname
; use Uname
;
53 package body Exp_Dist
is
55 -- The following model has been used to implement distributed objects:
56 -- given a designated type D and a RACW type R, then a record of the
58 -- type Stub is tagged record
59 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
61 -- is built. This type has two properties:
63 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
64 -- converted to and from this type to make it suitable for
65 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
66 -- to avoid memory leaks when the same remote object arrive on the
67 -- same partition by following different pathes
69 -- 2) It also has the same dispatching table as the designated type D,
70 -- and thus can be used as an object designated by a value of type
71 -- R on any partition other than the one on which the object has
72 -- been created, since only dispatching calls will be performed and
73 -- the fields themselves will not be used. We call Derive_Subprograms
74 -- to fake half a derivation to ensure that the subprograms do have
75 -- the same dispatching table.
77 -----------------------
78 -- Local subprograms --
79 -----------------------
81 procedure Build_General_Calling_Stubs
83 Statements
: in List_Id
;
84 Target_Partition
: in Entity_Id
;
85 RPC_Receiver
: in Node_Id
;
86 Subprogram_Id
: in Node_Id
;
87 Asynchronous
: in Node_Id
:= Empty
;
88 Is_Known_Asynchronous
: in Boolean := False;
89 Is_Known_Non_Asynchronous
: in Boolean := False;
90 Is_Function
: in Boolean;
92 Object_Type
: in Entity_Id
:= Empty
;
94 -- Build calling stubs for general purpose. The parameters are:
95 -- Decls : a place to put declarations
96 -- Statements : a place to put statements
97 -- Target_Partition : a node containing the target partition that must
98 -- be a N_Defining_Identifier
99 -- RPC_Receiver : a node containing the RPC receiver
100 -- Subprogram_Id : a node containing the subprogram ID
101 -- Asynchronous : True if an APC must be made instead of an RPC.
102 -- The value needs not be supplied if one of the
103 -- Is_Known_... is True.
104 -- Is_Known_Async... : True if we know that this is asynchronous
105 -- Is_Known_Non_A... : True if we know that this is not asynchronous
106 -- Spec : a node with a Parameter_Specifications and
107 -- a Subtype_Mark if applicable
108 -- Object_Type : in case of a RACW, parameters of type access to
109 -- Object_Type will be marshalled using the
110 -- address of this object (the addr field) rather
111 -- than using the 'Write on the object itself
112 -- Nod : used to provide sloc for generated code
114 function Build_Subprogram_Calling_Stubs
117 Asynchronous
: Boolean;
118 Dynamically_Asynchronous
: Boolean := False;
119 Stub_Type
: Entity_Id
:= Empty
;
120 Locator
: Entity_Id
:= Empty
;
121 New_Name
: Name_Id
:= No_Name
)
123 -- Build the calling stub for a given subprogram with the subprogram ID
124 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
125 -- parameters of this type will be marshalled instead of the object
126 -- itself. It will then be converted into Stub_Type before performing
127 -- the real call. If Dynamically_Asynchronous is True, then it will be
128 -- computed at run time whether the call is asynchronous or not.
129 -- Otherwise, the value of the formal Asynchronous will be used.
130 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
131 -- New_Name is given, then it will be used instead of the original name.
133 function Build_Subprogram_Receiving_Stubs
135 Asynchronous
: Boolean;
136 Dynamically_Asynchronous
: Boolean := False;
137 Stub_Type
: Entity_Id
:= Empty
;
138 RACW_Type
: Entity_Id
:= Empty
;
139 Parent_Primitive
: Entity_Id
:= Empty
)
141 -- Build the receiving stub for a given subprogram. The subprogram
142 -- declaration is also built by this procedure, and the value returned
143 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
144 -- found in the specification, then its address is read from the stream
145 -- instead of the object itself and converted into an access to
146 -- class-wide type before doing the real call using any of the RACW type
147 -- pointing on the designated type.
149 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
;
150 -- Return an ordered parameter list: unconstrained parameters are put
151 -- at the beginning of the list and constrained ones are put after. If
152 -- there are no parameters, an empty list is returned.
154 procedure Add_Calling_Stubs_To_Declarations
155 (Pkg_Spec
: in Node_Id
;
157 -- Add calling stubs to the declarative part
159 procedure Add_Receiving_Stubs_To_Declarations
160 (Pkg_Spec
: in Node_Id
;
162 -- Add receiving stubs to the declarative part
164 procedure Add_RAS_Dereference_Attribute
(N
: in Node_Id
);
165 -- Add a subprogram body for RAS dereference
167 procedure Add_RAS_Access_Attribute
(N
: in Node_Id
);
168 -- Add a subprogram body for RAS Access attribute
170 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean;
171 -- Return True if nothing prevents the program whose specification is
172 -- given to be asynchronous (i.e. no out parameter).
174 function Get_Pkg_Name_String_Id
(Decl_Node
: Node_Id
) return String_Id
;
175 function Get_String_Id
(Val
: String) return String_Id
;
176 -- Ugly functions used to retrieve a package name. Inherited from the
177 -- old exp_dist.adb and not rewritten yet ???
179 function Pack_Entity_Into_Stream_Access
183 Etyp
: Entity_Id
:= Empty
)
185 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
186 -- then Etype (Object) will be used if present. If the type is
187 -- constrained, then 'Write will be used to output the object,
188 -- If the type is unconstrained, 'Output will be used.
190 function Pack_Node_Into_Stream
196 -- Similar to above, with an arbitrary node instead of an entity
198 function Pack_Node_Into_Stream_Access
204 -- Similar to above, with Stream instead of Stream'Access
206 function Copy_Specification
209 Object_Type
: Entity_Id
:= Empty
;
210 Stub_Type
: Entity_Id
:= Empty
;
211 New_Name
: Name_Id
:= No_Name
)
213 -- Build a specification from another one. If Object_Type is not Empty
214 -- and any access to Object_Type is found, then it is replaced by an
215 -- access to Stub_Type. If New_Name is given, then it will be used as
216 -- the name for the newly created spec.
218 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
;
219 -- Return the scope represented by a given spec
221 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean;
222 -- Return True if the current parameter needs an extra formal to reflect
223 -- its constrained status.
225 function Is_RACW_Controlling_Formal
226 (Parameter
: Node_Id
; Stub_Type
: Entity_Id
)
228 -- Return True if the current parameter is a controlling formal argument
229 -- of type Stub_Type or access to Stub_Type.
231 type Stub_Structure
is record
232 Stub_Type
: Entity_Id
;
233 Stub_Type_Access
: Entity_Id
;
234 Object_RPC_Receiver
: Entity_Id
;
235 RPC_Receiver_Stream
: Entity_Id
;
236 RPC_Receiver_Result
: Entity_Id
;
237 RACW_Type
: Entity_Id
;
239 -- This structure is necessary because of the two phases analysis of
240 -- a RACW declaration occurring in the same Remote_Types package as the
241 -- designated type. RACW_Type is any of the RACW types pointing on this
242 -- designated type, it is used here to save an anonymous type creation
243 -- for each primitive operation.
245 Empty_Stub_Structure
: constant Stub_Structure
:=
246 (Empty
, Empty
, Empty
, Empty
, Empty
, Empty
);
248 type Hash_Index
is range 0 .. 50;
249 function Hash
(F
: Entity_Id
) return Hash_Index
;
251 package Stubs_Table
is
252 new Simple_HTable
(Header_Num
=> Hash_Index
,
253 Element
=> Stub_Structure
,
254 No_Element
=> Empty_Stub_Structure
,
258 -- Mapping between a RACW designated type and its stub type
260 package Asynchronous_Flags_Table
is
261 new Simple_HTable
(Header_Num
=> Hash_Index
,
267 -- Mapping between a RACW type and the node holding the value True if
268 -- the RACW is asynchronous and False otherwise.
270 package RCI_Locator_Table
is
271 new Simple_HTable
(Header_Num
=> Hash_Index
,
272 Element
=> Entity_Id
,
277 -- Mapping between a RCI package on which All_Calls_Remote applies and
278 -- the generic instantiation of RCI_Info for this package.
280 package RCI_Calling_Stubs_Table
is
281 new Simple_HTable
(Header_Num
=> Hash_Index
,
282 Element
=> Entity_Id
,
287 -- Mapping between a RCI subprogram and the corresponding calling stubs
289 procedure Add_Stub_Type
290 (Designated_Type
: in Entity_Id
;
291 RACW_Type
: in Entity_Id
;
293 Stub_Type
: out Entity_Id
;
294 Stub_Type_Access
: out Entity_Id
;
295 Object_RPC_Receiver
: out Entity_Id
;
296 Existing
: out Boolean);
297 -- Add the declaration of the stub type, the access to stub type and the
298 -- object RPC receiver at the end of Decls. If these already exist,
299 -- then nothing is added in the tree but the right values are returned
300 -- anyhow and Existing is set to True.
302 procedure Add_RACW_Read_Attribute
303 (RACW_Type
: in Entity_Id
;
304 Stub_Type
: in Entity_Id
;
305 Stub_Type_Access
: in Entity_Id
;
306 Declarations
: in List_Id
);
307 -- Add Read attribute in Decls for the RACW type. The Read attribute
308 -- is added right after the RACW_Type declaration while the body is
309 -- inserted after Declarations.
311 procedure Add_RACW_Write_Attribute
312 (RACW_Type
: in Entity_Id
;
313 Stub_Type
: in Entity_Id
;
314 Stub_Type_Access
: in Entity_Id
;
315 Object_RPC_Receiver
: in Entity_Id
;
316 Declarations
: in List_Id
);
317 -- Same thing for the Write attribute
319 procedure Add_RACW_Read_Write_Attributes
320 (RACW_Type
: in Entity_Id
;
321 Stub_Type
: in Entity_Id
;
322 Stub_Type_Access
: in Entity_Id
;
323 Object_RPC_Receiver
: in Entity_Id
;
324 Declarations
: in List_Id
);
325 -- Add Read and Write attributes declarations and bodies for a given
326 -- RACW type. The declarations are added just after the declaration
327 -- of the RACW type itself, while the bodies are inserted at the end
330 function RCI_Package_Locator
332 Package_Spec
: Node_Id
)
334 -- Instantiate the generic package RCI_Info in order to locate the
335 -- RCI package whose spec is given as argument.
337 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
;
338 -- Surround a node N by a tag check, as in:
342 -- when E : Ada.Tags.Tag_Error =>
343 -- Raise_Exception (Program_Error'Identity,
344 -- Exception_Message (E));
347 function Input_With_Tag_Check
349 Var_Type
: Entity_Id
;
352 -- Return a function with the following form:
353 -- function R return Var_Type is
355 -- return Var_Type'Input (S);
357 -- when E : Ada.Tags.Tag_Error =>
358 -- Raise_Exception (Program_Error'Identity,
359 -- Exception_Message (E));
362 ------------------------------------
363 -- Local variables and structures --
364 ------------------------------------
368 Output_From_Constrained
: constant array (Boolean) of Name_Id
:=
369 (False => Name_Output
,
371 -- The attribute to choose depending on the fact that the parameter
372 -- is constrained or not. There is no such thing as Input_From_Constrained
373 -- since this require separate mechanisms ('Input is a function while
374 -- 'Read is a procedure).
376 ---------------------------------------
377 -- Add_Calling_Stubs_To_Declarations --
378 ---------------------------------------
380 procedure Add_Calling_Stubs_To_Declarations
381 (Pkg_Spec
: in Node_Id
;
384 Current_Subprogram_Number
: Int
:= 0;
385 Current_Declaration
: Node_Id
;
387 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
389 RCI_Instantiation
: Node_Id
;
391 Subp_Stubs
: Node_Id
;
394 -- The first thing added is an instantiation of the generic package
395 -- System.Partition_interface.RCI_Info with the name of the (current)
396 -- remote package. This will act as an interface with the name server
397 -- to determine the Partition_ID and the RPC_Receiver for the
398 -- receiver of this package.
400 RCI_Instantiation
:= RCI_Package_Locator
(Loc
, Pkg_Spec
);
401 RCI_Cache
:= Defining_Unit_Name
(RCI_Instantiation
);
403 Append_To
(Decls
, RCI_Instantiation
);
404 Analyze
(RCI_Instantiation
);
406 -- For each subprogram declaration visible in the spec, we do
407 -- build a body. We also increment a counter to assign a different
408 -- Subprogram_Id to each subprograms. The receiving stubs processing
409 -- do use the same mechanism and will thus assign the same Id and
410 -- do the correct dispatching.
412 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
414 while Current_Declaration
/= Empty
loop
416 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
417 and then Comes_From_Source
(Current_Declaration
)
419 pragma Assert
(Current_Subprogram_Number
=
420 Get_Subprogram_Id
(Defining_Unit_Name
(Specification
(
421 Current_Declaration
))));
424 Build_Subprogram_Calling_Stubs
(
425 Vis_Decl
=> Current_Declaration
,
426 Subp_Id
=> Current_Subprogram_Number
,
428 Nkind
(Specification
(Current_Declaration
)) =
429 N_Procedure_Specification
431 Is_Asynchronous
(Defining_Unit_Name
(Specification
432 (Current_Declaration
))));
434 Append_To
(Decls
, Subp_Stubs
);
435 Analyze
(Subp_Stubs
);
437 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
440 Next
(Current_Declaration
);
443 end Add_Calling_Stubs_To_Declarations
;
445 -----------------------
446 -- Add_RACW_Features --
447 -----------------------
449 procedure Add_RACW_Features
(RACW_Type
: in Entity_Id
)
451 Desig
: constant Entity_Id
:=
452 Etype
(Designated_Type
(RACW_Type
));
454 List_Containing
(Declaration_Node
(RACW_Type
));
456 Same_Scope
: constant Boolean :=
457 Scope
(Desig
) = Scope
(RACW_Type
);
459 Stub_Type
: Entity_Id
;
460 Stub_Type_Access
: Entity_Id
;
461 Object_RPC_Receiver
: Entity_Id
;
465 if not Expander_Active
then
471 -- We are declaring a RACW in the same package than its designated
472 -- type, so the list to use for late declarations must be the
473 -- private part of the package. We do know that this private part
474 -- exists since the designated type has to be a private one.
476 Decls
:= Private_Declarations
477 (Package_Specification_Of_Scope
(Current_Scope
));
479 elsif Nkind
(Parent
(Decls
)) = N_Package_Specification
480 and then Present
(Private_Declarations
(Parent
(Decls
)))
482 Decls
:= Private_Declarations
(Parent
(Decls
));
485 -- If we were unable to find the declarations, that means that the
486 -- completion of the type was missing. We can safely return and let
487 -- the error be caught by the semantic analysis.
494 (Designated_Type
=> Desig
,
495 RACW_Type
=> RACW_Type
,
497 Stub_Type
=> Stub_Type
,
498 Stub_Type_Access
=> Stub_Type_Access
,
499 Object_RPC_Receiver
=> Object_RPC_Receiver
,
500 Existing
=> Existing
);
502 Add_RACW_Read_Write_Attributes
503 (RACW_Type
=> RACW_Type
,
504 Stub_Type
=> Stub_Type
,
505 Stub_Type_Access
=> Stub_Type_Access
,
506 Object_RPC_Receiver
=> Object_RPC_Receiver
,
507 Declarations
=> Decls
);
509 if not Same_Scope
and then not Existing
then
511 -- The RACW has been declared in another scope than the designated
512 -- type and has not been handled by another RACW in the same
513 -- package as the first one, so add primitive for the stub type
516 Add_RACW_Primitive_Declarations_And_Bodies
517 (Designated_Type
=> Desig
,
519 Parent
(Declaration_Node
(Object_RPC_Receiver
)),
523 Add_Access_Type_To_Process
(E
=> Desig
, A
=> RACW_Type
);
525 end Add_RACW_Features
;
527 -------------------------------------------------
528 -- Add_RACW_Primitive_Declarations_And_Bodies --
529 -------------------------------------------------
531 procedure Add_RACW_Primitive_Declarations_And_Bodies
532 (Designated_Type
: in Entity_Id
;
533 Insertion_Node
: in Node_Id
;
536 -- Set sloc of generated declaration to be that of the
537 -- insertion node, so the declarations are recognized as
538 -- belonging to the current package.
540 Loc
: constant Source_Ptr
:= Sloc
(Insertion_Node
);
542 Stub_Elements
: constant Stub_Structure
:=
543 Stubs_Table
.Get
(Designated_Type
);
545 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
547 Current_Insertion_Node
: Node_Id
:= Insertion_Node
;
549 RPC_Receiver_Declarations
: List_Id
;
550 RPC_Receiver_Statements
: List_Id
;
551 RPC_Receiver_Case_Alternatives
: constant List_Id
:= New_List
;
552 RPC_Receiver_Subp_Id
: Entity_Id
;
554 Current_Primitive_Elmt
: Elmt_Id
;
555 Current_Primitive
: Entity_Id
;
556 Current_Primitive_Body
: Node_Id
;
557 Current_Primitive_Spec
: Node_Id
;
558 Current_Primitive_Decl
: Node_Id
;
559 Current_Primitive_Number
: Int
:= 0;
561 Current_Primitive_Alias
: Node_Id
;
563 Current_Receiver
: Entity_Id
;
564 Current_Receiver_Body
: Node_Id
;
566 RPC_Receiver_Decl
: Node_Id
;
568 Possibly_Asynchronous
: Boolean;
572 if not Expander_Active
then
576 -- Build callers, receivers for every primitive operations and a RPC
577 -- receiver for this type.
579 if Present
(Primitive_Operations
(Designated_Type
)) then
581 Current_Primitive_Elmt
:=
582 First_Elmt
(Primitive_Operations
(Designated_Type
));
584 while Current_Primitive_Elmt
/= No_Elmt
loop
586 Current_Primitive
:= Node
(Current_Primitive_Elmt
);
588 -- Copy the primitive of all the parents, except predefined
589 -- ones that are not remotely dispatching.
591 if Chars
(Current_Primitive
) /= Name_uSize
592 and then Chars
(Current_Primitive
) /= Name_uDeep_Finalize
594 -- The first thing to do is build an up-to-date copy of
595 -- the spec with all the formals referencing Designated_Type
596 -- transformed into formals referencing Stub_Type. Since this
597 -- primitive may have been inherited, go back the alias chain
598 -- until the real primitive has been found.
600 Current_Primitive_Alias
:= Current_Primitive
;
601 while Present
(Alias
(Current_Primitive_Alias
)) loop
603 (Current_Primitive_Alias
604 /= Alias
(Current_Primitive_Alias
));
605 Current_Primitive_Alias
:= Alias
(Current_Primitive_Alias
);
608 Current_Primitive_Spec
:=
609 Copy_Specification
(Loc
,
610 Spec
=> Parent
(Current_Primitive_Alias
),
611 Object_Type
=> Designated_Type
,
612 Stub_Type
=> Stub_Elements
.Stub_Type
);
614 Current_Primitive_Decl
:=
615 Make_Subprogram_Declaration
(Loc
,
616 Specification
=> Current_Primitive_Spec
);
618 Insert_After
(Current_Insertion_Node
, Current_Primitive_Decl
);
619 Analyze
(Current_Primitive_Decl
);
620 Current_Insertion_Node
:= Current_Primitive_Decl
;
622 Possibly_Asynchronous
:=
623 Nkind
(Current_Primitive_Spec
) = N_Procedure_Specification
624 and then Could_Be_Asynchronous
(Current_Primitive_Spec
);
626 Current_Primitive_Body
:=
627 Build_Subprogram_Calling_Stubs
628 (Vis_Decl
=> Current_Primitive_Decl
,
629 Subp_Id
=> Current_Primitive_Number
,
630 Asynchronous
=> Possibly_Asynchronous
,
631 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
632 Stub_Type
=> Stub_Elements
.Stub_Type
);
633 Append_To
(Decls
, Current_Primitive_Body
);
635 -- Analyzing the body here would cause the Stub type to be
636 -- frozen, thus preventing subsequent primitive declarations.
637 -- For this reason, it will be analyzed later in the
640 -- Build the receiver stubs
642 Current_Receiver_Body
:=
643 Build_Subprogram_Receiving_Stubs
644 (Vis_Decl
=> Current_Primitive_Decl
,
645 Asynchronous
=> Possibly_Asynchronous
,
646 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
647 Stub_Type
=> Stub_Elements
.Stub_Type
,
648 RACW_Type
=> Stub_Elements
.RACW_Type
,
649 Parent_Primitive
=> Current_Primitive
);
652 Defining_Unit_Name
(Specification
(Current_Receiver_Body
));
654 Append_To
(Decls
, Current_Receiver_Body
);
656 -- Add a case alternative to the receiver
658 Append_To
(RPC_Receiver_Case_Alternatives
,
659 Make_Case_Statement_Alternative
(Loc
,
660 Discrete_Choices
=> New_List
(
661 Make_Integer_Literal
(Loc
, Current_Primitive_Number
)),
663 Statements
=> New_List
(
664 Make_Procedure_Call_Statement
(Loc
,
666 New_Occurrence_Of
(Current_Receiver
, Loc
),
667 Parameter_Associations
=> New_List
(
669 (Stub_Elements
.RPC_Receiver_Stream
, Loc
),
671 (Stub_Elements
.RPC_Receiver_Result
, Loc
))))));
673 -- Increment the index of current primitive
675 Current_Primitive_Number
:= Current_Primitive_Number
+ 1;
678 Next_Elmt
(Current_Primitive_Elmt
);
682 -- Build the case statement and the heart of the subprogram
684 Append_To
(RPC_Receiver_Case_Alternatives
,
685 Make_Case_Statement_Alternative
(Loc
,
686 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
687 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
689 RPC_Receiver_Subp_Id
:=
690 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
692 RPC_Receiver_Declarations
:= New_List
(
693 Make_Object_Declaration
(Loc
,
694 Defining_Identifier
=> RPC_Receiver_Subp_Id
,
696 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)));
698 RPC_Receiver_Statements
:= New_List
(
699 Make_Attribute_Reference
(Loc
,
701 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
704 Expressions
=> New_List
(
705 New_Occurrence_Of
(Stub_Elements
.RPC_Receiver_Stream
, Loc
),
706 New_Occurrence_Of
(RPC_Receiver_Subp_Id
, Loc
))));
708 Append_To
(RPC_Receiver_Statements
,
709 Make_Case_Statement
(Loc
,
711 New_Occurrence_Of
(RPC_Receiver_Subp_Id
, Loc
),
712 Alternatives
=> RPC_Receiver_Case_Alternatives
));
715 Make_Subprogram_Body
(Loc
,
717 Copy_Specification
(Loc
,
718 Parent
(Stub_Elements
.Object_RPC_Receiver
)),
719 Declarations
=> RPC_Receiver_Declarations
,
720 Handled_Statement_Sequence
=>
721 Make_Handled_Sequence_Of_Statements
(Loc
,
722 Statements
=> RPC_Receiver_Statements
));
724 Append_To
(Decls
, RPC_Receiver_Decl
);
726 -- Do not analyze RPC receiver at this stage since it will otherwise
727 -- reference subprograms that have not been analyzed yet. It will
728 -- be analyzed in the regular flow.
730 end Add_RACW_Primitive_Declarations_And_Bodies
;
732 -----------------------------
733 -- Add_RACW_Read_Attribute --
734 -----------------------------
736 procedure Add_RACW_Read_Attribute
737 (RACW_Type
: in Entity_Id
;
738 Stub_Type
: in Entity_Id
;
739 Stub_Type_Access
: in Entity_Id
;
740 Declarations
: in List_Id
)
742 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
745 -- Specification and body of the currently built procedure
747 Proc_Body_Spec
: Node_Id
;
755 Statements
: List_Id
;
756 Local_Statements
: List_Id
;
757 Remote_Statements
: List_Id
;
758 -- Various parts of the procedure
760 Procedure_Name
: constant Name_Id
:=
761 New_Internal_Name
('R');
762 Source_Partition
: constant Entity_Id
:=
763 Make_Defining_Identifier
764 (Loc
, New_Internal_Name
('P'));
765 Source_Receiver
: constant Entity_Id
:=
766 Make_Defining_Identifier
767 (Loc
, New_Internal_Name
('S'));
768 Source_Address
: constant Entity_Id
:=
769 Make_Defining_Identifier
770 (Loc
, New_Internal_Name
('P'));
771 Stream_Parameter
: constant Entity_Id
:=
772 Make_Defining_Identifier
773 (Loc
, New_Internal_Name
('S'));
774 Result
: constant Entity_Id
:=
775 Make_Defining_Identifier
776 (Loc
, New_Internal_Name
('P'));
777 Stubbed_Result
: constant Entity_Id
:=
778 Make_Defining_Identifier
779 (Loc
, New_Internal_Name
('S'));
780 Asynchronous_Flag
: constant Entity_Id
:=
781 Make_Defining_Identifier
782 (Loc
, New_Internal_Name
('S'));
783 Asynchronous_Node
: constant Node_Id
:=
784 New_Occurrence_Of
(Standard_False
, Loc
);
787 -- Declare the asynchronous flag. This flag will be changed to True
788 -- whenever it is known that the RACW type is asynchronous. Also, the
789 -- node gets stored since it may be rewritten when we process the
790 -- asynchronous pragma.
792 Append_To
(Declarations
,
793 Make_Object_Declaration
(Loc
,
794 Defining_Identifier
=> Asynchronous_Flag
,
795 Constant_Present
=> True,
796 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
797 Expression
=> Asynchronous_Node
));
799 Asynchronous_Flags_Table
.Set
(RACW_Type
, Asynchronous_Node
);
801 -- Object declarations
804 Make_Object_Declaration
(Loc
,
805 Defining_Identifier
=> Source_Partition
,
807 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
)),
809 Make_Object_Declaration
(Loc
,
810 Defining_Identifier
=> Source_Receiver
,
812 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
814 Make_Object_Declaration
(Loc
,
815 Defining_Identifier
=> Source_Address
,
817 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
819 Make_Object_Declaration
(Loc
,
820 Defining_Identifier
=> Stubbed_Result
,
822 New_Occurrence_Of
(Stub_Type_Access
, Loc
)));
824 -- Read the source Partition_ID and RPC_Receiver from incoming stream
826 Statements
:= New_List
(
827 Make_Attribute_Reference
(Loc
,
829 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
830 Attribute_Name
=> Name_Read
,
831 Expressions
=> New_List
(
832 New_Occurrence_Of
(Stream_Parameter
, Loc
),
833 New_Occurrence_Of
(Source_Partition
, Loc
))),
835 Make_Attribute_Reference
(Loc
,
837 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
840 Expressions
=> New_List
(
841 New_Occurrence_Of
(Stream_Parameter
, Loc
),
842 New_Occurrence_Of
(Source_Receiver
, Loc
))),
844 Make_Attribute_Reference
(Loc
,
846 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
849 Expressions
=> New_List
(
850 New_Occurrence_Of
(Stream_Parameter
, Loc
),
851 New_Occurrence_Of
(Source_Address
, Loc
))));
853 -- If the Address is Null_Address, then return a null object
855 Append_To
(Statements
,
856 Make_Implicit_If_Statement
(RACW_Type
,
859 Left_Opnd
=> New_Occurrence_Of
(Source_Address
, Loc
),
860 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
861 Then_Statements
=> New_List
(
862 Make_Assignment_Statement
(Loc
,
863 Name
=> New_Occurrence_Of
(Result
, Loc
),
864 Expression
=> Make_Null
(Loc
)),
865 Make_Return_Statement
(Loc
))));
867 -- If the RACW denotes an object created on the current partition, then
868 -- Local_Statements will be executed. The real object will be used.
870 Local_Statements
:= New_List
(
871 Make_Assignment_Statement
(Loc
,
872 Name
=> New_Occurrence_Of
(Result
, Loc
),
874 Unchecked_Convert_To
(RACW_Type
,
875 OK_Convert_To
(RTE
(RE_Address
),
876 New_Occurrence_Of
(Source_Address
, Loc
)))));
878 -- If the object is located on another partition, then a stub object
879 -- will be created with all the information needed to rebuild the
880 -- real object at the other end.
882 Remote_Statements
:= New_List
(
884 Make_Assignment_Statement
(Loc
,
885 Name
=> New_Occurrence_Of
(Stubbed_Result
, Loc
),
888 New_Occurrence_Of
(Stub_Type
, Loc
))),
890 Make_Assignment_Statement
(Loc
,
891 Name
=> Make_Selected_Component
(Loc
,
892 Prefix
=> New_Occurrence_Of
(Stubbed_Result
, Loc
),
893 Selector_Name
=> Make_Identifier
(Loc
, Name_Origin
)),
895 New_Occurrence_Of
(Source_Partition
, Loc
)),
897 Make_Assignment_Statement
(Loc
,
898 Name
=> Make_Selected_Component
(Loc
,
899 Prefix
=> New_Occurrence_Of
(Stubbed_Result
, Loc
),
900 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
)),
902 New_Occurrence_Of
(Source_Receiver
, Loc
)),
904 Make_Assignment_Statement
(Loc
,
905 Name
=> Make_Selected_Component
(Loc
,
906 Prefix
=> New_Occurrence_Of
(Stubbed_Result
, Loc
),
907 Selector_Name
=> Make_Identifier
(Loc
, Name_Addr
)),
909 New_Occurrence_Of
(Source_Address
, Loc
)));
911 Append_To
(Remote_Statements
,
912 Make_Assignment_Statement
(Loc
,
913 Name
=> Make_Selected_Component
(Loc
,
914 Prefix
=> New_Occurrence_Of
(Stubbed_Result
, Loc
),
915 Selector_Name
=> Make_Identifier
(Loc
, Name_Asynchronous
)),
917 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
919 Append_To
(Remote_Statements
,
920 Make_Procedure_Call_Statement
(Loc
,
922 New_Occurrence_Of
(RTE
(RE_Get_Unique_Remote_Pointer
), Loc
),
923 Parameter_Associations
=> New_List
(
924 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
925 New_Occurrence_Of
(Stubbed_Result
, Loc
)))));
927 Append_To
(Remote_Statements
,
928 Make_Assignment_Statement
(Loc
,
929 Name
=> New_Occurrence_Of
(Result
, Loc
),
930 Expression
=> Unchecked_Convert_To
(RACW_Type
,
931 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
933 -- Distinguish between the local and remote cases, and execute the
934 -- appropriate piece of code.
936 Append_To
(Statements
,
937 Make_Implicit_If_Statement
(RACW_Type
,
941 Make_Function_Call
(Loc
,
943 New_Occurrence_Of
(RTE
(RE_Get_Local_Partition_Id
), Loc
)),
944 Right_Opnd
=> New_Occurrence_Of
(Source_Partition
, Loc
)),
945 Then_Statements
=> Local_Statements
,
946 Else_Statements
=> Remote_Statements
));
949 Make_Procedure_Specification
(Loc
,
950 Defining_Unit_Name
=>
951 Make_Defining_Identifier
(Loc
, Procedure_Name
),
953 Parameter_Specifications
=> New_List
(
954 Make_Parameter_Specification
(Loc
,
955 Defining_Identifier
=> Stream_Parameter
,
957 Make_Access_Definition
(Loc
,
959 Make_Attribute_Reference
(Loc
,
961 New_Occurrence_Of
(RTE
(RE_Root_Stream_Type
), Loc
),
965 Make_Parameter_Specification
(Loc
,
966 Defining_Identifier
=> Result
,
969 New_Occurrence_Of
(RACW_Type
, Loc
))));
972 Make_Procedure_Specification
(Loc
,
973 Defining_Unit_Name
=>
974 Make_Defining_Identifier
(Loc
, Procedure_Name
),
976 Parameter_Specifications
=> New_List
(
977 Make_Parameter_Specification
(Loc
,
978 Defining_Identifier
=>
979 Make_Defining_Identifier
(Loc
, Chars
(Stream_Parameter
)),
981 Make_Access_Definition
(Loc
,
983 Make_Attribute_Reference
(Loc
,
985 New_Occurrence_Of
(RTE
(RE_Root_Stream_Type
), Loc
),
989 Make_Parameter_Specification
(Loc
,
990 Defining_Identifier
=>
991 Make_Defining_Identifier
(Loc
, Chars
(Result
)),
994 New_Occurrence_Of
(RACW_Type
, Loc
))));
997 Make_Subprogram_Body
(Loc
,
998 Specification
=> Proc_Body_Spec
,
999 Declarations
=> Decls
,
1000 Handled_Statement_Sequence
=>
1001 Make_Handled_Sequence_Of_Statements
(Loc
,
1002 Statements
=> Statements
));
1005 Make_Subprogram_Declaration
(Loc
, Specification
=> Proc_Spec
);
1008 Make_Attribute_Definition_Clause
(Loc
,
1009 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
1012 New_Occurrence_Of
(Defining_Unit_Name
(Proc_Spec
), Loc
));
1014 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
1015 Insert_After
(Proc_Decl
, Attr_Decl
);
1016 Append_To
(Declarations
, Body_Node
);
1017 end Add_RACW_Read_Attribute
;
1019 ------------------------------------
1020 -- Add_RACW_Read_Write_Attributes --
1021 ------------------------------------
1023 procedure Add_RACW_Read_Write_Attributes
1024 (RACW_Type
: in Entity_Id
;
1025 Stub_Type
: in Entity_Id
;
1026 Stub_Type_Access
: in Entity_Id
;
1027 Object_RPC_Receiver
: in Entity_Id
;
1028 Declarations
: in List_Id
)
1031 Add_RACW_Write_Attribute
1032 (RACW_Type
=> RACW_Type
,
1033 Stub_Type
=> Stub_Type
,
1034 Stub_Type_Access
=> Stub_Type_Access
,
1035 Object_RPC_Receiver
=> Object_RPC_Receiver
,
1036 Declarations
=> Declarations
);
1038 Add_RACW_Read_Attribute
1039 (RACW_Type
=> RACW_Type
,
1040 Stub_Type
=> Stub_Type
,
1041 Stub_Type_Access
=> Stub_Type_Access
,
1042 Declarations
=> Declarations
);
1043 end Add_RACW_Read_Write_Attributes
;
1045 ------------------------------
1046 -- Add_RACW_Write_Attribute --
1047 ------------------------------
1049 procedure Add_RACW_Write_Attribute
1050 (RACW_Type
: in Entity_Id
;
1051 Stub_Type
: in Entity_Id
;
1052 Stub_Type_Access
: in Entity_Id
;
1053 Object_RPC_Receiver
: in Entity_Id
;
1054 Declarations
: in List_Id
)
1056 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1058 Proc_Spec
: Node_Id
;
1060 Proc_Body_Spec
: Node_Id
;
1062 Body_Node
: Node_Id
;
1064 Proc_Decl
: Node_Id
;
1065 Attr_Decl
: Node_Id
;
1067 Statements
: List_Id
;
1068 Local_Statements
: List_Id
;
1069 Remote_Statements
: List_Id
;
1070 Null_Statements
: List_Id
;
1072 Procedure_Name
: constant Name_Id
:= New_Internal_Name
('R');
1074 Stream_Parameter
: constant Entity_Id
:=
1075 Make_Defining_Identifier
1076 (Loc
, New_Internal_Name
('S'));
1078 Object
: constant Entity_Id
:=
1079 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
1082 -- Build the code fragment corresponding to the marshalling of a
1085 Local_Statements
:= New_List
(
1087 Pack_Entity_Into_Stream_Access
(Loc
,
1088 Stream
=> Stream_Parameter
,
1089 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
1091 Pack_Node_Into_Stream_Access
(Loc
,
1092 Stream
=> Stream_Parameter
,
1093 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
1094 Make_Attribute_Reference
(Loc
,
1095 Prefix
=> New_Occurrence_Of
(Object_RPC_Receiver
, Loc
),
1096 Attribute_Name
=> Name_Address
)),
1097 Etyp
=> RTE
(RE_Unsigned_64
)),
1099 Pack_Node_Into_Stream_Access
(Loc
,
1100 Stream
=> Stream_Parameter
,
1101 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
1102 Make_Attribute_Reference
(Loc
,
1104 Make_Explicit_Dereference
(Loc
,
1105 Prefix
=> New_Occurrence_Of
(Object
, Loc
)),
1106 Attribute_Name
=> Name_Address
)),
1107 Etyp
=> RTE
(RE_Unsigned_64
)));
1109 -- Build the code fragment corresponding to the marshalling of
1112 Remote_Statements
:= New_List
(
1114 Pack_Node_Into_Stream_Access
(Loc
,
1115 Stream
=> Stream_Parameter
,
1117 Make_Selected_Component
(Loc
,
1118 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
1119 New_Occurrence_Of
(Object
, Loc
)),
1121 Make_Identifier
(Loc
, Name_Origin
)),
1122 Etyp
=> RTE
(RE_Partition_ID
)),
1124 Pack_Node_Into_Stream_Access
(Loc
,
1125 Stream
=> Stream_Parameter
,
1127 Make_Selected_Component
(Loc
,
1128 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
1129 New_Occurrence_Of
(Object
, Loc
)),
1131 Make_Identifier
(Loc
, Name_Receiver
)),
1132 Etyp
=> RTE
(RE_Unsigned_64
)),
1134 Pack_Node_Into_Stream_Access
(Loc
,
1135 Stream
=> Stream_Parameter
,
1137 Make_Selected_Component
(Loc
,
1138 Prefix
=> Unchecked_Convert_To
(Stub_Type_Access
,
1139 New_Occurrence_Of
(Object
, Loc
)),
1141 Make_Identifier
(Loc
, Name_Addr
)),
1142 Etyp
=> RTE
(RE_Unsigned_64
)));
1144 -- Build the code fragment corresponding to the marshalling of a null
1147 Null_Statements
:= New_List
(
1149 Pack_Entity_Into_Stream_Access
(Loc
,
1150 Stream
=> Stream_Parameter
,
1151 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
1153 Pack_Node_Into_Stream_Access
(Loc
,
1154 Stream
=> Stream_Parameter
,
1155 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
1156 Make_Attribute_Reference
(Loc
,
1157 Prefix
=> New_Occurrence_Of
(Object_RPC_Receiver
, Loc
),
1158 Attribute_Name
=> Name_Address
)),
1159 Etyp
=> RTE
(RE_Unsigned_64
)),
1161 Pack_Node_Into_Stream_Access
(Loc
,
1162 Stream
=> Stream_Parameter
,
1163 Object
=> Make_Integer_Literal
(Loc
, Uint_0
),
1164 Etyp
=> RTE
(RE_Unsigned_64
)));
1166 Statements
:= New_List
(
1167 Make_Implicit_If_Statement
(RACW_Type
,
1170 Left_Opnd
=> New_Occurrence_Of
(Object
, Loc
),
1171 Right_Opnd
=> Make_Null
(Loc
)),
1172 Then_Statements
=> Null_Statements
,
1173 Elsif_Parts
=> New_List
(
1174 Make_Elsif_Part
(Loc
,
1178 Make_Attribute_Reference
(Loc
,
1179 Prefix
=> New_Occurrence_Of
(Object
, Loc
),
1180 Attribute_Name
=> Name_Tag
),
1182 Make_Attribute_Reference
(Loc
,
1183 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
1184 Attribute_Name
=> Name_Tag
)),
1185 Then_Statements
=> Remote_Statements
)),
1186 Else_Statements
=> Local_Statements
));
1189 Make_Procedure_Specification
(Loc
,
1190 Defining_Unit_Name
=>
1191 Make_Defining_Identifier
(Loc
, Procedure_Name
),
1193 Parameter_Specifications
=> New_List
(
1194 Make_Parameter_Specification
(Loc
,
1195 Defining_Identifier
=> Stream_Parameter
,
1197 Make_Access_Definition
(Loc
,
1199 Make_Attribute_Reference
(Loc
,
1201 New_Occurrence_Of
(RTE
(RE_Root_Stream_Type
), Loc
),
1205 Make_Parameter_Specification
(Loc
,
1206 Defining_Identifier
=> Object
,
1209 New_Occurrence_Of
(RACW_Type
, Loc
))));
1212 Make_Subprogram_Declaration
(Loc
, Specification
=> Proc_Spec
);
1215 Make_Attribute_Definition_Clause
(Loc
,
1216 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
1217 Chars
=> Name_Write
,
1219 New_Occurrence_Of
(Defining_Unit_Name
(Proc_Spec
), Loc
));
1222 Make_Procedure_Specification
(Loc
,
1223 Defining_Unit_Name
=>
1224 Make_Defining_Identifier
(Loc
, Procedure_Name
),
1226 Parameter_Specifications
=> New_List
(
1227 Make_Parameter_Specification
(Loc
,
1228 Defining_Identifier
=>
1229 Make_Defining_Identifier
(Loc
, Chars
(Stream_Parameter
)),
1231 Make_Access_Definition
(Loc
,
1233 Make_Attribute_Reference
(Loc
,
1235 New_Occurrence_Of
(RTE
(RE_Root_Stream_Type
), Loc
),
1239 Make_Parameter_Specification
(Loc
,
1240 Defining_Identifier
=>
1241 Make_Defining_Identifier
(Loc
, Chars
(Object
)),
1244 New_Occurrence_Of
(RACW_Type
, Loc
))));
1247 Make_Subprogram_Body
(Loc
,
1248 Specification
=> Proc_Body_Spec
,
1249 Declarations
=> No_List
,
1250 Handled_Statement_Sequence
=>
1251 Make_Handled_Sequence_Of_Statements
(Loc
,
1252 Statements
=> Statements
));
1254 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
1255 Insert_After
(Proc_Decl
, Attr_Decl
);
1256 Append_To
(Declarations
, Body_Node
);
1257 end Add_RACW_Write_Attribute
;
1259 ------------------------------
1260 -- Add_RAS_Access_Attribute --
1261 ------------------------------
1263 procedure Add_RAS_Access_Attribute
(N
: in Node_Id
) is
1264 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
1265 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
1266 -- Ras_Type is the access to subprogram type while Fat_Type points to
1267 -- the record type corresponding to a remote access to subprogram type.
1269 Proc_Decls
: constant List_Id
:= New_List
;
1270 Proc_Statements
: constant List_Id
:= New_List
;
1272 Proc_Spec
: Node_Id
;
1273 Proc_Body
: Node_Id
;
1278 Package_Name
: Node_Id
;
1280 Asynchronous
: Node_Id
;
1281 Return_Value
: Node_Id
;
1283 Loc
: constant Source_Ptr
:= Sloc
(N
);
1285 procedure Set_Field
(Field_Name
: in Name_Id
; Value
: in Node_Id
);
1286 -- Set a field name for the return value
1288 procedure Set_Field
(Field_Name
: in Name_Id
; Value
: in Node_Id
)
1291 Append_To
(Proc_Statements
,
1292 Make_Assignment_Statement
(Loc
,
1294 Make_Selected_Component
(Loc
,
1295 Prefix
=> New_Occurrence_Of
(Return_Value
, Loc
),
1296 Selector_Name
=> Make_Identifier
(Loc
, Field_Name
)),
1297 Expression
=> Value
));
1300 -- Start of processing for Add_RAS_Access_Attribute
1303 Param
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
1304 Package_Name
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1305 Subp_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('N'));
1306 Asynchronous
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('B'));
1307 Return_Value
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
1309 -- Create the object which will be returned of type Fat_Type
1311 Append_To
(Proc_Decls
,
1312 Make_Object_Declaration
(Loc
,
1313 Defining_Identifier
=> Return_Value
,
1314 Object_Definition
=>
1315 New_Occurrence_Of
(Fat_Type
, Loc
)));
1317 -- Initialize the fields of the record type with the appropriate data
1319 Set_Field
(Name_Ras
,
1320 OK_Convert_To
(RTE
(RE_Unsigned_64
), New_Occurrence_Of
(Param
, Loc
)));
1322 Set_Field
(Name_Origin
,
1323 Unchecked_Convert_To
(Standard_Integer
,
1324 Make_Function_Call
(Loc
,
1326 New_Occurrence_Of
(RTE
(RE_Get_Active_Partition_Id
), Loc
),
1327 Parameter_Associations
=> New_List
(
1328 New_Occurrence_Of
(Package_Name
, Loc
)))));
1330 Set_Field
(Name_Receiver
,
1331 Make_Function_Call
(Loc
,
1333 New_Occurrence_Of
(RTE
(RE_Get_RCI_Package_Receiver
), Loc
),
1334 Parameter_Associations
=> New_List
(
1335 New_Occurrence_Of
(Package_Name
, Loc
))));
1337 Set_Field
(Name_Subp_Id
,
1338 New_Occurrence_Of
(Subp_Id
, Loc
));
1340 Set_Field
(Name_Async
,
1341 New_Occurrence_Of
(Asynchronous
, Loc
));
1343 -- Return the newly created value
1345 Append_To
(Proc_Statements
,
1346 Make_Return_Statement
(Loc
,
1348 New_Occurrence_Of
(Return_Value
, Loc
)));
1350 Proc
:= Make_Defining_Identifier
(Loc
, Name_uRAS_Access
);
1353 Make_Function_Specification
(Loc
,
1354 Defining_Unit_Name
=> Proc
,
1355 Parameter_Specifications
=> New_List
(
1356 Make_Parameter_Specification
(Loc
,
1357 Defining_Identifier
=> Param
,
1359 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
1361 Make_Parameter_Specification
(Loc
,
1362 Defining_Identifier
=> Package_Name
,
1364 New_Occurrence_Of
(Standard_String
, Loc
)),
1366 Make_Parameter_Specification
(Loc
,
1367 Defining_Identifier
=> Subp_Id
,
1369 New_Occurrence_Of
(Standard_Natural
, Loc
)),
1371 Make_Parameter_Specification
(Loc
,
1372 Defining_Identifier
=> Asynchronous
,
1374 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
1377 New_Occurrence_Of
(Fat_Type
, Loc
));
1379 -- Set the kind and return type of the function to prevent ambiguities
1380 -- between Ras_Type and Fat_Type in subsequent analysis.
1382 Set_Ekind
(Proc
, E_Function
);
1383 Set_Etype
(Proc
, New_Occurrence_Of
(Fat_Type
, Loc
));
1386 Make_Subprogram_Body
(Loc
,
1387 Specification
=> Proc_Spec
,
1388 Declarations
=> Proc_Decls
,
1389 Handled_Statement_Sequence
=>
1390 Make_Handled_Sequence_Of_Statements
(Loc
,
1391 Statements
=> Proc_Statements
));
1393 Set_TSS
(Fat_Type
, Proc
);
1395 end Add_RAS_Access_Attribute
;
1397 -----------------------------------
1398 -- Add_RAS_Dereference_Attribute --
1399 -----------------------------------
1401 procedure Add_RAS_Dereference_Attribute
(N
: in Node_Id
) is
1402 Loc
: constant Source_Ptr
:= Sloc
(N
);
1404 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
1406 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
1408 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
1410 Proc_Decls
: constant List_Id
:= New_List
;
1411 Proc_Statements
: constant List_Id
:= New_List
;
1413 Inner_Decls
: constant List_Id
:= New_List
;
1414 Inner_Statements
: constant List_Id
:= New_List
;
1416 Direct_Statements
: constant List_Id
:= New_List
;
1420 Proc_Spec
: Node_Id
;
1421 Proc_Body
: Node_Id
;
1423 Param_Specs
: constant List_Id
:= New_List
;
1424 Param_Assoc
: constant List_Id
:= New_List
;
1428 Converted_Ras
: Node_Id
;
1429 Target_Partition
: Node_Id
;
1430 RPC_Receiver
: Node_Id
;
1431 Subprogram_Id
: Node_Id
;
1432 Asynchronous
: Node_Id
;
1434 Is_Function
: constant Boolean :=
1435 Nkind
(Type_Def
) = N_Access_Function_Definition
;
1437 Spec
: constant Node_Id
:= Type_Def
;
1439 Current_Parameter
: Node_Id
;
1442 -- The way to do it is test if the Ras field is non-null and then if
1443 -- the Origin field is equal to the current partition ID (which is in
1444 -- fact Current_Package'Partition_ID). If this is the case, then it
1445 -- is safe to dereference the Ras field directly rather than
1446 -- performing a remote call.
1449 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
1452 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
1454 Append_To
(Proc_Decls
,
1455 Make_Object_Declaration
(Loc
,
1456 Defining_Identifier
=> Target_Partition
,
1457 Constant_Present
=> True,
1458 Object_Definition
=>
1459 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
1461 Unchecked_Convert_To
(RTE
(RE_Partition_ID
),
1462 Make_Selected_Component
(Loc
,
1464 New_Occurrence_Of
(Pointer
, Loc
),
1466 Make_Identifier
(Loc
, Name_Origin
)))));
1469 Make_Selected_Component
(Loc
,
1471 New_Occurrence_Of
(Pointer
, Loc
),
1473 Make_Identifier
(Loc
, Name_Receiver
));
1476 Unchecked_Convert_To
(RTE
(RE_Subprogram_Id
),
1477 Make_Selected_Component
(Loc
,
1479 New_Occurrence_Of
(Pointer
, Loc
),
1481 Make_Identifier
(Loc
, Name_Subp_Id
)));
1483 -- A function is never asynchronous. A procedure may or may not be
1484 -- asynchronous depending on whether a pragma Asynchronous applies
1485 -- on it. Since a RAST may point onto various subprograms, this is
1486 -- only known at runtime so both versions (synchronous and asynchronous)
1487 -- must be built every times it is not a function.
1490 Asynchronous
:= Empty
;
1494 Make_Selected_Component
(Loc
,
1496 New_Occurrence_Of
(Pointer
, Loc
),
1498 Make_Identifier
(Loc
, Name_Async
));
1502 if Present
(Parameter_Specifications
(Type_Def
)) then
1503 Current_Parameter
:= First
(Parameter_Specifications
(Type_Def
));
1505 while Current_Parameter
/= Empty
loop
1506 Append_To
(Param_Specs
,
1507 Make_Parameter_Specification
(Loc
,
1508 Defining_Identifier
=>
1509 Make_Defining_Identifier
(Loc
,
1510 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))),
1511 In_Present
=> In_Present
(Current_Parameter
),
1512 Out_Present
=> Out_Present
(Current_Parameter
),
1515 (Etype
(Parameter_Type
(Current_Parameter
)), Loc
),
1517 New_Copy_Tree
(Expression
(Current_Parameter
))));
1519 Append_To
(Param_Assoc
,
1520 Make_Identifier
(Loc
,
1521 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))));
1523 Next
(Current_Parameter
);
1527 Proc
:= Make_Defining_Identifier
(Loc
, Name_uRAS_Dereference
);
1531 Make_Function_Specification
(Loc
,
1532 Defining_Unit_Name
=> Proc
,
1533 Parameter_Specifications
=> Param_Specs
,
1536 Entity
(Subtype_Mark
(Spec
)), Loc
));
1538 Set_Ekind
(Proc
, E_Function
);
1541 New_Occurrence_Of
(Entity
(Subtype_Mark
(Spec
)), Loc
));
1545 Make_Procedure_Specification
(Loc
,
1546 Defining_Unit_Name
=> Proc
,
1547 Parameter_Specifications
=> Param_Specs
);
1549 Set_Ekind
(Proc
, E_Procedure
);
1550 Set_Etype
(Proc
, Standard_Void_Type
);
1553 -- Build the calling stubs for the dereference of the RAS
1555 Build_General_Calling_Stubs
1556 (Decls
=> Inner_Decls
,
1557 Statements
=> Inner_Statements
,
1558 Target_Partition
=> Target_Partition
,
1559 RPC_Receiver
=> RPC_Receiver
,
1560 Subprogram_Id
=> Subprogram_Id
,
1561 Asynchronous
=> Asynchronous
,
1562 Is_Known_Non_Asynchronous
=> Is_Function
,
1563 Is_Function
=> Is_Function
,
1568 Unchecked_Convert_To
(Ras_Type
,
1569 OK_Convert_To
(RTE
(RE_Address
),
1570 Make_Selected_Component
(Loc
,
1571 Prefix
=> New_Occurrence_Of
(Pointer
, Loc
),
1572 Selector_Name
=> Make_Identifier
(Loc
, Name_Ras
))));
1575 Append_To
(Direct_Statements
,
1576 Make_Return_Statement
(Loc
,
1578 Make_Function_Call
(Loc
,
1580 Make_Explicit_Dereference
(Loc
,
1581 Prefix
=> Converted_Ras
),
1582 Parameter_Associations
=> Param_Assoc
)));
1585 Append_To
(Direct_Statements
,
1586 Make_Procedure_Call_Statement
(Loc
,
1588 Make_Explicit_Dereference
(Loc
,
1589 Prefix
=> Converted_Ras
),
1590 Parameter_Associations
=> Param_Assoc
));
1593 Prepend_To
(Param_Specs
,
1594 Make_Parameter_Specification
(Loc
,
1595 Defining_Identifier
=> Pointer
,
1598 New_Occurrence_Of
(Fat_Type
, Loc
)));
1600 Append_To
(Proc_Statements
,
1601 Make_Implicit_If_Statement
(N
,
1607 Make_Selected_Component
(Loc
,
1608 Prefix
=> New_Occurrence_Of
(Pointer
, Loc
),
1609 Selector_Name
=> Make_Identifier
(Loc
, Name_Ras
)),
1611 Make_Integer_Literal
(Loc
, Uint_0
)),
1616 New_Occurrence_Of
(Target_Partition
, Loc
),
1618 Make_Function_Call
(Loc
,
1620 RTE
(RE_Get_Local_Partition_Id
), Loc
)))),
1625 Else_Statements
=> New_List
(
1626 Make_Block_Statement
(Loc
,
1627 Declarations
=> Inner_Decls
,
1628 Handled_Statement_Sequence
=>
1629 Make_Handled_Sequence_Of_Statements
(Loc
,
1630 Statements
=> Inner_Statements
)))));
1633 Make_Subprogram_Body
(Loc
,
1634 Specification
=> Proc_Spec
,
1635 Declarations
=> Proc_Decls
,
1636 Handled_Statement_Sequence
=>
1637 Make_Handled_Sequence_Of_Statements
(Loc
,
1638 Statements
=> Proc_Statements
));
1640 Set_TSS
(Fat_Type
, Defining_Unit_Name
(Proc_Spec
));
1642 end Add_RAS_Dereference_Attribute
;
1644 -----------------------
1645 -- Add_RAST_Features --
1646 -----------------------
1648 procedure Add_RAST_Features
(Vis_Decl
: Node_Id
) is
1650 -- Do not add attributes more than once in any case. This should
1651 -- be replaced by an assert or this comment removed if we decide
1652 -- that this is normal to be called several times ???
1654 if Present
(TSS
(Equivalent_Type
(Defining_Identifier
1655 (Vis_Decl
)), Name_uRAS_Access
))
1660 Add_RAS_Dereference_Attribute
(Vis_Decl
);
1661 Add_RAS_Access_Attribute
(Vis_Decl
);
1662 end Add_RAST_Features
;
1664 -----------------------------------------
1665 -- Add_Receiving_Stubs_To_Declarations --
1666 -----------------------------------------
1668 procedure Add_Receiving_Stubs_To_Declarations
1669 (Pkg_Spec
: in Node_Id
;
1672 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
1674 Stream_Parameter
: Node_Id
;
1675 Result_Parameter
: Node_Id
;
1677 Pkg_RPC_Receiver
: Node_Id
;
1678 Pkg_RPC_Receiver_Spec
: Node_Id
;
1679 Pkg_RPC_Receiver_Formals
: List_Id
;
1680 Pkg_RPC_Receiver_Decls
: List_Id
;
1681 Pkg_RPC_Receiver_Statements
: List_Id
;
1682 Pkg_RPC_Receiver_Cases
: List_Id
:= New_List
;
1683 Pkg_RPC_Receiver_Body
: Node_Id
;
1684 -- A Pkg_RPC_Receiver is built to decode the request
1687 -- Subprogram_Id as read from the incoming stream
1689 Current_Declaration
: Node_Id
;
1690 Current_Subprogram_Number
: Int
:= 0;
1691 Current_Stubs
: Node_Id
;
1695 Dummy_Register_Name
: Name_Id
;
1696 Dummy_Register_Spec
: Node_Id
;
1697 Dummy_Register_Decl
: Node_Id
;
1698 Dummy_Register_Body
: Node_Id
;
1701 -- Building receiving stubs consist in several operations:
1703 -- - a package RPC receiver must be built. This subprogram
1704 -- will get a Subprogram_Id from the incoming stream
1705 -- and will dispatch the call to the right subprogram
1707 -- - a receiving stub for any subprogram visible in the package
1708 -- spec. This stub will read all the parameters from the stream,
1709 -- and put the result as well as the exception occurrence in the
1712 -- - a dummy package with an empty spec and a body made of an
1713 -- elaboration part, whose job is to register the receiving
1714 -- part of this RCI package on the name server. This is done
1715 -- by calling System.Partition_Interface.Register_Receiving_Stub
1718 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1720 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
1722 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
1725 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
1727 -- The parameters of the package RPC receiver are made of two
1728 -- streams, an input one and an output one.
1730 Pkg_RPC_Receiver_Formals
:= New_List
(
1731 Make_Parameter_Specification
(Loc
,
1732 Defining_Identifier
=> Stream_Parameter
,
1734 Make_Access_Definition
(Loc
,
1736 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
))),
1737 Make_Parameter_Specification
(Loc
,
1738 Defining_Identifier
=> Result_Parameter
,
1740 Make_Access_Definition
(Loc
,
1742 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
))));
1744 Pkg_RPC_Receiver_Spec
:=
1745 Make_Procedure_Specification
(Loc
,
1746 Defining_Unit_Name
=> Pkg_RPC_Receiver
,
1747 Parameter_Specifications
=> Pkg_RPC_Receiver_Formals
);
1749 Pkg_RPC_Receiver_Decls
:= New_List
(
1750 Make_Object_Declaration
(Loc
,
1751 Defining_Identifier
=> Subp_Id
,
1752 Object_Definition
=>
1753 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)));
1755 Pkg_RPC_Receiver_Statements
:= New_List
(
1756 Make_Attribute_Reference
(Loc
,
1758 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
1761 Expressions
=> New_List
(
1762 New_Occurrence_Of
(Stream_Parameter
, Loc
),
1763 New_Occurrence_Of
(Subp_Id
, Loc
))));
1765 -- For each subprogram, the receiving stub will be built and a
1766 -- case statement will be made on the Subprogram_Id to dispatch
1767 -- to the right subprogram.
1769 Current_Declaration
:= First
(Visible_Declarations
(Pkg_Spec
));
1771 while Current_Declaration
/= Empty
loop
1773 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
1774 and then Comes_From_Source
(Current_Declaration
)
1776 pragma Assert
(Current_Subprogram_Number
=
1777 Get_Subprogram_Id
(Defining_Unit_Name
(Specification
(
1778 Current_Declaration
))));
1781 Build_Subprogram_Receiving_Stubs
1782 (Vis_Decl
=> Current_Declaration
,
1784 Nkind
(Specification
(Current_Declaration
)) =
1785 N_Procedure_Specification
1786 and then Is_Asynchronous
1787 (Defining_Unit_Name
(Specification
1788 (Current_Declaration
))));
1790 Append_To
(Decls
, Current_Stubs
);
1792 Analyze
(Current_Stubs
);
1794 Actuals
:= New_List
(New_Occurrence_Of
(Stream_Parameter
, Loc
));
1796 if Nkind
(Specification
(Current_Declaration
))
1797 = N_Function_Specification
1799 not Is_Asynchronous
(
1800 Defining_Entity
(Specification
(Current_Declaration
)))
1802 -- An asynchronous procedure does not want an output parameter
1803 -- since no result and no exception will ever be returned.
1806 New_Occurrence_Of
(Result_Parameter
, Loc
));
1810 Append_To
(Pkg_RPC_Receiver_Cases
,
1811 Make_Case_Statement_Alternative
(Loc
,
1814 Make_Integer_Literal
(Loc
, Current_Subprogram_Number
)),
1818 Make_Procedure_Call_Statement
(Loc
,
1821 Defining_Entity
(Current_Stubs
), Loc
),
1822 Parameter_Associations
=>
1825 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
1828 Next
(Current_Declaration
);
1831 -- If we receive an invalid Subprogram_Id, it is best to do nothing
1832 -- rather than raising an exception since we do not want someone
1833 -- to crash a remote partition by sending invalid subprogram ids.
1834 -- This is consistent with the other parts of the case statement
1835 -- since even in presence of incorrect parameters in the stream,
1836 -- every exception will be caught and (if the subprogram is not an
1837 -- APC) put into the result stream and sent away.
1839 Append_To
(Pkg_RPC_Receiver_Cases
,
1840 Make_Case_Statement_Alternative
(Loc
,
1842 New_List
(Make_Others_Choice
(Loc
)),
1844 New_List
(Make_Null_Statement
(Loc
))));
1846 Append_To
(Pkg_RPC_Receiver_Statements
,
1847 Make_Case_Statement
(Loc
,
1849 New_Occurrence_Of
(Subp_Id
, Loc
),
1850 Alternatives
=> Pkg_RPC_Receiver_Cases
));
1852 Pkg_RPC_Receiver_Body
:=
1853 Make_Subprogram_Body
(Loc
,
1854 Specification
=> Pkg_RPC_Receiver_Spec
,
1855 Declarations
=> Pkg_RPC_Receiver_Decls
,
1856 Handled_Statement_Sequence
=>
1857 Make_Handled_Sequence_Of_Statements
(Loc
,
1858 Statements
=> Pkg_RPC_Receiver_Statements
));
1860 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
1861 Analyze
(Pkg_RPC_Receiver_Body
);
1863 -- Construction of the dummy package used to register the package
1864 -- receiving stubs on the nameserver.
1866 Dummy_Register_Name
:= New_Internal_Name
('P');
1868 Dummy_Register_Spec
:=
1869 Make_Package_Specification
(Loc
,
1870 Defining_Unit_Name
=>
1871 Make_Defining_Identifier
(Loc
, Dummy_Register_Name
),
1872 Visible_Declarations
=> No_List
,
1873 End_Label
=> Empty
);
1875 Dummy_Register_Decl
:=
1876 Make_Package_Declaration
(Loc
,
1877 Specification
=> Dummy_Register_Spec
);
1880 Dummy_Register_Decl
);
1881 Analyze
(Dummy_Register_Decl
);
1883 Dummy_Register_Body
:=
1884 Make_Package_Body
(Loc
,
1885 Defining_Unit_Name
=>
1886 Make_Defining_Identifier
(Loc
, Dummy_Register_Name
),
1887 Declarations
=> No_List
,
1889 Handled_Statement_Sequence
=>
1890 Make_Handled_Sequence_Of_Statements
(Loc
,
1891 Statements
=> New_List
(
1892 Make_Procedure_Call_Statement
(Loc
,
1894 New_Occurrence_Of
(RTE
(RE_Register_Receiving_Stub
), Loc
),
1896 Parameter_Associations
=> New_List
(
1897 Make_String_Literal
(Loc
,
1898 Strval
=> Get_Pkg_Name_String_Id
(Pkg_Spec
)),
1899 Make_Attribute_Reference
(Loc
,
1901 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
1903 Name_Unrestricted_Access
),
1904 Make_Attribute_Reference
(Loc
,
1906 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
1910 Append_To
(Decls
, Dummy_Register_Body
);
1911 Analyze
(Dummy_Register_Body
);
1912 end Add_Receiving_Stubs_To_Declarations
;
1918 procedure Add_Stub_Type
1919 (Designated_Type
: in Entity_Id
;
1920 RACW_Type
: in Entity_Id
;
1922 Stub_Type
: out Entity_Id
;
1923 Stub_Type_Access
: out Entity_Id
;
1924 Object_RPC_Receiver
: out Entity_Id
;
1925 Existing
: out Boolean)
1927 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1929 Stub_Elements
: constant Stub_Structure
:=
1930 Stubs_Table
.Get
(Designated_Type
);
1932 Stub_Type_Declaration
: Node_Id
;
1933 Stub_Type_Access_Declaration
: Node_Id
;
1934 Object_RPC_Receiver_Declaration
: Node_Id
;
1936 RPC_Receiver_Stream
: Entity_Id
;
1937 RPC_Receiver_Result
: Entity_Id
;
1940 if Stub_Elements
/= Empty_Stub_Structure
then
1941 Stub_Type
:= Stub_Elements
.Stub_Type
;
1942 Stub_Type_Access
:= Stub_Elements
.Stub_Type_Access
;
1943 Object_RPC_Receiver
:= Stub_Elements
.Object_RPC_Receiver
;
1950 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1952 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1953 Object_RPC_Receiver
:=
1954 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
1955 RPC_Receiver_Stream
:=
1956 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1957 RPC_Receiver_Result
:=
1958 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
1959 Stubs_Table
.Set
(Designated_Type
,
1960 (Stub_Type
=> Stub_Type
,
1961 Stub_Type_Access
=> Stub_Type_Access
,
1962 Object_RPC_Receiver
=> Object_RPC_Receiver
,
1963 RPC_Receiver_Stream
=> RPC_Receiver_Stream
,
1964 RPC_Receiver_Result
=> RPC_Receiver_Result
,
1965 RACW_Type
=> RACW_Type
));
1967 -- The stub type definition below must match exactly the one in
1968 -- s-parint.ads, since unchecked conversions will be used in
1969 -- s-parint.adb to modify pointers passed to Get_Unique_Remote_Pointer.
1971 Stub_Type_Declaration
:=
1972 Make_Full_Type_Declaration
(Loc
,
1973 Defining_Identifier
=> Stub_Type
,
1975 Make_Record_Definition
(Loc
,
1976 Tagged_Present
=> True,
1977 Limited_Present
=> True,
1979 Make_Component_List
(Loc
,
1980 Component_Items
=> New_List
(
1982 Make_Component_Declaration
(Loc
,
1983 Defining_Identifier
=>
1984 Make_Defining_Identifier
(Loc
, Name_Origin
),
1985 Subtype_Indication
=>
1986 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
)),
1988 Make_Component_Declaration
(Loc
,
1989 Defining_Identifier
=>
1990 Make_Defining_Identifier
(Loc
, Name_Receiver
),
1991 Subtype_Indication
=>
1992 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
1994 Make_Component_Declaration
(Loc
,
1995 Defining_Identifier
=>
1996 Make_Defining_Identifier
(Loc
, Name_Addr
),
1997 Subtype_Indication
=>
1998 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
2000 Make_Component_Declaration
(Loc
,
2001 Defining_Identifier
=>
2002 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
2003 Subtype_Indication
=>
2004 New_Occurrence_Of
(Standard_Boolean
, Loc
))))));
2006 Append_To
(Decls
, Stub_Type_Declaration
);
2007 Analyze
(Stub_Type_Declaration
);
2009 -- This is in no way a type derivation, but we fake it to make
2010 -- sure that the dispatching table gets built with the corresponding
2011 -- primitive operations at the right place.
2013 Derive_Subprograms
(Parent_Type
=> Designated_Type
,
2014 Derived_Type
=> Stub_Type
);
2016 Stub_Type_Access_Declaration
:=
2017 Make_Full_Type_Declaration
(Loc
,
2018 Defining_Identifier
=> Stub_Type_Access
,
2020 Make_Access_To_Object_Definition
(Loc
,
2021 Subtype_Indication
=> New_Occurrence_Of
(Stub_Type
, Loc
)));
2023 Append_To
(Decls
, Stub_Type_Access_Declaration
);
2024 Analyze
(Stub_Type_Access_Declaration
);
2026 Object_RPC_Receiver_Declaration
:=
2027 Make_Subprogram_Declaration
(Loc
,
2028 Make_Procedure_Specification
(Loc
,
2029 Defining_Unit_Name
=> Object_RPC_Receiver
,
2030 Parameter_Specifications
=> New_List
(
2031 Make_Parameter_Specification
(Loc
,
2032 Defining_Identifier
=> RPC_Receiver_Stream
,
2034 Make_Access_Definition
(Loc
,
2036 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
))),
2038 Make_Parameter_Specification
(Loc
,
2039 Defining_Identifier
=> RPC_Receiver_Result
,
2041 Make_Access_Definition
(Loc
,
2044 (RTE
(RE_Params_Stream_Type
), Loc
))))));
2046 Append_To
(Decls
, Object_RPC_Receiver_Declaration
);
2049 ---------------------------------
2050 -- Build_General_Calling_Stubs --
2051 ---------------------------------
2053 procedure Build_General_Calling_Stubs
2055 Statements
: List_Id
;
2056 Target_Partition
: Entity_Id
;
2057 RPC_Receiver
: Node_Id
;
2058 Subprogram_Id
: Node_Id
;
2059 Asynchronous
: Node_Id
:= Empty
;
2060 Is_Known_Asynchronous
: Boolean := False;
2061 Is_Known_Non_Asynchronous
: Boolean := False;
2062 Is_Function
: Boolean;
2064 Object_Type
: Entity_Id
:= Empty
;
2067 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
2069 Stream_Parameter
: Node_Id
;
2070 -- Name of the stream used to transmit parameters to the remote package
2072 Result_Parameter
: Node_Id
;
2073 -- Name of the result parameter (in non-APC cases) which get the
2074 -- result of the remote subprogram.
2076 Exception_Return_Parameter
: Node_Id
;
2077 -- Name of the parameter which will hold the exception sent by the
2078 -- remote subprogram.
2080 Current_Parameter
: Node_Id
;
2081 -- Current parameter being handled
2083 Ordered_Parameters_List
: constant List_Id
:=
2084 Build_Ordered_Parameters_List
(Spec
);
2086 Asynchronous_Statements
: List_Id
:= No_List
;
2087 Non_Asynchronous_Statements
: List_Id
:= No_List
;
2088 -- Statements specifics to the Asynchronous/Non-Asynchronous cases.
2090 Extra_Formal_Statements
: constant List_Id
:= New_List
;
2091 -- List of statements for extra formal parameters. It will appear after
2092 -- the regular statements for writing out parameters.
2095 -- The general form of a calling stub for a given subprogram is:
2097 -- procedure X (...) is
2098 -- P : constant Partition_ID := RCI_Cache.Get_Active_Partition_ID;
2099 -- Stream, Result : aliased System.RPC.Params_Stream_Type (0);
2101 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
2102 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
2103 -- Put_Subprogram_Id_In_Stream;
2104 -- Put_Parameters_In_Stream;
2105 -- Do_RPC (Stream, Result);
2106 -- Read_Exception_Occurrence_From_Result; Raise_It;
2107 -- Read_Out_Parameters_And_Function_Return_From_Stream;
2110 -- There are some variations: Do_APC is called for an asynchronous
2111 -- procedure and the part after the call is completely ommitted
2112 -- as well as the declaration of Result. For a function call,
2113 -- 'Input is always used to read the result even if it is constrained.
2116 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
2119 Make_Object_Declaration
(Loc
,
2120 Defining_Identifier
=> Stream_Parameter
,
2121 Aliased_Present
=> True,
2122 Object_Definition
=>
2123 Make_Subtype_Indication
(Loc
,
2125 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
2127 Make_Index_Or_Discriminant_Constraint
(Loc
,
2129 New_List
(Make_Integer_Literal
(Loc
, 0))))));
2131 if not Is_Known_Asynchronous
then
2133 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
2136 Make_Object_Declaration
(Loc
,
2137 Defining_Identifier
=> Result_Parameter
,
2138 Aliased_Present
=> True,
2139 Object_Definition
=>
2140 Make_Subtype_Indication
(Loc
,
2142 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
2144 Make_Index_Or_Discriminant_Constraint
(Loc
,
2146 New_List
(Make_Integer_Literal
(Loc
, 0))))));
2148 Exception_Return_Parameter
:=
2149 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
2152 Make_Object_Declaration
(Loc
,
2153 Defining_Identifier
=> Exception_Return_Parameter
,
2154 Object_Definition
=>
2155 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
2158 Result_Parameter
:= Empty
;
2159 Exception_Return_Parameter
:= Empty
;
2162 -- Put first the RPC receiver corresponding to the remote package
2164 Append_To
(Statements
,
2165 Make_Attribute_Reference
(Loc
,
2167 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
2168 Attribute_Name
=> Name_Write
,
2169 Expressions
=> New_List
(
2170 Make_Attribute_Reference
(Loc
,
2172 New_Occurrence_Of
(Stream_Parameter
, Loc
),
2177 -- Then put the Subprogram_Id of the subprogram we want to call in
2180 Append_To
(Statements
,
2181 Make_Attribute_Reference
(Loc
,
2183 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
2186 Expressions
=> New_List
(
2187 Make_Attribute_Reference
(Loc
,
2189 New_Occurrence_Of
(Stream_Parameter
, Loc
),
2190 Attribute_Name
=> Name_Access
),
2193 Current_Parameter
:= First
(Ordered_Parameters_List
);
2195 while Current_Parameter
/= Empty
loop
2197 if Is_RACW_Controlling_Formal
(Current_Parameter
, Object_Type
) then
2199 -- In the case of a controlling formal argument, we marshall
2200 -- its addr field rather than the local stub.
2202 Append_To
(Statements
,
2203 Pack_Node_Into_Stream
(Loc
,
2204 Stream
=> Stream_Parameter
,
2206 Make_Selected_Component
(Loc
,
2209 Defining_Identifier
(Current_Parameter
), Loc
),
2211 Make_Identifier
(Loc
, Name_Addr
)),
2212 Etyp
=> RTE
(RE_Unsigned_64
)));
2216 Etyp
: constant Entity_Id
:=
2217 Etype
(Parameter_Type
(Current_Parameter
));
2219 Constrained
: constant Boolean :=
2220 Is_Constrained
(Etyp
)
2221 or else Is_Elementary_Type
(Etyp
);
2224 if In_Present
(Current_Parameter
)
2225 or else not Out_Present
(Current_Parameter
)
2226 or else not Constrained
2228 Append_To
(Statements
,
2229 Make_Attribute_Reference
(Loc
,
2231 New_Occurrence_Of
(Etyp
, Loc
),
2232 Attribute_Name
=> Output_From_Constrained
(Constrained
),
2233 Expressions
=> New_List
(
2234 Make_Attribute_Reference
(Loc
,
2236 New_Occurrence_Of
(Stream_Parameter
, Loc
),
2237 Attribute_Name
=> Name_Access
),
2239 Defining_Identifier
(Current_Parameter
), Loc
))));
2244 -- If the current parameter has a dynamic constrained status,
2245 -- then this status is transmitted as well.
2246 -- This should be done for accessibility as well ???
2248 if Nkind
(Parameter_Type
(Current_Parameter
)) /= N_Access_Definition
2249 and then Need_Extra_Constrained
(Current_Parameter
)
2251 -- In this block, we do not use the extra formal that has been
2252 -- created because it does not exist at the time of expansion
2253 -- when building calling stubs for remote access to subprogram
2254 -- types. We create an extra variable of this type and push it
2255 -- in the stream after the regular parameters.
2258 Extra_Parameter
: constant Entity_Id
:=
2259 Make_Defining_Identifier
2260 (Loc
, New_Internal_Name
('P'));
2264 Make_Object_Declaration
(Loc
,
2265 Defining_Identifier
=> Extra_Parameter
,
2266 Constant_Present
=> True,
2267 Object_Definition
=>
2268 New_Occurrence_Of
(Standard_Boolean
, Loc
),
2270 Make_Attribute_Reference
(Loc
,
2273 Defining_Identifier
(Current_Parameter
), Loc
),
2274 Attribute_Name
=> Name_Constrained
)));
2276 Append_To
(Extra_Formal_Statements
,
2277 Make_Attribute_Reference
(Loc
,
2279 New_Occurrence_Of
(Standard_Boolean
, Loc
),
2282 Expressions
=> New_List
(
2283 Make_Attribute_Reference
(Loc
,
2285 New_Occurrence_Of
(Stream_Parameter
, Loc
),
2288 New_Occurrence_Of
(Extra_Parameter
, Loc
))));
2292 Next
(Current_Parameter
);
2295 -- Append the formal statements list to the statements
2297 Append_List_To
(Statements
, Extra_Formal_Statements
);
2299 if not Is_Known_Non_Asynchronous
then
2301 -- Build the call to System.RPC.Do_APC
2303 Asynchronous_Statements
:= New_List
(
2304 Make_Procedure_Call_Statement
(Loc
,
2306 New_Occurrence_Of
(RTE
(RE_Do_Apc
), Loc
),
2307 Parameter_Associations
=> New_List
(
2308 New_Occurrence_Of
(Target_Partition
, Loc
),
2309 Make_Attribute_Reference
(Loc
,
2311 New_Occurrence_Of
(Stream_Parameter
, Loc
),
2315 Asynchronous_Statements
:= No_List
;
2318 if not Is_Known_Asynchronous
then
2320 -- Build the call to System.RPC.Do_RPC
2322 Non_Asynchronous_Statements
:= New_List
(
2323 Make_Procedure_Call_Statement
(Loc
,
2325 New_Occurrence_Of
(RTE
(RE_Do_Rpc
), Loc
),
2326 Parameter_Associations
=> New_List
(
2327 New_Occurrence_Of
(Target_Partition
, Loc
),
2329 Make_Attribute_Reference
(Loc
,
2331 New_Occurrence_Of
(Stream_Parameter
, Loc
),
2335 Make_Attribute_Reference
(Loc
,
2337 New_Occurrence_Of
(Result_Parameter
, Loc
),
2341 -- Read the exception occurrence from the result stream and
2342 -- reraise it. It does no harm if this is a Null_Occurrence since
2343 -- this does nothing.
2345 Append_To
(Non_Asynchronous_Statements
,
2346 Make_Attribute_Reference
(Loc
,
2348 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
2353 Expressions
=> New_List
(
2354 Make_Attribute_Reference
(Loc
,
2356 New_Occurrence_Of
(Result_Parameter
, Loc
),
2359 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
2361 Append_To
(Non_Asynchronous_Statements
,
2362 Make_Procedure_Call_Statement
(Loc
,
2364 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
2365 Parameter_Associations
=> New_List
(
2366 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
2370 -- If this is a function call, then read the value and return
2371 -- it. The return value is written/read using 'Output/'Input.
2373 Append_To
(Non_Asynchronous_Statements
,
2374 Make_Tag_Check
(Loc
,
2375 Make_Return_Statement
(Loc
,
2377 Make_Attribute_Reference
(Loc
,
2380 Etype
(Subtype_Mark
(Spec
)), Loc
),
2382 Attribute_Name
=> Name_Input
,
2384 Expressions
=> New_List
(
2385 Make_Attribute_Reference
(Loc
,
2387 New_Occurrence_Of
(Result_Parameter
, Loc
),
2388 Attribute_Name
=> Name_Access
))))));
2391 -- Loop around parameters and assign out (or in out) parameters.
2392 -- In the case of RACW, controlling arguments cannot possibly
2393 -- have changed since they are remote, so we do not read them
2396 Current_Parameter
:=
2397 First
(Ordered_Parameters_List
);
2399 while Current_Parameter
/= Empty
loop
2401 if Out_Present
(Current_Parameter
)
2403 Etype
(Parameter_Type
(Current_Parameter
)) /= Object_Type
2405 Append_To
(Non_Asynchronous_Statements
,
2406 Make_Attribute_Reference
(Loc
,
2409 Etype
(Parameter_Type
(Current_Parameter
)), Loc
),
2411 Attribute_Name
=> Name_Read
,
2413 Expressions
=> New_List
(
2414 Make_Attribute_Reference
(Loc
,
2416 New_Occurrence_Of
(Result_Parameter
, Loc
),
2420 Defining_Identifier
(Current_Parameter
), Loc
))));
2423 Next
(Current_Parameter
);
2428 if Is_Known_Asynchronous
then
2429 Append_List_To
(Statements
, Asynchronous_Statements
);
2431 elsif Is_Known_Non_Asynchronous
then
2432 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
2435 pragma Assert
(Asynchronous
/= Empty
);
2436 Prepend_To
(Asynchronous_Statements
,
2437 Make_Attribute_Reference
(Loc
,
2438 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2439 Attribute_Name
=> Name_Write
,
2440 Expressions
=> New_List
(
2441 Make_Attribute_Reference
(Loc
,
2442 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
2443 Attribute_Name
=> Name_Access
),
2444 New_Occurrence_Of
(Standard_True
, Loc
))));
2445 Prepend_To
(Non_Asynchronous_Statements
,
2446 Make_Attribute_Reference
(Loc
,
2447 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
2448 Attribute_Name
=> Name_Write
,
2449 Expressions
=> New_List
(
2450 Make_Attribute_Reference
(Loc
,
2451 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
2452 Attribute_Name
=> Name_Access
),
2453 New_Occurrence_Of
(Standard_False
, Loc
))));
2454 Append_To
(Statements
,
2455 Make_Implicit_If_Statement
(Nod
,
2456 Condition
=> Asynchronous
,
2457 Then_Statements
=> Asynchronous_Statements
,
2458 Else_Statements
=> Non_Asynchronous_Statements
));
2460 end Build_General_Calling_Stubs
;
2462 -----------------------------------
2463 -- Build_Ordered_Parameters_List --
2464 -----------------------------------
2466 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
is
2467 Constrained_List
: List_Id
;
2468 Unconstrained_List
: List_Id
;
2469 Current_Parameter
: Node_Id
;
2472 if not Present
(Parameter_Specifications
(Spec
)) then
2476 Constrained_List
:= New_List
;
2477 Unconstrained_List
:= New_List
;
2479 -- Loop through the parameters and add them to the right list
2481 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2482 while Current_Parameter
/= Empty
loop
2484 if Nkind
(Parameter_Type
(Current_Parameter
)) = N_Access_Definition
2486 Is_Constrained
(Etype
(Parameter_Type
(Current_Parameter
)))
2488 Is_Elementary_Type
(Etype
(Parameter_Type
(Current_Parameter
)))
2490 Append_To
(Constrained_List
, New_Copy
(Current_Parameter
));
2492 Append_To
(Unconstrained_List
, New_Copy
(Current_Parameter
));
2495 Next
(Current_Parameter
);
2498 -- Unconstrained parameters are returned first
2500 Append_List_To
(Unconstrained_List
, Constrained_List
);
2502 return Unconstrained_List
;
2504 end Build_Ordered_Parameters_List
;
2506 ----------------------------------
2507 -- Build_Passive_Partition_Stub --
2508 ----------------------------------
2510 procedure Build_Passive_Partition_Stub
(U
: Node_Id
) is
2514 Loc
: constant Source_Ptr
:= Sloc
(U
);
2515 Dist_OK
: Entity_Id
;
2518 -- Verify that the implementation supports distribution, by accessing
2519 -- a type defined in the proper version of system.rpc
2521 Dist_OK
:= RTE
(RE_Params_Stream_Type
);
2523 -- Use body if present, spec otherwise
2525 if Nkind
(U
) = N_Package_Declaration
then
2526 Pkg_Spec
:= Specification
(U
);
2527 L
:= Visible_Declarations
(Pkg_Spec
);
2529 Pkg_Spec
:= Parent
(Corresponding_Spec
(U
));
2530 L
:= Declarations
(U
);
2534 Make_Procedure_Call_Statement
(Loc
,
2536 New_Occurrence_Of
(RTE
(RE_Register_Passive_Package
), Loc
),
2537 Parameter_Associations
=> New_List
(
2538 Make_String_Literal
(Loc
, Get_Pkg_Name_String_Id
(Pkg_Spec
)),
2539 Make_Attribute_Reference
(Loc
,
2541 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
2546 end Build_Passive_Partition_Stub
;
2548 ------------------------------------
2549 -- Build_Subprogram_Calling_Stubs --
2550 ------------------------------------
2552 function Build_Subprogram_Calling_Stubs
2553 (Vis_Decl
: Node_Id
;
2555 Asynchronous
: Boolean;
2556 Dynamically_Asynchronous
: Boolean := False;
2557 Stub_Type
: Entity_Id
:= Empty
;
2558 Locator
: Entity_Id
:= Empty
;
2559 New_Name
: Name_Id
:= No_Name
)
2562 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
2564 Target_Partition
: Node_Id
;
2565 -- Contains the name of the target partition
2567 Decls
: constant List_Id
:= New_List
;
2568 Statements
: constant List_Id
:= New_List
;
2570 Subp_Spec
: Node_Id
;
2571 -- The specification of the body
2573 Controlling_Parameter
: Entity_Id
:= Empty
;
2574 RPC_Receiver
: Node_Id
;
2576 Asynchronous_Expr
: Node_Id
:= Empty
;
2578 RCI_Locator
: Entity_Id
;
2580 Spec_To_Use
: Node_Id
;
2582 procedure Insert_Partition_Check
(Parameter
: in Node_Id
);
2583 -- Check that the parameter has been elaborated on the same partition
2584 -- than the controlling parameter (E.4(19)).
2586 ----------------------------
2587 -- Insert_Partition_Check --
2588 ----------------------------
2590 procedure Insert_Partition_Check
(Parameter
: in Node_Id
) is
2591 Parameter_Entity
: constant Entity_Id
:=
2592 Defining_Identifier
(Parameter
);
2593 Designated_Object
: Node_Id
;
2594 Condition
: Node_Id
;
2597 -- The expression that will be built is of the form:
2598 -- if not (Parameter in Stub_Type and then
2599 -- Parameter.Origin = Controlling.Origin)
2601 -- raise Constraint_Error;
2604 -- Condition contains the reversed condition. Also, Parameter is
2605 -- dereferenced if it is an access type. We do not check that
2606 -- Parameter is in Stub_Type since such a check has been inserted
2607 -- at the point of call already (a tag check since we have multiple
2608 -- controlling operands).
2610 if Nkind
(Parameter_Type
(Parameter
)) = N_Access_Definition
then
2611 Designated_Object
:=
2612 Make_Explicit_Dereference
(Loc
,
2613 Prefix
=> New_Occurrence_Of
(Parameter_Entity
, Loc
));
2615 Designated_Object
:= New_Occurrence_Of
(Parameter_Entity
, Loc
);
2621 Make_Selected_Component
(Loc
,
2623 New_Occurrence_Of
(Parameter_Entity
, Loc
),
2625 Make_Identifier
(Loc
, Name_Origin
)),
2628 Make_Selected_Component
(Loc
,
2630 New_Occurrence_Of
(Controlling_Parameter
, Loc
),
2632 Make_Identifier
(Loc
, Name_Origin
)));
2635 Make_Raise_Constraint_Error
(Loc
,
2637 Make_Op_Not
(Loc
, Right_Opnd
=> Condition
),
2638 Reason
=> CE_Partition_Check_Failed
));
2639 end Insert_Partition_Check
;
2641 -- Start of processing for Build_Subprogram_Calling_Stubs
2645 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
2647 Subp_Spec
:= Copy_Specification
(Loc
,
2648 Spec
=> Specification
(Vis_Decl
),
2649 New_Name
=> New_Name
);
2651 if Locator
= Empty
then
2652 RCI_Locator
:= RCI_Cache
;
2653 Spec_To_Use
:= Specification
(Vis_Decl
);
2655 RCI_Locator
:= Locator
;
2656 Spec_To_Use
:= Subp_Spec
;
2659 -- Find a controlling argument if we have a stub type. Also check
2660 -- if this subprogram can be made asynchronous.
2662 if Stub_Type
/= Empty
2663 and then Present
(Parameter_Specifications
(Spec_To_Use
))
2666 Current_Parameter
: Node_Id
:=
2667 First
(Parameter_Specifications
2670 while Current_Parameter
/= Empty
loop
2673 Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
)
2675 if Controlling_Parameter
= Empty
then
2676 Controlling_Parameter
:=
2677 Defining_Identifier
(Current_Parameter
);
2679 Insert_Partition_Check
(Current_Parameter
);
2683 Next
(Current_Parameter
);
2688 if Stub_Type
/= Empty
then
2689 pragma Assert
(Controlling_Parameter
/= Empty
);
2692 Make_Object_Declaration
(Loc
,
2693 Defining_Identifier
=> Target_Partition
,
2694 Constant_Present
=> True,
2695 Object_Definition
=>
2696 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
2699 Make_Selected_Component
(Loc
,
2701 New_Occurrence_Of
(Controlling_Parameter
, Loc
),
2703 Make_Identifier
(Loc
, Name_Origin
))));
2706 Make_Selected_Component
(Loc
,
2708 New_Occurrence_Of
(Controlling_Parameter
, Loc
),
2710 Make_Identifier
(Loc
, Name_Receiver
));
2714 Make_Object_Declaration
(Loc
,
2715 Defining_Identifier
=> Target_Partition
,
2716 Constant_Present
=> True,
2717 Object_Definition
=>
2718 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
2721 Make_Function_Call
(Loc
,
2722 Name
=> Make_Selected_Component
(Loc
,
2724 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
2726 Make_Identifier
(Loc
, Name_Get_Active_Partition_ID
)))));
2729 Make_Selected_Component
(Loc
,
2731 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
2733 Make_Identifier
(Loc
, Name_Get_RCI_Package_Receiver
));
2736 if Dynamically_Asynchronous
then
2737 Asynchronous_Expr
:=
2738 Make_Selected_Component
(Loc
,
2740 New_Occurrence_Of
(Controlling_Parameter
, Loc
),
2742 Make_Identifier
(Loc
, Name_Asynchronous
));
2745 Build_General_Calling_Stubs
2747 Statements
=> Statements
,
2748 Target_Partition
=> Target_Partition
,
2749 RPC_Receiver
=> RPC_Receiver
,
2750 Subprogram_Id
=> Make_Integer_Literal
(Loc
, Subp_Id
),
2751 Asynchronous
=> Asynchronous_Expr
,
2752 Is_Known_Asynchronous
=> Asynchronous
2753 and then not Dynamically_Asynchronous
,
2754 Is_Known_Non_Asynchronous
2756 and then not Dynamically_Asynchronous
,
2757 Is_Function
=> Nkind
(Spec_To_Use
) =
2758 N_Function_Specification
,
2759 Spec
=> Spec_To_Use
,
2760 Object_Type
=> Stub_Type
,
2763 RCI_Calling_Stubs_Table
.Set
2764 (Defining_Unit_Name
(Specification
(Vis_Decl
)),
2765 Defining_Unit_Name
(Spec_To_Use
));
2768 Make_Subprogram_Body
(Loc
,
2769 Specification
=> Subp_Spec
,
2770 Declarations
=> Decls
,
2771 Handled_Statement_Sequence
=>
2772 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
));
2773 end Build_Subprogram_Calling_Stubs
;
2775 --------------------------------------
2776 -- Build_Subprogram_Receiving_Stubs --
2777 --------------------------------------
2779 function Build_Subprogram_Receiving_Stubs
2780 (Vis_Decl
: Node_Id
;
2781 Asynchronous
: Boolean;
2782 Dynamically_Asynchronous
: Boolean := False;
2783 Stub_Type
: Entity_Id
:= Empty
;
2784 RACW_Type
: Entity_Id
:= Empty
;
2785 Parent_Primitive
: Entity_Id
:= Empty
)
2788 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
2790 Stream_Parameter
: Node_Id
;
2791 Result_Parameter
: Node_Id
;
2792 -- See explanations of those in Build_Subprogram_Calling_Stubs
2794 Decls
: List_Id
:= New_List
;
2795 -- All the parameters will get declared before calling the real
2796 -- subprograms. Also the out parameters will be declared.
2798 Statements
: List_Id
:= New_List
;
2800 Extra_Formal_Statements
: List_Id
:= New_List
;
2801 -- Statements concerning extra formal parameters
2803 After_Statements
: List_Id
:= New_List
;
2804 -- Statements to be executed after the subprogram call
2806 Inner_Decls
: List_Id
:= No_List
;
2807 -- In case of a function, the inner declarations are needed since
2808 -- the result may be unconstrained.
2810 Excep_Handler
: Node_Id
;
2811 Excep_Choice
: Entity_Id
;
2812 Excep_Code
: List_Id
;
2814 Parameter_List
: List_Id
:= New_List
;
2815 -- List of parameters to be passed to the subprogram.
2817 Current_Parameter
: Node_Id
;
2819 Ordered_Parameters_List
: constant List_Id
:=
2820 Build_Ordered_Parameters_List
(Specification
(Vis_Decl
));
2822 Subp_Spec
: Node_Id
;
2823 -- Subprogram specification
2825 Called_Subprogram
: Node_Id
;
2826 -- The subprogram to call
2828 Null_Raise_Statement
: Node_Id
;
2830 Dynamic_Async
: Entity_Id
;
2833 if RACW_Type
/= Empty
then
2834 Called_Subprogram
:=
2835 New_Occurrence_Of
(Parent_Primitive
, Loc
);
2837 Called_Subprogram
:=
2839 Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
2843 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
2845 if Dynamically_Asynchronous
then
2847 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
2849 Dynamic_Async
:= Empty
;
2852 if not Asynchronous
or else Dynamically_Asynchronous
then
2854 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
2856 -- The first statement after the subprogram call is a statement to
2857 -- writes a Null_Occurrence into the result stream.
2859 Null_Raise_Statement
:=
2860 Make_Attribute_Reference
(Loc
,
2862 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
2863 Attribute_Name
=> Name_Write
,
2864 Expressions
=> New_List
(
2865 New_Occurrence_Of
(Result_Parameter
, Loc
),
2866 New_Occurrence_Of
(RTE
(RE_Null_Occurrence
), Loc
)));
2868 if Dynamically_Asynchronous
then
2869 Null_Raise_Statement
:=
2870 Make_Implicit_If_Statement
(Vis_Decl
,
2872 Make_Op_Not
(Loc
, New_Occurrence_Of
(Dynamic_Async
, Loc
)),
2873 Then_Statements
=> New_List
(Null_Raise_Statement
));
2876 Append_To
(After_Statements
, Null_Raise_Statement
);
2879 Result_Parameter
:= Empty
;
2882 -- Loop through every parameter and get its value from the stream. If
2883 -- the parameter is unconstrained, then the parameter is read using
2884 -- 'Input at the point of declaration.
2886 Current_Parameter
:= First
(Ordered_Parameters_List
);
2888 while Current_Parameter
/= Empty
loop
2892 Constrained
: Boolean;
2894 Expr
: Node_Id
:= Empty
;
2897 Object
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
2898 Set_Ekind
(Object
, E_Variable
);
2901 Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
)
2903 -- We have a controlling formal parameter. Read its address
2904 -- rather than a real object. The address is in Unsigned_64
2907 Etyp
:= RTE
(RE_Unsigned_64
);
2909 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
2913 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
2915 if In_Present
(Current_Parameter
)
2916 or else not Out_Present
(Current_Parameter
)
2917 or else not Constrained
2919 -- If an input parameter is contrained, then its reading is
2920 -- deferred until the beginning of the subprogram body. If
2921 -- it is unconstrained, then an expression is built for
2922 -- the object declaration and the variable is set using
2923 -- 'Input instead of 'Read.
2926 Append_To
(Statements
,
2927 Make_Attribute_Reference
(Loc
,
2928 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
2929 Attribute_Name
=> Name_Read
,
2930 Expressions
=> New_List
(
2931 New_Occurrence_Of
(Stream_Parameter
, Loc
),
2932 New_Occurrence_Of
(Object
, Loc
))));
2935 Expr
:= Input_With_Tag_Check
(Loc
,
2937 Stream
=> Stream_Parameter
);
2938 Append_To
(Decls
, Expr
);
2939 Expr
:= Make_Function_Call
(Loc
,
2940 New_Occurrence_Of
(Defining_Unit_Name
2941 (Specification
(Expr
)), Loc
));
2945 -- If we do not have to output the current parameter, then
2946 -- it can well be flagged as constant. This may allow further
2947 -- optimizations done by the back end.
2950 Make_Object_Declaration
(Loc
,
2951 Defining_Identifier
=> Object
,
2953 not Constrained
and then not Out_Present
(Current_Parameter
),
2954 Object_Definition
=>
2955 New_Occurrence_Of
(Etyp
, Loc
),
2956 Expression
=> Expr
));
2958 -- An out parameter may be written back using a 'Write
2959 -- attribute instead of a 'Output because it has been
2960 -- constrained by the parameter given to the caller. Note that
2961 -- out controlling arguments in the case of a RACW are not put
2962 -- back in the stream because the pointer on them has not
2965 if Out_Present
(Current_Parameter
)
2967 Etype
(Parameter_Type
(Current_Parameter
)) /= Stub_Type
2969 Append_To
(After_Statements
,
2970 Make_Attribute_Reference
(Loc
,
2971 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
2972 Attribute_Name
=> Name_Write
,
2973 Expressions
=> New_List
(
2974 New_Occurrence_Of
(Result_Parameter
, Loc
),
2975 New_Occurrence_Of
(Object
, Loc
))));
2979 Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
)
2982 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
2985 Append_To
(Parameter_List
,
2986 Make_Parameter_Association
(Loc
,
2989 Defining_Identifier
(Current_Parameter
), Loc
),
2990 Explicit_Actual_Parameter
=>
2991 Make_Explicit_Dereference
(Loc
,
2992 Unchecked_Convert_To
(RACW_Type
,
2993 OK_Convert_To
(RTE
(RE_Address
),
2994 New_Occurrence_Of
(Object
, Loc
))))));
2996 Append_To
(Parameter_List
,
2997 Make_Parameter_Association
(Loc
,
3000 Defining_Identifier
(Current_Parameter
), Loc
),
3001 Explicit_Actual_Parameter
=>
3002 Unchecked_Convert_To
(RACW_Type
,
3003 OK_Convert_To
(RTE
(RE_Address
),
3004 New_Occurrence_Of
(Object
, Loc
)))));
3007 Append_To
(Parameter_List
,
3008 Make_Parameter_Association
(Loc
,
3011 Defining_Identifier
(Current_Parameter
), Loc
),
3012 Explicit_Actual_Parameter
=>
3013 New_Occurrence_Of
(Object
, Loc
)));
3016 -- If the current parameter needs an extra formal, then read it
3017 -- from the stream and set the corresponding semantic field in
3018 -- the variable. If the kind of the parameter identifier is
3019 -- E_Void, then this is a compiler generated parameter that
3020 -- doesn't need an extra constrained status.
3022 -- The case of Extra_Accessibility should also be handled ???
3024 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
3027 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
3029 Present
(Extra_Constrained
3030 (Defining_Identifier
(Current_Parameter
)))
3033 Extra_Parameter
: constant Entity_Id
:=
3035 (Defining_Identifier
3036 (Current_Parameter
));
3038 Formal_Entity
: constant Entity_Id
:=
3039 Make_Defining_Identifier
3040 (Loc
, Chars
(Extra_Parameter
));
3042 Formal_Type
: constant Entity_Id
:=
3043 Etype
(Extra_Parameter
);
3047 Make_Object_Declaration
(Loc
,
3048 Defining_Identifier
=> Formal_Entity
,
3049 Object_Definition
=>
3050 New_Occurrence_Of
(Formal_Type
, Loc
)));
3052 Append_To
(Extra_Formal_Statements
,
3053 Make_Attribute_Reference
(Loc
,
3054 Prefix
=> New_Occurrence_Of
(Formal_Type
, Loc
),
3055 Attribute_Name
=> Name_Read
,
3056 Expressions
=> New_List
(
3057 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3058 New_Occurrence_Of
(Formal_Entity
, Loc
))));
3059 Set_Extra_Constrained
(Object
, Formal_Entity
);
3064 Next
(Current_Parameter
);
3067 -- Append the formal statements list at the end of regular statements
3069 Append_List_To
(Statements
, Extra_Formal_Statements
);
3071 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
3073 -- The remote subprogram is a function. We build an inner block to
3074 -- be able to hold a potentially unconstrained result in a variable.
3077 Etyp
: constant Entity_Id
:=
3078 Etype
(Subtype_Mark
(Specification
(Vis_Decl
)));
3079 Result
: constant Node_Id
:=
3080 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
3083 Inner_Decls
:= New_List
(
3084 Make_Object_Declaration
(Loc
,
3085 Defining_Identifier
=> Result
,
3086 Constant_Present
=> True,
3087 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
3089 Make_Function_Call
(Loc
,
3090 Name
=> Called_Subprogram
,
3091 Parameter_Associations
=> Parameter_List
)));
3093 Append_To
(After_Statements
,
3094 Make_Attribute_Reference
(Loc
,
3095 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
3096 Attribute_Name
=> Name_Output
,
3097 Expressions
=> New_List
(
3098 New_Occurrence_Of
(Result_Parameter
, Loc
),
3099 New_Occurrence_Of
(Result
, Loc
))));
3102 Append_To
(Statements
,
3103 Make_Block_Statement
(Loc
,
3104 Declarations
=> Inner_Decls
,
3105 Handled_Statement_Sequence
=>
3106 Make_Handled_Sequence_Of_Statements
(Loc
,
3107 Statements
=> After_Statements
)));
3110 -- The remote subprogram is a procedure. We do not need any inner
3111 -- block in this case.
3113 if Dynamically_Asynchronous
then
3115 Make_Object_Declaration
(Loc
,
3116 Defining_Identifier
=> Dynamic_Async
,
3117 Object_Definition
=>
3118 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
3120 Append_To
(Statements
,
3121 Make_Attribute_Reference
(Loc
,
3122 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
3123 Attribute_Name
=> Name_Read
,
3124 Expressions
=> New_List
(
3125 New_Occurrence_Of
(Stream_Parameter
, Loc
),
3126 New_Occurrence_Of
(Dynamic_Async
, Loc
))));
3129 Append_To
(Statements
,
3130 Make_Procedure_Call_Statement
(Loc
,
3131 Name
=> Called_Subprogram
,
3132 Parameter_Associations
=> Parameter_List
));
3134 Append_List_To
(Statements
, After_Statements
);
3138 if Asynchronous
and then not Dynamically_Asynchronous
then
3140 -- An asynchronous procedure does not want a Result
3141 -- parameter. Also, we put an exception handler with an others
3142 -- clause that does nothing.
3145 Make_Procedure_Specification
(Loc
,
3146 Defining_Unit_Name
=>
3147 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
3148 Parameter_Specifications
=> New_List
(
3149 Make_Parameter_Specification
(Loc
,
3150 Defining_Identifier
=> Stream_Parameter
,
3152 Make_Access_Definition
(Loc
,
3154 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
)))));
3157 Make_Exception_Handler
(Loc
,
3158 Exception_Choices
=>
3159 New_List
(Make_Others_Choice
(Loc
)),
3160 Statements
=> New_List
(
3161 Make_Null_Statement
(Loc
)));
3164 -- In the other cases, if an exception is raised, then the
3165 -- exception occurrence is copied into the output stream and
3166 -- no other output parameter is written.
3169 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
3171 Excep_Code
:= New_List
(
3172 Make_Attribute_Reference
(Loc
,
3174 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
3175 Attribute_Name
=> Name_Write
,
3176 Expressions
=> New_List
(
3177 New_Occurrence_Of
(Result_Parameter
, Loc
),
3178 New_Occurrence_Of
(Excep_Choice
, Loc
))));
3180 if Dynamically_Asynchronous
then
3181 Excep_Code
:= New_List
(
3182 Make_Implicit_If_Statement
(Vis_Decl
,
3183 Condition
=> Make_Op_Not
(Loc
,
3184 New_Occurrence_Of
(Dynamic_Async
, Loc
)),
3185 Then_Statements
=> Excep_Code
));
3189 Make_Exception_Handler
(Loc
,
3190 Choice_Parameter
=> Excep_Choice
,
3191 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
3192 Statements
=> Excep_Code
);
3195 Make_Procedure_Specification
(Loc
,
3196 Defining_Unit_Name
=>
3197 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
3199 Parameter_Specifications
=> New_List
(
3200 Make_Parameter_Specification
(Loc
,
3201 Defining_Identifier
=> Stream_Parameter
,
3203 Make_Access_Definition
(Loc
,
3205 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
))),
3207 Make_Parameter_Specification
(Loc
,
3208 Defining_Identifier
=> Result_Parameter
,
3210 Make_Access_Definition
(Loc
,
3212 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
)))));
3216 Make_Subprogram_Body
(Loc
,
3217 Specification
=> Subp_Spec
,
3218 Declarations
=> Decls
,
3219 Handled_Statement_Sequence
=>
3220 Make_Handled_Sequence_Of_Statements
(Loc
,
3221 Statements
=> Statements
,
3222 Exception_Handlers
=> New_List
(Excep_Handler
)));
3224 end Build_Subprogram_Receiving_Stubs
;
3226 ------------------------
3227 -- Copy_Specification --
3228 ------------------------
3230 function Copy_Specification
3233 Object_Type
: Entity_Id
:= Empty
;
3234 Stub_Type
: Entity_Id
:= Empty
;
3235 New_Name
: Name_Id
:= No_Name
)
3238 Parameters
: List_Id
:= No_List
;
3240 Current_Parameter
: Node_Id
;
3241 Current_Type
: Node_Id
;
3243 Name_For_New_Spec
: Name_Id
;
3245 New_Identifier
: Entity_Id
;
3248 if New_Name
= No_Name
then
3249 Name_For_New_Spec
:= Chars
(Defining_Unit_Name
(Spec
));
3251 Name_For_New_Spec
:= New_Name
;
3254 if Present
(Parameter_Specifications
(Spec
)) then
3256 Parameters
:= New_List
;
3257 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
3259 while Current_Parameter
/= Empty
loop
3261 Current_Type
:= Parameter_Type
(Current_Parameter
);
3263 if Nkind
(Current_Type
) = N_Access_Definition
then
3264 if Object_Type
= Empty
then
3266 Make_Access_Definition
(Loc
,
3268 New_Occurrence_Of
(Etype
(
3269 Subtype_Mark
(Current_Type
)), Loc
));
3272 (Root_Type
(Etype
(Subtype_Mark
(Current_Type
)))
3273 = Root_Type
(Object_Type
));
3275 Make_Access_Definition
(Loc
,
3276 Subtype_Mark
=> New_Occurrence_Of
(Stub_Type
, Loc
));
3279 elsif Object_Type
/= Empty
3280 and then Etype
(Current_Type
) = Object_Type
3282 Current_Type
:= New_Occurrence_Of
(Stub_Type
, Loc
);
3285 Current_Type
:= New_Occurrence_Of
(Etype
(Current_Type
), Loc
);
3288 New_Identifier
:= Make_Defining_Identifier
(Loc
,
3289 Chars
(Defining_Identifier
(Current_Parameter
)));
3291 Append_To
(Parameters
,
3292 Make_Parameter_Specification
(Loc
,
3293 Defining_Identifier
=> New_Identifier
,
3294 Parameter_Type
=> Current_Type
,
3295 In_Present
=> In_Present
(Current_Parameter
),
3296 Out_Present
=> Out_Present
(Current_Parameter
),
3298 New_Copy_Tree
(Expression
(Current_Parameter
))));
3300 Next
(Current_Parameter
);
3304 if Nkind
(Spec
) = N_Function_Specification
then
3306 Make_Function_Specification
(Loc
,
3307 Defining_Unit_Name
=>
3308 Make_Defining_Identifier
(Loc
,
3309 Chars
=> Name_For_New_Spec
),
3310 Parameter_Specifications
=> Parameters
,
3312 New_Occurrence_Of
(Etype
(Subtype_Mark
(Spec
)), Loc
));
3316 Make_Procedure_Specification
(Loc
,
3317 Defining_Unit_Name
=>
3318 Make_Defining_Identifier
(Loc
,
3319 Chars
=> Name_For_New_Spec
),
3320 Parameter_Specifications
=> Parameters
);
3323 end Copy_Specification
;
3325 ---------------------------
3326 -- Could_Be_Asynchronous --
3327 ---------------------------
3329 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean is
3330 Current_Parameter
: Node_Id
;
3333 if Present
(Parameter_Specifications
(Spec
)) then
3334 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
3335 while Current_Parameter
/= Empty
loop
3336 if Out_Present
(Current_Parameter
) then
3340 Next
(Current_Parameter
);
3345 end Could_Be_Asynchronous
;
3347 ---------------------------------------------
3348 -- Expand_All_Calls_Remote_Subprogram_Call --
3349 ---------------------------------------------
3351 procedure Expand_All_Calls_Remote_Subprogram_Call
(N
: in Node_Id
) is
3352 Called_Subprogram
: constant Entity_Id
:= Entity
(Name
(N
));
3353 RCI_Package
: constant Entity_Id
:= Scope
(Called_Subprogram
);
3354 Loc
: constant Source_Ptr
:= Sloc
(N
);
3355 RCI_Locator
: Node_Id
;
3356 RCI_Cache
: Entity_Id
;
3357 Calling_Stubs
: Node_Id
;
3358 E_Calling_Stubs
: Entity_Id
;
3361 E_Calling_Stubs
:= RCI_Calling_Stubs_Table
.Get
(Called_Subprogram
);
3363 if E_Calling_Stubs
= Empty
then
3364 RCI_Cache
:= RCI_Locator_Table
.Get
(RCI_Package
);
3366 if RCI_Cache
= Empty
then
3369 (Loc
, Specification
(Unit_Declaration_Node
(RCI_Package
)));
3370 Prepend_To
(Current_Sem_Unit_Declarations
, RCI_Locator
);
3372 -- The RCI_Locator package is inserted at the top level in the
3373 -- current unit, and must appear in the proper scope, so that it
3374 -- is not prematurely removed by the GCC back-end.
3377 Scop
: Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
3380 if Ekind
(Scop
) = E_Package_Body
then
3381 New_Scope
(Spec_Entity
(Scop
));
3383 elsif Ekind
(Scop
) = E_Subprogram_Body
then
3385 (Corresponding_Spec
(Unit_Declaration_Node
(Scop
)));
3391 Analyze
(RCI_Locator
);
3395 RCI_Cache
:= Defining_Unit_Name
(RCI_Locator
);
3398 RCI_Locator
:= Parent
(RCI_Cache
);
3401 Calling_Stubs
:= Build_Subprogram_Calling_Stubs
3402 (Vis_Decl
=> Parent
(Parent
(Called_Subprogram
)),
3403 Subp_Id
=> Get_Subprogram_Id
(Called_Subprogram
),
3404 Asynchronous
=> Nkind
(N
) = N_Procedure_Call_Statement
3406 Is_Asynchronous
(Called_Subprogram
),
3407 Locator
=> RCI_Cache
,
3408 New_Name
=> New_Internal_Name
('S'));
3409 Insert_After
(RCI_Locator
, Calling_Stubs
);
3410 Analyze
(Calling_Stubs
);
3411 E_Calling_Stubs
:= Defining_Unit_Name
(Specification
(Calling_Stubs
));
3414 Rewrite
(Name
(N
), New_Occurrence_Of
(E_Calling_Stubs
, Loc
));
3415 end Expand_All_Calls_Remote_Subprogram_Call
;
3417 ---------------------------------
3418 -- Expand_Calling_Stubs_Bodies --
3419 ---------------------------------
3421 procedure Expand_Calling_Stubs_Bodies
(Unit_Node
: in Node_Id
) is
3422 Spec
: constant Node_Id
:= Specification
(Unit_Node
);
3423 Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
3426 New_Scope
(Scope_Of_Spec
(Spec
));
3427 Add_Calling_Stubs_To_Declarations
(Specification
(Unit_Node
),
3430 end Expand_Calling_Stubs_Bodies
;
3432 -----------------------------------
3433 -- Expand_Receiving_Stubs_Bodies --
3434 -----------------------------------
3436 procedure Expand_Receiving_Stubs_Bodies
(Unit_Node
: in Node_Id
) is
3442 if Nkind
(Unit_Node
) = N_Package_Declaration
then
3443 Spec
:= Specification
(Unit_Node
);
3444 Decls
:= Visible_Declarations
(Spec
);
3445 New_Scope
(Scope_Of_Spec
(Spec
));
3446 Add_Receiving_Stubs_To_Declarations
(Spec
, Decls
);
3450 Package_Specification_Of_Scope
(Corresponding_Spec
(Unit_Node
));
3451 Decls
:= Declarations
(Unit_Node
);
3452 New_Scope
(Scope_Of_Spec
(Unit_Node
));
3454 Add_Receiving_Stubs_To_Declarations
(Spec
, Temp
);
3455 Insert_List_Before
(First
(Decls
), Temp
);
3459 end Expand_Receiving_Stubs_Bodies
;
3461 ----------------------------
3462 -- Get_Pkg_Name_string_Id --
3463 ----------------------------
3465 function Get_Pkg_Name_String_Id
(Decl_Node
: Node_Id
) return String_Id
is
3466 Unit_Name_Id
: Unit_Name_Type
:= Get_Unit_Name
(Decl_Node
);
3469 Get_Unit_Name_String
(Unit_Name_Id
);
3471 -- Remove seven last character (" (spec)" or " (body)").
3473 Name_Len
:= Name_Len
- 7;
3474 pragma Assert
(Name_Buffer
(Name_Len
+ 1) = ' ');
3476 return Get_String_Id
(Name_Buffer
(1 .. Name_Len
));
3477 end Get_Pkg_Name_String_Id
;
3483 function Get_String_Id
(Val
: String) return String_Id
is
3486 Store_String_Chars
(Val
);
3494 function Hash
(F
: Entity_Id
) return Hash_Index
is
3496 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
3499 --------------------------
3500 -- Input_With_Tag_Check --
3501 --------------------------
3503 function Input_With_Tag_Check
3505 Var_Type
: Entity_Id
;
3511 Make_Subprogram_Body
(Loc
,
3512 Specification
=> Make_Function_Specification
(Loc
,
3513 Defining_Unit_Name
=>
3514 Make_Defining_Identifier
(Loc
, New_Internal_Name
('S')),
3515 Subtype_Mark
=> New_Occurrence_Of
(Var_Type
, Loc
)),
3516 Declarations
=> No_List
,
3517 Handled_Statement_Sequence
=>
3518 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
3519 Make_Tag_Check
(Loc
,
3520 Make_Return_Statement
(Loc
,
3521 Make_Attribute_Reference
(Loc
,
3522 Prefix
=> New_Occurrence_Of
(Var_Type
, Loc
),
3523 Attribute_Name
=> Name_Input
,
3525 New_List
(New_Occurrence_Of
(Stream
, Loc
))))))));
3526 end Input_With_Tag_Check
;
3528 --------------------------------
3529 -- Is_RACW_Controlling_Formal --
3530 --------------------------------
3532 function Is_RACW_Controlling_Formal
3533 (Parameter
: Node_Id
;
3534 Stub_Type
: Entity_Id
)
3540 -- If the kind of the parameter is E_Void, then it is not a
3541 -- controlling formal (this can happen in the context of RAS).
3543 if Ekind
(Defining_Identifier
(Parameter
)) = E_Void
then
3547 -- If the parameter is not a controlling formal, then it cannot
3548 -- be possibly a RACW_Controlling_Formal.
3550 if not Is_Controlling_Formal
(Defining_Identifier
(Parameter
)) then
3554 Typ
:= Parameter_Type
(Parameter
);
3555 return (Nkind
(Typ
) = N_Access_Definition
3556 and then Etype
(Subtype_Mark
(Typ
)) = Stub_Type
)
3557 or else Etype
(Typ
) = Stub_Type
;
3558 end Is_RACW_Controlling_Formal
;
3560 --------------------
3561 -- Make_Tag_Check --
3562 --------------------
3564 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
is
3565 Occ
: constant Entity_Id
:=
3566 Make_Defining_Identifier
(Loc
, New_Internal_Name
('E'));
3569 return Make_Block_Statement
(Loc
,
3570 Handled_Statement_Sequence
=>
3571 Make_Handled_Sequence_Of_Statements
(Loc
,
3572 Statements
=> New_List
(N
),
3574 Exception_Handlers
=> New_List
(
3575 Make_Exception_Handler
(Loc
,
3576 Choice_Parameter
=> Occ
,
3578 Exception_Choices
=>
3579 New_List
(New_Occurrence_Of
(RTE
(RE_Tag_Error
), Loc
)),
3582 New_List
(Make_Procedure_Call_Statement
(Loc
,
3584 (RTE
(RE_Raise_Program_Error_Unknown_Tag
), Loc
),
3585 New_List
(New_Occurrence_Of
(Occ
, Loc
))))))));
3588 ----------------------------
3589 -- Need_Extra_Constrained --
3590 ----------------------------
3592 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean is
3593 Etyp
: constant Entity_Id
:= Etype
(Parameter_Type
(Parameter
));
3596 return Out_Present
(Parameter
)
3597 and then Has_Discriminants
(Etyp
)
3598 and then not Is_Constrained
(Etyp
)
3599 and then not Is_Indefinite_Subtype
(Etyp
);
3600 end Need_Extra_Constrained
;
3602 ------------------------------------
3603 -- Pack_Entity_Into_Stream_Access --
3604 ------------------------------------
3606 function Pack_Entity_Into_Stream_Access
3610 Etyp
: Entity_Id
:= Empty
)
3616 if Etyp
/= Empty
then
3619 Typ
:= Etype
(Object
);
3623 Pack_Node_Into_Stream_Access
(Loc
,
3625 Object
=> New_Occurrence_Of
(Object
, Loc
),
3627 end Pack_Entity_Into_Stream_Access
;
3629 ---------------------------
3630 -- Pack_Node_Into_Stream --
3631 ---------------------------
3633 function Pack_Node_Into_Stream
3640 Write_Attribute
: Name_Id
:= Name_Write
;
3643 if not Is_Constrained
(Etyp
) then
3644 Write_Attribute
:= Name_Output
;
3648 Make_Attribute_Reference
(Loc
,
3649 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
3650 Attribute_Name
=> Write_Attribute
,
3651 Expressions
=> New_List
(
3652 Make_Attribute_Reference
(Loc
,
3653 Prefix
=> New_Occurrence_Of
(Stream
, Loc
),
3654 Attribute_Name
=> Name_Access
),
3656 end Pack_Node_Into_Stream
;
3658 ----------------------------------
3659 -- Pack_Node_Into_Stream_Access --
3660 ----------------------------------
3662 function Pack_Node_Into_Stream_Access
3669 Write_Attribute
: Name_Id
:= Name_Write
;
3672 if not Is_Constrained
(Etyp
) then
3673 Write_Attribute
:= Name_Output
;
3677 Make_Attribute_Reference
(Loc
,
3678 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
3679 Attribute_Name
=> Write_Attribute
,
3680 Expressions
=> New_List
(
3681 New_Occurrence_Of
(Stream
, Loc
),
3683 end Pack_Node_Into_Stream_Access
;
3685 -------------------------------
3686 -- RACW_Type_Is_Asynchronous --
3687 -------------------------------
3689 procedure RACW_Type_Is_Asynchronous
(RACW_Type
: in Entity_Id
) is
3690 N
: constant Node_Id
:= Asynchronous_Flags_Table
.Get
(RACW_Type
);
3691 pragma Assert
(N
/= Empty
);
3694 Replace
(N
, New_Occurrence_Of
(Standard_True
, Sloc
(N
)));
3695 end RACW_Type_Is_Asynchronous
;
3697 -------------------------
3698 -- RCI_Package_Locator --
3699 -------------------------
3701 function RCI_Package_Locator
3703 Package_Spec
: Node_Id
)
3706 Inst
: constant Node_Id
:=
3707 Make_Package_Instantiation
(Loc
,
3708 Defining_Unit_Name
=>
3709 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R')),
3711 New_Occurrence_Of
(RTE
(RE_RCI_Info
), Loc
),
3712 Generic_Associations
=> New_List
(
3713 Make_Generic_Association
(Loc
,
3715 Make_Identifier
(Loc
, Name_RCI_Name
),
3716 Explicit_Generic_Actual_Parameter
=>
3717 Make_String_Literal
(Loc
,
3718 Strval
=> Get_Pkg_Name_String_Id
(Package_Spec
)))));
3721 RCI_Locator_Table
.Set
(Defining_Unit_Name
(Package_Spec
),
3722 Defining_Unit_Name
(Inst
));
3724 end RCI_Package_Locator
;
3726 -----------------------------------------------
3727 -- Remote_Types_Tagged_Full_View_Encountered --
3728 -----------------------------------------------
3730 procedure Remote_Types_Tagged_Full_View_Encountered
3731 (Full_View
: in Entity_Id
)
3733 Stub_Elements
: constant Stub_Structure
:=
3734 Stubs_Table
.Get
(Full_View
);
3737 if Stub_Elements
/= Empty_Stub_Structure
then
3738 Add_RACW_Primitive_Declarations_And_Bodies
3740 Parent
(Declaration_Node
(Stub_Elements
.Object_RPC_Receiver
)),
3741 List_Containing
(Declaration_Node
(Full_View
)));
3743 end Remote_Types_Tagged_Full_View_Encountered
;
3749 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
is
3750 Unit_Name
: Node_Id
:= Defining_Unit_Name
(Spec
);
3753 while Nkind
(Unit_Name
) /= N_Defining_Identifier
loop
3754 Unit_Name
:= Defining_Identifier
(Unit_Name
);