1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Exp_Strm; use Exp_Strm;
31 with Exp_Tss; use Exp_Tss;
32 with Exp_Util; use Exp_Util;
33 with GNAT.HTable; use GNAT.HTable;
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
59 -- type Stub is tagged record
60 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
63 -- is built. This type has two properties:
65 -- 1) Since it has the same structure than RACW_Stub_Type, it can be
66 -- converted to and from this type to make it suitable for
67 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
68 -- to avoid memory leaks when the same remote object arrive on the
69 -- same partition through several paths;
71 -- 2) It also has the same dispatching table as the designated type D,
72 -- and thus can be used as an object designated by a value of type
73 -- R on any partition other than the one on which the object has
74 -- been created, since only dispatching calls will be performed and
75 -- the fields themselves will not be used. We call Derive_Subprograms
76 -- to fake half a derivation to ensure that the subprograms do have
77 -- the same dispatching table.
79 -----------------------
80 -- Local subprograms --
81 -----------------------
83 function Get_Subprogram_Id (E : Entity_Id) return Int;
84 -- Given a subprogram defined in a RCI package, get its subprogram id
85 -- which will be used for remote calls.
87 procedure Build_General_Calling_Stubs
89 Statements : in List_Id;
90 Target_Partition : in Entity_Id;
91 RPC_Receiver : in Node_Id;
92 Subprogram_Id : in Node_Id;
93 Asynchronous : in Node_Id := Empty;
94 Is_Known_Asynchronous : in Boolean := False;
95 Is_Known_Non_Asynchronous : in Boolean := False;
96 Is_Function : in Boolean;
98 Object_Type : in Entity_Id := Empty;
100 -- Build calling stubs for general purpose. The parameters are:
101 -- Decls : a place to put declarations
102 -- Statements : a place to put statements
103 -- Target_Partition : a node containing the target partition that must
104 -- be a N_Defining_Identifier
105 -- RPC_Receiver : a node containing the RPC receiver
106 -- Subprogram_Id : a node containing the subprogram ID
107 -- Asynchronous : True if an APC must be made instead of an RPC.
108 -- The value needs not be supplied if one of the
109 -- Is_Known_... is True.
110 -- Is_Known_Async... : True if we know that this is asynchronous
111 -- Is_Known_Non_A... : True if we know that this is not asynchronous
112 -- Spec : a node with a Parameter_Specifications and
113 -- a Subtype_Mark if applicable
114 -- Object_Type : in case of a RACW, parameters of type access to
115 -- Object_Type will be marshalled using the
116 -- address of this object (the addr field) rather
117 -- than using the 'Write on the object itself
118 -- Nod : used to provide sloc for generated code
120 function Build_Subprogram_Calling_Stubs
123 Asynchronous : Boolean;
124 Dynamically_Asynchronous : Boolean := False;
125 Stub_Type : Entity_Id := Empty;
126 Locator : Entity_Id := Empty;
127 New_Name : Name_Id := No_Name)
129 -- Build the calling stub for a given subprogram with the subprogram ID
130 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
131 -- parameters of this type will be marshalled instead of the object
132 -- itself. It will then be converted into Stub_Type before performing
133 -- the real call. If Dynamically_Asynchronous is True, then it will be
134 -- computed at run time whether the call is asynchronous or not.
135 -- Otherwise, the value of the formal Asynchronous will be used.
136 -- If Locator is not Empty, it will be used instead of RCI_Cache. If
137 -- New_Name is given, then it will be used instead of the original name.
139 function Build_Subprogram_Receiving_Stubs
141 Asynchronous : Boolean;
142 Dynamically_Asynchronous : Boolean := False;
143 Stub_Type : Entity_Id := Empty;
144 RACW_Type : Entity_Id := Empty;
145 Parent_Primitive : Entity_Id := Empty)
147 -- Build the receiving stub for a given subprogram. The subprogram
148 -- declaration is also built by this procedure, and the value returned
149 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
150 -- found in the specification, then its address is read from the stream
151 -- instead of the object itself and converted into an access to
152 -- class-wide type before doing the real call using any of the RACW type
153 -- pointing on the designated type.
155 function Build_RPC_Receiver_Specification
156 (RPC_Receiver : Entity_Id;
157 Stream_Parameter : Entity_Id;
158 Result_Parameter : Entity_Id)
160 -- Make a subprogram specification for an RPC receiver,
161 -- with the given defining unit name and formal parameters.
163 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
164 -- Return an ordered parameter list: unconstrained parameters are put
165 -- at the beginning of the list and constrained ones are put after. If
166 -- there are no parameters, an empty list is returned.
168 procedure Add_Calling_Stubs_To_Declarations
169 (Pkg_Spec : in Node_Id;
171 -- Add calling stubs to the declarative part
173 procedure Add_Receiving_Stubs_To_Declarations
174 (Pkg_Spec : in Node_Id;
176 -- Add receiving stubs to the declarative part
178 procedure Add_RAS_Dereference_Attribute (N : in Node_Id);
179 -- Add a subprogram body for RAS dereference
181 procedure Add_RAS_Access_Attribute (N : in Node_Id);
182 -- Add a subprogram body for RAS Access attribute
184 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
185 -- Return True if nothing prevents the program whose specification is
186 -- given to be asynchronous (i.e. no out parameter).
188 function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id;
189 function Get_String_Id (Val : String) return String_Id;
190 -- Ugly functions used to retrieve a package name. Inherited from the
191 -- old exp_dist.adb and not rewritten yet ???
193 function Pack_Entity_Into_Stream_Access
197 Etyp : Entity_Id := Empty)
199 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
200 -- then Etype (Object) will be used if present. If the type is
201 -- constrained, then 'Write will be used to output the object,
202 -- If the type is unconstrained, 'Output will be used.
204 function Pack_Node_Into_Stream
210 -- Similar to above, with an arbitrary node instead of an entity
212 function Pack_Node_Into_Stream_Access
218 -- Similar to above, with Stream instead of Stream'Access
220 function Copy_Specification
223 Object_Type : Entity_Id := Empty;
224 Stub_Type : Entity_Id := Empty;
225 New_Name : Name_Id := No_Name)
227 -- Build a specification from another one. If Object_Type is not Empty
228 -- and any access to Object_Type is found, then it is replaced by an
229 -- access to Stub_Type. If New_Name is given, then it will be used as
230 -- the name for the newly created spec.
232 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
233 -- Return the scope represented by a given spec
235 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
236 -- Return True if the current parameter needs an extra formal to reflect
237 -- its constrained status.
239 function Is_RACW_Controlling_Formal
240 (Parameter : Node_Id; Stub_Type : Entity_Id)
242 -- Return True if the current parameter is a controlling formal argument
243 -- of type Stub_Type or access to Stub_Type.
245 type Stub_Structure is record
246 Stub_Type : Entity_Id;
247 Stub_Type_Access : Entity_Id;
248 Object_RPC_Receiver : Entity_Id;
249 RPC_Receiver_Stream : Entity_Id;
250 RPC_Receiver_Result : Entity_Id;
251 RACW_Type : Entity_Id;
253 -- This structure is necessary because of the two phases analysis of
254 -- a RACW declaration occurring in the same Remote_Types package as the
255 -- designated type. RACW_Type is any of the RACW types pointing on this
256 -- designated type, it is used here to save an anonymous type creation
257 -- for each primitive operation.
259 Empty_Stub_Structure : constant Stub_Structure :=
260 (Empty, Empty, Empty, Empty, Empty, Empty);
262 type Hash_Index is range 0 .. 50;
263 function Hash (F : Entity_Id) return Hash_Index;
265 package Stubs_Table is
266 new Simple_HTable (Header_Num => Hash_Index,
267 Element => Stub_Structure,
268 No_Element => Empty_Stub_Structure,
272 -- Mapping between a RACW designated type and its stub type
274 package Asynchronous_Flags_Table is
275 new Simple_HTable (Header_Num => Hash_Index,
281 -- Mapping between a RACW type and the node holding the value True if
282 -- the RACW is asynchronous and False otherwise.
284 package RCI_Locator_Table is
285 new Simple_HTable (Header_Num => Hash_Index,
286 Element => Entity_Id,
291 -- Mapping between a RCI package on which All_Calls_Remote applies and
292 -- the generic instantiation of RCI_Info for this package.
294 package RCI_Calling_Stubs_Table is
295 new Simple_HTable (Header_Num => Hash_Index,
296 Element => Entity_Id,
301 -- Mapping between a RCI subprogram and the corresponding calling stubs
303 procedure Add_Stub_Type
304 (Designated_Type : in Entity_Id;
305 RACW_Type : in Entity_Id;
307 Stub_Type : out Entity_Id;
308 Stub_Type_Access : out Entity_Id;
309 Object_RPC_Receiver : out Entity_Id;
310 Existing : out Boolean);
311 -- Add the declaration of the stub type, the access to stub type and the
312 -- object RPC receiver at the end of Decls. If these already exist,
313 -- then nothing is added in the tree but the right values are returned
314 -- anyhow and Existing is set to True.
316 procedure Add_RACW_Read_Attribute
317 (RACW_Type : in Entity_Id;
318 Stub_Type : in Entity_Id;
319 Stub_Type_Access : in Entity_Id;
320 Declarations : in List_Id);
321 -- Add Read attribute in Decls for the RACW type. The Read attribute
322 -- is added right after the RACW_Type declaration while the body is
323 -- inserted after Declarations.
325 procedure Add_RACW_Write_Attribute
326 (RACW_Type : in Entity_Id;
327 Stub_Type : in Entity_Id;
328 Stub_Type_Access : in Entity_Id;
329 Object_RPC_Receiver : in Entity_Id;
330 Declarations : in List_Id);
331 -- Same thing for the Write attribute
333 procedure Add_RACW_Read_Write_Attributes
334 (RACW_Type : in Entity_Id;
335 Stub_Type : in Entity_Id;
336 Stub_Type_Access : in Entity_Id;
337 Object_RPC_Receiver : in Entity_Id;
338 Declarations : in List_Id);
339 -- Add Read and Write attributes declarations and bodies for a given
340 -- RACW type. The declarations are added just after the declaration
341 -- of the RACW type itself, while the bodies are inserted at the end
344 function RCI_Package_Locator
346 Package_Spec : Node_Id)
348 -- Instantiate the generic package RCI_Info in order to locate the
349 -- RCI package whose spec is given as argument.
351 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
352 -- Surround a node N by a tag check, as in:
356 -- when E : Ada.Tags.Tag_Error =>
357 -- Raise_Exception (Program_Error'Identity,
358 -- Exception_Message (E));
361 function Input_With_Tag_Check
363 Var_Type : Entity_Id;
366 -- Return a function with the following form:
367 -- function R return Var_Type is
369 -- return Var_Type'Input (S);
371 -- when E : Ada.Tags.Tag_Error =>
372 -- Raise_Exception (Program_Error'Identity,
373 -- Exception_Message (E));
376 ------------------------------------
377 -- Local variables and structures --
378 ------------------------------------
382 Output_From_Constrained : constant array (Boolean) of Name_Id :=
383 (False => Name_Output,
385 -- The attribute to choose depending on the fact that the parameter
386 -- is constrained or not. There is no such thing as Input_From_Constrained
387 -- since this require separate mechanisms ('Input is a function while
388 -- 'Read is a procedure).
390 ---------------------------------------
391 -- Add_Calling_Stubs_To_Declarations --
392 ---------------------------------------
394 procedure Add_Calling_Stubs_To_Declarations
395 (Pkg_Spec : in Node_Id;
398 Current_Subprogram_Number : Int := 0;
399 Current_Declaration : Node_Id;
401 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
403 RCI_Instantiation : Node_Id;
405 Subp_Stubs : Node_Id;
408 -- The first thing added is an instantiation of the generic package
409 -- System.Partition_interface.RCI_Info with the name of the (current)
410 -- remote package. This will act as an interface with the name server
411 -- to determine the Partition_ID and the RPC_Receiver for the
412 -- receiver of this package.
414 RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
415 RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
417 Append_To (Decls, RCI_Instantiation);
418 Analyze (RCI_Instantiation);
420 -- For each subprogram declaration visible in the spec, we do
421 -- build a body. We also increment a counter to assign a different
422 -- Subprogram_Id to each subprograms. The receiving stubs processing
423 -- do use the same mechanism and will thus assign the same Id and
424 -- do the correct dispatching.
426 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
428 while Current_Declaration /= Empty loop
430 if Nkind (Current_Declaration) = N_Subprogram_Declaration
431 and then Comes_From_Source (Current_Declaration)
433 pragma Assert (Current_Subprogram_Number =
434 Get_Subprogram_Id (Defining_Unit_Name (Specification (
435 Current_Declaration))));
438 Build_Subprogram_Calling_Stubs (
439 Vis_Decl => Current_Declaration,
440 Subp_Id => Current_Subprogram_Number,
442 Nkind (Specification (Current_Declaration)) =
443 N_Procedure_Specification
445 Is_Asynchronous (Defining_Unit_Name (Specification
446 (Current_Declaration))));
448 Append_To (Decls, Subp_Stubs);
449 Analyze (Subp_Stubs);
451 Current_Subprogram_Number := Current_Subprogram_Number + 1;
454 Next (Current_Declaration);
457 end Add_Calling_Stubs_To_Declarations;
459 -----------------------
460 -- Add_RACW_Features --
461 -----------------------
463 procedure Add_RACW_Features (RACW_Type : in Entity_Id)
465 Desig : constant Entity_Id :=
466 Etype (Designated_Type (RACW_Type));
468 List_Containing (Declaration_Node (RACW_Type));
470 Same_Scope : constant Boolean :=
471 Scope (Desig) = Scope (RACW_Type);
473 Stub_Type : Entity_Id;
474 Stub_Type_Access : Entity_Id;
475 Object_RPC_Receiver : Entity_Id;
479 if not Expander_Active then
485 -- We are declaring a RACW in the same package than its designated
486 -- type, so the list to use for late declarations must be the
487 -- private part of the package. We do know that this private part
488 -- exists since the designated type has to be a private one.
490 Decls := Private_Declarations
491 (Package_Specification_Of_Scope (Current_Scope));
493 elsif Nkind (Parent (Decls)) = N_Package_Specification
494 and then Present (Private_Declarations (Parent (Decls)))
496 Decls := Private_Declarations (Parent (Decls));
499 -- If we were unable to find the declarations, that means that the
500 -- completion of the type was missing. We can safely return and let
501 -- the error be caught by the semantic analysis.
508 (Designated_Type => Desig,
509 RACW_Type => RACW_Type,
511 Stub_Type => Stub_Type,
512 Stub_Type_Access => Stub_Type_Access,
513 Object_RPC_Receiver => Object_RPC_Receiver,
514 Existing => Existing);
516 Add_RACW_Read_Write_Attributes
517 (RACW_Type => RACW_Type,
518 Stub_Type => Stub_Type,
519 Stub_Type_Access => Stub_Type_Access,
520 Object_RPC_Receiver => Object_RPC_Receiver,
521 Declarations => Decls);
523 if not Same_Scope and then not Existing then
525 -- The RACW has been declared in another scope than the designated
526 -- type and has not been handled by another RACW in the same
527 -- package as the first one, so add primitive for the stub type
530 Add_RACW_Primitive_Declarations_And_Bodies
531 (Designated_Type => Desig,
533 Parent (Declaration_Node (Object_RPC_Receiver)),
537 Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
539 end Add_RACW_Features;
541 -------------------------------------------------
542 -- Add_RACW_Primitive_Declarations_And_Bodies --
543 -------------------------------------------------
545 procedure Add_RACW_Primitive_Declarations_And_Bodies
546 (Designated_Type : in Entity_Id;
547 Insertion_Node : in Node_Id;
550 -- Set sloc of generated declaration to be that of the
551 -- insertion node, so the declarations are recognized as
552 -- belonging to the current package.
554 Loc : constant Source_Ptr := Sloc (Insertion_Node);
556 Stub_Elements : constant Stub_Structure :=
557 Stubs_Table.Get (Designated_Type);
559 pragma Assert (Stub_Elements /= Empty_Stub_Structure);
561 Current_Insertion_Node : Node_Id := Insertion_Node;
563 RPC_Receiver_Declarations : List_Id;
564 RPC_Receiver_Statements : List_Id;
565 RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
566 RPC_Receiver_Subp_Id : Entity_Id;
568 Current_Primitive_Elmt : Elmt_Id;
569 Current_Primitive : Entity_Id;
570 Current_Primitive_Body : Node_Id;
571 Current_Primitive_Spec : Node_Id;
572 Current_Primitive_Decl : Node_Id;
573 Current_Primitive_Number : Int := 0;
575 Current_Primitive_Alias : Node_Id;
577 Current_Receiver : Entity_Id;
578 Current_Receiver_Body : Node_Id;
580 RPC_Receiver_Decl : Node_Id;
582 Possibly_Asynchronous : Boolean;
585 if not Expander_Active then
589 -- Build callers, receivers for every primitive operations and a RPC
590 -- receiver for this type.
592 if Present (Primitive_Operations (Designated_Type)) then
594 Current_Primitive_Elmt :=
595 First_Elmt (Primitive_Operations (Designated_Type));
597 while Current_Primitive_Elmt /= No_Elmt loop
599 Current_Primitive := Node (Current_Primitive_Elmt);
601 -- Copy the primitive of all the parents, except predefined
602 -- ones that are not remotely dispatching.
604 if Chars (Current_Primitive) /= Name_uSize
605 and then Chars (Current_Primitive) /= Name_uAlignment
606 and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize)
608 -- The first thing to do is build an up-to-date copy of
609 -- the spec with all the formals referencing Designated_Type
610 -- transformed into formals referencing Stub_Type. Since this
611 -- primitive may have been inherited, go back the alias chain
612 -- until the real primitive has been found.
614 Current_Primitive_Alias := Current_Primitive;
615 while Present (Alias (Current_Primitive_Alias)) loop
617 (Current_Primitive_Alias
618 /= Alias (Current_Primitive_Alias));
619 Current_Primitive_Alias := Alias (Current_Primitive_Alias);
622 Current_Primitive_Spec :=
623 Copy_Specification (Loc,
624 Spec => Parent (Current_Primitive_Alias),
625 Object_Type => Designated_Type,
626 Stub_Type => Stub_Elements.Stub_Type);
628 Current_Primitive_Decl :=
629 Make_Subprogram_Declaration (Loc,
630 Specification => Current_Primitive_Spec);
632 Insert_After (Current_Insertion_Node, Current_Primitive_Decl);
633 Analyze (Current_Primitive_Decl);
634 Current_Insertion_Node := Current_Primitive_Decl;
636 Possibly_Asynchronous :=
637 Nkind (Current_Primitive_Spec) = N_Procedure_Specification
638 and then Could_Be_Asynchronous (Current_Primitive_Spec);
640 Current_Primitive_Body :=
641 Build_Subprogram_Calling_Stubs
642 (Vis_Decl => Current_Primitive_Decl,
643 Subp_Id => Current_Primitive_Number,
644 Asynchronous => Possibly_Asynchronous,
645 Dynamically_Asynchronous => Possibly_Asynchronous,
646 Stub_Type => Stub_Elements.Stub_Type);
647 Append_To (Decls, Current_Primitive_Body);
649 -- Analyzing the body here would cause the Stub type to be
650 -- frozen, thus preventing subsequent primitive declarations.
651 -- For this reason, it will be analyzed later in the
654 -- Build the receiver stubs
656 Current_Receiver_Body :=
657 Build_Subprogram_Receiving_Stubs
658 (Vis_Decl => Current_Primitive_Decl,
659 Asynchronous => Possibly_Asynchronous,
660 Dynamically_Asynchronous => Possibly_Asynchronous,
661 Stub_Type => Stub_Elements.Stub_Type,
662 RACW_Type => Stub_Elements.RACW_Type,
663 Parent_Primitive => Current_Primitive);
666 Defining_Unit_Name (Specification (Current_Receiver_Body));
668 Append_To (Decls, Current_Receiver_Body);
670 -- Add a case alternative to the receiver
672 Append_To (RPC_Receiver_Case_Alternatives,
673 Make_Case_Statement_Alternative (Loc,
674 Discrete_Choices => New_List (
675 Make_Integer_Literal (Loc, Current_Primitive_Number)),
677 Statements => New_List (
678 Make_Procedure_Call_Statement (Loc,
680 New_Occurrence_Of (Current_Receiver, Loc),
681 Parameter_Associations => New_List (
683 (Stub_Elements.RPC_Receiver_Stream, Loc),
685 (Stub_Elements.RPC_Receiver_Result, Loc))))));
687 -- Increment the index of current primitive
689 Current_Primitive_Number := Current_Primitive_Number + 1;
692 Next_Elmt (Current_Primitive_Elmt);
696 -- Build the case statement and the heart of the subprogram
698 Append_To (RPC_Receiver_Case_Alternatives,
699 Make_Case_Statement_Alternative (Loc,
700 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
701 Statements => New_List (Make_Null_Statement (Loc))));
703 RPC_Receiver_Subp_Id :=
704 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
706 RPC_Receiver_Declarations := New_List (
707 Make_Object_Declaration (Loc,
708 Defining_Identifier => RPC_Receiver_Subp_Id,
710 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)));
712 RPC_Receiver_Statements := New_List (
713 Make_Attribute_Reference (Loc,
715 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
718 Expressions => New_List (
719 New_Occurrence_Of (Stub_Elements.RPC_Receiver_Stream, Loc),
720 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc))));
722 Append_To (RPC_Receiver_Statements,
723 Make_Case_Statement (Loc,
725 New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
726 Alternatives => RPC_Receiver_Case_Alternatives));
729 Make_Subprogram_Body (Loc,
731 Copy_Specification (Loc,
732 Parent (Stub_Elements.Object_RPC_Receiver)),
733 Declarations => RPC_Receiver_Declarations,
734 Handled_Statement_Sequence =>
735 Make_Handled_Sequence_Of_Statements (Loc,
736 Statements => RPC_Receiver_Statements));
738 Append_To (Decls, RPC_Receiver_Decl);
740 -- Do not analyze RPC receiver at this stage since it will otherwise
741 -- reference subprograms that have not been analyzed yet. It will
742 -- be analyzed in the regular flow.
744 end Add_RACW_Primitive_Declarations_And_Bodies;
746 -----------------------------
747 -- Add_RACW_Read_Attribute --
748 -----------------------------
750 procedure Add_RACW_Read_Attribute
751 (RACW_Type : in Entity_Id;
752 Stub_Type : in Entity_Id;
753 Stub_Type_Access : in Entity_Id;
754 Declarations : in List_Id)
756 Loc : constant Source_Ptr := Sloc (RACW_Type);
764 Statements : List_Id;
765 Local_Statements : List_Id;
766 Remote_Statements : List_Id;
767 -- Various parts of the procedure
769 Procedure_Name : constant Name_Id :=
770 New_Internal_Name ('R');
771 Source_Partition : constant Entity_Id :=
772 Make_Defining_Identifier
773 (Loc, New_Internal_Name ('P'));
774 Source_Receiver : constant Entity_Id :=
775 Make_Defining_Identifier
776 (Loc, New_Internal_Name ('S'));
777 Source_Address : constant Entity_Id :=
778 Make_Defining_Identifier
779 (Loc, New_Internal_Name ('P'));
780 Stubbed_Result : constant Entity_Id :=
781 Make_Defining_Identifier
782 (Loc, New_Internal_Name ('S'));
783 Asynchronous_Flag : constant Entity_Id :=
784 Make_Defining_Identifier
785 (Loc, New_Internal_Name ('S'));
786 Asynchronous_Node : constant Node_Id :=
787 New_Occurrence_Of (Standard_False, Loc);
789 -- Functions to create occurrences of the formal
792 function Stream_Parameter return Node_Id;
793 function Result return Node_Id;
795 function Stream_Parameter return Node_Id is
797 return Make_Identifier (Loc, Name_S);
798 end Stream_Parameter;
800 function Result return Node_Id is
802 return Make_Identifier (Loc, Name_V);
806 -- Declare the asynchronous flag. This flag will be changed to True
807 -- whenever it is known that the RACW type is asynchronous. Also, the
808 -- node gets stored since it may be rewritten when we process the
809 -- asynchronous pragma.
811 Append_To (Declarations,
812 Make_Object_Declaration (Loc,
813 Defining_Identifier => Asynchronous_Flag,
814 Constant_Present => True,
815 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
816 Expression => Asynchronous_Node));
818 Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Node);
820 -- Object declarations
823 Make_Object_Declaration (Loc,
824 Defining_Identifier => Source_Partition,
826 New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
828 Make_Object_Declaration (Loc,
829 Defining_Identifier => Source_Receiver,
831 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
833 Make_Object_Declaration (Loc,
834 Defining_Identifier => Source_Address,
836 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
838 Make_Object_Declaration (Loc,
839 Defining_Identifier => Stubbed_Result,
841 New_Occurrence_Of (Stub_Type_Access, Loc)));
843 -- Read the source Partition_ID and RPC_Receiver from incoming stream
845 Statements := New_List (
846 Make_Attribute_Reference (Loc,
848 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
849 Attribute_Name => Name_Read,
850 Expressions => New_List (
852 New_Occurrence_Of (Source_Partition, Loc))),
854 Make_Attribute_Reference (Loc,
856 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
859 Expressions => New_List (
861 New_Occurrence_Of (Source_Receiver, Loc))),
863 Make_Attribute_Reference (Loc,
865 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
868 Expressions => New_List (
870 New_Occurrence_Of (Source_Address, Loc))));
872 -- If the Address is Null_Address, then return a null object
874 Append_To (Statements,
875 Make_Implicit_If_Statement (RACW_Type,
878 Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
879 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
880 Then_Statements => New_List (
881 Make_Assignment_Statement (Loc,
883 Expression => Make_Null (Loc)),
884 Make_Return_Statement (Loc))));
886 -- If the RACW denotes an object created on the current partition, then
887 -- Local_Statements will be executed. The real object will be used.
889 Local_Statements := New_List (
890 Make_Assignment_Statement (Loc,
893 Unchecked_Convert_To (RACW_Type,
894 OK_Convert_To (RTE (RE_Address),
895 New_Occurrence_Of (Source_Address, Loc)))));
897 -- If the object is located on another partition, then a stub object
898 -- will be created with all the information needed to rebuild the
899 -- real object at the other end.
901 Remote_Statements := New_List (
903 Make_Assignment_Statement (Loc,
904 Name => New_Occurrence_Of (Stubbed_Result, Loc),
907 New_Occurrence_Of (Stub_Type, Loc))),
909 Make_Assignment_Statement (Loc,
910 Name => Make_Selected_Component (Loc,
911 Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
912 Selector_Name => Make_Identifier (Loc, Name_Origin)),
914 New_Occurrence_Of (Source_Partition, Loc)),
916 Make_Assignment_Statement (Loc,
917 Name => Make_Selected_Component (Loc,
918 Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
919 Selector_Name => Make_Identifier (Loc, Name_Receiver)),
921 New_Occurrence_Of (Source_Receiver, Loc)),
923 Make_Assignment_Statement (Loc,
924 Name => Make_Selected_Component (Loc,
925 Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
926 Selector_Name => Make_Identifier (Loc, Name_Addr)),
928 New_Occurrence_Of (Source_Address, Loc)));
930 Append_To (Remote_Statements,
931 Make_Assignment_Statement (Loc,
932 Name => Make_Selected_Component (Loc,
933 Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
934 Selector_Name => Make_Identifier (Loc, Name_Asynchronous)),
936 New_Occurrence_Of (Asynchronous_Flag, Loc)));
938 Append_To (Remote_Statements,
939 Make_Procedure_Call_Statement (Loc,
941 New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
942 Parameter_Associations => New_List (
943 Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
944 New_Occurrence_Of (Stubbed_Result, Loc)))));
946 Append_To (Remote_Statements,
947 Make_Assignment_Statement (Loc,
949 Expression => Unchecked_Convert_To (RACW_Type,
950 New_Occurrence_Of (Stubbed_Result, Loc))));
952 -- Distinguish between the local and remote cases, and execute the
953 -- appropriate piece of code.
955 Append_To (Statements,
956 Make_Implicit_If_Statement (RACW_Type,
960 Make_Function_Call (Loc,
962 New_Occurrence_Of (RTE (RE_Get_Local_Partition_Id), Loc)),
963 Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
964 Then_Statements => Local_Statements,
965 Else_Statements => Remote_Statements));
967 Build_Stream_Procedure
968 (Loc, RACW_Type, Body_Node,
969 Make_Defining_Identifier (Loc, Procedure_Name),
970 Statements, Outp => True);
971 Set_Declarations (Body_Node, Decls);
973 Proc_Decl := Make_Subprogram_Declaration (Loc,
974 Copy_Specification (Loc, Specification (Body_Node)));
977 Make_Attribute_Definition_Clause (Loc,
978 Name => New_Occurrence_Of (RACW_Type, Loc),
982 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
984 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
985 Insert_After (Proc_Decl, Attr_Decl);
986 Append_To (Declarations, Body_Node);
987 end Add_RACW_Read_Attribute;
989 ------------------------------------
990 -- Add_RACW_Read_Write_Attributes --
991 ------------------------------------
993 procedure Add_RACW_Read_Write_Attributes
994 (RACW_Type : in Entity_Id;
995 Stub_Type : in Entity_Id;
996 Stub_Type_Access : in Entity_Id;
997 Object_RPC_Receiver : in Entity_Id;
998 Declarations : in List_Id)
1001 Add_RACW_Write_Attribute
1002 (RACW_Type => RACW_Type,
1003 Stub_Type => Stub_Type,
1004 Stub_Type_Access => Stub_Type_Access,
1005 Object_RPC_Receiver => Object_RPC_Receiver,
1006 Declarations => Declarations);
1008 Add_RACW_Read_Attribute
1009 (RACW_Type => RACW_Type,
1010 Stub_Type => Stub_Type,
1011 Stub_Type_Access => Stub_Type_Access,
1012 Declarations => Declarations);
1013 end Add_RACW_Read_Write_Attributes;
1015 ------------------------------
1016 -- Add_RACW_Write_Attribute --
1017 ------------------------------
1019 procedure Add_RACW_Write_Attribute
1020 (RACW_Type : in Entity_Id;
1021 Stub_Type : in Entity_Id;
1022 Stub_Type_Access : in Entity_Id;
1023 Object_RPC_Receiver : in Entity_Id;
1024 Declarations : in List_Id)
1026 Loc : constant Source_Ptr := Sloc (RACW_Type);
1028 Body_Node : Node_Id;
1029 Proc_Decl : Node_Id;
1030 Attr_Decl : Node_Id;
1032 Statements : List_Id;
1033 Local_Statements : List_Id;
1034 Remote_Statements : List_Id;
1035 Null_Statements : List_Id;
1037 Procedure_Name : constant Name_Id := New_Internal_Name ('R');
1039 -- Functions to create occurrences of the formal
1042 function Stream_Parameter return Node_Id;
1043 function Object return Node_Id;
1045 function Stream_Parameter return Node_Id is
1047 return Make_Identifier (Loc, Name_S);
1048 end Stream_Parameter;
1050 function Object return Node_Id is
1052 return Make_Identifier (Loc, Name_V);
1056 -- Build the code fragment corresponding to the marshalling of a
1059 Local_Statements := New_List (
1061 Pack_Entity_Into_Stream_Access (Loc,
1062 Stream => Stream_Parameter,
1063 Object => RTE (RE_Get_Local_Partition_Id)),
1065 Pack_Node_Into_Stream_Access (Loc,
1066 Stream => Stream_Parameter,
1067 Object => OK_Convert_To (RTE (RE_Unsigned_64),
1068 Make_Attribute_Reference (Loc,
1069 Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc),
1070 Attribute_Name => Name_Address)),
1071 Etyp => RTE (RE_Unsigned_64)),
1073 Pack_Node_Into_Stream_Access (Loc,
1074 Stream => Stream_Parameter,
1075 Object => OK_Convert_To (RTE (RE_Unsigned_64),
1076 Make_Attribute_Reference (Loc,
1078 Make_Explicit_Dereference (Loc,
1080 Attribute_Name => Name_Address)),
1081 Etyp => RTE (RE_Unsigned_64)));
1083 -- Build the code fragment corresponding to the marshalling of
1086 Remote_Statements := New_List (
1088 Pack_Node_Into_Stream_Access (Loc,
1089 Stream => Stream_Parameter,
1091 Make_Selected_Component (Loc,
1092 Prefix => Unchecked_Convert_To (Stub_Type_Access,
1095 Make_Identifier (Loc, Name_Origin)),
1096 Etyp => RTE (RE_Partition_ID)),
1098 Pack_Node_Into_Stream_Access (Loc,
1099 Stream => Stream_Parameter,
1101 Make_Selected_Component (Loc,
1102 Prefix => Unchecked_Convert_To (Stub_Type_Access,
1105 Make_Identifier (Loc, Name_Receiver)),
1106 Etyp => RTE (RE_Unsigned_64)),
1108 Pack_Node_Into_Stream_Access (Loc,
1109 Stream => Stream_Parameter,
1111 Make_Selected_Component (Loc,
1112 Prefix => Unchecked_Convert_To (Stub_Type_Access,
1115 Make_Identifier (Loc, Name_Addr)),
1116 Etyp => RTE (RE_Unsigned_64)));
1118 -- Build the code fragment corresponding to the marshalling of a null
1121 Null_Statements := New_List (
1123 Pack_Entity_Into_Stream_Access (Loc,
1124 Stream => Stream_Parameter,
1125 Object => RTE (RE_Get_Local_Partition_Id)),
1127 Pack_Node_Into_Stream_Access (Loc,
1128 Stream => Stream_Parameter,
1129 Object => OK_Convert_To (RTE (RE_Unsigned_64),
1130 Make_Attribute_Reference (Loc,
1131 Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc),
1132 Attribute_Name => Name_Address)),
1133 Etyp => RTE (RE_Unsigned_64)),
1135 Pack_Node_Into_Stream_Access (Loc,
1136 Stream => Stream_Parameter,
1137 Object => Make_Integer_Literal (Loc, Uint_0),
1138 Etyp => RTE (RE_Unsigned_64)));
1140 Statements := New_List (
1141 Make_Implicit_If_Statement (RACW_Type,
1144 Left_Opnd => Object,
1145 Right_Opnd => Make_Null (Loc)),
1146 Then_Statements => Null_Statements,
1147 Elsif_Parts => New_List (
1148 Make_Elsif_Part (Loc,
1152 Make_Attribute_Reference (Loc,
1154 Attribute_Name => Name_Tag),
1156 Make_Attribute_Reference (Loc,
1157 Prefix => New_Occurrence_Of (Stub_Type, Loc),
1158 Attribute_Name => Name_Tag)),
1159 Then_Statements => Remote_Statements)),
1160 Else_Statements => Local_Statements));
1162 Build_Stream_Procedure
1163 (Loc, RACW_Type, Body_Node,
1164 Make_Defining_Identifier (Loc, Procedure_Name),
1165 Statements, Outp => False);
1167 Proc_Decl := Make_Subprogram_Declaration (Loc,
1168 Copy_Specification (Loc, Specification (Body_Node)));
1171 Make_Attribute_Definition_Clause (Loc,
1172 Name => New_Occurrence_Of (RACW_Type, Loc),
1173 Chars => Name_Write,
1176 Defining_Unit_Name (Specification (Proc_Decl)), Loc));
1178 Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
1179 Insert_After (Proc_Decl, Attr_Decl);
1180 Append_To (Declarations, Body_Node);
1181 end Add_RACW_Write_Attribute;
1183 ------------------------------
1184 -- Add_RAS_Access_Attribute --
1185 ------------------------------
1187 procedure Add_RAS_Access_Attribute (N : in Node_Id) is
1188 Ras_Type : constant Entity_Id := Defining_Identifier (N);
1189 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
1190 -- Ras_Type is the access to subprogram type while Fat_Type points to
1191 -- the record type corresponding to a remote access to subprogram type.
1193 Proc_Decls : constant List_Id := New_List;
1194 Proc_Statements : constant List_Id := New_List;
1196 Proc_Spec : Node_Id;
1198 Local_Addr : Entity_Id;
1199 Package_Name : Entity_Id;
1200 Subp_Id : Entity_Id;
1201 Asynch_P : Entity_Id;
1203 Return_Value : Entity_Id;
1205 All_Calls_Remote : Entity_Id;
1206 -- True if an All_Calls_Remote pragma applies to the RCI unit
1207 -- that contains the subprogram (currently unused, all RAS
1208 -- dereferences are handled through the PCS).
1210 Loc : constant Source_Ptr := Sloc (N);
1213 (Field_Name : Name_Id;
1214 Value : Node_Id) return Node_Id;
1215 -- Construct an assignment that sets the named component in the
1223 (Field_Name : Name_Id;
1224 Value : Node_Id) return Node_Id
1228 Make_Assignment_Statement (Loc,
1230 Make_Selected_Component (Loc,
1231 Prefix => New_Occurrence_Of (Return_Value, Loc),
1232 Selector_Name => Make_Identifier (Loc, Field_Name)),
1233 Expression => Value);
1236 -- Start of processing for Add_RAS_Access_Attribute
1239 Local_Addr := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
1240 Package_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1241 Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
1242 Asynch_P := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
1243 Origin := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1244 Return_Value := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
1246 Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
1248 -- Create the object which will be returned of type Fat_Type
1250 Append_List_To (Proc_Decls, New_List (
1252 Make_Object_Declaration (Loc,
1253 Defining_Identifier => Origin,
1254 Constant_Present => True,
1255 Object_Definition =>
1256 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
1258 Make_Function_Call (Loc,
1260 New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
1261 Parameter_Associations => New_List (
1262 New_Occurrence_Of (Package_Name, Loc)))),
1264 Make_Object_Declaration (Loc,
1265 Defining_Identifier => Return_Value,
1266 Object_Definition =>
1267 New_Occurrence_Of (Fat_Type, Loc))));
1269 -- Initialize the fields of the record type with the appropriate data
1271 Append_List_To (Proc_Statements, New_List (
1272 Make_Implicit_If_Statement (N,
1277 New_Occurrence_Of (All_Calls_Remote, Loc)),
1281 New_Occurrence_Of (Origin, Loc),
1283 Make_Function_Call (Loc,
1285 RTE (RE_Get_Local_Partition_Id), Loc)))),
1287 Then_Statements => New_List (
1288 Set_Field (Name_Ras,
1289 OK_Convert_To (RTE (RE_Unsigned_64),
1290 New_Occurrence_Of (Local_Addr, Loc)))),
1292 Else_Statements => New_List (
1293 Set_Field (Name_Ras,
1294 Make_Integer_Literal (Loc, Uint_0)))),
1296 Set_Field (Name_Origin,
1297 Unchecked_Convert_To (Standard_Integer,
1298 New_Occurrence_Of (Origin, Loc))),
1300 Set_Field (Name_Receiver,
1301 Make_Function_Call (Loc,
1303 New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
1304 Parameter_Associations => New_List (
1305 New_Occurrence_Of (Package_Name, Loc)))),
1307 Set_Field (Name_Subp_Id,
1308 New_Occurrence_Of (Subp_Id, Loc)),
1310 Set_Field (Name_Async,
1311 New_Occurrence_Of (Asynch_P, Loc))));
1313 -- Return the newly created value
1315 Append_To (Proc_Statements,
1316 Make_Return_Statement (Loc,
1318 New_Occurrence_Of (Return_Value, Loc)));
1321 Make_Defining_Identifier (Loc,
1322 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
1325 Make_Function_Specification (Loc,
1326 Defining_Unit_Name => Proc,
1327 Parameter_Specifications => New_List (
1328 Make_Parameter_Specification (Loc,
1329 Defining_Identifier => Local_Addr,
1331 New_Occurrence_Of (RTE (RE_Address), Loc)),
1333 Make_Parameter_Specification (Loc,
1334 Defining_Identifier => Package_Name,
1336 New_Occurrence_Of (Standard_String, Loc)),
1338 Make_Parameter_Specification (Loc,
1339 Defining_Identifier => Subp_Id,
1341 New_Occurrence_Of (Standard_Natural, Loc)),
1343 Make_Parameter_Specification (Loc,
1344 Defining_Identifier => Asynch_P,
1346 New_Occurrence_Of (Standard_Boolean, Loc)),
1348 Make_Parameter_Specification (Loc,
1349 Defining_Identifier => All_Calls_Remote,
1351 New_Occurrence_Of (Standard_Boolean, Loc))),
1354 New_Occurrence_Of (Fat_Type, Loc));
1356 -- Set the kind and return type of the function to prevent ambiguities
1357 -- between Ras_Type and Fat_Type in subsequent analysis.
1359 Set_Ekind (Proc, E_Function);
1360 Set_Etype (Proc, New_Occurrence_Of (Fat_Type, Loc));
1363 Make_Subprogram_Body (Loc,
1364 Specification => Proc_Spec,
1365 Declarations => Proc_Decls,
1366 Handled_Statement_Sequence =>
1367 Make_Handled_Sequence_Of_Statements (Loc,
1368 Statements => Proc_Statements)));
1370 Set_TSS (Fat_Type, Proc);
1372 end Add_RAS_Access_Attribute;
1374 -----------------------------------
1375 -- Add_RAS_Dereference_Attribute --
1376 -----------------------------------
1378 procedure Add_RAS_Dereference_Attribute (N : in Node_Id) is
1379 Loc : constant Source_Ptr := Sloc (N);
1381 Type_Def : constant Node_Id := Type_Definition (N);
1383 Ras_Type : constant Entity_Id := Defining_Identifier (N);
1385 Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
1387 Proc_Decls : constant List_Id := New_List;
1388 Proc_Statements : constant List_Id := New_List;
1390 Inner_Decls : constant List_Id := New_List;
1391 Inner_Statements : constant List_Id := New_List;
1393 Direct_Statements : constant List_Id := New_List;
1396 Proc_Spec : Node_Id;
1397 Param_Specs : constant List_Id := New_List;
1398 Param_Assoc : constant List_Id := New_List;
1402 Converted_Ras : Node_Id;
1403 Target_Partition : Node_Id;
1404 RPC_Receiver : Node_Id;
1405 Subprogram_Id : Node_Id;
1406 Asynchronous : Node_Id;
1408 Is_Function : constant Boolean :=
1409 Nkind (Type_Def) = N_Access_Function_Definition;
1411 Spec : constant Node_Id := Type_Def;
1413 Current_Parameter : Node_Id;
1416 -- The way to do it is test if the Ras field is non-null and then if
1417 -- the Origin field is equal to the current partition ID (which is in
1418 -- fact Current_Package'Partition_ID). If this is the case, then it
1419 -- is safe to dereference the Ras field directly rather than
1420 -- performing a remote call.
1423 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1426 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1428 Append_To (Proc_Decls,
1429 Make_Object_Declaration (Loc,
1430 Defining_Identifier => Target_Partition,
1431 Constant_Present => True,
1432 Object_Definition =>
1433 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
1435 Unchecked_Convert_To (RTE (RE_Partition_ID),
1436 Make_Selected_Component (Loc,
1438 New_Occurrence_Of (Pointer, Loc),
1440 Make_Identifier (Loc, Name_Origin)))));
1443 Make_Selected_Component (Loc,
1445 New_Occurrence_Of (Pointer, Loc),
1447 Make_Identifier (Loc, Name_Receiver));
1450 Unchecked_Convert_To (RTE (RE_Subprogram_Id),
1451 Make_Selected_Component (Loc,
1453 New_Occurrence_Of (Pointer, Loc),
1455 Make_Identifier (Loc, Name_Subp_Id)));
1457 -- A function is never asynchronous. A procedure may or may not be
1458 -- asynchronous depending on whether a pragma Asynchronous applies
1459 -- on it. Since a RAST may point onto various subprograms, this is
1460 -- only known at runtime so both versions (synchronous and asynchronous)
1461 -- must be built every times it is not a function.
1464 Asynchronous := Empty;
1468 Make_Selected_Component (Loc,
1470 New_Occurrence_Of (Pointer, Loc),
1472 Make_Identifier (Loc, Name_Async));
1476 if Present (Parameter_Specifications (Type_Def)) then
1477 Current_Parameter := First (Parameter_Specifications (Type_Def));
1479 while Current_Parameter /= Empty loop
1480 Append_To (Param_Specs,
1481 Make_Parameter_Specification (Loc,
1482 Defining_Identifier =>
1483 Make_Defining_Identifier (Loc,
1485 Chars (Defining_Identifier (Current_Parameter))),
1486 In_Present => In_Present (Current_Parameter),
1487 Out_Present => Out_Present (Current_Parameter),
1489 New_Copy_Tree (Parameter_Type (Current_Parameter)),
1491 New_Copy_Tree (Expression (Current_Parameter))));
1493 Append_To (Param_Assoc,
1494 Make_Identifier (Loc,
1495 Chars => Chars (Defining_Identifier (Current_Parameter))));
1497 Next (Current_Parameter);
1502 Make_Defining_Identifier (Loc,
1503 Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Dereference));
1507 Make_Function_Specification (Loc,
1508 Defining_Unit_Name => Proc,
1509 Parameter_Specifications => Param_Specs,
1512 Entity (Subtype_Mark (Spec)), Loc));
1514 Set_Ekind (Proc, E_Function);
1517 New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
1521 Make_Procedure_Specification (Loc,
1522 Defining_Unit_Name => Proc,
1523 Parameter_Specifications => Param_Specs);
1525 Set_Ekind (Proc, E_Procedure);
1526 Set_Etype (Proc, Standard_Void_Type);
1529 -- Build the calling stubs for the dereference of the RAS
1531 Build_General_Calling_Stubs
1532 (Decls => Inner_Decls,
1533 Statements => Inner_Statements,
1534 Target_Partition => Target_Partition,
1535 RPC_Receiver => RPC_Receiver,
1536 Subprogram_Id => Subprogram_Id,
1537 Asynchronous => Asynchronous,
1538 Is_Known_Non_Asynchronous => Is_Function,
1539 Is_Function => Is_Function,
1544 Unchecked_Convert_To (Ras_Type,
1545 OK_Convert_To (RTE (RE_Address),
1546 Make_Selected_Component (Loc,
1547 Prefix => New_Occurrence_Of (Pointer, Loc),
1548 Selector_Name => Make_Identifier (Loc, Name_Ras))));
1551 Append_To (Direct_Statements,
1552 Make_Return_Statement (Loc,
1554 Make_Function_Call (Loc,
1556 Make_Explicit_Dereference (Loc,
1557 Prefix => Converted_Ras),
1558 Parameter_Associations => Param_Assoc)));
1561 Append_To (Direct_Statements,
1562 Make_Procedure_Call_Statement (Loc,
1564 Make_Explicit_Dereference (Loc,
1565 Prefix => Converted_Ras),
1566 Parameter_Associations => Param_Assoc));
1569 Prepend_To (Param_Specs,
1570 Make_Parameter_Specification (Loc,
1571 Defining_Identifier => Pointer,
1574 New_Occurrence_Of (Fat_Type, Loc)));
1576 Append_To (Proc_Statements,
1577 Make_Implicit_If_Statement (N,
1583 Make_Selected_Component (Loc,
1584 Prefix => New_Occurrence_Of (Pointer, Loc),
1585 Selector_Name => Make_Identifier (Loc, Name_Ras)),
1587 Make_Integer_Literal (Loc, Uint_0)),
1592 New_Occurrence_Of (Target_Partition, Loc),
1594 Make_Function_Call (Loc,
1596 RTE (RE_Get_Local_Partition_Id), Loc)))),
1601 Else_Statements => New_List (
1602 Make_Block_Statement (Loc,
1603 Declarations => Inner_Decls,
1604 Handled_Statement_Sequence =>
1605 Make_Handled_Sequence_Of_Statements (Loc,
1606 Statements => Inner_Statements)))));
1609 Make_Subprogram_Body (Loc,
1610 Specification => Proc_Spec,
1611 Declarations => Proc_Decls,
1612 Handled_Statement_Sequence =>
1613 Make_Handled_Sequence_Of_Statements (Loc,
1614 Statements => Proc_Statements)));
1616 Set_TSS (Fat_Type, Defining_Unit_Name (Proc_Spec));
1618 end Add_RAS_Dereference_Attribute;
1620 -----------------------
1621 -- Add_RAST_Features --
1622 -----------------------
1624 procedure Add_RAST_Features (Vis_Decl : Node_Id) is
1626 -- Do not add attributes more than once in any case. This should
1627 -- be replaced by an assert or this comment removed if we decide
1628 -- that this is normal to be called several times ???
1630 if Present (TSS (Equivalent_Type (Defining_Identifier (Vis_Decl)),
1636 Add_RAS_Dereference_Attribute (Vis_Decl);
1637 Add_RAS_Access_Attribute (Vis_Decl);
1638 end Add_RAST_Features;
1640 -----------------------------------------
1641 -- Add_Receiving_Stubs_To_Declarations --
1642 -----------------------------------------
1644 procedure Add_Receiving_Stubs_To_Declarations
1645 (Pkg_Spec : in Node_Id;
1648 Loc : constant Source_Ptr := Sloc (Pkg_Spec);
1650 Stream_Parameter : Node_Id;
1651 Result_Parameter : Node_Id;
1653 Pkg_RPC_Receiver : Node_Id;
1654 Pkg_RPC_Receiver_Spec : Node_Id;
1655 Pkg_RPC_Receiver_Decls : List_Id;
1656 Pkg_RPC_Receiver_Statements : List_Id;
1657 Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
1658 Pkg_RPC_Receiver_Body : Node_Id;
1659 -- A Pkg_RPC_Receiver is built to decode the request
1662 -- Subprogram_Id as read from the incoming stream
1664 Current_Declaration : Node_Id;
1665 Current_Subprogram_Number : Int := 0;
1666 Current_Stubs : Node_Id;
1670 Dummy_Register_Name : Name_Id;
1671 Dummy_Register_Spec : Node_Id;
1672 Dummy_Register_Decl : Node_Id;
1673 Dummy_Register_Body : Node_Id;
1676 -- Building receiving stubs consist in several operations:
1678 -- - a package RPC receiver must be built. This subprogram
1679 -- will get a Subprogram_Id from the incoming stream
1680 -- and will dispatch the call to the right subprogram
1682 -- - a receiving stub for any subprogram visible in the package
1683 -- spec. This stub will read all the parameters from the stream,
1684 -- and put the result as well as the exception occurrence in the
1687 -- - a dummy package with an empty spec and a body made of an
1688 -- elaboration part, whose job is to register the receiving
1689 -- part of this RCI package on the name server. This is done
1690 -- by calling System.Partition_Interface.Register_Receiving_Stub
1693 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1695 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
1697 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1700 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1702 -- The parameters of the package RPC receiver are made of two
1703 -- streams, an input one and an output one.
1705 Pkg_RPC_Receiver_Spec :=
1706 Build_RPC_Receiver_Specification
1707 (RPC_Receiver => Pkg_RPC_Receiver,
1708 Stream_Parameter => Stream_Parameter,
1709 Result_Parameter => Result_Parameter);
1711 Pkg_RPC_Receiver_Decls := New_List (
1712 Make_Object_Declaration (Loc,
1713 Defining_Identifier => Subp_Id,
1714 Object_Definition =>
1715 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)));
1717 Pkg_RPC_Receiver_Statements := New_List (
1718 Make_Attribute_Reference (Loc,
1720 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
1723 Expressions => New_List (
1724 New_Occurrence_Of (Stream_Parameter, Loc),
1725 New_Occurrence_Of (Subp_Id, Loc))));
1727 -- For each subprogram, the receiving stub will be built and a
1728 -- case statement will be made on the Subprogram_Id to dispatch
1729 -- to the right subprogram.
1731 Current_Declaration := First (Visible_Declarations (Pkg_Spec));
1733 while Current_Declaration /= Empty loop
1735 if Nkind (Current_Declaration) = N_Subprogram_Declaration
1736 and then Comes_From_Source (Current_Declaration)
1738 pragma Assert (Current_Subprogram_Number =
1739 Get_Subprogram_Id (Defining_Unit_Name (Specification (
1740 Current_Declaration))));
1743 Build_Subprogram_Receiving_Stubs
1744 (Vis_Decl => Current_Declaration,
1746 Nkind (Specification (Current_Declaration)) =
1747 N_Procedure_Specification
1748 and then Is_Asynchronous
1749 (Defining_Unit_Name (Specification
1750 (Current_Declaration))));
1752 Append_To (Decls, Current_Stubs);
1754 Analyze (Current_Stubs);
1756 Actuals := New_List (New_Occurrence_Of (Stream_Parameter, Loc));
1758 if Nkind (Specification (Current_Declaration))
1759 = N_Function_Specification
1761 not Is_Asynchronous (
1762 Defining_Entity (Specification (Current_Declaration)))
1764 -- An asynchronous procedure does not want an output parameter
1765 -- since no result and no exception will ever be returned.
1768 New_Occurrence_Of (Result_Parameter, Loc));
1772 Append_To (Pkg_RPC_Receiver_Cases,
1773 Make_Case_Statement_Alternative (Loc,
1776 Make_Integer_Literal (Loc, Current_Subprogram_Number)),
1780 Make_Procedure_Call_Statement (Loc,
1783 Defining_Entity (Current_Stubs), Loc),
1784 Parameter_Associations =>
1787 Current_Subprogram_Number := Current_Subprogram_Number + 1;
1790 Next (Current_Declaration);
1793 -- If we receive an invalid Subprogram_Id, it is best to do nothing
1794 -- rather than raising an exception since we do not want someone
1795 -- to crash a remote partition by sending invalid subprogram ids.
1796 -- This is consistent with the other parts of the case statement
1797 -- since even in presence of incorrect parameters in the stream,
1798 -- every exception will be caught and (if the subprogram is not an
1799 -- APC) put into the result stream and sent away.
1801 Append_To (Pkg_RPC_Receiver_Cases,
1802 Make_Case_Statement_Alternative (Loc,
1804 New_List (Make_Others_Choice (Loc)),
1806 New_List (Make_Null_Statement (Loc))));
1808 Append_To (Pkg_RPC_Receiver_Statements,
1809 Make_Case_Statement (Loc,
1811 New_Occurrence_Of (Subp_Id, Loc),
1812 Alternatives => Pkg_RPC_Receiver_Cases));
1814 Pkg_RPC_Receiver_Body :=
1815 Make_Subprogram_Body (Loc,
1816 Specification => Pkg_RPC_Receiver_Spec,
1817 Declarations => Pkg_RPC_Receiver_Decls,
1818 Handled_Statement_Sequence =>
1819 Make_Handled_Sequence_Of_Statements (Loc,
1820 Statements => Pkg_RPC_Receiver_Statements));
1822 Append_To (Decls, Pkg_RPC_Receiver_Body);
1823 Analyze (Pkg_RPC_Receiver_Body);
1825 -- Construction of the dummy package used to register the package
1826 -- receiving stubs on the nameserver.
1828 Dummy_Register_Name := New_Internal_Name ('P');
1830 Dummy_Register_Spec :=
1831 Make_Package_Specification (Loc,
1832 Defining_Unit_Name =>
1833 Make_Defining_Identifier (Loc, Dummy_Register_Name),
1834 Visible_Declarations => No_List,
1835 End_Label => Empty);
1837 Dummy_Register_Decl :=
1838 Make_Package_Declaration (Loc,
1839 Specification => Dummy_Register_Spec);
1842 Dummy_Register_Decl);
1843 Analyze (Dummy_Register_Decl);
1845 Dummy_Register_Body :=
1846 Make_Package_Body (Loc,
1847 Defining_Unit_Name =>
1848 Make_Defining_Identifier (Loc, Dummy_Register_Name),
1849 Declarations => No_List,
1851 Handled_Statement_Sequence =>
1852 Make_Handled_Sequence_Of_Statements (Loc,
1853 Statements => New_List (
1854 Make_Procedure_Call_Statement (Loc,
1856 New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
1858 Parameter_Associations => New_List (
1859 Make_String_Literal (Loc,
1860 Strval => Get_Pkg_Name_String_Id (Pkg_Spec)),
1861 Make_Attribute_Reference (Loc,
1863 New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
1865 Name_Unrestricted_Access),
1866 Make_Attribute_Reference (Loc,
1868 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
1872 Append_To (Decls, Dummy_Register_Body);
1873 Analyze (Dummy_Register_Body);
1874 end Add_Receiving_Stubs_To_Declarations;
1880 procedure Add_Stub_Type
1881 (Designated_Type : in Entity_Id;
1882 RACW_Type : in Entity_Id;
1884 Stub_Type : out Entity_Id;
1885 Stub_Type_Access : out Entity_Id;
1886 Object_RPC_Receiver : out Entity_Id;
1887 Existing : out Boolean)
1889 Loc : constant Source_Ptr := Sloc (RACW_Type);
1891 Stub_Elements : constant Stub_Structure :=
1892 Stubs_Table.Get (Designated_Type);
1894 Stub_Type_Declaration : Node_Id;
1895 Stub_Type_Access_Declaration : Node_Id;
1896 Object_RPC_Receiver_Declaration : Node_Id;
1898 RPC_Receiver_Stream : Entity_Id;
1899 RPC_Receiver_Result : Entity_Id;
1902 if Stub_Elements /= Empty_Stub_Structure then
1903 Stub_Type := Stub_Elements.Stub_Type;
1904 Stub_Type_Access := Stub_Elements.Stub_Type_Access;
1905 Object_RPC_Receiver := Stub_Elements.Object_RPC_Receiver;
1912 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1914 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1915 Object_RPC_Receiver :=
1916 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1917 RPC_Receiver_Stream :=
1918 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1919 RPC_Receiver_Result :=
1920 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
1921 Stubs_Table.Set (Designated_Type,
1922 (Stub_Type => Stub_Type,
1923 Stub_Type_Access => Stub_Type_Access,
1924 Object_RPC_Receiver => Object_RPC_Receiver,
1925 RPC_Receiver_Stream => RPC_Receiver_Stream,
1926 RPC_Receiver_Result => RPC_Receiver_Result,
1927 RACW_Type => RACW_Type));
1929 -- The stub type definition below must match exactly the one in
1930 -- s-parint.ads, since unchecked conversions will be used in
1931 -- s-parint.adb to modify pointers passed to Get_Unique_Remote_Pointer.
1933 Stub_Type_Declaration :=
1934 Make_Full_Type_Declaration (Loc,
1935 Defining_Identifier => Stub_Type,
1937 Make_Record_Definition (Loc,
1938 Tagged_Present => True,
1939 Limited_Present => True,
1941 Make_Component_List (Loc,
1942 Component_Items => New_List (
1944 Make_Component_Declaration (Loc,
1945 Defining_Identifier =>
1946 Make_Defining_Identifier (Loc, Name_Origin),
1947 Component_Definition =>
1948 Make_Component_Definition (Loc,
1949 Aliased_Present => False,
1950 Subtype_Indication =>
1951 New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
1953 Make_Component_Declaration (Loc,
1954 Defining_Identifier =>
1955 Make_Defining_Identifier (Loc, Name_Receiver),
1956 Component_Definition =>
1957 Make_Component_Definition (Loc,
1958 Aliased_Present => False,
1959 Subtype_Indication =>
1960 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
1962 Make_Component_Declaration (Loc,
1963 Defining_Identifier =>
1964 Make_Defining_Identifier (Loc, Name_Addr),
1965 Component_Definition =>
1966 Make_Component_Definition (Loc,
1967 Aliased_Present => False,
1968 Subtype_Indication =>
1969 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
1971 Make_Component_Declaration (Loc,
1972 Defining_Identifier =>
1973 Make_Defining_Identifier (Loc, Name_Asynchronous),
1974 Component_Definition =>
1975 Make_Component_Definition (Loc,
1976 Aliased_Present => False,
1977 Subtype_Indication =>
1978 New_Occurrence_Of (Standard_Boolean, Loc)))))));
1980 Append_To (Decls, Stub_Type_Declaration);
1981 Analyze (Stub_Type_Declaration);
1983 -- This is in no way a type derivation, but we fake it to make
1984 -- sure that the dispatching table gets built with the corresponding
1985 -- primitive operations at the right place.
1987 Derive_Subprograms (Parent_Type => Designated_Type,
1988 Derived_Type => Stub_Type);
1990 Stub_Type_Access_Declaration :=
1991 Make_Full_Type_Declaration (Loc,
1992 Defining_Identifier => Stub_Type_Access,
1994 Make_Access_To_Object_Definition (Loc,
1995 Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
1997 Append_To (Decls, Stub_Type_Access_Declaration);
1998 Analyze (Stub_Type_Access_Declaration);
2000 Object_RPC_Receiver_Declaration :=
2001 Make_Subprogram_Declaration (Loc,
2002 Build_RPC_Receiver_Specification (
2003 RPC_Receiver => Object_RPC_Receiver,
2004 Stream_Parameter => RPC_Receiver_Stream,
2005 Result_Parameter => RPC_Receiver_Result));
2007 Append_To (Decls, Object_RPC_Receiver_Declaration);
2010 ---------------------------------
2011 -- Build_General_Calling_Stubs --
2012 ---------------------------------
2014 procedure Build_General_Calling_Stubs
2016 Statements : List_Id;
2017 Target_Partition : Entity_Id;
2018 RPC_Receiver : Node_Id;
2019 Subprogram_Id : Node_Id;
2020 Asynchronous : Node_Id := Empty;
2021 Is_Known_Asynchronous : Boolean := False;
2022 Is_Known_Non_Asynchronous : Boolean := False;
2023 Is_Function : Boolean;
2025 Object_Type : Entity_Id := Empty;
2028 Loc : constant Source_Ptr := Sloc (Nod);
2030 Stream_Parameter : Node_Id;
2031 -- Name of the stream used to transmit parameters to the remote package
2033 Result_Parameter : Node_Id;
2034 -- Name of the result parameter (in non-APC cases) which get the
2035 -- result of the remote subprogram.
2037 Exception_Return_Parameter : Node_Id;
2038 -- Name of the parameter which will hold the exception sent by the
2039 -- remote subprogram.
2041 Current_Parameter : Node_Id;
2042 -- Current parameter being handled
2044 Ordered_Parameters_List : constant List_Id :=
2045 Build_Ordered_Parameters_List (Spec);
2047 Asynchronous_Statements : List_Id := No_List;
2048 Non_Asynchronous_Statements : List_Id := No_List;
2049 -- Statements specifics to the Asynchronous/Non-Asynchronous cases.
2051 Extra_Formal_Statements : constant List_Id := New_List;
2052 -- List of statements for extra formal parameters. It will appear after
2053 -- the regular statements for writing out parameters.
2056 -- The general form of a calling stub for a given subprogram is:
2058 -- procedure X (...) is
2059 -- P : constant Partition_ID := RCI_Cache.Get_Active_Partition_ID;
2060 -- Stream, Result : aliased System.RPC.Params_Stream_Type (0);
2062 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
2063 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
2064 -- Put_Subprogram_Id_In_Stream;
2065 -- Put_Parameters_In_Stream;
2066 -- Do_RPC (Stream, Result);
2067 -- Read_Exception_Occurrence_From_Result; Raise_It;
2068 -- Read_Out_Parameters_And_Function_Return_From_Stream;
2071 -- There are some variations: Do_APC is called for an asynchronous
2072 -- procedure and the part after the call is completely ommitted
2073 -- as well as the declaration of Result. For a function call,
2074 -- 'Input is always used to read the result even if it is constrained.
2077 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2080 Make_Object_Declaration (Loc,
2081 Defining_Identifier => Stream_Parameter,
2082 Aliased_Present => True,
2083 Object_Definition =>
2084 Make_Subtype_Indication (Loc,
2086 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
2088 Make_Index_Or_Discriminant_Constraint (Loc,
2090 New_List (Make_Integer_Literal (Loc, 0))))));
2092 if not Is_Known_Asynchronous then
2094 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2097 Make_Object_Declaration (Loc,
2098 Defining_Identifier => Result_Parameter,
2099 Aliased_Present => True,
2100 Object_Definition =>
2101 Make_Subtype_Indication (Loc,
2103 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
2105 Make_Index_Or_Discriminant_Constraint (Loc,
2107 New_List (Make_Integer_Literal (Loc, 0))))));
2109 Exception_Return_Parameter :=
2110 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
2113 Make_Object_Declaration (Loc,
2114 Defining_Identifier => Exception_Return_Parameter,
2115 Object_Definition =>
2116 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
2119 Result_Parameter := Empty;
2120 Exception_Return_Parameter := Empty;
2123 -- Put first the RPC receiver corresponding to the remote package
2125 Append_To (Statements,
2126 Make_Attribute_Reference (Loc,
2128 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
2129 Attribute_Name => Name_Write,
2130 Expressions => New_List (
2131 Make_Attribute_Reference (Loc,
2133 New_Occurrence_Of (Stream_Parameter, Loc),
2138 -- Then put the Subprogram_Id of the subprogram we want to call in
2141 Append_To (Statements,
2142 Make_Attribute_Reference (Loc,
2144 New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
2147 Expressions => New_List (
2148 Make_Attribute_Reference (Loc,
2150 New_Occurrence_Of (Stream_Parameter, Loc),
2151 Attribute_Name => Name_Access),
2154 Current_Parameter := First (Ordered_Parameters_List);
2156 while Current_Parameter /= Empty loop
2159 Typ : constant Node_Id :=
2160 Parameter_Type (Current_Parameter);
2162 Constrained : Boolean;
2164 Extra_Parameter : Entity_Id;
2168 if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then
2170 -- In the case of a controlling formal argument, we marshall
2171 -- its addr field rather than the local stub.
2173 Append_To (Statements,
2174 Pack_Node_Into_Stream (Loc,
2175 Stream => Stream_Parameter,
2177 Make_Selected_Component (Loc,
2180 Defining_Identifier (Current_Parameter), Loc),
2182 Make_Identifier (Loc, Name_Addr)),
2183 Etyp => RTE (RE_Unsigned_64)));
2186 Value := New_Occurrence_Of
2187 (Defining_Identifier (Current_Parameter), Loc);
2189 -- Access type parameters are transmitted as in out
2190 -- parameters. However, a dereference is needed so that
2191 -- we marshall the designated object.
2193 if Nkind (Typ) = N_Access_Definition then
2194 Value := Make_Explicit_Dereference (Loc, Value);
2195 Etyp := Etype (Subtype_Mark (Typ));
2197 Etyp := Etype (Typ);
2201 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
2203 -- Any parameter but unconstrained out parameters are
2204 -- transmitted to the peer.
2206 if In_Present (Current_Parameter)
2207 or else not Out_Present (Current_Parameter)
2208 or else not Constrained
2210 Append_To (Statements,
2211 Make_Attribute_Reference (Loc,
2213 New_Occurrence_Of (Etyp, Loc),
2214 Attribute_Name => Output_From_Constrained (Constrained),
2215 Expressions => New_List (
2216 Make_Attribute_Reference (Loc,
2218 New_Occurrence_Of (Stream_Parameter, Loc),
2219 Attribute_Name => Name_Access),
2224 -- If the current parameter has a dynamic constrained status,
2225 -- then this status is transmitted as well.
2226 -- This should be done for accessibility as well ???
2228 if Nkind (Typ) /= N_Access_Definition
2229 and then Need_Extra_Constrained (Current_Parameter)
2231 -- In this block, we do not use the extra formal that has been
2232 -- created because it does not exist at the time of expansion
2233 -- when building calling stubs for remote access to subprogram
2234 -- types. We create an extra variable of this type and push it
2235 -- in the stream after the regular parameters.
2237 Extra_Parameter := Make_Defining_Identifier
2238 (Loc, New_Internal_Name ('P'));
2241 Make_Object_Declaration (Loc,
2242 Defining_Identifier => Extra_Parameter,
2243 Constant_Present => True,
2244 Object_Definition =>
2245 New_Occurrence_Of (Standard_Boolean, Loc),
2247 Make_Attribute_Reference (Loc,
2250 Defining_Identifier (Current_Parameter), Loc),
2251 Attribute_Name => Name_Constrained)));
2253 Append_To (Extra_Formal_Statements,
2254 Make_Attribute_Reference (Loc,
2256 New_Occurrence_Of (Standard_Boolean, Loc),
2259 Expressions => New_List (
2260 Make_Attribute_Reference (Loc,
2262 New_Occurrence_Of (Stream_Parameter, Loc),
2265 New_Occurrence_Of (Extra_Parameter, Loc))));
2268 Next (Current_Parameter);
2272 -- Append the formal statements list to the statements
2274 Append_List_To (Statements, Extra_Formal_Statements);
2276 if not Is_Known_Non_Asynchronous then
2278 -- Build the call to System.RPC.Do_APC
2280 Asynchronous_Statements := New_List (
2281 Make_Procedure_Call_Statement (Loc,
2283 New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
2284 Parameter_Associations => New_List (
2285 New_Occurrence_Of (Target_Partition, Loc),
2286 Make_Attribute_Reference (Loc,
2288 New_Occurrence_Of (Stream_Parameter, Loc),
2292 Asynchronous_Statements := No_List;
2295 if not Is_Known_Asynchronous then
2297 -- Build the call to System.RPC.Do_RPC
2299 Non_Asynchronous_Statements := New_List (
2300 Make_Procedure_Call_Statement (Loc,
2302 New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
2303 Parameter_Associations => New_List (
2304 New_Occurrence_Of (Target_Partition, Loc),
2306 Make_Attribute_Reference (Loc,
2308 New_Occurrence_Of (Stream_Parameter, Loc),
2312 Make_Attribute_Reference (Loc,
2314 New_Occurrence_Of (Result_Parameter, Loc),
2318 -- Read the exception occurrence from the result stream and
2319 -- reraise it. It does no harm if this is a Null_Occurrence since
2320 -- this does nothing.
2322 Append_To (Non_Asynchronous_Statements,
2323 Make_Attribute_Reference (Loc,
2325 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
2330 Expressions => New_List (
2331 Make_Attribute_Reference (Loc,
2333 New_Occurrence_Of (Result_Parameter, Loc),
2336 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
2338 Append_To (Non_Asynchronous_Statements,
2339 Make_Procedure_Call_Statement (Loc,
2341 New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
2342 Parameter_Associations => New_List (
2343 New_Occurrence_Of (Exception_Return_Parameter, Loc))));
2347 -- If this is a function call, then read the value and return
2348 -- it. The return value is written/read using 'Output/'Input.
2350 Append_To (Non_Asynchronous_Statements,
2351 Make_Tag_Check (Loc,
2352 Make_Return_Statement (Loc,
2354 Make_Attribute_Reference (Loc,
2357 Etype (Subtype_Mark (Spec)), Loc),
2359 Attribute_Name => Name_Input,
2361 Expressions => New_List (
2362 Make_Attribute_Reference (Loc,
2364 New_Occurrence_Of (Result_Parameter, Loc),
2365 Attribute_Name => Name_Access))))));
2368 -- Loop around parameters and assign out (or in out) parameters.
2369 -- In the case of RACW, controlling arguments cannot possibly
2370 -- have changed since they are remote, so we do not read them
2373 Current_Parameter :=
2374 First (Ordered_Parameters_List);
2376 while Current_Parameter /= Empty loop
2379 Typ : constant Node_Id :=
2380 Parameter_Type (Current_Parameter);
2384 Value := New_Occurrence_Of
2385 (Defining_Identifier (Current_Parameter), Loc);
2387 if Nkind (Typ) = N_Access_Definition then
2388 Value := Make_Explicit_Dereference (Loc, Value);
2389 Etyp := Etype (Subtype_Mark (Typ));
2391 Etyp := Etype (Typ);
2394 if (Out_Present (Current_Parameter)
2395 or else Nkind (Typ) = N_Access_Definition)
2396 and then Etyp /= Object_Type
2398 Append_To (Non_Asynchronous_Statements,
2399 Make_Attribute_Reference (Loc,
2401 New_Occurrence_Of (Etyp, Loc),
2403 Attribute_Name => Name_Read,
2405 Expressions => New_List (
2406 Make_Attribute_Reference (Loc,
2408 New_Occurrence_Of (Result_Parameter, Loc),
2415 Next (Current_Parameter);
2420 if Is_Known_Asynchronous then
2421 Append_List_To (Statements, Asynchronous_Statements);
2423 elsif Is_Known_Non_Asynchronous then
2424 Append_List_To (Statements, Non_Asynchronous_Statements);
2427 pragma Assert (Asynchronous /= Empty);
2428 Prepend_To (Asynchronous_Statements,
2429 Make_Attribute_Reference (Loc,
2430 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
2431 Attribute_Name => Name_Write,
2432 Expressions => New_List (
2433 Make_Attribute_Reference (Loc,
2434 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
2435 Attribute_Name => Name_Access),
2436 New_Occurrence_Of (Standard_True, Loc))));
2437 Prepend_To (Non_Asynchronous_Statements,
2438 Make_Attribute_Reference (Loc,
2439 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
2440 Attribute_Name => Name_Write,
2441 Expressions => New_List (
2442 Make_Attribute_Reference (Loc,
2443 Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
2444 Attribute_Name => Name_Access),
2445 New_Occurrence_Of (Standard_False, Loc))));
2446 Append_To (Statements,
2447 Make_Implicit_If_Statement (Nod,
2448 Condition => Asynchronous,
2449 Then_Statements => Asynchronous_Statements,
2450 Else_Statements => Non_Asynchronous_Statements));
2452 end Build_General_Calling_Stubs;
2454 -----------------------------------
2455 -- Build_Ordered_Parameters_List --
2456 -----------------------------------
2458 function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
2459 Constrained_List : List_Id;
2460 Unconstrained_List : List_Id;
2461 Current_Parameter : Node_Id;
2464 if not Present (Parameter_Specifications (Spec)) then
2468 Constrained_List := New_List;
2469 Unconstrained_List := New_List;
2471 -- Loop through the parameters and add them to the right list
2473 Current_Parameter := First (Parameter_Specifications (Spec));
2474 while Current_Parameter /= Empty loop
2476 if Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
2478 Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
2480 Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter)))
2482 Append_To (Constrained_List, New_Copy (Current_Parameter));
2484 Append_To (Unconstrained_List, New_Copy (Current_Parameter));
2487 Next (Current_Parameter);
2490 -- Unconstrained parameters are returned first
2492 Append_List_To (Unconstrained_List, Constrained_List);
2494 return Unconstrained_List;
2496 end Build_Ordered_Parameters_List;
2498 ----------------------------------
2499 -- Build_Passive_Partition_Stub --
2500 ----------------------------------
2502 procedure Build_Passive_Partition_Stub (U : Node_Id) is
2506 Loc : constant Source_Ptr := Sloc (U);
2509 -- Verify that the implementation supports distribution, by accessing
2510 -- a type defined in the proper version of system.rpc
2513 Dist_OK : Entity_Id;
2514 pragma Warnings (Off, Dist_OK);
2517 Dist_OK := RTE (RE_Params_Stream_Type);
2520 -- Use body if present, spec otherwise
2522 if Nkind (U) = N_Package_Declaration then
2523 Pkg_Spec := Specification (U);
2524 L := Visible_Declarations (Pkg_Spec);
2526 Pkg_Spec := Parent (Corresponding_Spec (U));
2527 L := Declarations (U);
2531 Make_Procedure_Call_Statement (Loc,
2533 New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
2534 Parameter_Associations => New_List (
2535 Make_String_Literal (Loc, Get_Pkg_Name_String_Id (Pkg_Spec)),
2536 Make_Attribute_Reference (Loc,
2538 New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
2543 end Build_Passive_Partition_Stub;
2545 --------------------------------------
2546 -- Build_RPC_Receiver_Specification --
2547 --------------------------------------
2549 function Build_RPC_Receiver_Specification
2550 (RPC_Receiver : Entity_Id;
2551 Stream_Parameter : Entity_Id;
2552 Result_Parameter : Entity_Id)
2555 Loc : constant Source_Ptr := Sloc (RPC_Receiver);
2559 Make_Procedure_Specification (Loc,
2560 Defining_Unit_Name => RPC_Receiver,
2561 Parameter_Specifications => New_List (
2562 Make_Parameter_Specification (Loc,
2563 Defining_Identifier => Stream_Parameter,
2565 Make_Access_Definition (Loc,
2567 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
2569 Make_Parameter_Specification (Loc,
2570 Defining_Identifier => Result_Parameter,
2572 Make_Access_Definition (Loc,
2575 (RTE (RE_Params_Stream_Type), Loc)))));
2576 end Build_RPC_Receiver_Specification;
2578 ------------------------------------
2579 -- Build_Subprogram_Calling_Stubs --
2580 ------------------------------------
2582 function Build_Subprogram_Calling_Stubs
2583 (Vis_Decl : Node_Id;
2585 Asynchronous : Boolean;
2586 Dynamically_Asynchronous : Boolean := False;
2587 Stub_Type : Entity_Id := Empty;
2588 Locator : Entity_Id := Empty;
2589 New_Name : Name_Id := No_Name)
2592 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2594 Target_Partition : Node_Id;
2595 -- Contains the name of the target partition
2597 Decls : constant List_Id := New_List;
2598 Statements : constant List_Id := New_List;
2600 Subp_Spec : Node_Id;
2601 -- The specification of the body
2603 Controlling_Parameter : Entity_Id := Empty;
2604 RPC_Receiver : Node_Id;
2606 Asynchronous_Expr : Node_Id := Empty;
2608 RCI_Locator : Entity_Id;
2610 Spec_To_Use : Node_Id;
2612 procedure Insert_Partition_Check (Parameter : in Node_Id);
2613 -- Check that the parameter has been elaborated on the same partition
2614 -- than the controlling parameter (E.4(19)).
2616 ----------------------------
2617 -- Insert_Partition_Check --
2618 ----------------------------
2620 procedure Insert_Partition_Check (Parameter : in Node_Id) is
2621 Parameter_Entity : constant Entity_Id :=
2622 Defining_Identifier (Parameter);
2623 Condition : Node_Id;
2625 Designated_Object : Node_Id;
2626 pragma Warnings (Off, Designated_Object);
2627 -- Is it really right that this is unreferenced ???
2630 -- The expression that will be built is of the form:
2631 -- if not (Parameter in Stub_Type and then
2632 -- Parameter.Origin = Controlling.Origin)
2634 -- raise Constraint_Error;
2637 -- Condition contains the reversed condition. Also, Parameter is
2638 -- dereferenced if it is an access type. We do not check that
2639 -- Parameter is in Stub_Type since such a check has been inserted
2640 -- at the point of call already (a tag check since we have multiple
2641 -- controlling operands).
2643 if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
2644 Designated_Object :=
2645 Make_Explicit_Dereference (Loc,
2646 Prefix => New_Occurrence_Of (Parameter_Entity, Loc));
2648 Designated_Object := New_Occurrence_Of (Parameter_Entity, Loc);
2654 Make_Selected_Component (Loc,
2656 New_Occurrence_Of (Parameter_Entity, Loc),
2658 Make_Identifier (Loc, Name_Origin)),
2661 Make_Selected_Component (Loc,
2663 New_Occurrence_Of (Controlling_Parameter, Loc),
2665 Make_Identifier (Loc, Name_Origin)));
2668 Make_Raise_Constraint_Error (Loc,
2670 Make_Op_Not (Loc, Right_Opnd => Condition),
2671 Reason => CE_Partition_Check_Failed));
2672 end Insert_Partition_Check;
2674 -- Start of processing for Build_Subprogram_Calling_Stubs
2678 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
2680 Subp_Spec := Copy_Specification (Loc,
2681 Spec => Specification (Vis_Decl),
2682 New_Name => New_Name);
2684 if Locator = Empty then
2685 RCI_Locator := RCI_Cache;
2686 Spec_To_Use := Specification (Vis_Decl);
2688 RCI_Locator := Locator;
2689 Spec_To_Use := Subp_Spec;
2692 -- Find a controlling argument if we have a stub type. Also check
2693 -- if this subprogram can be made asynchronous.
2695 if Stub_Type /= Empty
2696 and then Present (Parameter_Specifications (Spec_To_Use))
2699 Current_Parameter : Node_Id :=
2700 First (Parameter_Specifications
2703 while Current_Parameter /= Empty loop
2706 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2708 if Controlling_Parameter = Empty then
2709 Controlling_Parameter :=
2710 Defining_Identifier (Current_Parameter);
2712 Insert_Partition_Check (Current_Parameter);
2716 Next (Current_Parameter);
2721 if Stub_Type /= Empty then
2722 pragma Assert (Controlling_Parameter /= Empty);
2725 Make_Object_Declaration (Loc,
2726 Defining_Identifier => Target_Partition,
2727 Constant_Present => True,
2728 Object_Definition =>
2729 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
2732 Make_Selected_Component (Loc,
2734 New_Occurrence_Of (Controlling_Parameter, Loc),
2736 Make_Identifier (Loc, Name_Origin))));
2739 Make_Selected_Component (Loc,
2741 New_Occurrence_Of (Controlling_Parameter, Loc),
2743 Make_Identifier (Loc, Name_Receiver));
2747 Make_Object_Declaration (Loc,
2748 Defining_Identifier => Target_Partition,
2749 Constant_Present => True,
2750 Object_Definition =>
2751 New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
2754 Make_Function_Call (Loc,
2755 Name => Make_Selected_Component (Loc,
2757 Make_Identifier (Loc, Chars (RCI_Locator)),
2759 Make_Identifier (Loc, Name_Get_Active_Partition_ID)))));
2762 Make_Selected_Component (Loc,
2764 Make_Identifier (Loc, Chars (RCI_Locator)),
2766 Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
2769 if Dynamically_Asynchronous then
2770 Asynchronous_Expr :=
2771 Make_Selected_Component (Loc,
2773 New_Occurrence_Of (Controlling_Parameter, Loc),
2775 Make_Identifier (Loc, Name_Asynchronous));
2778 Build_General_Calling_Stubs
2780 Statements => Statements,
2781 Target_Partition => Target_Partition,
2782 RPC_Receiver => RPC_Receiver,
2783 Subprogram_Id => Make_Integer_Literal (Loc, Subp_Id),
2784 Asynchronous => Asynchronous_Expr,
2785 Is_Known_Asynchronous => Asynchronous
2786 and then not Dynamically_Asynchronous,
2787 Is_Known_Non_Asynchronous
2789 and then not Dynamically_Asynchronous,
2790 Is_Function => Nkind (Spec_To_Use) =
2791 N_Function_Specification,
2792 Spec => Spec_To_Use,
2793 Object_Type => Stub_Type,
2796 RCI_Calling_Stubs_Table.Set
2797 (Defining_Unit_Name (Specification (Vis_Decl)),
2798 Defining_Unit_Name (Spec_To_Use));
2801 Make_Subprogram_Body (Loc,
2802 Specification => Subp_Spec,
2803 Declarations => Decls,
2804 Handled_Statement_Sequence =>
2805 Make_Handled_Sequence_Of_Statements (Loc, Statements));
2806 end Build_Subprogram_Calling_Stubs;
2808 -------------------------
2809 -- Build_Subprogram_Id --
2810 -------------------------
2812 function Build_Subprogram_Id
2814 E : Entity_Id) return Node_Id
2817 return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
2818 end Build_Subprogram_Id;
2820 --------------------------------------
2821 -- Build_Subprogram_Receiving_Stubs --
2822 --------------------------------------
2824 function Build_Subprogram_Receiving_Stubs
2825 (Vis_Decl : Node_Id;
2826 Asynchronous : Boolean;
2827 Dynamically_Asynchronous : Boolean := False;
2828 Stub_Type : Entity_Id := Empty;
2829 RACW_Type : Entity_Id := Empty;
2830 Parent_Primitive : Entity_Id := Empty)
2833 Loc : constant Source_Ptr := Sloc (Vis_Decl);
2835 Stream_Parameter : Node_Id;
2836 Result_Parameter : Node_Id;
2837 -- See explanations of those in Build_Subprogram_Calling_Stubs
2839 Decls : constant List_Id := New_List;
2840 -- All the parameters will get declared before calling the real
2841 -- subprograms. Also the out parameters will be declared.
2843 Statements : constant List_Id := New_List;
2845 Extra_Formal_Statements : constant List_Id := New_List;
2846 -- Statements concerning extra formal parameters
2848 After_Statements : constant List_Id := New_List;
2849 -- Statements to be executed after the subprogram call
2851 Inner_Decls : List_Id := No_List;
2852 -- In case of a function, the inner declarations are needed since
2853 -- the result may be unconstrained.
2855 Excep_Handler : Node_Id;
2856 Excep_Choice : Entity_Id;
2857 Excep_Code : List_Id;
2859 Parameter_List : constant List_Id := New_List;
2860 -- List of parameters to be passed to the subprogram
2862 Current_Parameter : Node_Id;
2864 Ordered_Parameters_List : constant List_Id :=
2865 Build_Ordered_Parameters_List
2866 (Specification (Vis_Decl));
2868 Subp_Spec : Node_Id;
2869 -- Subprogram specification
2871 Called_Subprogram : Node_Id;
2872 -- The subprogram to call
2874 Null_Raise_Statement : Node_Id;
2876 Dynamic_Async : Entity_Id;
2879 if RACW_Type /= Empty then
2880 Called_Subprogram :=
2881 New_Occurrence_Of (Parent_Primitive, Loc);
2883 Called_Subprogram :=
2885 Defining_Unit_Name (Specification (Vis_Decl)), Loc);
2889 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2891 if Dynamically_Asynchronous then
2893 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2895 Dynamic_Async := Empty;
2898 if not Asynchronous or else Dynamically_Asynchronous then
2900 Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2902 -- The first statement after the subprogram call is a statement to
2903 -- writes a Null_Occurrence into the result stream.
2905 Null_Raise_Statement :=
2906 Make_Attribute_Reference (Loc,
2908 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
2909 Attribute_Name => Name_Write,
2910 Expressions => New_List (
2911 New_Occurrence_Of (Result_Parameter, Loc),
2912 New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
2914 if Dynamically_Asynchronous then
2915 Null_Raise_Statement :=
2916 Make_Implicit_If_Statement (Vis_Decl,
2918 Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
2919 Then_Statements => New_List (Null_Raise_Statement));
2922 Append_To (After_Statements, Null_Raise_Statement);
2925 Result_Parameter := Empty;
2928 -- Loop through every parameter and get its value from the stream. If
2929 -- the parameter is unconstrained, then the parameter is read using
2930 -- 'Input at the point of declaration.
2932 Current_Parameter := First (Ordered_Parameters_List);
2934 while Current_Parameter /= Empty loop
2938 Constrained : Boolean;
2940 Expr : Node_Id := Empty;
2943 Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
2944 Set_Ekind (Object, E_Variable);
2947 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
2949 -- We have a controlling formal parameter. Read its address
2950 -- rather than a real object. The address is in Unsigned_64
2953 Etyp := RTE (RE_Unsigned_64);
2955 Etyp := Etype (Parameter_Type (Current_Parameter));
2959 Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
2961 if In_Present (Current_Parameter)
2962 or else not Out_Present (Current_Parameter)
2963 or else not Constrained
2965 -- If an input parameter is contrained, then its reading is
2966 -- deferred until the beginning of the subprogram body. If
2967 -- it is unconstrained, then an expression is built for
2968 -- the object declaration and the variable is set using
2969 -- 'Input instead of 'Read.
2972 Append_To (Statements,
2973 Make_Attribute_Reference (Loc,
2974 Prefix => New_Occurrence_Of (Etyp, Loc),
2975 Attribute_Name => Name_Read,
2976 Expressions => New_List (
2977 New_Occurrence_Of (Stream_Parameter, Loc),
2978 New_Occurrence_Of (Object, Loc))));
2981 Expr := Input_With_Tag_Check (Loc,
2983 Stream => Stream_Parameter);
2984 Append_To (Decls, Expr);
2985 Expr := Make_Function_Call (Loc,
2986 New_Occurrence_Of (Defining_Unit_Name
2987 (Specification (Expr)), Loc));
2991 -- If we do not have to output the current parameter, then
2992 -- it can well be flagged as constant. This may allow further
2993 -- optimizations done by the back end.
2996 Make_Object_Declaration (Loc,
2997 Defining_Identifier => Object,
2999 not Constrained and then not Out_Present (Current_Parameter),
3000 Object_Definition =>
3001 New_Occurrence_Of (Etyp, Loc),
3002 Expression => Expr));
3004 -- An out parameter may be written back using a 'Write
3005 -- attribute instead of a 'Output because it has been
3006 -- constrained by the parameter given to the caller. Note that
3007 -- out controlling arguments in the case of a RACW are not put
3008 -- back in the stream because the pointer on them has not
3011 if Out_Present (Current_Parameter)
3013 Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
3015 Append_To (After_Statements,
3016 Make_Attribute_Reference (Loc,
3017 Prefix => New_Occurrence_Of (Etyp, Loc),
3018 Attribute_Name => Name_Write,
3019 Expressions => New_List (
3020 New_Occurrence_Of (Result_Parameter, Loc),
3021 New_Occurrence_Of (Object, Loc))));
3025 Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
3028 if Nkind (Parameter_Type (Current_Parameter)) /=
3031 Append_To (Parameter_List,
3032 Make_Parameter_Association (Loc,
3035 Defining_Identifier (Current_Parameter), Loc),
3036 Explicit_Actual_Parameter =>
3037 Make_Explicit_Dereference (Loc,
3038 Unchecked_Convert_To (RACW_Type,
3039 OK_Convert_To (RTE (RE_Address),
3040 New_Occurrence_Of (Object, Loc))))));
3042 Append_To (Parameter_List,
3043 Make_Parameter_Association (Loc,
3046 Defining_Identifier (Current_Parameter), Loc),
3047 Explicit_Actual_Parameter =>
3048 Unchecked_Convert_To (RACW_Type,
3049 OK_Convert_To (RTE (RE_Address),
3050 New_Occurrence_Of (Object, Loc)))));
3053 Append_To (Parameter_List,
3054 Make_Parameter_Association (Loc,
3057 Defining_Identifier (Current_Parameter), Loc),
3058 Explicit_Actual_Parameter =>
3059 New_Occurrence_Of (Object, Loc)));
3062 -- If the current parameter needs an extra formal, then read it
3063 -- from the stream and set the corresponding semantic field in
3064 -- the variable. If the kind of the parameter identifier is
3065 -- E_Void, then this is a compiler generated parameter that
3066 -- doesn't need an extra constrained status.
3068 -- The case of Extra_Accessibility should also be handled ???
3070 if Nkind (Parameter_Type (Current_Parameter)) /=
3073 Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
3075 Present (Extra_Constrained
3076 (Defining_Identifier (Current_Parameter)))
3079 Extra_Parameter : constant Entity_Id :=
3081 (Defining_Identifier
3082 (Current_Parameter));
3084 Formal_Entity : constant Entity_Id :=
3085 Make_Defining_Identifier
3086 (Loc, Chars (Extra_Parameter));
3088 Formal_Type : constant Entity_Id :=
3089 Etype (Extra_Parameter);
3093 Make_Object_Declaration (Loc,
3094 Defining_Identifier => Formal_Entity,
3095 Object_Definition =>
3096 New_Occurrence_Of (Formal_Type, Loc)));
3098 Append_To (Extra_Formal_Statements,
3099 Make_Attribute_Reference (Loc,
3100 Prefix => New_Occurrence_Of (Formal_Type, Loc),
3101 Attribute_Name => Name_Read,
3102 Expressions => New_List (
3103 New_Occurrence_Of (Stream_Parameter, Loc),
3104 New_Occurrence_Of (Formal_Entity, Loc))));
3105 Set_Extra_Constrained (Object, Formal_Entity);
3110 Next (Current_Parameter);
3113 -- Append the formal statements list at the end of regular statements
3115 Append_List_To (Statements, Extra_Formal_Statements);
3117 if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
3119 -- The remote subprogram is a function. We build an inner block to
3120 -- be able to hold a potentially unconstrained result in a variable.
3123 Etyp : constant Entity_Id :=
3124 Etype (Subtype_Mark (Specification (Vis_Decl)));
3125 Result : constant Node_Id :=
3126 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3129 Inner_Decls := New_List (
3130 Make_Object_Declaration (Loc,
3131 Defining_Identifier => Result,
3132 Constant_Present => True,
3133 Object_Definition => New_Occurrence_Of (Etyp, Loc),
3135 Make_Function_Call (Loc,
3136 Name => Called_Subprogram,
3137 Parameter_Associations => Parameter_List)));
3139 Append_To (After_Statements,
3140 Make_Attribute_Reference (Loc,
3141 Prefix => New_Occurrence_Of (Etyp, Loc),
3142 Attribute_Name => Name_Output,
3143 Expressions => New_List (
3144 New_Occurrence_Of (Result_Parameter, Loc),
3145 New_Occurrence_Of (Result, Loc))));
3148 Append_To (Statements,
3149 Make_Block_Statement (Loc,
3150 Declarations => Inner_Decls,
3151 Handled_Statement_Sequence =>
3152 Make_Handled_Sequence_Of_Statements (Loc,
3153 Statements => After_Statements)));
3156 -- The remote subprogram is a procedure. We do not need any inner
3157 -- block in this case.
3159 if Dynamically_Asynchronous then
3161 Make_Object_Declaration (Loc,
3162 Defining_Identifier => Dynamic_Async,
3163 Object_Definition =>
3164 New_Occurrence_Of (Standard_Boolean, Loc)));
3166 Append_To (Statements,
3167 Make_Attribute_Reference (Loc,
3168 Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
3169 Attribute_Name => Name_Read,
3170 Expressions => New_List (
3171 New_Occurrence_Of (Stream_Parameter, Loc),
3172 New_Occurrence_Of (Dynamic_Async, Loc))));
3175 Append_To (Statements,
3176 Make_Procedure_Call_Statement (Loc,
3177 Name => Called_Subprogram,
3178 Parameter_Associations => Parameter_List));
3180 Append_List_To (Statements, After_Statements);
3184 if Asynchronous and then not Dynamically_Asynchronous then
3186 -- An asynchronous procedure does not want a Result
3187 -- parameter. Also, we put an exception handler with an others
3188 -- clause that does nothing.
3191 Make_Procedure_Specification (Loc,
3192 Defining_Unit_Name =>
3193 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
3194 Parameter_Specifications => New_List (
3195 Make_Parameter_Specification (Loc,
3196 Defining_Identifier => Stream_Parameter,
3198 Make_Access_Definition (Loc,
3200 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc)))));
3203 Make_Exception_Handler (Loc,
3204 Exception_Choices =>
3205 New_List (Make_Others_Choice (Loc)),
3206 Statements => New_List (
3207 Make_Null_Statement (Loc)));
3210 -- In the other cases, if an exception is raised, then the
3211 -- exception occurrence is copied into the output stream and
3212 -- no other output parameter is written.
3215 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3217 Excep_Code := New_List (
3218 Make_Attribute_Reference (Loc,
3220 New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
3221 Attribute_Name => Name_Write,
3222 Expressions => New_List (
3223 New_Occurrence_Of (Result_Parameter, Loc),
3224 New_Occurrence_Of (Excep_Choice, Loc))));
3226 if Dynamically_Asynchronous then
3227 Excep_Code := New_List (
3228 Make_Implicit_If_Statement (Vis_Decl,
3229 Condition => Make_Op_Not (Loc,
3230 New_Occurrence_Of (Dynamic_Async, Loc)),
3231 Then_Statements => Excep_Code));
3235 Make_Exception_Handler (Loc,
3236 Choice_Parameter => Excep_Choice,
3237 Exception_Choices => New_List (Make_Others_Choice (Loc)),
3238 Statements => Excep_Code);
3241 Make_Procedure_Specification (Loc,
3242 Defining_Unit_Name =>
3243 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
3245 Parameter_Specifications => New_List (
3246 Make_Parameter_Specification (Loc,
3247 Defining_Identifier => Stream_Parameter,
3249 Make_Access_Definition (Loc,
3251 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
3253 Make_Parameter_Specification (Loc,
3254 Defining_Identifier => Result_Parameter,
3256 Make_Access_Definition (Loc,
3258 New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc)))));
3262 Make_Subprogram_Body (Loc,
3263 Specification => Subp_Spec,
3264 Declarations => Decls,
3265 Handled_Statement_Sequence =>
3266 Make_Handled_Sequence_Of_Statements (Loc,
3267 Statements => Statements,
3268 Exception_Handlers => New_List (Excep_Handler)));
3270 end Build_Subprogram_Receiving_Stubs;
3272 ------------------------
3273 -- Copy_Specification --
3274 ------------------------
3276 function Copy_Specification
3279 Object_Type : Entity_Id := Empty;
3280 Stub_Type : Entity_Id := Empty;
3281 New_Name : Name_Id := No_Name)
3284 Parameters : List_Id := No_List;
3286 Current_Parameter : Node_Id;
3287 Current_Type : Node_Id;
3288 Current_Etype : Entity_Id;
3290 Name_For_New_Spec : Name_Id;
3292 New_Identifier : Entity_Id;
3295 if New_Name = No_Name then
3296 Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
3298 Name_For_New_Spec := New_Name;
3301 if Present (Parameter_Specifications (Spec)) then
3303 Parameters := New_List;
3304 Current_Parameter := First (Parameter_Specifications (Spec));
3306 while Current_Parameter /= Empty loop
3308 Current_Type := Parameter_Type (Current_Parameter);
3310 if Nkind (Current_Type) = N_Access_Definition then
3311 Current_Etype := Entity (Subtype_Mark (Current_Type));
3313 if Object_Type = Empty then
3315 Make_Access_Definition (Loc,
3317 New_Occurrence_Of (Current_Etype, Loc));
3320 (Root_Type (Current_Etype) = Root_Type (Object_Type));
3322 Make_Access_Definition (Loc,
3323 Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
3327 Current_Etype := Entity (Current_Type);
3329 if Object_Type /= Empty
3330 and then Current_Etype = Object_Type
3332 Current_Type := New_Occurrence_Of (Stub_Type, Loc);
3334 Current_Type := New_Occurrence_Of (Current_Etype, Loc);
3338 New_Identifier := Make_Defining_Identifier (Loc,
3339 Chars (Defining_Identifier (Current_Parameter)));
3341 Append_To (Parameters,
3342 Make_Parameter_Specification (Loc,
3343 Defining_Identifier => New_Identifier,
3344 Parameter_Type => Current_Type,
3345 In_Present => In_Present (Current_Parameter),
3346 Out_Present => Out_Present (Current_Parameter),
3348 New_Copy_Tree (Expression (Current_Parameter))));
3350 Next (Current_Parameter);
3354 if Nkind (Spec) = N_Function_Specification then
3356 Make_Function_Specification (Loc,
3357 Defining_Unit_Name =>
3358 Make_Defining_Identifier (Loc,
3359 Chars => Name_For_New_Spec),
3360 Parameter_Specifications => Parameters,
3362 New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
3366 Make_Procedure_Specification (Loc,
3367 Defining_Unit_Name =>
3368 Make_Defining_Identifier (Loc,
3369 Chars => Name_For_New_Spec),
3370 Parameter_Specifications => Parameters);
3373 end Copy_Specification;
3375 ---------------------------
3376 -- Could_Be_Asynchronous --
3377 ---------------------------
3379 function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
3380 Current_Parameter : Node_Id;
3383 if Present (Parameter_Specifications (Spec)) then
3384 Current_Parameter := First (Parameter_Specifications (Spec));
3385 while Current_Parameter /= Empty loop
3386 if Out_Present (Current_Parameter) then
3390 Next (Current_Parameter);
3395 end Could_Be_Asynchronous;
3397 ---------------------------------------------
3398 -- Expand_All_Calls_Remote_Subprogram_Call --
3399 ---------------------------------------------
3401 procedure Expand_All_Calls_Remote_Subprogram_Call (N : in Node_Id) is
3402 Called_Subprogram : constant Entity_Id := Entity (Name (N));
3403 RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
3404 Loc : constant Source_Ptr := Sloc (N);
3405 RCI_Locator : Node_Id;
3406 RCI_Cache : Entity_Id;
3407 Calling_Stubs : Node_Id;
3408 E_Calling_Stubs : Entity_Id;
3411 E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
3413 if E_Calling_Stubs = Empty then
3414 RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
3416 if RCI_Cache = Empty then
3419 (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
3420 Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
3422 -- The RCI_Locator package is inserted at the top level in the
3423 -- current unit, and must appear in the proper scope, so that it
3424 -- is not prematurely removed by the GCC back-end.
3427 Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
3430 if Ekind (Scop) = E_Package_Body then
3431 New_Scope (Spec_Entity (Scop));
3433 elsif Ekind (Scop) = E_Subprogram_Body then
3435 (Corresponding_Spec (Unit_Declaration_Node (Scop)));
3441 Analyze (RCI_Locator);
3445 RCI_Cache := Defining_Unit_Name (RCI_Locator);
3448 RCI_Locator := Parent (RCI_Cache);
3451 Calling_Stubs := Build_Subprogram_Calling_Stubs
3452 (Vis_Decl => Parent (Parent (Called_Subprogram)),
3453 Subp_Id => Get_Subprogram_Id (Called_Subprogram),
3454 Asynchronous => Nkind (N) = N_Procedure_Call_Statement
3456 Is_Asynchronous (Called_Subprogram),
3457 Locator => RCI_Cache,
3458 New_Name => New_Internal_Name ('S'));
3459 Insert_After (RCI_Locator, Calling_Stubs);
3460 Analyze (Calling_Stubs);
3461 E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
3464 Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
3465 end Expand_All_Calls_Remote_Subprogram_Call;
3467 ---------------------------------
3468 -- Expand_Calling_Stubs_Bodies --
3469 ---------------------------------
3471 procedure Expand_Calling_Stubs_Bodies (Unit_Node : in Node_Id) is
3472 Spec : constant Node_Id := Specification (Unit_Node);
3473 Decls : constant List_Id := Visible_Declarations (Spec);
3476 New_Scope (Scope_Of_Spec (Spec));
3477 Add_Calling_Stubs_To_Declarations (Specification (Unit_Node),
3480 end Expand_Calling_Stubs_Bodies;
3482 -----------------------------------
3483 -- Expand_Receiving_Stubs_Bodies --
3484 -----------------------------------
3486 procedure Expand_Receiving_Stubs_Bodies (Unit_Node : in Node_Id) is
3492 if Nkind (Unit_Node) = N_Package_Declaration then
3493 Spec := Specification (Unit_Node);
3494 Decls := Visible_Declarations (Spec);
3495 New_Scope (Scope_Of_Spec (Spec));
3496 Add_Receiving_Stubs_To_Declarations (Spec, Decls);
3500 Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
3501 Decls := Declarations (Unit_Node);
3502 New_Scope (Scope_Of_Spec (Unit_Node));
3504 Add_Receiving_Stubs_To_Declarations (Spec, Temp);
3505 Insert_List_Before (First (Decls), Temp);
3509 end Expand_Receiving_Stubs_Bodies;
3511 ----------------------------
3512 -- Get_Pkg_Name_string_Id --
3513 ----------------------------
3515 function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id is
3516 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
3519 Get_Unit_Name_String (Unit_Name_Id);
3521 -- Remove seven last character (" (spec)" or " (body)").
3523 Name_Len := Name_Len - 7;
3524 pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
3526 return Get_String_Id (Name_Buffer (1 .. Name_Len));
3527 end Get_Pkg_Name_String_Id;
3533 function Get_String_Id (Val : String) return String_Id is
3536 Store_String_Chars (Val);
3540 -----------------------
3541 -- Get_Subprogram_Id --
3542 -----------------------
3544 function Get_Subprogram_Id (E : Entity_Id) return Int is
3545 Current_Declaration : Node_Id;
3550 (Is_Remote_Call_Interface (Scope (E))
3552 (Nkind (Parent (E)) = N_Procedure_Specification
3554 Nkind (Parent (E)) = N_Function_Specification));
3556 Current_Declaration :=
3557 First (Visible_Declarations
3558 (Package_Specification_Of_Scope (Scope (E))));
3560 while Current_Declaration /= Empty loop
3561 if Nkind (Current_Declaration) = N_Subprogram_Declaration
3562 and then Comes_From_Source (Current_Declaration)
3564 if Defining_Unit_Name
3565 (Specification (Current_Declaration)) = E
3570 Result := Result + 1;
3573 Next (Current_Declaration);
3576 -- Error if we do not find it
3578 raise Program_Error;
3579 end Get_Subprogram_Id;
3585 function Hash (F : Entity_Id) return Hash_Index is
3587 return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
3590 --------------------------
3591 -- Input_With_Tag_Check --
3592 --------------------------
3594 function Input_With_Tag_Check
3596 Var_Type : Entity_Id;
3602 Make_Subprogram_Body (Loc,
3603 Specification => Make_Function_Specification (Loc,
3604 Defining_Unit_Name =>
3605 Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
3606 Subtype_Mark => New_Occurrence_Of (Var_Type, Loc)),
3607 Declarations => No_List,
3608 Handled_Statement_Sequence =>
3609 Make_Handled_Sequence_Of_Statements (Loc, New_List (
3610 Make_Tag_Check (Loc,
3611 Make_Return_Statement (Loc,
3612 Make_Attribute_Reference (Loc,
3613 Prefix => New_Occurrence_Of (Var_Type, Loc),
3614 Attribute_Name => Name_Input,
3616 New_List (New_Occurrence_Of (Stream, Loc))))))));
3617 end Input_With_Tag_Check;
3619 --------------------------------
3620 -- Is_RACW_Controlling_Formal --
3621 --------------------------------
3623 function Is_RACW_Controlling_Formal
3624 (Parameter : Node_Id;
3625 Stub_Type : Entity_Id)
3631 -- If the kind of the parameter is E_Void, then it is not a
3632 -- controlling formal (this can happen in the context of RAS).
3634 if Ekind (Defining_Identifier (Parameter)) = E_Void then
3638 -- If the parameter is not a controlling formal, then it cannot
3639 -- be possibly a RACW_Controlling_Formal.
3641 if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
3645 Typ := Parameter_Type (Parameter);
3646 return (Nkind (Typ) = N_Access_Definition
3647 and then Etype (Subtype_Mark (Typ)) = Stub_Type)
3648 or else Etype (Typ) = Stub_Type;
3649 end Is_RACW_Controlling_Formal;
3651 --------------------
3652 -- Make_Tag_Check --
3653 --------------------
3655 function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
3656 Occ : constant Entity_Id :=
3657 Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3660 return Make_Block_Statement (Loc,
3661 Handled_Statement_Sequence =>
3662 Make_Handled_Sequence_Of_Statements (Loc,
3663 Statements => New_List (N),
3665 Exception_Handlers => New_List (
3666 Make_Exception_Handler (Loc,
3667 Choice_Parameter => Occ,
3669 Exception_Choices =>
3670 New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
3673 New_List (Make_Procedure_Call_Statement (Loc,
3675 (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
3676 New_List (New_Occurrence_Of (Occ, Loc))))))));
3679 ----------------------------
3680 -- Need_Extra_Constrained --
3681 ----------------------------
3683 function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
3684 Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
3687 return Out_Present (Parameter)
3688 and then Has_Discriminants (Etyp)
3689 and then not Is_Constrained (Etyp)
3690 and then not Is_Indefinite_Subtype (Etyp);
3691 end Need_Extra_Constrained;
3693 ------------------------------------
3694 -- Pack_Entity_Into_Stream_Access --
3695 ------------------------------------
3697 function Pack_Entity_Into_Stream_Access
3701 Etyp : Entity_Id := Empty)
3707 if Etyp /= Empty then
3710 Typ := Etype (Object);
3714 Pack_Node_Into_Stream_Access (Loc,
3716 Object => New_Occurrence_Of (Object, Loc),
3718 end Pack_Entity_Into_Stream_Access;
3720 ---------------------------
3721 -- Pack_Node_Into_Stream --
3722 ---------------------------
3724 function Pack_Node_Into_Stream
3731 Write_Attribute : Name_Id := Name_Write;
3734 if not Is_Constrained (Etyp) then
3735 Write_Attribute := Name_Output;
3739 Make_Attribute_Reference (Loc,
3740 Prefix => New_Occurrence_Of (Etyp, Loc),
3741 Attribute_Name => Write_Attribute,
3742 Expressions => New_List (
3743 Make_Attribute_Reference (Loc,
3744 Prefix => New_Occurrence_Of (Stream, Loc),
3745 Attribute_Name => Name_Access),
3747 end Pack_Node_Into_Stream;
3749 ----------------------------------
3750 -- Pack_Node_Into_Stream_Access --
3751 ----------------------------------
3753 function Pack_Node_Into_Stream_Access
3760 Write_Attribute : Name_Id := Name_Write;
3763 if not Is_Constrained (Etyp) then
3764 Write_Attribute := Name_Output;
3768 Make_Attribute_Reference (Loc,
3769 Prefix => New_Occurrence_Of (Etyp, Loc),
3770 Attribute_Name => Write_Attribute,
3771 Expressions => New_List (
3774 end Pack_Node_Into_Stream_Access;
3776 -------------------------------
3777 -- RACW_Type_Is_Asynchronous --
3778 -------------------------------
3780 procedure RACW_Type_Is_Asynchronous (RACW_Type : in Entity_Id) is
3781 N : constant Node_Id := Asynchronous_Flags_Table.Get (RACW_Type);
3782 pragma Assert (N /= Empty);
3785 Replace (N, New_Occurrence_Of (Standard_True, Sloc (N)));
3786 end RACW_Type_Is_Asynchronous;
3788 -------------------------
3789 -- RCI_Package_Locator --
3790 -------------------------
3792 function RCI_Package_Locator
3794 Package_Spec : Node_Id)
3797 Inst : constant Node_Id :=
3798 Make_Package_Instantiation (Loc,
3799 Defining_Unit_Name =>
3800 Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
3802 New_Occurrence_Of (RTE (RE_RCI_Info), Loc),
3803 Generic_Associations => New_List (
3804 Make_Generic_Association (Loc,
3806 Make_Identifier (Loc, Name_RCI_Name),
3807 Explicit_Generic_Actual_Parameter =>
3808 Make_String_Literal (Loc,
3809 Strval => Get_Pkg_Name_String_Id (Package_Spec)))));
3812 RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
3813 Defining_Unit_Name (Inst));
3815 end RCI_Package_Locator;
3817 -----------------------------------------------
3818 -- Remote_Types_Tagged_Full_View_Encountered --
3819 -----------------------------------------------
3821 procedure Remote_Types_Tagged_Full_View_Encountered
3822 (Full_View : in Entity_Id)
3824 Stub_Elements : constant Stub_Structure :=
3825 Stubs_Table.Get (Full_View);
3828 if Stub_Elements /= Empty_Stub_Structure then
3829 Add_RACW_Primitive_Declarations_And_Bodies
3831 Parent (Declaration_Node (Stub_Elements.Object_RPC_Receiver)),
3832 List_Containing (Declaration_Node (Full_View)));
3834 end Remote_Types_Tagged_Full_View_Encountered;
3840 function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
3841 Unit_Name : Node_Id := Defining_Unit_Name (Spec);
3844 while Nkind (Unit_Name) /= N_Defining_Identifier loop
3845 Unit_Name := Defining_Identifier (Unit_Name);