1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Einfo
; use Einfo
;
28 with Elists
; use Elists
;
29 with Exp_Atag
; use Exp_Atag
;
30 with Exp_Disp
; use Exp_Disp
;
31 with Exp_Strm
; use Exp_Strm
;
32 with Exp_Tss
; use Exp_Tss
;
33 with Exp_Util
; use Exp_Util
;
35 with Nlists
; use Nlists
;
36 with Nmake
; use Nmake
;
38 with Rtsfind
; use Rtsfind
;
40 with Sem_Aux
; use Sem_Aux
;
41 with Sem_Cat
; use Sem_Cat
;
42 with Sem_Ch3
; use Sem_Ch3
;
43 with Sem_Ch8
; use Sem_Ch8
;
44 with Sem_Ch12
; use Sem_Ch12
;
45 with Sem_Dist
; use Sem_Dist
;
46 with Sem_Eval
; use Sem_Eval
;
47 with Sem_Util
; use Sem_Util
;
48 with Sinfo
; use Sinfo
;
49 with Stand
; use Stand
;
50 with Stringt
; use Stringt
;
51 with Tbuild
; use Tbuild
;
52 with Ttypes
; use Ttypes
;
53 with Uintp
; use Uintp
;
55 with GNAT
.HTable
; use GNAT
.HTable
;
57 package body Exp_Dist
is
59 -- The following model has been used to implement distributed objects:
60 -- given a designated type D and a RACW type R, then a record of the form:
62 -- type Stub is tagged record
63 -- [...declaration similar to s-parint.ads RACW_Stub_Type...]
66 -- is built. This type has two properties:
68 -- 1) Since it has the same structure as RACW_Stub_Type, it can
69 -- be converted to and from this type to make it suitable for
70 -- System.Partition_Interface.Get_Unique_Remote_Pointer in order
71 -- to avoid memory leaks when the same remote object arrives on the
72 -- same partition through several paths;
74 -- 2) It also has the same dispatching table as the designated type D,
75 -- and thus can be used as an object designated by a value of type
76 -- R on any partition other than the one on which the object has
77 -- been created, since only dispatching calls will be performed and
78 -- the fields themselves will not be used. We call Derive_Subprograms
79 -- to fake half a derivation to ensure that the subprograms do have
80 -- the same dispatching table.
82 First_RCI_Subprogram_Id
: constant := 2;
83 -- RCI subprograms are numbered starting at 2. The RCI receiver for
84 -- an RCI package can thus identify calls received through remote
85 -- access-to-subprogram dereferences by the fact that they have a
86 -- (primitive) subprogram id of 0, and 1 is used for the internal RAS
87 -- information lookup operation. (This is for the Garlic code generation,
88 -- where subprograms are identified by numbers; in the PolyORB version,
89 -- they are identified by name, with a numeric suffix for homonyms.)
91 type Hash_Index
is range 0 .. 50;
93 -----------------------
94 -- Local subprograms --
95 -----------------------
97 function Hash
(F
: Entity_Id
) return Hash_Index
;
98 -- DSA expansion associates stubs to distributed object types using a hash
99 -- table on entity ids.
101 function Hash
(F
: Name_Id
) return Hash_Index
;
102 -- The generation of subprogram identifiers requires an overload counter
103 -- to be associated with each remote subprogram name. These counters are
104 -- maintained in a hash table on name ids.
106 type Subprogram_Identifiers
is record
107 Str_Identifier
: String_Id
;
108 Int_Identifier
: Int
;
111 package Subprogram_Identifier_Table
is
112 new Simple_HTable
(Header_Num
=> Hash_Index
,
113 Element
=> Subprogram_Identifiers
,
114 No_Element
=> (No_String
, 0),
118 -- Mapping between a remote subprogram and the corresponding subprogram
121 package Overload_Counter_Table
is
122 new Simple_HTable
(Header_Num
=> Hash_Index
,
128 -- Mapping between a subprogram name and an integer that counts the number
129 -- of defining subprogram names with that Name_Id encountered so far in a
130 -- given context (an interface).
132 function Get_Subprogram_Ids
(Def
: Entity_Id
) return Subprogram_Identifiers
;
133 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
;
134 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
;
135 -- Given a subprogram defined in a RCI package, get its distribution
136 -- subprogram identifiers (the distribution identifiers are a unique
137 -- subprogram number, and the non-qualified subprogram name, in the
138 -- casing used for the subprogram declaration; if the name is overloaded,
139 -- a double underscore and a serial number are appended.
141 -- The integer identifier is used to perform remote calls with GARLIC;
142 -- the string identifier is used in the case of PolyORB.
144 -- Although the PolyORB DSA receiving stubs will make a caseless comparison
145 -- when receiving a call, the calling stubs will create requests with the
146 -- exact casing of the defining unit name of the called subprogram, so as
147 -- to allow calls to subprograms on distributed nodes that do distinguish
150 -- NOTE: Another design would be to allow a representation clause on
151 -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
153 pragma Warnings
(Off
, Get_Subprogram_Id
);
154 -- One homonym only is unreferenced (specific to the GARLIC version)
156 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
);
157 -- Add a subprogram body for RAS Dereference TSS
159 procedure Add_RAS_Proxy_And_Analyze
162 All_Calls_Remote_E
: Entity_Id
;
163 Proxy_Object_Addr
: out Entity_Id
);
164 -- Add the proxy type required, on the receiving (server) side, to handle
165 -- calls to the subprogram declared by Vis_Decl through a remote access
166 -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma
167 -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type
168 -- is appended to Decls. Proxy_Object_Addr is a constant of type
169 -- System.Address that designates an instance of the proxy object.
171 function Build_Remote_Subprogram_Proxy_Type
173 ACR_Expression
: Node_Id
) return Node_Id
;
174 -- Build and return a tagged record type definition for an RCI subprogram
175 -- proxy type. ACR_Expression is used as the initialization value for the
176 -- All_Calls_Remote component.
178 function Build_Get_Unique_RP_Call
181 Stub_Type
: Entity_Id
) return List_Id
;
182 -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
183 -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
184 -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
186 function Build_Stub_Tag
188 RACW_Type
: Entity_Id
) return Node_Id
;
189 -- Return an expression denoting the tag of the stub type associated with
192 function Build_Subprogram_Calling_Stubs
195 Asynchronous
: Boolean;
196 Dynamically_Asynchronous
: Boolean := False;
197 Stub_Type
: Entity_Id
:= Empty
;
198 RACW_Type
: Entity_Id
:= Empty
;
199 Locator
: Entity_Id
:= Empty
;
200 New_Name
: Name_Id
:= No_Name
) return Node_Id
;
201 -- Build the calling stub for a given subprogram with the subprogram ID
202 -- being Subp_Id. If Stub_Type is given, then the "addr" field of
203 -- parameters of this type will be marshalled instead of the object itself.
204 -- It will then be converted into Stub_Type before performing the real
205 -- call. If Dynamically_Asynchronous is True, then it will be computed at
206 -- run time whether the call is asynchronous or not. Otherwise, the value
207 -- of the formal Asynchronous will be used. If Locator is not Empty, it
208 -- will be used instead of RCI_Cache. If New_Name is given, then it will
209 -- be used instead of the original name.
211 function Build_RPC_Receiver_Specification
212 (RPC_Receiver
: Entity_Id
;
213 Request_Parameter
: Entity_Id
) return Node_Id
;
214 -- Make a subprogram specification for an RPC receiver, with the given
215 -- defining unit name and formal parameter.
217 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
;
218 -- Return an ordered parameter list: unconstrained parameters are put
219 -- at the beginning of the list and constrained ones are put after. If
220 -- there are no parameters, an empty list is returned. Special case:
221 -- the controlling formal of the equivalent RACW operation for a RAS
222 -- type is always left in first position.
224 function Transmit_As_Unconstrained
(Typ
: Entity_Id
) return Boolean;
225 -- True when Typ is an unconstrained type, or a null-excluding access type.
226 -- In either case, this means stubs cannot contain a default-initialized
227 -- object declaration of such type.
229 procedure Add_Calling_Stubs_To_Declarations
(Pkg_Spec
: Node_Id
);
230 -- Add calling stubs to the declarative part
232 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean;
233 -- Return True if nothing prevents the program whose specification is
234 -- given to be asynchronous (i.e. no [IN] OUT parameters).
236 function Pack_Entity_Into_Stream_Access
240 Etyp
: Entity_Id
:= Empty
) return Node_Id
;
241 -- Pack Object (of type Etyp) into Stream. If Etyp is not given,
242 -- then Etype (Object) will be used if present. If the type is
243 -- constrained, then 'Write will be used to output the object,
244 -- If the type is unconstrained, 'Output will be used.
246 function Pack_Node_Into_Stream
250 Etyp
: Entity_Id
) return Node_Id
;
251 -- Similar to above, with an arbitrary node instead of an entity
253 function Pack_Node_Into_Stream_Access
257 Etyp
: Entity_Id
) return Node_Id
;
258 -- Similar to above, with Stream instead of Stream'Access
260 function Make_Selected_Component
263 Selector_Name
: Name_Id
) return Node_Id
;
264 -- Return a selected_component whose prefix denotes the given entity, and
265 -- with the given Selector_Name.
267 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
;
268 -- Return the scope represented by a given spec
270 procedure Set_Renaming_TSS
273 TSS_Nam
: TSS_Name_Type
);
274 -- Create a renaming declaration of subprogram Nam, and register it as a
275 -- TSS for Typ with name TSS_Nam.
277 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean;
278 -- Return True if the current parameter needs an extra formal to reflect
279 -- its constrained status.
281 function Is_RACW_Controlling_Formal
282 (Parameter
: Node_Id
;
283 Stub_Type
: Entity_Id
) return Boolean;
284 -- Return True if the current parameter is a controlling formal argument
285 -- of type Stub_Type or access to Stub_Type.
287 procedure Declare_Create_NVList
292 -- Append the declaration of NVList to Decls, and its
293 -- initialization to Stmts.
295 function Add_Parameter_To_NVList
298 Parameter
: Entity_Id
;
299 Constrained
: Boolean;
300 RACW_Ctrl
: Boolean := False;
301 Any
: Entity_Id
) return Node_Id
;
302 -- Return a call to Add_Item to add the Any corresponding to the designated
303 -- formal Parameter (with the indicated Constrained status) to NVList.
304 -- RACW_Ctrl must be set to True for controlling formals of distributed
305 -- object primitive operations.
311 -- This record describes various tree fragments associated with the
312 -- generation of RACW calling stubs. One such record exists for every
313 -- distributed object type, i.e. each tagged type that is the designated
314 -- type of one or more RACW type.
316 type Stub_Structure
is record
317 Stub_Type
: Entity_Id
;
318 -- Stub type: this type has the same primitive operations as the
319 -- designated types, but the provided bodies for these operations
320 -- a remote call to an actual target object potentially located on
321 -- another partition; each value of the stub type encapsulates a
322 -- reference to a remote object.
324 Stub_Type_Access
: Entity_Id
;
325 -- A local access type designating the stub type (this is not an RACW
328 RPC_Receiver_Decl
: Node_Id
;
329 -- Declaration for the RPC receiver entity associated with the
330 -- designated type. As an exception, for the case of an RACW that
331 -- implements a RAS, no object RPC receiver is generated. Instead,
332 -- RPC_Receiver_Decl is the declaration after which the RPC receiver
333 -- would have been inserted.
335 Body_Decls
: List_Id
;
336 -- List of subprogram bodies to be included in generated code: bodies
337 -- for the RACW's stream attributes, and for the primitive operations
340 RACW_Type
: Entity_Id
;
341 -- One of the RACW types designating this distributed object type
342 -- (they are all interchangeable; we use any one of them in order to
343 -- avoid having to create various anonymous access types).
347 Empty_Stub_Structure
: constant Stub_Structure
:=
348 (Empty
, Empty
, Empty
, No_List
, Empty
);
350 package Stubs_Table
is
351 new Simple_HTable
(Header_Num
=> Hash_Index
,
352 Element
=> Stub_Structure
,
353 No_Element
=> Empty_Stub_Structure
,
357 -- Mapping between a RACW designated type and its stub type
359 package Asynchronous_Flags_Table
is
360 new Simple_HTable
(Header_Num
=> Hash_Index
,
361 Element
=> Entity_Id
,
366 -- Mapping between a RACW type and a constant having the value True
367 -- if the RACW is asynchronous and False otherwise.
369 package RCI_Locator_Table
is
370 new Simple_HTable
(Header_Num
=> Hash_Index
,
371 Element
=> Entity_Id
,
376 -- Mapping between a RCI package on which All_Calls_Remote applies and
377 -- the generic instantiation of RCI_Locator for this package.
379 package RCI_Calling_Stubs_Table
is
380 new Simple_HTable
(Header_Num
=> Hash_Index
,
381 Element
=> Entity_Id
,
386 -- Mapping between a RCI subprogram and the corresponding calling stubs
388 function Get_Stub_Elements
(RACW_Type
: Entity_Id
) return Stub_Structure
;
389 -- Return the stub information associated with the given RACW type
391 procedure Add_Stub_Type
392 (Designated_Type
: Entity_Id
;
393 RACW_Type
: Entity_Id
;
395 Stub_Type
: out Entity_Id
;
396 Stub_Type_Access
: out Entity_Id
;
397 RPC_Receiver_Decl
: out Node_Id
;
398 Body_Decls
: out List_Id
;
399 Existing
: out Boolean);
400 -- Add the declaration of the stub type, the access to stub type and the
401 -- object RPC receiver at the end of Decls. If these already exist,
402 -- then nothing is added in the tree but the right values are returned
403 -- anyhow and Existing is set to True.
405 function Get_And_Reset_RACW_Bodies
(RACW_Type
: Entity_Id
) return List_Id
;
406 -- Retrieve the Body_Decls list associated to RACW_Type in the stub
407 -- structure table, reset it to No_List, and return the previous value.
409 procedure Add_RACW_Asynchronous_Flag
410 (Declarations
: List_Id
;
411 RACW_Type
: Entity_Id
);
412 -- Declare a boolean constant associated with RACW_Type whose value
413 -- indicates at run time whether a pragma Asynchronous applies to it.
415 procedure Assign_Subprogram_Identifier
419 -- Determine the distribution subprogram identifier to
420 -- be used for remote subprogram Def, return it in Id and
421 -- store it in a hash table for later retrieval by
422 -- Get_Subprogram_Id. Spn is the subprogram number.
424 function RCI_Package_Locator
426 Package_Spec
: Node_Id
) return Node_Id
;
427 -- Instantiate the generic package RCI_Locator in order to locate the
428 -- RCI package whose spec is given as argument.
430 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
;
431 -- Surround a node N by a tag check, as in:
435 -- when E : Ada.Tags.Tag_Error =>
436 -- Raise_Exception (Program_Error'Identity,
437 -- Exception_Message (E));
440 function Input_With_Tag_Check
442 Var_Type
: Entity_Id
;
443 Stream
: Node_Id
) return Node_Id
;
444 -- Return a function with the following form:
445 -- function R return Var_Type is
447 -- return Var_Type'Input (S);
449 -- when E : Ada.Tags.Tag_Error =>
450 -- Raise_Exception (Program_Error'Identity,
451 -- Exception_Message (E));
454 procedure Build_Actual_Object_Declaration
460 -- Build the declaration of an object with the given defining identifier,
461 -- initialized with Expr if provided, to serve as actual parameter in a
462 -- server stub. If Variable is true, the declared object will be a variable
463 -- (case of an out or in out formal), else it will be a constant. Object's
464 -- Ekind is set accordingly. The declaration, as well as any other
465 -- declarations it requires, are appended to Decls.
467 --------------------------------------------
468 -- Hooks for PCS-specific code generation --
469 --------------------------------------------
471 -- Part of the code generation circuitry for distribution needs to be
472 -- tailored for each implementation of the PCS. For each routine that
473 -- needs to be specialized, a Specific_<routine> wrapper is created,
474 -- which calls the corresponding <routine> in package
475 -- <pcs_implementation>_Support.
477 procedure Specific_Add_RACW_Features
478 (RACW_Type
: Entity_Id
;
480 Stub_Type
: Entity_Id
;
481 Stub_Type_Access
: Entity_Id
;
482 RPC_Receiver_Decl
: Node_Id
;
483 Body_Decls
: List_Id
);
484 -- Add declaration for TSSs for a given RACW type. The declarations are
485 -- added just after the declaration of the RACW type itself. If the RACW
486 -- appears in the main unit, Body_Decls is a list of declarations to which
487 -- the bodies are appended. Else Body_Decls is No_List.
488 -- PCS-specific ancillary subprogram for Add_RACW_Features.
490 procedure Specific_Add_RAST_Features
492 RAS_Type
: Entity_Id
);
493 -- Add declaration for TSSs for a given RAS type. PCS-specific ancillary
494 -- subprogram for Add_RAST_Features.
496 -- An RPC_Target record is used during construction of calling stubs
497 -- to pass PCS-specific tree fragments corresponding to the information
498 -- necessary to locate the target of a remote subprogram call.
500 type RPC_Target
(PCS_Kind
: PCS_Names
) is record
502 when Name_PolyORB_DSA
=>
504 -- An expression whose value is a PolyORB reference to the target
508 Partition
: Entity_Id
;
509 -- A variable containing the Partition_ID of the target partition
511 RPC_Receiver
: Node_Id
;
512 -- An expression whose value is the address of the target RPC
517 procedure Specific_Build_General_Calling_Stubs
519 Statements
: List_Id
;
521 Subprogram_Id
: Node_Id
;
522 Asynchronous
: Node_Id
:= Empty
;
523 Is_Known_Asynchronous
: Boolean := False;
524 Is_Known_Non_Asynchronous
: Boolean := False;
525 Is_Function
: Boolean;
527 Stub_Type
: Entity_Id
:= Empty
;
528 RACW_Type
: Entity_Id
:= Empty
;
530 -- Build calling stubs for general purpose. The parameters are:
531 -- Decls : a place to put declarations
532 -- Statements : a place to put statements
533 -- Target : PCS-specific target information (see details
534 -- in RPC_Target declaration).
535 -- Subprogram_Id : a node containing the subprogram ID
536 -- Asynchronous : True if an APC must be made instead of an RPC.
537 -- The value needs not be supplied if one of the
538 -- Is_Known_... is True.
539 -- Is_Known_Async... : True if we know that this is asynchronous
540 -- Is_Known_Non_A... : True if we know that this is not asynchronous
541 -- Spec : a node with a Parameter_Specifications and
542 -- a Result_Definition if applicable
543 -- Stub_Type : in case of RACW stubs, parameters of type access
544 -- to Stub_Type will be marshalled using the
545 -- address of the object (the addr field) rather
546 -- than using the 'Write on the stub itself
547 -- Nod : used to provide sloc for generated code
549 function Specific_Build_Stub_Target
552 RCI_Locator
: Entity_Id
;
553 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
554 -- Build call target information nodes for use within calling stubs. In the
555 -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If
556 -- for an RACW, Controlling_Parameter is the entity for the controlling
557 -- formal parameter used to determine the location of the target of the
558 -- call. Decls provides a location where variable declarations can be
559 -- appended to construct the necessary values.
561 procedure Specific_Build_Stub_Type
562 (RACW_Type
: Entity_Id
;
563 Stub_Type_Comps
: out List_Id
;
564 RPC_Receiver_Decl
: out Node_Id
);
565 -- Build a components list for the stub type associated with an RACW type,
566 -- and build the necessary RPC receiver, if applicable. PCS-specific
567 -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
568 -- is generated, then RPC_Receiver_Decl is set to Empty.
570 procedure Specific_Build_RPC_Receiver_Body
571 (RPC_Receiver
: Entity_Id
;
572 Request
: out Entity_Id
;
573 Subp_Id
: out Entity_Id
;
574 Subp_Index
: out Entity_Id
;
577 -- Make a subprogram body for an RPC receiver, with the given
578 -- defining unit name. On return:
579 -- - Subp_Id is the subprogram identifier from the PCS.
580 -- - Subp_Index is the index in the list of subprograms
581 -- used for dispatching (a variable of type Subprogram_Id).
582 -- - Stmts is the place where the request dispatching
583 -- statements can occur,
584 -- - Decl is the subprogram body declaration.
586 function Specific_Build_Subprogram_Receiving_Stubs
588 Asynchronous
: Boolean;
589 Dynamically_Asynchronous
: Boolean := False;
590 Stub_Type
: Entity_Id
:= Empty
;
591 RACW_Type
: Entity_Id
:= Empty
;
592 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
593 -- Build the receiving stub for a given subprogram. The subprogram
594 -- declaration is also built by this procedure, and the value returned
595 -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
596 -- found in the specification, then its address is read from the stream
597 -- instead of the object itself and converted into an access to
598 -- class-wide type before doing the real call using any of the RACW type
599 -- pointing on the designated type.
601 procedure Specific_Add_Obj_RPC_Receiver_Completion
604 RPC_Receiver
: Entity_Id
;
605 Stub_Elements
: Stub_Structure
);
606 -- Add the necessary code to Decls after the completion of generation
607 -- of the RACW RPC receiver described by Stub_Elements.
609 procedure Specific_Add_Receiving_Stubs_To_Declarations
613 -- Add receiving stubs to the declarative part of an RCI unit
619 package GARLIC_Support
is
621 -- Support for generating DSA code that uses the GARLIC PCS
623 -- The subprograms below provide the GARLIC versions of the
624 -- corresponding Specific_<subprogram> routine declared above.
626 procedure Add_RACW_Features
627 (RACW_Type
: Entity_Id
;
628 Stub_Type
: Entity_Id
;
629 Stub_Type_Access
: Entity_Id
;
630 RPC_Receiver_Decl
: Node_Id
;
631 Body_Decls
: List_Id
);
633 procedure Add_RAST_Features
635 RAS_Type
: Entity_Id
);
637 procedure Build_General_Calling_Stubs
639 Statements
: List_Id
;
640 Target_Partition
: Entity_Id
; -- From RPC_Target
641 Target_RPC_Receiver
: Node_Id
; -- From RPC_Target
642 Subprogram_Id
: Node_Id
;
643 Asynchronous
: Node_Id
:= Empty
;
644 Is_Known_Asynchronous
: Boolean := False;
645 Is_Known_Non_Asynchronous
: Boolean := False;
646 Is_Function
: Boolean;
648 Stub_Type
: Entity_Id
:= Empty
;
649 RACW_Type
: Entity_Id
:= Empty
;
652 function Build_Stub_Target
655 RCI_Locator
: Entity_Id
;
656 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
658 procedure Build_Stub_Type
659 (RACW_Type
: Entity_Id
;
660 Stub_Type_Comps
: out List_Id
;
661 RPC_Receiver_Decl
: out Node_Id
);
663 function Build_Subprogram_Receiving_Stubs
665 Asynchronous
: Boolean;
666 Dynamically_Asynchronous
: Boolean := False;
667 Stub_Type
: Entity_Id
:= Empty
;
668 RACW_Type
: Entity_Id
:= Empty
;
669 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
671 procedure Add_Obj_RPC_Receiver_Completion
674 RPC_Receiver
: Entity_Id
;
675 Stub_Elements
: Stub_Structure
);
677 procedure Add_Receiving_Stubs_To_Declarations
682 procedure Build_RPC_Receiver_Body
683 (RPC_Receiver
: Entity_Id
;
684 Request
: out Entity_Id
;
685 Subp_Id
: out Entity_Id
;
686 Subp_Index
: out Entity_Id
;
692 ---------------------
693 -- PolyORB_Support --
694 ---------------------
696 package PolyORB_Support
is
698 -- Support for generating DSA code that uses the PolyORB PCS
700 -- The subprograms below provide the PolyORB versions of the
701 -- corresponding Specific_<subprogram> routine declared above.
703 procedure Add_RACW_Features
704 (RACW_Type
: Entity_Id
;
706 Stub_Type
: Entity_Id
;
707 Stub_Type_Access
: Entity_Id
;
708 RPC_Receiver_Decl
: Node_Id
;
709 Body_Decls
: List_Id
);
711 procedure Add_RAST_Features
713 RAS_Type
: Entity_Id
);
715 procedure Build_General_Calling_Stubs
717 Statements
: List_Id
;
718 Target_Object
: Node_Id
; -- From RPC_Target
719 Subprogram_Id
: Node_Id
;
720 Asynchronous
: Node_Id
:= Empty
;
721 Is_Known_Asynchronous
: Boolean := False;
722 Is_Known_Non_Asynchronous
: Boolean := False;
723 Is_Function
: Boolean;
725 Stub_Type
: Entity_Id
:= Empty
;
726 RACW_Type
: Entity_Id
:= Empty
;
729 function Build_Stub_Target
732 RCI_Locator
: Entity_Id
;
733 Controlling_Parameter
: Entity_Id
) return RPC_Target
;
735 procedure Build_Stub_Type
736 (RACW_Type
: Entity_Id
;
737 Stub_Type_Comps
: out List_Id
;
738 RPC_Receiver_Decl
: out Node_Id
);
740 function Build_Subprogram_Receiving_Stubs
742 Asynchronous
: Boolean;
743 Dynamically_Asynchronous
: Boolean := False;
744 Stub_Type
: Entity_Id
:= Empty
;
745 RACW_Type
: Entity_Id
:= Empty
;
746 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
;
748 procedure Add_Obj_RPC_Receiver_Completion
751 RPC_Receiver
: Entity_Id
;
752 Stub_Elements
: Stub_Structure
);
754 procedure Add_Receiving_Stubs_To_Declarations
759 procedure Build_RPC_Receiver_Body
760 (RPC_Receiver
: Entity_Id
;
761 Request
: out Entity_Id
;
762 Subp_Id
: out Entity_Id
;
763 Subp_Index
: out Entity_Id
;
767 procedure Reserve_NamingContext_Methods
;
768 -- Mark the method names for interface NamingContext as already used in
769 -- the overload table, so no clashes occur with user code (with the
770 -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
771 -- their methods to be accessed as objects, for the implementation of
772 -- remote access-to-subprogram types).
780 -- Routines to build distribution helper subprograms for user-defined
781 -- types. For implementation of the Distributed systems annex (DSA)
782 -- over the PolyORB generic middleware components, it is necessary to
783 -- generate several supporting subprograms for each application data
784 -- type used in inter-partition communication. These subprograms are:
786 -- A Typecode function returning a high-level description of the
789 -- Two conversion functions allowing conversion of values of the
790 -- type from and to the generic data containers used by PolyORB.
791 -- These generic containers are called 'Any' type values after the
792 -- CORBA terminology, and hence the conversion subprograms are
793 -- named To_Any and From_Any.
795 function Build_From_Any_Call
798 Decls
: List_Id
) return Node_Id
;
799 -- Build call to From_Any attribute function of type Typ with
800 -- expression N as actual parameter. Decls is the declarations list
801 -- for an appropriate enclosing scope of the point where the call
802 -- will be inserted; if the From_Any attribute for Typ needs to be
803 -- generated at this point, its declaration is appended to Decls.
805 procedure Build_From_Any_Function
809 Fnam
: out Entity_Id
);
810 -- Build From_Any attribute function for Typ. Loc is the reference
811 -- location for generated nodes, Typ is the type for which the
812 -- conversion function is generated. On return, Decl and Fnam contain
813 -- the declaration and entity for the newly-created function.
815 function Build_To_Any_Call
817 Decls
: List_Id
) return Node_Id
;
818 -- Build call to To_Any attribute function with expression as actual
819 -- parameter. Decls is the declarations list for an appropriate
820 -- enclosing scope of the point where the call will be inserted; if
821 -- the To_Any attribute for Typ needs to be generated at this point,
822 -- its declaration is appended to Decls.
824 procedure Build_To_Any_Function
828 Fnam
: out Entity_Id
);
829 -- Build To_Any attribute function for Typ. Loc is the reference
830 -- location for generated nodes, Typ is the type for which the
831 -- conversion function is generated. On return, Decl and Fnam contain
832 -- the declaration and entity for the newly-created function.
834 function Build_TypeCode_Call
837 Decls
: List_Id
) return Node_Id
;
838 -- Build call to TypeCode attribute function for Typ. Decls is the
839 -- declarations list for an appropriate enclosing scope of the point
840 -- where the call will be inserted; if the To_Any attribute for Typ
841 -- needs to be generated at this point, its declaration is appended
844 procedure Build_TypeCode_Function
848 Fnam
: out Entity_Id
);
849 -- Build TypeCode attribute function for Typ. Loc is the reference
850 -- location for generated nodes, Typ is the type for which the
851 -- conversion function is generated. On return, Decl and Fnam contain
852 -- the declaration and entity for the newly-created function.
854 procedure Build_Name_And_Repository_Id
856 Name_Str
: out String_Id
;
857 Repo_Id_Str
: out String_Id
);
858 -- In the PolyORB distribution model, each distributed object type
859 -- and each distributed operation has a globally unique identifier,
860 -- its Repository Id. This subprogram builds and returns two strings
861 -- for entity E (a distributed object type or operation): one
862 -- containing the name of E, the second containing its repository id.
864 procedure Assign_Opaque_From_Any
870 -- For a Target object of type Typ, which has opaque representation
871 -- as a sequence of octets determined by stream attributes (which
872 -- includes all limited types), append code to Stmts performing the
874 -- Target := Typ'From_Any (N)
876 -- or, if Target is Empty:
877 -- return Typ'From_Any (N)
883 -- The following PolyORB-specific subprograms are made visible to Exp_Attr:
885 function Build_From_Any_Call
888 Decls
: List_Id
) return Node_Id
889 renames PolyORB_Support
.Helpers
.Build_From_Any_Call
;
891 function Build_To_Any_Call
893 Decls
: List_Id
) return Node_Id
894 renames PolyORB_Support
.Helpers
.Build_To_Any_Call
;
896 function Build_TypeCode_Call
899 Decls
: List_Id
) return Node_Id
900 renames PolyORB_Support
.Helpers
.Build_TypeCode_Call
;
902 ------------------------------------
903 -- Local variables and structures --
904 ------------------------------------
907 -- Needs comments ???
909 Output_From_Constrained
: constant array (Boolean) of Name_Id
:=
910 (False => Name_Output
,
912 -- The attribute to choose depending on the fact that the parameter
913 -- is constrained or not. There is no such thing as Input_From_Constrained
914 -- since this require separate mechanisms ('Input is a function while
915 -- 'Read is a procedure).
918 with procedure Process_Subprogram_Declaration
(Decl
: Node_Id
);
919 -- Generate calling or receiving stub for this subprogram declaration
921 procedure Build_Package_Stubs
(Pkg_Spec
: Node_Id
);
922 -- Recursively visit the given RCI Package_Specification, calling
923 -- Process_Subprogram_Declaration for each remote subprogram.
925 -------------------------
926 -- Build_Package_Stubs --
927 -------------------------
929 procedure Build_Package_Stubs
(Pkg_Spec
: Node_Id
) is
930 Decls
: constant List_Id
:= Visible_Declarations
(Pkg_Spec
);
933 procedure Visit_Nested_Pkg
(Nested_Pkg_Decl
: Node_Id
);
934 -- Recurse for the given nested package declaration
936 -----------------------
937 -- Visit_Nested_Spec --
938 -----------------------
940 procedure Visit_Nested_Pkg
(Nested_Pkg_Decl
: Node_Id
) is
941 Nested_Pkg_Spec
: constant Node_Id
:= Specification
(Nested_Pkg_Decl
);
943 Push_Scope
(Scope_Of_Spec
(Nested_Pkg_Spec
));
944 Build_Package_Stubs
(Nested_Pkg_Spec
);
946 end Visit_Nested_Pkg
;
948 -- Start of processing for Build_Package_Stubs
951 Decl
:= First
(Decls
);
952 while Present
(Decl
) loop
954 when N_Subprogram_Declaration
=>
956 -- Note: we test Comes_From_Source on Spec, not Decl, because
957 -- in the case of a subprogram instance, only the specification
958 -- (not the declaration) is marked as coming from source.
960 if Comes_From_Source
(Specification
(Decl
)) then
961 Process_Subprogram_Declaration
(Decl
);
964 when N_Package_Declaration
=>
966 -- Case of a nested package or package instantiation coming
967 -- from source. Note that the anonymous wrapper package for
968 -- subprogram instances is not flagged Is_Generic_Instance at
969 -- this point, so there is a distinct circuit to handle them
970 -- (see case N_Subprogram_Instantiation below).
973 Pkg_Ent
: constant Entity_Id
:=
974 Defining_Unit_Name
(Specification
(Decl
));
976 if Comes_From_Source
(Decl
)
978 (Is_Generic_Instance
(Pkg_Ent
)
979 and then Comes_From_Source
980 (Get_Package_Instantiation_Node
(Pkg_Ent
)))
982 Visit_Nested_Pkg
(Decl
);
986 when N_Subprogram_Instantiation
=>
988 -- The subprogram declaration for an instance of a generic
989 -- subprogram is wrapped in a package that does not come from
990 -- source, so we need to explicitly traverse it here.
992 if Comes_From_Source
(Decl
) then
993 Visit_Nested_Pkg
(Instance_Spec
(Decl
));
1001 end Build_Package_Stubs
;
1003 ---------------------------------------
1004 -- Add_Calling_Stubs_To_Declarations --
1005 ---------------------------------------
1007 procedure Add_Calling_Stubs_To_Declarations
(Pkg_Spec
: Node_Id
) is
1008 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
1010 Current_Subprogram_Number
: Int
:= First_RCI_Subprogram_Id
;
1011 -- Subprogram id 0 is reserved for calls received from
1012 -- remote access-to-subprogram dereferences.
1014 RCI_Instantiation
: Node_Id
;
1016 procedure Visit_Subprogram
(Decl
: Node_Id
);
1017 -- Generate calling stub for one remote subprogram
1019 ----------------------
1020 -- Visit_Subprogram --
1021 ----------------------
1023 procedure Visit_Subprogram
(Decl
: Node_Id
) is
1024 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
1025 Spec
: constant Node_Id
:= Specification
(Decl
);
1026 Subp_Stubs
: Node_Id
;
1028 Subp_Str
: String_Id
;
1029 pragma Warnings
(Off
, Subp_Str
);
1032 Assign_Subprogram_Identifier
1033 (Defining_Unit_Name
(Spec
), Current_Subprogram_Number
, Subp_Str
);
1036 Build_Subprogram_Calling_Stubs
1039 Build_Subprogram_Id
(Loc
, Defining_Unit_Name
(Spec
)),
1041 Nkind
(Spec
) = N_Procedure_Specification
1042 and then Is_Asynchronous
(Defining_Unit_Name
(Spec
)));
1044 Append_To
(List_Containing
(Decl
), Subp_Stubs
);
1045 Analyze
(Subp_Stubs
);
1047 Current_Subprogram_Number
:= Current_Subprogram_Number
+ 1;
1048 end Visit_Subprogram
;
1050 procedure Visit_Spec
is new Build_Package_Stubs
(Visit_Subprogram
);
1052 -- Start of processing for Add_Calling_Stubs_To_Declarations
1055 Push_Scope
(Scope_Of_Spec
(Pkg_Spec
));
1057 -- The first thing added is an instantiation of the generic package
1058 -- System.Partition_Interface.RCI_Locator with the name of this remote
1059 -- package. This will act as an interface with the name server to
1060 -- determine the Partition_ID and the RPC_Receiver for the receiver
1063 RCI_Instantiation
:= RCI_Package_Locator
(Loc
, Pkg_Spec
);
1064 RCI_Cache
:= Defining_Unit_Name
(RCI_Instantiation
);
1066 Append_To
(Visible_Declarations
(Pkg_Spec
), RCI_Instantiation
);
1067 Analyze
(RCI_Instantiation
);
1069 -- For each subprogram declaration visible in the spec, we do build a
1070 -- body. We also increment a counter to assign a different Subprogram_Id
1071 -- to each subprogram. The receiving stubs processing uses the same
1072 -- mechanism and will thus assign the same Id and do the correct
1075 Overload_Counter_Table
.Reset
;
1076 PolyORB_Support
.Reserve_NamingContext_Methods
;
1078 Visit_Spec
(Pkg_Spec
);
1081 end Add_Calling_Stubs_To_Declarations
;
1083 -----------------------------
1084 -- Add_Parameter_To_NVList --
1085 -----------------------------
1087 function Add_Parameter_To_NVList
1090 Parameter
: Entity_Id
;
1091 Constrained
: Boolean;
1092 RACW_Ctrl
: Boolean := False;
1093 Any
: Entity_Id
) return Node_Id
1095 Parameter_Name_String
: String_Id
;
1096 Parameter_Mode
: Node_Id
;
1098 function Parameter_Passing_Mode
1100 Parameter
: Entity_Id
;
1101 Constrained
: Boolean) return Node_Id
;
1102 -- Return an expression that denotes the parameter passing mode to be
1103 -- used for Parameter in distribution stubs, where Constrained is
1104 -- Parameter's constrained status.
1106 ----------------------------
1107 -- Parameter_Passing_Mode --
1108 ----------------------------
1110 function Parameter_Passing_Mode
1112 Parameter
: Entity_Id
;
1113 Constrained
: Boolean) return Node_Id
1118 if Out_Present
(Parameter
) then
1119 if In_Present
(Parameter
)
1120 or else not Constrained
1122 -- Unconstrained formals must be translated
1123 -- to 'in' or 'inout', not 'out', because
1124 -- they need to be constrained by the actual.
1126 Lib_RE
:= RE_Mode_Inout
;
1128 Lib_RE
:= RE_Mode_Out
;
1132 Lib_RE
:= RE_Mode_In
;
1135 return New_Occurrence_Of
(RTE
(Lib_RE
), Loc
);
1136 end Parameter_Passing_Mode
;
1138 -- Start of processing for Add_Parameter_To_NVList
1141 if Nkind
(Parameter
) = N_Defining_Identifier
then
1142 Get_Name_String
(Chars
(Parameter
));
1144 Get_Name_String
(Chars
(Defining_Identifier
(Parameter
)));
1147 Parameter_Name_String
:= String_From_Name_Buffer
;
1149 if RACW_Ctrl
or else Nkind
(Parameter
) = N_Defining_Identifier
then
1151 -- When the parameter passed to Add_Parameter_To_NVList is an
1152 -- Extra_Constrained parameter, Parameter is an N_Defining_
1153 -- Identifier, instead of a complete N_Parameter_Specification.
1154 -- Thus, we explicitly set 'in' mode in this case.
1156 Parameter_Mode
:= New_Occurrence_Of
(RTE
(RE_Mode_In
), Loc
);
1160 Parameter_Passing_Mode
(Loc
, Parameter
, Constrained
);
1164 Make_Procedure_Call_Statement
(Loc
,
1167 (RTE
(RE_NVList_Add_Item
), Loc
),
1168 Parameter_Associations
=> New_List
(
1169 New_Occurrence_Of
(NVList
, Loc
),
1170 Make_Function_Call
(Loc
,
1173 (RTE
(RE_To_PolyORB_String
), Loc
),
1174 Parameter_Associations
=> New_List
(
1175 Make_String_Literal
(Loc
,
1176 Strval
=> Parameter_Name_String
))),
1177 New_Occurrence_Of
(Any
, Loc
),
1179 end Add_Parameter_To_NVList
;
1181 --------------------------------
1182 -- Add_RACW_Asynchronous_Flag --
1183 --------------------------------
1185 procedure Add_RACW_Asynchronous_Flag
1186 (Declarations
: List_Id
;
1187 RACW_Type
: Entity_Id
)
1189 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1191 Asynchronous_Flag
: constant Entity_Id
:=
1192 Make_Defining_Identifier
(Loc
,
1193 New_External_Name
(Chars
(RACW_Type
), 'A'));
1196 -- Declare the asynchronous flag. This flag will be changed to True
1197 -- whenever it is known that the RACW type is asynchronous.
1199 Append_To
(Declarations
,
1200 Make_Object_Declaration
(Loc
,
1201 Defining_Identifier
=> Asynchronous_Flag
,
1202 Constant_Present
=> True,
1203 Object_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
1204 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)));
1206 Asynchronous_Flags_Table
.Set
(RACW_Type
, Asynchronous_Flag
);
1207 end Add_RACW_Asynchronous_Flag
;
1209 -----------------------
1210 -- Add_RACW_Features --
1211 -----------------------
1213 procedure Add_RACW_Features
(RACW_Type
: Entity_Id
) is
1214 Desig
: constant Entity_Id
:= Etype
(Designated_Type
(RACW_Type
));
1215 Same_Scope
: constant Boolean := Scope
(Desig
) = Scope
(RACW_Type
);
1219 Body_Decls
: List_Id
;
1221 Stub_Type
: Entity_Id
;
1222 Stub_Type_Access
: Entity_Id
;
1223 RPC_Receiver_Decl
: Node_Id
;
1226 -- True when appropriate stubs have already been generated (this is the
1227 -- case when another RACW with the same designated type has already been
1228 -- encountered), in which case we reuse the previous stubs rather than
1229 -- generating new ones.
1232 if not Expander_Active
then
1236 -- Mark the current package declaration as containing an RACW, so that
1237 -- the bodies for the calling stubs and the RACW stream subprograms
1238 -- are attached to the tree when the corresponding body is encountered.
1240 Set_Has_RACW
(Current_Scope
);
1242 -- Look for place to declare the RACW stub type and RACW operations
1248 -- Case of declaring the RACW in the same package as its designated
1249 -- type: we know that the designated type is a private type, so we
1250 -- use the private declarations list.
1252 Pkg_Spec
:= Package_Specification_Of_Scope
(Current_Scope
);
1254 if Present
(Private_Declarations
(Pkg_Spec
)) then
1255 Decls
:= Private_Declarations
(Pkg_Spec
);
1257 Decls
:= Visible_Declarations
(Pkg_Spec
);
1261 -- Case of declaring the RACW in another package than its designated
1262 -- type: use the private declarations list if present; otherwise
1263 -- use the visible declarations.
1265 Decls
:= List_Containing
(Declaration_Node
(RACW_Type
));
1269 -- If we were unable to find the declarations, that means that the
1270 -- completion of the type was missing. We can safely return and let the
1271 -- error be caught by the semantic analysis.
1278 (Designated_Type
=> Desig
,
1279 RACW_Type
=> RACW_Type
,
1281 Stub_Type
=> Stub_Type
,
1282 Stub_Type_Access
=> Stub_Type_Access
,
1283 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1284 Body_Decls
=> Body_Decls
,
1285 Existing
=> Existing
);
1287 -- If this RACW is not in the main unit, do not generate primitive or
1290 if not Entity_Is_In_Main_Unit
(RACW_Type
) then
1291 Body_Decls
:= No_List
;
1294 Add_RACW_Asynchronous_Flag
1295 (Declarations
=> Decls
,
1296 RACW_Type
=> RACW_Type
);
1298 Specific_Add_RACW_Features
1299 (RACW_Type
=> RACW_Type
,
1301 Stub_Type
=> Stub_Type
,
1302 Stub_Type_Access
=> Stub_Type_Access
,
1303 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
1304 Body_Decls
=> Body_Decls
);
1306 -- If we already have stubs for this designated type, nothing to do
1312 if Is_Frozen
(Desig
) then
1313 Validate_RACW_Primitives
(RACW_Type
);
1314 Add_RACW_Primitive_Declarations_And_Bodies
1315 (Designated_Type
=> Desig
,
1316 Insertion_Node
=> RPC_Receiver_Decl
,
1317 Body_Decls
=> Body_Decls
);
1320 -- Validate_RACW_Primitives requires the list of all primitives of
1321 -- the designated type, so defer processing until Desig is frozen.
1322 -- See Exp_Ch3.Freeze_Type.
1324 Add_Access_Type_To_Process
(E
=> Desig
, A
=> RACW_Type
);
1326 end Add_RACW_Features
;
1328 ------------------------------------------------
1329 -- Add_RACW_Primitive_Declarations_And_Bodies --
1330 ------------------------------------------------
1332 procedure Add_RACW_Primitive_Declarations_And_Bodies
1333 (Designated_Type
: Entity_Id
;
1334 Insertion_Node
: Node_Id
;
1335 Body_Decls
: List_Id
)
1337 Loc
: constant Source_Ptr
:= Sloc
(Insertion_Node
);
1338 -- Set Sloc of generated declaration copy of insertion node Sloc, so
1339 -- the declarations are recognized as belonging to the current package.
1341 Stub_Elements
: constant Stub_Structure
:=
1342 Stubs_Table
.Get
(Designated_Type
);
1344 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
1346 Is_RAS
: constant Boolean :=
1347 not Comes_From_Source
(Stub_Elements
.RACW_Type
);
1348 -- Case of the RACW generated to implement a remote access-to-
1351 Build_Bodies
: constant Boolean :=
1352 In_Extended_Main_Code_Unit
(Stub_Elements
.Stub_Type
);
1353 -- True when bodies must be prepared in Body_Decls. Bodies are generated
1354 -- only when the main unit is the unit that contains the stub type.
1356 Current_Insertion_Node
: Node_Id
:= Insertion_Node
;
1358 RPC_Receiver
: Entity_Id
;
1359 RPC_Receiver_Statements
: List_Id
;
1360 RPC_Receiver_Case_Alternatives
: constant List_Id
:= New_List
;
1361 RPC_Receiver_Elsif_Parts
: List_Id
;
1362 RPC_Receiver_Request
: Entity_Id
;
1363 RPC_Receiver_Subp_Id
: Entity_Id
;
1364 RPC_Receiver_Subp_Index
: Entity_Id
;
1366 Subp_Str
: String_Id
;
1368 Current_Primitive_Elmt
: Elmt_Id
;
1369 Current_Primitive
: Entity_Id
;
1370 Current_Primitive_Body
: Node_Id
;
1371 Current_Primitive_Spec
: Node_Id
;
1372 Current_Primitive_Decl
: Node_Id
;
1373 Current_Primitive_Number
: Int
:= 0;
1374 Current_Primitive_Alias
: Node_Id
;
1375 Current_Receiver
: Entity_Id
;
1376 Current_Receiver_Body
: Node_Id
;
1377 RPC_Receiver_Decl
: Node_Id
;
1378 Possibly_Asynchronous
: Boolean;
1381 if not Expander_Active
then
1386 RPC_Receiver
:= Make_Temporary
(Loc
, 'P');
1388 Specific_Build_RPC_Receiver_Body
1389 (RPC_Receiver
=> RPC_Receiver
,
1390 Request
=> RPC_Receiver_Request
,
1391 Subp_Id
=> RPC_Receiver_Subp_Id
,
1392 Subp_Index
=> RPC_Receiver_Subp_Index
,
1393 Stmts
=> RPC_Receiver_Statements
,
1394 Decl
=> RPC_Receiver_Decl
);
1396 if Get_PCS_Name
= Name_PolyORB_DSA
then
1398 -- For the case of PolyORB, we need to map a textual operation
1399 -- name into a primitive index. Currently we do so using a simple
1400 -- sequence of string comparisons.
1402 RPC_Receiver_Elsif_Parts
:= New_List
;
1406 -- Build callers, receivers for every primitive operations and a RPC
1407 -- receiver for this type. Note that we use Direct_Primitive_Operations,
1408 -- not Primitive_Operations, because we really want just the primitives
1409 -- of the tagged type itself, and in the case of a tagged synchronized
1410 -- type we do not want to get the primitives of the corresponding
1413 if Present
(Direct_Primitive_Operations
(Designated_Type
)) then
1414 Overload_Counter_Table
.Reset
;
1416 Current_Primitive_Elmt
:=
1417 First_Elmt
(Direct_Primitive_Operations
(Designated_Type
));
1418 while Current_Primitive_Elmt
/= No_Elmt
loop
1419 Current_Primitive
:= Node
(Current_Primitive_Elmt
);
1421 -- Copy the primitive of all the parents, except predefined ones
1422 -- that are not remotely dispatching. Also omit hidden primitives
1423 -- (occurs in the case of primitives of interface progenitors
1424 -- other than immediate ancestors of the Designated_Type).
1426 if Chars
(Current_Primitive
) /= Name_uSize
1427 and then Chars
(Current_Primitive
) /= Name_uAlignment
1429 (Is_TSS
(Current_Primitive
, TSS_Deep_Finalize
) or else
1430 Is_TSS
(Current_Primitive
, TSS_Stream_Input
) or else
1431 Is_TSS
(Current_Primitive
, TSS_Stream_Output
) or else
1432 Is_TSS
(Current_Primitive
, TSS_Stream_Read
) or else
1433 Is_TSS
(Current_Primitive
, TSS_Stream_Write
)
1435 Is_Predefined_Interface_Primitive
(Current_Primitive
))
1436 and then not Is_Hidden
(Current_Primitive
)
1438 -- The first thing to do is build an up-to-date copy of the
1439 -- spec with all the formals referencing Controlling_Type
1440 -- transformed into formals referencing Stub_Type. Since this
1441 -- primitive may have been inherited, go back the alias chain
1442 -- until the real primitive has been found.
1444 Current_Primitive_Alias
:= Ultimate_Alias
(Current_Primitive
);
1446 -- Copy the spec from the original declaration for the purpose
1447 -- of declaring an overriding subprogram: we need to replace
1448 -- the type of each controlling formal with Stub_Type. The
1449 -- primitive may have been declared for Controlling_Type or
1450 -- inherited from some ancestor type for which we do not have
1451 -- an easily determined Entity_Id. We have no systematic way
1452 -- of knowing which type to substitute Stub_Type for. Instead,
1453 -- Copy_Specification relies on the flag Is_Controlling_Formal
1454 -- to determine which formals to change.
1456 Current_Primitive_Spec
:=
1457 Copy_Specification
(Loc
,
1458 Spec
=> Parent
(Current_Primitive_Alias
),
1459 Ctrl_Type
=> Stub_Elements
.Stub_Type
);
1461 Current_Primitive_Decl
:=
1462 Make_Subprogram_Declaration
(Loc
,
1463 Specification
=> Current_Primitive_Spec
);
1465 Insert_After_And_Analyze
(Current_Insertion_Node
,
1466 Current_Primitive_Decl
);
1467 Current_Insertion_Node
:= Current_Primitive_Decl
;
1469 Possibly_Asynchronous
:=
1470 Nkind
(Current_Primitive_Spec
) = N_Procedure_Specification
1471 and then Could_Be_Asynchronous
(Current_Primitive_Spec
);
1473 Assign_Subprogram_Identifier
(
1474 Defining_Unit_Name
(Current_Primitive_Spec
),
1475 Current_Primitive_Number
,
1478 if Build_Bodies
then
1479 Current_Primitive_Body
:=
1480 Build_Subprogram_Calling_Stubs
1481 (Vis_Decl
=> Current_Primitive_Decl
,
1483 Build_Subprogram_Id
(Loc
,
1484 Defining_Unit_Name
(Current_Primitive_Spec
)),
1485 Asynchronous
=> Possibly_Asynchronous
,
1486 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1487 Stub_Type
=> Stub_Elements
.Stub_Type
,
1488 RACW_Type
=> Stub_Elements
.RACW_Type
);
1489 Append_To
(Body_Decls
, Current_Primitive_Body
);
1491 -- Analyzing the body here would cause the Stub type to
1492 -- be frozen, thus preventing subsequent primitive
1493 -- declarations. For this reason, it will be analyzed
1494 -- later in the regular flow (and in the context of the
1495 -- appropriate unit body, see Append_RACW_Bodies).
1499 -- Build the receiver stubs
1501 if Build_Bodies
and then not Is_RAS
then
1502 Current_Receiver_Body
:=
1503 Specific_Build_Subprogram_Receiving_Stubs
1504 (Vis_Decl
=> Current_Primitive_Decl
,
1505 Asynchronous
=> Possibly_Asynchronous
,
1506 Dynamically_Asynchronous
=> Possibly_Asynchronous
,
1507 Stub_Type
=> Stub_Elements
.Stub_Type
,
1508 RACW_Type
=> Stub_Elements
.RACW_Type
,
1509 Parent_Primitive
=> Current_Primitive
);
1512 Defining_Unit_Name
(Specification
(Current_Receiver_Body
));
1514 Append_To
(Body_Decls
, Current_Receiver_Body
);
1516 -- Add a case alternative to the receiver
1518 if Get_PCS_Name
= Name_PolyORB_DSA
then
1519 Append_To
(RPC_Receiver_Elsif_Parts
,
1520 Make_Elsif_Part
(Loc
,
1522 Make_Function_Call
(Loc
,
1525 RTE
(RE_Caseless_String_Eq
), Loc
),
1526 Parameter_Associations
=> New_List
(
1527 New_Occurrence_Of
(RPC_Receiver_Subp_Id
, Loc
),
1528 Make_String_Literal
(Loc
, Subp_Str
))),
1530 Then_Statements
=> New_List
(
1531 Make_Assignment_Statement
(Loc
,
1532 Name
=> New_Occurrence_Of
(
1533 RPC_Receiver_Subp_Index
, Loc
),
1535 Make_Integer_Literal
(Loc
,
1536 Intval
=> Current_Primitive_Number
)))));
1539 Append_To
(RPC_Receiver_Case_Alternatives
,
1540 Make_Case_Statement_Alternative
(Loc
,
1541 Discrete_Choices
=> New_List
(
1542 Make_Integer_Literal
(Loc
, Current_Primitive_Number
)),
1544 Statements
=> New_List
(
1545 Make_Procedure_Call_Statement
(Loc
,
1547 New_Occurrence_Of
(Current_Receiver
, Loc
),
1548 Parameter_Associations
=> New_List
(
1549 New_Occurrence_Of
(RPC_Receiver_Request
, Loc
))))));
1552 -- Increment the index of current primitive
1554 Current_Primitive_Number
:= Current_Primitive_Number
+ 1;
1557 Next_Elmt
(Current_Primitive_Elmt
);
1561 -- Build the case statement and the heart of the subprogram
1563 if Build_Bodies
and then not Is_RAS
then
1564 if Get_PCS_Name
= Name_PolyORB_DSA
1565 and then Present
(First
(RPC_Receiver_Elsif_Parts
))
1567 Append_To
(RPC_Receiver_Statements
,
1568 Make_Implicit_If_Statement
(Designated_Type
,
1569 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
1570 Then_Statements
=> New_List
,
1571 Elsif_Parts
=> RPC_Receiver_Elsif_Parts
));
1574 Append_To
(RPC_Receiver_Case_Alternatives
,
1575 Make_Case_Statement_Alternative
(Loc
,
1576 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
1577 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
1579 Append_To
(RPC_Receiver_Statements
,
1580 Make_Case_Statement
(Loc
,
1582 New_Occurrence_Of
(RPC_Receiver_Subp_Index
, Loc
),
1583 Alternatives
=> RPC_Receiver_Case_Alternatives
));
1585 Append_To
(Body_Decls
, RPC_Receiver_Decl
);
1586 Specific_Add_Obj_RPC_Receiver_Completion
(Loc
,
1587 Body_Decls
, RPC_Receiver
, Stub_Elements
);
1589 -- Do not analyze RPC receiver body at this stage since it references
1590 -- subprograms that have not been analyzed yet. It will be analyzed in
1591 -- the regular flow (see Append_RACW_Bodies).
1594 end Add_RACW_Primitive_Declarations_And_Bodies
;
1596 -----------------------------
1597 -- Add_RAS_Dereference_TSS --
1598 -----------------------------
1600 procedure Add_RAS_Dereference_TSS
(N
: Node_Id
) is
1601 Loc
: constant Source_Ptr
:= Sloc
(N
);
1603 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
1604 RAS_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
1605 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(RAS_Type
);
1606 RACW_Type
: constant Entity_Id
:= Underlying_RACW_Type
(RAS_Type
);
1608 RACW_Primitive_Name
: Node_Id
;
1610 Proc
: constant Entity_Id
:=
1611 Make_Defining_Identifier
(Loc
,
1612 Chars
=> Make_TSS_Name
(RAS_Type
, TSS_RAS_Dereference
));
1614 Proc_Spec
: Node_Id
;
1615 Param_Specs
: List_Id
;
1616 Param_Assoc
: constant List_Id
:= New_List
;
1617 Stmts
: constant List_Id
:= New_List
;
1619 RAS_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
1621 Is_Function
: constant Boolean :=
1622 Nkind
(Type_Def
) = N_Access_Function_Definition
;
1624 Is_Degenerate
: Boolean;
1625 -- Set to True if the subprogram_specification for this RAS has an
1626 -- anonymous access parameter (see Process_Remote_AST_Declaration).
1628 Spec
: constant Node_Id
:= Type_Def
;
1630 Current_Parameter
: Node_Id
;
1632 -- Start of processing for Add_RAS_Dereference_TSS
1635 -- The Dereference TSS for a remote access-to-subprogram type has the
1638 -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
1641 -- This is called whenever a value of a RAS type is dereferenced
1643 -- First construct a list of parameter specifications:
1645 -- The first formal is the RAS values
1647 Param_Specs
:= New_List
(
1648 Make_Parameter_Specification
(Loc
,
1649 Defining_Identifier
=> RAS_Parameter
,
1652 New_Occurrence_Of
(Fat_Type
, Loc
)));
1654 -- The following formals are copied from the type declaration
1656 Is_Degenerate
:= False;
1657 Current_Parameter
:= First
(Parameter_Specifications
(Type_Def
));
1658 Parameters
: while Present
(Current_Parameter
) loop
1659 if Nkind
(Parameter_Type
(Current_Parameter
)) =
1662 Is_Degenerate
:= True;
1665 Append_To
(Param_Specs
,
1666 Make_Parameter_Specification
(Loc
,
1667 Defining_Identifier
=>
1668 Make_Defining_Identifier
(Loc
,
1669 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))),
1670 In_Present
=> In_Present
(Current_Parameter
),
1671 Out_Present
=> Out_Present
(Current_Parameter
),
1673 New_Copy_Tree
(Parameter_Type
(Current_Parameter
)),
1675 New_Copy_Tree
(Expression
(Current_Parameter
))));
1677 Append_To
(Param_Assoc
,
1678 Make_Identifier
(Loc
,
1679 Chars
=> Chars
(Defining_Identifier
(Current_Parameter
))));
1681 Next
(Current_Parameter
);
1682 end loop Parameters
;
1684 if Is_Degenerate
then
1685 Prepend_To
(Param_Assoc
, New_Occurrence_Of
(RAS_Parameter
, Loc
));
1687 -- Generate a dummy body. This code will never actually be executed,
1688 -- because null is the only legal value for a degenerate RAS type.
1689 -- For legality's sake (in order to avoid generating a function that
1690 -- does not contain a return statement), we include a dummy recursive
1691 -- call on the TSS itself.
1694 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Explicit_Raise
));
1695 RACW_Primitive_Name
:= New_Occurrence_Of
(Proc
, Loc
);
1698 -- For a normal RAS type, we cast the RAS formal to the corresponding
1699 -- tagged type, and perform a dispatching call to its Call primitive
1702 Prepend_To
(Param_Assoc
,
1703 Unchecked_Convert_To
(RACW_Type
,
1704 New_Occurrence_Of
(RAS_Parameter
, Loc
)));
1706 RACW_Primitive_Name
:=
1707 Make_Selected_Component
(Loc
,
1708 Prefix
=> Scope
(RACW_Type
),
1709 Selector_Name
=> Name_uCall
);
1714 Make_Simple_Return_Statement
(Loc
,
1716 Make_Function_Call
(Loc
,
1717 Name
=> RACW_Primitive_Name
,
1718 Parameter_Associations
=> Param_Assoc
)));
1722 Make_Procedure_Call_Statement
(Loc
,
1723 Name
=> RACW_Primitive_Name
,
1724 Parameter_Associations
=> Param_Assoc
));
1727 -- Build the complete subprogram
1731 Make_Function_Specification
(Loc
,
1732 Defining_Unit_Name
=> Proc
,
1733 Parameter_Specifications
=> Param_Specs
,
1734 Result_Definition
=>
1736 Entity
(Result_Definition
(Spec
)), Loc
));
1738 Set_Ekind
(Proc
, E_Function
);
1740 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
1744 Make_Procedure_Specification
(Loc
,
1745 Defining_Unit_Name
=> Proc
,
1746 Parameter_Specifications
=> Param_Specs
);
1748 Set_Ekind
(Proc
, E_Procedure
);
1749 Set_Etype
(Proc
, Standard_Void_Type
);
1753 Make_Subprogram_Body
(Loc
,
1754 Specification
=> Proc_Spec
,
1755 Declarations
=> New_List
,
1756 Handled_Statement_Sequence
=>
1757 Make_Handled_Sequence_Of_Statements
(Loc
,
1758 Statements
=> Stmts
)));
1760 Set_TSS
(Fat_Type
, Proc
);
1761 end Add_RAS_Dereference_TSS
;
1763 -------------------------------
1764 -- Add_RAS_Proxy_And_Analyze --
1765 -------------------------------
1767 procedure Add_RAS_Proxy_And_Analyze
1770 All_Calls_Remote_E
: Entity_Id
;
1771 Proxy_Object_Addr
: out Entity_Id
)
1773 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
1775 Subp_Name
: constant Entity_Id
:=
1776 Defining_Unit_Name
(Specification
(Vis_Decl
));
1778 Pkg_Name
: constant Entity_Id
:=
1779 Make_Defining_Identifier
(Loc
,
1780 Chars
=> New_External_Name
(Chars
(Subp_Name
), 'P', -1));
1782 Proxy_Type
: constant Entity_Id
:=
1783 Make_Defining_Identifier
(Loc
,
1786 (Related_Id
=> Chars
(Subp_Name
),
1789 Proxy_Type_Full_View
: constant Entity_Id
:=
1790 Make_Defining_Identifier
(Loc
,
1791 Chars
(Proxy_Type
));
1793 Subp_Decl_Spec
: constant Node_Id
:=
1794 Build_RAS_Primitive_Specification
1795 (Subp_Spec
=> Specification
(Vis_Decl
),
1796 Remote_Object_Type
=> Proxy_Type
);
1798 Subp_Body_Spec
: constant Node_Id
:=
1799 Build_RAS_Primitive_Specification
1800 (Subp_Spec
=> Specification
(Vis_Decl
),
1801 Remote_Object_Type
=> Proxy_Type
);
1803 Vis_Decls
: constant List_Id
:= New_List
;
1804 Pvt_Decls
: constant List_Id
:= New_List
;
1805 Actuals
: constant List_Id
:= New_List
;
1807 Perform_Call
: Node_Id
;
1810 -- type subpP is tagged limited private;
1812 Append_To
(Vis_Decls
,
1813 Make_Private_Type_Declaration
(Loc
,
1814 Defining_Identifier
=> Proxy_Type
,
1815 Tagged_Present
=> True,
1816 Limited_Present
=> True));
1818 -- [subprogram] Call
1819 -- (Self : access subpP;
1820 -- ...other-formals...)
1823 Append_To
(Vis_Decls
,
1824 Make_Subprogram_Declaration
(Loc
,
1825 Specification
=> Subp_Decl_Spec
));
1827 -- A : constant System.Address;
1829 Proxy_Object_Addr
:= Make_Defining_Identifier
(Loc
, Name_uA
);
1831 Append_To
(Vis_Decls
,
1832 Make_Object_Declaration
(Loc
,
1833 Defining_Identifier
=> Proxy_Object_Addr
,
1834 Constant_Present
=> True,
1835 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
1839 -- type subpP is tagged limited record
1840 -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
1844 Append_To
(Pvt_Decls
,
1845 Make_Full_Type_Declaration
(Loc
,
1846 Defining_Identifier
=> Proxy_Type_Full_View
,
1848 Build_Remote_Subprogram_Proxy_Type
(Loc
,
1849 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
))));
1851 -- Trick semantic analysis into swapping the public and full view when
1852 -- freezing the public view.
1854 Set_Comes_From_Source
(Proxy_Type_Full_View
, True);
1857 -- (Self : access O;
1858 -- ...other-formals...) is
1860 -- P (...other-formals...);
1864 -- (Self : access O;
1865 -- ...other-formals...)
1868 -- return F (...other-formals...);
1871 if Nkind
(Subp_Decl_Spec
) = N_Procedure_Specification
then
1873 Make_Procedure_Call_Statement
(Loc
,
1874 Name
=> New_Occurrence_Of
(Subp_Name
, Loc
),
1875 Parameter_Associations
=> Actuals
);
1878 Make_Simple_Return_Statement
(Loc
,
1880 Make_Function_Call
(Loc
,
1881 Name
=> New_Occurrence_Of
(Subp_Name
, Loc
),
1882 Parameter_Associations
=> Actuals
));
1885 Formal
:= First
(Parameter_Specifications
(Subp_Decl_Spec
));
1886 pragma Assert
(Present
(Formal
));
1889 exit when No
(Formal
);
1891 New_Occurrence_Of
(Defining_Identifier
(Formal
), Loc
));
1894 -- O : aliased subpP;
1896 Append_To
(Pvt_Decls
,
1897 Make_Object_Declaration
(Loc
,
1898 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uO
),
1899 Aliased_Present
=> True,
1900 Object_Definition
=> New_Occurrence_Of
(Proxy_Type
, Loc
)));
1902 -- A : constant System.Address := O'Address;
1904 Append_To
(Pvt_Decls
,
1905 Make_Object_Declaration
(Loc
,
1906 Defining_Identifier
=>
1907 Make_Defining_Identifier
(Loc
, Chars
(Proxy_Object_Addr
)),
1908 Constant_Present
=> True,
1909 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Address
), Loc
),
1911 Make_Attribute_Reference
(Loc
,
1912 Prefix
=> New_Occurrence_Of
(
1913 Defining_Identifier
(Last
(Pvt_Decls
)), Loc
),
1914 Attribute_Name
=> Name_Address
)));
1917 Make_Package_Declaration
(Loc
,
1918 Specification
=> Make_Package_Specification
(Loc
,
1919 Defining_Unit_Name
=> Pkg_Name
,
1920 Visible_Declarations
=> Vis_Decls
,
1921 Private_Declarations
=> Pvt_Decls
,
1922 End_Label
=> Empty
)));
1923 Analyze
(Last
(Decls
));
1926 Make_Package_Body
(Loc
,
1927 Defining_Unit_Name
=>
1928 Make_Defining_Identifier
(Loc
, Chars
(Pkg_Name
)),
1929 Declarations
=> New_List
(
1930 Make_Subprogram_Body
(Loc
,
1931 Specification
=> Subp_Body_Spec
,
1932 Declarations
=> New_List
,
1933 Handled_Statement_Sequence
=>
1934 Make_Handled_Sequence_Of_Statements
(Loc
,
1935 Statements
=> New_List
(Perform_Call
))))));
1936 Analyze
(Last
(Decls
));
1937 end Add_RAS_Proxy_And_Analyze
;
1939 -----------------------
1940 -- Add_RAST_Features --
1941 -----------------------
1943 procedure Add_RAST_Features
(Vis_Decl
: Node_Id
) is
1944 RAS_Type
: constant Entity_Id
:=
1945 Equivalent_Type
(Defining_Identifier
(Vis_Decl
));
1947 pragma Assert
(No
(TSS
(RAS_Type
, TSS_RAS_Access
)));
1948 Add_RAS_Dereference_TSS
(Vis_Decl
);
1949 Specific_Add_RAST_Features
(Vis_Decl
, RAS_Type
);
1950 end Add_RAST_Features
;
1956 procedure Add_Stub_Type
1957 (Designated_Type
: Entity_Id
;
1958 RACW_Type
: Entity_Id
;
1960 Stub_Type
: out Entity_Id
;
1961 Stub_Type_Access
: out Entity_Id
;
1962 RPC_Receiver_Decl
: out Node_Id
;
1963 Body_Decls
: out List_Id
;
1964 Existing
: out Boolean)
1966 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
1968 Stub_Elements
: constant Stub_Structure
:=
1969 Stubs_Table
.Get
(Designated_Type
);
1970 Stub_Type_Comps
: List_Id
;
1971 Stub_Type_Decl
: Node_Id
;
1972 Stub_Type_Access_Decl
: Node_Id
;
1975 if Stub_Elements
/= Empty_Stub_Structure
then
1976 Stub_Type
:= Stub_Elements
.Stub_Type
;
1977 Stub_Type_Access
:= Stub_Elements
.Stub_Type_Access
;
1978 RPC_Receiver_Decl
:= Stub_Elements
.RPC_Receiver_Decl
;
1979 Body_Decls
:= Stub_Elements
.Body_Decls
;
1985 Stub_Type
:= Make_Temporary
(Loc
, 'S');
1986 Set_Ekind
(Stub_Type
, E_Record_Type
);
1987 Set_Is_RACW_Stub_Type
(Stub_Type
);
1989 Make_Defining_Identifier
(Loc
,
1990 Chars
=> New_External_Name
1991 (Related_Id
=> Chars
(Stub_Type
), Suffix
=> 'A'));
1993 Specific_Build_Stub_Type
(RACW_Type
, Stub_Type_Comps
, RPC_Receiver_Decl
);
1996 Make_Full_Type_Declaration
(Loc
,
1997 Defining_Identifier
=> Stub_Type
,
1999 Make_Record_Definition
(Loc
,
2000 Tagged_Present
=> True,
2001 Limited_Present
=> True,
2003 Make_Component_List
(Loc
,
2004 Component_Items
=> Stub_Type_Comps
)));
2006 -- Does the stub type need to explicitly implement interfaces from the
2007 -- designated type???
2009 -- In particular are there issues in the case where the designated type
2010 -- is a synchronized interface???
2012 Stub_Type_Access_Decl
:=
2013 Make_Full_Type_Declaration
(Loc
,
2014 Defining_Identifier
=> Stub_Type_Access
,
2016 Make_Access_To_Object_Definition
(Loc
,
2017 All_Present
=> True,
2018 Subtype_Indication
=> New_Occurrence_Of
(Stub_Type
, Loc
)));
2020 Append_To
(Decls
, Stub_Type_Decl
);
2021 Analyze
(Last
(Decls
));
2022 Append_To
(Decls
, Stub_Type_Access_Decl
);
2023 Analyze
(Last
(Decls
));
2025 -- We can't directly derive the stub type from the designated type,
2026 -- because we don't want any components or discriminants from the real
2027 -- type, so instead we manually fake a derivation to get an appropriate
2030 Derive_Subprograms
(Parent_Type
=> Designated_Type
,
2031 Derived_Type
=> Stub_Type
);
2033 if Present
(RPC_Receiver_Decl
) then
2034 Append_To
(Decls
, RPC_Receiver_Decl
);
2036 RPC_Receiver_Decl
:= Last
(Decls
);
2039 Body_Decls
:= New_List
;
2041 Stubs_Table
.Set
(Designated_Type
,
2042 (Stub_Type
=> Stub_Type
,
2043 Stub_Type_Access
=> Stub_Type_Access
,
2044 RPC_Receiver_Decl
=> RPC_Receiver_Decl
,
2045 Body_Decls
=> Body_Decls
,
2046 RACW_Type
=> RACW_Type
));
2049 ------------------------
2050 -- Append_RACW_Bodies --
2051 ------------------------
2053 procedure Append_RACW_Bodies
(Decls
: List_Id
; Spec_Id
: Entity_Id
) is
2057 E
:= First_Entity
(Spec_Id
);
2058 while Present
(E
) loop
2059 if Is_Remote_Access_To_Class_Wide_Type
(E
) then
2060 Append_List_To
(Decls
, Get_And_Reset_RACW_Bodies
(E
));
2065 end Append_RACW_Bodies
;
2067 ----------------------------------
2068 -- Assign_Subprogram_Identifier --
2069 ----------------------------------
2071 procedure Assign_Subprogram_Identifier
2076 N
: constant Name_Id
:= Chars
(Def
);
2078 Overload_Order
: constant Int
:=
2079 Overload_Counter_Table
.Get
(N
) + 1;
2082 Overload_Counter_Table
.Set
(N
, Overload_Order
);
2084 Get_Name_String
(N
);
2086 -- Homonym handling: as in Exp_Dbug, but much simpler, because the only
2087 -- entities for which we have to generate names here need only to be
2088 -- disambiguated within their own scope.
2090 if Overload_Order
> 1 then
2091 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 2) := "__";
2092 Name_Len
:= Name_Len
+ 2;
2093 Add_Nat_To_Name_Buffer
(Overload_Order
);
2096 Id
:= String_From_Name_Buffer
;
2097 Subprogram_Identifier_Table
.Set
2099 Subprogram_Identifiers
'(Str_Identifier => Id, Int_Identifier => Spn));
2100 end Assign_Subprogram_Identifier;
2102 -------------------------------------
2103 -- Build_Actual_Object_Declaration --
2104 -------------------------------------
2106 procedure Build_Actual_Object_Declaration
2107 (Object : Entity_Id;
2113 Loc : constant Source_Ptr := Sloc (Object);
2116 -- Declare a temporary object for the actual, possibly initialized with
2117 -- a 'Input
/From_Any call
.
2119 -- Complication arises in the case of limited types, for which such a
2120 -- declaration is illegal in Ada 95. In that case, we first generate a
2121 -- renaming declaration of the 'Input call, and then if needed we
2122 -- generate an overlaid non-constant view.
2124 if Ada_Version
<= Ada_95
2125 and then Is_Limited_Type
(Etyp
)
2126 and then Present
(Expr
)
2129 -- Object : Etyp renames <func-call>
2132 Make_Object_Renaming_Declaration
(Loc
,
2133 Defining_Identifier
=> Object
,
2134 Subtype_Mark
=> New_Occurrence_Of
(Etyp
, Loc
),
2139 -- The name defined by the renaming declaration denotes a
2140 -- constant view; create a non-constant object at the same address
2141 -- to be used as the actual.
2144 Constant_Object
: constant Entity_Id
:=
2145 Make_Temporary
(Loc
, 'P');
2148 Set_Defining_Identifier
2149 (Last
(Decls
), Constant_Object
);
2151 -- We have an unconstrained Etyp: build the actual constrained
2152 -- subtype for the value we just read from the stream.
2154 -- subtype S is <actual subtype of Constant_Object>;
2157 Build_Actual_Subtype
(Etyp
,
2158 New_Occurrence_Of
(Constant_Object
, Loc
)));
2163 Make_Object_Declaration
(Loc
,
2164 Defining_Identifier
=> Object
,
2165 Object_Definition
=>
2167 (Defining_Identifier
(Last
(Decls
)), Loc
)));
2168 Set_Ekind
(Object
, E_Variable
);
2170 -- Suppress default initialization:
2171 -- pragma Import (Ada, Object);
2175 Chars
=> Name_Import
,
2176 Pragma_Argument_Associations
=> New_List
(
2177 Make_Pragma_Argument_Association
(Loc
,
2178 Chars
=> Name_Convention
,
2179 Expression
=> Make_Identifier
(Loc
, Name_Ada
)),
2180 Make_Pragma_Argument_Association
(Loc
,
2181 Chars
=> Name_Entity
,
2182 Expression
=> New_Occurrence_Of
(Object
, Loc
)))));
2184 -- for Object'Address use Constant_Object'Address;
2187 Make_Attribute_Definition_Clause
(Loc
,
2188 Name
=> New_Occurrence_Of
(Object
, Loc
),
2189 Chars
=> Name_Address
,
2191 Make_Attribute_Reference
(Loc
,
2192 Prefix
=> New_Occurrence_Of
(Constant_Object
, Loc
),
2193 Attribute_Name
=> Name_Address
)));
2198 -- General case of a regular object declaration. Object is flagged
2199 -- constant unless it has mode out or in out, to allow the backend
2200 -- to optimize where possible.
2202 -- Object : [constant] Etyp [:= <expr>];
2205 Make_Object_Declaration
(Loc
,
2206 Defining_Identifier
=> Object
,
2207 Constant_Present
=> Present
(Expr
) and then not Variable
,
2208 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
2209 Expression
=> Expr
));
2211 if Constant_Present
(Last
(Decls
)) then
2212 Set_Ekind
(Object
, E_Constant
);
2214 Set_Ekind
(Object
, E_Variable
);
2217 end Build_Actual_Object_Declaration
;
2219 ------------------------------
2220 -- Build_Get_Unique_RP_Call --
2221 ------------------------------
2223 function Build_Get_Unique_RP_Call
2225 Pointer
: Entity_Id
;
2226 Stub_Type
: Entity_Id
) return List_Id
2230 Make_Procedure_Call_Statement
(Loc
,
2232 New_Occurrence_Of
(RTE
(RE_Get_Unique_Remote_Pointer
), Loc
),
2233 Parameter_Associations
=> New_List
(
2234 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2235 New_Occurrence_Of
(Pointer
, Loc
)))),
2237 Make_Assignment_Statement
(Loc
,
2239 Make_Selected_Component
(Loc
,
2240 Prefix
=> New_Occurrence_Of
(Pointer
, Loc
),
2242 New_Occurrence_Of
(First_Tag_Component
2243 (Designated_Type
(Etype
(Pointer
))), Loc
)),
2245 Make_Attribute_Reference
(Loc
,
2246 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
2247 Attribute_Name
=> Name_Tag
)));
2249 -- Note: The assignment to Pointer._Tag is safe here because
2250 -- we carefully ensured that Stub_Type has exactly the same layout
2251 -- as System.Partition_Interface.RACW_Stub_Type.
2253 end Build_Get_Unique_RP_Call
;
2255 -----------------------------------
2256 -- Build_Ordered_Parameters_List --
2257 -----------------------------------
2259 function Build_Ordered_Parameters_List
(Spec
: Node_Id
) return List_Id
is
2260 Constrained_List
: List_Id
;
2261 Unconstrained_List
: List_Id
;
2262 Current_Parameter
: Node_Id
;
2265 First_Parameter
: Node_Id
;
2266 For_RAS
: Boolean := False;
2269 if No
(Parameter_Specifications
(Spec
)) then
2273 Constrained_List
:= New_List
;
2274 Unconstrained_List
:= New_List
;
2275 First_Parameter
:= First
(Parameter_Specifications
(Spec
));
2277 if Nkind
(Parameter_Type
(First_Parameter
)) = N_Access_Definition
2278 and then Chars
(Defining_Identifier
(First_Parameter
)) = Name_uS
2283 -- Loop through the parameters and add them to the right list. Note that
2284 -- we treat a parameter of a null-excluding access type as unconstrained
2285 -- because we can't declare an object of such a type with default
2288 Current_Parameter
:= First_Parameter
;
2289 while Present
(Current_Parameter
) loop
2290 Ptyp
:= Parameter_Type
(Current_Parameter
);
2292 if (Nkind
(Ptyp
) = N_Access_Definition
2293 or else not Transmit_As_Unconstrained
(Etype
(Ptyp
)))
2294 and then not (For_RAS
and then Current_Parameter
= First_Parameter
)
2296 Append_To
(Constrained_List
, New_Copy
(Current_Parameter
));
2298 Append_To
(Unconstrained_List
, New_Copy
(Current_Parameter
));
2301 Next
(Current_Parameter
);
2304 -- Unconstrained parameters are returned first
2306 Append_List_To
(Unconstrained_List
, Constrained_List
);
2308 return Unconstrained_List
;
2309 end Build_Ordered_Parameters_List
;
2311 ----------------------------------
2312 -- Build_Passive_Partition_Stub --
2313 ----------------------------------
2315 procedure Build_Passive_Partition_Stub
(U
: Node_Id
) is
2317 Pkg_Name
: String_Id
;
2320 Loc
: constant Source_Ptr
:= Sloc
(U
);
2323 -- Verify that the implementation supports distribution, by accessing
2324 -- a type defined in the proper version of system.rpc
2327 Dist_OK
: Entity_Id
;
2328 pragma Warnings
(Off
, Dist_OK
);
2330 Dist_OK
:= RTE
(RE_Params_Stream_Type
);
2333 -- Use body if present, spec otherwise
2335 if Nkind
(U
) = N_Package_Declaration
then
2336 Pkg_Spec
:= Specification
(U
);
2337 L
:= Visible_Declarations
(Pkg_Spec
);
2339 Pkg_Spec
:= Parent
(Corresponding_Spec
(U
));
2340 L
:= Declarations
(U
);
2343 Get_Library_Unit_Name_String
(Pkg_Spec
);
2344 Pkg_Name
:= String_From_Name_Buffer
;
2346 Make_Procedure_Call_Statement
(Loc
,
2348 New_Occurrence_Of
(RTE
(RE_Register_Passive_Package
), Loc
),
2349 Parameter_Associations
=> New_List
(
2350 Make_String_Literal
(Loc
, Pkg_Name
),
2351 Make_Attribute_Reference
(Loc
,
2353 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
2354 Attribute_Name
=> Name_Version
)));
2357 end Build_Passive_Partition_Stub
;
2359 --------------------------------------
2360 -- Build_RPC_Receiver_Specification --
2361 --------------------------------------
2363 function Build_RPC_Receiver_Specification
2364 (RPC_Receiver
: Entity_Id
;
2365 Request_Parameter
: Entity_Id
) return Node_Id
2367 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
2370 Make_Procedure_Specification
(Loc
,
2371 Defining_Unit_Name
=> RPC_Receiver
,
2372 Parameter_Specifications
=> New_List
(
2373 Make_Parameter_Specification
(Loc
,
2374 Defining_Identifier
=> Request_Parameter
,
2376 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
2377 end Build_RPC_Receiver_Specification
;
2379 ----------------------------------------
2380 -- Build_Remote_Subprogram_Proxy_Type --
2381 ----------------------------------------
2383 function Build_Remote_Subprogram_Proxy_Type
2385 ACR_Expression
: Node_Id
) return Node_Id
2389 Make_Record_Definition
(Loc
,
2390 Tagged_Present
=> True,
2391 Limited_Present
=> True,
2393 Make_Component_List
(Loc
,
2395 Component_Items
=> New_List
(
2396 Make_Component_Declaration
(Loc
,
2397 Defining_Identifier
=>
2398 Make_Defining_Identifier
(Loc
,
2399 Name_All_Calls_Remote
),
2400 Component_Definition
=>
2401 Make_Component_Definition
(Loc
,
2402 Subtype_Indication
=>
2403 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
2407 Make_Component_Declaration
(Loc
,
2408 Defining_Identifier
=>
2409 Make_Defining_Identifier
(Loc
,
2411 Component_Definition
=>
2412 Make_Component_Definition
(Loc
,
2413 Subtype_Indication
=>
2414 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
2416 New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
)),
2418 Make_Component_Declaration
(Loc
,
2419 Defining_Identifier
=>
2420 Make_Defining_Identifier
(Loc
,
2422 Component_Definition
=>
2423 Make_Component_Definition
(Loc
,
2424 Subtype_Indication
=>
2425 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))))));
2426 end Build_Remote_Subprogram_Proxy_Type
;
2428 --------------------
2429 -- Build_Stub_Tag --
2430 --------------------
2432 function Build_Stub_Tag
2434 RACW_Type
: Entity_Id
) return Node_Id
2436 Stub_Type
: constant Entity_Id
:= Corresponding_Stub_Type
(RACW_Type
);
2439 Make_Attribute_Reference
(Loc
,
2440 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
2441 Attribute_Name
=> Name_Tag
);
2444 ------------------------------------
2445 -- Build_Subprogram_Calling_Stubs --
2446 ------------------------------------
2448 function Build_Subprogram_Calling_Stubs
2449 (Vis_Decl
: Node_Id
;
2451 Asynchronous
: Boolean;
2452 Dynamically_Asynchronous
: Boolean := False;
2453 Stub_Type
: Entity_Id
:= Empty
;
2454 RACW_Type
: Entity_Id
:= Empty
;
2455 Locator
: Entity_Id
:= Empty
;
2456 New_Name
: Name_Id
:= No_Name
) return Node_Id
2458 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
2460 Decls
: constant List_Id
:= New_List
;
2461 Statements
: constant List_Id
:= New_List
;
2463 Subp_Spec
: Node_Id
;
2464 -- The specification of the body
2466 Controlling_Parameter
: Entity_Id
:= Empty
;
2468 Asynchronous_Expr
: Node_Id
:= Empty
;
2470 RCI_Locator
: Entity_Id
;
2472 Spec_To_Use
: Node_Id
;
2474 procedure Insert_Partition_Check
(Parameter
: Node_Id
);
2475 -- Check that the parameter has been elaborated on the same partition
2476 -- than the controlling parameter (E.4(19)).
2478 ----------------------------
2479 -- Insert_Partition_Check --
2480 ----------------------------
2482 procedure Insert_Partition_Check
(Parameter
: Node_Id
) is
2483 Parameter_Entity
: constant Entity_Id
:=
2484 Defining_Identifier
(Parameter
);
2486 -- The expression that will be built is of the form:
2488 -- if not Same_Partition (Parameter, Controlling_Parameter) then
2489 -- raise Constraint_Error;
2492 -- We do not check that Parameter is in Stub_Type since such a check
2493 -- has been inserted at the point of call already (a tag check since
2494 -- we have multiple controlling operands).
2497 Make_Raise_Constraint_Error
(Loc
,
2501 Make_Function_Call
(Loc
,
2503 New_Occurrence_Of
(RTE
(RE_Same_Partition
), Loc
),
2504 Parameter_Associations
=>
2506 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2507 New_Occurrence_Of
(Parameter_Entity
, Loc
)),
2508 Unchecked_Convert_To
(RTE
(RE_RACW_Stub_Type_Access
),
2509 New_Occurrence_Of
(Controlling_Parameter
, Loc
))))),
2510 Reason
=> CE_Partition_Check_Failed
));
2511 end Insert_Partition_Check
;
2513 -- Start of processing for Build_Subprogram_Calling_Stubs
2517 Copy_Specification
(Loc
,
2518 Spec
=> Specification
(Vis_Decl
),
2519 New_Name
=> New_Name
);
2521 if Locator
= Empty
then
2522 RCI_Locator
:= RCI_Cache
;
2523 Spec_To_Use
:= Specification
(Vis_Decl
);
2525 RCI_Locator
:= Locator
;
2526 Spec_To_Use
:= Subp_Spec
;
2529 -- Find a controlling argument if we have a stub type. Also check
2530 -- if this subprogram can be made asynchronous.
2532 if Present
(Stub_Type
)
2533 and then Present
(Parameter_Specifications
(Spec_To_Use
))
2536 Current_Parameter
: Node_Id
:=
2537 First
(Parameter_Specifications
2540 while Present
(Current_Parameter
) loop
2542 Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
)
2544 if Controlling_Parameter
= Empty
then
2545 Controlling_Parameter
:=
2546 Defining_Identifier
(Current_Parameter
);
2548 Insert_Partition_Check
(Current_Parameter
);
2552 Next
(Current_Parameter
);
2557 pragma Assert
(No
(Stub_Type
) or else Present
(Controlling_Parameter
));
2559 if Dynamically_Asynchronous
then
2560 Asynchronous_Expr
:= Make_Selected_Component
(Loc
,
2561 Prefix
=> Controlling_Parameter
,
2562 Selector_Name
=> Name_Asynchronous
);
2565 Specific_Build_General_Calling_Stubs
2567 Statements
=> Statements
,
2568 Target
=> Specific_Build_Stub_Target
(Loc
,
2569 Decls
, RCI_Locator
, Controlling_Parameter
),
2570 Subprogram_Id
=> Subp_Id
,
2571 Asynchronous
=> Asynchronous_Expr
,
2572 Is_Known_Asynchronous
=> Asynchronous
2573 and then not Dynamically_Asynchronous
,
2574 Is_Known_Non_Asynchronous
2576 and then not Dynamically_Asynchronous
,
2577 Is_Function
=> Nkind
(Spec_To_Use
) =
2578 N_Function_Specification
,
2579 Spec
=> Spec_To_Use
,
2580 Stub_Type
=> Stub_Type
,
2581 RACW_Type
=> RACW_Type
,
2584 RCI_Calling_Stubs_Table
.Set
2585 (Defining_Unit_Name
(Specification
(Vis_Decl
)),
2586 Defining_Unit_Name
(Spec_To_Use
));
2589 Make_Subprogram_Body
(Loc
,
2590 Specification
=> Subp_Spec
,
2591 Declarations
=> Decls
,
2592 Handled_Statement_Sequence
=>
2593 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
));
2594 end Build_Subprogram_Calling_Stubs
;
2596 -------------------------
2597 -- Build_Subprogram_Id --
2598 -------------------------
2600 function Build_Subprogram_Id
2602 E
: Entity_Id
) return Node_Id
2605 if Get_Subprogram_Ids
(E
).Str_Identifier
= No_String
then
2607 Current_Declaration
: Node_Id
;
2608 Current_Subp
: Entity_Id
;
2609 Current_Subp_Str
: String_Id
;
2610 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
2612 pragma Warnings
(Off
, Current_Subp_Str
);
2615 -- Build_Subprogram_Id is called outside of the context of
2616 -- generating calling or receiving stubs. Hence we are processing
2617 -- an 'Access attribute_reference for an RCI subprogram, for the
2618 -- purpose of obtaining a RAS value.
2621 (Is_Remote_Call_Interface
(Scope
(E
))
2623 (Nkind
(Parent
(E
)) = N_Procedure_Specification
2625 Nkind
(Parent
(E
)) = N_Function_Specification
));
2627 Current_Declaration
:=
2628 First
(Visible_Declarations
2629 (Package_Specification_Of_Scope
(Scope
(E
))));
2630 while Present
(Current_Declaration
) loop
2631 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
2632 and then Comes_From_Source
(Current_Declaration
)
2634 Current_Subp
:= Defining_Unit_Name
(Specification
(
2635 Current_Declaration
));
2637 Assign_Subprogram_Identifier
2638 (Current_Subp
, Current_Subp_Number
, Current_Subp_Str
);
2640 Current_Subp_Number
:= Current_Subp_Number
+ 1;
2643 Next
(Current_Declaration
);
2648 case Get_PCS_Name
is
2649 when Name_PolyORB_DSA
=>
2650 return Make_String_Literal
(Loc
, Get_Subprogram_Id
(E
));
2652 return Make_Integer_Literal
(Loc
, Get_Subprogram_Id
(E
));
2654 end Build_Subprogram_Id
;
2656 ------------------------
2657 -- Copy_Specification --
2658 ------------------------
2660 function Copy_Specification
2663 Ctrl_Type
: Entity_Id
:= Empty
;
2664 New_Name
: Name_Id
:= No_Name
) return Node_Id
2666 Parameters
: List_Id
:= No_List
;
2668 Current_Parameter
: Node_Id
;
2669 Current_Identifier
: Entity_Id
;
2670 Current_Type
: Node_Id
;
2672 Name_For_New_Spec
: Name_Id
;
2674 New_Identifier
: Entity_Id
;
2676 -- Comments needed in body below ???
2679 if New_Name
= No_Name
then
2680 pragma Assert
(Nkind
(Spec
) = N_Function_Specification
2681 or else Nkind
(Spec
) = N_Procedure_Specification
);
2683 Name_For_New_Spec
:= Chars
(Defining_Unit_Name
(Spec
));
2685 Name_For_New_Spec
:= New_Name
;
2688 if Present
(Parameter_Specifications
(Spec
)) then
2689 Parameters
:= New_List
;
2690 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2691 while Present
(Current_Parameter
) loop
2692 Current_Identifier
:= Defining_Identifier
(Current_Parameter
);
2693 Current_Type
:= Parameter_Type
(Current_Parameter
);
2695 if Nkind
(Current_Type
) = N_Access_Definition
then
2696 if Present
(Ctrl_Type
) then
2697 pragma Assert
(Is_Controlling_Formal
(Current_Identifier
));
2699 Make_Access_Definition
(Loc
,
2700 Subtype_Mark
=> New_Occurrence_Of
(Ctrl_Type
, Loc
),
2701 Null_Exclusion_Present
=>
2702 Null_Exclusion_Present
(Current_Type
));
2706 Make_Access_Definition
(Loc
,
2708 New_Copy_Tree
(Subtype_Mark
(Current_Type
)),
2709 Null_Exclusion_Present
=>
2710 Null_Exclusion_Present
(Current_Type
));
2714 if Present
(Ctrl_Type
)
2715 and then Is_Controlling_Formal
(Current_Identifier
)
2717 Current_Type
:= New_Occurrence_Of
(Ctrl_Type
, Loc
);
2719 Current_Type
:= New_Copy_Tree
(Current_Type
);
2723 New_Identifier
:= Make_Defining_Identifier
(Loc
,
2724 Chars
(Current_Identifier
));
2726 Append_To
(Parameters
,
2727 Make_Parameter_Specification
(Loc
,
2728 Defining_Identifier
=> New_Identifier
,
2729 Parameter_Type
=> Current_Type
,
2730 In_Present
=> In_Present
(Current_Parameter
),
2731 Out_Present
=> Out_Present
(Current_Parameter
),
2733 New_Copy_Tree
(Expression
(Current_Parameter
))));
2735 -- For a regular formal parameter (that needs to be marshalled
2736 -- in the context of remote calls), set the Etype now, because
2737 -- marshalling processing might need it.
2739 if Is_Entity_Name
(Current_Type
) then
2740 Set_Etype
(New_Identifier
, Entity
(Current_Type
));
2742 -- Current_Type is an access definition, special processing
2743 -- (not requiring etype) will occur for marshalling.
2749 Next
(Current_Parameter
);
2753 case Nkind
(Spec
) is
2755 when N_Function_Specification | N_Access_Function_Definition
=>
2757 Make_Function_Specification
(Loc
,
2758 Defining_Unit_Name
=>
2759 Make_Defining_Identifier
(Loc
,
2760 Chars
=> Name_For_New_Spec
),
2761 Parameter_Specifications
=> Parameters
,
2762 Result_Definition
=>
2763 New_Occurrence_Of
(Entity
(Result_Definition
(Spec
)), Loc
));
2765 when N_Procedure_Specification | N_Access_Procedure_Definition
=>
2767 Make_Procedure_Specification
(Loc
,
2768 Defining_Unit_Name
=>
2769 Make_Defining_Identifier
(Loc
,
2770 Chars
=> Name_For_New_Spec
),
2771 Parameter_Specifications
=> Parameters
);
2774 raise Program_Error
;
2776 end Copy_Specification
;
2778 -----------------------------
2779 -- Corresponding_Stub_Type --
2780 -----------------------------
2782 function Corresponding_Stub_Type
(RACW_Type
: Entity_Id
) return Entity_Id
is
2783 Desig
: constant Entity_Id
:=
2784 Etype
(Designated_Type
(RACW_Type
));
2785 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
2787 return Stub_Elements
.Stub_Type
;
2788 end Corresponding_Stub_Type
;
2790 ---------------------------
2791 -- Could_Be_Asynchronous --
2792 ---------------------------
2794 function Could_Be_Asynchronous
(Spec
: Node_Id
) return Boolean is
2795 Current_Parameter
: Node_Id
;
2798 if Present
(Parameter_Specifications
(Spec
)) then
2799 Current_Parameter
:= First
(Parameter_Specifications
(Spec
));
2800 while Present
(Current_Parameter
) loop
2801 if Out_Present
(Current_Parameter
) then
2805 Next
(Current_Parameter
);
2810 end Could_Be_Asynchronous
;
2812 ---------------------------
2813 -- Declare_Create_NVList --
2814 ---------------------------
2816 procedure Declare_Create_NVList
2824 Make_Object_Declaration
(Loc
,
2825 Defining_Identifier
=> NVList
,
2826 Aliased_Present
=> False,
2827 Object_Definition
=>
2828 New_Occurrence_Of
(RTE
(RE_NVList_Ref
), Loc
)));
2831 Make_Procedure_Call_Statement
(Loc
,
2832 Name
=> New_Occurrence_Of
(RTE
(RE_NVList_Create
), Loc
),
2833 Parameter_Associations
=> New_List
(
2834 New_Occurrence_Of
(NVList
, Loc
))));
2835 end Declare_Create_NVList
;
2837 ---------------------------------------------
2838 -- Expand_All_Calls_Remote_Subprogram_Call --
2839 ---------------------------------------------
2841 procedure Expand_All_Calls_Remote_Subprogram_Call
(N
: Node_Id
) is
2842 Loc
: constant Source_Ptr
:= Sloc
(N
);
2843 Called_Subprogram
: constant Entity_Id
:= Entity
(Name
(N
));
2844 RCI_Package
: constant Entity_Id
:= Scope
(Called_Subprogram
);
2845 RCI_Locator_Decl
: Node_Id
;
2846 RCI_Locator
: Entity_Id
;
2847 Calling_Stubs
: Node_Id
;
2848 E_Calling_Stubs
: Entity_Id
;
2851 E_Calling_Stubs
:= RCI_Calling_Stubs_Table
.Get
(Called_Subprogram
);
2853 if E_Calling_Stubs
= Empty
then
2854 RCI_Locator
:= RCI_Locator_Table
.Get
(RCI_Package
);
2856 -- The RCI_Locator package and calling stub are is inserted at the
2857 -- top level in the current unit, and must appear in the proper scope
2858 -- so that it is not prematurely removed by the GCC back end.
2861 Scop
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
2863 if Ekind
(Scop
) = E_Package_Body
then
2864 Push_Scope
(Spec_Entity
(Scop
));
2865 elsif Ekind
(Scop
) = E_Subprogram_Body
then
2867 (Corresponding_Spec
(Unit_Declaration_Node
(Scop
)));
2873 if RCI_Locator
= Empty
then
2876 (Loc
, Specification
(Unit_Declaration_Node
(RCI_Package
)));
2877 Prepend_To
(Current_Sem_Unit_Declarations
, RCI_Locator_Decl
);
2878 Analyze
(RCI_Locator_Decl
);
2879 RCI_Locator
:= Defining_Unit_Name
(RCI_Locator_Decl
);
2882 RCI_Locator_Decl
:= Parent
(RCI_Locator
);
2885 Calling_Stubs
:= Build_Subprogram_Calling_Stubs
2886 (Vis_Decl
=> Parent
(Parent
(Called_Subprogram
)),
2888 Build_Subprogram_Id
(Loc
, Called_Subprogram
),
2889 Asynchronous
=> Nkind
(N
) = N_Procedure_Call_Statement
2891 Is_Asynchronous
(Called_Subprogram
),
2892 Locator
=> RCI_Locator
,
2893 New_Name
=> New_Internal_Name
('S'));
2894 Insert_After
(RCI_Locator_Decl
, Calling_Stubs
);
2895 Analyze
(Calling_Stubs
);
2898 E_Calling_Stubs
:= Defining_Unit_Name
(Specification
(Calling_Stubs
));
2901 Rewrite
(Name
(N
), New_Occurrence_Of
(E_Calling_Stubs
, Loc
));
2902 end Expand_All_Calls_Remote_Subprogram_Call
;
2904 ---------------------------------
2905 -- Expand_Calling_Stubs_Bodies --
2906 ---------------------------------
2908 procedure Expand_Calling_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2909 Spec
: constant Node_Id
:= Specification
(Unit_Node
);
2911 Add_Calling_Stubs_To_Declarations
(Spec
);
2912 end Expand_Calling_Stubs_Bodies
;
2914 -----------------------------------
2915 -- Expand_Receiving_Stubs_Bodies --
2916 -----------------------------------
2918 procedure Expand_Receiving_Stubs_Bodies
(Unit_Node
: Node_Id
) is
2921 Stubs_Decls
: List_Id
;
2922 Stubs_Stmts
: List_Id
;
2925 if Nkind
(Unit_Node
) = N_Package_Declaration
then
2926 Spec
:= Specification
(Unit_Node
);
2927 Decls
:= Private_Declarations
(Spec
);
2930 Decls
:= Visible_Declarations
(Spec
);
2933 Push_Scope
(Scope_Of_Spec
(Spec
));
2934 Specific_Add_Receiving_Stubs_To_Declarations
(Spec
, Decls
, Decls
);
2938 Package_Specification_Of_Scope
(Corresponding_Spec
(Unit_Node
));
2939 Decls
:= Declarations
(Unit_Node
);
2941 Push_Scope
(Scope_Of_Spec
(Unit_Node
));
2942 Stubs_Decls
:= New_List
;
2943 Stubs_Stmts
:= New_List
;
2944 Specific_Add_Receiving_Stubs_To_Declarations
2945 (Spec
, Stubs_Decls
, Stubs_Stmts
);
2947 Insert_List_Before
(First
(Decls
), Stubs_Decls
);
2950 HSS_Stmts
: constant List_Id
:=
2951 Statements
(Handled_Statement_Sequence
(Unit_Node
));
2953 First_HSS_Stmt
: constant Node_Id
:= First
(HSS_Stmts
);
2956 if No
(First_HSS_Stmt
) then
2957 Append_List_To
(HSS_Stmts
, Stubs_Stmts
);
2959 Insert_List_Before
(First_HSS_Stmt
, Stubs_Stmts
);
2965 end Expand_Receiving_Stubs_Bodies
;
2967 --------------------
2968 -- GARLIC_Support --
2969 --------------------
2971 package body GARLIC_Support
is
2973 -- Local subprograms
2975 procedure Add_RACW_Read_Attribute
2976 (RACW_Type
: Entity_Id
;
2977 Stub_Type
: Entity_Id
;
2978 Stub_Type_Access
: Entity_Id
;
2979 Body_Decls
: List_Id
);
2980 -- Add Read attribute for the RACW type. The declaration and attribute
2981 -- definition clauses are inserted right after the declaration of
2982 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
2983 -- appended to it (case where the RACW declaration is in the main unit).
2985 procedure Add_RACW_Write_Attribute
2986 (RACW_Type
: Entity_Id
;
2987 Stub_Type
: Entity_Id
;
2988 Stub_Type_Access
: Entity_Id
;
2989 RPC_Receiver
: Node_Id
;
2990 Body_Decls
: List_Id
);
2991 -- Same as above for the Write attribute
2993 function Stream_Parameter
return Node_Id
;
2994 function Result
return Node_Id
;
2995 function Object
return Node_Id
renames Result
;
2996 -- Functions to create occurrences of the formal parameter names of the
2997 -- 'Read and 'Write attributes.
3000 -- Shared source location used by Add_{Read,Write}_Read_Attribute and
3001 -- their ancillary subroutines (set on entry by Add_RACW_Features).
3003 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
3004 -- Add a subprogram body for RAS Access TSS
3006 -------------------------------------
3007 -- Add_Obj_RPC_Receiver_Completion --
3008 -------------------------------------
3010 procedure Add_Obj_RPC_Receiver_Completion
3013 RPC_Receiver
: Entity_Id
;
3014 Stub_Elements
: Stub_Structure
)
3017 -- The RPC receiver body should not be the completion of the
3018 -- declaration recorded in the stub structure, because then the
3019 -- occurrences of the formal parameters within the body should refer
3020 -- to the entities from the declaration, not from the completion, to
3021 -- which we do not have easy access. Instead, the RPC receiver body
3022 -- acts as its own declaration, and the RPC receiver declaration is
3023 -- completed by a renaming-as-body.
3026 Make_Subprogram_Renaming_Declaration
(Loc
,
3028 Copy_Specification
(Loc
,
3029 Specification
(Stub_Elements
.RPC_Receiver_Decl
)),
3030 Name
=> New_Occurrence_Of
(RPC_Receiver
, Loc
)));
3031 end Add_Obj_RPC_Receiver_Completion
;
3033 -----------------------
3034 -- Add_RACW_Features --
3035 -----------------------
3037 procedure Add_RACW_Features
3038 (RACW_Type
: Entity_Id
;
3039 Stub_Type
: Entity_Id
;
3040 Stub_Type_Access
: Entity_Id
;
3041 RPC_Receiver_Decl
: Node_Id
;
3042 Body_Decls
: List_Id
)
3044 RPC_Receiver
: Node_Id
;
3045 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
3048 Loc
:= Sloc
(RACW_Type
);
3052 -- For a RAS, the RPC receiver is that of the RCI unit, not that
3053 -- of the corresponding distributed object type. We retrieve its
3054 -- address from the local proxy object.
3056 RPC_Receiver
:= Make_Selected_Component
(Loc
,
3058 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
), Object
),
3059 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
));
3062 RPC_Receiver
:= Make_Attribute_Reference
(Loc
,
3063 Prefix
=> New_Occurrence_Of
(
3064 Defining_Unit_Name
(Specification
(RPC_Receiver_Decl
)), Loc
),
3065 Attribute_Name
=> Name_Address
);
3068 Add_RACW_Write_Attribute
3075 Add_RACW_Read_Attribute
3080 end Add_RACW_Features
;
3082 -----------------------------
3083 -- Add_RACW_Read_Attribute --
3084 -----------------------------
3086 procedure Add_RACW_Read_Attribute
3087 (RACW_Type
: Entity_Id
;
3088 Stub_Type
: Entity_Id
;
3089 Stub_Type_Access
: Entity_Id
;
3090 Body_Decls
: List_Id
)
3092 Proc_Decl
: Node_Id
;
3093 Attr_Decl
: Node_Id
;
3095 Body_Node
: Node_Id
;
3097 Statements
: constant List_Id
:= New_List
;
3099 Local_Statements
: List_Id
;
3100 Remote_Statements
: List_Id
;
3101 -- Various parts of the procedure
3103 Pnam
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3104 Asynchronous_Flag
: constant Entity_Id
:=
3105 Asynchronous_Flags_Table
.Get
(RACW_Type
);
3106 pragma Assert
(Present
(Asynchronous_Flag
));
3108 -- Prepare local identifiers
3110 Source_Partition
: Entity_Id
;
3111 Source_Receiver
: Entity_Id
;
3112 Source_Address
: Entity_Id
;
3113 Local_Stub
: Entity_Id
;
3114 Stubbed_Result
: Entity_Id
;
3116 -- Start of processing for Add_RACW_Read_Attribute
3119 Build_Stream_Procedure
(Loc
,
3120 RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> True);
3121 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3122 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3125 Make_Attribute_Definition_Clause
(Loc
,
3126 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3130 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3132 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3133 Insert_After
(Proc_Decl
, Attr_Decl
);
3135 if No
(Body_Decls
) then
3137 -- Case of processing an RACW type from another unit than the
3138 -- main one: do not generate a body.
3143 -- Prepare local identifiers
3145 Source_Partition
:= Make_Temporary
(Loc
, 'P');
3146 Source_Receiver
:= Make_Temporary
(Loc
, 'S');
3147 Source_Address
:= Make_Temporary
(Loc
, 'P');
3148 Local_Stub
:= Make_Temporary
(Loc
, 'L');
3149 Stubbed_Result
:= Make_Temporary
(Loc
, 'S');
3151 -- Generate object declarations
3154 Make_Object_Declaration
(Loc
,
3155 Defining_Identifier
=> Source_Partition
,
3156 Object_Definition
=>
3157 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
)),
3159 Make_Object_Declaration
(Loc
,
3160 Defining_Identifier
=> Source_Receiver
,
3161 Object_Definition
=>
3162 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3164 Make_Object_Declaration
(Loc
,
3165 Defining_Identifier
=> Source_Address
,
3166 Object_Definition
=>
3167 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3169 Make_Object_Declaration
(Loc
,
3170 Defining_Identifier
=> Local_Stub
,
3171 Aliased_Present
=> True,
3172 Object_Definition
=> New_Occurrence_Of
(Stub_Type
, Loc
)),
3174 Make_Object_Declaration
(Loc
,
3175 Defining_Identifier
=> Stubbed_Result
,
3176 Object_Definition
=>
3177 New_Occurrence_Of
(Stub_Type_Access
, Loc
),
3179 Make_Attribute_Reference
(Loc
,
3181 New_Occurrence_Of
(Local_Stub
, Loc
),
3183 Name_Unchecked_Access
)));
3185 -- Read the source Partition_ID and RPC_Receiver from incoming stream
3187 Append_List_To
(Statements
, New_List
(
3188 Make_Attribute_Reference
(Loc
,
3190 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3191 Attribute_Name
=> Name_Read
,
3192 Expressions
=> New_List
(
3194 New_Occurrence_Of
(Source_Partition
, Loc
))),
3196 Make_Attribute_Reference
(Loc
,
3198 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3201 Expressions
=> New_List
(
3203 New_Occurrence_Of
(Source_Receiver
, Loc
))),
3205 Make_Attribute_Reference
(Loc
,
3207 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3210 Expressions
=> New_List
(
3212 New_Occurrence_Of
(Source_Address
, Loc
)))));
3214 -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
3216 Set_Etype
(Stubbed_Result
, Stub_Type_Access
);
3218 -- If the Address is Null_Address, then return a null object, unless
3219 -- RACW_Type is null-excluding, in which case unconditionally raise
3220 -- CONSTRAINT_ERROR instead.
3223 Zero_Statements
: List_Id
;
3224 -- Statements executed when a zero value is received
3227 if Can_Never_Be_Null
(RACW_Type
) then
3228 Zero_Statements
:= New_List
(
3229 Make_Raise_Constraint_Error
(Loc
,
3230 Reason
=> CE_Null_Not_Allowed
));
3232 Zero_Statements
:= New_List
(
3233 Make_Assignment_Statement
(Loc
,
3235 Expression
=> Make_Null
(Loc
)),
3236 Make_Simple_Return_Statement
(Loc
));
3239 Append_To
(Statements
,
3240 Make_Implicit_If_Statement
(RACW_Type
,
3243 Left_Opnd
=> New_Occurrence_Of
(Source_Address
, Loc
),
3244 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
3245 Then_Statements
=> Zero_Statements
));
3248 -- If the RACW denotes an object created on the current partition,
3249 -- Local_Statements will be executed. The real object will be used.
3251 Local_Statements
:= New_List
(
3252 Make_Assignment_Statement
(Loc
,
3255 Unchecked_Convert_To
(RACW_Type
,
3256 OK_Convert_To
(RTE
(RE_Address
),
3257 New_Occurrence_Of
(Source_Address
, Loc
)))));
3259 -- If the object is located on another partition, then a stub object
3260 -- will be created with all the information needed to rebuild the
3261 -- real object at the other end.
3263 Remote_Statements
:= New_List
(
3265 Make_Assignment_Statement
(Loc
,
3266 Name
=> Make_Selected_Component
(Loc
,
3267 Prefix
=> Stubbed_Result
,
3268 Selector_Name
=> Name_Origin
),
3270 New_Occurrence_Of
(Source_Partition
, Loc
)),
3272 Make_Assignment_Statement
(Loc
,
3273 Name
=> Make_Selected_Component
(Loc
,
3274 Prefix
=> Stubbed_Result
,
3275 Selector_Name
=> Name_Receiver
),
3277 New_Occurrence_Of
(Source_Receiver
, Loc
)),
3279 Make_Assignment_Statement
(Loc
,
3280 Name
=> Make_Selected_Component
(Loc
,
3281 Prefix
=> Stubbed_Result
,
3282 Selector_Name
=> Name_Addr
),
3284 New_Occurrence_Of
(Source_Address
, Loc
)));
3286 Append_To
(Remote_Statements
,
3287 Make_Assignment_Statement
(Loc
,
3288 Name
=> Make_Selected_Component
(Loc
,
3289 Prefix
=> Stubbed_Result
,
3290 Selector_Name
=> Name_Asynchronous
),
3292 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)));
3294 Append_List_To
(Remote_Statements
,
3295 Build_Get_Unique_RP_Call
(Loc
, Stubbed_Result
, Stub_Type
));
3296 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
3297 -- set on the stub type if, and only if, the RACW type has a pragma
3298 -- Asynchronous. This is incorrect for RACWs that implement RAS
3299 -- types, because in that case the /designated subprogram/ (not the
3300 -- type) might be asynchronous, and that causes the stub to need to
3301 -- be asynchronous too. A solution is to transport a RAS as a struct
3302 -- containing a RACW and an asynchronous flag, and to properly alter
3303 -- the Asynchronous component in the stub type in the RAS's Input
3306 Append_To
(Remote_Statements
,
3307 Make_Assignment_Statement
(Loc
,
3309 Expression
=> Unchecked_Convert_To
(RACW_Type
,
3310 New_Occurrence_Of
(Stubbed_Result
, Loc
))));
3312 -- Distinguish between the local and remote cases, and execute the
3313 -- appropriate piece of code.
3315 Append_To
(Statements
,
3316 Make_Implicit_If_Statement
(RACW_Type
,
3320 Make_Function_Call
(Loc
,
3321 Name
=> New_Occurrence_Of
(
3322 RTE
(RE_Get_Local_Partition_Id
), Loc
)),
3323 Right_Opnd
=> New_Occurrence_Of
(Source_Partition
, Loc
)),
3324 Then_Statements
=> Local_Statements
,
3325 Else_Statements
=> Remote_Statements
));
3327 Set_Declarations
(Body_Node
, Decls
);
3328 Append_To
(Body_Decls
, Body_Node
);
3329 end Add_RACW_Read_Attribute
;
3331 ------------------------------
3332 -- Add_RACW_Write_Attribute --
3333 ------------------------------
3335 procedure Add_RACW_Write_Attribute
3336 (RACW_Type
: Entity_Id
;
3337 Stub_Type
: Entity_Id
;
3338 Stub_Type_Access
: Entity_Id
;
3339 RPC_Receiver
: Node_Id
;
3340 Body_Decls
: List_Id
)
3342 Body_Node
: Node_Id
;
3343 Proc_Decl
: Node_Id
;
3344 Attr_Decl
: Node_Id
;
3346 Statements
: constant List_Id
:= New_List
;
3347 Local_Statements
: List_Id
;
3348 Remote_Statements
: List_Id
;
3349 Null_Statements
: List_Id
;
3351 Pnam
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3354 Build_Stream_Procedure
3355 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> False);
3357 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
3358 Copy_Specification
(Loc
, Specification
(Body_Node
)));
3361 Make_Attribute_Definition_Clause
(Loc
,
3362 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
3363 Chars
=> Name_Write
,
3366 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
3368 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
3369 Insert_After
(Proc_Decl
, Attr_Decl
);
3371 if No
(Body_Decls
) then
3375 -- Build the code fragment corresponding to the marshalling of a
3378 Local_Statements
:= New_List
(
3380 Pack_Entity_Into_Stream_Access
(Loc
,
3381 Stream
=> Stream_Parameter
,
3382 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3384 Pack_Node_Into_Stream_Access
(Loc
,
3385 Stream
=> Stream_Parameter
,
3386 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3387 Etyp
=> RTE
(RE_Unsigned_64
)),
3389 Pack_Node_Into_Stream_Access
(Loc
,
3390 Stream
=> Stream_Parameter
,
3391 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
),
3392 Make_Attribute_Reference
(Loc
,
3394 Make_Explicit_Dereference
(Loc
,
3396 Attribute_Name
=> Name_Address
)),
3397 Etyp
=> RTE
(RE_Unsigned_64
)));
3399 -- Build the code fragment corresponding to the marshalling of
3402 Remote_Statements
:= New_List
(
3403 Pack_Node_Into_Stream_Access
(Loc
,
3404 Stream
=> Stream_Parameter
,
3406 Make_Selected_Component
(Loc
,
3408 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3409 Selector_Name
=> Make_Identifier
(Loc
, Name_Origin
)),
3410 Etyp
=> RTE
(RE_Partition_ID
)),
3412 Pack_Node_Into_Stream_Access
(Loc
,
3413 Stream
=> Stream_Parameter
,
3415 Make_Selected_Component
(Loc
,
3417 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3418 Selector_Name
=> Make_Identifier
(Loc
, Name_Receiver
)),
3419 Etyp
=> RTE
(RE_Unsigned_64
)),
3421 Pack_Node_Into_Stream_Access
(Loc
,
3422 Stream
=> Stream_Parameter
,
3424 Make_Selected_Component
(Loc
,
3426 Unchecked_Convert_To
(Stub_Type_Access
, Object
),
3427 Selector_Name
=> Make_Identifier
(Loc
, Name_Addr
)),
3428 Etyp
=> RTE
(RE_Unsigned_64
)));
3430 -- Build code fragment corresponding to marshalling of a null object
3432 Null_Statements
:= New_List
(
3434 Pack_Entity_Into_Stream_Access
(Loc
,
3435 Stream
=> Stream_Parameter
,
3436 Object
=> RTE
(RE_Get_Local_Partition_Id
)),
3438 Pack_Node_Into_Stream_Access
(Loc
,
3439 Stream
=> Stream_Parameter
,
3440 Object
=> OK_Convert_To
(RTE
(RE_Unsigned_64
), RPC_Receiver
),
3441 Etyp
=> RTE
(RE_Unsigned_64
)),
3443 Pack_Node_Into_Stream_Access
(Loc
,
3444 Stream
=> Stream_Parameter
,
3445 Object
=> Make_Integer_Literal
(Loc
, Uint_0
),
3446 Etyp
=> RTE
(RE_Unsigned_64
)));
3448 Append_To
(Statements
,
3449 Make_Implicit_If_Statement
(RACW_Type
,
3452 Left_Opnd
=> Object
,
3453 Right_Opnd
=> Make_Null
(Loc
)),
3455 Then_Statements
=> Null_Statements
,
3457 Elsif_Parts
=> New_List
(
3458 Make_Elsif_Part
(Loc
,
3462 Make_Attribute_Reference
(Loc
,
3464 Attribute_Name
=> Name_Tag
),
3467 Make_Attribute_Reference
(Loc
,
3468 Prefix
=> New_Occurrence_Of
(Stub_Type
, Loc
),
3469 Attribute_Name
=> Name_Tag
)),
3470 Then_Statements
=> Remote_Statements
)),
3471 Else_Statements
=> Local_Statements
));
3473 Append_To
(Body_Decls
, Body_Node
);
3474 end Add_RACW_Write_Attribute
;
3476 ------------------------
3477 -- Add_RAS_Access_TSS --
3478 ------------------------
3480 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
3481 Loc
: constant Source_Ptr
:= Sloc
(N
);
3483 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
3484 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
3485 -- Ras_Type is the access to subprogram type while Fat_Type is the
3486 -- corresponding record type.
3488 RACW_Type
: constant Entity_Id
:=
3489 Underlying_RACW_Type
(Ras_Type
);
3490 Desig
: constant Entity_Id
:=
3491 Etype
(Designated_Type
(RACW_Type
));
3493 Stub_Elements
: constant Stub_Structure
:=
3494 Stubs_Table
.Get
(Desig
);
3495 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
3497 Proc
: constant Entity_Id
:=
3498 Make_Defining_Identifier
(Loc
,
3499 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
3501 Proc_Spec
: Node_Id
;
3503 -- Formal parameters
3505 Package_Name
: constant Entity_Id
:=
3506 Make_Defining_Identifier
(Loc
,
3510 Subp_Id
: constant Entity_Id
:=
3511 Make_Defining_Identifier
(Loc
,
3513 -- Target subprogram
3515 Asynch_P
: constant Entity_Id
:=
3516 Make_Defining_Identifier
(Loc
,
3517 Chars
=> Name_Asynchronous
);
3518 -- Is the procedure to which the 'Access applies asynchronous?
3520 All_Calls_Remote
: constant Entity_Id
:=
3521 Make_Defining_Identifier
(Loc
,
3522 Chars
=> Name_All_Calls_Remote
);
3523 -- True if an All_Calls_Remote pragma applies to the RCI unit
3524 -- that contains the subprogram.
3526 -- Common local variables
3528 Proc_Decls
: List_Id
;
3529 Proc_Statements
: List_Id
;
3531 Origin
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
3533 -- Additional local variables for the local case
3535 Proxy_Addr
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
3537 -- Additional local variables for the remote case
3539 Local_Stub
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
3540 Stub_Ptr
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
3543 (Field_Name
: Name_Id
;
3544 Value
: Node_Id
) return Node_Id
;
3545 -- Construct an assignment that sets the named component in the
3553 (Field_Name
: Name_Id
;
3554 Value
: Node_Id
) return Node_Id
3558 Make_Assignment_Statement
(Loc
,
3560 Make_Selected_Component
(Loc
,
3562 Selector_Name
=> Field_Name
),
3563 Expression
=> Value
);
3566 -- Start of processing for Add_RAS_Access_TSS
3569 Proc_Decls
:= New_List
(
3571 -- Common declarations
3573 Make_Object_Declaration
(Loc
,
3574 Defining_Identifier
=> Origin
,
3575 Constant_Present
=> True,
3576 Object_Definition
=>
3577 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
3579 Make_Function_Call
(Loc
,
3581 New_Occurrence_Of
(RTE
(RE_Get_Active_Partition_Id
), Loc
),
3582 Parameter_Associations
=> New_List
(
3583 New_Occurrence_Of
(Package_Name
, Loc
)))),
3585 -- Declaration use only in the local case: proxy address
3587 Make_Object_Declaration
(Loc
,
3588 Defining_Identifier
=> Proxy_Addr
,
3589 Object_Definition
=>
3590 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)),
3592 -- Declarations used only in the remote case: stub object and
3595 Make_Object_Declaration
(Loc
,
3596 Defining_Identifier
=> Local_Stub
,
3597 Aliased_Present
=> True,
3598 Object_Definition
=>
3599 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
3601 Make_Object_Declaration
(Loc
,
3602 Defining_Identifier
=>
3604 Object_Definition
=>
3605 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
3607 Make_Attribute_Reference
(Loc
,
3608 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
3609 Attribute_Name
=> Name_Unchecked_Access
)));
3611 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
3613 -- Build_Get_Unique_RP_Call needs above information
3615 -- Note: Here we assume that the Fat_Type is a record
3616 -- containing just a pointer to a proxy or stub object.
3618 Proc_Statements
:= New_List
(
3622 -- Get_RAS_Info (Pkg, Subp, PA);
3623 -- if Origin = Local_Partition_Id
3624 -- and then not All_Calls_Remote
3626 -- return Fat_Type!(PA);
3629 Make_Procedure_Call_Statement
(Loc
,
3630 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
3631 Parameter_Associations
=> New_List
(
3632 New_Occurrence_Of
(Package_Name
, Loc
),
3633 New_Occurrence_Of
(Subp_Id
, Loc
),
3634 New_Occurrence_Of
(Proxy_Addr
, Loc
))),
3636 Make_Implicit_If_Statement
(N
,
3642 New_Occurrence_Of
(Origin
, Loc
),
3644 Make_Function_Call
(Loc
,
3646 RTE
(RE_Get_Local_Partition_Id
), Loc
))),
3650 New_Occurrence_Of
(All_Calls_Remote
, Loc
))),
3652 Then_Statements
=> New_List
(
3653 Make_Simple_Return_Statement
(Loc
,
3654 Unchecked_Convert_To
(Fat_Type
,
3655 OK_Convert_To
(RTE
(RE_Address
),
3656 New_Occurrence_Of
(Proxy_Addr
, Loc
)))))),
3658 Set_Field
(Name_Origin
,
3659 New_Occurrence_Of
(Origin
, Loc
)),
3661 Set_Field
(Name_Receiver
,
3662 Make_Function_Call
(Loc
,
3664 New_Occurrence_Of
(RTE
(RE_Get_RCI_Package_Receiver
), Loc
),
3665 Parameter_Associations
=> New_List
(
3666 New_Occurrence_Of
(Package_Name
, Loc
)))),
3668 Set_Field
(Name_Addr
, New_Occurrence_Of
(Proxy_Addr
, Loc
)),
3670 -- E.4.1(9) A remote call is asynchronous if it is a call to
3671 -- a procedure or a call through a value of an access-to-procedure
3672 -- type to which a pragma Asynchronous applies.
3674 -- Asynch_P is true when the procedure is asynchronous;
3675 -- Asynch_T is true when the type is asynchronous.
3677 Set_Field
(Name_Asynchronous
,
3679 New_Occurrence_Of
(Asynch_P
, Loc
),
3680 New_Occurrence_Of
(Boolean_Literals
(
3681 Is_Asynchronous
(Ras_Type
)), Loc
))));
3683 Append_List_To
(Proc_Statements
,
3684 Build_Get_Unique_RP_Call
3685 (Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
3687 -- Return the newly created value
3689 Append_To
(Proc_Statements
,
3690 Make_Simple_Return_Statement
(Loc
,
3692 Unchecked_Convert_To
(Fat_Type
,
3693 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
3696 Make_Function_Specification
(Loc
,
3697 Defining_Unit_Name
=> Proc
,
3698 Parameter_Specifications
=> New_List
(
3699 Make_Parameter_Specification
(Loc
,
3700 Defining_Identifier
=> Package_Name
,
3702 New_Occurrence_Of
(Standard_String
, Loc
)),
3704 Make_Parameter_Specification
(Loc
,
3705 Defining_Identifier
=> Subp_Id
,
3707 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
)),
3709 Make_Parameter_Specification
(Loc
,
3710 Defining_Identifier
=> Asynch_P
,
3712 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
3714 Make_Parameter_Specification
(Loc
,
3715 Defining_Identifier
=> All_Calls_Remote
,
3717 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
3719 Result_Definition
=>
3720 New_Occurrence_Of
(Fat_Type
, Loc
));
3722 -- Set the kind and return type of the function to prevent
3723 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
3725 Set_Ekind
(Proc
, E_Function
);
3726 Set_Etype
(Proc
, Fat_Type
);
3729 Make_Subprogram_Body
(Loc
,
3730 Specification
=> Proc_Spec
,
3731 Declarations
=> Proc_Decls
,
3732 Handled_Statement_Sequence
=>
3733 Make_Handled_Sequence_Of_Statements
(Loc
,
3734 Statements
=> Proc_Statements
)));
3736 Set_TSS
(Fat_Type
, Proc
);
3737 end Add_RAS_Access_TSS
;
3739 -----------------------
3740 -- Add_RAST_Features --
3741 -----------------------
3743 procedure Add_RAST_Features
3744 (Vis_Decl
: Node_Id
;
3745 RAS_Type
: Entity_Id
)
3747 pragma Unreferenced
(RAS_Type
);
3749 Add_RAS_Access_TSS
(Vis_Decl
);
3750 end Add_RAST_Features
;
3752 -----------------------------------------
3753 -- Add_Receiving_Stubs_To_Declarations --
3754 -----------------------------------------
3756 procedure Add_Receiving_Stubs_To_Declarations
3757 (Pkg_Spec
: Node_Id
;
3761 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
3763 Request_Parameter
: Node_Id
;
3765 Pkg_RPC_Receiver
: constant Entity_Id
:=
3766 Make_Temporary
(Loc
, 'H');
3767 Pkg_RPC_Receiver_Statements
: List_Id
;
3768 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
3769 Pkg_RPC_Receiver_Body
: Node_Id
;
3770 -- A Pkg_RPC_Receiver is built to decode the request
3772 Lookup_RAS
: Node_Id
;
3773 Lookup_RAS_Info
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
3774 -- A remote subprogram is created to allow peers to look up RAS
3775 -- information using subprogram ids.
3777 Subp_Id
: Entity_Id
;
3778 Subp_Index
: Entity_Id
;
3779 -- Subprogram_Id as read from the incoming stream
3781 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
3782 Current_Stubs
: Node_Id
;
3784 Subp_Info_Array
: constant Entity_Id
:= Make_Temporary
(Loc
, 'I');
3785 Subp_Info_List
: constant List_Id
:= New_List
;
3787 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
3789 All_Calls_Remote_E
: Entity_Id
;
3790 Proxy_Object_Addr
: Entity_Id
;
3792 procedure Append_Stubs_To
3793 (RPC_Receiver_Cases
: List_Id
;
3795 Subprogram_Number
: Int
);
3796 -- Add one case to the specified RPC receiver case list
3797 -- associating Subprogram_Number with the subprogram declared
3798 -- by Declaration, for which we have receiving stubs in Stubs.
3800 procedure Visit_Subprogram
(Decl
: Node_Id
);
3801 -- Generate receiving stub for one remote subprogram
3803 ---------------------
3804 -- Append_Stubs_To --
3805 ---------------------
3807 procedure Append_Stubs_To
3808 (RPC_Receiver_Cases
: List_Id
;
3810 Subprogram_Number
: Int
)
3813 Append_To
(RPC_Receiver_Cases
,
3814 Make_Case_Statement_Alternative
(Loc
,
3816 New_List
(Make_Integer_Literal
(Loc
, Subprogram_Number
)),
3819 Make_Procedure_Call_Statement
(Loc
,
3821 New_Occurrence_Of
(Defining_Entity
(Stubs
), Loc
),
3822 Parameter_Associations
=> New_List
(
3823 New_Occurrence_Of
(Request_Parameter
, Loc
))))));
3824 end Append_Stubs_To
;
3826 ----------------------
3827 -- Visit_Subprogram --
3828 ----------------------
3830 procedure Visit_Subprogram
(Decl
: Node_Id
) is
3831 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
3832 Spec
: constant Node_Id
:= Specification
(Decl
);
3833 Subp_Def
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
3835 Subp_Val
: String_Id
;
3836 pragma Warnings
(Off
, Subp_Val
);
3839 -- Build receiving stub
3842 Build_Subprogram_Receiving_Stubs
3845 Nkind
(Spec
) = N_Procedure_Specification
3846 and then Is_Asynchronous
(Subp_Def
));
3848 Append_To
(Decls
, Current_Stubs
);
3849 Analyze
(Current_Stubs
);
3853 Add_RAS_Proxy_And_Analyze
(Decls
,
3855 All_Calls_Remote_E
=> All_Calls_Remote_E
,
3856 Proxy_Object_Addr
=> Proxy_Object_Addr
);
3858 -- Compute distribution identifier
3860 Assign_Subprogram_Identifier
3861 (Subp_Def
, Current_Subp_Number
, Subp_Val
);
3863 pragma Assert
(Current_Subp_Number
= Get_Subprogram_Id
(Subp_Def
));
3865 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
3866 -- table for this receiver. This aggregate must be kept consistent
3867 -- with the declaration of RCI_Subp_Info in
3868 -- System.Partition_Interface.
3870 Append_To
(Subp_Info_List
,
3871 Make_Component_Association
(Loc
,
3872 Choices
=> New_List
(
3873 Make_Integer_Literal
(Loc
, Current_Subp_Number
)),
3876 Make_Aggregate
(Loc
,
3877 Component_Associations
=> New_List
(
3881 Make_Component_Association
(Loc
,
3883 New_List
(Make_Identifier
(Loc
, Name_Addr
)),
3885 New_Occurrence_Of
(Proxy_Object_Addr
, Loc
))))));
3887 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3888 Stubs
=> Current_Stubs
,
3889 Subprogram_Number
=> Current_Subp_Number
);
3891 Current_Subp_Number
:= Current_Subp_Number
+ 1;
3892 end Visit_Subprogram
;
3894 procedure Visit_Spec
is new Build_Package_Stubs
(Visit_Subprogram
);
3896 -- Start of processing for Add_Receiving_Stubs_To_Declarations
3899 -- Building receiving stubs consist in several operations:
3901 -- - a package RPC receiver must be built. This subprogram
3902 -- will get a Subprogram_Id from the incoming stream
3903 -- and will dispatch the call to the right subprogram;
3905 -- - a receiving stub for each subprogram visible in the package
3906 -- spec. This stub will read all the parameters from the stream,
3907 -- and put the result as well as the exception occurrence in the
3910 -- - a dummy package with an empty spec and a body made of an
3911 -- elaboration part, whose job is to register the receiving
3912 -- part of this RCI package on the name server. This is done
3913 -- by calling System.Partition_Interface.Register_Receiving_Stub.
3915 Build_RPC_Receiver_Body
(
3916 RPC_Receiver
=> Pkg_RPC_Receiver
,
3917 Request
=> Request_Parameter
,
3919 Subp_Index
=> Subp_Index
,
3920 Stmts
=> Pkg_RPC_Receiver_Statements
,
3921 Decl
=> Pkg_RPC_Receiver_Body
);
3922 pragma Assert
(Subp_Id
= Subp_Index
);
3924 -- A null subp_id denotes a call through a RAS, in which case the
3925 -- next Uint_64 element in the stream is the address of the local
3926 -- proxy object, from which we can retrieve the actual subprogram id.
3928 Append_To
(Pkg_RPC_Receiver_Statements
,
3929 Make_Implicit_If_Statement
(Pkg_Spec
,
3932 New_Occurrence_Of
(Subp_Id
, Loc
),
3933 Make_Integer_Literal
(Loc
, 0)),
3935 Then_Statements
=> New_List
(
3936 Make_Assignment_Statement
(Loc
,
3938 New_Occurrence_Of
(Subp_Id
, Loc
),
3941 Make_Selected_Component
(Loc
,
3943 Unchecked_Convert_To
(RTE
(RE_RAS_Proxy_Type_Access
),
3944 OK_Convert_To
(RTE
(RE_Address
),
3945 Make_Attribute_Reference
(Loc
,
3947 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
3950 Expressions
=> New_List
(
3951 Make_Selected_Component
(Loc
,
3952 Prefix
=> Request_Parameter
,
3953 Selector_Name
=> Name_Params
))))),
3955 Selector_Name
=> Make_Identifier
(Loc
, Name_Subp_Id
))))));
3957 -- Build a subprogram for RAS information lookups
3960 Make_Subprogram_Declaration
(Loc
,
3962 Make_Function_Specification
(Loc
,
3963 Defining_Unit_Name
=>
3965 Parameter_Specifications
=> New_List
(
3966 Make_Parameter_Specification
(Loc
,
3967 Defining_Identifier
=>
3968 Make_Defining_Identifier
(Loc
, Name_Subp_Id
),
3972 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
))),
3973 Result_Definition
=>
3974 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
)));
3975 Append_To
(Decls
, Lookup_RAS
);
3976 Analyze
(Lookup_RAS
);
3978 Current_Stubs
:= Build_Subprogram_Receiving_Stubs
3979 (Vis_Decl
=> Lookup_RAS
,
3980 Asynchronous
=> False);
3981 Append_To
(Decls
, Current_Stubs
);
3982 Analyze
(Current_Stubs
);
3984 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
3985 Stubs
=> Current_Stubs
,
3986 Subprogram_Number
=> 1);
3988 -- For each subprogram, the receiving stub will be built and a
3989 -- case statement will be made on the Subprogram_Id to dispatch
3990 -- to the right subprogram.
3992 All_Calls_Remote_E
:=
3994 (Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
3996 Overload_Counter_Table
.Reset
;
3998 Visit_Spec
(Pkg_Spec
);
4000 -- If we receive an invalid Subprogram_Id, it is best to do nothing
4001 -- rather than raising an exception since we do not want someone
4002 -- to crash a remote partition by sending invalid subprogram ids.
4003 -- This is consistent with the other parts of the case statement
4004 -- since even in presence of incorrect parameters in the stream,
4005 -- every exception will be caught and (if the subprogram is not an
4006 -- APC) put into the result stream and sent away.
4008 Append_To
(Pkg_RPC_Receiver_Cases
,
4009 Make_Case_Statement_Alternative
(Loc
,
4010 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
4011 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
4013 Append_To
(Pkg_RPC_Receiver_Statements
,
4014 Make_Case_Statement
(Loc
,
4015 Expression
=> New_Occurrence_Of
(Subp_Id
, Loc
),
4016 Alternatives
=> Pkg_RPC_Receiver_Cases
));
4019 Make_Object_Declaration
(Loc
,
4020 Defining_Identifier
=> Subp_Info_Array
,
4021 Constant_Present
=> True,
4022 Aliased_Present
=> True,
4023 Object_Definition
=>
4024 Make_Subtype_Indication
(Loc
,
4026 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
4028 Make_Index_Or_Discriminant_Constraint
(Loc
,
4031 Low_Bound
=> Make_Integer_Literal
(Loc
,
4032 First_RCI_Subprogram_Id
),
4034 Make_Integer_Literal
(Loc
,
4036 First_RCI_Subprogram_Id
4037 + List_Length
(Subp_Info_List
) - 1)))))));
4039 -- For a degenerate RCI with no visible subprograms, Subp_Info_List
4040 -- has zero length, and the declaration is for an empty array, in
4041 -- which case no initialization aggregate must be generated.
4043 if Present
(First
(Subp_Info_List
)) then
4044 Set_Expression
(Last
(Decls
),
4045 Make_Aggregate
(Loc
,
4046 Component_Associations
=> Subp_Info_List
));
4048 -- No initialization provided: remove CONSTANT so that the
4049 -- declaration is not an incomplete deferred constant.
4052 Set_Constant_Present
(Last
(Decls
), False);
4055 Analyze
(Last
(Decls
));
4058 Subp_Info_Addr
: Node_Id
;
4059 -- Return statement for Lookup_RAS_Info: address of the subprogram
4060 -- information record for the requested subprogram id.
4063 if Present
(First
(Subp_Info_List
)) then
4065 Make_Selected_Component
(Loc
,
4067 Make_Indexed_Component
(Loc
,
4068 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4069 Expressions
=> New_List
(
4070 Convert_To
(Standard_Integer
,
4071 Make_Identifier
(Loc
, Name_Subp_Id
)))),
4072 Selector_Name
=> Make_Identifier
(Loc
, Name_Addr
));
4074 -- Case of no visible subprogram: just raise Constraint_Error, we
4075 -- know for sure we got junk from a remote partition.
4079 Make_Raise_Constraint_Error
(Loc
,
4080 Reason
=> CE_Range_Check_Failed
);
4081 Set_Etype
(Subp_Info_Addr
, RTE
(RE_Unsigned_64
));
4085 Make_Subprogram_Body
(Loc
,
4087 Copy_Specification
(Loc
, Parent
(Lookup_RAS_Info
)),
4088 Declarations
=> No_List
,
4089 Handled_Statement_Sequence
=>
4090 Make_Handled_Sequence_Of_Statements
(Loc
,
4091 Statements
=> New_List
(
4092 Make_Simple_Return_Statement
(Loc
,
4095 (RTE
(RE_Unsigned_64
), Subp_Info_Addr
))))));
4098 Analyze
(Last
(Decls
));
4100 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
4101 Analyze
(Last
(Decls
));
4103 Get_Library_Unit_Name_String
(Pkg_Spec
);
4107 Append_To
(Register_Pkg_Actuals
,
4108 Make_String_Literal
(Loc
,
4109 Strval
=> String_From_Name_Buffer
));
4113 Append_To
(Register_Pkg_Actuals
,
4114 Make_Attribute_Reference
(Loc
,
4115 Prefix
=> New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
4116 Attribute_Name
=> Name_Unrestricted_Access
));
4120 Append_To
(Register_Pkg_Actuals
,
4121 Make_Attribute_Reference
(Loc
,
4123 New_Occurrence_Of
(Defining_Entity
(Pkg_Spec
), Loc
),
4124 Attribute_Name
=> Name_Version
));
4128 Append_To
(Register_Pkg_Actuals
,
4129 Make_Attribute_Reference
(Loc
,
4130 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4131 Attribute_Name
=> Name_Address
));
4135 Append_To
(Register_Pkg_Actuals
,
4136 Make_Attribute_Reference
(Loc
,
4137 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
4138 Attribute_Name
=> Name_Length
));
4140 -- Generate the call
4143 Make_Procedure_Call_Statement
(Loc
,
4145 New_Occurrence_Of
(RTE
(RE_Register_Receiving_Stub
), Loc
),
4146 Parameter_Associations
=> Register_Pkg_Actuals
));
4147 Analyze
(Last
(Stmts
));
4148 end Add_Receiving_Stubs_To_Declarations
;
4150 ---------------------------------
4151 -- Build_General_Calling_Stubs --
4152 ---------------------------------
4154 procedure Build_General_Calling_Stubs
4156 Statements
: List_Id
;
4157 Target_Partition
: Entity_Id
;
4158 Target_RPC_Receiver
: Node_Id
;
4159 Subprogram_Id
: Node_Id
;
4160 Asynchronous
: Node_Id
:= Empty
;
4161 Is_Known_Asynchronous
: Boolean := False;
4162 Is_Known_Non_Asynchronous
: Boolean := False;
4163 Is_Function
: Boolean;
4165 Stub_Type
: Entity_Id
:= Empty
;
4166 RACW_Type
: Entity_Id
:= Empty
;
4169 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
4171 Stream_Parameter
: Node_Id
;
4172 -- Name of the stream used to transmit parameters to the remote
4175 Result_Parameter
: Node_Id
;
4176 -- Name of the result parameter (in non-APC cases) which get the
4177 -- result of the remote subprogram.
4179 Exception_Return_Parameter
: Node_Id
;
4180 -- Name of the parameter which will hold the exception sent by the
4181 -- remote subprogram.
4183 Current_Parameter
: Node_Id
;
4184 -- Current parameter being handled
4186 Ordered_Parameters_List
: constant List_Id
:=
4187 Build_Ordered_Parameters_List
(Spec
);
4189 Asynchronous_Statements
: List_Id
:= No_List
;
4190 Non_Asynchronous_Statements
: List_Id
:= No_List
;
4191 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
4193 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4194 -- List of statements for extra formal parameters. It will appear
4195 -- after the regular statements for writing out parameters.
4197 pragma Unreferenced
(RACW_Type
);
4198 -- Used only for the PolyORB case
4201 -- The general form of a calling stub for a given subprogram is:
4203 -- procedure X (...) is P : constant Partition_ID :=
4204 -- RCI_Cache.Get_Active_Partition_ID; Stream, Result : aliased
4205 -- System.RPC.Params_Stream_Type (0); begin
4206 -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
4207 -- comes from RCI_Cache.Get_RCI_Package_Receiver)
4208 -- Put_Subprogram_Id_In_Stream; Put_Parameters_In_Stream; Do_RPC
4209 -- (Stream, Result); Read_Exception_Occurrence_From_Result;
4211 -- Read_Out_Parameters_And_Function_Return_From_Stream; end X;
4213 -- There are some variations: Do_APC is called for an asynchronous
4214 -- procedure and the part after the call is completely ommitted as
4215 -- well as the declaration of Result. For a function call, 'Input is
4216 -- always used to read the result even if it is constrained.
4218 Stream_Parameter
:= Make_Temporary
(Loc
, 'S');
4221 Make_Object_Declaration
(Loc
,
4222 Defining_Identifier
=> Stream_Parameter
,
4223 Aliased_Present
=> True,
4224 Object_Definition
=>
4225 Make_Subtype_Indication
(Loc
,
4227 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4229 Make_Index_Or_Discriminant_Constraint
(Loc
,
4231 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4233 if not Is_Known_Asynchronous
then
4234 Result_Parameter
:= Make_Temporary
(Loc
, 'R');
4237 Make_Object_Declaration
(Loc
,
4238 Defining_Identifier
=> Result_Parameter
,
4239 Aliased_Present
=> True,
4240 Object_Definition
=>
4241 Make_Subtype_Indication
(Loc
,
4243 New_Occurrence_Of
(RTE
(RE_Params_Stream_Type
), Loc
),
4245 Make_Index_Or_Discriminant_Constraint
(Loc
,
4247 New_List
(Make_Integer_Literal
(Loc
, 0))))));
4249 Exception_Return_Parameter
:= Make_Temporary
(Loc
, 'E');
4252 Make_Object_Declaration
(Loc
,
4253 Defining_Identifier
=> Exception_Return_Parameter
,
4254 Object_Definition
=>
4255 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
4258 Result_Parameter
:= Empty
;
4259 Exception_Return_Parameter
:= Empty
;
4262 -- Put first the RPC receiver corresponding to the remote package
4264 Append_To
(Statements
,
4265 Make_Attribute_Reference
(Loc
,
4267 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
),
4268 Attribute_Name
=> Name_Write
,
4269 Expressions
=> New_List
(
4270 Make_Attribute_Reference
(Loc
,
4271 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
4272 Attribute_Name
=> Name_Access
),
4273 Target_RPC_Receiver
)));
4275 -- Then put the Subprogram_Id of the subprogram we want to call in
4278 Append_To
(Statements
,
4279 Make_Attribute_Reference
(Loc
,
4280 Prefix
=> New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4281 Attribute_Name
=> Name_Write
,
4282 Expressions
=> New_List
(
4283 Make_Attribute_Reference
(Loc
,
4284 Prefix
=> New_Occurrence_Of
(Stream_Parameter
, Loc
),
4285 Attribute_Name
=> Name_Access
),
4288 Current_Parameter
:= First
(Ordered_Parameters_List
);
4289 while Present
(Current_Parameter
) loop
4291 Typ
: constant Node_Id
:=
4292 Parameter_Type
(Current_Parameter
);
4294 Constrained
: Boolean;
4296 Extra_Parameter
: Entity_Id
;
4299 if Is_RACW_Controlling_Formal
4300 (Current_Parameter
, Stub_Type
)
4302 -- In the case of a controlling formal argument, we marshall
4303 -- its addr field rather than the local stub.
4305 Append_To
(Statements
,
4306 Pack_Node_Into_Stream
(Loc
,
4307 Stream
=> Stream_Parameter
,
4309 Make_Selected_Component
(Loc
,
4311 Defining_Identifier
(Current_Parameter
),
4312 Selector_Name
=> Name_Addr
),
4313 Etyp
=> RTE
(RE_Unsigned_64
)));
4318 (Defining_Identifier
(Current_Parameter
), Loc
);
4320 -- Access type parameters are transmitted as in out
4321 -- parameters. However, a dereference is needed so that
4322 -- we marshall the designated object.
4324 if Nkind
(Typ
) = N_Access_Definition
then
4325 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4326 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4328 Etyp
:= Etype
(Typ
);
4331 Constrained
:= not Transmit_As_Unconstrained
(Etyp
);
4333 -- Any parameter but unconstrained out parameters are
4334 -- transmitted to the peer.
4336 if In_Present
(Current_Parameter
)
4337 or else not Out_Present
(Current_Parameter
)
4338 or else not Constrained
4340 Append_To
(Statements
,
4341 Make_Attribute_Reference
(Loc
,
4342 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4344 Output_From_Constrained
(Constrained
),
4345 Expressions
=> New_List
(
4346 Make_Attribute_Reference
(Loc
,
4348 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4349 Attribute_Name
=> Name_Access
),
4354 -- If the current parameter has a dynamic constrained status,
4355 -- then this status is transmitted as well.
4356 -- This should be done for accessibility as well ???
4358 if Nkind
(Typ
) /= N_Access_Definition
4359 and then Need_Extra_Constrained
(Current_Parameter
)
4361 -- In this block, we do not use the extra formal that has
4362 -- been created because it does not exist at the time of
4363 -- expansion when building calling stubs for remote access
4364 -- to subprogram types. We create an extra variable of this
4365 -- type and push it in the stream after the regular
4368 Extra_Parameter
:= Make_Temporary
(Loc
, 'P');
4371 Make_Object_Declaration
(Loc
,
4372 Defining_Identifier
=> Extra_Parameter
,
4373 Constant_Present
=> True,
4374 Object_Definition
=>
4375 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4377 Make_Attribute_Reference
(Loc
,
4380 Defining_Identifier
(Current_Parameter
), Loc
),
4381 Attribute_Name
=> Name_Constrained
)));
4383 Append_To
(Extra_Formal_Statements
,
4384 Make_Attribute_Reference
(Loc
,
4386 New_Occurrence_Of
(Standard_Boolean
, Loc
),
4387 Attribute_Name
=> Name_Write
,
4388 Expressions
=> New_List
(
4389 Make_Attribute_Reference
(Loc
,
4392 (Stream_Parameter
, Loc
), Attribute_Name
=>
4394 New_Occurrence_Of
(Extra_Parameter
, Loc
))));
4397 Next
(Current_Parameter
);
4401 -- Append the formal statements list to the statements
4403 Append_List_To
(Statements
, Extra_Formal_Statements
);
4405 if not Is_Known_Non_Asynchronous
then
4407 -- Build the call to System.RPC.Do_APC
4409 Asynchronous_Statements
:= New_List
(
4410 Make_Procedure_Call_Statement
(Loc
,
4412 New_Occurrence_Of
(RTE
(RE_Do_Apc
), Loc
),
4413 Parameter_Associations
=> New_List
(
4414 New_Occurrence_Of
(Target_Partition
, Loc
),
4415 Make_Attribute_Reference
(Loc
,
4417 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4418 Attribute_Name
=> Name_Access
))));
4420 Asynchronous_Statements
:= No_List
;
4423 if not Is_Known_Asynchronous
then
4425 -- Build the call to System.RPC.Do_RPC
4427 Non_Asynchronous_Statements
:= New_List
(
4428 Make_Procedure_Call_Statement
(Loc
,
4430 New_Occurrence_Of
(RTE
(RE_Do_Rpc
), Loc
),
4431 Parameter_Associations
=> New_List
(
4432 New_Occurrence_Of
(Target_Partition
, Loc
),
4434 Make_Attribute_Reference
(Loc
,
4436 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4437 Attribute_Name
=> Name_Access
),
4439 Make_Attribute_Reference
(Loc
,
4441 New_Occurrence_Of
(Result_Parameter
, Loc
),
4442 Attribute_Name
=> Name_Access
))));
4444 -- Read the exception occurrence from the result stream and
4445 -- reraise it. It does no harm if this is a Null_Occurrence since
4446 -- this does nothing.
4448 Append_To
(Non_Asynchronous_Statements
,
4449 Make_Attribute_Reference
(Loc
,
4451 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4453 Attribute_Name
=> Name_Read
,
4455 Expressions
=> New_List
(
4456 Make_Attribute_Reference
(Loc
,
4458 New_Occurrence_Of
(Result_Parameter
, Loc
),
4459 Attribute_Name
=> Name_Access
),
4460 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4462 Append_To
(Non_Asynchronous_Statements
,
4463 Make_Procedure_Call_Statement
(Loc
,
4465 New_Occurrence_Of
(RTE
(RE_Reraise_Occurrence
), Loc
),
4466 Parameter_Associations
=> New_List
(
4467 New_Occurrence_Of
(Exception_Return_Parameter
, Loc
))));
4471 -- If this is a function call, then read the value and return
4472 -- it. The return value is written/read using 'Output/'Input.
4474 Append_To
(Non_Asynchronous_Statements
,
4475 Make_Tag_Check
(Loc
,
4476 Make_Simple_Return_Statement
(Loc
,
4478 Make_Attribute_Reference
(Loc
,
4481 Etype
(Result_Definition
(Spec
)), Loc
),
4483 Attribute_Name
=> Name_Input
,
4485 Expressions
=> New_List
(
4486 Make_Attribute_Reference
(Loc
,
4488 New_Occurrence_Of
(Result_Parameter
, Loc
),
4489 Attribute_Name
=> Name_Access
))))));
4492 -- Loop around parameters and assign out (or in out)
4493 -- parameters. In the case of RACW, controlling arguments
4494 -- cannot possibly have changed since they are remote, so
4495 -- we do not read them from the stream.
4497 Current_Parameter
:= First
(Ordered_Parameters_List
);
4498 while Present
(Current_Parameter
) loop
4500 Typ
: constant Node_Id
:=
4501 Parameter_Type
(Current_Parameter
);
4508 (Defining_Identifier
(Current_Parameter
), Loc
);
4510 if Nkind
(Typ
) = N_Access_Definition
then
4511 Value
:= Make_Explicit_Dereference
(Loc
, Value
);
4512 Etyp
:= Etype
(Subtype_Mark
(Typ
));
4514 Etyp
:= Etype
(Typ
);
4517 if (Out_Present
(Current_Parameter
)
4518 or else Nkind
(Typ
) = N_Access_Definition
)
4519 and then Etyp
/= Stub_Type
4521 Append_To
(Non_Asynchronous_Statements
,
4522 Make_Attribute_Reference
(Loc
,
4524 New_Occurrence_Of
(Etyp
, Loc
),
4526 Attribute_Name
=> Name_Read
,
4528 Expressions
=> New_List
(
4529 Make_Attribute_Reference
(Loc
,
4531 New_Occurrence_Of
(Result_Parameter
, Loc
),
4532 Attribute_Name
=> Name_Access
),
4537 Next
(Current_Parameter
);
4542 if Is_Known_Asynchronous
then
4543 Append_List_To
(Statements
, Asynchronous_Statements
);
4545 elsif Is_Known_Non_Asynchronous
then
4546 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
4549 pragma Assert
(Present
(Asynchronous
));
4550 Prepend_To
(Asynchronous_Statements
,
4551 Make_Attribute_Reference
(Loc
,
4552 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4553 Attribute_Name
=> Name_Write
,
4554 Expressions
=> New_List
(
4555 Make_Attribute_Reference
(Loc
,
4557 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4558 Attribute_Name
=> Name_Access
),
4559 New_Occurrence_Of
(Standard_True
, Loc
))));
4561 Prepend_To
(Non_Asynchronous_Statements
,
4562 Make_Attribute_Reference
(Loc
,
4563 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
4564 Attribute_Name
=> Name_Write
,
4565 Expressions
=> New_List
(
4566 Make_Attribute_Reference
(Loc
,
4568 New_Occurrence_Of
(Stream_Parameter
, Loc
),
4569 Attribute_Name
=> Name_Access
),
4570 New_Occurrence_Of
(Standard_False
, Loc
))));
4572 Append_To
(Statements
,
4573 Make_Implicit_If_Statement
(Nod
,
4574 Condition
=> Asynchronous
,
4575 Then_Statements
=> Asynchronous_Statements
,
4576 Else_Statements
=> Non_Asynchronous_Statements
));
4578 end Build_General_Calling_Stubs
;
4580 -----------------------------
4581 -- Build_RPC_Receiver_Body --
4582 -----------------------------
4584 procedure Build_RPC_Receiver_Body
4585 (RPC_Receiver
: Entity_Id
;
4586 Request
: out Entity_Id
;
4587 Subp_Id
: out Entity_Id
;
4588 Subp_Index
: out Entity_Id
;
4589 Stmts
: out List_Id
;
4592 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
4594 RPC_Receiver_Spec
: Node_Id
;
4595 RPC_Receiver_Decls
: List_Id
;
4598 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
4600 RPC_Receiver_Spec
:=
4601 Build_RPC_Receiver_Specification
4602 (RPC_Receiver
=> RPC_Receiver
,
4603 Request_Parameter
=> Request
);
4605 Subp_Id
:= Make_Temporary
(Loc
, 'P');
4606 Subp_Index
:= Subp_Id
;
4608 -- Subp_Id may not be a constant, because in the case of the RPC
4609 -- receiver for an RCI package, when a call is received from a RAS
4610 -- dereference, it will be assigned during subsequent processing.
4612 RPC_Receiver_Decls
:= New_List
(
4613 Make_Object_Declaration
(Loc
,
4614 Defining_Identifier
=> Subp_Id
,
4615 Object_Definition
=>
4616 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4618 Make_Attribute_Reference
(Loc
,
4620 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
4621 Attribute_Name
=> Name_Input
,
4622 Expressions
=> New_List
(
4623 Make_Selected_Component
(Loc
,
4625 Selector_Name
=> Name_Params
)))));
4630 Make_Subprogram_Body
(Loc
,
4631 Specification
=> RPC_Receiver_Spec
,
4632 Declarations
=> RPC_Receiver_Decls
,
4633 Handled_Statement_Sequence
=>
4634 Make_Handled_Sequence_Of_Statements
(Loc
,
4635 Statements
=> Stmts
));
4636 end Build_RPC_Receiver_Body
;
4638 -----------------------
4639 -- Build_Stub_Target --
4640 -----------------------
4642 function Build_Stub_Target
4645 RCI_Locator
: Entity_Id
;
4646 Controlling_Parameter
: Entity_Id
) return RPC_Target
4648 Target_Info
: RPC_Target
(PCS_Kind
=> Name_GARLIC_DSA
);
4651 Target_Info
.Partition
:= Make_Temporary
(Loc
, 'P');
4653 if Present
(Controlling_Parameter
) then
4655 Make_Object_Declaration
(Loc
,
4656 Defining_Identifier
=> Target_Info
.Partition
,
4657 Constant_Present
=> True,
4658 Object_Definition
=>
4659 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4662 Make_Selected_Component
(Loc
,
4663 Prefix
=> Controlling_Parameter
,
4664 Selector_Name
=> Name_Origin
)));
4666 Target_Info
.RPC_Receiver
:=
4667 Make_Selected_Component
(Loc
,
4668 Prefix
=> Controlling_Parameter
,
4669 Selector_Name
=> Name_Receiver
);
4673 Make_Object_Declaration
(Loc
,
4674 Defining_Identifier
=> Target_Info
.Partition
,
4675 Constant_Present
=> True,
4676 Object_Definition
=>
4677 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
),
4680 Make_Function_Call
(Loc
,
4681 Name
=> Make_Selected_Component
(Loc
,
4683 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4685 Make_Identifier
(Loc
,
4686 Name_Get_Active_Partition_ID
)))));
4688 Target_Info
.RPC_Receiver
:=
4689 Make_Selected_Component
(Loc
,
4691 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
4693 Make_Identifier
(Loc
, Name_Get_RCI_Package_Receiver
));
4696 end Build_Stub_Target
;
4698 ---------------------
4699 -- Build_Stub_Type --
4700 ---------------------
4702 procedure Build_Stub_Type
4703 (RACW_Type
: Entity_Id
;
4704 Stub_Type_Comps
: out List_Id
;
4705 RPC_Receiver_Decl
: out Node_Id
)
4707 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
4708 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
4711 Stub_Type_Comps
:= New_List
(
4712 Make_Component_Declaration
(Loc
,
4713 Defining_Identifier
=>
4714 Make_Defining_Identifier
(Loc
, Name_Origin
),
4715 Component_Definition
=>
4716 Make_Component_Definition
(Loc
,
4717 Aliased_Present
=> False,
4718 Subtype_Indication
=>
4719 New_Occurrence_Of
(RTE
(RE_Partition_ID
), Loc
))),
4721 Make_Component_Declaration
(Loc
,
4722 Defining_Identifier
=>
4723 Make_Defining_Identifier
(Loc
, Name_Receiver
),
4724 Component_Definition
=>
4725 Make_Component_Definition
(Loc
,
4726 Aliased_Present
=> False,
4727 Subtype_Indication
=>
4728 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4730 Make_Component_Declaration
(Loc
,
4731 Defining_Identifier
=>
4732 Make_Defining_Identifier
(Loc
, Name_Addr
),
4733 Component_Definition
=>
4734 Make_Component_Definition
(Loc
,
4735 Aliased_Present
=> False,
4736 Subtype_Indication
=>
4737 New_Occurrence_Of
(RTE
(RE_Unsigned_64
), Loc
))),
4739 Make_Component_Declaration
(Loc
,
4740 Defining_Identifier
=>
4741 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
4742 Component_Definition
=>
4743 Make_Component_Definition
(Loc
,
4744 Aliased_Present
=> False,
4745 Subtype_Indication
=>
4746 New_Occurrence_Of
(Standard_Boolean
, Loc
))));
4749 RPC_Receiver_Decl
:= Empty
;
4752 RPC_Receiver_Request
: constant Entity_Id
:=
4753 Make_Defining_Identifier
(Loc
, Name_R
);
4755 RPC_Receiver_Decl
:=
4756 Make_Subprogram_Declaration
(Loc
,
4757 Build_RPC_Receiver_Specification
4758 (RPC_Receiver
=> Make_Temporary
(Loc
, 'R'),
4759 Request_Parameter
=> RPC_Receiver_Request
));
4762 end Build_Stub_Type
;
4764 --------------------------------------
4765 -- Build_Subprogram_Receiving_Stubs --
4766 --------------------------------------
4768 function Build_Subprogram_Receiving_Stubs
4769 (Vis_Decl
: Node_Id
;
4770 Asynchronous
: Boolean;
4771 Dynamically_Asynchronous
: Boolean := False;
4772 Stub_Type
: Entity_Id
:= Empty
;
4773 RACW_Type
: Entity_Id
:= Empty
;
4774 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
4776 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
4778 Request_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
4779 -- Formal parameter for receiving stubs: a descriptor for an incoming
4782 Decls
: constant List_Id
:= New_List
;
4783 -- All the parameters will get declared before calling the real
4784 -- subprograms. Also the out parameters will be declared.
4786 Statements
: constant List_Id
:= New_List
;
4788 Extra_Formal_Statements
: constant List_Id
:= New_List
;
4789 -- Statements concerning extra formal parameters
4791 After_Statements
: constant List_Id
:= New_List
;
4792 -- Statements to be executed after the subprogram call
4794 Inner_Decls
: List_Id
:= No_List
;
4795 -- In case of a function, the inner declarations are needed since
4796 -- the result may be unconstrained.
4798 Excep_Handlers
: List_Id
:= No_List
;
4799 Excep_Choice
: Entity_Id
;
4800 Excep_Code
: List_Id
;
4802 Parameter_List
: constant List_Id
:= New_List
;
4803 -- List of parameters to be passed to the subprogram
4805 Current_Parameter
: Node_Id
;
4807 Ordered_Parameters_List
: constant List_Id
:=
4808 Build_Ordered_Parameters_List
4809 (Specification
(Vis_Decl
));
4811 Subp_Spec
: Node_Id
;
4812 -- Subprogram specification
4814 Called_Subprogram
: Node_Id
;
4815 -- The subprogram to call
4817 Null_Raise_Statement
: Node_Id
;
4819 Dynamic_Async
: Entity_Id
;
4822 if Present
(RACW_Type
) then
4823 Called_Subprogram
:= New_Occurrence_Of
(Parent_Primitive
, Loc
);
4825 Called_Subprogram
:=
4827 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
4830 if Dynamically_Asynchronous
then
4831 Dynamic_Async
:= Make_Temporary
(Loc
, 'S');
4833 Dynamic_Async
:= Empty
;
4836 if not Asynchronous
or Dynamically_Asynchronous
then
4838 -- The first statement after the subprogram call is a statement to
4839 -- write a Null_Occurrence into the result stream.
4841 Null_Raise_Statement
:=
4842 Make_Attribute_Reference
(Loc
,
4844 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
4845 Attribute_Name
=> Name_Write
,
4846 Expressions
=> New_List
(
4847 Make_Selected_Component
(Loc
,
4848 Prefix
=> Request_Parameter
,
4849 Selector_Name
=> Name_Result
),
4850 New_Occurrence_Of
(RTE
(RE_Null_Occurrence
), Loc
)));
4852 if Dynamically_Asynchronous
then
4853 Null_Raise_Statement
:=
4854 Make_Implicit_If_Statement
(Vis_Decl
,
4856 Make_Op_Not
(Loc
, New_Occurrence_Of
(Dynamic_Async
, Loc
)),
4857 Then_Statements
=> New_List
(Null_Raise_Statement
));
4860 Append_To
(After_Statements
, Null_Raise_Statement
);
4863 -- Loop through every parameter and get its value from the stream. If
4864 -- the parameter is unconstrained, then the parameter is read using
4865 -- 'Input at the point of declaration.
4867 Current_Parameter
:= First
(Ordered_Parameters_List
);
4868 while Present
(Current_Parameter
) loop
4871 Constrained
: Boolean;
4873 Need_Extra_Constrained
: Boolean;
4874 -- True when an Extra_Constrained actual is required
4876 Object
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
4878 Expr
: Node_Id
:= Empty
;
4880 Is_Controlling_Formal
: constant Boolean :=
4881 Is_RACW_Controlling_Formal
4882 (Current_Parameter
, Stub_Type
);
4885 if Is_Controlling_Formal
then
4887 -- We have a controlling formal parameter. Read its address
4888 -- rather than a real object. The address is in Unsigned_64
4891 Etyp
:= RTE
(RE_Unsigned_64
);
4893 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
4896 Constrained
:= not Transmit_As_Unconstrained
(Etyp
);
4898 if In_Present
(Current_Parameter
)
4899 or else not Out_Present
(Current_Parameter
)
4900 or else not Constrained
4901 or else Is_Controlling_Formal
4903 -- If an input parameter is constrained, then the read of
4904 -- the parameter is deferred until the beginning of the
4905 -- subprogram body. If it is unconstrained, then an
4906 -- expression is built for the object declaration and the
4907 -- variable is set using 'Input instead of 'Read. Note that
4908 -- this deferral does not change the order in which the
4909 -- actuals are read because Build_Ordered_Parameter_List
4910 -- puts them unconstrained first.
4913 Append_To
(Statements
,
4914 Make_Attribute_Reference
(Loc
,
4915 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4916 Attribute_Name
=> Name_Read
,
4917 Expressions
=> New_List
(
4918 Make_Selected_Component
(Loc
,
4919 Prefix
=> Request_Parameter
,
4920 Selector_Name
=> Name_Params
),
4921 New_Occurrence_Of
(Object
, Loc
))));
4925 -- Build and append Input_With_Tag_Check function
4928 Input_With_Tag_Check
(Loc
,
4931 Make_Selected_Component
(Loc
,
4932 Prefix
=> Request_Parameter
,
4933 Selector_Name
=> Name_Params
)));
4935 -- Prepare function call expression
4938 Make_Function_Call
(Loc
,
4942 (Specification
(Last
(Decls
))), Loc
));
4946 Need_Extra_Constrained
:=
4947 Nkind
(Parameter_Type
(Current_Parameter
)) /=
4950 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
4952 Present
(Extra_Constrained
4953 (Defining_Identifier
(Current_Parameter
)));
4955 -- We may not associate an extra constrained actual to a
4956 -- constant object, so if one is needed, declare the actual
4957 -- as a variable even if it won't be modified.
4959 Build_Actual_Object_Declaration
4962 Variable
=> Need_Extra_Constrained
4963 or else Out_Present
(Current_Parameter
),
4967 -- An out parameter may be written back using a 'Write
4968 -- attribute instead of a 'Output because it has been
4969 -- constrained by the parameter given to the caller. Note that
4970 -- out controlling arguments in the case of a RACW are not put
4971 -- back in the stream because the pointer on them has not
4974 if Out_Present
(Current_Parameter
)
4976 Etype
(Parameter_Type
(Current_Parameter
)) /= Stub_Type
4978 Append_To
(After_Statements
,
4979 Make_Attribute_Reference
(Loc
,
4980 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
4981 Attribute_Name
=> Name_Write
,
4982 Expressions
=> New_List
(
4983 Make_Selected_Component
(Loc
,
4984 Prefix
=> Request_Parameter
,
4985 Selector_Name
=> Name_Result
),
4986 New_Occurrence_Of
(Object
, Loc
))));
4989 -- For RACW controlling formals, the Etyp of Object is always
4990 -- an RACW, even if the parameter is not of an anonymous access
4991 -- type. In such case, we need to dereference it at call time.
4993 if Is_Controlling_Formal
then
4994 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
4997 Append_To
(Parameter_List
,
4998 Make_Parameter_Association
(Loc
,
5001 Defining_Identifier
(Current_Parameter
), Loc
),
5002 Explicit_Actual_Parameter
=>
5003 Make_Explicit_Dereference
(Loc
,
5004 Unchecked_Convert_To
(RACW_Type
,
5005 OK_Convert_To
(RTE
(RE_Address
),
5006 New_Occurrence_Of
(Object
, Loc
))))));
5009 Append_To
(Parameter_List
,
5010 Make_Parameter_Association
(Loc
,
5013 Defining_Identifier
(Current_Parameter
), Loc
),
5014 Explicit_Actual_Parameter
=>
5015 Unchecked_Convert_To
(RACW_Type
,
5016 OK_Convert_To
(RTE
(RE_Address
),
5017 New_Occurrence_Of
(Object
, Loc
)))));
5021 Append_To
(Parameter_List
,
5022 Make_Parameter_Association
(Loc
,
5025 Defining_Identifier
(Current_Parameter
), Loc
),
5026 Explicit_Actual_Parameter
=>
5027 New_Occurrence_Of
(Object
, Loc
)));
5030 -- If the current parameter needs an extra formal, then read it
5031 -- from the stream and set the corresponding semantic field in
5032 -- the variable. If the kind of the parameter identifier is
5033 -- E_Void, then this is a compiler generated parameter that
5034 -- doesn't need an extra constrained status.
5036 -- The case of Extra_Accessibility should also be handled ???
5038 if Need_Extra_Constrained
then
5040 Extra_Parameter
: constant Entity_Id
:=
5042 (Defining_Identifier
5043 (Current_Parameter
));
5045 Formal_Entity
: constant Entity_Id
:=
5046 Make_Defining_Identifier
5047 (Loc
, Chars
(Extra_Parameter
));
5049 Formal_Type
: constant Entity_Id
:=
5050 Etype
(Extra_Parameter
);
5054 Make_Object_Declaration
(Loc
,
5055 Defining_Identifier
=> Formal_Entity
,
5056 Object_Definition
=>
5057 New_Occurrence_Of
(Formal_Type
, Loc
)));
5059 Append_To
(Extra_Formal_Statements
,
5060 Make_Attribute_Reference
(Loc
,
5061 Prefix
=> New_Occurrence_Of
(
5063 Attribute_Name
=> Name_Read
,
5064 Expressions
=> New_List
(
5065 Make_Selected_Component
(Loc
,
5066 Prefix
=> Request_Parameter
,
5067 Selector_Name
=> Name_Params
),
5068 New_Occurrence_Of
(Formal_Entity
, Loc
))));
5070 -- Note: the call to Set_Extra_Constrained below relies
5071 -- on the fact that Object's Ekind has been set by
5072 -- Build_Actual_Object_Declaration.
5074 Set_Extra_Constrained
(Object
, Formal_Entity
);
5079 Next
(Current_Parameter
);
5082 -- Append the formal statements list at the end of regular statements
5084 Append_List_To
(Statements
, Extra_Formal_Statements
);
5086 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
5088 -- The remote subprogram is a function. We build an inner block to
5089 -- be able to hold a potentially unconstrained result in a
5093 Etyp
: constant Entity_Id
:=
5094 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
5095 Result
: constant Node_Id
:= Make_Temporary
(Loc
, 'R');
5098 Inner_Decls
:= New_List
(
5099 Make_Object_Declaration
(Loc
,
5100 Defining_Identifier
=> Result
,
5101 Constant_Present
=> True,
5102 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
5104 Make_Function_Call
(Loc
,
5105 Name
=> Called_Subprogram
,
5106 Parameter_Associations
=> Parameter_List
)));
5108 if Is_Class_Wide_Type
(Etyp
) then
5110 -- For a remote call to a function with a class-wide type,
5111 -- check that the returned value satisfies the requirements
5114 Append_To
(Inner_Decls
,
5115 Make_Transportable_Check
(Loc
,
5116 New_Occurrence_Of
(Result
, Loc
)));
5120 Append_To
(After_Statements
,
5121 Make_Attribute_Reference
(Loc
,
5122 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5123 Attribute_Name
=> Name_Output
,
5124 Expressions
=> New_List
(
5125 Make_Selected_Component
(Loc
,
5126 Prefix
=> Request_Parameter
,
5127 Selector_Name
=> Name_Result
),
5128 New_Occurrence_Of
(Result
, Loc
))));
5131 Append_To
(Statements
,
5132 Make_Block_Statement
(Loc
,
5133 Declarations
=> Inner_Decls
,
5134 Handled_Statement_Sequence
=>
5135 Make_Handled_Sequence_Of_Statements
(Loc
,
5136 Statements
=> After_Statements
)));
5139 -- The remote subprogram is a procedure. We do not need any inner
5140 -- block in this case.
5142 if Dynamically_Asynchronous
then
5144 Make_Object_Declaration
(Loc
,
5145 Defining_Identifier
=> Dynamic_Async
,
5146 Object_Definition
=>
5147 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
5149 Append_To
(Statements
,
5150 Make_Attribute_Reference
(Loc
,
5151 Prefix
=> New_Occurrence_Of
(Standard_Boolean
, Loc
),
5152 Attribute_Name
=> Name_Read
,
5153 Expressions
=> New_List
(
5154 Make_Selected_Component
(Loc
,
5155 Prefix
=> Request_Parameter
,
5156 Selector_Name
=> Name_Params
),
5157 New_Occurrence_Of
(Dynamic_Async
, Loc
))));
5160 Append_To
(Statements
,
5161 Make_Procedure_Call_Statement
(Loc
,
5162 Name
=> Called_Subprogram
,
5163 Parameter_Associations
=> Parameter_List
));
5165 Append_List_To
(Statements
, After_Statements
);
5168 if Asynchronous
and then not Dynamically_Asynchronous
then
5170 -- For an asynchronous procedure, add a null exception handler
5172 Excep_Handlers
:= New_List
(
5173 Make_Implicit_Exception_Handler
(Loc
,
5174 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5175 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
5178 -- In the other cases, if an exception is raised, then the
5179 -- exception occurrence is copied into the output stream and
5180 -- no other output parameter is written.
5182 Excep_Choice
:= Make_Temporary
(Loc
, 'E');
5184 Excep_Code
:= New_List
(
5185 Make_Attribute_Reference
(Loc
,
5187 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
),
5188 Attribute_Name
=> Name_Write
,
5189 Expressions
=> New_List
(
5190 Make_Selected_Component
(Loc
,
5191 Prefix
=> Request_Parameter
,
5192 Selector_Name
=> Name_Result
),
5193 New_Occurrence_Of
(Excep_Choice
, Loc
))));
5195 if Dynamically_Asynchronous
then
5196 Excep_Code
:= New_List
(
5197 Make_Implicit_If_Statement
(Vis_Decl
,
5198 Condition
=> Make_Op_Not
(Loc
,
5199 New_Occurrence_Of
(Dynamic_Async
, Loc
)),
5200 Then_Statements
=> Excep_Code
));
5203 Excep_Handlers
:= New_List
(
5204 Make_Implicit_Exception_Handler
(Loc
,
5205 Choice_Parameter
=> Excep_Choice
,
5206 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
5207 Statements
=> Excep_Code
));
5212 Make_Procedure_Specification
(Loc
,
5213 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'F'),
5215 Parameter_Specifications
=> New_List
(
5216 Make_Parameter_Specification
(Loc
,
5217 Defining_Identifier
=> Request_Parameter
,
5219 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
5222 Make_Subprogram_Body
(Loc
,
5223 Specification
=> Subp_Spec
,
5224 Declarations
=> Decls
,
5225 Handled_Statement_Sequence
=>
5226 Make_Handled_Sequence_Of_Statements
(Loc
,
5227 Statements
=> Statements
,
5228 Exception_Handlers
=> Excep_Handlers
));
5229 end Build_Subprogram_Receiving_Stubs
;
5235 function Result
return Node_Id
is
5237 return Make_Identifier
(Loc
, Name_V
);
5240 ----------------------
5241 -- Stream_Parameter --
5242 ----------------------
5244 function Stream_Parameter
return Node_Id
is
5246 return Make_Identifier
(Loc
, Name_S
);
5247 end Stream_Parameter
;
5251 -------------------------------
5252 -- Get_And_Reset_RACW_Bodies --
5253 -------------------------------
5255 function Get_And_Reset_RACW_Bodies
(RACW_Type
: Entity_Id
) return List_Id
is
5256 Desig
: constant Entity_Id
:=
5257 Etype
(Designated_Type
(RACW_Type
));
5259 Stub_Elements
: Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5261 Body_Decls
: List_Id
;
5262 -- Returned list of declarations
5265 if Stub_Elements
= Empty_Stub_Structure
then
5267 -- Stub elements may be missing as a consequence of a previously
5273 Body_Decls
:= Stub_Elements
.Body_Decls
;
5274 Stub_Elements
.Body_Decls
:= No_List
;
5275 Stubs_Table
.Set
(Desig
, Stub_Elements
);
5277 end Get_And_Reset_RACW_Bodies
;
5279 -----------------------
5280 -- Get_Stub_Elements --
5281 -----------------------
5283 function Get_Stub_Elements
(RACW_Type
: Entity_Id
) return Stub_Structure
is
5284 Desig
: constant Entity_Id
:=
5285 Etype
(Designated_Type
(RACW_Type
));
5286 Stub_Elements
: constant Stub_Structure
:= Stubs_Table
.Get
(Desig
);
5288 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
5289 return Stub_Elements
;
5290 end Get_Stub_Elements
;
5292 -----------------------
5293 -- Get_Subprogram_Id --
5294 -----------------------
5296 function Get_Subprogram_Id
(Def
: Entity_Id
) return String_Id
is
5297 Result
: constant String_Id
:= Get_Subprogram_Ids
(Def
).Str_Identifier
;
5299 pragma Assert
(Result
/= No_String
);
5301 end Get_Subprogram_Id
;
5303 -----------------------
5304 -- Get_Subprogram_Id --
5305 -----------------------
5307 function Get_Subprogram_Id
(Def
: Entity_Id
) return Int
is
5309 return Get_Subprogram_Ids
(Def
).Int_Identifier
;
5310 end Get_Subprogram_Id
;
5312 ------------------------
5313 -- Get_Subprogram_Ids --
5314 ------------------------
5316 function Get_Subprogram_Ids
5317 (Def
: Entity_Id
) return Subprogram_Identifiers
5320 return Subprogram_Identifier_Table
.Get
(Def
);
5321 end Get_Subprogram_Ids
;
5327 function Hash
(F
: Entity_Id
) return Hash_Index
is
5329 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5332 function Hash
(F
: Name_Id
) return Hash_Index
is
5334 return Hash_Index
(Natural (F
) mod Positive (Hash_Index
'Last + 1));
5337 --------------------------
5338 -- Input_With_Tag_Check --
5339 --------------------------
5341 function Input_With_Tag_Check
5343 Var_Type
: Entity_Id
;
5344 Stream
: Node_Id
) return Node_Id
5348 Make_Subprogram_Body
(Loc
,
5350 Make_Function_Specification
(Loc
,
5351 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'S'),
5352 Result_Definition
=> New_Occurrence_Of
(Var_Type
, Loc
)),
5353 Declarations
=> No_List
,
5354 Handled_Statement_Sequence
=>
5355 Make_Handled_Sequence_Of_Statements
(Loc
, New_List
(
5356 Make_Tag_Check
(Loc
,
5357 Make_Simple_Return_Statement
(Loc
,
5358 Make_Attribute_Reference
(Loc
,
5359 Prefix
=> New_Occurrence_Of
(Var_Type
, Loc
),
5360 Attribute_Name
=> Name_Input
,
5362 New_List
(Stream
)))))));
5363 end Input_With_Tag_Check
;
5365 --------------------------------
5366 -- Is_RACW_Controlling_Formal --
5367 --------------------------------
5369 function Is_RACW_Controlling_Formal
5370 (Parameter
: Node_Id
;
5371 Stub_Type
: Entity_Id
) return Boolean
5376 -- If the kind of the parameter is E_Void, then it is not a controlling
5377 -- formal (this can happen in the context of RAS).
5379 if Ekind
(Defining_Identifier
(Parameter
)) = E_Void
then
5383 -- If the parameter is not a controlling formal, then it cannot be
5384 -- possibly a RACW_Controlling_Formal.
5386 if not Is_Controlling_Formal
(Defining_Identifier
(Parameter
)) then
5390 Typ
:= Parameter_Type
(Parameter
);
5391 return (Nkind
(Typ
) = N_Access_Definition
5392 and then Etype
(Subtype_Mark
(Typ
)) = Stub_Type
)
5393 or else Etype
(Typ
) = Stub_Type
;
5394 end Is_RACW_Controlling_Formal
;
5396 ------------------------------
5397 -- Make_Transportable_Check --
5398 ------------------------------
5400 function Make_Transportable_Check
5402 Expr
: Node_Id
) return Node_Id
is
5405 Make_Raise_Program_Error
(Loc
,
5408 Build_Get_Transportable
(Loc
,
5409 Make_Selected_Component
(Loc
,
5411 Selector_Name
=> Make_Identifier
(Loc
, Name_uTag
)))),
5412 Reason
=> PE_Non_Transportable_Actual
);
5413 end Make_Transportable_Check
;
5415 -----------------------------
5416 -- Make_Selected_Component --
5417 -----------------------------
5419 function Make_Selected_Component
5422 Selector_Name
: Name_Id
) return Node_Id
5425 return Make_Selected_Component
(Loc
,
5426 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
5427 Selector_Name
=> Make_Identifier
(Loc
, Selector_Name
));
5428 end Make_Selected_Component
;
5430 --------------------
5431 -- Make_Tag_Check --
5432 --------------------
5434 function Make_Tag_Check
(Loc
: Source_Ptr
; N
: Node_Id
) return Node_Id
is
5435 Occ
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
5438 return Make_Block_Statement
(Loc
,
5439 Handled_Statement_Sequence
=>
5440 Make_Handled_Sequence_Of_Statements
(Loc
,
5441 Statements
=> New_List
(N
),
5443 Exception_Handlers
=> New_List
(
5444 Make_Implicit_Exception_Handler
(Loc
,
5445 Choice_Parameter
=> Occ
,
5447 Exception_Choices
=>
5448 New_List
(New_Occurrence_Of
(RTE
(RE_Tag_Error
), Loc
)),
5451 New_List
(Make_Procedure_Call_Statement
(Loc
,
5453 (RTE
(RE_Raise_Program_Error_Unknown_Tag
), Loc
),
5454 New_List
(New_Occurrence_Of
(Occ
, Loc
))))))));
5457 ----------------------------
5458 -- Need_Extra_Constrained --
5459 ----------------------------
5461 function Need_Extra_Constrained
(Parameter
: Node_Id
) return Boolean is
5462 Etyp
: constant Entity_Id
:= Etype
(Parameter_Type
(Parameter
));
5464 return Out_Present
(Parameter
)
5465 and then Has_Discriminants
(Etyp
)
5466 and then not Is_Constrained
(Etyp
)
5467 and then not Is_Indefinite_Subtype
(Etyp
);
5468 end Need_Extra_Constrained
;
5470 ------------------------------------
5471 -- Pack_Entity_Into_Stream_Access --
5472 ------------------------------------
5474 function Pack_Entity_Into_Stream_Access
5478 Etyp
: Entity_Id
:= Empty
) return Node_Id
5483 if Present
(Etyp
) then
5486 Typ
:= Etype
(Object
);
5490 Pack_Node_Into_Stream_Access
(Loc
,
5492 Object
=> New_Occurrence_Of
(Object
, Loc
),
5494 end Pack_Entity_Into_Stream_Access
;
5496 ---------------------------
5497 -- Pack_Node_Into_Stream --
5498 ---------------------------
5500 function Pack_Node_Into_Stream
5504 Etyp
: Entity_Id
) return Node_Id
5506 Write_Attribute
: Name_Id
:= Name_Write
;
5509 if not Is_Constrained
(Etyp
) then
5510 Write_Attribute
:= Name_Output
;
5514 Make_Attribute_Reference
(Loc
,
5515 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5516 Attribute_Name
=> Write_Attribute
,
5517 Expressions
=> New_List
(
5518 Make_Attribute_Reference
(Loc
,
5519 Prefix
=> New_Occurrence_Of
(Stream
, Loc
),
5520 Attribute_Name
=> Name_Access
),
5522 end Pack_Node_Into_Stream
;
5524 ----------------------------------
5525 -- Pack_Node_Into_Stream_Access --
5526 ----------------------------------
5528 function Pack_Node_Into_Stream_Access
5532 Etyp
: Entity_Id
) return Node_Id
5534 Write_Attribute
: Name_Id
:= Name_Write
;
5537 if not Is_Constrained
(Etyp
) then
5538 Write_Attribute
:= Name_Output
;
5542 Make_Attribute_Reference
(Loc
,
5543 Prefix
=> New_Occurrence_Of
(Etyp
, Loc
),
5544 Attribute_Name
=> Write_Attribute
,
5545 Expressions
=> New_List
(
5548 end Pack_Node_Into_Stream_Access
;
5550 ---------------------
5551 -- PolyORB_Support --
5552 ---------------------
5554 package body PolyORB_Support
is
5556 -- Local subprograms
5558 procedure Add_RACW_Read_Attribute
5559 (RACW_Type
: Entity_Id
;
5560 Stub_Type
: Entity_Id
;
5561 Stub_Type_Access
: Entity_Id
;
5562 Body_Decls
: List_Id
);
5563 -- Add Read attribute for the RACW type. The declaration and attribute
5564 -- definition clauses are inserted right after the declaration of
5565 -- RACW_Type. If Body_Decls is not No_List, the subprogram body is
5566 -- appended to it (case where the RACW declaration is in the main unit).
5568 procedure Add_RACW_Write_Attribute
5569 (RACW_Type
: Entity_Id
;
5570 Stub_Type
: Entity_Id
;
5571 Stub_Type_Access
: Entity_Id
;
5572 Body_Decls
: List_Id
);
5573 -- Same as above for the Write attribute
5575 procedure Add_RACW_From_Any
5576 (RACW_Type
: Entity_Id
;
5577 Body_Decls
: List_Id
);
5578 -- Add the From_Any TSS for this RACW type
5580 procedure Add_RACW_To_Any
5581 (RACW_Type
: Entity_Id
;
5582 Body_Decls
: List_Id
);
5583 -- Add the To_Any TSS for this RACW type
5585 procedure Add_RACW_TypeCode
5586 (Designated_Type
: Entity_Id
;
5587 RACW_Type
: Entity_Id
;
5588 Body_Decls
: List_Id
);
5589 -- Add the TypeCode TSS for this RACW type
5591 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
);
5592 -- Add the From_Any TSS for this RAS type
5594 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
);
5595 -- Add the To_Any TSS for this RAS type
5597 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
);
5598 -- Add the TypeCode TSS for this RAS type
5600 procedure Add_RAS_Access_TSS
(N
: Node_Id
);
5601 -- Add a subprogram body for RAS Access TSS
5603 -------------------------------------
5604 -- Add_Obj_RPC_Receiver_Completion --
5605 -------------------------------------
5607 procedure Add_Obj_RPC_Receiver_Completion
5610 RPC_Receiver
: Entity_Id
;
5611 Stub_Elements
: Stub_Structure
)
5613 Desig
: constant Entity_Id
:=
5614 Etype
(Designated_Type
(Stub_Elements
.RACW_Type
));
5617 Make_Procedure_Call_Statement
(Loc
,
5620 RTE
(RE_Register_Obj_Receiving_Stub
), Loc
),
5622 Parameter_Associations
=> New_List
(
5626 Make_String_Literal
(Loc
,
5627 Fully_Qualified_Name_String
(Desig
)),
5631 Make_Attribute_Reference
(Loc
,
5634 Defining_Unit_Name
(Parent
(RPC_Receiver
)), Loc
),
5640 Make_Attribute_Reference
(Loc
,
5643 Defining_Identifier
(
5644 Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5647 end Add_Obj_RPC_Receiver_Completion
;
5649 -----------------------
5650 -- Add_RACW_Features --
5651 -----------------------
5653 procedure Add_RACW_Features
5654 (RACW_Type
: Entity_Id
;
5656 Stub_Type
: Entity_Id
;
5657 Stub_Type_Access
: Entity_Id
;
5658 RPC_Receiver_Decl
: Node_Id
;
5659 Body_Decls
: List_Id
)
5661 pragma Unreferenced
(RPC_Receiver_Decl
);
5665 (RACW_Type
=> RACW_Type
,
5666 Body_Decls
=> Body_Decls
);
5669 (RACW_Type
=> RACW_Type
,
5670 Body_Decls
=> Body_Decls
);
5672 Add_RACW_Write_Attribute
5673 (RACW_Type
=> RACW_Type
,
5674 Stub_Type
=> Stub_Type
,
5675 Stub_Type_Access
=> Stub_Type_Access
,
5676 Body_Decls
=> Body_Decls
);
5678 Add_RACW_Read_Attribute
5679 (RACW_Type
=> RACW_Type
,
5680 Stub_Type
=> Stub_Type
,
5681 Stub_Type_Access
=> Stub_Type_Access
,
5682 Body_Decls
=> Body_Decls
);
5685 (Designated_Type
=> Desig
,
5686 RACW_Type
=> RACW_Type
,
5687 Body_Decls
=> Body_Decls
);
5688 end Add_RACW_Features
;
5690 -----------------------
5691 -- Add_RACW_From_Any --
5692 -----------------------
5694 procedure Add_RACW_From_Any
5695 (RACW_Type
: Entity_Id
;
5696 Body_Decls
: List_Id
)
5698 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5699 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5700 Fnam
: constant Entity_Id
:=
5701 Make_Defining_Identifier
(Loc
,
5702 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'F'));
5704 Func_Spec
: Node_Id
;
5705 Func_Decl
: Node_Id
;
5706 Func_Body
: Node_Id
;
5708 Statements
: List_Id
;
5709 -- Various parts of the subprogram
5711 Any_Parameter
: constant Entity_Id
:=
5712 Make_Defining_Identifier
(Loc
, Name_A
);
5714 Asynchronous_Flag
: constant Entity_Id
:=
5715 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5716 -- The flag object declared in Add_RACW_Asynchronous_Flag
5720 Make_Function_Specification
(Loc
,
5721 Defining_Unit_Name
=>
5723 Parameter_Specifications
=> New_List
(
5724 Make_Parameter_Specification
(Loc
,
5725 Defining_Identifier
=>
5728 New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
5729 Result_Definition
=> New_Occurrence_Of
(RACW_Type
, Loc
));
5731 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5732 -- entity in the declaration spec, not those of the body spec.
5734 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5735 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5736 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_From_Any
);
5738 if No
(Body_Decls
) then
5742 -- ??? Issue with asynchronous calls here: the Asynchronous flag is
5743 -- set on the stub type if, and only if, the RACW type has a pragma
5744 -- Asynchronous. This is incorrect for RACWs that implement RAS
5745 -- types, because in that case the /designated subprogram/ (not the
5746 -- type) might be asynchronous, and that causes the stub to need to
5747 -- be asynchronous too. A solution is to transport a RAS as a struct
5748 -- containing a RACW and an asynchronous flag, and to properly alter
5749 -- the Asynchronous component in the stub type in the RAS's _From_Any
5752 Statements
:= New_List
(
5753 Make_Simple_Return_Statement
(Loc
,
5754 Expression
=> Unchecked_Convert_To
(RACW_Type
,
5755 Make_Function_Call
(Loc
,
5756 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RACW
), Loc
),
5757 Parameter_Associations
=> New_List
(
5758 Make_Function_Call
(Loc
,
5759 Name
=> New_Occurrence_Of
(RTE
(RE_FA_ObjRef
), Loc
),
5760 Parameter_Associations
=> New_List
(
5761 New_Occurrence_Of
(Any_Parameter
, Loc
))),
5762 Build_Stub_Tag
(Loc
, RACW_Type
),
5763 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5764 New_Occurrence_Of
(Asynchronous_Flag
, Loc
))))));
5767 Make_Subprogram_Body
(Loc
,
5768 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
5769 Declarations
=> No_List
,
5770 Handled_Statement_Sequence
=>
5771 Make_Handled_Sequence_Of_Statements
(Loc
,
5772 Statements
=> Statements
));
5774 Append_To
(Body_Decls
, Func_Body
);
5775 end Add_RACW_From_Any
;
5777 -----------------------------
5778 -- Add_RACW_Read_Attribute --
5779 -----------------------------
5781 procedure Add_RACW_Read_Attribute
5782 (RACW_Type
: Entity_Id
;
5783 Stub_Type
: Entity_Id
;
5784 Stub_Type_Access
: Entity_Id
;
5785 Body_Decls
: List_Id
)
5787 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
5789 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5791 Proc_Decl
: Node_Id
;
5792 Attr_Decl
: Node_Id
;
5794 Body_Node
: Node_Id
;
5796 Decls
: constant List_Id
:= New_List
;
5797 Statements
: constant List_Id
:= New_List
;
5798 Reference
: constant Entity_Id
:=
5799 Make_Defining_Identifier
(Loc
, Name_R
);
5800 -- Various parts of the procedure
5802 Pnam
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
5804 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5806 Asynchronous_Flag
: constant Entity_Id
:=
5807 Asynchronous_Flags_Table
.Get
(RACW_Type
);
5808 pragma Assert
(Present
(Asynchronous_Flag
));
5810 function Stream_Parameter
return Node_Id
;
5811 function Result
return Node_Id
;
5813 -- Functions to create occurrences of the formal parameter names
5819 function Result
return Node_Id
is
5821 return Make_Identifier
(Loc
, Name_V
);
5824 ----------------------
5825 -- Stream_Parameter --
5826 ----------------------
5828 function Stream_Parameter
return Node_Id
is
5830 return Make_Identifier
(Loc
, Name_S
);
5831 end Stream_Parameter
;
5833 -- Start of processing for Add_RACW_Read_Attribute
5836 Build_Stream_Procedure
5837 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> True);
5839 Proc_Decl
:= Make_Subprogram_Declaration
(Loc
,
5840 Copy_Specification
(Loc
, Specification
(Body_Node
)));
5843 Make_Attribute_Definition_Clause
(Loc
,
5844 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
5848 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
5850 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
5851 Insert_After
(Proc_Decl
, Attr_Decl
);
5853 if No
(Body_Decls
) then
5858 Make_Object_Declaration
(Loc
,
5859 Defining_Identifier
=>
5861 Object_Definition
=>
5862 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)));
5864 Append_List_To
(Statements
, New_List
(
5865 Make_Attribute_Reference
(Loc
,
5867 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5868 Attribute_Name
=> Name_Read
,
5869 Expressions
=> New_List
(
5871 New_Occurrence_Of
(Reference
, Loc
))),
5873 Make_Assignment_Statement
(Loc
,
5877 Unchecked_Convert_To
(RACW_Type
,
5878 Make_Function_Call
(Loc
,
5880 New_Occurrence_Of
(RTE
(RE_Get_RACW
), Loc
),
5881 Parameter_Associations
=> New_List
(
5882 New_Occurrence_Of
(Reference
, Loc
),
5883 Build_Stub_Tag
(Loc
, RACW_Type
),
5884 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5885 New_Occurrence_Of
(Asynchronous_Flag
, Loc
)))))));
5887 Set_Declarations
(Body_Node
, Decls
);
5888 Append_To
(Body_Decls
, Body_Node
);
5889 end Add_RACW_Read_Attribute
;
5891 ---------------------
5892 -- Add_RACW_To_Any --
5893 ---------------------
5895 procedure Add_RACW_To_Any
5896 (RACW_Type
: Entity_Id
;
5897 Body_Decls
: List_Id
)
5899 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
5901 Fnam
: constant Entity_Id
:=
5902 Make_Defining_Identifier
(Loc
,
5903 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'T'));
5905 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
5907 Stub_Elements
: constant Stub_Structure
:=
5908 Get_Stub_Elements
(RACW_Type
);
5910 Func_Spec
: Node_Id
;
5911 Func_Decl
: Node_Id
;
5912 Func_Body
: Node_Id
;
5915 Statements
: List_Id
;
5916 -- Various parts of the subprogram
5918 RACW_Parameter
: constant Entity_Id
:=
5919 Make_Defining_Identifier
(Loc
, Name_R
);
5921 Reference
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
5922 Any
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
5926 Make_Function_Specification
(Loc
,
5927 Defining_Unit_Name
=>
5929 Parameter_Specifications
=> New_List
(
5930 Make_Parameter_Specification
(Loc
,
5931 Defining_Identifier
=>
5934 New_Occurrence_Of
(RACW_Type
, Loc
))),
5935 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
5937 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
5938 -- entity in the declaration spec, not in the body spec.
5940 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
5942 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
5943 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_To_Any
);
5945 if No
(Body_Decls
) then
5951 -- R : constant Object_Ref :=
5957 -- RPC_Receiver'Access);
5961 Make_Object_Declaration
(Loc
,
5962 Defining_Identifier
=> Reference
,
5963 Constant_Present
=> True,
5964 Object_Definition
=>
5965 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
5967 Make_Function_Call
(Loc
,
5968 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
5969 Parameter_Associations
=> New_List
(
5970 Unchecked_Convert_To
(RTE
(RE_Address
),
5971 New_Occurrence_Of
(RACW_Parameter
, Loc
)),
5972 Make_String_Literal
(Loc
,
5973 Strval
=> Fully_Qualified_Name_String
5974 (Etype
(Designated_Type
(RACW_Type
)))),
5975 Build_Stub_Tag
(Loc
, RACW_Type
),
5976 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
5977 Make_Attribute_Reference
(Loc
,
5980 (Defining_Identifier
5981 (Stub_Elements
.RPC_Receiver_Decl
), Loc
),
5982 Attribute_Name
=> Name_Access
)))),
5984 Make_Object_Declaration
(Loc
,
5985 Defining_Identifier
=> Any
,
5986 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
5990 -- Any := TA_ObjRef (Reference);
5991 -- Set_TC (Any, RPC_Receiver.Obj_TypeCode);
5994 Statements
:= New_List
(
5995 Make_Assignment_Statement
(Loc
,
5996 Name
=> New_Occurrence_Of
(Any
, Loc
),
5998 Make_Function_Call
(Loc
,
5999 Name
=> New_Occurrence_Of
(RTE
(RE_TA_ObjRef
), Loc
),
6000 Parameter_Associations
=> New_List
(
6001 New_Occurrence_Of
(Reference
, Loc
)))),
6003 Make_Procedure_Call_Statement
(Loc
,
6004 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6005 Parameter_Associations
=> New_List
(
6006 New_Occurrence_Of
(Any
, Loc
),
6007 Make_Selected_Component
(Loc
,
6009 Defining_Identifier
(
6010 Stub_Elements
.RPC_Receiver_Decl
),
6011 Selector_Name
=> Name_Obj_TypeCode
))),
6013 Make_Simple_Return_Statement
(Loc
,
6014 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
6017 Make_Subprogram_Body
(Loc
,
6018 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
6019 Declarations
=> Decls
,
6020 Handled_Statement_Sequence
=>
6021 Make_Handled_Sequence_Of_Statements
(Loc
,
6022 Statements
=> Statements
));
6023 Append_To
(Body_Decls
, Func_Body
);
6024 end Add_RACW_To_Any
;
6026 -----------------------
6027 -- Add_RACW_TypeCode --
6028 -----------------------
6030 procedure Add_RACW_TypeCode
6031 (Designated_Type
: Entity_Id
;
6032 RACW_Type
: Entity_Id
;
6033 Body_Decls
: List_Id
)
6035 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
6037 Fnam
: constant Entity_Id
:=
6038 Make_Defining_Identifier
(Loc
,
6039 Chars
=> New_External_Name
(Chars
(RACW_Type
), 'Y'));
6041 Stub_Elements
: constant Stub_Structure
:=
6042 Stubs_Table
.Get
(Designated_Type
);
6043 pragma Assert
(Stub_Elements
/= Empty_Stub_Structure
);
6045 Func_Spec
: Node_Id
;
6046 Func_Decl
: Node_Id
;
6047 Func_Body
: Node_Id
;
6050 -- The spec for this subprogram has a dummy 'access RACW' argument,
6051 -- which serves only for overloading purposes.
6054 Make_Function_Specification
(Loc
,
6055 Defining_Unit_Name
=> Fnam
,
6056 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6058 -- NOTE: The usage occurrences of RACW_Parameter must refer to the
6059 -- entity in the declaration spec, not those of the body spec.
6061 Func_Decl
:= Make_Subprogram_Declaration
(Loc
, Func_Spec
);
6062 Insert_After
(Declaration_Node
(RACW_Type
), Func_Decl
);
6063 Set_Renaming_TSS
(RACW_Type
, Fnam
, TSS_TypeCode
);
6065 if No
(Body_Decls
) then
6070 Make_Subprogram_Body
(Loc
,
6071 Specification
=> Copy_Specification
(Loc
, Func_Spec
),
6072 Declarations
=> Empty_List
,
6073 Handled_Statement_Sequence
=>
6074 Make_Handled_Sequence_Of_Statements
(Loc
,
6075 Statements
=> New_List
(
6076 Make_Simple_Return_Statement
(Loc
,
6078 Make_Selected_Component
(Loc
,
6081 (Stub_Elements
.RPC_Receiver_Decl
),
6082 Selector_Name
=> Name_Obj_TypeCode
)))));
6084 Append_To
(Body_Decls
, Func_Body
);
6085 end Add_RACW_TypeCode
;
6087 ------------------------------
6088 -- Add_RACW_Write_Attribute --
6089 ------------------------------
6091 procedure Add_RACW_Write_Attribute
6092 (RACW_Type
: Entity_Id
;
6093 Stub_Type
: Entity_Id
;
6094 Stub_Type_Access
: Entity_Id
;
6095 Body_Decls
: List_Id
)
6097 pragma Unreferenced
(Stub_Type
, Stub_Type_Access
);
6099 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
6101 Is_RAS
: constant Boolean := not Comes_From_Source
(RACW_Type
);
6103 Stub_Elements
: constant Stub_Structure
:=
6104 Get_Stub_Elements
(RACW_Type
);
6106 Body_Node
: Node_Id
;
6107 Proc_Decl
: Node_Id
;
6108 Attr_Decl
: Node_Id
;
6110 Statements
: constant List_Id
:= New_List
;
6111 Pnam
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
6113 function Stream_Parameter
return Node_Id
;
6114 function Object
return Node_Id
;
6115 -- Functions to create occurrences of the formal parameter names
6121 function Object
return Node_Id
is
6123 return Make_Identifier
(Loc
, Name_V
);
6126 ----------------------
6127 -- Stream_Parameter --
6128 ----------------------
6130 function Stream_Parameter
return Node_Id
is
6132 return Make_Identifier
(Loc
, Name_S
);
6133 end Stream_Parameter
;
6135 -- Start of processing for Add_RACW_Write_Attribute
6138 Build_Stream_Procedure
6139 (Loc
, RACW_Type
, Body_Node
, Pnam
, Statements
, Outp
=> False);
6142 Make_Subprogram_Declaration
(Loc
,
6143 Copy_Specification
(Loc
, Specification
(Body_Node
)));
6146 Make_Attribute_Definition_Clause
(Loc
,
6147 Name
=> New_Occurrence_Of
(RACW_Type
, Loc
),
6148 Chars
=> Name_Write
,
6151 Defining_Unit_Name
(Specification
(Proc_Decl
)), Loc
));
6153 Insert_After
(Declaration_Node
(RACW_Type
), Proc_Decl
);
6154 Insert_After
(Proc_Decl
, Attr_Decl
);
6156 if No
(Body_Decls
) then
6160 Append_To
(Statements
,
6161 Pack_Node_Into_Stream_Access
(Loc
,
6162 Stream
=> Stream_Parameter
,
6164 Make_Function_Call
(Loc
,
6165 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Reference
), Loc
),
6166 Parameter_Associations
=> New_List
(
6167 Unchecked_Convert_To
(RTE
(RE_Address
), Object
),
6168 Make_String_Literal
(Loc
,
6169 Strval
=> Fully_Qualified_Name_String
6170 (Etype
(Designated_Type
(RACW_Type
)))),
6171 Build_Stub_Tag
(Loc
, RACW_Type
),
6172 New_Occurrence_Of
(Boolean_Literals
(Is_RAS
), Loc
),
6173 Make_Attribute_Reference
(Loc
,
6176 (Defining_Identifier
6177 (Stub_Elements
.RPC_Receiver_Decl
), Loc
),
6178 Attribute_Name
=> Name_Access
))),
6180 Etyp
=> RTE
(RE_Object_Ref
)));
6182 Append_To
(Body_Decls
, Body_Node
);
6183 end Add_RACW_Write_Attribute
;
6185 -----------------------
6186 -- Add_RAST_Features --
6187 -----------------------
6189 procedure Add_RAST_Features
6190 (Vis_Decl
: Node_Id
;
6191 RAS_Type
: Entity_Id
)
6194 Add_RAS_Access_TSS
(Vis_Decl
);
6196 Add_RAS_From_Any
(RAS_Type
);
6197 Add_RAS_TypeCode
(RAS_Type
);
6199 -- To_Any uses TypeCode, and therefore needs to be generated last
6201 Add_RAS_To_Any
(RAS_Type
);
6202 end Add_RAST_Features
;
6204 ------------------------
6205 -- Add_RAS_Access_TSS --
6206 ------------------------
6208 procedure Add_RAS_Access_TSS
(N
: Node_Id
) is
6209 Loc
: constant Source_Ptr
:= Sloc
(N
);
6211 Ras_Type
: constant Entity_Id
:= Defining_Identifier
(N
);
6212 Fat_Type
: constant Entity_Id
:= Equivalent_Type
(Ras_Type
);
6213 -- Ras_Type is the access to subprogram type; Fat_Type is the
6214 -- corresponding record type.
6216 RACW_Type
: constant Entity_Id
:=
6217 Underlying_RACW_Type
(Ras_Type
);
6219 Stub_Elements
: constant Stub_Structure
:=
6220 Get_Stub_Elements
(RACW_Type
);
6222 Proc
: constant Entity_Id
:=
6223 Make_Defining_Identifier
(Loc
,
6224 Chars
=> Make_TSS_Name
(Ras_Type
, TSS_RAS_Access
));
6226 Proc_Spec
: Node_Id
;
6228 -- Formal parameters
6230 Package_Name
: constant Entity_Id
:=
6231 Make_Defining_Identifier
(Loc
,
6236 Subp_Id
: constant Entity_Id
:=
6237 Make_Defining_Identifier
(Loc
,
6240 -- Target subprogram
6242 Asynch_P
: constant Entity_Id
:=
6243 Make_Defining_Identifier
(Loc
,
6244 Chars
=> Name_Asynchronous
);
6245 -- Is the procedure to which the 'Access applies asynchronous?
6247 All_Calls_Remote
: constant Entity_Id
:=
6248 Make_Defining_Identifier
(Loc
,
6249 Chars
=> Name_All_Calls_Remote
);
6250 -- True if an All_Calls_Remote pragma applies to the RCI unit
6251 -- that contains the subprogram.
6253 -- Common local variables
6255 Proc_Decls
: List_Id
;
6256 Proc_Statements
: List_Id
;
6258 Subp_Ref
: constant Entity_Id
:=
6259 Make_Defining_Identifier
(Loc
, Name_R
);
6260 -- Reference that designates the target subprogram (returned
6261 -- by Get_RAS_Info).
6263 Is_Local
: constant Entity_Id
:=
6264 Make_Defining_Identifier
(Loc
, Name_L
);
6265 Local_Addr
: constant Entity_Id
:=
6266 Make_Defining_Identifier
(Loc
, Name_A
);
6267 -- For the call to Get_Local_Address
6269 Local_Stub
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
6270 Stub_Ptr
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
6271 -- Additional local variables for the remote case
6274 (Field_Name
: Name_Id
;
6275 Value
: Node_Id
) return Node_Id
;
6276 -- Construct an assignment that sets the named component in the
6284 (Field_Name
: Name_Id
;
6285 Value
: Node_Id
) return Node_Id
6289 Make_Assignment_Statement
(Loc
,
6291 Make_Selected_Component
(Loc
,
6293 Selector_Name
=> Field_Name
),
6294 Expression
=> Value
);
6297 -- Start of processing for Add_RAS_Access_TSS
6300 Proc_Decls
:= New_List
(
6302 -- Common declarations
6304 Make_Object_Declaration
(Loc
,
6305 Defining_Identifier
=> Subp_Ref
,
6306 Object_Definition
=>
6307 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
)),
6309 Make_Object_Declaration
(Loc
,
6310 Defining_Identifier
=> Is_Local
,
6311 Object_Definition
=>
6312 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6314 Make_Object_Declaration
(Loc
,
6315 Defining_Identifier
=> Local_Addr
,
6316 Object_Definition
=>
6317 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
6319 Make_Object_Declaration
(Loc
,
6320 Defining_Identifier
=> Local_Stub
,
6321 Aliased_Present
=> True,
6322 Object_Definition
=>
6323 New_Occurrence_Of
(Stub_Elements
.Stub_Type
, Loc
)),
6325 Make_Object_Declaration
(Loc
,
6326 Defining_Identifier
=> Stub_Ptr
,
6327 Object_Definition
=>
6328 New_Occurrence_Of
(Stub_Elements
.Stub_Type_Access
, Loc
),
6330 Make_Attribute_Reference
(Loc
,
6331 Prefix
=> New_Occurrence_Of
(Local_Stub
, Loc
),
6332 Attribute_Name
=> Name_Unchecked_Access
)));
6334 Set_Etype
(Stub_Ptr
, Stub_Elements
.Stub_Type_Access
);
6335 -- Build_Get_Unique_RP_Call needs this information
6337 -- Get_RAS_Info (Pkg, Subp, R);
6338 -- Obtain a reference to the target subprogram
6340 Proc_Statements
:= New_List
(
6341 Make_Procedure_Call_Statement
(Loc
,
6342 Name
=> New_Occurrence_Of
(RTE
(RE_Get_RAS_Info
), Loc
),
6343 Parameter_Associations
=> New_List
(
6344 New_Occurrence_Of
(Package_Name
, Loc
),
6345 New_Occurrence_Of
(Subp_Id
, Loc
),
6346 New_Occurrence_Of
(Subp_Ref
, Loc
))),
6348 -- Get_Local_Address (R, L, A);
6349 -- Determine whether the subprogram is local (L), and if so
6350 -- obtain the local address of its proxy (A).
6352 Make_Procedure_Call_Statement
(Loc
,
6353 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6354 Parameter_Associations
=> New_List
(
6355 New_Occurrence_Of
(Subp_Ref
, Loc
),
6356 New_Occurrence_Of
(Is_Local
, Loc
),
6357 New_Occurrence_Of
(Local_Addr
, Loc
))));
6359 -- Note: Here we assume that the Fat_Type is a record containing just
6360 -- an access to a proxy or stub object.
6362 Append_To
(Proc_Statements
,
6366 Make_Implicit_If_Statement
(N
,
6367 Condition
=> New_Occurrence_Of
(Is_Local
, Loc
),
6369 Then_Statements
=> New_List
(
6371 -- if A.Target = null then
6373 Make_Implicit_If_Statement
(N
,
6376 Make_Selected_Component
(Loc
,
6378 Unchecked_Convert_To
6379 (RTE
(RE_RAS_Proxy_Type_Access
),
6380 New_Occurrence_Of
(Local_Addr
, Loc
)),
6381 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)),
6384 Then_Statements
=> New_List
(
6386 -- A.Target := Entity_Of (Ref);
6388 Make_Assignment_Statement
(Loc
,
6390 Make_Selected_Component
(Loc
,
6392 Unchecked_Convert_To
6393 (RTE
(RE_RAS_Proxy_Type_Access
),
6394 New_Occurrence_Of
(Local_Addr
, Loc
)),
6395 Selector_Name
=> Make_Identifier
(Loc
, Name_Target
)),
6397 Make_Function_Call
(Loc
,
6398 Name
=> New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6399 Parameter_Associations
=> New_List
(
6400 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6402 -- Inc_Usage (A.Target);
6405 Make_Procedure_Call_Statement
(Loc
,
6406 Name
=> New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6407 Parameter_Associations
=> New_List
(
6408 Make_Selected_Component
(Loc
,
6410 Unchecked_Convert_To
6411 (RTE
(RE_RAS_Proxy_Type_Access
),
6412 New_Occurrence_Of
(Local_Addr
, Loc
)),
6414 Make_Identifier
(Loc
, Name_Target
)))))),
6416 -- if not All_Calls_Remote then
6417 -- return Fat_Type!(A);
6420 Make_Implicit_If_Statement
(N
,
6424 New_Occurrence_Of
(All_Calls_Remote
, Loc
)),
6426 Then_Statements
=> New_List
(
6427 Make_Simple_Return_Statement
(Loc
,
6429 Unchecked_Convert_To
6430 (Fat_Type
, New_Occurrence_Of
(Local_Addr
, Loc
))))))));
6432 Append_List_To
(Proc_Statements
, New_List
(
6434 -- Stub.Target := Entity_Of (Ref);
6436 Set_Field
(Name_Target
,
6437 Make_Function_Call
(Loc
,
6438 Name
=> New_Occurrence_Of
(RTE
(RE_Entity_Of
), Loc
),
6439 Parameter_Associations
=> New_List
(
6440 New_Occurrence_Of
(Subp_Ref
, Loc
)))),
6442 -- Inc_Usage (Stub.Target);
6444 Make_Procedure_Call_Statement
(Loc
,
6445 Name
=> New_Occurrence_Of
(RTE
(RE_Inc_Usage
), Loc
),
6446 Parameter_Associations
=> New_List
(
6447 Make_Selected_Component
(Loc
,
6449 Selector_Name
=> Name_Target
))),
6451 -- E.4.1(9) A remote call is asynchronous if it is a call to
6452 -- a procedure, or a call through a value of an access-to-procedure
6453 -- type, to which a pragma Asynchronous applies.
6455 -- Parameter Asynch_P is true when the procedure is asynchronous;
6456 -- Expression Asynch_T is true when the type is asynchronous.
6458 Set_Field
(Name_Asynchronous
,
6460 Left_Opnd
=> New_Occurrence_Of
(Asynch_P
, Loc
),
6463 (Boolean_Literals
(Is_Asynchronous
(Ras_Type
)), Loc
)))));
6465 Append_List_To
(Proc_Statements
,
6466 Build_Get_Unique_RP_Call
(Loc
, Stub_Ptr
, Stub_Elements
.Stub_Type
));
6468 Append_To
(Proc_Statements
,
6469 Make_Simple_Return_Statement
(Loc
,
6471 Unchecked_Convert_To
(Fat_Type
,
6472 New_Occurrence_Of
(Stub_Ptr
, Loc
))));
6475 Make_Function_Specification
(Loc
,
6476 Defining_Unit_Name
=> Proc
,
6477 Parameter_Specifications
=> New_List
(
6478 Make_Parameter_Specification
(Loc
,
6479 Defining_Identifier
=> Package_Name
,
6481 New_Occurrence_Of
(Standard_String
, Loc
)),
6483 Make_Parameter_Specification
(Loc
,
6484 Defining_Identifier
=> Subp_Id
,
6486 New_Occurrence_Of
(Standard_String
, Loc
)),
6488 Make_Parameter_Specification
(Loc
,
6489 Defining_Identifier
=> Asynch_P
,
6491 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
6493 Make_Parameter_Specification
(Loc
,
6494 Defining_Identifier
=> All_Calls_Remote
,
6496 New_Occurrence_Of
(Standard_Boolean
, Loc
))),
6498 Result_Definition
=>
6499 New_Occurrence_Of
(Fat_Type
, Loc
));
6501 -- Set the kind and return type of the function to prevent
6502 -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
6504 Set_Ekind
(Proc
, E_Function
);
6505 Set_Etype
(Proc
, Fat_Type
);
6508 Make_Subprogram_Body
(Loc
,
6509 Specification
=> Proc_Spec
,
6510 Declarations
=> Proc_Decls
,
6511 Handled_Statement_Sequence
=>
6512 Make_Handled_Sequence_Of_Statements
(Loc
,
6513 Statements
=> Proc_Statements
)));
6515 Set_TSS
(Fat_Type
, Proc
);
6516 end Add_RAS_Access_TSS
;
6518 ----------------------
6519 -- Add_RAS_From_Any --
6520 ----------------------
6522 procedure Add_RAS_From_Any
(RAS_Type
: Entity_Id
) is
6523 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6525 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6526 Make_TSS_Name
(RAS_Type
, TSS_From_Any
));
6528 Func_Spec
: Node_Id
;
6530 Statements
: List_Id
;
6532 Any_Parameter
: constant Entity_Id
:=
6533 Make_Defining_Identifier
(Loc
, Name_A
);
6536 Statements
:= New_List
(
6537 Make_Simple_Return_Statement
(Loc
,
6539 Make_Aggregate
(Loc
,
6540 Component_Associations
=> New_List
(
6541 Make_Component_Association
(Loc
,
6542 Choices
=> New_List
(Make_Identifier
(Loc
, Name_Ras
)),
6544 PolyORB_Support
.Helpers
.Build_From_Any_Call
(
6545 Underlying_RACW_Type
(RAS_Type
),
6546 New_Occurrence_Of
(Any_Parameter
, Loc
),
6550 Make_Function_Specification
(Loc
,
6551 Defining_Unit_Name
=> Fnam
,
6552 Parameter_Specifications
=> New_List
(
6553 Make_Parameter_Specification
(Loc
,
6554 Defining_Identifier
=> Any_Parameter
,
6555 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
6556 Result_Definition
=> New_Occurrence_Of
(RAS_Type
, Loc
));
6559 Make_Subprogram_Body
(Loc
,
6560 Specification
=> Func_Spec
,
6561 Declarations
=> No_List
,
6562 Handled_Statement_Sequence
=>
6563 Make_Handled_Sequence_Of_Statements
(Loc
,
6564 Statements
=> Statements
)));
6565 Set_TSS
(RAS_Type
, Fnam
);
6566 end Add_RAS_From_Any
;
6568 --------------------
6569 -- Add_RAS_To_Any --
6570 --------------------
6572 procedure Add_RAS_To_Any
(RAS_Type
: Entity_Id
) is
6573 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6575 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6576 Make_TSS_Name
(RAS_Type
, TSS_To_Any
));
6579 Statements
: List_Id
;
6581 Func_Spec
: Node_Id
;
6583 Any
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
6584 RAS_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
6585 RACW_Parameter
: constant Node_Id
:=
6586 Make_Selected_Component
(Loc
,
6587 Prefix
=> RAS_Parameter
,
6588 Selector_Name
=> Name_Ras
);
6591 -- Object declarations
6593 Set_Etype
(RACW_Parameter
, Underlying_RACW_Type
(RAS_Type
));
6595 Make_Object_Declaration
(Loc
,
6596 Defining_Identifier
=> Any
,
6597 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
6599 PolyORB_Support
.Helpers
.Build_To_Any_Call
6600 (RACW_Parameter
, No_List
)));
6602 Statements
:= New_List
(
6603 Make_Procedure_Call_Statement
(Loc
,
6604 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
6605 Parameter_Associations
=> New_List
(
6606 New_Occurrence_Of
(Any
, Loc
),
6607 PolyORB_Support
.Helpers
.Build_TypeCode_Call
(Loc
,
6610 Make_Simple_Return_Statement
(Loc
,
6611 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
6614 Make_Function_Specification
(Loc
,
6615 Defining_Unit_Name
=> Fnam
,
6616 Parameter_Specifications
=> New_List
(
6617 Make_Parameter_Specification
(Loc
,
6618 Defining_Identifier
=> RAS_Parameter
,
6619 Parameter_Type
=> New_Occurrence_Of
(RAS_Type
, Loc
))),
6620 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
6623 Make_Subprogram_Body
(Loc
,
6624 Specification
=> Func_Spec
,
6625 Declarations
=> Decls
,
6626 Handled_Statement_Sequence
=>
6627 Make_Handled_Sequence_Of_Statements
(Loc
,
6628 Statements
=> Statements
)));
6629 Set_TSS
(RAS_Type
, Fnam
);
6632 ----------------------
6633 -- Add_RAS_TypeCode --
6634 ----------------------
6636 procedure Add_RAS_TypeCode
(RAS_Type
: Entity_Id
) is
6637 Loc
: constant Source_Ptr
:= Sloc
(RAS_Type
);
6639 Fnam
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
,
6640 Make_TSS_Name
(RAS_Type
, TSS_TypeCode
));
6642 Func_Spec
: Node_Id
;
6643 Decls
: constant List_Id
:= New_List
;
6644 Name_String
: String_Id
;
6645 Repo_Id_String
: String_Id
;
6649 Make_Function_Specification
(Loc
,
6650 Defining_Unit_Name
=> Fnam
,
6651 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
6653 PolyORB_Support
.Helpers
.Build_Name_And_Repository_Id
6654 (RAS_Type
, Name_Str
=> Name_String
, Repo_Id_Str
=> Repo_Id_String
);
6657 Make_Subprogram_Body
(Loc
,
6658 Specification
=> Func_Spec
,
6659 Declarations
=> Decls
,
6660 Handled_Statement_Sequence
=>
6661 Make_Handled_Sequence_Of_Statements
(Loc
,
6662 Statements
=> New_List
(
6663 Make_Simple_Return_Statement
(Loc
,
6665 Make_Function_Call
(Loc
,
6666 Name
=> New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
6667 Parameter_Associations
=> New_List
(
6668 New_Occurrence_Of
(RTE
(RE_TC_Object
), Loc
),
6669 Make_Aggregate
(Loc
,
6672 Make_Function_Call
(Loc
,
6675 (RTE
(RE_TA_Std_String
), Loc
),
6676 Parameter_Associations
=> New_List
(
6677 Make_String_Literal
(Loc
, Name_String
))),
6678 Make_Function_Call
(Loc
,
6681 (RTE
(RE_TA_Std_String
), Loc
),
6682 Parameter_Associations
=> New_List
(
6683 Make_String_Literal
(Loc
,
6684 Strval
=> Repo_Id_String
))))))))))));
6685 Set_TSS
(RAS_Type
, Fnam
);
6686 end Add_RAS_TypeCode
;
6688 -----------------------------------------
6689 -- Add_Receiving_Stubs_To_Declarations --
6690 -----------------------------------------
6692 procedure Add_Receiving_Stubs_To_Declarations
6693 (Pkg_Spec
: Node_Id
;
6697 Loc
: constant Source_Ptr
:= Sloc
(Pkg_Spec
);
6699 Pkg_RPC_Receiver
: constant Entity_Id
:=
6700 Make_Temporary
(Loc
, 'H');
6701 Pkg_RPC_Receiver_Object
: Node_Id
;
6702 Pkg_RPC_Receiver_Body
: Node_Id
;
6703 Pkg_RPC_Receiver_Decls
: List_Id
;
6704 Pkg_RPC_Receiver_Statements
: List_Id
;
6706 Pkg_RPC_Receiver_Cases
: constant List_Id
:= New_List
;
6707 -- A Pkg_RPC_Receiver is built to decode the request
6710 -- Request object received from neutral layer
6712 Subp_Id
: Entity_Id
;
6713 -- Subprogram identifier as received from the neutral distribution
6716 Subp_Index
: Entity_Id
;
6717 -- Internal index as determined by matching either the method name
6718 -- from the request structure, or the local subprogram address (in
6721 Is_Local
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
6723 Local_Address
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
6724 -- Address of a local subprogram designated by a reference
6725 -- corresponding to a RAS.
6727 Dispatch_On_Address
: constant List_Id
:= New_List
;
6728 Dispatch_On_Name
: constant List_Id
:= New_List
;
6730 Current_Subp_Number
: Int
:= First_RCI_Subprogram_Id
;
6732 Subp_Info_Array
: constant Entity_Id
:= Make_Temporary
(Loc
, 'I');
6733 Subp_Info_List
: constant List_Id
:= New_List
;
6735 Register_Pkg_Actuals
: constant List_Id
:= New_List
;
6737 All_Calls_Remote_E
: Entity_Id
;
6739 procedure Append_Stubs_To
6740 (RPC_Receiver_Cases
: List_Id
;
6741 Declaration
: Node_Id
;
6744 Subp_Dist_Name
: Entity_Id
;
6745 Subp_Proxy_Addr
: Entity_Id
);
6746 -- Add one case to the specified RPC receiver case list associating
6747 -- Subprogram_Number with the subprogram declared by Declaration, for
6748 -- which we have receiving stubs in Stubs. Subp_Number is an internal
6749 -- subprogram index. Subp_Dist_Name is the string used to call the
6750 -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
6751 -- object, used in the context of calls through remote
6752 -- access-to-subprogram types.
6754 procedure Visit_Subprogram
(Decl
: Node_Id
);
6755 -- Generate receiving stub for one remote subprogram
6757 ---------------------
6758 -- Append_Stubs_To --
6759 ---------------------
6761 procedure Append_Stubs_To
6762 (RPC_Receiver_Cases
: List_Id
;
6763 Declaration
: Node_Id
;
6766 Subp_Dist_Name
: Entity_Id
;
6767 Subp_Proxy_Addr
: Entity_Id
)
6769 Case_Stmts
: List_Id
;
6771 Case_Stmts
:= New_List
(
6772 Make_Procedure_Call_Statement
(Loc
,
6775 Defining_Entity
(Stubs
), Loc
),
6776 Parameter_Associations
=>
6777 New_List
(New_Occurrence_Of
(Request
, Loc
))));
6779 if Nkind
(Specification
(Declaration
)) = N_Function_Specification
6781 Is_Asynchronous
(Defining_Entity
(Specification
(Declaration
)))
6783 Append_To
(Case_Stmts
, Make_Simple_Return_Statement
(Loc
));
6786 Append_To
(RPC_Receiver_Cases
,
6787 Make_Case_Statement_Alternative
(Loc
,
6789 New_List
(Make_Integer_Literal
(Loc
, Subp_Number
)),
6790 Statements
=> Case_Stmts
));
6792 Append_To
(Dispatch_On_Name
,
6793 Make_Elsif_Part
(Loc
,
6795 Make_Function_Call
(Loc
,
6797 New_Occurrence_Of
(RTE
(RE_Caseless_String_Eq
), Loc
),
6798 Parameter_Associations
=> New_List
(
6799 New_Occurrence_Of
(Subp_Id
, Loc
),
6800 New_Occurrence_Of
(Subp_Dist_Name
, Loc
))),
6802 Then_Statements
=> New_List
(
6803 Make_Assignment_Statement
(Loc
,
6804 New_Occurrence_Of
(Subp_Index
, Loc
),
6805 Make_Integer_Literal
(Loc
, Subp_Number
)))));
6807 Append_To
(Dispatch_On_Address
,
6808 Make_Elsif_Part
(Loc
,
6811 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
6812 Right_Opnd
=> New_Occurrence_Of
(Subp_Proxy_Addr
, Loc
)),
6814 Then_Statements
=> New_List
(
6815 Make_Assignment_Statement
(Loc
,
6816 New_Occurrence_Of
(Subp_Index
, Loc
),
6817 Make_Integer_Literal
(Loc
, Subp_Number
)))));
6818 end Append_Stubs_To
;
6820 ----------------------
6821 -- Visit_Subprogram --
6822 ----------------------
6824 procedure Visit_Subprogram
(Decl
: Node_Id
) is
6825 Loc
: constant Source_Ptr
:= Sloc
(Decl
);
6826 Spec
: constant Node_Id
:= Specification
(Decl
);
6827 Subp_Def
: constant Entity_Id
:= Defining_Unit_Name
(Spec
);
6829 Subp_Val
: String_Id
;
6831 Subp_Dist_Name
: constant Entity_Id
:=
6832 Make_Defining_Identifier
(Loc
,
6835 (Related_Id
=> Chars
(Subp_Def
),
6837 Suffix_Index
=> -1));
6839 Current_Stubs
: Node_Id
;
6840 Proxy_Obj_Addr
: Entity_Id
;
6843 -- Build receiving stub
6846 Build_Subprogram_Receiving_Stubs
6848 Asynchronous
=> Nkind
(Spec
) = N_Procedure_Specification
6849 and then Is_Asynchronous
(Subp_Def
));
6851 Append_To
(Decls
, Current_Stubs
);
6852 Analyze
(Current_Stubs
);
6856 Add_RAS_Proxy_And_Analyze
(Decls
,
6858 All_Calls_Remote_E
=> All_Calls_Remote_E
,
6859 Proxy_Object_Addr
=> Proxy_Obj_Addr
);
6861 -- Compute distribution identifier
6863 Assign_Subprogram_Identifier
6864 (Subp_Def
, Current_Subp_Number
, Subp_Val
);
6867 (Current_Subp_Number
= Get_Subprogram_Id
(Subp_Def
));
6870 Make_Object_Declaration
(Loc
,
6871 Defining_Identifier
=> Subp_Dist_Name
,
6872 Constant_Present
=> True,
6873 Object_Definition
=>
6874 New_Occurrence_Of
(Standard_String
, Loc
),
6876 Make_String_Literal
(Loc
, Subp_Val
)));
6877 Analyze
(Last
(Decls
));
6879 -- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
6880 -- table for this receiver. The aggregate below must be kept
6881 -- consistent with the declaration of RCI_Subp_Info in
6882 -- System.Partition_Interface.
6884 Append_To
(Subp_Info_List
,
6885 Make_Component_Association
(Loc
,
6887 New_List
(Make_Integer_Literal
(Loc
, Current_Subp_Number
)),
6890 Make_Aggregate
(Loc
,
6891 Expressions
=> New_List
(
6895 Make_Attribute_Reference
(Loc
,
6897 New_Occurrence_Of
(Subp_Dist_Name
, Loc
),
6898 Attribute_Name
=> Name_Address
),
6902 Make_Attribute_Reference
(Loc
,
6904 New_Occurrence_Of
(Subp_Dist_Name
, Loc
),
6905 Attribute_Name
=> Name_Length
),
6909 New_Occurrence_Of
(Proxy_Obj_Addr
, Loc
)))));
6911 Append_Stubs_To
(Pkg_RPC_Receiver_Cases
,
6912 Declaration
=> Decl
,
6913 Stubs
=> Current_Stubs
,
6914 Subp_Number
=> Current_Subp_Number
,
6915 Subp_Dist_Name
=> Subp_Dist_Name
,
6916 Subp_Proxy_Addr
=> Proxy_Obj_Addr
);
6918 Current_Subp_Number
:= Current_Subp_Number
+ 1;
6919 end Visit_Subprogram
;
6921 procedure Visit_Spec
is new Build_Package_Stubs
(Visit_Subprogram
);
6923 -- Start of processing for Add_Receiving_Stubs_To_Declarations
6926 -- Building receiving stubs consist in several operations:
6928 -- - a package RPC receiver must be built. This subprogram will get
6929 -- a Subprogram_Id from the incoming stream and will dispatch the
6930 -- call to the right subprogram;
6932 -- - a receiving stub for each subprogram visible in the package
6933 -- spec. This stub will read all the parameters from the stream,
6934 -- and put the result as well as the exception occurrence in the
6937 Build_RPC_Receiver_Body
(
6938 RPC_Receiver
=> Pkg_RPC_Receiver
,
6941 Subp_Index
=> Subp_Index
,
6942 Stmts
=> Pkg_RPC_Receiver_Statements
,
6943 Decl
=> Pkg_RPC_Receiver_Body
);
6944 Pkg_RPC_Receiver_Decls
:= Declarations
(Pkg_RPC_Receiver_Body
);
6946 -- Extract local address information from the target reference:
6947 -- if non-null, that means that this is a reference that denotes
6948 -- one particular operation, and hence that the operation name
6949 -- must not be taken into account for dispatching.
6951 Append_To
(Pkg_RPC_Receiver_Decls
,
6952 Make_Object_Declaration
(Loc
,
6953 Defining_Identifier
=> Is_Local
,
6954 Object_Definition
=>
6955 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
6957 Append_To
(Pkg_RPC_Receiver_Decls
,
6958 Make_Object_Declaration
(Loc
,
6959 Defining_Identifier
=> Local_Address
,
6960 Object_Definition
=>
6961 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6963 Append_To
(Pkg_RPC_Receiver_Statements
,
6964 Make_Procedure_Call_Statement
(Loc
,
6965 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
6966 Parameter_Associations
=> New_List
(
6967 Make_Selected_Component
(Loc
,
6969 Selector_Name
=> Name_Target
),
6970 New_Occurrence_Of
(Is_Local
, Loc
),
6971 New_Occurrence_Of
(Local_Address
, Loc
))));
6973 -- For each subprogram, the receiving stub will be built and a case
6974 -- statement will be made on the Subprogram_Id to dispatch to the
6975 -- right subprogram.
6977 All_Calls_Remote_E
:= Boolean_Literals
(
6978 Has_All_Calls_Remote
(Defining_Entity
(Pkg_Spec
)));
6980 Overload_Counter_Table
.Reset
;
6981 Reserve_NamingContext_Methods
;
6983 Visit_Spec
(Pkg_Spec
);
6986 Make_Object_Declaration
(Loc
,
6987 Defining_Identifier
=> Subp_Info_Array
,
6988 Constant_Present
=> True,
6989 Aliased_Present
=> True,
6990 Object_Definition
=>
6991 Make_Subtype_Indication
(Loc
,
6993 New_Occurrence_Of
(RTE
(RE_RCI_Subp_Info_Array
), Loc
),
6995 Make_Index_Or_Discriminant_Constraint
(Loc
,
6999 Make_Integer_Literal
(Loc
,
7000 Intval
=> First_RCI_Subprogram_Id
),
7002 Make_Integer_Literal
(Loc
,
7004 First_RCI_Subprogram_Id
7005 + List_Length
(Subp_Info_List
) - 1)))))));
7007 if Present
(First
(Subp_Info_List
)) then
7008 Set_Expression
(Last
(Decls
),
7009 Make_Aggregate
(Loc
,
7010 Component_Associations
=> Subp_Info_List
));
7012 -- Generate the dispatch statement to determine the subprogram id
7013 -- of the called subprogram.
7015 -- We first test whether the reference that was used to make the
7016 -- call was the base RCI reference (in which case Local_Address is
7017 -- zero, and the method identifier from the request must be used
7018 -- to determine which subprogram is called) or a reference
7019 -- identifying one particular subprogram (in which case
7020 -- Local_Address is the address of that subprogram, and the
7021 -- method name from the request is ignored). The latter occurs
7022 -- for the case of a call through a remote access-to-subprogram.
7024 -- In each case, cascaded elsifs are used to determine the proper
7025 -- subprogram index. Using hash tables might be more efficient.
7027 Append_To
(Pkg_RPC_Receiver_Statements
,
7028 Make_Implicit_If_Statement
(Pkg_Spec
,
7031 Left_Opnd
=> New_Occurrence_Of
(Local_Address
, Loc
),
7032 Right_Opnd
=> New_Occurrence_Of
7033 (RTE
(RE_Null_Address
), Loc
)),
7035 Then_Statements
=> New_List
(
7036 Make_Implicit_If_Statement
(Pkg_Spec
,
7037 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
7038 Then_Statements
=> New_List
(
7039 Make_Null_Statement
(Loc
)),
7040 Elsif_Parts
=> Dispatch_On_Address
)),
7042 Else_Statements
=> New_List
(
7043 Make_Implicit_If_Statement
(Pkg_Spec
,
7044 Condition
=> New_Occurrence_Of
(Standard_False
, Loc
),
7045 Then_Statements
=> New_List
(Make_Null_Statement
(Loc
)),
7046 Elsif_Parts
=> Dispatch_On_Name
))));
7049 -- For a degenerate RCI with no visible subprograms,
7050 -- Subp_Info_List has zero length, and the declaration is for an
7051 -- empty array, in which case no initialization aggregate must be
7052 -- generated. We do not generate a Dispatch_Statement either.
7054 -- No initialization provided: remove CONSTANT so that the
7055 -- declaration is not an incomplete deferred constant.
7057 Set_Constant_Present
(Last
(Decls
), False);
7060 -- Analyze Subp_Info_Array declaration
7062 Analyze
(Last
(Decls
));
7064 -- If we receive an invalid Subprogram_Id, it is best to do nothing
7065 -- rather than raising an exception since we do not want someone
7066 -- to crash a remote partition by sending invalid subprogram ids.
7067 -- This is consistent with the other parts of the case statement
7068 -- since even in presence of incorrect parameters in the stream,
7069 -- every exception will be caught and (if the subprogram is not an
7070 -- APC) put into the result stream and sent away.
7072 Append_To
(Pkg_RPC_Receiver_Cases
,
7073 Make_Case_Statement_Alternative
(Loc
,
7074 Discrete_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
7075 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
7077 Append_To
(Pkg_RPC_Receiver_Statements
,
7078 Make_Case_Statement
(Loc
,
7079 Expression
=> New_Occurrence_Of
(Subp_Index
, Loc
),
7080 Alternatives
=> Pkg_RPC_Receiver_Cases
));
7082 -- Pkg_RPC_Receiver body is now complete: insert it into the tree and
7085 Append_To
(Decls
, Pkg_RPC_Receiver_Body
);
7086 Analyze
(Last
(Decls
));
7088 Pkg_RPC_Receiver_Object
:=
7089 Make_Object_Declaration
(Loc
,
7090 Defining_Identifier
=> Make_Temporary
(Loc
, 'R'),
7091 Aliased_Present
=> True,
7092 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7093 Append_To
(Decls
, Pkg_RPC_Receiver_Object
);
7094 Analyze
(Last
(Decls
));
7096 Get_Library_Unit_Name_String
(Pkg_Spec
);
7100 Append_To
(Register_Pkg_Actuals
,
7101 Make_String_Literal
(Loc
,
7102 Strval
=> String_From_Name_Buffer
));
7106 Append_To
(Register_Pkg_Actuals
,
7107 Make_Attribute_Reference
(Loc
,
7110 (Defining_Entity
(Pkg_Spec
), Loc
),
7111 Attribute_Name
=> Name_Version
));
7115 Append_To
(Register_Pkg_Actuals
,
7116 Make_Attribute_Reference
(Loc
,
7118 New_Occurrence_Of
(Pkg_RPC_Receiver
, Loc
),
7119 Attribute_Name
=> Name_Access
));
7123 Append_To
(Register_Pkg_Actuals
,
7124 Make_Attribute_Reference
(Loc
,
7127 Defining_Identifier
(Pkg_RPC_Receiver_Object
), Loc
),
7128 Attribute_Name
=> Name_Access
));
7132 Append_To
(Register_Pkg_Actuals
,
7133 Make_Attribute_Reference
(Loc
,
7134 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7135 Attribute_Name
=> Name_Address
));
7139 Append_To
(Register_Pkg_Actuals
,
7140 Make_Attribute_Reference
(Loc
,
7141 Prefix
=> New_Occurrence_Of
(Subp_Info_Array
, Loc
),
7142 Attribute_Name
=> Name_Length
));
7144 -- Is_All_Calls_Remote
7146 Append_To
(Register_Pkg_Actuals
,
7147 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
));
7149 -- Finally call Register_Pkg_Receiving_Stub with the above parameters
7152 Make_Procedure_Call_Statement
(Loc
,
7154 New_Occurrence_Of
(RTE
(RE_Register_Pkg_Receiving_Stub
), Loc
),
7155 Parameter_Associations
=> Register_Pkg_Actuals
));
7156 Analyze
(Last
(Stmts
));
7157 end Add_Receiving_Stubs_To_Declarations
;
7159 ---------------------------------
7160 -- Build_General_Calling_Stubs --
7161 ---------------------------------
7163 procedure Build_General_Calling_Stubs
7165 Statements
: List_Id
;
7166 Target_Object
: Node_Id
;
7167 Subprogram_Id
: Node_Id
;
7168 Asynchronous
: Node_Id
:= Empty
;
7169 Is_Known_Asynchronous
: Boolean := False;
7170 Is_Known_Non_Asynchronous
: Boolean := False;
7171 Is_Function
: Boolean;
7173 Stub_Type
: Entity_Id
:= Empty
;
7174 RACW_Type
: Entity_Id
:= Empty
;
7177 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
7179 Request
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
7180 -- The request object constructed by these stubs
7181 -- Could we use Name_R instead??? (see GLADE client stubs)
7183 function Make_Request_RTE_Call
7185 Actuals
: List_Id
:= New_List
) return Node_Id
;
7186 -- Generate a procedure call statement calling RE with the given
7187 -- actuals. Request'Access is appended to the list.
7189 ---------------------------
7190 -- Make_Request_RTE_Call --
7191 ---------------------------
7193 function Make_Request_RTE_Call
7195 Actuals
: List_Id
:= New_List
) return Node_Id
7199 Make_Attribute_Reference
(Loc
,
7200 Prefix
=> New_Occurrence_Of
(Request
, Loc
),
7201 Attribute_Name
=> Name_Access
));
7202 return Make_Procedure_Call_Statement
(Loc
,
7204 New_Occurrence_Of
(RTE
(RE
), Loc
),
7205 Parameter_Associations
=> Actuals
);
7206 end Make_Request_RTE_Call
;
7208 Arguments
: Node_Id
;
7209 -- Name of the named values list used to transmit parameters
7210 -- to the remote package
7213 -- Name of the result named value (in non-APC cases) which get the
7214 -- result of the remote subprogram.
7216 Result_TC
: Node_Id
;
7217 -- Typecode expression for the result of the request (void
7218 -- typecode for procedures).
7220 Exception_Return_Parameter
: Node_Id
;
7221 -- Name of the parameter which will hold the exception sent by the
7222 -- remote subprogram.
7224 Current_Parameter
: Node_Id
;
7225 -- Current parameter being handled
7227 Ordered_Parameters_List
: constant List_Id
:=
7228 Build_Ordered_Parameters_List
(Spec
);
7230 Asynchronous_P
: Node_Id
;
7231 -- A Boolean expression indicating whether this call is asynchronous
7233 Asynchronous_Statements
: List_Id
:= No_List
;
7234 Non_Asynchronous_Statements
: List_Id
:= No_List
;
7235 -- Statements specifics to the Asynchronous/Non-Asynchronous cases
7237 Extra_Formal_Statements
: constant List_Id
:= New_List
;
7238 -- List of statements for extra formal parameters. It will appear
7239 -- after the regular statements for writing out parameters.
7241 After_Statements
: constant List_Id
:= New_List
;
7242 -- Statements to be executed after call returns (to assign IN OUT or
7243 -- OUT parameter values).
7246 -- The type of the formal parameter being processed
7248 Is_Controlling_Formal
: Boolean;
7249 Is_First_Controlling_Formal
: Boolean;
7250 First_Controlling_Formal_Seen
: Boolean := False;
7251 -- Controlling formal parameters of distributed object primitives
7252 -- require special handling, and the first such parameter needs even
7253 -- more special handling.
7256 -- ??? document general form of stub subprograms for the PolyORB case
7259 Make_Object_Declaration
(Loc
,
7260 Defining_Identifier
=> Request
,
7261 Aliased_Present
=> True,
7262 Object_Definition
=>
7263 New_Occurrence_Of
(RTE
(RE_Request
), Loc
)));
7265 Result
:= Make_Temporary
(Loc
, 'R');
7269 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7270 (Loc
, Etype
(Result_Definition
(Spec
)), Decls
);
7272 Result_TC
:= New_Occurrence_Of
(RTE
(RE_TC_Void
), Loc
);
7276 Make_Object_Declaration
(Loc
,
7277 Defining_Identifier
=> Result
,
7278 Aliased_Present
=> False,
7279 Object_Definition
=>
7280 New_Occurrence_Of
(RTE
(RE_NamedValue
), Loc
),
7282 Make_Aggregate
(Loc
,
7283 Component_Associations
=> New_List
(
7284 Make_Component_Association
(Loc
,
7285 Choices
=> New_List
(Make_Identifier
(Loc
, Name_Name
)),
7287 New_Occurrence_Of
(RTE
(RE_Result_Name
), Loc
)),
7288 Make_Component_Association
(Loc
,
7289 Choices
=> New_List
(
7290 Make_Identifier
(Loc
, Name_Argument
)),
7292 Make_Function_Call
(Loc
,
7293 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7294 Parameter_Associations
=> New_List
(Result_TC
))),
7295 Make_Component_Association
(Loc
,
7296 Choices
=> New_List
(
7297 Make_Identifier
(Loc
, Name_Arg_Modes
)),
7298 Expression
=> Make_Integer_Literal
(Loc
, 0))))));
7300 if not Is_Known_Asynchronous
then
7301 Exception_Return_Parameter
:= Make_Temporary
(Loc
, 'E');
7304 Make_Object_Declaration
(Loc
,
7305 Defining_Identifier
=> Exception_Return_Parameter
,
7306 Object_Definition
=>
7307 New_Occurrence_Of
(RTE
(RE_Exception_Occurrence
), Loc
)));
7310 Exception_Return_Parameter
:= Empty
;
7313 -- Initialize and fill in arguments list
7315 Arguments
:= Make_Temporary
(Loc
, 'A');
7316 Declare_Create_NVList
(Loc
, Arguments
, Decls
, Statements
);
7318 Current_Parameter
:= First
(Ordered_Parameters_List
);
7319 while Present
(Current_Parameter
) loop
7320 if Is_RACW_Controlling_Formal
(Current_Parameter
, Stub_Type
) then
7321 Is_Controlling_Formal
:= True;
7322 Is_First_Controlling_Formal
:=
7323 not First_Controlling_Formal_Seen
;
7324 First_Controlling_Formal_Seen
:= True;
7327 Is_Controlling_Formal
:= False;
7328 Is_First_Controlling_Formal
:= False;
7331 if Is_Controlling_Formal
then
7333 -- For a controlling formal argument, we send its reference
7338 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7341 -- The first controlling formal parameter is treated specially:
7342 -- it is used to set the target object of the call.
7344 if not Is_First_Controlling_Formal
then
7346 Constrained
: constant Boolean :=
7347 Is_Constrained
(Etyp
)
7348 or else Is_Elementary_Type
(Etyp
);
7350 Any
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
7352 Actual_Parameter
: Node_Id
:=
7354 Defining_Identifier
(
7355 Current_Parameter
), Loc
);
7360 if Is_Controlling_Formal
then
7362 -- For a controlling formal parameter (other than the
7363 -- first one), use the corresponding RACW. If the
7364 -- parameter is not an anonymous access parameter, that
7365 -- involves taking its 'Unrestricted_Access.
7367 if Nkind
(Parameter_Type
(Current_Parameter
))
7368 = N_Access_Definition
7370 Actual_Parameter
:= OK_Convert_To
7371 (Etyp
, Actual_Parameter
);
7373 Actual_Parameter
:= OK_Convert_To
(Etyp
,
7374 Make_Attribute_Reference
(Loc
,
7375 Prefix
=> Actual_Parameter
,
7376 Attribute_Name
=> Name_Unrestricted_Access
));
7381 if In_Present
(Current_Parameter
)
7382 or else not Out_Present
(Current_Parameter
)
7383 or else not Constrained
7384 or else Is_Controlling_Formal
7386 -- The parameter has an input value, is constrained at
7387 -- runtime by an input value, or is a controlling formal
7388 -- parameter (always passed as a reference) other than
7391 Expr
:= PolyORB_Support
.Helpers
.Build_To_Any_Call
7392 (Actual_Parameter
, Decls
);
7395 Expr
:= Make_Function_Call
(Loc
,
7396 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7397 Parameter_Associations
=> New_List
(
7398 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7399 (Loc
, Etyp
, Decls
)));
7403 Make_Object_Declaration
(Loc
,
7404 Defining_Identifier
=> Any
,
7405 Aliased_Present
=> False,
7406 Object_Definition
=>
7407 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7408 Expression
=> Expr
));
7410 Append_To
(Statements
,
7411 Add_Parameter_To_NVList
(Loc
,
7412 Parameter
=> Current_Parameter
,
7413 NVList
=> Arguments
,
7414 Constrained
=> Constrained
,
7417 if Out_Present
(Current_Parameter
)
7418 and then not Is_Controlling_Formal
7420 if Is_Limited_Type
(Etyp
) then
7421 Helpers
.Assign_Opaque_From_Any
(Loc
,
7422 Stms
=> After_Statements
,
7424 N
=> New_Occurrence_Of
(Any
, Loc
),
7426 Defining_Identifier
(Current_Parameter
));
7428 Append_To
(After_Statements
,
7429 Make_Assignment_Statement
(Loc
,
7432 Defining_Identifier
(Current_Parameter
), Loc
),
7434 PolyORB_Support
.Helpers
.Build_From_Any_Call
7436 New_Occurrence_Of
(Any
, Loc
),
7443 -- If the current parameter has a dynamic constrained status, then
7444 -- this status is transmitted as well.
7445 -- This should be done for accessibility as well ???
7447 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
7449 and then Need_Extra_Constrained
(Current_Parameter
)
7451 -- In this block, we do not use the extra formal that has been
7452 -- created because it does not exist at the time of expansion
7453 -- when building calling stubs for remote access to subprogram
7454 -- types. We create an extra variable of this type and push it
7455 -- in the stream after the regular parameters.
7458 Extra_Any_Parameter
: constant Entity_Id
:=
7459 Make_Temporary
(Loc
, 'P');
7461 Parameter_Exp
: constant Node_Id
:=
7462 Make_Attribute_Reference
(Loc
,
7463 Prefix
=> New_Occurrence_Of
(
7464 Defining_Identifier
(Current_Parameter
), Loc
),
7465 Attribute_Name
=> Name_Constrained
);
7468 Set_Etype
(Parameter_Exp
, Etype
(Standard_Boolean
));
7471 Make_Object_Declaration
(Loc
,
7472 Defining_Identifier
=> Extra_Any_Parameter
,
7473 Aliased_Present
=> False,
7474 Object_Definition
=>
7475 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7477 PolyORB_Support
.Helpers
.Build_To_Any_Call
7478 (Parameter_Exp
, Decls
)));
7480 Append_To
(Extra_Formal_Statements
,
7481 Add_Parameter_To_NVList
(Loc
,
7482 Parameter
=> Extra_Any_Parameter
,
7483 NVList
=> Arguments
,
7484 Constrained
=> True,
7485 Any
=> Extra_Any_Parameter
));
7489 Next
(Current_Parameter
);
7492 -- Append the formal statements list to the statements
7494 Append_List_To
(Statements
, Extra_Formal_Statements
);
7496 Append_To
(Statements
,
7497 Make_Procedure_Call_Statement
(Loc
,
7499 New_Occurrence_Of
(RTE
(RE_Request_Setup
), Loc
),
7500 Parameter_Associations
=> New_List
(
7501 New_Occurrence_Of
(Request
, Loc
),
7504 New_Occurrence_Of
(Arguments
, Loc
),
7505 New_Occurrence_Of
(Result
, Loc
),
7506 New_Occurrence_Of
(RTE
(RE_Nil_Exc_List
), Loc
))));
7509 (not (Is_Known_Non_Asynchronous
and Is_Known_Asynchronous
));
7511 if Is_Known_Non_Asynchronous
or Is_Known_Asynchronous
then
7514 (Boolean_Literals
(Is_Known_Asynchronous
), Loc
);
7517 pragma Assert
(Present
(Asynchronous
));
7518 Asynchronous_P
:= New_Copy_Tree
(Asynchronous
);
7520 -- The expression node Asynchronous will be used to build an 'if'
7521 -- statement at the end of Build_General_Calling_Stubs: we need to
7522 -- make a copy here.
7525 Append_To
(Parameter_Associations
(Last
(Statements
)),
7526 Make_Indexed_Component
(Loc
,
7529 RTE
(RE_Asynchronous_P_To_Sync_Scope
), Loc
),
7530 Expressions
=> New_List
(Asynchronous_P
)));
7532 Append_To
(Statements
, Make_Request_RTE_Call
(RE_Request_Invoke
));
7534 -- Asynchronous case
7536 if not Is_Known_Non_Asynchronous
then
7537 Asynchronous_Statements
:= New_List
(Make_Null_Statement
(Loc
));
7540 -- Non-asynchronous case
7542 if not Is_Known_Asynchronous
then
7543 -- Reraise an exception occurrence from the completed request.
7544 -- If the exception occurrence is empty, this is a no-op.
7546 Non_Asynchronous_Statements
:= New_List
(
7547 Make_Procedure_Call_Statement
(Loc
,
7549 New_Occurrence_Of
(RTE
(RE_Request_Raise_Occurrence
), Loc
),
7550 Parameter_Associations
=> New_List
(
7551 New_Occurrence_Of
(Request
, Loc
))));
7554 -- If this is a function call, read the value and return it
7556 Append_To
(Non_Asynchronous_Statements
,
7557 Make_Tag_Check
(Loc
,
7558 Make_Simple_Return_Statement
(Loc
,
7559 PolyORB_Support
.Helpers
.Build_From_Any_Call
7560 (Etype
(Result_Definition
(Spec
)),
7561 Make_Selected_Component
(Loc
,
7563 Selector_Name
=> Name_Argument
),
7568 -- Case of a procedure: deal with IN OUT and OUT formals
7570 Append_List_To
(Non_Asynchronous_Statements
, After_Statements
);
7574 if Is_Known_Asynchronous
then
7575 Append_List_To
(Statements
, Asynchronous_Statements
);
7577 elsif Is_Known_Non_Asynchronous
then
7578 Append_List_To
(Statements
, Non_Asynchronous_Statements
);
7581 pragma Assert
(Present
(Asynchronous
));
7582 Append_To
(Statements
,
7583 Make_Implicit_If_Statement
(Nod
,
7584 Condition
=> Asynchronous
,
7585 Then_Statements
=> Asynchronous_Statements
,
7586 Else_Statements
=> Non_Asynchronous_Statements
));
7588 end Build_General_Calling_Stubs
;
7590 -----------------------
7591 -- Build_Stub_Target --
7592 -----------------------
7594 function Build_Stub_Target
7597 RCI_Locator
: Entity_Id
;
7598 Controlling_Parameter
: Entity_Id
) return RPC_Target
7600 Target_Info
: RPC_Target
(PCS_Kind
=> Name_PolyORB_DSA
);
7601 Target_Reference
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
7604 if Present
(Controlling_Parameter
) then
7606 Make_Object_Declaration
(Loc
,
7607 Defining_Identifier
=> Target_Reference
,
7609 Object_Definition
=>
7610 New_Occurrence_Of
(RTE
(RE_Object_Ref
), Loc
),
7613 Make_Function_Call
(Loc
,
7615 New_Occurrence_Of
(RTE
(RE_Make_Ref
), Loc
),
7616 Parameter_Associations
=> New_List
(
7617 Make_Selected_Component
(Loc
,
7618 Prefix
=> Controlling_Parameter
,
7619 Selector_Name
=> Name_Target
)))));
7621 -- Note: Controlling_Parameter has the same components as
7622 -- System.Partition_Interface.RACW_Stub_Type.
7624 Target_Info
.Object
:= New_Occurrence_Of
(Target_Reference
, Loc
);
7627 Target_Info
.Object
:=
7628 Make_Selected_Component
(Loc
,
7630 Make_Identifier
(Loc
, Chars
(RCI_Locator
)),
7632 Make_Identifier
(Loc
, Name_Get_RCI_Package_Ref
));
7636 end Build_Stub_Target
;
7638 ---------------------
7639 -- Build_Stub_Type --
7640 ---------------------
7642 procedure Build_Stub_Type
7643 (RACW_Type
: Entity_Id
;
7644 Stub_Type_Comps
: out List_Id
;
7645 RPC_Receiver_Decl
: out Node_Id
)
7647 Loc
: constant Source_Ptr
:= Sloc
(RACW_Type
);
7650 Stub_Type_Comps
:= New_List
(
7651 Make_Component_Declaration
(Loc
,
7652 Defining_Identifier
=>
7653 Make_Defining_Identifier
(Loc
, Name_Target
),
7654 Component_Definition
=>
7655 Make_Component_Definition
(Loc
,
7656 Aliased_Present
=> False,
7657 Subtype_Indication
=>
7658 New_Occurrence_Of
(RTE
(RE_Entity_Ptr
), Loc
))),
7660 Make_Component_Declaration
(Loc
,
7661 Defining_Identifier
=>
7662 Make_Defining_Identifier
(Loc
, Name_Asynchronous
),
7664 Component_Definition
=>
7665 Make_Component_Definition
(Loc
,
7666 Aliased_Present
=> False,
7667 Subtype_Indication
=>
7668 New_Occurrence_Of
(Standard_Boolean
, Loc
))));
7670 RPC_Receiver_Decl
:=
7671 Make_Object_Declaration
(Loc
,
7672 Defining_Identifier
=> Make_Temporary
(Loc
, 'R'),
7673 Aliased_Present
=> True,
7674 Object_Definition
=>
7675 New_Occurrence_Of
(RTE
(RE_Servant
), Loc
));
7676 end Build_Stub_Type
;
7678 -----------------------------
7679 -- Build_RPC_Receiver_Body --
7680 -----------------------------
7682 procedure Build_RPC_Receiver_Body
7683 (RPC_Receiver
: Entity_Id
;
7684 Request
: out Entity_Id
;
7685 Subp_Id
: out Entity_Id
;
7686 Subp_Index
: out Entity_Id
;
7687 Stmts
: out List_Id
;
7690 Loc
: constant Source_Ptr
:= Sloc
(RPC_Receiver
);
7692 RPC_Receiver_Spec
: Node_Id
;
7693 RPC_Receiver_Decls
: List_Id
;
7696 Request
:= Make_Defining_Identifier
(Loc
, Name_R
);
7698 RPC_Receiver_Spec
:=
7699 Build_RPC_Receiver_Specification
7700 (RPC_Receiver
=> RPC_Receiver
,
7701 Request_Parameter
=> Request
);
7703 Subp_Id
:= Make_Defining_Identifier
(Loc
, Name_P
);
7704 Subp_Index
:= Make_Defining_Identifier
(Loc
, Name_I
);
7706 RPC_Receiver_Decls
:= New_List
(
7707 Make_Object_Renaming_Declaration
(Loc
,
7708 Defining_Identifier
=> Subp_Id
,
7709 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
7711 Make_Explicit_Dereference
(Loc
,
7713 Make_Selected_Component
(Loc
,
7715 Selector_Name
=> Name_Operation
))),
7717 Make_Object_Declaration
(Loc
,
7718 Defining_Identifier
=> Subp_Index
,
7719 Object_Definition
=>
7720 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7722 Make_Attribute_Reference
(Loc
,
7724 New_Occurrence_Of
(RTE
(RE_Subprogram_Id
), Loc
),
7725 Attribute_Name
=> Name_Last
)));
7730 Make_Subprogram_Body
(Loc
,
7731 Specification
=> RPC_Receiver_Spec
,
7732 Declarations
=> RPC_Receiver_Decls
,
7733 Handled_Statement_Sequence
=>
7734 Make_Handled_Sequence_Of_Statements
(Loc
,
7735 Statements
=> Stmts
));
7736 end Build_RPC_Receiver_Body
;
7738 --------------------------------------
7739 -- Build_Subprogram_Receiving_Stubs --
7740 --------------------------------------
7742 function Build_Subprogram_Receiving_Stubs
7743 (Vis_Decl
: Node_Id
;
7744 Asynchronous
: Boolean;
7745 Dynamically_Asynchronous
: Boolean := False;
7746 Stub_Type
: Entity_Id
:= Empty
;
7747 RACW_Type
: Entity_Id
:= Empty
;
7748 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
7750 Loc
: constant Source_Ptr
:= Sloc
(Vis_Decl
);
7752 Request_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
7753 -- Formal parameter for receiving stubs: a descriptor for an incoming
7756 Outer_Decls
: constant List_Id
:= New_List
;
7757 -- At the outermost level, an NVList and Any's are declared for all
7758 -- parameters. The Dynamic_Async flag also needs to be declared there
7759 -- to be visible from the exception handling code.
7761 Outer_Statements
: constant List_Id
:= New_List
;
7762 -- Statements that occur prior to the declaration of the actual
7763 -- parameter variables.
7765 Outer_Extra_Formal_Statements
: constant List_Id
:= New_List
;
7766 -- Statements concerning extra formal parameters, prior to the
7767 -- declaration of the actual parameter variables.
7769 Decls
: constant List_Id
:= New_List
;
7770 -- All the parameters will get declared before calling the real
7771 -- subprograms. Also the out parameters will be declared. At this
7772 -- level, parameters may be unconstrained.
7774 Statements
: constant List_Id
:= New_List
;
7776 After_Statements
: constant List_Id
:= New_List
;
7777 -- Statements to be executed after the subprogram call
7779 Inner_Decls
: List_Id
:= No_List
;
7780 -- In case of a function, the inner declarations are needed since
7781 -- the result may be unconstrained.
7783 Excep_Handlers
: List_Id
:= No_List
;
7785 Parameter_List
: constant List_Id
:= New_List
;
7786 -- List of parameters to be passed to the subprogram
7788 First_Controlling_Formal_Seen
: Boolean := False;
7790 Current_Parameter
: Node_Id
;
7792 Ordered_Parameters_List
: constant List_Id
:=
7793 Build_Ordered_Parameters_List
7794 (Specification
(Vis_Decl
));
7796 Arguments
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
7797 -- Name of the named values list used to retrieve parameters
7799 Subp_Spec
: Node_Id
;
7800 -- Subprogram specification
7802 Called_Subprogram
: Node_Id
;
7803 -- The subprogram to call
7806 if Present
(RACW_Type
) then
7807 Called_Subprogram
:=
7808 New_Occurrence_Of
(Parent_Primitive
, Loc
);
7810 Called_Subprogram
:=
7812 (Defining_Unit_Name
(Specification
(Vis_Decl
)), Loc
);
7815 Declare_Create_NVList
(Loc
, Arguments
, Outer_Decls
, Outer_Statements
);
7817 -- Loop through every parameter and get its value from the stream. If
7818 -- the parameter is unconstrained, then the parameter is read using
7819 -- 'Input at the point of declaration.
7821 Current_Parameter
:= First
(Ordered_Parameters_List
);
7822 while Present
(Current_Parameter
) loop
7825 Constrained
: Boolean;
7826 Any
: Entity_Id
:= Empty
;
7827 Object
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
7828 Expr
: Node_Id
:= Empty
;
7830 Is_Controlling_Formal
: constant Boolean :=
7831 Is_RACW_Controlling_Formal
7832 (Current_Parameter
, Stub_Type
);
7834 Is_First_Controlling_Formal
: Boolean := False;
7836 Need_Extra_Constrained
: Boolean;
7837 -- True when an extra constrained actual is required
7840 if Is_Controlling_Formal
then
7842 -- Controlling formals in distributed object primitive
7843 -- operations are handled specially:
7845 -- - the first controlling formal is used as the
7846 -- target of the call;
7848 -- - the remaining controlling formals are transmitted
7852 Is_First_Controlling_Formal
:=
7853 not First_Controlling_Formal_Seen
;
7854 First_Controlling_Formal_Seen
:= True;
7857 Etyp
:= Etype
(Parameter_Type
(Current_Parameter
));
7861 Is_Constrained
(Etyp
) or else Is_Elementary_Type
(Etyp
);
7863 if not Is_First_Controlling_Formal
then
7864 Any
:= Make_Temporary
(Loc
, 'A');
7866 Append_To
(Outer_Decls
,
7867 Make_Object_Declaration
(Loc
,
7868 Defining_Identifier
=> Any
,
7869 Object_Definition
=>
7870 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
7872 Make_Function_Call
(Loc
,
7873 Name
=> New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
7874 Parameter_Associations
=> New_List
(
7875 PolyORB_Support
.Helpers
.Build_TypeCode_Call
7876 (Loc
, Etyp
, Outer_Decls
)))));
7878 Append_To
(Outer_Statements
,
7879 Add_Parameter_To_NVList
(Loc
,
7880 Parameter
=> Current_Parameter
,
7881 NVList
=> Arguments
,
7882 Constrained
=> Constrained
,
7886 if Is_First_Controlling_Formal
then
7888 Addr
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
7890 Is_Local
: constant Entity_Id
:=
7891 Make_Temporary
(Loc
, 'L');
7894 -- Special case: obtain the first controlling formal
7895 -- from the target of the remote call, instead of the
7898 Append_To
(Outer_Decls
,
7899 Make_Object_Declaration
(Loc
,
7900 Defining_Identifier
=> Addr
,
7901 Object_Definition
=>
7902 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
7904 Append_To
(Outer_Decls
,
7905 Make_Object_Declaration
(Loc
,
7906 Defining_Identifier
=> Is_Local
,
7907 Object_Definition
=>
7908 New_Occurrence_Of
(Standard_Boolean
, Loc
)));
7910 Append_To
(Outer_Statements
,
7911 Make_Procedure_Call_Statement
(Loc
,
7913 New_Occurrence_Of
(RTE
(RE_Get_Local_Address
), Loc
),
7914 Parameter_Associations
=> New_List
(
7915 Make_Selected_Component
(Loc
,
7918 Request_Parameter
, Loc
),
7920 Make_Identifier
(Loc
, Name_Target
)),
7921 New_Occurrence_Of
(Is_Local
, Loc
),
7922 New_Occurrence_Of
(Addr
, Loc
))));
7924 Expr
:= Unchecked_Convert_To
(RACW_Type
,
7925 New_Occurrence_Of
(Addr
, Loc
));
7928 elsif In_Present
(Current_Parameter
)
7929 or else not Out_Present
(Current_Parameter
)
7930 or else not Constrained
7932 -- If an input parameter is constrained, then its reading is
7933 -- deferred until the beginning of the subprogram body. If
7934 -- it is unconstrained, then an expression is built for
7935 -- the object declaration and the variable is set using
7936 -- 'Input instead of 'Read.
7938 if Constrained
and then Is_Limited_Type
(Etyp
) then
7939 Helpers
.Assign_Opaque_From_Any
(Loc
,
7942 N
=> New_Occurrence_Of
(Any
, Loc
),
7946 Expr
:= Helpers
.Build_From_Any_Call
7947 (Etyp
, New_Occurrence_Of
(Any
, Loc
), Decls
);
7950 Append_To
(Statements
,
7951 Make_Assignment_Statement
(Loc
,
7952 Name
=> New_Occurrence_Of
(Object
, Loc
),
7953 Expression
=> Expr
));
7957 -- Expr will be used to initialize (and constrain) the
7958 -- parameter when it is declared.
7966 Need_Extra_Constrained
:=
7967 Nkind
(Parameter_Type
(Current_Parameter
)) /=
7970 Ekind
(Defining_Identifier
(Current_Parameter
)) /= E_Void
7972 Present
(Extra_Constrained
7973 (Defining_Identifier
(Current_Parameter
)));
7975 -- We may not associate an extra constrained actual to a
7976 -- constant object, so if one is needed, declare the actual
7977 -- as a variable even if it won't be modified.
7979 Build_Actual_Object_Declaration
7982 Variable
=> Need_Extra_Constrained
7983 or else Out_Present
(Current_Parameter
),
7986 Set_Etype
(Object
, Etyp
);
7988 -- An out parameter may be written back using a 'Write
7989 -- attribute instead of a 'Output because it has been
7990 -- constrained by the parameter given to the caller. Note that
7991 -- out controlling arguments in the case of a RACW are not put
7992 -- back in the stream because the pointer on them has not
7995 if Out_Present
(Current_Parameter
)
7996 and then not Is_Controlling_Formal
7998 Append_To
(After_Statements
,
7999 Make_Procedure_Call_Statement
(Loc
,
8000 Name
=> New_Occurrence_Of
(RTE
(RE_Move_Any_Value
), Loc
),
8001 Parameter_Associations
=> New_List
(
8002 New_Occurrence_Of
(Any
, Loc
),
8003 PolyORB_Support
.Helpers
.Build_To_Any_Call
8004 (New_Occurrence_Of
(Object
, Loc
), Decls
))));
8007 -- For RACW controlling formals, the Etyp of Object is always
8008 -- an RACW, even if the parameter is not of an anonymous access
8009 -- type. In such case, we need to dereference it at call time.
8011 if Is_Controlling_Formal
then
8012 if Nkind
(Parameter_Type
(Current_Parameter
)) /=
8015 Append_To
(Parameter_List
,
8016 Make_Parameter_Association
(Loc
,
8019 (Defining_Identifier
(Current_Parameter
), Loc
),
8020 Explicit_Actual_Parameter
=>
8021 Make_Explicit_Dereference
(Loc
,
8022 Prefix
=> New_Occurrence_Of
(Object
, Loc
))));
8025 Append_To
(Parameter_List
,
8026 Make_Parameter_Association
(Loc
,
8029 (Defining_Identifier
(Current_Parameter
), Loc
),
8031 Explicit_Actual_Parameter
=>
8032 New_Occurrence_Of
(Object
, Loc
)));
8036 Append_To
(Parameter_List
,
8037 Make_Parameter_Association
(Loc
,
8040 Defining_Identifier
(Current_Parameter
), Loc
),
8041 Explicit_Actual_Parameter
=>
8042 New_Occurrence_Of
(Object
, Loc
)));
8045 -- If the current parameter needs an extra formal, then read it
8046 -- from the stream and set the corresponding semantic field in
8047 -- the variable. If the kind of the parameter identifier is
8048 -- E_Void, then this is a compiler generated parameter that
8049 -- doesn't need an extra constrained status.
8051 -- The case of Extra_Accessibility should also be handled ???
8053 if Need_Extra_Constrained
then
8055 Extra_Parameter
: constant Entity_Id
:=
8057 (Defining_Identifier
8058 (Current_Parameter
));
8060 Extra_Any
: constant Entity_Id
:=
8061 Make_Temporary
(Loc
, 'A');
8063 Formal_Entity
: constant Entity_Id
:=
8064 Make_Defining_Identifier
(Loc
,
8065 Chars
=> Chars
(Extra_Parameter
));
8067 Formal_Type
: constant Entity_Id
:=
8068 Etype
(Extra_Parameter
);
8071 Append_To
(Outer_Decls
,
8072 Make_Object_Declaration
(Loc
,
8073 Defining_Identifier
=> Extra_Any
,
8074 Object_Definition
=>
8075 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8077 Make_Function_Call
(Loc
,
8079 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
8080 Parameter_Associations
=> New_List
(
8081 PolyORB_Support
.Helpers
.Build_TypeCode_Call
8082 (Loc
, Formal_Type
, Outer_Decls
)))));
8084 Append_To
(Outer_Extra_Formal_Statements
,
8085 Add_Parameter_To_NVList
(Loc
,
8086 Parameter
=> Extra_Parameter
,
8087 NVList
=> Arguments
,
8088 Constrained
=> True,
8092 Make_Object_Declaration
(Loc
,
8093 Defining_Identifier
=> Formal_Entity
,
8094 Object_Definition
=>
8095 New_Occurrence_Of
(Formal_Type
, Loc
)));
8097 Append_To
(Statements
,
8098 Make_Assignment_Statement
(Loc
,
8099 Name
=> New_Occurrence_Of
(Formal_Entity
, Loc
),
8101 PolyORB_Support
.Helpers
.Build_From_Any_Call
8103 New_Occurrence_Of
(Extra_Any
, Loc
),
8105 Set_Extra_Constrained
(Object
, Formal_Entity
);
8110 Next
(Current_Parameter
);
8113 -- Extra Formals should go after all the other parameters
8115 Append_List_To
(Outer_Statements
, Outer_Extra_Formal_Statements
);
8117 Append_To
(Outer_Statements
,
8118 Make_Procedure_Call_Statement
(Loc
,
8119 Name
=> New_Occurrence_Of
(RTE
(RE_Request_Arguments
), Loc
),
8120 Parameter_Associations
=> New_List
(
8121 New_Occurrence_Of
(Request_Parameter
, Loc
),
8122 New_Occurrence_Of
(Arguments
, Loc
))));
8124 if Nkind
(Specification
(Vis_Decl
)) = N_Function_Specification
then
8126 -- The remote subprogram is a function: Build an inner block to be
8127 -- able to hold a potentially unconstrained result in a variable.
8130 Etyp
: constant Entity_Id
:=
8131 Etype
(Result_Definition
(Specification
(Vis_Decl
)));
8132 Result
: constant Node_Id
:= Make_Temporary
(Loc
, 'R');
8135 Inner_Decls
:= New_List
(
8136 Make_Object_Declaration
(Loc
,
8137 Defining_Identifier
=> Result
,
8138 Constant_Present
=> True,
8139 Object_Definition
=> New_Occurrence_Of
(Etyp
, Loc
),
8141 Make_Function_Call
(Loc
,
8142 Name
=> Called_Subprogram
,
8143 Parameter_Associations
=> Parameter_List
)));
8145 if Is_Class_Wide_Type
(Etyp
) then
8147 -- For a remote call to a function with a class-wide type,
8148 -- check that the returned value satisfies the requirements
8151 Append_To
(Inner_Decls
,
8152 Make_Transportable_Check
(Loc
,
8153 New_Occurrence_Of
(Result
, Loc
)));
8157 Set_Etype
(Result
, Etyp
);
8158 Append_To
(After_Statements
,
8159 Make_Procedure_Call_Statement
(Loc
,
8160 Name
=> New_Occurrence_Of
(RTE
(RE_Set_Result
), Loc
),
8161 Parameter_Associations
=> New_List
(
8162 New_Occurrence_Of
(Request_Parameter
, Loc
),
8163 PolyORB_Support
.Helpers
.Build_To_Any_Call
8164 (New_Occurrence_Of
(Result
, Loc
), Decls
))));
8166 -- A DSA function does not have out or inout arguments
8169 Append_To
(Statements
,
8170 Make_Block_Statement
(Loc
,
8171 Declarations
=> Inner_Decls
,
8172 Handled_Statement_Sequence
=>
8173 Make_Handled_Sequence_Of_Statements
(Loc
,
8174 Statements
=> After_Statements
)));
8177 -- The remote subprogram is a procedure. We do not need any inner
8178 -- block in this case. No specific processing is required here for
8179 -- the dynamically asynchronous case: the indication of whether
8180 -- call is asynchronous or not is managed by the Sync_Scope
8181 -- attibute of the request, and is handled entirely in the
8184 Append_To
(After_Statements
,
8185 Make_Procedure_Call_Statement
(Loc
,
8186 Name
=> New_Occurrence_Of
(RTE
(RE_Request_Set_Out
), Loc
),
8187 Parameter_Associations
=> New_List
(
8188 New_Occurrence_Of
(Request_Parameter
, Loc
))));
8190 Append_To
(Statements
,
8191 Make_Procedure_Call_Statement
(Loc
,
8192 Name
=> Called_Subprogram
,
8193 Parameter_Associations
=> Parameter_List
));
8195 Append_List_To
(Statements
, After_Statements
);
8199 Make_Procedure_Specification
(Loc
,
8200 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'F'),
8202 Parameter_Specifications
=> New_List
(
8203 Make_Parameter_Specification
(Loc
,
8204 Defining_Identifier
=> Request_Parameter
,
8206 New_Occurrence_Of
(RTE
(RE_Request_Access
), Loc
))));
8208 -- An exception raised during the execution of an incoming remote
8209 -- subprogram call and that needs to be sent back to the caller is
8210 -- propagated by the receiving stubs, and will be handled by the
8211 -- caller (the distribution runtime).
8213 if Asynchronous
and then not Dynamically_Asynchronous
then
8215 -- For an asynchronous procedure, add a null exception handler
8217 Excep_Handlers
:= New_List
(
8218 Make_Implicit_Exception_Handler
(Loc
,
8219 Exception_Choices
=> New_List
(Make_Others_Choice
(Loc
)),
8220 Statements
=> New_List
(Make_Null_Statement
(Loc
))));
8223 -- In the other cases, if an exception is raised, then the
8224 -- exception occurrence is propagated.
8229 Append_To
(Outer_Statements
,
8230 Make_Block_Statement
(Loc
,
8231 Declarations
=> Decls
,
8232 Handled_Statement_Sequence
=>
8233 Make_Handled_Sequence_Of_Statements
(Loc
,
8234 Statements
=> Statements
)));
8237 Make_Subprogram_Body
(Loc
,
8238 Specification
=> Subp_Spec
,
8239 Declarations
=> Outer_Decls
,
8240 Handled_Statement_Sequence
=>
8241 Make_Handled_Sequence_Of_Statements
(Loc
,
8242 Statements
=> Outer_Statements
,
8243 Exception_Handlers
=> Excep_Handlers
));
8244 end Build_Subprogram_Receiving_Stubs
;
8250 package body Helpers
is
8252 -----------------------
8253 -- Local Subprograms --
8254 -----------------------
8256 function Find_Numeric_Representation
8257 (Typ
: Entity_Id
) return Entity_Id
;
8258 -- Given a numeric type Typ, return the smallest integer or floating
8259 -- point type from Standard, or the smallest unsigned (modular) type
8260 -- from System.Unsigned_Types, whose range encompasses that of Typ.
8262 function Make_Helper_Function_Name
8265 Nam
: Name_Id
) return Entity_Id
;
8266 -- Return the name to be assigned for helper subprogram Nam of Typ
8268 ------------------------------------------------------------
8269 -- Common subprograms for building various tree fragments --
8270 ------------------------------------------------------------
8272 function Build_Get_Aggregate_Element
8276 Idx
: Node_Id
) return Node_Id
;
8277 -- Build a call to Get_Aggregate_Element on Any for typecode TC,
8278 -- returning the Idx'th element.
8281 Subprogram
: Entity_Id
;
8282 -- Reference location for constructed nodes
8285 -- For 'Range and Etype
8288 -- For the construction of the innermost element expression
8290 with procedure Add_Process_Element
8293 Counter
: Entity_Id
;
8296 procedure Append_Array_Traversal
8299 Counter
: Entity_Id
:= Empty
;
8301 -- Build nested loop statements that iterate over the elements of an
8302 -- array Arry. The statement(s) built by Add_Process_Element are
8303 -- executed for each element; Indexes is the list of indexes to be
8304 -- used in the construction of the indexed component that denotes the
8305 -- current element. Subprogram is the entity for the subprogram for
8306 -- which this iterator is generated. The generated statements are
8307 -- appended to Stmts.
8311 -- The record entity being dealt with
8313 with procedure Add_Process_Element
8315 Container
: Node_Or_Entity_Id
;
8316 Counter
: in out Int
;
8319 -- Rec is the instance of the record type, or Empty.
8320 -- Field is either the N_Defining_Identifier for a component,
8321 -- or an N_Variant_Part.
8323 procedure Append_Record_Traversal
8326 Container
: Node_Or_Entity_Id
;
8327 Counter
: in out Int
);
8328 -- Process component list Clist. Individual fields are passed
8329 -- to Field_Processing. Each variant part is also processed.
8330 -- Container is the outer Any (for From_Any/To_Any),
8331 -- the outer typecode (for TC) to which the operation applies.
8333 -----------------------------
8334 -- Append_Record_Traversal --
8335 -----------------------------
8337 procedure Append_Record_Traversal
8340 Container
: Node_Or_Entity_Id
;
8341 Counter
: in out Int
)
8345 -- Clist's Component_Items and Variant_Part
8355 CI
:= Component_Items
(Clist
);
8356 VP
:= Variant_Part
(Clist
);
8359 while Present
(Item
) loop
8360 Def
:= Defining_Identifier
(Item
);
8362 if not Is_Internal_Name
(Chars
(Def
)) then
8364 (Stmts
, Container
, Counter
, Rec
, Def
);
8370 if Present
(VP
) then
8371 Add_Process_Element
(Stmts
, Container
, Counter
, Rec
, VP
);
8373 end Append_Record_Traversal
;
8375 -----------------------------
8376 -- Assign_Opaque_From_Any --
8377 -----------------------------
8379 procedure Assign_Opaque_From_Any
8386 Strm
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
8389 Read_Call_List
: List_Id
;
8390 -- List on which to place the 'Read attribute reference
8393 -- Strm : Buffer_Stream_Type;
8396 Make_Object_Declaration
(Loc
,
8397 Defining_Identifier
=> Strm
,
8398 Aliased_Present
=> True,
8399 Object_Definition
=>
8400 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
8402 -- Any_To_BS (Strm, A);
8405 Make_Procedure_Call_Statement
(Loc
,
8406 Name
=> New_Occurrence_Of
(RTE
(RE_Any_To_BS
), Loc
),
8407 Parameter_Associations
=> New_List
(
8409 New_Occurrence_Of
(Strm
, Loc
))));
8411 if Transmit_As_Unconstrained
(Typ
) then
8413 Make_Attribute_Reference
(Loc
,
8414 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
8415 Attribute_Name
=> Name_Input
,
8416 Expressions
=> New_List
(
8417 Make_Attribute_Reference
(Loc
,
8418 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
8419 Attribute_Name
=> Name_Access
)));
8421 -- Target := Typ'Input (Strm'Access)
8423 if Present
(Target
) then
8425 Make_Assignment_Statement
(Loc
,
8426 Name
=> New_Occurrence_Of
(Target
, Loc
),
8427 Expression
=> Expr
));
8429 -- return Typ'Input (Strm'Access);
8433 Make_Simple_Return_Statement
(Loc
,
8434 Expression
=> Expr
));
8438 if Present
(Target
) then
8439 Read_Call_List
:= Stms
;
8440 Expr
:= New_Occurrence_Of
(Target
, Loc
);
8444 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
8447 Read_Call_List
:= New_List
;
8448 Expr
:= New_Occurrence_Of
(Temp
, Loc
);
8450 Append_To
(Stms
, Make_Block_Statement
(Loc
,
8451 Declarations
=> New_List
(
8452 Make_Object_Declaration
(Loc
,
8453 Defining_Identifier
=>
8455 Object_Definition
=>
8456 New_Occurrence_Of
(Typ
, Loc
))),
8458 Handled_Statement_Sequence
=>
8459 Make_Handled_Sequence_Of_Statements
(Loc
,
8460 Statements
=> Read_Call_List
)));
8464 -- Typ'Read (Strm'Access, [Target|Temp])
8466 Append_To
(Read_Call_List
,
8467 Make_Attribute_Reference
(Loc
,
8468 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
8469 Attribute_Name
=> Name_Read
,
8470 Expressions
=> New_List
(
8471 Make_Attribute_Reference
(Loc
,
8472 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
8473 Attribute_Name
=> Name_Access
),
8480 Append_To
(Read_Call_List
,
8481 Make_Simple_Return_Statement
(Loc
,
8482 Expression
=> New_Copy
(Expr
)));
8485 end Assign_Opaque_From_Any
;
8487 -------------------------
8488 -- Build_From_Any_Call --
8489 -------------------------
8491 function Build_From_Any_Call
8494 Decls
: List_Id
) return Node_Id
8496 Loc
: constant Source_Ptr
:= Sloc
(N
);
8498 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
8500 Fnam
: Entity_Id
:= Empty
;
8501 Lib_RE
: RE_Id
:= RE_Null
;
8505 -- First simple case where the From_Any function is present
8506 -- in the type's TSS.
8508 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_From_Any
);
8510 -- For the subtype representing a generic actual type, go to the
8513 if Is_Generic_Actual_Type
(U_Type
) then
8514 U_Type
:= Underlying_Type
(Base_Type
(U_Type
));
8517 -- For a standard subtype, go to the base type
8519 if Sloc
(U_Type
) <= Standard_Location
then
8520 U_Type
:= Base_Type
(U_Type
);
8523 -- Check first for Boolean and Character. These are enumeration
8524 -- types, but we treat them specially, since they may require
8525 -- special handling in the transfer protocol. However, this
8526 -- special handling only applies if they have standard
8527 -- representation, otherwise they are treated like any other
8528 -- enumeration type.
8530 if Present
(Fnam
) then
8533 elsif U_Type
= Standard_Boolean
then
8536 elsif U_Type
= Standard_Character
then
8539 elsif U_Type
= Standard_Wide_Character
then
8542 elsif U_Type
= Standard_Wide_Wide_Character
then
8543 Lib_RE
:= RE_FA_WWC
;
8545 -- Floating point types
8547 elsif U_Type
= Standard_Short_Float
then
8550 elsif U_Type
= Standard_Float
then
8553 elsif U_Type
= Standard_Long_Float
then
8556 elsif U_Type
= Standard_Long_Long_Float
then
8557 Lib_RE
:= RE_FA_LLF
;
8561 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
8562 Lib_RE
:= RE_FA_SSI
;
8564 elsif U_Type
= Etype
(Standard_Short_Integer
) then
8567 elsif U_Type
= Etype
(Standard_Integer
) then
8570 elsif U_Type
= Etype
(Standard_Long_Integer
) then
8573 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
8574 Lib_RE
:= RE_FA_LLI
;
8576 -- Unsigned integer types
8578 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
8579 Lib_RE
:= RE_FA_SSU
;
8581 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
8584 elsif U_Type
= RTE
(RE_Unsigned
) then
8587 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
8590 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
8591 Lib_RE
:= RE_FA_LLU
;
8593 elsif Is_RTE
(U_Type
, RE_Unbounded_String
) then
8594 Lib_RE
:= RE_FA_String
;
8596 -- Special DSA types
8598 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
8601 -- Other (non-primitive) types
8608 Build_From_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
8609 Append_To
(Decls
, Decl
);
8613 -- Call the function
8615 if Lib_RE
/= RE_Null
then
8616 pragma Assert
(No
(Fnam
));
8617 Fnam
:= RTE
(Lib_RE
);
8621 Make_Function_Call
(Loc
,
8622 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
8623 Parameter_Associations
=> New_List
(N
));
8625 -- We must set the type of Result, so the unchecked conversion
8626 -- from the underlying type to the base type is properly done.
8628 Set_Etype
(Result
, U_Type
);
8630 return Unchecked_Convert_To
(Typ
, Result
);
8631 end Build_From_Any_Call
;
8633 -----------------------------
8634 -- Build_From_Any_Function --
8635 -----------------------------
8637 procedure Build_From_Any_Function
8641 Fnam
: out Entity_Id
)
8644 Decls
: constant List_Id
:= New_List
;
8645 Stms
: constant List_Id
:= New_List
;
8647 Any_Parameter
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
8649 Use_Opaque_Representation
: Boolean;
8652 -- For a derived type, we can't go past the base type (to the
8653 -- parent type) here, because that would cause the attribute's
8654 -- formal parameter to have the wrong type; hence the Base_Type
8657 if Is_Itype
(Typ
) and then Typ
/= Base_Type
(Typ
) then
8658 Build_From_Any_Function
8666 Fnam
:= Make_Helper_Function_Name
(Loc
, Typ
, Name_From_Any
);
8669 Make_Function_Specification
(Loc
,
8670 Defining_Unit_Name
=> Fnam
,
8671 Parameter_Specifications
=> New_List
(
8672 Make_Parameter_Specification
(Loc
,
8673 Defining_Identifier
=> Any_Parameter
,
8674 Parameter_Type
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
))),
8675 Result_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
8677 -- The RACW case is taken care of by Exp_Dist.Add_RACW_From_Any
8680 (not (Is_Remote_Access_To_Class_Wide_Type
(Typ
)));
8682 Use_Opaque_Representation
:= False;
8684 if Has_Stream_Attribute_Definition
8685 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
8687 Has_Stream_Attribute_Definition
8688 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
8690 -- If user-defined stream attributes are specified for this
8691 -- type, use them and transmit data as an opaque sequence of
8694 Use_Opaque_Representation
:= True;
8696 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
8698 Make_Simple_Return_Statement
(Loc
,
8703 New_Occurrence_Of
(Any_Parameter
, Loc
),
8706 elsif Is_Record_Type
(Typ
)
8707 and then not Is_Derived_Type
(Typ
)
8708 and then not Is_Tagged_Type
(Typ
)
8710 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
8712 Make_Simple_Return_Statement
(Loc
,
8716 New_Occurrence_Of
(Any_Parameter
, Loc
),
8721 Disc
: Entity_Id
:= Empty
;
8722 Discriminant_Associations
: List_Id
;
8723 Rdef
: constant Node_Id
:=
8725 (Declaration_Node
(Typ
));
8726 Component_Counter
: Int
:= 0;
8728 -- The returned object
8730 Res
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
8732 Res_Definition
: Node_Id
:= New_Occurrence_Of
(Typ
, Loc
);
8734 procedure FA_Rec_Add_Process_Element
8737 Counter
: in out Int
;
8741 procedure FA_Append_Record_Traversal
is
8742 new Append_Record_Traversal
8744 Add_Process_Element
=> FA_Rec_Add_Process_Element
);
8746 --------------------------------
8747 -- FA_Rec_Add_Process_Element --
8748 --------------------------------
8750 procedure FA_Rec_Add_Process_Element
8753 Counter
: in out Int
;
8759 if Nkind
(Field
) = N_Defining_Identifier
then
8760 -- A regular component
8762 Ctyp
:= Etype
(Field
);
8765 Make_Assignment_Statement
(Loc
,
8766 Name
=> Make_Selected_Component
(Loc
,
8768 New_Occurrence_Of
(Rec
, Loc
),
8770 New_Occurrence_Of
(Field
, Loc
)),
8773 Build_From_Any_Call
(Ctyp
,
8774 Build_Get_Aggregate_Element
(Loc
,
8777 Build_TypeCode_Call
(Loc
, Ctyp
, Decls
),
8779 Make_Integer_Literal
(Loc
, Counter
)),
8787 Struct_Counter
: Int
:= 0;
8789 Block_Decls
: constant List_Id
:= New_List
;
8790 Block_Stmts
: constant List_Id
:= New_List
;
8793 Alt_List
: constant List_Id
:= New_List
;
8794 Choice_List
: List_Id
;
8796 Struct_Any
: constant Entity_Id
:=
8797 Make_Temporary
(Loc
, 'S');
8801 Make_Object_Declaration
(Loc
,
8802 Defining_Identifier
=> Struct_Any
,
8803 Constant_Present
=> True,
8804 Object_Definition
=>
8805 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
8807 Make_Function_Call
(Loc
,
8810 (RTE
(RE_Extract_Union_Value
), Loc
),
8812 Parameter_Associations
=> New_List
(
8813 Build_Get_Aggregate_Element
(Loc
,
8816 Make_Function_Call
(Loc
,
8817 Name
=> New_Occurrence_Of
(
8818 RTE
(RE_Any_Member_Type
), Loc
),
8819 Parameter_Associations
=>
8821 New_Occurrence_Of
(Any
, Loc
),
8822 Make_Integer_Literal
(Loc
,
8823 Intval
=> Counter
))),
8825 Make_Integer_Literal
(Loc
,
8826 Intval
=> Counter
))))));
8829 Make_Block_Statement
(Loc
,
8830 Declarations
=> Block_Decls
,
8831 Handled_Statement_Sequence
=>
8832 Make_Handled_Sequence_Of_Statements
(Loc
,
8833 Statements
=> Block_Stmts
)));
8835 Append_To
(Block_Stmts
,
8836 Make_Case_Statement
(Loc
,
8838 Make_Selected_Component
(Loc
,
8840 Selector_Name
=> Chars
(Name
(Field
))),
8841 Alternatives
=> Alt_List
));
8843 Variant
:= First_Non_Pragma
(Variants
(Field
));
8844 while Present
(Variant
) loop
8847 (Discrete_Choices
(Variant
));
8849 VP_Stmts
:= New_List
;
8851 -- Struct_Counter should be reset before
8852 -- handling a variant part. Indeed only one
8853 -- of the case statement alternatives will be
8854 -- executed at run time, so the counter must
8855 -- start at 0 for every case statement.
8857 Struct_Counter
:= 0;
8859 FA_Append_Record_Traversal
(
8861 Clist
=> Component_List
(Variant
),
8862 Container
=> Struct_Any
,
8863 Counter
=> Struct_Counter
);
8865 Append_To
(Alt_List
,
8866 Make_Case_Statement_Alternative
(Loc
,
8867 Discrete_Choices
=> Choice_List
,
8868 Statements
=> VP_Stmts
));
8869 Next_Non_Pragma
(Variant
);
8874 Counter
:= Counter
+ 1;
8875 end FA_Rec_Add_Process_Element
;
8878 -- First all discriminants
8880 if Has_Discriminants
(Typ
) then
8881 Discriminant_Associations
:= New_List
;
8883 Disc
:= First_Discriminant
(Typ
);
8884 while Present
(Disc
) loop
8886 Disc_Var_Name
: constant Entity_Id
:=
8887 Make_Defining_Identifier
(Loc
,
8888 Chars
=> Chars
(Disc
));
8889 Disc_Type
: constant Entity_Id
:=
8894 Make_Object_Declaration
(Loc
,
8895 Defining_Identifier
=> Disc_Var_Name
,
8896 Constant_Present
=> True,
8897 Object_Definition
=>
8898 New_Occurrence_Of
(Disc_Type
, Loc
),
8901 Build_From_Any_Call
(Disc_Type
,
8902 Build_Get_Aggregate_Element
(Loc
,
8903 Any
=> Any_Parameter
,
8904 TC
=> Build_TypeCode_Call
8905 (Loc
, Disc_Type
, Decls
),
8906 Idx
=> Make_Integer_Literal
(Loc
,
8907 Intval
=> Component_Counter
)),
8910 Component_Counter
:= Component_Counter
+ 1;
8912 Append_To
(Discriminant_Associations
,
8913 Make_Discriminant_Association
(Loc
,
8914 Selector_Names
=> New_List
(
8915 New_Occurrence_Of
(Disc
, Loc
)),
8917 New_Occurrence_Of
(Disc_Var_Name
, Loc
)));
8919 Next_Discriminant
(Disc
);
8923 Make_Subtype_Indication
(Loc
,
8924 Subtype_Mark
=> Res_Definition
,
8926 Make_Index_Or_Discriminant_Constraint
(Loc
,
8927 Discriminant_Associations
));
8930 -- Now we have all the discriminants in variables, we can
8931 -- declared a constrained object. Note that we are not
8932 -- initializing (non-discriminant) components directly in
8933 -- the object declarations, because which fields to
8934 -- initialize depends (at run time) on the discriminant
8938 Make_Object_Declaration
(Loc
,
8939 Defining_Identifier
=> Res
,
8940 Object_Definition
=> Res_Definition
));
8942 -- ... then all components
8944 FA_Append_Record_Traversal
(Stms
,
8945 Clist
=> Component_List
(Rdef
),
8946 Container
=> Any_Parameter
,
8947 Counter
=> Component_Counter
);
8950 Make_Simple_Return_Statement
(Loc
,
8951 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
8955 elsif Is_Array_Type
(Typ
) then
8957 Constrained
: constant Boolean := Is_Constrained
(Typ
);
8959 procedure FA_Ary_Add_Process_Element
8962 Counter
: Entity_Id
;
8964 -- Assign the current element (as identified by Counter) of
8965 -- Any to the variable denoted by name Datum, and advance
8966 -- Counter by 1. If Datum is not an Any, a call to From_Any
8967 -- for its type is inserted.
8969 --------------------------------
8970 -- FA_Ary_Add_Process_Element --
8971 --------------------------------
8973 procedure FA_Ary_Add_Process_Element
8976 Counter
: Entity_Id
;
8979 Assignment
: constant Node_Id
:=
8980 Make_Assignment_Statement
(Loc
,
8982 Expression
=> Empty
);
8984 Element_Any
: Node_Id
;
8988 Element_TC
: Node_Id
;
8991 if Etype
(Datum
) = RTE
(RE_Any
) then
8993 -- When Datum is an Any the Etype field is not
8994 -- sufficient to determine the typecode of Datum
8995 -- (which can be a TC_SEQUENCE or TC_ARRAY
8996 -- depending on the value of Constrained).
8998 -- Therefore we retrieve the typecode which has
8999 -- been constructed in Append_Array_Traversal with
9000 -- a call to Get_Any_Type.
9003 Make_Function_Call
(Loc
,
9004 Name
=> New_Occurrence_Of
(
9005 RTE
(RE_Get_Any_Type
), Loc
),
9006 Parameter_Associations
=> New_List
(
9007 New_Occurrence_Of
(Entity
(Datum
), Loc
)));
9009 -- For non Any Datum we simply construct a typecode
9010 -- matching the Etype of the Datum.
9012 Element_TC
:= Build_TypeCode_Call
9013 (Loc
, Etype
(Datum
), Decls
);
9017 Build_Get_Aggregate_Element
(Loc
,
9020 Idx
=> New_Occurrence_Of
(Counter
, Loc
));
9023 -- Note: here we *prepend* statements to Stmts, so
9024 -- we must do it in reverse order.
9027 Make_Assignment_Statement
(Loc
,
9029 New_Occurrence_Of
(Counter
, Loc
),
9032 Left_Opnd
=> New_Occurrence_Of
(Counter
, Loc
),
9033 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
9035 if Nkind
(Datum
) /= N_Attribute_Reference
then
9037 -- We ignore the value of the length of each
9038 -- dimension, since the target array has already
9039 -- been constrained anyway.
9041 if Etype
(Datum
) /= RTE
(RE_Any
) then
9042 Set_Expression
(Assignment
,
9044 (Component_Type
(Typ
), Element_Any
, Decls
));
9046 Set_Expression
(Assignment
, Element_Any
);
9049 Prepend_To
(Stmts
, Assignment
);
9051 end FA_Ary_Add_Process_Element
;
9053 ------------------------
9054 -- Local Declarations --
9055 ------------------------
9057 Counter
: constant Entity_Id
:=
9058 Make_Defining_Identifier
(Loc
, Name_J
);
9060 Initial_Counter_Value
: Int
:= 0;
9062 Component_TC
: constant Entity_Id
:=
9063 Make_Defining_Identifier
(Loc
, Name_T
);
9065 Res
: constant Entity_Id
:=
9066 Make_Defining_Identifier
(Loc
, Name_R
);
9068 procedure Append_From_Any_Array_Iterator
is
9069 new Append_Array_Traversal
(
9072 Indexes
=> New_List
,
9073 Add_Process_Element
=> FA_Ary_Add_Process_Element
);
9075 Res_Subtype_Indication
: Node_Id
:=
9076 New_Occurrence_Of
(Typ
, Loc
);
9079 if not Constrained
then
9081 Ndim
: constant Int
:= Number_Dimensions
(Typ
);
9084 Indx
: Node_Id
:= First_Index
(Typ
);
9087 Ranges
: constant List_Id
:= New_List
;
9090 for J
in 1 .. Ndim
loop
9091 Lnam
:= New_External_Name
('L', J
);
9092 Hnam
:= New_External_Name
('H', J
);
9094 -- Note, for empty arrays bounds may be out of
9095 -- the range of Etype (Indx).
9097 Indt
:= Base_Type
(Etype
(Indx
));
9100 Make_Object_Declaration
(Loc
,
9101 Defining_Identifier
=>
9102 Make_Defining_Identifier
(Loc
, Lnam
),
9103 Constant_Present
=> True,
9104 Object_Definition
=>
9105 New_Occurrence_Of
(Indt
, Loc
),
9109 Build_Get_Aggregate_Element
(Loc
,
9110 Any
=> Any_Parameter
,
9111 TC
=> Build_TypeCode_Call
9114 Make_Integer_Literal
(Loc
, J
- 1)),
9118 Make_Object_Declaration
(Loc
,
9119 Defining_Identifier
=>
9120 Make_Defining_Identifier
(Loc
, Hnam
),
9122 Constant_Present
=> True,
9124 Object_Definition
=>
9125 New_Occurrence_Of
(Indt
, Loc
),
9127 Expression
=> Make_Attribute_Reference
(Loc
,
9129 New_Occurrence_Of
(Indt
, Loc
),
9131 Attribute_Name
=> Name_Val
,
9133 Expressions
=> New_List
(
9134 Make_Op_Subtract
(Loc
,
9139 (Standard_Long_Integer
,
9140 Make_Identifier
(Loc
, Lnam
)),
9144 (Standard_Long_Integer
,
9145 Make_Function_Call
(Loc
,
9147 New_Occurrence_Of
(RTE
(
9148 RE_Get_Nested_Sequence_Length
9150 Parameter_Associations
=>
9153 Any_Parameter
, Loc
),
9154 Make_Integer_Literal
(Loc
,
9158 Make_Integer_Literal
(Loc
, 1))))));
9162 Low_Bound
=> Make_Identifier
(Loc
, Lnam
),
9163 High_Bound
=> Make_Identifier
(Loc
, Hnam
)));
9168 -- Now we have all the necessary bound information:
9169 -- apply the set of range constraints to the
9170 -- (unconstrained) nominal subtype of Res.
9172 Initial_Counter_Value
:= Ndim
;
9173 Res_Subtype_Indication
:= Make_Subtype_Indication
(Loc
,
9174 Subtype_Mark
=> Res_Subtype_Indication
,
9176 Make_Index_Or_Discriminant_Constraint
(Loc
,
9177 Constraints
=> Ranges
));
9182 Make_Object_Declaration
(Loc
,
9183 Defining_Identifier
=> Res
,
9184 Object_Definition
=> Res_Subtype_Indication
));
9185 Set_Etype
(Res
, Typ
);
9188 Make_Object_Declaration
(Loc
,
9189 Defining_Identifier
=> Counter
,
9190 Object_Definition
=>
9191 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
9193 Make_Integer_Literal
(Loc
, Initial_Counter_Value
)));
9196 Make_Object_Declaration
(Loc
,
9197 Defining_Identifier
=> Component_TC
,
9198 Constant_Present
=> True,
9199 Object_Definition
=>
9200 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
),
9202 Build_TypeCode_Call
(Loc
,
9203 Component_Type
(Typ
), Decls
)));
9205 Append_From_Any_Array_Iterator
9206 (Stms
, Any_Parameter
, Counter
);
9209 Make_Simple_Return_Statement
(Loc
,
9210 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
9213 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9215 Make_Simple_Return_Statement
(Loc
,
9217 Unchecked_Convert_To
(Typ
,
9219 (Find_Numeric_Representation
(Typ
),
9220 New_Occurrence_Of
(Any_Parameter
, Loc
),
9224 Use_Opaque_Representation
:= True;
9227 if Use_Opaque_Representation
then
9228 Assign_Opaque_From_Any
(Loc
,
9231 N
=> New_Occurrence_Of
(Any_Parameter
, Loc
),
9236 Make_Subprogram_Body
(Loc
,
9237 Specification
=> Spec
,
9238 Declarations
=> Decls
,
9239 Handled_Statement_Sequence
=>
9240 Make_Handled_Sequence_Of_Statements
(Loc
,
9241 Statements
=> Stms
));
9242 end Build_From_Any_Function
;
9244 ---------------------------------
9245 -- Build_Get_Aggregate_Element --
9246 ---------------------------------
9248 function Build_Get_Aggregate_Element
9252 Idx
: Node_Id
) return Node_Id
9255 return Make_Function_Call
(Loc
,
9257 New_Occurrence_Of
(RTE
(RE_Get_Aggregate_Element
), Loc
),
9258 Parameter_Associations
=> New_List
(
9259 New_Occurrence_Of
(Any
, Loc
),
9262 end Build_Get_Aggregate_Element
;
9264 -------------------------
9265 -- Build_Reposiroty_Id --
9266 -------------------------
9268 procedure Build_Name_And_Repository_Id
9270 Name_Str
: out String_Id
;
9271 Repo_Id_Str
: out String_Id
)
9275 Store_String_Chars
("DSA:");
9276 Get_Library_Unit_Name_String
(Scope
(E
));
9278 (Name_Buffer
(Name_Buffer
'First ..
9279 Name_Buffer
'First + Name_Len
- 1));
9280 Store_String_Char
('.');
9281 Get_Name_String
(Chars
(E
));
9283 (Name_Buffer
(Name_Buffer
'First ..
9284 Name_Buffer
'First + Name_Len
- 1));
9285 Store_String_Chars
(":1.0");
9286 Repo_Id_Str
:= End_String
;
9287 Name_Str
:= String_From_Name_Buffer
;
9288 end Build_Name_And_Repository_Id
;
9290 -----------------------
9291 -- Build_To_Any_Call --
9292 -----------------------
9294 function Build_To_Any_Call
9296 Decls
: List_Id
) return Node_Id
9298 Loc
: constant Source_Ptr
:= Sloc
(N
);
9300 Typ
: Entity_Id
:= Etype
(N
);
9303 Fnam
: Entity_Id
:= Empty
;
9304 Lib_RE
: RE_Id
:= RE_Null
;
9307 -- If N is a selected component, then maybe its Etype has not been
9308 -- set yet: try to use Etype of the selector_name in that case.
9310 if No
(Typ
) and then Nkind
(N
) = N_Selected_Component
then
9311 Typ
:= Etype
(Selector_Name
(N
));
9314 pragma Assert
(Present
(Typ
));
9316 -- Get full view for private type, completion for incomplete type
9318 U_Type
:= Underlying_Type
(Typ
);
9320 -- First simple case where the To_Any function is present in the
9323 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_To_Any
);
9325 -- For the subtype representing a generic actual type, go to the
9328 if Is_Generic_Actual_Type
(U_Type
) then
9329 U_Type
:= Underlying_Type
(Base_Type
(U_Type
));
9332 -- For a standard subtype, go to the base type
9334 if Sloc
(U_Type
) <= Standard_Location
then
9335 U_Type
:= Base_Type
(U_Type
);
9338 if Present
(Fnam
) then
9341 -- Check first for Boolean and Character. These are enumeration
9342 -- types, but we treat them specially, since they may require
9343 -- special handling in the transfer protocol. However, this
9344 -- special handling only applies if they have standard
9345 -- representation, otherwise they are treated like any other
9346 -- enumeration type.
9348 elsif U_Type
= Standard_Boolean
then
9351 elsif U_Type
= Standard_Character
then
9354 elsif U_Type
= Standard_Wide_Character
then
9357 elsif U_Type
= Standard_Wide_Wide_Character
then
9358 Lib_RE
:= RE_TA_WWC
;
9360 -- Floating point types
9362 elsif U_Type
= Standard_Short_Float
then
9365 elsif U_Type
= Standard_Float
then
9368 elsif U_Type
= Standard_Long_Float
then
9371 elsif U_Type
= Standard_Long_Long_Float
then
9372 Lib_RE
:= RE_TA_LLF
;
9376 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
9377 Lib_RE
:= RE_TA_SSI
;
9379 elsif U_Type
= Etype
(Standard_Short_Integer
) then
9382 elsif U_Type
= Etype
(Standard_Integer
) then
9385 elsif U_Type
= Etype
(Standard_Long_Integer
) then
9388 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
9389 Lib_RE
:= RE_TA_LLI
;
9391 -- Unsigned integer types
9393 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
9394 Lib_RE
:= RE_TA_SSU
;
9396 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
9399 elsif U_Type
= RTE
(RE_Unsigned
) then
9402 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
9405 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
9406 Lib_RE
:= RE_TA_LLU
;
9408 elsif Is_RTE
(U_Type
, RE_Unbounded_String
) then
9409 Lib_RE
:= RE_TA_String
;
9411 -- Special DSA types
9413 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
9417 elsif U_Type
= Underlying_Type
(RTE
(RE_TypeCode
)) then
9419 -- No corresponding FA_TC ???
9423 -- Other (non-primitive) types
9429 Build_To_Any_Function
(Loc
, U_Type
, Decl
, Fnam
);
9430 Append_To
(Decls
, Decl
);
9434 -- Call the function
9436 if Lib_RE
/= RE_Null
then
9437 pragma Assert
(No
(Fnam
));
9438 Fnam
:= RTE
(Lib_RE
);
9441 -- If Fnam is already analyzed, find the proper expected type,
9442 -- else we have a newly constructed To_Any function and we know
9443 -- that the expected type of its parameter is U_Type.
9445 if Ekind
(Fnam
) = E_Function
9446 and then Present
(First_Formal
(Fnam
))
9448 C_Type
:= Etype
(First_Formal
(Fnam
));
9454 Make_Function_Call
(Loc
,
9455 Name
=> New_Occurrence_Of
(Fnam
, Loc
),
9456 Parameter_Associations
=>
9457 New_List
(OK_Convert_To
(C_Type
, N
)));
9458 end Build_To_Any_Call
;
9460 ---------------------------
9461 -- Build_To_Any_Function --
9462 ---------------------------
9464 procedure Build_To_Any_Function
9468 Fnam
: out Entity_Id
)
9471 Decls
: constant List_Id
:= New_List
;
9472 Stms
: constant List_Id
:= New_List
;
9474 Expr_Parameter
: Entity_Id
;
9476 Result_TC
: Node_Id
;
9480 Use_Opaque_Representation
: Boolean;
9481 -- When True, use stream attributes and represent type as an
9482 -- opaque sequence of bytes.
9485 -- For a derived type, we can't go past the base type (to the
9486 -- parent type) here, because that would cause the attribute's
9487 -- formal parameter to have the wrong type; hence the Base_Type
9490 if Is_Itype
(Typ
) and then Typ
/= Base_Type
(Typ
) then
9491 Build_To_Any_Function
9499 Expr_Parameter
:= Make_Defining_Identifier
(Loc
, Name_E
);
9500 Any
:= Make_Defining_Identifier
(Loc
, Name_A
);
9501 Result_TC
:= Build_TypeCode_Call
(Loc
, Typ
, Decls
);
9503 Fnam
:= Make_Helper_Function_Name
(Loc
, Typ
, Name_To_Any
);
9506 Make_Function_Specification
(Loc
,
9507 Defining_Unit_Name
=> Fnam
,
9508 Parameter_Specifications
=> New_List
(
9509 Make_Parameter_Specification
(Loc
,
9510 Defining_Identifier
=> Expr_Parameter
,
9511 Parameter_Type
=> New_Occurrence_Of
(Typ
, Loc
))),
9512 Result_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9513 Set_Etype
(Expr_Parameter
, Typ
);
9516 Make_Object_Declaration
(Loc
,
9517 Defining_Identifier
=> Any
,
9518 Object_Definition
=> New_Occurrence_Of
(RTE
(RE_Any
), Loc
));
9520 Use_Opaque_Representation
:= False;
9522 if Has_Stream_Attribute_Definition
9523 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
9525 Has_Stream_Attribute_Definition
9526 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
9528 -- If user-defined stream attributes are specified for this
9529 -- type, use them and transmit data as an opaque sequence of
9532 Use_Opaque_Representation
:= True;
9534 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9536 -- Non-tagged derived type: convert to root type
9539 Rt_Type
: constant Entity_Id
:= Root_Type
(Typ
);
9540 Expr
: constant Node_Id
:=
9543 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9545 Set_Expression
(Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9548 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
9550 -- Non-tagged record type
9552 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
9554 Rt_Type
: constant Entity_Id
:= Etype
(Typ
);
9555 Expr
: constant Node_Id
:=
9556 OK_Convert_To
(Rt_Type
,
9557 New_Occurrence_Of
(Expr_Parameter
, Loc
));
9561 (Any_Decl
, Build_To_Any_Call
(Expr
, Decls
));
9564 -- Comment needed here (and label on declare block ???)
9568 Disc
: Entity_Id
:= Empty
;
9569 Rdef
: constant Node_Id
:=
9570 Type_Definition
(Declaration_Node
(Typ
));
9572 Elements
: constant List_Id
:= New_List
;
9574 procedure TA_Rec_Add_Process_Element
9576 Container
: Node_Or_Entity_Id
;
9577 Counter
: in out Int
;
9580 -- Processing routine for traversal below
9582 procedure TA_Append_Record_Traversal
is
9583 new Append_Record_Traversal
9584 (Rec
=> Expr_Parameter
,
9585 Add_Process_Element
=> TA_Rec_Add_Process_Element
);
9587 --------------------------------
9588 -- TA_Rec_Add_Process_Element --
9589 --------------------------------
9591 procedure TA_Rec_Add_Process_Element
9593 Container
: Node_Or_Entity_Id
;
9594 Counter
: in out Int
;
9598 Field_Ref
: Node_Id
;
9601 if Nkind
(Field
) = N_Defining_Identifier
then
9603 -- A regular component
9605 Field_Ref
:= Make_Selected_Component
(Loc
,
9606 Prefix
=> New_Occurrence_Of
(Rec
, Loc
),
9607 Selector_Name
=> New_Occurrence_Of
(Field
, Loc
));
9608 Set_Etype
(Field_Ref
, Etype
(Field
));
9611 Make_Procedure_Call_Statement
(Loc
,
9614 RTE
(RE_Add_Aggregate_Element
), Loc
),
9615 Parameter_Associations
=> New_List
(
9616 New_Occurrence_Of
(Container
, Loc
),
9617 Build_To_Any_Call
(Field_Ref
, Decls
))));
9622 Variant_Part
: declare
9624 Struct_Counter
: Int
:= 0;
9626 Block_Decls
: constant List_Id
:= New_List
;
9627 Block_Stmts
: constant List_Id
:= New_List
;
9630 Alt_List
: constant List_Id
:= New_List
;
9631 Choice_List
: List_Id
;
9633 Union_Any
: constant Entity_Id
:=
9634 Make_Temporary
(Loc
, 'V');
9636 Struct_Any
: constant Entity_Id
:=
9637 Make_Temporary
(Loc
, 'S');
9639 function Make_Discriminant_Reference
9641 -- Build reference to the discriminant for this
9644 ---------------------------------
9645 -- Make_Discriminant_Reference --
9646 ---------------------------------
9648 function Make_Discriminant_Reference
9651 Nod
: constant Node_Id
:=
9652 Make_Selected_Component
(Loc
,
9655 Chars
(Name
(Field
)));
9657 Set_Etype
(Nod
, Etype
(Name
(Field
)));
9659 end Make_Discriminant_Reference
;
9661 -- Start of processing for Variant_Part
9665 Make_Block_Statement
(Loc
,
9668 Handled_Statement_Sequence
=>
9669 Make_Handled_Sequence_Of_Statements
(Loc
,
9670 Statements
=> Block_Stmts
)));
9672 -- Declare variant part aggregate (Union_Any).
9673 -- Knowing the position of this VP in the
9674 -- variant record, we can fetch the VP typecode
9677 Append_To
(Block_Decls
,
9678 Make_Object_Declaration
(Loc
,
9679 Defining_Identifier
=> Union_Any
,
9680 Object_Definition
=>
9681 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9683 Make_Function_Call
(Loc
,
9684 Name
=> New_Occurrence_Of
(
9685 RTE
(RE_Create_Any
), Loc
),
9686 Parameter_Associations
=> New_List
(
9687 Make_Function_Call
(Loc
,
9690 RTE
(RE_Any_Member_Type
), Loc
),
9691 Parameter_Associations
=> New_List
(
9692 New_Occurrence_Of
(Container
, Loc
),
9693 Make_Integer_Literal
(Loc
,
9696 -- Declare inner struct aggregate (which
9697 -- contains the components of this VP).
9699 Append_To
(Block_Decls
,
9700 Make_Object_Declaration
(Loc
,
9701 Defining_Identifier
=> Struct_Any
,
9702 Object_Definition
=>
9703 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
9705 Make_Function_Call
(Loc
,
9706 Name
=> New_Occurrence_Of
(
9707 RTE
(RE_Create_Any
), Loc
),
9708 Parameter_Associations
=> New_List
(
9709 Make_Function_Call
(Loc
,
9712 RTE
(RE_Any_Member_Type
), Loc
),
9713 Parameter_Associations
=> New_List
(
9714 New_Occurrence_Of
(Union_Any
, Loc
),
9715 Make_Integer_Literal
(Loc
,
9718 -- Build case statement
9720 Append_To
(Block_Stmts
,
9721 Make_Case_Statement
(Loc
,
9722 Expression
=> Make_Discriminant_Reference
,
9723 Alternatives
=> Alt_List
));
9725 Variant
:= First_Non_Pragma
(Variants
(Field
));
9726 while Present
(Variant
) loop
9727 Choice_List
:= New_Copy_List_Tree
9728 (Discrete_Choices
(Variant
));
9730 VP_Stmts
:= New_List
;
9732 -- Append discriminant val to union aggregate
9734 Append_To
(VP_Stmts
,
9735 Make_Procedure_Call_Statement
(Loc
,
9738 RTE
(RE_Add_Aggregate_Element
), Loc
),
9739 Parameter_Associations
=> New_List
(
9740 New_Occurrence_Of
(Union_Any
, Loc
),
9742 (Make_Discriminant_Reference
,
9745 -- Populate inner struct aggregate
9747 -- Struct_Counter should be reset before
9748 -- handling a variant part. Indeed only one
9749 -- of the case statement alternatives will be
9750 -- executed at run time, so the counter must
9751 -- start at 0 for every case statement.
9753 Struct_Counter
:= 0;
9755 TA_Append_Record_Traversal
9757 Clist
=> Component_List
(Variant
),
9758 Container
=> Struct_Any
,
9759 Counter
=> Struct_Counter
);
9761 -- Append inner struct to union aggregate
9763 Append_To
(VP_Stmts
,
9764 Make_Procedure_Call_Statement
(Loc
,
9767 (RTE
(RE_Add_Aggregate_Element
), Loc
),
9768 Parameter_Associations
=> New_List
(
9769 New_Occurrence_Of
(Union_Any
, Loc
),
9770 New_Occurrence_Of
(Struct_Any
, Loc
))));
9772 -- Append union to outer aggregate
9774 Append_To
(VP_Stmts
,
9775 Make_Procedure_Call_Statement
(Loc
,
9778 (RTE
(RE_Add_Aggregate_Element
), Loc
),
9779 Parameter_Associations
=> New_List
(
9780 New_Occurrence_Of
(Container
, Loc
),
9782 (Union_Any
, Loc
))));
9784 Append_To
(Alt_List
,
9785 Make_Case_Statement_Alternative
(Loc
,
9786 Discrete_Choices
=> Choice_List
,
9787 Statements
=> VP_Stmts
));
9789 Next_Non_Pragma
(Variant
);
9794 Counter
:= Counter
+ 1;
9795 end TA_Rec_Add_Process_Element
;
9798 -- Records are encoded in a TC_STRUCT aggregate:
9800 -- -- Outer aggregate (TC_STRUCT)
9801 -- | [discriminant1]
9802 -- | [discriminant2]
9809 -- A component can be a common component or variant part
9811 -- A variant part is encoded as a TC_UNION aggregate:
9813 -- -- Variant Part Aggregate (TC_UNION)
9814 -- | [discriminant choice for this Variant Part]
9816 -- | -- Inner struct (TC_STRUCT)
9821 -- Let's start by building the outer aggregate. First we
9822 -- construct Elements array containing all discriminants.
9824 if Has_Discriminants
(Typ
) then
9825 Disc
:= First_Discriminant
(Typ
);
9826 while Present
(Disc
) loop
9828 Discriminant
: constant Entity_Id
:=
9829 Make_Selected_Component
(Loc
,
9836 Set_Etype
(Discriminant
, Etype
(Disc
));
9838 Append_To
(Elements
,
9839 Make_Component_Association
(Loc
,
9840 Choices
=> New_List
(
9841 Make_Integer_Literal
(Loc
, Counter
)),
9843 Build_To_Any_Call
(Discriminant
, Decls
)));
9846 Counter
:= Counter
+ 1;
9847 Next_Discriminant
(Disc
);
9851 -- If there are no discriminants, we declare an empty
9855 Dummy_Any
: constant Entity_Id
:=
9856 Make_Temporary
(Loc
, 'A');
9860 Make_Object_Declaration
(Loc
,
9861 Defining_Identifier
=> Dummy_Any
,
9862 Object_Definition
=>
9863 New_Occurrence_Of
(RTE
(RE_Any
), Loc
)));
9865 Append_To
(Elements
,
9866 Make_Component_Association
(Loc
,
9867 Choices
=> New_List
(
9870 Make_Integer_Literal
(Loc
, 1),
9872 Make_Integer_Literal
(Loc
, 0))),
9874 New_Occurrence_Of
(Dummy_Any
, Loc
)));
9878 -- We build the result aggregate with discriminants
9879 -- as the first elements.
9881 Set_Expression
(Any_Decl
,
9882 Make_Function_Call
(Loc
,
9883 Name
=> New_Occurrence_Of
9884 (RTE
(RE_Any_Aggregate_Build
), Loc
),
9885 Parameter_Associations
=> New_List
(
9887 Make_Aggregate
(Loc
,
9888 Component_Associations
=> Elements
))));
9891 -- Then we append all the components to the result
9894 TA_Append_Record_Traversal
(Stms
,
9895 Clist
=> Component_List
(Rdef
),
9897 Counter
=> Counter
);
9901 elsif Is_Array_Type
(Typ
) then
9903 -- Constrained and unconstrained array types
9906 Constrained
: constant Boolean := Is_Constrained
(Typ
);
9908 procedure TA_Ary_Add_Process_Element
9911 Counter
: Entity_Id
;
9914 --------------------------------
9915 -- TA_Ary_Add_Process_Element --
9916 --------------------------------
9918 procedure TA_Ary_Add_Process_Element
9921 Counter
: Entity_Id
;
9924 pragma Unreferenced
(Counter
);
9926 Element_Any
: Node_Id
;
9929 if Etype
(Datum
) = RTE
(RE_Any
) then
9930 Element_Any
:= Datum
;
9932 Element_Any
:= Build_To_Any_Call
(Datum
, Decls
);
9936 Make_Procedure_Call_Statement
(Loc
,
9937 Name
=> New_Occurrence_Of
(
9938 RTE
(RE_Add_Aggregate_Element
), Loc
),
9939 Parameter_Associations
=> New_List
(
9940 New_Occurrence_Of
(Any
, Loc
),
9942 end TA_Ary_Add_Process_Element
;
9944 procedure Append_To_Any_Array_Iterator
is
9945 new Append_Array_Traversal
(
9947 Arry
=> Expr_Parameter
,
9948 Indexes
=> New_List
,
9949 Add_Process_Element
=> TA_Ary_Add_Process_Element
);
9954 Set_Expression
(Any_Decl
,
9955 Make_Function_Call
(Loc
,
9957 New_Occurrence_Of
(RTE
(RE_Create_Any
), Loc
),
9958 Parameter_Associations
=> New_List
(Result_TC
)));
9961 if not Constrained
then
9962 Index
:= First_Index
(Typ
);
9963 for J
in 1 .. Number_Dimensions
(Typ
) loop
9965 Make_Procedure_Call_Statement
(Loc
,
9968 RTE
(RE_Add_Aggregate_Element
), Loc
),
9969 Parameter_Associations
=> New_List
(
9970 New_Occurrence_Of
(Any
, Loc
),
9972 OK_Convert_To
(Etype
(Index
),
9973 Make_Attribute_Reference
(Loc
,
9975 New_Occurrence_Of
(Expr_Parameter
, Loc
),
9976 Attribute_Name
=> Name_First
,
9977 Expressions
=> New_List
(
9978 Make_Integer_Literal
(Loc
, J
)))),
9984 Append_To_Any_Array_Iterator
(Stms
, Any
);
9987 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
9991 Set_Expression
(Any_Decl
,
9994 Find_Numeric_Representation
(Typ
),
9995 New_Occurrence_Of
(Expr_Parameter
, Loc
)),
9999 -- Default case, including tagged types: opaque representation
10001 Use_Opaque_Representation
:= True;
10004 if Use_Opaque_Representation
then
10006 Strm
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
10007 -- Stream used to store data representation produced by
10008 -- stream attribute.
10012 -- Strm : aliased Buffer_Stream_Type;
10015 Make_Object_Declaration
(Loc
,
10016 Defining_Identifier
=>
10020 Object_Definition
=>
10021 New_Occurrence_Of
(RTE
(RE_Buffer_Stream_Type
), Loc
)));
10024 -- T'Output (Strm'Access, E);
10027 Make_Attribute_Reference
(Loc
,
10028 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
10029 Attribute_Name
=> Name_Output
,
10030 Expressions
=> New_List
(
10031 Make_Attribute_Reference
(Loc
,
10032 Prefix
=> New_Occurrence_Of
(Strm
, Loc
),
10033 Attribute_Name
=> Name_Access
),
10034 New_Occurrence_Of
(Expr_Parameter
, Loc
))));
10037 -- BS_To_Any (Strm, A);
10040 Make_Procedure_Call_Statement
(Loc
,
10041 Name
=> New_Occurrence_Of
(RTE
(RE_BS_To_Any
), Loc
),
10042 Parameter_Associations
=> New_List
(
10043 New_Occurrence_Of
(Strm
, Loc
),
10044 New_Occurrence_Of
(Any
, Loc
))));
10047 -- Release_Buffer (Strm);
10050 Make_Procedure_Call_Statement
(Loc
,
10051 Name
=> New_Occurrence_Of
(RTE
(RE_Release_Buffer
), Loc
),
10052 Parameter_Associations
=> New_List
(
10053 New_Occurrence_Of
(Strm
, Loc
))));
10057 Append_To
(Decls
, Any_Decl
);
10059 if Present
(Result_TC
) then
10061 Make_Procedure_Call_Statement
(Loc
,
10062 Name
=> New_Occurrence_Of
(RTE
(RE_Set_TC
), Loc
),
10063 Parameter_Associations
=> New_List
(
10064 New_Occurrence_Of
(Any
, Loc
),
10069 Make_Simple_Return_Statement
(Loc
,
10070 Expression
=> New_Occurrence_Of
(Any
, Loc
)));
10073 Make_Subprogram_Body
(Loc
,
10074 Specification
=> Spec
,
10075 Declarations
=> Decls
,
10076 Handled_Statement_Sequence
=>
10077 Make_Handled_Sequence_Of_Statements
(Loc
,
10078 Statements
=> Stms
));
10079 end Build_To_Any_Function
;
10081 -------------------------
10082 -- Build_TypeCode_Call --
10083 -------------------------
10085 function Build_TypeCode_Call
10088 Decls
: List_Id
) return Node_Id
10090 U_Type
: Entity_Id
:= Underlying_Type
(Typ
);
10091 -- The full view, if Typ is private; the completion,
10092 -- if Typ is incomplete.
10094 Fnam
: Entity_Id
:= Empty
;
10095 Lib_RE
: RE_Id
:= RE_Null
;
10099 -- Special case System.PolyORB.Interface.Any: its primitives have
10100 -- not been set yet, so can't call Find_Inherited_TSS.
10102 if Typ
= RTE
(RE_Any
) then
10103 Fnam
:= RTE
(RE_TC_A
);
10106 -- First simple case where the TypeCode is present
10107 -- in the type's TSS.
10109 Fnam
:= Find_Inherited_TSS
(U_Type
, TSS_TypeCode
);
10112 -- For the subtype representing a generic actual type, go to the
10115 if Is_Generic_Actual_Type
(U_Type
) then
10116 U_Type
:= Underlying_Type
(Base_Type
(U_Type
));
10119 -- For a standard subtype, go to the base type
10121 if Sloc
(U_Type
) <= Standard_Location
then
10122 U_Type
:= Base_Type
(U_Type
);
10126 if U_Type
= Standard_Boolean
then
10129 elsif U_Type
= Standard_Character
then
10132 elsif U_Type
= Standard_Wide_Character
then
10133 Lib_RE
:= RE_TC_WC
;
10135 elsif U_Type
= Standard_Wide_Wide_Character
then
10136 Lib_RE
:= RE_TC_WWC
;
10138 -- Floating point types
10140 elsif U_Type
= Standard_Short_Float
then
10141 Lib_RE
:= RE_TC_SF
;
10143 elsif U_Type
= Standard_Float
then
10146 elsif U_Type
= Standard_Long_Float
then
10147 Lib_RE
:= RE_TC_LF
;
10149 elsif U_Type
= Standard_Long_Long_Float
then
10150 Lib_RE
:= RE_TC_LLF
;
10152 -- Integer types (walk back to the base type)
10154 elsif U_Type
= Etype
(Standard_Short_Short_Integer
) then
10155 Lib_RE
:= RE_TC_SSI
;
10157 elsif U_Type
= Etype
(Standard_Short_Integer
) then
10158 Lib_RE
:= RE_TC_SI
;
10160 elsif U_Type
= Etype
(Standard_Integer
) then
10163 elsif U_Type
= Etype
(Standard_Long_Integer
) then
10164 Lib_RE
:= RE_TC_LI
;
10166 elsif U_Type
= Etype
(Standard_Long_Long_Integer
) then
10167 Lib_RE
:= RE_TC_LLI
;
10169 -- Unsigned integer types
10171 elsif U_Type
= RTE
(RE_Short_Short_Unsigned
) then
10172 Lib_RE
:= RE_TC_SSU
;
10174 elsif U_Type
= RTE
(RE_Short_Unsigned
) then
10175 Lib_RE
:= RE_TC_SU
;
10177 elsif U_Type
= RTE
(RE_Unsigned
) then
10180 elsif U_Type
= RTE
(RE_Long_Unsigned
) then
10181 Lib_RE
:= RE_TC_LU
;
10183 elsif U_Type
= RTE
(RE_Long_Long_Unsigned
) then
10184 Lib_RE
:= RE_TC_LLU
;
10186 elsif Is_RTE
(U_Type
, RE_Unbounded_String
) then
10187 Lib_RE
:= RE_TC_String
;
10189 -- Special DSA types
10191 elsif Is_RTE
(U_Type
, RE_Any_Container_Ptr
) then
10194 -- Other (non-primitive) types
10200 Build_TypeCode_Function
(Loc
, U_Type
, Decl
, Fnam
);
10201 Append_To
(Decls
, Decl
);
10205 if Lib_RE
/= RE_Null
then
10206 Fnam
:= RTE
(Lib_RE
);
10210 -- Call the function
10213 Make_Function_Call
(Loc
, Name
=> New_Occurrence_Of
(Fnam
, Loc
));
10215 -- Allow Expr to be used as arg to Build_To_Any_Call immediately
10217 Set_Etype
(Expr
, RTE
(RE_TypeCode
));
10220 end Build_TypeCode_Call
;
10222 -----------------------------
10223 -- Build_TypeCode_Function --
10224 -----------------------------
10226 procedure Build_TypeCode_Function
10229 Decl
: out Node_Id
;
10230 Fnam
: out Entity_Id
)
10233 Decls
: constant List_Id
:= New_List
;
10234 Stms
: constant List_Id
:= New_List
;
10236 TCNam
: constant Entity_Id
:=
10237 Make_Helper_Function_Name
(Loc
, Typ
, Name_TypeCode
);
10239 Parameters
: List_Id
;
10241 procedure Add_String_Parameter
10243 Parameter_List
: List_Id
);
10244 -- Add a literal for S to Parameters
10246 procedure Add_TypeCode_Parameter
10247 (TC_Node
: Node_Id
;
10248 Parameter_List
: List_Id
);
10249 -- Add the typecode for Typ to Parameters
10251 procedure Add_Long_Parameter
10252 (Expr_Node
: Node_Id
;
10253 Parameter_List
: List_Id
);
10254 -- Add a signed long integer expression to Parameters
10256 procedure Initialize_Parameter_List
10257 (Name_String
: String_Id
;
10258 Repo_Id_String
: String_Id
;
10259 Parameter_List
: out List_Id
);
10260 -- Return a list that contains the first two parameters
10261 -- for a parameterized typecode: name and repository id.
10263 function Make_Constructed_TypeCode
10265 Parameters
: List_Id
) return Node_Id
;
10266 -- Call TC_Build with the given kind and parameters
10268 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
);
10269 -- Make a return statement that calls TC_Build with the given
10270 -- typecode kind, and the constructed parameters list.
10272 procedure Return_Alias_TypeCode
(Base_TypeCode
: Node_Id
);
10273 -- Return a typecode that is a TC_Alias for the given typecode
10275 --------------------------
10276 -- Add_String_Parameter --
10277 --------------------------
10279 procedure Add_String_Parameter
10281 Parameter_List
: List_Id
)
10284 Append_To
(Parameter_List
,
10285 Make_Function_Call
(Loc
,
10286 Name
=> New_Occurrence_Of
(RTE
(RE_TA_Std_String
), Loc
),
10287 Parameter_Associations
=> New_List
(
10288 Make_String_Literal
(Loc
, S
))));
10289 end Add_String_Parameter
;
10291 ----------------------------
10292 -- Add_TypeCode_Parameter --
10293 ----------------------------
10295 procedure Add_TypeCode_Parameter
10296 (TC_Node
: Node_Id
;
10297 Parameter_List
: List_Id
)
10300 Append_To
(Parameter_List
,
10301 Make_Function_Call
(Loc
,
10302 Name
=> New_Occurrence_Of
(RTE
(RE_TA_TC
), Loc
),
10303 Parameter_Associations
=> New_List
(TC_Node
)));
10304 end Add_TypeCode_Parameter
;
10306 ------------------------
10307 -- Add_Long_Parameter --
10308 ------------------------
10310 procedure Add_Long_Parameter
10311 (Expr_Node
: Node_Id
;
10312 Parameter_List
: List_Id
)
10315 Append_To
(Parameter_List
,
10316 Make_Function_Call
(Loc
,
10317 Name
=> New_Occurrence_Of
(RTE
(RE_TA_LI
), Loc
),
10318 Parameter_Associations
=> New_List
(Expr_Node
)));
10319 end Add_Long_Parameter
;
10321 -------------------------------
10322 -- Initialize_Parameter_List --
10323 -------------------------------
10325 procedure Initialize_Parameter_List
10326 (Name_String
: String_Id
;
10327 Repo_Id_String
: String_Id
;
10328 Parameter_List
: out List_Id
)
10331 Parameter_List
:= New_List
;
10332 Add_String_Parameter
(Name_String
, Parameter_List
);
10333 Add_String_Parameter
(Repo_Id_String
, Parameter_List
);
10334 end Initialize_Parameter_List
;
10336 ---------------------------
10337 -- Return_Alias_TypeCode --
10338 ---------------------------
10340 procedure Return_Alias_TypeCode
10341 (Base_TypeCode
: Node_Id
)
10344 Add_TypeCode_Parameter
(Base_TypeCode
, Parameters
);
10345 Return_Constructed_TypeCode
(RTE
(RE_TC_Alias
));
10346 end Return_Alias_TypeCode
;
10348 -------------------------------
10349 -- Make_Constructed_TypeCode --
10350 -------------------------------
10352 function Make_Constructed_TypeCode
10354 Parameters
: List_Id
) return Node_Id
10356 Constructed_TC
: constant Node_Id
:=
10357 Make_Function_Call
(Loc
,
10359 New_Occurrence_Of
(RTE
(RE_TC_Build
), Loc
),
10360 Parameter_Associations
=> New_List
(
10361 New_Occurrence_Of
(Kind
, Loc
),
10362 Make_Aggregate
(Loc
,
10363 Expressions
=> Parameters
)));
10365 Set_Etype
(Constructed_TC
, RTE
(RE_TypeCode
));
10366 return Constructed_TC
;
10367 end Make_Constructed_TypeCode
;
10369 ---------------------------------
10370 -- Return_Constructed_TypeCode --
10371 ---------------------------------
10373 procedure Return_Constructed_TypeCode
(Kind
: Entity_Id
) is
10376 Make_Simple_Return_Statement
(Loc
,
10378 Make_Constructed_TypeCode
(Kind
, Parameters
)));
10379 end Return_Constructed_TypeCode
;
10385 procedure TC_Rec_Add_Process_Element
10388 Counter
: in out Int
;
10392 procedure TC_Append_Record_Traversal
is
10393 new Append_Record_Traversal
(
10395 Add_Process_Element
=> TC_Rec_Add_Process_Element
);
10397 --------------------------------
10398 -- TC_Rec_Add_Process_Element --
10399 --------------------------------
10401 procedure TC_Rec_Add_Process_Element
10404 Counter
: in out Int
;
10408 pragma Unreferenced
(Any
, Counter
, Rec
);
10411 if Nkind
(Field
) = N_Defining_Identifier
then
10413 -- A regular component
10415 Add_TypeCode_Parameter
10416 (Build_TypeCode_Call
(Loc
, Etype
(Field
), Decls
), Params
);
10417 Get_Name_String
(Chars
(Field
));
10418 Add_String_Parameter
(String_From_Name_Buffer
, Params
);
10425 Discriminant_Type
: constant Entity_Id
:=
10426 Etype
(Name
(Field
));
10428 Is_Enum
: constant Boolean :=
10429 Is_Enumeration_Type
(Discriminant_Type
);
10431 Union_TC_Params
: List_Id
;
10433 U_Name
: constant Name_Id
:=
10434 New_External_Name
(Chars
(Typ
), 'V', -1);
10436 Name_Str
: String_Id
;
10437 Struct_TC_Params
: List_Id
;
10441 Default
: constant Node_Id
:=
10442 Make_Integer_Literal
(Loc
, -1);
10444 Dummy_Counter
: Int
:= 0;
10446 Choice_Index
: Int
:= 0;
10448 procedure Add_Params_For_Variant_Components
;
10449 -- Add a struct TypeCode and a corresponding member name
10450 -- to the union parameter list.
10452 -- Ordering of declarations is a complete mess in this
10453 -- area, it is supposed to be types/variables, then
10454 -- subprogram specs, then subprogram bodies ???
10456 ---------------------------------------
10457 -- Add_Params_For_Variant_Components --
10458 ---------------------------------------
10460 procedure Add_Params_For_Variant_Components
10462 S_Name
: constant Name_Id
:=
10463 New_External_Name
(U_Name
, 'S', -1);
10466 Get_Name_String
(S_Name
);
10467 Name_Str
:= String_From_Name_Buffer
;
10468 Initialize_Parameter_List
10469 (Name_Str
, Name_Str
, Struct_TC_Params
);
10471 -- Build struct parameters
10473 TC_Append_Record_Traversal
(Struct_TC_Params
,
10474 Component_List
(Variant
),
10478 Add_TypeCode_Parameter
10479 (Make_Constructed_TypeCode
10480 (RTE
(RE_TC_Struct
), Struct_TC_Params
),
10483 Add_String_Parameter
(Name_Str
, Union_TC_Params
);
10484 end Add_Params_For_Variant_Components
;
10487 Get_Name_String
(U_Name
);
10488 Name_Str
:= String_From_Name_Buffer
;
10490 Initialize_Parameter_List
10491 (Name_Str
, Name_Str
, Union_TC_Params
);
10493 -- Add union in enclosing parameter list
10495 Add_TypeCode_Parameter
10496 (Make_Constructed_TypeCode
10497 (RTE
(RE_TC_Union
), Union_TC_Params
),
10500 Add_String_Parameter
(Name_Str
, Params
);
10502 -- Build union parameters
10504 Add_TypeCode_Parameter
10505 (Build_TypeCode_Call
10506 (Loc
, Discriminant_Type
, Decls
),
10509 Add_Long_Parameter
(Default
, Union_TC_Params
);
10511 Variant
:= First_Non_Pragma
(Variants
(Field
));
10512 while Present
(Variant
) loop
10513 Choice
:= First
(Discrete_Choices
(Variant
));
10514 while Present
(Choice
) loop
10515 case Nkind
(Choice
) is
10518 L
: constant Uint
:=
10519 Expr_Value
(Low_Bound
(Choice
));
10520 H
: constant Uint
:=
10521 Expr_Value
(High_Bound
(Choice
));
10523 -- 3.8.1(8) guarantees that the bounds of
10524 -- this range are static.
10531 Expr
:= New_Occurrence_Of
(
10532 Get_Enum_Lit_From_Pos
(
10533 Discriminant_Type
, J
, Loc
), Loc
);
10536 Make_Integer_Literal
(Loc
, J
);
10538 Append_To
(Union_TC_Params
,
10539 Build_To_Any_Call
(Expr
, Decls
));
10541 Add_Params_For_Variant_Components
;
10546 when N_Others_Choice
=>
10548 -- This variant possess a default choice.
10549 -- We must therefore set the default
10550 -- parameter to the current choice index. The
10551 -- default parameter is by construction the
10552 -- fourth in the Union_TC_Params list.
10555 Default_Node
: constant Node_Id
:=
10556 Pick
(Union_TC_Params
, 4);
10558 New_Default_Node
: constant Node_Id
:=
10559 Make_Function_Call
(Loc
,
10562 (RTE
(RE_TA_LI
), Loc
),
10563 Parameter_Associations
=>
10565 Make_Integer_Literal
10566 (Loc
, Choice_Index
)));
10572 Remove
(Default_Node
);
10575 -- Add a placeholder member label
10576 -- for the default case.
10577 -- It must be of the discriminant type.
10580 Exp
: constant Node_Id
:=
10581 Make_Attribute_Reference
(Loc
,
10582 Prefix
=> New_Occurrence_Of
10583 (Discriminant_Type
, Loc
),
10584 Attribute_Name
=> Name_First
);
10586 Set_Etype
(Exp
, Discriminant_Type
);
10587 Append_To
(Union_TC_Params
,
10588 Build_To_Any_Call
(Exp
, Decls
));
10591 Add_Params_For_Variant_Components
;
10595 -- Case of an explicit choice
10598 Exp
: constant Node_Id
:=
10599 New_Copy_Tree
(Choice
);
10601 Append_To
(Union_TC_Params
,
10602 Build_To_Any_Call
(Exp
, Decls
));
10605 Add_Params_For_Variant_Components
;
10609 Choice_Index
:= Choice_Index
+ 1;
10612 Next_Non_Pragma
(Variant
);
10616 end TC_Rec_Add_Process_Element
;
10618 Type_Name_Str
: String_Id
;
10619 Type_Repo_Id_Str
: String_Id
;
10621 -- Start of processing for Build_TypeCode_Function
10624 -- For a derived type, we can't go past the base type (to the
10625 -- parent type) here, because that would cause the attribute's
10626 -- formal parameter to have the wrong type; hence the Base_Type
10629 if Is_Itype
(Typ
) and then Typ
/= Base_Type
(Typ
) then
10630 Build_TypeCode_Function
10632 Typ
=> Etype
(Typ
),
10641 Make_Function_Specification
(Loc
,
10642 Defining_Unit_Name
=> Fnam
,
10643 Parameter_Specifications
=> Empty_List
,
10644 Result_Definition
=>
10645 New_Occurrence_Of
(RTE
(RE_TypeCode
), Loc
));
10647 Build_Name_And_Repository_Id
(Typ
,
10648 Name_Str
=> Type_Name_Str
, Repo_Id_Str
=> Type_Repo_Id_Str
);
10650 Initialize_Parameter_List
10651 (Type_Name_Str
, Type_Repo_Id_Str
, Parameters
);
10653 if Has_Stream_Attribute_Definition
10654 (Typ
, TSS_Stream_Output
, At_Any_Place
=> True)
10656 Has_Stream_Attribute_Definition
10657 (Typ
, TSS_Stream_Write
, At_Any_Place
=> True)
10659 -- If user-defined stream attributes are specified for this
10660 -- type, use them and transmit data as an opaque sequence of
10661 -- stream elements.
10663 Return_Alias_TypeCode
10664 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10666 elsif Is_Derived_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
10667 Return_Alias_TypeCode
(
10668 Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10670 elsif Is_Integer_Type
(Typ
) or else Is_Unsigned_Type
(Typ
) then
10671 Return_Alias_TypeCode
(
10672 Build_TypeCode_Call
(Loc
,
10673 Find_Numeric_Representation
(Typ
), Decls
));
10675 elsif Is_Record_Type
(Typ
) and then not Is_Tagged_Type
(Typ
) then
10677 -- Record typecodes are encoded as follows:
10681 -- | [Repository Id]
10683 -- Then for each discriminant:
10685 -- | [Discriminant Type Code]
10686 -- | [Discriminant Name]
10689 -- Then for each component:
10691 -- | [Component Type Code]
10692 -- | [Component Name]
10695 -- Variants components type codes are encoded as follows:
10699 -- | [Repository Id]
10700 -- | [Discriminant Type Code]
10701 -- | [Index of Default Variant Part or -1 for no default]
10703 -- Then for each Variant Part :
10708 -- | | [Variant Part Name]
10709 -- | | [Variant Part Repository Id]
10711 -- | Then for each VP component:
10712 -- | | [VP component Typecode]
10713 -- | | [VP component Name]
10719 if Nkind
(Declaration_Node
(Typ
)) = N_Subtype_Declaration
then
10720 Return_Alias_TypeCode
10721 (Build_TypeCode_Call
(Loc
, Etype
(Typ
), Decls
));
10725 Disc
: Entity_Id
:= Empty
;
10726 Rdef
: constant Node_Id
:=
10727 Type_Definition
(Declaration_Node
(Typ
));
10728 Dummy_Counter
: Int
:= 0;
10731 -- Construct the discriminants typecodes
10733 if Has_Discriminants
(Typ
) then
10734 Disc
:= First_Discriminant
(Typ
);
10737 while Present
(Disc
) loop
10738 Add_TypeCode_Parameter
(
10739 Build_TypeCode_Call
(Loc
, Etype
(Disc
), Decls
),
10741 Get_Name_String
(Chars
(Disc
));
10742 Add_String_Parameter
(
10743 String_From_Name_Buffer
,
10745 Next_Discriminant
(Disc
);
10748 -- then the components typecodes
10750 TC_Append_Record_Traversal
10751 (Parameters
, Component_List
(Rdef
),
10752 Empty
, Dummy_Counter
);
10753 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10757 elsif Is_Array_Type
(Typ
) then
10759 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10760 Inner_TypeCode
: Node_Id
;
10761 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10762 Indx
: Node_Id
:= First_Index
(Typ
);
10766 Build_TypeCode_Call
(Loc
, Component_Type
(Typ
), Decls
);
10768 for J
in 1 .. Ndim
loop
10769 if Constrained
then
10770 Inner_TypeCode
:= Make_Constructed_TypeCode
10771 (RTE
(RE_TC_Array
), New_List
(
10772 Build_To_Any_Call
(
10773 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10774 Make_Attribute_Reference
(Loc
,
10775 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
10776 Attribute_Name
=> Name_Length
,
10777 Expressions
=> New_List
(
10778 Make_Integer_Literal
(Loc
,
10779 Intval
=> Ndim
- J
+ 1)))),
10781 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10784 -- Unconstrained case: add low bound for each
10787 Add_TypeCode_Parameter
10788 (Build_TypeCode_Call
(Loc
, Etype
(Indx
), Decls
),
10790 Get_Name_String
(New_External_Name
('L', J
));
10791 Add_String_Parameter
(
10792 String_From_Name_Buffer
,
10796 Inner_TypeCode
:= Make_Constructed_TypeCode
10797 (RTE
(RE_TC_Sequence
), New_List
(
10798 Build_To_Any_Call
(
10799 OK_Convert_To
(RTE
(RE_Long_Unsigned
),
10800 Make_Integer_Literal
(Loc
, 0)),
10802 Build_To_Any_Call
(Inner_TypeCode
, Decls
)));
10806 if Constrained
then
10807 Return_Alias_TypeCode
(Inner_TypeCode
);
10809 Add_TypeCode_Parameter
(Inner_TypeCode
, Parameters
);
10811 Store_String_Char
('V');
10812 Add_String_Parameter
(End_String
, Parameters
);
10813 Return_Constructed_TypeCode
(RTE
(RE_TC_Struct
));
10818 -- Default: type is represented as an opaque sequence of bytes
10820 Return_Alias_TypeCode
10821 (New_Occurrence_Of
(RTE
(RE_TC_Opaque
), Loc
));
10825 Make_Subprogram_Body
(Loc
,
10826 Specification
=> Spec
,
10827 Declarations
=> Decls
,
10828 Handled_Statement_Sequence
=>
10829 Make_Handled_Sequence_Of_Statements
(Loc
,
10830 Statements
=> Stms
));
10831 end Build_TypeCode_Function
;
10833 ---------------------------------
10834 -- Find_Numeric_Representation --
10835 ---------------------------------
10837 function Find_Numeric_Representation
10838 (Typ
: Entity_Id
) return Entity_Id
10840 FST
: constant Entity_Id
:= First_Subtype
(Typ
);
10841 P_Size
: constant Uint
:= Esize
(FST
);
10844 if Is_Unsigned_Type
(Typ
) then
10845 if P_Size
<= Standard_Short_Short_Integer_Size
then
10846 return RTE
(RE_Short_Short_Unsigned
);
10848 elsif P_Size
<= Standard_Short_Integer_Size
then
10849 return RTE
(RE_Short_Unsigned
);
10851 elsif P_Size
<= Standard_Integer_Size
then
10852 return RTE
(RE_Unsigned
);
10854 elsif P_Size
<= Standard_Long_Integer_Size
then
10855 return RTE
(RE_Long_Unsigned
);
10858 return RTE
(RE_Long_Long_Unsigned
);
10861 elsif Is_Integer_Type
(Typ
) then
10862 if P_Size
<= Standard_Short_Short_Integer_Size
then
10863 return Standard_Short_Short_Integer
;
10865 elsif P_Size
<= Standard_Short_Integer_Size
then
10866 return Standard_Short_Integer
;
10868 elsif P_Size
<= Standard_Integer_Size
then
10869 return Standard_Integer
;
10871 elsif P_Size
<= Standard_Long_Integer_Size
then
10872 return Standard_Long_Integer
;
10875 return Standard_Long_Long_Integer
;
10878 elsif Is_Floating_Point_Type
(Typ
) then
10879 if P_Size
<= Standard_Short_Float_Size
then
10880 return Standard_Short_Float
;
10882 elsif P_Size
<= Standard_Float_Size
then
10883 return Standard_Float
;
10885 elsif P_Size
<= Standard_Long_Float_Size
then
10886 return Standard_Long_Float
;
10889 return Standard_Long_Long_Float
;
10893 raise Program_Error
;
10896 -- TBD: fixed point types???
10897 -- TBverified numeric types with a biased representation???
10899 end Find_Numeric_Representation
;
10901 ---------------------------
10902 -- Append_Array_Traversal --
10903 ---------------------------
10905 procedure Append_Array_Traversal
10908 Counter
: Entity_Id
:= Empty
;
10911 Loc
: constant Source_Ptr
:= Sloc
(Subprogram
);
10912 Typ
: constant Entity_Id
:= Etype
(Arry
);
10913 Constrained
: constant Boolean := Is_Constrained
(Typ
);
10914 Ndim
: constant Pos
:= Number_Dimensions
(Typ
);
10916 Inner_Any
, Inner_Counter
: Entity_Id
;
10918 Loop_Stm
: Node_Id
;
10919 Inner_Stmts
: constant List_Id
:= New_List
;
10922 if Depth
> Ndim
then
10924 -- Processing for one element of an array
10927 Element_Expr
: constant Node_Id
:=
10928 Make_Indexed_Component
(Loc
,
10929 New_Occurrence_Of
(Arry
, Loc
),
10932 Set_Etype
(Element_Expr
, Component_Type
(Typ
));
10933 Add_Process_Element
(Stmts
,
10935 Counter
=> Counter
,
10936 Datum
=> Element_Expr
);
10942 Append_To
(Indexes
,
10943 Make_Identifier
(Loc
, New_External_Name
('L', Depth
)));
10945 if not Constrained
or else Depth
> 1 then
10946 Inner_Any
:= Make_Defining_Identifier
(Loc
,
10947 New_External_Name
('A', Depth
));
10948 Set_Etype
(Inner_Any
, RTE
(RE_Any
));
10950 Inner_Any
:= Empty
;
10953 if Present
(Counter
) then
10954 Inner_Counter
:= Make_Defining_Identifier
(Loc
,
10955 New_External_Name
('J', Depth
));
10957 Inner_Counter
:= Empty
;
10961 Loop_Any
: Node_Id
:= Inner_Any
;
10964 -- For the first dimension of a constrained array, we add
10965 -- elements directly in the corresponding Any; there is no
10966 -- intervening inner Any.
10968 if No
(Loop_Any
) then
10972 Append_Array_Traversal
(Inner_Stmts
,
10974 Counter
=> Inner_Counter
,
10975 Depth
=> Depth
+ 1);
10979 Make_Implicit_Loop_Statement
(Subprogram
,
10980 Iteration_Scheme
=>
10981 Make_Iteration_Scheme
(Loc
,
10982 Loop_Parameter_Specification
=>
10983 Make_Loop_Parameter_Specification
(Loc
,
10984 Defining_Identifier
=>
10985 Make_Defining_Identifier
(Loc
,
10986 Chars
=> New_External_Name
('L', Depth
)),
10988 Discrete_Subtype_Definition
=>
10989 Make_Attribute_Reference
(Loc
,
10990 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
10991 Attribute_Name
=> Name_Range
,
10993 Expressions
=> New_List
(
10994 Make_Integer_Literal
(Loc
, Depth
))))),
10995 Statements
=> Inner_Stmts
);
10998 Decls
: constant List_Id
:= New_List
;
10999 Dimen_Stmts
: constant List_Id
:= New_List
;
11000 Length_Node
: Node_Id
;
11002 Inner_Any_TypeCode
: constant Entity_Id
:=
11003 Make_Defining_Identifier
(Loc
,
11004 New_External_Name
('T', Depth
));
11006 Inner_Any_TypeCode_Expr
: Node_Id
;
11010 if Constrained
then
11011 Inner_Any_TypeCode_Expr
:=
11012 Make_Function_Call
(Loc
,
11013 Name
=> New_Occurrence_Of
(RTE
(RE_Get_TC
), Loc
),
11014 Parameter_Associations
=> New_List
(
11015 New_Occurrence_Of
(Any
, Loc
)));
11018 Inner_Any_TypeCode_Expr
:=
11019 Make_Function_Call
(Loc
,
11021 New_Occurrence_Of
(RTE
(RE_Any_Member_Type
), Loc
),
11022 Parameter_Associations
=> New_List
(
11023 New_Occurrence_Of
(Any
, Loc
),
11024 Make_Integer_Literal
(Loc
, Ndim
)));
11028 Inner_Any_TypeCode_Expr
:=
11029 Make_Function_Call
(Loc
,
11030 Name
=> New_Occurrence_Of
(RTE
(RE_Content_Type
), Loc
),
11031 Parameter_Associations
=> New_List
(
11032 Make_Identifier
(Loc
,
11033 Chars
=> New_External_Name
('T', Depth
- 1))));
11037 Make_Object_Declaration
(Loc
,
11038 Defining_Identifier
=> Inner_Any_TypeCode
,
11039 Constant_Present
=> True,
11040 Object_Definition
=> New_Occurrence_Of
(
11041 RTE
(RE_TypeCode
), Loc
),
11042 Expression
=> Inner_Any_TypeCode_Expr
));
11044 if Present
(Inner_Any
) then
11046 Make_Object_Declaration
(Loc
,
11047 Defining_Identifier
=> Inner_Any
,
11048 Object_Definition
=>
11049 New_Occurrence_Of
(RTE
(RE_Any
), Loc
),
11051 Make_Function_Call
(Loc
,
11053 New_Occurrence_Of
(
11054 RTE
(RE_Create_Any
), Loc
),
11055 Parameter_Associations
=> New_List
(
11056 New_Occurrence_Of
(Inner_Any_TypeCode
, Loc
)))));
11059 if Present
(Inner_Counter
) then
11061 Make_Object_Declaration
(Loc
,
11062 Defining_Identifier
=> Inner_Counter
,
11063 Object_Definition
=>
11064 New_Occurrence_Of
(RTE
(RE_Long_Unsigned
), Loc
),
11066 Make_Integer_Literal
(Loc
, 0)));
11069 if not Constrained
then
11070 Length_Node
:= Make_Attribute_Reference
(Loc
,
11071 Prefix
=> New_Occurrence_Of
(Arry
, Loc
),
11072 Attribute_Name
=> Name_Length
,
11074 New_List
(Make_Integer_Literal
(Loc
, Depth
)));
11075 Set_Etype
(Length_Node
, RTE
(RE_Long_Unsigned
));
11077 Add_Process_Element
(Dimen_Stmts
,
11078 Datum
=> Length_Node
,
11080 Counter
=> Inner_Counter
);
11083 -- Loop_Stm does appropriate processing for each element
11086 Append_To
(Dimen_Stmts
, Loop_Stm
);
11088 -- Link outer and inner any
11090 if Present
(Inner_Any
) then
11091 Add_Process_Element
(Dimen_Stmts
,
11093 Counter
=> Counter
,
11094 Datum
=> New_Occurrence_Of
(Inner_Any
, Loc
));
11098 Make_Block_Statement
(Loc
,
11101 Handled_Statement_Sequence
=>
11102 Make_Handled_Sequence_Of_Statements
(Loc
,
11103 Statements
=> Dimen_Stmts
)));
11105 end Append_Array_Traversal
;
11107 -------------------------------
11108 -- Make_Helper_Function_Name --
11109 -------------------------------
11111 function Make_Helper_Function_Name
11114 Nam
: Name_Id
) return Entity_Id
11119 -- For tagged types that aren't frozen yet, generate the helper
11120 -- under its canonical name so that it matches the primitive
11121 -- spec. For all other cases, we use a serialized name so that
11122 -- multiple generations of the same procedure do not clash.
11125 if Is_Tagged_Type
(Typ
) and then not Is_Frozen
(Typ
) then
11128 Serial
:= Increment_Serial_Number
;
11131 -- Use prefixed underscore to avoid potential clash with user
11132 -- identifier (we use attribute names for Nam).
11135 Make_Defining_Identifier
(Loc
,
11138 (Related_Id
=> Nam
,
11140 Suffix_Index
=> Serial
,
11143 end Make_Helper_Function_Name
;
11146 -----------------------------------
11147 -- Reserve_NamingContext_Methods --
11148 -----------------------------------
11150 procedure Reserve_NamingContext_Methods
is
11151 Str_Resolve
: constant String := "resolve";
11153 Name_Buffer
(1 .. Str_Resolve
'Length) := Str_Resolve
;
11154 Name_Len
:= Str_Resolve
'Length;
11155 Overload_Counter_Table
.Set
(Name_Find
, 1);
11156 end Reserve_NamingContext_Methods
;
11158 end PolyORB_Support
;
11160 -------------------------------
11161 -- RACW_Type_Is_Asynchronous --
11162 -------------------------------
11164 procedure RACW_Type_Is_Asynchronous
(RACW_Type
: Entity_Id
) is
11165 Asynchronous_Flag
: constant Entity_Id
:=
11166 Asynchronous_Flags_Table
.Get
(RACW_Type
);
11168 Replace
(Expression
(Parent
(Asynchronous_Flag
)),
11169 New_Occurrence_Of
(Standard_True
, Sloc
(Asynchronous_Flag
)));
11170 end RACW_Type_Is_Asynchronous
;
11172 -------------------------
11173 -- RCI_Package_Locator --
11174 -------------------------
11176 function RCI_Package_Locator
11178 Package_Spec
: Node_Id
) return Node_Id
11181 Pkg_Name
: String_Id
;
11184 Get_Library_Unit_Name_String
(Package_Spec
);
11185 Pkg_Name
:= String_From_Name_Buffer
;
11187 Make_Package_Instantiation
(Loc
,
11188 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'R'),
11191 New_Occurrence_Of
(RTE
(RE_RCI_Locator
), Loc
),
11193 Generic_Associations
=> New_List
(
11194 Make_Generic_Association
(Loc
,
11196 Make_Identifier
(Loc
, Name_RCI_Name
),
11197 Explicit_Generic_Actual_Parameter
=>
11198 Make_String_Literal
(Loc
,
11199 Strval
=> Pkg_Name
)),
11201 Make_Generic_Association
(Loc
,
11203 Make_Identifier
(Loc
, Name_Version
),
11204 Explicit_Generic_Actual_Parameter
=>
11205 Make_Attribute_Reference
(Loc
,
11207 New_Occurrence_Of
(Defining_Entity
(Package_Spec
), Loc
),
11211 RCI_Locator_Table
.Set
11212 (Defining_Unit_Name
(Package_Spec
),
11213 Defining_Unit_Name
(Inst
));
11215 end RCI_Package_Locator
;
11217 -----------------------------------------------
11218 -- Remote_Types_Tagged_Full_View_Encountered --
11219 -----------------------------------------------
11221 procedure Remote_Types_Tagged_Full_View_Encountered
11222 (Full_View
: Entity_Id
)
11224 Stub_Elements
: constant Stub_Structure
:=
11225 Stubs_Table
.Get
(Full_View
);
11228 -- For an RACW encountered before the freeze point of its designated
11229 -- type, the stub type is generated at the point of the RACW declaration
11230 -- but the primitives are generated only once the designated type is
11231 -- frozen. That freeze can occur in another scope, for example when the
11232 -- RACW is declared in a nested package. In that case we need to
11233 -- reestablish the stub type's scope prior to generating its primitive
11236 if Stub_Elements
/= Empty_Stub_Structure
then
11238 Saved_Scope
: constant Entity_Id
:= Current_Scope
;
11239 Stubs_Scope
: constant Entity_Id
:=
11240 Scope
(Stub_Elements
.Stub_Type
);
11243 if Current_Scope
/= Stubs_Scope
then
11244 Push_Scope
(Stubs_Scope
);
11247 Add_RACW_Primitive_Declarations_And_Bodies
11249 Stub_Elements
.RPC_Receiver_Decl
,
11250 Stub_Elements
.Body_Decls
);
11252 if Current_Scope
/= Saved_Scope
then
11257 end Remote_Types_Tagged_Full_View_Encountered
;
11259 -------------------
11260 -- Scope_Of_Spec --
11261 -------------------
11263 function Scope_Of_Spec
(Spec
: Node_Id
) return Entity_Id
is
11264 Unit_Name
: Node_Id
;
11267 Unit_Name
:= Defining_Unit_Name
(Spec
);
11268 while Nkind
(Unit_Name
) /= N_Defining_Identifier
loop
11269 Unit_Name
:= Defining_Identifier
(Unit_Name
);
11275 ----------------------
11276 -- Set_Renaming_TSS --
11277 ----------------------
11279 procedure Set_Renaming_TSS
11282 TSS_Nam
: TSS_Name_Type
)
11284 Loc
: constant Source_Ptr
:= Sloc
(Nam
);
11285 Spec
: constant Node_Id
:= Parent
(Nam
);
11287 TSS_Node
: constant Node_Id
:=
11288 Make_Subprogram_Renaming_Declaration
(Loc
,
11290 Copy_Specification
(Loc
,
11292 New_Name
=> Make_TSS_Name
(Typ
, TSS_Nam
)),
11293 Name
=> New_Occurrence_Of
(Nam
, Loc
));
11295 Snam
: constant Entity_Id
:=
11296 Defining_Unit_Name
(Specification
(TSS_Node
));
11299 if Nkind
(Spec
) = N_Function_Specification
then
11300 Set_Ekind
(Snam
, E_Function
);
11301 Set_Etype
(Snam
, Entity
(Result_Definition
(Spec
)));
11303 Set_Ekind
(Snam
, E_Procedure
);
11304 Set_Etype
(Snam
, Standard_Void_Type
);
11307 Set_TSS
(Typ
, Snam
);
11308 end Set_Renaming_TSS
;
11310 ----------------------------------------------
11311 -- Specific_Add_Obj_RPC_Receiver_Completion --
11312 ----------------------------------------------
11314 procedure Specific_Add_Obj_RPC_Receiver_Completion
11317 RPC_Receiver
: Entity_Id
;
11318 Stub_Elements
: Stub_Structure
)
11321 case Get_PCS_Name
is
11322 when Name_PolyORB_DSA
=>
11323 PolyORB_Support
.Add_Obj_RPC_Receiver_Completion
11324 (Loc
, Decls
, RPC_Receiver
, Stub_Elements
);
11326 GARLIC_Support
.Add_Obj_RPC_Receiver_Completion
11327 (Loc
, Decls
, RPC_Receiver
, Stub_Elements
);
11329 end Specific_Add_Obj_RPC_Receiver_Completion
;
11331 --------------------------------
11332 -- Specific_Add_RACW_Features --
11333 --------------------------------
11335 procedure Specific_Add_RACW_Features
11336 (RACW_Type
: Entity_Id
;
11338 Stub_Type
: Entity_Id
;
11339 Stub_Type_Access
: Entity_Id
;
11340 RPC_Receiver_Decl
: Node_Id
;
11341 Body_Decls
: List_Id
)
11344 case Get_PCS_Name
is
11345 when Name_PolyORB_DSA
=>
11346 PolyORB_Support
.Add_RACW_Features
11355 GARLIC_Support
.Add_RACW_Features
11362 end Specific_Add_RACW_Features
;
11364 --------------------------------
11365 -- Specific_Add_RAST_Features --
11366 --------------------------------
11368 procedure Specific_Add_RAST_Features
11369 (Vis_Decl
: Node_Id
;
11370 RAS_Type
: Entity_Id
)
11373 case Get_PCS_Name
is
11374 when Name_PolyORB_DSA
=>
11375 PolyORB_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11377 GARLIC_Support
.Add_RAST_Features
(Vis_Decl
, RAS_Type
);
11379 end Specific_Add_RAST_Features
;
11381 --------------------------------------------------
11382 -- Specific_Add_Receiving_Stubs_To_Declarations --
11383 --------------------------------------------------
11385 procedure Specific_Add_Receiving_Stubs_To_Declarations
11386 (Pkg_Spec
: Node_Id
;
11391 case Get_PCS_Name
is
11392 when Name_PolyORB_DSA
=>
11393 PolyORB_Support
.Add_Receiving_Stubs_To_Declarations
11394 (Pkg_Spec
, Decls
, Stmts
);
11396 GARLIC_Support
.Add_Receiving_Stubs_To_Declarations
11397 (Pkg_Spec
, Decls
, Stmts
);
11399 end Specific_Add_Receiving_Stubs_To_Declarations
;
11401 ------------------------------------------
11402 -- Specific_Build_General_Calling_Stubs --
11403 ------------------------------------------
11405 procedure Specific_Build_General_Calling_Stubs
11407 Statements
: List_Id
;
11408 Target
: RPC_Target
;
11409 Subprogram_Id
: Node_Id
;
11410 Asynchronous
: Node_Id
:= Empty
;
11411 Is_Known_Asynchronous
: Boolean := False;
11412 Is_Known_Non_Asynchronous
: Boolean := False;
11413 Is_Function
: Boolean;
11415 Stub_Type
: Entity_Id
:= Empty
;
11416 RACW_Type
: Entity_Id
:= Empty
;
11420 case Get_PCS_Name
is
11421 when Name_PolyORB_DSA
=>
11422 PolyORB_Support
.Build_General_Calling_Stubs
11428 Is_Known_Asynchronous
,
11429 Is_Known_Non_Asynchronous
,
11437 GARLIC_Support
.Build_General_Calling_Stubs
11441 Target
.RPC_Receiver
,
11444 Is_Known_Asynchronous
,
11445 Is_Known_Non_Asynchronous
,
11452 end Specific_Build_General_Calling_Stubs
;
11454 --------------------------------------
11455 -- Specific_Build_RPC_Receiver_Body --
11456 --------------------------------------
11458 procedure Specific_Build_RPC_Receiver_Body
11459 (RPC_Receiver
: Entity_Id
;
11460 Request
: out Entity_Id
;
11461 Subp_Id
: out Entity_Id
;
11462 Subp_Index
: out Entity_Id
;
11463 Stmts
: out List_Id
;
11464 Decl
: out Node_Id
)
11467 case Get_PCS_Name
is
11468 when Name_PolyORB_DSA
=>
11469 PolyORB_Support
.Build_RPC_Receiver_Body
11478 GARLIC_Support
.Build_RPC_Receiver_Body
11486 end Specific_Build_RPC_Receiver_Body
;
11488 --------------------------------
11489 -- Specific_Build_Stub_Target --
11490 --------------------------------
11492 function Specific_Build_Stub_Target
11495 RCI_Locator
: Entity_Id
;
11496 Controlling_Parameter
: Entity_Id
) return RPC_Target
11499 case Get_PCS_Name
is
11500 when Name_PolyORB_DSA
=>
11502 PolyORB_Support
.Build_Stub_Target
11503 (Loc
, Decls
, RCI_Locator
, Controlling_Parameter
);
11507 GARLIC_Support
.Build_Stub_Target
11508 (Loc
, Decls
, RCI_Locator
, Controlling_Parameter
);
11510 end Specific_Build_Stub_Target
;
11512 ------------------------------
11513 -- Specific_Build_Stub_Type --
11514 ------------------------------
11516 procedure Specific_Build_Stub_Type
11517 (RACW_Type
: Entity_Id
;
11518 Stub_Type_Comps
: out List_Id
;
11519 RPC_Receiver_Decl
: out Node_Id
)
11522 case Get_PCS_Name
is
11523 when Name_PolyORB_DSA
=>
11524 PolyORB_Support
.Build_Stub_Type
11525 (RACW_Type
, Stub_Type_Comps
, RPC_Receiver_Decl
);
11528 GARLIC_Support
.Build_Stub_Type
11529 (RACW_Type
, Stub_Type_Comps
, RPC_Receiver_Decl
);
11531 end Specific_Build_Stub_Type
;
11533 -----------------------------------------------
11534 -- Specific_Build_Subprogram_Receiving_Stubs --
11535 -----------------------------------------------
11537 function Specific_Build_Subprogram_Receiving_Stubs
11538 (Vis_Decl
: Node_Id
;
11539 Asynchronous
: Boolean;
11540 Dynamically_Asynchronous
: Boolean := False;
11541 Stub_Type
: Entity_Id
:= Empty
;
11542 RACW_Type
: Entity_Id
:= Empty
;
11543 Parent_Primitive
: Entity_Id
:= Empty
) return Node_Id
11546 case Get_PCS_Name
is
11547 when Name_PolyORB_DSA
=>
11549 PolyORB_Support
.Build_Subprogram_Receiving_Stubs
11552 Dynamically_Asynchronous
,
11559 GARLIC_Support
.Build_Subprogram_Receiving_Stubs
11562 Dynamically_Asynchronous
,
11567 end Specific_Build_Subprogram_Receiving_Stubs
;
11569 -------------------------------
11570 -- Transmit_As_Unconstrained --
11571 -------------------------------
11573 function Transmit_As_Unconstrained
(Typ
: Entity_Id
) return Boolean is
11576 not (Is_Elementary_Type
(Typ
) or else Is_Constrained
(Typ
))
11577 or else (Is_Access_Type
(Typ
) and then Can_Never_Be_Null
(Typ
));
11578 end Transmit_As_Unconstrained
;
11580 --------------------------
11581 -- Underlying_RACW_Type --
11582 --------------------------
11584 function Underlying_RACW_Type
(RAS_Typ
: Entity_Id
) return Entity_Id
is
11585 Record_Type
: Entity_Id
;
11588 if Ekind
(RAS_Typ
) = E_Record_Type
then
11589 Record_Type
:= RAS_Typ
;
11591 pragma Assert
(Present
(Equivalent_Type
(RAS_Typ
)));
11592 Record_Type
:= Equivalent_Type
(RAS_Typ
);
11596 Etype
(Subtype_Indication
11597 (Component_Definition
11598 (First
(Component_Items
11601 (Declaration_Node
(Record_Type
))))))));
11602 end Underlying_RACW_Type
;